From b3e2038c09941f096ce4cdd61602837dd1258a11 Mon Sep 17 00:00:00 2001 From: butterunderflow Date: Thu, 27 Oct 2022 23:52:09 +0800 Subject: [PATCH 01/15] change Pconst_char payload (WIP) --- jscomp/core/js_of_lam_string.ml | 2 +- jscomp/core/lam_constant_convert.ml | 2 +- jscomp/ml/ast_helper.ml | 2 +- jscomp/ml/asttypes.ml | 4 ++-- jscomp/ml/matching.ml | 2 +- jscomp/ml/parmatch.ml | 6 +++--- jscomp/ml/parser.ml | 2 +- jscomp/ml/parsetree.ml | 2 +- jscomp/ml/pprintast.ml | 2 +- jscomp/ml/pprintast.pp.ml | 2 +- jscomp/ml/printast.ml | 2 +- jscomp/ml/printlambda.ml | 2 +- jscomp/ml/printtyped.ml | 2 +- jscomp/ml/typecore.ml | 2 +- 14 files changed, 17 insertions(+), 17 deletions(-) diff --git a/jscomp/core/js_of_lam_string.ml b/jscomp/core/js_of_lam_string.ml index 6ba28e7037..50c343f238 100644 --- a/jscomp/core/js_of_lam_string.ml +++ b/jscomp/core/js_of_lam_string.ml @@ -29,7 +29,7 @@ module E = Js_exp_make currently, it follows the same patten of ocaml, [char] is [int] *) -let const_char (i : char) = E.int ~c:i (Int32.of_int @@ Char.code i) +let const_char (i : char) = E.int ~c:i (Int32.of_int @@ (Char.code i)) (* string [s[i]] expects to return a [ocaml_char] *) let ref_string e e1 = E.string_index e e1 diff --git a/jscomp/core/lam_constant_convert.ml b/jscomp/core/lam_constant_convert.ml index 50b76e2ee2..bbd3f99e35 100644 --- a/jscomp/core/lam_constant_convert.ml +++ b/jscomp/core/lam_constant_convert.ml @@ -25,7 +25,7 @@ let rec convert_constant (const : Lambda.structured_constant) : Lam_constant.t = match const with | Const_base (Const_int i) -> Const_int { i = Int32.of_int i; comment = None } - | Const_base (Const_char i) -> Const_char i + | Const_base (Const_char i) -> Const_char (Obj.magic i) | Const_base (Const_string (s, opt)) -> let unicode = match opt with diff --git a/jscomp/ml/ast_helper.ml b/jscomp/ml/ast_helper.ml index 2d1f9b565b..80fb40a1c7 100644 --- a/jscomp/ml/ast_helper.ml +++ b/jscomp/ml/ast_helper.ml @@ -39,7 +39,7 @@ module Const = struct let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i) let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i) let float ?suffix f = Pconst_float (f, suffix) - let char c = Pconst_char c + let char c = Pconst_char (Char.code c) let string ?quotation_delimiter s = Pconst_string (s, quotation_delimiter) end diff --git a/jscomp/ml/asttypes.ml b/jscomp/ml/asttypes.ml index 9c6f4aea36..8fefc45283 100644 --- a/jscomp/ml/asttypes.ml +++ b/jscomp/ml/asttypes.ml @@ -17,7 +17,7 @@ type constant = Const_int of int - | Const_char of char + | Const_char of int | Const_string of string * string option | Const_float of string | Const_int32 of int32 @@ -70,4 +70,4 @@ let same_arg_label (x : arg_label) y = begin match y with | Optional s0 -> s = s0 | _ -> false - end \ No newline at end of file + end diff --git a/jscomp/ml/matching.ml b/jscomp/ml/matching.ml index e65cb7a21e..4802a3dbf8 100644 --- a/jscomp/ml/matching.ml +++ b/jscomp/ml/matching.ml @@ -2202,7 +2202,7 @@ let combine_constant names loc arg cst partial ctx def call_switcher loc fail arg min_int max_int int_lambda_list names | Const_char _ -> let int_lambda_list = - List.map (function Const_char c, l -> (Char.code c, l) + List.map (function Const_char c, l -> (c, l) | _ -> assert false) const_lambda_list in call_switcher loc fail arg 0 max_int int_lambda_list names diff --git a/jscomp/ml/parmatch.ml b/jscomp/ml/parmatch.ml index 47ca04ad0d..4836af68f3 100644 --- a/jscomp/ml/parmatch.ml +++ b/jscomp/ml/parmatch.ml @@ -379,7 +379,7 @@ let is_cons = function let pretty_const c = match c with | Const_int i -> Printf.sprintf "%d" i -| Const_char c -> Printf.sprintf "%C" c +| Const_char i -> Printf.sprintf "%s" (string_of_int i) | Const_string (s, _) -> Printf.sprintf "%S" s | Const_float f -> Printf.sprintf "%s" f | Const_int32 i -> Printf.sprintf "%ldl" i @@ -1088,9 +1088,9 @@ let build_other ext env : Typedtree.pattern = match env with | ({pat_desc=(Tpat_constant (Const_char _ ))} as p,_) :: _ -> build_other_constant (function - | Tpat_constant (Const_char i) -> Char.code i + | Tpat_constant (Const_char i) -> i | _ -> assert false) - (function i -> Tpat_constant(Const_char (Obj.magic (i:int) : char))) + (function i -> Tpat_constant(Const_char (i))) 0 succ p env | ({pat_desc=(Tpat_constant (Const_int32 _))} as p,_) :: _ -> build_other_constant diff --git a/jscomp/ml/parser.ml b/jscomp/ml/parser.ml index 5ddf83e25f..31527ccc9c 100644 --- a/jscomp/ml/parser.ml +++ b/jscomp/ml/parser.ml @@ -11015,7 +11015,7 @@ let yyact = [| let _1 = (Parsing.peek_val __caml_parser_env 0 : char) in Obj.repr( # 2155 "ml/parser.mly" - ( Pconst_char _1 ) + ( Pconst_char (Char.code _1) ) # 11020 "ml/parser.ml" : 'constant)) ; (fun __caml_parser_env -> diff --git a/jscomp/ml/parsetree.ml b/jscomp/ml/parsetree.ml index d2b997ab41..ebf1837755 100644 --- a/jscomp/ml/parsetree.ml +++ b/jscomp/ml/parsetree.ml @@ -24,7 +24,7 @@ type constant = Suffixes [g-z][G-Z] are accepted by the parser. Suffixes except 'l', 'L' and 'n' are rejected by the typechecker *) - | Pconst_char of char + | Pconst_char of int (* 'c' *) | Pconst_string of string * string option (* "constant" diff --git a/jscomp/ml/pprintast.ml b/jscomp/ml/pprintast.ml index 8c0ec6d74d..5f1cdfe319 100644 --- a/jscomp/ml/pprintast.ml +++ b/jscomp/ml/pprintast.ml @@ -193,7 +193,7 @@ let rec longident f = function let longident_loc f x = pp f "%a" longident x.txt let constant f = function - | Pconst_char i -> pp f "%C" i + | Pconst_char i -> pp f "%C" (Char.chr i) | Pconst_string (i, None) -> pp f "%S" i | Pconst_string (i, Some delim) -> pp f "{%s|%s|%s}" delim i delim | Pconst_integer (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i diff --git a/jscomp/ml/pprintast.pp.ml b/jscomp/ml/pprintast.pp.ml index 2bdeb8b923..442594bb95 100644 --- a/jscomp/ml/pprintast.pp.ml +++ b/jscomp/ml/pprintast.pp.ml @@ -192,7 +192,7 @@ let rec longident f = function let longident_loc f x = pp f "%a" longident x.txt let constant f = function - | Pconst_char i -> pp f "%C" i + | Pconst_char i -> pp f "%C" (Char.chr i) | Pconst_string (i, None) -> pp f "%S" i | Pconst_string (i, Some delim) -> pp f "{%s|%s|%s}" delim i delim | Pconst_integer (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i diff --git a/jscomp/ml/printast.ml b/jscomp/ml/printast.ml index 3ab833359c..eee7a90517 100644 --- a/jscomp/ml/printast.ml +++ b/jscomp/ml/printast.ml @@ -60,7 +60,7 @@ let fmt_char_option f = function let fmt_constant f x = match x with | Pconst_integer (i,m) -> fprintf f "PConst_int (%s,%a)" i fmt_char_option m; - | Pconst_char (c) -> fprintf f "PConst_char %02x" (Char.code c); + | Pconst_char (c) -> fprintf f "PConst_char %02x" c; | Pconst_string (s, None) -> fprintf f "PConst_string(%S,None)" s; | Pconst_string (s, Some delim) -> fprintf f "PConst_string (%S,Some %S)" s delim; diff --git a/jscomp/ml/printlambda.ml b/jscomp/ml/printlambda.ml index 636834bed9..a355c86768 100644 --- a/jscomp/ml/printlambda.ml +++ b/jscomp/ml/printlambda.ml @@ -21,7 +21,7 @@ open Lambda let rec struct_const ppf = function | Const_base(Const_int n) -> fprintf ppf "%i" n - | Const_base(Const_char c) -> fprintf ppf "%C" c + | Const_base(Const_char i) -> fprintf ppf "%s" (string_of_int i) | Const_base(Const_string (s, _)) -> fprintf ppf "%S" s | Const_immstring s -> fprintf ppf "#%S" s | Const_base(Const_float f) -> fprintf ppf "%s" f diff --git a/jscomp/ml/printtyped.ml b/jscomp/ml/printtyped.ml index 09e348c9fe..f6243f6c6e 100644 --- a/jscomp/ml/printtyped.ml +++ b/jscomp/ml/printtyped.ml @@ -58,7 +58,7 @@ let fmt_path f x = fprintf f "\"%a\"" fmt_path_aux x;; let fmt_constant f x = match x with | Const_int (i) -> fprintf f "Const_int %d" i; - | Const_char (c) -> fprintf f "Const_char %02x" (Char.code c); + | Const_char (c) -> fprintf f "Const_char %02x" c; | Const_string (s, None) -> fprintf f "Const_string(%S,None)" s; | Const_string (s, Some delim) -> fprintf f "Const_string (%S,Some %S)" s delim; diff --git a/jscomp/ml/typecore.ml b/jscomp/ml/typecore.ml index 012cdd765c..59e0cda9d8 100644 --- a/jscomp/ml/typecore.ml +++ b/jscomp/ml/typecore.ml @@ -1009,7 +1009,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env else or_ ~loc:gloc (constant ~loc:gloc (Pconst_char c1)) - (loop (Char.chr(Char.code c1 + 1)) c2) + (loop (c1 + 1) c2) in let p = if c1 <= c2 then loop c1 c2 else loop c2 c1 in let p = {p with ppat_loc=loc} in From 161832dce34fe66148dbec6af9664c24ae7c9cfa Mon Sep 17 00:00:00 2001 From: butterunderflow Date: Fri, 28 Oct 2022 02:31:58 +0800 Subject: [PATCH 02/15] tweak --- jscomp/ml/parser.mly | 2 +- jscomp/ml/pprintast.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/jscomp/ml/parser.mly b/jscomp/ml/parser.mly index dc1fca4229..fe4ace9a4e 100644 --- a/jscomp/ml/parser.mly +++ b/jscomp/ml/parser.mly @@ -2152,7 +2152,7 @@ label: constant: | INT { let (n, m) = $1 in Pconst_integer (n, m) } - | CHAR { Pconst_char $1 } + | CHAR { Pconst_char (Char.code $1) } | STRING { let (s, d) = $1 in Pconst_string (s, d) } | FLOAT { let (f, m) = $1 in Pconst_float (f, m) } ; diff --git a/jscomp/ml/pprintast.ml b/jscomp/ml/pprintast.ml index 5f1cdfe319..0efef3b106 100644 --- a/jscomp/ml/pprintast.ml +++ b/jscomp/ml/pprintast.ml @@ -193,7 +193,7 @@ let rec longident f = function let longident_loc f x = pp f "%a" longident x.txt let constant f = function - | Pconst_char i -> pp f "%C" (Char.chr i) + | Pconst_char i -> pp f "%C" (Char.unsafe_chr i) (*consider safety*) | Pconst_string (i, None) -> pp f "%S" i | Pconst_string (i, Some delim) -> pp f "{%s|%s|%s}" delim i delim | Pconst_integer (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i From 197f742b4fc7bd63dfdb14b3095482320c6675af Mon Sep 17 00:00:00 2001 From: butterunderflow Date: Fri, 28 Oct 2022 02:38:44 +0800 Subject: [PATCH 03/15] tweak --- jscomp/core/lam_constant_convert.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/jscomp/core/lam_constant_convert.ml b/jscomp/core/lam_constant_convert.ml index bbd3f99e35..143b44b3bb 100644 --- a/jscomp/core/lam_constant_convert.ml +++ b/jscomp/core/lam_constant_convert.ml @@ -25,7 +25,7 @@ let rec convert_constant (const : Lambda.structured_constant) : Lam_constant.t = match const with | Const_base (Const_int i) -> Const_int { i = Int32.of_int i; comment = None } - | Const_base (Const_char i) -> Const_char (Obj.magic i) + | Const_base (Const_char i) -> Const_char (Char.unsafe_chr i) | Const_base (Const_string (s, opt)) -> let unicode = match opt with From 863b799a0cd6fd4b705ec45f943022b9a662b8bd Mon Sep 17 00:00:00 2001 From: butterunderflow Date: Fri, 28 Oct 2022 04:14:43 +0800 Subject: [PATCH 04/15] representation of char for lambda --- jscomp/core/js_dump.ml | 2 +- jscomp/core/js_exp_make.mli | 2 +- jscomp/core/js_of_lam_string.ml | 2 +- jscomp/core/js_of_lam_string.mli | 2 +- jscomp/core/js_op.ml | 2 +- jscomp/core/lam.ml | 4 ++-- jscomp/core/lam_constant.ml | 2 +- jscomp/core/lam_constant.mli | 2 +- jscomp/core/lam_constant_convert.ml | 2 +- jscomp/core/lam_pass_lets_dce.ml | 2 +- jscomp/core/lam_pass_lets_dce.pp.ml | 2 +- jscomp/core/lam_print.ml | 2 +- jscomp/ml/pprintast.ml | 2 +- 13 files changed, 14 insertions(+), 14 deletions(-) diff --git a/jscomp/core/js_dump.ml b/jscomp/core/js_dump.ml index 4063b60bde..65e9a493ed 100644 --- a/jscomp/core/js_dump.ml +++ b/jscomp/core/js_dump.ml @@ -630,7 +630,7 @@ and expression_desc cxt ~(level : int) f x : cxt = match v with | Float { f } -> Js_number.caml_float_literal_to_js_string f (* attach string here for float constant folding?*) - | Int { i; c = Some c } -> Format.asprintf "/* %C */%ld" c i + | Int { i; c = Some c } -> Format.asprintf "/* %C */%ld" (Char.unsafe_chr c) i | Int { i; c = None } -> Int32.to_string i (* check , js convention with ocaml lexical convention *) diff --git a/jscomp/core/js_exp_make.mli b/jscomp/core/js_exp_make.mli index 0c9ef3bd28..351663cceb 100644 --- a/jscomp/core/js_exp_make.mli +++ b/jscomp/core/js_exp_make.mli @@ -103,7 +103,7 @@ val method_ : val econd : ?comment:string -> t -> t -> t -> t -val int : ?comment:string -> ?c:char -> int32 -> t +val int : ?comment:string -> ?c:int -> int32 -> t val uint32 : ?comment:string -> int32 -> t diff --git a/jscomp/core/js_of_lam_string.ml b/jscomp/core/js_of_lam_string.ml index 50c343f238..1ec3f77e98 100644 --- a/jscomp/core/js_of_lam_string.ml +++ b/jscomp/core/js_of_lam_string.ml @@ -29,7 +29,7 @@ module E = Js_exp_make currently, it follows the same patten of ocaml, [char] is [int] *) -let const_char (i : char) = E.int ~c:i (Int32.of_int @@ (Char.code i)) +let const_char (i : int) = E.int ~c:i (Int32.of_int @@ i) (* string [s[i]] expects to return a [ocaml_char] *) let ref_string e e1 = E.string_index e e1 diff --git a/jscomp/core/js_of_lam_string.mli b/jscomp/core/js_of_lam_string.mli index cb3f2aeb10..eb6ca708dd 100644 --- a/jscomp/core/js_of_lam_string.mli +++ b/jscomp/core/js_of_lam_string.mli @@ -34,6 +34,6 @@ val ref_byte : J.expression -> J.expression -> J.expression val set_byte : J.expression -> J.expression -> J.expression -> J.expression -val const_char : char -> J.expression +val const_char : int -> J.expression val bytes_to_string : J.expression -> J.expression diff --git a/jscomp/core/js_op.ml b/jscomp/core/js_op.ml index b7e25e2f4a..4e40d3eb5b 100644 --- a/jscomp/core/js_op.ml +++ b/jscomp/core/js_op.ml @@ -126,7 +126,7 @@ type float_lit = { f : string } [@@unboxed] type number = | Float of float_lit - | Int of { i : int32; c : char option } + | Int of { i : int32; c : int option } | Uint of int32 (* becareful when constant folding +/-, diff --git a/jscomp/core/lam.ml b/jscomp/core/lam.ml index 2915b1f5f7..989c047ac3 100644 --- a/jscomp/core/lam.ml +++ b/jscomp/core/lam.ml @@ -562,7 +562,7 @@ let prim ~primitive:(prim : Lam_primitive.t) ~args loc : t = | ( (Pstringrefs | Pstringrefu), Const_string { s = a; unicode = false }, Const_int { i = b } ) -> ( - try Lift.char (String.get a (Int32.to_int b)) with _ -> default ()) + try Lift.char (Char.code (String.get a (Int32.to_int b))) with _ -> default ()) | _ -> default ()) | _ -> ( match prim with @@ -633,7 +633,7 @@ let rec complete_range (sw_consts : (int * _) list) ~(start : int) ~finish = let rec eval_const_as_bool (v : Lam_constant.t) : bool = match v with | Const_int { i = x } -> x <> 0l - | Const_char x -> Char.code x <> 0 + | Const_char x -> x <> 0 | Const_int64 x -> x <> 0L | Const_js_false | Const_js_null | Const_module_alias | Const_js_undefined -> false diff --git a/jscomp/core/lam_constant.ml b/jscomp/core/lam_constant.ml index 547c5be174..5775e9b461 100644 --- a/jscomp/core/lam_constant.ml +++ b/jscomp/core/lam_constant.ml @@ -42,7 +42,7 @@ type t = | Const_js_true | Const_js_false | Const_int of { i : int32; comment : pointer_info } - | Const_char of char + | Const_char of int | Const_string of { s : string; unicode : bool } | Const_float of string | Const_int64 of int64 diff --git a/jscomp/core/lam_constant.mli b/jscomp/core/lam_constant.mli index eeb61134dd..4fdb33b1c9 100644 --- a/jscomp/core/lam_constant.mli +++ b/jscomp/core/lam_constant.mli @@ -38,7 +38,7 @@ type t = | Const_js_true | Const_js_false | Const_int of { i : int32; comment : pointer_info } - | Const_char of char + | Const_char of int | Const_string of { s : string; unicode : bool } | Const_float of string | Const_int64 of int64 diff --git a/jscomp/core/lam_constant_convert.ml b/jscomp/core/lam_constant_convert.ml index 143b44b3bb..50b76e2ee2 100644 --- a/jscomp/core/lam_constant_convert.ml +++ b/jscomp/core/lam_constant_convert.ml @@ -25,7 +25,7 @@ let rec convert_constant (const : Lambda.structured_constant) : Lam_constant.t = match const with | Const_base (Const_int i) -> Const_int { i = Int32.of_int i; comment = None } - | Const_base (Const_char i) -> Const_char (Char.unsafe_chr i) + | Const_base (Const_char i) -> Const_char i | Const_base (Const_string (s, opt)) -> let unicode = match opt with diff --git a/jscomp/core/lam_pass_lets_dce.ml b/jscomp/core/lam_pass_lets_dce.ml index 11c35d10da..75dc0c555a 100644 --- a/jscomp/core/lam_pass_lets_dce.ml +++ b/jscomp/core/lam_pass_lets_dce.ml @@ -209,7 +209,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = |Lconst((Const_int {i})) -> let i = Int32.to_int i in if i < String.length l_s && i >= 0 then - Lam.const ((Const_char l_s.[i])) + Lam.const ((Const_char (Char.code l_s.[i]))) else Lam.prim ~primitive ~args:[l';r'] loc | _ -> diff --git a/jscomp/core/lam_pass_lets_dce.pp.ml b/jscomp/core/lam_pass_lets_dce.pp.ml index b8bd3e4d31..cb9d2771ad 100644 --- a/jscomp/core/lam_pass_lets_dce.pp.ml +++ b/jscomp/core/lam_pass_lets_dce.pp.ml @@ -208,7 +208,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = |Lconst((Const_int {i})) -> let i = Int32.to_int i in if i < String.length l_s && i >= 0 then - Lam.const ((Const_char l_s.[i])) + Lam.const ((Const_char (Char.code l_s.[i]))) else Lam.prim ~primitive ~args:[l';r'] loc | _ -> diff --git a/jscomp/core/lam_print.ml b/jscomp/core/lam_print.ml index 80188805e8..1967277657 100644 --- a/jscomp/core/lam_print.ml +++ b/jscomp/core/lam_print.ml @@ -21,7 +21,7 @@ let rec struct_const ppf (cst : Lam_constant.t) = | Const_module_alias -> fprintf ppf "#alias" | Const_js_undefined -> fprintf ppf "#undefined" | Const_int { i } -> fprintf ppf "%ld" i - | Const_char c -> fprintf ppf "%C" c + | Const_char c -> fprintf ppf "%C" (Char.unsafe_chr c) | Const_string { s } -> fprintf ppf "%S" s | Const_float f -> fprintf ppf "%s" f | Const_int64 n -> fprintf ppf "%LiL" n diff --git a/jscomp/ml/pprintast.ml b/jscomp/ml/pprintast.ml index 0efef3b106..5f1cdfe319 100644 --- a/jscomp/ml/pprintast.ml +++ b/jscomp/ml/pprintast.ml @@ -193,7 +193,7 @@ let rec longident f = function let longident_loc f x = pp f "%a" longident x.txt let constant f = function - | Pconst_char i -> pp f "%C" (Char.unsafe_chr i) (*consider safety*) + | Pconst_char i -> pp f "%C" (Char.chr i) | Pconst_string (i, None) -> pp f "%S" i | Pconst_string (i, Some delim) -> pp f "{%s|%s|%s}" delim i delim | Pconst_integer (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i From 0121a20cee55661301b36e34617a37e7e8aa993d Mon Sep 17 00:00:00 2001 From: butterunderflow Date: Fri, 28 Oct 2022 04:57:00 +0800 Subject: [PATCH 05/15] lib --- lib/4.06.1/unstable/all_ounit_tests.ml | 11 +- lib/4.06.1/unstable/js_compiler.ml | 466 +++++++++--- lib/4.06.1/unstable/js_compiler.ml.d | 2 + lib/4.06.1/unstable/js_playground_compiler.ml | 715 ++++++++++------- lib/4.06.1/whole_compiler.ml | 719 +++++++++++------- 5 files changed, 1253 insertions(+), 660 deletions(-) diff --git a/lib/4.06.1/unstable/all_ounit_tests.ml b/lib/4.06.1/unstable/all_ounit_tests.ml index ec50f41a69..f03e1543ee 100644 --- a/lib/4.06.1/unstable/all_ounit_tests.ml +++ b/lib/4.06.1/unstable/all_ounit_tests.ml @@ -10698,7 +10698,7 @@ module Asttypes type constant = Const_int of int - | Const_char of char + | Const_char of int | Const_string of string * string option | Const_float of string | Const_int32 of int32 @@ -10752,6 +10752,7 @@ let same_arg_label (x : arg_label) y = | Optional s0 -> s = s0 | _ -> false end + end module Longident : sig #1 "longident.mli" @@ -10879,7 +10880,7 @@ type constant = Suffixes [g-z][G-Z] are accepted by the parser. Suffixes except 'l', 'L' and 'n' are rejected by the typechecker *) - | Pconst_char of char + | Pconst_char of int (* 'c' *) | Pconst_string of string * string option (* "constant" @@ -13983,7 +13984,7 @@ module Const = struct let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i) let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i) let float ?suffix f = Pconst_float (f, suffix) - let char c = Pconst_char c + let char c = Pconst_char (Char.code c) let string ?quotation_delimiter s = Pconst_string (s, quotation_delimiter) end @@ -25657,7 +25658,7 @@ let yyact = [| let _1 = (Parsing.peek_val __caml_parser_env 0 : char) in Obj.repr( # 2155 "ml/parser.mly" - ( Pconst_char _1 ) + ( Pconst_char (Char.code _1) ) # 11020 "ml/parser.ml" : 'constant)) ; (fun __caml_parser_env -> @@ -51154,7 +51155,7 @@ type float_lit = { f : string } [@@unboxed] type number = | Float of float_lit - | Int of { i : int32; c : char option } + | Int of { i : int32; c : int option } | Uint of int32 (* becareful when constant folding +/-, diff --git a/lib/4.06.1/unstable/js_compiler.ml b/lib/4.06.1/unstable/js_compiler.ml index 2d6e3cc4f5..2800ea3b98 100644 --- a/lib/4.06.1/unstable/js_compiler.ml +++ b/lib/4.06.1/unstable/js_compiler.ml @@ -3120,7 +3120,7 @@ module Asttypes type constant = Const_int of int - | Const_char of char + | Const_char of int | Const_string of string * string option | Const_float of string | Const_int32 of int32 @@ -3174,6 +3174,7 @@ let same_arg_label (x : arg_label) y = | Optional s0 -> s = s0 | _ -> false end + end module Identifiable : sig #1 "identifiable.mli" @@ -3998,7 +3999,7 @@ type constant = Suffixes [g-z][G-Z] are accepted by the parser. Suffixes except 'l', 'L' and 'n' are rejected by the typechecker *) - | Pconst_char of char + | Pconst_char of int (* 'c' *) | Pconst_string of string * string option (* "constant" @@ -12151,7 +12152,7 @@ module Const = struct let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i) let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i) let float ?suffix f = Pconst_float (f, suffix) - let char c = Pconst_char c + let char c = Pconst_char (Char.code c) let string ?quotation_delimiter s = Pconst_string (s, quotation_delimiter) end @@ -26837,7 +26838,7 @@ let is_cons = function let pretty_const c = match c with | Const_int i -> Printf.sprintf "%d" i -| Const_char c -> Printf.sprintf "%C" c +| Const_char i -> Printf.sprintf "%s" (string_of_int i) | Const_string (s, _) -> Printf.sprintf "%S" s | Const_float f -> Printf.sprintf "%s" f | Const_int32 i -> Printf.sprintf "%ldl" i @@ -27546,9 +27547,9 @@ let build_other ext env : Typedtree.pattern = match env with | ({pat_desc=(Tpat_constant (Const_char _ ))} as p,_) :: _ -> build_other_constant (function - | Tpat_constant (Const_char i) -> Char.code i + | Tpat_constant (Const_char i) -> i | _ -> assert false) - (function i -> Tpat_constant(Const_char (Obj.magic (i:int) : char))) + (function i -> Tpat_constant(Const_char (i))) 0 succ p env | ({pat_desc=(Tpat_constant (Const_int32 _))} as p,_) :: _ -> build_other_constant @@ -29128,7 +29129,7 @@ open Lambda let rec struct_const ppf = function | Const_base(Const_int n) -> fprintf ppf "%i" n - | Const_base(Const_char c) -> fprintf ppf "%C" c + | Const_base(Const_char i) -> fprintf ppf "%s" (string_of_int i) | Const_base(Const_string (s, _)) -> fprintf ppf "%S" s | Const_immstring s -> fprintf ppf "#%S" s | Const_base(Const_float f) -> fprintf ppf "%s" f @@ -39966,7 +39967,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env else or_ ~loc:gloc (constant ~loc:gloc (Pconst_char c1)) - (loop (Char.chr(Char.code c1 + 1)) c2) + (loop (c1 + 1) c2) in let p = if c1 <= c2 then loop c1 c2 else loop c2 c1 in let p = {p with ppat_loc=loc} in @@ -45059,7 +45060,7 @@ let combine_constant names loc arg cst partial ctx def call_switcher loc fail arg min_int max_int int_lambda_list names | Const_char _ -> let int_lambda_list = - List.map (function Const_char c, l -> (Char.code c, l) + List.map (function Const_char c, l -> (c, l) | _ -> assert false) const_lambda_list in call_switcher loc fail arg 0 max_int int_lambda_list names @@ -47773,6 +47774,8 @@ val isBlockExpr : Parsetree.expression -> bool val isTemplateLiteral : Parsetree.expression -> bool val hasTemplateLiteralAttr : Parsetree.attributes -> bool +val isSpreadBeltListConcat : Parsetree.expression -> bool + val collectOrPatternChain : Parsetree.pattern -> Parsetree.pattern list val processBracesAttr : @@ -48416,6 +48419,25 @@ let isTemplateLiteral expr = | Pexp_constant _ when hasTemplateLiteralAttr expr.pexp_attributes -> true | _ -> false +let hasSpreadAttr attrs = + List.exists + (fun attr -> + match attr with + | {Location.txt = "res.spread"}, _ -> true + | _ -> false) + attrs + +let isSpreadBeltListConcat expr = + match expr.pexp_desc with + | Pexp_ident + { + txt = + Longident.Ldot + (Longident.Ldot (Longident.Lident "Belt", "List"), "concatMany"); + } -> + hasSpreadAttr expr.pexp_attributes + | _ -> false + (* Blue | Red | Green -> [Blue; Red; Green] *) let collectOrPatternChain pat = let rec loop pattern chain = @@ -50847,7 +50869,7 @@ type t = | Open | True | False - | Codepoint of {c: char; original: string} + | Codepoint of {c: int; original: string} | Int of {i: string; suffix: char option} | Float of {f: string; suffix: char option} | String of string @@ -51104,6 +51126,163 @@ let isKeywordTxt str = let catch = Lident "catch" +end +module Res_utf8 : sig +#1 "res_utf8.mli" +val max : int + +val decodeCodePoint : int -> string -> int -> int * int + +val encodeCodePoint : int -> string + +val isValidCodePoint : int -> bool + +end = struct +#1 "res_utf8.ml" +(* https://tools.ietf.org/html/rfc3629#section-10 *) +(* let bom = 0xFEFF *) + +let repl = 0xFFFD + +(* let min = 0x0000 *) +let max = 0x10FFFF + +let surrogateMin = 0xD800 +let surrogateMax = 0xDFFF + +(* + * Char. number range | UTF-8 octet sequence + * (hexadecimal) | (binary) + * --------------------+--------------------------------------------- + * 0000 0000-0000 007F | 0xxxxxxx + * 0000 0080-0000 07FF | 110xxxxx 10xxxxxx + * 0000 0800-0000 FFFF | 1110xxxx 10xxxxxx 10xxxxxx + * 0001 0000-0010 FFFF | 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx + *) +let h2 = 0b1100_0000 +let h3 = 0b1110_0000 +let h4 = 0b1111_0000 + +let cont_mask = 0b0011_1111 + +type category = {low: int; high: int; size: int} + +let locb = 0b1000_0000 +let hicb = 0b1011_1111 + +let categoryTable = [| + (* 0 *) {low = -1; high= -1; size= 1}; (* invalid *) + (* 1 *) {low = 1; high= -1; size= 1}; (* ascii *) + (* 2 *) {low = locb; high= hicb; size= 2}; + (* 3 *) {low = 0xA0; high= hicb; size= 3}; + (* 4 *) {low = locb; high= hicb; size= 3}; + (* 5 *) {low = locb; high= 0x9F; size= 3}; + (* 6 *) {low = 0x90; high= hicb; size= 4}; + (* 7 *) {low = locb; high= hicb; size= 4}; + (* 8 *) {low = locb; high= 0x8F; size= 4}; +|] [@@ocamlformat "disable"] + +let categories = [| + 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; + 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; + 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; + 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; + 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; + 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; + 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; + 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; + + 0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0; + 0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0; + 0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0; + 0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0; + (* surrogate range U+D800 - U+DFFFF = 55296 - 917503 *) + 0; 0; 2; 2;2; 2; 2; 2;2; 2; 2; 2;2; 2; 2; 2; + 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; + 3; 4; 4; 4; 4; 4; 4; 4; 4; 4; 4; 4; 4; 5; 4; 4; + 6; 7; 7 ;7; 8; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; +|] [@@ocamlformat "disable"] + +let decodeCodePoint i s len = + if len < 1 then (repl, 1) + else + let first = int_of_char (String.unsafe_get s i) in + if first < 128 then (first, 1) + else + let index = Array.unsafe_get categories first in + if index = 0 then (repl, 1) + else + let cat = Array.unsafe_get categoryTable index in + if len < i + cat.size then (repl, 1) + else if cat.size == 2 then + let c1 = int_of_char (String.unsafe_get s (i + 1)) in + if c1 < cat.low || cat.high < c1 then (repl, 1) + else + let i1 = c1 land 0b00111111 in + let i0 = (first land 0b00011111) lsl 6 in + let uc = i0 lor i1 in + (uc, 2) + else if cat.size == 3 then + let c1 = int_of_char (String.unsafe_get s (i + 1)) in + let c2 = int_of_char (String.unsafe_get s (i + 2)) in + if c1 < cat.low || cat.high < c1 || c2 < locb || hicb < c2 then + (repl, 1) + else + let i0 = (first land 0b00001111) lsl 12 in + let i1 = (c1 land 0b00111111) lsl 6 in + let i2 = c2 land 0b00111111 in + let uc = i0 lor i1 lor i2 in + (uc, 3) + else + let c1 = int_of_char (String.unsafe_get s (i + 1)) in + let c2 = int_of_char (String.unsafe_get s (i + 2)) in + let c3 = int_of_char (String.unsafe_get s (i + 3)) in + if + c1 < cat.low || cat.high < c1 || c2 < locb || hicb < c2 || c3 < locb + || hicb < c3 + then (repl, 1) + else + let i1 = (c1 land 0x3f) lsl 12 in + let i2 = (c2 land 0x3f) lsl 6 in + let i3 = c3 land 0x3f in + let i0 = (first land 0x07) lsl 18 in + let uc = i0 lor i3 lor i2 lor i1 in + (uc, 4) + +let encodeCodePoint c = + if c <= 127 then ( + let bytes = (Bytes.create [@doesNotRaise]) 1 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr c); + Bytes.unsafe_to_string bytes) + else if c <= 2047 then ( + let bytes = (Bytes.create [@doesNotRaise]) 2 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h2 lor (c lsr 6))); + Bytes.unsafe_set bytes 1 + (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); + Bytes.unsafe_to_string bytes) + else if c <= 65535 then ( + let bytes = (Bytes.create [@doesNotRaise]) 3 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h3 lor (c lsr 12))); + Bytes.unsafe_set bytes 1 + (Char.unsafe_chr (0b1000_0000 lor ((c lsr 6) land cont_mask))); + Bytes.unsafe_set bytes 2 + (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); + Bytes.unsafe_to_string bytes) + else + (* if c <= max then *) + let bytes = (Bytes.create [@doesNotRaise]) 4 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h4 lor (c lsr 18))); + Bytes.unsafe_set bytes 1 + (Char.unsafe_chr (0b1000_0000 lor ((c lsr 12) land cont_mask))); + Bytes.unsafe_set bytes 2 + (Char.unsafe_chr (0b1000_0000 lor ((c lsr 6) land cont_mask))); + Bytes.unsafe_set bytes 3 + (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); + Bytes.unsafe_to_string bytes + +let isValidCodePoint c = + (0 <= c && c < surrogateMin) || (surrogateMax < c && c <= max) + end module Res_printer : sig #1 "res_printer.mli" @@ -51690,20 +51869,7 @@ let printConstant ?(templateLiteral = false) c = ] | Pconst_float (s, _) -> Doc.text s | Pconst_char c -> - let str = - match c with - | '\'' -> "\\'" - | '\\' -> "\\\\" - | '\n' -> "\\n" - | '\t' -> "\\t" - | '\r' -> "\\r" - | '\b' -> "\\b" - | ' ' .. '~' as c -> - let s = (Bytes.create [@doesNotRaise]) 1 in - Bytes.unsafe_set s 0 c; - Bytes.unsafe_to_string s - | c -> string_of_int (Obj.magic c) - in + let str = Res_utf8.encodeCodePoint c in Doc.text ("'" ^ str ^ "'") let printOptionalLabel attrs = @@ -54118,6 +54284,9 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = ]) | extension -> printExtension ~customLayout ~atModuleLvl:false extension cmtTbl) + | Pexp_apply (e, [(Nolabel, {pexp_desc = Pexp_array subLists})]) + when ParsetreeViewer.isSpreadBeltListConcat e -> + printBeltListConcatApply ~customLayout subLists cmtTbl | Pexp_apply _ -> if ParsetreeViewer.isUnaryExpression e then printUnaryExpression ~customLayout e cmtTbl @@ -54906,6 +55075,63 @@ and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = ]) | _ -> Doc.nil +and printBeltListConcatApply ~customLayout subLists cmtTbl = + let makeSpreadDoc commaBeforeSpread = function + | Some expr -> + Doc.concat + [ + commaBeforeSpread; + Doc.dotdotdot; + (let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + ] + | None -> Doc.nil + in + let makeSubListDoc (expressions, spread) = + let commaBeforeSpread = + match expressions with + | [] -> Doc.nil + | _ -> Doc.concat [Doc.text ","; Doc.line] + in + let spreadDoc = makeSpreadDoc commaBeforeSpread spread in + Doc.concat + [ + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + expressions); + spreadDoc; + ] + in + Doc.group + (Doc.concat + [ + Doc.text "list{"; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map makeSubListDoc + (List.map ParsetreeViewer.collectListExpressions subLists)); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ]) + (* callExpr(arg1, arg2) *) and printPexpApply ~customLayout expr cmtTbl = match expr.pexp_desc with @@ -69341,7 +69567,7 @@ let yyact = [| let _1 = (Parsing.peek_val __caml_parser_env 0 : char) in Obj.repr( # 2155 "ml/parser.mly" - ( Pconst_char _1 ) + ( Pconst_char (Char.code _1) ) # 11020 "ml/parser.ml" : 'constant)) ; (fun __caml_parser_env -> @@ -74901,7 +75127,7 @@ type float_lit = { f : string } [@@unboxed] type number = | Float of float_lit - | Int of { i : int32; c : char option } + | Int of { i : int32; c : int option } | Uint of int32 (* becareful when constant folding +/-, @@ -76841,7 +77067,7 @@ val method_ : val econd : ?comment:string -> t -> t -> t -> t -val int : ?comment:string -> ?c:char -> int32 -> t +val int : ?comment:string -> ?c:int -> int32 -> t val uint32 : ?comment:string -> int32 -> t @@ -79650,7 +79876,7 @@ and expression_desc cxt ~(level : int) f x : cxt = match v with | Float { f } -> Js_number.caml_float_literal_to_js_string f (* attach string here for float constant folding?*) - | Int { i; c = Some c } -> Format.asprintf "/* %C */%ld" c i + | Int { i; c = Some c } -> Format.asprintf "/* %C */%ld" (Char.unsafe_chr c) i | Int { i; c = None } -> Int32.to_string i (* check , js convention with ocaml lexical convention *) @@ -83388,7 +83614,7 @@ type t = | Const_js_true | Const_js_false | Const_int of { i : int32; comment : pointer_info } - | Const_char of char + | Const_char of int | Const_string of { s : string; unicode : bool } | Const_float of string | Const_int64 of int64 @@ -83451,7 +83677,7 @@ type t = | Const_js_true | Const_js_false | Const_int of { i : int32; comment : pointer_info } - | Const_char of char + | Const_char of int | Const_string of { s : string; unicode : bool } | Const_float of string | Const_int64 of int64 @@ -85243,7 +85469,7 @@ let prim ~primitive:(prim : Lam_primitive.t) ~args loc : t = | ( (Pstringrefs | Pstringrefu), Const_string { s = a; unicode = false }, Const_int { i = b } ) -> ( - try Lift.char (String.get a (Int32.to_int b)) with _ -> default ()) + try Lift.char (Char.code (String.get a (Int32.to_int b))) with _ -> default ()) | _ -> default ()) | _ -> ( match prim with @@ -85314,7 +85540,7 @@ let rec complete_range (sw_consts : (int * _) list) ~(start : int) ~finish = let rec eval_const_as_bool (v : Lam_constant.t) : bool = match v with | Const_int { i = x } -> x <> 0l - | Const_char x -> Char.code x <> 0 + | Const_char x -> x <> 0 | Const_int64 x -> x <> 0L | Const_js_false | Const_js_null | Const_module_alias | Const_js_undefined -> false @@ -92080,7 +92306,7 @@ let rec struct_const ppf (cst : Lam_constant.t) = | Const_module_alias -> fprintf ppf "#alias" | Const_js_undefined -> fprintf ppf "#undefined" | Const_int { i } -> fprintf ppf "%ld" i - | Const_char c -> fprintf ppf "%C" c + | Const_char c -> fprintf ppf "%C" (Char.unsafe_chr c) | Const_string { s } -> fprintf ppf "%S" s | Const_float f -> fprintf ppf "%s" f | Const_int64 n -> fprintf ppf "%LiL" n @@ -94882,7 +95108,7 @@ val ref_byte : J.expression -> J.expression -> J.expression val set_byte : J.expression -> J.expression -> J.expression -> J.expression -val const_char : char -> J.expression +val const_char : int -> J.expression val bytes_to_string : J.expression -> J.expression @@ -94919,7 +95145,7 @@ module E = Js_exp_make currently, it follows the same patten of ocaml, [char] is [int] *) -let const_char (i : char) = E.int ~c:i (Int32.of_int @@ Char.code i) +let const_char (i : int) = E.int ~c:i (Int32.of_int @@ i) (* string [s[i]] expects to return a [ocaml_char] *) let ref_string e e1 = E.string_index e e1 @@ -258215,7 +258441,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = |Lconst((Const_int {i})) -> let i = Int32.to_int i in if i < String.length l_s && i >= 0 then - Lam.const ((Const_char l_s.[i])) + Lam.const ((Const_char (Char.code l_s.[i]))) else Lam.prim ~primitive ~args:[l';r'] loc | _ -> @@ -271614,6 +271840,25 @@ let hasAttr (loc, _) = loc.txt = "react.component" let hasAttrOnBinding {pvb_attributes} = List.find_opt hasAttr pvb_attributes <> None +let coreTypeOfAttrs attributes = + List.find_map + (fun ({txt}, payload) -> + match (txt, payload) with + | "react.component", PTyp coreType -> Some coreType + | _ -> None) + attributes + +let typVarsOfCoreType {ptyp_desc} = + match ptyp_desc with + | Ptyp_constr (_, coreTypes) -> + List.filter + (fun {ptyp_desc} -> + match ptyp_desc with + | Ptyp_var _ -> true + | _ -> false) + coreTypes + | _ -> [] + let raiseError ~loc msg = Location.raise_errorf ~loc msg let raiseErrorMultipleReactComponent ~loc = @@ -272858,6 +273103,8 @@ let constantString ~loc str = (* {} empty record *) let emptyRecord ~loc = Exp.record ~loc [] None +let unitExpr ~loc = Exp.construct ~loc (Location.mkloc (Lident "()") loc) None + let safeTypeFromValue valueStr = let valueStr = getLabel valueStr in if valueStr = "" || (valueStr.[0] [@doesNotRaise]) <> '_' then valueStr @@ -273131,13 +273378,30 @@ let makeTypeDecls propsName loc namedTypeList = ~kind:(Ptype_record labelDeclList); ] +let makeTypeDeclsWithCoreType propsName loc coreType typVars = + [ + Type.mk ~loc {txt = propsName; loc} ~kind:Ptype_abstract + ~params:(typVars |> List.map (fun v -> (v, Invariant))) + ~manifest:coreType; + ] + (* type props<'x, 'y, ...> = { x: 'x, y?: 'y, ... } *) -let makePropsRecordType propsName loc namedTypeList = - Str.type_ Nonrecursive (makeTypeDecls propsName loc namedTypeList) +let makePropsRecordType ~coreTypeOfAttr ~typVarsOfCoreType propsName loc + namedTypeList = + Str.type_ Nonrecursive + (match coreTypeOfAttr with + | None -> makeTypeDecls propsName loc namedTypeList + | Some coreType -> + makeTypeDeclsWithCoreType propsName loc coreType typVarsOfCoreType) (* type props<'x, 'y, ...> = { x: 'x, y?: 'y, ... } *) -let makePropsRecordTypeSig propsName loc namedTypeList = - Sig.type_ Nonrecursive (makeTypeDecls propsName loc namedTypeList) +let makePropsRecordTypeSig ~coreTypeOfAttr ~typVarsOfCoreType propsName loc + namedTypeList = + Sig.type_ Nonrecursive + (match coreTypeOfAttr with + | None -> makeTypeDecls propsName loc namedTypeList + | Some coreType -> + makeTypeDeclsWithCoreType propsName loc coreType typVarsOfCoreType) let transformUppercaseCall3 ~config modulePath mapper jsxExprLoc callExprLoc attrs callArguments = @@ -273207,51 +273471,46 @@ let transformUppercaseCall3 ~config modulePath mapper jsxExprLoc callExprLoc match config.mode with (* The new jsx transform *) | "automatic" -> - let jsxExpr, key = + let jsxExpr, keyAndUnit = match (!childrenArg, keyProp) with - | None, (_, keyExpr) :: _ -> + | None, key :: _ -> ( Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "jsxKeyed")}, - [(nolabel, keyExpr)] ) + [key; (nolabel, unitExpr ~loc:Location.none)] ) | None, [] -> (Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "jsx")}, []) - | Some _, (_, keyExpr) :: _ -> + | Some _, key :: _ -> ( Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "jsxsKeyed")}, - [(nolabel, keyExpr)] ) + [key; (nolabel, unitExpr ~loc:Location.none)] ) | Some _, [] -> ( Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "jsxs")}, [] ) in - Exp.apply ~attrs jsxExpr ([(nolabel, makeID); (nolabel, props)] @ key) + Exp.apply ~attrs jsxExpr ([(nolabel, makeID); (nolabel, props)] @ keyAndUnit) | _ -> ( match (!childrenArg, keyProp) with - | None, (_, keyExpr) :: _ -> + | None, key :: _ -> Exp.apply ~attrs (Exp.ident { loc = Location.none; txt = Ldot (Lident "React", "createElementWithKey"); }) - [(nolabel, makeID); (nolabel, props); (nolabel, keyExpr)] + [key; (nolabel, makeID); (nolabel, props)] | None, [] -> Exp.apply ~attrs (Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "createElement")}) [(nolabel, makeID); (nolabel, props)] - | Some children, (_, keyExpr) :: _ -> + | Some children, key :: _ -> Exp.apply ~attrs (Exp.ident { loc = Location.none; txt = Ldot (Lident "React", "createElementVariadicWithKey"); }) - [ - (nolabel, makeID); - (nolabel, props); - (nolabel, children); - (nolabel, keyExpr); - ] + [key; (nolabel, makeID); (nolabel, props); (nolabel, children)] | Some children, [] -> Exp.apply ~attrs (Exp.ident @@ -273317,25 +273576,25 @@ let transformLowercaseCall3 ~config mapper jsxExprLoc callExprLoc attrs let keyProp = args |> List.filter (fun (arg_label, _) -> "key" = getLabel arg_label) in - let jsxExpr, key = + let jsxExpr, keyAndUnit = match (!childrenArg, keyProp) with - | None, (_, keyExpr) :: _ -> + | None, key :: _ -> ( Exp.ident {loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsxKeyed")}, - [(nolabel, keyExpr)] ) + [key; (nolabel, unitExpr ~loc:Location.none)] ) | None, [] -> ( Exp.ident {loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsx")}, [] ) - | Some _, (_, keyExpr) :: _ -> + | Some _, key :: _ -> ( Exp.ident {loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsxsKeyed")}, - [(nolabel, keyExpr)] ) + [key; (nolabel, unitExpr ~loc:Location.none)] ) | Some _, [] -> ( Exp.ident {loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsxs")}, [] ) in Exp.apply ~attrs jsxExpr - ([(nolabel, componentNameExpr); (nolabel, props)] @ key) + ([(nolabel, componentNameExpr); (nolabel, props)] @ keyAndUnit) | _ -> let children, nonChildrenProps = extractChildren ~loc:jsxExprLoc callArguments @@ -273558,6 +273817,12 @@ let transformStructureItem ~config mapper item = config.hasReactComponent <- true; check_string_int_attribute_iter.structure_item check_string_int_attribute_iter item; + let coreTypeOfAttr = React_jsx_common.coreTypeOfAttrs pval_attributes in + let typVarsOfCoreType = + coreTypeOfAttr + |> Option.map React_jsx_common.typVarsOfCoreType + |> Option.value ~default:[] + in let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = match ptyp_desc with | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) @@ -273574,11 +273839,14 @@ let transformStructureItem ~config mapper item = let retPropsType = Typ.constr ~loc:pstr_loc (Location.mkloc (Lident "props") pstr_loc) - (makePropsTypeParams namedTypeList) + (match coreTypeOfAttr with + | None -> makePropsTypeParams namedTypeList + | Some _ -> typVarsOfCoreType) in (* type props<'x, 'y> = { x: 'x, y?: 'y, ... } *) let propsRecordType = - makePropsRecordType "props" pstr_loc namedTypeList + makePropsRecordType ~coreTypeOfAttr ~typVarsOfCoreType "props" + pstr_loc namedTypeList in (* can't be an arrow because it will defensively uncurry *) let newExternalType = @@ -273612,6 +273880,14 @@ let transformStructureItem ~config mapper item = React_jsx_common.raiseErrorMultipleReactComponent ~loc:pstr_loc else ( config.hasReactComponent <- true; + let coreTypeOfAttr = + React_jsx_common.coreTypeOfAttrs binding.pvb_attributes + in + let typVarsOfCoreType = + coreTypeOfAttr + |> Option.map React_jsx_common.typVarsOfCoreType + |> Option.value ~default:[] + in let bindingLoc = binding.pvb_loc in let bindingPatLoc = binding.pvb_pat.ppat_loc in let binding = @@ -273802,7 +274078,8 @@ let transformStructureItem ~config mapper item = let vbMatchList = List.map vbMatch namedArgWithDefaultValueList in (* type props = { ... } *) let propsRecordType = - makePropsRecordType "props" pstr_loc namedTypeList + makePropsRecordType ~coreTypeOfAttr ~typVarsOfCoreType "props" + pstr_loc namedTypeList in let innerExpression = Exp.apply @@ -273814,6 +274091,13 @@ let transformStructureItem ~config mapper item = [(Nolabel, Exp.ident (Location.mknoloc @@ Lident "ref"))] | false -> []) in + let makePropsPattern = function + | [] -> Pat.var @@ Location.mknoloc "props" + | _ -> + Pat.constraint_ + (Pat.var @@ Location.mknoloc "props") + (Typ.constr (Location.mknoloc @@ Lident "props") [Typ.any ()]) + in let fullExpression = (* React component name should start with uppercase letter *) (* let make = { let \"App" = props => make(props); \"App" } *) @@ -273821,12 +274105,9 @@ let transformStructureItem ~config mapper item = let \"App" = (props, ref) => make({...props, ref: @optional (Js.Nullabel.toOption(ref))}) })*) Exp.fun_ nolabel None - (match namedTypeList with - | [] -> Pat.var @@ Location.mknoloc "props" - | _ -> - Pat.constraint_ - (Pat.var @@ Location.mknoloc "props") - (Typ.constr (Location.mknoloc @@ Lident "props") [Typ.any ()])) + (match coreTypeOfAttr with + | None -> makePropsPattern namedTypeList + | Some _ -> makePropsPattern typVarsOfCoreType) (if hasForwardRef then Exp.fun_ nolabel None (Pat.var @@ Location.mknoloc "ref") @@ -273930,8 +274211,12 @@ let transformStructureItem ~config mapper item = (Pat.constraint_ recordPattern (Typ.constr ~loc:emptyLoc {txt = Lident "props"; loc = emptyLoc} - (makePropsTypeParams ~stripExplicitOption:true - ~stripExplicitJsNullableOfRef:hasForwardRef namedTypeList))) + (match coreTypeOfAttr with + | None -> + makePropsTypeParams ~stripExplicitOption:true + ~stripExplicitJsNullableOfRef:hasForwardRef + namedTypeList + | Some _ -> typVarsOfCoreType))) expression in (* let make = ({id, name, ...}: props<'id, 'name, ...>) => { ... } *) @@ -274007,6 +274292,12 @@ let transformSignatureItem ~config _mapper item = check_string_int_attribute_iter.signature_item check_string_int_attribute_iter item; let hasForwardRef = ref false in + let coreTypeOfAttr = React_jsx_common.coreTypeOfAttrs pval_attributes in + let typVarsOfCoreType = + coreTypeOfAttr + |> Option.map React_jsx_common.typVarsOfCoreType + |> Option.value ~default:[] + in let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = match ptyp_desc with | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) @@ -274029,10 +274320,13 @@ let transformSignatureItem ~config _mapper item = let retPropsType = Typ.constr (Location.mkloc (Lident "props") psig_loc) - (makePropsTypeParams namedTypeList) + (match coreTypeOfAttr with + | None -> makePropsTypeParams namedTypeList + | Some _ -> typVarsOfCoreType) in let propsRecordType = - makePropsRecordTypeSig "props" psig_loc + makePropsRecordTypeSig ~coreTypeOfAttr ~typVarsOfCoreType "props" + psig_loc ((* If there is Nolabel arg, regard the type as ref in forwardRef *) (if !hasForwardRef then [(true, "ref", [], refType Location.none)] else []) @@ -274141,24 +274435,22 @@ let expr ~config mapper expression = Exp.ident ~loc {loc; txt = Ldot (Lident "React", "fragment")} in let childrenExpr = transformChildrenIfList ~mapper listItems in + let recordOfChildren children = + Exp.record [(Location.mknoloc (Lident "children"), children)] None + in let args = [ (nolabel, fragment); (match config.mode with - | "automatic" -> + | "automatic" -> ( ( nolabel, - Exp.record - [ - ( Location.mknoloc @@ Lident "children", - match childrenExpr with - | {pexp_desc = Pexp_array children} -> ( - match children with - | [] -> emptyRecord ~loc:Location.none - | [child] -> child - | _ -> childrenExpr) - | _ -> childrenExpr ); - ] - None ) + match childrenExpr with + | {pexp_desc = Pexp_array children} -> ( + match children with + | [] -> emptyRecord ~loc:Location.none + | [child] -> recordOfChildren child + | _ -> recordOfChildren childrenExpr) + | _ -> recordOfChildren childrenExpr )) | "classic" | _ -> (nolabel, childrenExpr)); ] in diff --git a/lib/4.06.1/unstable/js_compiler.ml.d b/lib/4.06.1/unstable/js_compiler.ml.d index 1a6e5bdc13..d9c1e6e21b 100644 --- a/lib/4.06.1/unstable/js_compiler.ml.d +++ b/lib/4.06.1/unstable/js_compiler.ml.d @@ -584,6 +584,8 @@ ../lib/4.06.1/unstable/js_compiler.ml: ./napkin/res_printer.ml ../lib/4.06.1/unstable/js_compiler.ml: ./napkin/res_printer.mli ../lib/4.06.1/unstable/js_compiler.ml: ./napkin/res_token.ml +../lib/4.06.1/unstable/js_compiler.ml: ./napkin/res_utf8.ml +../lib/4.06.1/unstable/js_compiler.ml: ./napkin/res_utf8.mli ../lib/4.06.1/unstable/js_compiler.ml: ./outcome_printer/outcome_printer_ns.ml ../lib/4.06.1/unstable/js_compiler.ml: ./outcome_printer/outcome_printer_ns.mli ../lib/4.06.1/unstable/js_compiler.ml: ./stubs/bs_hash_stubs.pp.ml diff --git a/lib/4.06.1/unstable/js_playground_compiler.ml b/lib/4.06.1/unstable/js_playground_compiler.ml index 09f03dfd53..d4f06a2e5f 100644 --- a/lib/4.06.1/unstable/js_playground_compiler.ml +++ b/lib/4.06.1/unstable/js_playground_compiler.ml @@ -2847,7 +2847,7 @@ module Asttypes type constant = Const_int of int - | Const_char of char + | Const_char of int | Const_string of string * string option | Const_float of string | Const_int32 of int32 @@ -2901,6 +2901,7 @@ let same_arg_label (x : arg_label) y = | Optional s0 -> s = s0 | _ -> false end + end module Builtin_cmi_datasets : sig #1 "builtin_cmi_datasets.mli" @@ -3998,7 +3999,7 @@ type constant = Suffixes [g-z][G-Z] are accepted by the parser. Suffixes except 'l', 'L' and 'n' are rejected by the typechecker *) - | Pconst_char of char + | Pconst_char of int (* 'c' *) | Pconst_string of string * string option (* "constant" @@ -12151,7 +12152,7 @@ module Const = struct let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i) let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i) let float ?suffix f = Pconst_float (f, suffix) - let char c = Pconst_char c + let char c = Pconst_char (Char.code c) let string ?quotation_delimiter s = Pconst_string (s, quotation_delimiter) end @@ -26837,7 +26838,7 @@ let is_cons = function let pretty_const c = match c with | Const_int i -> Printf.sprintf "%d" i -| Const_char c -> Printf.sprintf "%C" c +| Const_char i -> Printf.sprintf "%s" (string_of_int i) | Const_string (s, _) -> Printf.sprintf "%S" s | Const_float f -> Printf.sprintf "%s" f | Const_int32 i -> Printf.sprintf "%ldl" i @@ -27546,9 +27547,9 @@ let build_other ext env : Typedtree.pattern = match env with | ({pat_desc=(Tpat_constant (Const_char _ ))} as p,_) :: _ -> build_other_constant (function - | Tpat_constant (Const_char i) -> Char.code i + | Tpat_constant (Const_char i) -> i | _ -> assert false) - (function i -> Tpat_constant(Const_char (Obj.magic (i:int) : char))) + (function i -> Tpat_constant(Const_char (i))) 0 succ p env | ({pat_desc=(Tpat_constant (Const_int32 _))} as p,_) :: _ -> build_other_constant @@ -29128,7 +29129,7 @@ open Lambda let rec struct_const ppf = function | Const_base(Const_int n) -> fprintf ppf "%i" n - | Const_base(Const_char c) -> fprintf ppf "%C" c + | Const_base(Const_char i) -> fprintf ppf "%s" (string_of_int i) | Const_base(Const_string (s, _)) -> fprintf ppf "%S" s | Const_immstring s -> fprintf ppf "#%S" s | Const_base(Const_float f) -> fprintf ppf "%s" f @@ -39966,7 +39967,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env else or_ ~loc:gloc (constant ~loc:gloc (Pconst_char c1)) - (loop (Char.chr(Char.code c1 + 1)) c2) + (loop (c1 + 1) c2) in let p = if c1 <= c2 then loop c1 c2 else loop c2 c1 in let p = {p with ppat_loc=loc} in @@ -45059,7 +45060,7 @@ let combine_constant names loc arg cst partial ctx def call_switcher loc fail arg min_int max_int int_lambda_list names | Const_char _ -> let int_lambda_list = - List.map (function Const_char c, l -> (Char.code c, l) + List.map (function Const_char c, l -> (c, l) | _ -> assert false) const_lambda_list in call_switcher loc fail arg 0 max_int int_lambda_list names @@ -47773,6 +47774,8 @@ val isBlockExpr : Parsetree.expression -> bool val isTemplateLiteral : Parsetree.expression -> bool val hasTemplateLiteralAttr : Parsetree.attributes -> bool +val isSpreadBeltListConcat : Parsetree.expression -> bool + val collectOrPatternChain : Parsetree.pattern -> Parsetree.pattern list val processBracesAttr : @@ -48416,6 +48419,25 @@ let isTemplateLiteral expr = | Pexp_constant _ when hasTemplateLiteralAttr expr.pexp_attributes -> true | _ -> false +let hasSpreadAttr attrs = + List.exists + (fun attr -> + match attr with + | {Location.txt = "res.spread"}, _ -> true + | _ -> false) + attrs + +let isSpreadBeltListConcat expr = + match expr.pexp_desc with + | Pexp_ident + { + txt = + Longident.Ldot + (Longident.Ldot (Longident.Lident "Belt", "List"), "concatMany"); + } -> + hasSpreadAttr expr.pexp_attributes + | _ -> false + (* Blue | Red | Green -> [Blue; Red; Green] *) let collectOrPatternChain pat = let rec loop pattern chain = @@ -50847,7 +50869,7 @@ type t = | Open | True | False - | Codepoint of {c: char; original: string} + | Codepoint of {c: int; original: string} | Int of {i: string; suffix: char option} | Float of {f: string; suffix: char option} | String of string @@ -51104,6 +51126,163 @@ let isKeywordTxt str = let catch = Lident "catch" +end +module Res_utf8 : sig +#1 "res_utf8.mli" +val max : int + +val decodeCodePoint : int -> string -> int -> int * int + +val encodeCodePoint : int -> string + +val isValidCodePoint : int -> bool + +end = struct +#1 "res_utf8.ml" +(* https://tools.ietf.org/html/rfc3629#section-10 *) +(* let bom = 0xFEFF *) + +let repl = 0xFFFD + +(* let min = 0x0000 *) +let max = 0x10FFFF + +let surrogateMin = 0xD800 +let surrogateMax = 0xDFFF + +(* + * Char. number range | UTF-8 octet sequence + * (hexadecimal) | (binary) + * --------------------+--------------------------------------------- + * 0000 0000-0000 007F | 0xxxxxxx + * 0000 0080-0000 07FF | 110xxxxx 10xxxxxx + * 0000 0800-0000 FFFF | 1110xxxx 10xxxxxx 10xxxxxx + * 0001 0000-0010 FFFF | 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx + *) +let h2 = 0b1100_0000 +let h3 = 0b1110_0000 +let h4 = 0b1111_0000 + +let cont_mask = 0b0011_1111 + +type category = {low: int; high: int; size: int} + +let locb = 0b1000_0000 +let hicb = 0b1011_1111 + +let categoryTable = [| + (* 0 *) {low = -1; high= -1; size= 1}; (* invalid *) + (* 1 *) {low = 1; high= -1; size= 1}; (* ascii *) + (* 2 *) {low = locb; high= hicb; size= 2}; + (* 3 *) {low = 0xA0; high= hicb; size= 3}; + (* 4 *) {low = locb; high= hicb; size= 3}; + (* 5 *) {low = locb; high= 0x9F; size= 3}; + (* 6 *) {low = 0x90; high= hicb; size= 4}; + (* 7 *) {low = locb; high= hicb; size= 4}; + (* 8 *) {low = locb; high= 0x8F; size= 4}; +|] [@@ocamlformat "disable"] + +let categories = [| + 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; + 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; + 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; + 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; + 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; + 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; + 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; + 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; + + 0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0; + 0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0; + 0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0; + 0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0; + (* surrogate range U+D800 - U+DFFFF = 55296 - 917503 *) + 0; 0; 2; 2;2; 2; 2; 2;2; 2; 2; 2;2; 2; 2; 2; + 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; + 3; 4; 4; 4; 4; 4; 4; 4; 4; 4; 4; 4; 4; 5; 4; 4; + 6; 7; 7 ;7; 8; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; +|] [@@ocamlformat "disable"] + +let decodeCodePoint i s len = + if len < 1 then (repl, 1) + else + let first = int_of_char (String.unsafe_get s i) in + if first < 128 then (first, 1) + else + let index = Array.unsafe_get categories first in + if index = 0 then (repl, 1) + else + let cat = Array.unsafe_get categoryTable index in + if len < i + cat.size then (repl, 1) + else if cat.size == 2 then + let c1 = int_of_char (String.unsafe_get s (i + 1)) in + if c1 < cat.low || cat.high < c1 then (repl, 1) + else + let i1 = c1 land 0b00111111 in + let i0 = (first land 0b00011111) lsl 6 in + let uc = i0 lor i1 in + (uc, 2) + else if cat.size == 3 then + let c1 = int_of_char (String.unsafe_get s (i + 1)) in + let c2 = int_of_char (String.unsafe_get s (i + 2)) in + if c1 < cat.low || cat.high < c1 || c2 < locb || hicb < c2 then + (repl, 1) + else + let i0 = (first land 0b00001111) lsl 12 in + let i1 = (c1 land 0b00111111) lsl 6 in + let i2 = c2 land 0b00111111 in + let uc = i0 lor i1 lor i2 in + (uc, 3) + else + let c1 = int_of_char (String.unsafe_get s (i + 1)) in + let c2 = int_of_char (String.unsafe_get s (i + 2)) in + let c3 = int_of_char (String.unsafe_get s (i + 3)) in + if + c1 < cat.low || cat.high < c1 || c2 < locb || hicb < c2 || c3 < locb + || hicb < c3 + then (repl, 1) + else + let i1 = (c1 land 0x3f) lsl 12 in + let i2 = (c2 land 0x3f) lsl 6 in + let i3 = c3 land 0x3f in + let i0 = (first land 0x07) lsl 18 in + let uc = i0 lor i3 lor i2 lor i1 in + (uc, 4) + +let encodeCodePoint c = + if c <= 127 then ( + let bytes = (Bytes.create [@doesNotRaise]) 1 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr c); + Bytes.unsafe_to_string bytes) + else if c <= 2047 then ( + let bytes = (Bytes.create [@doesNotRaise]) 2 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h2 lor (c lsr 6))); + Bytes.unsafe_set bytes 1 + (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); + Bytes.unsafe_to_string bytes) + else if c <= 65535 then ( + let bytes = (Bytes.create [@doesNotRaise]) 3 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h3 lor (c lsr 12))); + Bytes.unsafe_set bytes 1 + (Char.unsafe_chr (0b1000_0000 lor ((c lsr 6) land cont_mask))); + Bytes.unsafe_set bytes 2 + (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); + Bytes.unsafe_to_string bytes) + else + (* if c <= max then *) + let bytes = (Bytes.create [@doesNotRaise]) 4 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h4 lor (c lsr 18))); + Bytes.unsafe_set bytes 1 + (Char.unsafe_chr (0b1000_0000 lor ((c lsr 12) land cont_mask))); + Bytes.unsafe_set bytes 2 + (Char.unsafe_chr (0b1000_0000 lor ((c lsr 6) land cont_mask))); + Bytes.unsafe_set bytes 3 + (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); + Bytes.unsafe_to_string bytes + +let isValidCodePoint c = + (0 <= c && c < surrogateMin) || (surrogateMax < c && c <= max) + end module Res_printer : sig #1 "res_printer.mli" @@ -51690,20 +51869,7 @@ let printConstant ?(templateLiteral = false) c = ] | Pconst_float (s, _) -> Doc.text s | Pconst_char c -> - let str = - match c with - | '\'' -> "\\'" - | '\\' -> "\\\\" - | '\n' -> "\\n" - | '\t' -> "\\t" - | '\r' -> "\\r" - | '\b' -> "\\b" - | ' ' .. '~' as c -> - let s = (Bytes.create [@doesNotRaise]) 1 in - Bytes.unsafe_set s 0 c; - Bytes.unsafe_to_string s - | c -> string_of_int (Obj.magic c) - in + let str = Res_utf8.encodeCodePoint c in Doc.text ("'" ^ str ^ "'") let printOptionalLabel attrs = @@ -54118,6 +54284,9 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = ]) | extension -> printExtension ~customLayout ~atModuleLvl:false extension cmtTbl) + | Pexp_apply (e, [(Nolabel, {pexp_desc = Pexp_array subLists})]) + when ParsetreeViewer.isSpreadBeltListConcat e -> + printBeltListConcatApply ~customLayout subLists cmtTbl | Pexp_apply _ -> if ParsetreeViewer.isUnaryExpression e then printUnaryExpression ~customLayout e cmtTbl @@ -54906,6 +55075,63 @@ and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = ]) | _ -> Doc.nil +and printBeltListConcatApply ~customLayout subLists cmtTbl = + let makeSpreadDoc commaBeforeSpread = function + | Some expr -> + Doc.concat + [ + commaBeforeSpread; + Doc.dotdotdot; + (let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + ] + | None -> Doc.nil + in + let makeSubListDoc (expressions, spread) = + let commaBeforeSpread = + match expressions with + | [] -> Doc.nil + | _ -> Doc.concat [Doc.text ","; Doc.line] + in + let spreadDoc = makeSpreadDoc commaBeforeSpread spread in + Doc.concat + [ + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + expressions); + spreadDoc; + ] + in + Doc.group + (Doc.concat + [ + Doc.text "list{"; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map makeSubListDoc + (List.map ParsetreeViewer.collectListExpressions subLists)); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ]) + (* callExpr(arg1, arg2) *) and printPexpApply ~customLayout expr cmtTbl = match expr.pexp_desc with @@ -69341,7 +69567,7 @@ let yyact = [| let _1 = (Parsing.peek_val __caml_parser_env 0 : char) in Obj.repr( # 2155 "ml/parser.mly" - ( Pconst_char _1 ) + ( Pconst_char (Char.code _1) ) # 11020 "ml/parser.ml" : 'constant)) ; (fun __caml_parser_env -> @@ -74901,7 +75127,7 @@ type float_lit = { f : string } [@@unboxed] type number = | Float of float_lit - | Int of { i : int32; c : char option } + | Int of { i : int32; c : int option } | Uint of int32 (* becareful when constant folding +/-, @@ -76841,7 +77067,7 @@ val method_ : val econd : ?comment:string -> t -> t -> t -> t -val int : ?comment:string -> ?c:char -> int32 -> t +val int : ?comment:string -> ?c:int -> int32 -> t val uint32 : ?comment:string -> int32 -> t @@ -79650,7 +79876,7 @@ and expression_desc cxt ~(level : int) f x : cxt = match v with | Float { f } -> Js_number.caml_float_literal_to_js_string f (* attach string here for float constant folding?*) - | Int { i; c = Some c } -> Format.asprintf "/* %C */%ld" c i + | Int { i; c = Some c } -> Format.asprintf "/* %C */%ld" (Char.unsafe_chr c) i | Int { i; c = None } -> Int32.to_string i (* check , js convention with ocaml lexical convention *) @@ -83388,7 +83614,7 @@ type t = | Const_js_true | Const_js_false | Const_int of { i : int32; comment : pointer_info } - | Const_char of char + | Const_char of int | Const_string of { s : string; unicode : bool } | Const_float of string | Const_int64 of int64 @@ -83451,7 +83677,7 @@ type t = | Const_js_true | Const_js_false | Const_int of { i : int32; comment : pointer_info } - | Const_char of char + | Const_char of int | Const_string of { s : string; unicode : bool } | Const_float of string | Const_int64 of int64 @@ -85243,7 +85469,7 @@ let prim ~primitive:(prim : Lam_primitive.t) ~args loc : t = | ( (Pstringrefs | Pstringrefu), Const_string { s = a; unicode = false }, Const_int { i = b } ) -> ( - try Lift.char (String.get a (Int32.to_int b)) with _ -> default ()) + try Lift.char (Char.code (String.get a (Int32.to_int b))) with _ -> default ()) | _ -> default ()) | _ -> ( match prim with @@ -85314,7 +85540,7 @@ let rec complete_range (sw_consts : (int * _) list) ~(start : int) ~finish = let rec eval_const_as_bool (v : Lam_constant.t) : bool = match v with | Const_int { i = x } -> x <> 0l - | Const_char x -> Char.code x <> 0 + | Const_char x -> x <> 0 | Const_int64 x -> x <> 0L | Const_js_false | Const_js_null | Const_module_alias | Const_js_undefined -> false @@ -92080,7 +92306,7 @@ let rec struct_const ppf (cst : Lam_constant.t) = | Const_module_alias -> fprintf ppf "#alias" | Const_js_undefined -> fprintf ppf "#undefined" | Const_int { i } -> fprintf ppf "%ld" i - | Const_char c -> fprintf ppf "%C" c + | Const_char c -> fprintf ppf "%C" (Char.unsafe_chr c) | Const_string { s } -> fprintf ppf "%S" s | Const_float f -> fprintf ppf "%s" f | Const_int64 n -> fprintf ppf "%LiL" n @@ -94882,7 +95108,7 @@ val ref_byte : J.expression -> J.expression -> J.expression val set_byte : J.expression -> J.expression -> J.expression -> J.expression -val const_char : char -> J.expression +val const_char : int -> J.expression val bytes_to_string : J.expression -> J.expression @@ -94919,7 +95145,7 @@ module E = Js_exp_make currently, it follows the same patten of ocaml, [char] is [int] *) -let const_char (i : char) = E.int ~c:i (Int32.of_int @@ Char.code i) +let const_char (i : int) = E.int ~c:i (Int32.of_int @@ i) (* string [s[i]] expects to return a [ocaml_char] *) let ref_string e e1 = E.string_index e e1 @@ -258215,7 +258441,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = |Lconst((Const_int {i})) -> let i = Int32.to_int i in if i < String.length l_s && i >= 0 then - Lam.const ((Const_char l_s.[i])) + Lam.const ((Const_char (Char.code l_s.[i]))) else Lam.prim ~primitive ~args:[l';r'] loc | _ -> @@ -262087,7 +262313,7 @@ let rec longident f = function let longident_loc f x = pp f "%a" longident x.txt let constant f = function - | Pconst_char i -> pp f "%C" i + | Pconst_char i -> pp f "%C" (Char.chr i) | Pconst_string (i, None) -> pp f "%S" i | Pconst_string (i, Some delim) -> pp f "{%s|%s|%s}" delim i delim | Pconst_integer (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i @@ -273077,6 +273303,25 @@ let hasAttr (loc, _) = loc.txt = "react.component" let hasAttrOnBinding {pvb_attributes} = List.find_opt hasAttr pvb_attributes <> None +let coreTypeOfAttrs attributes = + List.find_map + (fun ({txt}, payload) -> + match (txt, payload) with + | "react.component", PTyp coreType -> Some coreType + | _ -> None) + attributes + +let typVarsOfCoreType {ptyp_desc} = + match ptyp_desc with + | Ptyp_constr (_, coreTypes) -> + List.filter + (fun {ptyp_desc} -> + match ptyp_desc with + | Ptyp_var _ -> true + | _ -> false) + coreTypes + | _ -> [] + let raiseError ~loc msg = Location.raise_errorf ~loc msg let raiseErrorMultipleReactComponent ~loc = @@ -274321,6 +274566,8 @@ let constantString ~loc str = (* {} empty record *) let emptyRecord ~loc = Exp.record ~loc [] None +let unitExpr ~loc = Exp.construct ~loc (Location.mkloc (Lident "()") loc) None + let safeTypeFromValue valueStr = let valueStr = getLabel valueStr in if valueStr = "" || (valueStr.[0] [@doesNotRaise]) <> '_' then valueStr @@ -274594,13 +274841,30 @@ let makeTypeDecls propsName loc namedTypeList = ~kind:(Ptype_record labelDeclList); ] +let makeTypeDeclsWithCoreType propsName loc coreType typVars = + [ + Type.mk ~loc {txt = propsName; loc} ~kind:Ptype_abstract + ~params:(typVars |> List.map (fun v -> (v, Invariant))) + ~manifest:coreType; + ] + (* type props<'x, 'y, ...> = { x: 'x, y?: 'y, ... } *) -let makePropsRecordType propsName loc namedTypeList = - Str.type_ Nonrecursive (makeTypeDecls propsName loc namedTypeList) +let makePropsRecordType ~coreTypeOfAttr ~typVarsOfCoreType propsName loc + namedTypeList = + Str.type_ Nonrecursive + (match coreTypeOfAttr with + | None -> makeTypeDecls propsName loc namedTypeList + | Some coreType -> + makeTypeDeclsWithCoreType propsName loc coreType typVarsOfCoreType) (* type props<'x, 'y, ...> = { x: 'x, y?: 'y, ... } *) -let makePropsRecordTypeSig propsName loc namedTypeList = - Sig.type_ Nonrecursive (makeTypeDecls propsName loc namedTypeList) +let makePropsRecordTypeSig ~coreTypeOfAttr ~typVarsOfCoreType propsName loc + namedTypeList = + Sig.type_ Nonrecursive + (match coreTypeOfAttr with + | None -> makeTypeDecls propsName loc namedTypeList + | Some coreType -> + makeTypeDeclsWithCoreType propsName loc coreType typVarsOfCoreType) let transformUppercaseCall3 ~config modulePath mapper jsxExprLoc callExprLoc attrs callArguments = @@ -274670,51 +274934,46 @@ let transformUppercaseCall3 ~config modulePath mapper jsxExprLoc callExprLoc match config.mode with (* The new jsx transform *) | "automatic" -> - let jsxExpr, key = + let jsxExpr, keyAndUnit = match (!childrenArg, keyProp) with - | None, (_, keyExpr) :: _ -> + | None, key :: _ -> ( Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "jsxKeyed")}, - [(nolabel, keyExpr)] ) + [key; (nolabel, unitExpr ~loc:Location.none)] ) | None, [] -> (Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "jsx")}, []) - | Some _, (_, keyExpr) :: _ -> + | Some _, key :: _ -> ( Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "jsxsKeyed")}, - [(nolabel, keyExpr)] ) + [key; (nolabel, unitExpr ~loc:Location.none)] ) | Some _, [] -> ( Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "jsxs")}, [] ) in - Exp.apply ~attrs jsxExpr ([(nolabel, makeID); (nolabel, props)] @ key) + Exp.apply ~attrs jsxExpr ([(nolabel, makeID); (nolabel, props)] @ keyAndUnit) | _ -> ( match (!childrenArg, keyProp) with - | None, (_, keyExpr) :: _ -> + | None, key :: _ -> Exp.apply ~attrs (Exp.ident { loc = Location.none; txt = Ldot (Lident "React", "createElementWithKey"); }) - [(nolabel, makeID); (nolabel, props); (nolabel, keyExpr)] + [key; (nolabel, makeID); (nolabel, props)] | None, [] -> Exp.apply ~attrs (Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "createElement")}) [(nolabel, makeID); (nolabel, props)] - | Some children, (_, keyExpr) :: _ -> + | Some children, key :: _ -> Exp.apply ~attrs (Exp.ident { loc = Location.none; txt = Ldot (Lident "React", "createElementVariadicWithKey"); }) - [ - (nolabel, makeID); - (nolabel, props); - (nolabel, children); - (nolabel, keyExpr); - ] + [key; (nolabel, makeID); (nolabel, props); (nolabel, children)] | Some children, [] -> Exp.apply ~attrs (Exp.ident @@ -274780,25 +275039,25 @@ let transformLowercaseCall3 ~config mapper jsxExprLoc callExprLoc attrs let keyProp = args |> List.filter (fun (arg_label, _) -> "key" = getLabel arg_label) in - let jsxExpr, key = + let jsxExpr, keyAndUnit = match (!childrenArg, keyProp) with - | None, (_, keyExpr) :: _ -> + | None, key :: _ -> ( Exp.ident {loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsxKeyed")}, - [(nolabel, keyExpr)] ) + [key; (nolabel, unitExpr ~loc:Location.none)] ) | None, [] -> ( Exp.ident {loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsx")}, [] ) - | Some _, (_, keyExpr) :: _ -> + | Some _, key :: _ -> ( Exp.ident {loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsxsKeyed")}, - [(nolabel, keyExpr)] ) + [key; (nolabel, unitExpr ~loc:Location.none)] ) | Some _, [] -> ( Exp.ident {loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsxs")}, [] ) in Exp.apply ~attrs jsxExpr - ([(nolabel, componentNameExpr); (nolabel, props)] @ key) + ([(nolabel, componentNameExpr); (nolabel, props)] @ keyAndUnit) | _ -> let children, nonChildrenProps = extractChildren ~loc:jsxExprLoc callArguments @@ -275021,6 +275280,12 @@ let transformStructureItem ~config mapper item = config.hasReactComponent <- true; check_string_int_attribute_iter.structure_item check_string_int_attribute_iter item; + let coreTypeOfAttr = React_jsx_common.coreTypeOfAttrs pval_attributes in + let typVarsOfCoreType = + coreTypeOfAttr + |> Option.map React_jsx_common.typVarsOfCoreType + |> Option.value ~default:[] + in let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = match ptyp_desc with | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) @@ -275037,11 +275302,14 @@ let transformStructureItem ~config mapper item = let retPropsType = Typ.constr ~loc:pstr_loc (Location.mkloc (Lident "props") pstr_loc) - (makePropsTypeParams namedTypeList) + (match coreTypeOfAttr with + | None -> makePropsTypeParams namedTypeList + | Some _ -> typVarsOfCoreType) in (* type props<'x, 'y> = { x: 'x, y?: 'y, ... } *) let propsRecordType = - makePropsRecordType "props" pstr_loc namedTypeList + makePropsRecordType ~coreTypeOfAttr ~typVarsOfCoreType "props" + pstr_loc namedTypeList in (* can't be an arrow because it will defensively uncurry *) let newExternalType = @@ -275075,6 +275343,14 @@ let transformStructureItem ~config mapper item = React_jsx_common.raiseErrorMultipleReactComponent ~loc:pstr_loc else ( config.hasReactComponent <- true; + let coreTypeOfAttr = + React_jsx_common.coreTypeOfAttrs binding.pvb_attributes + in + let typVarsOfCoreType = + coreTypeOfAttr + |> Option.map React_jsx_common.typVarsOfCoreType + |> Option.value ~default:[] + in let bindingLoc = binding.pvb_loc in let bindingPatLoc = binding.pvb_pat.ppat_loc in let binding = @@ -275265,7 +275541,8 @@ let transformStructureItem ~config mapper item = let vbMatchList = List.map vbMatch namedArgWithDefaultValueList in (* type props = { ... } *) let propsRecordType = - makePropsRecordType "props" pstr_loc namedTypeList + makePropsRecordType ~coreTypeOfAttr ~typVarsOfCoreType "props" + pstr_loc namedTypeList in let innerExpression = Exp.apply @@ -275277,6 +275554,13 @@ let transformStructureItem ~config mapper item = [(Nolabel, Exp.ident (Location.mknoloc @@ Lident "ref"))] | false -> []) in + let makePropsPattern = function + | [] -> Pat.var @@ Location.mknoloc "props" + | _ -> + Pat.constraint_ + (Pat.var @@ Location.mknoloc "props") + (Typ.constr (Location.mknoloc @@ Lident "props") [Typ.any ()]) + in let fullExpression = (* React component name should start with uppercase letter *) (* let make = { let \"App" = props => make(props); \"App" } *) @@ -275284,12 +275568,9 @@ let transformStructureItem ~config mapper item = let \"App" = (props, ref) => make({...props, ref: @optional (Js.Nullabel.toOption(ref))}) })*) Exp.fun_ nolabel None - (match namedTypeList with - | [] -> Pat.var @@ Location.mknoloc "props" - | _ -> - Pat.constraint_ - (Pat.var @@ Location.mknoloc "props") - (Typ.constr (Location.mknoloc @@ Lident "props") [Typ.any ()])) + (match coreTypeOfAttr with + | None -> makePropsPattern namedTypeList + | Some _ -> makePropsPattern typVarsOfCoreType) (if hasForwardRef then Exp.fun_ nolabel None (Pat.var @@ Location.mknoloc "ref") @@ -275393,8 +275674,12 @@ let transformStructureItem ~config mapper item = (Pat.constraint_ recordPattern (Typ.constr ~loc:emptyLoc {txt = Lident "props"; loc = emptyLoc} - (makePropsTypeParams ~stripExplicitOption:true - ~stripExplicitJsNullableOfRef:hasForwardRef namedTypeList))) + (match coreTypeOfAttr with + | None -> + makePropsTypeParams ~stripExplicitOption:true + ~stripExplicitJsNullableOfRef:hasForwardRef + namedTypeList + | Some _ -> typVarsOfCoreType))) expression in (* let make = ({id, name, ...}: props<'id, 'name, ...>) => { ... } *) @@ -275470,6 +275755,12 @@ let transformSignatureItem ~config _mapper item = check_string_int_attribute_iter.signature_item check_string_int_attribute_iter item; let hasForwardRef = ref false in + let coreTypeOfAttr = React_jsx_common.coreTypeOfAttrs pval_attributes in + let typVarsOfCoreType = + coreTypeOfAttr + |> Option.map React_jsx_common.typVarsOfCoreType + |> Option.value ~default:[] + in let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = match ptyp_desc with | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) @@ -275492,10 +275783,13 @@ let transformSignatureItem ~config _mapper item = let retPropsType = Typ.constr (Location.mkloc (Lident "props") psig_loc) - (makePropsTypeParams namedTypeList) + (match coreTypeOfAttr with + | None -> makePropsTypeParams namedTypeList + | Some _ -> typVarsOfCoreType) in let propsRecordType = - makePropsRecordTypeSig "props" psig_loc + makePropsRecordTypeSig ~coreTypeOfAttr ~typVarsOfCoreType "props" + psig_loc ((* If there is Nolabel arg, regard the type as ref in forwardRef *) (if !hasForwardRef then [(true, "ref", [], refType Location.none)] else []) @@ -275604,24 +275898,22 @@ let expr ~config mapper expression = Exp.ident ~loc {loc; txt = Ldot (Lident "React", "fragment")} in let childrenExpr = transformChildrenIfList ~mapper listItems in + let recordOfChildren children = + Exp.record [(Location.mknoloc (Lident "children"), children)] None + in let args = [ (nolabel, fragment); (match config.mode with - | "automatic" -> + | "automatic" -> ( ( nolabel, - Exp.record - [ - ( Location.mknoloc @@ Lident "children", - match childrenExpr with - | {pexp_desc = Pexp_array children} -> ( - match children with - | [] -> emptyRecord ~loc:Location.none - | [child] -> child - | _ -> childrenExpr) - | _ -> childrenExpr ); - ] - None ) + match childrenExpr with + | {pexp_desc = Pexp_array children} -> ( + match children with + | [] -> emptyRecord ~loc:Location.none + | [child] -> recordOfChildren child + | _ -> recordOfChildren childrenExpr) + | _ -> recordOfChildren childrenExpr )) | "classic" | _ -> (nolabel, childrenExpr)); ] in @@ -281554,165 +281846,6 @@ let convertDecimalToHex ~strDecimal = "x" ^ String.concat "" [String.make 1 c1; String.make 1 c2] with Invalid_argument _ | Failure _ -> strDecimal -end -module Res_utf8 : sig -#1 "res_utf8.mli" -val repl : int - -val max : int - -val decodeCodePoint : int -> string -> int -> int * int - -val encodeCodePoint : int -> string - -val isValidCodePoint : int -> bool - -end = struct -#1 "res_utf8.ml" -(* https://tools.ietf.org/html/rfc3629#section-10 *) -(* let bom = 0xFEFF *) - -let repl = 0xFFFD - -(* let min = 0x0000 *) -let max = 0x10FFFF - -let surrogateMin = 0xD800 -let surrogateMax = 0xDFFF - -(* - * Char. number range | UTF-8 octet sequence - * (hexadecimal) | (binary) - * --------------------+--------------------------------------------- - * 0000 0000-0000 007F | 0xxxxxxx - * 0000 0080-0000 07FF | 110xxxxx 10xxxxxx - * 0000 0800-0000 FFFF | 1110xxxx 10xxxxxx 10xxxxxx - * 0001 0000-0010 FFFF | 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx - *) -let h2 = 0b1100_0000 -let h3 = 0b1110_0000 -let h4 = 0b1111_0000 - -let cont_mask = 0b0011_1111 - -type category = {low: int; high: int; size: int} - -let locb = 0b1000_0000 -let hicb = 0b1011_1111 - -let categoryTable = [| - (* 0 *) {low = -1; high= -1; size= 1}; (* invalid *) - (* 1 *) {low = 1; high= -1; size= 1}; (* ascii *) - (* 2 *) {low = locb; high= hicb; size= 2}; - (* 3 *) {low = 0xA0; high= hicb; size= 3}; - (* 4 *) {low = locb; high= hicb; size= 3}; - (* 5 *) {low = locb; high= 0x9F; size= 3}; - (* 6 *) {low = 0x90; high= hicb; size= 4}; - (* 7 *) {low = locb; high= hicb; size= 4}; - (* 8 *) {low = locb; high= 0x8F; size= 4}; -|] [@@ocamlformat "disable"] - -let categories = [| - 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; - 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; - 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; - 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; - 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; - 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; - 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; - 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; - - 0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0; - 0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0; - 0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0; - 0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0; - (* surrogate range U+D800 - U+DFFFF = 55296 - 917503 *) - 0; 0; 2; 2;2; 2; 2; 2;2; 2; 2; 2;2; 2; 2; 2; - 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; - 3; 4; 4; 4; 4; 4; 4; 4; 4; 4; 4; 4; 4; 5; 4; 4; - 6; 7; 7 ;7; 8; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; -|] [@@ocamlformat "disable"] - -let decodeCodePoint i s len = - if len < 1 then (repl, 1) - else - let first = int_of_char (String.unsafe_get s i) in - if first < 128 then (first, 1) - else - let index = Array.unsafe_get categories first in - if index = 0 then (repl, 1) - else - let cat = Array.unsafe_get categoryTable index in - if len < i + cat.size then (repl, 1) - else if cat.size == 2 then - let c1 = int_of_char (String.unsafe_get s (i + 1)) in - if c1 < cat.low || cat.high < c1 then (repl, 1) - else - let i1 = c1 land 0b00111111 in - let i0 = (first land 0b00011111) lsl 6 in - let uc = i0 lor i1 in - (uc, 2) - else if cat.size == 3 then - let c1 = int_of_char (String.unsafe_get s (i + 1)) in - let c2 = int_of_char (String.unsafe_get s (i + 2)) in - if c1 < cat.low || cat.high < c1 || c2 < locb || hicb < c2 then - (repl, 1) - else - let i0 = (first land 0b00001111) lsl 12 in - let i1 = (c1 land 0b00111111) lsl 6 in - let i2 = c2 land 0b00111111 in - let uc = i0 lor i1 lor i2 in - (uc, 3) - else - let c1 = int_of_char (String.unsafe_get s (i + 1)) in - let c2 = int_of_char (String.unsafe_get s (i + 2)) in - let c3 = int_of_char (String.unsafe_get s (i + 3)) in - if - c1 < cat.low || cat.high < c1 || c2 < locb || hicb < c2 || c3 < locb - || hicb < c3 - then (repl, 1) - else - let i1 = (c1 land 0x3f) lsl 12 in - let i2 = (c2 land 0x3f) lsl 6 in - let i3 = c3 land 0x3f in - let i0 = (first land 0x07) lsl 18 in - let uc = i0 lor i3 lor i2 lor i1 in - (uc, 4) - -let encodeCodePoint c = - if c <= 127 then ( - let bytes = (Bytes.create [@doesNotRaise]) 1 in - Bytes.unsafe_set bytes 0 (Char.unsafe_chr c); - Bytes.unsafe_to_string bytes) - else if c <= 2047 then ( - let bytes = (Bytes.create [@doesNotRaise]) 2 in - Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h2 lor (c lsr 6))); - Bytes.unsafe_set bytes 1 - (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); - Bytes.unsafe_to_string bytes) - else if c <= 65535 then ( - let bytes = (Bytes.create [@doesNotRaise]) 3 in - Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h3 lor (c lsr 12))); - Bytes.unsafe_set bytes 1 - (Char.unsafe_chr (0b1000_0000 lor ((c lsr 6) land cont_mask))); - Bytes.unsafe_set bytes 2 - (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); - Bytes.unsafe_to_string bytes) - else - (* if c <= max then *) - let bytes = (Bytes.create [@doesNotRaise]) 4 in - Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h4 lor (c lsr 18))); - Bytes.unsafe_set bytes 1 - (Char.unsafe_chr (0b1000_0000 lor ((c lsr 12) land cont_mask))); - Bytes.unsafe_set bytes 2 - (Char.unsafe_chr (0b1000_0000 lor ((c lsr 6) land cont_mask))); - Bytes.unsafe_set bytes 3 - (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); - Bytes.unsafe_to_string bytes - -let isValidCodePoint c = - (0 <= c && c < surrogateMin) || (surrogateMax < c && c <= max) - end module Res_scanner : sig #1 "res_scanner.mli" @@ -282221,24 +282354,23 @@ let scanEscape scanner = next scanner done; let c = !x in - if Res_utf8.isValidCodePoint c then Char.unsafe_chr c - else Char.unsafe_chr Res_utf8.repl + c in let codepoint = match scanner.ch with | '0' .. '9' -> convertNumber scanner ~n:3 ~base:10 | 'b' -> next scanner; - '\008' + 8 | 'n' -> next scanner; - '\010' + 10 | 'r' -> next scanner; - '\013' + 13 | 't' -> next scanner; - '\009' + 009 | 'x' -> next scanner; convertNumber scanner ~n:2 ~base:16 @@ -282265,14 +282397,13 @@ let scanEscape scanner = | '}' -> next scanner | _ -> ()); let c = !x in - if Res_utf8.isValidCodePoint c then Char.unsafe_chr c - else Char.unsafe_chr Res_utf8.repl + c | _ -> (* unicode escape sequence: '\u007A', exactly 4 hex digits *) convertNumber scanner ~n:4 ~base:16) | ch -> next scanner; - ch + Char.code ch in let contents = (String.sub [@doesNotRaise]) scanner.src offset (scanner.offset - offset) @@ -282606,7 +282737,10 @@ let rec scan scanner = let offset = scanner.offset + 1 in next3 scanner; Token.Codepoint - {c = ch; original = (String.sub [@doesNotRaise]) scanner.src offset 1} + { + c = Char.code ch; + original = (String.sub [@doesNotRaise]) scanner.src offset 1; + } | ch, _ -> next scanner; let offset = scanner.offset in @@ -283074,15 +283208,6 @@ module ErrorMessages = struct ...b}` wouldn't make sense, as `b` would override every field of `a` \ anyway." - let listExprSpread = - "Lists can only have one `...` spread, and at the end.\n\ - Explanation: lists are singly-linked list, where a node contains a value \ - and points to the next node. `list{a, ...bc}` efficiently creates a new \ - item and links `bc` as its next nodes. `list{...bc, a}` would be \ - expensive, as it'd need to traverse `bc` and prepend each item to `a` one \ - by one. We therefore disallow such syntax sugar.\n\ - Solution: directly use `concat`." - let variantIdent = "A polymorphic variant (e.g. #id) must start with an alphabetical letter \ or be a number (e.g. #742)" @@ -283174,6 +283299,8 @@ let suppressFragileMatchWarningAttr = let makeBracesAttr loc = (Location.mkloc "ns.braces" loc, Parsetree.PStr []) let templateLiteralAttr = (Location.mknoloc "res.template", Parsetree.PStr []) +let spreadAttr = (Location.mknoloc "res.spread", Parsetree.PStr []) + type typDefOrExt = | TypeDef of { recFlag: Asttypes.rec_flag; @@ -286698,38 +286825,60 @@ and parseTupleExpr ~first ~startPos p = let loc = mkLoc startPos p.prevEndPos in Ast_helper.Exp.tuple ~loc exprs -and parseSpreadExprRegion p = +and parseSpreadExprRegionWithLoc p = + let startPos = p.Parser.prevEndPos in match p.Parser.token with | DotDotDot -> Parser.next p; let expr = parseConstrainedOrCoercedExpr p in - Some (true, expr) + Some (true, expr, startPos, p.prevEndPos) | token when Grammar.isExprStart token -> - Some (false, parseConstrainedOrCoercedExpr p) + Some (false, parseConstrainedOrCoercedExpr p, startPos, p.prevEndPos) | _ -> None and parseListExpr ~startPos p = - let check_all_non_spread_exp exprs = - exprs - |> List.map (fun (spread, expr) -> - if spread then - Parser.err p (Diagnostics.message ErrorMessages.listExprSpread); - expr) - |> List.rev + let split_by_spread exprs = + List.fold_left + (fun acc curr -> + match (curr, acc) with + | (true, expr, startPos, endPos), _ -> + (* find a spread expression, prepend a new sublist *) + ([], Some expr, startPos, endPos) :: acc + | ( (false, expr, startPos, _endPos), + (no_spreads, spread, _accStartPos, accEndPos) :: acc ) -> + (* find a non-spread expression, and the accumulated is not empty, + * prepend to the first sublist, and update the loc of the first sublist *) + (expr :: no_spreads, spread, startPos, accEndPos) :: acc + | (false, expr, startPos, endPos), [] -> + (* find a non-spread expression, and the accumulated is empty *) + [([expr], None, startPos, endPos)]) + [] exprs + in + let make_sub_expr = function + | exprs, Some spread, startPos, endPos -> + makeListExpression (mkLoc startPos endPos) exprs (Some spread) + | exprs, None, startPos, endPos -> + makeListExpression (mkLoc startPos endPos) exprs None in let listExprsRev = parseCommaDelimitedReversedList p ~grammar:Grammar.ListExpr ~closing:Rbrace - ~f:parseSpreadExprRegion + ~f:parseSpreadExprRegionWithLoc in Parser.expect Rbrace p; let loc = mkLoc startPos p.prevEndPos in - match listExprsRev with - | (true (* spread expression *), expr) :: exprs -> - let exprs = check_all_non_spread_exp exprs in - makeListExpression loc exprs (Some expr) + match split_by_spread listExprsRev with + | [] -> makeListExpression loc [] None + | [(exprs, Some spread, _, _)] -> makeListExpression loc exprs (Some spread) + | [(exprs, None, _, _)] -> makeListExpression loc exprs None | exprs -> - let exprs = check_all_non_spread_exp exprs in - makeListExpression loc exprs None + let listExprs = List.map make_sub_expr exprs in + Ast_helper.Exp.apply ~loc + (Ast_helper.Exp.ident ~loc ~attrs:[spreadAttr] + (Location.mkloc + (Longident.Ldot + (Longident.Ldot (Longident.Lident "Belt", "List"), "concatMany")) + loc)) + [(Asttypes.Nolabel, Ast_helper.Exp.array ~loc listExprs)] (* Overparse ... and give a nice error message *) and parseNonSpreadExp ~msg p = diff --git a/lib/4.06.1/whole_compiler.ml b/lib/4.06.1/whole_compiler.ml index 76af460bdf..d8af3d5efe 100644 --- a/lib/4.06.1/whole_compiler.ml +++ b/lib/4.06.1/whole_compiler.ml @@ -2847,7 +2847,7 @@ module Asttypes type constant = Const_int of int - | Const_char of char + | Const_char of int | Const_string of string * string option | Const_float of string | Const_int32 of int32 @@ -2901,6 +2901,7 @@ let same_arg_label (x : arg_label) y = | Optional s0 -> s = s0 | _ -> false end + end module File_key = struct @@ -150038,7 +150039,7 @@ type constant = Suffixes [g-z][G-Z] are accepted by the parser. Suffixes except 'l', 'L' and 'n' are rejected by the typechecker *) - | Pconst_char of char + | Pconst_char of int (* 'c' *) | Pconst_string of string * string option (* "constant" @@ -155708,7 +155709,7 @@ module Const = struct let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i) let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i) let float ?suffix f = Pconst_float (f, suffix) - let char c = Pconst_char c + let char c = Pconst_char (Char.code c) let string ?quotation_delimiter s = Pconst_string (s, quotation_delimiter) end @@ -178625,7 +178626,7 @@ type float_lit = { f : string } [@@unboxed] type number = | Float of float_lit - | Int of { i : int32; c : char option } + | Int of { i : int32; c : int option } | Uint of int32 (* becareful when constant folding +/-, @@ -188634,7 +188635,7 @@ let is_cons = function let pretty_const c = match c with | Const_int i -> Printf.sprintf "%d" i -| Const_char c -> Printf.sprintf "%C" c +| Const_char i -> Printf.sprintf "%s" (string_of_int i) | Const_string (s, _) -> Printf.sprintf "%S" s | Const_float f -> Printf.sprintf "%s" f | Const_int32 i -> Printf.sprintf "%ldl" i @@ -189343,9 +189344,9 @@ let build_other ext env : Typedtree.pattern = match env with | ({pat_desc=(Tpat_constant (Const_char _ ))} as p,_) :: _ -> build_other_constant (function - | Tpat_constant (Const_char i) -> Char.code i + | Tpat_constant (Const_char i) -> i | _ -> assert false) - (function i -> Tpat_constant(Const_char (Obj.magic (i:int) : char))) + (function i -> Tpat_constant(Const_char (i))) 0 succ p env | ({pat_desc=(Tpat_constant (Const_int32 _))} as p,_) :: _ -> build_other_constant @@ -190925,7 +190926,7 @@ open Lambda let rec struct_const ppf = function | Const_base(Const_int n) -> fprintf ppf "%i" n - | Const_base(Const_char c) -> fprintf ppf "%C" c + | Const_base(Const_char i) -> fprintf ppf "%s" (string_of_int i) | Const_base(Const_string (s, _)) -> fprintf ppf "%S" s | Const_immstring s -> fprintf ppf "#%S" s | Const_base(Const_float f) -> fprintf ppf "%s" f @@ -202551,7 +202552,7 @@ let yyact = [| let _1 = (Parsing.peek_val __caml_parser_env 0 : char) in Obj.repr( # 2155 "ml/parser.mly" - ( Pconst_char _1 ) + ( Pconst_char (Char.code _1) ) # 11020 "ml/parser.ml" : 'constant)) ; (fun __caml_parser_env -> @@ -216353,7 +216354,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env else or_ ~loc:gloc (constant ~loc:gloc (Pconst_char c1)) - (loop (Char.chr(Char.code c1 + 1)) c2) + (loop (c1 + 1) c2) in let p = if c1 <= c2 then loop c1 c2 else loop c2 c1 in let p = {p with ppat_loc=loc} in @@ -221446,7 +221447,7 @@ let combine_constant names loc arg cst partial ctx def call_switcher loc fail arg min_int max_int int_lambda_list names | Const_char _ -> let int_lambda_list = - List.map (function Const_char c, l -> (Char.code c, l) + List.map (function Const_char c, l -> (c, l) | _ -> assert false) const_lambda_list in call_switcher loc fail arg 0 max_int int_lambda_list names @@ -223960,6 +223961,8 @@ val isBlockExpr : Parsetree.expression -> bool val isTemplateLiteral : Parsetree.expression -> bool val hasTemplateLiteralAttr : Parsetree.attributes -> bool +val isSpreadBeltListConcat : Parsetree.expression -> bool + val collectOrPatternChain : Parsetree.pattern -> Parsetree.pattern list val processBracesAttr : @@ -224603,6 +224606,25 @@ let isTemplateLiteral expr = | Pexp_constant _ when hasTemplateLiteralAttr expr.pexp_attributes -> true | _ -> false +let hasSpreadAttr attrs = + List.exists + (fun attr -> + match attr with + | {Location.txt = "res.spread"}, _ -> true + | _ -> false) + attrs + +let isSpreadBeltListConcat expr = + match expr.pexp_desc with + | Pexp_ident + { + txt = + Longident.Ldot + (Longident.Ldot (Longident.Lident "Belt", "List"), "concatMany"); + } -> + hasSpreadAttr expr.pexp_attributes + | _ -> false + (* Blue | Red | Green -> [Blue; Red; Green] *) let collectOrPatternChain pat = let rec loop pattern chain = @@ -227034,7 +227056,7 @@ type t = | Open | True | False - | Codepoint of {c: char; original: string} + | Codepoint of {c: int; original: string} | Int of {i: string; suffix: char option} | Float of {f: string; suffix: char option} | String of string @@ -227291,6 +227313,163 @@ let isKeywordTxt str = let catch = Lident "catch" +end +module Res_utf8 : sig +#1 "res_utf8.mli" +val max : int + +val decodeCodePoint : int -> string -> int -> int * int + +val encodeCodePoint : int -> string + +val isValidCodePoint : int -> bool + +end = struct +#1 "res_utf8.ml" +(* https://tools.ietf.org/html/rfc3629#section-10 *) +(* let bom = 0xFEFF *) + +let repl = 0xFFFD + +(* let min = 0x0000 *) +let max = 0x10FFFF + +let surrogateMin = 0xD800 +let surrogateMax = 0xDFFF + +(* + * Char. number range | UTF-8 octet sequence + * (hexadecimal) | (binary) + * --------------------+--------------------------------------------- + * 0000 0000-0000 007F | 0xxxxxxx + * 0000 0080-0000 07FF | 110xxxxx 10xxxxxx + * 0000 0800-0000 FFFF | 1110xxxx 10xxxxxx 10xxxxxx + * 0001 0000-0010 FFFF | 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx + *) +let h2 = 0b1100_0000 +let h3 = 0b1110_0000 +let h4 = 0b1111_0000 + +let cont_mask = 0b0011_1111 + +type category = {low: int; high: int; size: int} + +let locb = 0b1000_0000 +let hicb = 0b1011_1111 + +let categoryTable = [| + (* 0 *) {low = -1; high= -1; size= 1}; (* invalid *) + (* 1 *) {low = 1; high= -1; size= 1}; (* ascii *) + (* 2 *) {low = locb; high= hicb; size= 2}; + (* 3 *) {low = 0xA0; high= hicb; size= 3}; + (* 4 *) {low = locb; high= hicb; size= 3}; + (* 5 *) {low = locb; high= 0x9F; size= 3}; + (* 6 *) {low = 0x90; high= hicb; size= 4}; + (* 7 *) {low = locb; high= hicb; size= 4}; + (* 8 *) {low = locb; high= 0x8F; size= 4}; +|] [@@ocamlformat "disable"] + +let categories = [| + 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; + 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; + 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; + 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; + 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; + 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; + 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; + 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; + + 0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0; + 0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0; + 0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0; + 0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0; + (* surrogate range U+D800 - U+DFFFF = 55296 - 917503 *) + 0; 0; 2; 2;2; 2; 2; 2;2; 2; 2; 2;2; 2; 2; 2; + 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; + 3; 4; 4; 4; 4; 4; 4; 4; 4; 4; 4; 4; 4; 5; 4; 4; + 6; 7; 7 ;7; 8; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; +|] [@@ocamlformat "disable"] + +let decodeCodePoint i s len = + if len < 1 then (repl, 1) + else + let first = int_of_char (String.unsafe_get s i) in + if first < 128 then (first, 1) + else + let index = Array.unsafe_get categories first in + if index = 0 then (repl, 1) + else + let cat = Array.unsafe_get categoryTable index in + if len < i + cat.size then (repl, 1) + else if cat.size == 2 then + let c1 = int_of_char (String.unsafe_get s (i + 1)) in + if c1 < cat.low || cat.high < c1 then (repl, 1) + else + let i1 = c1 land 0b00111111 in + let i0 = (first land 0b00011111) lsl 6 in + let uc = i0 lor i1 in + (uc, 2) + else if cat.size == 3 then + let c1 = int_of_char (String.unsafe_get s (i + 1)) in + let c2 = int_of_char (String.unsafe_get s (i + 2)) in + if c1 < cat.low || cat.high < c1 || c2 < locb || hicb < c2 then + (repl, 1) + else + let i0 = (first land 0b00001111) lsl 12 in + let i1 = (c1 land 0b00111111) lsl 6 in + let i2 = c2 land 0b00111111 in + let uc = i0 lor i1 lor i2 in + (uc, 3) + else + let c1 = int_of_char (String.unsafe_get s (i + 1)) in + let c2 = int_of_char (String.unsafe_get s (i + 2)) in + let c3 = int_of_char (String.unsafe_get s (i + 3)) in + if + c1 < cat.low || cat.high < c1 || c2 < locb || hicb < c2 || c3 < locb + || hicb < c3 + then (repl, 1) + else + let i1 = (c1 land 0x3f) lsl 12 in + let i2 = (c2 land 0x3f) lsl 6 in + let i3 = c3 land 0x3f in + let i0 = (first land 0x07) lsl 18 in + let uc = i0 lor i3 lor i2 lor i1 in + (uc, 4) + +let encodeCodePoint c = + if c <= 127 then ( + let bytes = (Bytes.create [@doesNotRaise]) 1 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr c); + Bytes.unsafe_to_string bytes) + else if c <= 2047 then ( + let bytes = (Bytes.create [@doesNotRaise]) 2 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h2 lor (c lsr 6))); + Bytes.unsafe_set bytes 1 + (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); + Bytes.unsafe_to_string bytes) + else if c <= 65535 then ( + let bytes = (Bytes.create [@doesNotRaise]) 3 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h3 lor (c lsr 12))); + Bytes.unsafe_set bytes 1 + (Char.unsafe_chr (0b1000_0000 lor ((c lsr 6) land cont_mask))); + Bytes.unsafe_set bytes 2 + (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); + Bytes.unsafe_to_string bytes) + else + (* if c <= max then *) + let bytes = (Bytes.create [@doesNotRaise]) 4 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h4 lor (c lsr 18))); + Bytes.unsafe_set bytes 1 + (Char.unsafe_chr (0b1000_0000 lor ((c lsr 12) land cont_mask))); + Bytes.unsafe_set bytes 2 + (Char.unsafe_chr (0b1000_0000 lor ((c lsr 6) land cont_mask))); + Bytes.unsafe_set bytes 3 + (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); + Bytes.unsafe_to_string bytes + +let isValidCodePoint c = + (0 <= c && c < surrogateMin) || (surrogateMax < c && c <= max) + end module Res_printer : sig #1 "res_printer.mli" @@ -227877,20 +228056,7 @@ let printConstant ?(templateLiteral = false) c = ] | Pconst_float (s, _) -> Doc.text s | Pconst_char c -> - let str = - match c with - | '\'' -> "\\'" - | '\\' -> "\\\\" - | '\n' -> "\\n" - | '\t' -> "\\t" - | '\r' -> "\\r" - | '\b' -> "\\b" - | ' ' .. '~' as c -> - let s = (Bytes.create [@doesNotRaise]) 1 in - Bytes.unsafe_set s 0 c; - Bytes.unsafe_to_string s - | c -> string_of_int (Obj.magic c) - in + let str = Res_utf8.encodeCodePoint c in Doc.text ("'" ^ str ^ "'") let printOptionalLabel attrs = @@ -230305,6 +230471,9 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = ]) | extension -> printExtension ~customLayout ~atModuleLvl:false extension cmtTbl) + | Pexp_apply (e, [(Nolabel, {pexp_desc = Pexp_array subLists})]) + when ParsetreeViewer.isSpreadBeltListConcat e -> + printBeltListConcatApply ~customLayout subLists cmtTbl | Pexp_apply _ -> if ParsetreeViewer.isUnaryExpression e then printUnaryExpression ~customLayout e cmtTbl @@ -231093,6 +231262,63 @@ and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = ]) | _ -> Doc.nil +and printBeltListConcatApply ~customLayout subLists cmtTbl = + let makeSpreadDoc commaBeforeSpread = function + | Some expr -> + Doc.concat + [ + commaBeforeSpread; + Doc.dotdotdot; + (let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + ] + | None -> Doc.nil + in + let makeSubListDoc (expressions, spread) = + let commaBeforeSpread = + match expressions with + | [] -> Doc.nil + | _ -> Doc.concat [Doc.text ","; Doc.line] + in + let spreadDoc = makeSpreadDoc commaBeforeSpread spread in + Doc.concat + [ + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + expressions); + spreadDoc; + ] + in + Doc.group + (Doc.concat + [ + Doc.text "list{"; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map makeSubListDoc + (List.map ParsetreeViewer.collectListExpressions subLists)); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ]) + (* callExpr(arg1, arg2) *) and printPexpApply ~customLayout expr cmtTbl = match expr.pexp_desc with @@ -245514,7 +245740,7 @@ type t = | Const_js_true | Const_js_false | Const_int of { i : int32; comment : pointer_info } - | Const_char of char + | Const_char of int | Const_string of { s : string; unicode : bool } | Const_float of string | Const_int64 of int64 @@ -245577,7 +245803,7 @@ type t = | Const_js_true | Const_js_false | Const_int of { i : int32; comment : pointer_info } - | Const_char of char + | Const_char of int | Const_string of { s : string; unicode : bool } | Const_float of string | Const_int64 of int64 @@ -247622,7 +247848,7 @@ let prim ~primitive:(prim : Lam_primitive.t) ~args loc : t = | ( (Pstringrefs | Pstringrefu), Const_string { s = a; unicode = false }, Const_int { i = b } ) -> ( - try Lift.char (String.get a (Int32.to_int b)) with _ -> default ()) + try Lift.char (Char.code (String.get a (Int32.to_int b))) with _ -> default ()) | _ -> default ()) | _ -> ( match prim with @@ -247693,7 +247919,7 @@ let rec complete_range (sw_consts : (int * _) list) ~(start : int) ~finish = let rec eval_const_as_bool (v : Lam_constant.t) : bool = match v with | Const_int { i = x } -> x <> 0l - | Const_char x -> Char.code x <> 0 + | Const_char x -> x <> 0 | Const_int64 x -> x <> 0L | Const_js_false | Const_js_null | Const_module_alias | Const_js_undefined -> false @@ -252810,7 +253036,7 @@ val method_ : val econd : ?comment:string -> t -> t -> t -> t -val int : ?comment:string -> ?c:char -> int32 -> t +val int : ?comment:string -> ?c:int -> int32 -> t val uint32 : ?comment:string -> int32 -> t @@ -255619,7 +255845,7 @@ and expression_desc cxt ~(level : int) f x : cxt = match v with | Float { f } -> Js_number.caml_float_literal_to_js_string f (* attach string here for float constant folding?*) - | Int { i; c = Some c } -> Format.asprintf "/* %C */%ld" c i + | Int { i; c = Some c } -> Format.asprintf "/* %C */%ld" (Char.unsafe_chr c) i | Int { i; c = None } -> Int32.to_string i (* check , js convention with ocaml lexical convention *) @@ -261441,7 +261667,7 @@ let rec struct_const ppf (cst : Lam_constant.t) = | Const_module_alias -> fprintf ppf "#alias" | Const_js_undefined -> fprintf ppf "#undefined" | Const_int { i } -> fprintf ppf "%ld" i - | Const_char c -> fprintf ppf "%C" c + | Const_char c -> fprintf ppf "%C" (Char.unsafe_chr c) | Const_string { s } -> fprintf ppf "%S" s | Const_float f -> fprintf ppf "%s" f | Const_int64 n -> fprintf ppf "%LiL" n @@ -264243,7 +264469,7 @@ val ref_byte : J.expression -> J.expression -> J.expression val set_byte : J.expression -> J.expression -> J.expression -> J.expression -val const_char : char -> J.expression +val const_char : int -> J.expression val bytes_to_string : J.expression -> J.expression @@ -264280,7 +264506,7 @@ module E = Js_exp_make currently, it follows the same patten of ocaml, [char] is [int] *) -let const_char (i : char) = E.int ~c:i (Int32.of_int @@ Char.code i) +let const_char (i : int) = E.int ~c:i (Int32.of_int @@ i) (* string [s[i]] expects to return a [ocaml_char] *) let ref_string e e1 = E.string_index e e1 @@ -273485,7 +273711,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = |Lconst((Const_int {i})) -> let i = Int32.to_int i in if i < String.length l_s && i >= 0 then - Lam.const ((Const_char l_s.[i])) + Lam.const ((Const_char (Char.code l_s.[i]))) else Lam.prim ~primitive ~args:[l';r'] loc | _ -> @@ -274687,7 +274913,7 @@ let rec longident f = function let longident_loc f x = pp f "%a" longident x.txt let constant f = function - | Pconst_char i -> pp f "%C" i + | Pconst_char i -> pp f "%C" (Char.chr i) | Pconst_string (i, None) -> pp f "%S" i | Pconst_string (i, Some delim) -> pp f "{%s|%s|%s}" delim i delim | Pconst_integer (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i @@ -283461,6 +283687,25 @@ let hasAttr (loc, _) = loc.txt = "react.component" let hasAttrOnBinding {pvb_attributes} = List.find_opt hasAttr pvb_attributes <> None +let coreTypeOfAttrs attributes = + List.find_map + (fun ({txt}, payload) -> + match (txt, payload) with + | "react.component", PTyp coreType -> Some coreType + | _ -> None) + attributes + +let typVarsOfCoreType {ptyp_desc} = + match ptyp_desc with + | Ptyp_constr (_, coreTypes) -> + List.filter + (fun {ptyp_desc} -> + match ptyp_desc with + | Ptyp_var _ -> true + | _ -> false) + coreTypes + | _ -> [] + let raiseError ~loc msg = Location.raise_errorf ~loc msg let raiseErrorMultipleReactComponent ~loc = @@ -284705,6 +284950,8 @@ let constantString ~loc str = (* {} empty record *) let emptyRecord ~loc = Exp.record ~loc [] None +let unitExpr ~loc = Exp.construct ~loc (Location.mkloc (Lident "()") loc) None + let safeTypeFromValue valueStr = let valueStr = getLabel valueStr in if valueStr = "" || (valueStr.[0] [@doesNotRaise]) <> '_' then valueStr @@ -284978,13 +285225,30 @@ let makeTypeDecls propsName loc namedTypeList = ~kind:(Ptype_record labelDeclList); ] +let makeTypeDeclsWithCoreType propsName loc coreType typVars = + [ + Type.mk ~loc {txt = propsName; loc} ~kind:Ptype_abstract + ~params:(typVars |> List.map (fun v -> (v, Invariant))) + ~manifest:coreType; + ] + (* type props<'x, 'y, ...> = { x: 'x, y?: 'y, ... } *) -let makePropsRecordType propsName loc namedTypeList = - Str.type_ Nonrecursive (makeTypeDecls propsName loc namedTypeList) +let makePropsRecordType ~coreTypeOfAttr ~typVarsOfCoreType propsName loc + namedTypeList = + Str.type_ Nonrecursive + (match coreTypeOfAttr with + | None -> makeTypeDecls propsName loc namedTypeList + | Some coreType -> + makeTypeDeclsWithCoreType propsName loc coreType typVarsOfCoreType) (* type props<'x, 'y, ...> = { x: 'x, y?: 'y, ... } *) -let makePropsRecordTypeSig propsName loc namedTypeList = - Sig.type_ Nonrecursive (makeTypeDecls propsName loc namedTypeList) +let makePropsRecordTypeSig ~coreTypeOfAttr ~typVarsOfCoreType propsName loc + namedTypeList = + Sig.type_ Nonrecursive + (match coreTypeOfAttr with + | None -> makeTypeDecls propsName loc namedTypeList + | Some coreType -> + makeTypeDeclsWithCoreType propsName loc coreType typVarsOfCoreType) let transformUppercaseCall3 ~config modulePath mapper jsxExprLoc callExprLoc attrs callArguments = @@ -285054,51 +285318,46 @@ let transformUppercaseCall3 ~config modulePath mapper jsxExprLoc callExprLoc match config.mode with (* The new jsx transform *) | "automatic" -> - let jsxExpr, key = + let jsxExpr, keyAndUnit = match (!childrenArg, keyProp) with - | None, (_, keyExpr) :: _ -> + | None, key :: _ -> ( Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "jsxKeyed")}, - [(nolabel, keyExpr)] ) + [key; (nolabel, unitExpr ~loc:Location.none)] ) | None, [] -> (Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "jsx")}, []) - | Some _, (_, keyExpr) :: _ -> + | Some _, key :: _ -> ( Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "jsxsKeyed")}, - [(nolabel, keyExpr)] ) + [key; (nolabel, unitExpr ~loc:Location.none)] ) | Some _, [] -> ( Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "jsxs")}, [] ) in - Exp.apply ~attrs jsxExpr ([(nolabel, makeID); (nolabel, props)] @ key) + Exp.apply ~attrs jsxExpr ([(nolabel, makeID); (nolabel, props)] @ keyAndUnit) | _ -> ( match (!childrenArg, keyProp) with - | None, (_, keyExpr) :: _ -> + | None, key :: _ -> Exp.apply ~attrs (Exp.ident { loc = Location.none; txt = Ldot (Lident "React", "createElementWithKey"); }) - [(nolabel, makeID); (nolabel, props); (nolabel, keyExpr)] + [key; (nolabel, makeID); (nolabel, props)] | None, [] -> Exp.apply ~attrs (Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "createElement")}) [(nolabel, makeID); (nolabel, props)] - | Some children, (_, keyExpr) :: _ -> + | Some children, key :: _ -> Exp.apply ~attrs (Exp.ident { loc = Location.none; txt = Ldot (Lident "React", "createElementVariadicWithKey"); }) - [ - (nolabel, makeID); - (nolabel, props); - (nolabel, children); - (nolabel, keyExpr); - ] + [key; (nolabel, makeID); (nolabel, props); (nolabel, children)] | Some children, [] -> Exp.apply ~attrs (Exp.ident @@ -285164,25 +285423,25 @@ let transformLowercaseCall3 ~config mapper jsxExprLoc callExprLoc attrs let keyProp = args |> List.filter (fun (arg_label, _) -> "key" = getLabel arg_label) in - let jsxExpr, key = + let jsxExpr, keyAndUnit = match (!childrenArg, keyProp) with - | None, (_, keyExpr) :: _ -> + | None, key :: _ -> ( Exp.ident {loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsxKeyed")}, - [(nolabel, keyExpr)] ) + [key; (nolabel, unitExpr ~loc:Location.none)] ) | None, [] -> ( Exp.ident {loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsx")}, [] ) - | Some _, (_, keyExpr) :: _ -> + | Some _, key :: _ -> ( Exp.ident {loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsxsKeyed")}, - [(nolabel, keyExpr)] ) + [key; (nolabel, unitExpr ~loc:Location.none)] ) | Some _, [] -> ( Exp.ident {loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsxs")}, [] ) in Exp.apply ~attrs jsxExpr - ([(nolabel, componentNameExpr); (nolabel, props)] @ key) + ([(nolabel, componentNameExpr); (nolabel, props)] @ keyAndUnit) | _ -> let children, nonChildrenProps = extractChildren ~loc:jsxExprLoc callArguments @@ -285405,6 +285664,12 @@ let transformStructureItem ~config mapper item = config.hasReactComponent <- true; check_string_int_attribute_iter.structure_item check_string_int_attribute_iter item; + let coreTypeOfAttr = React_jsx_common.coreTypeOfAttrs pval_attributes in + let typVarsOfCoreType = + coreTypeOfAttr + |> Option.map React_jsx_common.typVarsOfCoreType + |> Option.value ~default:[] + in let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = match ptyp_desc with | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) @@ -285421,11 +285686,14 @@ let transformStructureItem ~config mapper item = let retPropsType = Typ.constr ~loc:pstr_loc (Location.mkloc (Lident "props") pstr_loc) - (makePropsTypeParams namedTypeList) + (match coreTypeOfAttr with + | None -> makePropsTypeParams namedTypeList + | Some _ -> typVarsOfCoreType) in (* type props<'x, 'y> = { x: 'x, y?: 'y, ... } *) let propsRecordType = - makePropsRecordType "props" pstr_loc namedTypeList + makePropsRecordType ~coreTypeOfAttr ~typVarsOfCoreType "props" + pstr_loc namedTypeList in (* can't be an arrow because it will defensively uncurry *) let newExternalType = @@ -285459,6 +285727,14 @@ let transformStructureItem ~config mapper item = React_jsx_common.raiseErrorMultipleReactComponent ~loc:pstr_loc else ( config.hasReactComponent <- true; + let coreTypeOfAttr = + React_jsx_common.coreTypeOfAttrs binding.pvb_attributes + in + let typVarsOfCoreType = + coreTypeOfAttr + |> Option.map React_jsx_common.typVarsOfCoreType + |> Option.value ~default:[] + in let bindingLoc = binding.pvb_loc in let bindingPatLoc = binding.pvb_pat.ppat_loc in let binding = @@ -285649,7 +285925,8 @@ let transformStructureItem ~config mapper item = let vbMatchList = List.map vbMatch namedArgWithDefaultValueList in (* type props = { ... } *) let propsRecordType = - makePropsRecordType "props" pstr_loc namedTypeList + makePropsRecordType ~coreTypeOfAttr ~typVarsOfCoreType "props" + pstr_loc namedTypeList in let innerExpression = Exp.apply @@ -285661,6 +285938,13 @@ let transformStructureItem ~config mapper item = [(Nolabel, Exp.ident (Location.mknoloc @@ Lident "ref"))] | false -> []) in + let makePropsPattern = function + | [] -> Pat.var @@ Location.mknoloc "props" + | _ -> + Pat.constraint_ + (Pat.var @@ Location.mknoloc "props") + (Typ.constr (Location.mknoloc @@ Lident "props") [Typ.any ()]) + in let fullExpression = (* React component name should start with uppercase letter *) (* let make = { let \"App" = props => make(props); \"App" } *) @@ -285668,12 +285952,9 @@ let transformStructureItem ~config mapper item = let \"App" = (props, ref) => make({...props, ref: @optional (Js.Nullabel.toOption(ref))}) })*) Exp.fun_ nolabel None - (match namedTypeList with - | [] -> Pat.var @@ Location.mknoloc "props" - | _ -> - Pat.constraint_ - (Pat.var @@ Location.mknoloc "props") - (Typ.constr (Location.mknoloc @@ Lident "props") [Typ.any ()])) + (match coreTypeOfAttr with + | None -> makePropsPattern namedTypeList + | Some _ -> makePropsPattern typVarsOfCoreType) (if hasForwardRef then Exp.fun_ nolabel None (Pat.var @@ Location.mknoloc "ref") @@ -285777,8 +286058,12 @@ let transformStructureItem ~config mapper item = (Pat.constraint_ recordPattern (Typ.constr ~loc:emptyLoc {txt = Lident "props"; loc = emptyLoc} - (makePropsTypeParams ~stripExplicitOption:true - ~stripExplicitJsNullableOfRef:hasForwardRef namedTypeList))) + (match coreTypeOfAttr with + | None -> + makePropsTypeParams ~stripExplicitOption:true + ~stripExplicitJsNullableOfRef:hasForwardRef + namedTypeList + | Some _ -> typVarsOfCoreType))) expression in (* let make = ({id, name, ...}: props<'id, 'name, ...>) => { ... } *) @@ -285854,6 +286139,12 @@ let transformSignatureItem ~config _mapper item = check_string_int_attribute_iter.signature_item check_string_int_attribute_iter item; let hasForwardRef = ref false in + let coreTypeOfAttr = React_jsx_common.coreTypeOfAttrs pval_attributes in + let typVarsOfCoreType = + coreTypeOfAttr + |> Option.map React_jsx_common.typVarsOfCoreType + |> Option.value ~default:[] + in let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = match ptyp_desc with | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) @@ -285876,10 +286167,13 @@ let transformSignatureItem ~config _mapper item = let retPropsType = Typ.constr (Location.mkloc (Lident "props") psig_loc) - (makePropsTypeParams namedTypeList) + (match coreTypeOfAttr with + | None -> makePropsTypeParams namedTypeList + | Some _ -> typVarsOfCoreType) in let propsRecordType = - makePropsRecordTypeSig "props" psig_loc + makePropsRecordTypeSig ~coreTypeOfAttr ~typVarsOfCoreType "props" + psig_loc ((* If there is Nolabel arg, regard the type as ref in forwardRef *) (if !hasForwardRef then [(true, "ref", [], refType Location.none)] else []) @@ -285988,24 +286282,22 @@ let expr ~config mapper expression = Exp.ident ~loc {loc; txt = Ldot (Lident "React", "fragment")} in let childrenExpr = transformChildrenIfList ~mapper listItems in + let recordOfChildren children = + Exp.record [(Location.mknoloc (Lident "children"), children)] None + in let args = [ (nolabel, fragment); (match config.mode with - | "automatic" -> + | "automatic" -> ( ( nolabel, - Exp.record - [ - ( Location.mknoloc @@ Lident "children", - match childrenExpr with - | {pexp_desc = Pexp_array children} -> ( - match children with - | [] -> emptyRecord ~loc:Location.none - | [child] -> child - | _ -> childrenExpr) - | _ -> childrenExpr ); - ] - None ) + match childrenExpr with + | {pexp_desc = Pexp_array children} -> ( + match children with + | [] -> emptyRecord ~loc:Location.none + | [child] -> recordOfChildren child + | _ -> recordOfChildren childrenExpr) + | _ -> recordOfChildren childrenExpr )) | "classic" | _ -> (nolabel, childrenExpr)); ] in @@ -286408,7 +286700,7 @@ let fmt_char_option f = function let fmt_constant f x = match x with | Pconst_integer (i,m) -> fprintf f "PConst_int (%s,%a)" i fmt_char_option m; - | Pconst_char (c) -> fprintf f "PConst_char %02x" (Char.code c); + | Pconst_char (c) -> fprintf f "PConst_char %02x" c; | Pconst_string (s, None) -> fprintf f "PConst_string(%S,None)" s; | Pconst_string (s, Some delim) -> fprintf f "PConst_string (%S,Some %S)" s delim; @@ -287276,7 +287568,7 @@ let fmt_path f x = fprintf f "\"%a\"" fmt_path_aux x;; let fmt_constant f x = match x with | Const_int (i) -> fprintf f "Const_int %d" i; - | Const_char (c) -> fprintf f "Const_char %02x" (Char.code c); + | Const_char (c) -> fprintf f "Const_char %02x" c; | Const_string (s, None) -> fprintf f "Const_string(%S,None)" s; | Const_string (s, Some delim) -> fprintf f "Const_string (%S,Some %S)" s delim; @@ -295086,165 +295378,6 @@ let convertDecimalToHex ~strDecimal = "x" ^ String.concat "" [String.make 1 c1; String.make 1 c2] with Invalid_argument _ | Failure _ -> strDecimal -end -module Res_utf8 : sig -#1 "res_utf8.mli" -val repl : int - -val max : int - -val decodeCodePoint : int -> string -> int -> int * int - -val encodeCodePoint : int -> string - -val isValidCodePoint : int -> bool - -end = struct -#1 "res_utf8.ml" -(* https://tools.ietf.org/html/rfc3629#section-10 *) -(* let bom = 0xFEFF *) - -let repl = 0xFFFD - -(* let min = 0x0000 *) -let max = 0x10FFFF - -let surrogateMin = 0xD800 -let surrogateMax = 0xDFFF - -(* - * Char. number range | UTF-8 octet sequence - * (hexadecimal) | (binary) - * --------------------+--------------------------------------------- - * 0000 0000-0000 007F | 0xxxxxxx - * 0000 0080-0000 07FF | 110xxxxx 10xxxxxx - * 0000 0800-0000 FFFF | 1110xxxx 10xxxxxx 10xxxxxx - * 0001 0000-0010 FFFF | 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx - *) -let h2 = 0b1100_0000 -let h3 = 0b1110_0000 -let h4 = 0b1111_0000 - -let cont_mask = 0b0011_1111 - -type category = {low: int; high: int; size: int} - -let locb = 0b1000_0000 -let hicb = 0b1011_1111 - -let categoryTable = [| - (* 0 *) {low = -1; high= -1; size= 1}; (* invalid *) - (* 1 *) {low = 1; high= -1; size= 1}; (* ascii *) - (* 2 *) {low = locb; high= hicb; size= 2}; - (* 3 *) {low = 0xA0; high= hicb; size= 3}; - (* 4 *) {low = locb; high= hicb; size= 3}; - (* 5 *) {low = locb; high= 0x9F; size= 3}; - (* 6 *) {low = 0x90; high= hicb; size= 4}; - (* 7 *) {low = locb; high= hicb; size= 4}; - (* 8 *) {low = locb; high= 0x8F; size= 4}; -|] [@@ocamlformat "disable"] - -let categories = [| - 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; - 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; - 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; - 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; - 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; - 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; - 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; - 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1; - - 0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0; - 0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0; - 0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0; - 0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0; - (* surrogate range U+D800 - U+DFFFF = 55296 - 917503 *) - 0; 0; 2; 2;2; 2; 2; 2;2; 2; 2; 2;2; 2; 2; 2; - 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; - 3; 4; 4; 4; 4; 4; 4; 4; 4; 4; 4; 4; 4; 5; 4; 4; - 6; 7; 7 ;7; 8; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; -|] [@@ocamlformat "disable"] - -let decodeCodePoint i s len = - if len < 1 then (repl, 1) - else - let first = int_of_char (String.unsafe_get s i) in - if first < 128 then (first, 1) - else - let index = Array.unsafe_get categories first in - if index = 0 then (repl, 1) - else - let cat = Array.unsafe_get categoryTable index in - if len < i + cat.size then (repl, 1) - else if cat.size == 2 then - let c1 = int_of_char (String.unsafe_get s (i + 1)) in - if c1 < cat.low || cat.high < c1 then (repl, 1) - else - let i1 = c1 land 0b00111111 in - let i0 = (first land 0b00011111) lsl 6 in - let uc = i0 lor i1 in - (uc, 2) - else if cat.size == 3 then - let c1 = int_of_char (String.unsafe_get s (i + 1)) in - let c2 = int_of_char (String.unsafe_get s (i + 2)) in - if c1 < cat.low || cat.high < c1 || c2 < locb || hicb < c2 then - (repl, 1) - else - let i0 = (first land 0b00001111) lsl 12 in - let i1 = (c1 land 0b00111111) lsl 6 in - let i2 = c2 land 0b00111111 in - let uc = i0 lor i1 lor i2 in - (uc, 3) - else - let c1 = int_of_char (String.unsafe_get s (i + 1)) in - let c2 = int_of_char (String.unsafe_get s (i + 2)) in - let c3 = int_of_char (String.unsafe_get s (i + 3)) in - if - c1 < cat.low || cat.high < c1 || c2 < locb || hicb < c2 || c3 < locb - || hicb < c3 - then (repl, 1) - else - let i1 = (c1 land 0x3f) lsl 12 in - let i2 = (c2 land 0x3f) lsl 6 in - let i3 = c3 land 0x3f in - let i0 = (first land 0x07) lsl 18 in - let uc = i0 lor i3 lor i2 lor i1 in - (uc, 4) - -let encodeCodePoint c = - if c <= 127 then ( - let bytes = (Bytes.create [@doesNotRaise]) 1 in - Bytes.unsafe_set bytes 0 (Char.unsafe_chr c); - Bytes.unsafe_to_string bytes) - else if c <= 2047 then ( - let bytes = (Bytes.create [@doesNotRaise]) 2 in - Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h2 lor (c lsr 6))); - Bytes.unsafe_set bytes 1 - (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); - Bytes.unsafe_to_string bytes) - else if c <= 65535 then ( - let bytes = (Bytes.create [@doesNotRaise]) 3 in - Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h3 lor (c lsr 12))); - Bytes.unsafe_set bytes 1 - (Char.unsafe_chr (0b1000_0000 lor ((c lsr 6) land cont_mask))); - Bytes.unsafe_set bytes 2 - (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); - Bytes.unsafe_to_string bytes) - else - (* if c <= max then *) - let bytes = (Bytes.create [@doesNotRaise]) 4 in - Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h4 lor (c lsr 18))); - Bytes.unsafe_set bytes 1 - (Char.unsafe_chr (0b1000_0000 lor ((c lsr 12) land cont_mask))); - Bytes.unsafe_set bytes 2 - (Char.unsafe_chr (0b1000_0000 lor ((c lsr 6) land cont_mask))); - Bytes.unsafe_set bytes 3 - (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); - Bytes.unsafe_to_string bytes - -let isValidCodePoint c = - (0 <= c && c < surrogateMin) || (surrogateMax < c && c <= max) - end module Res_scanner : sig #1 "res_scanner.mli" @@ -295753,24 +295886,23 @@ let scanEscape scanner = next scanner done; let c = !x in - if Res_utf8.isValidCodePoint c then Char.unsafe_chr c - else Char.unsafe_chr Res_utf8.repl + c in let codepoint = match scanner.ch with | '0' .. '9' -> convertNumber scanner ~n:3 ~base:10 | 'b' -> next scanner; - '\008' + 8 | 'n' -> next scanner; - '\010' + 10 | 'r' -> next scanner; - '\013' + 13 | 't' -> next scanner; - '\009' + 009 | 'x' -> next scanner; convertNumber scanner ~n:2 ~base:16 @@ -295797,14 +295929,13 @@ let scanEscape scanner = | '}' -> next scanner | _ -> ()); let c = !x in - if Res_utf8.isValidCodePoint c then Char.unsafe_chr c - else Char.unsafe_chr Res_utf8.repl + c | _ -> (* unicode escape sequence: '\u007A', exactly 4 hex digits *) convertNumber scanner ~n:4 ~base:16) | ch -> next scanner; - ch + Char.code ch in let contents = (String.sub [@doesNotRaise]) scanner.src offset (scanner.offset - offset) @@ -296138,7 +296269,10 @@ let rec scan scanner = let offset = scanner.offset + 1 in next3 scanner; Token.Codepoint - {c = ch; original = (String.sub [@doesNotRaise]) scanner.src offset 1} + { + c = Char.code ch; + original = (String.sub [@doesNotRaise]) scanner.src offset 1; + } | ch, _ -> next scanner; let offset = scanner.offset in @@ -296606,15 +296740,6 @@ module ErrorMessages = struct ...b}` wouldn't make sense, as `b` would override every field of `a` \ anyway." - let listExprSpread = - "Lists can only have one `...` spread, and at the end.\n\ - Explanation: lists are singly-linked list, where a node contains a value \ - and points to the next node. `list{a, ...bc}` efficiently creates a new \ - item and links `bc` as its next nodes. `list{...bc, a}` would be \ - expensive, as it'd need to traverse `bc` and prepend each item to `a` one \ - by one. We therefore disallow such syntax sugar.\n\ - Solution: directly use `concat`." - let variantIdent = "A polymorphic variant (e.g. #id) must start with an alphabetical letter \ or be a number (e.g. #742)" @@ -296706,6 +296831,8 @@ let suppressFragileMatchWarningAttr = let makeBracesAttr loc = (Location.mkloc "ns.braces" loc, Parsetree.PStr []) let templateLiteralAttr = (Location.mknoloc "res.template", Parsetree.PStr []) +let spreadAttr = (Location.mknoloc "res.spread", Parsetree.PStr []) + type typDefOrExt = | TypeDef of { recFlag: Asttypes.rec_flag; @@ -300230,38 +300357,60 @@ and parseTupleExpr ~first ~startPos p = let loc = mkLoc startPos p.prevEndPos in Ast_helper.Exp.tuple ~loc exprs -and parseSpreadExprRegion p = +and parseSpreadExprRegionWithLoc p = + let startPos = p.Parser.prevEndPos in match p.Parser.token with | DotDotDot -> Parser.next p; let expr = parseConstrainedOrCoercedExpr p in - Some (true, expr) + Some (true, expr, startPos, p.prevEndPos) | token when Grammar.isExprStart token -> - Some (false, parseConstrainedOrCoercedExpr p) + Some (false, parseConstrainedOrCoercedExpr p, startPos, p.prevEndPos) | _ -> None and parseListExpr ~startPos p = - let check_all_non_spread_exp exprs = - exprs - |> List.map (fun (spread, expr) -> - if spread then - Parser.err p (Diagnostics.message ErrorMessages.listExprSpread); - expr) - |> List.rev + let split_by_spread exprs = + List.fold_left + (fun acc curr -> + match (curr, acc) with + | (true, expr, startPos, endPos), _ -> + (* find a spread expression, prepend a new sublist *) + ([], Some expr, startPos, endPos) :: acc + | ( (false, expr, startPos, _endPos), + (no_spreads, spread, _accStartPos, accEndPos) :: acc ) -> + (* find a non-spread expression, and the accumulated is not empty, + * prepend to the first sublist, and update the loc of the first sublist *) + (expr :: no_spreads, spread, startPos, accEndPos) :: acc + | (false, expr, startPos, endPos), [] -> + (* find a non-spread expression, and the accumulated is empty *) + [([expr], None, startPos, endPos)]) + [] exprs + in + let make_sub_expr = function + | exprs, Some spread, startPos, endPos -> + makeListExpression (mkLoc startPos endPos) exprs (Some spread) + | exprs, None, startPos, endPos -> + makeListExpression (mkLoc startPos endPos) exprs None in let listExprsRev = parseCommaDelimitedReversedList p ~grammar:Grammar.ListExpr ~closing:Rbrace - ~f:parseSpreadExprRegion + ~f:parseSpreadExprRegionWithLoc in Parser.expect Rbrace p; let loc = mkLoc startPos p.prevEndPos in - match listExprsRev with - | (true (* spread expression *), expr) :: exprs -> - let exprs = check_all_non_spread_exp exprs in - makeListExpression loc exprs (Some expr) + match split_by_spread listExprsRev with + | [] -> makeListExpression loc [] None + | [(exprs, Some spread, _, _)] -> makeListExpression loc exprs (Some spread) + | [(exprs, None, _, _)] -> makeListExpression loc exprs None | exprs -> - let exprs = check_all_non_spread_exp exprs in - makeListExpression loc exprs None + let listExprs = List.map make_sub_expr exprs in + Ast_helper.Exp.apply ~loc + (Ast_helper.Exp.ident ~loc ~attrs:[spreadAttr] + (Location.mkloc + (Longident.Ldot + (Longident.Ldot (Longident.Lident "Belt", "List"), "concatMany")) + loc)) + [(Asttypes.Nolabel, Ast_helper.Exp.array ~loc listExprs)] (* Overparse ... and give a nice error message *) and parseNonSpreadExp ~msg p = From d63c1012e898408a25bfd41fadf1ed7cb40f2a59 Mon Sep 17 00:00:00 2001 From: butterunderflow Date: Fri, 28 Oct 2022 11:05:01 +0800 Subject: [PATCH 06/15] bugfix: replace wrong pp --- jscomp/ml/parmatch.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/jscomp/ml/parmatch.ml b/jscomp/ml/parmatch.ml index 4836af68f3..12bd99ca36 100644 --- a/jscomp/ml/parmatch.ml +++ b/jscomp/ml/parmatch.ml @@ -379,7 +379,7 @@ let is_cons = function let pretty_const c = match c with | Const_int i -> Printf.sprintf "%d" i -| Const_char i -> Printf.sprintf "%s" (string_of_int i) +| Const_char i -> Printf.sprintf "%C" (Char.unsafe_chr i) | Const_string (s, _) -> Printf.sprintf "%S" s | Const_float f -> Printf.sprintf "%s" f | Const_int32 i -> Printf.sprintf "%ldl" i From 86802830452ed68a1a07dcba0d3da6a3aa9f2d21 Mon Sep 17 00:00:00 2001 From: butterunderflow Date: Fri, 28 Oct 2022 11:05:13 +0800 Subject: [PATCH 07/15] libs --- lib/4.06.1/unstable/js_compiler.ml | 2 +- lib/4.06.1/unstable/js_playground_compiler.ml | 2 +- lib/4.06.1/whole_compiler.ml | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/4.06.1/unstable/js_compiler.ml b/lib/4.06.1/unstable/js_compiler.ml index 2800ea3b98..4fc2830404 100644 --- a/lib/4.06.1/unstable/js_compiler.ml +++ b/lib/4.06.1/unstable/js_compiler.ml @@ -26838,7 +26838,7 @@ let is_cons = function let pretty_const c = match c with | Const_int i -> Printf.sprintf "%d" i -| Const_char i -> Printf.sprintf "%s" (string_of_int i) +| Const_char i -> Printf.sprintf "%C" (Char.unsafe_chr i) | Const_string (s, _) -> Printf.sprintf "%S" s | Const_float f -> Printf.sprintf "%s" f | Const_int32 i -> Printf.sprintf "%ldl" i diff --git a/lib/4.06.1/unstable/js_playground_compiler.ml b/lib/4.06.1/unstable/js_playground_compiler.ml index d4f06a2e5f..ef109cb21e 100644 --- a/lib/4.06.1/unstable/js_playground_compiler.ml +++ b/lib/4.06.1/unstable/js_playground_compiler.ml @@ -26838,7 +26838,7 @@ let is_cons = function let pretty_const c = match c with | Const_int i -> Printf.sprintf "%d" i -| Const_char i -> Printf.sprintf "%s" (string_of_int i) +| Const_char i -> Printf.sprintf "%C" (Char.unsafe_chr i) | Const_string (s, _) -> Printf.sprintf "%S" s | Const_float f -> Printf.sprintf "%s" f | Const_int32 i -> Printf.sprintf "%ldl" i diff --git a/lib/4.06.1/whole_compiler.ml b/lib/4.06.1/whole_compiler.ml index d8af3d5efe..19034367ea 100644 --- a/lib/4.06.1/whole_compiler.ml +++ b/lib/4.06.1/whole_compiler.ml @@ -188635,7 +188635,7 @@ let is_cons = function let pretty_const c = match c with | Const_int i -> Printf.sprintf "%d" i -| Const_char i -> Printf.sprintf "%s" (string_of_int i) +| Const_char i -> Printf.sprintf "%C" (Char.unsafe_chr i) | Const_string (s, _) -> Printf.sprintf "%S" s | Const_float f -> Printf.sprintf "%s" f | Const_int32 i -> Printf.sprintf "%ldl" i From fe11ca76f425bfa9d029fe56eb0470f679283467 Mon Sep 17 00:00:00 2001 From: butterunderflow Date: Fri, 28 Oct 2022 11:16:27 +0800 Subject: [PATCH 08/15] bugfix: replace wrong print --- jscomp/ml/printlambda.ml | 2 +- lib/4.06.1/unstable/js_compiler.ml | 2 +- lib/4.06.1/unstable/js_playground_compiler.ml | 2 +- lib/4.06.1/whole_compiler.ml | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/jscomp/ml/printlambda.ml b/jscomp/ml/printlambda.ml index a355c86768..0e7cd9efd0 100644 --- a/jscomp/ml/printlambda.ml +++ b/jscomp/ml/printlambda.ml @@ -21,7 +21,7 @@ open Lambda let rec struct_const ppf = function | Const_base(Const_int n) -> fprintf ppf "%i" n - | Const_base(Const_char i) -> fprintf ppf "%s" (string_of_int i) + | Const_base(Const_char i) -> fprintf ppf "%C" (Char.unsafe_chr i) | Const_base(Const_string (s, _)) -> fprintf ppf "%S" s | Const_immstring s -> fprintf ppf "#%S" s | Const_base(Const_float f) -> fprintf ppf "%s" f diff --git a/lib/4.06.1/unstable/js_compiler.ml b/lib/4.06.1/unstable/js_compiler.ml index 4fc2830404..cc9f39ec62 100644 --- a/lib/4.06.1/unstable/js_compiler.ml +++ b/lib/4.06.1/unstable/js_compiler.ml @@ -29129,7 +29129,7 @@ open Lambda let rec struct_const ppf = function | Const_base(Const_int n) -> fprintf ppf "%i" n - | Const_base(Const_char i) -> fprintf ppf "%s" (string_of_int i) + | Const_base(Const_char i) -> fprintf ppf "%C" (Char.unsafe_chr i) | Const_base(Const_string (s, _)) -> fprintf ppf "%S" s | Const_immstring s -> fprintf ppf "#%S" s | Const_base(Const_float f) -> fprintf ppf "%s" f diff --git a/lib/4.06.1/unstable/js_playground_compiler.ml b/lib/4.06.1/unstable/js_playground_compiler.ml index ef109cb21e..8f3770e37d 100644 --- a/lib/4.06.1/unstable/js_playground_compiler.ml +++ b/lib/4.06.1/unstable/js_playground_compiler.ml @@ -29129,7 +29129,7 @@ open Lambda let rec struct_const ppf = function | Const_base(Const_int n) -> fprintf ppf "%i" n - | Const_base(Const_char i) -> fprintf ppf "%s" (string_of_int i) + | Const_base(Const_char i) -> fprintf ppf "%C" (Char.unsafe_chr i) | Const_base(Const_string (s, _)) -> fprintf ppf "%S" s | Const_immstring s -> fprintf ppf "#%S" s | Const_base(Const_float f) -> fprintf ppf "%s" f diff --git a/lib/4.06.1/whole_compiler.ml b/lib/4.06.1/whole_compiler.ml index 19034367ea..0bf3b22d82 100644 --- a/lib/4.06.1/whole_compiler.ml +++ b/lib/4.06.1/whole_compiler.ml @@ -190926,7 +190926,7 @@ open Lambda let rec struct_const ppf = function | Const_base(Const_int n) -> fprintf ppf "%i" n - | Const_base(Const_char i) -> fprintf ppf "%s" (string_of_int i) + | Const_base(Const_char i) -> fprintf ppf "%C" (Char.unsafe_chr i) | Const_base(Const_string (s, _)) -> fprintf ppf "%S" s | Const_immstring s -> fprintf ppf "#%S" s | Const_base(Const_float f) -> fprintf ppf "%s" f From cccc302105a6beea77971aed233b66ad4d40a75e Mon Sep 17 00:00:00 2001 From: butterunderflow Date: Fri, 28 Oct 2022 14:32:51 +0800 Subject: [PATCH 09/15] use unsafe_chr to handle possible overflow char --- jscomp/ml/pprintast.ml | 2 +- lib/4.06.1/unstable/js_compiler.ml | 19 ++++++++++++++++- lib/4.06.1/unstable/js_playground_compiler.ml | 21 +++++++++++++++++-- lib/4.06.1/whole_compiler.ml | 21 +++++++++++++++++-- 4 files changed, 57 insertions(+), 6 deletions(-) diff --git a/jscomp/ml/pprintast.ml b/jscomp/ml/pprintast.ml index 5f1cdfe319..d161a37858 100644 --- a/jscomp/ml/pprintast.ml +++ b/jscomp/ml/pprintast.ml @@ -193,7 +193,7 @@ let rec longident f = function let longident_loc f x = pp f "%a" longident x.txt let constant f = function - | Pconst_char i -> pp f "%C" (Char.chr i) + | Pconst_char i -> pp f "%C" (Char.unsafe_chr i) | Pconst_string (i, None) -> pp f "%S" i | Pconst_string (i, Some delim) -> pp f "{%s|%s|%s}" delim i delim | Pconst_integer (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i diff --git a/lib/4.06.1/unstable/js_compiler.ml b/lib/4.06.1/unstable/js_compiler.ml index cc9f39ec62..2e2466faeb 100644 --- a/lib/4.06.1/unstable/js_compiler.ml +++ b/lib/4.06.1/unstable/js_compiler.ml @@ -51129,6 +51129,8 @@ let catch = Lident "catch" end module Res_utf8 : sig #1 "res_utf8.mli" +val repl : int + val max : int val decodeCodePoint : int -> string -> int -> int * int @@ -51869,7 +51871,22 @@ let printConstant ?(templateLiteral = false) c = ] | Pconst_float (s, _) -> Doc.text s | Pconst_char c -> - let str = Res_utf8.encodeCodePoint c in + let str = + if c <= 127 then + match Char.chr c with + | '\'' -> "\\'" + | '\\' -> "\\\\" + | '\n' -> "\\n" + | '\t' -> "\\t" + | '\r' -> "\\r" + | '\b' -> "\\b" + | ' ' .. '~' as c -> + let s = (Bytes.create [@doesNotRaise]) 1 in + Bytes.unsafe_set s 0 c; + Bytes.unsafe_to_string s + | _ -> Res_utf8.encodeCodePoint c + else Res_utf8.encodeCodePoint c + in Doc.text ("'" ^ str ^ "'") let printOptionalLabel attrs = diff --git a/lib/4.06.1/unstable/js_playground_compiler.ml b/lib/4.06.1/unstable/js_playground_compiler.ml index 8f3770e37d..8a20e21b01 100644 --- a/lib/4.06.1/unstable/js_playground_compiler.ml +++ b/lib/4.06.1/unstable/js_playground_compiler.ml @@ -51129,6 +51129,8 @@ let catch = Lident "catch" end module Res_utf8 : sig #1 "res_utf8.mli" +val repl : int + val max : int val decodeCodePoint : int -> string -> int -> int * int @@ -51869,7 +51871,22 @@ let printConstant ?(templateLiteral = false) c = ] | Pconst_float (s, _) -> Doc.text s | Pconst_char c -> - let str = Res_utf8.encodeCodePoint c in + let str = + if c <= 127 then + match Char.chr c with + | '\'' -> "\\'" + | '\\' -> "\\\\" + | '\n' -> "\\n" + | '\t' -> "\\t" + | '\r' -> "\\r" + | '\b' -> "\\b" + | ' ' .. '~' as c -> + let s = (Bytes.create [@doesNotRaise]) 1 in + Bytes.unsafe_set s 0 c; + Bytes.unsafe_to_string s + | _ -> Res_utf8.encodeCodePoint c + else Res_utf8.encodeCodePoint c + in Doc.text ("'" ^ str ^ "'") let printOptionalLabel attrs = @@ -282354,7 +282371,7 @@ let scanEscape scanner = next scanner done; let c = !x in - c + if Res_utf8.isValidCodePoint c then c else Res_utf8.repl in let codepoint = match scanner.ch with diff --git a/lib/4.06.1/whole_compiler.ml b/lib/4.06.1/whole_compiler.ml index 0bf3b22d82..fe04ba5a04 100644 --- a/lib/4.06.1/whole_compiler.ml +++ b/lib/4.06.1/whole_compiler.ml @@ -227316,6 +227316,8 @@ let catch = Lident "catch" end module Res_utf8 : sig #1 "res_utf8.mli" +val repl : int + val max : int val decodeCodePoint : int -> string -> int -> int * int @@ -228056,7 +228058,22 @@ let printConstant ?(templateLiteral = false) c = ] | Pconst_float (s, _) -> Doc.text s | Pconst_char c -> - let str = Res_utf8.encodeCodePoint c in + let str = + if c <= 127 then + match Char.chr c with + | '\'' -> "\\'" + | '\\' -> "\\\\" + | '\n' -> "\\n" + | '\t' -> "\\t" + | '\r' -> "\\r" + | '\b' -> "\\b" + | ' ' .. '~' as c -> + let s = (Bytes.create [@doesNotRaise]) 1 in + Bytes.unsafe_set s 0 c; + Bytes.unsafe_to_string s + | _ -> Res_utf8.encodeCodePoint c + else Res_utf8.encodeCodePoint c + in Doc.text ("'" ^ str ^ "'") let printOptionalLabel attrs = @@ -295886,7 +295903,7 @@ let scanEscape scanner = next scanner done; let c = !x in - c + if Res_utf8.isValidCodePoint c then c else Res_utf8.repl in let codepoint = match scanner.ch with From ec1688e0ce8c4124c195b46c24eeec532c3b1511 Mon Sep 17 00:00:00 2001 From: butterunderflow Date: Sat, 29 Oct 2022 18:43:25 +0800 Subject: [PATCH 10/15] safe print int as char --- jscomp/core/js_dump.ml | 2 +- jscomp/core/lam_print.ml | 9 +- jscomp/ml/parmatch.ml | 2 +- jscomp/ml/pprintast.ml | 13 +- jscomp/ml/pprintast.mli | 1 + jscomp/ml/pprintast.pp.ml | 9 +- jscomp/ml/printlambda.ml | 2 +- jscomp/test/res_debug.js | 2 +- lib/4.06.1/unstable/js_compiler.ml | 1512 +- lib/4.06.1/unstable/js_compiler.ml.d | 2 + lib/4.06.1/unstable/js_playground_compiler.ml | 4345 +++--- lib/4.06.1/whole_compiler.ml | 11893 ++++++++-------- 12 files changed, 9659 insertions(+), 8133 deletions(-) diff --git a/jscomp/core/js_dump.ml b/jscomp/core/js_dump.ml index 65e9a493ed..05237aed31 100644 --- a/jscomp/core/js_dump.ml +++ b/jscomp/core/js_dump.ml @@ -630,7 +630,7 @@ and expression_desc cxt ~(level : int) f x : cxt = match v with | Float { f } -> Js_number.caml_float_literal_to_js_string f (* attach string here for float constant folding?*) - | Int { i; c = Some c } -> Format.asprintf "/* %C */%ld" (Char.unsafe_chr c) i + | Int { i; c = Some c } -> Format.asprintf "/* %s */%ld" (Pprintast.string_of_int_as_char c) i | Int { i; c = None } -> Int32.to_string i (* check , js convention with ocaml lexical convention *) diff --git a/jscomp/core/lam_print.ml b/jscomp/core/lam_print.ml index 1967277657..5907149e83 100644 --- a/jscomp/core/lam_print.ml +++ b/jscomp/core/lam_print.ml @@ -13,6 +13,13 @@ open Format open Asttypes +let string_of_int_as_char i = + if i >= 0 && i <= 255 + then + Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) + else + Printf.sprintf "\'\\%d\'" i + let rec struct_const ppf (cst : Lam_constant.t) = match cst with | Const_js_true -> fprintf ppf "#true" @@ -21,7 +28,7 @@ let rec struct_const ppf (cst : Lam_constant.t) = | Const_module_alias -> fprintf ppf "#alias" | Const_js_undefined -> fprintf ppf "#undefined" | Const_int { i } -> fprintf ppf "%ld" i - | Const_char c -> fprintf ppf "%C" (Char.unsafe_chr c) + | Const_char i -> fprintf ppf "%s" (string_of_int_as_char i) | Const_string { s } -> fprintf ppf "%S" s | Const_float f -> fprintf ppf "%s" f | Const_int64 n -> fprintf ppf "%LiL" n diff --git a/jscomp/ml/parmatch.ml b/jscomp/ml/parmatch.ml index 12bd99ca36..21e169a0ad 100644 --- a/jscomp/ml/parmatch.ml +++ b/jscomp/ml/parmatch.ml @@ -379,7 +379,7 @@ let is_cons = function let pretty_const c = match c with | Const_int i -> Printf.sprintf "%d" i -| Const_char i -> Printf.sprintf "%C" (Char.unsafe_chr i) +| Const_char i -> Printf.sprintf "%s" (Pprintast.string_of_int_as_char i) | Const_string (s, _) -> Printf.sprintf "%S" s | Const_float f -> Printf.sprintf "%s" f | Const_int32 i -> Printf.sprintf "%ldl" i diff --git a/jscomp/ml/pprintast.ml b/jscomp/ml/pprintast.ml index d161a37858..b161db201a 100644 --- a/jscomp/ml/pprintast.ml +++ b/jscomp/ml/pprintast.ml @@ -192,8 +192,15 @@ let rec longident f = function let longident_loc f x = pp f "%a" longident x.txt +let string_of_int_as_char i = + if i >= 0 && i <= 255 + then + Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) + else + Printf.sprintf "\'\\%d\'" i + let constant f = function - | Pconst_char i -> pp f "%C" (Char.unsafe_chr i) + | Pconst_char i -> pp f "%s" (string_of_int_as_char i) | Pconst_string (i, None) -> pp f "%S" i | Pconst_string (i, Some delim) -> pp f "{%s|%s|%s}" delim i delim | Pconst_integer (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i @@ -770,7 +777,7 @@ and value_description ctxt f x = pp f "@[%a%a@]" (core_type ctxt) x.pval_type (fun f x -> -# 772 "ml/pprintast.pp.ml" +# 779 "ml/pprintast.pp.ml" match x.pval_prim with | first :: second :: _ when Ext_string.first_marshal_char second @@ -783,7 +790,7 @@ and value_description ctxt f x = pp f "@ =@ %a" (list constant_string) x.pval_prim -# 787 "ml/pprintast.pp.ml" +# 794 "ml/pprintast.pp.ml" ) x and extension ctxt f (s, e) = diff --git a/jscomp/ml/pprintast.mli b/jscomp/ml/pprintast.mli index 18ffa38b0c..7da9ee0d12 100644 --- a/jscomp/ml/pprintast.mli +++ b/jscomp/ml/pprintast.mli @@ -24,3 +24,4 @@ val pattern: Format.formatter -> Parsetree.pattern -> unit val signature: Format.formatter -> Parsetree.signature -> unit val structure: Format.formatter -> Parsetree.structure -> unit val string_of_structure: Parsetree.structure -> string +val string_of_int_as_char: int -> string diff --git a/jscomp/ml/pprintast.pp.ml b/jscomp/ml/pprintast.pp.ml index 442594bb95..5ac5790a44 100644 --- a/jscomp/ml/pprintast.pp.ml +++ b/jscomp/ml/pprintast.pp.ml @@ -191,8 +191,15 @@ let rec longident f = function let longident_loc f x = pp f "%a" longident x.txt +let string_of_int_as_char i = + if i >= 0 && i <= 255 + then + Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) + else + Printf.sprintf "\'\\%d\'" i + let constant f = function - | Pconst_char i -> pp f "%C" (Char.chr i) + | Pconst_char i -> pp f "%s" (string_of_int_as_char i) | Pconst_string (i, None) -> pp f "%S" i | Pconst_string (i, Some delim) -> pp f "{%s|%s|%s}" delim i delim | Pconst_integer (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i diff --git a/jscomp/ml/printlambda.ml b/jscomp/ml/printlambda.ml index 0e7cd9efd0..8542238594 100644 --- a/jscomp/ml/printlambda.ml +++ b/jscomp/ml/printlambda.ml @@ -21,7 +21,7 @@ open Lambda let rec struct_const ppf = function | Const_base(Const_int n) -> fprintf ppf "%i" n - | Const_base(Const_char i) -> fprintf ppf "%C" (Char.unsafe_chr i) + | Const_base(Const_char i) -> fprintf ppf "%s" (Pprintast.string_of_int_as_char i) | Const_base(Const_string (s, _)) -> fprintf ppf "%S" s | Const_immstring s -> fprintf ppf "#%S" s | Const_base(Const_float f) -> fprintf ppf "%s" f diff --git a/jscomp/test/res_debug.js b/jscomp/test/res_debug.js index bd4779d995..5a9b1bfc4b 100644 --- a/jscomp/test/res_debug.js +++ b/jscomp/test/res_debug.js @@ -70,7 +70,7 @@ var v1 = { z: 3 }; -var h = /* '\522' */128522; +var h = /* '\128522' */128522; var hey = "hello, 世界"; diff --git a/lib/4.06.1/unstable/js_compiler.ml b/lib/4.06.1/unstable/js_compiler.ml index 2e2466faeb..894257411f 100644 --- a/lib/4.06.1/unstable/js_compiler.ml +++ b/lib/4.06.1/unstable/js_compiler.ml @@ -24863,6 +24863,1477 @@ let lam_of_loc kind loc = let reset () = raise_count := 0 +end +module Pprintast : sig +#1 "pprintast.mli" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Hongbo Zhang (University of Pennsylvania) *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type space_formatter = (unit, Format.formatter, unit) format + + +val expression : Format.formatter -> Parsetree.expression -> unit +val string_of_expression : Parsetree.expression -> string + +val core_type: Format.formatter -> Parsetree.core_type -> unit +val pattern: Format.formatter -> Parsetree.pattern -> unit +val signature: Format.formatter -> Parsetree.signature -> unit +val structure: Format.formatter -> Parsetree.structure -> unit +val string_of_structure: Parsetree.structure -> string +val string_of_int_as_char: int -> string + +end = struct +#1 "pprintast.pp.ml" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Thomas Gazagnaire, OCamlPro *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* Hongbo Zhang, University of Pennsylvania *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Original Code from Ber-metaocaml, modified for 3.12.0 and fixed *) +(* Printing code expressions *) +(* Authors: Ed Pizzi, Fabrice Le Fessant *) +(* Extensive Rewrite: Hongbo Zhang: University of Pennsylvania *) +(* TODO more fine-grained precedence pretty-printing *) + +open Asttypes +open Format +open Location +open Longident +open Parsetree +open Ast_helper + +let prefix_symbols = [ '!'; '?'; '~' ] ;; +let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/'; + '$'; '%'; '#' ] + +(* type fixity = Infix| Prefix *) +let special_infix_strings = + ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!="; "::" ] + +(* determines if the string is an infix string. + checks backwards, first allowing a renaming postfix ("_102") which + may have resulted from Pexp -> Texp -> Pexp translation, then checking + if all the characters in the beginning of the string are valid infix + characters. *) +let fixity_of_string = function + | s when List.mem s special_infix_strings -> `Infix s + | s when List.mem s.[0] infix_symbols -> `Infix s + | s when List.mem s.[0] prefix_symbols -> `Prefix s + | s when s.[0] = '.' -> `Mixfix s + | _ -> `Normal + +let view_fixity_of_exp = function + | {pexp_desc = Pexp_ident {txt=Lident l;_}; pexp_attributes = []} -> + fixity_of_string l + | _ -> `Normal + +let is_infix = function | `Infix _ -> true | _ -> false +let is_mixfix = function `Mixfix _ -> true | _ -> false + +(* which identifiers are in fact operators needing parentheses *) +let needs_parens txt = + let fix = fixity_of_string txt in + is_infix fix + || is_mixfix fix + || List.mem txt.[0] prefix_symbols + +(* some infixes need spaces around parens to avoid clashes with comment + syntax *) +let needs_spaces txt = + txt.[0]='*' || txt.[String.length txt - 1] = '*' + +(* add parentheses to binders when they are in fact infix or prefix operators *) +let protect_ident ppf txt = + let format : (_, _, _) format = + if not (needs_parens txt) then "%s" + else if needs_spaces txt then "(@;%s@;)" + else "(%s)" + in fprintf ppf format txt + +let protect_longident ppf print_longident longprefix txt = + let format : (_, _, _) format = + if not (needs_parens txt) then "%a.%s" + else if needs_spaces txt then "%a.(@;%s@;)" + else "%a.(%s)" in + fprintf ppf format print_longident longprefix txt + +type space_formatter = (unit, Format.formatter, unit) format + +let override = function + | Override -> "!" + | Fresh -> "" + +(* variance encoding: need to sync up with the [parser.mly] *) +let type_variance = function + | Invariant -> "" + | Covariant -> "+" + | Contravariant -> "-" + +type construct = + [ `cons of expression list + | `list of expression list + | `nil + | `normal + | `simple of Longident.t + | `tuple ] + +let view_expr x = + match x.pexp_desc with + | Pexp_construct ( {txt= Lident "()"; _},_) -> `tuple + | Pexp_construct ( {txt= Lident "[]";_},_) -> `nil + | Pexp_construct ( {txt= Lident"::";_},Some _) -> + let rec loop exp acc = match exp with + | {pexp_desc=Pexp_construct ({txt=Lident "[]";_},_); + pexp_attributes = []} -> + (List.rev acc,true) + | {pexp_desc= + Pexp_construct ({txt=Lident "::";_}, + Some ({pexp_desc= Pexp_tuple([e1;e2]); + pexp_attributes = []})); + pexp_attributes = []} + -> + loop e2 (e1::acc) + | e -> (List.rev (e::acc),false) in + let (ls,b) = loop x [] in + if b then + `list ls + else `cons ls + | Pexp_construct (x,None) -> `simple (x.txt) + | _ -> `normal + +let is_simple_construct :construct -> bool = function + | `nil | `tuple | `list _ | `simple _ -> true + | `cons _ | `normal -> false + +let pp = fprintf + +type ctxt = { + pipe : bool; + semi : bool; + ifthenelse : bool; +} + +let reset_ctxt = { pipe=false; semi=false; ifthenelse=false } +let under_pipe ctxt = { ctxt with pipe=true } +let under_semi ctxt = { ctxt with semi=true } +let under_ifthenelse ctxt = { ctxt with ifthenelse=true } +(* +let reset_semi ctxt = { ctxt with semi=false } +let reset_ifthenelse ctxt = { ctxt with ifthenelse=false } +let reset_pipe ctxt = { ctxt with pipe=false } +*) + +let list : 'a . ?sep:space_formatter -> ?first:space_formatter -> + ?last:space_formatter -> (Format.formatter -> 'a -> unit) -> + Format.formatter -> 'a list -> unit + = fun ?sep ?first ?last fu f xs -> + let first = match first with Some x -> x |None -> ("": _ format6) + and last = match last with Some x -> x |None -> ("": _ format6) + and sep = match sep with Some x -> x |None -> ("@ ": _ format6) in + let aux f = function + | [] -> () + | [x] -> fu f x + | xs -> + let rec loop f = function + | [x] -> fu f x + | x::xs -> fu f x; pp f sep; loop f xs; + | _ -> assert false in begin + pp f first; loop f xs; pp f last; + end in + aux f xs + +let option : 'a. ?first:space_formatter -> ?last:space_formatter -> + (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a option -> unit + = fun ?first ?last fu f a -> + let first = match first with Some x -> x | None -> ("": _ format6) + and last = match last with Some x -> x | None -> ("": _ format6) in + match a with + | None -> () + | Some x -> pp f first; fu f x; pp f last + +let paren: 'a . ?first:space_formatter -> ?last:space_formatter -> + bool -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit + = fun ?(first=("": _ format6)) ?(last=("": _ format6)) b fu f x -> + if b then (pp f "("; pp f first; fu f x; pp f last; pp f ")") + else fu f x + +let rec longident f = function + | Lident s -> protect_ident f s + | Ldot(y,s) -> protect_longident f longident y s + | Lapply (y,s) -> + pp f "%a(%a)" longident y longident s + +let longident_loc f x = pp f "%a" longident x.txt + +let string_of_int_as_char i = + if i >= 0 && i <= 255 + then + Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) + else + Printf.sprintf "\'\\%d\'" i + +let constant f = function + | Pconst_char i -> pp f "%s" (string_of_int_as_char i) + | Pconst_string (i, None) -> pp f "%S" i + | Pconst_string (i, Some delim) -> pp f "{%s|%s|%s}" delim i delim + | Pconst_integer (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i + | Pconst_integer (i, Some m) -> + paren (i.[0]='-') (fun f (i, m) -> pp f "%s%c" i m) f (i,m) + | Pconst_float (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i + | Pconst_float (i, Some m) -> paren (i.[0]='-') (fun f (i,m) -> + pp f "%s%c" i m) f (i,m) + +(* trailing space*) +let mutable_flag f = function + | Immutable -> () + | Mutable -> pp f "mutable@;" +let virtual_flag f = function + | Concrete -> () + | Virtual -> pp f "virtual@;" + +(* trailing space added *) +let rec_flag f rf = + match rf with + | Nonrecursive -> () + | Recursive -> pp f "rec " +let nonrec_flag f rf = + match rf with + | Nonrecursive -> pp f "nonrec " + | Recursive -> () +let direction_flag f = function + | Upto -> pp f "to@ " + | Downto -> pp f "downto@ " +let private_flag f = function + | Public -> () + | Private -> pp f "private@ " + +let constant_string f s = pp f "%S" s +let tyvar f str = pp f "'%s" str +let tyvar_loc f str = pp f "'%s" str.txt +let string_quot f x = pp f "`%s" x + +(* c ['a,'b] *) +let rec class_params_def ctxt f = function + | [] -> () + | l -> + pp f "[%a] " (* space *) + (list (type_param ctxt) ~sep:",") l + +and type_with_label ctxt f (label, c) = + match label with + | Nolabel -> core_type1 ctxt f c (* otherwise parenthesize *) + | Labelled s -> pp f "%s:%a" s (core_type1 ctxt) c + | Optional s -> pp f "?%s:%a" s (core_type1 ctxt) c + +and core_type ctxt f x = + if x.ptyp_attributes <> [] then begin + pp f "((%a)%a)" (core_type ctxt) {x with ptyp_attributes=[]} + (attributes ctxt) x.ptyp_attributes + end + else match x.ptyp_desc with + | Ptyp_arrow (l, ct1, ct2) -> + pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) + (type_with_label ctxt) (l,ct1) (core_type ctxt) ct2 + | Ptyp_alias (ct, s) -> + pp f "@[<2>%a@;as@;'%s@]" (core_type1 ctxt) ct s + | Ptyp_poly ([], ct) -> + core_type ctxt f ct + | Ptyp_poly (sl, ct) -> + pp f "@[<2>%a%a@]" + (fun f l -> + pp f "%a" + (fun f l -> match l with + | [] -> () + | _ -> + pp f "%a@;.@;" + (list tyvar_loc ~sep:"@;") l) + l) + sl (core_type ctxt) ct + | _ -> pp f "@[<2>%a@]" (core_type1 ctxt) x + +and core_type1 ctxt f x = + if x.ptyp_attributes <> [] then core_type ctxt f x + else match x.ptyp_desc with + | Ptyp_any -> pp f "_"; + | Ptyp_var s -> tyvar f s; + | Ptyp_tuple l -> pp f "(%a)" (list (core_type1 ctxt) ~sep:"@;*@;") l + | Ptyp_constr (li, l) -> + pp f (* "%a%a@;" *) "%a%a" + (fun f l -> match l with + |[] -> () + |[x]-> pp f "%a@;" (core_type1 ctxt) x + | _ -> list ~first:"(" ~last:")@;" (core_type ctxt) ~sep:",@;" f l) + l longident_loc li + | Ptyp_variant (l, closed, low) -> + let type_variant_helper f x = + match x with + | Rtag (l, attrs, _, ctl) -> + pp f "@[<2>%a%a@;%a@]" string_quot l.txt + (fun f l -> match l with + |[] -> () + | _ -> pp f "@;of@;%a" + (list (core_type ctxt) ~sep:"&") ctl) ctl + (attributes ctxt) attrs + | Rinherit ct -> core_type ctxt f ct in + pp f "@[<2>[%a%a]@]" + (fun f l -> + match l, closed with + | [], Closed -> () + | [], Open -> pp f ">" (* Cf #7200: print [>] correctly *) + | _ -> + pp f "%s@;%a" + (match (closed,low) with + | (Closed,None) -> "" + | (Closed,Some _) -> "<" (* FIXME desugar the syntax sugar*) + | (Open,_) -> ">") + (list type_variant_helper ~sep:"@;<1 -2>| ") l) l + (fun f low -> match low with + |Some [] |None -> () + |Some xs -> + pp f ">@ %a" + (list string_quot) xs) low + | Ptyp_object (l, o) -> + let core_field_type f = function + | Otag (l, attrs, ct) -> + pp f "@[%s: %a@ %a@ @]" l.txt + (core_type ctxt) ct (attributes ctxt) attrs (* Cf #7200 *) + | Oinherit ct -> + pp f "@[%a@ @]" (core_type ctxt) ct + in + let field_var f = function + | Asttypes.Closed -> () + | Asttypes.Open -> + match l with + | [] -> pp f ".." + | _ -> pp f " ;.." + in + pp f "@[<@ %a%a@ > @]" (list core_field_type ~sep:";") l + field_var o (* Cf #7200 *) + | Ptyp_class (li, l) -> (*FIXME*) + pp f "@[%a#%a@]" + (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") l + longident_loc li + | Ptyp_package (lid, cstrs) -> + let aux f (s, ct) = + pp f "type %a@ =@ %a" longident_loc s (core_type ctxt) ct in + (match cstrs with + |[] -> pp f "@[(module@ %a)@]" longident_loc lid + |_ -> + pp f "@[(module@ %a@ with@ %a)@]" longident_loc lid + (list aux ~sep:"@ and@ ") cstrs) + | Ptyp_extension e -> extension ctxt f e + | _ -> paren true (core_type ctxt) f x + +(********************pattern********************) +(* be cautious when use [pattern], [pattern1] is preferred *) +and pattern ctxt f x = + let rec list_of_pattern acc = function (* only consider ((A|B)|C)*) + | {ppat_desc= Ppat_or (p1,p2); ppat_attributes = []} -> + list_of_pattern (p2::acc) p1 + | x -> x::acc + in + if x.ppat_attributes <> [] then begin + pp f "((%a)%a)" (pattern ctxt) {x with ppat_attributes=[]} + (attributes ctxt) x.ppat_attributes + end + else match x.ppat_desc with + | Ppat_alias (p, s) -> + pp f "@[<2>%a@;as@;%a@]" (pattern ctxt) p protect_ident s.txt (* RA*) + | Ppat_or _ -> (* *) + pp f "@[%a@]" (list ~sep:"@,|" (pattern ctxt)) + (list_of_pattern [] x) + | _ -> pattern1 ctxt f x + +and pattern1 ctxt (f:Format.formatter) (x:pattern) : unit = + let rec pattern_list_helper f = function + | {ppat_desc = + Ppat_construct + ({ txt = Lident("::") ;_}, + Some ({ppat_desc = Ppat_tuple([pat1; pat2]);_})); + ppat_attributes = []} + + -> + pp f "%a::%a" (simple_pattern ctxt) pat1 pattern_list_helper pat2 (*RA*) + | p -> pattern1 ctxt f p + in + if x.ppat_attributes <> [] then pattern ctxt f x + else match x.ppat_desc with + | Ppat_variant (l, Some p) -> + pp f "@[<2>`%s@;%a@]" l (simple_pattern ctxt) p + | Ppat_construct (({txt=Lident("()"|"[]");_}), _) -> simple_pattern ctxt f x + | Ppat_construct (({txt;_} as li), po) -> + (* FIXME The third field always false *) + if txt = Lident "::" then + pp f "%a" pattern_list_helper x + else + (match po with + | Some x -> pp f "%a@;%a" longident_loc li (simple_pattern ctxt) x + | None -> pp f "%a" longident_loc li) + | _ -> simple_pattern ctxt f x + +and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = + if x.ppat_attributes <> [] then pattern ctxt f x + else match x.ppat_desc with + | Ppat_construct (({txt=Lident ("()"|"[]" as x);_}), _) -> pp f "%s" x + | Ppat_any -> pp f "_"; + | Ppat_var ({txt = txt;_}) -> protect_ident f txt + | Ppat_array l -> + pp f "@[<2>[|%a|]@]" (list (pattern1 ctxt) ~sep:";") l + | Ppat_unpack (s) -> + pp f "(module@ %s)@ " s.txt + | Ppat_type li -> + pp f "#%a" longident_loc li + | Ppat_record (l, closed) -> + let longident_x_pattern f (li, p) = + match (li,p) with + | ({txt=Lident s;_ }, + {ppat_desc=Ppat_var {txt;_}; + ppat_attributes=[]; _}) + when s = txt -> + pp f "@[<2>%a@]" longident_loc li + | _ -> + pp f "@[<2>%a@;=@;%a@]" longident_loc li (pattern1 ctxt) p + in + begin match closed with + | Closed -> + pp f "@[<2>{@;%a@;}@]" (list longident_x_pattern ~sep:";@;") l + | _ -> + pp f "@[<2>{@;%a;_}@]" (list longident_x_pattern ~sep:";@;") l + end + | Ppat_tuple l -> + pp f "@[<1>(%a)@]" (list ~sep:",@;" (pattern1 ctxt)) l (* level1*) + | Ppat_constant (c) -> pp f "%a" constant c + | Ppat_interval (c1, c2) -> pp f "%a..%a" constant c1 constant c2 + | Ppat_variant (l,None) -> pp f "`%s" l + | Ppat_constraint (p, ct) -> + pp f "@[<2>(%a@;:@;%a)@]" (pattern1 ctxt) p (core_type ctxt) ct + | Ppat_lazy p -> + pp f "@[<2>(lazy@;%a)@]" (pattern1 ctxt) p + | Ppat_exception p -> + pp f "@[<2>exception@;%a@]" (pattern1 ctxt) p + | Ppat_extension e -> extension ctxt f e + | Ppat_open (lid, p) -> + let with_paren = + match p.ppat_desc with + | Ppat_array _ | Ppat_record _ + | Ppat_construct (({txt=Lident ("()"|"[]");_}), _) -> false + | _ -> true in + pp f "@[<2>%a.%a @]" longident_loc lid + (paren with_paren @@ pattern1 ctxt) p + | _ -> paren true (pattern ctxt) f x + +and label_exp ctxt f (l,opt,p) = + match l with + | Nolabel -> + (* single case pattern parens needed here *) + pp f "%a@ " (simple_pattern ctxt) p + | Optional rest -> + begin match p with + | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []} + when txt = rest -> + (match opt with + | Some o -> pp f "?(%s=@;%a)@;" rest (expression ctxt) o + | None -> pp f "?%s@ " rest) + | _ -> + (match opt with + | Some o -> + pp f "?%s:(%a=@;%a)@;" + rest (pattern1 ctxt) p (expression ctxt) o + | None -> pp f "?%s:%a@;" rest (simple_pattern ctxt) p) + end + | Labelled l -> match p with + | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []} + when txt = l -> + pp f "~%s@;" l + | _ -> pp f "~%s:%a@;" l (simple_pattern ctxt) p + +and sugar_expr ctxt f e = + if e.pexp_attributes <> [] then false + else match e.pexp_desc with + | Pexp_apply ({ pexp_desc = Pexp_ident {txt = id; _}; + pexp_attributes=[]; _}, args) + when List.for_all (fun (lab, _) -> lab = Nolabel) args -> begin + let print_indexop a path_prefix assign left right print_index indices + rem_args = + let print_path ppf = function + | None -> () + | Some m -> pp ppf ".%a" longident m in + match assign, rem_args with + | false, [] -> + pp f "@[%a%a%s%a%s@]" + (simple_expr ctxt) a print_path path_prefix + left (list ~sep:"," print_index) indices right; true + | true, [v] -> + pp f "@[%a%a%s%a%s@ <-@;<1 2>%a@]" + (simple_expr ctxt) a print_path path_prefix + left (list ~sep:"," print_index) indices right + (simple_expr ctxt) v; true + | _ -> false in + match id, List.map snd args with + | Lident "!", [e] -> + pp f "@[!%a@]" (simple_expr ctxt) e; true + | Ldot (path, ("get"|"set" as func)), a :: other_args -> begin + let assign = func = "set" in + let print = print_indexop a None assign in + match path, other_args with + | Lident "Array", i :: rest -> + print ".(" ")" (expression ctxt) [i] rest + | Lident "String", i :: rest -> + print ".[" "]" (expression ctxt) [i] rest + | Ldot (Lident "Bigarray", "Array1"), i1 :: rest -> + print ".{" "}" (simple_expr ctxt) [i1] rest + | Ldot (Lident "Bigarray", "Array2"), i1 :: i2 :: rest -> + print ".{" "}" (simple_expr ctxt) [i1; i2] rest + | Ldot (Lident "Bigarray", "Array3"), i1 :: i2 :: i3 :: rest -> + print ".{" "}" (simple_expr ctxt) [i1; i2; i3] rest + | Ldot (Lident "Bigarray", "Genarray"), + {pexp_desc = Pexp_array indexes; pexp_attributes = []} :: rest -> + print ".{" "}" (simple_expr ctxt) indexes rest + | _ -> false + end + | (Lident s | Ldot(_,s)) , a :: i :: rest + when s.[0] = '.' -> + let n = String.length s in + (* extract operator: + assignment operators end with [right_bracket ^ "<-"], + access operators end with [right_bracket] directly + *) + let assign = s.[n - 1] = '-' in + let kind = + (* extract the right end bracket *) + if assign then s.[n - 3] else s.[n - 1] in + let left, right = match kind with + | ')' -> '(', ")" + | ']' -> '[', "]" + | '}' -> '{', "}" + | _ -> assert false in + let path_prefix = match id with + | Ldot(m,_) -> Some m + | _ -> None in + let left = String.sub s 0 (1+String.index s left) in + print_indexop a path_prefix assign left right + (expression ctxt) [i] rest + | _ -> false + end + | _ -> false + +and expression ctxt f x = + if x.pexp_attributes <> [] then + pp f "((%a)@,%a)" (expression ctxt) {x with pexp_attributes=[]} + (attributes ctxt) x.pexp_attributes + else match x.pexp_desc with + | Pexp_function _ | Pexp_fun _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _ + when ctxt.pipe || ctxt.semi -> + paren true (expression reset_ctxt) f x + | Pexp_ifthenelse _ | Pexp_sequence _ when ctxt.ifthenelse -> + paren true (expression reset_ctxt) f x + | Pexp_let _ | Pexp_letmodule _ | Pexp_open _ | Pexp_letexception _ + when ctxt.semi -> + paren true (expression reset_ctxt) f x + | Pexp_fun (l, e0, p, e) -> + pp f "@[<2>fun@;%a->@;%a@]" + (label_exp ctxt) (l, e0, p) + (expression ctxt) e + | Pexp_function l -> + pp f "@[function%a@]" (case_list ctxt) l + | Pexp_match (e, l) -> + pp f "@[@[@[<2>match %a@]@ with@]%a@]" + (expression reset_ctxt) e (case_list ctxt) l + + | Pexp_try (e, l) -> + pp f "@[<0>@[try@ %a@]@ @[<0>with%a@]@]" + (* "try@;@[<2>%a@]@\nwith@\n%a"*) + (expression reset_ctxt) e (case_list ctxt) l + | Pexp_let (rf, l, e) -> + (* pp f "@[<2>let %a%a in@;<1 -2>%a@]" + (*no indentation here, a new line*) *) + (* rec_flag rf *) + pp f "@[<2>%a in@;<1 -2>%a@]" + (bindings reset_ctxt) (rf,l) + (expression ctxt) e + | Pexp_apply (e, l) -> + begin if not (sugar_expr ctxt f x) then + match view_fixity_of_exp e with + | `Infix s -> + begin match l with + | [ (Nolabel, _) as arg1; (Nolabel, _) as arg2 ] -> + (* FIXME associativity label_x_expression_param *) + pp f "@[<2>%a@;%s@;%a@]" + (label_x_expression_param reset_ctxt) arg1 s + (label_x_expression_param ctxt) arg2 + | _ -> + pp f "@[<2>%a %a@]" + (simple_expr ctxt) e + (list (label_x_expression_param ctxt)) l + end + | `Prefix s -> + let s = + if List.mem s ["~+";"~-";"~+.";"~-."] && + (match l with + (* See #7200: avoid turning (~- 1) into (- 1) which is + parsed as an int literal *) + |[(_,{pexp_desc=Pexp_constant _})] -> false + | _ -> true) + then String.sub s 1 (String.length s -1) + else s in + begin match l with + | [(Nolabel, x)] -> + pp f "@[<2>%s@;%a@]" s (simple_expr ctxt) x + | _ -> + pp f "@[<2>%a %a@]" (simple_expr ctxt) e + (list (label_x_expression_param ctxt)) l + end + | _ -> + pp f "@[%a@]" begin fun f (e,l) -> + pp f "%a@ %a" (expression2 ctxt) e + (list (label_x_expression_param reset_ctxt)) l + (* reset here only because [function,match,try,sequence] + are lower priority *) + end (e,l) + end + + | Pexp_construct (li, Some eo) + when not (is_simple_construct (view_expr x))-> (* Not efficient FIXME*) + (match view_expr x with + | `cons ls -> list (simple_expr ctxt) f ls ~sep:"@;::@;" + | `normal -> + pp f "@[<2>%a@;%a@]" longident_loc li + (simple_expr ctxt) eo + | _ -> assert false) + | Pexp_setfield (e1, li, e2) -> + pp f "@[<2>%a.%a@ <-@ %a@]" + (simple_expr ctxt) e1 longident_loc li (simple_expr ctxt) e2 + | Pexp_ifthenelse (e1, e2, eo) -> + (* @;@[<2>else@ %a@]@] *) + let fmt:(_,_,_)format ="@[@[<2>if@ %a@]@;@[<2>then@ %a@]%a@]" in + let expression_under_ifthenelse = expression (under_ifthenelse ctxt) in + pp f fmt expression_under_ifthenelse e1 expression_under_ifthenelse e2 + (fun f eo -> match eo with + | Some x -> + pp f "@;@[<2>else@;%a@]" (expression (under_semi ctxt)) x + | None -> () (* pp f "()" *)) eo + | Pexp_sequence _ -> + let rec sequence_helper acc = function + | {pexp_desc=Pexp_sequence(e1,e2); pexp_attributes = []} -> + sequence_helper (e1::acc) e2 + | v -> List.rev (v::acc) in + let lst = sequence_helper [] x in + pp f "@[%a@]" + (list (expression (under_semi ctxt)) ~sep:";@;") lst + | Pexp_new (li) -> + pp f "@[new@ %a@]" longident_loc li; + | Pexp_setinstvar (s, e) -> + pp f "@[%s@ <-@ %a@]" s.txt (expression ctxt) e + | Pexp_override l -> (* FIXME *) + let string_x_expression f (s, e) = + pp f "@[%s@ =@ %a@]" s.txt (expression ctxt) e in + pp f "@[{<%a>}@]" + (list string_x_expression ~sep:";" ) l; + | Pexp_letmodule (s, me, e) -> + pp f "@[let@ module@ %s@ =@ %a@ in@ %a@]" s.txt + (module_expr reset_ctxt) me (expression ctxt) e + | Pexp_letexception (cd, e) -> + pp f "@[let@ exception@ %a@ in@ %a@]" + (extension_constructor ctxt) cd + (expression ctxt) e + | Pexp_assert e -> + pp f "@[assert@ %a@]" (simple_expr ctxt) e + | Pexp_lazy (e) -> + pp f "@[lazy@ %a@]" (simple_expr ctxt) e + (* Pexp_poly: impossible but we should print it anyway, rather than + assert false *) + | Pexp_poly (e, None) -> + pp f "@[!poly!@ %a@]" (simple_expr ctxt) e + | Pexp_poly (e, Some ct) -> + pp f "@[(!poly!@ %a@ : %a)@]" + (simple_expr ctxt) e (core_type ctxt) ct + | Pexp_open (ovf, lid, e) -> + pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid + (expression ctxt) e + | Pexp_variant (l,Some eo) -> + pp f "@[<2>`%s@;%a@]" l (simple_expr ctxt) eo + | Pexp_extension e -> extension ctxt f e + | Pexp_unreachable -> pp f "." + | _ -> expression1 ctxt f x + +and expression1 ctxt f x = + if x.pexp_attributes <> [] then expression ctxt f x + else match x.pexp_desc with + | Pexp_object cs -> pp f "%a" (class_structure ctxt) cs + | _ -> expression2 ctxt f x +(* used in [Pexp_apply] *) + +and expression2 ctxt f x = + if x.pexp_attributes <> [] then expression ctxt f x + else match x.pexp_desc with + | Pexp_field (e, li) -> + pp f "@[%a.%a@]" (simple_expr ctxt) e longident_loc li + | Pexp_send (e, s) -> pp f "@[%a#%s@]" (simple_expr ctxt) e s.txt + + | _ -> simple_expr ctxt f x + +and simple_expr ctxt f x = + if x.pexp_attributes <> [] then expression ctxt f x + else match x.pexp_desc with + | Pexp_construct _ when is_simple_construct (view_expr x) -> + (match view_expr x with + | `nil -> pp f "[]" + | `tuple -> pp f "()" + | `list xs -> + pp f "@[[%a]@]" + (list (expression (under_semi ctxt)) ~sep:";@;") xs + | `simple x -> longident f x + | _ -> assert false) + | Pexp_ident li -> + longident_loc f li + (* (match view_fixity_of_exp x with *) + (* |`Normal -> longident_loc f li *) + (* | `Prefix _ | `Infix _ -> pp f "( %a )" longident_loc li) *) + | Pexp_constant c -> constant f c; + | Pexp_pack me -> + pp f "(module@;%a)" (module_expr ctxt) me + | Pexp_newtype (lid, e) -> + pp f "fun@;(type@;%s)@;->@;%a" lid.txt (expression ctxt) e + | Pexp_tuple l -> + pp f "@[(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l + | Pexp_constraint (e, ct) -> + pp f "(%a : %a)" (expression ctxt) e (core_type ctxt) ct + | Pexp_coerce (e, cto1, ct) -> + pp f "(%a%a :> %a)" (expression ctxt) e + (option (core_type ctxt) ~first:" : " ~last:" ") cto1 (* no sep hint*) + (core_type ctxt) ct + | Pexp_variant (l, None) -> pp f "`%s" l + | Pexp_record (l, eo) -> + let longident_x_expression f ( li, e) = + match e with + | {pexp_desc=Pexp_ident {txt;_}; + pexp_attributes=[]; _} when li.txt = txt -> + pp f "@[%a@]" longident_loc li + | _ -> + pp f "@[%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e + in + pp f "@[@[{@;%a%a@]@;}@]"(* "@[{%a%a}@]" *) + (option ~last:" with@;" (simple_expr ctxt)) eo + (list longident_x_expression ~sep:";@;") l + | Pexp_array (l) -> + pp f "@[<0>@[<2>[|%a|]@]@]" + (list (simple_expr (under_semi ctxt)) ~sep:";") l + | Pexp_while (e1, e2) -> + let fmt : (_,_,_) format = "@[<2>while@;%a@;do@;%a@;done@]" in + pp f fmt (expression ctxt) e1 (expression ctxt) e2 + | Pexp_for (s, e1, e2, df, e3) -> + let fmt:(_,_,_)format = + "@[@[@[<2>for %a =@;%a@;%a%a@;do@]@;%a@]@;done@]" in + let expression = expression ctxt in + pp f fmt (pattern ctxt) s expression e1 direction_flag + df expression e2 expression e3 + | _ -> paren true (expression ctxt) f x + +and attributes ctxt f l = + List.iter (attribute ctxt f) l + +and item_attributes ctxt f l = + List.iter (item_attribute ctxt f) l + +and attribute ctxt f (s, e) = + pp f "@[<2>[@@%s@ %a]@]" s.txt (payload ctxt) e + +and item_attribute ctxt f (s, e) = + pp f "@[<2>[@@@@%s@ %a]@]" s.txt (payload ctxt) e + +and floating_attribute ctxt f (s, e) = + pp f "@[<2>[@@@@@@%s@ %a]@]" s.txt (payload ctxt) e + +and value_description ctxt f x = + (* note: value_description has an attribute field, + but they're already printed by the callers this method *) + pp f "@[%a%a@]" (core_type ctxt) x.pval_type + (fun f x -> + + if x.pval_prim <> [] + then pp f "@ =@ %a" (list constant_string) x.pval_prim + + ) x + +and extension ctxt f (s, e) = + pp f "@[<2>[%%%s@ %a]@]" s.txt (payload ctxt) e + +and item_extension ctxt f (s, e) = + pp f "@[<2>[%%%%%s@ %a]@]" s.txt (payload ctxt) e + +and exception_declaration ctxt f ext = + pp f "@[exception@ %a@]" (extension_constructor ctxt) ext + +and class_signature ctxt f { pcsig_self = ct; pcsig_fields = l ;_} = + let class_type_field f x = + match x.pctf_desc with + | Pctf_inherit (ct) -> + pp f "@[<2>inherit@ %a@]%a" (class_type ctxt) ct + (item_attributes ctxt) x.pctf_attributes + | Pctf_val (s, mf, vf, ct) -> + pp f "@[<2>val @ %a%a%s@ :@ %a@]%a" + mutable_flag mf virtual_flag vf s.txt (core_type ctxt) ct + (item_attributes ctxt) x.pctf_attributes + | Pctf_method (s, pf, vf, ct) -> + pp f "@[<2>method %a %a%s :@;%a@]%a" + private_flag pf virtual_flag vf s.txt (core_type ctxt) ct + (item_attributes ctxt) x.pctf_attributes + | Pctf_constraint (ct1, ct2) -> + pp f "@[<2>constraint@ %a@ =@ %a@]%a" + (core_type ctxt) ct1 (core_type ctxt) ct2 + (item_attributes ctxt) x.pctf_attributes + | Pctf_attribute a -> floating_attribute ctxt f a + | Pctf_extension e -> + item_extension ctxt f e; + item_attributes ctxt f x.pctf_attributes + in + pp f "@[@[object@[<1>%a@]@ %a@]@ end@]" + (fun f -> function + {ptyp_desc=Ptyp_any; ptyp_attributes=[]; _} -> () + | ct -> pp f " (%a)" (core_type ctxt) ct) ct + (list class_type_field ~sep:"@;") l + +(* call [class_signature] called by [class_signature] *) +and class_type ctxt f x = + match x.pcty_desc with + | Pcty_signature cs -> + class_signature ctxt f cs; + attributes ctxt f x.pcty_attributes + | Pcty_constr (li, l) -> + pp f "%a%a%a" + (fun f l -> match l with + | [] -> () + | _ -> pp f "[%a]@ " (list (core_type ctxt) ~sep:"," ) l) l + longident_loc li + (attributes ctxt) x.pcty_attributes + | Pcty_arrow (l, co, cl) -> + pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) + (type_with_label ctxt) (l,co) + (class_type ctxt) cl + | Pcty_extension e -> + extension ctxt f e; + attributes ctxt f x.pcty_attributes + | Pcty_open (ovf, lid, e) -> + pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid + (class_type ctxt) e + +(* [class type a = object end] *) +and class_type_declaration_list ctxt f l = + let class_type_declaration kwd f x = + let { pci_params=ls; pci_name={ txt; _ }; _ } = x in + pp f "@[<2>%s %a%a%s@ =@ %a@]%a" kwd + virtual_flag x.pci_virt + (class_params_def ctxt) ls txt + (class_type ctxt) x.pci_expr + (item_attributes ctxt) x.pci_attributes + in + match l with + | [] -> () + | [x] -> class_type_declaration "class type" f x + | x :: xs -> + pp f "@[%a@,%a@]" + (class_type_declaration "class type") x + (list ~sep:"@," (class_type_declaration "and")) xs + +and class_field ctxt f x = + match x.pcf_desc with + | Pcf_inherit () -> () + | Pcf_val (s, mf, Cfk_concrete (ovf, e)) -> + pp f "@[<2>val%s %a%s =@;%a@]%a" (override ovf) + mutable_flag mf s.txt + (expression ctxt) e + (item_attributes ctxt) x.pcf_attributes + | Pcf_method (s, pf, Cfk_virtual ct) -> + pp f "@[<2>method virtual %a %s :@;%a@]%a" + private_flag pf s.txt + (core_type ctxt) ct + (item_attributes ctxt) x.pcf_attributes + | Pcf_val (s, mf, Cfk_virtual ct) -> + pp f "@[<2>val virtual %a%s :@ %a@]%a" + mutable_flag mf s.txt + (core_type ctxt) ct + (item_attributes ctxt) x.pcf_attributes + | Pcf_method (s, pf, Cfk_concrete (ovf, e)) -> + let bind e = + binding ctxt f + {pvb_pat= + {ppat_desc=Ppat_var s;ppat_loc=Location.none;ppat_attributes=[]}; + pvb_expr=e; + pvb_attributes=[]; + pvb_loc=Location.none; + } + in + pp f "@[<2>method%s %a%a@]%a" + (override ovf) + private_flag pf + (fun f -> function + | {pexp_desc=Pexp_poly (e, Some ct); pexp_attributes=[]; _} -> + pp f "%s :@;%a=@;%a" + s.txt (core_type ctxt) ct (expression ctxt) e + | {pexp_desc=Pexp_poly (e, None); pexp_attributes=[]; _} -> + bind e + | _ -> bind e) e + (item_attributes ctxt) x.pcf_attributes + | Pcf_constraint (ct1, ct2) -> + pp f "@[<2>constraint %a =@;%a@]%a" + (core_type ctxt) ct1 + (core_type ctxt) ct2 + (item_attributes ctxt) x.pcf_attributes + | Pcf_initializer (e) -> + pp f "@[<2>initializer@ %a@]%a" + (expression ctxt) e + (item_attributes ctxt) x.pcf_attributes + | Pcf_attribute a -> floating_attribute ctxt f a + | Pcf_extension e -> + item_extension ctxt f e; + item_attributes ctxt f x.pcf_attributes + +and class_structure ctxt f { pcstr_self = p; pcstr_fields = l } = + pp f "@[@[object%a@;%a@]@;end@]" + (fun f p -> match p.ppat_desc with + | Ppat_any -> () + | Ppat_constraint _ -> pp f " %a" (pattern ctxt) p + | _ -> pp f " (%a)" (pattern ctxt) p) p + (list (class_field ctxt)) l + +and module_type ctxt f x = + if x.pmty_attributes <> [] then begin + pp f "((%a)%a)" (module_type ctxt) {x with pmty_attributes=[]} + (attributes ctxt) x.pmty_attributes + end else + match x.pmty_desc with + | Pmty_ident li -> + pp f "%a" longident_loc li; + | Pmty_alias li -> + pp f "(module %a)" longident_loc li; + | Pmty_signature (s) -> + pp f "@[@[sig@ %a@]@ end@]" (* "@[sig@ %a@ end@]" *) + (list (signature_item ctxt)) s (* FIXME wrong indentation*) + | Pmty_functor (_, None, mt2) -> + pp f "@[functor () ->@ %a@]" (module_type ctxt) mt2 + | Pmty_functor (s, Some mt1, mt2) -> + if s.txt = "_" then + pp f "@[%a@ ->@ %a@]" + (module_type ctxt) mt1 (module_type ctxt) mt2 + else + pp f "@[functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt + (module_type ctxt) mt1 (module_type ctxt) mt2 + | Pmty_with (mt, l) -> + let with_constraint f = function + | Pwith_type (li, ({ptype_params= ls ;_} as td)) -> + let ls = List.map fst ls in + pp f "type@ %a %a =@ %a" + (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") + ls longident_loc li (type_declaration ctxt) td + | Pwith_module (li, li2) -> + pp f "module %a =@ %a" longident_loc li longident_loc li2; + | Pwith_typesubst (li, ({ptype_params=ls;_} as td)) -> + let ls = List.map fst ls in + pp f "type@ %a %a :=@ %a" + (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") + ls longident_loc li + (type_declaration ctxt) td + | Pwith_modsubst (li, li2) -> + pp f "module %a :=@ %a" longident_loc li longident_loc li2 in + (match l with + | [] -> pp f "@[%a@]" (module_type ctxt) mt + | _ -> pp f "@[(%a@ with@ %a)@]" + (module_type ctxt) mt (list with_constraint ~sep:"@ and@ ") l) + | Pmty_typeof me -> + pp f "@[module@ type@ of@ %a@]" (module_expr ctxt) me + | Pmty_extension e -> extension ctxt f e + +and signature ctxt f x = list ~sep:"@\n" (signature_item ctxt) f x + +and signature_item ctxt f x : unit = + match x.psig_desc with + | Psig_type (rf, l) -> + type_def_list ctxt f (rf, l) + | Psig_value vd -> + let intro = if vd.pval_prim = [] then "val" else "external" in + pp f "@[<2>%s@ %a@ :@ %a@]%a" intro + protect_ident vd.pval_name.txt + (value_description ctxt) vd + (item_attributes ctxt) vd.pval_attributes + | Psig_typext te -> + type_extension ctxt f te + | Psig_exception ed -> + exception_declaration ctxt f ed + | Psig_class () -> + () + | Psig_module ({pmd_type={pmty_desc=Pmty_alias alias; + pmty_attributes=[]; _};_} as pmd) -> + pp f "@[module@ %s@ =@ %a@]%a" pmd.pmd_name.txt + longident_loc alias + (item_attributes ctxt) pmd.pmd_attributes + | Psig_module pmd -> + pp f "@[module@ %s@ :@ %a@]%a" + pmd.pmd_name.txt + (module_type ctxt) pmd.pmd_type + (item_attributes ctxt) pmd.pmd_attributes + | Psig_open od -> + pp f "@[open%s@ %a@]%a" + (override od.popen_override) + longident_loc od.popen_lid + (item_attributes ctxt) od.popen_attributes + | Psig_include incl -> + pp f "@[include@ %a@]%a" + (module_type ctxt) incl.pincl_mod + (item_attributes ctxt) incl.pincl_attributes + | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> + pp f "@[module@ type@ %s%a@]%a" + s.txt + (fun f md -> match md with + | None -> () + | Some mt -> + pp_print_space f () ; + pp f "@ =@ %a" (module_type ctxt) mt + ) md + (item_attributes ctxt) attrs + | Psig_class_type (l) -> class_type_declaration_list ctxt f l + | Psig_recmodule decls -> + let rec string_x_module_type_list f ?(first=true) l = + match l with + | [] -> () ; + | pmd :: tl -> + if not first then + pp f "@ @[and@ %s:@ %a@]%a" pmd.pmd_name.txt + (module_type ctxt) pmd.pmd_type + (item_attributes ctxt) pmd.pmd_attributes + else + pp f "@[module@ rec@ %s:@ %a@]%a" pmd.pmd_name.txt + (module_type ctxt) pmd.pmd_type + (item_attributes ctxt) pmd.pmd_attributes; + string_x_module_type_list f ~first:false tl + in + string_x_module_type_list f decls + | Psig_attribute a -> floating_attribute ctxt f a + | Psig_extension(e, a) -> + item_extension ctxt f e; + item_attributes ctxt f a + +and module_expr ctxt f x = + if x.pmod_attributes <> [] then + pp f "((%a)%a)" (module_expr ctxt) {x with pmod_attributes=[]} + (attributes ctxt) x.pmod_attributes + else match x.pmod_desc with + | Pmod_structure (s) -> + pp f "@[struct@;@[<0>%a@]@;<1 -2>end@]" + (list (structure_item ctxt) ~sep:"@\n") s; + | Pmod_constraint (me, mt) -> + pp f "@[(%a@ :@ %a)@]" + (module_expr ctxt) me + (module_type ctxt) mt + | Pmod_ident (li) -> + pp f "%a" longident_loc li; + | Pmod_functor (_, None, me) -> + pp f "functor ()@;->@;%a" (module_expr ctxt) me + | Pmod_functor (s, Some mt, me) -> + pp f "functor@ (%s@ :@ %a)@;->@;%a" + s.txt (module_type ctxt) mt (module_expr ctxt) me + | Pmod_apply (me1, me2) -> + pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2 + (* Cf: #7200 *) + | Pmod_unpack e -> + pp f "(val@ %a)" (expression ctxt) e + | Pmod_extension e -> extension ctxt f e + +and structure ctxt f x = list ~sep:"@\n" (structure_item ctxt) f x + +and payload ctxt f = function + | PStr [{pstr_desc = Pstr_eval (e, attrs)}] -> + pp f "@[<2>%a@]%a" + (expression ctxt) e + (item_attributes ctxt) attrs + | PStr x -> structure ctxt f x + | PTyp x -> pp f ":"; core_type ctxt f x + | PSig x -> pp f ":"; signature ctxt f x + | PPat (x, None) -> pp f "?"; pattern ctxt f x + | PPat (x, Some e) -> + pp f "?"; pattern ctxt f x; + pp f " when "; expression ctxt f e + +(* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *) +and binding ctxt f {pvb_pat=p; pvb_expr=x; _} = + (* .pvb_attributes have already been printed by the caller, #bindings *) + let rec pp_print_pexp_function f x = + if x.pexp_attributes <> [] then pp f "=@;%a" (expression ctxt) x + else match x.pexp_desc with + | Pexp_fun (label, eo, p, e) -> + if label=Nolabel then + pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function e + else + pp f "%a@ %a" + (label_exp ctxt) (label,eo,p) pp_print_pexp_function e + | Pexp_newtype (str,e) -> + pp f "(type@ %s)@ %a" str.txt pp_print_pexp_function e + | _ -> pp f "=@;%a" (expression ctxt) x + in + let tyvars_str tyvars = List.map (fun v -> v.txt) tyvars in + let is_desugared_gadt p e = + let gadt_pattern = + match p with + | {ppat_desc=Ppat_constraint({ppat_desc=Ppat_var _} as pat, + {ptyp_desc=Ptyp_poly (args_tyvars, rt)}); + ppat_attributes=[]}-> + Some (pat, args_tyvars, rt) + | _ -> None in + let rec gadt_exp tyvars e = + match e with + | {pexp_desc=Pexp_newtype (tyvar, e); pexp_attributes=[]} -> + gadt_exp (tyvar :: tyvars) e + | {pexp_desc=Pexp_constraint (e, ct); pexp_attributes=[]} -> + Some (List.rev tyvars, e, ct) + | _ -> None in + let gadt_exp = gadt_exp [] e in + match gadt_pattern, gadt_exp with + | Some (p, pt_tyvars, pt_ct), Some (e_tyvars, e, e_ct) + when tyvars_str pt_tyvars = tyvars_str e_tyvars -> + let ety = Typ.varify_constructors e_tyvars e_ct in + if ety = pt_ct then + Some (p, pt_tyvars, e_ct, e) else None + | _ -> None in + if x.pexp_attributes <> [] + then pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x else + match is_desugared_gadt p x with + | Some (p, [], ct, e) -> + pp f "%a@;: %a@;=@;%a" + (simple_pattern ctxt) p (core_type ctxt) ct (expression ctxt) e + | Some (p, tyvars, ct, e) -> begin + pp f "%a@;: type@;%a.@;%a@;=@;%a" + (simple_pattern ctxt) p (list pp_print_string ~sep:"@;") + (tyvars_str tyvars) (core_type ctxt) ct (expression ctxt) e + end + | None -> begin + match p with + | {ppat_desc=Ppat_constraint(p ,ty); + ppat_attributes=[]} -> (* special case for the first*) + begin match ty with + | {ptyp_desc=Ptyp_poly _; ptyp_attributes=[]} -> + pp f "%a@;:@;%a@;=@;%a" (simple_pattern ctxt) p + (core_type ctxt) ty (expression ctxt) x + | _ -> + pp f "(%a@;:@;%a)@;=@;%a" (simple_pattern ctxt) p + (core_type ctxt) ty (expression ctxt) x + end + | {ppat_desc=Ppat_var _; ppat_attributes=[]} -> + pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x + | _ -> + pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x + end + +(* [in] is not printed *) +and bindings ctxt f (rf,l) = + let binding kwd rf f x = + pp f "@[<2>%s %a%a@]%a" kwd rec_flag rf + (binding ctxt) x (item_attributes ctxt) x.pvb_attributes + in + match l with + | [] -> () + | [x] -> binding "let" rf f x + | x::xs -> + pp f "@[%a@,%a@]" + (binding "let" rf) x + (list ~sep:"@," (binding "and" Nonrecursive)) xs + +and structure_item ctxt f x = + match x.pstr_desc with + | Pstr_eval (e, attrs) -> + pp f "@[;;%a@]%a" + (expression ctxt) e + (item_attributes ctxt) attrs + | Pstr_type (_, []) -> assert false + | Pstr_type (rf, l) -> type_def_list ctxt f (rf, l) + | Pstr_value (rf, l) -> + (* pp f "@[let %a%a@]" rec_flag rf bindings l *) + pp f "@[<2>%a@]" (bindings ctxt) (rf,l) + | Pstr_typext te -> type_extension ctxt f te + | Pstr_exception ed -> exception_declaration ctxt f ed + | Pstr_module x -> + let rec module_helper = function + | {pmod_desc=Pmod_functor(s,mt,me'); pmod_attributes = []} -> + if mt = None then pp f "()" + else Misc.may (pp f "(%s:%a)" s.txt (module_type ctxt)) mt; + module_helper me' + | me -> me + in + pp f "@[module %s%a@]%a" + x.pmb_name.txt + (fun f me -> + let me = module_helper me in + match me with + | {pmod_desc= + Pmod_constraint + (me', + ({pmty_desc=(Pmty_ident (_) + | Pmty_signature (_));_} as mt)); + pmod_attributes = []} -> + pp f " :@;%a@;=@;%a@;" + (module_type ctxt) mt (module_expr ctxt) me' + | _ -> pp f " =@ %a" (module_expr ctxt) me + ) x.pmb_expr + (item_attributes ctxt) x.pmb_attributes + | Pstr_open od -> + pp f "@[<2>open%s@;%a@]%a" + (override od.popen_override) + longident_loc od.popen_lid + (item_attributes ctxt) od.popen_attributes + | Pstr_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> + pp f "@[module@ type@ %s%a@]%a" + s.txt + (fun f md -> match md with + | None -> () + | Some mt -> + pp_print_space f () ; + pp f "@ =@ %a" (module_type ctxt) mt + ) md + (item_attributes ctxt) attrs + | Pstr_class () -> () + | Pstr_class_type l -> class_type_declaration_list ctxt f l + | Pstr_primitive vd -> + pp f "@[external@ %a@ :@ %a@]%a" + protect_ident vd.pval_name.txt + (value_description ctxt) vd + (item_attributes ctxt) vd.pval_attributes + | Pstr_include incl -> + pp f "@[include@ %a@]%a" + (module_expr ctxt) incl.pincl_mod + (item_attributes ctxt) incl.pincl_attributes + | Pstr_recmodule decls -> (* 3.07 *) + let aux f = function + | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) -> + pp f "@[@ and@ %s:%a@ =@ %a@]%a" pmb.pmb_name.txt + (module_type ctxt) typ + (module_expr ctxt) expr + (item_attributes ctxt) pmb.pmb_attributes + | _ -> assert false + in + begin match decls with + | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 -> + pp f "@[@[module@ rec@ %s:%a@ =@ %a@]%a@ %a@]" + pmb.pmb_name.txt + (module_type ctxt) typ + (module_expr ctxt) expr + (item_attributes ctxt) pmb.pmb_attributes + (fun f l2 -> List.iter (aux f) l2) l2 + | _ -> assert false + end + | Pstr_attribute a -> floating_attribute ctxt f a + | Pstr_extension(e, a) -> + item_extension ctxt f e; + item_attributes ctxt f a + +and type_param ctxt f (ct, a) = + pp f "%s%a" (type_variance a) (core_type ctxt) ct + +and type_params ctxt f = function + | [] -> () + | l -> pp f "%a " (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",@;") l + +and type_def_list ctxt f (rf, l) = + let type_decl kwd rf f x = + let eq = + if (x.ptype_kind = Ptype_abstract) + && (x.ptype_manifest = None) then "" + else " =" + in + pp f "@[<2>%s %a%a%s%s%a@]%a" kwd + nonrec_flag rf + (type_params ctxt) x.ptype_params + x.ptype_name.txt eq + (type_declaration ctxt) x + (item_attributes ctxt) x.ptype_attributes + in + match l with + | [] -> assert false + | [x] -> type_decl "type" rf f x + | x :: xs -> pp f "@[%a@,%a@]" + (type_decl "type" rf) x + (list ~sep:"@," (type_decl "and" Recursive)) xs + +and record_declaration ctxt f lbls = + let type_record_field f pld = + pp f "@[<2>%a%s:@;%a@;%a@]" + mutable_flag pld.pld_mutable + pld.pld_name.txt + (core_type ctxt) pld.pld_type + (attributes ctxt) pld.pld_attributes + in + pp f "{@\n%a}" + (list type_record_field ~sep:";@\n" ) lbls + +and type_declaration ctxt f x = + (* type_declaration has an attribute field, + but it's been printed by the caller of this method *) + let priv f = + match x.ptype_private with + | Public -> () + | Private -> pp f "@;private" + in + let manifest f = + match x.ptype_manifest with + | None -> () + | Some y -> + if x.ptype_kind = Ptype_abstract then + pp f "%t@;%a" priv (core_type ctxt) y + else + pp f "@;%a" (core_type ctxt) y + in + let constructor_declaration f pcd = + pp f "|@;"; + constructor_declaration ctxt f + (pcd.pcd_name.txt, pcd.pcd_args, pcd.pcd_res, pcd.pcd_attributes) + in + let repr f = + let intro f = + if x.ptype_manifest = None then () + else pp f "@;=" + in + match x.ptype_kind with + | Ptype_variant xs -> + pp f "%t%t@\n%a" intro priv + (list ~sep:"@\n" constructor_declaration) xs + | Ptype_abstract -> () + | Ptype_record l -> + pp f "%t%t@;%a" intro priv (record_declaration ctxt) l + | Ptype_open -> pp f "%t%t@;.." intro priv + in + let constraints f = + List.iter + (fun (ct1,ct2,_) -> + pp f "@[@ constraint@ %a@ =@ %a@]" + (core_type ctxt) ct1 (core_type ctxt) ct2) + x.ptype_cstrs + in + pp f "%t%t%t" manifest repr constraints + +and type_extension ctxt f x = + let extension_constructor f x = + pp f "@\n|@;%a" (extension_constructor ctxt) x + in + pp f "@[<2>type %a%a += %a@ %a@]%a" + (fun f -> function + | [] -> () + | l -> + pp f "%a@;" (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",") l) + x.ptyext_params + longident_loc x.ptyext_path + private_flag x.ptyext_private (* Cf: #7200 *) + (list ~sep:"" extension_constructor) + x.ptyext_constructors + (item_attributes ctxt) x.ptyext_attributes + +and constructor_declaration ctxt f (name, args, res, attrs) = + let name = + match name with + | "::" -> "(::)" + | s -> s in + match res with + | None -> + pp f "%s%a@;%a" name + (fun f -> function + | Pcstr_tuple [] -> () + | Pcstr_tuple l -> + pp f "@;of@;%a" (list (core_type1 ctxt) ~sep:"@;*@;") l + | Pcstr_record l -> pp f "@;of@;%a" (record_declaration ctxt) l + ) args + (attributes ctxt) attrs + | Some r -> + pp f "%s:@;%a@;%a" name + (fun f -> function + | Pcstr_tuple [] -> core_type1 ctxt f r + | Pcstr_tuple l -> pp f "%a@;->@;%a" + (list (core_type1 ctxt) ~sep:"@;*@;") l + (core_type1 ctxt) r + | Pcstr_record l -> + pp f "%a@;->@;%a" (record_declaration ctxt) l (core_type1 ctxt) r + ) + args + (attributes ctxt) attrs + +and extension_constructor ctxt f x = + (* Cf: #7200 *) + match x.pext_kind with + | Pext_decl(l, r) -> + constructor_declaration ctxt f (x.pext_name.txt, l, r, x.pext_attributes) + | Pext_rebind li -> + pp f "%s%a@;=@;%a" x.pext_name.txt + (attributes ctxt) x.pext_attributes + longident_loc li + +and case_list ctxt f l : unit = + let aux f {pc_lhs; pc_guard; pc_rhs} = + pp f "@;| @[<2>%a%a@;->@;%a@]" + (pattern ctxt) pc_lhs (option (expression ctxt) ~first:"@;when@;") + pc_guard (expression (under_pipe ctxt)) pc_rhs + in + list aux f l ~sep:"" + +and label_x_expression_param ctxt f (l,e) = + let simple_name = match e with + | {pexp_desc=Pexp_ident {txt=Lident l;_}; + pexp_attributes=[]} -> Some l + | _ -> None + in match l with + | Nolabel -> expression2 ctxt f e (* level 2*) + | Optional str -> + if Some str = simple_name then + pp f "?%s" str + else + pp f "?%s:%a" str (simple_expr ctxt) e + | Labelled lbl -> + if Some lbl = simple_name then + pp f "~%s" lbl + else + pp f "~%s:%a" lbl (simple_expr ctxt) e + + + +let expression f x = + pp f "@[%a@]" (expression reset_ctxt) x + +let string_of_expression x = + ignore (flush_str_formatter ()) ; + let f = str_formatter in + expression f x; + flush_str_formatter () + +let string_of_structure x = + ignore (flush_str_formatter ()); + let f = str_formatter in + structure reset_ctxt f x; + flush_str_formatter () + + +let core_type = core_type reset_ctxt +let pattern = pattern reset_ctxt +let signature = signature reset_ctxt +let structure = structure reset_ctxt + end module TypedtreeIter : sig #1 "typedtreeIter.mli" @@ -26838,7 +28309,7 @@ let is_cons = function let pretty_const c = match c with | Const_int i -> Printf.sprintf "%d" i -| Const_char i -> Printf.sprintf "%C" (Char.unsafe_chr i) +| Const_char i -> Printf.sprintf "%s" (Pprintast.string_of_int_as_char i) | Const_string (s, _) -> Printf.sprintf "%S" s | Const_float f -> Printf.sprintf "%s" f | Const_int32 i -> Printf.sprintf "%ldl" i @@ -29129,7 +30600,7 @@ open Lambda let rec struct_const ppf = function | Const_base(Const_int n) -> fprintf ppf "%i" n - | Const_base(Const_char i) -> fprintf ppf "%C" (Char.unsafe_chr i) + | Const_base(Const_char i) -> fprintf ppf "%s" (Pprintast.string_of_int_as_char i) | Const_base(Const_string (s, _)) -> fprintf ppf "%S" s | Const_immstring s -> fprintf ppf "#%S" s | Const_base(Const_float f) -> fprintf ppf "%s" f @@ -51872,20 +53343,18 @@ let printConstant ?(templateLiteral = false) c = | Pconst_float (s, _) -> Doc.text s | Pconst_char c -> let str = - if c <= 127 then - match Char.chr c with - | '\'' -> "\\'" - | '\\' -> "\\\\" - | '\n' -> "\\n" - | '\t' -> "\\t" - | '\r' -> "\\r" - | '\b' -> "\\b" - | ' ' .. '~' as c -> - let s = (Bytes.create [@doesNotRaise]) 1 in - Bytes.unsafe_set s 0 c; - Bytes.unsafe_to_string s - | _ -> Res_utf8.encodeCodePoint c - else Res_utf8.encodeCodePoint c + match Char.unsafe_chr c with + | '\'' -> "\\'" + | '\\' -> "\\\\" + | '\n' -> "\\n" + | '\t' -> "\\t" + | '\r' -> "\\r" + | '\b' -> "\\b" + | ' ' .. '~' as c -> + let s = (Bytes.create [@doesNotRaise]) 1 in + Bytes.unsafe_set s 0 c; + Bytes.unsafe_to_string s + | _ -> Res_utf8.encodeCodePoint c in Doc.text ("'" ^ str ^ "'") @@ -79893,7 +81362,7 @@ and expression_desc cxt ~(level : int) f x : cxt = match v with | Float { f } -> Js_number.caml_float_literal_to_js_string f (* attach string here for float constant folding?*) - | Int { i; c = Some c } -> Format.asprintf "/* %C */%ld" (Char.unsafe_chr c) i + | Int { i; c = Some c } -> Format.asprintf "/* %s */%ld" (Pprintast.string_of_int_as_char c) i | Int { i; c = None } -> Int32.to_string i (* check , js convention with ocaml lexical convention *) @@ -92315,6 +93784,13 @@ end = struct open Format open Asttypes +let string_of_int_as_char i = + if i >= 0 && i <= 255 + then + Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) + else + Printf.sprintf "\'\\%d\'" i + let rec struct_const ppf (cst : Lam_constant.t) = match cst with | Const_js_true -> fprintf ppf "#true" @@ -92323,7 +93799,7 @@ let rec struct_const ppf (cst : Lam_constant.t) = | Const_module_alias -> fprintf ppf "#alias" | Const_js_undefined -> fprintf ppf "#undefined" | Const_int { i } -> fprintf ppf "%ld" i - | Const_char c -> fprintf ppf "%C" (Char.unsafe_chr c) + | Const_char i -> fprintf ppf "%s" (string_of_int_as_char i) | Const_string { s } -> fprintf ppf "%S" s | Const_float f -> fprintf ppf "%s" f | Const_int64 n -> fprintf ppf "%LiL" n diff --git a/lib/4.06.1/unstable/js_compiler.ml.d b/lib/4.06.1/unstable/js_compiler.ml.d index d9c1e6e21b..a16f0b5d82 100644 --- a/lib/4.06.1/unstable/js_compiler.ml.d +++ b/lib/4.06.1/unstable/js_compiler.ml.d @@ -513,6 +513,8 @@ ../lib/4.06.1/unstable/js_compiler.ml: ./ml/parsetree.ml ../lib/4.06.1/unstable/js_compiler.ml: ./ml/path.ml ../lib/4.06.1/unstable/js_compiler.ml: ./ml/path.mli +../lib/4.06.1/unstable/js_compiler.ml: ./ml/pprintast.mli +../lib/4.06.1/unstable/js_compiler.ml: ./ml/pprintast.pp.ml ../lib/4.06.1/unstable/js_compiler.ml: ./ml/predef.ml ../lib/4.06.1/unstable/js_compiler.ml: ./ml/predef.mli ../lib/4.06.1/unstable/js_compiler.ml: ./ml/primitive.ml diff --git a/lib/4.06.1/unstable/js_playground_compiler.ml b/lib/4.06.1/unstable/js_playground_compiler.ml index 8a20e21b01..eb9d0122d8 100644 --- a/lib/4.06.1/unstable/js_playground_compiler.ml +++ b/lib/4.06.1/unstable/js_playground_compiler.ml @@ -24864,15 +24864,15 @@ let reset () = raise_count := 0 end -module TypedtreeIter : sig -#1 "typedtreeIter.mli" +module Pprintast : sig +#1 "pprintast.mli" (**************************************************************************) (* *) (* OCaml *) (* *) -(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) +(* Hongbo Zhang (University of Pennsylvania) *) (* *) -(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. *) (* *) (* All rights reserved. This file is distributed under the terms of *) @@ -24881,87 +24881,28 @@ module TypedtreeIter : sig (* *) (**************************************************************************) -open Asttypes -open Typedtree - - -module type IteratorArgument = sig - val enter_structure : structure -> unit - val enter_value_description : value_description -> unit - val enter_type_extension : type_extension -> unit - val enter_extension_constructor : extension_constructor -> unit - val enter_pattern : pattern -> unit - val enter_expression : expression -> unit - val enter_package_type : package_type -> unit - val enter_signature : signature -> unit - val enter_signature_item : signature_item -> unit - val enter_module_type_declaration : module_type_declaration -> unit - val enter_module_type : module_type -> unit - val enter_module_expr : module_expr -> unit - val enter_with_constraint : with_constraint -> unit - val enter_class_signature : class_signature -> unit - val enter_class_description : class_description -> unit - val enter_class_type_declaration : class_type_declaration -> unit - val enter_class_type : class_type -> unit - val enter_class_type_field : class_type_field -> unit - val enter_core_type : core_type -> unit - val enter_structure_item : structure_item -> unit - - - val leave_structure : structure -> unit - val leave_value_description : value_description -> unit - val leave_type_extension : type_extension -> unit - val leave_extension_constructor : extension_constructor -> unit - val leave_pattern : pattern -> unit - val leave_expression : expression -> unit - val leave_package_type : package_type -> unit - val leave_signature : signature -> unit - val leave_signature_item : signature_item -> unit - val leave_module_type_declaration : module_type_declaration -> unit - val leave_module_type : module_type -> unit - val leave_module_expr : module_expr -> unit - val leave_with_constraint : with_constraint -> unit - val leave_class_signature : class_signature -> unit - val leave_class_description : class_description -> unit - val leave_class_type_declaration : class_type_declaration -> unit - val leave_class_type : class_type -> unit - val leave_class_type_field : class_type_field -> unit - val leave_core_type : core_type -> unit - val leave_structure_item : structure_item -> unit - - val enter_bindings : rec_flag -> unit - val enter_binding : value_binding -> unit - val leave_binding : value_binding -> unit - val leave_bindings : rec_flag -> unit - - val enter_type_declarations : rec_flag -> unit - val enter_type_declaration : type_declaration -> unit - val leave_type_declaration : type_declaration -> unit - val leave_type_declarations : rec_flag -> unit +type space_formatter = (unit, Format.formatter, unit) format -end -module [@warning "-67"] MakeIterator : - functor (Iter : IteratorArgument) -> - sig - val iter_structure : structure -> unit - val iter_signature : signature -> unit - val iter_structure_item : structure_item -> unit - val iter_signature_item : signature_item -> unit - val iter_expression : expression -> unit - val iter_module_type : module_type -> unit - val iter_pattern : pattern -> unit - end +val expression : Format.formatter -> Parsetree.expression -> unit +val string_of_expression : Parsetree.expression -> string -module DefaultIteratorArgument : IteratorArgument +val core_type: Format.formatter -> Parsetree.core_type -> unit +val pattern: Format.formatter -> Parsetree.pattern -> unit +val signature: Format.formatter -> Parsetree.signature -> unit +val structure: Format.formatter -> Parsetree.structure -> unit +val string_of_structure: Parsetree.structure -> string +val string_of_int_as_char: int -> string end = struct -#1 "typedtreeIter.ml" +#1 "pprintast.pp.ml" (**************************************************************************) (* *) (* OCaml *) (* *) -(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) +(* Thomas Gazagnaire, OCamlPro *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* Hongbo Zhang, University of Pennsylvania *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. *) @@ -24972,666 +24913,1430 @@ end = struct (* *) (**************************************************************************) -(* -TODO: - - 2012/05/10: Follow camlp4 way of building map and iter using classes - and inheritance ? -*) +(* Original Code from Ber-metaocaml, modified for 3.12.0 and fixed *) +(* Printing code expressions *) +(* Authors: Ed Pizzi, Fabrice Le Fessant *) +(* Extensive Rewrite: Hongbo Zhang: University of Pennsylvania *) +(* TODO more fine-grained precedence pretty-printing *) open Asttypes -open Typedtree - -module type IteratorArgument = sig +open Format +open Location +open Longident +open Parsetree +open Ast_helper - val enter_structure : structure -> unit - val enter_value_description : value_description -> unit - val enter_type_extension : type_extension -> unit - val enter_extension_constructor : extension_constructor -> unit - val enter_pattern : pattern -> unit - val enter_expression : expression -> unit - val enter_package_type : package_type -> unit - val enter_signature : signature -> unit - val enter_signature_item : signature_item -> unit - val enter_module_type_declaration : module_type_declaration -> unit - val enter_module_type : module_type -> unit - val enter_module_expr : module_expr -> unit - val enter_with_constraint : with_constraint -> unit - val enter_class_signature : class_signature -> unit +let prefix_symbols = [ '!'; '?'; '~' ] ;; +let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/'; + '$'; '%'; '#' ] - val enter_class_description : class_description -> unit - val enter_class_type_declaration : class_type_declaration -> unit - val enter_class_type : class_type -> unit - val enter_class_type_field : class_type_field -> unit - val enter_core_type : core_type -> unit - val enter_structure_item : structure_item -> unit +(* type fixity = Infix| Prefix *) +let special_infix_strings = + ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!="; "::" ] +(* determines if the string is an infix string. + checks backwards, first allowing a renaming postfix ("_102") which + may have resulted from Pexp -> Texp -> Pexp translation, then checking + if all the characters in the beginning of the string are valid infix + characters. *) +let fixity_of_string = function + | s when List.mem s special_infix_strings -> `Infix s + | s when List.mem s.[0] infix_symbols -> `Infix s + | s when List.mem s.[0] prefix_symbols -> `Prefix s + | s when s.[0] = '.' -> `Mixfix s + | _ -> `Normal - val leave_structure : structure -> unit - val leave_value_description : value_description -> unit - val leave_type_extension : type_extension -> unit - val leave_extension_constructor : extension_constructor -> unit - val leave_pattern : pattern -> unit - val leave_expression : expression -> unit - val leave_package_type : package_type -> unit - val leave_signature : signature -> unit - val leave_signature_item : signature_item -> unit - val leave_module_type_declaration : module_type_declaration -> unit - val leave_module_type : module_type -> unit - val leave_module_expr : module_expr -> unit - val leave_with_constraint : with_constraint -> unit - val leave_class_signature : class_signature -> unit +let view_fixity_of_exp = function + | {pexp_desc = Pexp_ident {txt=Lident l;_}; pexp_attributes = []} -> + fixity_of_string l + | _ -> `Normal - val leave_class_description : class_description -> unit - val leave_class_type_declaration : class_type_declaration -> unit - val leave_class_type : class_type -> unit - val leave_class_type_field : class_type_field -> unit - val leave_core_type : core_type -> unit - val leave_structure_item : structure_item -> unit +let is_infix = function | `Infix _ -> true | _ -> false +let is_mixfix = function `Mixfix _ -> true | _ -> false - val enter_bindings : rec_flag -> unit - val enter_binding : value_binding -> unit - val leave_binding : value_binding -> unit - val leave_bindings : rec_flag -> unit +(* which identifiers are in fact operators needing parentheses *) +let needs_parens txt = + let fix = fixity_of_string txt in + is_infix fix + || is_mixfix fix + || List.mem txt.[0] prefix_symbols - val enter_type_declarations : rec_flag -> unit - val enter_type_declaration : type_declaration -> unit - val leave_type_declaration : type_declaration -> unit - val leave_type_declarations : rec_flag -> unit +(* some infixes need spaces around parens to avoid clashes with comment + syntax *) +let needs_spaces txt = + txt.[0]='*' || txt.[String.length txt - 1] = '*' - end +(* add parentheses to binders when they are in fact infix or prefix operators *) +let protect_ident ppf txt = + let format : (_, _, _) format = + if not (needs_parens txt) then "%s" + else if needs_spaces txt then "(@;%s@;)" + else "(%s)" + in fprintf ppf format txt -module MakeIterator(Iter : IteratorArgument) : sig +let protect_longident ppf print_longident longprefix txt = + let format : (_, _, _) format = + if not (needs_parens txt) then "%a.%s" + else if needs_spaces txt then "%a.(@;%s@;)" + else "%a.(%s)" in + fprintf ppf format print_longident longprefix txt - val iter_structure : structure -> unit - val iter_signature : signature -> unit - val iter_structure_item : structure_item -> unit - val iter_signature_item : signature_item -> unit - val iter_expression : expression -> unit - val iter_module_type : module_type -> unit - val iter_pattern : pattern -> unit +type space_formatter = (unit, Format.formatter, unit) format - end = struct +let override = function + | Override -> "!" + | Fresh -> "" - let may_iter f v = - match v with - None -> () - | Some x -> f x +(* variance encoding: need to sync up with the [parser.mly] *) +let type_variance = function + | Invariant -> "" + | Covariant -> "+" + | Contravariant -> "-" +type construct = + [ `cons of expression list + | `list of expression list + | `nil + | `normal + | `simple of Longident.t + | `tuple ] - let rec iter_structure str = - Iter.enter_structure str; - List.iter iter_structure_item str.str_items; - Iter.leave_structure str +let view_expr x = + match x.pexp_desc with + | Pexp_construct ( {txt= Lident "()"; _},_) -> `tuple + | Pexp_construct ( {txt= Lident "[]";_},_) -> `nil + | Pexp_construct ( {txt= Lident"::";_},Some _) -> + let rec loop exp acc = match exp with + | {pexp_desc=Pexp_construct ({txt=Lident "[]";_},_); + pexp_attributes = []} -> + (List.rev acc,true) + | {pexp_desc= + Pexp_construct ({txt=Lident "::";_}, + Some ({pexp_desc= Pexp_tuple([e1;e2]); + pexp_attributes = []})); + pexp_attributes = []} + -> + loop e2 (e1::acc) + | e -> (List.rev (e::acc),false) in + let (ls,b) = loop x [] in + if b then + `list ls + else `cons ls + | Pexp_construct (x,None) -> `simple (x.txt) + | _ -> `normal +let is_simple_construct :construct -> bool = function + | `nil | `tuple | `list _ | `simple _ -> true + | `cons _ | `normal -> false - and iter_binding vb = - Iter.enter_binding vb; - iter_pattern vb.vb_pat; - iter_expression vb.vb_expr; - Iter.leave_binding vb +let pp = fprintf - and iter_bindings rec_flag list = - Iter.enter_bindings rec_flag; - List.iter iter_binding list; - Iter.leave_bindings rec_flag +type ctxt = { + pipe : bool; + semi : bool; + ifthenelse : bool; +} - and iter_case {c_lhs; c_guard; c_rhs} = - iter_pattern c_lhs; - may_iter iter_expression c_guard; - iter_expression c_rhs +let reset_ctxt = { pipe=false; semi=false; ifthenelse=false } +let under_pipe ctxt = { ctxt with pipe=true } +let under_semi ctxt = { ctxt with semi=true } +let under_ifthenelse ctxt = { ctxt with ifthenelse=true } +(* +let reset_semi ctxt = { ctxt with semi=false } +let reset_ifthenelse ctxt = { ctxt with ifthenelse=false } +let reset_pipe ctxt = { ctxt with pipe=false } +*) - and iter_cases cases = - List.iter iter_case cases +let list : 'a . ?sep:space_formatter -> ?first:space_formatter -> + ?last:space_formatter -> (Format.formatter -> 'a -> unit) -> + Format.formatter -> 'a list -> unit + = fun ?sep ?first ?last fu f xs -> + let first = match first with Some x -> x |None -> ("": _ format6) + and last = match last with Some x -> x |None -> ("": _ format6) + and sep = match sep with Some x -> x |None -> ("@ ": _ format6) in + let aux f = function + | [] -> () + | [x] -> fu f x + | xs -> + let rec loop f = function + | [x] -> fu f x + | x::xs -> fu f x; pp f sep; loop f xs; + | _ -> assert false in begin + pp f first; loop f xs; pp f last; + end in + aux f xs - and iter_structure_item item = - Iter.enter_structure_item item; - begin - match item.str_desc with - Tstr_eval (exp, _attrs) -> iter_expression exp - | Tstr_value (rec_flag, list) -> - iter_bindings rec_flag list - | Tstr_primitive vd -> iter_value_description vd - | Tstr_type (rf, list) -> iter_type_declarations rf list - | Tstr_typext tyext -> iter_type_extension tyext - | Tstr_exception ext -> iter_extension_constructor ext - | Tstr_module x -> iter_module_binding x - | Tstr_recmodule list -> List.iter iter_module_binding list - | Tstr_modtype mtd -> iter_module_type_declaration mtd - | Tstr_open _ -> () - | Tstr_class () -> () - | Tstr_class_type list -> - List.iter - (fun (_, _, ct) -> iter_class_type_declaration ct) - list - | Tstr_include incl -> iter_module_expr incl.incl_mod - | Tstr_attribute _ -> - () - end; - Iter.leave_structure_item item +let option : 'a. ?first:space_formatter -> ?last:space_formatter -> + (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a option -> unit + = fun ?first ?last fu f a -> + let first = match first with Some x -> x | None -> ("": _ format6) + and last = match last with Some x -> x | None -> ("": _ format6) in + match a with + | None -> () + | Some x -> pp f first; fu f x; pp f last - and iter_module_binding x = - iter_module_expr x.mb_expr +let paren: 'a . ?first:space_formatter -> ?last:space_formatter -> + bool -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit + = fun ?(first=("": _ format6)) ?(last=("": _ format6)) b fu f x -> + if b then (pp f "("; pp f first; fu f x; pp f last; pp f ")") + else fu f x - and iter_value_description v = - Iter.enter_value_description v; - iter_core_type v.val_desc; - Iter.leave_value_description v +let rec longident f = function + | Lident s -> protect_ident f s + | Ldot(y,s) -> protect_longident f longident y s + | Lapply (y,s) -> + pp f "%a(%a)" longident y longident s - and iter_constructor_arguments = function - | Cstr_tuple l -> List.iter iter_core_type l - | Cstr_record l -> List.iter (fun ld -> iter_core_type ld.ld_type) l +let longident_loc f x = pp f "%a" longident x.txt - and iter_constructor_declaration cd = - iter_constructor_arguments cd.cd_args; - option iter_core_type cd.cd_res; +let string_of_int_as_char i = + if i >= 0 && i <= 255 + then + Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) + else + Printf.sprintf "\'\\%d\'" i - and iter_type_parameter (ct, _v) = - iter_core_type ct +let constant f = function + | Pconst_char i -> pp f "%s" (string_of_int_as_char i) + | Pconst_string (i, None) -> pp f "%S" i + | Pconst_string (i, Some delim) -> pp f "{%s|%s|%s}" delim i delim + | Pconst_integer (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i + | Pconst_integer (i, Some m) -> + paren (i.[0]='-') (fun f (i, m) -> pp f "%s%c" i m) f (i,m) + | Pconst_float (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i + | Pconst_float (i, Some m) -> paren (i.[0]='-') (fun f (i,m) -> + pp f "%s%c" i m) f (i,m) - and iter_type_declaration decl = - Iter.enter_type_declaration decl; - List.iter iter_type_parameter decl.typ_params; - List.iter (fun (ct1, ct2, _loc) -> - iter_core_type ct1; - iter_core_type ct2 - ) decl.typ_cstrs; - begin match decl.typ_kind with - Ttype_abstract -> () - | Ttype_variant list -> - List.iter iter_constructor_declaration list - | Ttype_record list -> - List.iter - (fun ld -> - iter_core_type ld.ld_type - ) list - | Ttype_open -> () - end; - option iter_core_type decl.typ_manifest; - Iter.leave_type_declaration decl +(* trailing space*) +let mutable_flag f = function + | Immutable -> () + | Mutable -> pp f "mutable@;" +let virtual_flag f = function + | Concrete -> () + | Virtual -> pp f "virtual@;" - and iter_type_declarations rec_flag decls = - Iter.enter_type_declarations rec_flag; - List.iter iter_type_declaration decls; - Iter.leave_type_declarations rec_flag +(* trailing space added *) +let rec_flag f rf = + match rf with + | Nonrecursive -> () + | Recursive -> pp f "rec " +let nonrec_flag f rf = + match rf with + | Nonrecursive -> pp f "nonrec " + | Recursive -> () +let direction_flag f = function + | Upto -> pp f "to@ " + | Downto -> pp f "downto@ " +let private_flag f = function + | Public -> () + | Private -> pp f "private@ " - and iter_extension_constructor ext = - Iter.enter_extension_constructor ext; - begin match ext.ext_kind with - Text_decl(args, ret) -> - iter_constructor_arguments args; - option iter_core_type ret - | Text_rebind _ -> () - end; - Iter.leave_extension_constructor ext; +let constant_string f s = pp f "%S" s +let tyvar f str = pp f "'%s" str +let tyvar_loc f str = pp f "'%s" str.txt +let string_quot f x = pp f "`%s" x - and iter_type_extension tyext = - Iter.enter_type_extension tyext; - List.iter iter_type_parameter tyext.tyext_params; - List.iter iter_extension_constructor tyext.tyext_constructors; - Iter.leave_type_extension tyext +(* c ['a,'b] *) +let rec class_params_def ctxt f = function + | [] -> () + | l -> + pp f "[%a] " (* space *) + (list (type_param ctxt) ~sep:",") l - and iter_pattern pat = - Iter.enter_pattern pat; - List.iter (fun (cstr, _, _attrs) -> match cstr with - | Tpat_type _ -> () - | Tpat_unpack -> () - | Tpat_open _ -> () - | Tpat_constraint ct -> iter_core_type ct) pat.pat_extra; - begin - match pat.pat_desc with - Tpat_any -> () - | Tpat_var _ -> () - | Tpat_alias (pat1, _, _) -> iter_pattern pat1 - | Tpat_constant _ -> () - | Tpat_tuple list -> - List.iter iter_pattern list - | Tpat_construct (_, _, args) -> - List.iter iter_pattern args - | Tpat_variant (_, pato, _) -> - begin match pato with - None -> () - | Some pat -> iter_pattern pat - end - | Tpat_record (list, _closed) -> - List.iter (fun (_, _, pat) -> iter_pattern pat) list - | Tpat_array list -> List.iter iter_pattern list - | Tpat_or (p1, p2, _) -> iter_pattern p1; iter_pattern p2 - | Tpat_lazy p -> iter_pattern p - end; - Iter.leave_pattern pat +and type_with_label ctxt f (label, c) = + match label with + | Nolabel -> core_type1 ctxt f c (* otherwise parenthesize *) + | Labelled s -> pp f "%s:%a" s (core_type1 ctxt) c + | Optional s -> pp f "?%s:%a" s (core_type1 ctxt) c - and option f x = match x with None -> () | Some e -> f e +and core_type ctxt f x = + if x.ptyp_attributes <> [] then begin + pp f "((%a)%a)" (core_type ctxt) {x with ptyp_attributes=[]} + (attributes ctxt) x.ptyp_attributes + end + else match x.ptyp_desc with + | Ptyp_arrow (l, ct1, ct2) -> + pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) + (type_with_label ctxt) (l,ct1) (core_type ctxt) ct2 + | Ptyp_alias (ct, s) -> + pp f "@[<2>%a@;as@;'%s@]" (core_type1 ctxt) ct s + | Ptyp_poly ([], ct) -> + core_type ctxt f ct + | Ptyp_poly (sl, ct) -> + pp f "@[<2>%a%a@]" + (fun f l -> + pp f "%a" + (fun f l -> match l with + | [] -> () + | _ -> + pp f "%a@;.@;" + (list tyvar_loc ~sep:"@;") l) + l) + sl (core_type ctxt) ct + | _ -> pp f "@[<2>%a@]" (core_type1 ctxt) x - and iter_expression exp = - Iter.enter_expression exp; - List.iter (function (cstr, _, _attrs) -> - match cstr with - Texp_constraint ct -> - iter_core_type ct - | Texp_coerce (cty1, cty2) -> - option iter_core_type cty1; iter_core_type cty2 - | Texp_open _ -> () - | Texp_poly cto -> option iter_core_type cto - | Texp_newtype _ -> ()) - exp.exp_extra; - begin - match exp.exp_desc with - Texp_ident _ -> () - | Texp_constant _ -> () - | Texp_let (rec_flag, list, exp) -> - iter_bindings rec_flag list; - iter_expression exp - | Texp_function { cases; _ } -> - iter_cases cases - | Texp_apply (exp, list) -> - iter_expression exp; - List.iter (fun (_label, expo) -> - match expo with - None -> () - | Some exp -> iter_expression exp - ) list - | Texp_match (exp, list1, list2, _) -> - iter_expression exp; - iter_cases list1; - iter_cases list2; - | Texp_try (exp, list) -> - iter_expression exp; - iter_cases list - | Texp_tuple list -> - List.iter iter_expression list - | Texp_construct (_, _, args) -> - List.iter iter_expression args - | Texp_variant (_label, expo) -> - begin match expo with - None -> () - | Some exp -> iter_expression exp - end - | Texp_record { fields; extended_expression; _ } -> - Array.iter (function - | _, Kept _ -> () - | _, Overridden (_, exp) -> iter_expression exp) - fields; - begin match extended_expression with - None -> () - | Some exp -> iter_expression exp - end - | Texp_field (exp, _, _label) -> - iter_expression exp - | Texp_setfield (exp1, _, _label, exp2) -> - iter_expression exp1; - iter_expression exp2 - | Texp_array list -> - List.iter iter_expression list - | Texp_ifthenelse (exp1, exp2, expo) -> - iter_expression exp1; - iter_expression exp2; - begin match expo with - None -> () - | Some exp -> iter_expression exp - end - | Texp_sequence (exp1, exp2) -> - iter_expression exp1; - iter_expression exp2 - | Texp_while (exp1, exp2) -> - iter_expression exp1; - iter_expression exp2 - | Texp_for (_id, _, exp1, exp2, _dir, exp3) -> - iter_expression exp1; - iter_expression exp2; - iter_expression exp3 - | Texp_send (exp, _meth, expo) -> - iter_expression exp; - begin - match expo with - None -> () - | Some exp -> iter_expression exp - end - | Texp_new _ - | Texp_instvar _ - | Texp_setinstvar _ - | Texp_override _ -> () - | Texp_letmodule (_id, _, mexpr, exp) -> - iter_module_expr mexpr; - iter_expression exp - | Texp_letexception (cd, exp) -> - iter_extension_constructor cd; - iter_expression exp - | Texp_assert exp -> iter_expression exp - | Texp_lazy exp -> iter_expression exp - | Texp_object () -> - () - | Texp_pack (mexpr) -> - iter_module_expr mexpr - | Texp_unreachable -> - () - | Texp_extension_constructor _ -> - () - end; - Iter.leave_expression exp; +and core_type1 ctxt f x = + if x.ptyp_attributes <> [] then core_type ctxt f x + else match x.ptyp_desc with + | Ptyp_any -> pp f "_"; + | Ptyp_var s -> tyvar f s; + | Ptyp_tuple l -> pp f "(%a)" (list (core_type1 ctxt) ~sep:"@;*@;") l + | Ptyp_constr (li, l) -> + pp f (* "%a%a@;" *) "%a%a" + (fun f l -> match l with + |[] -> () + |[x]-> pp f "%a@;" (core_type1 ctxt) x + | _ -> list ~first:"(" ~last:")@;" (core_type ctxt) ~sep:",@;" f l) + l longident_loc li + | Ptyp_variant (l, closed, low) -> + let type_variant_helper f x = + match x with + | Rtag (l, attrs, _, ctl) -> + pp f "@[<2>%a%a@;%a@]" string_quot l.txt + (fun f l -> match l with + |[] -> () + | _ -> pp f "@;of@;%a" + (list (core_type ctxt) ~sep:"&") ctl) ctl + (attributes ctxt) attrs + | Rinherit ct -> core_type ctxt f ct in + pp f "@[<2>[%a%a]@]" + (fun f l -> + match l, closed with + | [], Closed -> () + | [], Open -> pp f ">" (* Cf #7200: print [>] correctly *) + | _ -> + pp f "%s@;%a" + (match (closed,low) with + | (Closed,None) -> "" + | (Closed,Some _) -> "<" (* FIXME desugar the syntax sugar*) + | (Open,_) -> ">") + (list type_variant_helper ~sep:"@;<1 -2>| ") l) l + (fun f low -> match low with + |Some [] |None -> () + |Some xs -> + pp f ">@ %a" + (list string_quot) xs) low + | Ptyp_object (l, o) -> + let core_field_type f = function + | Otag (l, attrs, ct) -> + pp f "@[%s: %a@ %a@ @]" l.txt + (core_type ctxt) ct (attributes ctxt) attrs (* Cf #7200 *) + | Oinherit ct -> + pp f "@[%a@ @]" (core_type ctxt) ct + in + let field_var f = function + | Asttypes.Closed -> () + | Asttypes.Open -> + match l with + | [] -> pp f ".." + | _ -> pp f " ;.." + in + pp f "@[<@ %a%a@ > @]" (list core_field_type ~sep:";") l + field_var o (* Cf #7200 *) + | Ptyp_class (li, l) -> (*FIXME*) + pp f "@[%a#%a@]" + (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") l + longident_loc li + | Ptyp_package (lid, cstrs) -> + let aux f (s, ct) = + pp f "type %a@ =@ %a" longident_loc s (core_type ctxt) ct in + (match cstrs with + |[] -> pp f "@[(module@ %a)@]" longident_loc lid + |_ -> + pp f "@[(module@ %a@ with@ %a)@]" longident_loc lid + (list aux ~sep:"@ and@ ") cstrs) + | Ptyp_extension e -> extension ctxt f e + | _ -> paren true (core_type ctxt) f x - and iter_package_type pack = - Iter.enter_package_type pack; - List.iter (fun (_s, ct) -> iter_core_type ct) pack.pack_fields; - Iter.leave_package_type pack; +(********************pattern********************) +(* be cautious when use [pattern], [pattern1] is preferred *) +and pattern ctxt f x = + let rec list_of_pattern acc = function (* only consider ((A|B)|C)*) + | {ppat_desc= Ppat_or (p1,p2); ppat_attributes = []} -> + list_of_pattern (p2::acc) p1 + | x -> x::acc + in + if x.ppat_attributes <> [] then begin + pp f "((%a)%a)" (pattern ctxt) {x with ppat_attributes=[]} + (attributes ctxt) x.ppat_attributes + end + else match x.ppat_desc with + | Ppat_alias (p, s) -> + pp f "@[<2>%a@;as@;%a@]" (pattern ctxt) p protect_ident s.txt (* RA*) + | Ppat_or _ -> (* *) + pp f "@[%a@]" (list ~sep:"@,|" (pattern ctxt)) + (list_of_pattern [] x) + | _ -> pattern1 ctxt f x - and iter_signature sg = - Iter.enter_signature sg; - List.iter iter_signature_item sg.sig_items; - Iter.leave_signature sg; +and pattern1 ctxt (f:Format.formatter) (x:pattern) : unit = + let rec pattern_list_helper f = function + | {ppat_desc = + Ppat_construct + ({ txt = Lident("::") ;_}, + Some ({ppat_desc = Ppat_tuple([pat1; pat2]);_})); + ppat_attributes = []} - and iter_signature_item item = - Iter.enter_signature_item item; - begin - match item.sig_desc with - Tsig_value vd -> - iter_value_description vd - | Tsig_type (rf, list) -> - iter_type_declarations rf list - | Tsig_exception ext -> - iter_extension_constructor ext - | Tsig_typext tyext -> - iter_type_extension tyext - | Tsig_module md -> - iter_module_type md.md_type - | Tsig_recmodule list -> - List.iter (fun md -> iter_module_type md.md_type) list - | Tsig_modtype mtd -> - iter_module_type_declaration mtd - | Tsig_open _ -> () - | Tsig_include incl -> iter_module_type incl.incl_mod - | Tsig_class () -> () - | Tsig_class_type list -> - List.iter iter_class_type_declaration list - | Tsig_attribute _ -> () - end; - Iter.leave_signature_item item; + -> + pp f "%a::%a" (simple_pattern ctxt) pat1 pattern_list_helper pat2 (*RA*) + | p -> pattern1 ctxt f p + in + if x.ppat_attributes <> [] then pattern ctxt f x + else match x.ppat_desc with + | Ppat_variant (l, Some p) -> + pp f "@[<2>`%s@;%a@]" l (simple_pattern ctxt) p + | Ppat_construct (({txt=Lident("()"|"[]");_}), _) -> simple_pattern ctxt f x + | Ppat_construct (({txt;_} as li), po) -> + (* FIXME The third field always false *) + if txt = Lident "::" then + pp f "%a" pattern_list_helper x + else + (match po with + | Some x -> pp f "%a@;%a" longident_loc li (simple_pattern ctxt) x + | None -> pp f "%a" longident_loc li) + | _ -> simple_pattern ctxt f x - and iter_module_type_declaration mtd = - Iter.enter_module_type_declaration mtd; - begin - match mtd.mtd_type with - | None -> () - | Some mtype -> iter_module_type mtype - end; - Iter.leave_module_type_declaration mtd +and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = + if x.ppat_attributes <> [] then pattern ctxt f x + else match x.ppat_desc with + | Ppat_construct (({txt=Lident ("()"|"[]" as x);_}), _) -> pp f "%s" x + | Ppat_any -> pp f "_"; + | Ppat_var ({txt = txt;_}) -> protect_ident f txt + | Ppat_array l -> + pp f "@[<2>[|%a|]@]" (list (pattern1 ctxt) ~sep:";") l + | Ppat_unpack (s) -> + pp f "(module@ %s)@ " s.txt + | Ppat_type li -> + pp f "#%a" longident_loc li + | Ppat_record (l, closed) -> + let longident_x_pattern f (li, p) = + match (li,p) with + | ({txt=Lident s;_ }, + {ppat_desc=Ppat_var {txt;_}; + ppat_attributes=[]; _}) + when s = txt -> + pp f "@[<2>%a@]" longident_loc li + | _ -> + pp f "@[<2>%a@;=@;%a@]" longident_loc li (pattern1 ctxt) p + in + begin match closed with + | Closed -> + pp f "@[<2>{@;%a@;}@]" (list longident_x_pattern ~sep:";@;") l + | _ -> + pp f "@[<2>{@;%a;_}@]" (list longident_x_pattern ~sep:";@;") l + end + | Ppat_tuple l -> + pp f "@[<1>(%a)@]" (list ~sep:",@;" (pattern1 ctxt)) l (* level1*) + | Ppat_constant (c) -> pp f "%a" constant c + | Ppat_interval (c1, c2) -> pp f "%a..%a" constant c1 constant c2 + | Ppat_variant (l,None) -> pp f "`%s" l + | Ppat_constraint (p, ct) -> + pp f "@[<2>(%a@;:@;%a)@]" (pattern1 ctxt) p (core_type ctxt) ct + | Ppat_lazy p -> + pp f "@[<2>(lazy@;%a)@]" (pattern1 ctxt) p + | Ppat_exception p -> + pp f "@[<2>exception@;%a@]" (pattern1 ctxt) p + | Ppat_extension e -> extension ctxt f e + | Ppat_open (lid, p) -> + let with_paren = + match p.ppat_desc with + | Ppat_array _ | Ppat_record _ + | Ppat_construct (({txt=Lident ("()"|"[]");_}), _) -> false + | _ -> true in + pp f "@[<2>%a.%a @]" longident_loc lid + (paren with_paren @@ pattern1 ctxt) p + | _ -> paren true (pattern ctxt) f x +and label_exp ctxt f (l,opt,p) = + match l with + | Nolabel -> + (* single case pattern parens needed here *) + pp f "%a@ " (simple_pattern ctxt) p + | Optional rest -> + begin match p with + | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []} + when txt = rest -> + (match opt with + | Some o -> pp f "?(%s=@;%a)@;" rest (expression ctxt) o + | None -> pp f "?%s@ " rest) + | _ -> + (match opt with + | Some o -> + pp f "?%s:(%a=@;%a)@;" + rest (pattern1 ctxt) p (expression ctxt) o + | None -> pp f "?%s:%a@;" rest (simple_pattern ctxt) p) + end + | Labelled l -> match p with + | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []} + when txt = l -> + pp f "~%s@;" l + | _ -> pp f "~%s:%a@;" l (simple_pattern ctxt) p +and sugar_expr ctxt f e = + if e.pexp_attributes <> [] then false + else match e.pexp_desc with + | Pexp_apply ({ pexp_desc = Pexp_ident {txt = id; _}; + pexp_attributes=[]; _}, args) + when List.for_all (fun (lab, _) -> lab = Nolabel) args -> begin + let print_indexop a path_prefix assign left right print_index indices + rem_args = + let print_path ppf = function + | None -> () + | Some m -> pp ppf ".%a" longident m in + match assign, rem_args with + | false, [] -> + pp f "@[%a%a%s%a%s@]" + (simple_expr ctxt) a print_path path_prefix + left (list ~sep:"," print_index) indices right; true + | true, [v] -> + pp f "@[%a%a%s%a%s@ <-@;<1 2>%a@]" + (simple_expr ctxt) a print_path path_prefix + left (list ~sep:"," print_index) indices right + (simple_expr ctxt) v; true + | _ -> false in + match id, List.map snd args with + | Lident "!", [e] -> + pp f "@[!%a@]" (simple_expr ctxt) e; true + | Ldot (path, ("get"|"set" as func)), a :: other_args -> begin + let assign = func = "set" in + let print = print_indexop a None assign in + match path, other_args with + | Lident "Array", i :: rest -> + print ".(" ")" (expression ctxt) [i] rest + | Lident "String", i :: rest -> + print ".[" "]" (expression ctxt) [i] rest + | Ldot (Lident "Bigarray", "Array1"), i1 :: rest -> + print ".{" "}" (simple_expr ctxt) [i1] rest + | Ldot (Lident "Bigarray", "Array2"), i1 :: i2 :: rest -> + print ".{" "}" (simple_expr ctxt) [i1; i2] rest + | Ldot (Lident "Bigarray", "Array3"), i1 :: i2 :: i3 :: rest -> + print ".{" "}" (simple_expr ctxt) [i1; i2; i3] rest + | Ldot (Lident "Bigarray", "Genarray"), + {pexp_desc = Pexp_array indexes; pexp_attributes = []} :: rest -> + print ".{" "}" (simple_expr ctxt) indexes rest + | _ -> false + end + | (Lident s | Ldot(_,s)) , a :: i :: rest + when s.[0] = '.' -> + let n = String.length s in + (* extract operator: + assignment operators end with [right_bracket ^ "<-"], + access operators end with [right_bracket] directly + *) + let assign = s.[n - 1] = '-' in + let kind = + (* extract the right end bracket *) + if assign then s.[n - 3] else s.[n - 1] in + let left, right = match kind with + | ')' -> '(', ")" + | ']' -> '[', "]" + | '}' -> '{', "}" + | _ -> assert false in + let path_prefix = match id with + | Ldot(m,_) -> Some m + | _ -> None in + let left = String.sub s 0 (1+String.index s left) in + print_indexop a path_prefix assign left right + (expression ctxt) [i] rest + | _ -> false + end + | _ -> false - and iter_class_type_declaration cd = - Iter.enter_class_type_declaration cd; - List.iter iter_type_parameter cd.ci_params; - iter_class_type cd.ci_expr; - Iter.leave_class_type_declaration cd; +and expression ctxt f x = + if x.pexp_attributes <> [] then + pp f "((%a)@,%a)" (expression ctxt) {x with pexp_attributes=[]} + (attributes ctxt) x.pexp_attributes + else match x.pexp_desc with + | Pexp_function _ | Pexp_fun _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _ + when ctxt.pipe || ctxt.semi -> + paren true (expression reset_ctxt) f x + | Pexp_ifthenelse _ | Pexp_sequence _ when ctxt.ifthenelse -> + paren true (expression reset_ctxt) f x + | Pexp_let _ | Pexp_letmodule _ | Pexp_open _ | Pexp_letexception _ + when ctxt.semi -> + paren true (expression reset_ctxt) f x + | Pexp_fun (l, e0, p, e) -> + pp f "@[<2>fun@;%a->@;%a@]" + (label_exp ctxt) (l, e0, p) + (expression ctxt) e + | Pexp_function l -> + pp f "@[function%a@]" (case_list ctxt) l + | Pexp_match (e, l) -> + pp f "@[@[@[<2>match %a@]@ with@]%a@]" + (expression reset_ctxt) e (case_list ctxt) l - and iter_module_type mty = - Iter.enter_module_type mty; - begin - match mty.mty_desc with - Tmty_ident _ -> () - | Tmty_alias _ -> () - | Tmty_signature sg -> iter_signature sg - | Tmty_functor (_, _, mtype1, mtype2) -> - Misc.may iter_module_type mtype1; iter_module_type mtype2 - | Tmty_with (mtype, list) -> - iter_module_type mtype; - List.iter (fun (_path, _, withc) -> - iter_with_constraint withc - ) list - | Tmty_typeof mexpr -> - iter_module_expr mexpr - end; - Iter.leave_module_type mty; + | Pexp_try (e, l) -> + pp f "@[<0>@[try@ %a@]@ @[<0>with%a@]@]" + (* "try@;@[<2>%a@]@\nwith@\n%a"*) + (expression reset_ctxt) e (case_list ctxt) l + | Pexp_let (rf, l, e) -> + (* pp f "@[<2>let %a%a in@;<1 -2>%a@]" + (*no indentation here, a new line*) *) + (* rec_flag rf *) + pp f "@[<2>%a in@;<1 -2>%a@]" + (bindings reset_ctxt) (rf,l) + (expression ctxt) e + | Pexp_apply (e, l) -> + begin if not (sugar_expr ctxt f x) then + match view_fixity_of_exp e with + | `Infix s -> + begin match l with + | [ (Nolabel, _) as arg1; (Nolabel, _) as arg2 ] -> + (* FIXME associativity label_x_expression_param *) + pp f "@[<2>%a@;%s@;%a@]" + (label_x_expression_param reset_ctxt) arg1 s + (label_x_expression_param ctxt) arg2 + | _ -> + pp f "@[<2>%a %a@]" + (simple_expr ctxt) e + (list (label_x_expression_param ctxt)) l + end + | `Prefix s -> + let s = + if List.mem s ["~+";"~-";"~+.";"~-."] && + (match l with + (* See #7200: avoid turning (~- 1) into (- 1) which is + parsed as an int literal *) + |[(_,{pexp_desc=Pexp_constant _})] -> false + | _ -> true) + then String.sub s 1 (String.length s -1) + else s in + begin match l with + | [(Nolabel, x)] -> + pp f "@[<2>%s@;%a@]" s (simple_expr ctxt) x + | _ -> + pp f "@[<2>%a %a@]" (simple_expr ctxt) e + (list (label_x_expression_param ctxt)) l + end + | _ -> + pp f "@[%a@]" begin fun f (e,l) -> + pp f "%a@ %a" (expression2 ctxt) e + (list (label_x_expression_param reset_ctxt)) l + (* reset here only because [function,match,try,sequence] + are lower priority *) + end (e,l) + end - and iter_with_constraint cstr = - Iter.enter_with_constraint cstr; - begin - match cstr with - Twith_type decl -> iter_type_declaration decl - | Twith_module _ -> () - | Twith_typesubst decl -> iter_type_declaration decl - | Twith_modsubst _ -> () - end; - Iter.leave_with_constraint cstr; + | Pexp_construct (li, Some eo) + when not (is_simple_construct (view_expr x))-> (* Not efficient FIXME*) + (match view_expr x with + | `cons ls -> list (simple_expr ctxt) f ls ~sep:"@;::@;" + | `normal -> + pp f "@[<2>%a@;%a@]" longident_loc li + (simple_expr ctxt) eo + | _ -> assert false) + | Pexp_setfield (e1, li, e2) -> + pp f "@[<2>%a.%a@ <-@ %a@]" + (simple_expr ctxt) e1 longident_loc li (simple_expr ctxt) e2 + | Pexp_ifthenelse (e1, e2, eo) -> + (* @;@[<2>else@ %a@]@] *) + let fmt:(_,_,_)format ="@[@[<2>if@ %a@]@;@[<2>then@ %a@]%a@]" in + let expression_under_ifthenelse = expression (under_ifthenelse ctxt) in + pp f fmt expression_under_ifthenelse e1 expression_under_ifthenelse e2 + (fun f eo -> match eo with + | Some x -> + pp f "@;@[<2>else@;%a@]" (expression (under_semi ctxt)) x + | None -> () (* pp f "()" *)) eo + | Pexp_sequence _ -> + let rec sequence_helper acc = function + | {pexp_desc=Pexp_sequence(e1,e2); pexp_attributes = []} -> + sequence_helper (e1::acc) e2 + | v -> List.rev (v::acc) in + let lst = sequence_helper [] x in + pp f "@[%a@]" + (list (expression (under_semi ctxt)) ~sep:";@;") lst + | Pexp_new (li) -> + pp f "@[new@ %a@]" longident_loc li; + | Pexp_setinstvar (s, e) -> + pp f "@[%s@ <-@ %a@]" s.txt (expression ctxt) e + | Pexp_override l -> (* FIXME *) + let string_x_expression f (s, e) = + pp f "@[%s@ =@ %a@]" s.txt (expression ctxt) e in + pp f "@[{<%a>}@]" + (list string_x_expression ~sep:";" ) l; + | Pexp_letmodule (s, me, e) -> + pp f "@[let@ module@ %s@ =@ %a@ in@ %a@]" s.txt + (module_expr reset_ctxt) me (expression ctxt) e + | Pexp_letexception (cd, e) -> + pp f "@[let@ exception@ %a@ in@ %a@]" + (extension_constructor ctxt) cd + (expression ctxt) e + | Pexp_assert e -> + pp f "@[assert@ %a@]" (simple_expr ctxt) e + | Pexp_lazy (e) -> + pp f "@[lazy@ %a@]" (simple_expr ctxt) e + (* Pexp_poly: impossible but we should print it anyway, rather than + assert false *) + | Pexp_poly (e, None) -> + pp f "@[!poly!@ %a@]" (simple_expr ctxt) e + | Pexp_poly (e, Some ct) -> + pp f "@[(!poly!@ %a@ : %a)@]" + (simple_expr ctxt) e (core_type ctxt) ct + | Pexp_open (ovf, lid, e) -> + pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid + (expression ctxt) e + | Pexp_variant (l,Some eo) -> + pp f "@[<2>`%s@;%a@]" l (simple_expr ctxt) eo + | Pexp_extension e -> extension ctxt f e + | Pexp_unreachable -> pp f "." + | _ -> expression1 ctxt f x - and iter_module_expr mexpr = - Iter.enter_module_expr mexpr; - begin - match mexpr.mod_desc with - Tmod_ident _ -> () - | Tmod_structure st -> iter_structure st - | Tmod_functor (_, _, mtype, mexpr) -> - Misc.may iter_module_type mtype; - iter_module_expr mexpr - | Tmod_apply (mexp1, mexp2, _) -> - iter_module_expr mexp1; - iter_module_expr mexp2 - | Tmod_constraint (mexpr, _, Tmodtype_implicit, _ ) -> - iter_module_expr mexpr - | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) -> - iter_module_expr mexpr; - iter_module_type mtype - | Tmod_unpack (exp, _mty) -> - iter_expression exp -(* iter_module_type mty *) - end; - Iter.leave_module_expr mexpr; +and expression1 ctxt f x = + if x.pexp_attributes <> [] then expression ctxt f x + else match x.pexp_desc with + | Pexp_object cs -> pp f "%a" (class_structure ctxt) cs + | _ -> expression2 ctxt f x +(* used in [Pexp_apply] *) +and expression2 ctxt f x = + if x.pexp_attributes <> [] then expression ctxt f x + else match x.pexp_desc with + | Pexp_field (e, li) -> + pp f "@[%a.%a@]" (simple_expr ctxt) e longident_loc li + | Pexp_send (e, s) -> pp f "@[%a#%s@]" (simple_expr ctxt) e s.txt - and iter_class_type ct = - Iter.enter_class_type ct; - begin - match ct.cltyp_desc with - Tcty_signature csg -> iter_class_signature csg - | Tcty_constr (_path, _, list) -> - List.iter iter_core_type list - | Tcty_arrow (_label, ct, cl) -> - iter_core_type ct; - iter_class_type cl - | Tcty_open (_, _, _, _, e) -> - iter_class_type e - end; - Iter.leave_class_type ct; + | _ -> simple_expr ctxt f x - and iter_class_signature cs = - Iter.enter_class_signature cs; - iter_core_type cs.csig_self; - List.iter iter_class_type_field cs.csig_fields; - Iter.leave_class_signature cs +and simple_expr ctxt f x = + if x.pexp_attributes <> [] then expression ctxt f x + else match x.pexp_desc with + | Pexp_construct _ when is_simple_construct (view_expr x) -> + (match view_expr x with + | `nil -> pp f "[]" + | `tuple -> pp f "()" + | `list xs -> + pp f "@[[%a]@]" + (list (expression (under_semi ctxt)) ~sep:";@;") xs + | `simple x -> longident f x + | _ -> assert false) + | Pexp_ident li -> + longident_loc f li + (* (match view_fixity_of_exp x with *) + (* |`Normal -> longident_loc f li *) + (* | `Prefix _ | `Infix _ -> pp f "( %a )" longident_loc li) *) + | Pexp_constant c -> constant f c; + | Pexp_pack me -> + pp f "(module@;%a)" (module_expr ctxt) me + | Pexp_newtype (lid, e) -> + pp f "fun@;(type@;%s)@;->@;%a" lid.txt (expression ctxt) e + | Pexp_tuple l -> + pp f "@[(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l + | Pexp_constraint (e, ct) -> + pp f "(%a : %a)" (expression ctxt) e (core_type ctxt) ct + | Pexp_coerce (e, cto1, ct) -> + pp f "(%a%a :> %a)" (expression ctxt) e + (option (core_type ctxt) ~first:" : " ~last:" ") cto1 (* no sep hint*) + (core_type ctxt) ct + | Pexp_variant (l, None) -> pp f "`%s" l + | Pexp_record (l, eo) -> + let longident_x_expression f ( li, e) = + match e with + | {pexp_desc=Pexp_ident {txt;_}; + pexp_attributes=[]; _} when li.txt = txt -> + pp f "@[%a@]" longident_loc li + | _ -> + pp f "@[%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e + in + pp f "@[@[{@;%a%a@]@;}@]"(* "@[{%a%a}@]" *) + (option ~last:" with@;" (simple_expr ctxt)) eo + (list longident_x_expression ~sep:";@;") l + | Pexp_array (l) -> + pp f "@[<0>@[<2>[|%a|]@]@]" + (list (simple_expr (under_semi ctxt)) ~sep:";") l + | Pexp_while (e1, e2) -> + let fmt : (_,_,_) format = "@[<2>while@;%a@;do@;%a@;done@]" in + pp f fmt (expression ctxt) e1 (expression ctxt) e2 + | Pexp_for (s, e1, e2, df, e3) -> + let fmt:(_,_,_)format = + "@[@[@[<2>for %a =@;%a@;%a%a@;do@]@;%a@]@;done@]" in + let expression = expression ctxt in + pp f fmt (pattern ctxt) s expression e1 direction_flag + df expression e2 expression e3 + | _ -> paren true (expression ctxt) f x +and attributes ctxt f l = + List.iter (attribute ctxt f) l - and iter_class_type_field ctf = - Iter.enter_class_type_field ctf; - begin - match ctf.ctf_desc with - Tctf_inherit ct -> iter_class_type ct - | Tctf_val (_s, _mut, _virt, ct) -> - iter_core_type ct - | Tctf_method (_s, _priv, _virt, ct) -> - iter_core_type ct - | Tctf_constraint (ct1, ct2) -> - iter_core_type ct1; - iter_core_type ct2 - | Tctf_attribute _ -> () - end; - Iter.leave_class_type_field ctf +and item_attributes ctxt f l = + List.iter (item_attribute ctxt f) l - and iter_core_type ct = - Iter.enter_core_type ct; - begin - match ct.ctyp_desc with - Ttyp_any -> () - | Ttyp_var _ -> () - | Ttyp_arrow (_label, ct1, ct2) -> - iter_core_type ct1; - iter_core_type ct2 - | Ttyp_tuple list -> List.iter iter_core_type list - | Ttyp_constr (_path, _, list) -> - List.iter iter_core_type list - | Ttyp_object (list, _o) -> - List.iter iter_object_field list - | Ttyp_class (_path, _, list) -> - List.iter iter_core_type list - | Ttyp_alias (ct, _s) -> - iter_core_type ct - | Ttyp_variant (list, _bool, _labels) -> - List.iter iter_row_field list - | Ttyp_poly (_list, ct) -> iter_core_type ct - | Ttyp_package pack -> iter_package_type pack - end; - Iter.leave_core_type ct +and attribute ctxt f (s, e) = + pp f "@[<2>[@@%s@ %a]@]" s.txt (payload ctxt) e - and iter_row_field rf = - match rf with - Ttag (_label, _attrs, _bool, list) -> - List.iter iter_core_type list - | Tinherit ct -> iter_core_type ct +and item_attribute ctxt f (s, e) = + pp f "@[<2>[@@@@%s@ %a]@]" s.txt (payload ctxt) e - and iter_object_field ofield = - match ofield with - OTtag (_, _, ct) | OTinherit ct -> iter_core_type ct +and floating_attribute ctxt f (s, e) = + pp f "@[<2>[@@@@@@%s@ %a]@]" s.txt (payload ctxt) e - end +and value_description ctxt f x = + (* note: value_description has an attribute field, + but they're already printed by the callers this method *) + pp f "@[%a%a@]" (core_type ctxt) x.pval_type + (fun f x -> + + if x.pval_prim <> [] + then pp f "@ =@ %a" (list constant_string) x.pval_prim -module DefaultIteratorArgument = struct + ) x - let enter_structure _ = () - let enter_value_description _ = () - let enter_type_extension _ = () - let enter_extension_constructor _ = () - let enter_pattern _ = () - let enter_expression _ = () - let enter_package_type _ = () - let enter_signature _ = () - let enter_signature_item _ = () - let enter_module_type_declaration _ = () - let enter_module_type _ = () - let enter_module_expr _ = () - let enter_with_constraint _ = () - let enter_class_signature _ = () +and extension ctxt f (s, e) = + pp f "@[<2>[%%%s@ %a]@]" s.txt (payload ctxt) e - let enter_class_description _ = () - let enter_class_type_declaration _ = () - let enter_class_type _ = () - let enter_class_type_field _ = () - let enter_core_type _ = () - let enter_structure_item _ = () +and item_extension ctxt f (s, e) = + pp f "@[<2>[%%%%%s@ %a]@]" s.txt (payload ctxt) e +and exception_declaration ctxt f ext = + pp f "@[exception@ %a@]" (extension_constructor ctxt) ext - let leave_structure _ = () - let leave_value_description _ = () - let leave_type_extension _ = () - let leave_extension_constructor _ = () - let leave_pattern _ = () - let leave_expression _ = () - let leave_package_type _ = () - let leave_signature _ = () - let leave_signature_item _ = () - let leave_module_type_declaration _ = () - let leave_module_type _ = () - let leave_module_expr _ = () - let leave_with_constraint _ = () - let leave_class_signature _ = () +and class_signature ctxt f { pcsig_self = ct; pcsig_fields = l ;_} = + let class_type_field f x = + match x.pctf_desc with + | Pctf_inherit (ct) -> + pp f "@[<2>inherit@ %a@]%a" (class_type ctxt) ct + (item_attributes ctxt) x.pctf_attributes + | Pctf_val (s, mf, vf, ct) -> + pp f "@[<2>val @ %a%a%s@ :@ %a@]%a" + mutable_flag mf virtual_flag vf s.txt (core_type ctxt) ct + (item_attributes ctxt) x.pctf_attributes + | Pctf_method (s, pf, vf, ct) -> + pp f "@[<2>method %a %a%s :@;%a@]%a" + private_flag pf virtual_flag vf s.txt (core_type ctxt) ct + (item_attributes ctxt) x.pctf_attributes + | Pctf_constraint (ct1, ct2) -> + pp f "@[<2>constraint@ %a@ =@ %a@]%a" + (core_type ctxt) ct1 (core_type ctxt) ct2 + (item_attributes ctxt) x.pctf_attributes + | Pctf_attribute a -> floating_attribute ctxt f a + | Pctf_extension e -> + item_extension ctxt f e; + item_attributes ctxt f x.pctf_attributes + in + pp f "@[@[object@[<1>%a@]@ %a@]@ end@]" + (fun f -> function + {ptyp_desc=Ptyp_any; ptyp_attributes=[]; _} -> () + | ct -> pp f " (%a)" (core_type ctxt) ct) ct + (list class_type_field ~sep:"@;") l - let leave_class_description _ = () - let leave_class_type_declaration _ = () - let leave_class_type _ = () - let leave_class_type_field _ = () - let leave_core_type _ = () - let leave_structure_item _ = () +(* call [class_signature] called by [class_signature] *) +and class_type ctxt f x = + match x.pcty_desc with + | Pcty_signature cs -> + class_signature ctxt f cs; + attributes ctxt f x.pcty_attributes + | Pcty_constr (li, l) -> + pp f "%a%a%a" + (fun f l -> match l with + | [] -> () + | _ -> pp f "[%a]@ " (list (core_type ctxt) ~sep:"," ) l) l + longident_loc li + (attributes ctxt) x.pcty_attributes + | Pcty_arrow (l, co, cl) -> + pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) + (type_with_label ctxt) (l,co) + (class_type ctxt) cl + | Pcty_extension e -> + extension ctxt f e; + attributes ctxt f x.pcty_attributes + | Pcty_open (ovf, lid, e) -> + pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid + (class_type ctxt) e - let enter_binding _ = () - let leave_binding _ = () +(* [class type a = object end] *) +and class_type_declaration_list ctxt f l = + let class_type_declaration kwd f x = + let { pci_params=ls; pci_name={ txt; _ }; _ } = x in + pp f "@[<2>%s %a%a%s@ =@ %a@]%a" kwd + virtual_flag x.pci_virt + (class_params_def ctxt) ls txt + (class_type ctxt) x.pci_expr + (item_attributes ctxt) x.pci_attributes + in + match l with + | [] -> () + | [x] -> class_type_declaration "class type" f x + | x :: xs -> + pp f "@[%a@,%a@]" + (class_type_declaration "class type") x + (list ~sep:"@," (class_type_declaration "and")) xs - let enter_bindings _ = () - let leave_bindings _ = () +and class_field ctxt f x = + match x.pcf_desc with + | Pcf_inherit () -> () + | Pcf_val (s, mf, Cfk_concrete (ovf, e)) -> + pp f "@[<2>val%s %a%s =@;%a@]%a" (override ovf) + mutable_flag mf s.txt + (expression ctxt) e + (item_attributes ctxt) x.pcf_attributes + | Pcf_method (s, pf, Cfk_virtual ct) -> + pp f "@[<2>method virtual %a %s :@;%a@]%a" + private_flag pf s.txt + (core_type ctxt) ct + (item_attributes ctxt) x.pcf_attributes + | Pcf_val (s, mf, Cfk_virtual ct) -> + pp f "@[<2>val virtual %a%s :@ %a@]%a" + mutable_flag mf s.txt + (core_type ctxt) ct + (item_attributes ctxt) x.pcf_attributes + | Pcf_method (s, pf, Cfk_concrete (ovf, e)) -> + let bind e = + binding ctxt f + {pvb_pat= + {ppat_desc=Ppat_var s;ppat_loc=Location.none;ppat_attributes=[]}; + pvb_expr=e; + pvb_attributes=[]; + pvb_loc=Location.none; + } + in + pp f "@[<2>method%s %a%a@]%a" + (override ovf) + private_flag pf + (fun f -> function + | {pexp_desc=Pexp_poly (e, Some ct); pexp_attributes=[]; _} -> + pp f "%s :@;%a=@;%a" + s.txt (core_type ctxt) ct (expression ctxt) e + | {pexp_desc=Pexp_poly (e, None); pexp_attributes=[]; _} -> + bind e + | _ -> bind e) e + (item_attributes ctxt) x.pcf_attributes + | Pcf_constraint (ct1, ct2) -> + pp f "@[<2>constraint %a =@;%a@]%a" + (core_type ctxt) ct1 + (core_type ctxt) ct2 + (item_attributes ctxt) x.pcf_attributes + | Pcf_initializer (e) -> + pp f "@[<2>initializer@ %a@]%a" + (expression ctxt) e + (item_attributes ctxt) x.pcf_attributes + | Pcf_attribute a -> floating_attribute ctxt f a + | Pcf_extension e -> + item_extension ctxt f e; + item_attributes ctxt f x.pcf_attributes - let enter_type_declaration _ = () - let leave_type_declaration _ = () +and class_structure ctxt f { pcstr_self = p; pcstr_fields = l } = + pp f "@[@[object%a@;%a@]@;end@]" + (fun f p -> match p.ppat_desc with + | Ppat_any -> () + | Ppat_constraint _ -> pp f " %a" (pattern ctxt) p + | _ -> pp f " (%a)" (pattern ctxt) p) p + (list (class_field ctxt)) l - let enter_type_declarations _ = () - let leave_type_declarations _ = () -end +and module_type ctxt f x = + if x.pmty_attributes <> [] then begin + pp f "((%a)%a)" (module_type ctxt) {x with pmty_attributes=[]} + (attributes ctxt) x.pmty_attributes + end else + match x.pmty_desc with + | Pmty_ident li -> + pp f "%a" longident_loc li; + | Pmty_alias li -> + pp f "(module %a)" longident_loc li; + | Pmty_signature (s) -> + pp f "@[@[sig@ %a@]@ end@]" (* "@[sig@ %a@ end@]" *) + (list (signature_item ctxt)) s (* FIXME wrong indentation*) + | Pmty_functor (_, None, mt2) -> + pp f "@[functor () ->@ %a@]" (module_type ctxt) mt2 + | Pmty_functor (s, Some mt1, mt2) -> + if s.txt = "_" then + pp f "@[%a@ ->@ %a@]" + (module_type ctxt) mt1 (module_type ctxt) mt2 + else + pp f "@[functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt + (module_type ctxt) mt1 (module_type ctxt) mt2 + | Pmty_with (mt, l) -> + let with_constraint f = function + | Pwith_type (li, ({ptype_params= ls ;_} as td)) -> + let ls = List.map fst ls in + pp f "type@ %a %a =@ %a" + (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") + ls longident_loc li (type_declaration ctxt) td + | Pwith_module (li, li2) -> + pp f "module %a =@ %a" longident_loc li longident_loc li2; + | Pwith_typesubst (li, ({ptype_params=ls;_} as td)) -> + let ls = List.map fst ls in + pp f "type@ %a %a :=@ %a" + (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") + ls longident_loc li + (type_declaration ctxt) td + | Pwith_modsubst (li, li2) -> + pp f "module %a :=@ %a" longident_loc li longident_loc li2 in + (match l with + | [] -> pp f "@[%a@]" (module_type ctxt) mt + | _ -> pp f "@[(%a@ with@ %a)@]" + (module_type ctxt) mt (list with_constraint ~sep:"@ and@ ") l) + | Pmty_typeof me -> + pp f "@[module@ type@ of@ %a@]" (module_expr ctxt) me + | Pmty_extension e -> extension ctxt f e -end -module Untypeast : sig -#1 "untypeast.mli" -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) -(* *) -(* Copyright 2007 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) +and signature ctxt f x = list ~sep:"@\n" (signature_item ctxt) f x -open Parsetree +and signature_item ctxt f x : unit = + match x.psig_desc with + | Psig_type (rf, l) -> + type_def_list ctxt f (rf, l) + | Psig_value vd -> + let intro = if vd.pval_prim = [] then "val" else "external" in + pp f "@[<2>%s@ %a@ :@ %a@]%a" intro + protect_ident vd.pval_name.txt + (value_description ctxt) vd + (item_attributes ctxt) vd.pval_attributes + | Psig_typext te -> + type_extension ctxt f te + | Psig_exception ed -> + exception_declaration ctxt f ed + | Psig_class () -> + () + | Psig_module ({pmd_type={pmty_desc=Pmty_alias alias; + pmty_attributes=[]; _};_} as pmd) -> + pp f "@[module@ %s@ =@ %a@]%a" pmd.pmd_name.txt + longident_loc alias + (item_attributes ctxt) pmd.pmd_attributes + | Psig_module pmd -> + pp f "@[module@ %s@ :@ %a@]%a" + pmd.pmd_name.txt + (module_type ctxt) pmd.pmd_type + (item_attributes ctxt) pmd.pmd_attributes + | Psig_open od -> + pp f "@[open%s@ %a@]%a" + (override od.popen_override) + longident_loc od.popen_lid + (item_attributes ctxt) od.popen_attributes + | Psig_include incl -> + pp f "@[include@ %a@]%a" + (module_type ctxt) incl.pincl_mod + (item_attributes ctxt) incl.pincl_attributes + | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> + pp f "@[module@ type@ %s%a@]%a" + s.txt + (fun f md -> match md with + | None -> () + | Some mt -> + pp_print_space f () ; + pp f "@ =@ %a" (module_type ctxt) mt + ) md + (item_attributes ctxt) attrs + | Psig_class_type (l) -> class_type_declaration_list ctxt f l + | Psig_recmodule decls -> + let rec string_x_module_type_list f ?(first=true) l = + match l with + | [] -> () ; + | pmd :: tl -> + if not first then + pp f "@ @[and@ %s:@ %a@]%a" pmd.pmd_name.txt + (module_type ctxt) pmd.pmd_type + (item_attributes ctxt) pmd.pmd_attributes + else + pp f "@[module@ rec@ %s:@ %a@]%a" pmd.pmd_name.txt + (module_type ctxt) pmd.pmd_type + (item_attributes ctxt) pmd.pmd_attributes; + string_x_module_type_list f ~first:false tl + in + string_x_module_type_list f decls + | Psig_attribute a -> floating_attribute ctxt f a + | Psig_extension(e, a) -> + item_extension ctxt f e; + item_attributes ctxt f a -val lident_of_path : Path.t -> Longident.t +and module_expr ctxt f x = + if x.pmod_attributes <> [] then + pp f "((%a)%a)" (module_expr ctxt) {x with pmod_attributes=[]} + (attributes ctxt) x.pmod_attributes + else match x.pmod_desc with + | Pmod_structure (s) -> + pp f "@[struct@;@[<0>%a@]@;<1 -2>end@]" + (list (structure_item ctxt) ~sep:"@\n") s; + | Pmod_constraint (me, mt) -> + pp f "@[(%a@ :@ %a)@]" + (module_expr ctxt) me + (module_type ctxt) mt + | Pmod_ident (li) -> + pp f "%a" longident_loc li; + | Pmod_functor (_, None, me) -> + pp f "functor ()@;->@;%a" (module_expr ctxt) me + | Pmod_functor (s, Some mt, me) -> + pp f "functor@ (%s@ :@ %a)@;->@;%a" + s.txt (module_type ctxt) mt (module_expr ctxt) me + | Pmod_apply (me1, me2) -> + pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2 + (* Cf: #7200 *) + | Pmod_unpack e -> + pp f "(val@ %a)" (expression ctxt) e + | Pmod_extension e -> extension ctxt f e -type mapper = { - attribute: mapper -> Typedtree.attribute -> attribute; - attributes: mapper -> Typedtree.attribute list -> attribute list; - case: mapper -> Typedtree.case -> case; - cases: mapper -> Typedtree.case list -> case list; - class_signature: mapper -> Typedtree.class_signature -> class_signature; - class_type: mapper -> Typedtree.class_type -> class_type; - class_type_declaration: mapper -> Typedtree.class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> Typedtree.class_type_field -> class_type_field; - constructor_declaration: mapper -> Typedtree.constructor_declaration - -> constructor_declaration; - expr: mapper -> Typedtree.expression -> expression; - extension_constructor: mapper -> Typedtree.extension_constructor - -> extension_constructor; - include_declaration: - mapper -> Typedtree.include_declaration -> include_declaration; - include_description: - mapper -> Typedtree.include_description -> include_description; - label_declaration: - mapper -> Typedtree.label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> Typedtree.module_binding -> module_binding; - module_declaration: - mapper -> Typedtree.module_declaration -> module_declaration; - module_expr: mapper -> Typedtree.module_expr -> module_expr; - module_type: mapper -> Typedtree.module_type -> module_type; - module_type_declaration: - mapper -> Typedtree.module_type_declaration -> module_type_declaration; - package_type: mapper -> Typedtree.package_type -> package_type; - open_description: mapper -> Typedtree.open_description -> open_description; - pat: mapper -> Typedtree.pattern -> pattern; - row_field: mapper -> Typedtree.row_field -> row_field; - object_field: mapper -> Typedtree.object_field -> object_field; - signature: mapper -> Typedtree.signature -> signature; - signature_item: mapper -> Typedtree.signature_item -> signature_item; - structure: mapper -> Typedtree.structure -> structure; - structure_item: mapper -> Typedtree.structure_item -> structure_item; - typ: mapper -> Typedtree.core_type -> core_type; - type_declaration: mapper -> Typedtree.type_declaration -> type_declaration; - type_extension: mapper -> Typedtree.type_extension -> type_extension; - type_kind: mapper -> Typedtree.type_kind -> type_kind; - value_binding: mapper -> Typedtree.value_binding -> value_binding; - value_description: mapper -> Typedtree.value_description -> value_description; - with_constraint: - mapper -> (Path.t * Longident.t Location.loc * Typedtree.with_constraint) - -> with_constraint; -} +and structure ctxt f x = list ~sep:"@\n" (structure_item ctxt) f x -val default_mapper : mapper +and payload ctxt f = function + | PStr [{pstr_desc = Pstr_eval (e, attrs)}] -> + pp f "@[<2>%a@]%a" + (expression ctxt) e + (item_attributes ctxt) attrs + | PStr x -> structure ctxt f x + | PTyp x -> pp f ":"; core_type ctxt f x + | PSig x -> pp f ":"; signature ctxt f x + | PPat (x, None) -> pp f "?"; pattern ctxt f x + | PPat (x, Some e) -> + pp f "?"; pattern ctxt f x; + pp f " when "; expression ctxt f e -val untype_structure : ?mapper:mapper -> Typedtree.structure -> structure -val untype_signature : ?mapper:mapper -> Typedtree.signature -> signature +(* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *) +and binding ctxt f {pvb_pat=p; pvb_expr=x; _} = + (* .pvb_attributes have already been printed by the caller, #bindings *) + let rec pp_print_pexp_function f x = + if x.pexp_attributes <> [] then pp f "=@;%a" (expression ctxt) x + else match x.pexp_desc with + | Pexp_fun (label, eo, p, e) -> + if label=Nolabel then + pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function e + else + pp f "%a@ %a" + (label_exp ctxt) (label,eo,p) pp_print_pexp_function e + | Pexp_newtype (str,e) -> + pp f "(type@ %s)@ %a" str.txt pp_print_pexp_function e + | _ -> pp f "=@;%a" (expression ctxt) x + in + let tyvars_str tyvars = List.map (fun v -> v.txt) tyvars in + let is_desugared_gadt p e = + let gadt_pattern = + match p with + | {ppat_desc=Ppat_constraint({ppat_desc=Ppat_var _} as pat, + {ptyp_desc=Ptyp_poly (args_tyvars, rt)}); + ppat_attributes=[]}-> + Some (pat, args_tyvars, rt) + | _ -> None in + let rec gadt_exp tyvars e = + match e with + | {pexp_desc=Pexp_newtype (tyvar, e); pexp_attributes=[]} -> + gadt_exp (tyvar :: tyvars) e + | {pexp_desc=Pexp_constraint (e, ct); pexp_attributes=[]} -> + Some (List.rev tyvars, e, ct) + | _ -> None in + let gadt_exp = gadt_exp [] e in + match gadt_pattern, gadt_exp with + | Some (p, pt_tyvars, pt_ct), Some (e_tyvars, e, e_ct) + when tyvars_str pt_tyvars = tyvars_str e_tyvars -> + let ety = Typ.varify_constructors e_tyvars e_ct in + if ety = pt_ct then + Some (p, pt_tyvars, e_ct, e) else None + | _ -> None in + if x.pexp_attributes <> [] + then pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x else + match is_desugared_gadt p x with + | Some (p, [], ct, e) -> + pp f "%a@;: %a@;=@;%a" + (simple_pattern ctxt) p (core_type ctxt) ct (expression ctxt) e + | Some (p, tyvars, ct, e) -> begin + pp f "%a@;: type@;%a.@;%a@;=@;%a" + (simple_pattern ctxt) p (list pp_print_string ~sep:"@;") + (tyvars_str tyvars) (core_type ctxt) ct (expression ctxt) e + end + | None -> begin + match p with + | {ppat_desc=Ppat_constraint(p ,ty); + ppat_attributes=[]} -> (* special case for the first*) + begin match ty with + | {ptyp_desc=Ptyp_poly _; ptyp_attributes=[]} -> + pp f "%a@;:@;%a@;=@;%a" (simple_pattern ctxt) p + (core_type ctxt) ty (expression ctxt) x + | _ -> + pp f "(%a@;:@;%a)@;=@;%a" (simple_pattern ctxt) p + (core_type ctxt) ty (expression ctxt) x + end + | {ppat_desc=Ppat_var _; ppat_attributes=[]} -> + pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x + | _ -> + pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x + end -val constant : Asttypes.constant -> Parsetree.constant +(* [in] is not printed *) +and bindings ctxt f (rf,l) = + let binding kwd rf f x = + pp f "@[<2>%s %a%a@]%a" kwd rec_flag rf + (binding ctxt) x (item_attributes ctxt) x.pvb_attributes + in + match l with + | [] -> () + | [x] -> binding "let" rf f x + | x::xs -> + pp f "@[%a@,%a@]" + (binding "let" rf) x + (list ~sep:"@," (binding "and" Nonrecursive)) xs -end = struct -#1 "untypeast.ml" +and structure_item ctxt f x = + match x.pstr_desc with + | Pstr_eval (e, attrs) -> + pp f "@[;;%a@]%a" + (expression ctxt) e + (item_attributes ctxt) attrs + | Pstr_type (_, []) -> assert false + | Pstr_type (rf, l) -> type_def_list ctxt f (rf, l) + | Pstr_value (rf, l) -> + (* pp f "@[let %a%a@]" rec_flag rf bindings l *) + pp f "@[<2>%a@]" (bindings ctxt) (rf,l) + | Pstr_typext te -> type_extension ctxt f te + | Pstr_exception ed -> exception_declaration ctxt f ed + | Pstr_module x -> + let rec module_helper = function + | {pmod_desc=Pmod_functor(s,mt,me'); pmod_attributes = []} -> + if mt = None then pp f "()" + else Misc.may (pp f "(%s:%a)" s.txt (module_type ctxt)) mt; + module_helper me' + | me -> me + in + pp f "@[module %s%a@]%a" + x.pmb_name.txt + (fun f me -> + let me = module_helper me in + match me with + | {pmod_desc= + Pmod_constraint + (me', + ({pmty_desc=(Pmty_ident (_) + | Pmty_signature (_));_} as mt)); + pmod_attributes = []} -> + pp f " :@;%a@;=@;%a@;" + (module_type ctxt) mt (module_expr ctxt) me' + | _ -> pp f " =@ %a" (module_expr ctxt) me + ) x.pmb_expr + (item_attributes ctxt) x.pmb_attributes + | Pstr_open od -> + pp f "@[<2>open%s@;%a@]%a" + (override od.popen_override) + longident_loc od.popen_lid + (item_attributes ctxt) od.popen_attributes + | Pstr_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> + pp f "@[module@ type@ %s%a@]%a" + s.txt + (fun f md -> match md with + | None -> () + | Some mt -> + pp_print_space f () ; + pp f "@ =@ %a" (module_type ctxt) mt + ) md + (item_attributes ctxt) attrs + | Pstr_class () -> () + | Pstr_class_type l -> class_type_declaration_list ctxt f l + | Pstr_primitive vd -> + pp f "@[external@ %a@ :@ %a@]%a" + protect_ident vd.pval_name.txt + (value_description ctxt) vd + (item_attributes ctxt) vd.pval_attributes + | Pstr_include incl -> + pp f "@[include@ %a@]%a" + (module_expr ctxt) incl.pincl_mod + (item_attributes ctxt) incl.pincl_attributes + | Pstr_recmodule decls -> (* 3.07 *) + let aux f = function + | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) -> + pp f "@[@ and@ %s:%a@ =@ %a@]%a" pmb.pmb_name.txt + (module_type ctxt) typ + (module_expr ctxt) expr + (item_attributes ctxt) pmb.pmb_attributes + | _ -> assert false + in + begin match decls with + | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 -> + pp f "@[@[module@ rec@ %s:%a@ =@ %a@]%a@ %a@]" + pmb.pmb_name.txt + (module_type ctxt) typ + (module_expr ctxt) expr + (item_attributes ctxt) pmb.pmb_attributes + (fun f l2 -> List.iter (aux f) l2) l2 + | _ -> assert false + end + | Pstr_attribute a -> floating_attribute ctxt f a + | Pstr_extension(e, a) -> + item_extension ctxt f e; + item_attributes ctxt f a + +and type_param ctxt f (ct, a) = + pp f "%s%a" (type_variance a) (core_type ctxt) ct + +and type_params ctxt f = function + | [] -> () + | l -> pp f "%a " (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",@;") l + +and type_def_list ctxt f (rf, l) = + let type_decl kwd rf f x = + let eq = + if (x.ptype_kind = Ptype_abstract) + && (x.ptype_manifest = None) then "" + else " =" + in + pp f "@[<2>%s %a%a%s%s%a@]%a" kwd + nonrec_flag rf + (type_params ctxt) x.ptype_params + x.ptype_name.txt eq + (type_declaration ctxt) x + (item_attributes ctxt) x.ptype_attributes + in + match l with + | [] -> assert false + | [x] -> type_decl "type" rf f x + | x :: xs -> pp f "@[%a@,%a@]" + (type_decl "type" rf) x + (list ~sep:"@," (type_decl "and" Recursive)) xs + +and record_declaration ctxt f lbls = + let type_record_field f pld = + pp f "@[<2>%a%s:@;%a@;%a@]" + mutable_flag pld.pld_mutable + pld.pld_name.txt + (core_type ctxt) pld.pld_type + (attributes ctxt) pld.pld_attributes + in + pp f "{@\n%a}" + (list type_record_field ~sep:";@\n" ) lbls + +and type_declaration ctxt f x = + (* type_declaration has an attribute field, + but it's been printed by the caller of this method *) + let priv f = + match x.ptype_private with + | Public -> () + | Private -> pp f "@;private" + in + let manifest f = + match x.ptype_manifest with + | None -> () + | Some y -> + if x.ptype_kind = Ptype_abstract then + pp f "%t@;%a" priv (core_type ctxt) y + else + pp f "@;%a" (core_type ctxt) y + in + let constructor_declaration f pcd = + pp f "|@;"; + constructor_declaration ctxt f + (pcd.pcd_name.txt, pcd.pcd_args, pcd.pcd_res, pcd.pcd_attributes) + in + let repr f = + let intro f = + if x.ptype_manifest = None then () + else pp f "@;=" + in + match x.ptype_kind with + | Ptype_variant xs -> + pp f "%t%t@\n%a" intro priv + (list ~sep:"@\n" constructor_declaration) xs + | Ptype_abstract -> () + | Ptype_record l -> + pp f "%t%t@;%a" intro priv (record_declaration ctxt) l + | Ptype_open -> pp f "%t%t@;.." intro priv + in + let constraints f = + List.iter + (fun (ct1,ct2,_) -> + pp f "@[@ constraint@ %a@ =@ %a@]" + (core_type ctxt) ct1 (core_type ctxt) ct2) + x.ptype_cstrs + in + pp f "%t%t%t" manifest repr constraints + +and type_extension ctxt f x = + let extension_constructor f x = + pp f "@\n|@;%a" (extension_constructor ctxt) x + in + pp f "@[<2>type %a%a += %a@ %a@]%a" + (fun f -> function + | [] -> () + | l -> + pp f "%a@;" (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",") l) + x.ptyext_params + longident_loc x.ptyext_path + private_flag x.ptyext_private (* Cf: #7200 *) + (list ~sep:"" extension_constructor) + x.ptyext_constructors + (item_attributes ctxt) x.ptyext_attributes + +and constructor_declaration ctxt f (name, args, res, attrs) = + let name = + match name with + | "::" -> "(::)" + | s -> s in + match res with + | None -> + pp f "%s%a@;%a" name + (fun f -> function + | Pcstr_tuple [] -> () + | Pcstr_tuple l -> + pp f "@;of@;%a" (list (core_type1 ctxt) ~sep:"@;*@;") l + | Pcstr_record l -> pp f "@;of@;%a" (record_declaration ctxt) l + ) args + (attributes ctxt) attrs + | Some r -> + pp f "%s:@;%a@;%a" name + (fun f -> function + | Pcstr_tuple [] -> core_type1 ctxt f r + | Pcstr_tuple l -> pp f "%a@;->@;%a" + (list (core_type1 ctxt) ~sep:"@;*@;") l + (core_type1 ctxt) r + | Pcstr_record l -> + pp f "%a@;->@;%a" (record_declaration ctxt) l (core_type1 ctxt) r + ) + args + (attributes ctxt) attrs + +and extension_constructor ctxt f x = + (* Cf: #7200 *) + match x.pext_kind with + | Pext_decl(l, r) -> + constructor_declaration ctxt f (x.pext_name.txt, l, r, x.pext_attributes) + | Pext_rebind li -> + pp f "%s%a@;=@;%a" x.pext_name.txt + (attributes ctxt) x.pext_attributes + longident_loc li + +and case_list ctxt f l : unit = + let aux f {pc_lhs; pc_guard; pc_rhs} = + pp f "@;| @[<2>%a%a@;->@;%a@]" + (pattern ctxt) pc_lhs (option (expression ctxt) ~first:"@;when@;") + pc_guard (expression (under_pipe ctxt)) pc_rhs + in + list aux f l ~sep:"" + +and label_x_expression_param ctxt f (l,e) = + let simple_name = match e with + | {pexp_desc=Pexp_ident {txt=Lident l;_}; + pexp_attributes=[]} -> Some l + | _ -> None + in match l with + | Nolabel -> expression2 ctxt f e (* level 2*) + | Optional str -> + if Some str = simple_name then + pp f "?%s" str + else + pp f "?%s:%a" str (simple_expr ctxt) e + | Labelled lbl -> + if Some lbl = simple_name then + pp f "~%s" lbl + else + pp f "~%s:%a" lbl (simple_expr ctxt) e + + + +let expression f x = + pp f "@[%a@]" (expression reset_ctxt) x + +let string_of_expression x = + ignore (flush_str_formatter ()) ; + let f = str_formatter in + expression f x; + flush_str_formatter () + +let string_of_structure x = + ignore (flush_str_formatter ()); + let f = str_formatter in + structure reset_ctxt f x; + flush_str_formatter () + + +let core_type = core_type reset_ctxt +let pattern = pattern reset_ctxt +let signature = signature reset_ctxt +let structure = structure reset_ctxt + +end +module TypedtreeIter : sig +#1 "typedtreeIter.mli" (**************************************************************************) (* *) (* OCaml *) @@ -25647,27 +26352,793 @@ end = struct (* *) (**************************************************************************) -open Longident open Asttypes -open Parsetree -open Ast_helper +open Typedtree -module T = Typedtree -type mapper = { - attribute: mapper -> T.attribute -> attribute; - attributes: mapper -> T.attribute list -> attribute list; - case: mapper -> T.case -> case; - cases: mapper -> T.case list -> case list; - class_signature: mapper -> T.class_signature -> class_signature; - class_type: mapper -> T.class_type -> class_type; - class_type_declaration: mapper -> T.class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> T.class_type_field -> class_type_field; - constructor_declaration: mapper -> T.constructor_declaration - -> constructor_declaration; - expr: mapper -> T.expression -> expression; - extension_constructor: mapper -> T.extension_constructor +module type IteratorArgument = sig + val enter_structure : structure -> unit + val enter_value_description : value_description -> unit + val enter_type_extension : type_extension -> unit + val enter_extension_constructor : extension_constructor -> unit + val enter_pattern : pattern -> unit + val enter_expression : expression -> unit + val enter_package_type : package_type -> unit + val enter_signature : signature -> unit + val enter_signature_item : signature_item -> unit + val enter_module_type_declaration : module_type_declaration -> unit + val enter_module_type : module_type -> unit + val enter_module_expr : module_expr -> unit + val enter_with_constraint : with_constraint -> unit + val enter_class_signature : class_signature -> unit + val enter_class_description : class_description -> unit + val enter_class_type_declaration : class_type_declaration -> unit + val enter_class_type : class_type -> unit + val enter_class_type_field : class_type_field -> unit + val enter_core_type : core_type -> unit + val enter_structure_item : structure_item -> unit + + + val leave_structure : structure -> unit + val leave_value_description : value_description -> unit + val leave_type_extension : type_extension -> unit + val leave_extension_constructor : extension_constructor -> unit + val leave_pattern : pattern -> unit + val leave_expression : expression -> unit + val leave_package_type : package_type -> unit + val leave_signature : signature -> unit + val leave_signature_item : signature_item -> unit + val leave_module_type_declaration : module_type_declaration -> unit + val leave_module_type : module_type -> unit + val leave_module_expr : module_expr -> unit + val leave_with_constraint : with_constraint -> unit + val leave_class_signature : class_signature -> unit + val leave_class_description : class_description -> unit + val leave_class_type_declaration : class_type_declaration -> unit + val leave_class_type : class_type -> unit + val leave_class_type_field : class_type_field -> unit + val leave_core_type : core_type -> unit + val leave_structure_item : structure_item -> unit + + val enter_bindings : rec_flag -> unit + val enter_binding : value_binding -> unit + val leave_binding : value_binding -> unit + val leave_bindings : rec_flag -> unit + + val enter_type_declarations : rec_flag -> unit + val enter_type_declaration : type_declaration -> unit + val leave_type_declaration : type_declaration -> unit + val leave_type_declarations : rec_flag -> unit + +end + +module [@warning "-67"] MakeIterator : + functor (Iter : IteratorArgument) -> + sig + val iter_structure : structure -> unit + val iter_signature : signature -> unit + val iter_structure_item : structure_item -> unit + val iter_signature_item : signature_item -> unit + val iter_expression : expression -> unit + val iter_module_type : module_type -> unit + val iter_pattern : pattern -> unit + end + +module DefaultIteratorArgument : IteratorArgument + +end = struct +#1 "typedtreeIter.ml" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* +TODO: + - 2012/05/10: Follow camlp4 way of building map and iter using classes + and inheritance ? +*) + +open Asttypes +open Typedtree + +module type IteratorArgument = sig + + val enter_structure : structure -> unit + val enter_value_description : value_description -> unit + val enter_type_extension : type_extension -> unit + val enter_extension_constructor : extension_constructor -> unit + val enter_pattern : pattern -> unit + val enter_expression : expression -> unit + val enter_package_type : package_type -> unit + val enter_signature : signature -> unit + val enter_signature_item : signature_item -> unit + val enter_module_type_declaration : module_type_declaration -> unit + val enter_module_type : module_type -> unit + val enter_module_expr : module_expr -> unit + val enter_with_constraint : with_constraint -> unit + val enter_class_signature : class_signature -> unit + + val enter_class_description : class_description -> unit + val enter_class_type_declaration : class_type_declaration -> unit + val enter_class_type : class_type -> unit + val enter_class_type_field : class_type_field -> unit + val enter_core_type : core_type -> unit + val enter_structure_item : structure_item -> unit + + + val leave_structure : structure -> unit + val leave_value_description : value_description -> unit + val leave_type_extension : type_extension -> unit + val leave_extension_constructor : extension_constructor -> unit + val leave_pattern : pattern -> unit + val leave_expression : expression -> unit + val leave_package_type : package_type -> unit + val leave_signature : signature -> unit + val leave_signature_item : signature_item -> unit + val leave_module_type_declaration : module_type_declaration -> unit + val leave_module_type : module_type -> unit + val leave_module_expr : module_expr -> unit + val leave_with_constraint : with_constraint -> unit + val leave_class_signature : class_signature -> unit + + val leave_class_description : class_description -> unit + val leave_class_type_declaration : class_type_declaration -> unit + val leave_class_type : class_type -> unit + val leave_class_type_field : class_type_field -> unit + val leave_core_type : core_type -> unit + val leave_structure_item : structure_item -> unit + + val enter_bindings : rec_flag -> unit + val enter_binding : value_binding -> unit + val leave_binding : value_binding -> unit + val leave_bindings : rec_flag -> unit + + val enter_type_declarations : rec_flag -> unit + val enter_type_declaration : type_declaration -> unit + val leave_type_declaration : type_declaration -> unit + val leave_type_declarations : rec_flag -> unit + + end + +module MakeIterator(Iter : IteratorArgument) : sig + + val iter_structure : structure -> unit + val iter_signature : signature -> unit + val iter_structure_item : structure_item -> unit + val iter_signature_item : signature_item -> unit + val iter_expression : expression -> unit + val iter_module_type : module_type -> unit + val iter_pattern : pattern -> unit + + end = struct + + let may_iter f v = + match v with + None -> () + | Some x -> f x + + + let rec iter_structure str = + Iter.enter_structure str; + List.iter iter_structure_item str.str_items; + Iter.leave_structure str + + + and iter_binding vb = + Iter.enter_binding vb; + iter_pattern vb.vb_pat; + iter_expression vb.vb_expr; + Iter.leave_binding vb + + and iter_bindings rec_flag list = + Iter.enter_bindings rec_flag; + List.iter iter_binding list; + Iter.leave_bindings rec_flag + + and iter_case {c_lhs; c_guard; c_rhs} = + iter_pattern c_lhs; + may_iter iter_expression c_guard; + iter_expression c_rhs + + and iter_cases cases = + List.iter iter_case cases + + and iter_structure_item item = + Iter.enter_structure_item item; + begin + match item.str_desc with + Tstr_eval (exp, _attrs) -> iter_expression exp + | Tstr_value (rec_flag, list) -> + iter_bindings rec_flag list + | Tstr_primitive vd -> iter_value_description vd + | Tstr_type (rf, list) -> iter_type_declarations rf list + | Tstr_typext tyext -> iter_type_extension tyext + | Tstr_exception ext -> iter_extension_constructor ext + | Tstr_module x -> iter_module_binding x + | Tstr_recmodule list -> List.iter iter_module_binding list + | Tstr_modtype mtd -> iter_module_type_declaration mtd + | Tstr_open _ -> () + | Tstr_class () -> () + | Tstr_class_type list -> + List.iter + (fun (_, _, ct) -> iter_class_type_declaration ct) + list + | Tstr_include incl -> iter_module_expr incl.incl_mod + | Tstr_attribute _ -> + () + end; + Iter.leave_structure_item item + + and iter_module_binding x = + iter_module_expr x.mb_expr + + and iter_value_description v = + Iter.enter_value_description v; + iter_core_type v.val_desc; + Iter.leave_value_description v + + and iter_constructor_arguments = function + | Cstr_tuple l -> List.iter iter_core_type l + | Cstr_record l -> List.iter (fun ld -> iter_core_type ld.ld_type) l + + and iter_constructor_declaration cd = + iter_constructor_arguments cd.cd_args; + option iter_core_type cd.cd_res; + + and iter_type_parameter (ct, _v) = + iter_core_type ct + + and iter_type_declaration decl = + Iter.enter_type_declaration decl; + List.iter iter_type_parameter decl.typ_params; + List.iter (fun (ct1, ct2, _loc) -> + iter_core_type ct1; + iter_core_type ct2 + ) decl.typ_cstrs; + begin match decl.typ_kind with + Ttype_abstract -> () + | Ttype_variant list -> + List.iter iter_constructor_declaration list + | Ttype_record list -> + List.iter + (fun ld -> + iter_core_type ld.ld_type + ) list + | Ttype_open -> () + end; + option iter_core_type decl.typ_manifest; + Iter.leave_type_declaration decl + + and iter_type_declarations rec_flag decls = + Iter.enter_type_declarations rec_flag; + List.iter iter_type_declaration decls; + Iter.leave_type_declarations rec_flag + + and iter_extension_constructor ext = + Iter.enter_extension_constructor ext; + begin match ext.ext_kind with + Text_decl(args, ret) -> + iter_constructor_arguments args; + option iter_core_type ret + | Text_rebind _ -> () + end; + Iter.leave_extension_constructor ext; + + and iter_type_extension tyext = + Iter.enter_type_extension tyext; + List.iter iter_type_parameter tyext.tyext_params; + List.iter iter_extension_constructor tyext.tyext_constructors; + Iter.leave_type_extension tyext + + and iter_pattern pat = + Iter.enter_pattern pat; + List.iter (fun (cstr, _, _attrs) -> match cstr with + | Tpat_type _ -> () + | Tpat_unpack -> () + | Tpat_open _ -> () + | Tpat_constraint ct -> iter_core_type ct) pat.pat_extra; + begin + match pat.pat_desc with + Tpat_any -> () + | Tpat_var _ -> () + | Tpat_alias (pat1, _, _) -> iter_pattern pat1 + | Tpat_constant _ -> () + | Tpat_tuple list -> + List.iter iter_pattern list + | Tpat_construct (_, _, args) -> + List.iter iter_pattern args + | Tpat_variant (_, pato, _) -> + begin match pato with + None -> () + | Some pat -> iter_pattern pat + end + | Tpat_record (list, _closed) -> + List.iter (fun (_, _, pat) -> iter_pattern pat) list + | Tpat_array list -> List.iter iter_pattern list + | Tpat_or (p1, p2, _) -> iter_pattern p1; iter_pattern p2 + | Tpat_lazy p -> iter_pattern p + end; + Iter.leave_pattern pat + + and option f x = match x with None -> () | Some e -> f e + + and iter_expression exp = + Iter.enter_expression exp; + List.iter (function (cstr, _, _attrs) -> + match cstr with + Texp_constraint ct -> + iter_core_type ct + | Texp_coerce (cty1, cty2) -> + option iter_core_type cty1; iter_core_type cty2 + | Texp_open _ -> () + | Texp_poly cto -> option iter_core_type cto + | Texp_newtype _ -> ()) + exp.exp_extra; + begin + match exp.exp_desc with + Texp_ident _ -> () + | Texp_constant _ -> () + | Texp_let (rec_flag, list, exp) -> + iter_bindings rec_flag list; + iter_expression exp + | Texp_function { cases; _ } -> + iter_cases cases + | Texp_apply (exp, list) -> + iter_expression exp; + List.iter (fun (_label, expo) -> + match expo with + None -> () + | Some exp -> iter_expression exp + ) list + | Texp_match (exp, list1, list2, _) -> + iter_expression exp; + iter_cases list1; + iter_cases list2; + | Texp_try (exp, list) -> + iter_expression exp; + iter_cases list + | Texp_tuple list -> + List.iter iter_expression list + | Texp_construct (_, _, args) -> + List.iter iter_expression args + | Texp_variant (_label, expo) -> + begin match expo with + None -> () + | Some exp -> iter_expression exp + end + | Texp_record { fields; extended_expression; _ } -> + Array.iter (function + | _, Kept _ -> () + | _, Overridden (_, exp) -> iter_expression exp) + fields; + begin match extended_expression with + None -> () + | Some exp -> iter_expression exp + end + | Texp_field (exp, _, _label) -> + iter_expression exp + | Texp_setfield (exp1, _, _label, exp2) -> + iter_expression exp1; + iter_expression exp2 + | Texp_array list -> + List.iter iter_expression list + | Texp_ifthenelse (exp1, exp2, expo) -> + iter_expression exp1; + iter_expression exp2; + begin match expo with + None -> () + | Some exp -> iter_expression exp + end + | Texp_sequence (exp1, exp2) -> + iter_expression exp1; + iter_expression exp2 + | Texp_while (exp1, exp2) -> + iter_expression exp1; + iter_expression exp2 + | Texp_for (_id, _, exp1, exp2, _dir, exp3) -> + iter_expression exp1; + iter_expression exp2; + iter_expression exp3 + | Texp_send (exp, _meth, expo) -> + iter_expression exp; + begin + match expo with + None -> () + | Some exp -> iter_expression exp + end + | Texp_new _ + | Texp_instvar _ + | Texp_setinstvar _ + | Texp_override _ -> () + | Texp_letmodule (_id, _, mexpr, exp) -> + iter_module_expr mexpr; + iter_expression exp + | Texp_letexception (cd, exp) -> + iter_extension_constructor cd; + iter_expression exp + | Texp_assert exp -> iter_expression exp + | Texp_lazy exp -> iter_expression exp + | Texp_object () -> + () + | Texp_pack (mexpr) -> + iter_module_expr mexpr + | Texp_unreachable -> + () + | Texp_extension_constructor _ -> + () + end; + Iter.leave_expression exp; + + and iter_package_type pack = + Iter.enter_package_type pack; + List.iter (fun (_s, ct) -> iter_core_type ct) pack.pack_fields; + Iter.leave_package_type pack; + + and iter_signature sg = + Iter.enter_signature sg; + List.iter iter_signature_item sg.sig_items; + Iter.leave_signature sg; + + and iter_signature_item item = + Iter.enter_signature_item item; + begin + match item.sig_desc with + Tsig_value vd -> + iter_value_description vd + | Tsig_type (rf, list) -> + iter_type_declarations rf list + | Tsig_exception ext -> + iter_extension_constructor ext + | Tsig_typext tyext -> + iter_type_extension tyext + | Tsig_module md -> + iter_module_type md.md_type + | Tsig_recmodule list -> + List.iter (fun md -> iter_module_type md.md_type) list + | Tsig_modtype mtd -> + iter_module_type_declaration mtd + | Tsig_open _ -> () + | Tsig_include incl -> iter_module_type incl.incl_mod + | Tsig_class () -> () + | Tsig_class_type list -> + List.iter iter_class_type_declaration list + | Tsig_attribute _ -> () + end; + Iter.leave_signature_item item; + + and iter_module_type_declaration mtd = + Iter.enter_module_type_declaration mtd; + begin + match mtd.mtd_type with + | None -> () + | Some mtype -> iter_module_type mtype + end; + Iter.leave_module_type_declaration mtd + + + + and iter_class_type_declaration cd = + Iter.enter_class_type_declaration cd; + List.iter iter_type_parameter cd.ci_params; + iter_class_type cd.ci_expr; + Iter.leave_class_type_declaration cd; + + and iter_module_type mty = + Iter.enter_module_type mty; + begin + match mty.mty_desc with + Tmty_ident _ -> () + | Tmty_alias _ -> () + | Tmty_signature sg -> iter_signature sg + | Tmty_functor (_, _, mtype1, mtype2) -> + Misc.may iter_module_type mtype1; iter_module_type mtype2 + | Tmty_with (mtype, list) -> + iter_module_type mtype; + List.iter (fun (_path, _, withc) -> + iter_with_constraint withc + ) list + | Tmty_typeof mexpr -> + iter_module_expr mexpr + end; + Iter.leave_module_type mty; + + and iter_with_constraint cstr = + Iter.enter_with_constraint cstr; + begin + match cstr with + Twith_type decl -> iter_type_declaration decl + | Twith_module _ -> () + | Twith_typesubst decl -> iter_type_declaration decl + | Twith_modsubst _ -> () + end; + Iter.leave_with_constraint cstr; + + and iter_module_expr mexpr = + Iter.enter_module_expr mexpr; + begin + match mexpr.mod_desc with + Tmod_ident _ -> () + | Tmod_structure st -> iter_structure st + | Tmod_functor (_, _, mtype, mexpr) -> + Misc.may iter_module_type mtype; + iter_module_expr mexpr + | Tmod_apply (mexp1, mexp2, _) -> + iter_module_expr mexp1; + iter_module_expr mexp2 + | Tmod_constraint (mexpr, _, Tmodtype_implicit, _ ) -> + iter_module_expr mexpr + | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) -> + iter_module_expr mexpr; + iter_module_type mtype + | Tmod_unpack (exp, _mty) -> + iter_expression exp +(* iter_module_type mty *) + end; + Iter.leave_module_expr mexpr; + + + and iter_class_type ct = + Iter.enter_class_type ct; + begin + match ct.cltyp_desc with + Tcty_signature csg -> iter_class_signature csg + | Tcty_constr (_path, _, list) -> + List.iter iter_core_type list + | Tcty_arrow (_label, ct, cl) -> + iter_core_type ct; + iter_class_type cl + | Tcty_open (_, _, _, _, e) -> + iter_class_type e + end; + Iter.leave_class_type ct; + + and iter_class_signature cs = + Iter.enter_class_signature cs; + iter_core_type cs.csig_self; + List.iter iter_class_type_field cs.csig_fields; + Iter.leave_class_signature cs + + + and iter_class_type_field ctf = + Iter.enter_class_type_field ctf; + begin + match ctf.ctf_desc with + Tctf_inherit ct -> iter_class_type ct + | Tctf_val (_s, _mut, _virt, ct) -> + iter_core_type ct + | Tctf_method (_s, _priv, _virt, ct) -> + iter_core_type ct + | Tctf_constraint (ct1, ct2) -> + iter_core_type ct1; + iter_core_type ct2 + | Tctf_attribute _ -> () + end; + Iter.leave_class_type_field ctf + + and iter_core_type ct = + Iter.enter_core_type ct; + begin + match ct.ctyp_desc with + Ttyp_any -> () + | Ttyp_var _ -> () + | Ttyp_arrow (_label, ct1, ct2) -> + iter_core_type ct1; + iter_core_type ct2 + | Ttyp_tuple list -> List.iter iter_core_type list + | Ttyp_constr (_path, _, list) -> + List.iter iter_core_type list + | Ttyp_object (list, _o) -> + List.iter iter_object_field list + | Ttyp_class (_path, _, list) -> + List.iter iter_core_type list + | Ttyp_alias (ct, _s) -> + iter_core_type ct + | Ttyp_variant (list, _bool, _labels) -> + List.iter iter_row_field list + | Ttyp_poly (_list, ct) -> iter_core_type ct + | Ttyp_package pack -> iter_package_type pack + end; + Iter.leave_core_type ct + + and iter_row_field rf = + match rf with + Ttag (_label, _attrs, _bool, list) -> + List.iter iter_core_type list + | Tinherit ct -> iter_core_type ct + + and iter_object_field ofield = + match ofield with + OTtag (_, _, ct) | OTinherit ct -> iter_core_type ct + + end + +module DefaultIteratorArgument = struct + + let enter_structure _ = () + let enter_value_description _ = () + let enter_type_extension _ = () + let enter_extension_constructor _ = () + let enter_pattern _ = () + let enter_expression _ = () + let enter_package_type _ = () + let enter_signature _ = () + let enter_signature_item _ = () + let enter_module_type_declaration _ = () + let enter_module_type _ = () + let enter_module_expr _ = () + let enter_with_constraint _ = () + let enter_class_signature _ = () + + let enter_class_description _ = () + let enter_class_type_declaration _ = () + let enter_class_type _ = () + let enter_class_type_field _ = () + let enter_core_type _ = () + let enter_structure_item _ = () + + + let leave_structure _ = () + let leave_value_description _ = () + let leave_type_extension _ = () + let leave_extension_constructor _ = () + let leave_pattern _ = () + let leave_expression _ = () + let leave_package_type _ = () + let leave_signature _ = () + let leave_signature_item _ = () + let leave_module_type_declaration _ = () + let leave_module_type _ = () + let leave_module_expr _ = () + let leave_with_constraint _ = () + let leave_class_signature _ = () + + let leave_class_description _ = () + let leave_class_type_declaration _ = () + let leave_class_type _ = () + let leave_class_type_field _ = () + let leave_core_type _ = () + let leave_structure_item _ = () + + let enter_binding _ = () + let leave_binding _ = () + + let enter_bindings _ = () + let leave_bindings _ = () + + let enter_type_declaration _ = () + let leave_type_declaration _ = () + + let enter_type_declarations _ = () + let leave_type_declarations _ = () +end + +end +module Untypeast : sig +#1 "untypeast.mli" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Parsetree + +val lident_of_path : Path.t -> Longident.t + +type mapper = { + attribute: mapper -> Typedtree.attribute -> attribute; + attributes: mapper -> Typedtree.attribute list -> attribute list; + case: mapper -> Typedtree.case -> case; + cases: mapper -> Typedtree.case list -> case list; + class_signature: mapper -> Typedtree.class_signature -> class_signature; + class_type: mapper -> Typedtree.class_type -> class_type; + class_type_declaration: mapper -> Typedtree.class_type_declaration + -> class_type_declaration; + class_type_field: mapper -> Typedtree.class_type_field -> class_type_field; + constructor_declaration: mapper -> Typedtree.constructor_declaration + -> constructor_declaration; + expr: mapper -> Typedtree.expression -> expression; + extension_constructor: mapper -> Typedtree.extension_constructor + -> extension_constructor; + include_declaration: + mapper -> Typedtree.include_declaration -> include_declaration; + include_description: + mapper -> Typedtree.include_description -> include_description; + label_declaration: + mapper -> Typedtree.label_declaration -> label_declaration; + location: mapper -> Location.t -> Location.t; + module_binding: mapper -> Typedtree.module_binding -> module_binding; + module_declaration: + mapper -> Typedtree.module_declaration -> module_declaration; + module_expr: mapper -> Typedtree.module_expr -> module_expr; + module_type: mapper -> Typedtree.module_type -> module_type; + module_type_declaration: + mapper -> Typedtree.module_type_declaration -> module_type_declaration; + package_type: mapper -> Typedtree.package_type -> package_type; + open_description: mapper -> Typedtree.open_description -> open_description; + pat: mapper -> Typedtree.pattern -> pattern; + row_field: mapper -> Typedtree.row_field -> row_field; + object_field: mapper -> Typedtree.object_field -> object_field; + signature: mapper -> Typedtree.signature -> signature; + signature_item: mapper -> Typedtree.signature_item -> signature_item; + structure: mapper -> Typedtree.structure -> structure; + structure_item: mapper -> Typedtree.structure_item -> structure_item; + typ: mapper -> Typedtree.core_type -> core_type; + type_declaration: mapper -> Typedtree.type_declaration -> type_declaration; + type_extension: mapper -> Typedtree.type_extension -> type_extension; + type_kind: mapper -> Typedtree.type_kind -> type_kind; + value_binding: mapper -> Typedtree.value_binding -> value_binding; + value_description: mapper -> Typedtree.value_description -> value_description; + with_constraint: + mapper -> (Path.t * Longident.t Location.loc * Typedtree.with_constraint) + -> with_constraint; +} + +val default_mapper : mapper + +val untype_structure : ?mapper:mapper -> Typedtree.structure -> structure +val untype_signature : ?mapper:mapper -> Typedtree.signature -> signature + +val constant : Asttypes.constant -> Parsetree.constant + +end = struct +#1 "untypeast.ml" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Longident +open Asttypes +open Parsetree +open Ast_helper + +module T = Typedtree + +type mapper = { + attribute: mapper -> T.attribute -> attribute; + attributes: mapper -> T.attribute list -> attribute list; + case: mapper -> T.case -> case; + cases: mapper -> T.case list -> case list; + class_signature: mapper -> T.class_signature -> class_signature; + class_type: mapper -> T.class_type -> class_type; + class_type_declaration: mapper -> T.class_type_declaration + -> class_type_declaration; + class_type_field: mapper -> T.class_type_field -> class_type_field; + constructor_declaration: mapper -> T.constructor_declaration + -> constructor_declaration; + expr: mapper -> T.expression -> expression; + extension_constructor: mapper -> T.extension_constructor -> extension_constructor; include_declaration: mapper -> T.include_declaration -> include_declaration; include_description: mapper -> T.include_description -> include_description; @@ -26838,7 +28309,7 @@ let is_cons = function let pretty_const c = match c with | Const_int i -> Printf.sprintf "%d" i -| Const_char i -> Printf.sprintf "%C" (Char.unsafe_chr i) +| Const_char i -> Printf.sprintf "%s" (Pprintast.string_of_int_as_char i) | Const_string (s, _) -> Printf.sprintf "%S" s | Const_float f -> Printf.sprintf "%s" f | Const_int32 i -> Printf.sprintf "%ldl" i @@ -29129,7 +30600,7 @@ open Lambda let rec struct_const ppf = function | Const_base(Const_int n) -> fprintf ppf "%i" n - | Const_base(Const_char i) -> fprintf ppf "%C" (Char.unsafe_chr i) + | Const_base(Const_char i) -> fprintf ppf "%s" (Pprintast.string_of_int_as_char i) | Const_base(Const_string (s, _)) -> fprintf ppf "%S" s | Const_immstring s -> fprintf ppf "#%S" s | Const_base(Const_float f) -> fprintf ppf "%s" f @@ -51872,20 +53343,18 @@ let printConstant ?(templateLiteral = false) c = | Pconst_float (s, _) -> Doc.text s | Pconst_char c -> let str = - if c <= 127 then - match Char.chr c with - | '\'' -> "\\'" - | '\\' -> "\\\\" - | '\n' -> "\\n" - | '\t' -> "\\t" - | '\r' -> "\\r" - | '\b' -> "\\b" - | ' ' .. '~' as c -> - let s = (Bytes.create [@doesNotRaise]) 1 in - Bytes.unsafe_set s 0 c; - Bytes.unsafe_to_string s - | _ -> Res_utf8.encodeCodePoint c - else Res_utf8.encodeCodePoint c + match Char.unsafe_chr c with + | '\'' -> "\\'" + | '\\' -> "\\\\" + | '\n' -> "\\n" + | '\t' -> "\\t" + | '\r' -> "\\r" + | '\b' -> "\\b" + | ' ' .. '~' as c -> + let s = (Bytes.create [@doesNotRaise]) 1 in + Bytes.unsafe_set s 0 c; + Bytes.unsafe_to_string s + | _ -> Res_utf8.encodeCodePoint c in Doc.text ("'" ^ str ^ "'") @@ -79893,7 +81362,7 @@ and expression_desc cxt ~(level : int) f x : cxt = match v with | Float { f } -> Js_number.caml_float_literal_to_js_string f (* attach string here for float constant folding?*) - | Int { i; c = Some c } -> Format.asprintf "/* %C */%ld" (Char.unsafe_chr c) i + | Int { i; c = Some c } -> Format.asprintf "/* %s */%ld" (Pprintast.string_of_int_as_char c) i | Int { i; c = None } -> Int32.to_string i (* check , js convention with ocaml lexical convention *) @@ -92315,6 +93784,13 @@ end = struct open Format open Asttypes +let string_of_int_as_char i = + if i >= 0 && i <= 255 + then + Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) + else + Printf.sprintf "\'\\%d\'" i + let rec struct_const ppf (cst : Lam_constant.t) = match cst with | Const_js_true -> fprintf ppf "#true" @@ -92323,7 +93799,7 @@ let rec struct_const ppf (cst : Lam_constant.t) = | Const_module_alias -> fprintf ppf "#alias" | Const_js_undefined -> fprintf ppf "#undefined" | Const_int { i } -> fprintf ppf "%ld" i - | Const_char c -> fprintf ppf "%C" (Char.unsafe_chr c) + | Const_char i -> fprintf ppf "%s" (string_of_int_as_char i) | Const_string { s } -> fprintf ppf "%S" s | Const_float f -> fprintf ppf "%s" f | Const_int64 n -> fprintf ppf "%LiL" n @@ -262104,1469 +263580,6 @@ and core_type = wrap Parser.parse_core_type and expression = wrap Parser.parse_expression and pattern = wrap Parser.parse_pattern -end -module Pprintast : sig -#1 "pprintast.mli" -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Hongbo Zhang (University of Pennsylvania) *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -type space_formatter = (unit, Format.formatter, unit) format - - -val expression : Format.formatter -> Parsetree.expression -> unit -val string_of_expression : Parsetree.expression -> string - -val core_type: Format.formatter -> Parsetree.core_type -> unit -val pattern: Format.formatter -> Parsetree.pattern -> unit -val signature: Format.formatter -> Parsetree.signature -> unit -val structure: Format.formatter -> Parsetree.structure -> unit -val string_of_structure: Parsetree.structure -> string - -end = struct -#1 "pprintast.pp.ml" -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Thomas Gazagnaire, OCamlPro *) -(* Fabrice Le Fessant, INRIA Saclay *) -(* Hongbo Zhang, University of Pennsylvania *) -(* *) -(* Copyright 2007 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Original Code from Ber-metaocaml, modified for 3.12.0 and fixed *) -(* Printing code expressions *) -(* Authors: Ed Pizzi, Fabrice Le Fessant *) -(* Extensive Rewrite: Hongbo Zhang: University of Pennsylvania *) -(* TODO more fine-grained precedence pretty-printing *) - -open Asttypes -open Format -open Location -open Longident -open Parsetree -open Ast_helper - -let prefix_symbols = [ '!'; '?'; '~' ] ;; -let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/'; - '$'; '%'; '#' ] - -(* type fixity = Infix| Prefix *) -let special_infix_strings = - ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!="; "::" ] - -(* determines if the string is an infix string. - checks backwards, first allowing a renaming postfix ("_102") which - may have resulted from Pexp -> Texp -> Pexp translation, then checking - if all the characters in the beginning of the string are valid infix - characters. *) -let fixity_of_string = function - | s when List.mem s special_infix_strings -> `Infix s - | s when List.mem s.[0] infix_symbols -> `Infix s - | s when List.mem s.[0] prefix_symbols -> `Prefix s - | s when s.[0] = '.' -> `Mixfix s - | _ -> `Normal - -let view_fixity_of_exp = function - | {pexp_desc = Pexp_ident {txt=Lident l;_}; pexp_attributes = []} -> - fixity_of_string l - | _ -> `Normal - -let is_infix = function | `Infix _ -> true | _ -> false -let is_mixfix = function `Mixfix _ -> true | _ -> false - -(* which identifiers are in fact operators needing parentheses *) -let needs_parens txt = - let fix = fixity_of_string txt in - is_infix fix - || is_mixfix fix - || List.mem txt.[0] prefix_symbols - -(* some infixes need spaces around parens to avoid clashes with comment - syntax *) -let needs_spaces txt = - txt.[0]='*' || txt.[String.length txt - 1] = '*' - -(* add parentheses to binders when they are in fact infix or prefix operators *) -let protect_ident ppf txt = - let format : (_, _, _) format = - if not (needs_parens txt) then "%s" - else if needs_spaces txt then "(@;%s@;)" - else "(%s)" - in fprintf ppf format txt - -let protect_longident ppf print_longident longprefix txt = - let format : (_, _, _) format = - if not (needs_parens txt) then "%a.%s" - else if needs_spaces txt then "%a.(@;%s@;)" - else "%a.(%s)" in - fprintf ppf format print_longident longprefix txt - -type space_formatter = (unit, Format.formatter, unit) format - -let override = function - | Override -> "!" - | Fresh -> "" - -(* variance encoding: need to sync up with the [parser.mly] *) -let type_variance = function - | Invariant -> "" - | Covariant -> "+" - | Contravariant -> "-" - -type construct = - [ `cons of expression list - | `list of expression list - | `nil - | `normal - | `simple of Longident.t - | `tuple ] - -let view_expr x = - match x.pexp_desc with - | Pexp_construct ( {txt= Lident "()"; _},_) -> `tuple - | Pexp_construct ( {txt= Lident "[]";_},_) -> `nil - | Pexp_construct ( {txt= Lident"::";_},Some _) -> - let rec loop exp acc = match exp with - | {pexp_desc=Pexp_construct ({txt=Lident "[]";_},_); - pexp_attributes = []} -> - (List.rev acc,true) - | {pexp_desc= - Pexp_construct ({txt=Lident "::";_}, - Some ({pexp_desc= Pexp_tuple([e1;e2]); - pexp_attributes = []})); - pexp_attributes = []} - -> - loop e2 (e1::acc) - | e -> (List.rev (e::acc),false) in - let (ls,b) = loop x [] in - if b then - `list ls - else `cons ls - | Pexp_construct (x,None) -> `simple (x.txt) - | _ -> `normal - -let is_simple_construct :construct -> bool = function - | `nil | `tuple | `list _ | `simple _ -> true - | `cons _ | `normal -> false - -let pp = fprintf - -type ctxt = { - pipe : bool; - semi : bool; - ifthenelse : bool; -} - -let reset_ctxt = { pipe=false; semi=false; ifthenelse=false } -let under_pipe ctxt = { ctxt with pipe=true } -let under_semi ctxt = { ctxt with semi=true } -let under_ifthenelse ctxt = { ctxt with ifthenelse=true } -(* -let reset_semi ctxt = { ctxt with semi=false } -let reset_ifthenelse ctxt = { ctxt with ifthenelse=false } -let reset_pipe ctxt = { ctxt with pipe=false } -*) - -let list : 'a . ?sep:space_formatter -> ?first:space_formatter -> - ?last:space_formatter -> (Format.formatter -> 'a -> unit) -> - Format.formatter -> 'a list -> unit - = fun ?sep ?first ?last fu f xs -> - let first = match first with Some x -> x |None -> ("": _ format6) - and last = match last with Some x -> x |None -> ("": _ format6) - and sep = match sep with Some x -> x |None -> ("@ ": _ format6) in - let aux f = function - | [] -> () - | [x] -> fu f x - | xs -> - let rec loop f = function - | [x] -> fu f x - | x::xs -> fu f x; pp f sep; loop f xs; - | _ -> assert false in begin - pp f first; loop f xs; pp f last; - end in - aux f xs - -let option : 'a. ?first:space_formatter -> ?last:space_formatter -> - (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a option -> unit - = fun ?first ?last fu f a -> - let first = match first with Some x -> x | None -> ("": _ format6) - and last = match last with Some x -> x | None -> ("": _ format6) in - match a with - | None -> () - | Some x -> pp f first; fu f x; pp f last - -let paren: 'a . ?first:space_formatter -> ?last:space_formatter -> - bool -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit - = fun ?(first=("": _ format6)) ?(last=("": _ format6)) b fu f x -> - if b then (pp f "("; pp f first; fu f x; pp f last; pp f ")") - else fu f x - -let rec longident f = function - | Lident s -> protect_ident f s - | Ldot(y,s) -> protect_longident f longident y s - | Lapply (y,s) -> - pp f "%a(%a)" longident y longident s - -let longident_loc f x = pp f "%a" longident x.txt - -let constant f = function - | Pconst_char i -> pp f "%C" (Char.chr i) - | Pconst_string (i, None) -> pp f "%S" i - | Pconst_string (i, Some delim) -> pp f "{%s|%s|%s}" delim i delim - | Pconst_integer (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i - | Pconst_integer (i, Some m) -> - paren (i.[0]='-') (fun f (i, m) -> pp f "%s%c" i m) f (i,m) - | Pconst_float (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i - | Pconst_float (i, Some m) -> paren (i.[0]='-') (fun f (i,m) -> - pp f "%s%c" i m) f (i,m) - -(* trailing space*) -let mutable_flag f = function - | Immutable -> () - | Mutable -> pp f "mutable@;" -let virtual_flag f = function - | Concrete -> () - | Virtual -> pp f "virtual@;" - -(* trailing space added *) -let rec_flag f rf = - match rf with - | Nonrecursive -> () - | Recursive -> pp f "rec " -let nonrec_flag f rf = - match rf with - | Nonrecursive -> pp f "nonrec " - | Recursive -> () -let direction_flag f = function - | Upto -> pp f "to@ " - | Downto -> pp f "downto@ " -let private_flag f = function - | Public -> () - | Private -> pp f "private@ " - -let constant_string f s = pp f "%S" s -let tyvar f str = pp f "'%s" str -let tyvar_loc f str = pp f "'%s" str.txt -let string_quot f x = pp f "`%s" x - -(* c ['a,'b] *) -let rec class_params_def ctxt f = function - | [] -> () - | l -> - pp f "[%a] " (* space *) - (list (type_param ctxt) ~sep:",") l - -and type_with_label ctxt f (label, c) = - match label with - | Nolabel -> core_type1 ctxt f c (* otherwise parenthesize *) - | Labelled s -> pp f "%s:%a" s (core_type1 ctxt) c - | Optional s -> pp f "?%s:%a" s (core_type1 ctxt) c - -and core_type ctxt f x = - if x.ptyp_attributes <> [] then begin - pp f "((%a)%a)" (core_type ctxt) {x with ptyp_attributes=[]} - (attributes ctxt) x.ptyp_attributes - end - else match x.ptyp_desc with - | Ptyp_arrow (l, ct1, ct2) -> - pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) - (type_with_label ctxt) (l,ct1) (core_type ctxt) ct2 - | Ptyp_alias (ct, s) -> - pp f "@[<2>%a@;as@;'%s@]" (core_type1 ctxt) ct s - | Ptyp_poly ([], ct) -> - core_type ctxt f ct - | Ptyp_poly (sl, ct) -> - pp f "@[<2>%a%a@]" - (fun f l -> - pp f "%a" - (fun f l -> match l with - | [] -> () - | _ -> - pp f "%a@;.@;" - (list tyvar_loc ~sep:"@;") l) - l) - sl (core_type ctxt) ct - | _ -> pp f "@[<2>%a@]" (core_type1 ctxt) x - -and core_type1 ctxt f x = - if x.ptyp_attributes <> [] then core_type ctxt f x - else match x.ptyp_desc with - | Ptyp_any -> pp f "_"; - | Ptyp_var s -> tyvar f s; - | Ptyp_tuple l -> pp f "(%a)" (list (core_type1 ctxt) ~sep:"@;*@;") l - | Ptyp_constr (li, l) -> - pp f (* "%a%a@;" *) "%a%a" - (fun f l -> match l with - |[] -> () - |[x]-> pp f "%a@;" (core_type1 ctxt) x - | _ -> list ~first:"(" ~last:")@;" (core_type ctxt) ~sep:",@;" f l) - l longident_loc li - | Ptyp_variant (l, closed, low) -> - let type_variant_helper f x = - match x with - | Rtag (l, attrs, _, ctl) -> - pp f "@[<2>%a%a@;%a@]" string_quot l.txt - (fun f l -> match l with - |[] -> () - | _ -> pp f "@;of@;%a" - (list (core_type ctxt) ~sep:"&") ctl) ctl - (attributes ctxt) attrs - | Rinherit ct -> core_type ctxt f ct in - pp f "@[<2>[%a%a]@]" - (fun f l -> - match l, closed with - | [], Closed -> () - | [], Open -> pp f ">" (* Cf #7200: print [>] correctly *) - | _ -> - pp f "%s@;%a" - (match (closed,low) with - | (Closed,None) -> "" - | (Closed,Some _) -> "<" (* FIXME desugar the syntax sugar*) - | (Open,_) -> ">") - (list type_variant_helper ~sep:"@;<1 -2>| ") l) l - (fun f low -> match low with - |Some [] |None -> () - |Some xs -> - pp f ">@ %a" - (list string_quot) xs) low - | Ptyp_object (l, o) -> - let core_field_type f = function - | Otag (l, attrs, ct) -> - pp f "@[%s: %a@ %a@ @]" l.txt - (core_type ctxt) ct (attributes ctxt) attrs (* Cf #7200 *) - | Oinherit ct -> - pp f "@[%a@ @]" (core_type ctxt) ct - in - let field_var f = function - | Asttypes.Closed -> () - | Asttypes.Open -> - match l with - | [] -> pp f ".." - | _ -> pp f " ;.." - in - pp f "@[<@ %a%a@ > @]" (list core_field_type ~sep:";") l - field_var o (* Cf #7200 *) - | Ptyp_class (li, l) -> (*FIXME*) - pp f "@[%a#%a@]" - (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") l - longident_loc li - | Ptyp_package (lid, cstrs) -> - let aux f (s, ct) = - pp f "type %a@ =@ %a" longident_loc s (core_type ctxt) ct in - (match cstrs with - |[] -> pp f "@[(module@ %a)@]" longident_loc lid - |_ -> - pp f "@[(module@ %a@ with@ %a)@]" longident_loc lid - (list aux ~sep:"@ and@ ") cstrs) - | Ptyp_extension e -> extension ctxt f e - | _ -> paren true (core_type ctxt) f x - -(********************pattern********************) -(* be cautious when use [pattern], [pattern1] is preferred *) -and pattern ctxt f x = - let rec list_of_pattern acc = function (* only consider ((A|B)|C)*) - | {ppat_desc= Ppat_or (p1,p2); ppat_attributes = []} -> - list_of_pattern (p2::acc) p1 - | x -> x::acc - in - if x.ppat_attributes <> [] then begin - pp f "((%a)%a)" (pattern ctxt) {x with ppat_attributes=[]} - (attributes ctxt) x.ppat_attributes - end - else match x.ppat_desc with - | Ppat_alias (p, s) -> - pp f "@[<2>%a@;as@;%a@]" (pattern ctxt) p protect_ident s.txt (* RA*) - | Ppat_or _ -> (* *) - pp f "@[%a@]" (list ~sep:"@,|" (pattern ctxt)) - (list_of_pattern [] x) - | _ -> pattern1 ctxt f x - -and pattern1 ctxt (f:Format.formatter) (x:pattern) : unit = - let rec pattern_list_helper f = function - | {ppat_desc = - Ppat_construct - ({ txt = Lident("::") ;_}, - Some ({ppat_desc = Ppat_tuple([pat1; pat2]);_})); - ppat_attributes = []} - - -> - pp f "%a::%a" (simple_pattern ctxt) pat1 pattern_list_helper pat2 (*RA*) - | p -> pattern1 ctxt f p - in - if x.ppat_attributes <> [] then pattern ctxt f x - else match x.ppat_desc with - | Ppat_variant (l, Some p) -> - pp f "@[<2>`%s@;%a@]" l (simple_pattern ctxt) p - | Ppat_construct (({txt=Lident("()"|"[]");_}), _) -> simple_pattern ctxt f x - | Ppat_construct (({txt;_} as li), po) -> - (* FIXME The third field always false *) - if txt = Lident "::" then - pp f "%a" pattern_list_helper x - else - (match po with - | Some x -> pp f "%a@;%a" longident_loc li (simple_pattern ctxt) x - | None -> pp f "%a" longident_loc li) - | _ -> simple_pattern ctxt f x - -and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = - if x.ppat_attributes <> [] then pattern ctxt f x - else match x.ppat_desc with - | Ppat_construct (({txt=Lident ("()"|"[]" as x);_}), _) -> pp f "%s" x - | Ppat_any -> pp f "_"; - | Ppat_var ({txt = txt;_}) -> protect_ident f txt - | Ppat_array l -> - pp f "@[<2>[|%a|]@]" (list (pattern1 ctxt) ~sep:";") l - | Ppat_unpack (s) -> - pp f "(module@ %s)@ " s.txt - | Ppat_type li -> - pp f "#%a" longident_loc li - | Ppat_record (l, closed) -> - let longident_x_pattern f (li, p) = - match (li,p) with - | ({txt=Lident s;_ }, - {ppat_desc=Ppat_var {txt;_}; - ppat_attributes=[]; _}) - when s = txt -> - pp f "@[<2>%a@]" longident_loc li - | _ -> - pp f "@[<2>%a@;=@;%a@]" longident_loc li (pattern1 ctxt) p - in - begin match closed with - | Closed -> - pp f "@[<2>{@;%a@;}@]" (list longident_x_pattern ~sep:";@;") l - | _ -> - pp f "@[<2>{@;%a;_}@]" (list longident_x_pattern ~sep:";@;") l - end - | Ppat_tuple l -> - pp f "@[<1>(%a)@]" (list ~sep:",@;" (pattern1 ctxt)) l (* level1*) - | Ppat_constant (c) -> pp f "%a" constant c - | Ppat_interval (c1, c2) -> pp f "%a..%a" constant c1 constant c2 - | Ppat_variant (l,None) -> pp f "`%s" l - | Ppat_constraint (p, ct) -> - pp f "@[<2>(%a@;:@;%a)@]" (pattern1 ctxt) p (core_type ctxt) ct - | Ppat_lazy p -> - pp f "@[<2>(lazy@;%a)@]" (pattern1 ctxt) p - | Ppat_exception p -> - pp f "@[<2>exception@;%a@]" (pattern1 ctxt) p - | Ppat_extension e -> extension ctxt f e - | Ppat_open (lid, p) -> - let with_paren = - match p.ppat_desc with - | Ppat_array _ | Ppat_record _ - | Ppat_construct (({txt=Lident ("()"|"[]");_}), _) -> false - | _ -> true in - pp f "@[<2>%a.%a @]" longident_loc lid - (paren with_paren @@ pattern1 ctxt) p - | _ -> paren true (pattern ctxt) f x - -and label_exp ctxt f (l,opt,p) = - match l with - | Nolabel -> - (* single case pattern parens needed here *) - pp f "%a@ " (simple_pattern ctxt) p - | Optional rest -> - begin match p with - | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []} - when txt = rest -> - (match opt with - | Some o -> pp f "?(%s=@;%a)@;" rest (expression ctxt) o - | None -> pp f "?%s@ " rest) - | _ -> - (match opt with - | Some o -> - pp f "?%s:(%a=@;%a)@;" - rest (pattern1 ctxt) p (expression ctxt) o - | None -> pp f "?%s:%a@;" rest (simple_pattern ctxt) p) - end - | Labelled l -> match p with - | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []} - when txt = l -> - pp f "~%s@;" l - | _ -> pp f "~%s:%a@;" l (simple_pattern ctxt) p - -and sugar_expr ctxt f e = - if e.pexp_attributes <> [] then false - else match e.pexp_desc with - | Pexp_apply ({ pexp_desc = Pexp_ident {txt = id; _}; - pexp_attributes=[]; _}, args) - when List.for_all (fun (lab, _) -> lab = Nolabel) args -> begin - let print_indexop a path_prefix assign left right print_index indices - rem_args = - let print_path ppf = function - | None -> () - | Some m -> pp ppf ".%a" longident m in - match assign, rem_args with - | false, [] -> - pp f "@[%a%a%s%a%s@]" - (simple_expr ctxt) a print_path path_prefix - left (list ~sep:"," print_index) indices right; true - | true, [v] -> - pp f "@[%a%a%s%a%s@ <-@;<1 2>%a@]" - (simple_expr ctxt) a print_path path_prefix - left (list ~sep:"," print_index) indices right - (simple_expr ctxt) v; true - | _ -> false in - match id, List.map snd args with - | Lident "!", [e] -> - pp f "@[!%a@]" (simple_expr ctxt) e; true - | Ldot (path, ("get"|"set" as func)), a :: other_args -> begin - let assign = func = "set" in - let print = print_indexop a None assign in - match path, other_args with - | Lident "Array", i :: rest -> - print ".(" ")" (expression ctxt) [i] rest - | Lident "String", i :: rest -> - print ".[" "]" (expression ctxt) [i] rest - | Ldot (Lident "Bigarray", "Array1"), i1 :: rest -> - print ".{" "}" (simple_expr ctxt) [i1] rest - | Ldot (Lident "Bigarray", "Array2"), i1 :: i2 :: rest -> - print ".{" "}" (simple_expr ctxt) [i1; i2] rest - | Ldot (Lident "Bigarray", "Array3"), i1 :: i2 :: i3 :: rest -> - print ".{" "}" (simple_expr ctxt) [i1; i2; i3] rest - | Ldot (Lident "Bigarray", "Genarray"), - {pexp_desc = Pexp_array indexes; pexp_attributes = []} :: rest -> - print ".{" "}" (simple_expr ctxt) indexes rest - | _ -> false - end - | (Lident s | Ldot(_,s)) , a :: i :: rest - when s.[0] = '.' -> - let n = String.length s in - (* extract operator: - assignment operators end with [right_bracket ^ "<-"], - access operators end with [right_bracket] directly - *) - let assign = s.[n - 1] = '-' in - let kind = - (* extract the right end bracket *) - if assign then s.[n - 3] else s.[n - 1] in - let left, right = match kind with - | ')' -> '(', ")" - | ']' -> '[', "]" - | '}' -> '{', "}" - | _ -> assert false in - let path_prefix = match id with - | Ldot(m,_) -> Some m - | _ -> None in - let left = String.sub s 0 (1+String.index s left) in - print_indexop a path_prefix assign left right - (expression ctxt) [i] rest - | _ -> false - end - | _ -> false - -and expression ctxt f x = - if x.pexp_attributes <> [] then - pp f "((%a)@,%a)" (expression ctxt) {x with pexp_attributes=[]} - (attributes ctxt) x.pexp_attributes - else match x.pexp_desc with - | Pexp_function _ | Pexp_fun _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _ - when ctxt.pipe || ctxt.semi -> - paren true (expression reset_ctxt) f x - | Pexp_ifthenelse _ | Pexp_sequence _ when ctxt.ifthenelse -> - paren true (expression reset_ctxt) f x - | Pexp_let _ | Pexp_letmodule _ | Pexp_open _ | Pexp_letexception _ - when ctxt.semi -> - paren true (expression reset_ctxt) f x - | Pexp_fun (l, e0, p, e) -> - pp f "@[<2>fun@;%a->@;%a@]" - (label_exp ctxt) (l, e0, p) - (expression ctxt) e - | Pexp_function l -> - pp f "@[function%a@]" (case_list ctxt) l - | Pexp_match (e, l) -> - pp f "@[@[@[<2>match %a@]@ with@]%a@]" - (expression reset_ctxt) e (case_list ctxt) l - - | Pexp_try (e, l) -> - pp f "@[<0>@[try@ %a@]@ @[<0>with%a@]@]" - (* "try@;@[<2>%a@]@\nwith@\n%a"*) - (expression reset_ctxt) e (case_list ctxt) l - | Pexp_let (rf, l, e) -> - (* pp f "@[<2>let %a%a in@;<1 -2>%a@]" - (*no indentation here, a new line*) *) - (* rec_flag rf *) - pp f "@[<2>%a in@;<1 -2>%a@]" - (bindings reset_ctxt) (rf,l) - (expression ctxt) e - | Pexp_apply (e, l) -> - begin if not (sugar_expr ctxt f x) then - match view_fixity_of_exp e with - | `Infix s -> - begin match l with - | [ (Nolabel, _) as arg1; (Nolabel, _) as arg2 ] -> - (* FIXME associativity label_x_expression_param *) - pp f "@[<2>%a@;%s@;%a@]" - (label_x_expression_param reset_ctxt) arg1 s - (label_x_expression_param ctxt) arg2 - | _ -> - pp f "@[<2>%a %a@]" - (simple_expr ctxt) e - (list (label_x_expression_param ctxt)) l - end - | `Prefix s -> - let s = - if List.mem s ["~+";"~-";"~+.";"~-."] && - (match l with - (* See #7200: avoid turning (~- 1) into (- 1) which is - parsed as an int literal *) - |[(_,{pexp_desc=Pexp_constant _})] -> false - | _ -> true) - then String.sub s 1 (String.length s -1) - else s in - begin match l with - | [(Nolabel, x)] -> - pp f "@[<2>%s@;%a@]" s (simple_expr ctxt) x - | _ -> - pp f "@[<2>%a %a@]" (simple_expr ctxt) e - (list (label_x_expression_param ctxt)) l - end - | _ -> - pp f "@[%a@]" begin fun f (e,l) -> - pp f "%a@ %a" (expression2 ctxt) e - (list (label_x_expression_param reset_ctxt)) l - (* reset here only because [function,match,try,sequence] - are lower priority *) - end (e,l) - end - - | Pexp_construct (li, Some eo) - when not (is_simple_construct (view_expr x))-> (* Not efficient FIXME*) - (match view_expr x with - | `cons ls -> list (simple_expr ctxt) f ls ~sep:"@;::@;" - | `normal -> - pp f "@[<2>%a@;%a@]" longident_loc li - (simple_expr ctxt) eo - | _ -> assert false) - | Pexp_setfield (e1, li, e2) -> - pp f "@[<2>%a.%a@ <-@ %a@]" - (simple_expr ctxt) e1 longident_loc li (simple_expr ctxt) e2 - | Pexp_ifthenelse (e1, e2, eo) -> - (* @;@[<2>else@ %a@]@] *) - let fmt:(_,_,_)format ="@[@[<2>if@ %a@]@;@[<2>then@ %a@]%a@]" in - let expression_under_ifthenelse = expression (under_ifthenelse ctxt) in - pp f fmt expression_under_ifthenelse e1 expression_under_ifthenelse e2 - (fun f eo -> match eo with - | Some x -> - pp f "@;@[<2>else@;%a@]" (expression (under_semi ctxt)) x - | None -> () (* pp f "()" *)) eo - | Pexp_sequence _ -> - let rec sequence_helper acc = function - | {pexp_desc=Pexp_sequence(e1,e2); pexp_attributes = []} -> - sequence_helper (e1::acc) e2 - | v -> List.rev (v::acc) in - let lst = sequence_helper [] x in - pp f "@[%a@]" - (list (expression (under_semi ctxt)) ~sep:";@;") lst - | Pexp_new (li) -> - pp f "@[new@ %a@]" longident_loc li; - | Pexp_setinstvar (s, e) -> - pp f "@[%s@ <-@ %a@]" s.txt (expression ctxt) e - | Pexp_override l -> (* FIXME *) - let string_x_expression f (s, e) = - pp f "@[%s@ =@ %a@]" s.txt (expression ctxt) e in - pp f "@[{<%a>}@]" - (list string_x_expression ~sep:";" ) l; - | Pexp_letmodule (s, me, e) -> - pp f "@[let@ module@ %s@ =@ %a@ in@ %a@]" s.txt - (module_expr reset_ctxt) me (expression ctxt) e - | Pexp_letexception (cd, e) -> - pp f "@[let@ exception@ %a@ in@ %a@]" - (extension_constructor ctxt) cd - (expression ctxt) e - | Pexp_assert e -> - pp f "@[assert@ %a@]" (simple_expr ctxt) e - | Pexp_lazy (e) -> - pp f "@[lazy@ %a@]" (simple_expr ctxt) e - (* Pexp_poly: impossible but we should print it anyway, rather than - assert false *) - | Pexp_poly (e, None) -> - pp f "@[!poly!@ %a@]" (simple_expr ctxt) e - | Pexp_poly (e, Some ct) -> - pp f "@[(!poly!@ %a@ : %a)@]" - (simple_expr ctxt) e (core_type ctxt) ct - | Pexp_open (ovf, lid, e) -> - pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid - (expression ctxt) e - | Pexp_variant (l,Some eo) -> - pp f "@[<2>`%s@;%a@]" l (simple_expr ctxt) eo - | Pexp_extension e -> extension ctxt f e - | Pexp_unreachable -> pp f "." - | _ -> expression1 ctxt f x - -and expression1 ctxt f x = - if x.pexp_attributes <> [] then expression ctxt f x - else match x.pexp_desc with - | Pexp_object cs -> pp f "%a" (class_structure ctxt) cs - | _ -> expression2 ctxt f x -(* used in [Pexp_apply] *) - -and expression2 ctxt f x = - if x.pexp_attributes <> [] then expression ctxt f x - else match x.pexp_desc with - | Pexp_field (e, li) -> - pp f "@[%a.%a@]" (simple_expr ctxt) e longident_loc li - | Pexp_send (e, s) -> pp f "@[%a#%s@]" (simple_expr ctxt) e s.txt - - | _ -> simple_expr ctxt f x - -and simple_expr ctxt f x = - if x.pexp_attributes <> [] then expression ctxt f x - else match x.pexp_desc with - | Pexp_construct _ when is_simple_construct (view_expr x) -> - (match view_expr x with - | `nil -> pp f "[]" - | `tuple -> pp f "()" - | `list xs -> - pp f "@[[%a]@]" - (list (expression (under_semi ctxt)) ~sep:";@;") xs - | `simple x -> longident f x - | _ -> assert false) - | Pexp_ident li -> - longident_loc f li - (* (match view_fixity_of_exp x with *) - (* |`Normal -> longident_loc f li *) - (* | `Prefix _ | `Infix _ -> pp f "( %a )" longident_loc li) *) - | Pexp_constant c -> constant f c; - | Pexp_pack me -> - pp f "(module@;%a)" (module_expr ctxt) me - | Pexp_newtype (lid, e) -> - pp f "fun@;(type@;%s)@;->@;%a" lid.txt (expression ctxt) e - | Pexp_tuple l -> - pp f "@[(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l - | Pexp_constraint (e, ct) -> - pp f "(%a : %a)" (expression ctxt) e (core_type ctxt) ct - | Pexp_coerce (e, cto1, ct) -> - pp f "(%a%a :> %a)" (expression ctxt) e - (option (core_type ctxt) ~first:" : " ~last:" ") cto1 (* no sep hint*) - (core_type ctxt) ct - | Pexp_variant (l, None) -> pp f "`%s" l - | Pexp_record (l, eo) -> - let longident_x_expression f ( li, e) = - match e with - | {pexp_desc=Pexp_ident {txt;_}; - pexp_attributes=[]; _} when li.txt = txt -> - pp f "@[%a@]" longident_loc li - | _ -> - pp f "@[%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e - in - pp f "@[@[{@;%a%a@]@;}@]"(* "@[{%a%a}@]" *) - (option ~last:" with@;" (simple_expr ctxt)) eo - (list longident_x_expression ~sep:";@;") l - | Pexp_array (l) -> - pp f "@[<0>@[<2>[|%a|]@]@]" - (list (simple_expr (under_semi ctxt)) ~sep:";") l - | Pexp_while (e1, e2) -> - let fmt : (_,_,_) format = "@[<2>while@;%a@;do@;%a@;done@]" in - pp f fmt (expression ctxt) e1 (expression ctxt) e2 - | Pexp_for (s, e1, e2, df, e3) -> - let fmt:(_,_,_)format = - "@[@[@[<2>for %a =@;%a@;%a%a@;do@]@;%a@]@;done@]" in - let expression = expression ctxt in - pp f fmt (pattern ctxt) s expression e1 direction_flag - df expression e2 expression e3 - | _ -> paren true (expression ctxt) f x - -and attributes ctxt f l = - List.iter (attribute ctxt f) l - -and item_attributes ctxt f l = - List.iter (item_attribute ctxt f) l - -and attribute ctxt f (s, e) = - pp f "@[<2>[@@%s@ %a]@]" s.txt (payload ctxt) e - -and item_attribute ctxt f (s, e) = - pp f "@[<2>[@@@@%s@ %a]@]" s.txt (payload ctxt) e - -and floating_attribute ctxt f (s, e) = - pp f "@[<2>[@@@@@@%s@ %a]@]" s.txt (payload ctxt) e - -and value_description ctxt f x = - (* note: value_description has an attribute field, - but they're already printed by the callers this method *) - pp f "@[%a%a@]" (core_type ctxt) x.pval_type - (fun f x -> - - if x.pval_prim <> [] - then pp f "@ =@ %a" (list constant_string) x.pval_prim - - ) x - -and extension ctxt f (s, e) = - pp f "@[<2>[%%%s@ %a]@]" s.txt (payload ctxt) e - -and item_extension ctxt f (s, e) = - pp f "@[<2>[%%%%%s@ %a]@]" s.txt (payload ctxt) e - -and exception_declaration ctxt f ext = - pp f "@[exception@ %a@]" (extension_constructor ctxt) ext - -and class_signature ctxt f { pcsig_self = ct; pcsig_fields = l ;_} = - let class_type_field f x = - match x.pctf_desc with - | Pctf_inherit (ct) -> - pp f "@[<2>inherit@ %a@]%a" (class_type ctxt) ct - (item_attributes ctxt) x.pctf_attributes - | Pctf_val (s, mf, vf, ct) -> - pp f "@[<2>val @ %a%a%s@ :@ %a@]%a" - mutable_flag mf virtual_flag vf s.txt (core_type ctxt) ct - (item_attributes ctxt) x.pctf_attributes - | Pctf_method (s, pf, vf, ct) -> - pp f "@[<2>method %a %a%s :@;%a@]%a" - private_flag pf virtual_flag vf s.txt (core_type ctxt) ct - (item_attributes ctxt) x.pctf_attributes - | Pctf_constraint (ct1, ct2) -> - pp f "@[<2>constraint@ %a@ =@ %a@]%a" - (core_type ctxt) ct1 (core_type ctxt) ct2 - (item_attributes ctxt) x.pctf_attributes - | Pctf_attribute a -> floating_attribute ctxt f a - | Pctf_extension e -> - item_extension ctxt f e; - item_attributes ctxt f x.pctf_attributes - in - pp f "@[@[object@[<1>%a@]@ %a@]@ end@]" - (fun f -> function - {ptyp_desc=Ptyp_any; ptyp_attributes=[]; _} -> () - | ct -> pp f " (%a)" (core_type ctxt) ct) ct - (list class_type_field ~sep:"@;") l - -(* call [class_signature] called by [class_signature] *) -and class_type ctxt f x = - match x.pcty_desc with - | Pcty_signature cs -> - class_signature ctxt f cs; - attributes ctxt f x.pcty_attributes - | Pcty_constr (li, l) -> - pp f "%a%a%a" - (fun f l -> match l with - | [] -> () - | _ -> pp f "[%a]@ " (list (core_type ctxt) ~sep:"," ) l) l - longident_loc li - (attributes ctxt) x.pcty_attributes - | Pcty_arrow (l, co, cl) -> - pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) - (type_with_label ctxt) (l,co) - (class_type ctxt) cl - | Pcty_extension e -> - extension ctxt f e; - attributes ctxt f x.pcty_attributes - | Pcty_open (ovf, lid, e) -> - pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid - (class_type ctxt) e - -(* [class type a = object end] *) -and class_type_declaration_list ctxt f l = - let class_type_declaration kwd f x = - let { pci_params=ls; pci_name={ txt; _ }; _ } = x in - pp f "@[<2>%s %a%a%s@ =@ %a@]%a" kwd - virtual_flag x.pci_virt - (class_params_def ctxt) ls txt - (class_type ctxt) x.pci_expr - (item_attributes ctxt) x.pci_attributes - in - match l with - | [] -> () - | [x] -> class_type_declaration "class type" f x - | x :: xs -> - pp f "@[%a@,%a@]" - (class_type_declaration "class type") x - (list ~sep:"@," (class_type_declaration "and")) xs - -and class_field ctxt f x = - match x.pcf_desc with - | Pcf_inherit () -> () - | Pcf_val (s, mf, Cfk_concrete (ovf, e)) -> - pp f "@[<2>val%s %a%s =@;%a@]%a" (override ovf) - mutable_flag mf s.txt - (expression ctxt) e - (item_attributes ctxt) x.pcf_attributes - | Pcf_method (s, pf, Cfk_virtual ct) -> - pp f "@[<2>method virtual %a %s :@;%a@]%a" - private_flag pf s.txt - (core_type ctxt) ct - (item_attributes ctxt) x.pcf_attributes - | Pcf_val (s, mf, Cfk_virtual ct) -> - pp f "@[<2>val virtual %a%s :@ %a@]%a" - mutable_flag mf s.txt - (core_type ctxt) ct - (item_attributes ctxt) x.pcf_attributes - | Pcf_method (s, pf, Cfk_concrete (ovf, e)) -> - let bind e = - binding ctxt f - {pvb_pat= - {ppat_desc=Ppat_var s;ppat_loc=Location.none;ppat_attributes=[]}; - pvb_expr=e; - pvb_attributes=[]; - pvb_loc=Location.none; - } - in - pp f "@[<2>method%s %a%a@]%a" - (override ovf) - private_flag pf - (fun f -> function - | {pexp_desc=Pexp_poly (e, Some ct); pexp_attributes=[]; _} -> - pp f "%s :@;%a=@;%a" - s.txt (core_type ctxt) ct (expression ctxt) e - | {pexp_desc=Pexp_poly (e, None); pexp_attributes=[]; _} -> - bind e - | _ -> bind e) e - (item_attributes ctxt) x.pcf_attributes - | Pcf_constraint (ct1, ct2) -> - pp f "@[<2>constraint %a =@;%a@]%a" - (core_type ctxt) ct1 - (core_type ctxt) ct2 - (item_attributes ctxt) x.pcf_attributes - | Pcf_initializer (e) -> - pp f "@[<2>initializer@ %a@]%a" - (expression ctxt) e - (item_attributes ctxt) x.pcf_attributes - | Pcf_attribute a -> floating_attribute ctxt f a - | Pcf_extension e -> - item_extension ctxt f e; - item_attributes ctxt f x.pcf_attributes - -and class_structure ctxt f { pcstr_self = p; pcstr_fields = l } = - pp f "@[@[object%a@;%a@]@;end@]" - (fun f p -> match p.ppat_desc with - | Ppat_any -> () - | Ppat_constraint _ -> pp f " %a" (pattern ctxt) p - | _ -> pp f " (%a)" (pattern ctxt) p) p - (list (class_field ctxt)) l - -and module_type ctxt f x = - if x.pmty_attributes <> [] then begin - pp f "((%a)%a)" (module_type ctxt) {x with pmty_attributes=[]} - (attributes ctxt) x.pmty_attributes - end else - match x.pmty_desc with - | Pmty_ident li -> - pp f "%a" longident_loc li; - | Pmty_alias li -> - pp f "(module %a)" longident_loc li; - | Pmty_signature (s) -> - pp f "@[@[sig@ %a@]@ end@]" (* "@[sig@ %a@ end@]" *) - (list (signature_item ctxt)) s (* FIXME wrong indentation*) - | Pmty_functor (_, None, mt2) -> - pp f "@[functor () ->@ %a@]" (module_type ctxt) mt2 - | Pmty_functor (s, Some mt1, mt2) -> - if s.txt = "_" then - pp f "@[%a@ ->@ %a@]" - (module_type ctxt) mt1 (module_type ctxt) mt2 - else - pp f "@[functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt - (module_type ctxt) mt1 (module_type ctxt) mt2 - | Pmty_with (mt, l) -> - let with_constraint f = function - | Pwith_type (li, ({ptype_params= ls ;_} as td)) -> - let ls = List.map fst ls in - pp f "type@ %a %a =@ %a" - (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") - ls longident_loc li (type_declaration ctxt) td - | Pwith_module (li, li2) -> - pp f "module %a =@ %a" longident_loc li longident_loc li2; - | Pwith_typesubst (li, ({ptype_params=ls;_} as td)) -> - let ls = List.map fst ls in - pp f "type@ %a %a :=@ %a" - (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") - ls longident_loc li - (type_declaration ctxt) td - | Pwith_modsubst (li, li2) -> - pp f "module %a :=@ %a" longident_loc li longident_loc li2 in - (match l with - | [] -> pp f "@[%a@]" (module_type ctxt) mt - | _ -> pp f "@[(%a@ with@ %a)@]" - (module_type ctxt) mt (list with_constraint ~sep:"@ and@ ") l) - | Pmty_typeof me -> - pp f "@[module@ type@ of@ %a@]" (module_expr ctxt) me - | Pmty_extension e -> extension ctxt f e - -and signature ctxt f x = list ~sep:"@\n" (signature_item ctxt) f x - -and signature_item ctxt f x : unit = - match x.psig_desc with - | Psig_type (rf, l) -> - type_def_list ctxt f (rf, l) - | Psig_value vd -> - let intro = if vd.pval_prim = [] then "val" else "external" in - pp f "@[<2>%s@ %a@ :@ %a@]%a" intro - protect_ident vd.pval_name.txt - (value_description ctxt) vd - (item_attributes ctxt) vd.pval_attributes - | Psig_typext te -> - type_extension ctxt f te - | Psig_exception ed -> - exception_declaration ctxt f ed - | Psig_class () -> - () - | Psig_module ({pmd_type={pmty_desc=Pmty_alias alias; - pmty_attributes=[]; _};_} as pmd) -> - pp f "@[module@ %s@ =@ %a@]%a" pmd.pmd_name.txt - longident_loc alias - (item_attributes ctxt) pmd.pmd_attributes - | Psig_module pmd -> - pp f "@[module@ %s@ :@ %a@]%a" - pmd.pmd_name.txt - (module_type ctxt) pmd.pmd_type - (item_attributes ctxt) pmd.pmd_attributes - | Psig_open od -> - pp f "@[open%s@ %a@]%a" - (override od.popen_override) - longident_loc od.popen_lid - (item_attributes ctxt) od.popen_attributes - | Psig_include incl -> - pp f "@[include@ %a@]%a" - (module_type ctxt) incl.pincl_mod - (item_attributes ctxt) incl.pincl_attributes - | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> - pp f "@[module@ type@ %s%a@]%a" - s.txt - (fun f md -> match md with - | None -> () - | Some mt -> - pp_print_space f () ; - pp f "@ =@ %a" (module_type ctxt) mt - ) md - (item_attributes ctxt) attrs - | Psig_class_type (l) -> class_type_declaration_list ctxt f l - | Psig_recmodule decls -> - let rec string_x_module_type_list f ?(first=true) l = - match l with - | [] -> () ; - | pmd :: tl -> - if not first then - pp f "@ @[and@ %s:@ %a@]%a" pmd.pmd_name.txt - (module_type ctxt) pmd.pmd_type - (item_attributes ctxt) pmd.pmd_attributes - else - pp f "@[module@ rec@ %s:@ %a@]%a" pmd.pmd_name.txt - (module_type ctxt) pmd.pmd_type - (item_attributes ctxt) pmd.pmd_attributes; - string_x_module_type_list f ~first:false tl - in - string_x_module_type_list f decls - | Psig_attribute a -> floating_attribute ctxt f a - | Psig_extension(e, a) -> - item_extension ctxt f e; - item_attributes ctxt f a - -and module_expr ctxt f x = - if x.pmod_attributes <> [] then - pp f "((%a)%a)" (module_expr ctxt) {x with pmod_attributes=[]} - (attributes ctxt) x.pmod_attributes - else match x.pmod_desc with - | Pmod_structure (s) -> - pp f "@[struct@;@[<0>%a@]@;<1 -2>end@]" - (list (structure_item ctxt) ~sep:"@\n") s; - | Pmod_constraint (me, mt) -> - pp f "@[(%a@ :@ %a)@]" - (module_expr ctxt) me - (module_type ctxt) mt - | Pmod_ident (li) -> - pp f "%a" longident_loc li; - | Pmod_functor (_, None, me) -> - pp f "functor ()@;->@;%a" (module_expr ctxt) me - | Pmod_functor (s, Some mt, me) -> - pp f "functor@ (%s@ :@ %a)@;->@;%a" - s.txt (module_type ctxt) mt (module_expr ctxt) me - | Pmod_apply (me1, me2) -> - pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2 - (* Cf: #7200 *) - | Pmod_unpack e -> - pp f "(val@ %a)" (expression ctxt) e - | Pmod_extension e -> extension ctxt f e - -and structure ctxt f x = list ~sep:"@\n" (structure_item ctxt) f x - -and payload ctxt f = function - | PStr [{pstr_desc = Pstr_eval (e, attrs)}] -> - pp f "@[<2>%a@]%a" - (expression ctxt) e - (item_attributes ctxt) attrs - | PStr x -> structure ctxt f x - | PTyp x -> pp f ":"; core_type ctxt f x - | PSig x -> pp f ":"; signature ctxt f x - | PPat (x, None) -> pp f "?"; pattern ctxt f x - | PPat (x, Some e) -> - pp f "?"; pattern ctxt f x; - pp f " when "; expression ctxt f e - -(* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *) -and binding ctxt f {pvb_pat=p; pvb_expr=x; _} = - (* .pvb_attributes have already been printed by the caller, #bindings *) - let rec pp_print_pexp_function f x = - if x.pexp_attributes <> [] then pp f "=@;%a" (expression ctxt) x - else match x.pexp_desc with - | Pexp_fun (label, eo, p, e) -> - if label=Nolabel then - pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function e - else - pp f "%a@ %a" - (label_exp ctxt) (label,eo,p) pp_print_pexp_function e - | Pexp_newtype (str,e) -> - pp f "(type@ %s)@ %a" str.txt pp_print_pexp_function e - | _ -> pp f "=@;%a" (expression ctxt) x - in - let tyvars_str tyvars = List.map (fun v -> v.txt) tyvars in - let is_desugared_gadt p e = - let gadt_pattern = - match p with - | {ppat_desc=Ppat_constraint({ppat_desc=Ppat_var _} as pat, - {ptyp_desc=Ptyp_poly (args_tyvars, rt)}); - ppat_attributes=[]}-> - Some (pat, args_tyvars, rt) - | _ -> None in - let rec gadt_exp tyvars e = - match e with - | {pexp_desc=Pexp_newtype (tyvar, e); pexp_attributes=[]} -> - gadt_exp (tyvar :: tyvars) e - | {pexp_desc=Pexp_constraint (e, ct); pexp_attributes=[]} -> - Some (List.rev tyvars, e, ct) - | _ -> None in - let gadt_exp = gadt_exp [] e in - match gadt_pattern, gadt_exp with - | Some (p, pt_tyvars, pt_ct), Some (e_tyvars, e, e_ct) - when tyvars_str pt_tyvars = tyvars_str e_tyvars -> - let ety = Typ.varify_constructors e_tyvars e_ct in - if ety = pt_ct then - Some (p, pt_tyvars, e_ct, e) else None - | _ -> None in - if x.pexp_attributes <> [] - then pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x else - match is_desugared_gadt p x with - | Some (p, [], ct, e) -> - pp f "%a@;: %a@;=@;%a" - (simple_pattern ctxt) p (core_type ctxt) ct (expression ctxt) e - | Some (p, tyvars, ct, e) -> begin - pp f "%a@;: type@;%a.@;%a@;=@;%a" - (simple_pattern ctxt) p (list pp_print_string ~sep:"@;") - (tyvars_str tyvars) (core_type ctxt) ct (expression ctxt) e - end - | None -> begin - match p with - | {ppat_desc=Ppat_constraint(p ,ty); - ppat_attributes=[]} -> (* special case for the first*) - begin match ty with - | {ptyp_desc=Ptyp_poly _; ptyp_attributes=[]} -> - pp f "%a@;:@;%a@;=@;%a" (simple_pattern ctxt) p - (core_type ctxt) ty (expression ctxt) x - | _ -> - pp f "(%a@;:@;%a)@;=@;%a" (simple_pattern ctxt) p - (core_type ctxt) ty (expression ctxt) x - end - | {ppat_desc=Ppat_var _; ppat_attributes=[]} -> - pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x - | _ -> - pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x - end - -(* [in] is not printed *) -and bindings ctxt f (rf,l) = - let binding kwd rf f x = - pp f "@[<2>%s %a%a@]%a" kwd rec_flag rf - (binding ctxt) x (item_attributes ctxt) x.pvb_attributes - in - match l with - | [] -> () - | [x] -> binding "let" rf f x - | x::xs -> - pp f "@[%a@,%a@]" - (binding "let" rf) x - (list ~sep:"@," (binding "and" Nonrecursive)) xs - -and structure_item ctxt f x = - match x.pstr_desc with - | Pstr_eval (e, attrs) -> - pp f "@[;;%a@]%a" - (expression ctxt) e - (item_attributes ctxt) attrs - | Pstr_type (_, []) -> assert false - | Pstr_type (rf, l) -> type_def_list ctxt f (rf, l) - | Pstr_value (rf, l) -> - (* pp f "@[let %a%a@]" rec_flag rf bindings l *) - pp f "@[<2>%a@]" (bindings ctxt) (rf,l) - | Pstr_typext te -> type_extension ctxt f te - | Pstr_exception ed -> exception_declaration ctxt f ed - | Pstr_module x -> - let rec module_helper = function - | {pmod_desc=Pmod_functor(s,mt,me'); pmod_attributes = []} -> - if mt = None then pp f "()" - else Misc.may (pp f "(%s:%a)" s.txt (module_type ctxt)) mt; - module_helper me' - | me -> me - in - pp f "@[module %s%a@]%a" - x.pmb_name.txt - (fun f me -> - let me = module_helper me in - match me with - | {pmod_desc= - Pmod_constraint - (me', - ({pmty_desc=(Pmty_ident (_) - | Pmty_signature (_));_} as mt)); - pmod_attributes = []} -> - pp f " :@;%a@;=@;%a@;" - (module_type ctxt) mt (module_expr ctxt) me' - | _ -> pp f " =@ %a" (module_expr ctxt) me - ) x.pmb_expr - (item_attributes ctxt) x.pmb_attributes - | Pstr_open od -> - pp f "@[<2>open%s@;%a@]%a" - (override od.popen_override) - longident_loc od.popen_lid - (item_attributes ctxt) od.popen_attributes - | Pstr_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> - pp f "@[module@ type@ %s%a@]%a" - s.txt - (fun f md -> match md with - | None -> () - | Some mt -> - pp_print_space f () ; - pp f "@ =@ %a" (module_type ctxt) mt - ) md - (item_attributes ctxt) attrs - | Pstr_class () -> () - | Pstr_class_type l -> class_type_declaration_list ctxt f l - | Pstr_primitive vd -> - pp f "@[external@ %a@ :@ %a@]%a" - protect_ident vd.pval_name.txt - (value_description ctxt) vd - (item_attributes ctxt) vd.pval_attributes - | Pstr_include incl -> - pp f "@[include@ %a@]%a" - (module_expr ctxt) incl.pincl_mod - (item_attributes ctxt) incl.pincl_attributes - | Pstr_recmodule decls -> (* 3.07 *) - let aux f = function - | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) -> - pp f "@[@ and@ %s:%a@ =@ %a@]%a" pmb.pmb_name.txt - (module_type ctxt) typ - (module_expr ctxt) expr - (item_attributes ctxt) pmb.pmb_attributes - | _ -> assert false - in - begin match decls with - | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 -> - pp f "@[@[module@ rec@ %s:%a@ =@ %a@]%a@ %a@]" - pmb.pmb_name.txt - (module_type ctxt) typ - (module_expr ctxt) expr - (item_attributes ctxt) pmb.pmb_attributes - (fun f l2 -> List.iter (aux f) l2) l2 - | _ -> assert false - end - | Pstr_attribute a -> floating_attribute ctxt f a - | Pstr_extension(e, a) -> - item_extension ctxt f e; - item_attributes ctxt f a - -and type_param ctxt f (ct, a) = - pp f "%s%a" (type_variance a) (core_type ctxt) ct - -and type_params ctxt f = function - | [] -> () - | l -> pp f "%a " (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",@;") l - -and type_def_list ctxt f (rf, l) = - let type_decl kwd rf f x = - let eq = - if (x.ptype_kind = Ptype_abstract) - && (x.ptype_manifest = None) then "" - else " =" - in - pp f "@[<2>%s %a%a%s%s%a@]%a" kwd - nonrec_flag rf - (type_params ctxt) x.ptype_params - x.ptype_name.txt eq - (type_declaration ctxt) x - (item_attributes ctxt) x.ptype_attributes - in - match l with - | [] -> assert false - | [x] -> type_decl "type" rf f x - | x :: xs -> pp f "@[%a@,%a@]" - (type_decl "type" rf) x - (list ~sep:"@," (type_decl "and" Recursive)) xs - -and record_declaration ctxt f lbls = - let type_record_field f pld = - pp f "@[<2>%a%s:@;%a@;%a@]" - mutable_flag pld.pld_mutable - pld.pld_name.txt - (core_type ctxt) pld.pld_type - (attributes ctxt) pld.pld_attributes - in - pp f "{@\n%a}" - (list type_record_field ~sep:";@\n" ) lbls - -and type_declaration ctxt f x = - (* type_declaration has an attribute field, - but it's been printed by the caller of this method *) - let priv f = - match x.ptype_private with - | Public -> () - | Private -> pp f "@;private" - in - let manifest f = - match x.ptype_manifest with - | None -> () - | Some y -> - if x.ptype_kind = Ptype_abstract then - pp f "%t@;%a" priv (core_type ctxt) y - else - pp f "@;%a" (core_type ctxt) y - in - let constructor_declaration f pcd = - pp f "|@;"; - constructor_declaration ctxt f - (pcd.pcd_name.txt, pcd.pcd_args, pcd.pcd_res, pcd.pcd_attributes) - in - let repr f = - let intro f = - if x.ptype_manifest = None then () - else pp f "@;=" - in - match x.ptype_kind with - | Ptype_variant xs -> - pp f "%t%t@\n%a" intro priv - (list ~sep:"@\n" constructor_declaration) xs - | Ptype_abstract -> () - | Ptype_record l -> - pp f "%t%t@;%a" intro priv (record_declaration ctxt) l - | Ptype_open -> pp f "%t%t@;.." intro priv - in - let constraints f = - List.iter - (fun (ct1,ct2,_) -> - pp f "@[@ constraint@ %a@ =@ %a@]" - (core_type ctxt) ct1 (core_type ctxt) ct2) - x.ptype_cstrs - in - pp f "%t%t%t" manifest repr constraints - -and type_extension ctxt f x = - let extension_constructor f x = - pp f "@\n|@;%a" (extension_constructor ctxt) x - in - pp f "@[<2>type %a%a += %a@ %a@]%a" - (fun f -> function - | [] -> () - | l -> - pp f "%a@;" (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",") l) - x.ptyext_params - longident_loc x.ptyext_path - private_flag x.ptyext_private (* Cf: #7200 *) - (list ~sep:"" extension_constructor) - x.ptyext_constructors - (item_attributes ctxt) x.ptyext_attributes - -and constructor_declaration ctxt f (name, args, res, attrs) = - let name = - match name with - | "::" -> "(::)" - | s -> s in - match res with - | None -> - pp f "%s%a@;%a" name - (fun f -> function - | Pcstr_tuple [] -> () - | Pcstr_tuple l -> - pp f "@;of@;%a" (list (core_type1 ctxt) ~sep:"@;*@;") l - | Pcstr_record l -> pp f "@;of@;%a" (record_declaration ctxt) l - ) args - (attributes ctxt) attrs - | Some r -> - pp f "%s:@;%a@;%a" name - (fun f -> function - | Pcstr_tuple [] -> core_type1 ctxt f r - | Pcstr_tuple l -> pp f "%a@;->@;%a" - (list (core_type1 ctxt) ~sep:"@;*@;") l - (core_type1 ctxt) r - | Pcstr_record l -> - pp f "%a@;->@;%a" (record_declaration ctxt) l (core_type1 ctxt) r - ) - args - (attributes ctxt) attrs - -and extension_constructor ctxt f x = - (* Cf: #7200 *) - match x.pext_kind with - | Pext_decl(l, r) -> - constructor_declaration ctxt f (x.pext_name.txt, l, r, x.pext_attributes) - | Pext_rebind li -> - pp f "%s%a@;=@;%a" x.pext_name.txt - (attributes ctxt) x.pext_attributes - longident_loc li - -and case_list ctxt f l : unit = - let aux f {pc_lhs; pc_guard; pc_rhs} = - pp f "@;| @[<2>%a%a@;->@;%a@]" - (pattern ctxt) pc_lhs (option (expression ctxt) ~first:"@;when@;") - pc_guard (expression (under_pipe ctxt)) pc_rhs - in - list aux f l ~sep:"" - -and label_x_expression_param ctxt f (l,e) = - let simple_name = match e with - | {pexp_desc=Pexp_ident {txt=Lident l;_}; - pexp_attributes=[]} -> Some l - | _ -> None - in match l with - | Nolabel -> expression2 ctxt f e (* level 2*) - | Optional str -> - if Some str = simple_name then - pp f "?%s" str - else - pp f "?%s:%a" str (simple_expr ctxt) e - | Labelled lbl -> - if Some lbl = simple_name then - pp f "~%s" lbl - else - pp f "~%s:%a" lbl (simple_expr ctxt) e - - - -let expression f x = - pp f "@[%a@]" (expression reset_ctxt) x - -let string_of_expression x = - ignore (flush_str_formatter ()) ; - let f = str_formatter in - expression f x; - flush_str_formatter () - -let string_of_structure x = - ignore (flush_str_formatter ()); - let f = str_formatter in - structure reset_ctxt f x; - flush_str_formatter () - - -let core_type = core_type reset_ctxt -let pattern = pattern reset_ctxt -let signature = signature reset_ctxt -let structure = structure reset_ctxt - end module Ast_payload : sig #1 "ast_payload.mli" @@ -282414,7 +282427,7 @@ let scanEscape scanner = | '}' -> next scanner | _ -> ()); let c = !x in - c + if Res_utf8.isValidCodePoint c then c else Res_utf8.repl | _ -> (* unicode escape sequence: '\u007A', exactly 4 hex digits *) convertNumber scanner ~n:4 ~base:16) @@ -282773,7 +282786,7 @@ let rec scan scanner = (String.sub [@doesNotRaise]) scanner.src offset length in next scanner; - Token.Codepoint {c = Obj.magic codepoint; original = contents}) + Token.Codepoint {c = codepoint; original = contents}) else ( scanner.ch <- ch; scanner.offset <- offset; diff --git a/lib/4.06.1/whole_compiler.ml b/lib/4.06.1/whole_compiler.ml index fe04ba5a04..d70b7c0f58 100644 --- a/lib/4.06.1/whole_compiler.ml +++ b/lib/4.06.1/whole_compiler.ml @@ -186661,15 +186661,15 @@ let maybe_pointer_type env typ = | _ -> true end -module TypedtreeIter : sig -#1 "typedtreeIter.mli" +module Pprintast : sig +#1 "pprintast.mli" (**************************************************************************) (* *) (* OCaml *) (* *) -(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) +(* Hongbo Zhang (University of Pennsylvania) *) (* *) -(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. *) (* *) (* All rights reserved. This file is distributed under the terms of *) @@ -186678,87 +186678,28 @@ module TypedtreeIter : sig (* *) (**************************************************************************) -open Asttypes -open Typedtree - - -module type IteratorArgument = sig - val enter_structure : structure -> unit - val enter_value_description : value_description -> unit - val enter_type_extension : type_extension -> unit - val enter_extension_constructor : extension_constructor -> unit - val enter_pattern : pattern -> unit - val enter_expression : expression -> unit - val enter_package_type : package_type -> unit - val enter_signature : signature -> unit - val enter_signature_item : signature_item -> unit - val enter_module_type_declaration : module_type_declaration -> unit - val enter_module_type : module_type -> unit - val enter_module_expr : module_expr -> unit - val enter_with_constraint : with_constraint -> unit - val enter_class_signature : class_signature -> unit - val enter_class_description : class_description -> unit - val enter_class_type_declaration : class_type_declaration -> unit - val enter_class_type : class_type -> unit - val enter_class_type_field : class_type_field -> unit - val enter_core_type : core_type -> unit - val enter_structure_item : structure_item -> unit - - - val leave_structure : structure -> unit - val leave_value_description : value_description -> unit - val leave_type_extension : type_extension -> unit - val leave_extension_constructor : extension_constructor -> unit - val leave_pattern : pattern -> unit - val leave_expression : expression -> unit - val leave_package_type : package_type -> unit - val leave_signature : signature -> unit - val leave_signature_item : signature_item -> unit - val leave_module_type_declaration : module_type_declaration -> unit - val leave_module_type : module_type -> unit - val leave_module_expr : module_expr -> unit - val leave_with_constraint : with_constraint -> unit - val leave_class_signature : class_signature -> unit - val leave_class_description : class_description -> unit - val leave_class_type_declaration : class_type_declaration -> unit - val leave_class_type : class_type -> unit - val leave_class_type_field : class_type_field -> unit - val leave_core_type : core_type -> unit - val leave_structure_item : structure_item -> unit - - val enter_bindings : rec_flag -> unit - val enter_binding : value_binding -> unit - val leave_binding : value_binding -> unit - val leave_bindings : rec_flag -> unit - - val enter_type_declarations : rec_flag -> unit - val enter_type_declaration : type_declaration -> unit - val leave_type_declaration : type_declaration -> unit - val leave_type_declarations : rec_flag -> unit +type space_formatter = (unit, Format.formatter, unit) format -end -module [@warning "-67"] MakeIterator : - functor (Iter : IteratorArgument) -> - sig - val iter_structure : structure -> unit - val iter_signature : signature -> unit - val iter_structure_item : structure_item -> unit - val iter_signature_item : signature_item -> unit - val iter_expression : expression -> unit - val iter_module_type : module_type -> unit - val iter_pattern : pattern -> unit - end +val expression : Format.formatter -> Parsetree.expression -> unit +val string_of_expression : Parsetree.expression -> string -module DefaultIteratorArgument : IteratorArgument +val core_type: Format.formatter -> Parsetree.core_type -> unit +val pattern: Format.formatter -> Parsetree.pattern -> unit +val signature: Format.formatter -> Parsetree.signature -> unit +val structure: Format.formatter -> Parsetree.structure -> unit +val string_of_structure: Parsetree.structure -> string +val string_of_int_as_char: int -> string end = struct -#1 "typedtreeIter.ml" +#1 "pprintast.pp.ml" (**************************************************************************) (* *) (* OCaml *) (* *) -(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) +(* Thomas Gazagnaire, OCamlPro *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* Hongbo Zhang, University of Pennsylvania *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. *) @@ -186769,666 +186710,1430 @@ end = struct (* *) (**************************************************************************) -(* -TODO: - - 2012/05/10: Follow camlp4 way of building map and iter using classes - and inheritance ? -*) +(* Original Code from Ber-metaocaml, modified for 3.12.0 and fixed *) +(* Printing code expressions *) +(* Authors: Ed Pizzi, Fabrice Le Fessant *) +(* Extensive Rewrite: Hongbo Zhang: University of Pennsylvania *) +(* TODO more fine-grained precedence pretty-printing *) open Asttypes -open Typedtree - -module type IteratorArgument = sig +open Format +open Location +open Longident +open Parsetree +open Ast_helper - val enter_structure : structure -> unit - val enter_value_description : value_description -> unit - val enter_type_extension : type_extension -> unit - val enter_extension_constructor : extension_constructor -> unit - val enter_pattern : pattern -> unit - val enter_expression : expression -> unit - val enter_package_type : package_type -> unit - val enter_signature : signature -> unit - val enter_signature_item : signature_item -> unit - val enter_module_type_declaration : module_type_declaration -> unit - val enter_module_type : module_type -> unit - val enter_module_expr : module_expr -> unit - val enter_with_constraint : with_constraint -> unit - val enter_class_signature : class_signature -> unit +let prefix_symbols = [ '!'; '?'; '~' ] ;; +let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/'; + '$'; '%'; '#' ] - val enter_class_description : class_description -> unit - val enter_class_type_declaration : class_type_declaration -> unit - val enter_class_type : class_type -> unit - val enter_class_type_field : class_type_field -> unit - val enter_core_type : core_type -> unit - val enter_structure_item : structure_item -> unit +(* type fixity = Infix| Prefix *) +let special_infix_strings = + ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!="; "::" ] +(* determines if the string is an infix string. + checks backwards, first allowing a renaming postfix ("_102") which + may have resulted from Pexp -> Texp -> Pexp translation, then checking + if all the characters in the beginning of the string are valid infix + characters. *) +let fixity_of_string = function + | s when List.mem s special_infix_strings -> `Infix s + | s when List.mem s.[0] infix_symbols -> `Infix s + | s when List.mem s.[0] prefix_symbols -> `Prefix s + | s when s.[0] = '.' -> `Mixfix s + | _ -> `Normal - val leave_structure : structure -> unit - val leave_value_description : value_description -> unit - val leave_type_extension : type_extension -> unit - val leave_extension_constructor : extension_constructor -> unit - val leave_pattern : pattern -> unit - val leave_expression : expression -> unit - val leave_package_type : package_type -> unit - val leave_signature : signature -> unit - val leave_signature_item : signature_item -> unit - val leave_module_type_declaration : module_type_declaration -> unit - val leave_module_type : module_type -> unit - val leave_module_expr : module_expr -> unit - val leave_with_constraint : with_constraint -> unit - val leave_class_signature : class_signature -> unit +let view_fixity_of_exp = function + | {pexp_desc = Pexp_ident {txt=Lident l;_}; pexp_attributes = []} -> + fixity_of_string l + | _ -> `Normal - val leave_class_description : class_description -> unit - val leave_class_type_declaration : class_type_declaration -> unit - val leave_class_type : class_type -> unit - val leave_class_type_field : class_type_field -> unit - val leave_core_type : core_type -> unit - val leave_structure_item : structure_item -> unit +let is_infix = function | `Infix _ -> true | _ -> false +let is_mixfix = function `Mixfix _ -> true | _ -> false - val enter_bindings : rec_flag -> unit - val enter_binding : value_binding -> unit - val leave_binding : value_binding -> unit - val leave_bindings : rec_flag -> unit +(* which identifiers are in fact operators needing parentheses *) +let needs_parens txt = + let fix = fixity_of_string txt in + is_infix fix + || is_mixfix fix + || List.mem txt.[0] prefix_symbols - val enter_type_declarations : rec_flag -> unit - val enter_type_declaration : type_declaration -> unit - val leave_type_declaration : type_declaration -> unit - val leave_type_declarations : rec_flag -> unit +(* some infixes need spaces around parens to avoid clashes with comment + syntax *) +let needs_spaces txt = + txt.[0]='*' || txt.[String.length txt - 1] = '*' - end +(* add parentheses to binders when they are in fact infix or prefix operators *) +let protect_ident ppf txt = + let format : (_, _, _) format = + if not (needs_parens txt) then "%s" + else if needs_spaces txt then "(@;%s@;)" + else "(%s)" + in fprintf ppf format txt -module MakeIterator(Iter : IteratorArgument) : sig +let protect_longident ppf print_longident longprefix txt = + let format : (_, _, _) format = + if not (needs_parens txt) then "%a.%s" + else if needs_spaces txt then "%a.(@;%s@;)" + else "%a.(%s)" in + fprintf ppf format print_longident longprefix txt - val iter_structure : structure -> unit - val iter_signature : signature -> unit - val iter_structure_item : structure_item -> unit - val iter_signature_item : signature_item -> unit - val iter_expression : expression -> unit - val iter_module_type : module_type -> unit - val iter_pattern : pattern -> unit +type space_formatter = (unit, Format.formatter, unit) format - end = struct +let override = function + | Override -> "!" + | Fresh -> "" - let may_iter f v = - match v with - None -> () - | Some x -> f x +(* variance encoding: need to sync up with the [parser.mly] *) +let type_variance = function + | Invariant -> "" + | Covariant -> "+" + | Contravariant -> "-" +type construct = + [ `cons of expression list + | `list of expression list + | `nil + | `normal + | `simple of Longident.t + | `tuple ] - let rec iter_structure str = - Iter.enter_structure str; - List.iter iter_structure_item str.str_items; - Iter.leave_structure str +let view_expr x = + match x.pexp_desc with + | Pexp_construct ( {txt= Lident "()"; _},_) -> `tuple + | Pexp_construct ( {txt= Lident "[]";_},_) -> `nil + | Pexp_construct ( {txt= Lident"::";_},Some _) -> + let rec loop exp acc = match exp with + | {pexp_desc=Pexp_construct ({txt=Lident "[]";_},_); + pexp_attributes = []} -> + (List.rev acc,true) + | {pexp_desc= + Pexp_construct ({txt=Lident "::";_}, + Some ({pexp_desc= Pexp_tuple([e1;e2]); + pexp_attributes = []})); + pexp_attributes = []} + -> + loop e2 (e1::acc) + | e -> (List.rev (e::acc),false) in + let (ls,b) = loop x [] in + if b then + `list ls + else `cons ls + | Pexp_construct (x,None) -> `simple (x.txt) + | _ -> `normal +let is_simple_construct :construct -> bool = function + | `nil | `tuple | `list _ | `simple _ -> true + | `cons _ | `normal -> false - and iter_binding vb = - Iter.enter_binding vb; - iter_pattern vb.vb_pat; - iter_expression vb.vb_expr; - Iter.leave_binding vb +let pp = fprintf - and iter_bindings rec_flag list = - Iter.enter_bindings rec_flag; - List.iter iter_binding list; - Iter.leave_bindings rec_flag +type ctxt = { + pipe : bool; + semi : bool; + ifthenelse : bool; +} - and iter_case {c_lhs; c_guard; c_rhs} = - iter_pattern c_lhs; - may_iter iter_expression c_guard; - iter_expression c_rhs +let reset_ctxt = { pipe=false; semi=false; ifthenelse=false } +let under_pipe ctxt = { ctxt with pipe=true } +let under_semi ctxt = { ctxt with semi=true } +let under_ifthenelse ctxt = { ctxt with ifthenelse=true } +(* +let reset_semi ctxt = { ctxt with semi=false } +let reset_ifthenelse ctxt = { ctxt with ifthenelse=false } +let reset_pipe ctxt = { ctxt with pipe=false } +*) - and iter_cases cases = - List.iter iter_case cases +let list : 'a . ?sep:space_formatter -> ?first:space_formatter -> + ?last:space_formatter -> (Format.formatter -> 'a -> unit) -> + Format.formatter -> 'a list -> unit + = fun ?sep ?first ?last fu f xs -> + let first = match first with Some x -> x |None -> ("": _ format6) + and last = match last with Some x -> x |None -> ("": _ format6) + and sep = match sep with Some x -> x |None -> ("@ ": _ format6) in + let aux f = function + | [] -> () + | [x] -> fu f x + | xs -> + let rec loop f = function + | [x] -> fu f x + | x::xs -> fu f x; pp f sep; loop f xs; + | _ -> assert false in begin + pp f first; loop f xs; pp f last; + end in + aux f xs - and iter_structure_item item = - Iter.enter_structure_item item; - begin - match item.str_desc with - Tstr_eval (exp, _attrs) -> iter_expression exp - | Tstr_value (rec_flag, list) -> - iter_bindings rec_flag list - | Tstr_primitive vd -> iter_value_description vd - | Tstr_type (rf, list) -> iter_type_declarations rf list - | Tstr_typext tyext -> iter_type_extension tyext - | Tstr_exception ext -> iter_extension_constructor ext - | Tstr_module x -> iter_module_binding x - | Tstr_recmodule list -> List.iter iter_module_binding list - | Tstr_modtype mtd -> iter_module_type_declaration mtd - | Tstr_open _ -> () - | Tstr_class () -> () - | Tstr_class_type list -> - List.iter - (fun (_, _, ct) -> iter_class_type_declaration ct) - list - | Tstr_include incl -> iter_module_expr incl.incl_mod - | Tstr_attribute _ -> - () - end; - Iter.leave_structure_item item +let option : 'a. ?first:space_formatter -> ?last:space_formatter -> + (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a option -> unit + = fun ?first ?last fu f a -> + let first = match first with Some x -> x | None -> ("": _ format6) + and last = match last with Some x -> x | None -> ("": _ format6) in + match a with + | None -> () + | Some x -> pp f first; fu f x; pp f last - and iter_module_binding x = - iter_module_expr x.mb_expr +let paren: 'a . ?first:space_formatter -> ?last:space_formatter -> + bool -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit + = fun ?(first=("": _ format6)) ?(last=("": _ format6)) b fu f x -> + if b then (pp f "("; pp f first; fu f x; pp f last; pp f ")") + else fu f x - and iter_value_description v = - Iter.enter_value_description v; - iter_core_type v.val_desc; - Iter.leave_value_description v +let rec longident f = function + | Lident s -> protect_ident f s + | Ldot(y,s) -> protect_longident f longident y s + | Lapply (y,s) -> + pp f "%a(%a)" longident y longident s - and iter_constructor_arguments = function - | Cstr_tuple l -> List.iter iter_core_type l - | Cstr_record l -> List.iter (fun ld -> iter_core_type ld.ld_type) l +let longident_loc f x = pp f "%a" longident x.txt - and iter_constructor_declaration cd = - iter_constructor_arguments cd.cd_args; - option iter_core_type cd.cd_res; +let string_of_int_as_char i = + if i >= 0 && i <= 255 + then + Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) + else + Printf.sprintf "\'\\%d\'" i - and iter_type_parameter (ct, _v) = - iter_core_type ct +let constant f = function + | Pconst_char i -> pp f "%s" (string_of_int_as_char i) + | Pconst_string (i, None) -> pp f "%S" i + | Pconst_string (i, Some delim) -> pp f "{%s|%s|%s}" delim i delim + | Pconst_integer (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i + | Pconst_integer (i, Some m) -> + paren (i.[0]='-') (fun f (i, m) -> pp f "%s%c" i m) f (i,m) + | Pconst_float (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i + | Pconst_float (i, Some m) -> paren (i.[0]='-') (fun f (i,m) -> + pp f "%s%c" i m) f (i,m) - and iter_type_declaration decl = - Iter.enter_type_declaration decl; - List.iter iter_type_parameter decl.typ_params; - List.iter (fun (ct1, ct2, _loc) -> - iter_core_type ct1; - iter_core_type ct2 - ) decl.typ_cstrs; - begin match decl.typ_kind with - Ttype_abstract -> () - | Ttype_variant list -> - List.iter iter_constructor_declaration list - | Ttype_record list -> - List.iter - (fun ld -> - iter_core_type ld.ld_type - ) list - | Ttype_open -> () - end; - option iter_core_type decl.typ_manifest; - Iter.leave_type_declaration decl +(* trailing space*) +let mutable_flag f = function + | Immutable -> () + | Mutable -> pp f "mutable@;" +let virtual_flag f = function + | Concrete -> () + | Virtual -> pp f "virtual@;" - and iter_type_declarations rec_flag decls = - Iter.enter_type_declarations rec_flag; - List.iter iter_type_declaration decls; - Iter.leave_type_declarations rec_flag +(* trailing space added *) +let rec_flag f rf = + match rf with + | Nonrecursive -> () + | Recursive -> pp f "rec " +let nonrec_flag f rf = + match rf with + | Nonrecursive -> pp f "nonrec " + | Recursive -> () +let direction_flag f = function + | Upto -> pp f "to@ " + | Downto -> pp f "downto@ " +let private_flag f = function + | Public -> () + | Private -> pp f "private@ " - and iter_extension_constructor ext = - Iter.enter_extension_constructor ext; - begin match ext.ext_kind with - Text_decl(args, ret) -> - iter_constructor_arguments args; - option iter_core_type ret - | Text_rebind _ -> () - end; - Iter.leave_extension_constructor ext; +let constant_string f s = pp f "%S" s +let tyvar f str = pp f "'%s" str +let tyvar_loc f str = pp f "'%s" str.txt +let string_quot f x = pp f "`%s" x - and iter_type_extension tyext = - Iter.enter_type_extension tyext; - List.iter iter_type_parameter tyext.tyext_params; - List.iter iter_extension_constructor tyext.tyext_constructors; - Iter.leave_type_extension tyext +(* c ['a,'b] *) +let rec class_params_def ctxt f = function + | [] -> () + | l -> + pp f "[%a] " (* space *) + (list (type_param ctxt) ~sep:",") l - and iter_pattern pat = - Iter.enter_pattern pat; - List.iter (fun (cstr, _, _attrs) -> match cstr with - | Tpat_type _ -> () - | Tpat_unpack -> () - | Tpat_open _ -> () - | Tpat_constraint ct -> iter_core_type ct) pat.pat_extra; - begin - match pat.pat_desc with - Tpat_any -> () - | Tpat_var _ -> () - | Tpat_alias (pat1, _, _) -> iter_pattern pat1 - | Tpat_constant _ -> () - | Tpat_tuple list -> - List.iter iter_pattern list - | Tpat_construct (_, _, args) -> - List.iter iter_pattern args - | Tpat_variant (_, pato, _) -> - begin match pato with - None -> () - | Some pat -> iter_pattern pat - end - | Tpat_record (list, _closed) -> - List.iter (fun (_, _, pat) -> iter_pattern pat) list - | Tpat_array list -> List.iter iter_pattern list - | Tpat_or (p1, p2, _) -> iter_pattern p1; iter_pattern p2 - | Tpat_lazy p -> iter_pattern p - end; - Iter.leave_pattern pat +and type_with_label ctxt f (label, c) = + match label with + | Nolabel -> core_type1 ctxt f c (* otherwise parenthesize *) + | Labelled s -> pp f "%s:%a" s (core_type1 ctxt) c + | Optional s -> pp f "?%s:%a" s (core_type1 ctxt) c - and option f x = match x with None -> () | Some e -> f e +and core_type ctxt f x = + if x.ptyp_attributes <> [] then begin + pp f "((%a)%a)" (core_type ctxt) {x with ptyp_attributes=[]} + (attributes ctxt) x.ptyp_attributes + end + else match x.ptyp_desc with + | Ptyp_arrow (l, ct1, ct2) -> + pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) + (type_with_label ctxt) (l,ct1) (core_type ctxt) ct2 + | Ptyp_alias (ct, s) -> + pp f "@[<2>%a@;as@;'%s@]" (core_type1 ctxt) ct s + | Ptyp_poly ([], ct) -> + core_type ctxt f ct + | Ptyp_poly (sl, ct) -> + pp f "@[<2>%a%a@]" + (fun f l -> + pp f "%a" + (fun f l -> match l with + | [] -> () + | _ -> + pp f "%a@;.@;" + (list tyvar_loc ~sep:"@;") l) + l) + sl (core_type ctxt) ct + | _ -> pp f "@[<2>%a@]" (core_type1 ctxt) x - and iter_expression exp = - Iter.enter_expression exp; - List.iter (function (cstr, _, _attrs) -> - match cstr with - Texp_constraint ct -> - iter_core_type ct - | Texp_coerce (cty1, cty2) -> - option iter_core_type cty1; iter_core_type cty2 - | Texp_open _ -> () - | Texp_poly cto -> option iter_core_type cto - | Texp_newtype _ -> ()) - exp.exp_extra; - begin - match exp.exp_desc with - Texp_ident _ -> () - | Texp_constant _ -> () - | Texp_let (rec_flag, list, exp) -> - iter_bindings rec_flag list; - iter_expression exp - | Texp_function { cases; _ } -> - iter_cases cases - | Texp_apply (exp, list) -> - iter_expression exp; - List.iter (fun (_label, expo) -> - match expo with - None -> () - | Some exp -> iter_expression exp - ) list - | Texp_match (exp, list1, list2, _) -> - iter_expression exp; - iter_cases list1; - iter_cases list2; - | Texp_try (exp, list) -> - iter_expression exp; - iter_cases list - | Texp_tuple list -> - List.iter iter_expression list - | Texp_construct (_, _, args) -> - List.iter iter_expression args - | Texp_variant (_label, expo) -> - begin match expo with - None -> () - | Some exp -> iter_expression exp - end - | Texp_record { fields; extended_expression; _ } -> - Array.iter (function - | _, Kept _ -> () - | _, Overridden (_, exp) -> iter_expression exp) - fields; - begin match extended_expression with - None -> () - | Some exp -> iter_expression exp - end - | Texp_field (exp, _, _label) -> - iter_expression exp - | Texp_setfield (exp1, _, _label, exp2) -> - iter_expression exp1; - iter_expression exp2 - | Texp_array list -> - List.iter iter_expression list - | Texp_ifthenelse (exp1, exp2, expo) -> - iter_expression exp1; - iter_expression exp2; - begin match expo with - None -> () - | Some exp -> iter_expression exp - end - | Texp_sequence (exp1, exp2) -> - iter_expression exp1; - iter_expression exp2 - | Texp_while (exp1, exp2) -> - iter_expression exp1; - iter_expression exp2 - | Texp_for (_id, _, exp1, exp2, _dir, exp3) -> - iter_expression exp1; - iter_expression exp2; - iter_expression exp3 - | Texp_send (exp, _meth, expo) -> - iter_expression exp; - begin - match expo with - None -> () - | Some exp -> iter_expression exp - end - | Texp_new _ - | Texp_instvar _ - | Texp_setinstvar _ - | Texp_override _ -> () - | Texp_letmodule (_id, _, mexpr, exp) -> - iter_module_expr mexpr; - iter_expression exp - | Texp_letexception (cd, exp) -> - iter_extension_constructor cd; - iter_expression exp - | Texp_assert exp -> iter_expression exp - | Texp_lazy exp -> iter_expression exp - | Texp_object () -> - () - | Texp_pack (mexpr) -> - iter_module_expr mexpr - | Texp_unreachable -> - () - | Texp_extension_constructor _ -> - () - end; - Iter.leave_expression exp; +and core_type1 ctxt f x = + if x.ptyp_attributes <> [] then core_type ctxt f x + else match x.ptyp_desc with + | Ptyp_any -> pp f "_"; + | Ptyp_var s -> tyvar f s; + | Ptyp_tuple l -> pp f "(%a)" (list (core_type1 ctxt) ~sep:"@;*@;") l + | Ptyp_constr (li, l) -> + pp f (* "%a%a@;" *) "%a%a" + (fun f l -> match l with + |[] -> () + |[x]-> pp f "%a@;" (core_type1 ctxt) x + | _ -> list ~first:"(" ~last:")@;" (core_type ctxt) ~sep:",@;" f l) + l longident_loc li + | Ptyp_variant (l, closed, low) -> + let type_variant_helper f x = + match x with + | Rtag (l, attrs, _, ctl) -> + pp f "@[<2>%a%a@;%a@]" string_quot l.txt + (fun f l -> match l with + |[] -> () + | _ -> pp f "@;of@;%a" + (list (core_type ctxt) ~sep:"&") ctl) ctl + (attributes ctxt) attrs + | Rinherit ct -> core_type ctxt f ct in + pp f "@[<2>[%a%a]@]" + (fun f l -> + match l, closed with + | [], Closed -> () + | [], Open -> pp f ">" (* Cf #7200: print [>] correctly *) + | _ -> + pp f "%s@;%a" + (match (closed,low) with + | (Closed,None) -> "" + | (Closed,Some _) -> "<" (* FIXME desugar the syntax sugar*) + | (Open,_) -> ">") + (list type_variant_helper ~sep:"@;<1 -2>| ") l) l + (fun f low -> match low with + |Some [] |None -> () + |Some xs -> + pp f ">@ %a" + (list string_quot) xs) low + | Ptyp_object (l, o) -> + let core_field_type f = function + | Otag (l, attrs, ct) -> + pp f "@[%s: %a@ %a@ @]" l.txt + (core_type ctxt) ct (attributes ctxt) attrs (* Cf #7200 *) + | Oinherit ct -> + pp f "@[%a@ @]" (core_type ctxt) ct + in + let field_var f = function + | Asttypes.Closed -> () + | Asttypes.Open -> + match l with + | [] -> pp f ".." + | _ -> pp f " ;.." + in + pp f "@[<@ %a%a@ > @]" (list core_field_type ~sep:";") l + field_var o (* Cf #7200 *) + | Ptyp_class (li, l) -> (*FIXME*) + pp f "@[%a#%a@]" + (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") l + longident_loc li + | Ptyp_package (lid, cstrs) -> + let aux f (s, ct) = + pp f "type %a@ =@ %a" longident_loc s (core_type ctxt) ct in + (match cstrs with + |[] -> pp f "@[(module@ %a)@]" longident_loc lid + |_ -> + pp f "@[(module@ %a@ with@ %a)@]" longident_loc lid + (list aux ~sep:"@ and@ ") cstrs) + | Ptyp_extension e -> extension ctxt f e + | _ -> paren true (core_type ctxt) f x - and iter_package_type pack = - Iter.enter_package_type pack; - List.iter (fun (_s, ct) -> iter_core_type ct) pack.pack_fields; - Iter.leave_package_type pack; +(********************pattern********************) +(* be cautious when use [pattern], [pattern1] is preferred *) +and pattern ctxt f x = + let rec list_of_pattern acc = function (* only consider ((A|B)|C)*) + | {ppat_desc= Ppat_or (p1,p2); ppat_attributes = []} -> + list_of_pattern (p2::acc) p1 + | x -> x::acc + in + if x.ppat_attributes <> [] then begin + pp f "((%a)%a)" (pattern ctxt) {x with ppat_attributes=[]} + (attributes ctxt) x.ppat_attributes + end + else match x.ppat_desc with + | Ppat_alias (p, s) -> + pp f "@[<2>%a@;as@;%a@]" (pattern ctxt) p protect_ident s.txt (* RA*) + | Ppat_or _ -> (* *) + pp f "@[%a@]" (list ~sep:"@,|" (pattern ctxt)) + (list_of_pattern [] x) + | _ -> pattern1 ctxt f x - and iter_signature sg = - Iter.enter_signature sg; - List.iter iter_signature_item sg.sig_items; - Iter.leave_signature sg; +and pattern1 ctxt (f:Format.formatter) (x:pattern) : unit = + let rec pattern_list_helper f = function + | {ppat_desc = + Ppat_construct + ({ txt = Lident("::") ;_}, + Some ({ppat_desc = Ppat_tuple([pat1; pat2]);_})); + ppat_attributes = []} - and iter_signature_item item = - Iter.enter_signature_item item; - begin - match item.sig_desc with - Tsig_value vd -> - iter_value_description vd - | Tsig_type (rf, list) -> - iter_type_declarations rf list - | Tsig_exception ext -> - iter_extension_constructor ext - | Tsig_typext tyext -> - iter_type_extension tyext - | Tsig_module md -> - iter_module_type md.md_type - | Tsig_recmodule list -> - List.iter (fun md -> iter_module_type md.md_type) list - | Tsig_modtype mtd -> - iter_module_type_declaration mtd - | Tsig_open _ -> () - | Tsig_include incl -> iter_module_type incl.incl_mod - | Tsig_class () -> () - | Tsig_class_type list -> - List.iter iter_class_type_declaration list - | Tsig_attribute _ -> () - end; - Iter.leave_signature_item item; + -> + pp f "%a::%a" (simple_pattern ctxt) pat1 pattern_list_helper pat2 (*RA*) + | p -> pattern1 ctxt f p + in + if x.ppat_attributes <> [] then pattern ctxt f x + else match x.ppat_desc with + | Ppat_variant (l, Some p) -> + pp f "@[<2>`%s@;%a@]" l (simple_pattern ctxt) p + | Ppat_construct (({txt=Lident("()"|"[]");_}), _) -> simple_pattern ctxt f x + | Ppat_construct (({txt;_} as li), po) -> + (* FIXME The third field always false *) + if txt = Lident "::" then + pp f "%a" pattern_list_helper x + else + (match po with + | Some x -> pp f "%a@;%a" longident_loc li (simple_pattern ctxt) x + | None -> pp f "%a" longident_loc li) + | _ -> simple_pattern ctxt f x - and iter_module_type_declaration mtd = - Iter.enter_module_type_declaration mtd; - begin - match mtd.mtd_type with - | None -> () - | Some mtype -> iter_module_type mtype - end; - Iter.leave_module_type_declaration mtd +and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = + if x.ppat_attributes <> [] then pattern ctxt f x + else match x.ppat_desc with + | Ppat_construct (({txt=Lident ("()"|"[]" as x);_}), _) -> pp f "%s" x + | Ppat_any -> pp f "_"; + | Ppat_var ({txt = txt;_}) -> protect_ident f txt + | Ppat_array l -> + pp f "@[<2>[|%a|]@]" (list (pattern1 ctxt) ~sep:";") l + | Ppat_unpack (s) -> + pp f "(module@ %s)@ " s.txt + | Ppat_type li -> + pp f "#%a" longident_loc li + | Ppat_record (l, closed) -> + let longident_x_pattern f (li, p) = + match (li,p) with + | ({txt=Lident s;_ }, + {ppat_desc=Ppat_var {txt;_}; + ppat_attributes=[]; _}) + when s = txt -> + pp f "@[<2>%a@]" longident_loc li + | _ -> + pp f "@[<2>%a@;=@;%a@]" longident_loc li (pattern1 ctxt) p + in + begin match closed with + | Closed -> + pp f "@[<2>{@;%a@;}@]" (list longident_x_pattern ~sep:";@;") l + | _ -> + pp f "@[<2>{@;%a;_}@]" (list longident_x_pattern ~sep:";@;") l + end + | Ppat_tuple l -> + pp f "@[<1>(%a)@]" (list ~sep:",@;" (pattern1 ctxt)) l (* level1*) + | Ppat_constant (c) -> pp f "%a" constant c + | Ppat_interval (c1, c2) -> pp f "%a..%a" constant c1 constant c2 + | Ppat_variant (l,None) -> pp f "`%s" l + | Ppat_constraint (p, ct) -> + pp f "@[<2>(%a@;:@;%a)@]" (pattern1 ctxt) p (core_type ctxt) ct + | Ppat_lazy p -> + pp f "@[<2>(lazy@;%a)@]" (pattern1 ctxt) p + | Ppat_exception p -> + pp f "@[<2>exception@;%a@]" (pattern1 ctxt) p + | Ppat_extension e -> extension ctxt f e + | Ppat_open (lid, p) -> + let with_paren = + match p.ppat_desc with + | Ppat_array _ | Ppat_record _ + | Ppat_construct (({txt=Lident ("()"|"[]");_}), _) -> false + | _ -> true in + pp f "@[<2>%a.%a @]" longident_loc lid + (paren with_paren @@ pattern1 ctxt) p + | _ -> paren true (pattern ctxt) f x +and label_exp ctxt f (l,opt,p) = + match l with + | Nolabel -> + (* single case pattern parens needed here *) + pp f "%a@ " (simple_pattern ctxt) p + | Optional rest -> + begin match p with + | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []} + when txt = rest -> + (match opt with + | Some o -> pp f "?(%s=@;%a)@;" rest (expression ctxt) o + | None -> pp f "?%s@ " rest) + | _ -> + (match opt with + | Some o -> + pp f "?%s:(%a=@;%a)@;" + rest (pattern1 ctxt) p (expression ctxt) o + | None -> pp f "?%s:%a@;" rest (simple_pattern ctxt) p) + end + | Labelled l -> match p with + | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []} + when txt = l -> + pp f "~%s@;" l + | _ -> pp f "~%s:%a@;" l (simple_pattern ctxt) p +and sugar_expr ctxt f e = + if e.pexp_attributes <> [] then false + else match e.pexp_desc with + | Pexp_apply ({ pexp_desc = Pexp_ident {txt = id; _}; + pexp_attributes=[]; _}, args) + when List.for_all (fun (lab, _) -> lab = Nolabel) args -> begin + let print_indexop a path_prefix assign left right print_index indices + rem_args = + let print_path ppf = function + | None -> () + | Some m -> pp ppf ".%a" longident m in + match assign, rem_args with + | false, [] -> + pp f "@[%a%a%s%a%s@]" + (simple_expr ctxt) a print_path path_prefix + left (list ~sep:"," print_index) indices right; true + | true, [v] -> + pp f "@[%a%a%s%a%s@ <-@;<1 2>%a@]" + (simple_expr ctxt) a print_path path_prefix + left (list ~sep:"," print_index) indices right + (simple_expr ctxt) v; true + | _ -> false in + match id, List.map snd args with + | Lident "!", [e] -> + pp f "@[!%a@]" (simple_expr ctxt) e; true + | Ldot (path, ("get"|"set" as func)), a :: other_args -> begin + let assign = func = "set" in + let print = print_indexop a None assign in + match path, other_args with + | Lident "Array", i :: rest -> + print ".(" ")" (expression ctxt) [i] rest + | Lident "String", i :: rest -> + print ".[" "]" (expression ctxt) [i] rest + | Ldot (Lident "Bigarray", "Array1"), i1 :: rest -> + print ".{" "}" (simple_expr ctxt) [i1] rest + | Ldot (Lident "Bigarray", "Array2"), i1 :: i2 :: rest -> + print ".{" "}" (simple_expr ctxt) [i1; i2] rest + | Ldot (Lident "Bigarray", "Array3"), i1 :: i2 :: i3 :: rest -> + print ".{" "}" (simple_expr ctxt) [i1; i2; i3] rest + | Ldot (Lident "Bigarray", "Genarray"), + {pexp_desc = Pexp_array indexes; pexp_attributes = []} :: rest -> + print ".{" "}" (simple_expr ctxt) indexes rest + | _ -> false + end + | (Lident s | Ldot(_,s)) , a :: i :: rest + when s.[0] = '.' -> + let n = String.length s in + (* extract operator: + assignment operators end with [right_bracket ^ "<-"], + access operators end with [right_bracket] directly + *) + let assign = s.[n - 1] = '-' in + let kind = + (* extract the right end bracket *) + if assign then s.[n - 3] else s.[n - 1] in + let left, right = match kind with + | ')' -> '(', ")" + | ']' -> '[', "]" + | '}' -> '{', "}" + | _ -> assert false in + let path_prefix = match id with + | Ldot(m,_) -> Some m + | _ -> None in + let left = String.sub s 0 (1+String.index s left) in + print_indexop a path_prefix assign left right + (expression ctxt) [i] rest + | _ -> false + end + | _ -> false - and iter_class_type_declaration cd = - Iter.enter_class_type_declaration cd; - List.iter iter_type_parameter cd.ci_params; - iter_class_type cd.ci_expr; - Iter.leave_class_type_declaration cd; +and expression ctxt f x = + if x.pexp_attributes <> [] then + pp f "((%a)@,%a)" (expression ctxt) {x with pexp_attributes=[]} + (attributes ctxt) x.pexp_attributes + else match x.pexp_desc with + | Pexp_function _ | Pexp_fun _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _ + when ctxt.pipe || ctxt.semi -> + paren true (expression reset_ctxt) f x + | Pexp_ifthenelse _ | Pexp_sequence _ when ctxt.ifthenelse -> + paren true (expression reset_ctxt) f x + | Pexp_let _ | Pexp_letmodule _ | Pexp_open _ | Pexp_letexception _ + when ctxt.semi -> + paren true (expression reset_ctxt) f x + | Pexp_fun (l, e0, p, e) -> + pp f "@[<2>fun@;%a->@;%a@]" + (label_exp ctxt) (l, e0, p) + (expression ctxt) e + | Pexp_function l -> + pp f "@[function%a@]" (case_list ctxt) l + | Pexp_match (e, l) -> + pp f "@[@[@[<2>match %a@]@ with@]%a@]" + (expression reset_ctxt) e (case_list ctxt) l - and iter_module_type mty = - Iter.enter_module_type mty; - begin - match mty.mty_desc with - Tmty_ident _ -> () - | Tmty_alias _ -> () - | Tmty_signature sg -> iter_signature sg - | Tmty_functor (_, _, mtype1, mtype2) -> - Misc.may iter_module_type mtype1; iter_module_type mtype2 - | Tmty_with (mtype, list) -> - iter_module_type mtype; - List.iter (fun (_path, _, withc) -> - iter_with_constraint withc - ) list - | Tmty_typeof mexpr -> - iter_module_expr mexpr - end; - Iter.leave_module_type mty; - - and iter_with_constraint cstr = - Iter.enter_with_constraint cstr; - begin - match cstr with - Twith_type decl -> iter_type_declaration decl - | Twith_module _ -> () - | Twith_typesubst decl -> iter_type_declaration decl - | Twith_modsubst _ -> () - end; - Iter.leave_with_constraint cstr; - - and iter_module_expr mexpr = - Iter.enter_module_expr mexpr; - begin - match mexpr.mod_desc with - Tmod_ident _ -> () - | Tmod_structure st -> iter_structure st - | Tmod_functor (_, _, mtype, mexpr) -> - Misc.may iter_module_type mtype; - iter_module_expr mexpr - | Tmod_apply (mexp1, mexp2, _) -> - iter_module_expr mexp1; - iter_module_expr mexp2 - | Tmod_constraint (mexpr, _, Tmodtype_implicit, _ ) -> - iter_module_expr mexpr - | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) -> - iter_module_expr mexpr; - iter_module_type mtype - | Tmod_unpack (exp, _mty) -> - iter_expression exp -(* iter_module_type mty *) - end; - Iter.leave_module_expr mexpr; + | Pexp_try (e, l) -> + pp f "@[<0>@[try@ %a@]@ @[<0>with%a@]@]" + (* "try@;@[<2>%a@]@\nwith@\n%a"*) + (expression reset_ctxt) e (case_list ctxt) l + | Pexp_let (rf, l, e) -> + (* pp f "@[<2>let %a%a in@;<1 -2>%a@]" + (*no indentation here, a new line*) *) + (* rec_flag rf *) + pp f "@[<2>%a in@;<1 -2>%a@]" + (bindings reset_ctxt) (rf,l) + (expression ctxt) e + | Pexp_apply (e, l) -> + begin if not (sugar_expr ctxt f x) then + match view_fixity_of_exp e with + | `Infix s -> + begin match l with + | [ (Nolabel, _) as arg1; (Nolabel, _) as arg2 ] -> + (* FIXME associativity label_x_expression_param *) + pp f "@[<2>%a@;%s@;%a@]" + (label_x_expression_param reset_ctxt) arg1 s + (label_x_expression_param ctxt) arg2 + | _ -> + pp f "@[<2>%a %a@]" + (simple_expr ctxt) e + (list (label_x_expression_param ctxt)) l + end + | `Prefix s -> + let s = + if List.mem s ["~+";"~-";"~+.";"~-."] && + (match l with + (* See #7200: avoid turning (~- 1) into (- 1) which is + parsed as an int literal *) + |[(_,{pexp_desc=Pexp_constant _})] -> false + | _ -> true) + then String.sub s 1 (String.length s -1) + else s in + begin match l with + | [(Nolabel, x)] -> + pp f "@[<2>%s@;%a@]" s (simple_expr ctxt) x + | _ -> + pp f "@[<2>%a %a@]" (simple_expr ctxt) e + (list (label_x_expression_param ctxt)) l + end + | _ -> + pp f "@[%a@]" begin fun f (e,l) -> + pp f "%a@ %a" (expression2 ctxt) e + (list (label_x_expression_param reset_ctxt)) l + (* reset here only because [function,match,try,sequence] + are lower priority *) + end (e,l) + end + | Pexp_construct (li, Some eo) + when not (is_simple_construct (view_expr x))-> (* Not efficient FIXME*) + (match view_expr x with + | `cons ls -> list (simple_expr ctxt) f ls ~sep:"@;::@;" + | `normal -> + pp f "@[<2>%a@;%a@]" longident_loc li + (simple_expr ctxt) eo + | _ -> assert false) + | Pexp_setfield (e1, li, e2) -> + pp f "@[<2>%a.%a@ <-@ %a@]" + (simple_expr ctxt) e1 longident_loc li (simple_expr ctxt) e2 + | Pexp_ifthenelse (e1, e2, eo) -> + (* @;@[<2>else@ %a@]@] *) + let fmt:(_,_,_)format ="@[@[<2>if@ %a@]@;@[<2>then@ %a@]%a@]" in + let expression_under_ifthenelse = expression (under_ifthenelse ctxt) in + pp f fmt expression_under_ifthenelse e1 expression_under_ifthenelse e2 + (fun f eo -> match eo with + | Some x -> + pp f "@;@[<2>else@;%a@]" (expression (under_semi ctxt)) x + | None -> () (* pp f "()" *)) eo + | Pexp_sequence _ -> + let rec sequence_helper acc = function + | {pexp_desc=Pexp_sequence(e1,e2); pexp_attributes = []} -> + sequence_helper (e1::acc) e2 + | v -> List.rev (v::acc) in + let lst = sequence_helper [] x in + pp f "@[%a@]" + (list (expression (under_semi ctxt)) ~sep:";@;") lst + | Pexp_new (li) -> + pp f "@[new@ %a@]" longident_loc li; + | Pexp_setinstvar (s, e) -> + pp f "@[%s@ <-@ %a@]" s.txt (expression ctxt) e + | Pexp_override l -> (* FIXME *) + let string_x_expression f (s, e) = + pp f "@[%s@ =@ %a@]" s.txt (expression ctxt) e in + pp f "@[{<%a>}@]" + (list string_x_expression ~sep:";" ) l; + | Pexp_letmodule (s, me, e) -> + pp f "@[let@ module@ %s@ =@ %a@ in@ %a@]" s.txt + (module_expr reset_ctxt) me (expression ctxt) e + | Pexp_letexception (cd, e) -> + pp f "@[let@ exception@ %a@ in@ %a@]" + (extension_constructor ctxt) cd + (expression ctxt) e + | Pexp_assert e -> + pp f "@[assert@ %a@]" (simple_expr ctxt) e + | Pexp_lazy (e) -> + pp f "@[lazy@ %a@]" (simple_expr ctxt) e + (* Pexp_poly: impossible but we should print it anyway, rather than + assert false *) + | Pexp_poly (e, None) -> + pp f "@[!poly!@ %a@]" (simple_expr ctxt) e + | Pexp_poly (e, Some ct) -> + pp f "@[(!poly!@ %a@ : %a)@]" + (simple_expr ctxt) e (core_type ctxt) ct + | Pexp_open (ovf, lid, e) -> + pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid + (expression ctxt) e + | Pexp_variant (l,Some eo) -> + pp f "@[<2>`%s@;%a@]" l (simple_expr ctxt) eo + | Pexp_extension e -> extension ctxt f e + | Pexp_unreachable -> pp f "." + | _ -> expression1 ctxt f x - and iter_class_type ct = - Iter.enter_class_type ct; - begin - match ct.cltyp_desc with - Tcty_signature csg -> iter_class_signature csg - | Tcty_constr (_path, _, list) -> - List.iter iter_core_type list - | Tcty_arrow (_label, ct, cl) -> - iter_core_type ct; - iter_class_type cl - | Tcty_open (_, _, _, _, e) -> - iter_class_type e - end; - Iter.leave_class_type ct; +and expression1 ctxt f x = + if x.pexp_attributes <> [] then expression ctxt f x + else match x.pexp_desc with + | Pexp_object cs -> pp f "%a" (class_structure ctxt) cs + | _ -> expression2 ctxt f x +(* used in [Pexp_apply] *) - and iter_class_signature cs = - Iter.enter_class_signature cs; - iter_core_type cs.csig_self; - List.iter iter_class_type_field cs.csig_fields; - Iter.leave_class_signature cs +and expression2 ctxt f x = + if x.pexp_attributes <> [] then expression ctxt f x + else match x.pexp_desc with + | Pexp_field (e, li) -> + pp f "@[%a.%a@]" (simple_expr ctxt) e longident_loc li + | Pexp_send (e, s) -> pp f "@[%a#%s@]" (simple_expr ctxt) e s.txt + | _ -> simple_expr ctxt f x - and iter_class_type_field ctf = - Iter.enter_class_type_field ctf; - begin - match ctf.ctf_desc with - Tctf_inherit ct -> iter_class_type ct - | Tctf_val (_s, _mut, _virt, ct) -> - iter_core_type ct - | Tctf_method (_s, _priv, _virt, ct) -> - iter_core_type ct - | Tctf_constraint (ct1, ct2) -> - iter_core_type ct1; - iter_core_type ct2 - | Tctf_attribute _ -> () - end; - Iter.leave_class_type_field ctf +and simple_expr ctxt f x = + if x.pexp_attributes <> [] then expression ctxt f x + else match x.pexp_desc with + | Pexp_construct _ when is_simple_construct (view_expr x) -> + (match view_expr x with + | `nil -> pp f "[]" + | `tuple -> pp f "()" + | `list xs -> + pp f "@[[%a]@]" + (list (expression (under_semi ctxt)) ~sep:";@;") xs + | `simple x -> longident f x + | _ -> assert false) + | Pexp_ident li -> + longident_loc f li + (* (match view_fixity_of_exp x with *) + (* |`Normal -> longident_loc f li *) + (* | `Prefix _ | `Infix _ -> pp f "( %a )" longident_loc li) *) + | Pexp_constant c -> constant f c; + | Pexp_pack me -> + pp f "(module@;%a)" (module_expr ctxt) me + | Pexp_newtype (lid, e) -> + pp f "fun@;(type@;%s)@;->@;%a" lid.txt (expression ctxt) e + | Pexp_tuple l -> + pp f "@[(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l + | Pexp_constraint (e, ct) -> + pp f "(%a : %a)" (expression ctxt) e (core_type ctxt) ct + | Pexp_coerce (e, cto1, ct) -> + pp f "(%a%a :> %a)" (expression ctxt) e + (option (core_type ctxt) ~first:" : " ~last:" ") cto1 (* no sep hint*) + (core_type ctxt) ct + | Pexp_variant (l, None) -> pp f "`%s" l + | Pexp_record (l, eo) -> + let longident_x_expression f ( li, e) = + match e with + | {pexp_desc=Pexp_ident {txt;_}; + pexp_attributes=[]; _} when li.txt = txt -> + pp f "@[%a@]" longident_loc li + | _ -> + pp f "@[%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e + in + pp f "@[@[{@;%a%a@]@;}@]"(* "@[{%a%a}@]" *) + (option ~last:" with@;" (simple_expr ctxt)) eo + (list longident_x_expression ~sep:";@;") l + | Pexp_array (l) -> + pp f "@[<0>@[<2>[|%a|]@]@]" + (list (simple_expr (under_semi ctxt)) ~sep:";") l + | Pexp_while (e1, e2) -> + let fmt : (_,_,_) format = "@[<2>while@;%a@;do@;%a@;done@]" in + pp f fmt (expression ctxt) e1 (expression ctxt) e2 + | Pexp_for (s, e1, e2, df, e3) -> + let fmt:(_,_,_)format = + "@[@[@[<2>for %a =@;%a@;%a%a@;do@]@;%a@]@;done@]" in + let expression = expression ctxt in + pp f fmt (pattern ctxt) s expression e1 direction_flag + df expression e2 expression e3 + | _ -> paren true (expression ctxt) f x - and iter_core_type ct = - Iter.enter_core_type ct; - begin - match ct.ctyp_desc with - Ttyp_any -> () - | Ttyp_var _ -> () - | Ttyp_arrow (_label, ct1, ct2) -> - iter_core_type ct1; - iter_core_type ct2 - | Ttyp_tuple list -> List.iter iter_core_type list - | Ttyp_constr (_path, _, list) -> - List.iter iter_core_type list - | Ttyp_object (list, _o) -> - List.iter iter_object_field list - | Ttyp_class (_path, _, list) -> - List.iter iter_core_type list - | Ttyp_alias (ct, _s) -> - iter_core_type ct - | Ttyp_variant (list, _bool, _labels) -> - List.iter iter_row_field list - | Ttyp_poly (_list, ct) -> iter_core_type ct - | Ttyp_package pack -> iter_package_type pack - end; - Iter.leave_core_type ct +and attributes ctxt f l = + List.iter (attribute ctxt f) l - and iter_row_field rf = - match rf with - Ttag (_label, _attrs, _bool, list) -> - List.iter iter_core_type list - | Tinherit ct -> iter_core_type ct +and item_attributes ctxt f l = + List.iter (item_attribute ctxt f) l - and iter_object_field ofield = - match ofield with - OTtag (_, _, ct) | OTinherit ct -> iter_core_type ct +and attribute ctxt f (s, e) = + pp f "@[<2>[@@%s@ %a]@]" s.txt (payload ctxt) e - end +and item_attribute ctxt f (s, e) = + pp f "@[<2>[@@@@%s@ %a]@]" s.txt (payload ctxt) e -module DefaultIteratorArgument = struct +and floating_attribute ctxt f (s, e) = + pp f "@[<2>[@@@@@@%s@ %a]@]" s.txt (payload ctxt) e - let enter_structure _ = () - let enter_value_description _ = () - let enter_type_extension _ = () - let enter_extension_constructor _ = () - let enter_pattern _ = () - let enter_expression _ = () - let enter_package_type _ = () - let enter_signature _ = () - let enter_signature_item _ = () - let enter_module_type_declaration _ = () - let enter_module_type _ = () - let enter_module_expr _ = () - let enter_with_constraint _ = () - let enter_class_signature _ = () +and value_description ctxt f x = + (* note: value_description has an attribute field, + but they're already printed by the callers this method *) + pp f "@[%a%a@]" (core_type ctxt) x.pval_type + (fun f x -> + + if x.pval_prim <> [] + then pp f "@ =@ %a" (list constant_string) x.pval_prim - let enter_class_description _ = () - let enter_class_type_declaration _ = () - let enter_class_type _ = () - let enter_class_type_field _ = () - let enter_core_type _ = () - let enter_structure_item _ = () + ) x +and extension ctxt f (s, e) = + pp f "@[<2>[%%%s@ %a]@]" s.txt (payload ctxt) e - let leave_structure _ = () - let leave_value_description _ = () - let leave_type_extension _ = () - let leave_extension_constructor _ = () - let leave_pattern _ = () - let leave_expression _ = () - let leave_package_type _ = () - let leave_signature _ = () - let leave_signature_item _ = () - let leave_module_type_declaration _ = () - let leave_module_type _ = () - let leave_module_expr _ = () - let leave_with_constraint _ = () - let leave_class_signature _ = () +and item_extension ctxt f (s, e) = + pp f "@[<2>[%%%%%s@ %a]@]" s.txt (payload ctxt) e - let leave_class_description _ = () - let leave_class_type_declaration _ = () - let leave_class_type _ = () - let leave_class_type_field _ = () - let leave_core_type _ = () - let leave_structure_item _ = () +and exception_declaration ctxt f ext = + pp f "@[exception@ %a@]" (extension_constructor ctxt) ext - let enter_binding _ = () - let leave_binding _ = () +and class_signature ctxt f { pcsig_self = ct; pcsig_fields = l ;_} = + let class_type_field f x = + match x.pctf_desc with + | Pctf_inherit (ct) -> + pp f "@[<2>inherit@ %a@]%a" (class_type ctxt) ct + (item_attributes ctxt) x.pctf_attributes + | Pctf_val (s, mf, vf, ct) -> + pp f "@[<2>val @ %a%a%s@ :@ %a@]%a" + mutable_flag mf virtual_flag vf s.txt (core_type ctxt) ct + (item_attributes ctxt) x.pctf_attributes + | Pctf_method (s, pf, vf, ct) -> + pp f "@[<2>method %a %a%s :@;%a@]%a" + private_flag pf virtual_flag vf s.txt (core_type ctxt) ct + (item_attributes ctxt) x.pctf_attributes + | Pctf_constraint (ct1, ct2) -> + pp f "@[<2>constraint@ %a@ =@ %a@]%a" + (core_type ctxt) ct1 (core_type ctxt) ct2 + (item_attributes ctxt) x.pctf_attributes + | Pctf_attribute a -> floating_attribute ctxt f a + | Pctf_extension e -> + item_extension ctxt f e; + item_attributes ctxt f x.pctf_attributes + in + pp f "@[@[object@[<1>%a@]@ %a@]@ end@]" + (fun f -> function + {ptyp_desc=Ptyp_any; ptyp_attributes=[]; _} -> () + | ct -> pp f " (%a)" (core_type ctxt) ct) ct + (list class_type_field ~sep:"@;") l - let enter_bindings _ = () - let leave_bindings _ = () +(* call [class_signature] called by [class_signature] *) +and class_type ctxt f x = + match x.pcty_desc with + | Pcty_signature cs -> + class_signature ctxt f cs; + attributes ctxt f x.pcty_attributes + | Pcty_constr (li, l) -> + pp f "%a%a%a" + (fun f l -> match l with + | [] -> () + | _ -> pp f "[%a]@ " (list (core_type ctxt) ~sep:"," ) l) l + longident_loc li + (attributes ctxt) x.pcty_attributes + | Pcty_arrow (l, co, cl) -> + pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) + (type_with_label ctxt) (l,co) + (class_type ctxt) cl + | Pcty_extension e -> + extension ctxt f e; + attributes ctxt f x.pcty_attributes + | Pcty_open (ovf, lid, e) -> + pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid + (class_type ctxt) e - let enter_type_declaration _ = () - let leave_type_declaration _ = () +(* [class type a = object end] *) +and class_type_declaration_list ctxt f l = + let class_type_declaration kwd f x = + let { pci_params=ls; pci_name={ txt; _ }; _ } = x in + pp f "@[<2>%s %a%a%s@ =@ %a@]%a" kwd + virtual_flag x.pci_virt + (class_params_def ctxt) ls txt + (class_type ctxt) x.pci_expr + (item_attributes ctxt) x.pci_attributes + in + match l with + | [] -> () + | [x] -> class_type_declaration "class type" f x + | x :: xs -> + pp f "@[%a@,%a@]" + (class_type_declaration "class type") x + (list ~sep:"@," (class_type_declaration "and")) xs - let enter_type_declarations _ = () - let leave_type_declarations _ = () -end +and class_field ctxt f x = + match x.pcf_desc with + | Pcf_inherit () -> () + | Pcf_val (s, mf, Cfk_concrete (ovf, e)) -> + pp f "@[<2>val%s %a%s =@;%a@]%a" (override ovf) + mutable_flag mf s.txt + (expression ctxt) e + (item_attributes ctxt) x.pcf_attributes + | Pcf_method (s, pf, Cfk_virtual ct) -> + pp f "@[<2>method virtual %a %s :@;%a@]%a" + private_flag pf s.txt + (core_type ctxt) ct + (item_attributes ctxt) x.pcf_attributes + | Pcf_val (s, mf, Cfk_virtual ct) -> + pp f "@[<2>val virtual %a%s :@ %a@]%a" + mutable_flag mf s.txt + (core_type ctxt) ct + (item_attributes ctxt) x.pcf_attributes + | Pcf_method (s, pf, Cfk_concrete (ovf, e)) -> + let bind e = + binding ctxt f + {pvb_pat= + {ppat_desc=Ppat_var s;ppat_loc=Location.none;ppat_attributes=[]}; + pvb_expr=e; + pvb_attributes=[]; + pvb_loc=Location.none; + } + in + pp f "@[<2>method%s %a%a@]%a" + (override ovf) + private_flag pf + (fun f -> function + | {pexp_desc=Pexp_poly (e, Some ct); pexp_attributes=[]; _} -> + pp f "%s :@;%a=@;%a" + s.txt (core_type ctxt) ct (expression ctxt) e + | {pexp_desc=Pexp_poly (e, None); pexp_attributes=[]; _} -> + bind e + | _ -> bind e) e + (item_attributes ctxt) x.pcf_attributes + | Pcf_constraint (ct1, ct2) -> + pp f "@[<2>constraint %a =@;%a@]%a" + (core_type ctxt) ct1 + (core_type ctxt) ct2 + (item_attributes ctxt) x.pcf_attributes + | Pcf_initializer (e) -> + pp f "@[<2>initializer@ %a@]%a" + (expression ctxt) e + (item_attributes ctxt) x.pcf_attributes + | Pcf_attribute a -> floating_attribute ctxt f a + | Pcf_extension e -> + item_extension ctxt f e; + item_attributes ctxt f x.pcf_attributes -end -module Untypeast : sig -#1 "untypeast.mli" -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) -(* *) -(* Copyright 2007 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) +and class_structure ctxt f { pcstr_self = p; pcstr_fields = l } = + pp f "@[@[object%a@;%a@]@;end@]" + (fun f p -> match p.ppat_desc with + | Ppat_any -> () + | Ppat_constraint _ -> pp f " %a" (pattern ctxt) p + | _ -> pp f " (%a)" (pattern ctxt) p) p + (list (class_field ctxt)) l -open Parsetree +and module_type ctxt f x = + if x.pmty_attributes <> [] then begin + pp f "((%a)%a)" (module_type ctxt) {x with pmty_attributes=[]} + (attributes ctxt) x.pmty_attributes + end else + match x.pmty_desc with + | Pmty_ident li -> + pp f "%a" longident_loc li; + | Pmty_alias li -> + pp f "(module %a)" longident_loc li; + | Pmty_signature (s) -> + pp f "@[@[sig@ %a@]@ end@]" (* "@[sig@ %a@ end@]" *) + (list (signature_item ctxt)) s (* FIXME wrong indentation*) + | Pmty_functor (_, None, mt2) -> + pp f "@[functor () ->@ %a@]" (module_type ctxt) mt2 + | Pmty_functor (s, Some mt1, mt2) -> + if s.txt = "_" then + pp f "@[%a@ ->@ %a@]" + (module_type ctxt) mt1 (module_type ctxt) mt2 + else + pp f "@[functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt + (module_type ctxt) mt1 (module_type ctxt) mt2 + | Pmty_with (mt, l) -> + let with_constraint f = function + | Pwith_type (li, ({ptype_params= ls ;_} as td)) -> + let ls = List.map fst ls in + pp f "type@ %a %a =@ %a" + (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") + ls longident_loc li (type_declaration ctxt) td + | Pwith_module (li, li2) -> + pp f "module %a =@ %a" longident_loc li longident_loc li2; + | Pwith_typesubst (li, ({ptype_params=ls;_} as td)) -> + let ls = List.map fst ls in + pp f "type@ %a %a :=@ %a" + (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") + ls longident_loc li + (type_declaration ctxt) td + | Pwith_modsubst (li, li2) -> + pp f "module %a :=@ %a" longident_loc li longident_loc li2 in + (match l with + | [] -> pp f "@[%a@]" (module_type ctxt) mt + | _ -> pp f "@[(%a@ with@ %a)@]" + (module_type ctxt) mt (list with_constraint ~sep:"@ and@ ") l) + | Pmty_typeof me -> + pp f "@[module@ type@ of@ %a@]" (module_expr ctxt) me + | Pmty_extension e -> extension ctxt f e -val lident_of_path : Path.t -> Longident.t +and signature ctxt f x = list ~sep:"@\n" (signature_item ctxt) f x -type mapper = { - attribute: mapper -> Typedtree.attribute -> attribute; - attributes: mapper -> Typedtree.attribute list -> attribute list; - case: mapper -> Typedtree.case -> case; - cases: mapper -> Typedtree.case list -> case list; - class_signature: mapper -> Typedtree.class_signature -> class_signature; - class_type: mapper -> Typedtree.class_type -> class_type; - class_type_declaration: mapper -> Typedtree.class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> Typedtree.class_type_field -> class_type_field; - constructor_declaration: mapper -> Typedtree.constructor_declaration - -> constructor_declaration; - expr: mapper -> Typedtree.expression -> expression; - extension_constructor: mapper -> Typedtree.extension_constructor - -> extension_constructor; - include_declaration: - mapper -> Typedtree.include_declaration -> include_declaration; - include_description: - mapper -> Typedtree.include_description -> include_description; - label_declaration: - mapper -> Typedtree.label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> Typedtree.module_binding -> module_binding; - module_declaration: - mapper -> Typedtree.module_declaration -> module_declaration; - module_expr: mapper -> Typedtree.module_expr -> module_expr; - module_type: mapper -> Typedtree.module_type -> module_type; - module_type_declaration: - mapper -> Typedtree.module_type_declaration -> module_type_declaration; - package_type: mapper -> Typedtree.package_type -> package_type; - open_description: mapper -> Typedtree.open_description -> open_description; - pat: mapper -> Typedtree.pattern -> pattern; - row_field: mapper -> Typedtree.row_field -> row_field; - object_field: mapper -> Typedtree.object_field -> object_field; - signature: mapper -> Typedtree.signature -> signature; - signature_item: mapper -> Typedtree.signature_item -> signature_item; - structure: mapper -> Typedtree.structure -> structure; - structure_item: mapper -> Typedtree.structure_item -> structure_item; - typ: mapper -> Typedtree.core_type -> core_type; - type_declaration: mapper -> Typedtree.type_declaration -> type_declaration; - type_extension: mapper -> Typedtree.type_extension -> type_extension; - type_kind: mapper -> Typedtree.type_kind -> type_kind; - value_binding: mapper -> Typedtree.value_binding -> value_binding; - value_description: mapper -> Typedtree.value_description -> value_description; - with_constraint: - mapper -> (Path.t * Longident.t Location.loc * Typedtree.with_constraint) - -> with_constraint; -} +and signature_item ctxt f x : unit = + match x.psig_desc with + | Psig_type (rf, l) -> + type_def_list ctxt f (rf, l) + | Psig_value vd -> + let intro = if vd.pval_prim = [] then "val" else "external" in + pp f "@[<2>%s@ %a@ :@ %a@]%a" intro + protect_ident vd.pval_name.txt + (value_description ctxt) vd + (item_attributes ctxt) vd.pval_attributes + | Psig_typext te -> + type_extension ctxt f te + | Psig_exception ed -> + exception_declaration ctxt f ed + | Psig_class () -> + () + | Psig_module ({pmd_type={pmty_desc=Pmty_alias alias; + pmty_attributes=[]; _};_} as pmd) -> + pp f "@[module@ %s@ =@ %a@]%a" pmd.pmd_name.txt + longident_loc alias + (item_attributes ctxt) pmd.pmd_attributes + | Psig_module pmd -> + pp f "@[module@ %s@ :@ %a@]%a" + pmd.pmd_name.txt + (module_type ctxt) pmd.pmd_type + (item_attributes ctxt) pmd.pmd_attributes + | Psig_open od -> + pp f "@[open%s@ %a@]%a" + (override od.popen_override) + longident_loc od.popen_lid + (item_attributes ctxt) od.popen_attributes + | Psig_include incl -> + pp f "@[include@ %a@]%a" + (module_type ctxt) incl.pincl_mod + (item_attributes ctxt) incl.pincl_attributes + | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> + pp f "@[module@ type@ %s%a@]%a" + s.txt + (fun f md -> match md with + | None -> () + | Some mt -> + pp_print_space f () ; + pp f "@ =@ %a" (module_type ctxt) mt + ) md + (item_attributes ctxt) attrs + | Psig_class_type (l) -> class_type_declaration_list ctxt f l + | Psig_recmodule decls -> + let rec string_x_module_type_list f ?(first=true) l = + match l with + | [] -> () ; + | pmd :: tl -> + if not first then + pp f "@ @[and@ %s:@ %a@]%a" pmd.pmd_name.txt + (module_type ctxt) pmd.pmd_type + (item_attributes ctxt) pmd.pmd_attributes + else + pp f "@[module@ rec@ %s:@ %a@]%a" pmd.pmd_name.txt + (module_type ctxt) pmd.pmd_type + (item_attributes ctxt) pmd.pmd_attributes; + string_x_module_type_list f ~first:false tl + in + string_x_module_type_list f decls + | Psig_attribute a -> floating_attribute ctxt f a + | Psig_extension(e, a) -> + item_extension ctxt f e; + item_attributes ctxt f a -val default_mapper : mapper +and module_expr ctxt f x = + if x.pmod_attributes <> [] then + pp f "((%a)%a)" (module_expr ctxt) {x with pmod_attributes=[]} + (attributes ctxt) x.pmod_attributes + else match x.pmod_desc with + | Pmod_structure (s) -> + pp f "@[struct@;@[<0>%a@]@;<1 -2>end@]" + (list (structure_item ctxt) ~sep:"@\n") s; + | Pmod_constraint (me, mt) -> + pp f "@[(%a@ :@ %a)@]" + (module_expr ctxt) me + (module_type ctxt) mt + | Pmod_ident (li) -> + pp f "%a" longident_loc li; + | Pmod_functor (_, None, me) -> + pp f "functor ()@;->@;%a" (module_expr ctxt) me + | Pmod_functor (s, Some mt, me) -> + pp f "functor@ (%s@ :@ %a)@;->@;%a" + s.txt (module_type ctxt) mt (module_expr ctxt) me + | Pmod_apply (me1, me2) -> + pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2 + (* Cf: #7200 *) + | Pmod_unpack e -> + pp f "(val@ %a)" (expression ctxt) e + | Pmod_extension e -> extension ctxt f e -val untype_structure : ?mapper:mapper -> Typedtree.structure -> structure -val untype_signature : ?mapper:mapper -> Typedtree.signature -> signature +and structure ctxt f x = list ~sep:"@\n" (structure_item ctxt) f x -val constant : Asttypes.constant -> Parsetree.constant +and payload ctxt f = function + | PStr [{pstr_desc = Pstr_eval (e, attrs)}] -> + pp f "@[<2>%a@]%a" + (expression ctxt) e + (item_attributes ctxt) attrs + | PStr x -> structure ctxt f x + | PTyp x -> pp f ":"; core_type ctxt f x + | PSig x -> pp f ":"; signature ctxt f x + | PPat (x, None) -> pp f "?"; pattern ctxt f x + | PPat (x, Some e) -> + pp f "?"; pattern ctxt f x; + pp f " when "; expression ctxt f e -end = struct -#1 "untypeast.ml" +(* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *) +and binding ctxt f {pvb_pat=p; pvb_expr=x; _} = + (* .pvb_attributes have already been printed by the caller, #bindings *) + let rec pp_print_pexp_function f x = + if x.pexp_attributes <> [] then pp f "=@;%a" (expression ctxt) x + else match x.pexp_desc with + | Pexp_fun (label, eo, p, e) -> + if label=Nolabel then + pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function e + else + pp f "%a@ %a" + (label_exp ctxt) (label,eo,p) pp_print_pexp_function e + | Pexp_newtype (str,e) -> + pp f "(type@ %s)@ %a" str.txt pp_print_pexp_function e + | _ -> pp f "=@;%a" (expression ctxt) x + in + let tyvars_str tyvars = List.map (fun v -> v.txt) tyvars in + let is_desugared_gadt p e = + let gadt_pattern = + match p with + | {ppat_desc=Ppat_constraint({ppat_desc=Ppat_var _} as pat, + {ptyp_desc=Ptyp_poly (args_tyvars, rt)}); + ppat_attributes=[]}-> + Some (pat, args_tyvars, rt) + | _ -> None in + let rec gadt_exp tyvars e = + match e with + | {pexp_desc=Pexp_newtype (tyvar, e); pexp_attributes=[]} -> + gadt_exp (tyvar :: tyvars) e + | {pexp_desc=Pexp_constraint (e, ct); pexp_attributes=[]} -> + Some (List.rev tyvars, e, ct) + | _ -> None in + let gadt_exp = gadt_exp [] e in + match gadt_pattern, gadt_exp with + | Some (p, pt_tyvars, pt_ct), Some (e_tyvars, e, e_ct) + when tyvars_str pt_tyvars = tyvars_str e_tyvars -> + let ety = Typ.varify_constructors e_tyvars e_ct in + if ety = pt_ct then + Some (p, pt_tyvars, e_ct, e) else None + | _ -> None in + if x.pexp_attributes <> [] + then pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x else + match is_desugared_gadt p x with + | Some (p, [], ct, e) -> + pp f "%a@;: %a@;=@;%a" + (simple_pattern ctxt) p (core_type ctxt) ct (expression ctxt) e + | Some (p, tyvars, ct, e) -> begin + pp f "%a@;: type@;%a.@;%a@;=@;%a" + (simple_pattern ctxt) p (list pp_print_string ~sep:"@;") + (tyvars_str tyvars) (core_type ctxt) ct (expression ctxt) e + end + | None -> begin + match p with + | {ppat_desc=Ppat_constraint(p ,ty); + ppat_attributes=[]} -> (* special case for the first*) + begin match ty with + | {ptyp_desc=Ptyp_poly _; ptyp_attributes=[]} -> + pp f "%a@;:@;%a@;=@;%a" (simple_pattern ctxt) p + (core_type ctxt) ty (expression ctxt) x + | _ -> + pp f "(%a@;:@;%a)@;=@;%a" (simple_pattern ctxt) p + (core_type ctxt) ty (expression ctxt) x + end + | {ppat_desc=Ppat_var _; ppat_attributes=[]} -> + pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x + | _ -> + pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x + end + +(* [in] is not printed *) +and bindings ctxt f (rf,l) = + let binding kwd rf f x = + pp f "@[<2>%s %a%a@]%a" kwd rec_flag rf + (binding ctxt) x (item_attributes ctxt) x.pvb_attributes + in + match l with + | [] -> () + | [x] -> binding "let" rf f x + | x::xs -> + pp f "@[%a@,%a@]" + (binding "let" rf) x + (list ~sep:"@," (binding "and" Nonrecursive)) xs + +and structure_item ctxt f x = + match x.pstr_desc with + | Pstr_eval (e, attrs) -> + pp f "@[;;%a@]%a" + (expression ctxt) e + (item_attributes ctxt) attrs + | Pstr_type (_, []) -> assert false + | Pstr_type (rf, l) -> type_def_list ctxt f (rf, l) + | Pstr_value (rf, l) -> + (* pp f "@[let %a%a@]" rec_flag rf bindings l *) + pp f "@[<2>%a@]" (bindings ctxt) (rf,l) + | Pstr_typext te -> type_extension ctxt f te + | Pstr_exception ed -> exception_declaration ctxt f ed + | Pstr_module x -> + let rec module_helper = function + | {pmod_desc=Pmod_functor(s,mt,me'); pmod_attributes = []} -> + if mt = None then pp f "()" + else Misc.may (pp f "(%s:%a)" s.txt (module_type ctxt)) mt; + module_helper me' + | me -> me + in + pp f "@[module %s%a@]%a" + x.pmb_name.txt + (fun f me -> + let me = module_helper me in + match me with + | {pmod_desc= + Pmod_constraint + (me', + ({pmty_desc=(Pmty_ident (_) + | Pmty_signature (_));_} as mt)); + pmod_attributes = []} -> + pp f " :@;%a@;=@;%a@;" + (module_type ctxt) mt (module_expr ctxt) me' + | _ -> pp f " =@ %a" (module_expr ctxt) me + ) x.pmb_expr + (item_attributes ctxt) x.pmb_attributes + | Pstr_open od -> + pp f "@[<2>open%s@;%a@]%a" + (override od.popen_override) + longident_loc od.popen_lid + (item_attributes ctxt) od.popen_attributes + | Pstr_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> + pp f "@[module@ type@ %s%a@]%a" + s.txt + (fun f md -> match md with + | None -> () + | Some mt -> + pp_print_space f () ; + pp f "@ =@ %a" (module_type ctxt) mt + ) md + (item_attributes ctxt) attrs + | Pstr_class () -> () + | Pstr_class_type l -> class_type_declaration_list ctxt f l + | Pstr_primitive vd -> + pp f "@[external@ %a@ :@ %a@]%a" + protect_ident vd.pval_name.txt + (value_description ctxt) vd + (item_attributes ctxt) vd.pval_attributes + | Pstr_include incl -> + pp f "@[include@ %a@]%a" + (module_expr ctxt) incl.pincl_mod + (item_attributes ctxt) incl.pincl_attributes + | Pstr_recmodule decls -> (* 3.07 *) + let aux f = function + | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) -> + pp f "@[@ and@ %s:%a@ =@ %a@]%a" pmb.pmb_name.txt + (module_type ctxt) typ + (module_expr ctxt) expr + (item_attributes ctxt) pmb.pmb_attributes + | _ -> assert false + in + begin match decls with + | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 -> + pp f "@[@[module@ rec@ %s:%a@ =@ %a@]%a@ %a@]" + pmb.pmb_name.txt + (module_type ctxt) typ + (module_expr ctxt) expr + (item_attributes ctxt) pmb.pmb_attributes + (fun f l2 -> List.iter (aux f) l2) l2 + | _ -> assert false + end + | Pstr_attribute a -> floating_attribute ctxt f a + | Pstr_extension(e, a) -> + item_extension ctxt f e; + item_attributes ctxt f a + +and type_param ctxt f (ct, a) = + pp f "%s%a" (type_variance a) (core_type ctxt) ct + +and type_params ctxt f = function + | [] -> () + | l -> pp f "%a " (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",@;") l + +and type_def_list ctxt f (rf, l) = + let type_decl kwd rf f x = + let eq = + if (x.ptype_kind = Ptype_abstract) + && (x.ptype_manifest = None) then "" + else " =" + in + pp f "@[<2>%s %a%a%s%s%a@]%a" kwd + nonrec_flag rf + (type_params ctxt) x.ptype_params + x.ptype_name.txt eq + (type_declaration ctxt) x + (item_attributes ctxt) x.ptype_attributes + in + match l with + | [] -> assert false + | [x] -> type_decl "type" rf f x + | x :: xs -> pp f "@[%a@,%a@]" + (type_decl "type" rf) x + (list ~sep:"@," (type_decl "and" Recursive)) xs + +and record_declaration ctxt f lbls = + let type_record_field f pld = + pp f "@[<2>%a%s:@;%a@;%a@]" + mutable_flag pld.pld_mutable + pld.pld_name.txt + (core_type ctxt) pld.pld_type + (attributes ctxt) pld.pld_attributes + in + pp f "{@\n%a}" + (list type_record_field ~sep:";@\n" ) lbls + +and type_declaration ctxt f x = + (* type_declaration has an attribute field, + but it's been printed by the caller of this method *) + let priv f = + match x.ptype_private with + | Public -> () + | Private -> pp f "@;private" + in + let manifest f = + match x.ptype_manifest with + | None -> () + | Some y -> + if x.ptype_kind = Ptype_abstract then + pp f "%t@;%a" priv (core_type ctxt) y + else + pp f "@;%a" (core_type ctxt) y + in + let constructor_declaration f pcd = + pp f "|@;"; + constructor_declaration ctxt f + (pcd.pcd_name.txt, pcd.pcd_args, pcd.pcd_res, pcd.pcd_attributes) + in + let repr f = + let intro f = + if x.ptype_manifest = None then () + else pp f "@;=" + in + match x.ptype_kind with + | Ptype_variant xs -> + pp f "%t%t@\n%a" intro priv + (list ~sep:"@\n" constructor_declaration) xs + | Ptype_abstract -> () + | Ptype_record l -> + pp f "%t%t@;%a" intro priv (record_declaration ctxt) l + | Ptype_open -> pp f "%t%t@;.." intro priv + in + let constraints f = + List.iter + (fun (ct1,ct2,_) -> + pp f "@[@ constraint@ %a@ =@ %a@]" + (core_type ctxt) ct1 (core_type ctxt) ct2) + x.ptype_cstrs + in + pp f "%t%t%t" manifest repr constraints + +and type_extension ctxt f x = + let extension_constructor f x = + pp f "@\n|@;%a" (extension_constructor ctxt) x + in + pp f "@[<2>type %a%a += %a@ %a@]%a" + (fun f -> function + | [] -> () + | l -> + pp f "%a@;" (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",") l) + x.ptyext_params + longident_loc x.ptyext_path + private_flag x.ptyext_private (* Cf: #7200 *) + (list ~sep:"" extension_constructor) + x.ptyext_constructors + (item_attributes ctxt) x.ptyext_attributes + +and constructor_declaration ctxt f (name, args, res, attrs) = + let name = + match name with + | "::" -> "(::)" + | s -> s in + match res with + | None -> + pp f "%s%a@;%a" name + (fun f -> function + | Pcstr_tuple [] -> () + | Pcstr_tuple l -> + pp f "@;of@;%a" (list (core_type1 ctxt) ~sep:"@;*@;") l + | Pcstr_record l -> pp f "@;of@;%a" (record_declaration ctxt) l + ) args + (attributes ctxt) attrs + | Some r -> + pp f "%s:@;%a@;%a" name + (fun f -> function + | Pcstr_tuple [] -> core_type1 ctxt f r + | Pcstr_tuple l -> pp f "%a@;->@;%a" + (list (core_type1 ctxt) ~sep:"@;*@;") l + (core_type1 ctxt) r + | Pcstr_record l -> + pp f "%a@;->@;%a" (record_declaration ctxt) l (core_type1 ctxt) r + ) + args + (attributes ctxt) attrs + +and extension_constructor ctxt f x = + (* Cf: #7200 *) + match x.pext_kind with + | Pext_decl(l, r) -> + constructor_declaration ctxt f (x.pext_name.txt, l, r, x.pext_attributes) + | Pext_rebind li -> + pp f "%s%a@;=@;%a" x.pext_name.txt + (attributes ctxt) x.pext_attributes + longident_loc li + +and case_list ctxt f l : unit = + let aux f {pc_lhs; pc_guard; pc_rhs} = + pp f "@;| @[<2>%a%a@;->@;%a@]" + (pattern ctxt) pc_lhs (option (expression ctxt) ~first:"@;when@;") + pc_guard (expression (under_pipe ctxt)) pc_rhs + in + list aux f l ~sep:"" + +and label_x_expression_param ctxt f (l,e) = + let simple_name = match e with + | {pexp_desc=Pexp_ident {txt=Lident l;_}; + pexp_attributes=[]} -> Some l + | _ -> None + in match l with + | Nolabel -> expression2 ctxt f e (* level 2*) + | Optional str -> + if Some str = simple_name then + pp f "?%s" str + else + pp f "?%s:%a" str (simple_expr ctxt) e + | Labelled lbl -> + if Some lbl = simple_name then + pp f "~%s" lbl + else + pp f "~%s:%a" lbl (simple_expr ctxt) e + + + +let expression f x = + pp f "@[%a@]" (expression reset_ctxt) x + +let string_of_expression x = + ignore (flush_str_formatter ()) ; + let f = str_formatter in + expression f x; + flush_str_formatter () + +let string_of_structure x = + ignore (flush_str_formatter ()); + let f = str_formatter in + structure reset_ctxt f x; + flush_str_formatter () + + +let core_type = core_type reset_ctxt +let pattern = pattern reset_ctxt +let signature = signature reset_ctxt +let structure = structure reset_ctxt + +end +module TypedtreeIter : sig +#1 "typedtreeIter.mli" (**************************************************************************) (* *) (* OCaml *) @@ -187444,718 +188149,687 @@ end = struct (* *) (**************************************************************************) -open Longident open Asttypes -open Parsetree -open Ast_helper +open Typedtree -module T = Typedtree -type mapper = { - attribute: mapper -> T.attribute -> attribute; - attributes: mapper -> T.attribute list -> attribute list; - case: mapper -> T.case -> case; - cases: mapper -> T.case list -> case list; - class_signature: mapper -> T.class_signature -> class_signature; - class_type: mapper -> T.class_type -> class_type; - class_type_declaration: mapper -> T.class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> T.class_type_field -> class_type_field; - constructor_declaration: mapper -> T.constructor_declaration - -> constructor_declaration; - expr: mapper -> T.expression -> expression; - extension_constructor: mapper -> T.extension_constructor - -> extension_constructor; - include_declaration: mapper -> T.include_declaration -> include_declaration; - include_description: mapper -> T.include_description -> include_description; - label_declaration: mapper -> T.label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> T.module_binding -> module_binding; - module_declaration: mapper -> T.module_declaration -> module_declaration; - module_expr: mapper -> T.module_expr -> module_expr; - module_type: mapper -> T.module_type -> module_type; - module_type_declaration: - mapper -> T.module_type_declaration -> module_type_declaration; - package_type: mapper -> T.package_type -> package_type; - open_description: mapper -> T.open_description -> open_description; - pat: mapper -> T.pattern -> pattern; - row_field: mapper -> T.row_field -> row_field; - object_field: mapper -> T.object_field -> object_field; - signature: mapper -> T.signature -> signature; - signature_item: mapper -> T.signature_item -> signature_item; - structure: mapper -> T.structure -> structure; - structure_item: mapper -> T.structure_item -> structure_item; - typ: mapper -> T.core_type -> core_type; - type_declaration: mapper -> T.type_declaration -> type_declaration; - type_extension: mapper -> T.type_extension -> type_extension; - type_kind: mapper -> T.type_kind -> type_kind; - value_binding: mapper -> T.value_binding -> value_binding; - value_description: mapper -> T.value_description -> value_description; - with_constraint: - mapper -> (Path.t * Longident.t Location.loc * T.with_constraint) - -> with_constraint; -} +module type IteratorArgument = sig + val enter_structure : structure -> unit + val enter_value_description : value_description -> unit + val enter_type_extension : type_extension -> unit + val enter_extension_constructor : extension_constructor -> unit + val enter_pattern : pattern -> unit + val enter_expression : expression -> unit + val enter_package_type : package_type -> unit + val enter_signature : signature -> unit + val enter_signature_item : signature_item -> unit + val enter_module_type_declaration : module_type_declaration -> unit + val enter_module_type : module_type -> unit + val enter_module_expr : module_expr -> unit + val enter_with_constraint : with_constraint -> unit + val enter_class_signature : class_signature -> unit + val enter_class_description : class_description -> unit + val enter_class_type_declaration : class_type_declaration -> unit + val enter_class_type : class_type -> unit + val enter_class_type_field : class_type_field -> unit + val enter_core_type : core_type -> unit + val enter_structure_item : structure_item -> unit -open T -(* -Some notes: + val leave_structure : structure -> unit + val leave_value_description : value_description -> unit + val leave_type_extension : type_extension -> unit + val leave_extension_constructor : extension_constructor -> unit + val leave_pattern : pattern -> unit + val leave_expression : expression -> unit + val leave_package_type : package_type -> unit + val leave_signature : signature -> unit + val leave_signature_item : signature_item -> unit + val leave_module_type_declaration : module_type_declaration -> unit + val leave_module_type : module_type -> unit + val leave_module_expr : module_expr -> unit + val leave_with_constraint : with_constraint -> unit + val leave_class_signature : class_signature -> unit + val leave_class_description : class_description -> unit + val leave_class_type_declaration : class_type_declaration -> unit + val leave_class_type : class_type -> unit + val leave_class_type_field : class_type_field -> unit + val leave_core_type : core_type -> unit + val leave_structure_item : structure_item -> unit - * For Pexp_function, we cannot go back to the exact original version - when there is a default argument, because the default argument is - translated in the typer. The code, if printed, will not be parsable because - new generated identifiers are not correct. + val enter_bindings : rec_flag -> unit + val enter_binding : value_binding -> unit + val leave_binding : value_binding -> unit + val leave_bindings : rec_flag -> unit - * For Pexp_apply, it is unclear whether arguments are reordered, especially - when there are optional arguments. + val enter_type_declarations : rec_flag -> unit + val enter_type_declaration : type_declaration -> unit + val leave_type_declaration : type_declaration -> unit + val leave_type_declarations : rec_flag -> unit -*) +end +module [@warning "-67"] MakeIterator : + functor (Iter : IteratorArgument) -> + sig + val iter_structure : structure -> unit + val iter_signature : signature -> unit + val iter_structure_item : structure_item -> unit + val iter_signature_item : signature_item -> unit + val iter_expression : expression -> unit + val iter_module_type : module_type -> unit + val iter_pattern : pattern -> unit + end -(** Utility functions. *) +module DefaultIteratorArgument : IteratorArgument +end = struct +#1 "typedtreeIter.ml" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) -let map_opt f = function None -> None | Some e -> Some (f e) +(* +TODO: + - 2012/05/10: Follow camlp4 way of building map and iter using classes + and inheritance ? +*) -let rec lident_of_path = function - | Path.Pident id -> Longident.Lident (Ident.name id) - | Path.Pdot (p, s, _) -> Longident.Ldot (lident_of_path p, s) - | Path.Papply (p1, p2) -> - Longident.Lapply (lident_of_path p1, lident_of_path p2) +open Asttypes +open Typedtree -let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} +module type IteratorArgument = sig -(** Try a name [$name$0], check if it's free, if not, increment and repeat. *) -let fresh_name s env = - let rec aux i = - let name = s ^ string_of_int i in - try - let _ = Env.lookup_value (Lident name) env in - name - with - | Not_found -> aux (i+1) - in - aux 0 + val enter_structure : structure -> unit + val enter_value_description : value_description -> unit + val enter_type_extension : type_extension -> unit + val enter_extension_constructor : extension_constructor -> unit + val enter_pattern : pattern -> unit + val enter_expression : expression -> unit + val enter_package_type : package_type -> unit + val enter_signature : signature -> unit + val enter_signature_item : signature_item -> unit + val enter_module_type_declaration : module_type_declaration -> unit + val enter_module_type : module_type -> unit + val enter_module_expr : module_expr -> unit + val enter_with_constraint : with_constraint -> unit + val enter_class_signature : class_signature -> unit -(** Mapping functions. *) + val enter_class_description : class_description -> unit + val enter_class_type_declaration : class_type_declaration -> unit + val enter_class_type : class_type -> unit + val enter_class_type_field : class_type_field -> unit + val enter_core_type : core_type -> unit + val enter_structure_item : structure_item -> unit -let constant = function - | Const_char c -> Pconst_char c - | Const_string (s,d) -> Pconst_string (s,d) - | Const_int i -> Pconst_integer (string_of_int i, None) - | Const_int32 i -> Pconst_integer (Int32.to_string i, Some 'l') - | Const_int64 i -> Pconst_integer (Int64.to_string i, Some 'L') - | Const_nativeint i -> Pconst_integer (Nativeint.to_string i, Some 'n') - | Const_float f -> Pconst_float (f,None) -let attribute sub (s, p) = (map_loc sub s, p) -let attributes sub l = List.map (sub.attribute sub) l + val leave_structure : structure -> unit + val leave_value_description : value_description -> unit + val leave_type_extension : type_extension -> unit + val leave_extension_constructor : extension_constructor -> unit + val leave_pattern : pattern -> unit + val leave_expression : expression -> unit + val leave_package_type : package_type -> unit + val leave_signature : signature -> unit + val leave_signature_item : signature_item -> unit + val leave_module_type_declaration : module_type_declaration -> unit + val leave_module_type : module_type -> unit + val leave_module_expr : module_expr -> unit + val leave_with_constraint : with_constraint -> unit + val leave_class_signature : class_signature -> unit -let structure sub str = - List.map (sub.structure_item sub) str.str_items + val leave_class_description : class_description -> unit + val leave_class_type_declaration : class_type_declaration -> unit + val leave_class_type : class_type -> unit + val leave_class_type_field : class_type_field -> unit + val leave_core_type : core_type -> unit + val leave_structure_item : structure_item -> unit -let open_description sub od = - let loc = sub.location sub od.open_loc in - let attrs = sub.attributes sub od.open_attributes in - Opn.mk ~loc ~attrs - ~override:od.open_override - (map_loc sub od.open_txt) + val enter_bindings : rec_flag -> unit + val enter_binding : value_binding -> unit + val leave_binding : value_binding -> unit + val leave_bindings : rec_flag -> unit -let structure_item sub item = - let loc = sub.location sub item.str_loc in - let desc = - match item.str_desc with - Tstr_eval (exp, attrs) -> Pstr_eval (sub.expr sub exp, attrs) - | Tstr_value (rec_flag, list) -> - Pstr_value (rec_flag, List.map (sub.value_binding sub) list) - | Tstr_primitive vd -> - Pstr_primitive (sub.value_description sub vd) - | Tstr_type (rec_flag, list) -> - Pstr_type (rec_flag, List.map (sub.type_declaration sub) list) - | Tstr_typext tyext -> - Pstr_typext (sub.type_extension sub tyext) - | Tstr_exception ext -> - Pstr_exception (sub.extension_constructor sub ext) - | Tstr_module mb -> - Pstr_module (sub.module_binding sub mb) - | Tstr_recmodule list -> - Pstr_recmodule (List.map (sub.module_binding sub) list) - | Tstr_modtype mtd -> - Pstr_modtype (sub.module_type_declaration sub mtd) - | Tstr_open od -> - Pstr_open (sub.open_description sub od) - | Tstr_class _list -> - Pstr_class () - | Tstr_class_type list -> - Pstr_class_type - (List.map - (fun (_id, _name, ct) -> sub.class_type_declaration sub ct) - list) - | Tstr_include incl -> - Pstr_include (sub.include_declaration sub incl) - | Tstr_attribute x -> - Pstr_attribute x - in - Str.mk ~loc desc + val enter_type_declarations : rec_flag -> unit + val enter_type_declaration : type_declaration -> unit + val leave_type_declaration : type_declaration -> unit + val leave_type_declarations : rec_flag -> unit -let value_description sub v = - let loc = sub.location sub v.val_loc in - let attrs = sub.attributes sub v.val_attributes in - Val.mk ~loc ~attrs - ~prim:v.val_prim - (map_loc sub v.val_name) - (sub.typ sub v.val_desc) + end -let module_binding sub mb = - let loc = sub.location sub mb.mb_loc in - let attrs = sub.attributes sub mb.mb_attributes in - Mb.mk ~loc ~attrs - (map_loc sub mb.mb_name) - (sub.module_expr sub mb.mb_expr) +module MakeIterator(Iter : IteratorArgument) : sig -let type_parameter sub (ct, v) = (sub.typ sub ct, v) + val iter_structure : structure -> unit + val iter_signature : signature -> unit + val iter_structure_item : structure_item -> unit + val iter_signature_item : signature_item -> unit + val iter_expression : expression -> unit + val iter_module_type : module_type -> unit + val iter_pattern : pattern -> unit -let type_declaration sub decl = - let loc = sub.location sub decl.typ_loc in - let attrs = sub.attributes sub decl.typ_attributes in - Type.mk ~loc ~attrs - ~params:(List.map (type_parameter sub) decl.typ_params) - ~cstrs:( - List.map - (fun (ct1, ct2, loc) -> - (sub.typ sub ct1, sub.typ sub ct2, sub.location sub loc)) - decl.typ_cstrs) - ~kind:(sub.type_kind sub decl.typ_kind) - ~priv:decl.typ_private - ?manifest:(map_opt (sub.typ sub) decl.typ_manifest) - (map_loc sub decl.typ_name) + end = struct -let type_kind sub tk = match tk with - | Ttype_abstract -> Ptype_abstract - | Ttype_variant list -> - Ptype_variant (List.map (sub.constructor_declaration sub) list) - | Ttype_record list -> - Ptype_record (List.map (sub.label_declaration sub) list) - | Ttype_open -> Ptype_open + let may_iter f v = + match v with + None -> () + | Some x -> f x -let constructor_arguments sub = function - | Cstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) - | Cstr_record l -> Pcstr_record (List.map (sub.label_declaration sub) l) -let constructor_declaration sub cd = - let loc = sub.location sub cd.cd_loc in - let attrs = sub.attributes sub cd.cd_attributes in - Type.constructor ~loc ~attrs - ~args:(constructor_arguments sub cd.cd_args) - ?res:(map_opt (sub.typ sub) cd.cd_res) - (map_loc sub cd.cd_name) + let rec iter_structure str = + Iter.enter_structure str; + List.iter iter_structure_item str.str_items; + Iter.leave_structure str -let label_declaration sub ld = - let loc = sub.location sub ld.ld_loc in - let attrs = sub.attributes sub ld.ld_attributes in - Type.field ~loc ~attrs - ~mut:ld.ld_mutable - (map_loc sub ld.ld_name) - (sub.typ sub ld.ld_type) -let type_extension sub tyext = - let attrs = sub.attributes sub tyext.tyext_attributes in - Te.mk ~attrs - ~params:(List.map (type_parameter sub) tyext.tyext_params) - ~priv:tyext.tyext_private - (map_loc sub tyext.tyext_txt) - (List.map (sub.extension_constructor sub) tyext.tyext_constructors) + and iter_binding vb = + Iter.enter_binding vb; + iter_pattern vb.vb_pat; + iter_expression vb.vb_expr; + Iter.leave_binding vb -let extension_constructor sub ext = - let loc = sub.location sub ext.ext_loc in - let attrs = sub.attributes sub ext.ext_attributes in - Te.constructor ~loc ~attrs - (map_loc sub ext.ext_name) - (match ext.ext_kind with - | Text_decl (args, ret) -> - Pext_decl (constructor_arguments sub args, - map_opt (sub.typ sub) ret) - | Text_rebind (_p, lid) -> Pext_rebind (map_loc sub lid) - ) + and iter_bindings rec_flag list = + Iter.enter_bindings rec_flag; + List.iter iter_binding list; + Iter.leave_bindings rec_flag -let pattern sub pat = - let loc = sub.location sub pat.pat_loc in - (* todo: fix attributes on extras *) - let attrs = sub.attributes sub pat.pat_attributes in - let desc = - match pat with - { pat_extra=[Tpat_unpack, _, _attrs]; pat_desc = Tpat_var (_,name); _ } -> - Ppat_unpack name - | { pat_extra=[Tpat_type (_path, lid), _, _attrs]; _ } -> - Ppat_type (map_loc sub lid) - | { pat_extra= (Tpat_constraint ct, _, _attrs) :: rem; _ } -> - Ppat_constraint (sub.pat sub { pat with pat_extra=rem }, - sub.typ sub ct) - | _ -> - match pat.pat_desc with - Tpat_any -> Ppat_any - | Tpat_var (id, name) -> - begin - match (Ident.name id).[0] with - 'A'..'Z' -> - Ppat_unpack name - | _ -> - Ppat_var name - end + and iter_case {c_lhs; c_guard; c_rhs} = + iter_pattern c_lhs; + may_iter iter_expression c_guard; + iter_expression c_rhs - (* We transform (_ as x) in x if _ and x have the same location. - The compiler transforms (x:t) into (_ as x : t). - This avoids transforming a warning 27 into a 26. - *) - | Tpat_alias ({pat_desc = Tpat_any; pat_loc}, _id, name) - when pat_loc = pat.pat_loc -> - Ppat_var name + and iter_cases cases = + List.iter iter_case cases - | Tpat_alias (pat, _id, name) -> - Ppat_alias (sub.pat sub pat, name) - | Tpat_constant cst -> Ppat_constant (constant cst) - | Tpat_tuple list -> - Ppat_tuple (List.map (sub.pat sub) list) - | Tpat_construct (lid, _, args) -> - Ppat_construct (map_loc sub lid, - (match args with - [] -> None - | [arg] -> Some (sub.pat sub arg) - | args -> - Some - (Pat.tuple ~loc - (List.map (sub.pat sub) args) - ) - )) - | Tpat_variant (label, pato, _) -> - Ppat_variant (label, map_opt (sub.pat sub) pato) - | Tpat_record (list, closed) -> - Ppat_record (List.map (fun (lid, _, pat) -> - map_loc sub lid, sub.pat sub pat) list, closed) - | Tpat_array list -> Ppat_array (List.map (sub.pat sub) list) - | Tpat_or (p1, p2, _) -> Ppat_or (sub.pat sub p1, sub.pat sub p2) - | Tpat_lazy p -> Ppat_lazy (sub.pat sub p) - in - Pat.mk ~loc ~attrs desc + and iter_structure_item item = + Iter.enter_structure_item item; + begin + match item.str_desc with + Tstr_eval (exp, _attrs) -> iter_expression exp + | Tstr_value (rec_flag, list) -> + iter_bindings rec_flag list + | Tstr_primitive vd -> iter_value_description vd + | Tstr_type (rf, list) -> iter_type_declarations rf list + | Tstr_typext tyext -> iter_type_extension tyext + | Tstr_exception ext -> iter_extension_constructor ext + | Tstr_module x -> iter_module_binding x + | Tstr_recmodule list -> List.iter iter_module_binding list + | Tstr_modtype mtd -> iter_module_type_declaration mtd + | Tstr_open _ -> () + | Tstr_class () -> () + | Tstr_class_type list -> + List.iter + (fun (_, _, ct) -> iter_class_type_declaration ct) + list + | Tstr_include incl -> iter_module_expr incl.incl_mod + | Tstr_attribute _ -> + () + end; + Iter.leave_structure_item item -let exp_extra sub (extra, loc, attrs) sexp = - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - let desc = - match extra with - Texp_coerce (cty1, cty2) -> - Pexp_coerce (sexp, - map_opt (sub.typ sub) cty1, - sub.typ sub cty2) - | Texp_constraint cty -> - Pexp_constraint (sexp, sub.typ sub cty) - | Texp_open (ovf, _path, lid, _) -> - Pexp_open (ovf, map_loc sub lid, sexp) - | Texp_poly cto -> Pexp_poly (sexp, map_opt (sub.typ sub) cto) - | Texp_newtype s -> Pexp_newtype (mkloc s loc, sexp) - in - Exp.mk ~loc ~attrs desc + and iter_module_binding x = + iter_module_expr x.mb_expr -let cases sub l = List.map (sub.case sub) l + and iter_value_description v = + Iter.enter_value_description v; + iter_core_type v.val_desc; + Iter.leave_value_description v -let case sub {c_lhs; c_guard; c_rhs} = - { - pc_lhs = sub.pat sub c_lhs; - pc_guard = map_opt (sub.expr sub) c_guard; - pc_rhs = sub.expr sub c_rhs; - } + and iter_constructor_arguments = function + | Cstr_tuple l -> List.iter iter_core_type l + | Cstr_record l -> List.iter (fun ld -> iter_core_type ld.ld_type) l -let value_binding sub vb = - let loc = sub.location sub vb.vb_loc in - let attrs = sub.attributes sub vb.vb_attributes in - Vb.mk ~loc ~attrs - (sub.pat sub vb.vb_pat) - (sub.expr sub vb.vb_expr) + and iter_constructor_declaration cd = + iter_constructor_arguments cd.cd_args; + option iter_core_type cd.cd_res; -let expression sub exp = - let loc = sub.location sub exp.exp_loc in - let attrs = sub.attributes sub exp.exp_attributes in - let desc = - match exp.exp_desc with - Texp_ident (_path, lid, _) -> Pexp_ident (map_loc sub lid) - | Texp_constant cst -> Pexp_constant (constant cst) - | Texp_let (rec_flag, list, exp) -> - Pexp_let (rec_flag, - List.map (sub.value_binding sub) list, - sub.expr sub exp) + and iter_type_parameter (ct, _v) = + iter_core_type ct - (* Pexp_function can't have a label, so we split in 3 cases. *) - (* One case, no guard: It's a fun. *) - | Texp_function { arg_label; cases = [{c_lhs=p; c_guard=None; c_rhs=e}]; - _ } -> - Pexp_fun (arg_label, None, sub.pat sub p, sub.expr sub e) - (* No label: it's a function. *) - | Texp_function { arg_label = Nolabel; cases; _; } -> - Pexp_function (sub.cases sub cases) - (* Mix of both, we generate `fun ~label:$name$ -> match $name$ with ...` *) - | Texp_function { arg_label = Labelled s | Optional s as label; cases; - _ } -> - let name = fresh_name s exp.exp_env in - Pexp_fun (label, None, Pat.var ~loc {loc;txt = name }, - Exp.match_ ~loc (Exp.ident ~loc {loc;txt= Lident name}) - (sub.cases sub cases)) - | Texp_apply (exp, list) -> - Pexp_apply (sub.expr sub exp, - List.fold_right (fun (label, expo) list -> - match expo with - None -> list - | Some exp -> (label, sub.expr sub exp) :: list - ) list []) - | Texp_match (exp, cases, exn_cases, _) -> - let merged_cases = sub.cases sub cases - @ List.map - (fun c -> - let uc = sub.case sub c in - let pat = { uc.pc_lhs - with ppat_desc = Ppat_exception uc.pc_lhs } - in - { uc with pc_lhs = pat }) - exn_cases - in - Pexp_match (sub.expr sub exp, merged_cases) - | Texp_try (exp, cases) -> - Pexp_try (sub.expr sub exp, sub.cases sub cases) - | Texp_tuple list -> - Pexp_tuple (List.map (sub.expr sub) list) - | Texp_construct (lid, _, args) -> - Pexp_construct (map_loc sub lid, - (match args with - [] -> None - | [ arg ] -> Some (sub.expr sub arg) - | args -> - Some - (Exp.tuple ~loc (List.map (sub.expr sub) args)) - )) - | Texp_variant (label, expo) -> - Pexp_variant (label, map_opt (sub.expr sub) expo) - | Texp_record { fields; extended_expression; _ } -> - let list = Array.fold_left (fun l -> function - | _, Kept _ -> l - | _, Overridden (lid, exp) -> (lid, sub.expr sub exp) :: l) - [] fields - in - Pexp_record (list, map_opt (sub.expr sub) extended_expression) - | Texp_field (exp, lid, _label) -> - Pexp_field (sub.expr sub exp, map_loc sub lid) - | Texp_setfield (exp1, lid, _label, exp2) -> - Pexp_setfield (sub.expr sub exp1, map_loc sub lid, - sub.expr sub exp2) - | Texp_array list -> - Pexp_array (List.map (sub.expr sub) list) - | Texp_ifthenelse (exp1, exp2, expo) -> - Pexp_ifthenelse (sub.expr sub exp1, - sub.expr sub exp2, - map_opt (sub.expr sub) expo) - | Texp_sequence (exp1, exp2) -> - Pexp_sequence (sub.expr sub exp1, sub.expr sub exp2) - | Texp_while (exp1, exp2) -> - Pexp_while (sub.expr sub exp1, sub.expr sub exp2) - | Texp_for (_id, name, exp1, exp2, dir, exp3) -> - Pexp_for (name, - sub.expr sub exp1, sub.expr sub exp2, - dir, sub.expr sub exp3) - | Texp_send (exp, meth, _) -> - Pexp_send (sub.expr sub exp, match meth with - Tmeth_name name -> mkloc name loc) - | Texp_new _ - | Texp_instvar _ - | Texp_setinstvar _ - | Texp_override _ -> - assert false - | Texp_letmodule (_id, name, mexpr, exp) -> - Pexp_letmodule (name, sub.module_expr sub mexpr, - sub.expr sub exp) - | Texp_letexception (ext, exp) -> - Pexp_letexception (sub.extension_constructor sub ext, - sub.expr sub exp) - | Texp_assert exp -> Pexp_assert (sub.expr sub exp) - | Texp_lazy exp -> Pexp_lazy (sub.expr sub exp) - | Texp_object () -> - assert false - | Texp_pack (mexpr) -> - Pexp_pack (sub.module_expr sub mexpr) - | Texp_unreachable -> - Pexp_unreachable - | Texp_extension_constructor (lid, _) -> - Pexp_extension ({ txt = "ocaml.extension_constructor"; loc }, - PStr [ Str.eval ~loc - (Exp.construct ~loc (map_loc sub lid) None) - ]) - in - List.fold_right (exp_extra sub) exp.exp_extra - (Exp.mk ~loc ~attrs desc) + and iter_type_declaration decl = + Iter.enter_type_declaration decl; + List.iter iter_type_parameter decl.typ_params; + List.iter (fun (ct1, ct2, _loc) -> + iter_core_type ct1; + iter_core_type ct2 + ) decl.typ_cstrs; + begin match decl.typ_kind with + Ttype_abstract -> () + | Ttype_variant list -> + List.iter iter_constructor_declaration list + | Ttype_record list -> + List.iter + (fun ld -> + iter_core_type ld.ld_type + ) list + | Ttype_open -> () + end; + option iter_core_type decl.typ_manifest; + Iter.leave_type_declaration decl -let package_type sub pack = - (map_loc sub pack.pack_txt, - List.map (fun (s, ct) -> - (s, sub.typ sub ct)) pack.pack_fields) + and iter_type_declarations rec_flag decls = + Iter.enter_type_declarations rec_flag; + List.iter iter_type_declaration decls; + Iter.leave_type_declarations rec_flag -let module_type_declaration sub mtd = - let loc = sub.location sub mtd.mtd_loc in - let attrs = sub.attributes sub mtd.mtd_attributes in - Mtd.mk ~loc ~attrs - ?typ:(map_opt (sub.module_type sub) mtd.mtd_type) - (map_loc sub mtd.mtd_name) + and iter_extension_constructor ext = + Iter.enter_extension_constructor ext; + begin match ext.ext_kind with + Text_decl(args, ret) -> + iter_constructor_arguments args; + option iter_core_type ret + | Text_rebind _ -> () + end; + Iter.leave_extension_constructor ext; -let signature sub sg = - List.map (sub.signature_item sub) sg.sig_items + and iter_type_extension tyext = + Iter.enter_type_extension tyext; + List.iter iter_type_parameter tyext.tyext_params; + List.iter iter_extension_constructor tyext.tyext_constructors; + Iter.leave_type_extension tyext -let signature_item sub item = - let loc = sub.location sub item.sig_loc in - let desc = - match item.sig_desc with - Tsig_value v -> - Psig_value (sub.value_description sub v) - | Tsig_type (rec_flag, list) -> - Psig_type (rec_flag, List.map (sub.type_declaration sub) list) - | Tsig_typext tyext -> - Psig_typext (sub.type_extension sub tyext) - | Tsig_exception ext -> - Psig_exception (sub.extension_constructor sub ext) - | Tsig_module md -> - Psig_module (sub.module_declaration sub md) - | Tsig_recmodule list -> - Psig_recmodule (List.map (sub.module_declaration sub) list) - | Tsig_modtype mtd -> - Psig_modtype (sub.module_type_declaration sub mtd) - | Tsig_open od -> - Psig_open (sub.open_description sub od) - | Tsig_include incl -> - Psig_include (sub.include_description sub incl) - | Tsig_class () -> - Psig_class () - | Tsig_class_type list -> - Psig_class_type (List.map (sub.class_type_declaration sub) list) - | Tsig_attribute x -> - Psig_attribute x - in - Sig.mk ~loc desc + and iter_pattern pat = + Iter.enter_pattern pat; + List.iter (fun (cstr, _, _attrs) -> match cstr with + | Tpat_type _ -> () + | Tpat_unpack -> () + | Tpat_open _ -> () + | Tpat_constraint ct -> iter_core_type ct) pat.pat_extra; + begin + match pat.pat_desc with + Tpat_any -> () + | Tpat_var _ -> () + | Tpat_alias (pat1, _, _) -> iter_pattern pat1 + | Tpat_constant _ -> () + | Tpat_tuple list -> + List.iter iter_pattern list + | Tpat_construct (_, _, args) -> + List.iter iter_pattern args + | Tpat_variant (_, pato, _) -> + begin match pato with + None -> () + | Some pat -> iter_pattern pat + end + | Tpat_record (list, _closed) -> + List.iter (fun (_, _, pat) -> iter_pattern pat) list + | Tpat_array list -> List.iter iter_pattern list + | Tpat_or (p1, p2, _) -> iter_pattern p1; iter_pattern p2 + | Tpat_lazy p -> iter_pattern p + end; + Iter.leave_pattern pat -let module_declaration sub md = - let loc = sub.location sub md.md_loc in - let attrs = sub.attributes sub md.md_attributes in - Md.mk ~loc ~attrs - (map_loc sub md.md_name) - (sub.module_type sub md.md_type) + and option f x = match x with None -> () | Some e -> f e -let include_infos f sub incl = - let loc = sub.location sub incl.incl_loc in - let attrs = sub.attributes sub incl.incl_attributes in - Incl.mk ~loc ~attrs - (f sub incl.incl_mod) + and iter_expression exp = + Iter.enter_expression exp; + List.iter (function (cstr, _, _attrs) -> + match cstr with + Texp_constraint ct -> + iter_core_type ct + | Texp_coerce (cty1, cty2) -> + option iter_core_type cty1; iter_core_type cty2 + | Texp_open _ -> () + | Texp_poly cto -> option iter_core_type cto + | Texp_newtype _ -> ()) + exp.exp_extra; + begin + match exp.exp_desc with + Texp_ident _ -> () + | Texp_constant _ -> () + | Texp_let (rec_flag, list, exp) -> + iter_bindings rec_flag list; + iter_expression exp + | Texp_function { cases; _ } -> + iter_cases cases + | Texp_apply (exp, list) -> + iter_expression exp; + List.iter (fun (_label, expo) -> + match expo with + None -> () + | Some exp -> iter_expression exp + ) list + | Texp_match (exp, list1, list2, _) -> + iter_expression exp; + iter_cases list1; + iter_cases list2; + | Texp_try (exp, list) -> + iter_expression exp; + iter_cases list + | Texp_tuple list -> + List.iter iter_expression list + | Texp_construct (_, _, args) -> + List.iter iter_expression args + | Texp_variant (_label, expo) -> + begin match expo with + None -> () + | Some exp -> iter_expression exp + end + | Texp_record { fields; extended_expression; _ } -> + Array.iter (function + | _, Kept _ -> () + | _, Overridden (_, exp) -> iter_expression exp) + fields; + begin match extended_expression with + None -> () + | Some exp -> iter_expression exp + end + | Texp_field (exp, _, _label) -> + iter_expression exp + | Texp_setfield (exp1, _, _label, exp2) -> + iter_expression exp1; + iter_expression exp2 + | Texp_array list -> + List.iter iter_expression list + | Texp_ifthenelse (exp1, exp2, expo) -> + iter_expression exp1; + iter_expression exp2; + begin match expo with + None -> () + | Some exp -> iter_expression exp + end + | Texp_sequence (exp1, exp2) -> + iter_expression exp1; + iter_expression exp2 + | Texp_while (exp1, exp2) -> + iter_expression exp1; + iter_expression exp2 + | Texp_for (_id, _, exp1, exp2, _dir, exp3) -> + iter_expression exp1; + iter_expression exp2; + iter_expression exp3 + | Texp_send (exp, _meth, expo) -> + iter_expression exp; + begin + match expo with + None -> () + | Some exp -> iter_expression exp + end + | Texp_new _ + | Texp_instvar _ + | Texp_setinstvar _ + | Texp_override _ -> () + | Texp_letmodule (_id, _, mexpr, exp) -> + iter_module_expr mexpr; + iter_expression exp + | Texp_letexception (cd, exp) -> + iter_extension_constructor cd; + iter_expression exp + | Texp_assert exp -> iter_expression exp + | Texp_lazy exp -> iter_expression exp + | Texp_object () -> + () + | Texp_pack (mexpr) -> + iter_module_expr mexpr + | Texp_unreachable -> + () + | Texp_extension_constructor _ -> + () + end; + Iter.leave_expression exp; -let include_declaration sub = include_infos sub.module_expr sub -let include_description sub = include_infos sub.module_type sub + and iter_package_type pack = + Iter.enter_package_type pack; + List.iter (fun (_s, ct) -> iter_core_type ct) pack.pack_fields; + Iter.leave_package_type pack; -let class_infos f sub ci = - let loc = sub.location sub ci.ci_loc in - let attrs = sub.attributes sub ci.ci_attributes in - Ci.mk ~loc ~attrs - ~virt:ci.ci_virt - ~params:(List.map (type_parameter sub) ci.ci_params) - (map_loc sub ci.ci_id_name) - (f sub ci.ci_expr) + and iter_signature sg = + Iter.enter_signature sg; + List.iter iter_signature_item sg.sig_items; + Iter.leave_signature sg; -let class_type_declaration sub = class_infos sub.class_type sub + and iter_signature_item item = + Iter.enter_signature_item item; + begin + match item.sig_desc with + Tsig_value vd -> + iter_value_description vd + | Tsig_type (rf, list) -> + iter_type_declarations rf list + | Tsig_exception ext -> + iter_extension_constructor ext + | Tsig_typext tyext -> + iter_type_extension tyext + | Tsig_module md -> + iter_module_type md.md_type + | Tsig_recmodule list -> + List.iter (fun md -> iter_module_type md.md_type) list + | Tsig_modtype mtd -> + iter_module_type_declaration mtd + | Tsig_open _ -> () + | Tsig_include incl -> iter_module_type incl.incl_mod + | Tsig_class () -> () + | Tsig_class_type list -> + List.iter iter_class_type_declaration list + | Tsig_attribute _ -> () + end; + Iter.leave_signature_item item; -let module_type sub mty = - let loc = sub.location sub mty.mty_loc in - let attrs = sub.attributes sub mty.mty_attributes in - let desc = match mty.mty_desc with - Tmty_ident (_path, lid) -> Pmty_ident (map_loc sub lid) - | Tmty_alias (_path, lid) -> Pmty_alias (map_loc sub lid) - | Tmty_signature sg -> Pmty_signature (sub.signature sub sg) - | Tmty_functor (_id, name, mtype1, mtype2) -> - Pmty_functor (name, map_opt (sub.module_type sub) mtype1, - sub.module_type sub mtype2) - | Tmty_with (mtype, list) -> - Pmty_with (sub.module_type sub mtype, - List.map (sub.with_constraint sub) list) - | Tmty_typeof mexpr -> - Pmty_typeof (sub.module_expr sub mexpr) - in - Mty.mk ~loc ~attrs desc + and iter_module_type_declaration mtd = + Iter.enter_module_type_declaration mtd; + begin + match mtd.mtd_type with + | None -> () + | Some mtype -> iter_module_type mtype + end; + Iter.leave_module_type_declaration mtd -let with_constraint sub (_path, lid, cstr) = - match cstr with - | Twith_type decl -> - Pwith_type (map_loc sub lid, sub.type_declaration sub decl) - | Twith_module (_path, lid2) -> - Pwith_module (map_loc sub lid, map_loc sub lid2) - | Twith_typesubst decl -> - Pwith_typesubst (map_loc sub lid, sub.type_declaration sub decl) - | Twith_modsubst (_path, lid2) -> - Pwith_modsubst (map_loc sub lid, map_loc sub lid2) -let module_expr sub mexpr = - let loc = sub.location sub mexpr.mod_loc in - let attrs = sub.attributes sub mexpr.mod_attributes in - match mexpr.mod_desc with - Tmod_constraint (m, _, Tmodtype_implicit, _ ) -> - sub.module_expr sub m - | _ -> - let desc = match mexpr.mod_desc with - Tmod_ident (_p, lid) -> Pmod_ident (map_loc sub lid) - | Tmod_structure st -> Pmod_structure (sub.structure sub st) - | Tmod_functor (_id, name, mtype, mexpr) -> - Pmod_functor (name, Misc.may_map (sub.module_type sub) mtype, - sub.module_expr sub mexpr) - | Tmod_apply (mexp1, mexp2, _) -> - Pmod_apply (sub.module_expr sub mexp1, sub.module_expr sub mexp2) - | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) -> - Pmod_constraint (sub.module_expr sub mexpr, - sub.module_type sub mtype) - | Tmod_constraint (_mexpr, _, Tmodtype_implicit, _) -> - assert false - | Tmod_unpack (exp, _pack) -> - Pmod_unpack (sub.expr sub exp) - (* TODO , sub.package_type sub pack) *) - in - Mod.mk ~loc ~attrs desc + and iter_class_type_declaration cd = + Iter.enter_class_type_declaration cd; + List.iter iter_type_parameter cd.ci_params; + iter_class_type cd.ci_expr; + Iter.leave_class_type_declaration cd; + and iter_module_type mty = + Iter.enter_module_type mty; + begin + match mty.mty_desc with + Tmty_ident _ -> () + | Tmty_alias _ -> () + | Tmty_signature sg -> iter_signature sg + | Tmty_functor (_, _, mtype1, mtype2) -> + Misc.may iter_module_type mtype1; iter_module_type mtype2 + | Tmty_with (mtype, list) -> + iter_module_type mtype; + List.iter (fun (_path, _, withc) -> + iter_with_constraint withc + ) list + | Tmty_typeof mexpr -> + iter_module_expr mexpr + end; + Iter.leave_module_type mty; -let class_type sub ct = - let loc = sub.location sub ct.cltyp_loc in - let attrs = sub.attributes sub ct.cltyp_attributes in - let desc = match ct.cltyp_desc with - Tcty_signature csg -> Pcty_signature (sub.class_signature sub csg) - | Tcty_constr (_path, lid, list) -> - Pcty_constr (map_loc sub lid, List.map (sub.typ sub) list) - | Tcty_arrow (label, ct, cl) -> - Pcty_arrow (label, sub.typ sub ct, sub.class_type sub cl) - | Tcty_open (ovf, _p, lid, _env, e) -> - Pcty_open (ovf, lid, sub.class_type sub e) - in - Cty.mk ~loc ~attrs desc + and iter_with_constraint cstr = + Iter.enter_with_constraint cstr; + begin + match cstr with + Twith_type decl -> iter_type_declaration decl + | Twith_module _ -> () + | Twith_typesubst decl -> iter_type_declaration decl + | Twith_modsubst _ -> () + end; + Iter.leave_with_constraint cstr; -let class_signature sub cs = - { - pcsig_self = sub.typ sub cs.csig_self; - pcsig_fields = List.map (sub.class_type_field sub) cs.csig_fields; - } + and iter_module_expr mexpr = + Iter.enter_module_expr mexpr; + begin + match mexpr.mod_desc with + Tmod_ident _ -> () + | Tmod_structure st -> iter_structure st + | Tmod_functor (_, _, mtype, mexpr) -> + Misc.may iter_module_type mtype; + iter_module_expr mexpr + | Tmod_apply (mexp1, mexp2, _) -> + iter_module_expr mexp1; + iter_module_expr mexp2 + | Tmod_constraint (mexpr, _, Tmodtype_implicit, _ ) -> + iter_module_expr mexpr + | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) -> + iter_module_expr mexpr; + iter_module_type mtype + | Tmod_unpack (exp, _mty) -> + iter_expression exp +(* iter_module_type mty *) + end; + Iter.leave_module_expr mexpr; -let class_type_field sub ctf = - let loc = sub.location sub ctf.ctf_loc in - let attrs = sub.attributes sub ctf.ctf_attributes in - let desc = match ctf.ctf_desc with - Tctf_inherit ct -> Pctf_inherit (sub.class_type sub ct) - | Tctf_val (s, mut, virt, ct) -> - Pctf_val (mkloc s loc, mut, virt, sub.typ sub ct) - | Tctf_method (s, priv, virt, ct) -> - Pctf_method (mkloc s loc, priv, virt, sub.typ sub ct) - | Tctf_constraint (ct1, ct2) -> - Pctf_constraint (sub.typ sub ct1, sub.typ sub ct2) - | Tctf_attribute x -> Pctf_attribute x - in - Ctf.mk ~loc ~attrs desc -let core_type sub ct = - let loc = sub.location sub ct.ctyp_loc in - let attrs = sub.attributes sub ct.ctyp_attributes in - let desc = match ct.ctyp_desc with - Ttyp_any -> Ptyp_any - | Ttyp_var s -> Ptyp_var s - | Ttyp_arrow (label, ct1, ct2) -> - Ptyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2) - | Ttyp_tuple list -> Ptyp_tuple (List.map (sub.typ sub) list) - | Ttyp_constr (_path, lid, list) -> - Ptyp_constr (map_loc sub lid, - List.map (sub.typ sub) list) - | Ttyp_object (list, o) -> - Ptyp_object - (List.map (sub.object_field sub) list, o) - | Ttyp_class (_path, lid, list) -> - Ptyp_class (map_loc sub lid, List.map (sub.typ sub) list) - | Ttyp_alias (ct, s) -> - Ptyp_alias (sub.typ sub ct, s) - | Ttyp_variant (list, bool, labels) -> - Ptyp_variant (List.map (sub.row_field sub) list, bool, labels) - | Ttyp_poly (list, ct) -> - let list = List.map (fun v -> mkloc v loc) list in - Ptyp_poly (list, sub.typ sub ct) - | Ttyp_package pack -> Ptyp_package (sub.package_type sub pack) - in - Typ.mk ~loc ~attrs desc + and iter_class_type ct = + Iter.enter_class_type ct; + begin + match ct.cltyp_desc with + Tcty_signature csg -> iter_class_signature csg + | Tcty_constr (_path, _, list) -> + List.iter iter_core_type list + | Tcty_arrow (_label, ct, cl) -> + iter_core_type ct; + iter_class_type cl + | Tcty_open (_, _, _, _, e) -> + iter_class_type e + end; + Iter.leave_class_type ct; + and iter_class_signature cs = + Iter.enter_class_signature cs; + iter_core_type cs.csig_self; + List.iter iter_class_type_field cs.csig_fields; + Iter.leave_class_signature cs -let row_field sub rf = - match rf with - Ttag (label, attrs, bool, list) -> - Rtag (label, sub.attributes sub attrs, bool, List.map (sub.typ sub) list) - | Tinherit ct -> Rinherit (sub.typ sub ct) -let object_field sub ofield = - match ofield with - OTtag (label, attrs, ct) -> - Otag (label, sub.attributes sub attrs, sub.typ sub ct) - | OTinherit ct -> Oinherit (sub.typ sub ct) + and iter_class_type_field ctf = + Iter.enter_class_type_field ctf; + begin + match ctf.ctf_desc with + Tctf_inherit ct -> iter_class_type ct + | Tctf_val (_s, _mut, _virt, ct) -> + iter_core_type ct + | Tctf_method (_s, _priv, _virt, ct) -> + iter_core_type ct + | Tctf_constraint (ct1, ct2) -> + iter_core_type ct1; + iter_core_type ct2 + | Tctf_attribute _ -> () + end; + Iter.leave_class_type_field ctf + and iter_core_type ct = + Iter.enter_core_type ct; + begin + match ct.ctyp_desc with + Ttyp_any -> () + | Ttyp_var _ -> () + | Ttyp_arrow (_label, ct1, ct2) -> + iter_core_type ct1; + iter_core_type ct2 + | Ttyp_tuple list -> List.iter iter_core_type list + | Ttyp_constr (_path, _, list) -> + List.iter iter_core_type list + | Ttyp_object (list, _o) -> + List.iter iter_object_field list + | Ttyp_class (_path, _, list) -> + List.iter iter_core_type list + | Ttyp_alias (ct, _s) -> + iter_core_type ct + | Ttyp_variant (list, _bool, _labels) -> + List.iter iter_row_field list + | Ttyp_poly (_list, ct) -> iter_core_type ct + | Ttyp_package pack -> iter_package_type pack + end; + Iter.leave_core_type ct + and iter_row_field rf = + match rf with + Ttag (_label, _attrs, _bool, list) -> + List.iter iter_core_type list + | Tinherit ct -> iter_core_type ct -let location _sub l = l + and iter_object_field ofield = + match ofield with + OTtag (_, _, ct) | OTinherit ct -> iter_core_type ct -let default_mapper = - { - attribute = attribute ; - attributes = attributes ; - structure = structure; - structure_item = structure_item; - module_expr = module_expr; - signature = signature; - signature_item = signature_item; - module_type = module_type; - with_constraint = with_constraint; - class_type = class_type; - class_type_field = class_type_field; - class_signature = class_signature; - class_type_declaration = class_type_declaration; - type_declaration = type_declaration; - type_kind = type_kind; - typ = core_type; - type_extension = type_extension; - extension_constructor = extension_constructor; - value_description = value_description; - pat = pattern; - expr = expression; - module_declaration = module_declaration; - module_type_declaration = module_type_declaration; - module_binding = module_binding; - package_type = package_type ; - open_description = open_description; - include_description = include_description; - include_declaration = include_declaration; - value_binding = value_binding; - constructor_declaration = constructor_declaration; - label_declaration = label_declaration; - cases = cases; - case = case; - location = location; - row_field = row_field ; - object_field = object_field ; - } + end -let untype_structure ?(mapper=default_mapper) structure = - mapper.structure mapper structure +module DefaultIteratorArgument = struct -let untype_signature ?(mapper=default_mapper) signature = - mapper.signature mapper signature + let enter_structure _ = () + let enter_value_description _ = () + let enter_type_extension _ = () + let enter_extension_constructor _ = () + let enter_pattern _ = () + let enter_expression _ = () + let enter_package_type _ = () + let enter_signature _ = () + let enter_signature_item _ = () + let enter_module_type_declaration _ = () + let enter_module_type _ = () + let enter_module_expr _ = () + let enter_with_constraint _ = () + let enter_class_signature _ = () + + let enter_class_description _ = () + let enter_class_type_declaration _ = () + let enter_class_type _ = () + let enter_class_type_field _ = () + let enter_core_type _ = () + let enter_structure_item _ = () + + + let leave_structure _ = () + let leave_value_description _ = () + let leave_type_extension _ = () + let leave_extension_constructor _ = () + let leave_pattern _ = () + let leave_expression _ = () + let leave_package_type _ = () + let leave_signature _ = () + let leave_signature_item _ = () + let leave_module_type_declaration _ = () + let leave_module_type _ = () + let leave_module_expr _ = () + let leave_with_constraint _ = () + let leave_class_signature _ = () + + let leave_class_description _ = () + let leave_class_type_declaration _ = () + let leave_class_type _ = () + let leave_class_type_field _ = () + let leave_core_type _ = () + let leave_structure_item _ = () + + let enter_binding _ = () + let leave_binding _ = () + + let enter_bindings _ = () + let leave_bindings _ = () + + let enter_type_declaration _ = () + let leave_type_declaration _ = () + + let enter_type_declarations _ = () + let leave_type_declarations _ = () +end end -module Parmatch : sig -#1 "parmatch.mli" +module Untypeast : sig +#1 "untypeast.mli" (**************************************************************************) (* *) (* OCaml *) (* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) (* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. *) (* *) (* All rights reserved. This file is distributed under the terms of *) @@ -188164,103 +188838,75 @@ module Parmatch : sig (* *) (**************************************************************************) -(* Detection of partial matches and unused match cases. *) -open Asttypes -open Typedtree -open Types - -val pretty_const : constant -> string -val top_pretty : Format.formatter -> pattern -> unit -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 -val normalize_pat : pattern -> pattern -val all_record_args : - (Longident.t loc * label_description * pattern) list -> - (Longident.t loc * label_description * pattern) list -val const_compare : constant -> constant -> int - -val le_pat : pattern -> pattern -> bool -val le_pats : pattern list -> pattern list -> bool - -(* Exported compatibility functor, abstracted over constructor equality *) -module [@warning "-67"] Compat : - functor - (Constr: sig - val equal : - Types.constructor_description -> - Types.constructor_description -> - bool - end) -> sig - val compat : pattern -> pattern -> bool - val compats : pattern list -> pattern list -> bool - end - -exception Empty -val lub : pattern -> pattern -> pattern -val lubs : pattern list -> pattern list -> pattern list - -val get_mins : ('a -> 'a -> bool) -> 'a list -> 'a list - -(* Those two functions recombine one pattern and its arguments: - For instance: - (_,_)::p1::p2::rem -> (p1, p2)::rem - The second one will replace mutable arguments by '_' -*) -val set_args : pattern -> pattern list -> pattern list -val set_args_erase_mutable : pattern -> pattern list -> pattern list - -val pat_of_constr : pattern -> constructor_description -> pattern -val complete_constrs : - pattern -> constructor_tag list -> constructor_description list -val ppat_of_type : - Env.t -> type_expr -> - Parsetree.pattern * - (string, constructor_description) Hashtbl.t * - (string, label_description) Hashtbl.t +open Parsetree -val pressure_variants: Env.t -> pattern list -> unit -val check_partial_gadt: - ((string, constructor_description) Hashtbl.t -> - (string, label_description) Hashtbl.t -> - Parsetree.pattern -> pattern option) -> - Location.t -> case list -> partial -val check_unused: - (bool -> - (string, constructor_description) Hashtbl.t -> - (string, label_description) Hashtbl.t -> - Parsetree.pattern -> pattern option) -> - case list -> unit +val lident_of_path : Path.t -> Longident.t -(* Irrefutability tests *) -val irrefutable : pattern -> bool +type mapper = { + attribute: mapper -> Typedtree.attribute -> attribute; + attributes: mapper -> Typedtree.attribute list -> attribute list; + case: mapper -> Typedtree.case -> case; + cases: mapper -> Typedtree.case list -> case list; + class_signature: mapper -> Typedtree.class_signature -> class_signature; + class_type: mapper -> Typedtree.class_type -> class_type; + class_type_declaration: mapper -> Typedtree.class_type_declaration + -> class_type_declaration; + class_type_field: mapper -> Typedtree.class_type_field -> class_type_field; + constructor_declaration: mapper -> Typedtree.constructor_declaration + -> constructor_declaration; + expr: mapper -> Typedtree.expression -> expression; + extension_constructor: mapper -> Typedtree.extension_constructor + -> extension_constructor; + include_declaration: + mapper -> Typedtree.include_declaration -> include_declaration; + include_description: + mapper -> Typedtree.include_description -> include_description; + label_declaration: + mapper -> Typedtree.label_declaration -> label_declaration; + location: mapper -> Location.t -> Location.t; + module_binding: mapper -> Typedtree.module_binding -> module_binding; + module_declaration: + mapper -> Typedtree.module_declaration -> module_declaration; + module_expr: mapper -> Typedtree.module_expr -> module_expr; + module_type: mapper -> Typedtree.module_type -> module_type; + module_type_declaration: + mapper -> Typedtree.module_type_declaration -> module_type_declaration; + package_type: mapper -> Typedtree.package_type -> package_type; + open_description: mapper -> Typedtree.open_description -> open_description; + pat: mapper -> Typedtree.pattern -> pattern; + row_field: mapper -> Typedtree.row_field -> row_field; + object_field: mapper -> Typedtree.object_field -> object_field; + signature: mapper -> Typedtree.signature -> signature; + signature_item: mapper -> Typedtree.signature_item -> signature_item; + structure: mapper -> Typedtree.structure -> structure; + structure_item: mapper -> Typedtree.structure_item -> structure_item; + typ: mapper -> Typedtree.core_type -> core_type; + type_declaration: mapper -> Typedtree.type_declaration -> type_declaration; + type_extension: mapper -> Typedtree.type_extension -> type_extension; + type_kind: mapper -> Typedtree.type_kind -> type_kind; + value_binding: mapper -> Typedtree.value_binding -> value_binding; + value_description: mapper -> Typedtree.value_description -> value_description; + with_constraint: + mapper -> (Path.t * Longident.t Location.loc * Typedtree.with_constraint) + -> with_constraint; +} -(** An inactive pattern is a pattern, matching against which can be duplicated, erased or - delayed without change in observable behavior of the program. Patterns containing - (lazy _) subpatterns or reads of mutable fields are active. *) -val inactive : partial:partial -> pattern -> bool +val default_mapper : mapper -(* Ambiguous bindings *) -val check_ambiguous_bindings : case list -> unit +val untype_structure : ?mapper:mapper -> Typedtree.structure -> structure +val untype_signature : ?mapper:mapper -> Typedtree.signature -> signature -(* The tag used for open polymorphic variant types *) -val some_other_tag : label +val constant : Asttypes.constant -> Parsetree.constant end = struct -#1 "parmatch.ml" +#1 "untypeast.ml" (**************************************************************************) (* *) (* OCaml *) (* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) (* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. *) (* *) (* All rights reserved. This file is distributed under the terms of *) @@ -188269,531 +188915,1356 @@ end = struct (* *) (**************************************************************************) -(* Detection of partial matches and unused match cases. *) - -open Misc +open Longident open Asttypes -open Types -open Typedtree +open Parsetree +open Ast_helper -(*************************************) -(* Utilities for building patterns *) -(*************************************) +module T = Typedtree -let make_pat desc ty tenv = - {pat_desc = desc; pat_loc = Location.none; pat_extra = []; - pat_type = ty ; pat_env = tenv; - pat_attributes = []; - } +type mapper = { + attribute: mapper -> T.attribute -> attribute; + attributes: mapper -> T.attribute list -> attribute list; + case: mapper -> T.case -> case; + cases: mapper -> T.case list -> case list; + class_signature: mapper -> T.class_signature -> class_signature; + class_type: mapper -> T.class_type -> class_type; + class_type_declaration: mapper -> T.class_type_declaration + -> class_type_declaration; + class_type_field: mapper -> T.class_type_field -> class_type_field; + constructor_declaration: mapper -> T.constructor_declaration + -> constructor_declaration; + expr: mapper -> T.expression -> expression; + extension_constructor: mapper -> T.extension_constructor + -> extension_constructor; + include_declaration: mapper -> T.include_declaration -> include_declaration; + include_description: mapper -> T.include_description -> include_description; + label_declaration: mapper -> T.label_declaration -> label_declaration; + location: mapper -> Location.t -> Location.t; + module_binding: mapper -> T.module_binding -> module_binding; + module_declaration: mapper -> T.module_declaration -> module_declaration; + module_expr: mapper -> T.module_expr -> module_expr; + module_type: mapper -> T.module_type -> module_type; + module_type_declaration: + mapper -> T.module_type_declaration -> module_type_declaration; + package_type: mapper -> T.package_type -> package_type; + open_description: mapper -> T.open_description -> open_description; + pat: mapper -> T.pattern -> pattern; + row_field: mapper -> T.row_field -> row_field; + object_field: mapper -> T.object_field -> object_field; + signature: mapper -> T.signature -> signature; + signature_item: mapper -> T.signature_item -> signature_item; + structure: mapper -> T.structure -> structure; + structure_item: mapper -> T.structure_item -> structure_item; + typ: mapper -> T.core_type -> core_type; + type_declaration: mapper -> T.type_declaration -> type_declaration; + type_extension: mapper -> T.type_extension -> type_extension; + type_kind: mapper -> T.type_kind -> type_kind; + value_binding: mapper -> T.value_binding -> value_binding; + value_description: mapper -> T.value_description -> value_description; + with_constraint: + mapper -> (Path.t * Longident.t Location.loc * T.with_constraint) + -> with_constraint; +} -let omega = make_pat Tpat_any Ctype.none Env.empty +open T -let extra_pat = - make_pat - (Tpat_var (Ident.create "+", mknoloc "+")) - Ctype.none Env.empty +(* +Some notes: -let rec omegas i = - if i <= 0 then [] else omega :: omegas (i-1) + * For Pexp_function, we cannot go back to the exact original version + when there is a default argument, because the default argument is + translated in the typer. The code, if printed, will not be parsable because + new generated identifiers are not correct. -let omega_list l = List.map (fun _ -> omega) l + * For Pexp_apply, it is unclear whether arguments are reordered, especially + when there are optional arguments. -let zero = make_pat (Tpat_constant (Const_int 0)) Ctype.none Env.empty +*) -(*******************) -(* Coherence check *) -(*******************) -(* For some of the operations we do in this module, we would like (because it - simplifies matters) to assume that patterns appearing on a given column in a - pattern matrix are /coherent/ (think "of the same type"). - Unfortunately that is not always true. +(** Utility functions. *) - Consider the following (well-typed) example: - {[ - type _ t = S : string t | U : unit t - let f (type a) (t1 : a t) (t2 : a t) (a : a) = - match t1, t2, a with - | U, _, () -> () - | _, S, "" -> () - ]} +let map_opt f = function None -> None | Some e -> Some (f e) - Clearly the 3rd column contains incoherent patterns. +let rec lident_of_path = function + | Path.Pident id -> Longident.Lident (Ident.name id) + | Path.Pdot (p, s, _) -> Longident.Ldot (lident_of_path p, s) + | Path.Papply (p1, p2) -> + Longident.Lapply (lident_of_path p1, lident_of_path p2) - On the example above, most of the algorithms will explore the pattern matrix - as illustrated by the following tree: +let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} - {v - S - -------> | "" | - U | S, "" | __/ | () | - --------> | _, () | \ ¬ S - | U, _, () | __/ -------> | () | - | _, S, "" | \ - ---------> | S, "" | ----------> | "" | - ¬ U S - v} +(** Try a name [$name$0], check if it's free, if not, increment and repeat. *) +let fresh_name s env = + let rec aux i = + let name = s ^ string_of_int i in + try + let _ = Env.lookup_value (Lident name) env in + name + with + | Not_found -> aux (i+1) + in + aux 0 - where following an edge labelled by a pattern P means "assuming the value I - am matching on is filtered by [P] on the column I am currently looking at, - then the following submatrix is still reachable". +(** Mapping functions. *) - Notice that at any point of that tree, if the first column of a matrix is - incoherent, then the branch leading to it can only be taken if the scrutinee - is ill-typed. - In the example above the only case where we have a matrix with an incoherent - first column is when we consider [t1, t2, a] to be [U, S, ...]. However such - a value would be ill-typed, so we can never actually get there. +let constant = function + | Const_char c -> Pconst_char c + | Const_string (s,d) -> Pconst_string (s,d) + | Const_int i -> Pconst_integer (string_of_int i, None) + | Const_int32 i -> Pconst_integer (Int32.to_string i, Some 'l') + | Const_int64 i -> Pconst_integer (Int64.to_string i, Some 'L') + | Const_nativeint i -> Pconst_integer (Nativeint.to_string i, Some 'n') + | Const_float f -> Pconst_float (f,None) - Checking the first column at each step of the recursion and making the - concious decision of "aborting" the algorithm whenever the first column - becomes incoherent, allows us to retain the initial assumption in later - stages of the algorithms. +let attribute sub (s, p) = (map_loc sub s, p) +let attributes sub l = List.map (sub.attribute sub) l - --- +let structure sub str = + List.map (sub.structure_item sub) str.str_items - N.B. two patterns can be considered coherent even though they might not be of - the same type. +let open_description sub od = + let loc = sub.location sub od.open_loc in + let attrs = sub.attributes sub od.open_attributes in + Opn.mk ~loc ~attrs + ~override:od.open_override + (map_loc sub od.open_txt) - That's in part because we only care about the "head" of patterns and leave - checking coherence of subpatterns for the next steps of the algorithm: - ('a', 'b') and (1, ()) will be deemed coherent because they are both a tuples - of arity 2 (we'll notice at a later stage the incoherence of 'a' and 1). - - But also because it can be hard/costly to determine exactly whether two - patterns are of the same type or not (eg. in the example above with _ and S, - but see also the module [Coherence_illustration] in - testsuite/tests/basic-more/robustmatch.ml). +let structure_item sub item = + let loc = sub.location sub item.str_loc in + let desc = + match item.str_desc with + Tstr_eval (exp, attrs) -> Pstr_eval (sub.expr sub exp, attrs) + | Tstr_value (rec_flag, list) -> + Pstr_value (rec_flag, List.map (sub.value_binding sub) list) + | Tstr_primitive vd -> + Pstr_primitive (sub.value_description sub vd) + | Tstr_type (rec_flag, list) -> + Pstr_type (rec_flag, List.map (sub.type_declaration sub) list) + | Tstr_typext tyext -> + Pstr_typext (sub.type_extension sub tyext) + | Tstr_exception ext -> + Pstr_exception (sub.extension_constructor sub ext) + | Tstr_module mb -> + Pstr_module (sub.module_binding sub mb) + | Tstr_recmodule list -> + Pstr_recmodule (List.map (sub.module_binding sub) list) + | Tstr_modtype mtd -> + Pstr_modtype (sub.module_type_declaration sub mtd) + | Tstr_open od -> + Pstr_open (sub.open_description sub od) + | Tstr_class _list -> + Pstr_class () + | Tstr_class_type list -> + Pstr_class_type + (List.map + (fun (_id, _name, ct) -> sub.class_type_declaration sub ct) + list) + | Tstr_include incl -> + Pstr_include (sub.include_declaration sub incl) + | Tstr_attribute x -> + Pstr_attribute x + in + Str.mk ~loc desc - For the moment our weak, loosely-syntactic, coherence check seems to be - enough and we leave it to each user to consider (and document!) what happens - when an "incoherence" is not detected by this check. -*) +let value_description sub v = + let loc = sub.location sub v.val_loc in + let attrs = sub.attributes sub v.val_attributes in + Val.mk ~loc ~attrs + ~prim:v.val_prim + (map_loc sub v.val_name) + (sub.typ sub v.val_desc) +let module_binding sub mb = + let loc = sub.location sub mb.mb_loc in + let attrs = sub.attributes sub mb.mb_attributes in + Mb.mk ~loc ~attrs + (map_loc sub mb.mb_name) + (sub.module_expr sub mb.mb_expr) -let simplify_head_pat p k = - let rec simplify_head_pat p k = - match p.pat_desc with - | Tpat_alias (p,_,_) -> simplify_head_pat p k - | Tpat_var (_,_) -> omega :: k - | Tpat_or (p1,p2,_) -> simplify_head_pat p1 (simplify_head_pat p2 k) - | _ -> p :: k - in simplify_head_pat p k +let type_parameter sub (ct, v) = (sub.typ sub ct, v) -let rec simplified_first_col = function - | [] -> [] - | [] :: _ -> assert false (* the rows are non-empty! *) - | (p::_) :: rows -> - simplify_head_pat p (simplified_first_col rows) +let type_declaration sub decl = + let loc = sub.location sub decl.typ_loc in + let attrs = sub.attributes sub decl.typ_attributes in + Type.mk ~loc ~attrs + ~params:(List.map (type_parameter sub) decl.typ_params) + ~cstrs:( + List.map + (fun (ct1, ct2, loc) -> + (sub.typ sub ct1, sub.typ sub ct2, sub.location sub loc)) + decl.typ_cstrs) + ~kind:(sub.type_kind sub decl.typ_kind) + ~priv:decl.typ_private + ?manifest:(map_opt (sub.typ sub) decl.typ_manifest) + (map_loc sub decl.typ_name) -(* Given the simplified first column of a matrix, this function first looks for - a "discriminating" pattern on that column (i.e. a non-omega one) and then - check that every other head pattern in the column is coherent with that one. -*) -let all_coherent column = - let coherent_heads hp1 hp2 = - match hp1.pat_desc, hp2.pat_desc with - | (Tpat_var _ | Tpat_alias _ | Tpat_or _), _ - | _, (Tpat_var _ | Tpat_alias _ | Tpat_or _) -> - assert false - | Tpat_construct (_, c, _), Tpat_construct (_, c', _) -> - c.cstr_consts = c'.cstr_consts - && c.cstr_nonconsts = c'.cstr_nonconsts - | Tpat_constant c1, Tpat_constant c2 -> begin - match c1, c2 with - | Const_char _, Const_char _ - | Const_int _, Const_int _ - | Const_int32 _, Const_int32 _ - | Const_int64 _, Const_int64 _ - | Const_nativeint _, Const_nativeint _ - | Const_float _, Const_float _ - | Const_string _, Const_string _ -> true - | ( Const_char _ - | Const_int _ - | Const_int32 _ - | Const_int64 _ - | Const_nativeint _ - | Const_float _ - | Const_string _), _ -> false - end - | Tpat_tuple l1, Tpat_tuple l2 -> List.length l1 = List.length l2 - | Tpat_record ((_, lbl1, _) :: _, _), Tpat_record ((_, lbl2, _) :: _, _) -> - Array.length lbl1.lbl_all = Array.length lbl2.lbl_all - | Tpat_any, _ - | _, Tpat_any - | Tpat_record ([], _), Tpat_record (_, _) - | Tpat_record (_, _), Tpat_record ([], _) - | Tpat_variant _, Tpat_variant _ - | Tpat_array _, Tpat_array _ - | Tpat_lazy _, Tpat_lazy _ -> true - | _, _ -> false - in - match - List.find (fun head_pat -> - match head_pat.pat_desc with - | Tpat_var _ | Tpat_alias _ | Tpat_or _ -> assert false - | Tpat_any -> false - | _ -> true - ) column - with - | exception Not_found -> - (* only omegas on the column: the column is coherent. *) - true - | discr_pat -> - List.for_all (coherent_heads discr_pat) column +let type_kind sub tk = match tk with + | Ttype_abstract -> Ptype_abstract + | Ttype_variant list -> + Ptype_variant (List.map (sub.constructor_declaration sub) list) + | Ttype_record list -> + Ptype_record (List.map (sub.label_declaration sub) list) + | Ttype_open -> Ptype_open -let first_column simplified_matrix = - List.map fst simplified_matrix +let constructor_arguments sub = function + | Cstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) + | Cstr_record l -> Pcstr_record (List.map (sub.label_declaration sub) l) -(***********************) -(* Compatibility check *) -(***********************) +let constructor_declaration sub cd = + let loc = sub.location sub cd.cd_loc in + let attrs = sub.attributes sub cd.cd_attributes in + Type.constructor ~loc ~attrs + ~args:(constructor_arguments sub cd.cd_args) + ?res:(map_opt (sub.typ sub) cd.cd_res) + (map_loc sub cd.cd_name) -(* Patterns p and q compatible means: - there exists value V that matches both, However.... +let label_declaration sub ld = + let loc = sub.location sub ld.ld_loc in + let attrs = sub.attributes sub ld.ld_attributes in + Type.field ~loc ~attrs + ~mut:ld.ld_mutable + (map_loc sub ld.ld_name) + (sub.typ sub ld.ld_type) - The case of extension types is dubious, as constructor rebind permits - that different constructors are the same (and are thus compatible). +let type_extension sub tyext = + let attrs = sub.attributes sub tyext.tyext_attributes in + Te.mk ~attrs + ~params:(List.map (type_parameter sub) tyext.tyext_params) + ~priv:tyext.tyext_private + (map_loc sub tyext.tyext_txt) + (List.map (sub.extension_constructor sub) tyext.tyext_constructors) - Compilation must take this into account, consider: +let extension_constructor sub ext = + let loc = sub.location sub ext.ext_loc in + let attrs = sub.attributes sub ext.ext_attributes in + Te.constructor ~loc ~attrs + (map_loc sub ext.ext_name) + (match ext.ext_kind with + | Text_decl (args, ret) -> + Pext_decl (constructor_arguments sub args, + map_opt (sub.typ sub) ret) + | Text_rebind (_p, lid) -> Pext_rebind (map_loc sub lid) + ) - type t = .. - type t += A|B - type t += C=A +let pattern sub pat = + let loc = sub.location sub pat.pat_loc in + (* todo: fix attributes on extras *) + let attrs = sub.attributes sub pat.pat_attributes in + let desc = + match pat with + { pat_extra=[Tpat_unpack, _, _attrs]; pat_desc = Tpat_var (_,name); _ } -> + Ppat_unpack name + | { pat_extra=[Tpat_type (_path, lid), _, _attrs]; _ } -> + Ppat_type (map_loc sub lid) + | { pat_extra= (Tpat_constraint ct, _, _attrs) :: rem; _ } -> + Ppat_constraint (sub.pat sub { pat with pat_extra=rem }, + sub.typ sub ct) + | _ -> + match pat.pat_desc with + Tpat_any -> Ppat_any + | Tpat_var (id, name) -> + begin + match (Ident.name id).[0] with + 'A'..'Z' -> + Ppat_unpack name + | _ -> + Ppat_var name + end - let f x y = match x,y with - | true,A -> '1' - | _,C -> '2' - | false,A -> '3' - | _,_ -> '_' + (* We transform (_ as x) in x if _ and x have the same location. + The compiler transforms (x:t) into (_ as x : t). + This avoids transforming a warning 27 into a 26. + *) + | Tpat_alias ({pat_desc = Tpat_any; pat_loc}, _id, name) + when pat_loc = pat.pat_loc -> + Ppat_var name - As C is bound to A the value of f false A is '2' (and not '3' as it would - be in the absence of rebinding). + | Tpat_alias (pat, _id, name) -> + Ppat_alias (sub.pat sub pat, name) + | Tpat_constant cst -> Ppat_constant (constant cst) + | Tpat_tuple list -> + Ppat_tuple (List.map (sub.pat sub) list) + | Tpat_construct (lid, _, args) -> + Ppat_construct (map_loc sub lid, + (match args with + [] -> None + | [arg] -> Some (sub.pat sub arg) + | args -> + Some + (Pat.tuple ~loc + (List.map (sub.pat sub) args) + ) + )) + | Tpat_variant (label, pato, _) -> + Ppat_variant (label, map_opt (sub.pat sub) pato) + | Tpat_record (list, closed) -> + Ppat_record (List.map (fun (lid, _, pat) -> + map_loc sub lid, sub.pat sub pat) list, closed) + | Tpat_array list -> Ppat_array (List.map (sub.pat sub) list) + | Tpat_or (p1, p2, _) -> Ppat_or (sub.pat sub p1, sub.pat sub p2) + | Tpat_lazy p -> Ppat_lazy (sub.pat sub p) + in + Pat.mk ~loc ~attrs desc - Not considering rebinding, patterns "false,A" and "_,C" are incompatible - and the compiler can swap the second and third clause, resulting in the - (more efficiently compiled) matching +let exp_extra sub (extra, loc, attrs) sexp = + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + let desc = + match extra with + Texp_coerce (cty1, cty2) -> + Pexp_coerce (sexp, + map_opt (sub.typ sub) cty1, + sub.typ sub cty2) + | Texp_constraint cty -> + Pexp_constraint (sexp, sub.typ sub cty) + | Texp_open (ovf, _path, lid, _) -> + Pexp_open (ovf, map_loc sub lid, sexp) + | Texp_poly cto -> Pexp_poly (sexp, map_opt (sub.typ sub) cto) + | Texp_newtype s -> Pexp_newtype (mkloc s loc, sexp) + in + Exp.mk ~loc ~attrs desc - match x,y with - | true,A -> '1' - | false,A -> '3' - | _,C -> '2' - | _,_ -> '_' +let cases sub l = List.map (sub.case sub) l - This is not correct: when C is bound to A, "f false A" returns '2' (not '3') +let case sub {c_lhs; c_guard; c_rhs} = + { + pc_lhs = sub.pat sub c_lhs; + pc_guard = map_opt (sub.expr sub) c_guard; + pc_rhs = sub.expr sub c_rhs; + } +let value_binding sub vb = + let loc = sub.location sub vb.vb_loc in + let attrs = sub.attributes sub vb.vb_attributes in + Vb.mk ~loc ~attrs + (sub.pat sub vb.vb_pat) + (sub.expr sub vb.vb_expr) - However, diagnostics do not take constructor rebinding into account. - Notice, that due to module abstraction constructor rebinding is hidden. +let expression sub exp = + let loc = sub.location sub exp.exp_loc in + let attrs = sub.attributes sub exp.exp_attributes in + let desc = + match exp.exp_desc with + Texp_ident (_path, lid, _) -> Pexp_ident (map_loc sub lid) + | Texp_constant cst -> Pexp_constant (constant cst) + | Texp_let (rec_flag, list, exp) -> + Pexp_let (rec_flag, + List.map (sub.value_binding sub) list, + sub.expr sub exp) - module X : sig type t = .. type t += A|B end = struct - type t = .. - type t += A - type t += B=A - end + (* Pexp_function can't have a label, so we split in 3 cases. *) + (* One case, no guard: It's a fun. *) + | Texp_function { arg_label; cases = [{c_lhs=p; c_guard=None; c_rhs=e}]; + _ } -> + Pexp_fun (arg_label, None, sub.pat sub p, sub.expr sub e) + (* No label: it's a function. *) + | Texp_function { arg_label = Nolabel; cases; _; } -> + Pexp_function (sub.cases sub cases) + (* Mix of both, we generate `fun ~label:$name$ -> match $name$ with ...` *) + | Texp_function { arg_label = Labelled s | Optional s as label; cases; + _ } -> + let name = fresh_name s exp.exp_env in + Pexp_fun (label, None, Pat.var ~loc {loc;txt = name }, + Exp.match_ ~loc (Exp.ident ~loc {loc;txt= Lident name}) + (sub.cases sub cases)) + | Texp_apply (exp, list) -> + Pexp_apply (sub.expr sub exp, + List.fold_right (fun (label, expo) list -> + match expo with + None -> list + | Some exp -> (label, sub.expr sub exp) :: list + ) list []) + | Texp_match (exp, cases, exn_cases, _) -> + let merged_cases = sub.cases sub cases + @ List.map + (fun c -> + let uc = sub.case sub c in + let pat = { uc.pc_lhs + with ppat_desc = Ppat_exception uc.pc_lhs } + in + { uc with pc_lhs = pat }) + exn_cases + in + Pexp_match (sub.expr sub exp, merged_cases) + | Texp_try (exp, cases) -> + Pexp_try (sub.expr sub exp, sub.cases sub cases) + | Texp_tuple list -> + Pexp_tuple (List.map (sub.expr sub) list) + | Texp_construct (lid, _, args) -> + Pexp_construct (map_loc sub lid, + (match args with + [] -> None + | [ arg ] -> Some (sub.expr sub arg) + | args -> + Some + (Exp.tuple ~loc (List.map (sub.expr sub) args)) + )) + | Texp_variant (label, expo) -> + Pexp_variant (label, map_opt (sub.expr sub) expo) + | Texp_record { fields; extended_expression; _ } -> + let list = Array.fold_left (fun l -> function + | _, Kept _ -> l + | _, Overridden (lid, exp) -> (lid, sub.expr sub exp) :: l) + [] fields + in + Pexp_record (list, map_opt (sub.expr sub) extended_expression) + | Texp_field (exp, lid, _label) -> + Pexp_field (sub.expr sub exp, map_loc sub lid) + | Texp_setfield (exp1, lid, _label, exp2) -> + Pexp_setfield (sub.expr sub exp1, map_loc sub lid, + sub.expr sub exp2) + | Texp_array list -> + Pexp_array (List.map (sub.expr sub) list) + | Texp_ifthenelse (exp1, exp2, expo) -> + Pexp_ifthenelse (sub.expr sub exp1, + sub.expr sub exp2, + map_opt (sub.expr sub) expo) + | Texp_sequence (exp1, exp2) -> + Pexp_sequence (sub.expr sub exp1, sub.expr sub exp2) + | Texp_while (exp1, exp2) -> + Pexp_while (sub.expr sub exp1, sub.expr sub exp2) + | Texp_for (_id, name, exp1, exp2, dir, exp3) -> + Pexp_for (name, + sub.expr sub exp1, sub.expr sub exp2, + dir, sub.expr sub exp3) + | Texp_send (exp, meth, _) -> + Pexp_send (sub.expr sub exp, match meth with + Tmeth_name name -> mkloc name loc) + | Texp_new _ + | Texp_instvar _ + | Texp_setinstvar _ + | Texp_override _ -> + assert false + | Texp_letmodule (_id, name, mexpr, exp) -> + Pexp_letmodule (name, sub.module_expr sub mexpr, + sub.expr sub exp) + | Texp_letexception (ext, exp) -> + Pexp_letexception (sub.extension_constructor sub ext, + sub.expr sub exp) + | Texp_assert exp -> Pexp_assert (sub.expr sub exp) + | Texp_lazy exp -> Pexp_lazy (sub.expr sub exp) + | Texp_object () -> + assert false + | Texp_pack (mexpr) -> + Pexp_pack (sub.module_expr sub mexpr) + | Texp_unreachable -> + Pexp_unreachable + | Texp_extension_constructor (lid, _) -> + Pexp_extension ({ txt = "ocaml.extension_constructor"; loc }, + PStr [ Str.eval ~loc + (Exp.construct ~loc (map_loc sub lid) None) + ]) + in + List.fold_right (exp_extra sub) exp.exp_extra + (Exp.mk ~loc ~attrs desc) - open X +let package_type sub pack = + (map_loc sub pack.pack_txt, + List.map (fun (s, ct) -> + (s, sub.typ sub ct)) pack.pack_fields) - let f x = match x with - | A -> '1' - | B -> '2' - | _ -> '_' +let module_type_declaration sub mtd = + let loc = sub.location sub mtd.mtd_loc in + let attrs = sub.attributes sub mtd.mtd_attributes in + Mtd.mk ~loc ~attrs + ?typ:(map_opt (sub.module_type sub) mtd.mtd_type) + (map_loc sub mtd.mtd_name) - The second clause above will NOT (and cannot) be flagged as useless. +let signature sub sg = + List.map (sub.signature_item sub) sg.sig_items - Finally, there are two compatibility fonction - compat p q ---> 'syntactic compatibility, used for diagnostics. - may_compat p q ---> a safe approximation of possible compat, - for compilation +let signature_item sub item = + let loc = sub.location sub item.sig_loc in + let desc = + match item.sig_desc with + Tsig_value v -> + Psig_value (sub.value_description sub v) + | Tsig_type (rec_flag, list) -> + Psig_type (rec_flag, List.map (sub.type_declaration sub) list) + | Tsig_typext tyext -> + Psig_typext (sub.type_extension sub tyext) + | Tsig_exception ext -> + Psig_exception (sub.extension_constructor sub ext) + | Tsig_module md -> + Psig_module (sub.module_declaration sub md) + | Tsig_recmodule list -> + Psig_recmodule (List.map (sub.module_declaration sub) list) + | Tsig_modtype mtd -> + Psig_modtype (sub.module_type_declaration sub mtd) + | Tsig_open od -> + Psig_open (sub.open_description sub od) + | Tsig_include incl -> + Psig_include (sub.include_description sub incl) + | Tsig_class () -> + Psig_class () + | Tsig_class_type list -> + Psig_class_type (List.map (sub.class_type_declaration sub) list) + | Tsig_attribute x -> + Psig_attribute x + in + Sig.mk ~loc desc -*) +let module_declaration sub md = + let loc = sub.location sub md.md_loc in + let attrs = sub.attributes sub md.md_attributes in + Md.mk ~loc ~attrs + (map_loc sub md.md_name) + (sub.module_type sub md.md_type) +let include_infos f sub incl = + let loc = sub.location sub incl.incl_loc in + let attrs = sub.attributes sub incl.incl_attributes in + Incl.mk ~loc ~attrs + (f sub incl.incl_mod) -let is_absent tag row = Btype.row_field tag !row = Rabsent +let include_declaration sub = include_infos sub.module_expr sub +let include_description sub = include_infos sub.module_type sub -let is_absent_pat p = match p.pat_desc with -| Tpat_variant (tag, _, row) -> is_absent tag row -| _ -> false +let class_infos f sub ci = + let loc = sub.location sub ci.ci_loc in + let attrs = sub.attributes sub ci.ci_attributes in + Ci.mk ~loc ~attrs + ~virt:ci.ci_virt + ~params:(List.map (type_parameter sub) ci.ci_params) + (map_loc sub ci.ci_id_name) + (f sub ci.ci_expr) -let const_compare x y = - match x,y with - | Const_float f1, Const_float f2 -> - compare (float_of_string f1) (float_of_string f2) - | Const_string (s1, _), Const_string (s2, _) -> - String.compare s1 s2 - | _, _ -> compare x y - -let records_args l1 l2 = - (* Invariant: fields are already sorted by Typecore.type_label_a_list *) - let rec combine r1 r2 l1 l2 = match l1,l2 with - | [],[] -> List.rev r1, List.rev r2 - | [],(_,_,p2)::rem2 -> combine (omega::r1) (p2::r2) [] rem2 - | (_,_,p1)::rem1,[] -> combine (p1::r1) (omega::r2) rem1 [] - | (_,lbl1,p1)::rem1, ( _,lbl2,p2)::rem2 -> - if lbl1.lbl_pos < lbl2.lbl_pos then - combine (p1::r1) (omega::r2) rem1 l2 - else if lbl1.lbl_pos > lbl2.lbl_pos then - combine (omega::r1) (p2::r2) l1 rem2 - else (* same label on both sides *) - combine (p1::r1) (p2::r2) rem1 rem2 in - combine [] [] l1 l2 +let class_type_declaration sub = class_infos sub.class_type sub +let module_type sub mty = + let loc = sub.location sub mty.mty_loc in + let attrs = sub.attributes sub mty.mty_attributes in + let desc = match mty.mty_desc with + Tmty_ident (_path, lid) -> Pmty_ident (map_loc sub lid) + | Tmty_alias (_path, lid) -> Pmty_alias (map_loc sub lid) + | Tmty_signature sg -> Pmty_signature (sub.signature sub sg) + | Tmty_functor (_id, name, mtype1, mtype2) -> + Pmty_functor (name, map_opt (sub.module_type sub) mtype1, + sub.module_type sub mtype2) + | Tmty_with (mtype, list) -> + Pmty_with (sub.module_type sub mtype, + List.map (sub.with_constraint sub) list) + | Tmty_typeof mexpr -> + Pmty_typeof (sub.module_expr sub mexpr) + in + Mty.mk ~loc ~attrs desc +let with_constraint sub (_path, lid, cstr) = + match cstr with + | Twith_type decl -> + Pwith_type (map_loc sub lid, sub.type_declaration sub decl) + | Twith_module (_path, lid2) -> + Pwith_module (map_loc sub lid, map_loc sub lid2) + | Twith_typesubst decl -> + Pwith_typesubst (map_loc sub lid, sub.type_declaration sub decl) + | Twith_modsubst (_path, lid2) -> + Pwith_modsubst (map_loc sub lid, map_loc sub lid2) -module Compat - (Constr:sig - val equal : - Types.constructor_description -> - Types.constructor_description -> - bool - end) = struct +let module_expr sub mexpr = + let loc = sub.location sub mexpr.mod_loc in + let attrs = sub.attributes sub mexpr.mod_attributes in + match mexpr.mod_desc with + Tmod_constraint (m, _, Tmodtype_implicit, _ ) -> + sub.module_expr sub m + | _ -> + let desc = match mexpr.mod_desc with + Tmod_ident (_p, lid) -> Pmod_ident (map_loc sub lid) + | Tmod_structure st -> Pmod_structure (sub.structure sub st) + | Tmod_functor (_id, name, mtype, mexpr) -> + Pmod_functor (name, Misc.may_map (sub.module_type sub) mtype, + sub.module_expr sub mexpr) + | Tmod_apply (mexp1, mexp2, _) -> + Pmod_apply (sub.module_expr sub mexp1, sub.module_expr sub mexp2) + | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) -> + Pmod_constraint (sub.module_expr sub mexpr, + sub.module_type sub mtype) + | Tmod_constraint (_mexpr, _, Tmodtype_implicit, _) -> + assert false + | Tmod_unpack (exp, _pack) -> + Pmod_unpack (sub.expr sub exp) + (* TODO , sub.package_type sub pack) *) + in + Mod.mk ~loc ~attrs desc - let rec compat p q = match p.pat_desc,q.pat_desc with -(* Variables match any value *) - | ((Tpat_any|Tpat_var _),_) - | (_,(Tpat_any|Tpat_var _)) -> true -(* Structural induction *) - | Tpat_alias (p,_,_),_ -> compat p q - | _,Tpat_alias (q,_,_) -> compat p q - | Tpat_or (p1,p2,_),_ -> - (compat p1 q || compat p2 q) - | _,Tpat_or (q1,q2,_) -> - (compat p q1 || compat p q2) -(* Constructors, with special case for extension *) - | Tpat_construct (_, c1,ps1), Tpat_construct (_, c2,ps2) -> - Constr.equal c1 c2 && compats ps1 ps2 -(* More standard stuff *) - | Tpat_variant(l1,op1, _), Tpat_variant(l2,op2,_) -> - l1=l2 && ocompat op1 op2 - | Tpat_constant c1, Tpat_constant c2 -> - const_compare c1 c2 = 0 - | Tpat_tuple ps, Tpat_tuple qs -> compats ps qs - | Tpat_lazy p, Tpat_lazy q -> compat p q - | Tpat_record (l1,_),Tpat_record (l2,_) -> - let ps,qs = records_args l1 l2 in - compats ps qs - | Tpat_array ps, Tpat_array qs -> - List.length ps = List.length qs && - compats ps qs - | _,_ -> false - and ocompat op oq = match op,oq with - | None,None -> true - | Some p,Some q -> compat p q - | (None,Some _)|(Some _,None) -> false - and compats ps qs = match ps,qs with - | [], [] -> true - | p::ps, q::qs -> compat p q && compats ps qs - | _,_ -> false +let class_type sub ct = + let loc = sub.location sub ct.cltyp_loc in + let attrs = sub.attributes sub ct.cltyp_attributes in + let desc = match ct.cltyp_desc with + Tcty_signature csg -> Pcty_signature (sub.class_signature sub csg) + | Tcty_constr (_path, lid, list) -> + Pcty_constr (map_loc sub lid, List.map (sub.typ sub) list) + | Tcty_arrow (label, ct, cl) -> + Pcty_arrow (label, sub.typ sub ct, sub.class_type sub cl) + | Tcty_open (ovf, _p, lid, _env, e) -> + Pcty_open (ovf, lid, sub.class_type sub e) + in + Cty.mk ~loc ~attrs desc -end +let class_signature sub cs = + { + pcsig_self = sub.typ sub cs.csig_self; + pcsig_fields = List.map (sub.class_type_field sub) cs.csig_fields; + } -module SyntacticCompat = - Compat - (struct - let equal c1 c2 = Types.equal_tag c1.cstr_tag c2.cstr_tag - end) +let class_type_field sub ctf = + let loc = sub.location sub ctf.ctf_loc in + let attrs = sub.attributes sub ctf.ctf_attributes in + let desc = match ctf.ctf_desc with + Tctf_inherit ct -> Pctf_inherit (sub.class_type sub ct) + | Tctf_val (s, mut, virt, ct) -> + Pctf_val (mkloc s loc, mut, virt, sub.typ sub ct) + | Tctf_method (s, priv, virt, ct) -> + Pctf_method (mkloc s loc, priv, virt, sub.typ sub ct) + | Tctf_constraint (ct1, ct2) -> + Pctf_constraint (sub.typ sub ct1, sub.typ sub ct2) + | Tctf_attribute x -> Pctf_attribute x + in + Ctf.mk ~loc ~attrs desc -let compat = SyntacticCompat.compat -and compats = SyntacticCompat.compats +let core_type sub ct = + let loc = sub.location sub ct.ctyp_loc in + let attrs = sub.attributes sub ct.ctyp_attributes in + let desc = match ct.ctyp_desc with + Ttyp_any -> Ptyp_any + | Ttyp_var s -> Ptyp_var s + | Ttyp_arrow (label, ct1, ct2) -> + Ptyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2) + | Ttyp_tuple list -> Ptyp_tuple (List.map (sub.typ sub) list) + | Ttyp_constr (_path, lid, list) -> + Ptyp_constr (map_loc sub lid, + List.map (sub.typ sub) list) + | Ttyp_object (list, o) -> + Ptyp_object + (List.map (sub.object_field sub) list, o) + | Ttyp_class (_path, lid, list) -> + Ptyp_class (map_loc sub lid, List.map (sub.typ sub) list) + | Ttyp_alias (ct, s) -> + Ptyp_alias (sub.typ sub ct, s) + | Ttyp_variant (list, bool, labels) -> + Ptyp_variant (List.map (sub.row_field sub) list, bool, labels) + | Ttyp_poly (list, ct) -> + let list = List.map (fun v -> mkloc v loc) list in + Ptyp_poly (list, sub.typ sub ct) + | Ttyp_package pack -> Ptyp_package (sub.package_type sub pack) + in + Typ.mk ~loc ~attrs desc -(* Due to (potential) rebinding, two extension constructors - of the same arity type may equal *) -exception Empty (* Empty pattern *) +let row_field sub rf = + match rf with + Ttag (label, attrs, bool, list) -> + Rtag (label, sub.attributes sub attrs, bool, List.map (sub.typ sub) list) + | Tinherit ct -> Rinherit (sub.typ sub ct) -(****************************************) -(* Utilities for retrieving type paths *) -(****************************************) +let object_field sub ofield = + match ofield with + OTtag (label, attrs, ct) -> + Otag (label, sub.attributes sub attrs, sub.typ sub ct) + | OTinherit ct -> Oinherit (sub.typ sub ct) -(* May need a clean copy, cf. PR#4745 *) -let clean_copy ty = - if ty.level = Btype.generic_level then ty - else Subst.type_expr Subst.identity ty -let get_type_path ty tenv = - let ty = Ctype.repr (Ctype.expand_head tenv (clean_copy ty)) in - match ty.desc with - | Tconstr (path,_,_) -> path - | _ -> fatal_error "Parmatch.get_type_path" -(*************************************) -(* Values as patterns pretty printer *) -(*************************************) +let location _sub l = l -let print_res_pat: (Typedtree.pattern -> string) ref = - ref (fun _ -> assert false) +let default_mapper = + { + attribute = attribute ; + attributes = attributes ; + structure = structure; + structure_item = structure_item; + module_expr = module_expr; + signature = signature; + signature_item = signature_item; + module_type = module_type; + with_constraint = with_constraint; + class_type = class_type; + class_type_field = class_type_field; + class_signature = class_signature; + class_type_declaration = class_type_declaration; + type_declaration = type_declaration; + type_kind = type_kind; + typ = core_type; + type_extension = type_extension; + extension_constructor = extension_constructor; + value_description = value_description; + pat = pattern; + expr = expression; + module_declaration = module_declaration; + module_type_declaration = module_type_declaration; + module_binding = module_binding; + package_type = package_type ; + open_description = open_description; + include_description = include_description; + include_declaration = include_declaration; + value_binding = value_binding; + constructor_declaration = constructor_declaration; + label_declaration = label_declaration; + cases = cases; + case = case; + location = location; + row_field = row_field ; + object_field = object_field ; + } -open Format -;; +let untype_structure ?(mapper=default_mapper) structure = + mapper.structure mapper structure -let is_cons = function -| {cstr_name = "::"} -> true -| _ -> false +let untype_signature ?(mapper=default_mapper) signature = + mapper.signature mapper signature -let pretty_const c = match c with -| Const_int i -> Printf.sprintf "%d" i -| Const_char i -> Printf.sprintf "%C" (Char.unsafe_chr i) -| Const_string (s, _) -> Printf.sprintf "%S" s -| Const_float f -> Printf.sprintf "%s" f -| Const_int32 i -> Printf.sprintf "%ldl" i -| Const_int64 i -> Printf.sprintf "%LdL" i -| Const_nativeint i -> Printf.sprintf "%ndn" i +end +module Parmatch : sig +#1 "parmatch.mli" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) -let rec pretty_val ppf v = - match v.pat_extra with - (cstr, _loc, _attrs) :: rem -> - begin match cstr with - | Tpat_unpack -> - fprintf ppf "@[(module %a)@]" pretty_val { v with pat_extra = rem } - | Tpat_constraint _ -> - fprintf ppf "@[(%a : _)@]" pretty_val { v with pat_extra = rem } - | Tpat_type _ -> - fprintf ppf "@[(# %a)@]" pretty_val { v with pat_extra = rem } - | Tpat_open _ -> - fprintf ppf "@[(# %a)@]" pretty_val { v with pat_extra = rem } - end - | [] -> - match v.pat_desc with - | Tpat_any -> fprintf ppf "_" - | Tpat_var (x,_) -> fprintf ppf "%s" (Ident.name x) - | Tpat_constant c -> fprintf ppf "%s" (pretty_const c) - | Tpat_tuple vs -> - fprintf ppf "@[(%a)@]" (pretty_vals ",") vs - | Tpat_construct (_, cstr, []) -> - fprintf ppf "%s" cstr.cstr_name - | Tpat_construct (_, cstr, [w]) -> - fprintf ppf "@[<2>%s(%a)@]" cstr.cstr_name pretty_arg w - | Tpat_construct (_, cstr, vs) -> - let name = cstr.cstr_name in - begin match (name, vs) with - ("::", [v1;v2]) -> - fprintf ppf "@[%a::@,%a@]" pretty_car v1 pretty_cdr v2 - | _ -> - fprintf ppf "@[<2>%s@ @[(%a)@]@]" name (pretty_vals ",") vs - end - | Tpat_variant (l, None, _) -> - fprintf ppf "#%s" l - | Tpat_variant (l, Some w, _) -> - fprintf ppf "@[<2>#%s(%a)@]" l pretty_arg w - | Tpat_record (lvs,_) -> - let filtered_lvs = Ext_list.filter lvs - (function - | (_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *) - | _ -> true) in - begin match filtered_lvs with - | [] -> fprintf ppf "_" - | (_, _lbl, _) :: _q -> - let elision_mark _ = () in - fprintf ppf "@[{%a%t}@]" - pretty_lvals filtered_lvs elision_mark - end - | Tpat_array vs -> - fprintf ppf "@[[%a]@]" (pretty_vals ",") vs - | Tpat_lazy v -> - fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v - | Tpat_alias (v, x,_) -> - fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x - | Tpat_or (v,w,_) -> - fprintf ppf "@[%a | @,%a@]" pretty_or v pretty_or w +(* Detection of partial matches and unused match cases. *) +open Asttypes +open Typedtree +open Types -and pretty_car ppf v = match v.pat_desc with -| Tpat_construct (_,cstr, [_ ; _]) - when is_cons cstr -> - fprintf ppf "(%a)" pretty_val v -| _ -> pretty_val ppf v +val pretty_const : constant -> string +val top_pretty : Format.formatter -> pattern -> unit +val pretty_pat : pattern -> unit +val pretty_line : pattern list -> unit +val pretty_matrix : pattern list list -> unit -and pretty_cdr ppf v = match v.pat_desc with -| Tpat_construct (_,cstr, [v1 ; v2]) - when is_cons cstr -> - fprintf ppf "%a::@,%a" pretty_car v1 pretty_cdr v2 -| _ -> pretty_val ppf v +val print_res_pat: (Typedtree.pattern -> string) ref -and pretty_arg ppf v = match v.pat_desc with -| Tpat_construct (_,_,_::_) -| Tpat_variant (_, Some _, _) -> fprintf ppf "(%a)" pretty_val v -| _ -> pretty_val ppf v +val omega : pattern +val omegas : int -> pattern list +val omega_list : 'a list -> pattern list +val normalize_pat : pattern -> pattern +val all_record_args : + (Longident.t loc * label_description * pattern) list -> + (Longident.t loc * label_description * pattern) list +val const_compare : constant -> constant -> int -and pretty_or ppf v = match v.pat_desc with -| Tpat_or (v,w,_) -> - fprintf ppf "%a | @,%a" pretty_or v pretty_or w -| _ -> pretty_val ppf v +val le_pat : pattern -> pattern -> bool +val le_pats : pattern list -> pattern list -> bool -and pretty_vals sep ppf = function - | [] -> () - | [v] -> pretty_val ppf v - | v::vs -> - fprintf ppf "%a%s@ %a" pretty_val v sep (pretty_vals sep) vs +(* Exported compatibility functor, abstracted over constructor equality *) +module [@warning "-67"] Compat : + functor + (Constr: sig + val equal : + Types.constructor_description -> + Types.constructor_description -> + bool + end) -> sig + val compat : pattern -> pattern -> bool + val compats : pattern list -> pattern list -> bool + end -and pretty_lvals ppf = function - | [] -> () - | [_,lbl,v] -> - fprintf ppf "%s: %a" lbl.lbl_name pretty_val v - | (_, lbl,v)::rest -> - fprintf ppf "%s: %a,@ %a" - lbl.lbl_name pretty_val v pretty_lvals rest +exception Empty +val lub : pattern -> pattern -> pattern +val lubs : pattern list -> pattern list -> pattern list -let top_pretty ppf v = - fprintf ppf "@[%a@]@?" pretty_val v +val get_mins : ('a -> 'a -> bool) -> 'a list -> 'a list +(* Those two functions recombine one pattern and its arguments: + For instance: + (_,_)::p1::p2::rem -> (p1, p2)::rem + The second one will replace mutable arguments by '_' +*) +val set_args : pattern -> pattern list -> pattern list +val set_args_erase_mutable : pattern -> pattern list -> pattern list -let pretty_pat p = - top_pretty Format.str_formatter p ; - prerr_string (Format.flush_str_formatter ()) +val pat_of_constr : pattern -> constructor_description -> pattern +val complete_constrs : + pattern -> constructor_tag list -> constructor_description list +val ppat_of_type : + Env.t -> type_expr -> + Parsetree.pattern * + (string, constructor_description) Hashtbl.t * + (string, label_description) Hashtbl.t -type matrix = pattern list list +val pressure_variants: Env.t -> pattern list -> unit +val check_partial_gadt: + ((string, constructor_description) Hashtbl.t -> + (string, label_description) Hashtbl.t -> + Parsetree.pattern -> pattern option) -> + Location.t -> case list -> partial +val check_unused: + (bool -> + (string, constructor_description) Hashtbl.t -> + (string, label_description) Hashtbl.t -> + Parsetree.pattern -> pattern option) -> + case list -> unit -let pretty_line ps = - List.iter - (fun p -> - top_pretty Format.str_formatter p ; - prerr_string " <" ; - prerr_string (Format.flush_str_formatter ()) ; - prerr_string ">") - ps +(* Irrefutability tests *) +val irrefutable : pattern -> bool -let pretty_matrix (pss : matrix) = - prerr_endline "begin matrix" ; - List.iter - (fun ps -> - pretty_line ps ; - prerr_endline "") - pss ; - prerr_endline "end matrix" +(** An inactive pattern is a pattern, matching against which can be duplicated, erased or + delayed without change in observable behavior of the program. Patterns containing + (lazy _) subpatterns or reads of mutable fields are active. *) +val inactive : partial:partial -> pattern -> bool +(* Ambiguous bindings *) +val check_ambiguous_bindings : case list -> unit -(****************************) -(* Utilities for matching *) -(****************************) +(* The tag used for open polymorphic variant types *) +val some_other_tag : label -(* Check top matching *) -let simple_match p1 p2 = - match p1.pat_desc, p2.pat_desc with - | Tpat_construct(_, c1, _), Tpat_construct(_, c2, _) -> - Types.equal_tag c1.cstr_tag c2.cstr_tag - | Tpat_variant(l1, _, _), Tpat_variant(l2, _, _) -> - l1 = l2 - | Tpat_constant(c1), Tpat_constant(c2) -> const_compare c1 c2 = 0 - | Tpat_lazy _, Tpat_lazy _ -> true - | Tpat_record _ , Tpat_record _ -> true - | Tpat_tuple p1s, Tpat_tuple p2s - | Tpat_array p1s, Tpat_array p2s -> List.length p1s = List.length p2s - | _, (Tpat_any | Tpat_var(_)) -> true - | _, _ -> false +end = struct +#1 "parmatch.ml" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) +(* Detection of partial matches and unused match cases. *) +open Misc +open Asttypes +open Types +open Typedtree +(*************************************) +(* Utilities for building patterns *) +(*************************************) -(* extract record fields as a whole *) -let record_arg p = match p.pat_desc with -| Tpat_any -> [] -| Tpat_record (args,_) -> args -| _ -> fatal_error "Parmatch.as_record" +let make_pat desc ty tenv = + {pat_desc = desc; pat_loc = Location.none; pat_extra = []; + pat_type = ty ; pat_env = tenv; + pat_attributes = []; + } +let omega = make_pat Tpat_any Ctype.none Env.empty -(* Raise Not_found when pos is not present in arg *) +let extra_pat = + make_pat + (Tpat_var (Ident.create "+", mknoloc "+")) + Ctype.none Env.empty + +let rec omegas i = + if i <= 0 then [] else omega :: omegas (i-1) + +let omega_list l = List.map (fun _ -> omega) l + +let zero = make_pat (Tpat_constant (Const_int 0)) Ctype.none Env.empty + +(*******************) +(* Coherence check *) +(*******************) + +(* For some of the operations we do in this module, we would like (because it + simplifies matters) to assume that patterns appearing on a given column in a + pattern matrix are /coherent/ (think "of the same type"). + Unfortunately that is not always true. + + Consider the following (well-typed) example: + {[ + type _ t = S : string t | U : unit t + + let f (type a) (t1 : a t) (t2 : a t) (a : a) = + match t1, t2, a with + | U, _, () -> () + | _, S, "" -> () + ]} + + Clearly the 3rd column contains incoherent patterns. + + On the example above, most of the algorithms will explore the pattern matrix + as illustrated by the following tree: + + {v + S + -------> | "" | + U | S, "" | __/ | () | + --------> | _, () | \ ¬ S + | U, _, () | __/ -------> | () | + | _, S, "" | \ + ---------> | S, "" | ----------> | "" | + ¬ U S + v} + + where following an edge labelled by a pattern P means "assuming the value I + am matching on is filtered by [P] on the column I am currently looking at, + then the following submatrix is still reachable". + + Notice that at any point of that tree, if the first column of a matrix is + incoherent, then the branch leading to it can only be taken if the scrutinee + is ill-typed. + In the example above the only case where we have a matrix with an incoherent + first column is when we consider [t1, t2, a] to be [U, S, ...]. However such + a value would be ill-typed, so we can never actually get there. + + Checking the first column at each step of the recursion and making the + concious decision of "aborting" the algorithm whenever the first column + becomes incoherent, allows us to retain the initial assumption in later + stages of the algorithms. + + --- + + N.B. two patterns can be considered coherent even though they might not be of + the same type. + + That's in part because we only care about the "head" of patterns and leave + checking coherence of subpatterns for the next steps of the algorithm: + ('a', 'b') and (1, ()) will be deemed coherent because they are both a tuples + of arity 2 (we'll notice at a later stage the incoherence of 'a' and 1). + + But also because it can be hard/costly to determine exactly whether two + patterns are of the same type or not (eg. in the example above with _ and S, + but see also the module [Coherence_illustration] in + testsuite/tests/basic-more/robustmatch.ml). + + For the moment our weak, loosely-syntactic, coherence check seems to be + enough and we leave it to each user to consider (and document!) what happens + when an "incoherence" is not detected by this check. +*) + + +let simplify_head_pat p k = + let rec simplify_head_pat p k = + match p.pat_desc with + | Tpat_alias (p,_,_) -> simplify_head_pat p k + | Tpat_var (_,_) -> omega :: k + | Tpat_or (p1,p2,_) -> simplify_head_pat p1 (simplify_head_pat p2 k) + | _ -> p :: k + in simplify_head_pat p k + +let rec simplified_first_col = function + | [] -> [] + | [] :: _ -> assert false (* the rows are non-empty! *) + | (p::_) :: rows -> + simplify_head_pat p (simplified_first_col rows) + +(* Given the simplified first column of a matrix, this function first looks for + a "discriminating" pattern on that column (i.e. a non-omega one) and then + check that every other head pattern in the column is coherent with that one. +*) +let all_coherent column = + let coherent_heads hp1 hp2 = + match hp1.pat_desc, hp2.pat_desc with + | (Tpat_var _ | Tpat_alias _ | Tpat_or _), _ + | _, (Tpat_var _ | Tpat_alias _ | Tpat_or _) -> + assert false + | Tpat_construct (_, c, _), Tpat_construct (_, c', _) -> + c.cstr_consts = c'.cstr_consts + && c.cstr_nonconsts = c'.cstr_nonconsts + | Tpat_constant c1, Tpat_constant c2 -> begin + match c1, c2 with + | Const_char _, Const_char _ + | Const_int _, Const_int _ + | Const_int32 _, Const_int32 _ + | Const_int64 _, Const_int64 _ + | Const_nativeint _, Const_nativeint _ + | Const_float _, Const_float _ + | Const_string _, Const_string _ -> true + | ( Const_char _ + | Const_int _ + | Const_int32 _ + | Const_int64 _ + | Const_nativeint _ + | Const_float _ + | Const_string _), _ -> false + end + | Tpat_tuple l1, Tpat_tuple l2 -> List.length l1 = List.length l2 + | Tpat_record ((_, lbl1, _) :: _, _), Tpat_record ((_, lbl2, _) :: _, _) -> + Array.length lbl1.lbl_all = Array.length lbl2.lbl_all + | Tpat_any, _ + | _, Tpat_any + | Tpat_record ([], _), Tpat_record (_, _) + | Tpat_record (_, _), Tpat_record ([], _) + | Tpat_variant _, Tpat_variant _ + | Tpat_array _, Tpat_array _ + | Tpat_lazy _, Tpat_lazy _ -> true + | _, _ -> false + in + match + List.find (fun head_pat -> + match head_pat.pat_desc with + | Tpat_var _ | Tpat_alias _ | Tpat_or _ -> assert false + | Tpat_any -> false + | _ -> true + ) column + with + | exception Not_found -> + (* only omegas on the column: the column is coherent. *) + true + | discr_pat -> + List.for_all (coherent_heads discr_pat) column + +let first_column simplified_matrix = + List.map fst simplified_matrix + +(***********************) +(* Compatibility check *) +(***********************) + +(* Patterns p and q compatible means: + there exists value V that matches both, However.... + + The case of extension types is dubious, as constructor rebind permits + that different constructors are the same (and are thus compatible). + + Compilation must take this into account, consider: + + type t = .. + type t += A|B + type t += C=A + + let f x y = match x,y with + | true,A -> '1' + | _,C -> '2' + | false,A -> '3' + | _,_ -> '_' + + As C is bound to A the value of f false A is '2' (and not '3' as it would + be in the absence of rebinding). + + Not considering rebinding, patterns "false,A" and "_,C" are incompatible + and the compiler can swap the second and third clause, resulting in the + (more efficiently compiled) matching + + match x,y with + | true,A -> '1' + | false,A -> '3' + | _,C -> '2' + | _,_ -> '_' + + This is not correct: when C is bound to A, "f false A" returns '2' (not '3') + + + However, diagnostics do not take constructor rebinding into account. + Notice, that due to module abstraction constructor rebinding is hidden. + + module X : sig type t = .. type t += A|B end = struct + type t = .. + type t += A + type t += B=A + end + + open X + + let f x = match x with + | A -> '1' + | B -> '2' + | _ -> '_' + + The second clause above will NOT (and cannot) be flagged as useless. + + Finally, there are two compatibility fonction + compat p q ---> 'syntactic compatibility, used for diagnostics. + may_compat p q ---> a safe approximation of possible compat, + for compilation + +*) + + +let is_absent tag row = Btype.row_field tag !row = Rabsent + +let is_absent_pat p = match p.pat_desc with +| Tpat_variant (tag, _, row) -> is_absent tag row +| _ -> false + +let const_compare x y = + match x,y with + | Const_float f1, Const_float f2 -> + compare (float_of_string f1) (float_of_string f2) + | Const_string (s1, _), Const_string (s2, _) -> + String.compare s1 s2 + | _, _ -> compare x y + +let records_args l1 l2 = + (* Invariant: fields are already sorted by Typecore.type_label_a_list *) + let rec combine r1 r2 l1 l2 = match l1,l2 with + | [],[] -> List.rev r1, List.rev r2 + | [],(_,_,p2)::rem2 -> combine (omega::r1) (p2::r2) [] rem2 + | (_,_,p1)::rem1,[] -> combine (p1::r1) (omega::r2) rem1 [] + | (_,lbl1,p1)::rem1, ( _,lbl2,p2)::rem2 -> + if lbl1.lbl_pos < lbl2.lbl_pos then + combine (p1::r1) (omega::r2) rem1 l2 + else if lbl1.lbl_pos > lbl2.lbl_pos then + combine (omega::r1) (p2::r2) l1 rem2 + else (* same label on both sides *) + combine (p1::r1) (p2::r2) rem1 rem2 in + combine [] [] l1 l2 + + + +module Compat + (Constr:sig + val equal : + Types.constructor_description -> + Types.constructor_description -> + bool + end) = struct + + let rec compat p q = match p.pat_desc,q.pat_desc with +(* Variables match any value *) + | ((Tpat_any|Tpat_var _),_) + | (_,(Tpat_any|Tpat_var _)) -> true +(* Structural induction *) + | Tpat_alias (p,_,_),_ -> compat p q + | _,Tpat_alias (q,_,_) -> compat p q + | Tpat_or (p1,p2,_),_ -> + (compat p1 q || compat p2 q) + | _,Tpat_or (q1,q2,_) -> + (compat p q1 || compat p q2) +(* Constructors, with special case for extension *) + | Tpat_construct (_, c1,ps1), Tpat_construct (_, c2,ps2) -> + Constr.equal c1 c2 && compats ps1 ps2 +(* More standard stuff *) + | Tpat_variant(l1,op1, _), Tpat_variant(l2,op2,_) -> + l1=l2 && ocompat op1 op2 + | Tpat_constant c1, Tpat_constant c2 -> + const_compare c1 c2 = 0 + | Tpat_tuple ps, Tpat_tuple qs -> compats ps qs + | Tpat_lazy p, Tpat_lazy q -> compat p q + | Tpat_record (l1,_),Tpat_record (l2,_) -> + let ps,qs = records_args l1 l2 in + compats ps qs + | Tpat_array ps, Tpat_array qs -> + List.length ps = List.length qs && + compats ps qs + | _,_ -> false + + and ocompat op oq = match op,oq with + | None,None -> true + | Some p,Some q -> compat p q + | (None,Some _)|(Some _,None) -> false + + and compats ps qs = match ps,qs with + | [], [] -> true + | p::ps, q::qs -> compat p q && compats ps qs + | _,_ -> false + +end + +module SyntacticCompat = + Compat + (struct + let equal c1 c2 = Types.equal_tag c1.cstr_tag c2.cstr_tag + end) + +let compat = SyntacticCompat.compat +and compats = SyntacticCompat.compats + +(* Due to (potential) rebinding, two extension constructors + of the same arity type may equal *) + +exception Empty (* Empty pattern *) + +(****************************************) +(* Utilities for retrieving type paths *) +(****************************************) + +(* May need a clean copy, cf. PR#4745 *) +let clean_copy ty = + if ty.level = Btype.generic_level then ty + else Subst.type_expr Subst.identity ty + +let get_type_path ty tenv = + let ty = Ctype.repr (Ctype.expand_head tenv (clean_copy ty)) in + match ty.desc with + | Tconstr (path,_,_) -> path + | _ -> fatal_error "Parmatch.get_type_path" + +(*************************************) +(* Values as patterns pretty printer *) +(*************************************) + +let print_res_pat: (Typedtree.pattern -> string) ref = + ref (fun _ -> assert false) + +open Format +;; + +let is_cons = function +| {cstr_name = "::"} -> true +| _ -> false + +let pretty_const c = match c with +| Const_int i -> Printf.sprintf "%d" i +| Const_char i -> Printf.sprintf "%s" (Pprintast.string_of_int_as_char i) +| Const_string (s, _) -> Printf.sprintf "%S" s +| Const_float f -> Printf.sprintf "%s" f +| Const_int32 i -> Printf.sprintf "%ldl" i +| Const_int64 i -> Printf.sprintf "%LdL" i +| Const_nativeint i -> Printf.sprintf "%ndn" i + +let rec pretty_val ppf v = + match v.pat_extra with + (cstr, _loc, _attrs) :: rem -> + begin match cstr with + | Tpat_unpack -> + fprintf ppf "@[(module %a)@]" pretty_val { v with pat_extra = rem } + | Tpat_constraint _ -> + fprintf ppf "@[(%a : _)@]" pretty_val { v with pat_extra = rem } + | Tpat_type _ -> + fprintf ppf "@[(# %a)@]" pretty_val { v with pat_extra = rem } + | Tpat_open _ -> + fprintf ppf "@[(# %a)@]" pretty_val { v with pat_extra = rem } + end + | [] -> + match v.pat_desc with + | Tpat_any -> fprintf ppf "_" + | Tpat_var (x,_) -> fprintf ppf "%s" (Ident.name x) + | Tpat_constant c -> fprintf ppf "%s" (pretty_const c) + | Tpat_tuple vs -> + fprintf ppf "@[(%a)@]" (pretty_vals ",") vs + | Tpat_construct (_, cstr, []) -> + fprintf ppf "%s" cstr.cstr_name + | Tpat_construct (_, cstr, [w]) -> + fprintf ppf "@[<2>%s(%a)@]" cstr.cstr_name pretty_arg w + | Tpat_construct (_, cstr, vs) -> + let name = cstr.cstr_name in + begin match (name, vs) with + ("::", [v1;v2]) -> + fprintf ppf "@[%a::@,%a@]" pretty_car v1 pretty_cdr v2 + | _ -> + fprintf ppf "@[<2>%s@ @[(%a)@]@]" name (pretty_vals ",") vs + end + | Tpat_variant (l, None, _) -> + fprintf ppf "#%s" l + | Tpat_variant (l, Some w, _) -> + fprintf ppf "@[<2>#%s(%a)@]" l pretty_arg w + | Tpat_record (lvs,_) -> + let filtered_lvs = Ext_list.filter lvs + (function + | (_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *) + | _ -> true) in + begin match filtered_lvs with + | [] -> fprintf ppf "_" + | (_, _lbl, _) :: _q -> + let elision_mark _ = () in + fprintf ppf "@[{%a%t}@]" + pretty_lvals filtered_lvs elision_mark + end + | Tpat_array vs -> + fprintf ppf "@[[%a]@]" (pretty_vals ",") vs + | Tpat_lazy v -> + fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v + | Tpat_alias (v, x,_) -> + fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x + | Tpat_or (v,w,_) -> + fprintf ppf "@[%a | @,%a@]" pretty_or v pretty_or w + +and pretty_car ppf v = match v.pat_desc with +| Tpat_construct (_,cstr, [_ ; _]) + when is_cons cstr -> + fprintf ppf "(%a)" pretty_val v +| _ -> pretty_val ppf v + +and pretty_cdr ppf v = match v.pat_desc with +| Tpat_construct (_,cstr, [v1 ; v2]) + when is_cons cstr -> + fprintf ppf "%a::@,%a" pretty_car v1 pretty_cdr v2 +| _ -> pretty_val ppf v + +and pretty_arg ppf v = match v.pat_desc with +| Tpat_construct (_,_,_::_) +| Tpat_variant (_, Some _, _) -> fprintf ppf "(%a)" pretty_val v +| _ -> pretty_val ppf v + +and pretty_or ppf v = match v.pat_desc with +| Tpat_or (v,w,_) -> + fprintf ppf "%a | @,%a" pretty_or v pretty_or w +| _ -> pretty_val ppf v + +and pretty_vals sep ppf = function + | [] -> () + | [v] -> pretty_val ppf v + | v::vs -> + fprintf ppf "%a%s@ %a" pretty_val v sep (pretty_vals sep) vs + +and pretty_lvals ppf = function + | [] -> () + | [_,lbl,v] -> + fprintf ppf "%s: %a" lbl.lbl_name pretty_val v + | (_, lbl,v)::rest -> + fprintf ppf "%s: %a,@ %a" + lbl.lbl_name pretty_val v pretty_lvals rest + +let top_pretty ppf v = + fprintf ppf "@[%a@]@?" pretty_val v + + +let pretty_pat p = + top_pretty Format.str_formatter p ; + prerr_string (Format.flush_str_formatter ()) + +type matrix = pattern list list + +let pretty_line ps = + List.iter + (fun p -> + top_pretty Format.str_formatter p ; + prerr_string " <" ; + prerr_string (Format.flush_str_formatter ()) ; + prerr_string ">") + ps + +let pretty_matrix (pss : matrix) = + prerr_endline "begin matrix" ; + List.iter + (fun ps -> + pretty_line ps ; + prerr_endline "") + pss ; + prerr_endline "end matrix" + + +(****************************) +(* Utilities for matching *) +(****************************) + +(* Check top matching *) +let simple_match p1 p2 = + match p1.pat_desc, p2.pat_desc with + | Tpat_construct(_, c1, _), Tpat_construct(_, c2, _) -> + Types.equal_tag c1.cstr_tag c2.cstr_tag + | Tpat_variant(l1, _, _), Tpat_variant(l2, _, _) -> + l1 = l2 + | Tpat_constant(c1), Tpat_constant(c2) -> const_compare c1 c2 = 0 + | Tpat_lazy _, Tpat_lazy _ -> true + | Tpat_record _ , Tpat_record _ -> true + | Tpat_tuple p1s, Tpat_tuple p2s + | Tpat_array p1s, Tpat_array p2s -> List.length p1s = List.length p2s + | _, (Tpat_any | Tpat_var(_)) -> true + | _, _ -> false + + + + +(* extract record fields as a whole *) +let record_arg p = match p.pat_desc with +| Tpat_any -> [] +| Tpat_record (args,_) -> args +| _ -> fatal_error "Parmatch.as_record" + + +(* Raise Not_found when pos is not present in arg *) let get_field pos arg = let _,_, p = List.find (fun (_,lbl,_) -> pos = lbl.lbl_pos) arg in p @@ -190926,7 +192397,7 @@ open Lambda let rec struct_const ppf = function | Const_base(Const_int n) -> fprintf ppf "%i" n - | Const_base(Const_char i) -> fprintf ppf "%C" (Char.unsafe_chr i) + | Const_base(Const_char i) -> fprintf ppf "%s" (Pprintast.string_of_int_as_char i) | Const_base(Const_string (s, _)) -> fprintf ppf "%S" s | Const_immstring s -> fprintf ppf "#%S" s | Const_base(Const_float f) -> fprintf ppf "%s" f @@ -228059,20 +229530,18 @@ let printConstant ?(templateLiteral = false) c = | Pconst_float (s, _) -> Doc.text s | Pconst_char c -> let str = - if c <= 127 then - match Char.chr c with - | '\'' -> "\\'" - | '\\' -> "\\\\" - | '\n' -> "\\n" - | '\t' -> "\\t" - | '\r' -> "\\r" - | '\b' -> "\\b" - | ' ' .. '~' as c -> - let s = (Bytes.create [@doesNotRaise]) 1 in - Bytes.unsafe_set s 0 c; - Bytes.unsafe_to_string s - | _ -> Res_utf8.encodeCodePoint c - else Res_utf8.encodeCodePoint c + match Char.unsafe_chr c with + | '\'' -> "\\'" + | '\\' -> "\\\\" + | '\n' -> "\\n" + | '\t' -> "\\t" + | '\r' -> "\\r" + | '\b' -> "\\b" + | ' ' .. '~' as c -> + let s = (Bytes.create [@doesNotRaise]) 1 in + Bytes.unsafe_set s 0 c; + Bytes.unsafe_to_string s + | _ -> Res_utf8.encodeCodePoint c in Doc.text ("'" ^ str ^ "'") @@ -255862,7 +257331,7 @@ and expression_desc cxt ~(level : int) f x : cxt = match v with | Float { f } -> Js_number.caml_float_literal_to_js_string f (* attach string here for float constant folding?*) - | Int { i; c = Some c } -> Format.asprintf "/* %C */%ld" (Char.unsafe_chr c) i + | Int { i; c = Some c } -> Format.asprintf "/* %s */%ld" (Pprintast.string_of_int_as_char c) i | Int { i; c = None } -> Int32.to_string i (* check , js convention with ocaml lexical convention *) @@ -261676,6 +263145,13 @@ end = struct open Format open Asttypes +let string_of_int_as_char i = + if i >= 0 && i <= 255 + then + Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) + else + Printf.sprintf "\'\\%d\'" i + let rec struct_const ppf (cst : Lam_constant.t) = match cst with | Const_js_true -> fprintf ppf "#true" @@ -261684,7 +263160,7 @@ let rec struct_const ppf (cst : Lam_constant.t) = | Const_module_alias -> fprintf ppf "#alias" | Const_js_undefined -> fprintf ppf "#undefined" | Const_int { i } -> fprintf ppf "%ld" i - | Const_char c -> fprintf ppf "%C" (Char.unsafe_chr c) + | Const_char i -> fprintf ppf "%s" (string_of_int_as_char i) | Const_string { s } -> fprintf ppf "%S" s | Const_float f -> fprintf ppf "%s" f | Const_int64 n -> fprintf ppf "%LiL" n @@ -271693,1657 +273169,201 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : case int 1: 'b' case int 2: 'c'))) ]} - To elemininate the id [switcher], we need ensure it appears only - in two places. - - To advance this case, when [sw_failaction] is None - *) - match (kind, new_e, new_body) with - | ( Alias, - Lprim - { primitive = Poffsetint offset; args = [ (Lvar _ as matcher) ] }, - Lswitch - ( Lvar switcher3, - ({ - sw_consts_full = false; - sw_consts; - sw_blocks = []; - sw_blocks_full = true; - sw_failaction = Some ifso; - } as px) ) ) - when Ident.same switcher3 id - && (not (Lam_hit.hit_variable id ifso)) - && not (Ext_list.exists_snd sw_consts (Lam_hit.hit_variable id)) - -> - Lam.switch matcher - { - px with - sw_consts = - Ext_list.map sw_consts (fun (i, act) -> (i - offset, act)); - } - | _ -> Lam.let_ kind id new_e new_body) - and convert_pipe (f : Lambda.lambda) (x : Lambda.lambda) outer_loc = - let x = convert_aux x in - let f = convert_aux f in - match f with - | Lfunction - { - params = [ param ]; - body = Lprim { primitive; args = [ Lvar inner_arg ] }; - } - when Ident.same param inner_arg -> - Lam.prim ~primitive ~args:[ x ] outer_loc - | Lapply - { - ap_func = - Lfunction { params; body = Lprim { primitive; args = inner_args } }; - ap_args = args; - } - when Ext_list.for_all2_no_exn inner_args params lam_is_var - && Ext_list.length_larger_than_n inner_args args 1 -> - Lam.prim ~primitive ~args:(Ext_list.append_one args x) outer_loc - | Lapply { ap_func; ap_args; ap_info } -> - Lam.apply ap_func - (Ext_list.append_one ap_args x) - { - ap_loc = outer_loc; - ap_inlined = ap_info.ap_inlined; - ap_status = App_na; - } - | _ -> - Lam.apply f [ x ] - { - ap_loc = outer_loc; - ap_inlined = Default_inline; - ap_status = App_na; - } - and convert_switch (e : Lambda.lambda) (s : Lambda.lambda_switch) = - let e = convert_aux e in - match s with - | { - sw_failaction = None; - sw_blocks = []; - sw_numblocks = 0; - sw_consts; - sw_numconsts; - } -> ( - match happens_to_be_diff sw_consts with - | Some 0 -> e - | Some i -> - prim ~primitive:Paddint - ~args: - [ - e; - Lam.const (Const_int { i = Int32.of_int i; comment = None }); - ] - Location.none - | None -> - Lam.switch e - { - sw_failaction = None; - sw_blocks = []; - sw_blocks_full = true; - sw_consts = Ext_list.map_snd sw_consts convert_aux; - sw_consts_full = Ext_list.length_ge sw_consts sw_numconsts; - sw_names = s.sw_names; - }) - | _ -> - Lam.switch e - { - sw_consts_full = Ext_list.length_ge s.sw_consts s.sw_numconsts; - sw_consts = Ext_list.map_snd s.sw_consts convert_aux; - sw_blocks_full = Ext_list.length_ge s.sw_blocks s.sw_numblocks; - sw_blocks = Ext_list.map_snd s.sw_blocks convert_aux; - sw_failaction = Ext_option.map s.sw_failaction convert_aux; - sw_names = s.sw_names; - } - in - (convert_aux lam, may_depends) - -(** FIXME: more precise analysis of [id], if it is not - used, we can remove it - only two places emit [Lifused], - {[ - lsequence (Lifused(id, set_inst_var obj id expr)) rem - Lifused (env2, Lprim(Parrayset Paddrarray, [Lvar self; Lvar env2; Lvar env1'])) - ]} - - Note the variable, [id], or [env2] is already defined, it can be removed if it is not - used. This optimization seems useful, but doesnt really matter since it only hit translclass - - more details, see [translclass] and [if_used_test] - seems to be an optimization trick for [translclass] - - | Lifused(v, l) -> - if count_var v > 0 then simplif l else lambda_unit -*) - -(* - | Lfunction(kind,params,Lprim(prim,inner_args,inner_loc)) - when List.for_all2_no_exn (fun x y -> - match y with - | Lambda.Lvar y when Ident.same x y -> true - | _ -> false - ) params inner_args - -> - let rec aux outer_args params = - match outer_args, params with - | x::xs , _::ys -> - x :: aux xs ys - | [], [] -> [] - | x::xs, [] -> - | [], y::ys - if Ext_list.same_length inner_args args then - aux (Lprim(prim,args,inner_loc)) - else - - {[ - (fun x y -> f x y) (computation;e) --> - (fun y -> f (computation;e) y) - ]} - is wrong - - or - {[ - (fun x y -> f x y ) ([|1;2;3|]) --> - (fun y -> f [|1;2;3|] y) - ]} - is also wrong. - - It seems, we need handle [@variadic] earlier - - or - {[ - (fun x y -> f x y) ([|1;2;3|]) --> - let x0, x1, x2 =1,2,3 in - (fun y -> f [|x0;x1;x2|] y) - ]} - But this still need us to know [@variadic] in advance - - - we should not remove it immediately, since we have to be careful - where it is used, it can be [exported], [Lvar] or [Lassign] etc - The other common mistake is that - {[ - let x = y (* elimiated x/y*) - let u = x (* eliminated u/x *) - ]} - - however, [x] is already eliminated - To improve the algorithm - {[ - let x = y (* x/y *) - let u = x (* u/y *) - ]} - This looks more correct, but lets be conservative here - - global module inclusion {[ include List ]} - will cause code like {[ let include =a Lglobal_module (list)]} - - when [u] is global, it can not be bound again, - it should always be the leaf -*) - -end -module Lam_pass_alpha_conversion : sig -#1 "lam_pass_alpha_conversion.mli" -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** alpha conversion based on arity *) - -val alpha_conversion : Lam_stats.t -> Lam.t -> Lam.t - -end = struct -#1 "lam_pass_alpha_conversion.ml" -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = - let rec populateApplyInfo (args_arity : int list) (len : int) (fn : Lam.t) - (args : Lam.t list) ap_info : Lam.t = - match args_arity with - | 0 :: _ | [] -> Lam.apply (simpl fn) (Ext_list.map args simpl) ap_info - | x :: _ -> - if x = len then - Lam.apply (simpl fn) (Ext_list.map args simpl) - { ap_info with ap_status = App_infer_full } - else if x > len then - let fn = simpl fn in - let args = Ext_list.map args simpl in - Lam_eta_conversion.transform_under_supply (x - len) - { ap_info with ap_status = App_infer_full } - fn args - else - let first, rest = Ext_list.split_at args x in - Lam.apply - (Lam.apply (simpl fn) (Ext_list.map first simpl) - { ap_info with ap_status = App_infer_full }) - (Ext_list.map rest simpl) ap_info - (* TODO refien *) - and simpl (lam : Lam.t) = - match lam with - | Lconst _ -> lam - | Lvar _ -> lam - | Lapply { ap_func; ap_args; ap_info } -> - (* detect functor application *) - let args_arity = - Lam_arity.extract_arity (Lam_arity_analysis.get_arity meta ap_func) - in - let len = List.length ap_args in - populateApplyInfo args_arity len ap_func ap_args ap_info - | Llet (str, v, l1, l2) -> Lam.let_ str v (simpl l1) (simpl l2) - | Lletrec (bindings, body) -> - let bindings = Ext_list.map_snd bindings simpl in - Lam.letrec bindings (simpl body) - | Lglobal_module _ -> lam - | Lprim { primitive = Pjs_fn_make len as primitive; args = [ arg ]; loc } - -> ( - match - Lam_arity.get_first_arity (Lam_arity_analysis.get_arity meta arg) - with - | Some x -> - let arg = simpl arg in - Lam_eta_conversion.unsafe_adjust_to_arity loc ~to_:len ~from:x arg - | None -> Lam.prim ~primitive ~args:[ simpl arg ] loc) - | Lprim { primitive; args; loc } -> - Lam.prim ~primitive ~args:(Ext_list.map args simpl) loc - | Lfunction { arity; params; body; attr } -> - (* Lam_mk.lfunction kind params (simpl l) *) - Lam.function_ ~arity ~params ~body:(simpl body) ~attr - | Lswitch - ( l, - { - sw_failaction; - sw_consts; - sw_blocks; - sw_blocks_full; - sw_consts_full; - sw_names; - } ) -> - Lam.switch (simpl l) - { - sw_consts = Ext_list.map_snd sw_consts simpl; - sw_blocks = Ext_list.map_snd sw_blocks simpl; - sw_consts_full; - sw_blocks_full; - sw_failaction = Ext_option.map sw_failaction simpl; - sw_names; - } - | Lstringswitch (l, sw, d) -> - Lam.stringswitch (simpl l) - (Ext_list.map_snd sw simpl) - (Ext_option.map d simpl) - | Lstaticraise (i, ls) -> Lam.staticraise i (Ext_list.map ls simpl) - | Lstaticcatch (l1, ids, l2) -> Lam.staticcatch (simpl l1) ids (simpl l2) - | Ltrywith (l1, v, l2) -> Lam.try_ (simpl l1) v (simpl l2) - | Lifthenelse (l1, l2, l3) -> Lam.if_ (simpl l1) (simpl l2) (simpl l3) - | Lsequence (l1, l2) -> Lam.seq (simpl l1) (simpl l2) - | Lwhile (l1, l2) -> Lam.while_ (simpl l1) (simpl l2) - | Lfor (flag, l1, l2, dir, l3) -> - Lam.for_ flag (simpl l1) (simpl l2) dir (simpl l3) - | Lassign (v, l) -> - (* Lalias-bound variables are never assigned, so don't increase - v's refsimpl *) - Lam.assign v (simpl l) - in - - simpl lam - -end -module Lam_pass_collect : sig -#1 "lam_pass_collect.mli" -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** This pass is used to collect meta data information. - - It includes: - alias table, arity for identifiers and might more information, - - ATTENTION: - For later pass to keep its information complete and up to date, - we need update its table accordingly - - - Alias inference is not for substitution, it is for analyze which module is - actually a global module or an exception, so it can be relaxed a bit - (without relying on strict analysis) - - - Js object (local) analysis - - Design choice: - - Side effectful operations: - - Lassign - - Psetfield - - 1. What information should be collected: - - 2. What's the key - If it's identifier, - - Information that is always sound, not subject to change - - - shall we collect that if an identifier is passed as a parameter, (useful for escape analysis), - however, since it's going to change after inlning (for local function) - - - function arity, subject to change when you make it a mutable ref and change it later - - - Immutable blocks of identifiers - - if identifier itself is function/non block then the access can be inlined - if identifier itself is immutable block can be inlined - if identifier is mutable block can be inlined (without Lassign) since - - - When collect some information, shall we propogate this information to - all alias table immeidately - - - annotation identifiers (at first time) - - -*) - -val collect_info : Lam_stats.t -> Lam.t -> unit -(** Modify existing [meta] *) - -end = struct -#1 "lam_pass_collect.ml" -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* Check, it is shared across ident_tbl, - Only [Lassign] will break such invariant, - how about guarantee that [Lassign] only check the local ref - and we track which ids are [Lassign]ed -*) -(** - might not be the same due to refinement - assert (old.arity = v) -*) -let annotate (meta : Lam_stats.t) rec_flag (k : Ident.t) (arity : Lam_arity.t) - lambda = - Hash_ident.add meta.ident_tbl k - (FunctionId { arity; lambda = Some (lambda, rec_flag) }) -(* see #3609 - we have to update since bounded function lambda - may contain stale unbounded varaibles -*) -(* match Hash_ident.find_opt meta.ident_tbl k with - | None -> (** FIXME: need do a sanity check of arity is NA or Determin(_,[],_) *) - - | Some (FunctionId old) -> - Hash_ident.add meta.ident_tbl k - (FunctionId {arity; lambda = Some (lambda, rec_flag) }) - (* old.arity <- arity *) - (* due to we keep refining arity analysis after each round*) - | _ -> assert false *) -(* TODO -- avoid exception *) - -(** it only make senses recording arities for - function definition, - alias propgation - and toplevel identifiers, this needs to be exported -*) -let collect_info (meta : Lam_stats.t) (lam : Lam.t) = - let rec collect_bind rec_flag (ident : Ident.t) (lam : Lam.t) = - match lam with - | Lconst v -> Hash_ident.replace meta.ident_tbl ident (Constant v) - | Lprim { primitive = Pmakeblock (_, _, Immutable); args = ls } -> - Hash_ident.replace meta.ident_tbl ident - (Lam_util.kind_of_lambda_block ls); - List.iter collect ls - | Lprim { primitive = Psome | Psome_not_nest; args = [ v ] } -> - Hash_ident.replace meta.ident_tbl ident (Normal_optional v); - collect v - | Lprim - { - primitive = Praw_js_code { code_info = Exp (Js_function { arity }) }; - args = _; - } -> - Hash_ident.replace meta.ident_tbl ident - (FunctionId { arity = Lam_arity.info [ arity ] false; lambda = None }) - | Lprim { primitive = Pnull_to_opt; args = [ (Lvar _ as l) ]; _ } -> - Hash_ident.replace meta.ident_tbl ident (OptionalBlock (l, Null)) - | Lprim { primitive = Pundefined_to_opt; args = [ (Lvar _ as l) ]; _ } -> - Hash_ident.replace meta.ident_tbl ident (OptionalBlock (l, Undefined)) - | Lprim { primitive = Pnull_undefined_to_opt; args = [ (Lvar _ as l) ] } -> - Hash_ident.replace meta.ident_tbl ident - (OptionalBlock (l, Null_undefined)) - | Lglobal_module v -> Lam_util.alias_ident_or_global meta ident v (Module v) - | Lvar v -> - (* if Ident.global v then *) - Lam_util.alias_ident_or_global meta ident v NA - (* enven for not subsitution, it still propogate some properties *) - (* else () *) - | Lfunction { params; body } - (* TODO record parameters ident ?, but it will be broken after inlining *) - -> - (* TODO could be optimized in one pass? - -- since collect would iter everywhere, - so -- it would still iterate internally - *) - Ext_list.iter params (fun p -> - Hash_ident.add meta.ident_tbl p Parameter); - let arity = Lam_arity_analysis.get_arity meta lam in - annotate meta rec_flag ident arity lam; - collect body - | x -> - collect x; - if Set_ident.mem meta.export_idents ident then - annotate meta rec_flag ident (Lam_arity_analysis.get_arity meta x) lam - and collect (lam : Lam.t) = - match lam with - | Lconst _ -> () - | Lvar _ -> () - | Lapply { ap_func = l1; ap_args = ll; _ } -> - collect l1; - List.iter collect ll - | Lfunction { params; body = l } -> - (* functor ? *) - List.iter (fun p -> Hash_ident.add meta.ident_tbl p Parameter) params; - collect l - | Llet (_kind, ident, arg, body) -> - collect_bind Lam_non_rec ident arg; - collect body - | Lletrec (bindings, body) -> - (match bindings with - | [ (ident, arg) ] -> collect_bind Lam_self_rec ident arg - | _ -> - Ext_list.iter bindings (fun (ident, arg) -> - collect_bind Lam_rec ident arg)); - collect body - | Lglobal_module _ -> () - | Lprim { args; _ } -> List.iter collect args - | Lswitch (l, { sw_failaction; sw_consts; sw_blocks }) -> - collect l; - Ext_list.iter_snd sw_consts collect; - Ext_list.iter_snd sw_blocks collect; - Ext_option.iter sw_failaction collect - | Lstringswitch (l, sw, d) -> - collect l; - Ext_list.iter_snd sw collect; - Ext_option.iter d collect - | Lstaticraise (_code, ls) -> List.iter collect ls - | Lstaticcatch (l1, (_, _), l2) -> - collect l1; - collect l2 - | Ltrywith (l1, _, l2) -> - collect l1; - collect l2 - | Lifthenelse (l1, l2, l3) -> - collect l1; - collect l2; - collect l3 - | Lsequence (l1, l2) -> - collect l1; - collect l2 - | Lwhile (l1, l2) -> - collect l1; - collect l2 - | Lfor (_, l1, l2, _dir, l3) -> - collect l1; - collect l2; - collect l3 - | Lassign (_v, l) -> - (* Lalias-bound variables are never assigned, so don't increase - v's refcollect *) - collect l - in - collect lam - -end -module Lam_pass_deep_flatten : sig -#1 "lam_pass_deep_flatten.mli" -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val deep_flatten : Lam.t -> Lam.t - -end = struct -#1 "lam_pass_deep_flatten.ml" -(* Copyright (C) 2015- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* type eliminate = - | Not_eliminatable - | *) - -let rec eliminate_tuple (id : Ident.t) (lam : Lam.t) acc = - match lam with - | Llet - (Alias, v, Lprim { primitive = Pfield (i, _); args = [ Lvar tuple ] }, e2) - when Ident.same tuple id -> - eliminate_tuple id e2 (Map_int.add acc i v) - (* it is okay to have duplicates*) - | _ -> if Lam_hit.hit_variable id lam then None else Some (acc, lam) -(* [groups] are in reverse order *) - -(* be careful to flatten letrec - like below : - {[ - let rec even = - let odd n = if n ==1 then true else even (n - 1) in - fun n -> if n ==0 then true else odd (n - 1) - ]} - odd and even are recursive values, since all definitions inside - e.g, [odd] can see [even] now, however, it should be fine - in our case? since ocaml's recursive value does not allow immediate - access its value direclty?, seems no - {[ - let rec even2 = - let odd = even2 in - fun n -> if n ==0 then true else odd (n - 1) - ]} -*) -(* FIXME: - here we try to move inner definitions of [recurisve value] upwards - for example: - {[ - let rec x = - let y = 32 in - y :: x - and z = .. - --- - le ty = 32 in - let rec x = y::x - and z = .. - ]} - however, the inner definitions can see [z] and [x], so we - can not blindly move it in the beginning, however, for - recursive value, ocaml does not allow immediate access to - recursive value, so what's the best strategy? - --- - the motivation is to capture real tail call -*) -(* | Single ((Alias | Strict | StrictOpt), id, ( Lfunction _ )) -> - (** FIXME: - It should be alias and alias will be optimized away - in later optmizations, however, - this means if we don't optimize - {[ let u/a = v in ..]} - the output would be wrong, we should *optimize - this away right now* instead of delaying it to the - later passes - *) - (acc, set, g :: wrap, stop) -*) -(* could also be from nested [let rec] - like - {[ - let rec x = - let rec y = 1 :: y in - 2:: List.hd y:: x - ]} - TODO: seems like we should update depenency graph, -*) - -(* Printlambda.lambda Format.err_formatter lam ; assert false *) - -(** TODO: more flattening, - - also for function compilation, flattening should be done first - - [compile_group] and [compile] become mutually recursive function - *) -let lambda_of_groups ~(rev_bindings : Lam_group.t list) (result : Lam.t) : Lam.t - = - Ext_list.fold_left rev_bindings result (fun acc x -> - match x with - | Nop l -> Lam.seq l acc - | Single (kind, ident, lam) -> Lam_util.refine_let ~kind ident lam acc - | Recursive bindings -> Lam.letrec bindings acc) - -(* TODO: - refine effectful [ket_kind] to be pure or not - Be careful of how [Lifused(v,l)] work - since its semantics depend on whether v is used or not - return value are in reverse order, but handled by [lambda_of_groups] -*) -let deep_flatten (lam : Lam.t) : Lam.t = - let rec flatten (acc : Lam_group.t list) (lam : Lam.t) : - Lam.t * Lam_group.t list = - match lam with - | Llet - ( str, - id, - (Lprim - { - primitive = - Pnull_to_opt | Pundefined_to_opt | Pnull_undefined_to_opt; - args = [ Lvar _ ]; - } as arg), - body ) -> - flatten (Single (str, id, aux arg) :: acc) body - | Llet - ( str, - id, - Lprim - { - primitive = - (Pnull_to_opt | Pundefined_to_opt | Pnull_undefined_to_opt) as - primitive; - args = [ arg ]; - }, - body ) -> - let newId = Ident.rename id in - flatten acc - (Lam.let_ str newId arg - (Lam.let_ Alias id - (Lam.prim ~primitive ~args:[ Lam.var newId ] - Location.none (* FIXME*)) - body)) - | Llet (str, id, arg, body) -> ( - (* - {[ let match = (a,b,c) - let d = (match/1) - let e = (match/2) - .. - ]} - *) - let res, accux = flatten acc arg in - match (id.name, str, res) with - | ( ("match" | "include" | "param"), - (Alias | Strict | StrictOpt), - Lprim { primitive = Pmakeblock (_, _, Immutable); args } ) -> ( - match eliminate_tuple id body Map_int.empty with - | Some (tuple_mapping, body) -> - flatten - (Ext_list.fold_left_with_offset args accux 0 (fun arg acc i -> - match Map_int.find_opt tuple_mapping i with - | None -> Lam_group.nop_cons arg acc - | Some key -> Lam_group.single str key arg :: acc)) - body - | None -> flatten (Single (str, id, res) :: accux) body) - | _ -> flatten (Single (str, id, res) :: accux) body) - | Lletrec (bind_args, body) -> - flatten (Recursive (Ext_list.map_snd bind_args aux) :: acc) body - | Lsequence (l, r) -> - let res, l = flatten acc l in - flatten (Lam_group.nop_cons res l) r - | x -> (aux x, acc) - and aux (lam : Lam.t) : Lam.t = - match lam with - | Llet _ -> - let res, groups = flatten [] lam in - lambda_of_groups res ~rev_bindings:groups - | Lletrec (bind_args, body) -> - (* Attention: don't mess up with internal {let rec} *) - let rec iter bind_args groups set = - match bind_args with - | [] -> (List.rev groups, set) - | (id, arg) :: rest -> - iter rest ((id, aux arg) :: groups) (Set_ident.add set id) - in - let groups, collections = iter bind_args [] Set_ident.empty in - (* Try to extract some value definitions from recursive values as [wrap], - it will stop whenever it find it could not move forward - {[ - let rec x = - let y = 1 in - let z = 2 in - ... - ]} - *) - let rev_bindings, rev_wrap, _ = - Ext_list.fold_left groups ([], [], false) - (fun (inner_recursive_bindings, wrap, stop) (id, lam) -> - if stop || Lam_hit.hit_variables collections lam then - ((id, lam) :: inner_recursive_bindings, wrap, true) - else - ( inner_recursive_bindings, - Lam_group.Single (Strict, id, lam) :: wrap, - false )) - in - lambda_of_groups - ~rev_bindings: - rev_wrap (* These bindings are extracted from [letrec] *) - (Lam.letrec (List.rev rev_bindings) (aux body)) - | Lsequence (l, r) -> Lam.seq (aux l) (aux r) - | Lconst _ -> lam - | Lvar _ -> lam - (* | Lapply(Lfunction(Curried, params, body), args, _) *) - (* when List.length params = List.length args -> *) - (* aux (beta_reduce params body args) *) - (* | Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock _, args)], _) *) - (* (\** TODO: keep track of this parameter in ocaml trunk, *) - (* can we switch to the tupled backend? *\) *) - (* when List.length params = List.length args -> *) - (* aux (beta_reduce params body args) *) - | Lapply { ap_func = l1; ap_args = ll; ap_info } -> - Lam.apply (aux l1) (Ext_list.map ll aux) ap_info - (* This kind of simple optimizations should be done each time - and as early as possible *) - | Lglobal_module _ -> lam - | Lprim { primitive; args; loc } -> - let args = Ext_list.map args aux in - Lam.prim ~primitive ~args loc - | Lfunction { arity; params; body; attr } -> - Lam.function_ ~arity ~params ~body:(aux body) ~attr - | Lswitch - ( l, - { - sw_failaction; - sw_consts; - sw_blocks; - sw_blocks_full; - sw_consts_full; - sw_names; - } ) -> - Lam.switch (aux l) - { - sw_consts = Ext_list.map_snd sw_consts aux; - sw_blocks = Ext_list.map_snd sw_blocks aux; - sw_consts_full; - sw_blocks_full; - sw_failaction = Ext_option.map sw_failaction aux; - sw_names; - } - | Lstringswitch (l, sw, d) -> - Lam.stringswitch (aux l) (Ext_list.map_snd sw aux) - (Ext_option.map d aux) - | Lstaticraise (i, ls) -> Lam.staticraise i (Ext_list.map ls aux) - | Lstaticcatch (l1, ids, l2) -> Lam.staticcatch (aux l1) ids (aux l2) - | Ltrywith (l1, v, l2) -> Lam.try_ (aux l1) v (aux l2) - | Lifthenelse (l1, l2, l3) -> Lam.if_ (aux l1) (aux l2) (aux l3) - | Lwhile (l1, l2) -> Lam.while_ (aux l1) (aux l2) - | Lfor (flag, l1, l2, dir, l3) -> - Lam.for_ flag (aux l1) (aux l2) dir (aux l3) - | Lassign (v, l) -> - (* Lalias-bound variables are never assigned, so don't increase - v's refaux *) - Lam.assign v (aux l) - in - aux lam - -end -module Lam_exit_count : sig -#1 "lam_exit_count.mli" -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type collection - -val count_helper : Lam.t -> collection - -val count_exit : collection -> int -> int - -end = struct -#1 "lam_exit_count.ml" -(* Copyright (C) 2018 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type collection = int Hash_int.t - -(* Count occurrences of (exit n ...) statements *) -let count_exit (exits : collection) i = Hash_int.find_default exits i 0 - -let incr_exit (exits : collection) i = - Hash_int.add_or_update exits i 1 ~update:succ - -(** - This funcition counts how each [exit] is used, it will affect how the following optimizations performed. - - Some smart cases (this requires the following optimizations follow it): - - {[ - Lstaticcatch(l1, (i,_), l2) - ]} - If [l1] does not contain [(exit i)], - [l2] will be removed, so don't count it. - - About Switch default branch handling, it maybe backend-specific - See https://github.com/ocaml/ocaml/commit/fcf3571123e2c914768e34f1bd17e4cbaaa7d212#diff-704f66c0fa0fc9339230b39ce7d90919 - For Lstringswitch ^ - - For Lswitch, if it is not exhuastive pattern match, default will be counted twice. - Since for pattern match, we will test whether it is an integer or block, both have default cases predicate: [sw_consts_full] vs nconsts -*) -let count_helper (lam : Lam.t) : collection = - let exits : collection = Hash_int.create 17 in - let rec count (lam : Lam.t) = - match lam with - | Lstaticraise (i, ls) -> - incr_exit exits i; - Ext_list.iter ls count - | Lstaticcatch (l1, (i, _), l2) -> - count l1; - if count_exit exits i > 0 then count l2 - | Lstringswitch (l, sw, d) -> - count l; - Ext_list.iter_snd sw count; - Ext_option.iter d count - | Lglobal_module _ | Lvar _ | Lconst _ -> () - | Lapply { ap_func; ap_args; _ } -> - count ap_func; - Ext_list.iter ap_args count - | Lfunction { body } -> count body - | Llet (_, _, l1, l2) -> - count l2; - count l1 - | Lletrec (bindings, body) -> - Ext_list.iter_snd bindings count; - count body - | Lprim { args; _ } -> List.iter count args - | Lswitch (l, sw) -> - count_default sw; - count l; - Ext_list.iter_snd sw.sw_consts count; - Ext_list.iter_snd sw.sw_blocks count - | Ltrywith (l1, _v, l2) -> - count l1; - count l2 - | Lifthenelse (l1, l2, l3) -> - count l1; - count l2; - count l3 - | Lsequence (l1, l2) -> - count l1; - count l2 - | Lwhile (l1, l2) -> - count l1; - count l2 - | Lfor (_, l1, l2, _dir, l3) -> - count l1; - count l2; - count l3 - | Lassign (_, l) -> count l - and count_default sw = - match sw.sw_failaction with - | None -> () - | Some al -> - if (not sw.sw_consts_full) && not sw.sw_blocks_full then ( - count al; - count al) - else count al - in - count lam; - exits - -end -module Lam_subst : sig -#1 "lam_subst.mli" -(* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* Apply a substitution to a lambda-term. - Assumes that the bound variables of the lambda-term do not - belong to the domain of the substitution. - Assumes that the image of the substitution is out of reach - of the bound variables of the lambda-term (no capture). *) - -val subst : Lam.t Map_ident.t -> Lam.t -> Lam.t - -end = struct -#1 "lam_subst.ml" -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* Apply a substitution to a lambda-term. - Assumes that the bound variables of the lambda-term do not - belong to the domain of the substitution. - Assumes that the image of the substitution is out of reach - of the bound variables of the lambda-term (no capture). *) + To elemininate the id [switcher], we need ensure it appears only + in two places. -let subst (s : Lam.t Map_ident.t) lam = - let rec subst_aux (x : Lam.t) : Lam.t = - match x with - | Lvar id -> Map_ident.find_default s id x - | Lconst _ -> x + To advance this case, when [sw_failaction] is None + *) + match (kind, new_e, new_body) with + | ( Alias, + Lprim + { primitive = Poffsetint offset; args = [ (Lvar _ as matcher) ] }, + Lswitch + ( Lvar switcher3, + ({ + sw_consts_full = false; + sw_consts; + sw_blocks = []; + sw_blocks_full = true; + sw_failaction = Some ifso; + } as px) ) ) + when Ident.same switcher3 id + && (not (Lam_hit.hit_variable id ifso)) + && not (Ext_list.exists_snd sw_consts (Lam_hit.hit_variable id)) + -> + Lam.switch matcher + { + px with + sw_consts = + Ext_list.map sw_consts (fun (i, act) -> (i - offset, act)); + } + | _ -> Lam.let_ kind id new_e new_body) + and convert_pipe (f : Lambda.lambda) (x : Lambda.lambda) outer_loc = + let x = convert_aux x in + let f = convert_aux f in + match f with + | Lfunction + { + params = [ param ]; + body = Lprim { primitive; args = [ Lvar inner_arg ] }; + } + when Ident.same param inner_arg -> + Lam.prim ~primitive ~args:[ x ] outer_loc + | Lapply + { + ap_func = + Lfunction { params; body = Lprim { primitive; args = inner_args } }; + ap_args = args; + } + when Ext_list.for_all2_no_exn inner_args params lam_is_var + && Ext_list.length_larger_than_n inner_args args 1 -> + Lam.prim ~primitive ~args:(Ext_list.append_one args x) outer_loc | Lapply { ap_func; ap_args; ap_info } -> - Lam.apply (subst_aux ap_func) (Ext_list.map ap_args subst_aux) ap_info - | Lfunction { arity; params; body; attr } -> - Lam.function_ ~arity ~params ~body:(subst_aux body) ~attr - | Llet (str, id, arg, body) -> - Lam.let_ str id (subst_aux arg) (subst_aux body) - | Lletrec (decl, body) -> - Lam.letrec (Ext_list.map decl subst_decl) (subst_aux body) - | Lprim { primitive; args; loc } -> - Lam.prim ~primitive ~args:(Ext_list.map args subst_aux) loc - | Lglobal_module _ -> x - | Lswitch (arg, sw) -> - Lam.switch (subst_aux arg) + Lam.apply ap_func + (Ext_list.append_one ap_args x) { - sw with - sw_consts = Ext_list.map sw.sw_consts subst_case; - sw_blocks = Ext_list.map sw.sw_blocks subst_case; - sw_failaction = subst_opt sw.sw_failaction; + ap_loc = outer_loc; + ap_inlined = ap_info.ap_inlined; + ap_status = App_na; } - | Lstringswitch (arg, cases, default) -> - Lam.stringswitch (subst_aux arg) - (Ext_list.map cases subst_strcase) - (subst_opt default) - | Lstaticraise (i, args) -> Lam.staticraise i (Ext_list.map args subst_aux) - | Lstaticcatch (e1, io, e2) -> - Lam.staticcatch (subst_aux e1) io (subst_aux e2) - | Ltrywith (e1, exn, e2) -> Lam.try_ (subst_aux e1) exn (subst_aux e2) - | Lifthenelse (e1, e2, e3) -> - Lam.if_ (subst_aux e1) (subst_aux e2) (subst_aux e3) - | Lsequence (e1, e2) -> Lam.seq (subst_aux e1) (subst_aux e2) - | Lwhile (e1, e2) -> Lam.while_ (subst_aux e1) (subst_aux e2) - | Lfor (v, e1, e2, dir, e3) -> - Lam.for_ v (subst_aux e1) (subst_aux e2) dir (subst_aux e3) - | Lassign (id, e) -> Lam.assign id (subst_aux e) - and subst_decl (id, exp) = (id, subst_aux exp) - and subst_case (key, case) = (key, subst_aux case) - and subst_strcase (key, case) = (key, subst_aux case) - and subst_opt = function None -> None | Some e -> Some (subst_aux e) in - subst_aux lam - -end -module Lam_pass_exits : sig -#1 "lam_pass_exits.mli" -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) -(* Adapted for Javascript backend: Hongbo Zhang, *) + | _ -> + Lam.apply f [ x ] + { + ap_loc = outer_loc; + ap_inlined = Default_inline; + ap_status = App_na; + } + and convert_switch (e : Lambda.lambda) (s : Lambda.lambda_switch) = + let e = convert_aux e in + match s with + | { + sw_failaction = None; + sw_blocks = []; + sw_numblocks = 0; + sw_consts; + sw_numconsts; + } -> ( + match happens_to_be_diff sw_consts with + | Some 0 -> e + | Some i -> + prim ~primitive:Paddint + ~args: + [ + e; + Lam.const (Const_int { i = Int32.of_int i; comment = None }); + ] + Location.none + | None -> + Lam.switch e + { + sw_failaction = None; + sw_blocks = []; + sw_blocks_full = true; + sw_consts = Ext_list.map_snd sw_consts convert_aux; + sw_consts_full = Ext_list.length_ge sw_consts sw_numconsts; + sw_names = s.sw_names; + }) + | _ -> + Lam.switch e + { + sw_consts_full = Ext_list.length_ge s.sw_consts s.sw_numconsts; + sw_consts = Ext_list.map_snd s.sw_consts convert_aux; + sw_blocks_full = Ext_list.length_ge s.sw_blocks s.sw_numblocks; + sw_blocks = Ext_list.map_snd s.sw_blocks convert_aux; + sw_failaction = Ext_option.map s.sw_failaction convert_aux; + sw_names = s.sw_names; + } + in + (convert_aux lam, may_depends) -(** A pass used to optimize the exit code compilation, adaped from the compiler's - [simplif] module -*) +(** FIXME: more precise analysis of [id], if it is not + used, we can remove it + only two places emit [Lifused], + {[ + lsequence (Lifused(id, set_inst_var obj id expr)) rem + Lifused (env2, Lprim(Parrayset Paddrarray, [Lvar self; Lvar env2; Lvar env1'])) + ]} -val simplify_exits : Lam.t -> Lam.t + Note the variable, [id], or [env2] is already defined, it can be removed if it is not + used. This optimization seems useful, but doesnt really matter since it only hit translclass -end = struct -#1 "lam_pass_exits.ml" -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) -(* Adapted for Javascript backend: Hongbo Zhang *) + more details, see [translclass] and [if_used_test] + seems to be an optimization trick for [translclass] -(** - [no_bounded_varaibles lambda] - checks if [lambda] contains bounded variable, for - example [Llet (str,id,arg,body) ] will fail such check. - This is used to indicate such lambda expression if it is okay - to inline directly since if it contains bounded variables it - must be rebounded before inlining + | Lifused(v, l) -> + if count_var v > 0 then simplif l else lambda_unit *) -let rec no_list args = Ext_list.for_all args no_bounded_variables - -and no_list_snd : 'a. ('a * Lam.t) list -> bool = - fun args -> Ext_list.for_all_snd args no_bounded_variables - -and no_opt x = match x with None -> true | Some a -> no_bounded_variables a - -and no_bounded_variables (l : Lam.t) = - match l with - | Lvar _ -> true - | Lconst _ -> true - | Lassign (_id, e) -> no_bounded_variables e - | Lapply { ap_func; ap_args; _ } -> - no_bounded_variables ap_func && no_list ap_args - | Lglobal_module _ -> true - | Lprim { args; primitive = _ } -> no_list args - | Lswitch (arg, sw) -> - no_bounded_variables arg && no_list_snd sw.sw_consts - && no_list_snd sw.sw_blocks && no_opt sw.sw_failaction - | Lstringswitch (arg, cases, default) -> - no_bounded_variables arg && no_list_snd cases && no_opt default - | Lstaticraise (_, args) -> no_list args - | Lifthenelse (e1, e2, e3) -> - no_bounded_variables e1 && no_bounded_variables e2 - && no_bounded_variables e3 - | Lsequence (e1, e2) -> no_bounded_variables e1 && no_bounded_variables e2 - | Lwhile (e1, e2) -> no_bounded_variables e1 && no_bounded_variables e2 - | Lstaticcatch (e1, (_, vars), e2) -> - vars = [] && no_bounded_variables e1 && no_bounded_variables e2 - | Lfunction { body; params } -> params = [] && no_bounded_variables body - | Lfor _ -> false - | Ltrywith _ -> false - | Llet _ -> false - | Lletrec (decl, body) -> decl = [] && no_bounded_variables body (* - TODO: - we should have a pass called, always inlinable - as long as its length is smaller than [exit=exit_id], for example - - {[ - switch(box_name) - {case "":exit=178;break; - case "b":exit=178;break; - case "h":box_type=/* Pp_hbox */0;break; - case "hov":box_type=/* Pp_hovbox */3;break; - case "hv":box_type=/* Pp_hvbox */2;break; - case "v":box_type=/* Pp_vbox */1;break; - default:box_type=invalid_box(/* () */0);} - - switch(exit){case 178:box_type=/* Pp_box */4;break} - ]} -*) - -(** The third argument is its occurrence, - when do the substitution, if its occurence is > 1, - we should refresh -*) -type lam_subst = Id of Lam.t [@@unboxed] -(* | Refresh of Lam.t *) - -type subst_tbl = (Ident.t list * lam_subst) Hash_int.t - -let to_lam x = match x with Id x -> x -(* | Refresh x -> Lam_bounded_vars.refresh x *) - -(** - Simplify ``catch body with (i ...) handler'' - - if (exit i ...) does not occur in body, suppress catch - - if (exit i ...) occurs exactly once in body, - substitute it with handler - - If handler is a single variable, replace (exit i ..) with it - + | Lfunction(kind,params,Lprim(prim,inner_args,inner_loc)) + when List.for_all2_no_exn (fun x y -> + match y with + | Lambda.Lvar y when Ident.same x y -> true + | _ -> false + ) params inner_args + -> + let rec aux outer_args params = + match outer_args, params with + | x::xs , _::ys -> + x :: aux xs ys + | [], [] -> [] + | x::xs, [] -> + | [], y::ys + if Ext_list.same_length inner_args args then + aux (Lprim(prim,args,inner_loc)) + else - Note: - In ``catch body with (i x1 .. xn) handler'' - Substituted expression is - let y1 = x1 and ... yn = xn in - handler[x1 <- y1 ; ... ; xn <- yn] - For the sake of preserving the uniqueness of bound variables. - ASKS: This documentation seems outdated - (No alpha conversion of ``handler'' is presently needed, since - substitution of several ``(exit i ...)'' - occurs only when ``handler'' is a variable.) - Note that - for [query] result = 2, - the non-inline cost is {[ - var exit ; - - exit = 11; - exit = 11; - - switch(exit){ - case exit = 11 : body ; break - } - + (fun x y -> f x y) (computation;e) --> + (fun y -> f (computation;e) y) ]} - the inline cost is + is wrong + or {[ - body; - body; + (fun x y -> f x y ) ([|1;2;3|]) --> + (fun y -> f [|1;2;3|] y) ]} + is also wrong. - when [i] is negative, we can not inline in general, - since the outer is a traditional [try .. catch] body, - if it is guaranteed to be non throw, then we can inline -*) - -(** TODO: better heuristics, also if we can group same exit code [j] - in a very early stage -- maybe we can define our enhanced [Lambda] - representation and counter can be more precise, for example [apply] - does not need patch from the compiler - - FIXME: when inlining, need refresh local bound identifiers - #1438 when the action containes bounded variable - to keep the invariant, everytime, we do an inlining, - we need refresh, just refreshing once is not enough - We need to decide whether inline or not based on post-simplification - code, since when we do the substitution - we use the post-simplified expression, it is more consistent - TODO: when we do the case merging on the js side, - the j is not very indicative -*) - -let subst_helper (subst : subst_tbl) (query : int -> int) (lam : Lam.t) : Lam.t - = - let rec simplif (lam : Lam.t) = - match lam with - | Lstaticcatch (l1, (i, xs), l2) -> ( - let i_occur = query i in - match (i_occur, l2) with - | 0, _ -> simplif l1 - | _, Lvar _ | _, Lconst _ (* when i >= 0 # 2316 *) -> - Hash_int.add subst i (xs, Id (simplif l2)); - simplif l1 (* l1 will inline *) - | 1, _ when i >= 0 -> - (* Ask: Note that we have predicate i >=0 *) - Hash_int.add subst i (xs, Id (simplif l2)); - simplif l1 (* l1 will inline *) - | _ -> - let l2 = simplif l2 in - (* we only inline when [l2] does not contain bound variables - no need to refresh - *) - let ok_to_inline = - i >= 0 && no_bounded_variables l2 - && - let lam_size = Lam_analysis.size l2 in - (i_occur <= 2 && lam_size < Lam_analysis.exit_inline_size) - || lam_size < 5 - in - if ok_to_inline then ( - Hash_int.add subst i (xs, Id l2); - simplif l1) - else Lam.staticcatch (simplif l1) (i, xs) l2) - | Lstaticraise (i, []) -> ( - match Hash_int.find_opt subst i with - | Some (_, handler) -> to_lam handler - | None -> lam) - | Lstaticraise (i, ls) -> ( - let ls = Ext_list.map ls simplif in - match Hash_int.find_opt subst i with - | Some (xs, handler) -> - let handler = to_lam handler in - let ys = Ext_list.map xs Ident.rename in - let env = - Ext_list.fold_right2 xs ys Map_ident.empty (fun x y t -> - Map_ident.add t x (Lam.var y)) - in - Ext_list.fold_right2 ys ls (Lam_subst.subst env handler) - (fun y l r -> Lam.let_ Strict y l r) - | None -> Lam.staticraise i ls) - | Lvar _ | Lconst _ -> lam - | Lapply { ap_func; ap_args; ap_info } -> - Lam.apply (simplif ap_func) (Ext_list.map ap_args simplif) ap_info - | Lfunction { arity; params; body; attr } -> - Lam.function_ ~arity ~params ~body:(simplif body) ~attr - | Llet (kind, v, l1, l2) -> Lam.let_ kind v (simplif l1) (simplif l2) - | Lletrec (bindings, body) -> - Lam.letrec (Ext_list.map_snd bindings simplif) (simplif body) - | Lglobal_module _ -> lam - | Lprim { primitive; args; loc } -> - let args = Ext_list.map args simplif in - Lam.prim ~primitive ~args loc - | Lswitch (l, sw) -> - let new_l = simplif l in - let new_consts = Ext_list.map_snd sw.sw_consts simplif in - let new_blocks = Ext_list.map_snd sw.sw_blocks simplif in - let new_fail = Ext_option.map sw.sw_failaction simplif in - Lam.switch new_l - { - sw with - sw_consts = new_consts; - sw_blocks = new_blocks; - sw_failaction = new_fail; - } - | Lstringswitch (l, sw, d) -> - Lam.stringswitch (simplif l) - (Ext_list.map_snd sw simplif) - (Ext_option.map d simplif) - | Ltrywith (l1, v, l2) -> Lam.try_ (simplif l1) v (simplif l2) - | Lifthenelse (l1, l2, l3) -> Lam.if_ (simplif l1) (simplif l2) (simplif l3) - | Lsequence (l1, l2) -> Lam.seq (simplif l1) (simplif l2) - | Lwhile (l1, l2) -> Lam.while_ (simplif l1) (simplif l2) - | Lfor (v, l1, l2, dir, l3) -> - Lam.for_ v (simplif l1) (simplif l2) dir (simplif l3) - | Lassign (v, l) -> Lam.assign v (simplif l) - in - simplif lam - -let simplify_exits (lam : Lam.t) = - let exits = Lam_exit_count.count_helper lam in - subst_helper (Hash_int.create 17) (Lam_exit_count.count_exit exits) lam - -(* Compile-time beta-reduction of functions immediately applied: - Lapply(Lfunction(Curried, params, body), args, loc) -> - let paramN = argN in ... let param1 = arg1 in body - Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock(args))], loc) -> - let paramN = argN in ... let param1 = arg1 in body - Assumes |args| = |params|. -*) - -end -module Lam_pass_count : sig -#1 "lam_pass_count.mli" -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) -(* Adapted for Javascript backend : Hongbo Zhang, *) - -type used_info = { - mutable times : int; - mutable captured : bool; - (* captured in functon or loop, - inline in such cases should be careful - 1. can not inline mutable values - 2. avoid re-computation - *) -} - -type occ_tbl = used_info Hash_ident.t - -val dummy_info : unit -> used_info - -val collect_occurs : Lam.t -> occ_tbl - -val pp_occ_tbl : Format.formatter -> occ_tbl -> unit - -end = struct -#1 "lam_pass_count.ml" -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) -(* Adapted for Javascript backend : Hongbo Zhang, *) - -(*A naive dead code elimination *) -type used_info = { - mutable times : int; - mutable captured : bool; - (* captured in functon or loop, - inline in such cases should be careful - 1. can not inline mutable values - 2. avoid re-computation - *) -} - -type occ_tbl = used_info Hash_ident.t -(* First pass: count the occurrences of all let-bound identifiers *) - -type local_tbl = used_info Map_ident.t - -let dummy_info () = { times = 0; captured = false } -(* y is untouched *) - -let absorb_info (x : used_info) (y : used_info) = - match (x, y) with - | { times = x0 }, { times = y0; captured } -> - x.times <- x0 + y0; - if captured then x.captured <- true - -let pp_info fmt (x : used_info) = - Format.fprintf fmt "(:%d)" x.captured x.times - -let pp_occ_tbl fmt tbl = - Hash_ident.iter tbl (fun k v -> - Format.fprintf fmt "@[%a@ %a@]@." Ident.print k pp_info v) + It seems, we need handle [@variadic] earlier -(* The global table [occ] associates to each let-bound identifier - the number of its uses (as a reference): - - 0 if never used - - 1 if used exactly once in and not under a lambda or within a loop - - when under a lambda, - - it's probably a closure - - within a loop - - update reference, - niether is good for inlining - - > 1 if used several times or under a lambda or within a loop. - The local table [bv] associates to each locally-let-bound variable - its reference count, as above. [bv] is enriched at let bindings - but emptied when crossing lambdas and loops. *) -let collect_occurs lam : occ_tbl = - let occ : occ_tbl = Hash_ident.create 83 in + or + {[ + (fun x y -> f x y) ([|1;2;3|]) --> + let x0, x1, x2 =1,2,3 in + (fun y -> f [|x0;x1;x2|] y) + ]} + But this still need us to know [@variadic] in advance - (* Current use count of a variable. *) - let used v = - match Hash_ident.find_opt occ v with - | None -> false - | Some { times; _ } -> times > 0 - in - (* Entering a [let]. Returns updated [bv]. *) - let bind_var bv ident = - let r = dummy_info () in - Hash_ident.add occ ident r; - Map_ident.add bv ident r - in + we should not remove it immediately, since we have to be careful + where it is used, it can be [exported], [Lvar] or [Lassign] etc + The other common mistake is that + {[ + let x = y (* elimiated x/y*) + let u = x (* eliminated u/x *) + ]} - (* Record a use of a variable *) - let add_one_use bv ident = - match Map_ident.find_opt bv ident with - | Some r -> r.times <- r.times + 1 - | None -> ( - (* ident is not locally bound, therefore this is a use under a lambda - or within a loop. Increase use count by 2 -- enough so - that single-use optimizations will not apply. *) - match Hash_ident.find_opt occ ident with - | Some r -> absorb_info r { times = 1; captured = true } - | None -> - (* Not a let-bound variable, ignore *) - ()) - in + however, [x] is already eliminated + To improve the algorithm + {[ + let x = y (* x/y *) + let u = x (* u/y *) + ]} + This looks more correct, but lets be conservative here - let inherit_use bv ident bid = - let n = - match Hash_ident.find_opt occ bid with - | None -> dummy_info () - | Some v -> v - in - match Map_ident.find_opt bv ident with - | Some r -> absorb_info r n - | None -> ( - (* ident is not locally bound, therefore this is a use under a lambda - or within a loop. Increase use count by 2 -- enough so - that single-use optimizations will not apply. *) - match Hash_ident.find_opt occ ident with - | Some r -> absorb_info r { n with captured = true } - | None -> - (* Not a let-bound variable, ignore *) - ()) - in + global module inclusion {[ include List ]} + will cause code like {[ let include =a Lglobal_module (list)]} - let rec count (bv : local_tbl) (lam : Lam.t) = - match lam with - | Lfunction { body = l } -> count Map_ident.empty l - (* when entering a function local [bv] - is cleaned up, so that all closure variables will not be - carried over, since the parameters are never rebound, - so it is fine to kep it empty - *) - | Lfor (_, l1, l2, _dir, l3) -> - count bv l1; - count bv l2; - count Map_ident.empty l3 - | Lwhile (l1, l2) -> - count Map_ident.empty l1; - count Map_ident.empty l2 - | Lvar v -> add_one_use bv v - | Llet (_, v, Lvar w, l2) -> - (* v will be replaced by w in l2, so each occurrence of v in l2 - increases w's refcount *) - count (bind_var bv v) l2; - inherit_use bv w v - | Llet (kind, v, l1, l2) -> - count (bind_var bv v) l2; - (* count [l2] first, - If v is unused, l1 will be removed, so don't count its variables *) - if kind = Strict || used v then count bv l1 - | Lassign (_, l) -> - (* Lalias-bound variables are never assigned, so don't increase - this ident's refcount *) - count bv l - | Lglobal_module _ -> () - | Lprim { args; _ } -> List.iter (count bv) args - | Lletrec (bindings, body) -> - List.iter (fun (_v, l) -> count bv l) bindings; - count bv body - (* Note there is a difference here when do beta reduction for *) - | Lapply { ap_func = Lfunction { params; body }; ap_args = args; _ } - when Ext_list.same_length params args -> - count bv (Lam_beta_reduce.no_names_beta_reduce params body args) - (* | Lapply{fn = Lfunction{function_kind = Tupled; params; body}; *) - (* args = [Lprim {primitive = Pmakeblock _; args; _}]; _} *) - (* when Ext_list.same_length params args -> *) - (* count bv (Lam_beta_reduce.beta_reduce params body args) *) - | Lapply { ap_func = l1; ap_args = ll; _ } -> - count bv l1; - List.iter (count bv) ll - | Lconst _cst -> () - | Lswitch (l, sw) -> - count_default bv sw; - count bv l; - List.iter (fun (_, l) -> count bv l) sw.sw_consts; - List.iter (fun (_, l) -> count bv l) sw.sw_blocks - | Lstringswitch (l, sw, d) -> ( - count bv l; - List.iter (fun (_, l) -> count bv l) sw; - match d with Some d -> count bv d | None -> ()) - (* x2 for native backend *) - (* begin match sw with *) - (* | []|[_] -> count bv d *) - (* | _ -> count bv d ; count bv d *) - (* end *) - | Lstaticraise (_i, ls) -> List.iter (count bv) ls - | Lstaticcatch (l1, (_i, _), l2) -> - count bv l1; - count bv l2 - | Ltrywith (l1, _v, l2) -> - count bv l1; - count bv l2 - | Lifthenelse (l1, l2, l3) -> - count bv l1; - count bv l2; - count bv l3 - | Lsequence (l1, l2) -> - count bv l1; - count bv l2 - and count_default bv sw = - match sw.sw_failaction with - | None -> () - | Some al -> - if (not sw.sw_consts_full) && not sw.sw_blocks_full then ( - (* default action will occur twice in native code *) - count bv al; - count bv al) - else ( - (* default action will occur once *) - assert ((not sw.sw_consts_full) || not sw.sw_blocks_full); - count bv al) - in - count Map_ident.empty lam; - occ + when [u] is global, it can not be bound again, + it should always be the leaf +*) end -module Lam_pass_eliminate_ref : sig -#1 "lam_pass_eliminate_ref.mli" -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. +module Lam_pass_alpha_conversion : sig +#1 "lam_pass_alpha_conversion.mli" +(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by @@ -273367,424 +273387,205 @@ module Lam_pass_eliminate_ref : sig * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -exception Real_reference - -val eliminate_ref : Ident.t -> Lam.t -> Lam.t - -end = struct -#1 "lam_pass_eliminate_ref.ml" -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) -(* Adapted for Javascript backend : Hongbo Zhang, *) - -exception Real_reference - -let rec eliminate_ref id (lam : Lam.t) = - match lam with - (* we can do better escape analysis in Javascript backend *) - | Lvar v -> if Ident.same v id then raise_notrace Real_reference else lam - | Lprim { primitive = Pfield (0, _); args = [ Lvar v ] } when Ident.same v id - -> - Lam.var id - | Lfunction _ -> - if Lam_hit.hit_variable id lam then raise_notrace Real_reference else lam - (* In Javascript backend, its okay, we can reify it later - a failed case - {[ - for i = .. - let v = ref 0 - for j = .. - incr v - a[j] = ()=>{!v} - - ]} - here v is captured by a block, and it's a loop mutable value, - we have to generate - {[ - for i = .. - let v = ref 0 - (function (v){for j = .. - a[j] = ()=>{!v}}(v) - - ]} - now, v is a real reference - TODO: we can refine analysis in later - *) - (* Lfunction(kind, params, eliminate_ref id body) *) - | Lprim { primitive = Psetfield (0, _); args = [ Lvar v; e ] } - when Ident.same v id -> - Lam.assign id (eliminate_ref id e) - | Lprim { primitive = Poffsetref delta; args = [ Lvar v ]; loc } - when Ident.same v id -> - Lam.assign id - (Lam.prim ~primitive:(Poffsetint delta) ~args:[ Lam.var id ] loc) - | Lconst _ -> lam - | Lapply { ap_func = e1; ap_args = el; ap_info } -> - Lam.apply (eliminate_ref id e1) - (Ext_list.map el (eliminate_ref id)) - ap_info - | Llet (str, v, e1, e2) -> - Lam.let_ str v (eliminate_ref id e1) (eliminate_ref id e2) - | Lletrec (idel, e2) -> - Lam.letrec - (Ext_list.map idel (fun (v, e) -> (v, eliminate_ref id e))) - (eliminate_ref id e2) - | Lglobal_module _ -> lam - | Lprim { primitive; args; loc } -> - Lam.prim ~primitive ~args:(Ext_list.map args (eliminate_ref id)) loc - | Lswitch (e, sw) -> - Lam.switch (eliminate_ref id e) - { - sw_consts_full = sw.sw_consts_full; - sw_consts = - Ext_list.map sw.sw_consts (fun (n, e) -> (n, eliminate_ref id e)); - sw_blocks_full = sw.sw_blocks_full; - sw_blocks = - Ext_list.map sw.sw_blocks (fun (n, e) -> (n, eliminate_ref id e)); - sw_failaction = - (match sw.sw_failaction with - | None -> None - | Some x -> Some (eliminate_ref id x)); - sw_names = sw.sw_names; - } - | Lstringswitch (e, sw, default) -> - Lam.stringswitch (eliminate_ref id e) - (Ext_list.map sw (fun (s, e) -> (s, eliminate_ref id e))) - (match default with - | None -> None - | Some x -> Some (eliminate_ref id x)) - | Lstaticraise (i, args) -> - Lam.staticraise i (Ext_list.map args (eliminate_ref id)) - | Lstaticcatch (e1, i, e2) -> - Lam.staticcatch (eliminate_ref id e1) i (eliminate_ref id e2) - | Ltrywith (e1, v, e2) -> - Lam.try_ (eliminate_ref id e1) v (eliminate_ref id e2) - | Lifthenelse (e1, e2, e3) -> - Lam.if_ (eliminate_ref id e1) (eliminate_ref id e2) (eliminate_ref id e3) - | Lsequence (e1, e2) -> Lam.seq (eliminate_ref id e1) (eliminate_ref id e2) - | Lwhile (e1, e2) -> Lam.while_ (eliminate_ref id e1) (eliminate_ref id e2) - | Lfor (v, e1, e2, dir, e3) -> - Lam.for_ v (eliminate_ref id e1) (eliminate_ref id e2) dir - (eliminate_ref id e3) - | Lassign (v, e) -> Lam.assign v (eliminate_ref id e) - -end -module Lam_pass_lets_dce : sig -#1 "lam_pass_lets_dce.mli" -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) -(* Adapted for Javascript backend: Hongbo Zhang *) - -val simplify_lets : Lam.t -> Lam.t -(** - This pass would do beta reduction, and dead code elimination (adapted from compiler's built-in [Simplif] module ) - - 1. beta reduction -> Llet (Strict ) - - 2. The global table [occ] associates to each let-bound identifier - the number of its uses (as a reference): - - 0 if never used - - 1 if used exactly once in and *not under a lambda or within a loop - - > 1 if used several times or under a lambda or within a loop. - - The local table [bv] associates to each locally-let-bound variable - its reference count, as above. [bv] is enriched at let bindings - but emptied when crossing lambdas and loops. - - For this pass, when it' used under a lambda or within a loop, we don't do anything, - in theory, we can still do something if it's pure but we are conservative here. - - [bv] is used to help caculate [occ] it is not useful outside +(** alpha conversion based on arity *) -*) +val alpha_conversion : Lam_stats.t -> Lam.t -> Lam.t end = struct -#1 "lam_pass_lets_dce.pp.ml" -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) -(* Adapted for Javascript backend : Hongbo Zhang, *) - +#1 "lam_pass_alpha_conversion.ml" +(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. + * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = - let subst : Lam.t Hash_ident.t = Hash_ident.create 32 in - let string_table : string Hash_ident.t = Hash_ident.create 32 in - let used v = (count_var v ).times > 0 in - let rec simplif (lam : Lam.t) = - match lam with - | Lvar v -> Hash_ident.find_default subst v lam - | Llet( (Strict | Alias | StrictOpt) , v, Lvar w, l2) - -> - Hash_ident.add subst v (simplif (Lam.var w)); - simplif l2 - | Llet(Strict as kind, - v, (Lprim {primitive = (Pmakeblock(0, _, Mutable) - as primitive); - args = [linit] ; loc}), lbody) - -> - let slinit = simplif linit in - let slbody = simplif lbody in - begin - try (* TODO: record all references variables *) - Lam_util.refine_let - ~kind:Variable v slinit - (Lam_pass_eliminate_ref.eliminate_ref v slbody) - with Lam_pass_eliminate_ref.Real_reference -> - Lam_util.refine_let - ~kind v (Lam.prim ~primitive ~args:[slinit] loc) - slbody - end - | Llet(Alias, v, l1, l2) -> - (* For alias, [l1] is pure, we can always inline, - when captured, we should avoid recomputation - *) - begin - match count_var v, l1 with - | {times = 0; _}, _ -> simplif l2 - | {times = 1; captured = false }, _ - | {times = 1; captured = true }, (Lconst _ | Lvar _) - | _, (Lconst - (( - Const_int _ | Const_char _ | Const_float _ - ) - | Const_pointer _ |Const_js_true | Const_js_false | Const_js_undefined) (* could be poly-variant [`A] -> [65a]*) - | Lprim {primitive = Pfield (_); - args = [ - Lglobal_module _ - ]} - ) - (* Const_int64 is no longer primitive - Note for some constant which is not - inlined, we can still record it and - do constant folding independently - *) - -> - Hash_ident.add subst v (simplif l1); simplif l2 - | _, Lconst (Const_string {s; unicode = false} ) -> - (* only "" added for later inlining *) - Hash_ident.add string_table v s; - Lam.let_ Alias v l1 (simplif l2) - (* we need move [simplif l2] later, since adding Hash does have side effect *) - | _ -> Lam.let_ Alias v (simplif l1) (simplif l2) - (* for Alias, in most cases [l1] is already simplified *) - end - | Llet(StrictOpt as kind, v, l1, lbody) -> - (* can not be inlined since [l1] depend on the store - {[ - let v = [|1;2;3|] - ]} - get [StrictOpt] here, we can not inline v, - since the value of [v] can be changed +let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = + let rec populateApplyInfo (args_arity : int list) (len : int) (fn : Lam.t) + (args : Lam.t list) ap_info : Lam.t = + match args_arity with + | 0 :: _ | [] -> Lam.apply (simpl fn) (Ext_list.map args simpl) ap_info + | x :: _ -> + if x = len then + Lam.apply (simpl fn) (Ext_list.map args simpl) + { ap_info with ap_status = App_infer_full } + else if x > len then + let fn = simpl fn in + let args = Ext_list.map args simpl in + Lam_eta_conversion.transform_under_supply (x - len) + { ap_info with ap_status = App_infer_full } + fn args + else + let first, rest = Ext_list.split_at args x in + Lam.apply + (Lam.apply (simpl fn) (Ext_list.map first simpl) + { ap_info with ap_status = App_infer_full }) + (Ext_list.map rest simpl) ap_info + (* TODO refien *) + and simpl (lam : Lam.t) = + match lam with + | Lconst _ -> lam + | Lvar _ -> lam + | Lapply { ap_func; ap_args; ap_info } -> + (* detect functor application *) + let args_arity = + Lam_arity.extract_arity (Lam_arity_analysis.get_arity meta ap_func) + in + let len = List.length ap_args in + populateApplyInfo args_arity len ap_func ap_args ap_info + | Llet (str, v, l1, l2) -> Lam.let_ str v (simpl l1) (simpl l2) + | Lletrec (bindings, body) -> + let bindings = Ext_list.map_snd bindings simpl in + Lam.letrec bindings (simpl body) + | Lglobal_module _ -> lam + | Lprim { primitive = Pjs_fn_make len as primitive; args = [ arg ]; loc } + -> ( + match + Lam_arity.get_first_arity (Lam_arity_analysis.get_arity meta arg) + with + | Some x -> + let arg = simpl arg in + Lam_eta_conversion.unsafe_adjust_to_arity loc ~to_:len ~from:x arg + | None -> Lam.prim ~primitive ~args:[ simpl arg ] loc) + | Lprim { primitive; args; loc } -> + Lam.prim ~primitive ~args:(Ext_list.map args simpl) loc + | Lfunction { arity; params; body; attr } -> + (* Lam_mk.lfunction kind params (simpl l) *) + Lam.function_ ~arity ~params ~body:(simpl body) ~attr + | Lswitch + ( l, + { + sw_failaction; + sw_consts; + sw_blocks; + sw_blocks_full; + sw_consts_full; + sw_names; + } ) -> + Lam.switch (simpl l) + { + sw_consts = Ext_list.map_snd sw_consts simpl; + sw_blocks = Ext_list.map_snd sw_blocks simpl; + sw_consts_full; + sw_blocks_full; + sw_failaction = Ext_option.map sw_failaction simpl; + sw_names; + } + | Lstringswitch (l, sw, d) -> + Lam.stringswitch (simpl l) + (Ext_list.map_snd sw simpl) + (Ext_option.map d simpl) + | Lstaticraise (i, ls) -> Lam.staticraise i (Ext_list.map ls simpl) + | Lstaticcatch (l1, ids, l2) -> Lam.staticcatch (simpl l1) ids (simpl l2) + | Ltrywith (l1, v, l2) -> Lam.try_ (simpl l1) v (simpl l2) + | Lifthenelse (l1, l2, l3) -> Lam.if_ (simpl l1) (simpl l2) (simpl l3) + | Lsequence (l1, l2) -> Lam.seq (simpl l1) (simpl l2) + | Lwhile (l1, l2) -> Lam.while_ (simpl l1) (simpl l2) + | Lfor (flag, l1, l2, dir, l3) -> + Lam.for_ flag (simpl l1) (simpl l2) dir (simpl l3) + | Lassign (v, l) -> + (* Lalias-bound variables are never assigned, so don't increase + v's refsimpl *) + Lam.assign v (simpl l) + in - GPR #1476 - Note to pass the sanitizer, we do need remove dead code (not just best effort) - This logic is tied to {!Lam_pass_count.count} - {[ - if kind = Strict || used v then count bv l1 - ]} - If the code which should be removed is not removed, it will hold references - to other variables which is already removed. - *) - if not (used v) - then simplif lbody (* GPR #1476 *) - else - begin match l1 with - | (Lprim {primitive = (Pmakeblock(0, _, Mutable) - as primitive); - args = [linit] ; loc}) - -> - let slinit = simplif linit in - let slbody = simplif lbody in - begin - try (* TODO: record all references variables *) - Lam_util.refine_let - ~kind:Variable v slinit - (Lam_pass_eliminate_ref.eliminate_ref v slbody) - with Lam_pass_eliminate_ref.Real_reference -> - Lam_util.refine_let - ~kind v (Lam.prim ~primitive ~args:[slinit] loc) - slbody - end + simpl lam - | _ -> - let l1 = simplif l1 in - begin match l1 with - | Lconst(Const_string { s; unicode = false }) -> - Hash_ident.add string_table v s; - (* we need move [simplif lbody] later, since adding Hash does have side effect *) - Lam.let_ Alias v l1 (simplif lbody) - | _ -> - Lam_util.refine_let ~kind v l1 (simplif lbody) - end - end - (* TODO: check if it is correct rollback to [StrictOpt]? *) +end +module Lam_pass_collect : sig +#1 "lam_pass_collect.mli" +(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. + * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - | Llet((Strict | Variable as kind), v, l1, l2) -> - if not (used v) - then - let l1 = simplif l1 in - let l2 = simplif l2 in - if Lam_analysis.no_side_effects l1 - then l2 - else Lam.seq l1 l2 - else - let l1 = (simplif l1) in +(** This pass is used to collect meta data information. - begin match kind, l1 with - | Strict, Lconst((Const_string { s; unicode = false })) - -> - Hash_ident.add string_table v s; - Lam.let_ Alias v l1 (simplif l2) - | _ -> - Lam_util.refine_let ~kind v l1 (simplif l2) - end - | Lsequence(l1, l2) -> Lam.seq (simplif l1) (simplif l2) + It includes: + alias table, arity for identifiers and might more information, - | Lapply{ap_func = Lfunction{params; body}; ap_args = args; _} - when Ext_list.same_length params args -> - simplif (Lam_beta_reduce.no_names_beta_reduce params body args) - (* | Lapply{ fn = Lfunction{function_kind = Tupled; params; body}; *) - (* args = [Lprim {primitive = Pmakeblock _; args; _}]; _} *) - (* (\** TODO: keep track of this parameter in ocaml trunk, *) - (* can we switch to the tupled backend? *) - (* *\) *) - (* when Ext_list.same_length params args -> *) - (* simplif (Lam_beta_reduce.beta_reduce params body args) *) + ATTENTION: + For later pass to keep its information complete and up to date, + we need update its table accordingly - | Lapply{ap_func = l1; ap_args = ll; ap_info} -> - Lam.apply (simplif l1) (Ext_list.map ll simplif) ap_info - | Lfunction{arity; params; body; attr} -> - Lam.function_ ~arity ~params ~body:(simplif body) ~attr - | Lconst _ -> lam - | Lletrec(bindings, body) -> - Lam.letrec - (Ext_list.map_snd bindings simplif) - (simplif body) - | Lprim {primitive=Pstringadd; args = [l;r]; loc } -> - begin - let l' = simplif l in - let r' = simplif r in - let opt_l = - match l' with - | Lconst(Const_string { s = ls; unicode = false }) -> Some ls - | Lvar i -> Hash_ident.find_opt string_table i - | _ -> None in - match opt_l with - | None -> Lam.prim ~primitive:Pstringadd ~args:[l';r'] loc - | Some l_s -> - let opt_r = - match r' with - | Lconst (Const_string {s = rs; unicode = false}) -> Some rs - | Lvar i -> Hash_ident.find_opt string_table i - | _ -> None in - begin match opt_r with - | None -> Lam.prim ~primitive:Pstringadd ~args:[l';r'] loc - | Some r_s -> - Lam.const (Const_string { s = l_s^r_s; unicode = false }) - end - end + - Alias inference is not for substitution, it is for analyze which module is + actually a global module or an exception, so it can be relaxed a bit + (without relying on strict analysis) - | Lprim {primitive = (Pstringrefu|Pstringrefs) as primitive ; - args = [l;r] ; loc - } -> (* TODO: introudce new constant *) - let l' = simplif l in - let r' = simplif r in - let opt_l = - match l' with - | Lconst (Const_string { s = ls; unicode = false }) -> - Some ls - | Lvar i -> Hash_ident.find_opt string_table i - | _ -> None in - begin match opt_l with - | None -> Lam.prim ~primitive ~args:[l';r'] loc - | Some l_s -> - match r with - |Lconst((Const_int {i})) -> - let i = Int32.to_int i in - if i < String.length l_s && i >= 0 then - Lam.const ((Const_char (Char.code l_s.[i]))) - else - Lam.prim ~primitive ~args:[l';r'] loc - | _ -> - Lam.prim ~primitive ~args:[l';r'] loc - end - | Lglobal_module _ -> lam - | Lprim {primitive; args; loc} - -> Lam.prim ~primitive ~args:(Ext_list.map args simplif) loc - | Lswitch(l, sw) -> - let new_l = simplif l - and new_consts = Ext_list.map_snd sw.sw_consts simplif - and new_blocks = Ext_list.map_snd sw.sw_blocks simplif - and new_fail = Ext_option.map sw.sw_failaction simplif - in - Lam.switch - new_l - {sw with sw_consts = new_consts ; sw_blocks = new_blocks; - sw_failaction = new_fail} - | Lstringswitch (l,sw,d) -> - Lam.stringswitch - (simplif l) (Ext_list.map_snd sw simplif) - (Ext_option.map d simplif) - | Lstaticraise (i,ls) -> - Lam.staticraise i (Ext_list.map ls simplif) - | Lstaticcatch(l1, (i,args), l2) -> - Lam.staticcatch (simplif l1) (i,args) (simplif l2) - | Ltrywith(l1, v, l2) -> Lam.try_ (simplif l1) v (simplif l2) - | Lifthenelse(l1, l2, l3) -> - Lam.if_ (simplif l1) (simplif l2) (simplif l3) - | Lwhile(l1, l2) - -> - Lam.while_ (simplif l1) (simplif l2) - | Lfor(v, l1, l2, dir, l3) -> - Lam.for_ v (simplif l1) (simplif l2) dir (simplif l3) - | Lassign(v, l) -> Lam.assign v (simplif l) - in simplif lam + - Js object (local) analysis + Design choice: -(* To transform let-bound references into variables *) -let apply_lets occ lambda = - let count_var v = - match - Hash_ident.find_opt occ v - with - | None -> Lam_pass_count.dummy_info () - | Some v -> v in - lets_helper count_var lambda + Side effectful operations: + - Lassign + - Psetfield -let simplify_lets (lam : Lam.t) : Lam.t = - let occ = Lam_pass_count.collect_occurs lam in + 1. What information should be collected: - apply_lets occ lam + 2. What's the key + If it's identifier, -end -module Lam_pass_remove_alias : sig -#1 "lam_pass_remove_alias.mli" + Information that is always sound, not subject to change + + - shall we collect that if an identifier is passed as a parameter, (useful for escape analysis), + however, since it's going to change after inlning (for local function) + + - function arity, subject to change when you make it a mutable ref and change it later + + - Immutable blocks of identifiers + + if identifier itself is function/non block then the access can be inlined + if identifier itself is immutable block can be inlined + if identifier is mutable block can be inlined (without Lassign) since + + - When collect some information, shall we propogate this information to + all alias table immeidately + + - annotation identifiers (at first time) + - +*) + +val collect_info : Lam_stats.t -> Lam.t -> unit +(** Modify existing [meta] *) + +end = struct +#1 "lam_pass_collect.ml" (* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript * This program is free software: you can redistribute it and/or modify @@ -273809,24 +273610,149 @@ module Lam_pass_remove_alias : sig * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -(** Keep track of the global module Aliases *) - +(* Check, it is shared across ident_tbl, + Only [Lassign] will break such invariant, + how about guarantee that [Lassign] only check the local ref + and we track which ids are [Lassign]ed +*) (** - One way: guarantee that all global aliases *would be removed* , - it will not be aliased + might not be the same due to refinement + assert (old.arity = v) +*) +let annotate (meta : Lam_stats.t) rec_flag (k : Ident.t) (arity : Lam_arity.t) + lambda = + Hash_ident.add meta.ident_tbl k + (FunctionId { arity; lambda = Some (lambda, rec_flag) }) +(* see #3609 + we have to update since bounded function lambda + may contain stale unbounded varaibles +*) +(* match Hash_ident.find_opt meta.ident_tbl k with + | None -> (** FIXME: need do a sanity check of arity is NA or Determin(_,[],_) *) - So the only remaining place for globals is either - just Pgetglobal in functor application or - `Lprim (Pfield( i ), [Pgetglobal])` + | Some (FunctionId old) -> + Hash_ident.add meta.ident_tbl k + (FunctionId {arity; lambda = Some (lambda, rec_flag) }) + (* old.arity <- arity *) + (* due to we keep refining arity analysis after each round*) + | _ -> assert false *) +(* TODO -- avoid exception *) - This pass does not change meta data +(** it only make senses recording arities for + function definition, + alias propgation - and toplevel identifiers, this needs to be exported *) +let collect_info (meta : Lam_stats.t) (lam : Lam.t) = + let rec collect_bind rec_flag (ident : Ident.t) (lam : Lam.t) = + match lam with + | Lconst v -> Hash_ident.replace meta.ident_tbl ident (Constant v) + | Lprim { primitive = Pmakeblock (_, _, Immutable); args = ls } -> + Hash_ident.replace meta.ident_tbl ident + (Lam_util.kind_of_lambda_block ls); + List.iter collect ls + | Lprim { primitive = Psome | Psome_not_nest; args = [ v ] } -> + Hash_ident.replace meta.ident_tbl ident (Normal_optional v); + collect v + | Lprim + { + primitive = Praw_js_code { code_info = Exp (Js_function { arity }) }; + args = _; + } -> + Hash_ident.replace meta.ident_tbl ident + (FunctionId { arity = Lam_arity.info [ arity ] false; lambda = None }) + | Lprim { primitive = Pnull_to_opt; args = [ (Lvar _ as l) ]; _ } -> + Hash_ident.replace meta.ident_tbl ident (OptionalBlock (l, Null)) + | Lprim { primitive = Pundefined_to_opt; args = [ (Lvar _ as l) ]; _ } -> + Hash_ident.replace meta.ident_tbl ident (OptionalBlock (l, Undefined)) + | Lprim { primitive = Pnull_undefined_to_opt; args = [ (Lvar _ as l) ] } -> + Hash_ident.replace meta.ident_tbl ident + (OptionalBlock (l, Null_undefined)) + | Lglobal_module v -> Lam_util.alias_ident_or_global meta ident v (Module v) + | Lvar v -> + (* if Ident.global v then *) + Lam_util.alias_ident_or_global meta ident v NA + (* enven for not subsitution, it still propogate some properties *) + (* else () *) + | Lfunction { params; body } + (* TODO record parameters ident ?, but it will be broken after inlining *) + -> + (* TODO could be optimized in one pass? + -- since collect would iter everywhere, + so -- it would still iterate internally + *) + Ext_list.iter params (fun p -> + Hash_ident.add meta.ident_tbl p Parameter); + let arity = Lam_arity_analysis.get_arity meta lam in + annotate meta rec_flag ident arity lam; + collect body + | x -> + collect x; + if Set_ident.mem meta.export_idents ident then + annotate meta rec_flag ident (Lam_arity_analysis.get_arity meta x) lam + and collect (lam : Lam.t) = + match lam with + | Lconst _ -> () + | Lvar _ -> () + | Lapply { ap_func = l1; ap_args = ll; _ } -> + collect l1; + List.iter collect ll + | Lfunction { params; body = l } -> + (* functor ? *) + List.iter (fun p -> Hash_ident.add meta.ident_tbl p Parameter) params; + collect l + | Llet (_kind, ident, arg, body) -> + collect_bind Lam_non_rec ident arg; + collect body + | Lletrec (bindings, body) -> + (match bindings with + | [ (ident, arg) ] -> collect_bind Lam_self_rec ident arg + | _ -> + Ext_list.iter bindings (fun (ident, arg) -> + collect_bind Lam_rec ident arg)); + collect body + | Lglobal_module _ -> () + | Lprim { args; _ } -> List.iter collect args + | Lswitch (l, { sw_failaction; sw_consts; sw_blocks }) -> + collect l; + Ext_list.iter_snd sw_consts collect; + Ext_list.iter_snd sw_blocks collect; + Ext_option.iter sw_failaction collect + | Lstringswitch (l, sw, d) -> + collect l; + Ext_list.iter_snd sw collect; + Ext_option.iter d collect + | Lstaticraise (_code, ls) -> List.iter collect ls + | Lstaticcatch (l1, (_, _), l2) -> + collect l1; + collect l2 + | Ltrywith (l1, _, l2) -> + collect l1; + collect l2 + | Lifthenelse (l1, l2, l3) -> + collect l1; + collect l2; + collect l3 + | Lsequence (l1, l2) -> + collect l1; + collect l2 + | Lwhile (l1, l2) -> + collect l1; + collect l2 + | Lfor (_, l1, l2, _dir, l3) -> + collect l1; + collect l2; + collect l3 + | Lassign (_v, l) -> + (* Lalias-bound variables are never assigned, so don't increase + v's refcollect *) + collect l + in + collect lam -val simplify_alias : Lam_stats.t -> Lam.t -> Lam.t - -end = struct -#1 "lam_pass_remove_alias.ml" -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. +end +module Lam_pass_deep_flatten : sig +#1 "lam_pass_deep_flatten.mli" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by @@ -273850,209 +273776,247 @@ end = struct * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type outcome = Eval_false | Eval_true | Eval_unknown +val deep_flatten : Lam.t -> Lam.t + +end = struct +#1 "lam_pass_deep_flatten.ml" +(* Copyright (C) 2015- Hongbo Zhang, Authors of ReScript + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +(* type eliminate = + | Not_eliminatable + | *) + +let rec eliminate_tuple (id : Ident.t) (lam : Lam.t) acc = + match lam with + | Llet + (Alias, v, Lprim { primitive = Pfield (i, _); args = [ Lvar tuple ] }, e2) + when Ident.same tuple id -> + eliminate_tuple id e2 (Map_int.add acc i v) + (* it is okay to have duplicates*) + | _ -> if Lam_hit.hit_variable id lam then None else Some (acc, lam) +(* [groups] are in reverse order *) + +(* be careful to flatten letrec + like below : + {[ + let rec even = + let odd n = if n ==1 then true else even (n - 1) in + fun n -> if n ==0 then true else odd (n - 1) + ]} + odd and even are recursive values, since all definitions inside + e.g, [odd] can see [even] now, however, it should be fine + in our case? since ocaml's recursive value does not allow immediate + access its value direclty?, seems no + {[ + let rec even2 = + let odd = even2 in + fun n -> if n ==0 then true else odd (n - 1) + ]} +*) +(* FIXME: + here we try to move inner definitions of [recurisve value] upwards + for example: + {[ + let rec x = + let y = 32 in + y :: x + and z = .. + --- + le ty = 32 in + let rec x = y::x + and z = .. + ]} + however, the inner definitions can see [z] and [x], so we + can not blindly move it in the beginning, however, for + recursive value, ocaml does not allow immediate access to + recursive value, so what's the best strategy? + --- + the motivation is to capture real tail call +*) +(* | Single ((Alias | Strict | StrictOpt), id, ( Lfunction _ )) -> + (** FIXME: + It should be alias and alias will be optimized away + in later optmizations, however, + this means if we don't optimize + {[ let u/a = v in ..]} + the output would be wrong, we should *optimize + this away right now* instead of delaying it to the + later passes + *) + (acc, set, g :: wrap, stop) +*) +(* could also be from nested [let rec] + like + {[ + let rec x = + let rec y = 1 :: y in + 2:: List.hd y:: x + ]} + TODO: seems like we should update depenency graph, +*) + +(* Printlambda.lambda Format.err_formatter lam ; assert false *) -let id_is_for_sure_true_in_boolean (tbl : Lam_stats.ident_tbl) id = - match Hash_ident.find_opt tbl id with - | Some (ImmutableBlock _) - | Some (Normal_optional _) - | Some (MutableBlock _) - | Some (Constant (Const_block _ | Const_js_true)) -> - Eval_true - | Some (Constant (Const_int { i })) -> - if i = 0l then Eval_false else Eval_true - | Some (Constant (Const_js_false | Const_js_null | Const_js_undefined)) -> - Eval_false - | Some - ( Constant _ | Module _ | FunctionId _ | Exception | Parameter | NA - | OptionalBlock (_, (Undefined | Null | Null_undefined)) ) - | None -> - Eval_unknown +(** TODO: more flattening, + - also for function compilation, flattening should be done first + - [compile_group] and [compile] become mutually recursive function + *) +let lambda_of_groups ~(rev_bindings : Lam_group.t list) (result : Lam.t) : Lam.t + = + Ext_list.fold_left rev_bindings result (fun acc x -> + match x with + | Nop l -> Lam.seq l acc + | Single (kind, ident, lam) -> Lam_util.refine_let ~kind ident lam acc + | Recursive bindings -> Lam.letrec bindings acc) -let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = - let rec simpl (lam : Lam.t) : Lam.t = +(* TODO: + refine effectful [ket_kind] to be pure or not + Be careful of how [Lifused(v,l)] work + since its semantics depend on whether v is used or not + return value are in reverse order, but handled by [lambda_of_groups] +*) +let deep_flatten (lam : Lam.t) : Lam.t = + let rec flatten (acc : Lam_group.t list) (lam : Lam.t) : + Lam.t * Lam_group.t list = + match lam with + | Llet + ( str, + id, + (Lprim + { + primitive = + Pnull_to_opt | Pundefined_to_opt | Pnull_undefined_to_opt; + args = [ Lvar _ ]; + } as arg), + body ) -> + flatten (Single (str, id, aux arg) :: acc) body + | Llet + ( str, + id, + Lprim + { + primitive = + (Pnull_to_opt | Pundefined_to_opt | Pnull_undefined_to_opt) as + primitive; + args = [ arg ]; + }, + body ) -> + let newId = Ident.rename id in + flatten acc + (Lam.let_ str newId arg + (Lam.let_ Alias id + (Lam.prim ~primitive ~args:[ Lam.var newId ] + Location.none (* FIXME*)) + body)) + | Llet (str, id, arg, body) -> ( + (* + {[ let match = (a,b,c) + let d = (match/1) + let e = (match/2) + .. + ]} + *) + let res, accux = flatten acc arg in + match (id.name, str, res) with + | ( ("match" | "include" | "param"), + (Alias | Strict | StrictOpt), + Lprim { primitive = Pmakeblock (_, _, Immutable); args } ) -> ( + match eliminate_tuple id body Map_int.empty with + | Some (tuple_mapping, body) -> + flatten + (Ext_list.fold_left_with_offset args accux 0 (fun arg acc i -> + match Map_int.find_opt tuple_mapping i with + | None -> Lam_group.nop_cons arg acc + | Some key -> Lam_group.single str key arg :: acc)) + body + | None -> flatten (Single (str, id, res) :: accux) body) + | _ -> flatten (Single (str, id, res) :: accux) body) + | Lletrec (bind_args, body) -> + flatten (Recursive (Ext_list.map_snd bind_args aux) :: acc) body + | Lsequence (l, r) -> + let res, l = flatten acc l in + flatten (Lam_group.nop_cons res l) r + | x -> (aux x, acc) + and aux (lam : Lam.t) : Lam.t = match lam with + | Llet _ -> + let res, groups = flatten [] lam in + lambda_of_groups res ~rev_bindings:groups + | Lletrec (bind_args, body) -> + (* Attention: don't mess up with internal {let rec} *) + let rec iter bind_args groups set = + match bind_args with + | [] -> (List.rev groups, set) + | (id, arg) :: rest -> + iter rest ((id, aux arg) :: groups) (Set_ident.add set id) + in + let groups, collections = iter bind_args [] Set_ident.empty in + (* Try to extract some value definitions from recursive values as [wrap], + it will stop whenever it find it could not move forward + {[ + let rec x = + let y = 1 in + let z = 2 in + ... + ]} + *) + let rev_bindings, rev_wrap, _ = + Ext_list.fold_left groups ([], [], false) + (fun (inner_recursive_bindings, wrap, stop) (id, lam) -> + if stop || Lam_hit.hit_variables collections lam then + ((id, lam) :: inner_recursive_bindings, wrap, true) + else + ( inner_recursive_bindings, + Lam_group.Single (Strict, id, lam) :: wrap, + false )) + in + lambda_of_groups + ~rev_bindings: + rev_wrap (* These bindings are extracted from [letrec] *) + (Lam.letrec (List.rev rev_bindings) (aux body)) + | Lsequence (l, r) -> Lam.seq (aux l) (aux r) + | Lconst _ -> lam | Lvar _ -> lam - | Lprim { primitive = Pfield (i, info) as primitive; args = [ arg ]; loc } - -> ( - (* ATTENTION: - Main use case, we should detect inline all immutable block .. *) - match simpl arg with - | Lvar v as l -> - Lam_util.field_flatten_get - (fun _ -> Lam.prim ~primitive ~args:[ l ] loc) - v i info meta.ident_tbl - | l -> Lam.prim ~primitive ~args:[ l ] loc) - | Lprim - { - primitive = (Pval_from_option | Pval_from_option_not_nest) as p; - args = [ (Lvar v as lvar) ]; - } as x -> ( - match Hash_ident.find_opt meta.ident_tbl v with - | Some (OptionalBlock (l, _)) -> l - | _ -> if p = Pval_from_option_not_nest then lvar else x) + (* | Lapply(Lfunction(Curried, params, body), args, _) *) + (* when List.length params = List.length args -> *) + (* aux (beta_reduce params body args) *) + (* | Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock _, args)], _) *) + (* (\** TODO: keep track of this parameter in ocaml trunk, *) + (* can we switch to the tupled backend? *\) *) + (* when List.length params = List.length args -> *) + (* aux (beta_reduce params body args) *) + | Lapply { ap_func = l1; ap_args = ll; ap_info } -> + Lam.apply (aux l1) (Ext_list.map ll aux) ap_info + (* This kind of simple optimizations should be done each time + and as early as possible *) | Lglobal_module _ -> lam | Lprim { primitive; args; loc } -> - Lam.prim ~primitive ~args:(Ext_list.map args simpl) loc - | Lifthenelse - ((Lprim { primitive = Pis_not_none; args = [ Lvar id ] } as l1), l2, l3) - -> ( - match Hash_ident.find_opt meta.ident_tbl id with - | Some (ImmutableBlock _ | MutableBlock _ | Normal_optional _) -> - simpl l2 - | Some (OptionalBlock (l, Null)) -> - Lam.if_ - (Lam.not_ Location.none - (Lam.prim ~primitive:Pis_null ~args:[ l ] Location.none)) - (simpl l2) (simpl l3) - | Some (OptionalBlock (l, Undefined)) -> - Lam.if_ - (Lam.not_ Location.none - (Lam.prim ~primitive:Pis_undefined ~args:[ l ] Location.none)) - (simpl l2) (simpl l3) - | Some (OptionalBlock (l, Null_undefined)) -> - Lam.if_ - (Lam.not_ Location.none - (Lam.prim ~primitive:Pis_null_undefined ~args:[ l ] - Location.none)) - (simpl l2) (simpl l3) - | Some _ | None -> Lam.if_ l1 (simpl l2) (simpl l3)) - (* could be the code path - {[ match x with - | h::hs -> - ]} - *) - | Lifthenelse (l1, l2, l3) -> ( - match l1 with - | Lvar id -> ( - match id_is_for_sure_true_in_boolean meta.ident_tbl id with - | Eval_true -> simpl l2 - | Eval_false -> simpl l3 - | Eval_unknown -> Lam.if_ (simpl l1) (simpl l2) (simpl l3)) - | _ -> Lam.if_ (simpl l1) (simpl l2) (simpl l3)) - | Lconst _ -> lam - | Llet (str, v, l1, l2) -> Lam.let_ str v (simpl l1) (simpl l2) - | Lletrec (bindings, body) -> - let bindings = Ext_list.map_snd bindings simpl in - Lam.letrec bindings (simpl body) - (* complicated - 1. inline this function - 2. ... - exports.Make= - function(funarg) - {var $$let=Make(funarg); - return [0, $$let[5],... $$let[16]]} - *) - | Lapply - { - ap_func = - Lprim - { - primitive = Pfield (_, Fld_module { name = fld_name }); - args = [ Lglobal_module ident ]; - _; - } as l1; - ap_args = args; - ap_info; - } -> ( - match Lam_compile_env.query_external_id_info ident fld_name with - | { persistent_closed_lambda = Some (Lfunction { params; body; _ }) } - (* be more cautious when do cross module inlining *) - when Ext_list.same_length params args - && Ext_list.for_all args (fun arg -> - match arg with - | Lvar p -> ( - match Hash_ident.find_opt meta.ident_tbl p with - | Some v -> v <> Parameter - | None -> true) - | _ -> true) -> - simpl (Lam_beta_reduce.propogate_beta_reduce meta params body args) - | _ -> Lam.apply (simpl l1) (Ext_list.map args simpl) ap_info) - (* Function inlining interact with other optimizations... - - - parameter attributes - - scope issues - - code bloat - *) - | Lapply { ap_func = Lvar v as fn; ap_args; ap_info } -> ( - (* Check info for always inlining *) - - (* Ext_log.dwarn __LOC__ "%s/%d" v.name v.stamp; *) - let ap_args = Ext_list.map ap_args simpl in - let[@local] normal () = Lam.apply (simpl fn) ap_args ap_info in - match Hash_ident.find_opt meta.ident_tbl v with - | Some - (FunctionId - { - lambda = - Some - ( Lfunction ({ params; body; attr = { is_a_functor } } as m), - rec_flag ); - }) -> - if Ext_list.same_length ap_args params (* && false *) then - if - is_a_functor - (* && (Set_ident.mem v meta.export_idents) && false *) - then - (* TODO: check l1 if it is exported, - if so, maybe not since in that case, - we are going to have two copy? - *) - - (* Check: recursive applying may result in non-termination *) - (* Ext_log.dwarn __LOC__ "beta .. %s/%d" v.name v.stamp ; *) - simpl - (Lam_beta_reduce.propogate_beta_reduce meta params body - ap_args) - else if - (* Lam_analysis.size body < Lam_analysis.small_inline_size *) - (* ap_inlined = Always_inline || *) - Lam_analysis.ok_to_inline_fun_when_app m ap_args - then - (* let param_map = *) - (* Lam_analysis.free_variables meta.export_idents *) - (* (Lam_analysis.param_map_of_list params) body in *) - (* let old_count = List.length params in *) - (* let new_count = Map_ident.cardinal param_map in *) - let param_map = - Lam_closure.is_closed_with_map meta.export_idents params body - in - let is_export_id = Set_ident.mem meta.export_idents v in - match (is_export_id, param_map) with - | false, (_, param_map) | true, (true, param_map) -> ( - match rec_flag with - | Lam_rec -> - Lam_beta_reduce.propogate_beta_reduce_with_map meta - param_map params body ap_args - | Lam_self_rec -> normal () - | Lam_non_rec -> - if - Ext_list.exists ap_args (fun lam -> - Lam_hit.hit_variable v lam) - (*avoid nontermination, e.g, `g(g)`*) - then normal () - else - simpl - (Lam_beta_reduce.propogate_beta_reduce_with_map meta - param_map params body ap_args)) - | _ -> normal () - else normal () - else normal () - | Some _ | None -> normal ()) - | Lapply { ap_func = Lfunction { params; body }; ap_args = args; _ } - when Ext_list.same_length params args -> - simpl (Lam_beta_reduce.propogate_beta_reduce meta params body args) - (* | Lapply{ fn = Lfunction{function_kind = Tupled; params; body}; *) - (* args = [Lprim {primitive = Pmakeblock _; args; _}]; _} *) - (* (\** TODO: keep track of this parameter in ocaml trunk, *) - (* can we switch to the tupled backend? *) - (* *\) *) - (* when Ext_list.same_length params args -> *) - (* simpl (Lam_beta_reduce.propogate_beta_reduce meta params body args) *) - | Lapply { ap_func = l1; ap_args = ll; ap_info } -> - Lam.apply (simpl l1) (Ext_list.map ll simpl) ap_info + let args = Ext_list.map args aux in + Lam.prim ~primitive ~args loc | Lfunction { arity; params; body; attr } -> - Lam.function_ ~arity ~params ~body:(simpl body) ~attr + Lam.function_ ~arity ~params ~body:(aux body) ~attr | Lswitch ( l, { @@ -274063,44 +274027,37 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = sw_consts_full; sw_names; } ) -> - Lam.switch (simpl l) + Lam.switch (aux l) { - sw_consts = Ext_list.map_snd sw_consts simpl; - sw_blocks = Ext_list.map_snd sw_blocks simpl; + sw_consts = Ext_list.map_snd sw_consts aux; + sw_blocks = Ext_list.map_snd sw_blocks aux; sw_consts_full; sw_blocks_full; - sw_failaction = Ext_option.map sw_failaction simpl; + sw_failaction = Ext_option.map sw_failaction aux; sw_names; } | Lstringswitch (l, sw, d) -> - let l = - match l with - | Lvar s -> ( - match Hash_ident.find_opt meta.ident_tbl s with - | Some (Constant s) -> Lam.const s - | Some _ | None -> simpl l) - | _ -> simpl l - in - Lam.stringswitch l (Ext_list.map_snd sw simpl) (Ext_option.map d simpl) - | Lstaticraise (i, ls) -> Lam.staticraise i (Ext_list.map ls simpl) - | Lstaticcatch (l1, ids, l2) -> Lam.staticcatch (simpl l1) ids (simpl l2) - | Ltrywith (l1, v, l2) -> Lam.try_ (simpl l1) v (simpl l2) - | Lsequence (l1, l2) -> Lam.seq (simpl l1) (simpl l2) - | Lwhile (l1, l2) -> Lam.while_ (simpl l1) (simpl l2) + Lam.stringswitch (aux l) (Ext_list.map_snd sw aux) + (Ext_option.map d aux) + | Lstaticraise (i, ls) -> Lam.staticraise i (Ext_list.map ls aux) + | Lstaticcatch (l1, ids, l2) -> Lam.staticcatch (aux l1) ids (aux l2) + | Ltrywith (l1, v, l2) -> Lam.try_ (aux l1) v (aux l2) + | Lifthenelse (l1, l2, l3) -> Lam.if_ (aux l1) (aux l2) (aux l3) + | Lwhile (l1, l2) -> Lam.while_ (aux l1) (aux l2) | Lfor (flag, l1, l2, dir, l3) -> - Lam.for_ flag (simpl l1) (simpl l2) dir (simpl l3) + Lam.for_ flag (aux l1) (aux l2) dir (aux l3) | Lassign (v, l) -> (* Lalias-bound variables are never assigned, so don't increase - v's refsimpl *) - Lam.assign v (simpl l) + v's refaux *) + Lam.assign v (aux l) in - simpl lam + aux lam end -module Ext_log : sig -#1 "ext_log.mli" -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * +module Lam_exit_count : sig +#1 "lam_exit_count.mli" +(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -274118,27 +274075,21 @@ module Ext_log : sig * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -(** A Poor man's logging utility - - Example: - {[ - err __LOC__ "xx" - ]} -*) +type collection -type 'a logging = ('a, Format.formatter, unit, unit, unit, unit) format6 -> 'a +val count_helper : Lam.t -> collection -val dwarn : ?__POS__:string * int * int * int -> 'a logging +val count_exit : collection -> int -> int end = struct -#1 "ext_log.ml" -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * +#1 "lam_exit_count.ml" +(* Copyright (C) 2018 Hongbo Zhang, Authors of ReScript + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -274156,29 +274107,103 @@ end = struct * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type 'a logging = ('a, Format.formatter, unit, unit, unit, unit) format6 -> 'a +type collection = int Hash_int.t -(* TODO: add {[@.]} later for all *) -let dwarn ?(__POS__ : (string * int * int * int) option) f = - if Js_config.get_diagnose () then - match __POS__ with - | None -> Format.fprintf Format.err_formatter ("WARN: " ^^ f ^^ "@.") - | Some (file, line, _, _) -> - Format.fprintf Format.err_formatter - ("WARN: %s,%d " ^^ f ^^ "@.") - file line - else Format.ifprintf Format.err_formatter ("WARN: " ^^ f ^^ "@.") +(* Count occurrences of (exit n ...) statements *) +let count_exit (exits : collection) i = Hash_int.find_default exits i 0 + +let incr_exit (exits : collection) i = + Hash_int.add_or_update exits i 1 ~update:succ + +(** + This funcition counts how each [exit] is used, it will affect how the following optimizations performed. + + Some smart cases (this requires the following optimizations follow it): + + {[ + Lstaticcatch(l1, (i,_), l2) + ]} + If [l1] does not contain [(exit i)], + [l2] will be removed, so don't count it. + + About Switch default branch handling, it maybe backend-specific + See https://github.com/ocaml/ocaml/commit/fcf3571123e2c914768e34f1bd17e4cbaaa7d212#diff-704f66c0fa0fc9339230b39ce7d90919 + For Lstringswitch ^ + + For Lswitch, if it is not exhuastive pattern match, default will be counted twice. + Since for pattern match, we will test whether it is an integer or block, both have default cases predicate: [sw_consts_full] vs nconsts +*) +let count_helper (lam : Lam.t) : collection = + let exits : collection = Hash_int.create 17 in + let rec count (lam : Lam.t) = + match lam with + | Lstaticraise (i, ls) -> + incr_exit exits i; + Ext_list.iter ls count + | Lstaticcatch (l1, (i, _), l2) -> + count l1; + if count_exit exits i > 0 then count l2 + | Lstringswitch (l, sw, d) -> + count l; + Ext_list.iter_snd sw count; + Ext_option.iter d count + | Lglobal_module _ | Lvar _ | Lconst _ -> () + | Lapply { ap_func; ap_args; _ } -> + count ap_func; + Ext_list.iter ap_args count + | Lfunction { body } -> count body + | Llet (_, _, l1, l2) -> + count l2; + count l1 + | Lletrec (bindings, body) -> + Ext_list.iter_snd bindings count; + count body + | Lprim { args; _ } -> List.iter count args + | Lswitch (l, sw) -> + count_default sw; + count l; + Ext_list.iter_snd sw.sw_consts count; + Ext_list.iter_snd sw.sw_blocks count + | Ltrywith (l1, _v, l2) -> + count l1; + count l2 + | Lifthenelse (l1, l2, l3) -> + count l1; + count l2; + count l3 + | Lsequence (l1, l2) -> + count l1; + count l2 + | Lwhile (l1, l2) -> + count l1; + count l2 + | Lfor (_, l1, l2, _dir, l3) -> + count l1; + count l2; + count l3 + | Lassign (_, l) -> count l + and count_default sw = + match sw.sw_failaction with + | None -> () + | Some al -> + if (not sw.sw_consts_full) && not sw.sw_blocks_full then ( + count al; + count al) + else count al + in + count lam; + exits end -module Lam_stats_export : sig -#1 "lam_stats_export.mli" -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript +module Lam_subst : sig +#1 "lam_subst.mli" +(* Copyright (C) 2017 Authors of ReScript + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -274201,20 +274226,18 @@ module Lam_stats_export : sig * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val get_dependent_module_effect : - string option -> Lam_module_ident.t list -> string option - -val export_to_cmj : - Lam_stats.t -> - Js_cmj_format.effect -> - Lam.t Map_ident.t -> - Ext_js_file_kind.case -> - Js_cmj_format.t +(* Apply a substitution to a lambda-term. + Assumes that the bound variables of the lambda-term do not + belong to the domain of the substitution. + Assumes that the image of the substitution is out of reach + of the bound variables of the lambda-term (no capture). *) + +val subst : Lam.t Map_ident.t -> Lam.t -> Lam.t end = struct -#1 "lam_stats_export.ml" -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript +#1 "lam_subst.ml" +(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -274237,165 +274260,566 @@ end = struct * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -(* let pp = Format.fprintf *) -(* we should exclude meaninglist names and do the convert as well *) +(* Apply a substitution to a lambda-term. + Assumes that the bound variables of the lambda-term do not + belong to the domain of the substitution. + Assumes that the image of the substitution is out of reach + of the bound variables of the lambda-term (no capture). *) -(* let meaningless_names = ["*opt*"; "param";] *) +let subst (s : Lam.t Map_ident.t) lam = + let rec subst_aux (x : Lam.t) : Lam.t = + match x with + | Lvar id -> Map_ident.find_default s id x + | Lconst _ -> x + | Lapply { ap_func; ap_args; ap_info } -> + Lam.apply (subst_aux ap_func) (Ext_list.map ap_args subst_aux) ap_info + | Lfunction { arity; params; body; attr } -> + Lam.function_ ~arity ~params ~body:(subst_aux body) ~attr + | Llet (str, id, arg, body) -> + Lam.let_ str id (subst_aux arg) (subst_aux body) + | Lletrec (decl, body) -> + Lam.letrec (Ext_list.map decl subst_decl) (subst_aux body) + | Lprim { primitive; args; loc } -> + Lam.prim ~primitive ~args:(Ext_list.map args subst_aux) loc + | Lglobal_module _ -> x + | Lswitch (arg, sw) -> + Lam.switch (subst_aux arg) + { + sw with + sw_consts = Ext_list.map sw.sw_consts subst_case; + sw_blocks = Ext_list.map sw.sw_blocks subst_case; + sw_failaction = subst_opt sw.sw_failaction; + } + | Lstringswitch (arg, cases, default) -> + Lam.stringswitch (subst_aux arg) + (Ext_list.map cases subst_strcase) + (subst_opt default) + | Lstaticraise (i, args) -> Lam.staticraise i (Ext_list.map args subst_aux) + | Lstaticcatch (e1, io, e2) -> + Lam.staticcatch (subst_aux e1) io (subst_aux e2) + | Ltrywith (e1, exn, e2) -> Lam.try_ (subst_aux e1) exn (subst_aux e2) + | Lifthenelse (e1, e2, e3) -> + Lam.if_ (subst_aux e1) (subst_aux e2) (subst_aux e3) + | Lsequence (e1, e2) -> Lam.seq (subst_aux e1) (subst_aux e2) + | Lwhile (e1, e2) -> Lam.while_ (subst_aux e1) (subst_aux e2) + | Lfor (v, e1, e2, dir, e3) -> + Lam.for_ v (subst_aux e1) (subst_aux e2) dir (subst_aux e3) + | Lassign (id, e) -> Lam.assign id (subst_aux e) + and subst_decl (id, exp) = (id, subst_aux exp) + and subst_case (key, case) = (key, subst_aux case) + and subst_strcase (key, case) = (key, subst_aux case) + and subst_opt = function None -> None | Some e -> Some (subst_aux e) in + subst_aux lam -let single_na = Js_cmj_format.single_na +end +module Lam_pass_exits : sig +#1 "lam_pass_exits.mli" +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) +(* Adapted for Javascript backend: Hongbo Zhang, *) -let values_of_export (meta : Lam_stats.t) (export_map : Lam.t Map_ident.t) : - Js_cmj_format.cmj_value Map_string.t = - Ext_list.fold_left meta.exports Map_string.empty (fun acc x -> - let arity : Js_cmj_format.arity = - match Hash_ident.find_opt meta.ident_tbl x with - | Some (FunctionId { arity; _ }) -> Single arity - | Some (ImmutableBlock elems) -> - (* FIXME: field name for dumping*) - Submodule - (Ext_array.map elems (fun x -> - match x with - | NA -> Lam_arity.na - | SimpleForm lam -> Lam_arity_analysis.get_arity meta lam)) - | Some _ | None -> ( - match Map_ident.find_opt export_map x with - | Some (Lprim { primitive = Pmakeblock (_, _, Immutable); args }) -> - Submodule - (Ext_array.of_list_map args (fun lam -> - Lam_arity_analysis.get_arity meta lam)) - | Some _ | None -> single_na) - in - let persistent_closed_lambda = - let optlam = Map_ident.find_opt export_map x in - match optlam with - | Some - (Lconst - ( Const_js_null | Const_js_undefined | Const_js_true - | Const_js_false )) - | None -> - optlam - | Some lambda -> - if not !Js_config.cross_module_inline then None - else if - Lam_analysis.safe_to_inline lambda - (* when inlning a non function, we have to be very careful, - only truly immutable values can be inlined - *) - then - match lambda with - | Lfunction { attr = { inline = Always_inline } } - (* FIXME: is_closed lambda is too restrictive - It precludes ues cases - - inline forEach but not forEachU - *) - | Lfunction { attr = { is_a_functor = true } } -> - if Lam_closure.is_closed lambda (* TODO: seriealize more*) - then optlam - else None - | _ -> - let lam_size = Lam_analysis.size lambda in - (* TODO: - 1. global need re-assocate when do the beta reduction - 2. [lambda_exports] is not precise - *) - let free_variables = - Lam_closure.free_variables Set_ident.empty Map_ident.empty - lambda - in - if - lam_size < Lam_analysis.small_inline_size - && Map_ident.is_empty free_variables - then ( - Ext_log.dwarn ~__POS__ "%s recorded for inlining @." x.name; - optlam) - else None - else None - in - match (arity, persistent_closed_lambda) with - | Single Arity_na, (None | Some (Lconst Const_module_alias)) -> acc - | Submodule [||], None -> acc - | _ -> - let cmj_value : Js_cmj_format.cmj_value = - { arity; persistent_closed_lambda } - in - Map_string.add acc x.name cmj_value) +(** A pass used to optimize the exit code compilation, adaped from the compiler's + [simplif] module +*) -(* ATTENTION: all runtime modules, if it is not hard required, - it should be okay to not reference it +val simplify_exits : Lam.t -> Lam.t + +end = struct +#1 "lam_pass_exits.ml" +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) +(* Adapted for Javascript backend: Hongbo Zhang *) + +(** + [no_bounded_varaibles lambda] + checks if [lambda] contains bounded variable, for + example [Llet (str,id,arg,body) ] will fail such check. + This is used to indicate such lambda expression if it is okay + to inline directly since if it contains bounded variables it + must be rebounded before inlining *) -let get_dependent_module_effect (maybe_pure : string option) - (external_ids : Lam_module_ident.t list) = - if maybe_pure = None then - let non_pure_module = - Ext_list.find_first_not external_ids Lam_compile_env.is_pure_module - in - Ext_option.map non_pure_module (fun x -> Lam_module_ident.name x) - else maybe_pure +let rec no_list args = Ext_list.for_all args no_bounded_variables + +and no_list_snd : 'a. ('a * Lam.t) list -> bool = + fun args -> Ext_list.for_all_snd args no_bounded_variables + +and no_opt x = match x with None -> true | Some a -> no_bounded_variables a + +and no_bounded_variables (l : Lam.t) = + match l with + | Lvar _ -> true + | Lconst _ -> true + | Lassign (_id, e) -> no_bounded_variables e + | Lapply { ap_func; ap_args; _ } -> + no_bounded_variables ap_func && no_list ap_args + | Lglobal_module _ -> true + | Lprim { args; primitive = _ } -> no_list args + | Lswitch (arg, sw) -> + no_bounded_variables arg && no_list_snd sw.sw_consts + && no_list_snd sw.sw_blocks && no_opt sw.sw_failaction + | Lstringswitch (arg, cases, default) -> + no_bounded_variables arg && no_list_snd cases && no_opt default + | Lstaticraise (_, args) -> no_list args + | Lifthenelse (e1, e2, e3) -> + no_bounded_variables e1 && no_bounded_variables e2 + && no_bounded_variables e3 + | Lsequence (e1, e2) -> no_bounded_variables e1 && no_bounded_variables e2 + | Lwhile (e1, e2) -> no_bounded_variables e1 && no_bounded_variables e2 + | Lstaticcatch (e1, (_, vars), e2) -> + vars = [] && no_bounded_variables e1 && no_bounded_variables e2 + | Lfunction { body; params } -> params = [] && no_bounded_variables body + | Lfor _ -> false + | Ltrywith _ -> false + | Llet _ -> false + | Lletrec (decl, body) -> decl = [] && no_bounded_variables body + +(* + TODO: + we should have a pass called, always inlinable + as long as its length is smaller than [exit=exit_id], for example -(* Note that - [lambda_exports] is - lambda expression to be exported - for the js backend, we compile to js - for the inliner, we try to seriaize it -- - relies on other optimizations to make this happen {[ - exports.Make = function () {.....} + switch(box_name) + {case "":exit=178;break; + case "b":exit=178;break; + case "h":box_type=/* Pp_hbox */0;break; + case "hov":box_type=/* Pp_hovbox */3;break; + case "hv":box_type=/* Pp_hvbox */2;break; + case "v":box_type=/* Pp_vbox */1;break; + default:box_type=invalid_box(/* () */0);} + + switch(exit){case 178:box_type=/* Pp_box */4;break} ]} - TODO: check that we don't do this in browser environment *) -let export_to_cmj (meta : Lam_stats.t) effect export_map case : Js_cmj_format.t + +(** The third argument is its occurrence, + when do the substitution, if its occurence is > 1, + we should refresh +*) +type lam_subst = Id of Lam.t [@@unboxed] +(* | Refresh of Lam.t *) + +type subst_tbl = (Ident.t list * lam_subst) Hash_int.t + +let to_lam x = match x with Id x -> x +(* | Refresh x -> Lam_bounded_vars.refresh x *) + +(** + Simplify ``catch body with (i ...) handler'' + - if (exit i ...) does not occur in body, suppress catch + - if (exit i ...) occurs exactly once in body, + substitute it with handler + - If handler is a single variable, replace (exit i ..) with it + + + Note: + In ``catch body with (i x1 .. xn) handler'' + Substituted expression is + let y1 = x1 and ... yn = xn in + handler[x1 <- y1 ; ... ; xn <- yn] + For the sake of preserving the uniqueness of bound variables. + ASKS: This documentation seems outdated + (No alpha conversion of ``handler'' is presently needed, since + substitution of several ``(exit i ...)'' + occurs only when ``handler'' is a variable.) + Note that + for [query] result = 2, + the non-inline cost is + {[ + var exit ; + + exit = 11; + exit = 11; + + switch(exit){ + case exit = 11 : body ; break + } + + ]} + the inline cost is + + {[ + body; + body; + ]} + + when [i] is negative, we can not inline in general, + since the outer is a traditional [try .. catch] body, + if it is guaranteed to be non throw, then we can inline +*) + +(** TODO: better heuristics, also if we can group same exit code [j] + in a very early stage -- maybe we can define our enhanced [Lambda] + representation and counter can be more precise, for example [apply] + does not need patch from the compiler + + FIXME: when inlining, need refresh local bound identifiers + #1438 when the action containes bounded variable + to keep the invariant, everytime, we do an inlining, + we need refresh, just refreshing once is not enough + We need to decide whether inline or not based on post-simplification + code, since when we do the substitution + we use the post-simplified expression, it is more consistent + TODO: when we do the case merging on the js side, + the j is not very indicative +*) + +let subst_helper (subst : subst_tbl) (query : int -> int) (lam : Lam.t) : Lam.t = - let values = values_of_export meta export_map in + let rec simplif (lam : Lam.t) = + match lam with + | Lstaticcatch (l1, (i, xs), l2) -> ( + let i_occur = query i in + match (i_occur, l2) with + | 0, _ -> simplif l1 + | _, Lvar _ | _, Lconst _ (* when i >= 0 # 2316 *) -> + Hash_int.add subst i (xs, Id (simplif l2)); + simplif l1 (* l1 will inline *) + | 1, _ when i >= 0 -> + (* Ask: Note that we have predicate i >=0 *) + Hash_int.add subst i (xs, Id (simplif l2)); + simplif l1 (* l1 will inline *) + | _ -> + let l2 = simplif l2 in + (* we only inline when [l2] does not contain bound variables + no need to refresh + *) + let ok_to_inline = + i >= 0 && no_bounded_variables l2 + && + let lam_size = Lam_analysis.size l2 in + (i_occur <= 2 && lam_size < Lam_analysis.exit_inline_size) + || lam_size < 5 + in + if ok_to_inline then ( + Hash_int.add subst i (xs, Id l2); + simplif l1) + else Lam.staticcatch (simplif l1) (i, xs) l2) + | Lstaticraise (i, []) -> ( + match Hash_int.find_opt subst i with + | Some (_, handler) -> to_lam handler + | None -> lam) + | Lstaticraise (i, ls) -> ( + let ls = Ext_list.map ls simplif in + match Hash_int.find_opt subst i with + | Some (xs, handler) -> + let handler = to_lam handler in + let ys = Ext_list.map xs Ident.rename in + let env = + Ext_list.fold_right2 xs ys Map_ident.empty (fun x y t -> + Map_ident.add t x (Lam.var y)) + in + Ext_list.fold_right2 ys ls (Lam_subst.subst env handler) + (fun y l r -> Lam.let_ Strict y l r) + | None -> Lam.staticraise i ls) + | Lvar _ | Lconst _ -> lam + | Lapply { ap_func; ap_args; ap_info } -> + Lam.apply (simplif ap_func) (Ext_list.map ap_args simplif) ap_info + | Lfunction { arity; params; body; attr } -> + Lam.function_ ~arity ~params ~body:(simplif body) ~attr + | Llet (kind, v, l1, l2) -> Lam.let_ kind v (simplif l1) (simplif l2) + | Lletrec (bindings, body) -> + Lam.letrec (Ext_list.map_snd bindings simplif) (simplif body) + | Lglobal_module _ -> lam + | Lprim { primitive; args; loc } -> + let args = Ext_list.map args simplif in + Lam.prim ~primitive ~args loc + | Lswitch (l, sw) -> + let new_l = simplif l in + let new_consts = Ext_list.map_snd sw.sw_consts simplif in + let new_blocks = Ext_list.map_snd sw.sw_blocks simplif in + let new_fail = Ext_option.map sw.sw_failaction simplif in + Lam.switch new_l + { + sw with + sw_consts = new_consts; + sw_blocks = new_blocks; + sw_failaction = new_fail; + } + | Lstringswitch (l, sw, d) -> + Lam.stringswitch (simplif l) + (Ext_list.map_snd sw simplif) + (Ext_option.map d simplif) + | Ltrywith (l1, v, l2) -> Lam.try_ (simplif l1) v (simplif l2) + | Lifthenelse (l1, l2, l3) -> Lam.if_ (simplif l1) (simplif l2) (simplif l3) + | Lsequence (l1, l2) -> Lam.seq (simplif l1) (simplif l2) + | Lwhile (l1, l2) -> Lam.while_ (simplif l1) (simplif l2) + | Lfor (v, l1, l2, dir, l3) -> + Lam.for_ v (simplif l1) (simplif l2) dir (simplif l3) + | Lassign (v, l) -> Lam.assign v (simplif l) + in + simplif lam - Js_cmj_format.make ~values ~effect - ~package_spec:(Js_packages_state.get_packages_info ()) - ~case -(* FIXME: make sure [-o] would not change its case - add test for ns/non-ns +let simplify_exits (lam : Lam.t) = + let exits = Lam_exit_count.count_helper lam in + subst_helper (Hash_int.create 17) (Lam_exit_count.count_exit exits) lam + +(* Compile-time beta-reduction of functions immediately applied: + Lapply(Lfunction(Curried, params, body), args, loc) -> + let paramN = argN in ... let param1 = arg1 in body + Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock(args))], loc) -> + let paramN = argN in ... let param1 = arg1 in body + Assumes |args| = |params|. *) -end -module Lam_compile_main : sig -#1 "lam_compile_main.mli" -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +end +module Lam_pass_count : sig +#1 "lam_pass_count.mli" +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) +(* Adapted for Javascript backend : Hongbo Zhang, *) + +type used_info = { + mutable times : int; + mutable captured : bool; + (* captured in functon or loop, + inline in such cases should be careful + 1. can not inline mutable values + 2. avoid re-computation + *) +} + +type occ_tbl = used_info Hash_ident.t + +val dummy_info : unit -> used_info + +val collect_occurs : Lam.t -> occ_tbl + +val pp_occ_tbl : Format.formatter -> occ_tbl -> unit + +end = struct +#1 "lam_pass_count.ml" +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) +(* Adapted for Javascript backend : Hongbo Zhang, *) + +(*A naive dead code elimination *) +type used_info = { + mutable times : int; + mutable captured : bool; + (* captured in functon or loop, + inline in such cases should be careful + 1. can not inline mutable values + 2. avoid re-computation + *) +} + +type occ_tbl = used_info Hash_ident.t +(* First pass: count the occurrences of all let-bound identifiers *) + +type local_tbl = used_info Map_ident.t + +let dummy_info () = { times = 0; captured = false } +(* y is untouched *) + +let absorb_info (x : used_info) (y : used_info) = + match (x, y) with + | { times = x0 }, { times = y0; captured } -> + x.times <- x0 + y0; + if captured then x.captured <- true + +let pp_info fmt (x : used_info) = + Format.fprintf fmt "(:%d)" x.captured x.times + +let pp_occ_tbl fmt tbl = + Hash_ident.iter tbl (fun k v -> + Format.fprintf fmt "@[%a@ %a@]@." Ident.print k pp_info v) + +(* The global table [occ] associates to each let-bound identifier + the number of its uses (as a reference): + - 0 if never used + - 1 if used exactly once in and not under a lambda or within a loop + - when under a lambda, + - it's probably a closure + - within a loop + - update reference, + niether is good for inlining + - > 1 if used several times or under a lambda or within a loop. + The local table [bv] associates to each locally-let-bound variable + its reference count, as above. [bv] is enriched at let bindings + but emptied when crossing lambdas and loops. *) +let collect_occurs lam : occ_tbl = + let occ : occ_tbl = Hash_ident.create 83 in + + (* Current use count of a variable. *) + let used v = + match Hash_ident.find_opt occ v with + | None -> false + | Some { times; _ } -> times > 0 + in -(** ReScript entry point in the OCaml compiler *) + (* Entering a [let]. Returns updated [bv]. *) + let bind_var bv ident = + let r = dummy_info () in + Hash_ident.add occ ident r; + Map_ident.add bv ident r + in -(** Compile and register the hook of function to compile a lambda to JS IR -*) + (* Record a use of a variable *) + let add_one_use bv ident = + match Map_ident.find_opt bv ident with + | Some r -> r.times <- r.times + 1 + | None -> ( + (* ident is not locally bound, therefore this is a use under a lambda + or within a loop. Increase use count by 2 -- enough so + that single-use optimizations will not apply. *) + match Hash_ident.find_opt occ ident with + | Some r -> absorb_info r { times = 1; captured = true } + | None -> + (* Not a let-bound variable, ignore *) + ()) + in -val compile : string -> Ident.t list -> Lambda.lambda -> J.deps_program -(** For toplevel, [filename] is [""] which is the same as - {!Env.get_unit_name ()} -*) + let inherit_use bv ident bid = + let n = + match Hash_ident.find_opt occ bid with + | None -> dummy_info () + | Some v -> v + in + match Map_ident.find_opt bv ident with + | Some r -> absorb_info r n + | None -> ( + (* ident is not locally bound, therefore this is a use under a lambda + or within a loop. Increase use count by 2 -- enough so + that single-use optimizations will not apply. *) + match Hash_ident.find_opt occ ident with + | Some r -> absorb_info r { n with captured = true } + | None -> + (* Not a let-bound variable, ignore *) + ()) + in -val lambda_as_module : J.deps_program -> string -> unit + let rec count (bv : local_tbl) (lam : Lam.t) = + match lam with + | Lfunction { body = l } -> count Map_ident.empty l + (* when entering a function local [bv] + is cleaned up, so that all closure variables will not be + carried over, since the parameters are never rebound, + so it is fine to kep it empty + *) + | Lfor (_, l1, l2, _dir, l3) -> + count bv l1; + count bv l2; + count Map_ident.empty l3 + | Lwhile (l1, l2) -> + count Map_ident.empty l1; + count Map_ident.empty l2 + | Lvar v -> add_one_use bv v + | Llet (_, v, Lvar w, l2) -> + (* v will be replaced by w in l2, so each occurrence of v in l2 + increases w's refcount *) + count (bind_var bv v) l2; + inherit_use bv w v + | Llet (kind, v, l1, l2) -> + count (bind_var bv v) l2; + (* count [l2] first, + If v is unused, l1 will be removed, so don't count its variables *) + if kind = Strict || used v then count bv l1 + | Lassign (_, l) -> + (* Lalias-bound variables are never assigned, so don't increase + this ident's refcount *) + count bv l + | Lglobal_module _ -> () + | Lprim { args; _ } -> List.iter (count bv) args + | Lletrec (bindings, body) -> + List.iter (fun (_v, l) -> count bv l) bindings; + count bv body + (* Note there is a difference here when do beta reduction for *) + | Lapply { ap_func = Lfunction { params; body }; ap_args = args; _ } + when Ext_list.same_length params args -> + count bv (Lam_beta_reduce.no_names_beta_reduce params body args) + (* | Lapply{fn = Lfunction{function_kind = Tupled; params; body}; *) + (* args = [Lprim {primitive = Pmakeblock _; args; _}]; _} *) + (* when Ext_list.same_length params args -> *) + (* count bv (Lam_beta_reduce.beta_reduce params body args) *) + | Lapply { ap_func = l1; ap_args = ll; _ } -> + count bv l1; + List.iter (count bv) ll + | Lconst _cst -> () + | Lswitch (l, sw) -> + count_default bv sw; + count bv l; + List.iter (fun (_, l) -> count bv l) sw.sw_consts; + List.iter (fun (_, l) -> count bv l) sw.sw_blocks + | Lstringswitch (l, sw, d) -> ( + count bv l; + List.iter (fun (_, l) -> count bv l) sw; + match d with Some d -> count bv d | None -> ()) + (* x2 for native backend *) + (* begin match sw with *) + (* | []|[_] -> count bv d *) + (* | _ -> count bv d ; count bv d *) + (* end *) + | Lstaticraise (_i, ls) -> List.iter (count bv) ls + | Lstaticcatch (l1, (_i, _), l2) -> + count bv l1; + count bv l2 + | Ltrywith (l1, _v, l2) -> + count bv l1; + count bv l2 + | Lifthenelse (l1, l2, l3) -> + count bv l1; + count bv l2; + count bv l3 + | Lsequence (l1, l2) -> + count bv l1; + count bv l2 + and count_default bv sw = + match sw.sw_failaction with + | None -> () + | Some al -> + if (not sw.sw_consts_full) && not sw.sw_blocks_full then ( + (* default action will occur twice in native code *) + count bv al; + count bv al) + else ( + (* default action will occur once *) + assert ((not sw.sw_consts_full) || not sw.sw_blocks_full); + count bv al) + in + count Map_ident.empty lam; + occ -end = struct -#1 "lam_compile_main.pp.ml" -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. +end +module Lam_pass_eliminate_ref : sig +#1 "lam_pass_eliminate_ref.mli" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by @@ -274419,1753 +274843,1342 @@ end = struct * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +exception Real_reference +val eliminate_ref : Ident.t -> Lam.t -> Lam.t +end = struct +#1 "lam_pass_eliminate_ref.ml" +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) +(* Adapted for Javascript backend : Hongbo Zhang, *) +exception Real_reference +let rec eliminate_ref id (lam : Lam.t) = + match lam with + (* we can do better escape analysis in Javascript backend *) + | Lvar v -> if Ident.same v id then raise_notrace Real_reference else lam + | Lprim { primitive = Pfield (0, _); args = [ Lvar v ] } when Ident.same v id + -> + Lam.var id + | Lfunction _ -> + if Lam_hit.hit_variable id lam then raise_notrace Real_reference else lam + (* In Javascript backend, its okay, we can reify it later + a failed case + {[ + for i = .. + let v = ref 0 + for j = .. + incr v + a[j] = ()=>{!v} + ]} + here v is captured by a block, and it's a loop mutable value, + we have to generate + {[ + for i = .. + let v = ref 0 + (function (v){for j = .. + a[j] = ()=>{!v}}(v) + ]} + now, v is a real reference + TODO: we can refine analysis in later + *) + (* Lfunction(kind, params, eliminate_ref id body) *) + | Lprim { primitive = Psetfield (0, _); args = [ Lvar v; e ] } + when Ident.same v id -> + Lam.assign id (eliminate_ref id e) + | Lprim { primitive = Poffsetref delta; args = [ Lvar v ]; loc } + when Ident.same v id -> + Lam.assign id + (Lam.prim ~primitive:(Poffsetint delta) ~args:[ Lam.var id ] loc) + | Lconst _ -> lam + | Lapply { ap_func = e1; ap_args = el; ap_info } -> + Lam.apply (eliminate_ref id e1) + (Ext_list.map el (eliminate_ref id)) + ap_info + | Llet (str, v, e1, e2) -> + Lam.let_ str v (eliminate_ref id e1) (eliminate_ref id e2) + | Lletrec (idel, e2) -> + Lam.letrec + (Ext_list.map idel (fun (v, e) -> (v, eliminate_ref id e))) + (eliminate_ref id e2) + | Lglobal_module _ -> lam + | Lprim { primitive; args; loc } -> + Lam.prim ~primitive ~args:(Ext_list.map args (eliminate_ref id)) loc + | Lswitch (e, sw) -> + Lam.switch (eliminate_ref id e) + { + sw_consts_full = sw.sw_consts_full; + sw_consts = + Ext_list.map sw.sw_consts (fun (n, e) -> (n, eliminate_ref id e)); + sw_blocks_full = sw.sw_blocks_full; + sw_blocks = + Ext_list.map sw.sw_blocks (fun (n, e) -> (n, eliminate_ref id e)); + sw_failaction = + (match sw.sw_failaction with + | None -> None + | Some x -> Some (eliminate_ref id x)); + sw_names = sw.sw_names; + } + | Lstringswitch (e, sw, default) -> + Lam.stringswitch (eliminate_ref id e) + (Ext_list.map sw (fun (s, e) -> (s, eliminate_ref id e))) + (match default with + | None -> None + | Some x -> Some (eliminate_ref id x)) + | Lstaticraise (i, args) -> + Lam.staticraise i (Ext_list.map args (eliminate_ref id)) + | Lstaticcatch (e1, i, e2) -> + Lam.staticcatch (eliminate_ref id e1) i (eliminate_ref id e2) + | Ltrywith (e1, v, e2) -> + Lam.try_ (eliminate_ref id e1) v (eliminate_ref id e2) + | Lifthenelse (e1, e2, e3) -> + Lam.if_ (eliminate_ref id e1) (eliminate_ref id e2) (eliminate_ref id e3) + | Lsequence (e1, e2) -> Lam.seq (eliminate_ref id e1) (eliminate_ref id e2) + | Lwhile (e1, e2) -> Lam.while_ (eliminate_ref id e1) (eliminate_ref id e2) + | Lfor (v, e1, e2, dir, e3) -> + Lam.for_ v (eliminate_ref id e1) (eliminate_ref id e2) dir + (eliminate_ref id e3) + | Lassign (v, e) -> Lam.assign v (eliminate_ref id e) -(* module E = Js_exp_make *) -(* module S = Js_stmt_make *) - - -let compile_group (meta : Lam_stats.t) - (x : Lam_group.t) : Js_output.t = - match x with - (* - We need - - 2. [E.builtin_dot] for javascript builtin - 3. [E.mldot] - *) - (* ATTENTION: check {!Lam_compile_global} for consistency *) - (* Special handling for values in [Pervasives] *) - (* - we delegate [stdout, stderr, and stdin] into [caml_io] module, - the motivation is to help dead code eliminatiion, it's helpful - to make those parts pure (not a function call), then it can be removed - if unused - *) - - (* QUICK hack to make hello world example nicer, - Note the arity of [print_endline] is already analyzed before, - so it should be safe - *) - - | Single (kind, id, lam) -> - (* let lam = Optimizer.simplify_lets [] lam in *) - (* can not apply again, it's wrong USE it with care*) - (* ([Js_stmt_make.comment (Gen_of_env.query_type id env )], None) ++ *) - Lam_compile.compile_lambda { continuation = Declare (kind, id); - jmp_table = Lam_compile_context.empty_handler_map; - meta - } lam - - | Recursive id_lams -> - Lam_compile.compile_recursive_lets - { continuation = EffectCall Not_tail; - jmp_table = Lam_compile_context.empty_handler_map; - meta - } - id_lams - | Nop lam -> (* TODO: Side effect callls, log and see statistics *) - Lam_compile.compile_lambda {continuation = EffectCall Not_tail; - jmp_table = Lam_compile_context.empty_handler_map; - meta - } lam - -;; - -(** Also need analyze its depenency is pure or not *) -let no_side_effects (rest : Lam_group.t list) : string option = - Ext_list.find_opt rest (fun x -> - match x with - | Single(kind,id,body) -> - begin - match kind with - | Strict | Variable -> - if not @@ Lam_analysis.no_side_effects body - then Some (Printf.sprintf "%s" id.name) - else None - | _ -> None - end - | Recursive bindings -> - Ext_list.find_opt bindings (fun (id,lam) -> - if not @@ Lam_analysis.no_side_effects lam - then Some (Printf.sprintf "%s" id.Ident.name ) - else None - ) - | Nop lam -> - if not @@ Lam_analysis.no_side_effects lam - then - (* (Lam_util.string_of_lambda lam) *) - Some "" - else None (* TODO :*)) - - -let _d = fun s lam -> - - lam - -let _j = Js_pass_debug.dump - -(** Actually simplify_lets is kind of global optimization since it requires you to know whether - it's used or not -*) -let compile - (output_prefix : string) - export_idents - (lam : Lambda.lambda) = - let export_ident_sets = Set_ident.of_list export_idents in - (* To make toplevel happy - reentrant for js-demo *) - let () = - - Lam_compile_env.reset () ; - in - let lam, may_required_modules = Lam_convert.convert export_ident_sets lam in - - - let lam = _d "initial" lam in - let lam = Lam_pass_deep_flatten.deep_flatten lam in - let lam = _d "flatten0" lam in - let meta : Lam_stats.t = - Lam_stats.make - ~export_idents - ~export_ident_sets in - let () = Lam_pass_collect.collect_info meta lam in - let lam = - let lam = - lam - |> _d "flattern1" - |> Lam_pass_exits.simplify_exits - |> _d "simplyf_exits" - |> (fun lam -> Lam_pass_collect.collect_info meta lam; - - lam) - |> Lam_pass_remove_alias.simplify_alias meta - |> _d "simplify_alias" - |> Lam_pass_deep_flatten.deep_flatten - |> _d "flatten2" - in (* Inling happens*) - - let () = Lam_pass_collect.collect_info meta lam in - let lam = Lam_pass_remove_alias.simplify_alias meta lam in - let lam = Lam_pass_deep_flatten.deep_flatten lam in - let () = Lam_pass_collect.collect_info meta lam in - let lam = - lam - |> _d "alpha_before" - |> Lam_pass_alpha_conversion.alpha_conversion meta - |> _d "alpha_after" - |> Lam_pass_exits.simplify_exits in - let () = Lam_pass_collect.collect_info meta lam in - - - lam - |> _d "simplify_alias_before" - |> Lam_pass_remove_alias.simplify_alias meta - |> _d "alpha_conversion" - |> Lam_pass_alpha_conversion.alpha_conversion meta - |> _d "before-simplify_lets" - (* we should investigate a better way to put different passes : )*) - |> Lam_pass_lets_dce.simplify_lets - - |> _d "before-simplify-exits" - (* |> (fun lam -> Lam_pass_collect.collect_info meta lam - ; Lam_pass_remove_alias.simplify_alias meta lam) *) - (* |> Lam_group_pass.scc_pass - |> _d "scc" *) - |> Lam_pass_exits.simplify_exits - |> _d "simplify_lets" - - in - - let ({Lam_coercion.groups = groups } as coerced_input , meta) = - Lam_coercion.coerce_and_group_big_lambda meta lam - in - - -let maybe_pure = no_side_effects groups in - -let body = - Ext_list.map groups (fun group -> compile_group meta group) - |> Js_output.concat - |> Js_output.output_as_block -in - -(* The file is not big at all compared with [cmo] *) -(* Ext_marshal.to_file (Ext_path.chop_extension filename ^ ".mj") js; *) -let meta_exports = meta.exports in -let export_set = Set_ident.of_list meta_exports in -let js : J.program = - { - exports = meta_exports ; - export_set; - block = body} -in -js -|> _j "initial" -|> Js_pass_flatten.program -|> _j "flattern" -|> Js_pass_tailcall_inline.tailcall_inline -|> _j "inline_and_shake" -|> Js_pass_flatten_and_mark_dead.program -|> _j "flatten_and_mark_dead" -(* |> Js_inline_and_eliminate.inline_and_shake *) -(* |> _j "inline_and_shake" *) -|> (fun js -> ignore @@ Js_pass_scope.program js ; js ) -|> Js_shake.shake_program -|> _j "shake" -|> ( fun (program: J.program) -> - let external_module_ids : Lam_module_ident.t list = - if !Js_config.all_module_aliases then [] - else - let hard_deps = - Js_fold_basic.calculate_hard_dependencies program.block in - Lam_compile_env.populate_required_modules - may_required_modules hard_deps ; - Ext_list.sort_via_array (Lam_module_ident.Hash_set.to_list hard_deps) - (fun id1 id2 -> - Ext_string.compare (Lam_module_ident.name id1) (Lam_module_ident.name id2) - ) - in - Warnings.check_fatal(); - let effect = - Lam_stats_export.get_dependent_module_effect - maybe_pure external_module_ids in - let v : Js_cmj_format.t = - Lam_stats_export.export_to_cmj - meta - effect - coerced_input.export_map - (if Ext_char.is_lower_case (Filename.basename output_prefix).[0] then Little else Upper) - in - (if not !Clflags.dont_write_files then - Js_cmj_format.to_file - ~check_exists:(not !Js_config.force_cmj) - (output_prefix ^ Literals.suffix_cmj) v); - {J.program = program ; side_effect = effect ; modules = external_module_ids } - ) -;; - -let (//) = Filename.concat - -let lambda_as_module - (lambda_output : J.deps_program) - (output_prefix : string) - : unit = - let package_info = Js_packages_state.get_packages_info () in - if Js_packages_info.is_empty package_info && !Js_config.js_stdout then begin - Js_dump_program.dump_deps_program ~output_prefix NodeJS lambda_output stdout - end else - Js_packages_info.iter package_info (fun {module_system; path; suffix} -> - let output_chan chan = - Js_dump_program.dump_deps_program ~output_prefix - module_system - lambda_output - chan in - let basename = - Ext_namespace.change_ext_ns_suffix - (Filename.basename - output_prefix) - (Ext_js_suffix.to_string suffix) - in - let target_file = - (Lazy.force Ext_path.package_dir // - path // - basename - (* #913 only generate little-case js file *) - ) in - (if not !Clflags.dont_write_files then - Ext_pervasives.with_file_as_chan - target_file output_chan ); - if !Warnings.has_warnings then begin - Warnings.has_warnings := false ; - (* 5206: When there were warnings found during the compilation, we want the file - to be rebuilt on the next "rescript build" so that the warnings keep being shown. - Set the timestamp of the ast file to 1970-01-01 to make this rebuild happen. - (Do *not* set the timestamp of the JS output file instead - as that does not play well with every bundler.) *) - let ast_file = output_prefix ^ Literals.suffix_ast in - if Sys.file_exists ast_file then begin - Bs_hash_stubs.set_as_old_file ast_file - end - - end - ) - - - -(* We can use {!Env.current_unit = "Pervasives"} to tell if it is some specific module, - We need handle some definitions in standard libraries in a special way, most are io specific, - includes {!Pervasives.stdin, Pervasives.stdout, Pervasives.stderr} - - However, use filename instead of {!Env.current_unit} is more honest, since node-js module system is coupled with the file name -*) - -end -module Pprintast : sig -#1 "pprintast.mli" -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Hongbo Zhang (University of Pennsylvania) *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -type space_formatter = (unit, Format.formatter, unit) format - - -val expression : Format.formatter -> Parsetree.expression -> unit -val string_of_expression : Parsetree.expression -> string - -val core_type: Format.formatter -> Parsetree.core_type -> unit -val pattern: Format.formatter -> Parsetree.pattern -> unit -val signature: Format.formatter -> Parsetree.signature -> unit -val structure: Format.formatter -> Parsetree.structure -> unit -val string_of_structure: Parsetree.structure -> string - -end = struct -#1 "pprintast.pp.ml" -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Thomas Gazagnaire, OCamlPro *) -(* Fabrice Le Fessant, INRIA Saclay *) -(* Hongbo Zhang, University of Pennsylvania *) -(* *) -(* Copyright 2007 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Original Code from Ber-metaocaml, modified for 3.12.0 and fixed *) -(* Printing code expressions *) -(* Authors: Ed Pizzi, Fabrice Le Fessant *) -(* Extensive Rewrite: Hongbo Zhang: University of Pennsylvania *) -(* TODO more fine-grained precedence pretty-printing *) +end +module Lam_pass_lets_dce : sig +#1 "lam_pass_lets_dce.mli" +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) +(* Adapted for Javascript backend: Hongbo Zhang *) -open Asttypes -open Format -open Location -open Longident -open Parsetree -open Ast_helper +val simplify_lets : Lam.t -> Lam.t +(** + This pass would do beta reduction, and dead code elimination (adapted from compiler's built-in [Simplif] module ) -let prefix_symbols = [ '!'; '?'; '~' ] ;; -let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/'; - '$'; '%'; '#' ] + 1. beta reduction -> Llet (Strict ) -(* type fixity = Infix| Prefix *) -let special_infix_strings = - ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!="; "::" ] + 2. The global table [occ] associates to each let-bound identifier + the number of its uses (as a reference): + - 0 if never used + - 1 if used exactly once in and *not under a lambda or within a loop + - > 1 if used several times or under a lambda or within a loop. -(* determines if the string is an infix string. - checks backwards, first allowing a renaming postfix ("_102") which - may have resulted from Pexp -> Texp -> Pexp translation, then checking - if all the characters in the beginning of the string are valid infix - characters. *) -let fixity_of_string = function - | s when List.mem s special_infix_strings -> `Infix s - | s when List.mem s.[0] infix_symbols -> `Infix s - | s when List.mem s.[0] prefix_symbols -> `Prefix s - | s when s.[0] = '.' -> `Mixfix s - | _ -> `Normal + The local table [bv] associates to each locally-let-bound variable + its reference count, as above. [bv] is enriched at let bindings + but emptied when crossing lambdas and loops. -let view_fixity_of_exp = function - | {pexp_desc = Pexp_ident {txt=Lident l;_}; pexp_attributes = []} -> - fixity_of_string l - | _ -> `Normal + For this pass, when it' used under a lambda or within a loop, we don't do anything, + in theory, we can still do something if it's pure but we are conservative here. -let is_infix = function | `Infix _ -> true | _ -> false -let is_mixfix = function `Mixfix _ -> true | _ -> false + [bv] is used to help caculate [occ] it is not useful outside -(* which identifiers are in fact operators needing parentheses *) -let needs_parens txt = - let fix = fixity_of_string txt in - is_infix fix - || is_mixfix fix - || List.mem txt.[0] prefix_symbols +*) -(* some infixes need spaces around parens to avoid clashes with comment - syntax *) -let needs_spaces txt = - txt.[0]='*' || txt.[String.length txt - 1] = '*' +end = struct +#1 "lam_pass_lets_dce.pp.ml" +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) +(* Adapted for Javascript backend : Hongbo Zhang, *) -(* add parentheses to binders when they are in fact infix or prefix operators *) -let protect_ident ppf txt = - let format : (_, _, _) format = - if not (needs_parens txt) then "%s" - else if needs_spaces txt then "(@;%s@;)" - else "(%s)" - in fprintf ppf format txt -let protect_longident ppf print_longident longprefix txt = - let format : (_, _, _) format = - if not (needs_parens txt) then "%a.%s" - else if needs_spaces txt then "%a.(@;%s@;)" - else "%a.(%s)" in - fprintf ppf format print_longident longprefix txt +let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = + let subst : Lam.t Hash_ident.t = Hash_ident.create 32 in + let string_table : string Hash_ident.t = Hash_ident.create 32 in + let used v = (count_var v ).times > 0 in + let rec simplif (lam : Lam.t) = + match lam with + | Lvar v -> Hash_ident.find_default subst v lam + | Llet( (Strict | Alias | StrictOpt) , v, Lvar w, l2) + -> + Hash_ident.add subst v (simplif (Lam.var w)); + simplif l2 + | Llet(Strict as kind, + v, (Lprim {primitive = (Pmakeblock(0, _, Mutable) + as primitive); + args = [linit] ; loc}), lbody) + -> + let slinit = simplif linit in + let slbody = simplif lbody in + begin + try (* TODO: record all references variables *) + Lam_util.refine_let + ~kind:Variable v slinit + (Lam_pass_eliminate_ref.eliminate_ref v slbody) + with Lam_pass_eliminate_ref.Real_reference -> + Lam_util.refine_let + ~kind v (Lam.prim ~primitive ~args:[slinit] loc) + slbody + end + | Llet(Alias, v, l1, l2) -> + (* For alias, [l1] is pure, we can always inline, + when captured, we should avoid recomputation + *) + begin + match count_var v, l1 with + | {times = 0; _}, _ -> simplif l2 + | {times = 1; captured = false }, _ + | {times = 1; captured = true }, (Lconst _ | Lvar _) + | _, (Lconst + (( + Const_int _ | Const_char _ | Const_float _ + ) + | Const_pointer _ |Const_js_true | Const_js_false | Const_js_undefined) (* could be poly-variant [`A] -> [65a]*) + | Lprim {primitive = Pfield (_); + args = [ + Lglobal_module _ + ]} + ) + (* Const_int64 is no longer primitive + Note for some constant which is not + inlined, we can still record it and + do constant folding independently + *) + -> + Hash_ident.add subst v (simplif l1); simplif l2 + | _, Lconst (Const_string {s; unicode = false} ) -> + (* only "" added for later inlining *) + Hash_ident.add string_table v s; + Lam.let_ Alias v l1 (simplif l2) + (* we need move [simplif l2] later, since adding Hash does have side effect *) + | _ -> Lam.let_ Alias v (simplif l1) (simplif l2) + (* for Alias, in most cases [l1] is already simplified *) + end + | Llet(StrictOpt as kind, v, l1, lbody) -> + (* can not be inlined since [l1] depend on the store + {[ + let v = [|1;2;3|] + ]} + get [StrictOpt] here, we can not inline v, + since the value of [v] can be changed -type space_formatter = (unit, Format.formatter, unit) format + GPR #1476 + Note to pass the sanitizer, we do need remove dead code (not just best effort) + This logic is tied to {!Lam_pass_count.count} + {[ + if kind = Strict || used v then count bv l1 + ]} + If the code which should be removed is not removed, it will hold references + to other variables which is already removed. + *) + if not (used v) + then simplif lbody (* GPR #1476 *) + else + begin match l1 with + | (Lprim {primitive = (Pmakeblock(0, _, Mutable) + as primitive); + args = [linit] ; loc}) + -> + let slinit = simplif linit in + let slbody = simplif lbody in + begin + try (* TODO: record all references variables *) + Lam_util.refine_let + ~kind:Variable v slinit + (Lam_pass_eliminate_ref.eliminate_ref v slbody) + with Lam_pass_eliminate_ref.Real_reference -> + Lam_util.refine_let + ~kind v (Lam.prim ~primitive ~args:[slinit] loc) + slbody + end -let override = function - | Override -> "!" - | Fresh -> "" + | _ -> + let l1 = simplif l1 in + begin match l1 with + | Lconst(Const_string { s; unicode = false }) -> + Hash_ident.add string_table v s; + (* we need move [simplif lbody] later, since adding Hash does have side effect *) + Lam.let_ Alias v l1 (simplif lbody) + | _ -> + Lam_util.refine_let ~kind v l1 (simplif lbody) + end + end + (* TODO: check if it is correct rollback to [StrictOpt]? *) -(* variance encoding: need to sync up with the [parser.mly] *) -let type_variance = function - | Invariant -> "" - | Covariant -> "+" - | Contravariant -> "-" + | Llet((Strict | Variable as kind), v, l1, l2) -> + if not (used v) + then + let l1 = simplif l1 in + let l2 = simplif l2 in + if Lam_analysis.no_side_effects l1 + then l2 + else Lam.seq l1 l2 + else + let l1 = (simplif l1) in -type construct = - [ `cons of expression list - | `list of expression list - | `nil - | `normal - | `simple of Longident.t - | `tuple ] + begin match kind, l1 with + | Strict, Lconst((Const_string { s; unicode = false })) + -> + Hash_ident.add string_table v s; + Lam.let_ Alias v l1 (simplif l2) + | _ -> + Lam_util.refine_let ~kind v l1 (simplif l2) + end + | Lsequence(l1, l2) -> Lam.seq (simplif l1) (simplif l2) -let view_expr x = - match x.pexp_desc with - | Pexp_construct ( {txt= Lident "()"; _},_) -> `tuple - | Pexp_construct ( {txt= Lident "[]";_},_) -> `nil - | Pexp_construct ( {txt= Lident"::";_},Some _) -> - let rec loop exp acc = match exp with - | {pexp_desc=Pexp_construct ({txt=Lident "[]";_},_); - pexp_attributes = []} -> - (List.rev acc,true) - | {pexp_desc= - Pexp_construct ({txt=Lident "::";_}, - Some ({pexp_desc= Pexp_tuple([e1;e2]); - pexp_attributes = []})); - pexp_attributes = []} - -> - loop e2 (e1::acc) - | e -> (List.rev (e::acc),false) in - let (ls,b) = loop x [] in - if b then - `list ls - else `cons ls - | Pexp_construct (x,None) -> `simple (x.txt) - | _ -> `normal + | Lapply{ap_func = Lfunction{params; body}; ap_args = args; _} + when Ext_list.same_length params args -> + simplif (Lam_beta_reduce.no_names_beta_reduce params body args) + (* | Lapply{ fn = Lfunction{function_kind = Tupled; params; body}; *) + (* args = [Lprim {primitive = Pmakeblock _; args; _}]; _} *) + (* (\** TODO: keep track of this parameter in ocaml trunk, *) + (* can we switch to the tupled backend? *) + (* *\) *) + (* when Ext_list.same_length params args -> *) + (* simplif (Lam_beta_reduce.beta_reduce params body args) *) -let is_simple_construct :construct -> bool = function - | `nil | `tuple | `list _ | `simple _ -> true - | `cons _ | `normal -> false + | Lapply{ap_func = l1; ap_args = ll; ap_info} -> + Lam.apply (simplif l1) (Ext_list.map ll simplif) ap_info + | Lfunction{arity; params; body; attr} -> + Lam.function_ ~arity ~params ~body:(simplif body) ~attr + | Lconst _ -> lam + | Lletrec(bindings, body) -> + Lam.letrec + (Ext_list.map_snd bindings simplif) + (simplif body) + | Lprim {primitive=Pstringadd; args = [l;r]; loc } -> + begin + let l' = simplif l in + let r' = simplif r in + let opt_l = + match l' with + | Lconst(Const_string { s = ls; unicode = false }) -> Some ls + | Lvar i -> Hash_ident.find_opt string_table i + | _ -> None in + match opt_l with + | None -> Lam.prim ~primitive:Pstringadd ~args:[l';r'] loc + | Some l_s -> + let opt_r = + match r' with + | Lconst (Const_string {s = rs; unicode = false}) -> Some rs + | Lvar i -> Hash_ident.find_opt string_table i + | _ -> None in + begin match opt_r with + | None -> Lam.prim ~primitive:Pstringadd ~args:[l';r'] loc + | Some r_s -> + Lam.const (Const_string { s = l_s^r_s; unicode = false }) + end + end -let pp = fprintf + | Lprim {primitive = (Pstringrefu|Pstringrefs) as primitive ; + args = [l;r] ; loc + } -> (* TODO: introudce new constant *) + let l' = simplif l in + let r' = simplif r in + let opt_l = + match l' with + | Lconst (Const_string { s = ls; unicode = false }) -> + Some ls + | Lvar i -> Hash_ident.find_opt string_table i + | _ -> None in + begin match opt_l with + | None -> Lam.prim ~primitive ~args:[l';r'] loc + | Some l_s -> + match r with + |Lconst((Const_int {i})) -> + let i = Int32.to_int i in + if i < String.length l_s && i >= 0 then + Lam.const ((Const_char (Char.code l_s.[i]))) + else + Lam.prim ~primitive ~args:[l';r'] loc + | _ -> + Lam.prim ~primitive ~args:[l';r'] loc + end + | Lglobal_module _ -> lam + | Lprim {primitive; args; loc} + -> Lam.prim ~primitive ~args:(Ext_list.map args simplif) loc + | Lswitch(l, sw) -> + let new_l = simplif l + and new_consts = Ext_list.map_snd sw.sw_consts simplif + and new_blocks = Ext_list.map_snd sw.sw_blocks simplif + and new_fail = Ext_option.map sw.sw_failaction simplif + in + Lam.switch + new_l + {sw with sw_consts = new_consts ; sw_blocks = new_blocks; + sw_failaction = new_fail} + | Lstringswitch (l,sw,d) -> + Lam.stringswitch + (simplif l) (Ext_list.map_snd sw simplif) + (Ext_option.map d simplif) + | Lstaticraise (i,ls) -> + Lam.staticraise i (Ext_list.map ls simplif) + | Lstaticcatch(l1, (i,args), l2) -> + Lam.staticcatch (simplif l1) (i,args) (simplif l2) + | Ltrywith(l1, v, l2) -> Lam.try_ (simplif l1) v (simplif l2) + | Lifthenelse(l1, l2, l3) -> + Lam.if_ (simplif l1) (simplif l2) (simplif l3) + | Lwhile(l1, l2) + -> + Lam.while_ (simplif l1) (simplif l2) + | Lfor(v, l1, l2, dir, l3) -> + Lam.for_ v (simplif l1) (simplif l2) dir (simplif l3) + | Lassign(v, l) -> Lam.assign v (simplif l) + in simplif lam -type ctxt = { - pipe : bool; - semi : bool; - ifthenelse : bool; -} -let reset_ctxt = { pipe=false; semi=false; ifthenelse=false } -let under_pipe ctxt = { ctxt with pipe=true } -let under_semi ctxt = { ctxt with semi=true } -let under_ifthenelse ctxt = { ctxt with ifthenelse=true } -(* -let reset_semi ctxt = { ctxt with semi=false } -let reset_ifthenelse ctxt = { ctxt with ifthenelse=false } -let reset_pipe ctxt = { ctxt with pipe=false } -*) +(* To transform let-bound references into variables *) +let apply_lets occ lambda = + let count_var v = + match + Hash_ident.find_opt occ v + with + | None -> Lam_pass_count.dummy_info () + | Some v -> v in + lets_helper count_var lambda -let list : 'a . ?sep:space_formatter -> ?first:space_formatter -> - ?last:space_formatter -> (Format.formatter -> 'a -> unit) -> - Format.formatter -> 'a list -> unit - = fun ?sep ?first ?last fu f xs -> - let first = match first with Some x -> x |None -> ("": _ format6) - and last = match last with Some x -> x |None -> ("": _ format6) - and sep = match sep with Some x -> x |None -> ("@ ": _ format6) in - let aux f = function - | [] -> () - | [x] -> fu f x - | xs -> - let rec loop f = function - | [x] -> fu f x - | x::xs -> fu f x; pp f sep; loop f xs; - | _ -> assert false in begin - pp f first; loop f xs; pp f last; - end in - aux f xs +let simplify_lets (lam : Lam.t) : Lam.t = + let occ = Lam_pass_count.collect_occurs lam in -let option : 'a. ?first:space_formatter -> ?last:space_formatter -> - (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a option -> unit - = fun ?first ?last fu f a -> - let first = match first with Some x -> x | None -> ("": _ format6) - and last = match last with Some x -> x | None -> ("": _ format6) in - match a with - | None -> () - | Some x -> pp f first; fu f x; pp f last + apply_lets occ lam -let paren: 'a . ?first:space_formatter -> ?last:space_formatter -> - bool -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit - = fun ?(first=("": _ format6)) ?(last=("": _ format6)) b fu f x -> - if b then (pp f "("; pp f first; fu f x; pp f last; pp f ")") - else fu f x +end +module Lam_pass_remove_alias : sig +#1 "lam_pass_remove_alias.mli" +(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. + * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -let rec longident f = function - | Lident s -> protect_ident f s - | Ldot(y,s) -> protect_longident f longident y s - | Lapply (y,s) -> - pp f "%a(%a)" longident y longident s +(** Keep track of the global module Aliases *) -let longident_loc f x = pp f "%a" longident x.txt +(** + One way: guarantee that all global aliases *would be removed* , + it will not be aliased -let constant f = function - | Pconst_char i -> pp f "%C" (Char.chr i) - | Pconst_string (i, None) -> pp f "%S" i - | Pconst_string (i, Some delim) -> pp f "{%s|%s|%s}" delim i delim - | Pconst_integer (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i - | Pconst_integer (i, Some m) -> - paren (i.[0]='-') (fun f (i, m) -> pp f "%s%c" i m) f (i,m) - | Pconst_float (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i - | Pconst_float (i, Some m) -> paren (i.[0]='-') (fun f (i,m) -> - pp f "%s%c" i m) f (i,m) + So the only remaining place for globals is either + just Pgetglobal in functor application or + `Lprim (Pfield( i ), [Pgetglobal])` -(* trailing space*) -let mutable_flag f = function - | Immutable -> () - | Mutable -> pp f "mutable@;" -let virtual_flag f = function - | Concrete -> () - | Virtual -> pp f "virtual@;" + This pass does not change meta data +*) -(* trailing space added *) -let rec_flag f rf = - match rf with - | Nonrecursive -> () - | Recursive -> pp f "rec " -let nonrec_flag f rf = - match rf with - | Nonrecursive -> pp f "nonrec " - | Recursive -> () -let direction_flag f = function - | Upto -> pp f "to@ " - | Downto -> pp f "downto@ " -let private_flag f = function - | Public -> () - | Private -> pp f "private@ " +val simplify_alias : Lam_stats.t -> Lam.t -> Lam.t -let constant_string f s = pp f "%S" s -let tyvar f str = pp f "'%s" str -let tyvar_loc f str = pp f "'%s" str.txt -let string_quot f x = pp f "`%s" x +end = struct +#1 "lam_pass_remove_alias.ml" +(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. + * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -(* c ['a,'b] *) -let rec class_params_def ctxt f = function - | [] -> () - | l -> - pp f "[%a] " (* space *) - (list (type_param ctxt) ~sep:",") l +type outcome = Eval_false | Eval_true | Eval_unknown -and type_with_label ctxt f (label, c) = - match label with - | Nolabel -> core_type1 ctxt f c (* otherwise parenthesize *) - | Labelled s -> pp f "%s:%a" s (core_type1 ctxt) c - | Optional s -> pp f "?%s:%a" s (core_type1 ctxt) c +let id_is_for_sure_true_in_boolean (tbl : Lam_stats.ident_tbl) id = + match Hash_ident.find_opt tbl id with + | Some (ImmutableBlock _) + | Some (Normal_optional _) + | Some (MutableBlock _) + | Some (Constant (Const_block _ | Const_js_true)) -> + Eval_true + | Some (Constant (Const_int { i })) -> + if i = 0l then Eval_false else Eval_true + | Some (Constant (Const_js_false | Const_js_null | Const_js_undefined)) -> + Eval_false + | Some + ( Constant _ | Module _ | FunctionId _ | Exception | Parameter | NA + | OptionalBlock (_, (Undefined | Null | Null_undefined)) ) + | None -> + Eval_unknown -and core_type ctxt f x = - if x.ptyp_attributes <> [] then begin - pp f "((%a)%a)" (core_type ctxt) {x with ptyp_attributes=[]} - (attributes ctxt) x.ptyp_attributes - end - else match x.ptyp_desc with - | Ptyp_arrow (l, ct1, ct2) -> - pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) - (type_with_label ctxt) (l,ct1) (core_type ctxt) ct2 - | Ptyp_alias (ct, s) -> - pp f "@[<2>%a@;as@;'%s@]" (core_type1 ctxt) ct s - | Ptyp_poly ([], ct) -> - core_type ctxt f ct - | Ptyp_poly (sl, ct) -> - pp f "@[<2>%a%a@]" - (fun f l -> - pp f "%a" - (fun f l -> match l with - | [] -> () - | _ -> - pp f "%a@;.@;" - (list tyvar_loc ~sep:"@;") l) - l) - sl (core_type ctxt) ct - | _ -> pp f "@[<2>%a@]" (core_type1 ctxt) x +let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = + let rec simpl (lam : Lam.t) : Lam.t = + match lam with + | Lvar _ -> lam + | Lprim { primitive = Pfield (i, info) as primitive; args = [ arg ]; loc } + -> ( + (* ATTENTION: + Main use case, we should detect inline all immutable block .. *) + match simpl arg with + | Lvar v as l -> + Lam_util.field_flatten_get + (fun _ -> Lam.prim ~primitive ~args:[ l ] loc) + v i info meta.ident_tbl + | l -> Lam.prim ~primitive ~args:[ l ] loc) + | Lprim + { + primitive = (Pval_from_option | Pval_from_option_not_nest) as p; + args = [ (Lvar v as lvar) ]; + } as x -> ( + match Hash_ident.find_opt meta.ident_tbl v with + | Some (OptionalBlock (l, _)) -> l + | _ -> if p = Pval_from_option_not_nest then lvar else x) + | Lglobal_module _ -> lam + | Lprim { primitive; args; loc } -> + Lam.prim ~primitive ~args:(Ext_list.map args simpl) loc + | Lifthenelse + ((Lprim { primitive = Pis_not_none; args = [ Lvar id ] } as l1), l2, l3) + -> ( + match Hash_ident.find_opt meta.ident_tbl id with + | Some (ImmutableBlock _ | MutableBlock _ | Normal_optional _) -> + simpl l2 + | Some (OptionalBlock (l, Null)) -> + Lam.if_ + (Lam.not_ Location.none + (Lam.prim ~primitive:Pis_null ~args:[ l ] Location.none)) + (simpl l2) (simpl l3) + | Some (OptionalBlock (l, Undefined)) -> + Lam.if_ + (Lam.not_ Location.none + (Lam.prim ~primitive:Pis_undefined ~args:[ l ] Location.none)) + (simpl l2) (simpl l3) + | Some (OptionalBlock (l, Null_undefined)) -> + Lam.if_ + (Lam.not_ Location.none + (Lam.prim ~primitive:Pis_null_undefined ~args:[ l ] + Location.none)) + (simpl l2) (simpl l3) + | Some _ | None -> Lam.if_ l1 (simpl l2) (simpl l3)) + (* could be the code path + {[ match x with + | h::hs -> + ]} + *) + | Lifthenelse (l1, l2, l3) -> ( + match l1 with + | Lvar id -> ( + match id_is_for_sure_true_in_boolean meta.ident_tbl id with + | Eval_true -> simpl l2 + | Eval_false -> simpl l3 + | Eval_unknown -> Lam.if_ (simpl l1) (simpl l2) (simpl l3)) + | _ -> Lam.if_ (simpl l1) (simpl l2) (simpl l3)) + | Lconst _ -> lam + | Llet (str, v, l1, l2) -> Lam.let_ str v (simpl l1) (simpl l2) + | Lletrec (bindings, body) -> + let bindings = Ext_list.map_snd bindings simpl in + Lam.letrec bindings (simpl body) + (* complicated + 1. inline this function + 2. ... + exports.Make= + function(funarg) + {var $$let=Make(funarg); + return [0, $$let[5],... $$let[16]]} + *) + | Lapply + { + ap_func = + Lprim + { + primitive = Pfield (_, Fld_module { name = fld_name }); + args = [ Lglobal_module ident ]; + _; + } as l1; + ap_args = args; + ap_info; + } -> ( + match Lam_compile_env.query_external_id_info ident fld_name with + | { persistent_closed_lambda = Some (Lfunction { params; body; _ }) } + (* be more cautious when do cross module inlining *) + when Ext_list.same_length params args + && Ext_list.for_all args (fun arg -> + match arg with + | Lvar p -> ( + match Hash_ident.find_opt meta.ident_tbl p with + | Some v -> v <> Parameter + | None -> true) + | _ -> true) -> + simpl (Lam_beta_reduce.propogate_beta_reduce meta params body args) + | _ -> Lam.apply (simpl l1) (Ext_list.map args simpl) ap_info) + (* Function inlining interact with other optimizations... -and core_type1 ctxt f x = - if x.ptyp_attributes <> [] then core_type ctxt f x - else match x.ptyp_desc with - | Ptyp_any -> pp f "_"; - | Ptyp_var s -> tyvar f s; - | Ptyp_tuple l -> pp f "(%a)" (list (core_type1 ctxt) ~sep:"@;*@;") l - | Ptyp_constr (li, l) -> - pp f (* "%a%a@;" *) "%a%a" - (fun f l -> match l with - |[] -> () - |[x]-> pp f "%a@;" (core_type1 ctxt) x - | _ -> list ~first:"(" ~last:")@;" (core_type ctxt) ~sep:",@;" f l) - l longident_loc li - | Ptyp_variant (l, closed, low) -> - let type_variant_helper f x = - match x with - | Rtag (l, attrs, _, ctl) -> - pp f "@[<2>%a%a@;%a@]" string_quot l.txt - (fun f l -> match l with - |[] -> () - | _ -> pp f "@;of@;%a" - (list (core_type ctxt) ~sep:"&") ctl) ctl - (attributes ctxt) attrs - | Rinherit ct -> core_type ctxt f ct in - pp f "@[<2>[%a%a]@]" - (fun f l -> - match l, closed with - | [], Closed -> () - | [], Open -> pp f ">" (* Cf #7200: print [>] correctly *) - | _ -> - pp f "%s@;%a" - (match (closed,low) with - | (Closed,None) -> "" - | (Closed,Some _) -> "<" (* FIXME desugar the syntax sugar*) - | (Open,_) -> ">") - (list type_variant_helper ~sep:"@;<1 -2>| ") l) l - (fun f low -> match low with - |Some [] |None -> () - |Some xs -> - pp f ">@ %a" - (list string_quot) xs) low - | Ptyp_object (l, o) -> - let core_field_type f = function - | Otag (l, attrs, ct) -> - pp f "@[%s: %a@ %a@ @]" l.txt - (core_type ctxt) ct (attributes ctxt) attrs (* Cf #7200 *) - | Oinherit ct -> - pp f "@[%a@ @]" (core_type ctxt) ct - in - let field_var f = function - | Asttypes.Closed -> () - | Asttypes.Open -> - match l with - | [] -> pp f ".." - | _ -> pp f " ;.." - in - pp f "@[<@ %a%a@ > @]" (list core_field_type ~sep:";") l - field_var o (* Cf #7200 *) - | Ptyp_class (li, l) -> (*FIXME*) - pp f "@[%a#%a@]" - (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") l - longident_loc li - | Ptyp_package (lid, cstrs) -> - let aux f (s, ct) = - pp f "type %a@ =@ %a" longident_loc s (core_type ctxt) ct in - (match cstrs with - |[] -> pp f "@[(module@ %a)@]" longident_loc lid - |_ -> - pp f "@[(module@ %a@ with@ %a)@]" longident_loc lid - (list aux ~sep:"@ and@ ") cstrs) - | Ptyp_extension e -> extension ctxt f e - | _ -> paren true (core_type ctxt) f x + - parameter attributes + - scope issues + - code bloat + *) + | Lapply { ap_func = Lvar v as fn; ap_args; ap_info } -> ( + (* Check info for always inlining *) -(********************pattern********************) -(* be cautious when use [pattern], [pattern1] is preferred *) -and pattern ctxt f x = - let rec list_of_pattern acc = function (* only consider ((A|B)|C)*) - | {ppat_desc= Ppat_or (p1,p2); ppat_attributes = []} -> - list_of_pattern (p2::acc) p1 - | x -> x::acc + (* Ext_log.dwarn __LOC__ "%s/%d" v.name v.stamp; *) + let ap_args = Ext_list.map ap_args simpl in + let[@local] normal () = Lam.apply (simpl fn) ap_args ap_info in + match Hash_ident.find_opt meta.ident_tbl v with + | Some + (FunctionId + { + lambda = + Some + ( Lfunction ({ params; body; attr = { is_a_functor } } as m), + rec_flag ); + }) -> + if Ext_list.same_length ap_args params (* && false *) then + if + is_a_functor + (* && (Set_ident.mem v meta.export_idents) && false *) + then + (* TODO: check l1 if it is exported, + if so, maybe not since in that case, + we are going to have two copy? + *) + + (* Check: recursive applying may result in non-termination *) + (* Ext_log.dwarn __LOC__ "beta .. %s/%d" v.name v.stamp ; *) + simpl + (Lam_beta_reduce.propogate_beta_reduce meta params body + ap_args) + else if + (* Lam_analysis.size body < Lam_analysis.small_inline_size *) + (* ap_inlined = Always_inline || *) + Lam_analysis.ok_to_inline_fun_when_app m ap_args + then + (* let param_map = *) + (* Lam_analysis.free_variables meta.export_idents *) + (* (Lam_analysis.param_map_of_list params) body in *) + (* let old_count = List.length params in *) + (* let new_count = Map_ident.cardinal param_map in *) + let param_map = + Lam_closure.is_closed_with_map meta.export_idents params body + in + let is_export_id = Set_ident.mem meta.export_idents v in + match (is_export_id, param_map) with + | false, (_, param_map) | true, (true, param_map) -> ( + match rec_flag with + | Lam_rec -> + Lam_beta_reduce.propogate_beta_reduce_with_map meta + param_map params body ap_args + | Lam_self_rec -> normal () + | Lam_non_rec -> + if + Ext_list.exists ap_args (fun lam -> + Lam_hit.hit_variable v lam) + (*avoid nontermination, e.g, `g(g)`*) + then normal () + else + simpl + (Lam_beta_reduce.propogate_beta_reduce_with_map meta + param_map params body ap_args)) + | _ -> normal () + else normal () + else normal () + | Some _ | None -> normal ()) + | Lapply { ap_func = Lfunction { params; body }; ap_args = args; _ } + when Ext_list.same_length params args -> + simpl (Lam_beta_reduce.propogate_beta_reduce meta params body args) + (* | Lapply{ fn = Lfunction{function_kind = Tupled; params; body}; *) + (* args = [Lprim {primitive = Pmakeblock _; args; _}]; _} *) + (* (\** TODO: keep track of this parameter in ocaml trunk, *) + (* can we switch to the tupled backend? *) + (* *\) *) + (* when Ext_list.same_length params args -> *) + (* simpl (Lam_beta_reduce.propogate_beta_reduce meta params body args) *) + | Lapply { ap_func = l1; ap_args = ll; ap_info } -> + Lam.apply (simpl l1) (Ext_list.map ll simpl) ap_info + | Lfunction { arity; params; body; attr } -> + Lam.function_ ~arity ~params ~body:(simpl body) ~attr + | Lswitch + ( l, + { + sw_failaction; + sw_consts; + sw_blocks; + sw_blocks_full; + sw_consts_full; + sw_names; + } ) -> + Lam.switch (simpl l) + { + sw_consts = Ext_list.map_snd sw_consts simpl; + sw_blocks = Ext_list.map_snd sw_blocks simpl; + sw_consts_full; + sw_blocks_full; + sw_failaction = Ext_option.map sw_failaction simpl; + sw_names; + } + | Lstringswitch (l, sw, d) -> + let l = + match l with + | Lvar s -> ( + match Hash_ident.find_opt meta.ident_tbl s with + | Some (Constant s) -> Lam.const s + | Some _ | None -> simpl l) + | _ -> simpl l + in + Lam.stringswitch l (Ext_list.map_snd sw simpl) (Ext_option.map d simpl) + | Lstaticraise (i, ls) -> Lam.staticraise i (Ext_list.map ls simpl) + | Lstaticcatch (l1, ids, l2) -> Lam.staticcatch (simpl l1) ids (simpl l2) + | Ltrywith (l1, v, l2) -> Lam.try_ (simpl l1) v (simpl l2) + | Lsequence (l1, l2) -> Lam.seq (simpl l1) (simpl l2) + | Lwhile (l1, l2) -> Lam.while_ (simpl l1) (simpl l2) + | Lfor (flag, l1, l2, dir, l3) -> + Lam.for_ flag (simpl l1) (simpl l2) dir (simpl l3) + | Lassign (v, l) -> + (* Lalias-bound variables are never assigned, so don't increase + v's refsimpl *) + Lam.assign v (simpl l) in - if x.ppat_attributes <> [] then begin - pp f "((%a)%a)" (pattern ctxt) {x with ppat_attributes=[]} - (attributes ctxt) x.ppat_attributes - end - else match x.ppat_desc with - | Ppat_alias (p, s) -> - pp f "@[<2>%a@;as@;%a@]" (pattern ctxt) p protect_ident s.txt (* RA*) - | Ppat_or _ -> (* *) - pp f "@[%a@]" (list ~sep:"@,|" (pattern ctxt)) - (list_of_pattern [] x) - | _ -> pattern1 ctxt f x + simpl lam -and pattern1 ctxt (f:Format.formatter) (x:pattern) : unit = - let rec pattern_list_helper f = function - | {ppat_desc = - Ppat_construct - ({ txt = Lident("::") ;_}, - Some ({ppat_desc = Ppat_tuple([pat1; pat2]);_})); - ppat_attributes = []} +end +module Ext_log : sig +#1 "ext_log.mli" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -> - pp f "%a::%a" (simple_pattern ctxt) pat1 pattern_list_helper pat2 (*RA*) - | p -> pattern1 ctxt f p - in - if x.ppat_attributes <> [] then pattern ctxt f x - else match x.ppat_desc with - | Ppat_variant (l, Some p) -> - pp f "@[<2>`%s@;%a@]" l (simple_pattern ctxt) p - | Ppat_construct (({txt=Lident("()"|"[]");_}), _) -> simple_pattern ctxt f x - | Ppat_construct (({txt;_} as li), po) -> - (* FIXME The third field always false *) - if txt = Lident "::" then - pp f "%a" pattern_list_helper x - else - (match po with - | Some x -> pp f "%a@;%a" longident_loc li (simple_pattern ctxt) x - | None -> pp f "%a" longident_loc li) - | _ -> simple_pattern ctxt f x +(** A Poor man's logging utility -and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = - if x.ppat_attributes <> [] then pattern ctxt f x - else match x.ppat_desc with - | Ppat_construct (({txt=Lident ("()"|"[]" as x);_}), _) -> pp f "%s" x - | Ppat_any -> pp f "_"; - | Ppat_var ({txt = txt;_}) -> protect_ident f txt - | Ppat_array l -> - pp f "@[<2>[|%a|]@]" (list (pattern1 ctxt) ~sep:";") l - | Ppat_unpack (s) -> - pp f "(module@ %s)@ " s.txt - | Ppat_type li -> - pp f "#%a" longident_loc li - | Ppat_record (l, closed) -> - let longident_x_pattern f (li, p) = - match (li,p) with - | ({txt=Lident s;_ }, - {ppat_desc=Ppat_var {txt;_}; - ppat_attributes=[]; _}) - when s = txt -> - pp f "@[<2>%a@]" longident_loc li - | _ -> - pp f "@[<2>%a@;=@;%a@]" longident_loc li (pattern1 ctxt) p - in - begin match closed with - | Closed -> - pp f "@[<2>{@;%a@;}@]" (list longident_x_pattern ~sep:";@;") l - | _ -> - pp f "@[<2>{@;%a;_}@]" (list longident_x_pattern ~sep:";@;") l - end - | Ppat_tuple l -> - pp f "@[<1>(%a)@]" (list ~sep:",@;" (pattern1 ctxt)) l (* level1*) - | Ppat_constant (c) -> pp f "%a" constant c - | Ppat_interval (c1, c2) -> pp f "%a..%a" constant c1 constant c2 - | Ppat_variant (l,None) -> pp f "`%s" l - | Ppat_constraint (p, ct) -> - pp f "@[<2>(%a@;:@;%a)@]" (pattern1 ctxt) p (core_type ctxt) ct - | Ppat_lazy p -> - pp f "@[<2>(lazy@;%a)@]" (pattern1 ctxt) p - | Ppat_exception p -> - pp f "@[<2>exception@;%a@]" (pattern1 ctxt) p - | Ppat_extension e -> extension ctxt f e - | Ppat_open (lid, p) -> - let with_paren = - match p.ppat_desc with - | Ppat_array _ | Ppat_record _ - | Ppat_construct (({txt=Lident ("()"|"[]");_}), _) -> false - | _ -> true in - pp f "@[<2>%a.%a @]" longident_loc lid - (paren with_paren @@ pattern1 ctxt) p - | _ -> paren true (pattern ctxt) f x + Example: + {[ + err __LOC__ "xx" + ]} +*) -and label_exp ctxt f (l,opt,p) = - match l with - | Nolabel -> - (* single case pattern parens needed here *) - pp f "%a@ " (simple_pattern ctxt) p - | Optional rest -> - begin match p with - | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []} - when txt = rest -> - (match opt with - | Some o -> pp f "?(%s=@;%a)@;" rest (expression ctxt) o - | None -> pp f "?%s@ " rest) - | _ -> - (match opt with - | Some o -> - pp f "?%s:(%a=@;%a)@;" - rest (pattern1 ctxt) p (expression ctxt) o - | None -> pp f "?%s:%a@;" rest (simple_pattern ctxt) p) - end - | Labelled l -> match p with - | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []} - when txt = l -> - pp f "~%s@;" l - | _ -> pp f "~%s:%a@;" l (simple_pattern ctxt) p +type 'a logging = ('a, Format.formatter, unit, unit, unit, unit) format6 -> 'a -and sugar_expr ctxt f e = - if e.pexp_attributes <> [] then false - else match e.pexp_desc with - | Pexp_apply ({ pexp_desc = Pexp_ident {txt = id; _}; - pexp_attributes=[]; _}, args) - when List.for_all (fun (lab, _) -> lab = Nolabel) args -> begin - let print_indexop a path_prefix assign left right print_index indices - rem_args = - let print_path ppf = function - | None -> () - | Some m -> pp ppf ".%a" longident m in - match assign, rem_args with - | false, [] -> - pp f "@[%a%a%s%a%s@]" - (simple_expr ctxt) a print_path path_prefix - left (list ~sep:"," print_index) indices right; true - | true, [v] -> - pp f "@[%a%a%s%a%s@ <-@;<1 2>%a@]" - (simple_expr ctxt) a print_path path_prefix - left (list ~sep:"," print_index) indices right - (simple_expr ctxt) v; true - | _ -> false in - match id, List.map snd args with - | Lident "!", [e] -> - pp f "@[!%a@]" (simple_expr ctxt) e; true - | Ldot (path, ("get"|"set" as func)), a :: other_args -> begin - let assign = func = "set" in - let print = print_indexop a None assign in - match path, other_args with - | Lident "Array", i :: rest -> - print ".(" ")" (expression ctxt) [i] rest - | Lident "String", i :: rest -> - print ".[" "]" (expression ctxt) [i] rest - | Ldot (Lident "Bigarray", "Array1"), i1 :: rest -> - print ".{" "}" (simple_expr ctxt) [i1] rest - | Ldot (Lident "Bigarray", "Array2"), i1 :: i2 :: rest -> - print ".{" "}" (simple_expr ctxt) [i1; i2] rest - | Ldot (Lident "Bigarray", "Array3"), i1 :: i2 :: i3 :: rest -> - print ".{" "}" (simple_expr ctxt) [i1; i2; i3] rest - | Ldot (Lident "Bigarray", "Genarray"), - {pexp_desc = Pexp_array indexes; pexp_attributes = []} :: rest -> - print ".{" "}" (simple_expr ctxt) indexes rest - | _ -> false - end - | (Lident s | Ldot(_,s)) , a :: i :: rest - when s.[0] = '.' -> - let n = String.length s in - (* extract operator: - assignment operators end with [right_bracket ^ "<-"], - access operators end with [right_bracket] directly - *) - let assign = s.[n - 1] = '-' in - let kind = - (* extract the right end bracket *) - if assign then s.[n - 3] else s.[n - 1] in - let left, right = match kind with - | ')' -> '(', ")" - | ']' -> '[', "]" - | '}' -> '{', "}" - | _ -> assert false in - let path_prefix = match id with - | Ldot(m,_) -> Some m - | _ -> None in - let left = String.sub s 0 (1+String.index s left) in - print_indexop a path_prefix assign left right - (expression ctxt) [i] rest - | _ -> false - end - | _ -> false +val dwarn : ?__POS__:string * int * int * int -> 'a logging -and expression ctxt f x = - if x.pexp_attributes <> [] then - pp f "((%a)@,%a)" (expression ctxt) {x with pexp_attributes=[]} - (attributes ctxt) x.pexp_attributes - else match x.pexp_desc with - | Pexp_function _ | Pexp_fun _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _ - when ctxt.pipe || ctxt.semi -> - paren true (expression reset_ctxt) f x - | Pexp_ifthenelse _ | Pexp_sequence _ when ctxt.ifthenelse -> - paren true (expression reset_ctxt) f x - | Pexp_let _ | Pexp_letmodule _ | Pexp_open _ | Pexp_letexception _ - when ctxt.semi -> - paren true (expression reset_ctxt) f x - | Pexp_fun (l, e0, p, e) -> - pp f "@[<2>fun@;%a->@;%a@]" - (label_exp ctxt) (l, e0, p) - (expression ctxt) e - | Pexp_function l -> - pp f "@[function%a@]" (case_list ctxt) l - | Pexp_match (e, l) -> - pp f "@[@[@[<2>match %a@]@ with@]%a@]" - (expression reset_ctxt) e (case_list ctxt) l +end = struct +#1 "ext_log.ml" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - | Pexp_try (e, l) -> - pp f "@[<0>@[try@ %a@]@ @[<0>with%a@]@]" - (* "try@;@[<2>%a@]@\nwith@\n%a"*) - (expression reset_ctxt) e (case_list ctxt) l - | Pexp_let (rf, l, e) -> - (* pp f "@[<2>let %a%a in@;<1 -2>%a@]" - (*no indentation here, a new line*) *) - (* rec_flag rf *) - pp f "@[<2>%a in@;<1 -2>%a@]" - (bindings reset_ctxt) (rf,l) - (expression ctxt) e - | Pexp_apply (e, l) -> - begin if not (sugar_expr ctxt f x) then - match view_fixity_of_exp e with - | `Infix s -> - begin match l with - | [ (Nolabel, _) as arg1; (Nolabel, _) as arg2 ] -> - (* FIXME associativity label_x_expression_param *) - pp f "@[<2>%a@;%s@;%a@]" - (label_x_expression_param reset_ctxt) arg1 s - (label_x_expression_param ctxt) arg2 - | _ -> - pp f "@[<2>%a %a@]" - (simple_expr ctxt) e - (list (label_x_expression_param ctxt)) l - end - | `Prefix s -> - let s = - if List.mem s ["~+";"~-";"~+.";"~-."] && - (match l with - (* See #7200: avoid turning (~- 1) into (- 1) which is - parsed as an int literal *) - |[(_,{pexp_desc=Pexp_constant _})] -> false - | _ -> true) - then String.sub s 1 (String.length s -1) - else s in - begin match l with - | [(Nolabel, x)] -> - pp f "@[<2>%s@;%a@]" s (simple_expr ctxt) x - | _ -> - pp f "@[<2>%a %a@]" (simple_expr ctxt) e - (list (label_x_expression_param ctxt)) l - end - | _ -> - pp f "@[%a@]" begin fun f (e,l) -> - pp f "%a@ %a" (expression2 ctxt) e - (list (label_x_expression_param reset_ctxt)) l - (* reset here only because [function,match,try,sequence] - are lower priority *) - end (e,l) - end +type 'a logging = ('a, Format.formatter, unit, unit, unit, unit) format6 -> 'a - | Pexp_construct (li, Some eo) - when not (is_simple_construct (view_expr x))-> (* Not efficient FIXME*) - (match view_expr x with - | `cons ls -> list (simple_expr ctxt) f ls ~sep:"@;::@;" - | `normal -> - pp f "@[<2>%a@;%a@]" longident_loc li - (simple_expr ctxt) eo - | _ -> assert false) - | Pexp_setfield (e1, li, e2) -> - pp f "@[<2>%a.%a@ <-@ %a@]" - (simple_expr ctxt) e1 longident_loc li (simple_expr ctxt) e2 - | Pexp_ifthenelse (e1, e2, eo) -> - (* @;@[<2>else@ %a@]@] *) - let fmt:(_,_,_)format ="@[@[<2>if@ %a@]@;@[<2>then@ %a@]%a@]" in - let expression_under_ifthenelse = expression (under_ifthenelse ctxt) in - pp f fmt expression_under_ifthenelse e1 expression_under_ifthenelse e2 - (fun f eo -> match eo with - | Some x -> - pp f "@;@[<2>else@;%a@]" (expression (under_semi ctxt)) x - | None -> () (* pp f "()" *)) eo - | Pexp_sequence _ -> - let rec sequence_helper acc = function - | {pexp_desc=Pexp_sequence(e1,e2); pexp_attributes = []} -> - sequence_helper (e1::acc) e2 - | v -> List.rev (v::acc) in - let lst = sequence_helper [] x in - pp f "@[%a@]" - (list (expression (under_semi ctxt)) ~sep:";@;") lst - | Pexp_new (li) -> - pp f "@[new@ %a@]" longident_loc li; - | Pexp_setinstvar (s, e) -> - pp f "@[%s@ <-@ %a@]" s.txt (expression ctxt) e - | Pexp_override l -> (* FIXME *) - let string_x_expression f (s, e) = - pp f "@[%s@ =@ %a@]" s.txt (expression ctxt) e in - pp f "@[{<%a>}@]" - (list string_x_expression ~sep:";" ) l; - | Pexp_letmodule (s, me, e) -> - pp f "@[let@ module@ %s@ =@ %a@ in@ %a@]" s.txt - (module_expr reset_ctxt) me (expression ctxt) e - | Pexp_letexception (cd, e) -> - pp f "@[let@ exception@ %a@ in@ %a@]" - (extension_constructor ctxt) cd - (expression ctxt) e - | Pexp_assert e -> - pp f "@[assert@ %a@]" (simple_expr ctxt) e - | Pexp_lazy (e) -> - pp f "@[lazy@ %a@]" (simple_expr ctxt) e - (* Pexp_poly: impossible but we should print it anyway, rather than - assert false *) - | Pexp_poly (e, None) -> - pp f "@[!poly!@ %a@]" (simple_expr ctxt) e - | Pexp_poly (e, Some ct) -> - pp f "@[(!poly!@ %a@ : %a)@]" - (simple_expr ctxt) e (core_type ctxt) ct - | Pexp_open (ovf, lid, e) -> - pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid - (expression ctxt) e - | Pexp_variant (l,Some eo) -> - pp f "@[<2>`%s@;%a@]" l (simple_expr ctxt) eo - | Pexp_extension e -> extension ctxt f e - | Pexp_unreachable -> pp f "." - | _ -> expression1 ctxt f x +(* TODO: add {[@.]} later for all *) +let dwarn ?(__POS__ : (string * int * int * int) option) f = + if Js_config.get_diagnose () then + match __POS__ with + | None -> Format.fprintf Format.err_formatter ("WARN: " ^^ f ^^ "@.") + | Some (file, line, _, _) -> + Format.fprintf Format.err_formatter + ("WARN: %s,%d " ^^ f ^^ "@.") + file line + else Format.ifprintf Format.err_formatter ("WARN: " ^^ f ^^ "@.") -and expression1 ctxt f x = - if x.pexp_attributes <> [] then expression ctxt f x - else match x.pexp_desc with - | Pexp_object cs -> pp f "%a" (class_structure ctxt) cs - | _ -> expression2 ctxt f x -(* used in [Pexp_apply] *) +end +module Lam_stats_export : sig +#1 "lam_stats_export.mli" +(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. + * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -and expression2 ctxt f x = - if x.pexp_attributes <> [] then expression ctxt f x - else match x.pexp_desc with - | Pexp_field (e, li) -> - pp f "@[%a.%a@]" (simple_expr ctxt) e longident_loc li - | Pexp_send (e, s) -> pp f "@[%a#%s@]" (simple_expr ctxt) e s.txt +val get_dependent_module_effect : + string option -> Lam_module_ident.t list -> string option - | _ -> simple_expr ctxt f x +val export_to_cmj : + Lam_stats.t -> + Js_cmj_format.effect -> + Lam.t Map_ident.t -> + Ext_js_file_kind.case -> + Js_cmj_format.t -and simple_expr ctxt f x = - if x.pexp_attributes <> [] then expression ctxt f x - else match x.pexp_desc with - | Pexp_construct _ when is_simple_construct (view_expr x) -> - (match view_expr x with - | `nil -> pp f "[]" - | `tuple -> pp f "()" - | `list xs -> - pp f "@[[%a]@]" - (list (expression (under_semi ctxt)) ~sep:";@;") xs - | `simple x -> longident f x - | _ -> assert false) - | Pexp_ident li -> - longident_loc f li - (* (match view_fixity_of_exp x with *) - (* |`Normal -> longident_loc f li *) - (* | `Prefix _ | `Infix _ -> pp f "( %a )" longident_loc li) *) - | Pexp_constant c -> constant f c; - | Pexp_pack me -> - pp f "(module@;%a)" (module_expr ctxt) me - | Pexp_newtype (lid, e) -> - pp f "fun@;(type@;%s)@;->@;%a" lid.txt (expression ctxt) e - | Pexp_tuple l -> - pp f "@[(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l - | Pexp_constraint (e, ct) -> - pp f "(%a : %a)" (expression ctxt) e (core_type ctxt) ct - | Pexp_coerce (e, cto1, ct) -> - pp f "(%a%a :> %a)" (expression ctxt) e - (option (core_type ctxt) ~first:" : " ~last:" ") cto1 (* no sep hint*) - (core_type ctxt) ct - | Pexp_variant (l, None) -> pp f "`%s" l - | Pexp_record (l, eo) -> - let longident_x_expression f ( li, e) = - match e with - | {pexp_desc=Pexp_ident {txt;_}; - pexp_attributes=[]; _} when li.txt = txt -> - pp f "@[%a@]" longident_loc li - | _ -> - pp f "@[%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e - in - pp f "@[@[{@;%a%a@]@;}@]"(* "@[{%a%a}@]" *) - (option ~last:" with@;" (simple_expr ctxt)) eo - (list longident_x_expression ~sep:";@;") l - | Pexp_array (l) -> - pp f "@[<0>@[<2>[|%a|]@]@]" - (list (simple_expr (under_semi ctxt)) ~sep:";") l - | Pexp_while (e1, e2) -> - let fmt : (_,_,_) format = "@[<2>while@;%a@;do@;%a@;done@]" in - pp f fmt (expression ctxt) e1 (expression ctxt) e2 - | Pexp_for (s, e1, e2, df, e3) -> - let fmt:(_,_,_)format = - "@[@[@[<2>for %a =@;%a@;%a%a@;do@]@;%a@]@;done@]" in - let expression = expression ctxt in - pp f fmt (pattern ctxt) s expression e1 direction_flag - df expression e2 expression e3 - | _ -> paren true (expression ctxt) f x +end = struct +#1 "lam_stats_export.ml" +(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. + * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -and attributes ctxt f l = - List.iter (attribute ctxt f) l +(* let pp = Format.fprintf *) +(* we should exclude meaninglist names and do the convert as well *) -and item_attributes ctxt f l = - List.iter (item_attribute ctxt f) l +(* let meaningless_names = ["*opt*"; "param";] *) + +let single_na = Js_cmj_format.single_na + +let values_of_export (meta : Lam_stats.t) (export_map : Lam.t Map_ident.t) : + Js_cmj_format.cmj_value Map_string.t = + Ext_list.fold_left meta.exports Map_string.empty (fun acc x -> + let arity : Js_cmj_format.arity = + match Hash_ident.find_opt meta.ident_tbl x with + | Some (FunctionId { arity; _ }) -> Single arity + | Some (ImmutableBlock elems) -> + (* FIXME: field name for dumping*) + Submodule + (Ext_array.map elems (fun x -> + match x with + | NA -> Lam_arity.na + | SimpleForm lam -> Lam_arity_analysis.get_arity meta lam)) + | Some _ | None -> ( + match Map_ident.find_opt export_map x with + | Some (Lprim { primitive = Pmakeblock (_, _, Immutable); args }) -> + Submodule + (Ext_array.of_list_map args (fun lam -> + Lam_arity_analysis.get_arity meta lam)) + | Some _ | None -> single_na) + in + let persistent_closed_lambda = + let optlam = Map_ident.find_opt export_map x in + match optlam with + | Some + (Lconst + ( Const_js_null | Const_js_undefined | Const_js_true + | Const_js_false )) + | None -> + optlam + | Some lambda -> + if not !Js_config.cross_module_inline then None + else if + Lam_analysis.safe_to_inline lambda + (* when inlning a non function, we have to be very careful, + only truly immutable values can be inlined + *) + then + match lambda with + | Lfunction { attr = { inline = Always_inline } } + (* FIXME: is_closed lambda is too restrictive + It precludes ues cases + - inline forEach but not forEachU + *) + | Lfunction { attr = { is_a_functor = true } } -> + if Lam_closure.is_closed lambda (* TODO: seriealize more*) + then optlam + else None + | _ -> + let lam_size = Lam_analysis.size lambda in + (* TODO: + 1. global need re-assocate when do the beta reduction + 2. [lambda_exports] is not precise + *) + let free_variables = + Lam_closure.free_variables Set_ident.empty Map_ident.empty + lambda + in + if + lam_size < Lam_analysis.small_inline_size + && Map_ident.is_empty free_variables + then ( + Ext_log.dwarn ~__POS__ "%s recorded for inlining @." x.name; + optlam) + else None + else None + in + match (arity, persistent_closed_lambda) with + | Single Arity_na, (None | Some (Lconst Const_module_alias)) -> acc + | Submodule [||], None -> acc + | _ -> + let cmj_value : Js_cmj_format.cmj_value = + { arity; persistent_closed_lambda } + in + Map_string.add acc x.name cmj_value) -and attribute ctxt f (s, e) = - pp f "@[<2>[@@%s@ %a]@]" s.txt (payload ctxt) e +(* ATTENTION: all runtime modules, if it is not hard required, + it should be okay to not reference it +*) +let get_dependent_module_effect (maybe_pure : string option) + (external_ids : Lam_module_ident.t list) = + if maybe_pure = None then + let non_pure_module = + Ext_list.find_first_not external_ids Lam_compile_env.is_pure_module + in + Ext_option.map non_pure_module (fun x -> Lam_module_ident.name x) + else maybe_pure -and item_attribute ctxt f (s, e) = - pp f "@[<2>[@@@@%s@ %a]@]" s.txt (payload ctxt) e +(* Note that + [lambda_exports] is + lambda expression to be exported + for the js backend, we compile to js + for the inliner, we try to seriaize it -- + relies on other optimizations to make this happen + {[ + exports.Make = function () {.....} + ]} + TODO: check that we don't do this in browser environment +*) +let export_to_cmj (meta : Lam_stats.t) effect export_map case : Js_cmj_format.t + = + let values = values_of_export meta export_map in -and floating_attribute ctxt f (s, e) = - pp f "@[<2>[@@@@@@%s@ %a]@]" s.txt (payload ctxt) e + Js_cmj_format.make ~values ~effect + ~package_spec:(Js_packages_state.get_packages_info ()) + ~case +(* FIXME: make sure [-o] would not change its case + add test for ns/non-ns +*) -and value_description ctxt f x = - (* note: value_description has an attribute field, - but they're already printed by the callers this method *) - pp f "@[%a%a@]" (core_type ctxt) x.pval_type - (fun f x -> - - if x.pval_prim <> [] - then pp f "@ =@ %a" (list constant_string) x.pval_prim +end +module Lam_compile_main : sig +#1 "lam_compile_main.mli" +(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. + * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - ) x +(** ReScript entry point in the OCaml compiler *) -and extension ctxt f (s, e) = - pp f "@[<2>[%%%s@ %a]@]" s.txt (payload ctxt) e +(** Compile and register the hook of function to compile a lambda to JS IR +*) -and item_extension ctxt f (s, e) = - pp f "@[<2>[%%%%%s@ %a]@]" s.txt (payload ctxt) e +val compile : string -> Ident.t list -> Lambda.lambda -> J.deps_program +(** For toplevel, [filename] is [""] which is the same as + {!Env.get_unit_name ()} +*) -and exception_declaration ctxt f ext = - pp f "@[exception@ %a@]" (extension_constructor ctxt) ext +val lambda_as_module : J.deps_program -> string -> unit -and class_signature ctxt f { pcsig_self = ct; pcsig_fields = l ;_} = - let class_type_field f x = - match x.pctf_desc with - | Pctf_inherit (ct) -> - pp f "@[<2>inherit@ %a@]%a" (class_type ctxt) ct - (item_attributes ctxt) x.pctf_attributes - | Pctf_val (s, mf, vf, ct) -> - pp f "@[<2>val @ %a%a%s@ :@ %a@]%a" - mutable_flag mf virtual_flag vf s.txt (core_type ctxt) ct - (item_attributes ctxt) x.pctf_attributes - | Pctf_method (s, pf, vf, ct) -> - pp f "@[<2>method %a %a%s :@;%a@]%a" - private_flag pf virtual_flag vf s.txt (core_type ctxt) ct - (item_attributes ctxt) x.pctf_attributes - | Pctf_constraint (ct1, ct2) -> - pp f "@[<2>constraint@ %a@ =@ %a@]%a" - (core_type ctxt) ct1 (core_type ctxt) ct2 - (item_attributes ctxt) x.pctf_attributes - | Pctf_attribute a -> floating_attribute ctxt f a - | Pctf_extension e -> - item_extension ctxt f e; - item_attributes ctxt f x.pctf_attributes - in - pp f "@[@[object@[<1>%a@]@ %a@]@ end@]" - (fun f -> function - {ptyp_desc=Ptyp_any; ptyp_attributes=[]; _} -> () - | ct -> pp f " (%a)" (core_type ctxt) ct) ct - (list class_type_field ~sep:"@;") l +end = struct +#1 "lam_compile_main.pp.ml" +(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. + * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -(* call [class_signature] called by [class_signature] *) -and class_type ctxt f x = - match x.pcty_desc with - | Pcty_signature cs -> - class_signature ctxt f cs; - attributes ctxt f x.pcty_attributes - | Pcty_constr (li, l) -> - pp f "%a%a%a" - (fun f l -> match l with - | [] -> () - | _ -> pp f "[%a]@ " (list (core_type ctxt) ~sep:"," ) l) l - longident_loc li - (attributes ctxt) x.pcty_attributes - | Pcty_arrow (l, co, cl) -> - pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) - (type_with_label ctxt) (l,co) - (class_type ctxt) cl - | Pcty_extension e -> - extension ctxt f e; - attributes ctxt f x.pcty_attributes - | Pcty_open (ovf, lid, e) -> - pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid - (class_type ctxt) e -(* [class type a = object end] *) -and class_type_declaration_list ctxt f l = - let class_type_declaration kwd f x = - let { pci_params=ls; pci_name={ txt; _ }; _ } = x in - pp f "@[<2>%s %a%a%s@ =@ %a@]%a" kwd - virtual_flag x.pci_virt - (class_params_def ctxt) ls txt - (class_type ctxt) x.pci_expr - (item_attributes ctxt) x.pci_attributes - in - match l with - | [] -> () - | [x] -> class_type_declaration "class type" f x - | x :: xs -> - pp f "@[%a@,%a@]" - (class_type_declaration "class type") x - (list ~sep:"@," (class_type_declaration "and")) xs -and class_field ctxt f x = - match x.pcf_desc with - | Pcf_inherit () -> () - | Pcf_val (s, mf, Cfk_concrete (ovf, e)) -> - pp f "@[<2>val%s %a%s =@;%a@]%a" (override ovf) - mutable_flag mf s.txt - (expression ctxt) e - (item_attributes ctxt) x.pcf_attributes - | Pcf_method (s, pf, Cfk_virtual ct) -> - pp f "@[<2>method virtual %a %s :@;%a@]%a" - private_flag pf s.txt - (core_type ctxt) ct - (item_attributes ctxt) x.pcf_attributes - | Pcf_val (s, mf, Cfk_virtual ct) -> - pp f "@[<2>val virtual %a%s :@ %a@]%a" - mutable_flag mf s.txt - (core_type ctxt) ct - (item_attributes ctxt) x.pcf_attributes - | Pcf_method (s, pf, Cfk_concrete (ovf, e)) -> - let bind e = - binding ctxt f - {pvb_pat= - {ppat_desc=Ppat_var s;ppat_loc=Location.none;ppat_attributes=[]}; - pvb_expr=e; - pvb_attributes=[]; - pvb_loc=Location.none; - } - in - pp f "@[<2>method%s %a%a@]%a" - (override ovf) - private_flag pf - (fun f -> function - | {pexp_desc=Pexp_poly (e, Some ct); pexp_attributes=[]; _} -> - pp f "%s :@;%a=@;%a" - s.txt (core_type ctxt) ct (expression ctxt) e - | {pexp_desc=Pexp_poly (e, None); pexp_attributes=[]; _} -> - bind e - | _ -> bind e) e - (item_attributes ctxt) x.pcf_attributes - | Pcf_constraint (ct1, ct2) -> - pp f "@[<2>constraint %a =@;%a@]%a" - (core_type ctxt) ct1 - (core_type ctxt) ct2 - (item_attributes ctxt) x.pcf_attributes - | Pcf_initializer (e) -> - pp f "@[<2>initializer@ %a@]%a" - (expression ctxt) e - (item_attributes ctxt) x.pcf_attributes - | Pcf_attribute a -> floating_attribute ctxt f a - | Pcf_extension e -> - item_extension ctxt f e; - item_attributes ctxt f x.pcf_attributes -and class_structure ctxt f { pcstr_self = p; pcstr_fields = l } = - pp f "@[@[object%a@;%a@]@;end@]" - (fun f p -> match p.ppat_desc with - | Ppat_any -> () - | Ppat_constraint _ -> pp f " %a" (pattern ctxt) p - | _ -> pp f " (%a)" (pattern ctxt) p) p - (list (class_field ctxt)) l -and module_type ctxt f x = - if x.pmty_attributes <> [] then begin - pp f "((%a)%a)" (module_type ctxt) {x with pmty_attributes=[]} - (attributes ctxt) x.pmty_attributes - end else - match x.pmty_desc with - | Pmty_ident li -> - pp f "%a" longident_loc li; - | Pmty_alias li -> - pp f "(module %a)" longident_loc li; - | Pmty_signature (s) -> - pp f "@[@[sig@ %a@]@ end@]" (* "@[sig@ %a@ end@]" *) - (list (signature_item ctxt)) s (* FIXME wrong indentation*) - | Pmty_functor (_, None, mt2) -> - pp f "@[functor () ->@ %a@]" (module_type ctxt) mt2 - | Pmty_functor (s, Some mt1, mt2) -> - if s.txt = "_" then - pp f "@[%a@ ->@ %a@]" - (module_type ctxt) mt1 (module_type ctxt) mt2 - else - pp f "@[functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt - (module_type ctxt) mt1 (module_type ctxt) mt2 - | Pmty_with (mt, l) -> - let with_constraint f = function - | Pwith_type (li, ({ptype_params= ls ;_} as td)) -> - let ls = List.map fst ls in - pp f "type@ %a %a =@ %a" - (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") - ls longident_loc li (type_declaration ctxt) td - | Pwith_module (li, li2) -> - pp f "module %a =@ %a" longident_loc li longident_loc li2; - | Pwith_typesubst (li, ({ptype_params=ls;_} as td)) -> - let ls = List.map fst ls in - pp f "type@ %a %a :=@ %a" - (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") - ls longident_loc li - (type_declaration ctxt) td - | Pwith_modsubst (li, li2) -> - pp f "module %a :=@ %a" longident_loc li longident_loc li2 in - (match l with - | [] -> pp f "@[%a@]" (module_type ctxt) mt - | _ -> pp f "@[(%a@ with@ %a)@]" - (module_type ctxt) mt (list with_constraint ~sep:"@ and@ ") l) - | Pmty_typeof me -> - pp f "@[module@ type@ of@ %a@]" (module_expr ctxt) me - | Pmty_extension e -> extension ctxt f e -and signature ctxt f x = list ~sep:"@\n" (signature_item ctxt) f x -and signature_item ctxt f x : unit = - match x.psig_desc with - | Psig_type (rf, l) -> - type_def_list ctxt f (rf, l) - | Psig_value vd -> - let intro = if vd.pval_prim = [] then "val" else "external" in - pp f "@[<2>%s@ %a@ :@ %a@]%a" intro - protect_ident vd.pval_name.txt - (value_description ctxt) vd - (item_attributes ctxt) vd.pval_attributes - | Psig_typext te -> - type_extension ctxt f te - | Psig_exception ed -> - exception_declaration ctxt f ed - | Psig_class () -> - () - | Psig_module ({pmd_type={pmty_desc=Pmty_alias alias; - pmty_attributes=[]; _};_} as pmd) -> - pp f "@[module@ %s@ =@ %a@]%a" pmd.pmd_name.txt - longident_loc alias - (item_attributes ctxt) pmd.pmd_attributes - | Psig_module pmd -> - pp f "@[module@ %s@ :@ %a@]%a" - pmd.pmd_name.txt - (module_type ctxt) pmd.pmd_type - (item_attributes ctxt) pmd.pmd_attributes - | Psig_open od -> - pp f "@[open%s@ %a@]%a" - (override od.popen_override) - longident_loc od.popen_lid - (item_attributes ctxt) od.popen_attributes - | Psig_include incl -> - pp f "@[include@ %a@]%a" - (module_type ctxt) incl.pincl_mod - (item_attributes ctxt) incl.pincl_attributes - | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> - pp f "@[module@ type@ %s%a@]%a" - s.txt - (fun f md -> match md with - | None -> () - | Some mt -> - pp_print_space f () ; - pp f "@ =@ %a" (module_type ctxt) mt - ) md - (item_attributes ctxt) attrs - | Psig_class_type (l) -> class_type_declaration_list ctxt f l - | Psig_recmodule decls -> - let rec string_x_module_type_list f ?(first=true) l = - match l with - | [] -> () ; - | pmd :: tl -> - if not first then - pp f "@ @[and@ %s:@ %a@]%a" pmd.pmd_name.txt - (module_type ctxt) pmd.pmd_type - (item_attributes ctxt) pmd.pmd_attributes - else - pp f "@[module@ rec@ %s:@ %a@]%a" pmd.pmd_name.txt - (module_type ctxt) pmd.pmd_type - (item_attributes ctxt) pmd.pmd_attributes; - string_x_module_type_list f ~first:false tl - in - string_x_module_type_list f decls - | Psig_attribute a -> floating_attribute ctxt f a - | Psig_extension(e, a) -> - item_extension ctxt f e; - item_attributes ctxt f a -and module_expr ctxt f x = - if x.pmod_attributes <> [] then - pp f "((%a)%a)" (module_expr ctxt) {x with pmod_attributes=[]} - (attributes ctxt) x.pmod_attributes - else match x.pmod_desc with - | Pmod_structure (s) -> - pp f "@[struct@;@[<0>%a@]@;<1 -2>end@]" - (list (structure_item ctxt) ~sep:"@\n") s; - | Pmod_constraint (me, mt) -> - pp f "@[(%a@ :@ %a)@]" - (module_expr ctxt) me - (module_type ctxt) mt - | Pmod_ident (li) -> - pp f "%a" longident_loc li; - | Pmod_functor (_, None, me) -> - pp f "functor ()@;->@;%a" (module_expr ctxt) me - | Pmod_functor (s, Some mt, me) -> - pp f "functor@ (%s@ :@ %a)@;->@;%a" - s.txt (module_type ctxt) mt (module_expr ctxt) me - | Pmod_apply (me1, me2) -> - pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2 - (* Cf: #7200 *) - | Pmod_unpack e -> - pp f "(val@ %a)" (expression ctxt) e - | Pmod_extension e -> extension ctxt f e +(* module E = Js_exp_make *) +(* module S = Js_stmt_make *) -and structure ctxt f x = list ~sep:"@\n" (structure_item ctxt) f x -and payload ctxt f = function - | PStr [{pstr_desc = Pstr_eval (e, attrs)}] -> - pp f "@[<2>%a@]%a" - (expression ctxt) e - (item_attributes ctxt) attrs - | PStr x -> structure ctxt f x - | PTyp x -> pp f ":"; core_type ctxt f x - | PSig x -> pp f ":"; signature ctxt f x - | PPat (x, None) -> pp f "?"; pattern ctxt f x - | PPat (x, Some e) -> - pp f "?"; pattern ctxt f x; - pp f " when "; expression ctxt f e +let compile_group (meta : Lam_stats.t) + (x : Lam_group.t) : Js_output.t = + match x with + (* + We need -(* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *) -and binding ctxt f {pvb_pat=p; pvb_expr=x; _} = - (* .pvb_attributes have already been printed by the caller, #bindings *) - let rec pp_print_pexp_function f x = - if x.pexp_attributes <> [] then pp f "=@;%a" (expression ctxt) x - else match x.pexp_desc with - | Pexp_fun (label, eo, p, e) -> - if label=Nolabel then - pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function e - else - pp f "%a@ %a" - (label_exp ctxt) (label,eo,p) pp_print_pexp_function e - | Pexp_newtype (str,e) -> - pp f "(type@ %s)@ %a" str.txt pp_print_pexp_function e - | _ -> pp f "=@;%a" (expression ctxt) x - in - let tyvars_str tyvars = List.map (fun v -> v.txt) tyvars in - let is_desugared_gadt p e = - let gadt_pattern = - match p with - | {ppat_desc=Ppat_constraint({ppat_desc=Ppat_var _} as pat, - {ptyp_desc=Ptyp_poly (args_tyvars, rt)}); - ppat_attributes=[]}-> - Some (pat, args_tyvars, rt) - | _ -> None in - let rec gadt_exp tyvars e = - match e with - | {pexp_desc=Pexp_newtype (tyvar, e); pexp_attributes=[]} -> - gadt_exp (tyvar :: tyvars) e - | {pexp_desc=Pexp_constraint (e, ct); pexp_attributes=[]} -> - Some (List.rev tyvars, e, ct) - | _ -> None in - let gadt_exp = gadt_exp [] e in - match gadt_pattern, gadt_exp with - | Some (p, pt_tyvars, pt_ct), Some (e_tyvars, e, e_ct) - when tyvars_str pt_tyvars = tyvars_str e_tyvars -> - let ety = Typ.varify_constructors e_tyvars e_ct in - if ety = pt_ct then - Some (p, pt_tyvars, e_ct, e) else None - | _ -> None in - if x.pexp_attributes <> [] - then pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x else - match is_desugared_gadt p x with - | Some (p, [], ct, e) -> - pp f "%a@;: %a@;=@;%a" - (simple_pattern ctxt) p (core_type ctxt) ct (expression ctxt) e - | Some (p, tyvars, ct, e) -> begin - pp f "%a@;: type@;%a.@;%a@;=@;%a" - (simple_pattern ctxt) p (list pp_print_string ~sep:"@;") - (tyvars_str tyvars) (core_type ctxt) ct (expression ctxt) e - end - | None -> begin - match p with - | {ppat_desc=Ppat_constraint(p ,ty); - ppat_attributes=[]} -> (* special case for the first*) - begin match ty with - | {ptyp_desc=Ptyp_poly _; ptyp_attributes=[]} -> - pp f "%a@;:@;%a@;=@;%a" (simple_pattern ctxt) p - (core_type ctxt) ty (expression ctxt) x - | _ -> - pp f "(%a@;:@;%a)@;=@;%a" (simple_pattern ctxt) p - (core_type ctxt) ty (expression ctxt) x - end - | {ppat_desc=Ppat_var _; ppat_attributes=[]} -> - pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x - | _ -> - pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x - end + 2. [E.builtin_dot] for javascript builtin + 3. [E.mldot] + *) + (* ATTENTION: check {!Lam_compile_global} for consistency *) + (* Special handling for values in [Pervasives] *) + (* + we delegate [stdout, stderr, and stdin] into [caml_io] module, + the motivation is to help dead code eliminatiion, it's helpful + to make those parts pure (not a function call), then it can be removed + if unused + *) -(* [in] is not printed *) -and bindings ctxt f (rf,l) = - let binding kwd rf f x = - pp f "@[<2>%s %a%a@]%a" kwd rec_flag rf - (binding ctxt) x (item_attributes ctxt) x.pvb_attributes - in - match l with - | [] -> () - | [x] -> binding "let" rf f x - | x::xs -> - pp f "@[%a@,%a@]" - (binding "let" rf) x - (list ~sep:"@," (binding "and" Nonrecursive)) xs + (* QUICK hack to make hello world example nicer, + Note the arity of [print_endline] is already analyzed before, + so it should be safe + *) -and structure_item ctxt f x = - match x.pstr_desc with - | Pstr_eval (e, attrs) -> - pp f "@[;;%a@]%a" - (expression ctxt) e - (item_attributes ctxt) attrs - | Pstr_type (_, []) -> assert false - | Pstr_type (rf, l) -> type_def_list ctxt f (rf, l) - | Pstr_value (rf, l) -> - (* pp f "@[let %a%a@]" rec_flag rf bindings l *) - pp f "@[<2>%a@]" (bindings ctxt) (rf,l) - | Pstr_typext te -> type_extension ctxt f te - | Pstr_exception ed -> exception_declaration ctxt f ed - | Pstr_module x -> - let rec module_helper = function - | {pmod_desc=Pmod_functor(s,mt,me'); pmod_attributes = []} -> - if mt = None then pp f "()" - else Misc.may (pp f "(%s:%a)" s.txt (module_type ctxt)) mt; - module_helper me' - | me -> me - in - pp f "@[module %s%a@]%a" - x.pmb_name.txt - (fun f me -> - let me = module_helper me in - match me with - | {pmod_desc= - Pmod_constraint - (me', - ({pmty_desc=(Pmty_ident (_) - | Pmty_signature (_));_} as mt)); - pmod_attributes = []} -> - pp f " :@;%a@;=@;%a@;" - (module_type ctxt) mt (module_expr ctxt) me' - | _ -> pp f " =@ %a" (module_expr ctxt) me - ) x.pmb_expr - (item_attributes ctxt) x.pmb_attributes - | Pstr_open od -> - pp f "@[<2>open%s@;%a@]%a" - (override od.popen_override) - longident_loc od.popen_lid - (item_attributes ctxt) od.popen_attributes - | Pstr_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> - pp f "@[module@ type@ %s%a@]%a" - s.txt - (fun f md -> match md with - | None -> () - | Some mt -> - pp_print_space f () ; - pp f "@ =@ %a" (module_type ctxt) mt - ) md - (item_attributes ctxt) attrs - | Pstr_class () -> () - | Pstr_class_type l -> class_type_declaration_list ctxt f l - | Pstr_primitive vd -> - pp f "@[external@ %a@ :@ %a@]%a" - protect_ident vd.pval_name.txt - (value_description ctxt) vd - (item_attributes ctxt) vd.pval_attributes - | Pstr_include incl -> - pp f "@[include@ %a@]%a" - (module_expr ctxt) incl.pincl_mod - (item_attributes ctxt) incl.pincl_attributes - | Pstr_recmodule decls -> (* 3.07 *) - let aux f = function - | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) -> - pp f "@[@ and@ %s:%a@ =@ %a@]%a" pmb.pmb_name.txt - (module_type ctxt) typ - (module_expr ctxt) expr - (item_attributes ctxt) pmb.pmb_attributes - | _ -> assert false - in - begin match decls with - | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 -> - pp f "@[@[module@ rec@ %s:%a@ =@ %a@]%a@ %a@]" - pmb.pmb_name.txt - (module_type ctxt) typ - (module_expr ctxt) expr - (item_attributes ctxt) pmb.pmb_attributes - (fun f l2 -> List.iter (aux f) l2) l2 - | _ -> assert false - end - | Pstr_attribute a -> floating_attribute ctxt f a - | Pstr_extension(e, a) -> - item_extension ctxt f e; - item_attributes ctxt f a + | Single (kind, id, lam) -> + (* let lam = Optimizer.simplify_lets [] lam in *) + (* can not apply again, it's wrong USE it with care*) + (* ([Js_stmt_make.comment (Gen_of_env.query_type id env )], None) ++ *) + Lam_compile.compile_lambda { continuation = Declare (kind, id); + jmp_table = Lam_compile_context.empty_handler_map; + meta + } lam -and type_param ctxt f (ct, a) = - pp f "%s%a" (type_variance a) (core_type ctxt) ct + | Recursive id_lams -> + Lam_compile.compile_recursive_lets + { continuation = EffectCall Not_tail; + jmp_table = Lam_compile_context.empty_handler_map; + meta + } + id_lams + | Nop lam -> (* TODO: Side effect callls, log and see statistics *) + Lam_compile.compile_lambda {continuation = EffectCall Not_tail; + jmp_table = Lam_compile_context.empty_handler_map; + meta + } lam -and type_params ctxt f = function - | [] -> () - | l -> pp f "%a " (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",@;") l +;; -and type_def_list ctxt f (rf, l) = - let type_decl kwd rf f x = - let eq = - if (x.ptype_kind = Ptype_abstract) - && (x.ptype_manifest = None) then "" - else " =" - in - pp f "@[<2>%s %a%a%s%s%a@]%a" kwd - nonrec_flag rf - (type_params ctxt) x.ptype_params - x.ptype_name.txt eq - (type_declaration ctxt) x - (item_attributes ctxt) x.ptype_attributes - in - match l with - | [] -> assert false - | [x] -> type_decl "type" rf f x - | x :: xs -> pp f "@[%a@,%a@]" - (type_decl "type" rf) x - (list ~sep:"@," (type_decl "and" Recursive)) xs +(** Also need analyze its depenency is pure or not *) +let no_side_effects (rest : Lam_group.t list) : string option = + Ext_list.find_opt rest (fun x -> + match x with + | Single(kind,id,body) -> + begin + match kind with + | Strict | Variable -> + if not @@ Lam_analysis.no_side_effects body + then Some (Printf.sprintf "%s" id.name) + else None + | _ -> None + end + | Recursive bindings -> + Ext_list.find_opt bindings (fun (id,lam) -> + if not @@ Lam_analysis.no_side_effects lam + then Some (Printf.sprintf "%s" id.Ident.name ) + else None + ) + | Nop lam -> + if not @@ Lam_analysis.no_side_effects lam + then + (* (Lam_util.string_of_lambda lam) *) + Some "" + else None (* TODO :*)) -and record_declaration ctxt f lbls = - let type_record_field f pld = - pp f "@[<2>%a%s:@;%a@;%a@]" - mutable_flag pld.pld_mutable - pld.pld_name.txt - (core_type ctxt) pld.pld_type - (attributes ctxt) pld.pld_attributes - in - pp f "{@\n%a}" - (list type_record_field ~sep:";@\n" ) lbls -and type_declaration ctxt f x = - (* type_declaration has an attribute field, - but it's been printed by the caller of this method *) - let priv f = - match x.ptype_private with - | Public -> () - | Private -> pp f "@;private" - in - let manifest f = - match x.ptype_manifest with - | None -> () - | Some y -> - if x.ptype_kind = Ptype_abstract then - pp f "%t@;%a" priv (core_type ctxt) y - else - pp f "@;%a" (core_type ctxt) y - in - let constructor_declaration f pcd = - pp f "|@;"; - constructor_declaration ctxt f - (pcd.pcd_name.txt, pcd.pcd_args, pcd.pcd_res, pcd.pcd_attributes) - in - let repr f = - let intro f = - if x.ptype_manifest = None then () - else pp f "@;=" - in - match x.ptype_kind with - | Ptype_variant xs -> - pp f "%t%t@\n%a" intro priv - (list ~sep:"@\n" constructor_declaration) xs - | Ptype_abstract -> () - | Ptype_record l -> - pp f "%t%t@;%a" intro priv (record_declaration ctxt) l - | Ptype_open -> pp f "%t%t@;.." intro priv - in - let constraints f = - List.iter - (fun (ct1,ct2,_) -> - pp f "@[@ constraint@ %a@ =@ %a@]" - (core_type ctxt) ct1 (core_type ctxt) ct2) - x.ptype_cstrs - in - pp f "%t%t%t" manifest repr constraints +let _d = fun s lam -> -and type_extension ctxt f x = - let extension_constructor f x = - pp f "@\n|@;%a" (extension_constructor ctxt) x - in - pp f "@[<2>type %a%a += %a@ %a@]%a" - (fun f -> function - | [] -> () - | l -> - pp f "%a@;" (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",") l) - x.ptyext_params - longident_loc x.ptyext_path - private_flag x.ptyext_private (* Cf: #7200 *) - (list ~sep:"" extension_constructor) - x.ptyext_constructors - (item_attributes ctxt) x.ptyext_attributes + lam -and constructor_declaration ctxt f (name, args, res, attrs) = - let name = - match name with - | "::" -> "(::)" - | s -> s in - match res with - | None -> - pp f "%s%a@;%a" name - (fun f -> function - | Pcstr_tuple [] -> () - | Pcstr_tuple l -> - pp f "@;of@;%a" (list (core_type1 ctxt) ~sep:"@;*@;") l - | Pcstr_record l -> pp f "@;of@;%a" (record_declaration ctxt) l - ) args - (attributes ctxt) attrs - | Some r -> - pp f "%s:@;%a@;%a" name - (fun f -> function - | Pcstr_tuple [] -> core_type1 ctxt f r - | Pcstr_tuple l -> pp f "%a@;->@;%a" - (list (core_type1 ctxt) ~sep:"@;*@;") l - (core_type1 ctxt) r - | Pcstr_record l -> - pp f "%a@;->@;%a" (record_declaration ctxt) l (core_type1 ctxt) r - ) - args - (attributes ctxt) attrs +let _j = Js_pass_debug.dump -and extension_constructor ctxt f x = - (* Cf: #7200 *) - match x.pext_kind with - | Pext_decl(l, r) -> - constructor_declaration ctxt f (x.pext_name.txt, l, r, x.pext_attributes) - | Pext_rebind li -> - pp f "%s%a@;=@;%a" x.pext_name.txt - (attributes ctxt) x.pext_attributes - longident_loc li +(** Actually simplify_lets is kind of global optimization since it requires you to know whether + it's used or not +*) +let compile + (output_prefix : string) + export_idents + (lam : Lambda.lambda) = + let export_ident_sets = Set_ident.of_list export_idents in + (* To make toplevel happy - reentrant for js-demo *) + let () = + + Lam_compile_env.reset () ; + in + let lam, may_required_modules = Lam_convert.convert export_ident_sets lam in -and case_list ctxt f l : unit = - let aux f {pc_lhs; pc_guard; pc_rhs} = - pp f "@;| @[<2>%a%a@;->@;%a@]" - (pattern ctxt) pc_lhs (option (expression ctxt) ~first:"@;when@;") - pc_guard (expression (under_pipe ctxt)) pc_rhs + + let lam = _d "initial" lam in + let lam = Lam_pass_deep_flatten.deep_flatten lam in + let lam = _d "flatten0" lam in + let meta : Lam_stats.t = + Lam_stats.make + ~export_idents + ~export_ident_sets in + let () = Lam_pass_collect.collect_info meta lam in + let lam = + let lam = + lam + |> _d "flattern1" + |> Lam_pass_exits.simplify_exits + |> _d "simplyf_exits" + |> (fun lam -> Lam_pass_collect.collect_info meta lam; + + lam) + |> Lam_pass_remove_alias.simplify_alias meta + |> _d "simplify_alias" + |> Lam_pass_deep_flatten.deep_flatten + |> _d "flatten2" + in (* Inling happens*) + + let () = Lam_pass_collect.collect_info meta lam in + let lam = Lam_pass_remove_alias.simplify_alias meta lam in + let lam = Lam_pass_deep_flatten.deep_flatten lam in + let () = Lam_pass_collect.collect_info meta lam in + let lam = + lam + |> _d "alpha_before" + |> Lam_pass_alpha_conversion.alpha_conversion meta + |> _d "alpha_after" + |> Lam_pass_exits.simplify_exits in + let () = Lam_pass_collect.collect_info meta lam in + + + lam + |> _d "simplify_alias_before" + |> Lam_pass_remove_alias.simplify_alias meta + |> _d "alpha_conversion" + |> Lam_pass_alpha_conversion.alpha_conversion meta + |> _d "before-simplify_lets" + (* we should investigate a better way to put different passes : )*) + |> Lam_pass_lets_dce.simplify_lets + + |> _d "before-simplify-exits" + (* |> (fun lam -> Lam_pass_collect.collect_info meta lam + ; Lam_pass_remove_alias.simplify_alias meta lam) *) + (* |> Lam_group_pass.scc_pass + |> _d "scc" *) + |> Lam_pass_exits.simplify_exits + |> _d "simplify_lets" + in - list aux f l ~sep:"" -and label_x_expression_param ctxt f (l,e) = - let simple_name = match e with - | {pexp_desc=Pexp_ident {txt=Lident l;_}; - pexp_attributes=[]} -> Some l - | _ -> None - in match l with - | Nolabel -> expression2 ctxt f e (* level 2*) - | Optional str -> - if Some str = simple_name then - pp f "?%s" str - else - pp f "?%s:%a" str (simple_expr ctxt) e - | Labelled lbl -> - if Some lbl = simple_name then - pp f "~%s" lbl - else - pp f "~%s:%a" lbl (simple_expr ctxt) e + let ({Lam_coercion.groups = groups } as coerced_input , meta) = + Lam_coercion.coerce_and_group_big_lambda meta lam + in + +let maybe_pure = no_side_effects groups in + +let body = + Ext_list.map groups (fun group -> compile_group meta group) + |> Js_output.concat + |> Js_output.output_as_block +in + +(* The file is not big at all compared with [cmo] *) +(* Ext_marshal.to_file (Ext_path.chop_extension filename ^ ".mj") js; *) +let meta_exports = meta.exports in +let export_set = Set_ident.of_list meta_exports in +let js : J.program = + { + exports = meta_exports ; + export_set; + block = body} +in +js +|> _j "initial" +|> Js_pass_flatten.program +|> _j "flattern" +|> Js_pass_tailcall_inline.tailcall_inline +|> _j "inline_and_shake" +|> Js_pass_flatten_and_mark_dead.program +|> _j "flatten_and_mark_dead" +(* |> Js_inline_and_eliminate.inline_and_shake *) +(* |> _j "inline_and_shake" *) +|> (fun js -> ignore @@ Js_pass_scope.program js ; js ) +|> Js_shake.shake_program +|> _j "shake" +|> ( fun (program: J.program) -> + let external_module_ids : Lam_module_ident.t list = + if !Js_config.all_module_aliases then [] + else + let hard_deps = + Js_fold_basic.calculate_hard_dependencies program.block in + Lam_compile_env.populate_required_modules + may_required_modules hard_deps ; + Ext_list.sort_via_array (Lam_module_ident.Hash_set.to_list hard_deps) + (fun id1 id2 -> + Ext_string.compare (Lam_module_ident.name id1) (Lam_module_ident.name id2) + ) + in + Warnings.check_fatal(); + let effect = + Lam_stats_export.get_dependent_module_effect + maybe_pure external_module_ids in + let v : Js_cmj_format.t = + Lam_stats_export.export_to_cmj + meta + effect + coerced_input.export_map + (if Ext_char.is_lower_case (Filename.basename output_prefix).[0] then Little else Upper) + in + (if not !Clflags.dont_write_files then + Js_cmj_format.to_file + ~check_exists:(not !Js_config.force_cmj) + (output_prefix ^ Literals.suffix_cmj) v); + {J.program = program ; side_effect = effect ; modules = external_module_ids } + ) +;; +let (//) = Filename.concat -let expression f x = - pp f "@[%a@]" (expression reset_ctxt) x +let lambda_as_module + (lambda_output : J.deps_program) + (output_prefix : string) + : unit = + let package_info = Js_packages_state.get_packages_info () in + if Js_packages_info.is_empty package_info && !Js_config.js_stdout then begin + Js_dump_program.dump_deps_program ~output_prefix NodeJS lambda_output stdout + end else + Js_packages_info.iter package_info (fun {module_system; path; suffix} -> + let output_chan chan = + Js_dump_program.dump_deps_program ~output_prefix + module_system + lambda_output + chan in + let basename = + Ext_namespace.change_ext_ns_suffix + (Filename.basename + output_prefix) + (Ext_js_suffix.to_string suffix) + in + let target_file = + (Lazy.force Ext_path.package_dir // + path // + basename + (* #913 only generate little-case js file *) + ) in + (if not !Clflags.dont_write_files then + Ext_pervasives.with_file_as_chan + target_file output_chan ); + if !Warnings.has_warnings then begin + Warnings.has_warnings := false ; + (* 5206: When there were warnings found during the compilation, we want the file + to be rebuilt on the next "rescript build" so that the warnings keep being shown. + Set the timestamp of the ast file to 1970-01-01 to make this rebuild happen. + (Do *not* set the timestamp of the JS output file instead + as that does not play well with every bundler.) *) + let ast_file = output_prefix ^ Literals.suffix_ast in + if Sys.file_exists ast_file then begin + Bs_hash_stubs.set_as_old_file ast_file + end + + end + ) -let string_of_expression x = - ignore (flush_str_formatter ()) ; - let f = str_formatter in - expression f x; - flush_str_formatter () -let string_of_structure x = - ignore (flush_str_formatter ()); - let f = str_formatter in - structure reset_ctxt f x; - flush_str_formatter () +(* We can use {!Env.current_unit = "Pervasives"} to tell if it is some specific module, + We need handle some definitions in standard libraries in a special way, most are io specific, + includes {!Pervasives.stdin, Pervasives.stdout, Pervasives.stderr} -let core_type = core_type reset_ctxt -let pattern = pattern reset_ctxt -let signature = signature reset_ctxt -let structure = structure reset_ctxt + However, use filename instead of {!Env.current_unit} is more honest, since node-js module system is coupled with the file name +*) end module Ast_async @@ -295946,7 +295959,7 @@ let scanEscape scanner = | '}' -> next scanner | _ -> ()); let c = !x in - c + if Res_utf8.isValidCodePoint c then c else Res_utf8.repl | _ -> (* unicode escape sequence: '\u007A', exactly 4 hex digits *) convertNumber scanner ~n:4 ~base:16) @@ -296305,7 +296318,7 @@ let rec scan scanner = (String.sub [@doesNotRaise]) scanner.src offset length in next scanner; - Token.Codepoint {c = Obj.magic codepoint; original = contents}) + Token.Codepoint {c = codepoint; original = contents}) else ( scanner.ch <- ch; scanner.offset <- offset; From a0e137109b3120bcec5f75aa207ca0579066f4e8 Mon Sep 17 00:00:00 2001 From: butterunderflow Date: Sun, 30 Oct 2022 02:53:42 +0800 Subject: [PATCH 11/15] reduce duplication --- jscomp/core/js_dump.ml | 2 +- jscomp/core/lam_print.ml | 9 +- jscomp/ext/ext_util.ml | 7 + jscomp/ext/ext_util.mli | 3 + jscomp/ml/pprintast.ml | 11 +- jscomp/ml/pprintast.pp.ml | 7 +- lib/4.06.1/rescript.ml | 10 + lib/4.06.1/unstable/all_ounit_tests.ml | 10 + lib/4.06.1/unstable/js_compiler.ml | 14392 ++++----- lib/4.06.1/unstable/js_playground_compiler.ml | 23894 +++++++-------- lib/4.06.1/whole_compiler.ml | 24555 ++++++++-------- 11 files changed, 31978 insertions(+), 30922 deletions(-) diff --git a/jscomp/core/js_dump.ml b/jscomp/core/js_dump.ml index 05237aed31..7bc42e1164 100644 --- a/jscomp/core/js_dump.ml +++ b/jscomp/core/js_dump.ml @@ -630,7 +630,7 @@ and expression_desc cxt ~(level : int) f x : cxt = match v with | Float { f } -> Js_number.caml_float_literal_to_js_string f (* attach string here for float constant folding?*) - | Int { i; c = Some c } -> Format.asprintf "/* %s */%ld" (Pprintast.string_of_int_as_char c) i + | Int { i; c = Some c } -> Format.asprintf "/* %s */%ld" (Ext_util.string_of_int_as_char c) i | Int { i; c = None } -> Int32.to_string i (* check , js convention with ocaml lexical convention *) diff --git a/jscomp/core/lam_print.ml b/jscomp/core/lam_print.ml index 5907149e83..b6cb43989a 100644 --- a/jscomp/core/lam_print.ml +++ b/jscomp/core/lam_print.ml @@ -13,13 +13,6 @@ open Format open Asttypes -let string_of_int_as_char i = - if i >= 0 && i <= 255 - then - Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) - else - Printf.sprintf "\'\\%d\'" i - let rec struct_const ppf (cst : Lam_constant.t) = match cst with | Const_js_true -> fprintf ppf "#true" @@ -28,7 +21,7 @@ let rec struct_const ppf (cst : Lam_constant.t) = | Const_module_alias -> fprintf ppf "#alias" | Const_js_undefined -> fprintf ppf "#undefined" | Const_int { i } -> fprintf ppf "%ld" i - | Const_char i -> fprintf ppf "%s" (string_of_int_as_char i) + | Const_char i -> fprintf ppf "%s" (Ext_util.string_of_int_as_char i) | Const_string { s } -> fprintf ppf "%S" s | Const_float f -> fprintf ppf "%s" f | Const_int64 n -> fprintf ppf "%LiL" n diff --git a/jscomp/ext/ext_util.ml b/jscomp/ext/ext_util.ml index 0664f4aac5..41b29437aa 100644 --- a/jscomp/ext/ext_util.ml +++ b/jscomp/ext/ext_util.ml @@ -40,3 +40,10 @@ let stats_to_string num_buckets max_bucket_length (String.concat "," (Array.to_list (Array.map string_of_int bucket_histogram))) + +let string_of_int_as_char i = + if i >= 0 && i <= 255 + then + Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) + else + Printf.sprintf "\'\\%d\'" i diff --git a/jscomp/ext/ext_util.mli b/jscomp/ext/ext_util.mli index 6b73837687..d31d11a90b 100644 --- a/jscomp/ext/ext_util.mli +++ b/jscomp/ext/ext_util.mli @@ -25,3 +25,6 @@ val power_2_above : int -> int -> int val stats_to_string : Hashtbl.statistics -> string + +val string_of_int_as_char : int -> string + diff --git a/jscomp/ml/pprintast.ml b/jscomp/ml/pprintast.ml index b161db201a..37d549bb77 100644 --- a/jscomp/ml/pprintast.ml +++ b/jscomp/ml/pprintast.ml @@ -192,12 +192,7 @@ let rec longident f = function let longident_loc f x = pp f "%a" longident x.txt -let string_of_int_as_char i = - if i >= 0 && i <= 255 - then - Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) - else - Printf.sprintf "\'\\%d\'" i +let string_of_int_as_char i = Ext_util.string_of_int_as_char i let constant f = function | Pconst_char i -> pp f "%s" (string_of_int_as_char i) @@ -777,7 +772,7 @@ and value_description ctxt f x = pp f "@[%a%a@]" (core_type ctxt) x.pval_type (fun f x -> -# 779 "ml/pprintast.pp.ml" +# 774 "ml/pprintast.pp.ml" match x.pval_prim with | first :: second :: _ when Ext_string.first_marshal_char second @@ -790,7 +785,7 @@ and value_description ctxt f x = pp f "@ =@ %a" (list constant_string) x.pval_prim -# 794 "ml/pprintast.pp.ml" +# 789 "ml/pprintast.pp.ml" ) x and extension ctxt f (s, e) = diff --git a/jscomp/ml/pprintast.pp.ml b/jscomp/ml/pprintast.pp.ml index 5ac5790a44..b531404ef6 100644 --- a/jscomp/ml/pprintast.pp.ml +++ b/jscomp/ml/pprintast.pp.ml @@ -191,12 +191,7 @@ let rec longident f = function let longident_loc f x = pp f "%a" longident x.txt -let string_of_int_as_char i = - if i >= 0 && i <= 255 - then - Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) - else - Printf.sprintf "\'\\%d\'" i +let string_of_int_as_char i = Ext_util.string_of_int_as_char i let constant f = function | Pconst_char i -> pp f "%s" (string_of_int_as_char i) diff --git a/lib/4.06.1/rescript.ml b/lib/4.06.1/rescript.ml index 7bfb38d172..a1fec32709 100644 --- a/lib/4.06.1/rescript.ml +++ b/lib/4.06.1/rescript.ml @@ -6503,6 +6503,9 @@ val power_2_above : int -> int -> int val stats_to_string : Hashtbl.statistics -> string +val string_of_int_as_char : int -> string + + end = struct #1 "ext_util.ml" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. @@ -6548,6 +6551,13 @@ let stats_to_string (String.concat "," (Array.to_list (Array.map string_of_int bucket_histogram))) +let string_of_int_as_char i = + if i >= 0 && i <= 255 + then + Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) + else + Printf.sprintf "\'\\%d\'" i + end module Hash_gen = struct diff --git a/lib/4.06.1/unstable/all_ounit_tests.ml b/lib/4.06.1/unstable/all_ounit_tests.ml index f03e1543ee..113d11f14d 100644 --- a/lib/4.06.1/unstable/all_ounit_tests.ml +++ b/lib/4.06.1/unstable/all_ounit_tests.ml @@ -6419,6 +6419,9 @@ val power_2_above : int -> int -> int val stats_to_string : Hashtbl.statistics -> string +val string_of_int_as_char : int -> string + + end = struct #1 "ext_util.ml" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. @@ -6464,6 +6467,13 @@ let stats_to_string (String.concat "," (Array.to_list (Array.map string_of_int bucket_histogram))) +let string_of_int_as_char i = + if i >= 0 && i <= 255 + then + Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) + else + Printf.sprintf "\'\\%d\'" i + end module Hash_gen = struct diff --git a/lib/4.06.1/unstable/js_compiler.ml b/lib/4.06.1/unstable/js_compiler.ml index 894257411f..7648567382 100644 --- a/lib/4.06.1/unstable/js_compiler.ml +++ b/lib/4.06.1/unstable/js_compiler.ml @@ -24863,6 +24863,92 @@ let lam_of_loc kind loc = let reset () = raise_count := 0 +end +module Ext_util : sig +#1 "ext_util.mli" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +val power_2_above : int -> int -> int + +val stats_to_string : Hashtbl.statistics -> string + +val string_of_int_as_char : int -> string + + +end = struct +#1 "ext_util.ml" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +(** + {[ + (power_2_above 16 63 = 64) + (power_2_above 16 76 = 128) + ]} +*) +let rec power_2_above x n = + if x >= n then x + else if x * 2 > Sys.max_array_length then x + else power_2_above (x * 2) n + +let stats_to_string + ({ num_bindings; num_buckets; max_bucket_length; bucket_histogram } : + Hashtbl.statistics) = + Printf.sprintf "bindings: %d,buckets: %d, longest: %d, hist:[%s]" num_bindings + num_buckets max_bucket_length + (String.concat "," + (Array.to_list (Array.map string_of_int bucket_histogram))) + +let string_of_int_as_char i = + if i >= 0 && i <= 255 + then + Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) + else + Printf.sprintf "\'\\%d\'" i + end module Pprintast : sig #1 "pprintast.mli" @@ -25089,12 +25175,7 @@ let rec longident f = function let longident_loc f x = pp f "%a" longident x.txt -let string_of_int_as_char i = - if i >= 0 && i <= 255 - then - Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) - else - Printf.sprintf "\'\\%d\'" i +let string_of_int_as_char i = Ext_util.string_of_int_as_char i let constant f = function | Pconst_char i -> pp f "%s" (string_of_int_as_char i) @@ -48534,24 +48615,21 @@ module Res_comment : sig type t val toString : t -> string - val loc : t -> Location.t val txt : t -> string val prevTokEndPos : t -> Lexing.position - val setPrevTokEndPos : t -> Lexing.position -> unit - val isDocComment : t -> bool - val isModuleComment : t -> bool - val isSingleLineComment : t -> bool - val makeSingleLineComment : loc:Location.t -> string -> t + val makeMultiLineComment : loc:Location.t -> docComment:bool -> standalone:bool -> string -> t + val fromOcamlComment : loc:Location.t -> txt:string -> prevTokEndPos:Lexing.position -> t + val trimSpaces : string -> string end = struct @@ -48566,26 +48644,22 @@ let styleToString s = | ModuleComment -> "ModuleComment" type t = { - txt: string; - style: style; - loc: Location.t; - mutable prevTokEndPos: Lexing.position; + txt : string; + style : style; + loc : Location.t; + mutable prevTokEndPos : Lexing.position; } let loc t = t.loc let txt t = t.txt let prevTokEndPos t = t.prevTokEndPos - let setPrevTokEndPos t pos = t.prevTokEndPos <- pos - let isSingleLineComment t = t.style = SingleLine - let isDocComment t = t.style = DocComment - let isModuleComment t = t.style = ModuleComment let toString t = - let {Location.loc_start; loc_end} = t.loc in + let { Location.loc_start; loc_end } = t.loc in Format.sprintf "(txt: %s\nstyle: %s\nlocation: %d,%d-%d,%d)" t.txt (styleToString t.style) loc_start.pos_lnum (loc_start.pos_cnum - loc_start.pos_bol) @@ -48593,7 +48667,7 @@ let toString t = (loc_end.pos_cnum - loc_end.pos_bol) let makeSingleLineComment ~loc txt = - {txt; loc; style = SingleLine; prevTokEndPos = Lexing.dummy_pos} + { txt; loc; style = SingleLine; prevTokEndPos = Lexing.dummy_pos } let makeMultiLineComment ~loc ~docComment ~standalone txt = { @@ -48606,7 +48680,7 @@ let makeMultiLineComment ~loc ~docComment ~standalone txt = } let fromOcamlComment ~loc ~txt ~prevTokEndPos = - {txt; loc; style = MultiLine; prevTokEndPos} + { txt; loc; style = MultiLine; prevTokEndPos } let trimSpaces s = let len = String.length s in @@ -48628,6 +48702,7 @@ end module Res_minibuffer : sig #1 "res_minibuffer.mli" type t + val add_char : t -> char -> unit val add_string : t -> string -> unit val contents : t -> string @@ -48636,12 +48711,16 @@ val flush_newline : t -> unit end = struct #1 "res_minibuffer.ml" -type t = {mutable buffer: bytes; mutable position: int; mutable length: int} +type t = { + mutable buffer : bytes; + mutable position : int; + mutable length : int; +} let create n = let n = if n < 1 then 1 else n in let s = (Bytes.create [@doesNotRaise]) n in - {buffer = s; position = 0; length = n} + { buffer = s; position = 0; length = n } let contents b = (Bytes.sub_string [@doesNotRaise]) b.buffer 0 b.position @@ -48711,7 +48790,6 @@ val join : sep:t -> t list -> t (* [(doc1, sep1); (doc2,sep2)] joins as doc1 sep1 doc2 *) val joinWithSep : (t * t) list -> t - val space : t val comma : t val dot : t @@ -48751,7 +48829,6 @@ val doubleQuote : t [@@live] * force breaks from bottom to top. *) val willBreak : t -> bool - val toString : width:int -> t -> string val debug : t -> unit [@@live] @@ -48775,11 +48852,11 @@ type t = | Text of string | Concat of t list | Indent of t - | IfBreaks of {yes: t; no: t; mutable broken: bool} + | IfBreaks of { yes : t; no : t; mutable broken : bool } (* when broken is true, treat as the yes branch *) | LineSuffix of t | LineBreak of lineStyle - | Group of {mutable shouldBreak: bool; doc: t} + | Group of { mutable shouldBreak : bool; doc : t } | CustomLayout of t list | BreakParent @@ -48796,22 +48873,20 @@ let rec _concat acc l = | Text s1 :: Text s2 :: rest -> Text (s1 ^ s2) :: _concat acc rest | Nil :: rest -> _concat acc rest | Concat l2 :: rest -> - _concat (_concat acc rest) l2 (* notice the order here *) + _concat (_concat acc rest) l2 (* notice the order here *) | x :: rest -> - let rest1 = _concat acc rest in - if rest1 == rest then l else x :: rest1 + let rest1 = _concat acc rest in + if rest1 == rest then l else x :: rest1 | [] -> acc let concat l = Concat (_concat [] l) - let indent d = Indent d -let ifBreaks t f = IfBreaks {yes = t; no = f; broken = false} +let ifBreaks t f = IfBreaks { yes = t; no = f; broken = false } let lineSuffix d = LineSuffix d -let group d = Group {shouldBreak = false; doc = d} -let breakableGroup ~forceBreak d = Group {shouldBreak = forceBreak; doc = d} +let group d = Group { shouldBreak = false; doc = d } +let breakableGroup ~forceBreak d = Group { shouldBreak = forceBreak; doc = d } let customLayout gs = CustomLayout gs let breakParent = BreakParent - let space = Text " " let comma = Text "," let dot = Text "." @@ -48839,36 +48914,36 @@ let propagateForcedBreaks doc = | LineBreak (Hard | Literal) -> true | LineBreak (Classic | Soft) -> false | Indent children -> - let childForcesBreak = walk children in - childForcesBreak - | IfBreaks ({yes = trueDoc; no = falseDoc} as ib) -> - let falseForceBreak = walk falseDoc in - if falseForceBreak then ( - let _ = walk trueDoc in - ib.broken <- true; - true) - else - let forceBreak = walk trueDoc in - forceBreak - | Group ({shouldBreak = forceBreak; doc = children} as gr) -> - let childForcesBreak = walk children in - let shouldBreak = forceBreak || childForcesBreak in - gr.shouldBreak <- shouldBreak; - shouldBreak + let childForcesBreak = walk children in + childForcesBreak + | IfBreaks ({ yes = trueDoc; no = falseDoc } as ib) -> + let falseForceBreak = walk falseDoc in + if falseForceBreak then ( + let _ = walk trueDoc in + ib.broken <- true; + true) + else + let forceBreak = walk trueDoc in + forceBreak + | Group ({ shouldBreak = forceBreak; doc = children } as gr) -> + let childForcesBreak = walk children in + let shouldBreak = forceBreak || childForcesBreak in + gr.shouldBreak <- shouldBreak; + shouldBreak | Concat children -> - List.fold_left - (fun forceBreak child -> - let childForcesBreak = walk child in - forceBreak || childForcesBreak) - false children + List.fold_left + (fun forceBreak child -> + let childForcesBreak = walk child in + forceBreak || childForcesBreak) + false children | CustomLayout children -> - (* When using CustomLayout, we don't want to propagate forced breaks - * from the children up. By definition it picks the first layout that fits - * otherwise it takes the last of the list. - * However we do want to propagate forced breaks in the sublayouts. They - * might need to be broken. We just don't propagate them any higher here *) - let _ = walk (Concat children) in - false + (* When using CustomLayout, we don't want to propagate forced breaks + * from the children up. By definition it picks the first layout that fits + * otherwise it takes the last of the list. + * However we do want to propagate forced breaks in the sublayouts. They + * might need to be broken. We just don't propagate them any higher here *) + let _ = walk (Concat children) in + false in let _ = walk doc in () @@ -48876,18 +48951,18 @@ let propagateForcedBreaks doc = (* See documentation in interface file *) let rec willBreak doc = match doc with - | LineBreak (Hard | Literal) | BreakParent | Group {shouldBreak = true} -> - true - | Group {doc} | Indent doc | CustomLayout (doc :: _) -> willBreak doc + | LineBreak (Hard | Literal) | BreakParent | Group { shouldBreak = true } -> + true + | Group { doc } | Indent doc | CustomLayout (doc :: _) -> willBreak doc | Concat docs -> List.exists willBreak docs - | IfBreaks {yes; no} -> willBreak yes || willBreak no + | IfBreaks { yes; no } -> willBreak yes || willBreak no | _ -> false let join ~sep docs = let rec loop acc sep docs = match docs with | [] -> List.rev acc - | [x] -> List.rev (x :: acc) + | [ x ] -> List.rev (x :: acc) | x :: xs -> loop (sep :: x :: acc) sep xs in concat (loop [] sep docs) @@ -48896,7 +48971,7 @@ let joinWithSep docsWithSep = let rec loop acc docs = match docs with | [] -> List.rev acc - | [(x, _sep)] -> List.rev (x :: acc) + | [ (x, _sep) ] -> List.rev (x :: acc) | (x, sep) :: xs -> loop (sep :: x :: acc) xs in concat (loop [] docsWithSep) @@ -48916,32 +48991,32 @@ let fits w stack = | Flat, LineBreak Classic -> width := width.contents - 1 | Flat, LineBreak Soft -> () | Break, LineBreak _ -> result := Some true - | _, Group {shouldBreak = true; doc} -> calculate indent Break doc - | _, Group {doc} -> calculate indent mode doc - | _, IfBreaks {yes = breakDoc; broken = true} -> - calculate indent mode breakDoc - | Break, IfBreaks {yes = breakDoc} -> calculate indent mode breakDoc - | Flat, IfBreaks {no = flatDoc} -> calculate indent mode flatDoc + | _, Group { shouldBreak = true; doc } -> calculate indent Break doc + | _, Group { doc } -> calculate indent mode doc + | _, IfBreaks { yes = breakDoc; broken = true } -> + calculate indent mode breakDoc + | Break, IfBreaks { yes = breakDoc } -> calculate indent mode breakDoc + | Flat, IfBreaks { no = flatDoc } -> calculate indent mode flatDoc | _, Concat docs -> calculateConcat indent mode docs | _, CustomLayout (hd :: _) -> - (* TODO: if we have nested custom layouts, what we should do here? *) - calculate indent mode hd + (* TODO: if we have nested custom layouts, what we should do here? *) + calculate indent mode hd | _, CustomLayout [] -> () and calculateConcat indent mode docs = if result.contents == None then match docs with | [] -> () | doc :: rest -> - calculate indent mode doc; - calculateConcat indent mode rest + calculate indent mode doc; + calculateConcat indent mode rest in let rec calculateAll stack = match (result.contents, stack) with | Some r, _ -> r | None, [] -> !width >= 0 | None, (indent, mode, doc) :: rest -> - calculate indent mode doc; - calculateAll rest + calculate indent mode doc; + calculateAll rest in calculateAll stack @@ -48952,73 +49027,75 @@ let toString ~width doc = let rec process ~pos lineSuffices stack = match stack with | ((ind, mode, doc) as cmd) :: rest -> ( - match doc with - | Nil | BreakParent -> process ~pos lineSuffices rest - | Text txt -> - MiniBuffer.add_string buffer txt; - process ~pos:(String.length txt + pos) lineSuffices rest - | LineSuffix doc -> process ~pos ((ind, mode, doc) :: lineSuffices) rest - | Concat docs -> - let ops = List.map (fun doc -> (ind, mode, doc)) docs in - process ~pos lineSuffices (List.append ops rest) - | Indent doc -> process ~pos lineSuffices ((ind + 2, mode, doc) :: rest) - | IfBreaks {yes = breakDoc; broken = true} -> - process ~pos lineSuffices ((ind, mode, breakDoc) :: rest) - | IfBreaks {yes = breakDoc; no = flatDoc} -> - if mode = Break then - process ~pos lineSuffices ((ind, mode, breakDoc) :: rest) - else process ~pos lineSuffices ((ind, mode, flatDoc) :: rest) - | LineBreak lineStyle -> - if mode = Break then - match lineSuffices with - | [] -> - if lineStyle = Literal then ( - MiniBuffer.add_char buffer '\n'; - process ~pos:0 [] rest) - else ( - MiniBuffer.flush_newline buffer; - MiniBuffer.add_string buffer (String.make ind ' ' [@doesNotRaise]); - process ~pos:ind [] rest) - | _docs -> - process ~pos:ind [] - (List.concat [List.rev lineSuffices; cmd :: rest]) - else - (* mode = Flat *) - let pos = - match lineStyle with - | Classic -> - MiniBuffer.add_string buffer " "; - pos + 1 - | Hard -> - MiniBuffer.flush_newline buffer; - 0 - | Literal -> - MiniBuffer.add_char buffer '\n'; - 0 - | Soft -> pos - in - process ~pos lineSuffices rest - | Group {shouldBreak; doc} -> - if shouldBreak || not (fits (width - pos) ((ind, Flat, doc) :: rest)) - then process ~pos lineSuffices ((ind, Break, doc) :: rest) - else process ~pos lineSuffices ((ind, Flat, doc) :: rest) - | CustomLayout docs -> - let rec findGroupThatFits groups = - match groups with - | [] -> Nil - | [lastGroup] -> lastGroup - | doc :: docs -> - if fits (width - pos) ((ind, Flat, doc) :: rest) then doc - else findGroupThatFits docs - in - let doc = findGroupThatFits docs in - process ~pos lineSuffices ((ind, Flat, doc) :: rest)) + match doc with + | Nil | BreakParent -> process ~pos lineSuffices rest + | Text txt -> + MiniBuffer.add_string buffer txt; + process ~pos:(String.length txt + pos) lineSuffices rest + | LineSuffix doc -> process ~pos ((ind, mode, doc) :: lineSuffices) rest + | Concat docs -> + let ops = List.map (fun doc -> (ind, mode, doc)) docs in + process ~pos lineSuffices (List.append ops rest) + | Indent doc -> process ~pos lineSuffices ((ind + 2, mode, doc) :: rest) + | IfBreaks { yes = breakDoc; broken = true } -> + process ~pos lineSuffices ((ind, mode, breakDoc) :: rest) + | IfBreaks { yes = breakDoc; no = flatDoc } -> + if mode = Break then + process ~pos lineSuffices ((ind, mode, breakDoc) :: rest) + else process ~pos lineSuffices ((ind, mode, flatDoc) :: rest) + | LineBreak lineStyle -> + if mode = Break then + match lineSuffices with + | [] -> + if lineStyle = Literal then ( + MiniBuffer.add_char buffer '\n'; + process ~pos:0 [] rest) + else ( + MiniBuffer.flush_newline buffer; + MiniBuffer.add_string buffer + (String.make ind ' ' [@doesNotRaise]); + process ~pos:ind [] rest) + | _docs -> + process ~pos:ind [] + (List.concat [ List.rev lineSuffices; cmd :: rest ]) + else + (* mode = Flat *) + let pos = + match lineStyle with + | Classic -> + MiniBuffer.add_string buffer " "; + pos + 1 + | Hard -> + MiniBuffer.flush_newline buffer; + 0 + | Literal -> + MiniBuffer.add_char buffer '\n'; + 0 + | Soft -> pos + in + process ~pos lineSuffices rest + | Group { shouldBreak; doc } -> + if + shouldBreak || not (fits (width - pos) ((ind, Flat, doc) :: rest)) + then process ~pos lineSuffices ((ind, Break, doc) :: rest) + else process ~pos lineSuffices ((ind, Flat, doc) :: rest) + | CustomLayout docs -> + let rec findGroupThatFits groups = + match groups with + | [] -> Nil + | [ lastGroup ] -> lastGroup + | doc :: docs -> + if fits (width - pos) ((ind, Flat, doc) :: rest) then doc + else findGroupThatFits docs + in + let doc = findGroupThatFits docs in + process ~pos lineSuffices ((ind, Flat, doc) :: rest)) | [] -> ( - match lineSuffices with - | [] -> () - | suffices -> process ~pos:0 [] (List.rev suffices)) + match lineSuffices with + | [] -> () + | suffices -> process ~pos:0 [] (List.rev suffices)) in - process ~pos:0 [] [(0, Flat, doc)]; + process ~pos:0 [] [ (0, Flat, doc) ]; MiniBuffer.contents buffer let debug t = @@ -49027,82 +49104,91 @@ let debug t = | BreakParent -> text "breakparent" | Text txt -> text ("text(\"" ^ txt ^ "\")") | LineSuffix doc -> - group - (concat - [ - text "linesuffix("; - indent (concat [line; toDoc doc]); - line; - text ")"; - ]) + group + (concat + [ + text "linesuffix("; + indent (concat [ line; toDoc doc ]); + line; + text ")"; + ]) | Concat [] -> text "concat()" | Concat docs -> - group - (concat - [ - text "concat("; - indent - (concat - [ - line; - join ~sep:(concat [text ","; line]) (List.map toDoc docs); - ]); - line; - text ")"; - ]) + group + (concat + [ + text "concat("; + indent + (concat + [ + line; + join + ~sep:(concat [ text ","; line ]) + (List.map toDoc docs); + ]); + line; + text ")"; + ]) | CustomLayout docs -> - group - (concat - [ - text "customLayout("; - indent - (concat - [ - line; - join ~sep:(concat [text ","; line]) (List.map toDoc docs); - ]); - line; - text ")"; - ]) + group + (concat + [ + text "customLayout("; + indent + (concat + [ + line; + join + ~sep:(concat [ text ","; line ]) + (List.map toDoc docs); + ]); + line; + text ")"; + ]) | Indent doc -> - concat [text "indent("; softLine; toDoc doc; softLine; text ")"] - | IfBreaks {yes = trueDoc; broken = true} -> toDoc trueDoc - | IfBreaks {yes = trueDoc; no = falseDoc} -> - group - (concat - [ - text "ifBreaks("; - indent - (concat - [line; toDoc trueDoc; concat [text ","; line]; toDoc falseDoc]); - line; - text ")"; - ]) + concat [ text "indent("; softLine; toDoc doc; softLine; text ")" ] + | IfBreaks { yes = trueDoc; broken = true } -> toDoc trueDoc + | IfBreaks { yes = trueDoc; no = falseDoc } -> + group + (concat + [ + text "ifBreaks("; + indent + (concat + [ + line; + toDoc trueDoc; + concat [ text ","; line ]; + toDoc falseDoc; + ]); + line; + text ")"; + ]) | LineBreak break -> - let breakTxt = - match break with - | Classic -> "Classic" - | Soft -> "Soft" - | Hard -> "Hard" - | Literal -> "Liteal" - in - text ("LineBreak(" ^ breakTxt ^ ")") - | Group {shouldBreak; doc} -> - group - (concat - [ - text "Group("; - indent - (concat - [ - line; - text ("{shouldBreak: " ^ string_of_bool shouldBreak ^ "}"); - concat [text ","; line]; - toDoc doc; - ]); - line; - text ")"; - ]) + let breakTxt = + match break with + | Classic -> "Classic" + | Soft -> "Soft" + | Hard -> "Hard" + | Literal -> "Liteal" + in + text ("LineBreak(" ^ breakTxt ^ ")") + | Group { shouldBreak; doc } -> + group + (concat + [ + text "Group("; + indent + (concat + [ + line; + text ("{shouldBreak: " ^ string_of_bool shouldBreak ^ "}"); + concat [ text ","; line ]; + toDoc doc; + ]); + line; + text ")"; + ]) in let doc = toDoc t in toString ~width:10 doc |> print_endline @@ -49131,14 +49217,13 @@ val processUncurriedAttribute : Parsetree.attributes -> bool * Parsetree.attributes type functionAttributesInfo = { - async: bool; - uncurried: bool; - attributes: Parsetree.attributes; + async : bool; + uncurried : bool; + attributes : Parsetree.attributes; } (* determines whether a function is async and/or uncurried based on the given attributes *) val processFunctionAttributes : Parsetree.attributes -> functionAttributesInfo - val hasAwaitAttribute : Parsetree.attributes -> bool type ifConditionKind = @@ -49159,12 +49244,15 @@ val collectListExpressions : type funParamKind = | Parameter of { - attrs: Parsetree.attributes; - lbl: Asttypes.arg_label; - defaultExpr: Parsetree.expression option; - pat: Parsetree.pattern; + attrs : Parsetree.attributes; + lbl : Asttypes.arg_label; + defaultExpr : Parsetree.expression option; + pat : Parsetree.pattern; + } + | NewTypes of { + attrs : Parsetree.attributes; + locs : string Asttypes.loc list; } - | NewTypes of {attrs: Parsetree.attributes; locs: string Asttypes.loc list} val funExpr : Parsetree.expression -> @@ -49177,21 +49265,14 @@ val funExpr : * })` * Notice howe `({` and `})` "hug" or stick to each other *) val isHuggableExpression : Parsetree.expression -> bool - val isHuggablePattern : Parsetree.pattern -> bool - val isHuggableRhs : Parsetree.expression -> bool - val operatorPrecedence : string -> int - val isUnaryExpression : Parsetree.expression -> bool val isBinaryOperator : string -> bool val isBinaryExpression : Parsetree.expression -> bool - val flattenableOperators : string -> string -> bool - val hasAttributes : Parsetree.attributes -> bool - val isArrayAccess : Parsetree.expression -> bool val isTernaryExpr : Parsetree.expression -> bool val isIfLetExpr : Parsetree.expression -> bool @@ -49201,23 +49282,22 @@ val collectTernaryParts : (Parsetree.expression * Parsetree.expression) list * Parsetree.expression val parametersShouldHug : funParamKind list -> bool - val filterTernaryAttributes : Parsetree.attributes -> Parsetree.attributes val filterFragileMatchAttributes : Parsetree.attributes -> Parsetree.attributes - val isJsxExpression : Parsetree.expression -> bool val hasJsxAttribute : Parsetree.attributes -> bool val hasOptionalAttribute : Parsetree.attributes -> bool - val shouldIndentBinaryExpr : Parsetree.expression -> bool val shouldInlineRhsBinaryExpr : Parsetree.expression -> bool val hasPrintableAttributes : Parsetree.attributes -> bool val filterPrintableAttributes : Parsetree.attributes -> Parsetree.attributes + val partitionPrintableAttributes : Parsetree.attributes -> Parsetree.attributes * Parsetree.attributes val requiresSpecialCallbackPrintingLastArg : (Asttypes.arg_label * Parsetree.expression) list -> bool + val requiresSpecialCallbackPrintingFirstArg : (Asttypes.arg_label * Parsetree.expression) list -> bool @@ -49241,21 +49321,16 @@ val collectPatternsFromListConstruct : Parsetree.pattern list * Parsetree.pattern val isBlockExpr : Parsetree.expression -> bool - val isTemplateLiteral : Parsetree.expression -> bool val hasTemplateLiteralAttr : Parsetree.attributes -> bool - val isSpreadBeltListConcat : Parsetree.expression -> bool - val collectOrPatternChain : Parsetree.pattern -> Parsetree.pattern list val processBracesAttr : Parsetree.expression -> Parsetree.attribute option * Parsetree.expression val filterParsingAttrs : Parsetree.attributes -> Parsetree.attributes - val isBracedExpr : Parsetree.expression -> bool - val isSinglePipeExpr : Parsetree.expression -> bool (* (__x) => f(a, __x, c) -----> f(a, _, c) *) @@ -49263,9 +49338,7 @@ val rewriteUnderscoreApply : Parsetree.expression -> Parsetree.expression (* (__x) => f(a, __x, c) -----> f(a, _, c) *) val isUnderscoreApplySugar : Parsetree.expression -> bool - val hasIfLetAttribute : Parsetree.attributes -> bool - val isRewrittenUnderscoreApplySugar : Parsetree.expression -> bool end = struct @@ -49279,31 +49352,33 @@ let arrowType ct = ptyp_desc = Ptyp_arrow ((Nolabel as lbl), typ1, typ2); ptyp_attributes = []; } -> - let arg = ([], lbl, typ1) in - process attrsBefore (arg :: acc) typ2 + let arg = ([], lbl, typ1) in + process attrsBefore (arg :: acc) typ2 | { ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); - ptyp_attributes = [({txt = "bs"}, _)]; + ptyp_attributes = [ ({ txt = "bs" }, _) ]; } -> - (* stop here, the uncurried attribute always indicates the beginning of an arrow function - * e.g. `(. int) => (. int)` instead of `(. int, . int)` *) - (attrsBefore, List.rev acc, typ) - | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = _attrs} - as returnType -> - let args = List.rev acc in - (attrsBefore, args, returnType) + (* stop here, the uncurried attribute always indicates the beginning of an arrow function + * e.g. `(. int) => (. int)` instead of `(. int, . int)` *) + (attrsBefore, List.rev acc, typ) + | { + ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); + ptyp_attributes = _attrs; + } as returnType -> + let args = List.rev acc in + (attrsBefore, args, returnType) | { ptyp_desc = Ptyp_arrow (((Labelled _ | Optional _) as lbl), typ1, typ2); ptyp_attributes = attrs; } -> - let arg = (attrs, lbl, typ1) in - process attrsBefore (arg :: acc) typ2 + let arg = (attrs, lbl, typ1) in + process attrsBefore (arg :: acc) typ2 | typ -> (attrsBefore, List.rev acc, typ) in match ct with - | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = attrs} as - typ -> - process attrs [] {typ with ptyp_attributes = []} + | { ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = attrs } + as typ -> + process attrs [] { typ with ptyp_attributes = [] } | typ -> process [] [] typ let functorType modtype = @@ -49313,8 +49388,8 @@ let functorType modtype = pmty_desc = Pmty_functor (lbl, argType, returnType); pmty_attributes = attrs; } -> - let arg = (attrs, lbl, argType) in - process (arg :: acc) returnType + let arg = (attrs, lbl, argType) in + process (arg :: acc) returnType | modType -> (List.rev acc, modType) in process [] modtype @@ -49323,43 +49398,41 @@ let processUncurriedAttribute attrs = let rec process uncurriedSpotted acc attrs = match attrs with | [] -> (uncurriedSpotted, List.rev acc) - | ({Location.txt = "bs"}, _) :: rest -> process true acc rest + | ({ Location.txt = "bs" }, _) :: rest -> process true acc rest | attr :: rest -> process uncurriedSpotted (attr :: acc) rest in process false [] attrs type functionAttributesInfo = { - async: bool; - uncurried: bool; - attributes: Parsetree.attributes; + async : bool; + uncurried : bool; + attributes : Parsetree.attributes; } let processFunctionAttributes attrs = let rec process async uncurried acc attrs = match attrs with - | [] -> {async; uncurried; attributes = List.rev acc} - | ({Location.txt = "bs"}, _) :: rest -> process async true acc rest - | ({Location.txt = "res.async"}, _) :: rest -> - process true uncurried acc rest + | [] -> { async; uncurried; attributes = List.rev acc } + | ({ Location.txt = "bs" }, _) :: rest -> process async true acc rest + | ({ Location.txt = "res.async" }, _) :: rest -> + process true uncurried acc rest | attr :: rest -> process async uncurried (attr :: acc) rest in process false false [] attrs let hasAwaitAttribute attrs = List.exists - (function - | {Location.txt = "res.await"}, _ -> true - | _ -> false) + (function { Location.txt = "res.await" }, _ -> true | _ -> false) attrs let collectListExpressions expr = let rec collect acc expr = match expr.pexp_desc with - | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> (List.rev acc, None) + | Pexp_construct ({ txt = Longident.Lident "[]" }, _) -> (List.rev acc, None) | Pexp_construct - ( {txt = Longident.Lident "::"}, - Some {pexp_desc = Pexp_tuple (hd :: [tail])} ) -> - collect (hd :: acc) tail + ( { txt = Longident.Lident "::" }, + Some { pexp_desc = Pexp_tuple (hd :: [ tail ]) } ) -> + collect (hd :: acc) tail | _ -> (List.rev acc, Some expr) in collect [] expr @@ -49370,42 +49443,48 @@ let rewriteUnderscoreApply expr = | Pexp_fun ( Nolabel, None, - {ppat_desc = Ppat_var {txt = "__x"}}, - ({pexp_desc = Pexp_apply (callExpr, args)} as e) ) -> - let newArgs = - List.map - (fun arg -> - match arg with - | ( lbl, - ({pexp_desc = Pexp_ident ({txt = Longident.Lident "__x"} as lid)} - as argExpr) ) -> - ( lbl, - { - argExpr with - pexp_desc = Pexp_ident {lid with txt = Longident.Lident "_"}; - } ) - | arg -> arg) - args - in - {e with pexp_desc = Pexp_apply (callExpr, newArgs)} + { ppat_desc = Ppat_var { txt = "__x" } }, + ({ pexp_desc = Pexp_apply (callExpr, args) } as e) ) -> + let newArgs = + List.map + (fun arg -> + match arg with + | ( lbl, + ({ + pexp_desc = + Pexp_ident ({ txt = Longident.Lident "__x" } as lid); + } as argExpr) ) -> + ( lbl, + { + argExpr with + pexp_desc = + Pexp_ident { lid with txt = Longident.Lident "_" }; + } ) + | arg -> arg) + args + in + { e with pexp_desc = Pexp_apply (callExpr, newArgs) } | _ -> expr type funParamKind = | Parameter of { - attrs: Parsetree.attributes; - lbl: Asttypes.arg_label; - defaultExpr: Parsetree.expression option; - pat: Parsetree.pattern; + attrs : Parsetree.attributes; + lbl : Asttypes.arg_label; + defaultExpr : Parsetree.expression option; + pat : Parsetree.pattern; + } + | NewTypes of { + attrs : Parsetree.attributes; + locs : string Asttypes.loc list; } - | NewTypes of {attrs: Parsetree.attributes; locs: string Asttypes.loc list} let funExpr expr = (* Turns (type t, type u, type z) into "type t u z" *) let rec collectNewTypes acc returnExpr = match returnExpr with - | {pexp_desc = Pexp_newtype (stringLoc, returnExpr); pexp_attributes = []} + | { pexp_desc = Pexp_newtype (stringLoc, returnExpr); pexp_attributes = [] } -> - collectNewTypes (stringLoc :: acc) returnExpr + collectNewTypes (stringLoc :: acc) returnExpr | returnExpr -> (List.rev acc, returnExpr) in let rec collect n attrsBefore acc expr = @@ -49415,43 +49494,48 @@ let funExpr expr = Pexp_fun ( Nolabel, None, - {ppat_desc = Ppat_var {txt = "__x"}}, - {pexp_desc = Pexp_apply _} ); + { ppat_desc = Ppat_var { txt = "__x" } }, + { pexp_desc = Pexp_apply _ } ); } -> - (attrsBefore, List.rev acc, rewriteUnderscoreApply expr) + (attrsBefore, List.rev acc, rewriteUnderscoreApply expr) | { pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr); pexp_attributes = []; } -> - let parameter = Parameter {attrs = []; lbl; defaultExpr; pat = pattern} in - collect (n + 1) attrsBefore (parameter :: acc) returnExpr - | {pexp_desc = Pexp_newtype (stringLoc, rest); pexp_attributes = attrs} -> - let stringLocs, returnExpr = collectNewTypes [stringLoc] rest in - let param = NewTypes {attrs; locs = stringLocs} in - collect (n + 1) attrsBefore (param :: acc) returnExpr - | {pexp_desc = Pexp_fun _; pexp_attributes} + let parameter = + Parameter { attrs = []; lbl; defaultExpr; pat = pattern } + in + collect (n + 1) attrsBefore (parameter :: acc) returnExpr + | { pexp_desc = Pexp_newtype (stringLoc, rest); pexp_attributes = attrs } -> + let stringLocs, returnExpr = collectNewTypes [ stringLoc ] rest in + let param = NewTypes { attrs; locs = stringLocs } in + collect (n + 1) attrsBefore (param :: acc) returnExpr + | { pexp_desc = Pexp_fun _; pexp_attributes } when pexp_attributes - |> List.exists (fun ({Location.txt}, _) -> + |> List.exists (fun ({ Location.txt }, _) -> txt = "bs" || txt = "res.async") && n > 0 -> - (* stop here, the uncurried or async attribute always indicates the beginning of an arrow function - * e.g. `(. a) => (. b)` instead of `(. a, . b)` *) - (attrsBefore, List.rev acc, expr) + (* stop here, the uncurried or async attribute always indicates the beginning of an arrow function + * e.g. `(. a) => (. b)` instead of `(. a, . b)` *) + (attrsBefore, List.rev acc, expr) | { pexp_desc = Pexp_fun (((Labelled _ | Optional _) as lbl), defaultExpr, pattern, returnExpr); pexp_attributes = attrs; } -> - (* Normally attributes are attached to the labelled argument, e.g. (@foo ~x) => ... - In the case of `@res.async`, pass the attribute to the outside *) - let attrs_async, attrs_other = - attrs |> List.partition (fun ({Location.txt}, _) -> txt = "res.async") - in - let parameter = - Parameter {attrs = attrs_other; lbl; defaultExpr; pat = pattern} - in - collect (n + 1) (attrs_async @ attrsBefore) (parameter :: acc) returnExpr + (* Normally attributes are attached to the labelled argument, e.g. (@foo ~x) => ... + In the case of `@res.async`, pass the attribute to the outside *) + let attrs_async, attrs_other = + attrs + |> List.partition (fun ({ Location.txt }, _) -> txt = "res.async") + in + let parameter = + Parameter { attrs = attrs_other; lbl; defaultExpr; pat = pattern } + in + collect (n + 1) + (attrs_async @ attrsBefore) + (parameter :: acc) returnExpr | expr -> (attrsBefore, List.rev acc, expr) in match expr with @@ -49459,13 +49543,13 @@ let funExpr expr = pexp_desc = Pexp_fun (Nolabel, _defaultExpr, _pattern, _returnExpr); pexp_attributes = attrs; } as expr -> - collect 0 attrs [] {expr with pexp_attributes = []} + collect 0 attrs [] { expr with pexp_attributes = [] } | expr -> collect 0 [] [] expr let processBracesAttr expr = match expr.pexp_attributes with - | (({txt = "ns.braces"}, _) as attr) :: attrs -> - (Some attr, {expr with pexp_attributes = attrs}) + | (({ txt = "ns.braces" }, _) as attr) :: attrs -> + (Some attr, { expr with pexp_attributes = attrs }) | _ -> (None, expr) let filterParsingAttrs attrs = @@ -49479,7 +49563,7 @@ let filterParsingAttrs attrs = | "res.template" ); }, _ ) -> - false + false | _ -> true) attrs @@ -49487,13 +49571,11 @@ let isBlockExpr expr = match expr.pexp_desc with | Pexp_letmodule _ | Pexp_letexception _ | Pexp_let _ | Pexp_open _ | Pexp_sequence _ -> - true + true | _ -> false let isBracedExpr expr = - match processBracesAttr expr with - | Some _, _ -> true - | _ -> false + match processBracesAttr expr with Some _, _ -> true | _ -> false let isMultilineText txt = let len = String.length txt in @@ -49512,10 +49594,10 @@ let isHuggableExpression expr = match expr.pexp_desc with | Pexp_array _ | Pexp_tuple _ | Pexp_constant (Pconst_string (_, Some _)) - | Pexp_construct ({txt = Longident.Lident ("::" | "[]")}, _) - | Pexp_extension ({txt = "bs.obj" | "obj"}, _) + | Pexp_construct ({ txt = Longident.Lident ("::" | "[]") }, _) + | Pexp_extension ({ txt = "bs.obj" | "obj" }, _) | Pexp_record _ -> - true + true | _ when isBlockExpr expr -> true | _ when isBracedExpr expr -> true | Pexp_constant (Pconst_string (txt, None)) when isMultilineText txt -> true @@ -49524,9 +49606,9 @@ let isHuggableExpression expr = let isHuggableRhs expr = match expr.pexp_desc with | Pexp_array _ | Pexp_tuple _ - | Pexp_extension ({txt = "bs.obj" | "obj"}, _) + | Pexp_extension ({ txt = "bs.obj" | "obj" }, _) | Pexp_record _ -> - true + true | _ when isBracedExpr expr -> true | _ -> false @@ -49534,7 +49616,7 @@ let isHuggablePattern pattern = match pattern.ppat_desc with | Ppat_array _ | Ppat_tuple _ | Ppat_record _ | Ppat_variant _ | Ppat_construct _ -> - true + true | _ -> false let operatorPrecedence operator = @@ -49550,17 +49632,15 @@ let operatorPrecedence operator = | _ -> 0 let isUnaryOperator operator = - match operator with - | "~+" | "~+." | "~-" | "~-." | "not" -> true - | _ -> false + match operator with "~+" | "~+." | "~-" | "~-." | "not" -> true | _ -> false let isUnaryExpression expr = match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [(Nolabel, _arg)] ) + ( { pexp_desc = Pexp_ident { txt = Longident.Lident operator } }, + [ (Nolabel, _arg) ] ) when isUnaryOperator operator -> - true + true | _ -> false (* TODO: tweak this to check for ghost ^ as template literal *) @@ -49569,7 +49649,7 @@ let isBinaryOperator operator = | ":=" | "||" | "&&" | "=" | "==" | "<" | ">" | "!=" | "!==" | "<=" | ">=" | "|>" | "+" | "+." | "-" | "-." | "^" | "*" | "*." | "/" | "/." | "**" | "|." | "<>" -> - true + true | _ -> false let isBinaryExpression expr = @@ -49577,19 +49657,17 @@ let isBinaryExpression expr = | Pexp_apply ( { pexp_desc = - Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}; + Pexp_ident { txt = Longident.Lident operator; loc = operatorLoc }; }, - [(Nolabel, _operand1); (Nolabel, _operand2)] ) + [ (Nolabel, _operand1); (Nolabel, _operand2) ] ) when isBinaryOperator operator && not (operatorLoc.loc_ghost && operator = "^") (* template literal *) -> - true + true | _ -> false let isEqualityOperator operator = - match operator with - | "=" | "==" | "<>" | "!=" -> true - | _ -> false + match operator with "=" | "==" | "<>" | "!=" -> true | _ -> false let flattenableOperators parentOperator childOperator = let precParent = operatorPrecedence parentOperator in @@ -49601,20 +49679,20 @@ let flattenableOperators parentOperator childOperator = let rec hasIfLetAttribute attrs = match attrs with | [] -> false - | ({Location.txt = "ns.iflet"}, _) :: _ -> true + | ({ Location.txt = "ns.iflet" }, _) :: _ -> true | _ :: attrs -> hasIfLetAttribute attrs let isIfLetExpr expr = match expr with - | {pexp_attributes = attrs; pexp_desc = Pexp_match _} + | { pexp_attributes = attrs; pexp_desc = Pexp_match _ } when hasIfLetAttribute attrs -> - true + true | _ -> false let rec hasOptionalAttribute attrs = match attrs with | [] -> false - | ({Location.txt = "ns.optional"}, _) :: _ -> true + | ({ Location.txt = "ns.optional" }, _) :: _ -> true | _ :: attrs -> hasOptionalAttribute attrs let hasAttributes attrs = @@ -49627,27 +49705,30 @@ let hasAttributes attrs = | "res.await" | "res.template" ); }, _ ) -> - false + false (* Remove the fragile pattern warning for iflet expressions *) - | ( {Location.txt = "warning"}, + | ( { Location.txt = "warning" }, PStr [ { pstr_desc = Pstr_eval - ({pexp_desc = Pexp_constant (Pconst_string ("-4", None))}, _); + ( { pexp_desc = Pexp_constant (Pconst_string ("-4", None)) }, + _ ); }; ] ) -> - not (hasIfLetAttribute attrs) + not (hasIfLetAttribute attrs) | _ -> true) attrs let isArrayAccess expr = match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "get")}}, - [(Nolabel, _parentExpr); (Nolabel, _memberExpr)] ) -> - true + ( { + pexp_desc = Pexp_ident { txt = Longident.Ldot (Lident "Array", "get") }; + }, + [ (Nolabel, _parentExpr); (Nolabel, _memberExpr) ] ) -> + true | _ -> false type ifConditionKind = @@ -49659,32 +49740,36 @@ let collectIfExpressions expr = let exprLoc = expr.pexp_loc in match expr.pexp_desc with | Pexp_ifthenelse (ifExpr, thenExpr, Some elseExpr) -> - collect ((exprLoc, If ifExpr, thenExpr) :: acc) elseExpr + collect ((exprLoc, If ifExpr, thenExpr) :: acc) elseExpr | Pexp_ifthenelse (ifExpr, thenExpr, (None as elseExpr)) -> - let ifs = List.rev ((exprLoc, If ifExpr, thenExpr) :: acc) in - (ifs, elseExpr) + let ifs = List.rev ((exprLoc, If ifExpr, thenExpr) :: acc) in + (ifs, elseExpr) | Pexp_match ( condition, [ - {pc_lhs = pattern; pc_guard = None; pc_rhs = thenExpr}; + { pc_lhs = pattern; pc_guard = None; pc_rhs = thenExpr }; { pc_rhs = - {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)}; + { + pexp_desc = Pexp_construct ({ txt = Longident.Lident "()" }, _); + }; }; ] ) when isIfLetExpr expr -> - let ifs = - List.rev ((exprLoc, IfLet (pattern, condition), thenExpr) :: acc) - in - (ifs, None) + let ifs = + List.rev ((exprLoc, IfLet (pattern, condition), thenExpr) :: acc) + in + (ifs, None) | Pexp_match ( condition, [ - {pc_lhs = pattern; pc_guard = None; pc_rhs = thenExpr}; - {pc_rhs = elseExpr}; + { pc_lhs = pattern; pc_guard = None; pc_rhs = thenExpr }; + { pc_rhs = elseExpr }; ] ) when isIfLetExpr expr -> - collect ((exprLoc, IfLet (pattern, condition), thenExpr) :: acc) elseExpr + collect + ((exprLoc, IfLet (pattern, condition), thenExpr) :: acc) + elseExpr | _ -> (List.rev acc, Some expr) in collect [] expr @@ -49692,14 +49777,14 @@ let collectIfExpressions expr = let rec hasTernaryAttribute attrs = match attrs with | [] -> false - | ({Location.txt = "ns.ternary"}, _) :: _ -> true + | ({ Location.txt = "ns.ternary" }, _) :: _ -> true | _ :: attrs -> hasTernaryAttribute attrs let isTernaryExpr expr = match expr with - | {pexp_attributes = attrs; pexp_desc = Pexp_ifthenelse _} + | { pexp_attributes = attrs; pexp_desc = Pexp_ifthenelse _ } when hasTernaryAttribute attrs -> - true + true | _ -> false let collectTernaryParts expr = @@ -49710,40 +49795,40 @@ let collectTernaryParts expr = pexp_desc = Pexp_ifthenelse (condition, consequent, Some alternate); } when hasTernaryAttribute attrs -> - collect ((condition, consequent) :: acc) alternate + collect ((condition, consequent) :: acc) alternate | alternate -> (List.rev acc, alternate) in collect [] expr let parametersShouldHug parameters = match parameters with - | [Parameter {attrs = []; lbl = Asttypes.Nolabel; defaultExpr = None; pat}] + | [ + Parameter { attrs = []; lbl = Asttypes.Nolabel; defaultExpr = None; pat }; + ] when isHuggablePattern pat -> - true + true | _ -> false let filterTernaryAttributes attrs = List.filter (fun attr -> - match attr with - | {Location.txt = "ns.ternary"}, _ -> false - | _ -> true) + match attr with { Location.txt = "ns.ternary" }, _ -> false | _ -> true) attrs let filterFragileMatchAttributes attrs = List.filter (fun attr -> match attr with - | ( {Location.txt = "warning"}, + | ( { Location.txt = "warning" }, PStr [ { pstr_desc = Pstr_eval - ({pexp_desc = Pexp_constant (Pconst_string ("-4", _))}, _); + ({ pexp_desc = Pexp_constant (Pconst_string ("-4", _)) }, _); }; ] ) -> - false + false | _ -> true) attrs @@ -49751,7 +49836,7 @@ let isJsxExpression expr = let rec loop attrs = match attrs with | [] -> false - | ({Location.txt = "JSX"}, _) :: _ -> true + | ({ Location.txt = "JSX" }, _) :: _ -> true | _ :: attrs -> loop attrs in match expr.pexp_desc with @@ -49762,7 +49847,7 @@ let hasJsxAttribute attributes = let rec loop attrs = match attrs with | [] -> false - | ({Location.txt = "JSX"}, _) :: _ -> true + | ({ Location.txt = "JSX" }, _) :: _ -> true | _ :: attrs -> loop attrs in loop attributes @@ -49773,24 +49858,24 @@ let shouldIndentBinaryExpr expr = | { pexp_desc = Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident subOperator}}, - [(Nolabel, _lhs); (Nolabel, _rhs)] ); + ( { pexp_desc = Pexp_ident { txt = Longident.Lident subOperator } }, + [ (Nolabel, _lhs); (Nolabel, _rhs) ] ); } when isBinaryOperator subOperator -> - flattenableOperators operator subOperator + flattenableOperators operator subOperator | _ -> true in match expr with | { pexp_desc = Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [(Nolabel, lhs); (Nolabel, _rhs)] ); + ( { pexp_desc = Pexp_ident { txt = Longident.Lident operator } }, + [ (Nolabel, lhs); (Nolabel, _rhs) ] ); } when isBinaryOperator operator -> - isEqualityOperator operator - || (not (samePrecedenceSubExpression operator lhs)) - || operator = ":=" + isEqualityOperator operator + || (not (samePrecedenceSubExpression operator lhs)) + || operator = ":=" | _ -> false let shouldInlineRhsBinaryExpr rhs = @@ -49798,7 +49883,7 @@ let shouldInlineRhsBinaryExpr rhs = | Parsetree.Pexp_constant _ | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ | Pexp_sequence _ | Pexp_open _ | Pexp_ifthenelse _ | Pexp_for _ | Pexp_while _ | Pexp_try _ | Pexp_array _ | Pexp_record _ -> - true + true | _ -> false let isPrintableAttribute attr = @@ -49809,11 +49894,10 @@ let isPrintableAttribute attr = | "res.template" | "ns.ternary" ); }, _ ) -> - false + false | _ -> true let hasPrintableAttributes attrs = List.exists isPrintableAttribute attrs - let filterPrintableAttributes attrs = List.filter isPrintableAttribute attrs let partitionPrintableAttributes attrs = @@ -49823,8 +49907,8 @@ let requiresSpecialCallbackPrintingLastArg args = let rec loop args = match args with | [] -> false - | [(_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})] -> true - | (_, {pexp_desc = Pexp_fun _ | Pexp_newtype _}) :: _ -> false + | [ (_, { pexp_desc = Pexp_fun _ | Pexp_newtype _ }) ] -> true + | (_, { pexp_desc = Pexp_fun _ | Pexp_newtype _ }) :: _ -> false | _ :: rest -> loop rest in loop args @@ -49833,18 +49917,18 @@ let requiresSpecialCallbackPrintingFirstArg args = let rec loop args = match args with | [] -> true - | (_, {pexp_desc = Pexp_fun _ | Pexp_newtype _}) :: _ -> false + | (_, { pexp_desc = Pexp_fun _ | Pexp_newtype _ }) :: _ -> false | _ :: rest -> loop rest in match args with - | [(_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})] -> false - | (_, {pexp_desc = Pexp_fun _ | Pexp_newtype _}) :: rest -> loop rest + | [ (_, { pexp_desc = Pexp_fun _ | Pexp_newtype _ }) ] -> false + | (_, { pexp_desc = Pexp_fun _ | Pexp_newtype _ }) :: rest -> loop rest | _ -> false let modExprApply modExpr = let rec loop acc modExpr = match modExpr with - | {pmod_desc = Pmod_apply (next, arg)} -> loop (arg :: acc) next + | { pmod_desc = Pmod_apply (next, arg) } -> loop (arg :: acc) next | _ -> (acc, modExpr) in loop [] modExpr @@ -49856,8 +49940,8 @@ let modExprFunctor modExpr = pmod_desc = Pmod_functor (lbl, modType, returnModExpr); pmod_attributes = attrs; } -> - let param = (attrs, lbl, modType) in - loop (param :: acc) returnModExpr + let param = (attrs, lbl, modType) in + loop (param :: acc) returnModExpr | returnModExpr -> (List.rev acc, returnModExpr) in loop [] modExpr @@ -49866,26 +49950,26 @@ let rec collectPatternsFromListConstruct acc pattern = let open Parsetree in match pattern.ppat_desc with | Ppat_construct - ({txt = Longident.Lident "::"}, Some {ppat_desc = Ppat_tuple [pat; rest]}) - -> - collectPatternsFromListConstruct (pat :: acc) rest + ( { txt = Longident.Lident "::" }, + Some { ppat_desc = Ppat_tuple [ pat; rest ] } ) -> + collectPatternsFromListConstruct (pat :: acc) rest | _ -> (List.rev acc, pattern) let hasTemplateLiteralAttr attrs = List.exists (fun attr -> match attr with - | {Location.txt = "res.template"}, _ -> true + | { Location.txt = "res.template" }, _ -> true | _ -> false) attrs let isTemplateLiteral expr = match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident "^"}}, - [(Nolabel, _); (Nolabel, _)] ) + ( { pexp_desc = Pexp_ident { txt = Longident.Lident "^" } }, + [ (Nolabel, _); (Nolabel, _) ] ) when hasTemplateLiteralAttr expr.pexp_attributes -> - true + true | Pexp_constant (Pconst_string (_, Some "")) -> true | Pexp_constant _ when hasTemplateLiteralAttr expr.pexp_attributes -> true | _ -> false @@ -49893,9 +49977,7 @@ let isTemplateLiteral expr = let hasSpreadAttr attrs = List.exists (fun attr -> - match attr with - | {Location.txt = "res.spread"}, _ -> true - | _ -> false) + match attr with { Location.txt = "res.spread" }, _ -> true | _ -> false) attrs let isSpreadBeltListConcat expr = @@ -49906,7 +49988,7 @@ let isSpreadBeltListConcat expr = Longident.Ldot (Longident.Ldot (Longident.Lident "Belt", "List"), "concatMany"); } -> - hasSpreadAttr expr.pexp_attributes + hasSpreadAttr expr.pexp_attributes | _ -> false (* Blue | Red | Green -> [Blue; Red; Green] *) @@ -49934,17 +50016,17 @@ let isSinglePipeExpr expr = let isPipeExpr expr = match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident ("|." | "|>")}}, - [(Nolabel, _operand1); (Nolabel, _operand2)] ) -> - true + ( { pexp_desc = Pexp_ident { txt = Longident.Lident ("|." | "|>") } }, + [ (Nolabel, _operand1); (Nolabel, _operand2) ] ) -> + true | _ -> false in match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident ("|." | "|>")}}, - [(Nolabel, operand1); (Nolabel, _operand2)] ) + ( { pexp_desc = Pexp_ident { txt = Longident.Lident ("|." | "|>") } }, + [ (Nolabel, operand1); (Nolabel, _operand2) ] ) when not (isPipeExpr operand1) -> - true + true | _ -> false let isUnderscoreApplySugar expr = @@ -49952,14 +50034,14 @@ let isUnderscoreApplySugar expr = | Pexp_fun ( Nolabel, None, - {ppat_desc = Ppat_var {txt = "__x"}}, - {pexp_desc = Pexp_apply _} ) -> - true + { ppat_desc = Ppat_var { txt = "__x" } }, + { pexp_desc = Pexp_apply _ } ) -> + true | _ -> false let isRewrittenUnderscoreApplySugar expr = match expr.pexp_desc with - | Pexp_ident {txt = Longident.Lident "_"} -> true + | Pexp_ident { txt = Longident.Lident "_" } -> true | _ -> false end @@ -49971,9 +50053,9 @@ module Doc = Res_doc module ParsetreeViewer = Res_parsetree_viewer type t = { - leading: (Location.t, Comment.t list) Hashtbl.t; - inside: (Location.t, Comment.t list) Hashtbl.t; - trailing: (Location.t, Comment.t list) Hashtbl.t; + leading : (Location.t, Comment.t list) Hashtbl.t; + inside : (Location.t, Comment.t list) Hashtbl.t; + trailing : (Location.t, Comment.t list) Hashtbl.t; } let make () = @@ -50021,7 +50103,7 @@ let printEntries tbl = [ Doc.line; Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) (List.map (fun c -> Doc.text (Comment.txt c)) v); ]); Doc.line; @@ -50038,33 +50120,31 @@ let log t = (Doc.concat [ Doc.text "leading comments:"; - Doc.indent (Doc.concat [Doc.line; Doc.concat leadingStuff]); + Doc.indent (Doc.concat [ Doc.line; Doc.concat leadingStuff ]); Doc.line; Doc.text "comments inside:"; - Doc.indent (Doc.concat [Doc.line; Doc.concat stuffInside]); + Doc.indent (Doc.concat [ Doc.line; Doc.concat stuffInside ]); Doc.line; Doc.text "trailing comments:"; - Doc.indent (Doc.concat [Doc.line; Doc.concat trailingStuff]); + Doc.indent (Doc.concat [ Doc.line; Doc.concat trailingStuff ]); Doc.line; ]) |> Doc.toString ~width:80 |> print_endline let attach tbl loc comments = - match comments with - | [] -> () - | comments -> Hashtbl.replace tbl loc comments + match comments with [] -> () | comments -> Hashtbl.replace tbl loc comments let partitionByLoc comments loc = let rec loop (leading, inside, trailing) comments = let open Location in match comments with | comment :: rest -> - let cmtLoc = Comment.loc comment in - if cmtLoc.loc_end.pos_cnum <= loc.loc_start.pos_cnum then - loop (comment :: leading, inside, trailing) rest - else if cmtLoc.loc_start.pos_cnum >= loc.loc_end.pos_cnum then - loop (leading, inside, comment :: trailing) rest - else loop (leading, comment :: inside, trailing) rest + let cmtLoc = Comment.loc comment in + if cmtLoc.loc_end.pos_cnum <= loc.loc_start.pos_cnum then + loop (comment :: leading, inside, trailing) rest + else if cmtLoc.loc_start.pos_cnum >= loc.loc_end.pos_cnum then + loop (leading, inside, comment :: trailing) rest + else loop (leading, comment :: inside, trailing) rest | [] -> (List.rev leading, List.rev inside, List.rev trailing) in loop ([], [], []) comments @@ -50074,10 +50154,10 @@ let partitionLeadingTrailing comments loc = let open Location in match comments with | comment :: rest -> - let cmtLoc = Comment.loc comment in - if cmtLoc.loc_end.pos_cnum <= loc.loc_start.pos_cnum then - loop (comment :: leading, trailing) rest - else loop (leading, comment :: trailing) rest + let cmtLoc = Comment.loc comment in + if cmtLoc.loc_end.pos_cnum <= loc.loc_start.pos_cnum then + loop (comment :: leading, trailing) rest + else loop (leading, comment :: trailing) rest | [] -> (List.rev leading, List.rev trailing) in loop ([], []) comments @@ -50088,10 +50168,10 @@ let partitionByOnSameLine loc comments = match comments with | [] -> (List.rev onSameLine, List.rev onOtherLine) | comment :: rest -> - let cmtLoc = Comment.loc comment in - if cmtLoc.loc_start.pos_lnum == loc.loc_end.pos_lnum then - loop (comment :: onSameLine, onOtherLine) rest - else loop (onSameLine, comment :: onOtherLine) rest + let cmtLoc = Comment.loc comment in + if cmtLoc.loc_start.pos_lnum == loc.loc_end.pos_lnum then + loop (comment :: onSameLine, onOtherLine) rest + else loop (onSameLine, comment :: onOtherLine) rest in loop ([], []) comments @@ -50102,11 +50182,11 @@ let partitionAdjacentTrailing loc1 comments = match comments with | [] -> (List.rev afterLoc1, []) | comment :: rest as comments -> - let cmtPrevEndPos = Comment.prevTokEndPos comment in - if prevEndPos.Lexing.pos_cnum == cmtPrevEndPos.pos_cnum then - let commentEnd = (Comment.loc comment).loc_end in - loop ~prevEndPos:commentEnd (comment :: afterLoc1) rest - else (List.rev afterLoc1, comments) + let cmtPrevEndPos = Comment.prevTokEndPos comment in + if prevEndPos.Lexing.pos_cnum == cmtPrevEndPos.pos_cnum then + let commentEnd = (Comment.loc comment).loc_end in + loop ~prevEndPos:commentEnd (comment :: afterLoc1) rest + else (List.rev afterLoc1, comments) in loop ~prevEndPos:loc1.loc_end [] comments @@ -50114,20 +50194,20 @@ let rec collectListPatterns acc pattern = let open Parsetree in match pattern.ppat_desc with | Ppat_construct - ({txt = Longident.Lident "::"}, Some {ppat_desc = Ppat_tuple [pat; rest]}) - -> - collectListPatterns (pat :: acc) rest - | Ppat_construct ({txt = Longident.Lident "[]"}, None) -> List.rev acc + ( { txt = Longident.Lident "::" }, + Some { ppat_desc = Ppat_tuple [ pat; rest ] } ) -> + collectListPatterns (pat :: acc) rest + | Ppat_construct ({ txt = Longident.Lident "[]" }, None) -> List.rev acc | _ -> List.rev (pattern :: acc) let rec collectListExprs acc expr = let open Parsetree in match expr.pexp_desc with | Pexp_construct - ({txt = Longident.Lident "::"}, Some {pexp_desc = Pexp_tuple [expr; rest]}) - -> - collectListExprs (expr :: acc) rest - | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> List.rev acc + ( { txt = Longident.Lident "::" }, + Some { pexp_desc = Pexp_tuple [ expr; rest ] } ) -> + collectListExprs (expr :: acc) rest + | Pexp_construct ({ txt = Longident.Lident "[]" }, _) -> List.rev acc | _ -> List.rev (expr :: acc) (* TODO: use ParsetreeViewer *) @@ -50139,37 +50219,39 @@ let arrowType ct = ptyp_desc = Ptyp_arrow ((Nolabel as lbl), typ1, typ2); ptyp_attributes = []; } -> - let arg = ([], lbl, typ1) in - process attrsBefore (arg :: acc) typ2 + let arg = ([], lbl, typ1) in + process attrsBefore (arg :: acc) typ2 | { ptyp_desc = Ptyp_arrow ((Nolabel as lbl), typ1, typ2); - ptyp_attributes = [({txt = "bs"}, _)] as attrs; + ptyp_attributes = [ ({ txt = "bs" }, _) ] as attrs; } -> - let arg = (attrs, lbl, typ1) in - process attrsBefore (arg :: acc) typ2 - | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = _attrs} - as returnType -> - let args = List.rev acc in - (attrsBefore, args, returnType) + let arg = (attrs, lbl, typ1) in + process attrsBefore (arg :: acc) typ2 + | { + ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); + ptyp_attributes = _attrs; + } as returnType -> + let args = List.rev acc in + (attrsBefore, args, returnType) | { ptyp_desc = Ptyp_arrow (((Labelled _ | Optional _) as lbl), typ1, typ2); ptyp_attributes = attrs; } -> - let arg = (attrs, lbl, typ1) in - process attrsBefore (arg :: acc) typ2 + let arg = (attrs, lbl, typ1) in + process attrsBefore (arg :: acc) typ2 | typ -> (attrsBefore, List.rev acc, typ) in match ct with - | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = attrs} as - typ -> - process attrs [] {typ with ptyp_attributes = []} + | { ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = attrs } + as typ -> + process attrs [] { typ with ptyp_attributes = [] } | typ -> process [] [] typ (* TODO: avoiding the dependency on ParsetreeViewer here, is this a good idea? *) let modExprApply modExpr = let rec loop acc modExpr = match modExpr with - | {Parsetree.pmod_desc = Pmod_apply (next, arg)} -> loop (arg :: acc) next + | { Parsetree.pmod_desc = Pmod_apply (next, arg) } -> loop (arg :: acc) next | _ -> modExpr :: acc in loop [] modExpr @@ -50182,8 +50264,8 @@ let modExprFunctor modExpr = Parsetree.pmod_desc = Pmod_functor (lbl, modType, returnModExpr); pmod_attributes = attrs; } -> - let param = (attrs, lbl, modType) in - loop (param :: acc) returnModExpr + let param = (attrs, lbl, modType) in + loop (param :: acc) returnModExpr | returnModExpr -> (List.rev acc, returnModExpr) in loop [] modExpr @@ -50195,8 +50277,8 @@ let functorType modtype = Parsetree.pmty_desc = Pmty_functor (lbl, argType, returnType); pmty_attributes = attrs; } -> - let arg = (attrs, lbl, argType) in - process (arg :: acc) returnType + let arg = (attrs, lbl, argType) in + process (arg :: acc) returnType | modType -> (List.rev acc, modType) in process [] modtype @@ -50206,22 +50288,22 @@ let funExpr expr = (* Turns (type t, type u, type z) into "type t u z" *) let rec collectNewTypes acc returnExpr = match returnExpr with - | {pexp_desc = Pexp_newtype (stringLoc, returnExpr); pexp_attributes = []} + | { pexp_desc = Pexp_newtype (stringLoc, returnExpr); pexp_attributes = [] } -> - collectNewTypes (stringLoc :: acc) returnExpr + collectNewTypes (stringLoc :: acc) returnExpr | returnExpr -> - let loc = - match (acc, List.rev acc) with - | _startLoc :: _, endLoc :: _ -> - {endLoc.loc with loc_end = endLoc.loc.loc_end} - | _ -> Location.none - in - let txt = - List.fold_right - (fun curr acc -> acc ^ " " ^ curr.Location.txt) - acc "type" - in - (Location.mkloc txt loc, returnExpr) + let loc = + match (acc, List.rev acc) with + | _startLoc :: _, endLoc :: _ -> + { endLoc.loc with loc_end = endLoc.loc.loc_end } + | _ -> Location.none + in + let txt = + List.fold_right + (fun curr acc -> acc ^ " " ^ curr.Location.txt) + acc "type" + in + (Location.mkloc txt loc, returnExpr) in (* For simplicity reason Pexp_newtype gets converted to a Nolabel parameter, * otherwise this function would need to return a variant: @@ -50235,31 +50317,31 @@ let funExpr expr = pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr); pexp_attributes = []; } -> - let parameter = ([], lbl, defaultExpr, pattern) in - collect attrsBefore (parameter :: acc) returnExpr - | {pexp_desc = Pexp_newtype (stringLoc, rest); pexp_attributes = attrs} -> - let var, returnExpr = collectNewTypes [stringLoc] rest in - let parameter = - ( attrs, - Asttypes.Nolabel, - None, - Ast_helper.Pat.var ~loc:stringLoc.loc var ) - in - collect attrsBefore (parameter :: acc) returnExpr + let parameter = ([], lbl, defaultExpr, pattern) in + collect attrsBefore (parameter :: acc) returnExpr + | { pexp_desc = Pexp_newtype (stringLoc, rest); pexp_attributes = attrs } -> + let var, returnExpr = collectNewTypes [ stringLoc ] rest in + let parameter = + ( attrs, + Asttypes.Nolabel, + None, + Ast_helper.Pat.var ~loc:stringLoc.loc var ) + in + collect attrsBefore (parameter :: acc) returnExpr | { pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr); - pexp_attributes = [({txt = "bs"}, _)] as attrs; + pexp_attributes = [ ({ txt = "bs" }, _) ] as attrs; } -> - let parameter = (attrs, lbl, defaultExpr, pattern) in - collect attrsBefore (parameter :: acc) returnExpr + let parameter = (attrs, lbl, defaultExpr, pattern) in + collect attrsBefore (parameter :: acc) returnExpr | { pexp_desc = Pexp_fun (((Labelled _ | Optional _) as lbl), defaultExpr, pattern, returnExpr); pexp_attributes = attrs; } -> - let parameter = (attrs, lbl, defaultExpr, pattern) in - collect attrsBefore (parameter :: acc) returnExpr + let parameter = (attrs, lbl, defaultExpr, pattern) in + collect attrsBefore (parameter :: acc) returnExpr | expr -> (attrsBefore, List.rev acc, expr) in match expr with @@ -50267,7 +50349,7 @@ let funExpr expr = pexp_desc = Pexp_fun (Nolabel, _defaultExpr, _pattern, _returnExpr); pexp_attributes = attrs; } as expr -> - collect attrs [] {expr with pexp_attributes = []} + collect attrs [] { expr with pexp_attributes = [] } | expr -> collect [] [] expr let rec isBlockExpr expr = @@ -50275,7 +50357,7 @@ let rec isBlockExpr expr = match expr.pexp_desc with | Pexp_letmodule _ | Pexp_letexception _ | Pexp_let _ | Pexp_open _ | Pexp_sequence _ -> - true + true | Pexp_apply (callExpr, _) when isBlockExpr callExpr -> true | Pexp_constraint (expr, _) when isBlockExpr expr -> true | Pexp_field (expr, _) when isBlockExpr expr -> true @@ -50284,9 +50366,7 @@ let rec isBlockExpr expr = let isIfThenElseExpr expr = let open Parsetree in - match expr.pexp_desc with - | Pexp_ifthenelse _ -> true - | _ -> false + match expr.pexp_desc with Pexp_ifthenelse _ -> true | _ -> false type node = | Case of Parsetree.case @@ -50313,35 +50393,35 @@ let getLoc node = let open Parsetree in match node with | Case case -> - {case.pc_lhs.ppat_loc with loc_end = case.pc_rhs.pexp_loc.loc_end} + { case.pc_lhs.ppat_loc with loc_end = case.pc_rhs.pexp_loc.loc_end } | CoreType ct -> ct.ptyp_loc | ExprArgument expr -> ( - match expr.Parsetree.pexp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _attrs -> - {loc with loc_end = expr.pexp_loc.loc_end} - | _ -> expr.pexp_loc) + match expr.Parsetree.pexp_attributes with + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _attrs -> + { loc with loc_end = expr.pexp_loc.loc_end } + | _ -> expr.pexp_loc) | Expression e -> ( - match e.pexp_attributes with - | ({txt = "ns.braces"; loc}, _) :: _ -> loc - | _ -> e.pexp_loc) - | ExprRecordRow (li, e) -> {li.loc with loc_end = e.pexp_loc.loc_end} + match e.pexp_attributes with + | ({ txt = "ns.braces"; loc }, _) :: _ -> loc + | _ -> e.pexp_loc) + | ExprRecordRow (li, e) -> { li.loc with loc_end = e.pexp_loc.loc_end } | ExtensionConstructor ec -> ec.pext_loc | LabelDeclaration ld -> ld.pld_loc | ModuleBinding mb -> mb.pmb_loc | ModuleDeclaration md -> md.pmd_loc | ModuleExpr me -> me.pmod_loc | ObjectField field -> ( - match field with - | Parsetree.Otag (lbl, _, typ) -> - {lbl.loc with loc_end = typ.ptyp_loc.loc_end} - | _ -> Location.none) - | PackageConstraint (li, te) -> {li.loc with loc_end = te.ptyp_loc.loc_end} + match field with + | Parsetree.Otag (lbl, _, typ) -> + { lbl.loc with loc_end = typ.ptyp_loc.loc_end } + | _ -> Location.none) + | PackageConstraint (li, te) -> { li.loc with loc_end = te.ptyp_loc.loc_end } | Pattern p -> p.ppat_loc - | PatternRecordRow (li, p) -> {li.loc with loc_end = p.ppat_loc.loc_end} + | PatternRecordRow (li, p) -> { li.loc with loc_end = p.ppat_loc.loc_end } | RowField rf -> ( - match rf with - | Parsetree.Rtag ({loc}, _, _, _) -> loc - | Rinherit {ptyp_loc} -> ptyp_loc) + match rf with + | Parsetree.Rtag ({ loc }, _, _, _) -> loc + | Rinherit { ptyp_loc } -> ptyp_loc) | SignatureItem si -> si.psig_loc | StructureItem si -> si.pstr_loc | TypeDeclaration td -> td.ptype_loc @@ -50357,24 +50437,24 @@ and walkStructureItem si t comments = match si.Parsetree.pstr_desc with | _ when comments = [] -> () | Pstr_primitive valueDescription -> - walkValueDescription valueDescription t comments + walkValueDescription valueDescription t comments | Pstr_open openDescription -> walkOpenDescription openDescription t comments | Pstr_value (_, valueBindings) -> walkValueBindings valueBindings t comments | Pstr_type (_, typeDeclarations) -> - walkTypeDeclarations typeDeclarations t comments + walkTypeDeclarations typeDeclarations t comments | Pstr_eval (expr, _) -> walkExpression expr t comments | Pstr_module moduleBinding -> walkModuleBinding moduleBinding t comments | Pstr_recmodule moduleBindings -> - walkList - (moduleBindings |> List.map (fun mb -> ModuleBinding mb)) - t comments + walkList + (moduleBindings |> List.map (fun mb -> ModuleBinding mb)) + t comments | Pstr_modtype modTypDecl -> walkModuleTypeDeclaration modTypDecl t comments | Pstr_attribute attribute -> walkAttribute attribute t comments | Pstr_extension (extension, _) -> walkExtension extension t comments | Pstr_include includeDeclaration -> - walkIncludeDeclaration includeDeclaration t comments + walkIncludeDeclaration includeDeclaration t comments | Pstr_exception extensionConstructor -> - walkExtensionConstructor extensionConstructor t comments + walkExtensionConstructor extensionConstructor t comments | Pstr_typext typeExtension -> walkTypeExtension typeExtension t comments | Pstr_class_type _ | Pstr_class _ -> () @@ -50401,9 +50481,9 @@ and walkTypeExtension te t comments = match te.ptyext_params with | [] -> rest | typeParams -> - visitListButContinueWithRemainingComments - ~getLoc:(fun (typexpr, _variance) -> typexpr.Parsetree.ptyp_loc) - ~walkNode:walkTypeParam ~newlineDelimited:false typeParams t rest + visitListButContinueWithRemainingComments + ~getLoc:(fun (typexpr, _variance) -> typexpr.Parsetree.ptyp_loc) + ~walkNode:walkTypeParam ~newlineDelimited:false typeParams t rest in walkList (te.ptyext_constructors |> List.map (fun ec -> ExtensionConstructor ec)) @@ -50423,14 +50503,14 @@ and walkModuleTypeDeclaration mtd t comments = match mtd.pmtd_type with | None -> attach t.trailing mtd.pmtd_name.loc trailing | Some modType -> - let afterName, rest = - partitionAdjacentTrailing mtd.pmtd_name.loc trailing - in - attach t.trailing mtd.pmtd_name.loc afterName; - let before, inside, after = partitionByLoc rest modType.pmty_loc in - attach t.leading modType.pmty_loc before; - walkModType modType t inside; - attach t.trailing modType.pmty_loc after + let afterName, rest = + partitionAdjacentTrailing mtd.pmtd_name.loc trailing + in + attach t.trailing mtd.pmtd_name.loc afterName; + let before, inside, after = partitionByLoc rest modType.pmty_loc in + attach t.leading modType.pmty_loc before; + walkModType modType t inside; + attach t.trailing modType.pmty_loc after and walkModuleBinding mb t comments = let leading, trailing = partitionLeadingTrailing comments mb.pmb_name.loc in @@ -50440,10 +50520,10 @@ and walkModuleBinding mb t comments = let leading, inside, trailing = partitionByLoc rest mb.pmb_expr.pmod_loc in (match mb.pmb_expr.pmod_desc with | Pmod_constraint _ -> - walkModuleExpr mb.pmb_expr t (List.concat [leading; inside]) + walkModuleExpr mb.pmb_expr t (List.concat [ leading; inside ]) | _ -> - attach t.leading mb.pmb_expr.pmod_loc leading; - walkModuleExpr mb.pmb_expr t inside); + attach t.leading mb.pmb_expr.pmod_loc leading; + walkModuleExpr mb.pmb_expr t inside); attach t.trailing mb.pmb_expr.pmod_loc trailing and walkSignature signature t comments = @@ -50451,29 +50531,29 @@ and walkSignature signature t comments = | _ when comments = [] -> () | [] -> attach t.inside Location.none comments | _s -> - walkList (signature |> List.map (fun si -> SignatureItem si)) t comments + walkList (signature |> List.map (fun si -> SignatureItem si)) t comments and walkSignatureItem (si : Parsetree.signature_item) t comments = match si.psig_desc with | _ when comments = [] -> () | Psig_value valueDescription -> - walkValueDescription valueDescription t comments + walkValueDescription valueDescription t comments | Psig_type (_, typeDeclarations) -> - walkTypeDeclarations typeDeclarations t comments + walkTypeDeclarations typeDeclarations t comments | Psig_typext typeExtension -> walkTypeExtension typeExtension t comments | Psig_exception extensionConstructor -> - walkExtensionConstructor extensionConstructor t comments + walkExtensionConstructor extensionConstructor t comments | Psig_module moduleDeclaration -> - walkModuleDeclaration moduleDeclaration t comments + walkModuleDeclaration moduleDeclaration t comments | Psig_recmodule moduleDeclarations -> - walkList - (moduleDeclarations |> List.map (fun md -> ModuleDeclaration md)) - t comments + walkList + (moduleDeclarations |> List.map (fun md -> ModuleDeclaration md)) + t comments | Psig_modtype moduleTypeDeclaration -> - walkModuleTypeDeclaration moduleTypeDeclaration t comments + walkModuleTypeDeclaration moduleTypeDeclaration t comments | Psig_open openDescription -> walkOpenDescription openDescription t comments | Psig_include includeDescription -> - walkIncludeDescription includeDescription t comments + walkIncludeDescription includeDescription t comments | Psig_attribute attribute -> walkAttribute attribute t comments | Psig_extension (extension, _) -> walkExtension extension t comments | Psig_class _ | Psig_class_type _ -> () @@ -50521,31 +50601,35 @@ and walkList : ?prevLoc:Location.t -> node list -> t -> Comment.t list -> unit = match l with | _ when comments = [] -> () | [] -> ( - match prevLoc with - | Some loc -> attach t.trailing loc comments - | None -> ()) + match prevLoc with + | Some loc -> attach t.trailing loc comments + | None -> ()) | node :: rest -> - let currLoc = getLoc node in - let leading, inside, trailing = partitionByLoc comments currLoc in - (match prevLoc with - | None -> - (* first node, all leading comments attach here *) - attach t.leading currLoc leading - | Some prevLoc -> - (* Same line *) - if prevLoc.loc_end.pos_lnum == currLoc.loc_start.pos_lnum then ( - let afterPrev, beforeCurr = partitionAdjacentTrailing prevLoc leading in - attach t.trailing prevLoc afterPrev; - attach t.leading currLoc beforeCurr) - else - let onSameLineAsPrev, afterPrev = - partitionByOnSameLine prevLoc leading - in - attach t.trailing prevLoc onSameLineAsPrev; - let leading, _inside, _trailing = partitionByLoc afterPrev currLoc in - attach t.leading currLoc leading); - walkNode node t inside; - walkList ~prevLoc:currLoc rest t trailing + let currLoc = getLoc node in + let leading, inside, trailing = partitionByLoc comments currLoc in + (match prevLoc with + | None -> + (* first node, all leading comments attach here *) + attach t.leading currLoc leading + | Some prevLoc -> + (* Same line *) + if prevLoc.loc_end.pos_lnum == currLoc.loc_start.pos_lnum then ( + let afterPrev, beforeCurr = + partitionAdjacentTrailing prevLoc leading + in + attach t.trailing prevLoc afterPrev; + attach t.leading currLoc beforeCurr) + else + let onSameLineAsPrev, afterPrev = + partitionByOnSameLine prevLoc leading + in + attach t.trailing prevLoc onSameLineAsPrev; + let leading, _inside, _trailing = + partitionByLoc afterPrev currLoc + in + attach t.leading currLoc leading); + walkNode node t inside; + walkList ~prevLoc:currLoc rest t trailing (* The parsetree doesn't always contain location info about the opening or * closing token of a "list-of-things". This routine visits the whole list, @@ -50565,45 +50649,47 @@ and visitListButContinueWithRemainingComments : match l with | _ when comments = [] -> [] | [] -> ( - match prevLoc with - | Some loc -> - let afterPrev, rest = - if newlineDelimited then partitionByOnSameLine loc comments - else partitionAdjacentTrailing loc comments - in - attach t.trailing loc afterPrev; - rest - | None -> comments) - | node :: rest -> - let currLoc = getLoc node in - let leading, inside, trailing = partitionByLoc comments currLoc in - let () = match prevLoc with - | None -> - (* first node, all leading comments attach here *) - attach t.leading currLoc leading; - () - | Some prevLoc -> - (* Same line *) - if prevLoc.loc_end.pos_lnum == currLoc.loc_start.pos_lnum then - let afterPrev, beforeCurr = - partitionAdjacentTrailing prevLoc leading - in - let () = attach t.trailing prevLoc afterPrev in - let () = attach t.leading currLoc beforeCurr in - () - else - let onSameLineAsPrev, afterPrev = - partitionByOnSameLine prevLoc leading + | Some loc -> + let afterPrev, rest = + if newlineDelimited then partitionByOnSameLine loc comments + else partitionAdjacentTrailing loc comments in - let () = attach t.trailing prevLoc onSameLineAsPrev in - let leading, _inside, _trailing = partitionByLoc afterPrev currLoc in - let () = attach t.leading currLoc leading in - () - in - walkNode node t inside; - visitListButContinueWithRemainingComments ~prevLoc:currLoc ~getLoc ~walkNode - ~newlineDelimited rest t trailing + attach t.trailing loc afterPrev; + rest + | None -> comments) + | node :: rest -> + let currLoc = getLoc node in + let leading, inside, trailing = partitionByLoc comments currLoc in + let () = + match prevLoc with + | None -> + (* first node, all leading comments attach here *) + attach t.leading currLoc leading; + () + | Some prevLoc -> + (* Same line *) + if prevLoc.loc_end.pos_lnum == currLoc.loc_start.pos_lnum then + let afterPrev, beforeCurr = + partitionAdjacentTrailing prevLoc leading + in + let () = attach t.trailing prevLoc afterPrev in + let () = attach t.leading currLoc beforeCurr in + () + else + let onSameLineAsPrev, afterPrev = + partitionByOnSameLine prevLoc leading + in + let () = attach t.trailing prevLoc onSameLineAsPrev in + let leading, _inside, _trailing = + partitionByLoc afterPrev currLoc + in + let () = attach t.leading currLoc leading in + () + in + walkNode node t inside; + visitListButContinueWithRemainingComments ~prevLoc:currLoc ~getLoc + ~walkNode ~newlineDelimited rest t trailing and walkValueBindings vbs t comments = walkList (vbs |> List.map (fun vb -> ValueBinding vb)) t comments @@ -50634,25 +50720,25 @@ and walkTypeDeclaration (td : Parsetree.type_declaration) t comments = match td.ptype_params with | [] -> rest | typeParams -> - visitListButContinueWithRemainingComments - ~getLoc:(fun (typexpr, _variance) -> typexpr.Parsetree.ptyp_loc) - ~walkNode:walkTypeParam ~newlineDelimited:false typeParams t rest + visitListButContinueWithRemainingComments + ~getLoc:(fun (typexpr, _variance) -> typexpr.Parsetree.ptyp_loc) + ~walkNode:walkTypeParam ~newlineDelimited:false typeParams t rest in (* manifest: = typexpr *) let rest = match td.ptype_manifest with | Some typexpr -> - let beforeTyp, insideTyp, afterTyp = - partitionByLoc rest typexpr.ptyp_loc - in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - let afterTyp, rest = - partitionAdjacentTrailing typexpr.Parsetree.ptyp_loc afterTyp - in - attach t.trailing typexpr.ptyp_loc afterTyp; - rest + let beforeTyp, insideTyp, afterTyp = + partitionByLoc rest typexpr.ptyp_loc + in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkCoreType typexpr t insideTyp; + let afterTyp, rest = + partitionAdjacentTrailing typexpr.Parsetree.ptyp_loc afterTyp + in + attach t.trailing typexpr.ptyp_loc afterTyp; + rest | None -> rest in @@ -50660,16 +50746,16 @@ and walkTypeDeclaration (td : Parsetree.type_declaration) t comments = match td.ptype_kind with | Ptype_abstract | Ptype_open -> rest | Ptype_record labelDeclarations -> - let () = - if labelDeclarations = [] then attach t.inside td.ptype_loc rest - else - walkList - (labelDeclarations |> List.map (fun ld -> LabelDeclaration ld)) - t rest - in - [] + let () = + if labelDeclarations = [] then attach t.inside td.ptype_loc rest + else + walkList + (labelDeclarations |> List.map (fun ld -> LabelDeclaration ld)) + t rest + in + [] | Ptype_variant constructorDeclarations -> - walkConstructorDeclarations constructorDeclarations t rest + walkConstructorDeclarations constructorDeclarations t rest in attach t.trailing td.ptype_loc rest @@ -50705,16 +50791,16 @@ and walkConstructorDeclaration cd t comments = let rest = match cd.pcd_res with | Some typexpr -> - let beforeTyp, insideTyp, afterTyp = - partitionByLoc rest typexpr.ptyp_loc - in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - let afterTyp, rest = - partitionAdjacentTrailing typexpr.Parsetree.ptyp_loc afterTyp - in - attach t.trailing typexpr.ptyp_loc afterTyp; - rest + let beforeTyp, insideTyp, afterTyp = + partitionByLoc rest typexpr.ptyp_loc + in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkCoreType typexpr t insideTyp; + let afterTyp, rest = + partitionAdjacentTrailing typexpr.Parsetree.ptyp_loc afterTyp + in + attach t.trailing typexpr.ptyp_loc afterTyp; + rest | None -> rest in attach t.trailing cd.pcd_loc rest @@ -50722,63 +50808,71 @@ and walkConstructorDeclaration cd t comments = and walkConstructorArguments args t comments = match args with | Pcstr_tuple typexprs -> - visitListButContinueWithRemainingComments - ~getLoc:(fun n -> n.Parsetree.ptyp_loc) - ~walkNode:walkCoreType ~newlineDelimited:false typexprs t comments + visitListButContinueWithRemainingComments + ~getLoc:(fun n -> n.Parsetree.ptyp_loc) + ~walkNode:walkCoreType ~newlineDelimited:false typexprs t comments | Pcstr_record labelDeclarations -> - walkLabelDeclarations labelDeclarations t comments + walkLabelDeclarations labelDeclarations t comments and walkValueBinding vb t comments = let open Location in let vb = let open Parsetree in match (vb.pvb_pat, vb.pvb_expr) with - | ( {ppat_desc = Ppat_constraint (pat, {ptyp_desc = Ptyp_poly ([], t)})}, - {pexp_desc = Pexp_constraint (expr, _typ)} ) -> - { - vb with - pvb_pat = - Ast_helper.Pat.constraint_ - ~loc:{pat.ppat_loc with loc_end = t.Parsetree.ptyp_loc.loc_end} - pat t; - pvb_expr = expr; - } - | ( {ppat_desc = Ppat_constraint (pat, {ptyp_desc = Ptyp_poly (_ :: _, t)})}, - {pexp_desc = Pexp_fun _} ) -> - { - vb with - pvb_pat = - { - vb.pvb_pat with - ppat_loc = {pat.ppat_loc with loc_end = t.ptyp_loc.loc_end}; - }; - } + | ( { ppat_desc = Ppat_constraint (pat, { ptyp_desc = Ptyp_poly ([], t) }) }, + { pexp_desc = Pexp_constraint (expr, _typ) } ) -> + { + vb with + pvb_pat = + Ast_helper.Pat.constraint_ + ~loc:{ pat.ppat_loc with loc_end = t.Parsetree.ptyp_loc.loc_end } + pat t; + pvb_expr = expr; + } + | ( { + ppat_desc = + Ppat_constraint (pat, { ptyp_desc = Ptyp_poly (_ :: _, t) }); + }, + { pexp_desc = Pexp_fun _ } ) -> + { + vb with + pvb_pat = + { + vb.pvb_pat with + ppat_loc = { pat.ppat_loc with loc_end = t.ptyp_loc.loc_end }; + }; + } | ( ({ ppat_desc = - Ppat_constraint (pat, ({ptyp_desc = Ptyp_poly (_ :: _, t)} as typ)); + Ppat_constraint + (pat, ({ ptyp_desc = Ptyp_poly (_ :: _, t) } as typ)); } as constrainedPattern), - {pexp_desc = Pexp_newtype (_, {pexp_desc = Pexp_constraint (expr, _)})} - ) -> - (* - * The location of the Ptyp_poly on the pattern is the whole thing. - * let x: - * type t. (int, int) => int = - * (a, b) => { - * // comment - * a + b - * } - *) - { - vb with - pvb_pat = - { - constrainedPattern with - ppat_desc = Ppat_constraint (pat, typ); - ppat_loc = - {constrainedPattern.ppat_loc with loc_end = t.ptyp_loc.loc_end}; - }; - pvb_expr = expr; - } + { + pexp_desc = Pexp_newtype (_, { pexp_desc = Pexp_constraint (expr, _) }); + } ) -> + (* + * The location of the Ptyp_poly on the pattern is the whole thing. + * let x: + * type t. (int, int) => int = + * (a, b) => { + * // comment + * a + b + * } + *) + { + vb with + pvb_pat = + { + constrainedPattern with + ppat_desc = Ppat_constraint (pat, typ); + ppat_loc = + { + constrainedPattern.ppat_loc with + loc_end = t.ptyp_loc.loc_end; + }; + }; + pvb_expr = expr; + } | _ -> vb in let patternLoc = vb.Parsetree.pvb_pat.ppat_loc in @@ -50799,7 +50893,7 @@ and walkValueBinding vb t comments = partitionByLoc surroundingExpr exprLoc in if isBlockExpr expr then - walkExpression expr t (List.concat [beforeExpr; insideExpr; afterExpr]) + walkExpression expr t (List.concat [ beforeExpr; insideExpr; afterExpr ]) else ( attach t.leading exprLoc beforeExpr; walkExpression expr t insideExpr; @@ -50810,421 +50904,441 @@ and walkExpression expr t comments = match expr.Parsetree.pexp_desc with | _ when comments = [] -> () | Pexp_constant _ -> - let leading, trailing = partitionLeadingTrailing comments expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - attach t.trailing expr.pexp_loc trailing + let leading, trailing = partitionLeadingTrailing comments expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + attach t.trailing expr.pexp_loc trailing | Pexp_ident longident -> - let leading, trailing = partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc leading; - attach t.trailing longident.loc trailing + let leading, trailing = partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc leading; + attach t.trailing longident.loc trailing | Pexp_let ( _recFlag, valueBindings, - {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, None)} ) -> - walkValueBindings valueBindings t comments + { pexp_desc = Pexp_construct ({ txt = Longident.Lident "()" }, None) } + ) -> + walkValueBindings valueBindings t comments | Pexp_let (_recFlag, valueBindings, expr2) -> - let comments = - visitListButContinueWithRemainingComments - ~getLoc:(fun n -> - if n.Parsetree.pvb_pat.ppat_loc.loc_ghost then n.pvb_expr.pexp_loc - else n.Parsetree.pvb_loc) - ~walkNode:walkValueBinding ~newlineDelimited:true valueBindings t - comments - in - if isBlockExpr expr2 then walkExpression expr2 t comments - else - let leading, inside, trailing = partitionByLoc comments expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; - attach t.trailing expr2.pexp_loc trailing - | Pexp_sequence (expr1, expr2) -> - let leading, inside, trailing = partitionByLoc comments expr1.pexp_loc in - let comments = - if isBlockExpr expr1 then ( - let afterExpr, comments = - partitionByOnSameLine expr1.pexp_loc trailing + let comments = + visitListButContinueWithRemainingComments + ~getLoc:(fun n -> + if n.Parsetree.pvb_pat.ppat_loc.loc_ghost then n.pvb_expr.pexp_loc + else n.Parsetree.pvb_loc) + ~walkNode:walkValueBinding ~newlineDelimited:true valueBindings t + comments + in + if isBlockExpr expr2 then walkExpression expr2 t comments + else + let leading, inside, trailing = + partitionByLoc comments expr2.pexp_loc in - walkExpression expr1 t (List.concat [leading; inside; afterExpr]); - comments) - else ( - attach t.leading expr1.pexp_loc leading; - walkExpression expr1 t inside; - let afterExpr, comments = - partitionByOnSameLine expr1.pexp_loc trailing + attach t.leading expr2.pexp_loc leading; + walkExpression expr2 t inside; + attach t.trailing expr2.pexp_loc trailing + | Pexp_sequence (expr1, expr2) -> + let leading, inside, trailing = partitionByLoc comments expr1.pexp_loc in + let comments = + if isBlockExpr expr1 then ( + let afterExpr, comments = + partitionByOnSameLine expr1.pexp_loc trailing + in + walkExpression expr1 t (List.concat [ leading; inside; afterExpr ]); + comments) + else ( + attach t.leading expr1.pexp_loc leading; + walkExpression expr1 t inside; + let afterExpr, comments = + partitionByOnSameLine expr1.pexp_loc trailing + in + attach t.trailing expr1.pexp_loc afterExpr; + comments) + in + if isBlockExpr expr2 then walkExpression expr2 t comments + else + let leading, inside, trailing = + partitionByLoc comments expr2.pexp_loc in - attach t.trailing expr1.pexp_loc afterExpr; - comments) - in - if isBlockExpr expr2 then walkExpression expr2 t comments - else - let leading, inside, trailing = partitionByLoc comments expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; - attach t.trailing expr2.pexp_loc trailing + attach t.leading expr2.pexp_loc leading; + walkExpression expr2 t inside; + attach t.trailing expr2.pexp_loc trailing | Pexp_open (_override, longident, expr2) -> - let leading, comments = partitionLeadingTrailing comments expr.pexp_loc in - attach t.leading - {expr.pexp_loc with loc_end = longident.loc.loc_end} - leading; - let leading, trailing = partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc leading; - let afterLongident, rest = partitionByOnSameLine longident.loc trailing in - attach t.trailing longident.loc afterLongident; - if isBlockExpr expr2 then walkExpression expr2 t rest - else - let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; - attach t.trailing expr2.pexp_loc trailing + let leading, comments = partitionLeadingTrailing comments expr.pexp_loc in + attach t.leading + { expr.pexp_loc with loc_end = longident.loc.loc_end } + leading; + let leading, trailing = partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc leading; + let afterLongident, rest = partitionByOnSameLine longident.loc trailing in + attach t.trailing longident.loc afterLongident; + if isBlockExpr expr2 then walkExpression expr2 t rest + else + let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walkExpression expr2 t inside; + attach t.trailing expr2.pexp_loc trailing | Pexp_extension - ( {txt = "bs.obj" | "obj"}, - PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_record (rows, _)}, [])}] - ) -> - walkList - (rows |> List.map (fun (li, e) -> ExprRecordRow (li, e))) - t comments + ( { txt = "bs.obj" | "obj" }, + PStr + [ + { + pstr_desc = Pstr_eval ({ pexp_desc = Pexp_record (rows, _) }, []); + }; + ] ) -> + walkList + (rows |> List.map (fun (li, e) -> ExprRecordRow (li, e))) + t comments | Pexp_extension extension -> walkExtension extension t comments | Pexp_letexception (extensionConstructor, expr2) -> - let leading, comments = partitionLeadingTrailing comments expr.pexp_loc in - attach t.leading - {expr.pexp_loc with loc_end = extensionConstructor.pext_loc.loc_end} - leading; - let leading, inside, trailing = - partitionByLoc comments extensionConstructor.pext_loc - in - attach t.leading extensionConstructor.pext_loc leading; - walkExtensionConstructor extensionConstructor t inside; - let afterExtConstr, rest = - partitionByOnSameLine extensionConstructor.pext_loc trailing - in - attach t.trailing extensionConstructor.pext_loc afterExtConstr; - if isBlockExpr expr2 then walkExpression expr2 t rest - else - let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; - attach t.trailing expr2.pexp_loc trailing + let leading, comments = partitionLeadingTrailing comments expr.pexp_loc in + attach t.leading + { expr.pexp_loc with loc_end = extensionConstructor.pext_loc.loc_end } + leading; + let leading, inside, trailing = + partitionByLoc comments extensionConstructor.pext_loc + in + attach t.leading extensionConstructor.pext_loc leading; + walkExtensionConstructor extensionConstructor t inside; + let afterExtConstr, rest = + partitionByOnSameLine extensionConstructor.pext_loc trailing + in + attach t.trailing extensionConstructor.pext_loc afterExtConstr; + if isBlockExpr expr2 then walkExpression expr2 t rest + else + let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walkExpression expr2 t inside; + attach t.trailing expr2.pexp_loc trailing | Pexp_letmodule (stringLoc, modExpr, expr2) -> - let leading, comments = partitionLeadingTrailing comments expr.pexp_loc in - attach t.leading - {expr.pexp_loc with loc_end = modExpr.pmod_loc.loc_end} - leading; - let leading, trailing = partitionLeadingTrailing comments stringLoc.loc in - attach t.leading stringLoc.loc leading; - let afterString, rest = partitionAdjacentTrailing stringLoc.loc trailing in - attach t.trailing stringLoc.loc afterString; - let beforeModExpr, insideModExpr, afterModExpr = - partitionByLoc rest modExpr.pmod_loc - in - attach t.leading modExpr.pmod_loc beforeModExpr; - walkModuleExpr modExpr t insideModExpr; - let afterModExpr, rest = - partitionByOnSameLine modExpr.pmod_loc afterModExpr - in - attach t.trailing modExpr.pmod_loc afterModExpr; - if isBlockExpr expr2 then walkExpression expr2 t rest - else - let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; - attach t.trailing expr2.pexp_loc trailing + let leading, comments = partitionLeadingTrailing comments expr.pexp_loc in + attach t.leading + { expr.pexp_loc with loc_end = modExpr.pmod_loc.loc_end } + leading; + let leading, trailing = partitionLeadingTrailing comments stringLoc.loc in + attach t.leading stringLoc.loc leading; + let afterString, rest = + partitionAdjacentTrailing stringLoc.loc trailing + in + attach t.trailing stringLoc.loc afterString; + let beforeModExpr, insideModExpr, afterModExpr = + partitionByLoc rest modExpr.pmod_loc + in + attach t.leading modExpr.pmod_loc beforeModExpr; + walkModuleExpr modExpr t insideModExpr; + let afterModExpr, rest = + partitionByOnSameLine modExpr.pmod_loc afterModExpr + in + attach t.trailing modExpr.pmod_loc afterModExpr; + if isBlockExpr expr2 then walkExpression expr2 t rest + else + let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walkExpression expr2 t inside; + attach t.trailing expr2.pexp_loc trailing | Pexp_assert expr | Pexp_lazy expr -> - if isBlockExpr expr then walkExpression expr t comments - else + if isBlockExpr expr then walkExpression expr t comments + else + let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + walkExpression expr t inside; + attach t.trailing expr.pexp_loc trailing + | Pexp_coerce (expr, optTypexpr, typexpr) -> let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in attach t.leading expr.pexp_loc leading; walkExpression expr t inside; - attach t.trailing expr.pexp_loc trailing - | Pexp_coerce (expr, optTypexpr, typexpr) -> - let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; - let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc trailing in - attach t.trailing expr.pexp_loc afterExpr; - let rest = - match optTypexpr with - | Some typexpr -> - let leading, inside, trailing = - partitionByLoc comments typexpr.ptyp_loc - in - attach t.leading typexpr.ptyp_loc leading; - walkCoreType typexpr t inside; - let afterTyp, rest = - partitionAdjacentTrailing typexpr.ptyp_loc trailing - in - attach t.trailing typexpr.ptyp_loc afterTyp; - rest - | None -> rest - in - let leading, inside, trailing = partitionByLoc rest typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc leading; - walkCoreType typexpr t inside; - attach t.trailing typexpr.ptyp_loc trailing + let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc trailing in + attach t.trailing expr.pexp_loc afterExpr; + let rest = + match optTypexpr with + | Some typexpr -> + let leading, inside, trailing = + partitionByLoc comments typexpr.ptyp_loc + in + attach t.leading typexpr.ptyp_loc leading; + walkCoreType typexpr t inside; + let afterTyp, rest = + partitionAdjacentTrailing typexpr.ptyp_loc trailing + in + attach t.trailing typexpr.ptyp_loc afterTyp; + rest + | None -> rest + in + let leading, inside, trailing = partitionByLoc rest typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc leading; + walkCoreType typexpr t inside; + attach t.trailing typexpr.ptyp_loc trailing | Pexp_constraint (expr, typexpr) -> - let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; - let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc trailing in - attach t.trailing expr.pexp_loc afterExpr; - let leading, inside, trailing = partitionByLoc rest typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc leading; - walkCoreType typexpr t inside; - attach t.trailing typexpr.ptyp_loc trailing + let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + walkExpression expr t inside; + let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc trailing in + attach t.trailing expr.pexp_loc afterExpr; + let leading, inside, trailing = partitionByLoc rest typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc leading; + walkCoreType typexpr t inside; + attach t.trailing typexpr.ptyp_loc trailing | Pexp_tuple [] | Pexp_array [] - | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> - attach t.inside expr.pexp_loc comments - | Pexp_construct ({txt = Longident.Lident "::"}, _) -> - walkList - (collectListExprs [] expr |> List.map (fun e -> Expression e)) - t comments + | Pexp_construct ({ txt = Longident.Lident "[]" }, _) -> + attach t.inside expr.pexp_loc comments + | Pexp_construct ({ txt = Longident.Lident "::" }, _) -> + walkList + (collectListExprs [] expr |> List.map (fun e -> Expression e)) + t comments | Pexp_construct (longident, args) -> ( - let leading, trailing = partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc leading; - match args with - | Some expr -> - let afterLongident, rest = - partitionAdjacentTrailing longident.loc trailing - in - attach t.trailing longident.loc afterLongident; - walkExpression expr t rest - | None -> attach t.trailing longident.loc trailing) + let leading, trailing = partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc leading; + match args with + | Some expr -> + let afterLongident, rest = + partitionAdjacentTrailing longident.loc trailing + in + attach t.trailing longident.loc afterLongident; + walkExpression expr t rest + | None -> attach t.trailing longident.loc trailing) | Pexp_variant (_label, None) -> () | Pexp_variant (_label, Some expr) -> walkExpression expr t comments | Pexp_array exprs | Pexp_tuple exprs -> - walkList (exprs |> List.map (fun e -> Expression e)) t comments + walkList (exprs |> List.map (fun e -> Expression e)) t comments | Pexp_record (rows, spreadExpr) -> - if rows = [] then attach t.inside expr.pexp_loc comments - else - let comments = - match spreadExpr with - | None -> comments - | Some expr -> - let leading, inside, trailing = - partitionByLoc comments expr.pexp_loc + if rows = [] then attach t.inside expr.pexp_loc comments + else + let comments = + match spreadExpr with + | None -> comments + | Some expr -> + let leading, inside, trailing = + partitionByLoc comments expr.pexp_loc + in + attach t.leading expr.pexp_loc leading; + walkExpression expr t inside; + let afterExpr, rest = + partitionAdjacentTrailing expr.pexp_loc trailing + in + attach t.trailing expr.pexp_loc afterExpr; + rest + in + walkList + (rows |> List.map (fun (li, e) -> ExprRecordRow (li, e))) + t comments + | Pexp_field (expr, longident) -> + let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in + let trailing = + if isBlockExpr expr then ( + let afterExpr, rest = + partitionAdjacentTrailing expr.pexp_loc trailing in + walkExpression expr t (List.concat [ leading; inside; afterExpr ]); + rest) + else ( attach t.leading expr.pexp_loc leading; walkExpression expr t inside; + trailing) + in + let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc trailing in + attach t.trailing expr.pexp_loc afterExpr; + let leading, trailing = partitionLeadingTrailing rest longident.loc in + attach t.leading longident.loc leading; + attach t.trailing longident.loc trailing + | Pexp_setfield (expr1, longident, expr2) -> + let leading, inside, trailing = partitionByLoc comments expr1.pexp_loc in + let rest = + if isBlockExpr expr1 then ( let afterExpr, rest = - partitionAdjacentTrailing expr.pexp_loc trailing + partitionAdjacentTrailing expr1.pexp_loc trailing + in + walkExpression expr1 t (List.concat [ leading; inside; afterExpr ]); + rest) + else + let afterExpr, rest = + partitionAdjacentTrailing expr1.pexp_loc trailing in - attach t.trailing expr.pexp_loc afterExpr; + attach t.leading expr1.pexp_loc leading; + walkExpression expr1 t inside; + attach t.trailing expr1.pexp_loc afterExpr; rest in - walkList - (rows |> List.map (fun (li, e) -> ExprRecordRow (li, e))) - t comments - | Pexp_field (expr, longident) -> - let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in - let trailing = - if isBlockExpr expr then ( - let afterExpr, rest = - partitionAdjacentTrailing expr.pexp_loc trailing - in - walkExpression expr t (List.concat [leading; inside; afterExpr]); - rest) - else ( - attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; - trailing) - in - let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc trailing in - attach t.trailing expr.pexp_loc afterExpr; - let leading, trailing = partitionLeadingTrailing rest longident.loc in - attach t.leading longident.loc leading; - attach t.trailing longident.loc trailing - | Pexp_setfield (expr1, longident, expr2) -> - let leading, inside, trailing = partitionByLoc comments expr1.pexp_loc in - let rest = - if isBlockExpr expr1 then ( - let afterExpr, rest = - partitionAdjacentTrailing expr1.pexp_loc trailing - in - walkExpression expr1 t (List.concat [leading; inside; afterExpr]); - rest) + let beforeLongident, afterLongident = + partitionLeadingTrailing rest longident.loc + in + attach t.leading longident.loc beforeLongident; + let afterLongident, rest = + partitionAdjacentTrailing longident.loc afterLongident + in + attach t.trailing longident.loc afterLongident; + if isBlockExpr expr2 then walkExpression expr2 t rest else - let afterExpr, rest = - partitionAdjacentTrailing expr1.pexp_loc trailing - in - attach t.leading expr1.pexp_loc leading; - walkExpression expr1 t inside; - attach t.trailing expr1.pexp_loc afterExpr; - rest - in - let beforeLongident, afterLongident = - partitionLeadingTrailing rest longident.loc - in - attach t.leading longident.loc beforeLongident; - let afterLongident, rest = - partitionAdjacentTrailing longident.loc afterLongident - in - attach t.trailing longident.loc afterLongident; - if isBlockExpr expr2 then walkExpression expr2 t rest - else - let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; - attach t.trailing expr2.pexp_loc trailing + let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walkExpression expr2 t inside; + attach t.trailing expr2.pexp_loc trailing | Pexp_ifthenelse (ifExpr, thenExpr, elseExpr) -> ( - let leading, rest = partitionLeadingTrailing comments expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - let leading, inside, trailing = partitionByLoc rest ifExpr.pexp_loc in - let comments = - if isBlockExpr ifExpr then ( - let afterExpr, comments = - partitionAdjacentTrailing ifExpr.pexp_loc trailing - in - walkExpression ifExpr t (List.concat [leading; inside; afterExpr]); - comments) - else ( - attach t.leading ifExpr.pexp_loc leading; - walkExpression ifExpr t inside; - let afterExpr, comments = - partitionAdjacentTrailing ifExpr.pexp_loc trailing - in - attach t.trailing ifExpr.pexp_loc afterExpr; - comments) - in - let leading, inside, trailing = partitionByLoc comments thenExpr.pexp_loc in - let comments = - if isBlockExpr thenExpr then ( - let afterExpr, trailing = - partitionAdjacentTrailing thenExpr.pexp_loc trailing - in - walkExpression thenExpr t (List.concat [leading; inside; afterExpr]); - trailing) - else ( - attach t.leading thenExpr.pexp_loc leading; - walkExpression thenExpr t inside; - let afterExpr, comments = - partitionAdjacentTrailing thenExpr.pexp_loc trailing - in - attach t.trailing thenExpr.pexp_loc afterExpr; - comments) - in - match elseExpr with - | None -> () - | Some expr -> - if isBlockExpr expr || isIfThenElseExpr expr then - walkExpression expr t comments - else - let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; - attach t.trailing expr.pexp_loc trailing) + let leading, rest = partitionLeadingTrailing comments expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + let leading, inside, trailing = partitionByLoc rest ifExpr.pexp_loc in + let comments = + if isBlockExpr ifExpr then ( + let afterExpr, comments = + partitionAdjacentTrailing ifExpr.pexp_loc trailing + in + walkExpression ifExpr t (List.concat [ leading; inside; afterExpr ]); + comments) + else ( + attach t.leading ifExpr.pexp_loc leading; + walkExpression ifExpr t inside; + let afterExpr, comments = + partitionAdjacentTrailing ifExpr.pexp_loc trailing + in + attach t.trailing ifExpr.pexp_loc afterExpr; + comments) + in + let leading, inside, trailing = + partitionByLoc comments thenExpr.pexp_loc + in + let comments = + if isBlockExpr thenExpr then ( + let afterExpr, trailing = + partitionAdjacentTrailing thenExpr.pexp_loc trailing + in + walkExpression thenExpr t (List.concat [ leading; inside; afterExpr ]); + trailing) + else ( + attach t.leading thenExpr.pexp_loc leading; + walkExpression thenExpr t inside; + let afterExpr, comments = + partitionAdjacentTrailing thenExpr.pexp_loc trailing + in + attach t.trailing thenExpr.pexp_loc afterExpr; + comments) + in + match elseExpr with + | None -> () + | Some expr -> + if isBlockExpr expr || isIfThenElseExpr expr then + walkExpression expr t comments + else + let leading, inside, trailing = + partitionByLoc comments expr.pexp_loc + in + attach t.leading expr.pexp_loc leading; + walkExpression expr t inside; + attach t.trailing expr.pexp_loc trailing) | Pexp_while (expr1, expr2) -> - let leading, inside, trailing = partitionByLoc comments expr1.pexp_loc in - let rest = - if isBlockExpr expr1 then ( - let afterExpr, rest = - partitionAdjacentTrailing expr1.pexp_loc trailing - in - walkExpression expr1 t (List.concat [leading; inside; afterExpr]); - rest) - else ( - attach t.leading expr1.pexp_loc leading; - walkExpression expr1 t inside; - let afterExpr, rest = - partitionAdjacentTrailing expr1.pexp_loc trailing - in - attach t.trailing expr1.pexp_loc afterExpr; - rest) - in - if isBlockExpr expr2 then walkExpression expr2 t rest - else + let leading, inside, trailing = partitionByLoc comments expr1.pexp_loc in + let rest = + if isBlockExpr expr1 then ( + let afterExpr, rest = + partitionAdjacentTrailing expr1.pexp_loc trailing + in + walkExpression expr1 t (List.concat [ leading; inside; afterExpr ]); + rest) + else ( + attach t.leading expr1.pexp_loc leading; + walkExpression expr1 t inside; + let afterExpr, rest = + partitionAdjacentTrailing expr1.pexp_loc trailing + in + attach t.trailing expr1.pexp_loc afterExpr; + rest) + in + if isBlockExpr expr2 then walkExpression expr2 t rest + else + let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walkExpression expr2 t inside; + attach t.trailing expr2.pexp_loc trailing + | Pexp_for (pat, expr1, expr2, _, expr3) -> + let leading, inside, trailing = partitionByLoc comments pat.ppat_loc in + attach t.leading pat.ppat_loc leading; + walkPattern pat t inside; + let afterPat, rest = partitionAdjacentTrailing pat.ppat_loc trailing in + attach t.trailing pat.ppat_loc afterPat; + let leading, inside, trailing = partitionByLoc rest expr1.pexp_loc in + attach t.leading expr1.pexp_loc leading; + walkExpression expr1 t inside; + let afterExpr, rest = partitionAdjacentTrailing expr1.pexp_loc trailing in + attach t.trailing expr1.pexp_loc afterExpr; let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in attach t.leading expr2.pexp_loc leading; walkExpression expr2 t inside; - attach t.trailing expr2.pexp_loc trailing - | Pexp_for (pat, expr1, expr2, _, expr3) -> - let leading, inside, trailing = partitionByLoc comments pat.ppat_loc in - attach t.leading pat.ppat_loc leading; - walkPattern pat t inside; - let afterPat, rest = partitionAdjacentTrailing pat.ppat_loc trailing in - attach t.trailing pat.ppat_loc afterPat; - let leading, inside, trailing = partitionByLoc rest expr1.pexp_loc in - attach t.leading expr1.pexp_loc leading; - walkExpression expr1 t inside; - let afterExpr, rest = partitionAdjacentTrailing expr1.pexp_loc trailing in - attach t.trailing expr1.pexp_loc afterExpr; - let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; - let afterExpr, rest = partitionAdjacentTrailing expr2.pexp_loc trailing in - attach t.trailing expr2.pexp_loc afterExpr; - if isBlockExpr expr3 then walkExpression expr3 t rest - else - let leading, inside, trailing = partitionByLoc rest expr3.pexp_loc in - attach t.leading expr3.pexp_loc leading; - walkExpression expr3 t inside; - attach t.trailing expr3.pexp_loc trailing + let afterExpr, rest = partitionAdjacentTrailing expr2.pexp_loc trailing in + attach t.trailing expr2.pexp_loc afterExpr; + if isBlockExpr expr3 then walkExpression expr3 t rest + else + let leading, inside, trailing = partitionByLoc rest expr3.pexp_loc in + attach t.leading expr3.pexp_loc leading; + walkExpression expr3 t inside; + attach t.trailing expr3.pexp_loc trailing | Pexp_pack modExpr -> - let before, inside, after = partitionByLoc comments modExpr.pmod_loc in - attach t.leading modExpr.pmod_loc before; - walkModuleExpr modExpr t inside; - attach t.trailing modExpr.pmod_loc after - | Pexp_match (expr1, [case; elseBranch]) + let before, inside, after = partitionByLoc comments modExpr.pmod_loc in + attach t.leading modExpr.pmod_loc before; + walkModuleExpr modExpr t inside; + attach t.trailing modExpr.pmod_loc after + | Pexp_match (expr1, [ case; elseBranch ]) when Res_parsetree_viewer.hasIfLetAttribute expr.pexp_attributes -> - let before, inside, after = partitionByLoc comments case.pc_lhs.ppat_loc in - attach t.leading case.pc_lhs.ppat_loc before; - walkPattern case.pc_lhs t inside; - let afterPat, rest = partitionAdjacentTrailing case.pc_lhs.ppat_loc after in - attach t.trailing case.pc_lhs.ppat_loc afterPat; - let before, inside, after = partitionByLoc rest expr1.pexp_loc in - attach t.leading expr1.pexp_loc before; - walkExpression expr1 t inside; - let afterExpr, rest = partitionAdjacentTrailing expr1.pexp_loc after in - attach t.trailing expr1.pexp_loc afterExpr; - let before, inside, after = partitionByLoc rest case.pc_rhs.pexp_loc in - let after = - if isBlockExpr case.pc_rhs then ( - let afterExpr, rest = - partitionAdjacentTrailing case.pc_rhs.pexp_loc after - in - walkExpression case.pc_rhs t (List.concat [before; inside; afterExpr]); - rest) - else ( - attach t.leading case.pc_rhs.pexp_loc before; - walkExpression case.pc_rhs t inside; - after) - in - let afterExpr, rest = - partitionAdjacentTrailing case.pc_rhs.pexp_loc after - in - attach t.trailing case.pc_rhs.pexp_loc afterExpr; - let before, inside, after = - partitionByLoc rest elseBranch.pc_rhs.pexp_loc - in - let after = - if isBlockExpr elseBranch.pc_rhs then ( - let afterExpr, rest = - partitionAdjacentTrailing elseBranch.pc_rhs.pexp_loc after - in - walkExpression elseBranch.pc_rhs t - (List.concat [before; inside; afterExpr]); - rest) - else ( - attach t.leading elseBranch.pc_rhs.pexp_loc before; - walkExpression elseBranch.pc_rhs t inside; - after) - in - attach t.trailing elseBranch.pc_rhs.pexp_loc after + let before, inside, after = + partitionByLoc comments case.pc_lhs.ppat_loc + in + attach t.leading case.pc_lhs.ppat_loc before; + walkPattern case.pc_lhs t inside; + let afterPat, rest = + partitionAdjacentTrailing case.pc_lhs.ppat_loc after + in + attach t.trailing case.pc_lhs.ppat_loc afterPat; + let before, inside, after = partitionByLoc rest expr1.pexp_loc in + attach t.leading expr1.pexp_loc before; + walkExpression expr1 t inside; + let afterExpr, rest = partitionAdjacentTrailing expr1.pexp_loc after in + attach t.trailing expr1.pexp_loc afterExpr; + let before, inside, after = partitionByLoc rest case.pc_rhs.pexp_loc in + let after = + if isBlockExpr case.pc_rhs then ( + let afterExpr, rest = + partitionAdjacentTrailing case.pc_rhs.pexp_loc after + in + walkExpression case.pc_rhs t + (List.concat [ before; inside; afterExpr ]); + rest) + else ( + attach t.leading case.pc_rhs.pexp_loc before; + walkExpression case.pc_rhs t inside; + after) + in + let afterExpr, rest = + partitionAdjacentTrailing case.pc_rhs.pexp_loc after + in + attach t.trailing case.pc_rhs.pexp_loc afterExpr; + let before, inside, after = + partitionByLoc rest elseBranch.pc_rhs.pexp_loc + in + let after = + if isBlockExpr elseBranch.pc_rhs then ( + let afterExpr, rest = + partitionAdjacentTrailing elseBranch.pc_rhs.pexp_loc after + in + walkExpression elseBranch.pc_rhs t + (List.concat [ before; inside; afterExpr ]); + rest) + else ( + attach t.leading elseBranch.pc_rhs.pexp_loc before; + walkExpression elseBranch.pc_rhs t inside; + after) + in + attach t.trailing elseBranch.pc_rhs.pexp_loc after | Pexp_match (expr, cases) | Pexp_try (expr, cases) -> - let before, inside, after = partitionByLoc comments expr.pexp_loc in - let after = - if isBlockExpr expr then ( - let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc after in - walkExpression expr t (List.concat [before; inside; afterExpr]); - rest) - else ( - attach t.leading expr.pexp_loc before; - walkExpression expr t inside; - after) - in - let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc after in - attach t.trailing expr.pexp_loc afterExpr; - walkList (cases |> List.map (fun case -> Case case)) t rest - (* unary expression: todo use parsetreeviewer *) + let before, inside, after = partitionByLoc comments expr.pexp_loc in + let after = + if isBlockExpr expr then ( + let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc after in + walkExpression expr t (List.concat [ before; inside; afterExpr ]); + rest) + else ( + attach t.leading expr.pexp_loc before; + walkExpression expr t inside; + after) + in + let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc after in + attach t.trailing expr.pexp_loc afterExpr; + walkList (cases |> List.map (fun case -> Case case)) t rest + (* unary expression: todo use parsetreeviewer *) | Pexp_apply ( { pexp_desc = @@ -51234,11 +51348,11 @@ and walkExpression expr t comments = Longident.Lident ("~+" | "~+." | "~-" | "~-." | "not" | "!"); }; }, - [(Nolabel, argExpr)] ) -> - let before, inside, after = partitionByLoc comments argExpr.pexp_loc in - attach t.leading argExpr.pexp_loc before; - walkExpression argExpr t inside; - attach t.trailing argExpr.pexp_loc after + [ (Nolabel, argExpr) ] ) -> + let before, inside, after = partitionByLoc comments argExpr.pexp_loc in + attach t.leading argExpr.pexp_loc before; + walkExpression argExpr t inside; + attach t.trailing argExpr.pexp_loc after (* binary expression *) | Pexp_apply ( { @@ -51252,118 +51366,127 @@ and walkExpression expr t comments = | "*" | "*." | "/" | "/." | "**" | "|." | "<>" ); }; }, - [(Nolabel, operand1); (Nolabel, operand2)] ) -> - let before, inside, after = partitionByLoc comments operand1.pexp_loc in - attach t.leading operand1.pexp_loc before; - walkExpression operand1 t inside; - let afterOperand1, rest = - partitionAdjacentTrailing operand1.pexp_loc after - in - attach t.trailing operand1.pexp_loc afterOperand1; - let before, inside, after = partitionByLoc rest operand2.pexp_loc in - attach t.leading operand2.pexp_loc before; - walkExpression operand2 t inside; - (* (List.concat [inside; after]); *) - attach t.trailing operand2.pexp_loc after + [ (Nolabel, operand1); (Nolabel, operand2) ] ) -> + let before, inside, after = partitionByLoc comments operand1.pexp_loc in + attach t.leading operand1.pexp_loc before; + walkExpression operand1 t inside; + let afterOperand1, rest = + partitionAdjacentTrailing operand1.pexp_loc after + in + attach t.trailing operand1.pexp_loc afterOperand1; + let before, inside, after = partitionByLoc rest operand2.pexp_loc in + attach t.leading operand2.pexp_loc before; + walkExpression operand2 t inside; + (* (List.concat [inside; after]); *) + attach t.trailing operand2.pexp_loc after | Pexp_apply (callExpr, arguments) -> - let before, inside, after = partitionByLoc comments callExpr.pexp_loc in - let after = - if isBlockExpr callExpr then ( + let before, inside, after = partitionByLoc comments callExpr.pexp_loc in + let after = + if isBlockExpr callExpr then ( + let afterExpr, rest = + partitionAdjacentTrailing callExpr.pexp_loc after + in + walkExpression callExpr t (List.concat [ before; inside; afterExpr ]); + rest) + else ( + attach t.leading callExpr.pexp_loc before; + walkExpression callExpr t inside; + after) + in + if ParsetreeViewer.isJsxExpression expr then ( + let props = + arguments + |> List.filter (fun (label, _) -> + match label with + | Asttypes.Labelled "children" -> false + | Asttypes.Nolabel -> false + | _ -> true) + in + let maybeChildren = + arguments + |> List.find_opt (fun (label, _) -> + label = Asttypes.Labelled "children") + in + match maybeChildren with + (* There is no need to deal with this situation as the children cannot be NONE *) + | None -> () + | Some (_, children) -> + let leading, inside, _ = partitionByLoc after children.pexp_loc in + if props = [] then + (* All comments inside a tag are trailing comments of the tag if there are no props + + *) + let afterExpr, _ = + partitionAdjacentTrailing callExpr.pexp_loc after + in + attach t.trailing callExpr.pexp_loc afterExpr + else + walkList + (props |> List.map (fun (_, e) -> ExprArgument e)) + t leading; + walkExpression children t inside) + else let afterExpr, rest = partitionAdjacentTrailing callExpr.pexp_loc after in - walkExpression callExpr t (List.concat [before; inside; afterExpr]); - rest) - else ( - attach t.leading callExpr.pexp_loc before; - walkExpression callExpr t inside; - after) - in - if ParsetreeViewer.isJsxExpression expr then ( - let props = - arguments - |> List.filter (fun (label, _) -> - match label with - | Asttypes.Labelled "children" -> false - | Asttypes.Nolabel -> false - | _ -> true) - in - let maybeChildren = - arguments - |> List.find_opt (fun (label, _) -> - label = Asttypes.Labelled "children") + attach t.trailing callExpr.pexp_loc afterExpr; + walkList (arguments |> List.map (fun (_, e) -> ExprArgument e)) t rest + | Pexp_fun (_, _, _, _) | Pexp_newtype _ -> ( + let _, parameters, returnExpr = funExpr expr in + let comments = + visitListButContinueWithRemainingComments ~newlineDelimited:false + ~walkNode:walkExprPararameter + ~getLoc:(fun (_attrs, _argLbl, exprOpt, pattern) -> + let open Parsetree in + let startPos = + match pattern.ppat_attributes with + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _attrs -> + loc.loc_start + | _ -> pattern.ppat_loc.loc_start + in + match exprOpt with + | None -> { pattern.ppat_loc with loc_start = startPos } + | Some expr -> + { + pattern.ppat_loc with + loc_start = startPos; + loc_end = expr.pexp_loc.loc_end; + }) + parameters t comments in - match maybeChildren with - (* There is no need to deal with this situation as the children cannot be NONE *) - | None -> () - | Some (_, children) -> - let leading, inside, _ = partitionByLoc after children.pexp_loc in - if props = [] then - (* All comments inside a tag are trailing comments of the tag if there are no props - - *) - let afterExpr, _ = - partitionAdjacentTrailing callExpr.pexp_loc after + match returnExpr.pexp_desc with + | Pexp_constraint (expr, typ) + when expr.pexp_loc.loc_start.pos_cnum >= typ.ptyp_loc.loc_end.pos_cnum + -> + let leading, inside, trailing = + partitionByLoc comments typ.ptyp_loc in - attach t.trailing callExpr.pexp_loc afterExpr - else - walkList (props |> List.map (fun (_, e) -> ExprArgument e)) t leading; - walkExpression children t inside) - else - let afterExpr, rest = partitionAdjacentTrailing callExpr.pexp_loc after in - attach t.trailing callExpr.pexp_loc afterExpr; - walkList (arguments |> List.map (fun (_, e) -> ExprArgument e)) t rest - | Pexp_fun (_, _, _, _) | Pexp_newtype _ -> ( - let _, parameters, returnExpr = funExpr expr in - let comments = - visitListButContinueWithRemainingComments ~newlineDelimited:false - ~walkNode:walkExprPararameter - ~getLoc:(fun (_attrs, _argLbl, exprOpt, pattern) -> - let open Parsetree in - let startPos = - match pattern.ppat_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _attrs -> - loc.loc_start - | _ -> pattern.ppat_loc.loc_start + attach t.leading typ.ptyp_loc leading; + walkCoreType typ t inside; + let afterTyp, comments = + partitionAdjacentTrailing typ.ptyp_loc trailing in - match exprOpt with - | None -> {pattern.ppat_loc with loc_start = startPos} - | Some expr -> - { - pattern.ppat_loc with - loc_start = startPos; - loc_end = expr.pexp_loc.loc_end; - }) - parameters t comments - in - match returnExpr.pexp_desc with - | Pexp_constraint (expr, typ) - when expr.pexp_loc.loc_start.pos_cnum >= typ.ptyp_loc.loc_end.pos_cnum -> - let leading, inside, trailing = partitionByLoc comments typ.ptyp_loc in - attach t.leading typ.ptyp_loc leading; - walkCoreType typ t inside; - let afterTyp, comments = - partitionAdjacentTrailing typ.ptyp_loc trailing - in - attach t.trailing typ.ptyp_loc afterTyp; - if isBlockExpr expr then walkExpression expr t comments - else - let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; - attach t.trailing expr.pexp_loc trailing - | _ -> - if isBlockExpr returnExpr then walkExpression returnExpr t comments - else - let leading, inside, trailing = - partitionByLoc comments returnExpr.pexp_loc - in - attach t.leading returnExpr.pexp_loc leading; - walkExpression returnExpr t inside; - attach t.trailing returnExpr.pexp_loc trailing) + attach t.trailing typ.ptyp_loc afterTyp; + if isBlockExpr expr then walkExpression expr t comments + else + let leading, inside, trailing = + partitionByLoc comments expr.pexp_loc + in + attach t.leading expr.pexp_loc leading; + walkExpression expr t inside; + attach t.trailing expr.pexp_loc trailing + | _ -> + if isBlockExpr returnExpr then walkExpression returnExpr t comments + else + let leading, inside, trailing = + partitionByLoc comments returnExpr.pexp_loc + in + attach t.leading returnExpr.pexp_loc leading; + walkExpression returnExpr t inside; + attach t.trailing returnExpr.pexp_loc trailing) | _ -> () and walkExprPararameter (_attrs, _argLbl, exprOpt, pattern) t comments = @@ -51372,52 +51495,54 @@ and walkExprPararameter (_attrs, _argLbl, exprOpt, pattern) t comments = walkPattern pattern t inside; match exprOpt with | Some expr -> - let _afterPat, rest = partitionAdjacentTrailing pattern.ppat_loc trailing in - attach t.trailing pattern.ppat_loc trailing; - if isBlockExpr expr then walkExpression expr t rest - else - let leading, inside, trailing = partitionByLoc rest expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; - attach t.trailing expr.pexp_loc trailing + let _afterPat, rest = + partitionAdjacentTrailing pattern.ppat_loc trailing + in + attach t.trailing pattern.ppat_loc trailing; + if isBlockExpr expr then walkExpression expr t rest + else + let leading, inside, trailing = partitionByLoc rest expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + walkExpression expr t inside; + attach t.trailing expr.pexp_loc trailing | None -> attach t.trailing pattern.ppat_loc trailing and walkExprArgument expr t comments = match expr.Parsetree.pexp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _attrs -> - let leading, trailing = partitionLeadingTrailing comments loc in - attach t.leading loc leading; - let afterLabel, rest = partitionAdjacentTrailing loc trailing in - attach t.trailing loc afterLabel; - let before, inside, after = partitionByLoc rest expr.pexp_loc in - attach t.leading expr.pexp_loc before; - walkExpression expr t inside; - attach t.trailing expr.pexp_loc after + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _attrs -> + let leading, trailing = partitionLeadingTrailing comments loc in + attach t.leading loc leading; + let afterLabel, rest = partitionAdjacentTrailing loc trailing in + attach t.trailing loc afterLabel; + let before, inside, after = partitionByLoc rest expr.pexp_loc in + attach t.leading expr.pexp_loc before; + walkExpression expr t inside; + attach t.trailing expr.pexp_loc after | _ -> - let before, inside, after = partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc before; - walkExpression expr t inside; - attach t.trailing expr.pexp_loc after + let before, inside, after = partitionByLoc comments expr.pexp_loc in + attach t.leading expr.pexp_loc before; + walkExpression expr t inside; + attach t.trailing expr.pexp_loc after and walkCase (case : Parsetree.case) t comments = let before, inside, after = partitionByLoc comments case.pc_lhs.ppat_loc in (* cases don't have a location on their own, leading comments should go * after the bar on the pattern *) - walkPattern case.pc_lhs t (List.concat [before; inside]); + walkPattern case.pc_lhs t (List.concat [ before; inside ]); let afterPat, rest = partitionAdjacentTrailing case.pc_lhs.ppat_loc after in attach t.trailing case.pc_lhs.ppat_loc afterPat; let comments = match case.pc_guard with | Some expr -> - let before, inside, after = partitionByLoc rest expr.pexp_loc in - let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc after in - if isBlockExpr expr then - walkExpression expr t (List.concat [before; inside; afterExpr]) - else ( - attach t.leading expr.pexp_loc before; - walkExpression expr t inside; - attach t.trailing expr.pexp_loc afterExpr); - rest + let before, inside, after = partitionByLoc rest expr.pexp_loc in + let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc after in + if isBlockExpr expr then + walkExpression expr t (List.concat [ before; inside; afterExpr ]) + else ( + attach t.leading expr.pexp_loc before; + walkExpression expr t inside; + attach t.trailing expr.pexp_loc afterExpr); + rest | None -> rest in if isBlockExpr case.pc_rhs then walkExpression case.pc_rhs t comments @@ -51455,89 +51580,91 @@ and walkExtensionConstructor extConstr t comments = and walkExtensionConstructorKind kind t comments = match kind with | Pext_rebind longident -> - let leading, trailing = partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc leading; - attach t.trailing longident.loc trailing + let leading, trailing = partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc leading; + attach t.trailing longident.loc trailing | Pext_decl (constructorArguments, maybeTypExpr) -> ( - let rest = walkConstructorArguments constructorArguments t comments in - match maybeTypExpr with - | None -> () - | Some typexpr -> - let before, inside, after = partitionByLoc rest typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc before; - walkCoreType typexpr t inside; - attach t.trailing typexpr.ptyp_loc after) + let rest = walkConstructorArguments constructorArguments t comments in + match maybeTypExpr with + | None -> () + | Some typexpr -> + let before, inside, after = partitionByLoc rest typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc before; + walkCoreType typexpr t inside; + attach t.trailing typexpr.ptyp_loc after) and walkModuleExpr modExpr t comments = match modExpr.pmod_desc with | Pmod_ident longident -> - let before, after = partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc before; - attach t.trailing longident.loc after + let before, after = partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc before; + attach t.trailing longident.loc after | Pmod_structure [] -> attach t.inside modExpr.pmod_loc comments | Pmod_structure structure -> walkStructure structure t comments | Pmod_extension extension -> walkExtension extension t comments | Pmod_unpack expr -> - let before, inside, after = partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc before; - walkExpression expr t inside; - attach t.trailing expr.pexp_loc after + let before, inside, after = partitionByLoc comments expr.pexp_loc in + attach t.leading expr.pexp_loc before; + walkExpression expr t inside; + attach t.trailing expr.pexp_loc after | Pmod_constraint (modexpr, modtype) -> - if modtype.pmty_loc.loc_start >= modexpr.pmod_loc.loc_end then ( - let before, inside, after = partitionByLoc comments modexpr.pmod_loc in - attach t.leading modexpr.pmod_loc before; - walkModuleExpr modexpr t inside; - let after, rest = partitionAdjacentTrailing modexpr.pmod_loc after in - attach t.trailing modexpr.pmod_loc after; - let before, inside, after = partitionByLoc rest modtype.pmty_loc in - attach t.leading modtype.pmty_loc before; - walkModType modtype t inside; - attach t.trailing modtype.pmty_loc after) - else - let before, inside, after = partitionByLoc comments modtype.pmty_loc in - attach t.leading modtype.pmty_loc before; - walkModType modtype t inside; - let after, rest = partitionAdjacentTrailing modtype.pmty_loc after in - attach t.trailing modtype.pmty_loc after; - let before, inside, after = partitionByLoc rest modexpr.pmod_loc in - attach t.leading modexpr.pmod_loc before; - walkModuleExpr modexpr t inside; - attach t.trailing modexpr.pmod_loc after + if modtype.pmty_loc.loc_start >= modexpr.pmod_loc.loc_end then ( + let before, inside, after = partitionByLoc comments modexpr.pmod_loc in + attach t.leading modexpr.pmod_loc before; + walkModuleExpr modexpr t inside; + let after, rest = partitionAdjacentTrailing modexpr.pmod_loc after in + attach t.trailing modexpr.pmod_loc after; + let before, inside, after = partitionByLoc rest modtype.pmty_loc in + attach t.leading modtype.pmty_loc before; + walkModType modtype t inside; + attach t.trailing modtype.pmty_loc after) + else + let before, inside, after = partitionByLoc comments modtype.pmty_loc in + attach t.leading modtype.pmty_loc before; + walkModType modtype t inside; + let after, rest = partitionAdjacentTrailing modtype.pmty_loc after in + attach t.trailing modtype.pmty_loc after; + let before, inside, after = partitionByLoc rest modexpr.pmod_loc in + attach t.leading modexpr.pmod_loc before; + walkModuleExpr modexpr t inside; + attach t.trailing modexpr.pmod_loc after | Pmod_apply (_callModExpr, _argModExpr) -> - let modExprs = modExprApply modExpr in - walkList (modExprs |> List.map (fun me -> ModuleExpr me)) t comments + let modExprs = modExprApply modExpr in + walkList (modExprs |> List.map (fun me -> ModuleExpr me)) t comments | Pmod_functor _ -> ( - let parameters, returnModExpr = modExprFunctor modExpr in - let comments = - visitListButContinueWithRemainingComments - ~getLoc:(fun (_, lbl, modTypeOption) -> - match modTypeOption with - | None -> lbl.Asttypes.loc - | Some modType -> - {lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end}) - ~walkNode:walkModExprParameter ~newlineDelimited:false parameters t - comments - in - match returnModExpr.pmod_desc with - | Pmod_constraint (modExpr, modType) - when modType.pmty_loc.loc_end.pos_cnum - <= modExpr.pmod_loc.loc_start.pos_cnum -> - let before, inside, after = partitionByLoc comments modType.pmty_loc in - attach t.leading modType.pmty_loc before; - walkModType modType t inside; - let after, rest = partitionAdjacentTrailing modType.pmty_loc after in - attach t.trailing modType.pmty_loc after; - let before, inside, after = partitionByLoc rest modExpr.pmod_loc in - attach t.leading modExpr.pmod_loc before; - walkModuleExpr modExpr t inside; - attach t.trailing modExpr.pmod_loc after - | _ -> - let before, inside, after = - partitionByLoc comments returnModExpr.pmod_loc + let parameters, returnModExpr = modExprFunctor modExpr in + let comments = + visitListButContinueWithRemainingComments + ~getLoc:(fun (_, lbl, modTypeOption) -> + match modTypeOption with + | None -> lbl.Asttypes.loc + | Some modType -> + { lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end }) + ~walkNode:walkModExprParameter ~newlineDelimited:false parameters t + comments in - attach t.leading returnModExpr.pmod_loc before; - walkModuleExpr returnModExpr t inside; - attach t.trailing returnModExpr.pmod_loc after) + match returnModExpr.pmod_desc with + | Pmod_constraint (modExpr, modType) + when modType.pmty_loc.loc_end.pos_cnum + <= modExpr.pmod_loc.loc_start.pos_cnum -> + let before, inside, after = + partitionByLoc comments modType.pmty_loc + in + attach t.leading modType.pmty_loc before; + walkModType modType t inside; + let after, rest = partitionAdjacentTrailing modType.pmty_loc after in + attach t.trailing modType.pmty_loc after; + let before, inside, after = partitionByLoc rest modExpr.pmod_loc in + attach t.leading modExpr.pmod_loc before; + walkModuleExpr modExpr t inside; + attach t.trailing modExpr.pmod_loc after + | _ -> + let before, inside, after = + partitionByLoc comments returnModExpr.pmod_loc + in + attach t.leading returnModExpr.pmod_loc before; + walkModuleExpr returnModExpr t inside; + attach t.trailing returnModExpr.pmod_loc after) and walkModExprParameter parameter t comments = let _attrs, lbl, modTypeOption = parameter in @@ -51546,52 +51673,53 @@ and walkModExprParameter parameter t comments = match modTypeOption with | None -> attach t.trailing lbl.loc trailing | Some modType -> - let afterLbl, rest = partitionAdjacentTrailing lbl.loc trailing in - attach t.trailing lbl.loc afterLbl; - let before, inside, after = partitionByLoc rest modType.pmty_loc in - attach t.leading modType.pmty_loc before; - walkModType modType t inside; - attach t.trailing modType.pmty_loc after + let afterLbl, rest = partitionAdjacentTrailing lbl.loc trailing in + attach t.trailing lbl.loc afterLbl; + let before, inside, after = partitionByLoc rest modType.pmty_loc in + attach t.leading modType.pmty_loc before; + walkModType modType t inside; + attach t.trailing modType.pmty_loc after and walkModType modType t comments = match modType.pmty_desc with | Pmty_ident longident | Pmty_alias longident -> - let leading, trailing = partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc leading; - attach t.trailing longident.loc trailing + let leading, trailing = partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc leading; + attach t.trailing longident.loc trailing | Pmty_signature [] -> attach t.inside modType.pmty_loc comments | Pmty_signature signature -> walkSignature signature t comments | Pmty_extension extension -> walkExtension extension t comments | Pmty_typeof modExpr -> - let before, inside, after = partitionByLoc comments modExpr.pmod_loc in - attach t.leading modExpr.pmod_loc before; - walkModuleExpr modExpr t inside; - attach t.trailing modExpr.pmod_loc after + let before, inside, after = partitionByLoc comments modExpr.pmod_loc in + attach t.leading modExpr.pmod_loc before; + walkModuleExpr modExpr t inside; + attach t.trailing modExpr.pmod_loc after | Pmty_with (modType, _withConstraints) -> - let before, inside, after = partitionByLoc comments modType.pmty_loc in - attach t.leading modType.pmty_loc before; - walkModType modType t inside; - attach t.trailing modType.pmty_loc after - (* TODO: withConstraints*) + let before, inside, after = partitionByLoc comments modType.pmty_loc in + attach t.leading modType.pmty_loc before; + walkModType modType t inside; + attach t.trailing modType.pmty_loc after + (* TODO: withConstraints*) | Pmty_functor _ -> - let parameters, returnModType = functorType modType in - let comments = - visitListButContinueWithRemainingComments - ~getLoc:(fun (_, lbl, modTypeOption) -> - match modTypeOption with - | None -> lbl.Asttypes.loc - | Some modType -> - if lbl.txt = "_" then modType.Parsetree.pmty_loc - else {lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end}) - ~walkNode:walkModTypeParameter ~newlineDelimited:false parameters t - comments - in - let before, inside, after = - partitionByLoc comments returnModType.pmty_loc - in - attach t.leading returnModType.pmty_loc before; - walkModType returnModType t inside; - attach t.trailing returnModType.pmty_loc after + let parameters, returnModType = functorType modType in + let comments = + visitListButContinueWithRemainingComments + ~getLoc:(fun (_, lbl, modTypeOption) -> + match modTypeOption with + | None -> lbl.Asttypes.loc + | Some modType -> + if lbl.txt = "_" then modType.Parsetree.pmty_loc + else + { lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end }) + ~walkNode:walkModTypeParameter ~newlineDelimited:false parameters t + comments + in + let before, inside, after = + partitionByLoc comments returnModType.pmty_loc + in + attach t.leading returnModType.pmty_loc before; + walkModType returnModType t inside; + attach t.trailing returnModType.pmty_loc after and walkModTypeParameter (_, lbl, modTypeOption) t comments = let leading, trailing = partitionLeadingTrailing comments lbl.loc in @@ -51599,92 +51727,94 @@ and walkModTypeParameter (_, lbl, modTypeOption) t comments = match modTypeOption with | None -> attach t.trailing lbl.loc trailing | Some modType -> - let afterLbl, rest = partitionAdjacentTrailing lbl.loc trailing in - attach t.trailing lbl.loc afterLbl; - let before, inside, after = partitionByLoc rest modType.pmty_loc in - attach t.leading modType.pmty_loc before; - walkModType modType t inside; - attach t.trailing modType.pmty_loc after + let afterLbl, rest = partitionAdjacentTrailing lbl.loc trailing in + attach t.trailing lbl.loc afterLbl; + let before, inside, after = partitionByLoc rest modType.pmty_loc in + attach t.leading modType.pmty_loc before; + walkModType modType t inside; + attach t.trailing modType.pmty_loc after and walkPattern pat t comments = let open Location in match pat.Parsetree.ppat_desc with | _ when comments = [] -> () | Ppat_alias (pat, alias) -> - let leading, inside, trailing = partitionByLoc comments pat.ppat_loc in - attach t.leading pat.ppat_loc leading; - walkPattern pat t inside; - let afterPat, rest = partitionAdjacentTrailing pat.ppat_loc trailing in - attach t.leading pat.ppat_loc leading; - attach t.trailing pat.ppat_loc afterPat; - let beforeAlias, afterAlias = partitionLeadingTrailing rest alias.loc in - attach t.leading alias.loc beforeAlias; - attach t.trailing alias.loc afterAlias + let leading, inside, trailing = partitionByLoc comments pat.ppat_loc in + attach t.leading pat.ppat_loc leading; + walkPattern pat t inside; + let afterPat, rest = partitionAdjacentTrailing pat.ppat_loc trailing in + attach t.leading pat.ppat_loc leading; + attach t.trailing pat.ppat_loc afterPat; + let beforeAlias, afterAlias = partitionLeadingTrailing rest alias.loc in + attach t.leading alias.loc beforeAlias; + attach t.trailing alias.loc afterAlias | Ppat_tuple [] | Ppat_array [] - | Ppat_construct ({txt = Longident.Lident "()"}, _) - | Ppat_construct ({txt = Longident.Lident "[]"}, _) -> - attach t.inside pat.ppat_loc comments + | Ppat_construct ({ txt = Longident.Lident "()" }, _) + | Ppat_construct ({ txt = Longident.Lident "[]" }, _) -> + attach t.inside pat.ppat_loc comments | Ppat_array patterns -> - walkList (patterns |> List.map (fun p -> Pattern p)) t comments + walkList (patterns |> List.map (fun p -> Pattern p)) t comments | Ppat_tuple patterns -> - walkList (patterns |> List.map (fun p -> Pattern p)) t comments - | Ppat_construct ({txt = Longident.Lident "::"}, _) -> - walkList - (collectListPatterns [] pat |> List.map (fun p -> Pattern p)) - t comments + walkList (patterns |> List.map (fun p -> Pattern p)) t comments + | Ppat_construct ({ txt = Longident.Lident "::" }, _) -> + walkList + (collectListPatterns [] pat |> List.map (fun p -> Pattern p)) + t comments | Ppat_construct (constr, None) -> - let beforeConstr, afterConstr = - partitionLeadingTrailing comments constr.loc - in - attach t.leading constr.loc beforeConstr; - attach t.trailing constr.loc afterConstr + let beforeConstr, afterConstr = + partitionLeadingTrailing comments constr.loc + in + attach t.leading constr.loc beforeConstr; + attach t.trailing constr.loc afterConstr | Ppat_construct (constr, Some pat) -> - let leading, trailing = partitionLeadingTrailing comments constr.loc in - attach t.leading constr.loc leading; - let afterConstructor, rest = - partitionAdjacentTrailing constr.loc trailing - in - attach t.trailing constr.loc afterConstructor; - let leading, inside, trailing = partitionByLoc rest pat.ppat_loc in - attach t.leading pat.ppat_loc leading; - walkPattern pat t inside; - attach t.trailing pat.ppat_loc trailing + let leading, trailing = partitionLeadingTrailing comments constr.loc in + attach t.leading constr.loc leading; + let afterConstructor, rest = + partitionAdjacentTrailing constr.loc trailing + in + attach t.trailing constr.loc afterConstructor; + let leading, inside, trailing = partitionByLoc rest pat.ppat_loc in + attach t.leading pat.ppat_loc leading; + walkPattern pat t inside; + attach t.trailing pat.ppat_loc trailing | Ppat_variant (_label, None) -> () | Ppat_variant (_label, Some pat) -> walkPattern pat t comments | Ppat_type _ -> () | Ppat_record (recordRows, _) -> - walkList - (recordRows |> List.map (fun (li, p) -> PatternRecordRow (li, p))) - t comments + walkList + (recordRows |> List.map (fun (li, p) -> PatternRecordRow (li, p))) + t comments | Ppat_or _ -> - walkList - (Res_parsetree_viewer.collectOrPatternChain pat - |> List.map (fun pat -> Pattern pat)) - t comments + walkList + (Res_parsetree_viewer.collectOrPatternChain pat + |> List.map (fun pat -> Pattern pat)) + t comments | Ppat_constraint (pattern, typ) -> - let beforePattern, insidePattern, afterPattern = - partitionByLoc comments pattern.ppat_loc - in - attach t.leading pattern.ppat_loc beforePattern; - walkPattern pattern t insidePattern; - let afterPattern, rest = - partitionAdjacentTrailing pattern.ppat_loc afterPattern - in - attach t.trailing pattern.ppat_loc afterPattern; - let beforeTyp, insideTyp, afterTyp = partitionByLoc rest typ.ptyp_loc in - attach t.leading typ.ptyp_loc beforeTyp; - walkCoreType typ t insideTyp; - attach t.trailing typ.ptyp_loc afterTyp + let beforePattern, insidePattern, afterPattern = + partitionByLoc comments pattern.ppat_loc + in + attach t.leading pattern.ppat_loc beforePattern; + walkPattern pattern t insidePattern; + let afterPattern, rest = + partitionAdjacentTrailing pattern.ppat_loc afterPattern + in + attach t.trailing pattern.ppat_loc afterPattern; + let beforeTyp, insideTyp, afterTyp = partitionByLoc rest typ.ptyp_loc in + attach t.leading typ.ptyp_loc beforeTyp; + walkCoreType typ t insideTyp; + attach t.trailing typ.ptyp_loc afterTyp | Ppat_lazy pattern | Ppat_exception pattern -> - let leading, inside, trailing = partitionByLoc comments pattern.ppat_loc in - attach t.leading pattern.ppat_loc leading; - walkPattern pattern t inside; - attach t.trailing pattern.ppat_loc trailing + let leading, inside, trailing = + partitionByLoc comments pattern.ppat_loc + in + attach t.leading pattern.ppat_loc leading; + walkPattern pattern t inside; + attach t.trailing pattern.ppat_loc trailing | Ppat_unpack stringLoc -> - let leading, trailing = partitionLeadingTrailing comments stringLoc.loc in - attach t.leading stringLoc.loc leading; - attach t.trailing stringLoc.loc trailing + let leading, trailing = partitionLeadingTrailing comments stringLoc.loc in + attach t.leading stringLoc.loc leading; + attach t.trailing stringLoc.loc trailing | Ppat_extension extension -> walkExtension extension t comments | _ -> () @@ -51692,83 +51822,87 @@ and walkPattern pat t comments = and walkPatternRecordRow row t comments = match row with (* punned {x}*) - | ( {Location.txt = Longident.Lident ident; loc = longidentLoc}, - {Parsetree.ppat_desc = Ppat_var {txt; _}} ) + | ( { Location.txt = Longident.Lident ident; loc = longidentLoc }, + { Parsetree.ppat_desc = Ppat_var { txt; _ } } ) when ident = txt -> - let beforeLbl, afterLbl = partitionLeadingTrailing comments longidentLoc in - attach t.leading longidentLoc beforeLbl; - attach t.trailing longidentLoc afterLbl + let beforeLbl, afterLbl = + partitionLeadingTrailing comments longidentLoc + in + attach t.leading longidentLoc beforeLbl; + attach t.trailing longidentLoc afterLbl | longident, pattern -> - let beforeLbl, afterLbl = partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc beforeLbl; - let afterLbl, rest = partitionAdjacentTrailing longident.loc afterLbl in - attach t.trailing longident.loc afterLbl; - let leading, inside, trailing = partitionByLoc rest pattern.ppat_loc in - attach t.leading pattern.ppat_loc leading; - walkPattern pattern t inside; - attach t.trailing pattern.ppat_loc trailing + let beforeLbl, afterLbl = + partitionLeadingTrailing comments longident.loc + in + attach t.leading longident.loc beforeLbl; + let afterLbl, rest = partitionAdjacentTrailing longident.loc afterLbl in + attach t.trailing longident.loc afterLbl; + let leading, inside, trailing = partitionByLoc rest pattern.ppat_loc in + attach t.leading pattern.ppat_loc leading; + walkPattern pattern t inside; + attach t.trailing pattern.ppat_loc trailing and walkRowField (rowField : Parsetree.row_field) t comments = match rowField with - | Parsetree.Rtag ({loc}, _, _, _) -> - let before, after = partitionLeadingTrailing comments loc in - attach t.leading loc before; - attach t.trailing loc after + | Parsetree.Rtag ({ loc }, _, _, _) -> + let before, after = partitionLeadingTrailing comments loc in + attach t.leading loc before; + attach t.trailing loc after | Rinherit _ -> () and walkCoreType typ t comments = match typ.Parsetree.ptyp_desc with | _ when comments = [] -> () | Ptyp_tuple typexprs -> - walkList (typexprs |> List.map (fun ct -> CoreType ct)) t comments + walkList (typexprs |> List.map (fun ct -> CoreType ct)) t comments | Ptyp_extension extension -> walkExtension extension t comments | Ptyp_package packageType -> walkPackageType packageType t comments | Ptyp_alias (typexpr, _alias) -> - let beforeTyp, insideTyp, afterTyp = - partitionByLoc comments typexpr.ptyp_loc - in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - attach t.trailing typexpr.ptyp_loc afterTyp + let beforeTyp, insideTyp, afterTyp = + partitionByLoc comments typexpr.ptyp_loc + in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkCoreType typexpr t insideTyp; + attach t.trailing typexpr.ptyp_loc afterTyp | Ptyp_poly (strings, typexpr) -> - let comments = - visitListButContinueWithRemainingComments - ~getLoc:(fun n -> n.Asttypes.loc) - ~walkNode:(fun longident t comments -> - let beforeLongident, afterLongident = - partitionLeadingTrailing comments longident.loc - in - attach t.leading longident.loc beforeLongident; - attach t.trailing longident.loc afterLongident) - ~newlineDelimited:false strings t comments - in - let beforeTyp, insideTyp, afterTyp = - partitionByLoc comments typexpr.ptyp_loc - in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - attach t.trailing typexpr.ptyp_loc afterTyp + let comments = + visitListButContinueWithRemainingComments + ~getLoc:(fun n -> n.Asttypes.loc) + ~walkNode:(fun longident t comments -> + let beforeLongident, afterLongident = + partitionLeadingTrailing comments longident.loc + in + attach t.leading longident.loc beforeLongident; + attach t.trailing longident.loc afterLongident) + ~newlineDelimited:false strings t comments + in + let beforeTyp, insideTyp, afterTyp = + partitionByLoc comments typexpr.ptyp_loc + in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkCoreType typexpr t insideTyp; + attach t.trailing typexpr.ptyp_loc afterTyp | Ptyp_variant (rowFields, _, _) -> - walkList (rowFields |> List.map (fun rf -> RowField rf)) t comments + walkList (rowFields |> List.map (fun rf -> RowField rf)) t comments | Ptyp_constr (longident, typexprs) -> - let beforeLongident, _afterLongident = - partitionLeadingTrailing comments longident.loc - in - let afterLongident, rest = - partitionAdjacentTrailing longident.loc comments - in - attach t.leading longident.loc beforeLongident; - attach t.trailing longident.loc afterLongident; - walkList (typexprs |> List.map (fun ct -> CoreType ct)) t rest + let beforeLongident, _afterLongident = + partitionLeadingTrailing comments longident.loc + in + let afterLongident, rest = + partitionAdjacentTrailing longident.loc comments + in + attach t.leading longident.loc beforeLongident; + attach t.trailing longident.loc afterLongident; + walkList (typexprs |> List.map (fun ct -> CoreType ct)) t rest | Ptyp_arrow _ -> - let _, parameters, typexpr = arrowType typ in - let comments = walkTypeParameters parameters t comments in - let beforeTyp, insideTyp, afterTyp = - partitionByLoc comments typexpr.ptyp_loc - in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - attach t.trailing typexpr.ptyp_loc afterTyp + let _, parameters, typexpr = arrowType typ in + let comments = walkTypeParameters parameters t comments in + let beforeTyp, insideTyp, afterTyp = + partitionByLoc comments typexpr.ptyp_loc + in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkCoreType typexpr t insideTyp; + attach t.trailing typexpr.ptyp_loc afterTyp | Ptyp_object (fields, _) -> walkTypObjectFields fields t comments | _ -> () @@ -51778,22 +51912,24 @@ and walkTypObjectFields fields t comments = and walkObjectField field t comments = match field with | Otag (lbl, _, typexpr) -> - let beforeLbl, afterLbl = partitionLeadingTrailing comments lbl.loc in - attach t.leading lbl.loc beforeLbl; - let afterLbl, rest = partitionAdjacentTrailing lbl.loc afterLbl in - attach t.trailing lbl.loc afterLbl; - let beforeTyp, insideTyp, afterTyp = partitionByLoc rest typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - attach t.trailing typexpr.ptyp_loc afterTyp + let beforeLbl, afterLbl = partitionLeadingTrailing comments lbl.loc in + attach t.leading lbl.loc beforeLbl; + let afterLbl, rest = partitionAdjacentTrailing lbl.loc afterLbl in + attach t.trailing lbl.loc afterLbl; + let beforeTyp, insideTyp, afterTyp = + partitionByLoc rest typexpr.ptyp_loc + in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkCoreType typexpr t insideTyp; + attach t.trailing typexpr.ptyp_loc afterTyp | _ -> () and walkTypeParameters typeParameters t comments = visitListButContinueWithRemainingComments ~getLoc:(fun (_, _, typexpr) -> match typexpr.Parsetree.ptyp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _attrs -> - {loc with loc_end = typexpr.ptyp_loc.loc_end} + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _attrs -> + { loc with loc_end = typexpr.ptyp_loc.loc_end } | _ -> typexpr.ptyp_loc) ~walkNode:walkTypeParameter ~newlineDelimited:false typeParameters t comments @@ -51854,9 +51990,7 @@ and walkAttribute (id, payload) t comments = walkPayload payload t rest and walkPayload payload t comments = - match payload with - | PStr s -> walkStructure s t comments - | _ -> () + match payload with PStr s -> walkStructure s t comments | _ -> () end module Res_parens : sig @@ -51865,172 +51999,166 @@ type kind = Parenthesized | Braced of Location.t | Nothing val expr : Parsetree.expression -> kind val structureExpr : Parsetree.expression -> kind - val unaryExprOperand : Parsetree.expression -> kind - val binaryExprOperand : isLhs:bool -> Parsetree.expression -> kind val subBinaryExprOperand : string -> string -> bool val rhsBinaryExprOperand : string -> Parsetree.expression -> bool val flattenOperandRhs : string -> Parsetree.expression -> bool - val lazyOrAssertOrAwaitExprRhs : Parsetree.expression -> kind - val fieldExpr : Parsetree.expression -> kind - val setFieldExprRhs : Parsetree.expression -> kind - val ternaryOperand : Parsetree.expression -> kind - val jsxPropExpr : Parsetree.expression -> kind val jsxChildExpr : Parsetree.expression -> kind - val binaryExpr : Parsetree.expression -> kind val modTypeFunctorReturn : Parsetree.module_type -> bool val modTypeWithOperand : Parsetree.module_type -> bool val modExprFunctorConstraint : Parsetree.module_type -> bool - val bracedExpr : Parsetree.expression -> bool val callExpr : Parsetree.expression -> kind - val includeModExpr : Parsetree.module_expr -> bool - val arrowReturnTypExpr : Parsetree.core_type -> bool - val patternRecordRowRhs : Parsetree.pattern -> bool end = struct #1 "res_parens.ml" module ParsetreeViewer = Res_parsetree_viewer + type kind = Parenthesized | Braced of Location.t | Nothing let expr expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc | _ -> ( - match expr with - | { - Parsetree.pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_constraint _} -> Parenthesized - | _ -> Nothing) + match expr with + | { + Parsetree.pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + } -> + Nothing + | { pexp_desc = Pexp_constraint _ } -> Parenthesized + | _ -> Nothing) let callExpr expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc | _ -> ( - match expr with - | {Parsetree.pexp_attributes = attrs} - when match ParsetreeViewer.filterParsingAttrs attrs with - | _ :: _ -> true - | [] -> false -> - Parenthesized - | _ - when ParsetreeViewer.isUnaryExpression expr - || ParsetreeViewer.isBinaryExpression expr -> - Parenthesized - | { - Parsetree.pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_fun _} when ParsetreeViewer.isUnderscoreApplySugar expr - -> - Nothing - | { - pexp_desc = - ( Pexp_lazy _ | Pexp_assert _ | Pexp_fun _ | Pexp_newtype _ - | Pexp_function _ | Pexp_constraint _ | Pexp_setfield _ | Pexp_match _ - | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_ifthenelse _ ); - } -> - Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> - Parenthesized - | _ -> Nothing) + match expr with + | { Parsetree.pexp_attributes = attrs } + when match ParsetreeViewer.filterParsingAttrs attrs with + | _ :: _ -> true + | [] -> false -> + Parenthesized + | _ + when ParsetreeViewer.isUnaryExpression expr + || ParsetreeViewer.isBinaryExpression expr -> + Parenthesized + | { + Parsetree.pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + } -> + Nothing + | { pexp_desc = Pexp_fun _ } + when ParsetreeViewer.isUnderscoreApplySugar expr -> + Nothing + | { + pexp_desc = + ( Pexp_lazy _ | Pexp_assert _ | Pexp_fun _ | Pexp_newtype _ + | Pexp_function _ | Pexp_constraint _ | Pexp_setfield _ | Pexp_match _ + | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_ifthenelse _ ); + } -> + Parenthesized + | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> + Parenthesized + | _ -> Nothing) let structureExpr expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc | None -> ( - match expr with - | _ - when ParsetreeViewer.hasAttributes expr.pexp_attributes - && not (ParsetreeViewer.isJsxExpression expr) -> - Parenthesized - | { - Parsetree.pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_constraint _} -> Parenthesized - | _ -> Nothing) + match expr with + | _ + when ParsetreeViewer.hasAttributes expr.pexp_attributes + && not (ParsetreeViewer.isJsxExpression expr) -> + Parenthesized + | { + Parsetree.pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + } -> + Nothing + | { pexp_desc = Pexp_constraint _ } -> Parenthesized + | _ -> Nothing) let unaryExprOperand expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc | None -> ( - match expr with - | {Parsetree.pexp_attributes = attrs} - when match ParsetreeViewer.filterParsingAttrs attrs with - | _ :: _ -> true - | [] -> false -> - Parenthesized - | expr - when ParsetreeViewer.isUnaryExpression expr - || ParsetreeViewer.isBinaryExpression expr -> - Parenthesized - | { - pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_fun _} when ParsetreeViewer.isUnderscoreApplySugar expr - -> - Nothing - | { - pexp_desc = - ( Pexp_lazy _ | Pexp_assert _ | Pexp_fun _ | Pexp_newtype _ - | Pexp_function _ | Pexp_constraint _ | Pexp_setfield _ - | Pexp_extension _ (* readability? maybe remove *) | Pexp_match _ - | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_ifthenelse _ ); - } -> - Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> - Parenthesized - | _ -> Nothing) + match expr with + | { Parsetree.pexp_attributes = attrs } + when match ParsetreeViewer.filterParsingAttrs attrs with + | _ :: _ -> true + | [] -> false -> + Parenthesized + | expr + when ParsetreeViewer.isUnaryExpression expr + || ParsetreeViewer.isBinaryExpression expr -> + Parenthesized + | { + pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + } -> + Nothing + | { pexp_desc = Pexp_fun _ } + when ParsetreeViewer.isUnderscoreApplySugar expr -> + Nothing + | { + pexp_desc = + ( Pexp_lazy _ | Pexp_assert _ | Pexp_fun _ | Pexp_newtype _ + | Pexp_function _ | Pexp_constraint _ | Pexp_setfield _ + | Pexp_extension _ (* readability? maybe remove *) | Pexp_match _ + | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_ifthenelse _ ); + } -> + Parenthesized + | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> + Parenthesized + | _ -> Nothing) let binaryExprOperand ~isLhs expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc | None -> ( - match expr with - | { - Parsetree.pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_fun _} when ParsetreeViewer.isUnderscoreApplySugar expr - -> - Nothing - | { - pexp_desc = - Pexp_constraint _ | Pexp_fun _ | Pexp_function _ | Pexp_newtype _; - } -> - Parenthesized - | expr when ParsetreeViewer.isBinaryExpression expr -> Parenthesized - | expr when ParsetreeViewer.isTernaryExpr expr -> Parenthesized - | {pexp_desc = Pexp_lazy _ | Pexp_assert _} when isLhs -> Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> - Parenthesized - | {Parsetree.pexp_attributes = attrs} -> - if ParsetreeViewer.hasPrintableAttributes attrs then Parenthesized - else Nothing) + match expr with + | { + Parsetree.pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + } -> + Nothing + | { pexp_desc = Pexp_fun _ } + when ParsetreeViewer.isUnderscoreApplySugar expr -> + Nothing + | { + pexp_desc = + Pexp_constraint _ | Pexp_fun _ | Pexp_function _ | Pexp_newtype _; + } -> + Parenthesized + | expr when ParsetreeViewer.isBinaryExpression expr -> Parenthesized + | expr when ParsetreeViewer.isTernaryExpr expr -> Parenthesized + | { pexp_desc = Pexp_lazy _ | Pexp_assert _ } when isLhs -> Parenthesized + | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> + Parenthesized + | { Parsetree.pexp_attributes = attrs } -> + if ParsetreeViewer.hasPrintableAttributes attrs then Parenthesized + else Nothing) let subBinaryExprOperand parentOperator childOperator = let precParent = ParsetreeViewer.operatorPrecedence parentOperator in @@ -52047,14 +52175,14 @@ let rhsBinaryExprOperand parentOperator rhs = ( { pexp_attributes = []; pexp_desc = - Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}; + Pexp_ident { txt = Longident.Lident operator; loc = operatorLoc }; }, - [(_, _left); (_, _right)] ) + [ (_, _left); (_, _right) ] ) when ParsetreeViewer.isBinaryOperator operator && not (operatorLoc.loc_ghost && operator = "^") -> - let precParent = ParsetreeViewer.operatorPrecedence parentOperator in - let precChild = ParsetreeViewer.operatorPrecedence operator in - precParent == precChild + let precParent = ParsetreeViewer.operatorPrecedence parentOperator in + let precChild = ParsetreeViewer.operatorPrecedence operator in + precParent == precChild | _ -> false let flattenOperandRhs parentOperator rhs = @@ -52062,16 +52190,17 @@ let flattenOperandRhs parentOperator rhs = | Parsetree.Pexp_apply ( { pexp_desc = - Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}; + Pexp_ident { txt = Longident.Lident operator; loc = operatorLoc }; }, - [(_, _left); (_, _right)] ) + [ (_, _left); (_, _right) ] ) when ParsetreeViewer.isBinaryOperator operator && not (operatorLoc.loc_ghost && operator = "^") -> - let precParent = ParsetreeViewer.operatorPrecedence parentOperator in - let precChild = ParsetreeViewer.operatorPrecedence operator in - precParent >= precChild || rhs.pexp_attributes <> [] - | Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}) -> - false + let precParent = ParsetreeViewer.operatorPrecedence parentOperator in + let precChild = ParsetreeViewer.operatorPrecedence operator in + precParent >= precChild || rhs.pexp_attributes <> [] + | Pexp_constraint ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }) + -> + false | Pexp_fun _ when ParsetreeViewer.isUnderscoreApplySugar rhs -> false | Pexp_fun _ | Pexp_newtype _ | Pexp_setfield _ | Pexp_constraint _ -> true | _ when ParsetreeViewer.isTernaryExpr rhs -> true @@ -52080,33 +52209,34 @@ let flattenOperandRhs parentOperator rhs = let lazyOrAssertOrAwaitExprRhs expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc | None -> ( - match expr with - | {Parsetree.pexp_attributes = attrs} - when match ParsetreeViewer.filterParsingAttrs attrs with - | _ :: _ -> true - | [] -> false -> - Parenthesized - | expr when ParsetreeViewer.isBinaryExpression expr -> Parenthesized - | { - pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_fun _} when ParsetreeViewer.isUnderscoreApplySugar expr - -> - Nothing - | { - pexp_desc = - ( Pexp_lazy _ | Pexp_assert _ | Pexp_fun _ | Pexp_newtype _ - | Pexp_function _ | Pexp_constraint _ | Pexp_setfield _ | Pexp_match _ - | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_ifthenelse _ ); - } -> - Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> - Parenthesized - | _ -> Nothing) + match expr with + | { Parsetree.pexp_attributes = attrs } + when match ParsetreeViewer.filterParsingAttrs attrs with + | _ :: _ -> true + | [] -> false -> + Parenthesized + | expr when ParsetreeViewer.isBinaryExpression expr -> Parenthesized + | { + pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + } -> + Nothing + | { pexp_desc = Pexp_fun _ } + when ParsetreeViewer.isUnderscoreApplySugar expr -> + Nothing + | { + pexp_desc = + ( Pexp_lazy _ | Pexp_assert _ | Pexp_fun _ | Pexp_newtype _ + | Pexp_function _ | Pexp_constraint _ | Pexp_setfield _ | Pexp_match _ + | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_ifthenelse _ ); + } -> + Parenthesized + | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> + Parenthesized + | _ -> Nothing) let isNegativeConstant constant = let isNeg txt = @@ -52120,74 +52250,78 @@ let isNegativeConstant constant = let fieldExpr expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc | None -> ( - match expr with - | {Parsetree.pexp_attributes = attrs} - when match ParsetreeViewer.filterParsingAttrs attrs with - | _ :: _ -> true - | [] -> false -> - Parenthesized - | expr - when ParsetreeViewer.isBinaryExpression expr - || ParsetreeViewer.isUnaryExpression expr -> - Parenthesized - | { - pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_constant c} when isNegativeConstant c -> Parenthesized - | {pexp_desc = Pexp_fun _} when ParsetreeViewer.isUnderscoreApplySugar expr - -> - Nothing - | { - pexp_desc = - ( Pexp_lazy _ | Pexp_assert _ - | Pexp_extension _ (* %extension.x vs (%extension).x *) | Pexp_fun _ - | Pexp_newtype _ | Pexp_function _ | Pexp_constraint _ | Pexp_setfield _ - | Pexp_match _ | Pexp_try _ | Pexp_while _ | Pexp_for _ - | Pexp_ifthenelse _ ); - } -> - Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> - Parenthesized - | _ -> Nothing) + match expr with + | { Parsetree.pexp_attributes = attrs } + when match ParsetreeViewer.filterParsingAttrs attrs with + | _ :: _ -> true + | [] -> false -> + Parenthesized + | expr + when ParsetreeViewer.isBinaryExpression expr + || ParsetreeViewer.isUnaryExpression expr -> + Parenthesized + | { + pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + } -> + Nothing + | { pexp_desc = Pexp_constant c } when isNegativeConstant c -> + Parenthesized + | { pexp_desc = Pexp_fun _ } + when ParsetreeViewer.isUnderscoreApplySugar expr -> + Nothing + | { + pexp_desc = + ( Pexp_lazy _ | Pexp_assert _ + | Pexp_extension _ (* %extension.x vs (%extension).x *) | Pexp_fun _ + | Pexp_newtype _ | Pexp_function _ | Pexp_constraint _ + | Pexp_setfield _ | Pexp_match _ | Pexp_try _ | Pexp_while _ + | Pexp_for _ | Pexp_ifthenelse _ ); + } -> + Parenthesized + | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> + Parenthesized + | _ -> Nothing) let setFieldExprRhs expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc | None -> ( - match expr with - | { - Parsetree.pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_constraint _} -> Parenthesized - | _ -> Nothing) + match expr with + | { + Parsetree.pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + } -> + Nothing + | { pexp_desc = Pexp_constraint _ } -> Parenthesized + | _ -> Nothing) let ternaryOperand expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc | None -> ( - match expr with - | { - Parsetree.pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_constraint _} -> Parenthesized - | {pexp_desc = Pexp_fun _ | Pexp_newtype _} -> ( - let _attrsOnArrow, _parameters, returnExpr = - ParsetreeViewer.funExpr expr - in - match returnExpr.pexp_desc with - | Pexp_constraint _ -> Parenthesized + match expr with + | { + Parsetree.pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + } -> + Nothing + | { pexp_desc = Pexp_constraint _ } -> Parenthesized + | { pexp_desc = Pexp_fun _ | Pexp_newtype _ } -> ( + let _attrsOnArrow, _parameters, returnExpr = + ParsetreeViewer.funExpr expr + in + match returnExpr.pexp_desc with + | Pexp_constraint _ -> Parenthesized + | _ -> Nothing) | _ -> Nothing) - | _ -> Nothing) let startsWithMinus txt = let len = String.length txt in @@ -52200,93 +52334,93 @@ let jsxPropExpr expr = match expr.Parsetree.pexp_desc with | Parsetree.Pexp_let _ | Pexp_sequence _ | Pexp_letexception _ | Pexp_letmodule _ | Pexp_open _ -> - Nothing + Nothing | _ -> ( - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc - | None -> ( - match expr with - | { - Parsetree.pexp_desc = - Pexp_constant (Pconst_integer (x, _) | Pconst_float (x, _)); - pexp_attributes = []; - } - when startsWithMinus x -> - Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> - Parenthesized - | { - Parsetree.pexp_desc = - ( Pexp_ident _ | Pexp_constant _ | Pexp_field _ | Pexp_construct _ - | Pexp_variant _ | Pexp_array _ | Pexp_pack _ | Pexp_record _ - | Pexp_extension _ | Pexp_letmodule _ | Pexp_letexception _ - | Pexp_open _ | Pexp_sequence _ | Pexp_let _ | Pexp_tuple _ ); - pexp_attributes = []; - } -> - Nothing - | { - Parsetree.pexp_desc = - Pexp_constraint - ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - pexp_attributes = []; - } -> - Nothing - | _ -> Parenthesized)) + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc + | None -> ( + match expr with + | { + Parsetree.pexp_desc = + Pexp_constant (Pconst_integer (x, _) | Pconst_float (x, _)); + pexp_attributes = []; + } + when startsWithMinus x -> + Parenthesized + | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> + Parenthesized + | { + Parsetree.pexp_desc = + ( Pexp_ident _ | Pexp_constant _ | Pexp_field _ | Pexp_construct _ + | Pexp_variant _ | Pexp_array _ | Pexp_pack _ | Pexp_record _ + | Pexp_extension _ | Pexp_letmodule _ | Pexp_letexception _ + | Pexp_open _ | Pexp_sequence _ | Pexp_let _ | Pexp_tuple _ ); + pexp_attributes = []; + } -> + Nothing + | { + Parsetree.pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + pexp_attributes = []; + } -> + Nothing + | _ -> Parenthesized)) let jsxChildExpr expr = match expr.Parsetree.pexp_desc with | Parsetree.Pexp_let _ | Pexp_sequence _ | Pexp_letexception _ | Pexp_letmodule _ | Pexp_open _ -> - Nothing + Nothing | _ -> ( - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc - | _ -> ( - match expr with - | { - Parsetree.pexp_desc = - Pexp_constant (Pconst_integer (x, _) | Pconst_float (x, _)); - pexp_attributes = []; - } - when startsWithMinus x -> - Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> - Parenthesized - | { - Parsetree.pexp_desc = - ( Pexp_ident _ | Pexp_constant _ | Pexp_field _ | Pexp_construct _ - | Pexp_variant _ | Pexp_array _ | Pexp_pack _ | Pexp_record _ - | Pexp_extension _ | Pexp_letmodule _ | Pexp_letexception _ - | Pexp_open _ | Pexp_sequence _ | Pexp_let _ ); - pexp_attributes = []; - } -> - Nothing - | { - Parsetree.pexp_desc = - Pexp_constraint - ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - pexp_attributes = []; - } -> - Nothing - | expr when ParsetreeViewer.isJsxExpression expr -> Nothing - | _ -> Parenthesized)) + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc + | _ -> ( + match expr with + | { + Parsetree.pexp_desc = + Pexp_constant (Pconst_integer (x, _) | Pconst_float (x, _)); + pexp_attributes = []; + } + when startsWithMinus x -> + Parenthesized + | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> + Parenthesized + | { + Parsetree.pexp_desc = + ( Pexp_ident _ | Pexp_constant _ | Pexp_field _ | Pexp_construct _ + | Pexp_variant _ | Pexp_array _ | Pexp_pack _ | Pexp_record _ + | Pexp_extension _ | Pexp_letmodule _ | Pexp_letexception _ + | Pexp_open _ | Pexp_sequence _ | Pexp_let _ ); + pexp_attributes = []; + } -> + Nothing + | { + Parsetree.pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + pexp_attributes = []; + } -> + Nothing + | expr when ParsetreeViewer.isJsxExpression expr -> Nothing + | _ -> Parenthesized)) let binaryExpr expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc | None -> ( - match expr with - | {Parsetree.pexp_attributes = _ :: _} as expr - when ParsetreeViewer.isBinaryExpression expr -> - Parenthesized - | _ -> Nothing) + match expr with + | { Parsetree.pexp_attributes = _ :: _ } as expr + when ParsetreeViewer.isBinaryExpression expr -> + Parenthesized + | _ -> Nothing) let modTypeFunctorReturn modType = match modType with - | {Parsetree.pmty_desc = Pmty_with _} -> true + | { Parsetree.pmty_desc = Pmty_with _ } -> true | _ -> false (* Add parens for readability: @@ -52296,18 +52430,19 @@ let modTypeFunctorReturn modType = *) let modTypeWithOperand modType = match modType with - | {Parsetree.pmty_desc = Pmty_functor _ | Pmty_with _} -> true + | { Parsetree.pmty_desc = Pmty_functor _ | Pmty_with _ } -> true | _ -> false let modExprFunctorConstraint modType = match modType with - | {Parsetree.pmty_desc = Pmty_functor _ | Pmty_with _} -> true + | { Parsetree.pmty_desc = Pmty_functor _ | Pmty_with _ } -> true | _ -> false let bracedExpr expr = match expr.Parsetree.pexp_desc with - | Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}) -> - false + | Pexp_constraint ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }) + -> + false | Pexp_constraint _ -> true | _ -> false @@ -52323,9 +52458,9 @@ let arrowReturnTypExpr typExpr = let patternRecordRowRhs (pattern : Parsetree.pattern) = match pattern.ppat_desc with - | Ppat_constraint ({ppat_desc = Ppat_unpack _}, {ptyp_desc = Ptyp_package _}) - -> - false + | Ppat_constraint + ({ ppat_desc = Ppat_unpack _ }, { ptyp_desc = Ptyp_package _ }) -> + false | Ppat_constraint _ -> true | _ -> false @@ -52340,9 +52475,9 @@ type t = | Open | True | False - | Codepoint of {c: int; original: string} - | Int of {i: string; suffix: char option} - | Float of {f: string; suffix: char option} + | Codepoint of { c : int; original : string } + | Int of { i : string; suffix : char option } + | Float of { f : string; suffix : char option } | String of string | Lident of string | Uident of string @@ -52438,7 +52573,7 @@ let precedence = function | Land -> 3 | Equal | EqualEqual | EqualEqualEqual | LessThan | GreaterThan | BangEqual | BangEqualEqual | LessEqual | GreaterEqual | BarGreater -> - 4 + 4 | Plus | PlusDot | Minus | MinusDot | PlusPlus -> 5 | Asterisk | AsteriskDot | Forwardslash | ForwardslashDot -> 6 | Exponentiation -> 7 @@ -52451,15 +52586,15 @@ let toString = function | Open -> "open" | True -> "true" | False -> "false" - | Codepoint {original} -> "codepoint '" ^ original ^ "'" + | Codepoint { original } -> "codepoint '" ^ original ^ "'" | String s -> "string \"" ^ s ^ "\"" | Lident str -> str | Uident str -> str | Dot -> "." | DotDot -> ".." | DotDotDot -> "..." - | Int {i} -> "int " ^ i - | Float {f} -> "Float: " ^ f + | Int { i } -> "int " ^ i + | Float { f } -> "Float: " ^ f | Bang -> "!" | Semicolon -> ";" | Let -> "let" @@ -52579,7 +52714,7 @@ let isKeyword = function | Await | And | As | Assert | Constraint | Else | Exception | External | False | For | If | In | Include | Land | Lazy | Let | List | Lor | Module | Mutable | Of | Open | Private | Rec | Switch | True | Try | Typ | When | While -> - true + true | _ -> false let lookupKeyword str = @@ -52601,13 +52736,9 @@ end module Res_utf8 : sig #1 "res_utf8.mli" val repl : int - val max : int - val decodeCodePoint : int -> string -> int -> int * int - val encodeCodePoint : int -> string - val isValidCodePoint : int -> bool end = struct @@ -52619,7 +52750,6 @@ let repl = 0xFFFD (* let min = 0x0000 *) let max = 0x10FFFF - let surrogateMin = 0xD800 let surrogateMax = 0xDFFF @@ -52635,10 +52765,9 @@ let surrogateMax = 0xDFFF let h2 = 0b1100_0000 let h3 = 0b1110_0000 let h4 = 0b1111_0000 - let cont_mask = 0b0011_1111 -type category = {low: int; high: int; size: int} +type category = { low : int; high : int; size : int } let locb = 0b1000_0000 let hicb = 0b1011_1111 @@ -52768,11 +52897,8 @@ val printTypeParams : Res_doc.t val printLongident : Longident.t -> Res_doc.t - val printTypExpr : Parsetree.core_type -> Res_comments_table.t -> Res_doc.t - val addParens : Res_doc.t -> Res_doc.t - val printExpression : Parsetree.expression -> Res_comments_table.t -> Res_doc.t val printPattern : Parsetree.pattern -> Res_comments_table.t -> Res_doc.t @@ -52783,6 +52909,7 @@ val printStructure : Parsetree.structure -> Res_comments_table.t -> Res_doc.t val printImplementation : width:int -> Parsetree.structure -> comments:Res_comment.t list -> string + val printInterface : width:int -> Parsetree.signature -> comments:Res_comment.t list -> string @@ -52854,7 +52981,7 @@ let addParens doc = (Doc.concat [ Doc.lparen; - Doc.indent (Doc.concat [Doc.softLine; doc]); + Doc.indent (Doc.concat [ Doc.softLine; doc ]); Doc.softLine; Doc.rparen; ]) @@ -52864,12 +52991,12 @@ let addBraces doc = (Doc.concat [ Doc.lbrace; - Doc.indent (Doc.concat [Doc.softLine; doc]); + Doc.indent (Doc.concat [ Doc.softLine; doc ]); Doc.softLine; Doc.rbrace; ]) -let addAsync doc = Doc.concat [Doc.text "async "; doc] +let addAsync doc = Doc.concat [ Doc.text "async "; doc ] let getFirstLeadingComment tbl loc = match Hashtbl.find tbl.CommentTable.leading loc with @@ -52886,8 +53013,8 @@ let hasLeadingLineComment tbl loc = let hasCommentBelow tbl loc = match Hashtbl.find tbl.CommentTable.trailing loc with | comment :: _ -> - let commentLoc = Comment.loc comment in - commentLoc.Location.loc_start.pos_lnum > loc.Location.loc_end.pos_lnum + let commentLoc = Comment.loc comment in + commentLoc.Location.loc_start.pos_lnum > loc.Location.loc_end.pos_lnum | [] -> false | exception Not_found -> false @@ -52895,10 +53022,10 @@ let hasNestedJsxOrMoreThanOneChild expr = let rec loop inRecursion expr = match expr.Parsetree.pexp_desc with | Pexp_construct - ({txt = Longident.Lident "::"}, Some {pexp_desc = Pexp_tuple [hd; tail]}) - -> - if inRecursion || ParsetreeViewer.isJsxExpression hd then true - else loop true tail + ( { txt = Longident.Lident "::" }, + Some { pexp_desc = Pexp_tuple [ hd; tail ] } ) -> + if inRecursion || ParsetreeViewer.isJsxExpression hd then true + else loop true tail | _ -> false in loop false expr @@ -52929,42 +53056,40 @@ let printMultilineCommentContent txt = let rec indentStars lines acc = match lines with | [] -> Doc.nil - | [lastLine] -> - let line = String.trim lastLine in - let doc = Doc.text (" " ^ line) in - let trailingSpace = if line = "" then Doc.nil else Doc.space in - List.rev (trailingSpace :: doc :: acc) |> Doc.concat - | line :: lines -> - let line = String.trim line in - if line != "" && String.unsafe_get line 0 == '*' then + | [ lastLine ] -> + let line = String.trim lastLine in let doc = Doc.text (" " ^ line) in - indentStars lines (Doc.hardLine :: doc :: acc) - else - let trailingSpace = - let len = String.length txt in - if len > 0 && String.unsafe_get txt (len - 1) = ' ' then Doc.space - else Doc.nil - in - let content = Comment.trimSpaces txt in - Doc.concat [Doc.text content; trailingSpace] + let trailingSpace = if line = "" then Doc.nil else Doc.space in + List.rev (trailingSpace :: doc :: acc) |> Doc.concat + | line :: lines -> + let line = String.trim line in + if line != "" && String.unsafe_get line 0 == '*' then + let doc = Doc.text (" " ^ line) in + indentStars lines (Doc.hardLine :: doc :: acc) + else + let trailingSpace = + let len = String.length txt in + if len > 0 && String.unsafe_get txt (len - 1) = ' ' then Doc.space + else Doc.nil + in + let content = Comment.trimSpaces txt in + Doc.concat [ Doc.text content; trailingSpace ] in let lines = String.split_on_char '\n' txt in match lines with | [] -> Doc.text "/* */" - | [line] -> - Doc.concat - [Doc.text "/* "; Doc.text (Comment.trimSpaces line); Doc.text " */"] + | [ line ] -> + Doc.concat + [ Doc.text "/* "; Doc.text (Comment.trimSpaces line); Doc.text " */" ] | first :: rest -> - let firstLine = Comment.trimSpaces first in - Doc.concat - [ - Doc.text "/*"; - (match firstLine with - | "" | "*" -> Doc.nil - | _ -> Doc.space); - indentStars rest [Doc.hardLine; Doc.text firstLine]; - Doc.text "*/"; - ] + let firstLine = Comment.trimSpaces first in + Doc.concat + [ + Doc.text "/*"; + (match firstLine with "" | "*" -> Doc.nil | _ -> Doc.space); + indentStars rest [ Doc.hardLine; Doc.text firstLine ]; + Doc.text "*/"; + ] let printTrailingComment (prevLoc : Location.t) (nodeLoc : Location.t) comment = let singleLine = Comment.isSingleLineComment comment in @@ -52992,8 +53117,8 @@ let printTrailingComment (prevLoc : Location.t) (nodeLoc : Location.t) comment = content; ]); ] - else if not singleLine then Doc.concat [Doc.space; content] - else Doc.lineSuffix (Doc.concat [Doc.space; content]) + else if not singleLine then Doc.concat [ Doc.space; content ] + else Doc.lineSuffix (Doc.concat [ Doc.space; content ]) let printLeadingComment ?nextComment comment = let singleLine = Comment.isSingleLineComment comment in @@ -53005,28 +53130,28 @@ let printLeadingComment ?nextComment comment = let separator = Doc.concat [ - (if singleLine then Doc.concat [Doc.hardLine; Doc.breakParent] + (if singleLine then Doc.concat [ Doc.hardLine; Doc.breakParent ] else Doc.nil); (match nextComment with | Some next -> - let nextLoc = Comment.loc next in - let currLoc = Comment.loc comment in - let diff = - nextLoc.Location.loc_start.pos_lnum - - currLoc.Location.loc_end.pos_lnum - in - let nextSingleLine = Comment.isSingleLineComment next in - if singleLine && nextSingleLine then - if diff > 1 then Doc.hardLine else Doc.nil - else if singleLine && not nextSingleLine then - if diff > 1 then Doc.hardLine else Doc.nil - else if diff > 1 then Doc.concat [Doc.hardLine; Doc.hardLine] - else if diff == 1 then Doc.hardLine - else Doc.space + let nextLoc = Comment.loc next in + let currLoc = Comment.loc comment in + let diff = + nextLoc.Location.loc_start.pos_lnum + - currLoc.Location.loc_end.pos_lnum + in + let nextSingleLine = Comment.isSingleLineComment next in + if singleLine && nextSingleLine then + if diff > 1 then Doc.hardLine else Doc.nil + else if singleLine && not nextSingleLine then + if diff > 1 then Doc.hardLine else Doc.nil + else if diff > 1 then Doc.concat [ Doc.hardLine; Doc.hardLine ] + else if diff == 1 then Doc.hardLine + else Doc.space | None -> Doc.nil); ] in - Doc.concat [content; separator] + Doc.concat [ content; separator ] (* This function is used for printing comments inside an empty block *) let printCommentsInside cmtTbl loc = @@ -53042,96 +53167,98 @@ let printCommentsInside cmtTbl loc = let rec loop acc comments = match comments with | [] -> Doc.nil - | [comment] -> - let cmtDoc = printComment comment in - let cmtsDoc = Doc.concat (Doc.softLine :: List.rev (cmtDoc :: acc)) in - let doc = - Doc.breakableGroup ~forceBreak - (Doc.concat [Doc.ifBreaks (Doc.indent cmtsDoc) cmtsDoc; Doc.softLine]) - in - doc + | [ comment ] -> + let cmtDoc = printComment comment in + let cmtsDoc = Doc.concat (Doc.softLine :: List.rev (cmtDoc :: acc)) in + let doc = + Doc.breakableGroup ~forceBreak + (Doc.concat + [ Doc.ifBreaks (Doc.indent cmtsDoc) cmtsDoc; Doc.softLine ]) + in + doc | comment :: rest -> - let cmtDoc = Doc.concat [printComment comment; Doc.line] in - loop (cmtDoc :: acc) rest + let cmtDoc = Doc.concat [ printComment comment; Doc.line ] in + loop (cmtDoc :: acc) rest in match Hashtbl.find cmtTbl.CommentTable.inside loc with | exception Not_found -> Doc.nil | comments -> - Hashtbl.remove cmtTbl.inside loc; - loop [] comments + Hashtbl.remove cmtTbl.inside loc; + loop [] comments (* This function is used for printing comments inside an empty file *) let printCommentsInsideFile cmtTbl = let rec loop acc comments = match comments with | [] -> Doc.nil - | [comment] -> - let cmtDoc = printLeadingComment comment in - let doc = - Doc.group (Doc.concat [Doc.concat (List.rev (cmtDoc :: acc))]) - in - doc + | [ comment ] -> + let cmtDoc = printLeadingComment comment in + let doc = + Doc.group (Doc.concat [ Doc.concat (List.rev (cmtDoc :: acc)) ]) + in + doc | comment :: (nextComment :: _comments as rest) -> - let cmtDoc = printLeadingComment ~nextComment comment in - loop (cmtDoc :: acc) rest + let cmtDoc = printLeadingComment ~nextComment comment in + loop (cmtDoc :: acc) rest in match Hashtbl.find cmtTbl.CommentTable.inside Location.none with | exception Not_found -> Doc.nil | comments -> - Hashtbl.remove cmtTbl.inside Location.none; - Doc.group (loop [] comments) + Hashtbl.remove cmtTbl.inside Location.none; + Doc.group (loop [] comments) let printLeadingComments node tbl loc = let rec loop acc comments = match comments with | [] -> node - | [comment] -> - let cmtDoc = printLeadingComment comment in - let diff = - loc.Location.loc_start.pos_lnum - - (Comment.loc comment).Location.loc_end.pos_lnum - in - let separator = - if Comment.isSingleLineComment comment then - if diff > 1 then Doc.hardLine else Doc.nil - else if diff == 0 then Doc.space - else if diff > 1 then Doc.concat [Doc.hardLine; Doc.hardLine] - else Doc.hardLine - in - let doc = - Doc.group - (Doc.concat [Doc.concat (List.rev (cmtDoc :: acc)); separator; node]) - in - doc + | [ comment ] -> + let cmtDoc = printLeadingComment comment in + let diff = + loc.Location.loc_start.pos_lnum + - (Comment.loc comment).Location.loc_end.pos_lnum + in + let separator = + if Comment.isSingleLineComment comment then + if diff > 1 then Doc.hardLine else Doc.nil + else if diff == 0 then Doc.space + else if diff > 1 then Doc.concat [ Doc.hardLine; Doc.hardLine ] + else Doc.hardLine + in + let doc = + Doc.group + (Doc.concat + [ Doc.concat (List.rev (cmtDoc :: acc)); separator; node ]) + in + doc | comment :: (nextComment :: _comments as rest) -> - let cmtDoc = printLeadingComment ~nextComment comment in - loop (cmtDoc :: acc) rest + let cmtDoc = printLeadingComment ~nextComment comment in + loop (cmtDoc :: acc) rest in match Hashtbl.find tbl loc with | exception Not_found -> node | comments -> - (* Remove comments from tbl: Some ast nodes have the same location. - * We only want to print comments once *) - Hashtbl.remove tbl loc; - loop [] comments + (* Remove comments from tbl: Some ast nodes have the same location. + * We only want to print comments once *) + Hashtbl.remove tbl loc; + loop [] comments let printTrailingComments node tbl loc = let rec loop prev acc comments = match comments with | [] -> Doc.concat (List.rev acc) | comment :: comments -> - let cmtDoc = printTrailingComment prev loc comment in - loop (Comment.loc comment) (cmtDoc :: acc) comments + let cmtDoc = printTrailingComment prev loc comment in + loop (Comment.loc comment) (cmtDoc :: acc) comments in match Hashtbl.find tbl loc with | exception Not_found -> node | [] -> node | _first :: _ as comments -> - (* Remove comments from tbl: Some ast nodes have the same location. - * We only want to print comments once *) - Hashtbl.remove tbl loc; - let cmtsDoc = loop loc [] comments in - Doc.concat [node; cmtsDoc] + (* Remove comments from tbl: Some ast nodes have the same location. + * We only want to print comments once *) + Hashtbl.remove tbl loc; + let cmtsDoc = loop loc [] comments in + Doc.concat [ node; cmtsDoc ] let printComments doc (tbl : CommentTable.t) loc = let docWithLeadingComments = printLeadingComments doc tbl.leading loc in @@ -53142,68 +53269,68 @@ let printList ~getLoc ~nodes ~print ?(forceBreak = false) t = match nodes with | [] -> (prevLoc, Doc.concat (List.rev acc)) | node :: nodes -> - let loc = getLoc node in - let startPos = - match getFirstLeadingComment t loc with - | None -> loc.loc_start - | Some comment -> (Comment.loc comment).loc_start - in - let sep = - if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then - Doc.concat [Doc.hardLine; Doc.hardLine] - else Doc.hardLine - in - let doc = printComments (print node t) t loc in - loop loc (doc :: sep :: acc) nodes + let loc = getLoc node in + let startPos = + match getFirstLeadingComment t loc with + | None -> loc.loc_start + | Some comment -> (Comment.loc comment).loc_start + in + let sep = + if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then + Doc.concat [ Doc.hardLine; Doc.hardLine ] + else Doc.hardLine + in + let doc = printComments (print node t) t loc in + loop loc (doc :: sep :: acc) nodes in match nodes with | [] -> Doc.nil | node :: nodes -> - let firstLoc = getLoc node in - let doc = printComments (print node t) t firstLoc in - let lastLoc, docs = loop firstLoc [doc] nodes in - let forceBreak = - forceBreak || firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak docs + let firstLoc = getLoc node in + let doc = printComments (print node t) t firstLoc in + let lastLoc, docs = loop firstLoc [ doc ] nodes in + let forceBreak = + forceBreak || firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak docs let printListi ~getLoc ~nodes ~print ?(forceBreak = false) t = let rec loop i (prevLoc : Location.t) acc nodes = match nodes with | [] -> (prevLoc, Doc.concat (List.rev acc)) | node :: nodes -> - let loc = getLoc node in - let startPos = - match getFirstLeadingComment t loc with - | None -> loc.loc_start - | Some comment -> (Comment.loc comment).loc_start - in - let sep = - if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then - Doc.concat [Doc.hardLine; Doc.hardLine] - else Doc.line - in - let doc = printComments (print node t i) t loc in - loop (i + 1) loc (doc :: sep :: acc) nodes + let loc = getLoc node in + let startPos = + match getFirstLeadingComment t loc with + | None -> loc.loc_start + | Some comment -> (Comment.loc comment).loc_start + in + let sep = + if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then + Doc.concat [ Doc.hardLine; Doc.hardLine ] + else Doc.line + in + let doc = printComments (print node t i) t loc in + loop (i + 1) loc (doc :: sep :: acc) nodes in match nodes with | [] -> Doc.nil | node :: nodes -> - let firstLoc = getLoc node in - let doc = printComments (print node t 0) t firstLoc in - let lastLoc, docs = loop 1 firstLoc [doc] nodes in - let forceBreak = - forceBreak || firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak docs + let firstLoc = getLoc node in + let doc = printComments (print node t 0) t firstLoc in + let lastLoc, docs = loop 1 firstLoc [ doc ] nodes in + let forceBreak = + forceBreak || firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak docs let rec printLongidentAux accu = function | Longident.Lident s -> Doc.text s :: accu | Ldot (lid, s) -> printLongidentAux (Doc.text s :: accu) lid | Lapply (lid1, lid2) -> - let d1 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid1) in - let d2 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid2) in - Doc.concat [d1; Doc.lparen; d2; Doc.rparen] :: accu + let d1 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid1) in + let d2 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid2) in + Doc.concat [ d1; Doc.lparen; d2; Doc.rparen ] :: accu let printLongident = function | Longident.Lident txt -> Doc.text txt @@ -53231,7 +53358,7 @@ let classifyIdentContent ?(allowUident = false) txt = let printIdentLike ?allowUident txt = match classifyIdentContent ?allowUident txt with - | ExoticIdent -> Doc.concat [Doc.text "\\\""; Doc.text txt; Doc.text "\""] + | ExoticIdent -> Doc.concat [ Doc.text "\\\""; Doc.text txt; Doc.text "\"" ] | NormalIdent -> Doc.text txt let rec unsafe_for_all_range s ~start ~finish p = @@ -53252,10 +53379,7 @@ let isValidNumericPolyvarNumber (x : string) = a <= 57 && if len > 1 then - a > 48 - && for_all_from x 1 (function - | '0' .. '9' -> true - | _ -> false) + a > 48 && for_all_from x 1 (function '0' .. '9' -> true | _ -> false) else a >= 48 (* Exotic identifiers in poly-vars have a "lighter" syntax: #"ease-in" *) @@ -53264,11 +53388,11 @@ let printPolyVarIdent txt = if isValidNumericPolyvarNumber txt then Doc.text txt else match classifyIdentContent ~allowUident:true txt with - | ExoticIdent -> Doc.concat [Doc.text "\""; Doc.text txt; Doc.text "\""] + | ExoticIdent -> Doc.concat [ Doc.text "\""; Doc.text txt; Doc.text "\"" ] | NormalIdent -> ( - match txt with - | "" -> Doc.concat [Doc.text "\""; Doc.text txt; Doc.text "\""] - | _ -> Doc.text txt) + match txt with + | "" -> Doc.concat [ Doc.text "\""; Doc.text txt; Doc.text "\"" ] + | _ -> Doc.text txt) let printLident l = let flatLidOpt lid = @@ -53282,18 +53406,18 @@ let printLident l = match l with | Longident.Lident txt -> printIdentLike txt | Longident.Ldot (path, txt) -> - let doc = - match flatLidOpt path with - | Some txts -> - Doc.concat - [ - Doc.join ~sep:Doc.dot (List.map Doc.text txts); - Doc.dot; - printIdentLike txt; - ] - | None -> Doc.text "printLident: Longident.Lapply is not supported" - in - doc + let doc = + match flatLidOpt path with + | Some txts -> + Doc.concat + [ + Doc.join ~sep:Doc.dot (List.map Doc.text txts); + Doc.dot; + printIdentLike txt; + ] + | None -> Doc.text "printLident: Longident.Lapply is not supported" + in + doc | Lapply (_, _) -> Doc.text "printLident: Longident.Lapply is not supported" let printLongidentLocation l cmtTbl = @@ -53321,42 +53445,42 @@ let printStringContents txt = let printConstant ?(templateLiteral = false) c = match c with | Parsetree.Pconst_integer (s, suffix) -> ( - match suffix with - | Some c -> Doc.text (s ^ Char.escaped c) - | None -> Doc.text s) + match suffix with + | Some c -> Doc.text (s ^ Char.escaped c) + | None -> Doc.text s) | Pconst_string (txt, None) -> - Doc.concat [Doc.text "\""; printStringContents txt; Doc.text "\""] + Doc.concat [ Doc.text "\""; printStringContents txt; Doc.text "\"" ] | Pconst_string (txt, Some prefix) -> - if prefix = "INTERNAL_RES_CHAR_CONTENTS" then - Doc.concat [Doc.text "'"; Doc.text txt; Doc.text "'"] - else - let lquote, rquote = - if templateLiteral then ("`", "`") else ("\"", "\"") - in - Doc.concat - [ - (if prefix = "js" then Doc.nil else Doc.text prefix); - Doc.text lquote; - printStringContents txt; - Doc.text rquote; - ] + if prefix = "INTERNAL_RES_CHAR_CONTENTS" then + Doc.concat [ Doc.text "'"; Doc.text txt; Doc.text "'" ] + else + let lquote, rquote = + if templateLiteral then ("`", "`") else ("\"", "\"") + in + Doc.concat + [ + (if prefix = "js" then Doc.nil else Doc.text prefix); + Doc.text lquote; + printStringContents txt; + Doc.text rquote; + ] | Pconst_float (s, _) -> Doc.text s | Pconst_char c -> - let str = - match Char.unsafe_chr c with - | '\'' -> "\\'" - | '\\' -> "\\\\" - | '\n' -> "\\n" - | '\t' -> "\\t" - | '\r' -> "\\r" - | '\b' -> "\\b" - | ' ' .. '~' as c -> - let s = (Bytes.create [@doesNotRaise]) 1 in - Bytes.unsafe_set s 0 c; - Bytes.unsafe_to_string s - | _ -> Res_utf8.encodeCodePoint c - in - Doc.text ("'" ^ str ^ "'") + let str = + match Char.unsafe_chr c with + | '\'' -> "\\'" + | '\\' -> "\\\\" + | '\n' -> "\\n" + | '\t' -> "\\t" + | '\r' -> "\\r" + | '\b' -> "\\b" + | ' ' .. '~' as c -> + let s = (Bytes.create [@doesNotRaise]) 1 in + Bytes.unsafe_set s 0 c; + Bytes.unsafe_to_string s + | _ -> Res_utf8.encodeCodePoint c + in + Doc.text ("'" ^ str ^ "'") let printOptionalLabel attrs = if Res_parsetree_viewer.hasOptionalAttribute attrs then Doc.text "?" @@ -53368,66 +53492,66 @@ let rec printStructure ~customLayout (s : Parsetree.structure) t = match s with | [] -> printCommentsInsideFile t | structure -> - printList - ~getLoc:(fun s -> s.Parsetree.pstr_loc) - ~nodes:structure - ~print:(printStructureItem ~customLayout) - t + printList + ~getLoc:(fun s -> s.Parsetree.pstr_loc) + ~nodes:structure + ~print:(printStructureItem ~customLayout) + t and printStructureItem ~customLayout (si : Parsetree.structure_item) cmtTbl = match si.pstr_desc with | Pstr_value (rec_flag, valueBindings) -> - let recFlag = - match rec_flag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - printValueBindings ~customLayout ~recFlag valueBindings cmtTbl + let recFlag = + match rec_flag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + printValueBindings ~customLayout ~recFlag valueBindings cmtTbl | Pstr_type (recFlag, typeDeclarations) -> - let recFlag = - match recFlag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - printTypeDeclarations ~customLayout ~recFlag typeDeclarations cmtTbl + let recFlag = + match recFlag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + printTypeDeclarations ~customLayout ~recFlag typeDeclarations cmtTbl | Pstr_primitive valueDescription -> - printValueDescription ~customLayout valueDescription cmtTbl + printValueDescription ~customLayout valueDescription cmtTbl | Pstr_eval (expr, attrs) -> - let exprDoc = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.structureExpr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat [printAttributes ~customLayout attrs cmtTbl; exprDoc] + let exprDoc = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.structureExpr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [ printAttributes ~customLayout attrs cmtTbl; exprDoc ] | Pstr_attribute attr -> - fst (printAttribute ~customLayout ~standalone:true attr cmtTbl) + fst (printAttribute ~customLayout ~standalone:true attr cmtTbl) | Pstr_extension (extension, attrs) -> - Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - Doc.concat - [printExtension ~customLayout ~atModuleLvl:true extension cmtTbl]; - ] + Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + Doc.concat + [ printExtension ~customLayout ~atModuleLvl:true extension cmtTbl ]; + ] | Pstr_include includeDeclaration -> - printIncludeDeclaration ~customLayout includeDeclaration cmtTbl + printIncludeDeclaration ~customLayout includeDeclaration cmtTbl | Pstr_open openDescription -> - printOpenDescription ~customLayout openDescription cmtTbl + printOpenDescription ~customLayout openDescription cmtTbl | Pstr_modtype modTypeDecl -> - printModuleTypeDeclaration ~customLayout modTypeDecl cmtTbl + printModuleTypeDeclaration ~customLayout modTypeDecl cmtTbl | Pstr_module moduleBinding -> - printModuleBinding ~customLayout ~isRec:false moduleBinding cmtTbl 0 + printModuleBinding ~customLayout ~isRec:false moduleBinding cmtTbl 0 | Pstr_recmodule moduleBindings -> - printListi - ~getLoc:(fun mb -> mb.Parsetree.pmb_loc) - ~nodes:moduleBindings - ~print:(printModuleBinding ~customLayout ~isRec:true) - cmtTbl + printListi + ~getLoc:(fun mb -> mb.Parsetree.pmb_loc) + ~nodes:moduleBindings + ~print:(printModuleBinding ~customLayout ~isRec:true) + cmtTbl | Pstr_exception extensionConstructor -> - printExceptionDef ~customLayout extensionConstructor cmtTbl + printExceptionDef ~customLayout extensionConstructor cmtTbl | Pstr_typext typeExtension -> - printTypeExtension ~customLayout typeExtension cmtTbl + printTypeExtension ~customLayout typeExtension cmtTbl | Pstr_class _ | Pstr_class_type _ -> Doc.nil and printTypeExtension ~customLayout (te : Parsetree.type_extension) cmtTbl = @@ -53439,13 +53563,14 @@ and printTypeExtension ~customLayout (te : Parsetree.type_extension) cmtTbl = let forceBreak = match (ecs, List.rev ecs) with | first :: _, last :: _ -> - first.pext_loc.loc_start.pos_lnum > te.ptyext_path.loc.loc_end.pos_lnum - || first.pext_loc.loc_start.pos_lnum < last.pext_loc.loc_end.pos_lnum + first.pext_loc.loc_start.pos_lnum + > te.ptyext_path.loc.loc_end.pos_lnum + || first.pext_loc.loc_start.pos_lnum < last.pext_loc.loc_end.pos_lnum | _ -> false in let privateFlag = match te.ptyext_private with - | Asttypes.Private -> Doc.concat [Doc.text "private"; Doc.line] + | Asttypes.Private -> Doc.concat [ Doc.text "private"; Doc.line ] | Public -> Doc.nil in let rows = @@ -53482,14 +53607,15 @@ and printModuleBinding ~customLayout ~isRec moduleBinding cmtTbl i = let prefix = if i = 0 then Doc.concat - [Doc.text "module "; (if isRec then Doc.text "rec " else Doc.nil)] + [ Doc.text "module "; (if isRec then Doc.text "rec " else Doc.nil) ] else Doc.text "and " in let modExprDoc, modConstraintDoc = match moduleBinding.pmb_expr with - | {pmod_desc = Pmod_constraint (modExpr, modType)} -> - ( printModExpr ~customLayout modExpr cmtTbl, - Doc.concat [Doc.text ": "; printModType ~customLayout modType cmtTbl] ) + | { pmod_desc = Pmod_constraint (modExpr, modType) } -> + ( printModExpr ~customLayout modExpr cmtTbl, + Doc.concat + [ Doc.text ": "; printModType ~customLayout modType cmtTbl ] ) | modExpr -> (printModExpr ~customLayout modExpr cmtTbl, Doc.nil) in let modName = @@ -53524,153 +53650,160 @@ and printModuleTypeDeclaration ~customLayout (match modTypeDecl.pmtd_type with | None -> Doc.nil | Some modType -> - Doc.concat [Doc.text " = "; printModType ~customLayout modType cmtTbl]); + Doc.concat + [ Doc.text " = "; printModType ~customLayout modType cmtTbl ]); ] and printModType ~customLayout modType cmtTbl = let modTypeDoc = match modType.pmty_desc with | Parsetree.Pmty_ident longident -> - Doc.concat - [ - printAttributes ~customLayout ~loc:longident.loc - modType.pmty_attributes cmtTbl; - printLongidentLocation longident cmtTbl; - ] + Doc.concat + [ + printAttributes ~customLayout ~loc:longident.loc + modType.pmty_attributes cmtTbl; + printLongidentLocation longident cmtTbl; + ] | Pmty_signature [] -> - if hasCommentsInside cmtTbl modType.pmty_loc then - let doc = printCommentsInside cmtTbl modType.pmty_loc in - Doc.concat [Doc.lbrace; doc; Doc.rbrace] - else - let shouldBreak = - modType.pmty_loc.loc_start.pos_lnum - < modType.pmty_loc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak:shouldBreak - (Doc.concat [Doc.lbrace; Doc.softLine; Doc.softLine; Doc.rbrace]) - | Pmty_signature signature -> - let signatureDoc = - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [Doc.line; printSignature ~customLayout signature cmtTbl]); - Doc.line; - Doc.rbrace; - ]) - in - Doc.concat - [ - printAttributes ~customLayout modType.pmty_attributes cmtTbl; - signatureDoc; - ] - | Pmty_functor _ -> - let parameters, returnType = ParsetreeViewer.functorType modType in - let parametersDoc = - match parameters with - | [] -> Doc.nil - | [(attrs, {Location.txt = "_"; loc}, Some modType)] -> - let cmtLoc = - {loc with loc_end = modType.Parsetree.pmty_loc.loc_end} - in - let attrs = printAttributes ~customLayout attrs cmtTbl in - let doc = - Doc.concat [attrs; printModType ~customLayout modType cmtTbl] + if hasCommentsInside cmtTbl modType.pmty_loc then + let doc = printCommentsInside cmtTbl modType.pmty_loc in + Doc.concat [ Doc.lbrace; doc; Doc.rbrace ] + else + let shouldBreak = + modType.pmty_loc.loc_start.pos_lnum + < modType.pmty_loc.loc_end.pos_lnum in - printComments doc cmtTbl cmtLoc - | params -> - Doc.group + Doc.breakableGroup ~forceBreak:shouldBreak + (Doc.concat [ Doc.lbrace; Doc.softLine; Doc.softLine; Doc.rbrace ]) + | Pmty_signature signature -> + let signatureDoc = + Doc.breakableGroup ~forceBreak:true (Doc.concat [ - Doc.lparen; + Doc.lbrace; Doc.indent (Doc.concat [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun (attrs, lbl, modType) -> - let cmtLoc = - match modType with - | None -> lbl.Asttypes.loc - | Some modType -> - { - lbl.Asttypes.loc with - loc_end = - modType.Parsetree.pmty_loc.loc_end; - } - in - let attrs = - printAttributes ~customLayout attrs cmtTbl - in - let lblDoc = - if lbl.Location.txt = "_" || lbl.txt = "*" then - Doc.nil - else - let doc = Doc.text lbl.txt in - printComments doc cmtTbl lbl.loc - in - let doc = - Doc.concat - [ - attrs; - lblDoc; - (match modType with - | None -> Doc.nil - | Some modType -> - Doc.concat - [ - (if lbl.txt = "_" then Doc.nil - else Doc.text ": "); - printModType ~customLayout modType - cmtTbl; - ]); - ] - in - printComments doc cmtTbl cmtLoc) - params); + Doc.line; printSignature ~customLayout signature cmtTbl; ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; + Doc.line; + Doc.rbrace; ]) - in - let returnDoc = - let doc = printModType ~customLayout returnType cmtTbl in - if Parens.modTypeFunctorReturn returnType then addParens doc else doc - in - Doc.group - (Doc.concat - [ - parametersDoc; - Doc.group (Doc.concat [Doc.text " =>"; Doc.line; returnDoc]); - ]) + in + Doc.concat + [ + printAttributes ~customLayout modType.pmty_attributes cmtTbl; + signatureDoc; + ] + | Pmty_functor _ -> + let parameters, returnType = ParsetreeViewer.functorType modType in + let parametersDoc = + match parameters with + | [] -> Doc.nil + | [ (attrs, { Location.txt = "_"; loc }, Some modType) ] -> + let cmtLoc = + { loc with loc_end = modType.Parsetree.pmty_loc.loc_end } + in + let attrs = printAttributes ~customLayout attrs cmtTbl in + let doc = + Doc.concat [ attrs; printModType ~customLayout modType cmtTbl ] + in + printComments doc cmtTbl cmtLoc + | params -> + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun (attrs, lbl, modType) -> + let cmtLoc = + match modType with + | None -> lbl.Asttypes.loc + | Some modType -> + { + lbl.Asttypes.loc with + loc_end = + modType.Parsetree.pmty_loc.loc_end; + } + in + let attrs = + printAttributes ~customLayout attrs cmtTbl + in + let lblDoc = + if lbl.Location.txt = "_" || lbl.txt = "*" + then Doc.nil + else + let doc = Doc.text lbl.txt in + printComments doc cmtTbl lbl.loc + in + let doc = + Doc.concat + [ + attrs; + lblDoc; + (match modType with + | None -> Doc.nil + | Some modType -> + Doc.concat + [ + (if lbl.txt = "_" then Doc.nil + else Doc.text ": "); + printModType ~customLayout + modType cmtTbl; + ]); + ] + in + printComments doc cmtTbl cmtLoc) + params); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) + in + let returnDoc = + let doc = printModType ~customLayout returnType cmtTbl in + if Parens.modTypeFunctorReturn returnType then addParens doc else doc + in + Doc.group + (Doc.concat + [ + parametersDoc; + Doc.group (Doc.concat [ Doc.text " =>"; Doc.line; returnDoc ]); + ]) | Pmty_typeof modExpr -> - Doc.concat - [Doc.text "module type of "; printModExpr ~customLayout modExpr cmtTbl] + Doc.concat + [ + Doc.text "module type of "; + printModExpr ~customLayout modExpr cmtTbl; + ] | Pmty_extension extension -> - printExtension ~customLayout ~atModuleLvl:false extension cmtTbl + printExtension ~customLayout ~atModuleLvl:false extension cmtTbl | Pmty_alias longident -> - Doc.concat [Doc.text "module "; printLongidentLocation longident cmtTbl] + Doc.concat + [ Doc.text "module "; printLongidentLocation longident cmtTbl ] | Pmty_with (modType, withConstraints) -> - let operand = - let doc = printModType ~customLayout modType cmtTbl in - if Parens.modTypeWithOperand modType then addParens doc else doc - in - Doc.group - (Doc.concat - [ - operand; - Doc.indent - (Doc.concat - [ - Doc.line; - printWithConstraints ~customLayout withConstraints cmtTbl; - ]); - ]) + let operand = + let doc = printModType ~customLayout modType cmtTbl in + if Parens.modTypeWithOperand modType then addParens doc else doc + in + Doc.group + (Doc.concat + [ + operand; + Doc.indent + (Doc.concat + [ + Doc.line; + printWithConstraints ~customLayout withConstraints cmtTbl; + ]); + ]) in let attrsAlreadyPrinted = match modType.pmty_desc with @@ -53706,78 +53839,78 @@ and printWithConstraint ~customLayout match withConstraint with (* with type X.t = ... *) | Pwith_type (longident, typeDeclaration) -> - Doc.group - (printTypeDeclaration ~customLayout - ~name:(printLidentPath longident cmtTbl) - ~equalSign:"=" ~recFlag:Doc.nil 0 typeDeclaration CommentTable.empty) + Doc.group + (printTypeDeclaration ~customLayout + ~name:(printLidentPath longident cmtTbl) + ~equalSign:"=" ~recFlag:Doc.nil 0 typeDeclaration CommentTable.empty) (* with module X.Y = Z *) - | Pwith_module ({txt = longident1}, {txt = longident2}) -> - Doc.concat - [ - Doc.text "module "; - printLongident longident1; - Doc.text " ="; - Doc.indent (Doc.concat [Doc.line; printLongident longident2]); - ] + | Pwith_module ({ txt = longident1 }, { txt = longident2 }) -> + Doc.concat + [ + Doc.text "module "; + printLongident longident1; + Doc.text " ="; + Doc.indent (Doc.concat [ Doc.line; printLongident longident2 ]); + ] (* with type X.t := ..., same format as [Pwith_type] *) | Pwith_typesubst (longident, typeDeclaration) -> - Doc.group - (printTypeDeclaration ~customLayout - ~name:(printLidentPath longident cmtTbl) - ~equalSign:":=" ~recFlag:Doc.nil 0 typeDeclaration CommentTable.empty) - | Pwith_modsubst ({txt = longident1}, {txt = longident2}) -> - Doc.concat - [ - Doc.text "module "; - printLongident longident1; - Doc.text " :="; - Doc.indent (Doc.concat [Doc.line; printLongident longident2]); - ] + Doc.group + (printTypeDeclaration ~customLayout + ~name:(printLidentPath longident cmtTbl) + ~equalSign:":=" ~recFlag:Doc.nil 0 typeDeclaration CommentTable.empty) + | Pwith_modsubst ({ txt = longident1 }, { txt = longident2 }) -> + Doc.concat + [ + Doc.text "module "; + printLongident longident1; + Doc.text " :="; + Doc.indent (Doc.concat [ Doc.line; printLongident longident2 ]); + ] and printSignature ~customLayout signature cmtTbl = match signature with | [] -> printCommentsInsideFile cmtTbl | signature -> - printList - ~getLoc:(fun s -> s.Parsetree.psig_loc) - ~nodes:signature - ~print:(printSignatureItem ~customLayout) - cmtTbl + printList + ~getLoc:(fun s -> s.Parsetree.psig_loc) + ~nodes:signature + ~print:(printSignatureItem ~customLayout) + cmtTbl and printSignatureItem ~customLayout (si : Parsetree.signature_item) cmtTbl = match si.psig_desc with | Parsetree.Psig_value valueDescription -> - printValueDescription ~customLayout valueDescription cmtTbl + printValueDescription ~customLayout valueDescription cmtTbl | Psig_type (recFlag, typeDeclarations) -> - let recFlag = - match recFlag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - printTypeDeclarations ~customLayout ~recFlag typeDeclarations cmtTbl + let recFlag = + match recFlag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + printTypeDeclarations ~customLayout ~recFlag typeDeclarations cmtTbl | Psig_typext typeExtension -> - printTypeExtension ~customLayout typeExtension cmtTbl + printTypeExtension ~customLayout typeExtension cmtTbl | Psig_exception extensionConstructor -> - printExceptionDef ~customLayout extensionConstructor cmtTbl + printExceptionDef ~customLayout extensionConstructor cmtTbl | Psig_module moduleDeclaration -> - printModuleDeclaration ~customLayout moduleDeclaration cmtTbl + printModuleDeclaration ~customLayout moduleDeclaration cmtTbl | Psig_recmodule moduleDeclarations -> - printRecModuleDeclarations ~customLayout moduleDeclarations cmtTbl + printRecModuleDeclarations ~customLayout moduleDeclarations cmtTbl | Psig_modtype modTypeDecl -> - printModuleTypeDeclaration ~customLayout modTypeDecl cmtTbl + printModuleTypeDeclaration ~customLayout modTypeDecl cmtTbl | Psig_open openDescription -> - printOpenDescription ~customLayout openDescription cmtTbl + printOpenDescription ~customLayout openDescription cmtTbl | Psig_include includeDescription -> - printIncludeDescription ~customLayout includeDescription cmtTbl + printIncludeDescription ~customLayout includeDescription cmtTbl | Psig_attribute attr -> - fst (printAttribute ~customLayout ~standalone:true attr cmtTbl) + fst (printAttribute ~customLayout ~standalone:true attr cmtTbl) | Psig_extension (extension, attrs) -> - Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - Doc.concat - [printExtension ~customLayout ~atModuleLvl:true extension cmtTbl]; - ] + Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + Doc.concat + [ printExtension ~customLayout ~atModuleLvl:true extension cmtTbl ]; + ] | Psig_class _ | Psig_class_type _ -> Doc.nil and printRecModuleDeclarations ~customLayout moduleDeclarations cmtTbl = @@ -53791,23 +53924,22 @@ and printRecModuleDeclaration ~customLayout md cmtTbl i = let body = match md.pmd_type.pmty_desc with | Parsetree.Pmty_alias longident -> - Doc.concat [Doc.text " = "; printLongidentLocation longident cmtTbl] + Doc.concat [ Doc.text " = "; printLongidentLocation longident cmtTbl ] | _ -> - let needsParens = - match md.pmd_type.pmty_desc with - | Pmty_with _ -> true - | _ -> false - in - let modTypeDoc = - let doc = printModType ~customLayout md.pmd_type cmtTbl in - if needsParens then addParens doc else doc - in - Doc.concat [Doc.text ": "; modTypeDoc] + let needsParens = + match md.pmd_type.pmty_desc with Pmty_with _ -> true | _ -> false + in + let modTypeDoc = + let doc = printModType ~customLayout md.pmd_type cmtTbl in + if needsParens then addParens doc else doc + in + Doc.concat [ Doc.text ": "; modTypeDoc ] in let prefix = if i < 1 then "module rec " else "and " in Doc.concat [ - printAttributes ~customLayout ~loc:md.pmd_name.loc md.pmd_attributes cmtTbl; + printAttributes ~customLayout ~loc:md.pmd_name.loc md.pmd_attributes + cmtTbl; Doc.text prefix; printComments (Doc.text md.pmd_name.txt) cmtTbl md.pmd_name.loc; body; @@ -53818,13 +53950,15 @@ and printModuleDeclaration ~customLayout (md : Parsetree.module_declaration) let body = match md.pmd_type.pmty_desc with | Parsetree.Pmty_alias longident -> - Doc.concat [Doc.text " = "; printLongidentLocation longident cmtTbl] + Doc.concat [ Doc.text " = "; printLongidentLocation longident cmtTbl ] | _ -> - Doc.concat [Doc.text ": "; printModType ~customLayout md.pmd_type cmtTbl] + Doc.concat + [ Doc.text ": "; printModType ~customLayout md.pmd_type cmtTbl ] in Doc.concat [ - printAttributes ~customLayout ~loc:md.pmd_name.loc md.pmd_attributes cmtTbl; + printAttributes ~customLayout ~loc:md.pmd_name.loc md.pmd_attributes + cmtTbl; Doc.text "module "; printComments (Doc.text md.pmd_name.txt) cmtTbl md.pmd_name.loc; body; @@ -53875,9 +54009,7 @@ and printValueBindings ~customLayout ~recFlag and printValueDescription ~customLayout valueDescription cmtTbl = let isExternal = - match valueDescription.pval_prim with - | [] -> false - | _ -> true + match valueDescription.pval_prim with [] -> false | _ -> true in let attrs = printAttributes ~customLayout ~loc:valueDescription.pval_name.loc @@ -53907,7 +54039,7 @@ and printValueDescription ~customLayout valueDescription cmtTbl = (List.map (fun s -> Doc.concat - [Doc.text "\""; Doc.text s; Doc.text "\""]) + [ Doc.text "\""; Doc.text s; Doc.text "\"" ]) valueDescription.pval_prim); ]); ]) @@ -53959,72 +54091,72 @@ and printTypeDeclaration ~customLayout ~name ~equalSign ~recFlag i printAttributes ~customLayout ~loc:td.ptype_loc td.ptype_attributes cmtTbl in let prefix = - if i > 0 then Doc.text "and " else Doc.concat [Doc.text "type "; recFlag] + if i > 0 then Doc.text "and " else Doc.concat [ Doc.text "type "; recFlag ] in let typeName = name in let typeParams = printTypeParams ~customLayout td.ptype_params cmtTbl in let manifestAndKind = match td.ptype_kind with | Ptype_abstract -> ( - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> + Doc.concat + [ + Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + printPrivateFlag td.ptype_private; + printTypExpr ~customLayout typ cmtTbl; + ]) + | Ptype_open -> Doc.concat [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; printPrivateFlag td.ptype_private; - printTypExpr ~customLayout typ cmtTbl; - ]) - | Ptype_open -> - Doc.concat - [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - Doc.text ".."; - ] + Doc.text ".."; + ] | Ptype_record lds -> - let manifest = - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr ~customLayout typ cmtTbl; - ] - in - Doc.concat - [ - manifest; - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - printRecordDeclaration ~customLayout lds cmtTbl; - ] + let manifest = + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> + Doc.concat + [ + Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + printTypExpr ~customLayout typ cmtTbl; + ] + in + Doc.concat + [ + manifest; + Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + printPrivateFlag td.ptype_private; + printRecordDeclaration ~customLayout lds cmtTbl; + ] | Ptype_variant cds -> - let manifest = - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr ~customLayout typ cmtTbl; - ] - in - Doc.concat - [ - manifest; - Doc.concat [Doc.space; Doc.text equalSign]; - printConstructorDeclarations ~customLayout - ~privateFlag:td.ptype_private cds cmtTbl; - ] + let manifest = + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> + Doc.concat + [ + Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + printTypExpr ~customLayout typ cmtTbl; + ] + in + Doc.concat + [ + manifest; + Doc.concat [ Doc.space; Doc.text equalSign ]; + printConstructorDeclarations ~customLayout + ~privateFlag:td.ptype_private cds cmtTbl; + ] in let constraints = printTypeDefinitionConstraints ~customLayout td.ptype_cstrs in Doc.group (Doc.concat - [attrs; prefix; typeName; typeParams; manifestAndKind; constraints]) + [ attrs; prefix; typeName; typeParams; manifestAndKind; constraints ]) and printTypeDeclaration2 ~customLayout ~recFlag (td : Parsetree.type_declaration) cmtTbl i = @@ -54037,99 +54169,99 @@ and printTypeDeclaration2 ~customLayout ~recFlag printAttributes ~customLayout ~loc:td.ptype_loc td.ptype_attributes cmtTbl in let prefix = - if i > 0 then Doc.text "and " else Doc.concat [Doc.text "type "; recFlag] + if i > 0 then Doc.text "and " else Doc.concat [ Doc.text "type "; recFlag ] in let typeName = name in let typeParams = printTypeParams ~customLayout td.ptype_params cmtTbl in let manifestAndKind = match td.ptype_kind with | Ptype_abstract -> ( - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - printTypExpr ~customLayout typ cmtTbl; - ]) + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> + Doc.concat + [ + Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + printPrivateFlag td.ptype_private; + printTypExpr ~customLayout typ cmtTbl; + ]) | Ptype_open -> - Doc.concat - [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - Doc.text ".."; - ] - | Ptype_record lds -> - if lds = [] then Doc.concat [ - Doc.space; - Doc.text equalSign; - Doc.space; - Doc.lbrace; - printCommentsInside cmtTbl td.ptype_loc; - Doc.rbrace; + Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + printPrivateFlag td.ptype_private; + Doc.text ".."; ] - else + | Ptype_record lds -> + if lds = [] then + Doc.concat + [ + Doc.space; + Doc.text equalSign; + Doc.space; + Doc.lbrace; + printCommentsInside cmtTbl td.ptype_loc; + Doc.rbrace; + ] + else + let manifest = + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> + Doc.concat + [ + Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + printTypExpr ~customLayout typ cmtTbl; + ] + in + Doc.concat + [ + manifest; + Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + printPrivateFlag td.ptype_private; + printRecordDeclaration ~customLayout lds cmtTbl; + ] + | Ptype_variant cds -> let manifest = match td.ptype_manifest with | None -> Doc.nil | Some typ -> - Doc.concat - [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr ~customLayout typ cmtTbl; - ] + Doc.concat + [ + Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + printTypExpr ~customLayout typ cmtTbl; + ] in Doc.concat [ manifest; - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - printRecordDeclaration ~customLayout lds cmtTbl; + Doc.concat [ Doc.space; Doc.text equalSign ]; + printConstructorDeclarations ~customLayout + ~privateFlag:td.ptype_private cds cmtTbl; ] - | Ptype_variant cds -> - let manifest = - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr ~customLayout typ cmtTbl; - ] - in - Doc.concat - [ - manifest; - Doc.concat [Doc.space; Doc.text equalSign]; - printConstructorDeclarations ~customLayout - ~privateFlag:td.ptype_private cds cmtTbl; - ] in let constraints = printTypeDefinitionConstraints ~customLayout td.ptype_cstrs in Doc.group (Doc.concat - [attrs; prefix; typeName; typeParams; manifestAndKind; constraints]) + [ attrs; prefix; typeName; typeParams; manifestAndKind; constraints ]) and printTypeDefinitionConstraints ~customLayout cstrs = match cstrs with | [] -> Doc.nil | cstrs -> - Doc.indent - (Doc.group - (Doc.concat - [ - Doc.line; - Doc.group - (Doc.join ~sep:Doc.line - (List.map - (printTypeDefinitionConstraint ~customLayout) - cstrs)); - ])) + Doc.indent + (Doc.group + (Doc.concat + [ + Doc.line; + Doc.group + (Doc.join ~sep:Doc.line + (List.map + (printTypeDefinitionConstraint ~customLayout) + cstrs)); + ])) and printTypeDefinitionConstraint ~customLayout ((typ1, typ2, _loc) : @@ -54143,37 +54275,35 @@ and printTypeDefinitionConstraint ~customLayout ] and printPrivateFlag (flag : Asttypes.private_flag) = - match flag with - | Private -> Doc.text "private " - | Public -> Doc.nil + match flag with Private -> Doc.text "private " | Public -> Doc.nil and printTypeParams ~customLayout typeParams cmtTbl = match typeParams with | [] -> Doc.nil | typeParams -> - Doc.group - (Doc.concat - [ - Doc.lessThan; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun typeParam -> - let doc = - printTypeParam ~customLayout typeParam cmtTbl - in - printComments doc cmtTbl - (fst typeParam).Parsetree.ptyp_loc) - typeParams); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.greaterThan; - ]) + Doc.group + (Doc.concat + [ + Doc.lessThan; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun typeParam -> + let doc = + printTypeParam ~customLayout typeParam cmtTbl + in + printComments doc cmtTbl + (fst typeParam).Parsetree.ptyp_loc) + typeParams); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.greaterThan; + ]) and printTypeParam ~customLayout (param : Parsetree.core_type * Asttypes.variance) cmtTbl = @@ -54184,14 +54314,14 @@ and printTypeParam ~customLayout | Contravariant -> Doc.text "-" | Invariant -> Doc.nil in - Doc.concat [printedVariance; printTypExpr ~customLayout typ cmtTbl] + Doc.concat [ printedVariance; printTypExpr ~customLayout typ cmtTbl ] and printRecordDeclaration ~customLayout (lds : Parsetree.label_declaration list) cmtTbl = let forceBreak = match (lds, List.rev lds) with | first :: _, last :: _ -> - first.pld_loc.loc_start.pos_lnum < last.pld_loc.loc_end.pos_lnum + first.pld_loc.loc_start.pos_lnum < last.pld_loc.loc_end.pos_lnum | _ -> false in Doc.breakableGroup ~forceBreak @@ -54203,7 +54333,7 @@ and printRecordDeclaration ~customLayout [ Doc.softLine; Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) (List.map (fun ld -> let doc = @@ -54222,12 +54352,12 @@ and printConstructorDeclarations ~customLayout ~privateFlag let forceBreak = match (cds, List.rev cds) with | first :: _, last :: _ -> - first.pcd_loc.loc_start.pos_lnum < last.pcd_loc.loc_end.pos_lnum + first.pcd_loc.loc_start.pos_lnum < last.pcd_loc.loc_end.pos_lnum | _ -> false in let privateFlag = match privateFlag with - | Asttypes.Private -> Doc.concat [Doc.text "private"; Doc.line] + | Asttypes.Private -> Doc.concat [ Doc.text "private"; Doc.line ] | Public -> Doc.nil in let rows = @@ -54240,7 +54370,7 @@ and printConstructorDeclarations ~customLayout ~privateFlag ~forceBreak cmtTbl in Doc.breakableGroup ~forceBreak - (Doc.indent (Doc.concat [Doc.line; privateFlag; rows])) + (Doc.indent (Doc.concat [ Doc.line; privateFlag; rows ])) and printConstructorDeclaration2 ~customLayout i (cd : Parsetree.constructor_declaration) cmtTbl = @@ -54260,8 +54390,8 @@ and printConstructorDeclaration2 ~customLayout i match cd.pcd_res with | None -> Doc.nil | Some typ -> - Doc.indent - (Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ cmtTbl]) + Doc.indent + (Doc.concat [ Doc.text ": "; printTypExpr ~customLayout typ cmtTbl ]) in Doc.concat [ @@ -54282,54 +54412,55 @@ and printConstructorArguments ~customLayout ~indent match cdArgs with | Pcstr_tuple [] -> Doc.nil | Pcstr_tuple types -> - let args = - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun typexpr -> printTypExpr ~customLayout typexpr cmtTbl) - types); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - in - Doc.group (if indent then Doc.indent args else args) + let args = + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun typexpr -> + printTypExpr ~customLayout typexpr cmtTbl) + types); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + in + Doc.group (if indent then Doc.indent args else args) | Pcstr_record lds -> - let args = - Doc.concat - [ - Doc.lparen; - (* manually inline the printRecordDeclaration, gives better layout *) - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun ld -> - let doc = - printLabelDeclaration ~customLayout ld cmtTbl - in - printComments doc cmtTbl ld.Parsetree.pld_loc) - lds); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - Doc.rparen; - ] - in - if indent then Doc.indent args else args + let args = + Doc.concat + [ + Doc.lparen; + (* manually inline the printRecordDeclaration, gives better layout *) + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun ld -> + let doc = + printLabelDeclaration ~customLayout ld cmtTbl + in + printComments doc cmtTbl ld.Parsetree.pld_loc) + lds); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + Doc.rparen; + ] + in + if indent then Doc.indent args else args and printLabelDeclaration ~customLayout (ld : Parsetree.label_declaration) cmtTbl = @@ -54362,242 +54493,261 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = match typExpr.ptyp_desc with | Ptyp_any -> Doc.text "_" | Ptyp_var var -> - Doc.concat [Doc.text "'"; printIdentLike ~allowUident:true var] + Doc.concat [ Doc.text "'"; printIdentLike ~allowUident:true var ] | Ptyp_extension extension -> - printExtension ~customLayout ~atModuleLvl:false extension cmtTbl + printExtension ~customLayout ~atModuleLvl:false extension cmtTbl | Ptyp_alias (typ, alias) -> - let typ = - (* Technically type t = (string, float) => unit as 'x, doesn't require - * parens around the arrow expression. This is very confusing though. - * Is the "as" part of "unit" or "(string, float) => unit". By printing - * parens we guide the user towards its meaning.*) - let needsParens = - match typ.ptyp_desc with - | Ptyp_arrow _ -> true - | _ -> false + let typ = + (* Technically type t = (string, float) => unit as 'x, doesn't require + * parens around the arrow expression. This is very confusing though. + * Is the "as" part of "unit" or "(string, float) => unit". By printing + * parens we guide the user towards its meaning.*) + let needsParens = + match typ.ptyp_desc with Ptyp_arrow _ -> true | _ -> false + in + let doc = printTypExpr ~customLayout typ cmtTbl in + if needsParens then Doc.concat [ Doc.lparen; doc; Doc.rparen ] + else doc in - let doc = printTypExpr ~customLayout typ cmtTbl in - if needsParens then Doc.concat [Doc.lparen; doc; Doc.rparen] else doc - in - Doc.concat - [typ; Doc.text " as "; Doc.concat [Doc.text "'"; printIdentLike alias]] + Doc.concat + [ + typ; + Doc.text " as "; + Doc.concat [ Doc.text "'"; printIdentLike alias ]; + ] (* object printings *) | Ptyp_object (fields, openFlag) -> - printObject ~customLayout ~inline:false fields openFlag cmtTbl - | Ptyp_constr (longidentLoc, [{ptyp_desc = Ptyp_object (fields, openFlag)}]) + printObject ~customLayout ~inline:false fields openFlag cmtTbl + | Ptyp_constr + (longidentLoc, [ { ptyp_desc = Ptyp_object (fields, openFlag) } ]) -> + (* for foo<{"a": b}>, when the object is long and needs a line break, we + want the <{ and }> to stay hugged together *) + let constrName = printLidentPath longidentLoc cmtTbl in + Doc.concat + [ + constrName; + Doc.lessThan; + printObject ~customLayout ~inline:true fields openFlag cmtTbl; + Doc.greaterThan; + ] + | Ptyp_constr (longidentLoc, [ { ptyp_desc = Parsetree.Ptyp_tuple tuple } ]) -> - (* for foo<{"a": b}>, when the object is long and needs a line break, we - want the <{ and }> to stay hugged together *) - let constrName = printLidentPath longidentLoc cmtTbl in - Doc.concat - [ - constrName; - Doc.lessThan; - printObject ~customLayout ~inline:true fields openFlag cmtTbl; - Doc.greaterThan; - ] - | Ptyp_constr (longidentLoc, [{ptyp_desc = Parsetree.Ptyp_tuple tuple}]) -> - let constrName = printLidentPath longidentLoc cmtTbl in - Doc.group - (Doc.concat - [ - constrName; - Doc.lessThan; - printTupleType ~customLayout ~inline:true tuple cmtTbl; - Doc.greaterThan; - ]) - | Ptyp_constr (longidentLoc, constrArgs) -> ( - let constrName = printLidentPath longidentLoc cmtTbl in - match constrArgs with - | [] -> constrName - | _args -> + let constrName = printLidentPath longidentLoc cmtTbl in Doc.group (Doc.concat [ constrName; Doc.lessThan; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun typexpr -> - printTypExpr ~customLayout typexpr cmtTbl) - constrArgs); - ]); - Doc.trailingComma; - Doc.softLine; + printTupleType ~customLayout ~inline:true tuple cmtTbl; Doc.greaterThan; - ])) + ]) + | Ptyp_constr (longidentLoc, constrArgs) -> ( + let constrName = printLidentPath longidentLoc cmtTbl in + match constrArgs with + | [] -> constrName + | _args -> + Doc.group + (Doc.concat + [ + constrName; + Doc.lessThan; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun typexpr -> + printTypExpr ~customLayout typexpr cmtTbl) + constrArgs); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.greaterThan; + ])) | Ptyp_arrow _ -> ( - let attrsBefore, args, returnType = ParsetreeViewer.arrowType typExpr in - let returnTypeNeedsParens = - match returnType.ptyp_desc with - | Ptyp_alias _ -> true - | _ -> false - in - let returnDoc = - let doc = printTypExpr ~customLayout returnType cmtTbl in - if returnTypeNeedsParens then Doc.concat [Doc.lparen; doc; Doc.rparen] - else doc - in - let isUncurried, attrs = - ParsetreeViewer.processUncurriedAttribute attrsBefore - in - match args with - | [] -> Doc.nil - | [([], Nolabel, n)] when not isUncurried -> - let hasAttrsBefore = not (attrs = []) in - let attrs = - if hasAttrsBefore then - printAttributes ~customLayout ~inline:true attrsBefore cmtTbl - else Doc.nil + let attrsBefore, args, returnType = ParsetreeViewer.arrowType typExpr in + let returnTypeNeedsParens = + match returnType.ptyp_desc with Ptyp_alias _ -> true | _ -> false in - let typDoc = - let doc = printTypExpr ~customLayout n cmtTbl in - match n.ptyp_desc with - | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> addParens doc - | _ -> doc + let returnDoc = + let doc = printTypExpr ~customLayout returnType cmtTbl in + if returnTypeNeedsParens then + Doc.concat [ Doc.lparen; doc; Doc.rparen ] + else doc in - Doc.group - (Doc.concat - [ - Doc.group attrs; - Doc.group - (if hasAttrsBefore then - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [Doc.softLine; typDoc; Doc.text " => "; returnDoc]); - Doc.softLine; - Doc.rparen; - ] - else Doc.concat [typDoc; Doc.text " => "; returnDoc]); - ]) - | args -> - let attrs = printAttributes ~customLayout ~inline:true attrs cmtTbl in - let renderedArgs = - Doc.concat - [ - attrs; - Doc.text "("; - Doc.indent - (Doc.concat - [ - Doc.softLine; - (if isUncurried then Doc.concat [Doc.dot; Doc.space] - else Doc.nil); - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun tp -> printTypeParameter ~customLayout tp cmtTbl) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.text ")"; - ] + let isUncurried, attrs = + ParsetreeViewer.processUncurriedAttribute attrsBefore in - Doc.group (Doc.concat [renderedArgs; Doc.text " => "; returnDoc])) + match args with + | [] -> Doc.nil + | [ ([], Nolabel, n) ] when not isUncurried -> + let hasAttrsBefore = not (attrs = []) in + let attrs = + if hasAttrsBefore then + printAttributes ~customLayout ~inline:true attrsBefore cmtTbl + else Doc.nil + in + let typDoc = + let doc = printTypExpr ~customLayout n cmtTbl in + match n.ptyp_desc with + | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> addParens doc + | _ -> doc + in + Doc.group + (Doc.concat + [ + Doc.group attrs; + Doc.group + (if hasAttrsBefore then + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + typDoc; + Doc.text " => "; + returnDoc; + ]); + Doc.softLine; + Doc.rparen; + ] + else Doc.concat [ typDoc; Doc.text " => "; returnDoc ]); + ]) + | args -> + let attrs = + printAttributes ~customLayout ~inline:true attrs cmtTbl + in + let renderedArgs = + Doc.concat + [ + attrs; + Doc.text "("; + Doc.indent + (Doc.concat + [ + Doc.softLine; + (if isUncurried then Doc.concat [ Doc.dot; Doc.space ] + else Doc.nil); + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun tp -> + printTypeParameter ~customLayout tp cmtTbl) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.text ")"; + ] + in + Doc.group (Doc.concat [ renderedArgs; Doc.text " => "; returnDoc ])) | Ptyp_tuple types -> - printTupleType ~customLayout ~inline:false types cmtTbl + printTupleType ~customLayout ~inline:false types cmtTbl | Ptyp_poly ([], typ) -> printTypExpr ~customLayout typ cmtTbl | Ptyp_poly (stringLocs, typ) -> - Doc.concat - [ - Doc.join ~sep:Doc.space - (List.map - (fun {Location.txt; loc} -> - let doc = Doc.concat [Doc.text "'"; Doc.text txt] in - printComments doc cmtTbl loc) - stringLocs); - Doc.dot; - Doc.space; - printTypExpr ~customLayout typ cmtTbl; - ] + Doc.concat + [ + Doc.join ~sep:Doc.space + (List.map + (fun { Location.txt; loc } -> + let doc = Doc.concat [ Doc.text "'"; Doc.text txt ] in + printComments doc cmtTbl loc) + stringLocs); + Doc.dot; + Doc.space; + printTypExpr ~customLayout typ cmtTbl; + ] | Ptyp_package packageType -> - printPackageType ~customLayout ~printModuleKeywordAndParens:true - packageType cmtTbl + printPackageType ~customLayout ~printModuleKeywordAndParens:true + packageType cmtTbl | Ptyp_class _ -> Doc.text "classes are not supported in types" | Ptyp_variant (rowFields, closedFlag, labelsOpt) -> - let forceBreak = - typExpr.ptyp_loc.Location.loc_start.pos_lnum - < typExpr.ptyp_loc.loc_end.pos_lnum - in - let printRowField = function - | Parsetree.Rtag ({txt; loc}, attrs, true, []) -> - let doc = - Doc.group - (Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - Doc.concat [Doc.text "#"; printPolyVarIdent txt]; - ]) - in - printComments doc cmtTbl loc - | Rtag ({txt}, attrs, truth, types) -> - let doType t = - match t.Parsetree.ptyp_desc with - | Ptyp_tuple _ -> printTypExpr ~customLayout t cmtTbl - | _ -> + let forceBreak = + typExpr.ptyp_loc.Location.loc_start.pos_lnum + < typExpr.ptyp_loc.loc_end.pos_lnum + in + let printRowField = function + | Parsetree.Rtag ({ txt; loc }, attrs, true, []) -> + let doc = + Doc.group + (Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + Doc.concat [ Doc.text "#"; printPolyVarIdent txt ]; + ]) + in + printComments doc cmtTbl loc + | Rtag ({ txt }, attrs, truth, types) -> + let doType t = + match t.Parsetree.ptyp_desc with + | Ptyp_tuple _ -> printTypExpr ~customLayout t cmtTbl + | _ -> + Doc.concat + [ + Doc.lparen; + printTypExpr ~customLayout t cmtTbl; + Doc.rparen; + ] + in + let printedTypes = List.map doType types in + let cases = + Doc.join + ~sep:(Doc.concat [ Doc.line; Doc.text "& " ]) + printedTypes + in + let cases = + if truth then Doc.concat [ Doc.line; Doc.text "& "; cases ] + else cases + in + Doc.group + (Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + Doc.concat [ Doc.text "#"; printPolyVarIdent txt ]; + cases; + ]) + | Rinherit coreType -> printTypExpr ~customLayout coreType cmtTbl + in + let docs = List.map printRowField rowFields in + let cases = + Doc.join ~sep:(Doc.concat [ Doc.line; Doc.text "| " ]) docs + in + let cases = + if docs = [] then cases + else Doc.concat [ Doc.ifBreaks (Doc.text "| ") Doc.nil; cases ] + in + let openingSymbol = + if closedFlag = Open then Doc.concat [ Doc.greaterThan; Doc.line ] + else if labelsOpt = None then Doc.softLine + else Doc.concat [ Doc.lessThan; Doc.line ] + in + let labels = + match labelsOpt with + | None | Some [] -> Doc.nil + | Some labels -> Doc.concat - [Doc.lparen; printTypExpr ~customLayout t cmtTbl; Doc.rparen] - in - let printedTypes = List.map doType types in - let cases = - Doc.join ~sep:(Doc.concat [Doc.line; Doc.text "& "]) printedTypes - in - let cases = - if truth then Doc.concat [Doc.line; Doc.text "& "; cases] else cases - in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - Doc.concat [Doc.text "#"; printPolyVarIdent txt]; - cases; - ]) - | Rinherit coreType -> printTypExpr ~customLayout coreType cmtTbl - in - let docs = List.map printRowField rowFields in - let cases = Doc.join ~sep:(Doc.concat [Doc.line; Doc.text "| "]) docs in - let cases = - if docs = [] then cases - else Doc.concat [Doc.ifBreaks (Doc.text "| ") Doc.nil; cases] - in - let openingSymbol = - if closedFlag = Open then Doc.concat [Doc.greaterThan; Doc.line] - else if labelsOpt = None then Doc.softLine - else Doc.concat [Doc.lessThan; Doc.line] - in - let labels = - match labelsOpt with - | None | Some [] -> Doc.nil - | Some labels -> - Doc.concat - (List.map - (fun label -> - Doc.concat [Doc.line; Doc.text "#"; printPolyVarIdent label]) - labels) - in - let closingSymbol = - match labelsOpt with - | None | Some [] -> Doc.nil - | _ -> Doc.text " >" - in - Doc.breakableGroup ~forceBreak - (Doc.concat - [ - Doc.lbracket; - Doc.indent - (Doc.concat [openingSymbol; cases; closingSymbol; labels]); - Doc.softLine; - Doc.rbracket; - ]) + (List.map + (fun label -> + Doc.concat + [ Doc.line; Doc.text "#"; printPolyVarIdent label ]) + labels) + in + let closingSymbol = + match labelsOpt with None | Some [] -> Doc.nil | _ -> Doc.text " >" + in + Doc.breakableGroup ~forceBreak + (Doc.concat + [ + Doc.lbracket; + Doc.indent + (Doc.concat [ openingSymbol; cases; closingSymbol; labels ]); + Doc.softLine; + Doc.rbracket; + ]) in let shouldPrintItsOwnAttributes = match typExpr.ptyp_desc with @@ -54607,8 +54757,9 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = let doc = match typExpr.ptyp_attributes with | _ :: _ as attrs when not shouldPrintItsOwnAttributes -> - Doc.group - (Doc.concat [printAttributes ~customLayout attrs cmtTbl; renderedType]) + Doc.group + (Doc.concat + [ printAttributes ~customLayout attrs cmtTbl; renderedType ]) | _ -> renderedType in printComments doc cmtTbl typExpr.ptyp_loc @@ -54617,40 +54768,41 @@ and printObject ~customLayout ~inline fields openFlag cmtTbl = let doc = match fields with | [] -> - Doc.concat - [ - Doc.lbrace; - (match openFlag with - | Asttypes.Closed -> Doc.dot - | Open -> Doc.dotdot); - Doc.rbrace; - ] + Doc.concat + [ + Doc.lbrace; + (match openFlag with + | Asttypes.Closed -> Doc.dot + | Open -> Doc.dotdot); + Doc.rbrace; + ] | fields -> - Doc.concat - [ - Doc.lbrace; - (match openFlag with - | Asttypes.Closed -> Doc.nil - | Open -> ( - match fields with - (* handle `type t = {.. ...objType, "x": int}` - * .. and ... should have a space in between *) - | Oinherit _ :: _ -> Doc.text ".. " - | _ -> Doc.dotdot)); - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun field -> printObjectField ~customLayout field cmtTbl) - fields); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ] + Doc.concat + [ + Doc.lbrace; + (match openFlag with + | Asttypes.Closed -> Doc.nil + | Open -> ( + match fields with + (* handle `type t = {.. ...objType, "x": int}` + * .. and ... should have a space in between *) + | Oinherit _ :: _ -> Doc.text ".. " + | _ -> Doc.dotdot)); + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun field -> + printObjectField ~customLayout field cmtTbl) + fields); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ] in if inline then doc else Doc.group doc @@ -54665,7 +54817,7 @@ and printTupleType ~customLayout ~inline (types : Parsetree.core_type list) [ Doc.softLine; Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) (List.map (fun typexpr -> printTypExpr ~customLayout typexpr cmtTbl) types); @@ -54680,23 +54832,23 @@ and printTupleType ~customLayout ~inline (types : Parsetree.core_type list) and printObjectField ~customLayout (field : Parsetree.object_field) cmtTbl = match field with | Otag (labelLoc, attrs, typ) -> - let lbl = - let doc = Doc.text ("\"" ^ labelLoc.txt ^ "\"") in - printComments doc cmtTbl labelLoc.loc - in - let doc = - Doc.concat - [ - printAttributes ~customLayout ~loc:labelLoc.loc attrs cmtTbl; - lbl; - Doc.text ": "; - printTypExpr ~customLayout typ cmtTbl; - ] - in - let cmtLoc = {labelLoc.loc with loc_end = typ.ptyp_loc.loc_end} in - printComments doc cmtTbl cmtLoc + let lbl = + let doc = Doc.text ("\"" ^ labelLoc.txt ^ "\"") in + printComments doc cmtTbl labelLoc.loc + in + let doc = + Doc.concat + [ + printAttributes ~customLayout ~loc:labelLoc.loc attrs cmtTbl; + lbl; + Doc.text ": "; + printTypExpr ~customLayout typ cmtTbl; + ] + in + let cmtLoc = { labelLoc.loc with loc_end = typ.ptyp_loc.loc_end } in + printComments doc cmtTbl cmtLoc | Oinherit typexpr -> - Doc.concat [Doc.dotdotdot; printTypExpr ~customLayout typexpr cmtTbl] + Doc.concat [ Doc.dotdotdot; printTypExpr ~customLayout typexpr cmtTbl ] (* es6 arrow type arg * type t = (~foo: string, ~bar: float=?, unit) => unit @@ -54704,16 +54856,16 @@ and printObjectField ~customLayout (field : Parsetree.object_field) cmtTbl = and printTypeParameter ~customLayout (attrs, lbl, typ) cmtTbl = let isUncurried, attrs = ParsetreeViewer.processUncurriedAttribute attrs in let uncurried = - if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil + if isUncurried then Doc.concat [ Doc.dot; Doc.space ] else Doc.nil in let attrs = printAttributes ~customLayout attrs cmtTbl in let label = match lbl with | Asttypes.Nolabel -> Doc.nil | Labelled lbl -> - Doc.concat [Doc.text "~"; printIdentLike lbl; Doc.text ": "] + Doc.concat [ Doc.text "~"; printIdentLike lbl; Doc.text ": " ] | Optional lbl -> - Doc.concat [Doc.text "~"; printIdentLike lbl; Doc.text ": "] + Doc.concat [ Doc.text "~"; printIdentLike lbl; Doc.text ": " ] in let optionalIndicator = match lbl with @@ -54722,9 +54874,9 @@ and printTypeParameter ~customLayout (attrs, lbl, typ) cmtTbl = in let loc, typ = match typ.ptyp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: attrs -> - ( {loc with loc_end = typ.ptyp_loc.loc_end}, - {typ with ptyp_attributes = attrs} ) + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: attrs -> + ( { loc with loc_end = typ.ptyp_loc.loc_end }, + { typ with ptyp_attributes = attrs } ) | _ -> (typ.ptyp_loc, typ) in let doc = @@ -54747,169 +54899,178 @@ and printValueBinding ~customLayout ~recFlag (vb : Parsetree.value_binding) cmtTbl in let header = - if i == 0 then Doc.concat [Doc.text "let "; recFlag] else Doc.text "and " + if i == 0 then Doc.concat [ Doc.text "let "; recFlag ] else Doc.text "and " in match vb with | { pvb_pat = { ppat_desc = - Ppat_constraint (pattern, ({ptyp_desc = Ptyp_poly _} as patTyp)); + Ppat_constraint (pattern, ({ ptyp_desc = Ptyp_poly _ } as patTyp)); }; - pvb_expr = {pexp_desc = Pexp_newtype _} as expr; + pvb_expr = { pexp_desc = Pexp_newtype _ } as expr; } -> ( - let _attrs, parameters, returnExpr = ParsetreeViewer.funExpr expr in - let abstractType = - match parameters with - | [NewTypes {locs = vars}] -> - Doc.concat - [ - Doc.text "type "; - Doc.join ~sep:Doc.space - (List.map (fun var -> Doc.text var.Asttypes.txt) vars); - Doc.dot; - ] - | _ -> Doc.nil - in - match returnExpr.pexp_desc with - | Pexp_constraint (expr, typ) -> - Doc.group - (Doc.concat - [ - attrs; - header; - printPattern ~customLayout pattern cmtTbl; - Doc.text ":"; - Doc.indent - (Doc.concat - [ - Doc.line; - abstractType; - Doc.space; - printTypExpr ~customLayout typ cmtTbl; - Doc.text " ="; - Doc.concat - [ - Doc.line; - printExpressionWithComments ~customLayout expr cmtTbl; - ]; - ]); - ]) - | _ -> - (* Example: - * let cancel_and_collect_callbacks: - * 'a 'u 'c. (list, promise<'a, 'u, 'c>) => list = * (type x, callbacks_accumulator, p: promise<_, _, c>) - *) - Doc.group - (Doc.concat - [ - attrs; - header; - printPattern ~customLayout pattern cmtTbl; - Doc.text ":"; - Doc.indent - (Doc.concat - [ - Doc.line; - abstractType; - Doc.space; - printTypExpr ~customLayout patTyp cmtTbl; - Doc.text " ="; - Doc.concat - [ - Doc.line; - printExpressionWithComments ~customLayout expr cmtTbl; - ]; - ]); - ])) - | _ -> - let optBraces, expr = ParsetreeViewer.processBracesAttr vb.pvb_expr in - let printedExpr = - let doc = printExpressionWithComments ~customLayout vb.pvb_expr cmtTbl in - match Parens.expr vb.pvb_expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - let patternDoc = printPattern ~customLayout vb.pvb_pat cmtTbl in - (* - * we want to optimize the layout of one pipe: - * let tbl = data->Js.Array2.reduce((map, curr) => { - * ... - * }) - * important is that we don't do this for multiple pipes: - * let decoratorTags = - * items - * ->Js.Array2.filter(items => {items.category === Decorators}) - * ->Belt.Array.map(...) - * Multiple pipes chained together lend themselves more towards the last layout. - *) - if ParsetreeViewer.isSinglePipeExpr vb.pvb_expr then - Doc.customLayout - [ + let _attrs, parameters, returnExpr = ParsetreeViewer.funExpr expr in + let abstractType = + match parameters with + | [ NewTypes { locs = vars } ] -> + Doc.concat + [ + Doc.text "type "; + Doc.join ~sep:Doc.space + (List.map (fun var -> Doc.text var.Asttypes.txt) vars); + Doc.dot; + ] + | _ -> Doc.nil + in + match returnExpr.pexp_desc with + | Pexp_constraint (expr, typ) -> Doc.group (Doc.concat [ - attrs; header; patternDoc; Doc.text " ="; Doc.space; printedExpr; - ]); + attrs; + header; + printPattern ~customLayout pattern cmtTbl; + Doc.text ":"; + Doc.indent + (Doc.concat + [ + Doc.line; + abstractType; + Doc.space; + printTypExpr ~customLayout typ cmtTbl; + Doc.text " ="; + Doc.concat + [ + Doc.line; + printExpressionWithComments ~customLayout expr + cmtTbl; + ]; + ]); + ]) + | _ -> + (* Example: + * let cancel_and_collect_callbacks: + * 'a 'u 'c. (list, promise<'a, 'u, 'c>) => list = * (type x, callbacks_accumulator, p: promise<_, _, c>) + *) Doc.group (Doc.concat [ attrs; header; - patternDoc; - Doc.text " ="; - Doc.indent (Doc.concat [Doc.line; printedExpr]); - ]); - ] - else - let shouldIndent = - match optBraces with - | Some _ -> false - | _ -> ( - ParsetreeViewer.isBinaryExpression expr - || - match vb.pvb_expr with - | { - pexp_attributes = [({Location.txt = "ns.ternary"}, _)]; - pexp_desc = Pexp_ifthenelse (ifExpr, _, _); - } -> - ParsetreeViewer.isBinaryExpression ifExpr - || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes - | {pexp_desc = Pexp_newtype _} -> false - | e -> - ParsetreeViewer.hasAttributes e.pexp_attributes - || ParsetreeViewer.isArrayAccess e) + printPattern ~customLayout pattern cmtTbl; + Doc.text ":"; + Doc.indent + (Doc.concat + [ + Doc.line; + abstractType; + Doc.space; + printTypExpr ~customLayout patTyp cmtTbl; + Doc.text " ="; + Doc.concat + [ + Doc.line; + printExpressionWithComments ~customLayout expr + cmtTbl; + ]; + ]); + ])) + | _ -> + let optBraces, expr = ParsetreeViewer.processBracesAttr vb.pvb_expr in + let printedExpr = + let doc = + printExpressionWithComments ~customLayout vb.pvb_expr cmtTbl + in + match Parens.expr vb.pvb_expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc in - Doc.group - (Doc.concat - [ - attrs; - header; - patternDoc; - Doc.text " ="; - (if shouldIndent then - Doc.indent (Doc.concat [Doc.line; printedExpr]) - else Doc.concat [Doc.space; printedExpr]); - ]) + let patternDoc = printPattern ~customLayout vb.pvb_pat cmtTbl in + (* + * we want to optimize the layout of one pipe: + * let tbl = data->Js.Array2.reduce((map, curr) => { + * ... + * }) + * important is that we don't do this for multiple pipes: + * let decoratorTags = + * items + * ->Js.Array2.filter(items => {items.category === Decorators}) + * ->Belt.Array.map(...) + * Multiple pipes chained together lend themselves more towards the last layout. + *) + if ParsetreeViewer.isSinglePipeExpr vb.pvb_expr then + Doc.customLayout + [ + Doc.group + (Doc.concat + [ + attrs; + header; + patternDoc; + Doc.text " ="; + Doc.space; + printedExpr; + ]); + Doc.group + (Doc.concat + [ + attrs; + header; + patternDoc; + Doc.text " ="; + Doc.indent (Doc.concat [ Doc.line; printedExpr ]); + ]); + ] + else + let shouldIndent = + match optBraces with + | Some _ -> false + | _ -> ( + ParsetreeViewer.isBinaryExpression expr + || + match vb.pvb_expr with + | { + pexp_attributes = [ ({ Location.txt = "ns.ternary" }, _) ]; + pexp_desc = Pexp_ifthenelse (ifExpr, _, _); + } -> + ParsetreeViewer.isBinaryExpression ifExpr + || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes + | { pexp_desc = Pexp_newtype _ } -> false + | e -> + ParsetreeViewer.hasAttributes e.pexp_attributes + || ParsetreeViewer.isArrayAccess e) + in + Doc.group + (Doc.concat + [ + attrs; + header; + patternDoc; + Doc.text " ="; + (if shouldIndent then + Doc.indent (Doc.concat [ Doc.line; printedExpr ]) + else Doc.concat [ Doc.space; printedExpr ]); + ]) and printPackageType ~customLayout ~printModuleKeywordAndParens (packageType : Parsetree.package_type) cmtTbl = let doc = match packageType with | longidentLoc, [] -> - Doc.group (Doc.concat [printLongidentLocation longidentLoc cmtTbl]) + Doc.group (Doc.concat [ printLongidentLocation longidentLoc cmtTbl ]) | longidentLoc, packageConstraints -> - Doc.group - (Doc.concat - [ - printLongidentLocation longidentLoc cmtTbl; - printPackageConstraints ~customLayout packageConstraints cmtTbl; - Doc.softLine; - ]) + Doc.group + (Doc.concat + [ + printLongidentLocation longidentLoc cmtTbl; + printPackageConstraints ~customLayout packageConstraints cmtTbl; + Doc.softLine; + ]) in if printModuleKeywordAndParens then - Doc.concat [Doc.text "module("; doc; Doc.rparen] + Doc.concat [ Doc.text "module("; doc; Doc.rparen ] else doc and printPackageConstraints ~customLayout packageConstraints cmtTbl = @@ -54961,7 +55122,7 @@ and printExtension ~customLayout ~atModuleLvl (stringLoc, payload) cmtTbl = in printComments doc cmtTbl stringLoc.Location.loc in - Doc.group (Doc.concat [extName; printPayload ~customLayout payload cmtTbl]) + Doc.group (Doc.concat [ extName; printPayload ~customLayout payload cmtTbl ]) and printPattern ~customLayout (p : Parsetree.pattern) cmtTbl = let patternWithoutAttributes = @@ -54969,376 +55130,404 @@ and printPattern ~customLayout (p : Parsetree.pattern) cmtTbl = | Ppat_any -> Doc.text "_" | Ppat_var var -> printIdentLike var.txt | Ppat_constant c -> - let templateLiteral = - ParsetreeViewer.hasTemplateLiteralAttr p.ppat_attributes - in - printConstant ~templateLiteral c + let templateLiteral = + ParsetreeViewer.hasTemplateLiteralAttr p.ppat_attributes + in + printConstant ~templateLiteral c | Ppat_tuple patterns -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) - patterns); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) | Ppat_array [] -> - Doc.concat - [Doc.lbracket; printCommentsInside cmtTbl p.ppat_loc; Doc.rbracket] + Doc.concat + [ Doc.lbracket; printCommentsInside cmtTbl p.ppat_loc; Doc.rbracket ] | Ppat_array patterns -> - Doc.group - (Doc.concat - [ - Doc.text "["; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) - patterns); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.text "]"; - ]) - | Ppat_construct ({txt = Longident.Lident "()"}, _) -> - Doc.concat [Doc.lparen; printCommentsInside cmtTbl p.ppat_loc; Doc.rparen] - | Ppat_construct ({txt = Longident.Lident "[]"}, _) -> - Doc.concat - [Doc.text "list{"; printCommentsInside cmtTbl p.ppat_loc; Doc.rbrace] - | Ppat_construct ({txt = Longident.Lident "::"}, _) -> - let patterns, tail = - ParsetreeViewer.collectPatternsFromListConstruct [] p - in - let shouldHug = - match (patterns, tail) with - | [pat], {ppat_desc = Ppat_construct ({txt = Longident.Lident "[]"}, _)} - when ParsetreeViewer.isHuggablePattern pat -> - true - | _ -> false - in - let children = + Doc.group + (Doc.concat + [ + Doc.text "["; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.text "]"; + ]) + | Ppat_construct ({ txt = Longident.Lident "()" }, _) -> + Doc.concat + [ Doc.lparen; printCommentsInside cmtTbl p.ppat_loc; Doc.rparen ] + | Ppat_construct ({ txt = Longident.Lident "[]" }, _) -> Doc.concat [ - (if shouldHug then Doc.nil else Doc.softLine); - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) - patterns); - (match tail.Parsetree.ppat_desc with - | Ppat_construct ({txt = Longident.Lident "[]"}, _) -> Doc.nil - | _ -> - let doc = - Doc.concat - [Doc.text "..."; printPattern ~customLayout tail cmtTbl] - in - let tail = printComments doc cmtTbl tail.ppat_loc in - Doc.concat [Doc.text ","; Doc.line; tail]); + Doc.text "list{"; printCommentsInside cmtTbl p.ppat_loc; Doc.rbrace; ] - in - Doc.group - (Doc.concat - [ - Doc.text "list{"; - (if shouldHug then children - else - Doc.concat - [ - Doc.indent children; - Doc.ifBreaks (Doc.text ",") Doc.nil; - Doc.softLine; - ]); - Doc.rbrace; - ]) - | Ppat_construct (constrName, constructorArgs) -> - let constrName = printLongidentLocation constrName cmtTbl in - let argsDoc = - match constructorArgs with - | None -> Doc.nil - | Some - { - ppat_loc; - ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _); - } -> - Doc.concat - [Doc.lparen; printCommentsInside cmtTbl ppat_loc; Doc.rparen] - | Some {ppat_desc = Ppat_tuple []; ppat_loc = loc} -> - Doc.concat [Doc.lparen; printCommentsInside cmtTbl loc; Doc.rparen] - (* Some((1, 2) *) - | Some {ppat_desc = Ppat_tuple [({ppat_desc = Ppat_tuple _} as arg)]} -> - Doc.concat - [Doc.lparen; printPattern ~customLayout arg cmtTbl; Doc.rparen] - | Some {ppat_desc = Ppat_tuple patterns} -> + | Ppat_construct ({ txt = Longident.Lident "::" }, _) -> + let patterns, tail = + ParsetreeViewer.collectPatternsFromListConstruct [] p + in + let shouldHug = + match (patterns, tail) with + | ( [ pat ], + { + ppat_desc = Ppat_construct ({ txt = Longident.Lident "[]" }, _); + } ) + when ParsetreeViewer.isHuggablePattern pat -> + true + | _ -> false + in + let children = Doc.concat [ - Doc.lparen; - Doc.indent - (Doc.concat + (if shouldHug then Doc.nil else Doc.softLine); + Doc.join + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); + (match tail.Parsetree.ppat_desc with + | Ppat_construct ({ txt = Longident.Lident "[]" }, _) -> Doc.nil + | _ -> + let doc = + Doc.concat + [ Doc.text "..."; printPattern ~customLayout tail cmtTbl ] + in + let tail = printComments doc cmtTbl tail.ppat_loc in + Doc.concat [ Doc.text ","; Doc.line; tail ]); + ] + in + Doc.group + (Doc.concat + [ + Doc.text "list{"; + (if shouldHug then children + else + Doc.concat [ + Doc.indent children; + Doc.ifBreaks (Doc.text ",") Doc.nil; Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) - patterns); ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some arg -> - let argDoc = printPattern ~customLayout arg cmtTbl in - let shouldHug = ParsetreeViewer.isHuggablePattern arg in - Doc.concat - [ - Doc.lparen; - (if shouldHug then argDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [Doc.softLine; argDoc]); - Doc.trailingComma; - Doc.softLine; - ]); - Doc.rparen; - ] - in - Doc.group (Doc.concat [constrName; argsDoc]) + Doc.rbrace; + ]) + | Ppat_construct (constrName, constructorArgs) -> + let constrName = printLongidentLocation constrName cmtTbl in + let argsDoc = + match constructorArgs with + | None -> Doc.nil + | Some + { + ppat_loc; + ppat_desc = Ppat_construct ({ txt = Longident.Lident "()" }, _); + } -> + Doc.concat + [ Doc.lparen; printCommentsInside cmtTbl ppat_loc; Doc.rparen ] + | Some { ppat_desc = Ppat_tuple []; ppat_loc = loc } -> + Doc.concat + [ Doc.lparen; printCommentsInside cmtTbl loc; Doc.rparen ] + (* Some((1, 2) *) + | Some + { + ppat_desc = Ppat_tuple [ ({ ppat_desc = Ppat_tuple _ } as arg) ]; + } -> + Doc.concat + [ + Doc.lparen; printPattern ~customLayout arg cmtTbl; Doc.rparen; + ] + | Some { ppat_desc = Ppat_tuple patterns } -> + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + | Some arg -> + let argDoc = printPattern ~customLayout arg cmtTbl in + let shouldHug = ParsetreeViewer.isHuggablePattern arg in + Doc.concat + [ + Doc.lparen; + (if shouldHug then argDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [ Doc.softLine; argDoc ]); + Doc.trailingComma; + Doc.softLine; + ]); + Doc.rparen; + ] + in + Doc.group (Doc.concat [ constrName; argsDoc ]) | Ppat_variant (label, None) -> - Doc.concat [Doc.text "#"; printPolyVarIdent label] + Doc.concat [ Doc.text "#"; printPolyVarIdent label ] | Ppat_variant (label, variantArgs) -> - let variantName = Doc.concat [Doc.text "#"; printPolyVarIdent label] in - let argsDoc = - match variantArgs with - | None -> Doc.nil - | Some {ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _)} - -> - Doc.text "()" - | Some {ppat_desc = Ppat_tuple []; ppat_loc = loc} -> - Doc.concat [Doc.lparen; printCommentsInside cmtTbl loc; Doc.rparen] - (* Some((1, 2) *) - | Some {ppat_desc = Ppat_tuple [({ppat_desc = Ppat_tuple _} as arg)]} -> - Doc.concat - [Doc.lparen; printPattern ~customLayout arg cmtTbl; Doc.rparen] - | Some {ppat_desc = Ppat_tuple patterns} -> - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) - patterns); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some arg -> - let argDoc = printPattern ~customLayout arg cmtTbl in - let shouldHug = ParsetreeViewer.isHuggablePattern arg in - Doc.concat - [ - Doc.lparen; - (if shouldHug then argDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [Doc.softLine; argDoc]); - Doc.trailingComma; - Doc.softLine; - ]); - Doc.rparen; - ] - in - Doc.group (Doc.concat [variantName; argsDoc]) + let variantName = + Doc.concat [ Doc.text "#"; printPolyVarIdent label ] + in + let argsDoc = + match variantArgs with + | None -> Doc.nil + | Some + { + ppat_desc = Ppat_construct ({ txt = Longident.Lident "()" }, _); + } -> + Doc.text "()" + | Some { ppat_desc = Ppat_tuple []; ppat_loc = loc } -> + Doc.concat + [ Doc.lparen; printCommentsInside cmtTbl loc; Doc.rparen ] + (* Some((1, 2) *) + | Some + { + ppat_desc = Ppat_tuple [ ({ ppat_desc = Ppat_tuple _ } as arg) ]; + } -> + Doc.concat + [ + Doc.lparen; printPattern ~customLayout arg cmtTbl; Doc.rparen; + ] + | Some { ppat_desc = Ppat_tuple patterns } -> + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + | Some arg -> + let argDoc = printPattern ~customLayout arg cmtTbl in + let shouldHug = ParsetreeViewer.isHuggablePattern arg in + Doc.concat + [ + Doc.lparen; + (if shouldHug then argDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [ Doc.softLine; argDoc ]); + Doc.trailingComma; + Doc.softLine; + ]); + Doc.rparen; + ] + in + Doc.group (Doc.concat [ variantName; argsDoc ]) | Ppat_type ident -> - Doc.concat [Doc.text "#..."; printIdentPath ident cmtTbl] + Doc.concat [ Doc.text "#..."; printIdentPath ident cmtTbl ] | Ppat_record (rows, openFlag) -> - Doc.group - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun row -> - printPatternRecordRow ~customLayout row cmtTbl) - rows); - (match openFlag with - | Open -> Doc.concat [Doc.text ","; Doc.line; Doc.text "_"] - | Closed -> Doc.nil); - ]); - Doc.ifBreaks (Doc.text ",") Doc.nil; - Doc.softLine; - Doc.rbrace; - ]) + Doc.group + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) + (List.map + (fun row -> + printPatternRecordRow ~customLayout row cmtTbl) + rows); + (match openFlag with + | Open -> + Doc.concat [ Doc.text ","; Doc.line; Doc.text "_" ] + | Closed -> Doc.nil); + ]); + Doc.ifBreaks (Doc.text ",") Doc.nil; + Doc.softLine; + Doc.rbrace; + ]) | Ppat_exception p -> - let needsParens = - match p.ppat_desc with - | Ppat_or (_, _) | Ppat_alias (_, _) -> true - | _ -> false - in - let pat = - let p = printPattern ~customLayout p cmtTbl in - if needsParens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p - in - Doc.group (Doc.concat [Doc.text "exception"; Doc.line; pat]) + let needsParens = + match p.ppat_desc with + | Ppat_or (_, _) | Ppat_alias (_, _) -> true + | _ -> false + in + let pat = + let p = printPattern ~customLayout p cmtTbl in + if needsParens then Doc.concat [ Doc.text "("; p; Doc.text ")" ] + else p + in + Doc.group (Doc.concat [ Doc.text "exception"; Doc.line; pat ]) | Ppat_or _ -> - (* Blue | Red | Green -> [Blue; Red; Green] *) - let orChain = ParsetreeViewer.collectOrPatternChain p in - let docs = - List.mapi - (fun i pat -> - let patternDoc = printPattern ~customLayout pat cmtTbl in - Doc.concat - [ - (if i == 0 then Doc.nil - else Doc.concat [Doc.line; Doc.text "| "]); - (match pat.ppat_desc with - (* (Blue | Red) | (Green | Black) | White *) - | Ppat_or _ -> addParens patternDoc - | _ -> patternDoc); - ]) - orChain - in - let isSpreadOverMultipleLines = - match (orChain, List.rev orChain) with - | first :: _, last :: _ -> - first.ppat_loc.loc_start.pos_lnum < last.ppat_loc.loc_end.pos_lnum - | _ -> false - in - Doc.breakableGroup ~forceBreak:isSpreadOverMultipleLines (Doc.concat docs) + (* Blue | Red | Green -> [Blue; Red; Green] *) + let orChain = ParsetreeViewer.collectOrPatternChain p in + let docs = + List.mapi + (fun i pat -> + let patternDoc = printPattern ~customLayout pat cmtTbl in + Doc.concat + [ + (if i == 0 then Doc.nil + else Doc.concat [ Doc.line; Doc.text "| " ]); + (match pat.ppat_desc with + (* (Blue | Red) | (Green | Black) | White *) + | Ppat_or _ -> addParens patternDoc + | _ -> patternDoc); + ]) + orChain + in + let isSpreadOverMultipleLines = + match (orChain, List.rev orChain) with + | first :: _, last :: _ -> + first.ppat_loc.loc_start.pos_lnum < last.ppat_loc.loc_end.pos_lnum + | _ -> false + in + Doc.breakableGroup ~forceBreak:isSpreadOverMultipleLines + (Doc.concat docs) | Ppat_extension ext -> - printExtension ~customLayout ~atModuleLvl:false ext cmtTbl + printExtension ~customLayout ~atModuleLvl:false ext cmtTbl | Ppat_lazy p -> - let needsParens = - match p.ppat_desc with - | Ppat_or (_, _) | Ppat_alias (_, _) -> true - | _ -> false - in - let pat = - let p = printPattern ~customLayout p cmtTbl in - if needsParens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p - in - Doc.concat [Doc.text "lazy "; pat] + let needsParens = + match p.ppat_desc with + | Ppat_or (_, _) | Ppat_alias (_, _) -> true + | _ -> false + in + let pat = + let p = printPattern ~customLayout p cmtTbl in + if needsParens then Doc.concat [ Doc.text "("; p; Doc.text ")" ] + else p + in + Doc.concat [ Doc.text "lazy "; pat ] | Ppat_alias (p, aliasLoc) -> - let needsParens = - match p.ppat_desc with - | Ppat_or (_, _) | Ppat_alias (_, _) -> true - | _ -> false - in - let renderedPattern = - let p = printPattern ~customLayout p cmtTbl in - if needsParens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p - in - Doc.concat - [renderedPattern; Doc.text " as "; printStringLoc aliasLoc cmtTbl] + let needsParens = + match p.ppat_desc with + | Ppat_or (_, _) | Ppat_alias (_, _) -> true + | _ -> false + in + let renderedPattern = + let p = printPattern ~customLayout p cmtTbl in + if needsParens then Doc.concat [ Doc.text "("; p; Doc.text ")" ] + else p + in + Doc.concat + [ renderedPattern; Doc.text " as "; printStringLoc aliasLoc cmtTbl ] (* Note: module(P : S) is represented as *) (* Ppat_constraint(Ppat_unpack, Ptyp_package) *) | Ppat_constraint - ( {ppat_desc = Ppat_unpack stringLoc}, - {ptyp_desc = Ptyp_package packageType; ptyp_loc} ) -> - Doc.concat - [ - Doc.text "module("; - printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; - Doc.text ": "; - printComments - (printPackageType ~customLayout ~printModuleKeywordAndParens:false - packageType cmtTbl) - cmtTbl ptyp_loc; - Doc.rparen; - ] + ( { ppat_desc = Ppat_unpack stringLoc }, + { ptyp_desc = Ptyp_package packageType; ptyp_loc } ) -> + Doc.concat + [ + Doc.text "module("; + printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; + Doc.text ": "; + printComments + (printPackageType ~customLayout ~printModuleKeywordAndParens:false + packageType cmtTbl) + cmtTbl ptyp_loc; + Doc.rparen; + ] | Ppat_constraint (pattern, typ) -> - Doc.concat - [ - printPattern ~customLayout pattern cmtTbl; - Doc.text ": "; - printTypExpr ~customLayout typ cmtTbl; - ] + Doc.concat + [ + printPattern ~customLayout pattern cmtTbl; + Doc.text ": "; + printTypExpr ~customLayout typ cmtTbl; + ] (* Note: module(P : S) is represented as *) (* Ppat_constraint(Ppat_unpack, Ptyp_package) *) | Ppat_unpack stringLoc -> - Doc.concat - [ - Doc.text "module("; - printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; - Doc.rparen; - ] + Doc.concat + [ + Doc.text "module("; + printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; + Doc.rparen; + ] | Ppat_interval (a, b) -> - Doc.concat [printConstant a; Doc.text " .. "; printConstant b] + Doc.concat [ printConstant a; Doc.text " .. "; printConstant b ] | Ppat_open _ -> Doc.nil in let doc = match p.ppat_attributes with | [] -> patternWithoutAttributes | attrs -> - Doc.group - (Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; patternWithoutAttributes; - ]) + Doc.group + (Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + patternWithoutAttributes; + ]) in printComments doc cmtTbl p.ppat_loc and printPatternRecordRow ~customLayout row cmtTbl = match row with (* punned {x}*) - | ( ({Location.txt = Longident.Lident ident} as longident), - {Parsetree.ppat_desc = Ppat_var {txt; _}; ppat_attributes} ) + | ( ({ Location.txt = Longident.Lident ident } as longident), + { Parsetree.ppat_desc = Ppat_var { txt; _ }; ppat_attributes } ) when ident = txt -> - Doc.concat - [ - printOptionalLabel ppat_attributes; - printAttributes ~customLayout ppat_attributes cmtTbl; - printLidentPath longident cmtTbl; - ] + Doc.concat + [ + printOptionalLabel ppat_attributes; + printAttributes ~customLayout ppat_attributes cmtTbl; + printLidentPath longident cmtTbl; + ] | longident, pattern -> - let locForComments = - {longident.loc with loc_end = pattern.Parsetree.ppat_loc.loc_end} - in - let rhsDoc = - let doc = printPattern ~customLayout pattern cmtTbl in + let locForComments = + { longident.loc with loc_end = pattern.Parsetree.ppat_loc.loc_end } + in + let rhsDoc = + let doc = printPattern ~customLayout pattern cmtTbl in + let doc = + if Parens.patternRecordRowRhs pattern then addParens doc else doc + in + Doc.concat [ printOptionalLabel pattern.ppat_attributes; doc ] + in let doc = - if Parens.patternRecordRowRhs pattern then addParens doc else doc + Doc.group + (Doc.concat + [ + printLidentPath longident cmtTbl; + Doc.text ":"; + (if ParsetreeViewer.isHuggablePattern pattern then + Doc.concat [ Doc.space; rhsDoc ] + else Doc.indent (Doc.concat [ Doc.line; rhsDoc ])); + ]) in - Doc.concat [printOptionalLabel pattern.ppat_attributes; doc] - in - let doc = - Doc.group - (Doc.concat - [ - printLidentPath longident cmtTbl; - Doc.text ":"; - (if ParsetreeViewer.isHuggablePattern pattern then - Doc.concat [Doc.space; rhsDoc] - else Doc.indent (Doc.concat [Doc.line; rhsDoc])); - ]) - in - printComments doc cmtTbl locForComments + printComments doc cmtTbl locForComments and printExpressionWithComments ~customLayout expr cmtTbl : Doc.t = let doc = printExpression ~customLayout expr cmtTbl in @@ -55353,54 +55542,55 @@ and printIfChain ~customLayout pexp_attributes ifs elseExpr cmtTbl = let doc = match ifExpr with | ParsetreeViewer.If ifExpr -> - let condition = - if ParsetreeViewer.isBlockExpr ifExpr then - printExpressionBlock ~customLayout ~braces:true ifExpr cmtTbl - else + let condition = + if ParsetreeViewer.isBlockExpr ifExpr then + printExpressionBlock ~customLayout ~braces:true ifExpr + cmtTbl + else + let doc = + printExpressionWithComments ~customLayout ifExpr cmtTbl + in + match Parens.expr ifExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc ifExpr braces + | Nothing -> Doc.ifBreaks (addParens doc) doc + in + Doc.concat + [ + ifTxt; + Doc.group condition; + Doc.space; + (let thenExpr = + match ParsetreeViewer.processBracesAttr thenExpr with + (* This case only happens when coming from Reason, we strip braces *) + | Some _, expr -> expr + | _ -> thenExpr + in + printExpressionBlock ~customLayout ~braces:true thenExpr + cmtTbl); + ] + | IfLet (pattern, conditionExpr) -> + let conditionDoc = let doc = - printExpressionWithComments ~customLayout ifExpr cmtTbl + printExpressionWithComments ~customLayout conditionExpr + cmtTbl in - match Parens.expr ifExpr with + match Parens.expr conditionExpr with | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc ifExpr braces - | Nothing -> Doc.ifBreaks (addParens doc) doc - in - Doc.concat - [ - ifTxt; - Doc.group condition; - Doc.space; - (let thenExpr = - match ParsetreeViewer.processBracesAttr thenExpr with - (* This case only happens when coming from Reason, we strip braces *) - | Some _, expr -> expr - | _ -> thenExpr - in - printExpressionBlock ~customLayout ~braces:true thenExpr - cmtTbl); - ] - | IfLet (pattern, conditionExpr) -> - let conditionDoc = - let doc = - printExpressionWithComments ~customLayout conditionExpr - cmtTbl + | Braced braces -> printBraces doc conditionExpr braces + | Nothing -> doc in - match Parens.expr conditionExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc conditionExpr braces - | Nothing -> doc - in - Doc.concat - [ - ifTxt; - Doc.text "let "; - printPattern ~customLayout pattern cmtTbl; - Doc.text " = "; - conditionDoc; - Doc.space; - printExpressionBlock ~customLayout ~braces:true thenExpr - cmtTbl; - ] + Doc.concat + [ + ifTxt; + Doc.text "let "; + printPattern ~customLayout pattern cmtTbl; + Doc.text " = "; + conditionDoc; + Doc.space; + printExpressionBlock ~customLayout ~braces:true thenExpr + cmtTbl; + ] in printLeadingComments doc cmtTbl.leading outerLoc) ifs) @@ -55409,707 +55599,736 @@ and printIfChain ~customLayout pexp_attributes ifs elseExpr cmtTbl = match elseExpr with | None -> Doc.nil | Some expr -> - Doc.concat - [ - Doc.text " else "; - printExpressionBlock ~customLayout ~braces:true expr cmtTbl; - ] + Doc.concat + [ + Doc.text " else "; + printExpressionBlock ~customLayout ~braces:true expr cmtTbl; + ] in let attrs = ParsetreeViewer.filterFragileMatchAttributes pexp_attributes in - Doc.concat [printAttributes ~customLayout attrs cmtTbl; ifDocs; elseDoc] + Doc.concat [ printAttributes ~customLayout attrs cmtTbl; ifDocs; elseDoc ] and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = let printedExpression = match e.pexp_desc with | Parsetree.Pexp_constant c -> - printConstant ~templateLiteral:(ParsetreeViewer.isTemplateLiteral e) c + printConstant ~templateLiteral:(ParsetreeViewer.isTemplateLiteral e) c | Pexp_construct _ when ParsetreeViewer.hasJsxAttribute e.pexp_attributes -> - printJsxFragment ~customLayout e cmtTbl - | Pexp_construct ({txt = Longident.Lident "()"}, _) -> Doc.text "()" - | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> - Doc.concat - [Doc.text "list{"; printCommentsInside cmtTbl e.pexp_loc; Doc.rbrace] - | Pexp_construct ({txt = Longident.Lident "::"}, _) -> - let expressions, spread = ParsetreeViewer.collectListExpressions e in - let spreadDoc = - match spread with - | Some expr -> - Doc.concat - [ - Doc.text ","; - Doc.line; - Doc.dotdotdot; - (let doc = - printExpressionWithComments ~customLayout expr cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); - ] - | None -> Doc.nil - in - Doc.group - (Doc.concat - [ - Doc.text "list{"; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun expr -> - let doc = - printExpressionWithComments ~customLayout expr - cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - expressions); - spreadDoc; - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ]) - | Pexp_construct (longidentLoc, args) -> - let constr = printLongidentLocation longidentLoc cmtTbl in - let args = - match args with - | None -> Doc.nil - | Some {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)} - -> - Doc.text "()" - (* Some((1, 2)) *) - | Some {pexp_desc = Pexp_tuple [({pexp_desc = Pexp_tuple _} as arg)]} -> - Doc.concat - [ - Doc.lparen; - (let doc = printExpressionWithComments ~customLayout arg cmtTbl in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc); - Doc.rparen; - ] - | Some {pexp_desc = Pexp_tuple args} -> - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun expr -> - let doc = - printExpressionWithComments ~customLayout expr - cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some arg -> - let argDoc = - let doc = printExpressionWithComments ~customLayout arg cmtTbl in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc - in - let shouldHug = ParsetreeViewer.isHuggableExpression arg in - Doc.concat - [ - Doc.lparen; - (if shouldHug then argDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [Doc.softLine; argDoc]); - Doc.trailingComma; - Doc.softLine; - ]); - Doc.rparen; - ] - in - Doc.group (Doc.concat [constr; args]) - | Pexp_ident path -> printLidentPath path cmtTbl - | Pexp_tuple exprs -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun expr -> - let doc = - printExpressionWithComments ~customLayout expr - cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - exprs); - ]); - Doc.ifBreaks (Doc.text ",") Doc.nil; - Doc.softLine; - Doc.rparen; - ]) - | Pexp_array [] -> - Doc.concat - [Doc.lbracket; printCommentsInside cmtTbl e.pexp_loc; Doc.rbracket] - | Pexp_array exprs -> - Doc.group - (Doc.concat - [ - Doc.lbracket; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun expr -> - let doc = - printExpressionWithComments ~customLayout expr - cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - exprs); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbracket; - ]) - | Pexp_variant (label, args) -> - let variantName = Doc.concat [Doc.text "#"; printPolyVarIdent label] in - let args = - match args with - | None -> Doc.nil - | Some {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)} - -> - Doc.text "()" - (* #poly((1, 2) *) - | Some {pexp_desc = Pexp_tuple [({pexp_desc = Pexp_tuple _} as arg)]} -> - Doc.concat - [ - Doc.lparen; - (let doc = printExpressionWithComments ~customLayout arg cmtTbl in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc); - Doc.rparen; - ] - | Some {pexp_desc = Pexp_tuple args} -> - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun expr -> - let doc = - printExpressionWithComments ~customLayout expr - cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some arg -> - let argDoc = - let doc = printExpressionWithComments ~customLayout arg cmtTbl in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc - in - let shouldHug = ParsetreeViewer.isHuggableExpression arg in - Doc.concat - [ - Doc.lparen; - (if shouldHug then argDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [Doc.softLine; argDoc]); - Doc.trailingComma; - Doc.softLine; - ]); - Doc.rparen; - ] - in - Doc.group (Doc.concat [variantName; args]) - | Pexp_record (rows, spreadExpr) -> - if rows = [] then + printJsxFragment ~customLayout e cmtTbl + | Pexp_construct ({ txt = Longident.Lident "()" }, _) -> Doc.text "()" + | Pexp_construct ({ txt = Longident.Lident "[]" }, _) -> Doc.concat - [Doc.lbrace; printCommentsInside cmtTbl e.pexp_loc; Doc.rbrace] - else - let spread = - match spreadExpr with - | None -> Doc.nil + [ + Doc.text "list{"; printCommentsInside cmtTbl e.pexp_loc; Doc.rbrace; + ] + | Pexp_construct ({ txt = Longident.Lident "::" }, _) -> + let expressions, spread = ParsetreeViewer.collectListExpressions e in + let spreadDoc = + match spread with | Some expr -> - Doc.concat - [ - Doc.dotdotdot; - (let doc = - printExpressionWithComments ~customLayout expr cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); - Doc.comma; - Doc.line; - ] - in - (* If the record is written over multiple lines, break automatically - * `let x = {a: 1, b: 3}` -> same line, break when line-width exceeded - * `let x = { - * a: 1, - * b: 2, - * }` -> record is written on multiple lines, break the group *) - let forceBreak = - e.pexp_loc.loc_start.pos_lnum < e.pexp_loc.loc_end.pos_lnum - in - let punningAllowed = - match (spreadExpr, rows) with - | None, [_] -> false (* disallow punning for single-element records *) - | _ -> true + Doc.concat + [ + Doc.text ","; + Doc.line; + Doc.dotdotdot; + (let doc = + printExpressionWithComments ~customLayout expr cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + ] + | None -> Doc.nil in - Doc.breakableGroup ~forceBreak + Doc.group (Doc.concat [ - Doc.lbrace; + Doc.text "list{"; Doc.indent (Doc.concat [ Doc.softLine; - spread; Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) (List.map - (fun row -> - printExpressionRecordRow ~customLayout row cmtTbl - punningAllowed) - rows); + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + expressions); + spreadDoc; ]); Doc.trailingComma; Doc.softLine; Doc.rbrace; ]) - | Pexp_extension extension -> ( - match extension with - | ( {txt = "bs.obj" | "obj"}, - PStr - [ + | Pexp_construct (longidentLoc, args) -> + let constr = printLongidentLocation longidentLoc cmtTbl in + let args = + match args with + | None -> Doc.nil + | Some { - pstr_loc = loc; - pstr_desc = Pstr_eval ({pexp_desc = Pexp_record (rows, _)}, []); - }; - ] ) -> - (* If the object is written over multiple lines, break automatically - * `let x = {"a": 1, "b": 3}` -> same line, break when line-width exceeded - * `let x = { - * "a": 1, - * "b": 2, - * }` -> object is written on multiple lines, break the group *) - let forceBreak = loc.loc_start.pos_lnum < loc.loc_end.pos_lnum in - Doc.breakableGroup ~forceBreak + pexp_desc = Pexp_construct ({ txt = Longident.Lident "()" }, _); + } -> + Doc.text "()" + (* Some((1, 2)) *) + | Some + { + pexp_desc = Pexp_tuple [ ({ pexp_desc = Pexp_tuple _ } as arg) ]; + } -> + Doc.concat + [ + Doc.lparen; + (let doc = + printExpressionWithComments ~customLayout arg cmtTbl + in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc); + Doc.rparen; + ] + | Some { pexp_desc = Pexp_tuple args } -> + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + | Some arg -> + let argDoc = + let doc = + printExpressionWithComments ~customLayout arg cmtTbl + in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc + in + let shouldHug = ParsetreeViewer.isHuggableExpression arg in + Doc.concat + [ + Doc.lparen; + (if shouldHug then argDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [ Doc.softLine; argDoc ]); + Doc.trailingComma; + Doc.softLine; + ]); + Doc.rparen; + ] + in + Doc.group (Doc.concat [ constr; args ]) + | Pexp_ident path -> printLidentPath path cmtTbl + | Pexp_tuple exprs -> + Doc.group (Doc.concat [ - Doc.lbrace; + Doc.lparen; Doc.indent (Doc.concat [ Doc.softLine; Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) (List.map - (fun row -> - printBsObjectRow ~customLayout row cmtTbl) - rows); + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + exprs); + ]); + Doc.ifBreaks (Doc.text ",") Doc.nil; + Doc.softLine; + Doc.rparen; + ]) + | Pexp_array [] -> + Doc.concat + [ Doc.lbracket; printCommentsInside cmtTbl e.pexp_loc; Doc.rbracket ] + | Pexp_array exprs -> + Doc.group + (Doc.concat + [ + Doc.lbracket; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) + (List.map + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + exprs); ]); Doc.trailingComma; Doc.softLine; - Doc.rbrace; + Doc.rbracket; ]) - | extension -> - printExtension ~customLayout ~atModuleLvl:false extension cmtTbl) - | Pexp_apply (e, [(Nolabel, {pexp_desc = Pexp_array subLists})]) + | Pexp_variant (label, args) -> + let variantName = + Doc.concat [ Doc.text "#"; printPolyVarIdent label ] + in + let args = + match args with + | None -> Doc.nil + | Some + { + pexp_desc = Pexp_construct ({ txt = Longident.Lident "()" }, _); + } -> + Doc.text "()" + (* #poly((1, 2) *) + | Some + { + pexp_desc = Pexp_tuple [ ({ pexp_desc = Pexp_tuple _ } as arg) ]; + } -> + Doc.concat + [ + Doc.lparen; + (let doc = + printExpressionWithComments ~customLayout arg cmtTbl + in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc); + Doc.rparen; + ] + | Some { pexp_desc = Pexp_tuple args } -> + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + | Some arg -> + let argDoc = + let doc = + printExpressionWithComments ~customLayout arg cmtTbl + in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc + in + let shouldHug = ParsetreeViewer.isHuggableExpression arg in + Doc.concat + [ + Doc.lparen; + (if shouldHug then argDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [ Doc.softLine; argDoc ]); + Doc.trailingComma; + Doc.softLine; + ]); + Doc.rparen; + ] + in + Doc.group (Doc.concat [ variantName; args ]) + | Pexp_record (rows, spreadExpr) -> + if rows = [] then + Doc.concat + [ Doc.lbrace; printCommentsInside cmtTbl e.pexp_loc; Doc.rbrace ] + else + let spread = + match spreadExpr with + | None -> Doc.nil + | Some expr -> + Doc.concat + [ + Doc.dotdotdot; + (let doc = + printExpressionWithComments ~customLayout expr cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + Doc.comma; + Doc.line; + ] + in + (* If the record is written over multiple lines, break automatically + * `let x = {a: 1, b: 3}` -> same line, break when line-width exceeded + * `let x = { + * a: 1, + * b: 2, + * }` -> record is written on multiple lines, break the group *) + let forceBreak = + e.pexp_loc.loc_start.pos_lnum < e.pexp_loc.loc_end.pos_lnum + in + let punningAllowed = + match (spreadExpr, rows) with + | None, [ _ ] -> + false (* disallow punning for single-element records *) + | _ -> true + in + Doc.breakableGroup ~forceBreak + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.softLine; + spread; + Doc.join + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) + (List.map + (fun row -> + printExpressionRecordRow ~customLayout row cmtTbl + punningAllowed) + rows); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ]) + | Pexp_extension extension -> ( + match extension with + | ( { txt = "bs.obj" | "obj" }, + PStr + [ + { + pstr_loc = loc; + pstr_desc = + Pstr_eval ({ pexp_desc = Pexp_record (rows, _) }, []); + }; + ] ) -> + (* If the object is written over multiple lines, break automatically + * `let x = {"a": 1, "b": 3}` -> same line, break when line-width exceeded + * `let x = { + * "a": 1, + * "b": 2, + * }` -> object is written on multiple lines, break the group *) + let forceBreak = loc.loc_start.pos_lnum < loc.loc_end.pos_lnum in + Doc.breakableGroup ~forceBreak + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) + (List.map + (fun row -> + printBsObjectRow ~customLayout row cmtTbl) + rows); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ]) + | extension -> + printExtension ~customLayout ~atModuleLvl:false extension cmtTbl) + | Pexp_apply (e, [ (Nolabel, { pexp_desc = Pexp_array subLists }) ]) when ParsetreeViewer.isSpreadBeltListConcat e -> - printBeltListConcatApply ~customLayout subLists cmtTbl + printBeltListConcatApply ~customLayout subLists cmtTbl | Pexp_apply _ -> - if ParsetreeViewer.isUnaryExpression e then - printUnaryExpression ~customLayout e cmtTbl - else if ParsetreeViewer.isTemplateLiteral e then - printTemplateLiteral ~customLayout e cmtTbl - else if ParsetreeViewer.isBinaryExpression e then - printBinaryExpression ~customLayout e cmtTbl - else printPexpApply ~customLayout e cmtTbl + if ParsetreeViewer.isUnaryExpression e then + printUnaryExpression ~customLayout e cmtTbl + else if ParsetreeViewer.isTemplateLiteral e then + printTemplateLiteral ~customLayout e cmtTbl + else if ParsetreeViewer.isBinaryExpression e then + printBinaryExpression ~customLayout e cmtTbl + else printPexpApply ~customLayout e cmtTbl | Pexp_unreachable -> Doc.dot | Pexp_field (expr, longidentLoc) -> - let lhs = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.fieldExpr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat [lhs; Doc.dot; printLidentPath longidentLoc cmtTbl] + let lhs = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.fieldExpr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [ lhs; Doc.dot; printLidentPath longidentLoc cmtTbl ] | Pexp_setfield (expr1, longidentLoc, expr2) -> - printSetFieldExpr ~customLayout e.pexp_attributes expr1 longidentLoc expr2 - e.pexp_loc cmtTbl + printSetFieldExpr ~customLayout e.pexp_attributes expr1 longidentLoc + expr2 e.pexp_loc cmtTbl | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) when ParsetreeViewer.isTernaryExpr e -> - let parts, alternate = ParsetreeViewer.collectTernaryParts e in - let ternaryDoc = - match parts with - | (condition1, consequent1) :: rest -> - Doc.group - (Doc.concat - [ - printTernaryOperand ~customLayout condition1 cmtTbl; - Doc.indent - (Doc.concat - [ - Doc.line; - Doc.indent - (Doc.concat - [ - Doc.text "? "; - printTernaryOperand ~customLayout consequent1 - cmtTbl; - ]); - Doc.concat - (List.map - (fun (condition, consequent) -> - Doc.concat + let parts, alternate = ParsetreeViewer.collectTernaryParts e in + let ternaryDoc = + match parts with + | (condition1, consequent1) :: rest -> + Doc.group + (Doc.concat + [ + printTernaryOperand ~customLayout condition1 cmtTbl; + Doc.indent + (Doc.concat + [ + Doc.line; + Doc.indent + (Doc.concat [ - Doc.line; - Doc.text ": "; - printTernaryOperand ~customLayout condition - cmtTbl; - Doc.line; Doc.text "? "; - printTernaryOperand ~customLayout consequent + printTernaryOperand ~customLayout consequent1 cmtTbl; - ]) - rest); - Doc.line; - Doc.text ": "; - Doc.indent - (printTernaryOperand ~customLayout alternate cmtTbl); - ]); - ]) - | _ -> Doc.nil - in - let attrs = ParsetreeViewer.filterTernaryAttributes e.pexp_attributes in - let needsParens = - match ParsetreeViewer.filterParsingAttrs attrs with - | [] -> false - | _ -> true - in - Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - (if needsParens then addParens ternaryDoc else ternaryDoc); - ] + ]); + Doc.concat + (List.map + (fun (condition, consequent) -> + Doc.concat + [ + Doc.line; + Doc.text ": "; + printTernaryOperand ~customLayout + condition cmtTbl; + Doc.line; + Doc.text "? "; + printTernaryOperand ~customLayout + consequent cmtTbl; + ]) + rest); + Doc.line; + Doc.text ": "; + Doc.indent + (printTernaryOperand ~customLayout alternate + cmtTbl); + ]); + ]) + | _ -> Doc.nil + in + let attrs = ParsetreeViewer.filterTernaryAttributes e.pexp_attributes in + let needsParens = + match ParsetreeViewer.filterParsingAttrs attrs with + | [] -> false + | _ -> true + in + Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + (if needsParens then addParens ternaryDoc else ternaryDoc); + ] | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) -> - let ifs, elseExpr = ParsetreeViewer.collectIfExpressions e in - printIfChain ~customLayout e.pexp_attributes ifs elseExpr cmtTbl + let ifs, elseExpr = ParsetreeViewer.collectIfExpressions e in + printIfChain ~customLayout e.pexp_attributes ifs elseExpr cmtTbl | Pexp_while (expr1, expr2) -> - let condition = - let doc = printExpressionWithComments ~customLayout expr1 cmtTbl in - match Parens.expr expr1 with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr1 braces - | Nothing -> doc - in - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.text "while "; - (if ParsetreeViewer.isBlockExpr expr1 then condition - else Doc.group (Doc.ifBreaks (addParens condition) condition)); - Doc.space; - printExpressionBlock ~customLayout ~braces:true expr2 cmtTbl; - ]) + let condition = + let doc = printExpressionWithComments ~customLayout expr1 cmtTbl in + match Parens.expr expr1 with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr1 braces + | Nothing -> doc + in + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.text "while "; + (if ParsetreeViewer.isBlockExpr expr1 then condition + else Doc.group (Doc.ifBreaks (addParens condition) condition)); + Doc.space; + printExpressionBlock ~customLayout ~braces:true expr2 cmtTbl; + ]) | Pexp_for (pattern, fromExpr, toExpr, directionFlag, body) -> - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.text "for "; - printPattern ~customLayout pattern cmtTbl; - Doc.text " in "; - (let doc = - printExpressionWithComments ~customLayout fromExpr cmtTbl - in - match Parens.expr fromExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc fromExpr braces - | Nothing -> doc); - printDirectionFlag directionFlag; - (let doc = - printExpressionWithComments ~customLayout toExpr cmtTbl - in - match Parens.expr toExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc toExpr braces - | Nothing -> doc); - Doc.space; - printExpressionBlock ~customLayout ~braces:true body cmtTbl; - ]) + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.text "for "; + printPattern ~customLayout pattern cmtTbl; + Doc.text " in "; + (let doc = + printExpressionWithComments ~customLayout fromExpr cmtTbl + in + match Parens.expr fromExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc fromExpr braces + | Nothing -> doc); + printDirectionFlag directionFlag; + (let doc = + printExpressionWithComments ~customLayout toExpr cmtTbl + in + match Parens.expr toExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc toExpr braces + | Nothing -> doc); + Doc.space; + printExpressionBlock ~customLayout ~braces:true body cmtTbl; + ]) | Pexp_constraint - ( {pexp_desc = Pexp_pack modExpr}, - {ptyp_desc = Ptyp_package packageType; ptyp_loc} ) -> - Doc.group - (Doc.concat - [ - Doc.text "module("; - Doc.indent - (Doc.concat - [ - Doc.softLine; - printModExpr ~customLayout modExpr cmtTbl; - Doc.text ": "; - printComments - (printPackageType ~customLayout - ~printModuleKeywordAndParens:false packageType cmtTbl) - cmtTbl ptyp_loc; - ]); - Doc.softLine; - Doc.rparen; - ]) + ( { pexp_desc = Pexp_pack modExpr }, + { ptyp_desc = Ptyp_package packageType; ptyp_loc } ) -> + Doc.group + (Doc.concat + [ + Doc.text "module("; + Doc.indent + (Doc.concat + [ + Doc.softLine; + printModExpr ~customLayout modExpr cmtTbl; + Doc.text ": "; + printComments + (printPackageType ~customLayout + ~printModuleKeywordAndParens:false packageType cmtTbl) + cmtTbl ptyp_loc; + ]); + Doc.softLine; + Doc.rparen; + ]) | Pexp_constraint (expr, typ) -> - let exprDoc = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat [exprDoc; Doc.text ": "; printTypExpr ~customLayout typ cmtTbl] - | Pexp_letmodule ({txt = _modName}, _modExpr, _expr) -> - printExpressionBlock ~customLayout ~braces:true e cmtTbl + let exprDoc = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat + [ exprDoc; Doc.text ": "; printTypExpr ~customLayout typ cmtTbl ] + | Pexp_letmodule ({ txt = _modName }, _modExpr, _expr) -> + printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_letexception (_extensionConstructor, _expr) -> - printExpressionBlock ~customLayout ~braces:true e cmtTbl + printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_assert expr -> - let rhs = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.lazyOrAssertOrAwaitExprRhs expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat [Doc.text "assert "; rhs] + let rhs = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.lazyOrAssertOrAwaitExprRhs expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [ Doc.text "assert "; rhs ] | Pexp_lazy expr -> - let rhs = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.lazyOrAssertOrAwaitExprRhs expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.group (Doc.concat [Doc.text "lazy "; rhs]) + let rhs = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.lazyOrAssertOrAwaitExprRhs expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.group (Doc.concat [ Doc.text "lazy "; rhs ]) | Pexp_open (_overrideFlag, _longidentLoc, _expr) -> - printExpressionBlock ~customLayout ~braces:true e cmtTbl + printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_pack modExpr -> - Doc.group - (Doc.concat - [ - Doc.text "module("; - Doc.indent - (Doc.concat - [Doc.softLine; printModExpr ~customLayout modExpr cmtTbl]); - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + Doc.text "module("; + Doc.indent + (Doc.concat + [ Doc.softLine; printModExpr ~customLayout modExpr cmtTbl ]); + Doc.softLine; + Doc.rparen; + ]) | Pexp_sequence _ -> - printExpressionBlock ~customLayout ~braces:true e cmtTbl + printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_let _ -> printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_fun ( Nolabel, None, - {ppat_desc = Ppat_var {txt = "__x"}}, - {pexp_desc = Pexp_apply _} ) -> - (* (__x) => f(a, __x, c) -----> f(a, _, c) *) - printExpressionWithComments ~customLayout - (ParsetreeViewer.rewriteUnderscoreApply e) - cmtTbl + { ppat_desc = Ppat_var { txt = "__x" } }, + { pexp_desc = Pexp_apply _ } ) -> + (* (__x) => f(a, __x, c) -----> f(a, _, c) *) + printExpressionWithComments ~customLayout + (ParsetreeViewer.rewriteUnderscoreApply e) + cmtTbl | Pexp_fun _ | Pexp_newtype _ -> - let attrsOnArrow, parameters, returnExpr = ParsetreeViewer.funExpr e in - let ParsetreeViewer.{async; uncurried; attributes = attrs} = - ParsetreeViewer.processFunctionAttributes attrsOnArrow - in - let returnExpr, typConstraint = - match returnExpr.pexp_desc with - | Pexp_constraint (expr, typ) -> - ( { - expr with - pexp_attributes = - List.concat [expr.pexp_attributes; returnExpr.pexp_attributes]; - }, - Some typ ) - | _ -> (returnExpr, None) - in - let hasConstraint = - match typConstraint with - | Some _ -> true - | None -> false - in - let parametersDoc = - printExprFunParameters ~customLayout ~inCallback:NoCallback ~uncurried - ~async ~hasConstraint parameters cmtTbl - in - let returnExprDoc = - let optBraces, _ = ParsetreeViewer.processBracesAttr returnExpr in - let shouldInline = - match (returnExpr.pexp_desc, optBraces) with - | _, Some _ -> true - | ( ( Pexp_array _ | Pexp_tuple _ - | Pexp_construct (_, Some _) - | Pexp_record _ ), - _ ) -> - true - | _ -> false + let attrsOnArrow, parameters, returnExpr = ParsetreeViewer.funExpr e in + let ParsetreeViewer.{ async; uncurried; attributes = attrs } = + ParsetreeViewer.processFunctionAttributes attrsOnArrow in - let shouldIndent = + let returnExpr, typConstraint = match returnExpr.pexp_desc with - | Pexp_sequence _ | Pexp_let _ | Pexp_letmodule _ - | Pexp_letexception _ | Pexp_open _ -> - false - | _ -> true + | Pexp_constraint (expr, typ) -> + ( { + expr with + pexp_attributes = + List.concat + [ expr.pexp_attributes; returnExpr.pexp_attributes ]; + }, + Some typ ) + | _ -> (returnExpr, None) in - let returnDoc = - let doc = - printExpressionWithComments ~customLayout returnExpr cmtTbl + let hasConstraint = + match typConstraint with Some _ -> true | None -> false + in + let parametersDoc = + printExprFunParameters ~customLayout ~inCallback:NoCallback ~uncurried + ~async ~hasConstraint parameters cmtTbl + in + let returnExprDoc = + let optBraces, _ = ParsetreeViewer.processBracesAttr returnExpr in + let shouldInline = + match (returnExpr.pexp_desc, optBraces) with + | _, Some _ -> true + | ( ( Pexp_array _ | Pexp_tuple _ + | Pexp_construct (_, Some _) + | Pexp_record _ ), + _ ) -> + true + | _ -> false in - match Parens.expr returnExpr with + let shouldIndent = + match returnExpr.pexp_desc with + | Pexp_sequence _ | Pexp_let _ | Pexp_letmodule _ + | Pexp_letexception _ | Pexp_open _ -> + false + | _ -> true + in + let returnDoc = + let doc = + printExpressionWithComments ~customLayout returnExpr cmtTbl + in + match Parens.expr returnExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc returnExpr braces + | Nothing -> doc + in + if shouldInline then Doc.concat [ Doc.space; returnDoc ] + else + Doc.group + (if shouldIndent then + Doc.indent (Doc.concat [ Doc.line; returnDoc ]) + else Doc.concat [ Doc.space; returnDoc ]) + in + let typConstraintDoc = + match typConstraint with + | Some typ -> + let typDoc = + let doc = printTypExpr ~customLayout typ cmtTbl in + if Parens.arrowReturnTypExpr typ then addParens doc else doc + in + Doc.concat [ Doc.text ": "; typDoc ] + | _ -> Doc.nil + in + let attrs = printAttributes ~customLayout attrs cmtTbl in + Doc.group + (Doc.concat + [ + attrs; + parametersDoc; + typConstraintDoc; + Doc.text " =>"; + returnExprDoc; + ]) + | Pexp_try (expr, cases) -> + let exprDoc = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc returnExpr braces + | Braced braces -> printBraces doc expr braces | Nothing -> doc in - if shouldInline then Doc.concat [Doc.space; returnDoc] - else - Doc.group - (if shouldIndent then Doc.indent (Doc.concat [Doc.line; returnDoc]) - else Doc.concat [Doc.space; returnDoc]) - in - let typConstraintDoc = - match typConstraint with - | Some typ -> - let typDoc = - let doc = printTypExpr ~customLayout typ cmtTbl in - if Parens.arrowReturnTypExpr typ then addParens doc else doc - in - Doc.concat [Doc.text ": "; typDoc] - | _ -> Doc.nil - in - let attrs = printAttributes ~customLayout attrs cmtTbl in - Doc.group - (Doc.concat - [ - attrs; - parametersDoc; - typConstraintDoc; - Doc.text " =>"; - returnExprDoc; - ]) - | Pexp_try (expr, cases) -> - let exprDoc = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat - [ - Doc.text "try "; - exprDoc; - Doc.text " catch "; - printCases ~customLayout cases cmtTbl; - ] - | Pexp_match (_, [_; _]) when ParsetreeViewer.isIfLetExpr e -> - let ifs, elseExpr = ParsetreeViewer.collectIfExpressions e in - printIfChain ~customLayout e.pexp_attributes ifs elseExpr cmtTbl + Doc.concat + [ + Doc.text "try "; + exprDoc; + Doc.text " catch "; + printCases ~customLayout cases cmtTbl; + ] + | Pexp_match (_, [ _; _ ]) when ParsetreeViewer.isIfLetExpr e -> + let ifs, elseExpr = ParsetreeViewer.collectIfExpressions e in + printIfChain ~customLayout e.pexp_attributes ifs elseExpr cmtTbl | Pexp_match (expr, cases) -> - let exprDoc = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat - [ - Doc.text "switch "; - exprDoc; - Doc.space; - printCases ~customLayout cases cmtTbl; - ] + let exprDoc = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat + [ + Doc.text "switch "; + exprDoc; + Doc.space; + printCases ~customLayout cases cmtTbl; + ] | Pexp_function cases -> - Doc.concat - [Doc.text "x => switch x "; printCases ~customLayout cases cmtTbl] + Doc.concat + [ Doc.text "x => switch x "; printCases ~customLayout cases cmtTbl ] | Pexp_coerce (expr, typOpt, typ) -> - let docExpr = printExpressionWithComments ~customLayout expr cmtTbl in - let docTyp = printTypExpr ~customLayout typ cmtTbl in - let ofType = - match typOpt with - | None -> Doc.nil - | Some typ1 -> - Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ1 cmtTbl] - in - Doc.concat - [Doc.lparen; docExpr; ofType; Doc.text " :> "; docTyp; Doc.rparen] + let docExpr = printExpressionWithComments ~customLayout expr cmtTbl in + let docTyp = printTypExpr ~customLayout typ cmtTbl in + let ofType = + match typOpt with + | None -> Doc.nil + | Some typ1 -> + Doc.concat + [ Doc.text ": "; printTypExpr ~customLayout typ1 cmtTbl ] + in + Doc.concat + [ Doc.lparen; docExpr; ofType; Doc.text " :> "; docTyp; Doc.rparen ] | Pexp_send (parentExpr, label) -> - let parentDoc = - let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces - | Nothing -> doc - in - let member = - let memberDoc = printComments (Doc.text label.txt) cmtTbl label.loc in - Doc.concat [Doc.text "\""; memberDoc; Doc.text "\""] - in - Doc.group (Doc.concat [parentDoc; Doc.lbracket; member; Doc.rbracket]) + let parentDoc = + let doc = + printExpressionWithComments ~customLayout parentExpr cmtTbl + in + match Parens.unaryExprOperand parentExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc parentExpr braces + | Nothing -> doc + in + let member = + let memberDoc = printComments (Doc.text label.txt) cmtTbl label.loc in + Doc.concat [ Doc.text "\""; memberDoc; Doc.text "\"" ] + in + Doc.group (Doc.concat [ parentDoc; Doc.lbracket; member; Doc.rbracket ]) | Pexp_new _ -> Doc.text "Pexp_new not impemented in printer" | Pexp_setinstvar _ -> Doc.text "Pexp_setinstvar not impemented in printer" | Pexp_override _ -> Doc.text "Pexp_override not impemented in printer" @@ -56126,7 +56345,7 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = pexp_attributes = List.filter (function - | {Location.txt = "res.await" | "ns.braces"}, _ -> false + | { Location.txt = "res.await" | "ns.braces" }, _ -> false | _ -> true) e.pexp_attributes; } @@ -56135,55 +56354,53 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = | Braced braces -> printBraces printedExpression e braces | Nothing -> printedExpression in - Doc.concat [Doc.text "await "; rhs] + Doc.concat [ Doc.text "await "; rhs ] else printedExpression in let shouldPrintItsOwnAttributes = match e.pexp_desc with | Pexp_apply _ | Pexp_fun _ | Pexp_newtype _ | Pexp_setfield _ | Pexp_ifthenelse _ -> - true + true | Pexp_match _ when ParsetreeViewer.isIfLetExpr e -> true | Pexp_construct _ when ParsetreeViewer.hasJsxAttribute e.pexp_attributes -> - true + true | _ -> false in match e.pexp_attributes with | [] -> exprWithAwait | attrs when not shouldPrintItsOwnAttributes -> - Doc.group - (Doc.concat [printAttributes ~customLayout attrs cmtTbl; exprWithAwait]) + Doc.group + (Doc.concat + [ printAttributes ~customLayout attrs cmtTbl; exprWithAwait ]) | _ -> exprWithAwait and printPexpFun ~customLayout ~inCallback e cmtTbl = let attrsOnArrow, parameters, returnExpr = ParsetreeViewer.funExpr e in - let ParsetreeViewer.{async; uncurried; attributes = attrs} = + let ParsetreeViewer.{ async; uncurried; attributes = attrs } = ParsetreeViewer.processFunctionAttributes attrsOnArrow in let returnExpr, typConstraint = match returnExpr.pexp_desc with | Pexp_constraint (expr, typ) -> - ( { - expr with - pexp_attributes = - List.concat [expr.pexp_attributes; returnExpr.pexp_attributes]; - }, - Some typ ) + ( { + expr with + pexp_attributes = + List.concat [ expr.pexp_attributes; returnExpr.pexp_attributes ]; + }, + Some typ ) | _ -> (returnExpr, None) in let parametersDoc = printExprFunParameters ~customLayout ~inCallback ~async ~uncurried - ~hasConstraint: - (match typConstraint with - | Some _ -> true - | None -> false) + ~hasConstraint:(match typConstraint with Some _ -> true | None -> false) parameters cmtTbl in let returnShouldIndent = match returnExpr.pexp_desc with | Pexp_sequence _ | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ -> - false + false | _ -> true in let returnExprDoc = @@ -56195,7 +56412,7 @@ and printPexpFun ~customLayout ~inCallback e cmtTbl = | Pexp_construct (_, Some _) | Pexp_record _ ), _ ) -> - true + true | _ -> false in let returnDoc = @@ -56205,23 +56422,23 @@ and printPexpFun ~customLayout ~inCallback e cmtTbl = | Braced braces -> printBraces doc returnExpr braces | Nothing -> doc in - if shouldInline then Doc.concat [Doc.space; returnDoc] + if shouldInline then Doc.concat [ Doc.space; returnDoc ] else Doc.group (if returnShouldIndent then Doc.concat [ - Doc.indent (Doc.concat [Doc.line; returnDoc]); + Doc.indent (Doc.concat [ Doc.line; returnDoc ]); (match inCallback with | FitsOnOneLine | ArgumentsFitOnOneLine -> Doc.softLine | _ -> Doc.nil); ] - else Doc.concat [Doc.space; returnDoc]) + else Doc.concat [ Doc.space; returnDoc ]) in let typConstraintDoc = match typConstraint with | Some typ -> - Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ cmtTbl] + Doc.concat [ Doc.text ": "; printTypExpr ~customLayout typ cmtTbl ] | _ -> Doc.nil in Doc.concat @@ -56265,15 +56482,16 @@ and printSetFieldExpr ~customLayout attrs lhs longidentLoc rhs loc cmtTbl = printLidentPath longidentLoc cmtTbl; Doc.text " ="; (if shouldIndent then - Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) - else Doc.concat [Doc.space; rhsDoc]); + Doc.group (Doc.indent (Doc.concat [ Doc.line; rhsDoc ])) + else Doc.concat [ Doc.space; rhsDoc ]); ]) in let doc = match attrs with | [] -> doc | attrs -> - Doc.group (Doc.concat [printAttributes ~customLayout attrs cmtTbl; doc]) + Doc.group + (Doc.concat [ printAttributes ~customLayout attrs cmtTbl; doc ]) in printComments doc cmtTbl loc @@ -56283,17 +56501,17 @@ and printTemplateLiteral ~customLayout expr cmtTbl = let open Parsetree in match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident "^"}}, - [(Nolabel, arg1); (Nolabel, arg2)] ) -> - let lhs = walkExpr arg1 in - let rhs = walkExpr arg2 in - Doc.concat [lhs; rhs] + ( { pexp_desc = Pexp_ident { txt = Longident.Lident "^" } }, + [ (Nolabel, arg1); (Nolabel, arg2) ] ) -> + let lhs = walkExpr arg1 in + let rhs = walkExpr arg2 in + Doc.concat [ lhs; rhs ] | Pexp_constant (Pconst_string (txt, Some prefix)) -> - tag := prefix; - printStringContents txt + tag := prefix; + printStringContents txt | _ -> - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - Doc.group (Doc.concat [Doc.text "${"; Doc.indent doc; Doc.rbrace]) + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + Doc.group (Doc.concat [ Doc.text "${"; Doc.indent doc; Doc.rbrace ]) in let content = walkExpr expr in Doc.concat @@ -56317,17 +56535,17 @@ and printUnaryExpression ~customLayout expr cmtTbl = in match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [(Nolabel, operand)] ) -> - let printedOperand = - let doc = printExpressionWithComments ~customLayout operand cmtTbl in - match Parens.unaryExprOperand operand with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc operand braces - | Nothing -> doc - in - let doc = Doc.concat [printUnaryOperator operator; printedOperand] in - printComments doc cmtTbl expr.pexp_loc + ( { pexp_desc = Pexp_ident { txt = Longident.Lident operator } }, + [ (Nolabel, operand) ] ) -> + let printedOperand = + let doc = printExpressionWithComments ~customLayout operand cmtTbl in + match Parens.unaryExprOperand operand with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc operand braces + | Nothing -> doc + in + let doc = Doc.concat [ printUnaryOperator operator; printedOperand ] in + printComments doc cmtTbl expr.pexp_loc | _ -> assert false and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = @@ -56354,7 +56572,7 @@ and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = else Doc.line in Doc.concat - [spacingBeforeOperator; Doc.text operatorTxt; spacingAfterOperator] + [ spacingBeforeOperator; Doc.text operatorTxt; spacingAfterOperator ] in let printOperand ~isLhs expr parentOperator = let rec flatten ~isLhs expr parentOperator = @@ -56363,230 +56581,232 @@ and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = | { pexp_desc = Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [(_, left); (_, right)] ); + ( { pexp_desc = Pexp_ident { txt = Longident.Lident operator } }, + [ (_, left); (_, right) ] ); } -> - if - ParsetreeViewer.flattenableOperators parentOperator operator - && not (ParsetreeViewer.hasAttributes expr.pexp_attributes) - then - let leftPrinted = flatten ~isLhs:true left operator in - let rightPrinted = - let rightPrinteableAttrs, rightInternalAttrs = + if + ParsetreeViewer.flattenableOperators parentOperator operator + && not (ParsetreeViewer.hasAttributes expr.pexp_attributes) + then + let leftPrinted = flatten ~isLhs:true left operator in + let rightPrinted = + let rightPrinteableAttrs, rightInternalAttrs = + ParsetreeViewer.partitionPrintableAttributes + right.pexp_attributes + in + let doc = + printExpressionWithComments ~customLayout + { right with pexp_attributes = rightInternalAttrs } + cmtTbl + in + let doc = + if Parens.flattenOperandRhs parentOperator right then + Doc.concat [ Doc.lparen; doc; Doc.rparen ] + else doc + in + let doc = + Doc.concat + [ + printAttributes ~customLayout rightPrinteableAttrs cmtTbl; + doc; + ] + in + match rightPrinteableAttrs with [] -> doc | _ -> addParens doc + in + let isAwait = + ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes + in + let doc = + if isAwait then + Doc.concat + [ + Doc.text "await "; + Doc.lparen; + leftPrinted; + printBinaryOperator ~inlineRhs:false operator; + rightPrinted; + Doc.rparen; + ] + else + Doc.concat + [ + leftPrinted; + printBinaryOperator ~inlineRhs:false operator; + rightPrinted; + ] + in + + let doc = + if (not isLhs) && Parens.rhsBinaryExprOperand operator expr then + Doc.concat [ Doc.lparen; doc; Doc.rparen ] + else doc + in + printComments doc cmtTbl expr.pexp_loc + else + let printeableAttrs, internalAttrs = ParsetreeViewer.partitionPrintableAttributes - right.pexp_attributes + expr.pexp_attributes in let doc = printExpressionWithComments ~customLayout - {right with pexp_attributes = rightInternalAttrs} + { expr with pexp_attributes = internalAttrs } cmtTbl in let doc = - if Parens.flattenOperandRhs parentOperator right then - Doc.concat [Doc.lparen; doc; Doc.rparen] + if + Parens.subBinaryExprOperand parentOperator operator + || printeableAttrs <> [] + && (ParsetreeViewer.isBinaryExpression expr + || ParsetreeViewer.isTernaryExpr expr) + then Doc.concat [ Doc.lparen; doc; Doc.rparen ] else doc in - let doc = - Doc.concat - [ - printAttributes ~customLayout rightPrinteableAttrs cmtTbl; - doc; - ] - in - match rightPrinteableAttrs with - | [] -> doc - | _ -> addParens doc - in - let isAwait = - ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes - in - let doc = - if isAwait then - Doc.concat - [ - Doc.text "await "; - Doc.lparen; - leftPrinted; - printBinaryOperator ~inlineRhs:false operator; - rightPrinted; - Doc.rparen; - ] - else - Doc.concat - [ - leftPrinted; - printBinaryOperator ~inlineRhs:false operator; - rightPrinted; - ] - in - - let doc = - if (not isLhs) && Parens.rhsBinaryExprOperand operator expr then - Doc.concat [Doc.lparen; doc; Doc.rparen] - else doc - in - printComments doc cmtTbl expr.pexp_loc - else - let printeableAttrs, internalAttrs = - ParsetreeViewer.partitionPrintableAttributes expr.pexp_attributes - in - let doc = - printExpressionWithComments ~customLayout - {expr with pexp_attributes = internalAttrs} - cmtTbl - in - let doc = - if - Parens.subBinaryExprOperand parentOperator operator - || printeableAttrs <> [] - && (ParsetreeViewer.isBinaryExpression expr - || ParsetreeViewer.isTernaryExpr expr) - then Doc.concat [Doc.lparen; doc; Doc.rparen] - else doc - in - Doc.concat - [printAttributes ~customLayout printeableAttrs cmtTbl; doc] + Doc.concat + [ printAttributes ~customLayout printeableAttrs cmtTbl; doc ] | _ -> assert false else match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident "^"; loc}}, - [(Nolabel, _); (Nolabel, _)] ) + ( { pexp_desc = Pexp_ident { txt = Longident.Lident "^"; loc } }, + [ (Nolabel, _); (Nolabel, _) ] ) when loc.loc_ghost -> - let doc = printTemplateLiteral ~customLayout expr cmtTbl in - printComments doc cmtTbl expr.Parsetree.pexp_loc + let doc = printTemplateLiteral ~customLayout expr cmtTbl in + printComments doc cmtTbl expr.Parsetree.pexp_loc | Pexp_setfield (lhs, field, rhs) -> - let doc = - printSetFieldExpr ~customLayout expr.pexp_attributes lhs field rhs - expr.pexp_loc cmtTbl - in - if isLhs then addParens doc else doc + let doc = + printSetFieldExpr ~customLayout expr.pexp_attributes lhs field rhs + expr.pexp_loc cmtTbl + in + if isLhs then addParens doc else doc | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}}, - [(Nolabel, lhs); (Nolabel, rhs)] ) -> - let rhsDoc = printExpressionWithComments ~customLayout rhs cmtTbl in - let lhsDoc = printExpressionWithComments ~customLayout lhs cmtTbl in - (* TODO: unify indentation of "=" *) - let shouldIndent = ParsetreeViewer.isBinaryExpression rhs in - let doc = - Doc.group - (Doc.concat - [ - lhsDoc; - Doc.text " ="; - (if shouldIndent then - Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) - else Doc.concat [Doc.space; rhsDoc]); - ]) - in - let doc = - match expr.pexp_attributes with - | [] -> doc - | attrs -> + ( { pexp_desc = Pexp_ident { txt = Longident.Lident "#=" } }, + [ (Nolabel, lhs); (Nolabel, rhs) ] ) -> + let rhsDoc = printExpressionWithComments ~customLayout rhs cmtTbl in + let lhsDoc = printExpressionWithComments ~customLayout lhs cmtTbl in + (* TODO: unify indentation of "=" *) + let shouldIndent = ParsetreeViewer.isBinaryExpression rhs in + let doc = Doc.group - (Doc.concat [printAttributes ~customLayout attrs cmtTbl; doc]) - in - if isLhs then addParens doc else doc + (Doc.concat + [ + lhsDoc; + Doc.text " ="; + (if shouldIndent then + Doc.group (Doc.indent (Doc.concat [ Doc.line; rhsDoc ])) + else Doc.concat [ Doc.space; rhsDoc ]); + ]) + in + let doc = + match expr.pexp_attributes with + | [] -> doc + | attrs -> + Doc.group + (Doc.concat + [ printAttributes ~customLayout attrs cmtTbl; doc ]) + in + if isLhs then addParens doc else doc | _ -> ( - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.binaryExprOperand ~isLhs expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.binaryExprOperand ~isLhs expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) in flatten ~isLhs expr parentOperator in match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident (("|." | "|>") as op)}}, - [(Nolabel, lhs); (Nolabel, rhs)] ) + ( { + pexp_desc = Pexp_ident { txt = Longident.Lident (("|." | "|>") as op) }; + }, + [ (Nolabel, lhs); (Nolabel, rhs) ] ) when not (ParsetreeViewer.isBinaryExpression lhs || ParsetreeViewer.isBinaryExpression rhs || printAttributes ~customLayout expr.pexp_attributes cmtTbl <> Doc.nil) -> - let lhsHasCommentBelow = hasCommentBelow cmtTbl lhs.pexp_loc in - let lhsDoc = printOperand ~isLhs:true lhs op in - let rhsDoc = printOperand ~isLhs:false rhs op in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - lhsDoc; - (match (lhsHasCommentBelow, op) with - | true, "|." -> Doc.concat [Doc.softLine; Doc.text "->"] - | false, "|." -> Doc.text "->" - | true, "|>" -> Doc.concat [Doc.line; Doc.text "|> "] - | false, "|>" -> Doc.text " |> " - | _ -> Doc.nil); - rhsDoc; - ]) + let lhsHasCommentBelow = hasCommentBelow cmtTbl lhs.pexp_loc in + let lhsDoc = printOperand ~isLhs:true lhs op in + let rhsDoc = printOperand ~isLhs:false rhs op in + Doc.group + (Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + lhsDoc; + (match (lhsHasCommentBelow, op) with + | true, "|." -> Doc.concat [ Doc.softLine; Doc.text "->" ] + | false, "|." -> Doc.text "->" + | true, "|>" -> Doc.concat [ Doc.line; Doc.text "|> " ] + | false, "|>" -> Doc.text " |> " + | _ -> Doc.nil); + rhsDoc; + ]) | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [(Nolabel, lhs); (Nolabel, rhs)] ) -> - let right = - let operatorWithRhs = - let rhsDoc = printOperand ~isLhs:false rhs operator in - Doc.concat - [ - printBinaryOperator - ~inlineRhs:(ParsetreeViewer.shouldInlineRhsBinaryExpr rhs) - operator; - rhsDoc; - ] + ( { pexp_desc = Pexp_ident { txt = Longident.Lident operator } }, + [ (Nolabel, lhs); (Nolabel, rhs) ] ) -> + let right = + let operatorWithRhs = + let rhsDoc = printOperand ~isLhs:false rhs operator in + Doc.concat + [ + printBinaryOperator + ~inlineRhs:(ParsetreeViewer.shouldInlineRhsBinaryExpr rhs) + operator; + rhsDoc; + ] + in + if ParsetreeViewer.shouldIndentBinaryExpr expr then + Doc.group (Doc.indent operatorWithRhs) + else operatorWithRhs in - if ParsetreeViewer.shouldIndentBinaryExpr expr then - Doc.group (Doc.indent operatorWithRhs) - else operatorWithRhs - in - let doc = - Doc.group (Doc.concat [printOperand ~isLhs:true lhs operator; right]) - in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - (match - Parens.binaryExpr - { - expr with - pexp_attributes = - ParsetreeViewer.filterPrintableAttributes - expr.pexp_attributes; - } - with - | Braced bracesLoc -> printBraces doc expr bracesLoc - | Parenthesized -> addParens doc - | Nothing -> doc); - ]) + let doc = + Doc.group (Doc.concat [ printOperand ~isLhs:true lhs operator; right ]) + in + Doc.group + (Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + (match + Parens.binaryExpr + { + expr with + pexp_attributes = + ParsetreeViewer.filterPrintableAttributes + expr.pexp_attributes; + } + with + | Braced bracesLoc -> printBraces doc expr bracesLoc + | Parenthesized -> addParens doc + | Nothing -> doc); + ]) | _ -> Doc.nil and printBeltListConcatApply ~customLayout subLists cmtTbl = let makeSpreadDoc commaBeforeSpread = function | Some expr -> - Doc.concat - [ - commaBeforeSpread; - Doc.dotdotdot; - (let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); - ] + Doc.concat + [ + commaBeforeSpread; + Doc.dotdotdot; + (let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + ] | None -> Doc.nil in let makeSubListDoc (expressions, spread) = let commaBeforeSpread = match expressions with | [] -> Doc.nil - | _ -> Doc.concat [Doc.text ","; Doc.line] + | _ -> Doc.concat [ Doc.text ","; Doc.line ] in let spreadDoc = makeSpreadDoc commaBeforeSpread spread in Doc.concat [ Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) (List.map (fun expr -> let doc = @@ -56609,7 +56829,7 @@ and printBeltListConcatApply ~customLayout subLists cmtTbl = [ Doc.softLine; Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) (List.map makeSubListDoc (List.map ParsetreeViewer.collectListExpressions subLists)); ]); @@ -56622,228 +56842,243 @@ and printBeltListConcatApply ~customLayout subLists cmtTbl = and printPexpApply ~customLayout expr cmtTbl = match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident "##"}}, - [(Nolabel, parentExpr); (Nolabel, memberExpr)] ) -> - let parentDoc = - let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces - | Nothing -> doc - in - let member = - let memberDoc = - match memberExpr.pexp_desc with - | Pexp_ident lident -> - printComments (printLongident lident.txt) cmtTbl memberExpr.pexp_loc - | _ -> printExpressionWithComments ~customLayout memberExpr cmtTbl + ( { pexp_desc = Pexp_ident { txt = Longident.Lident "##" } }, + [ (Nolabel, parentExpr); (Nolabel, memberExpr) ] ) -> + let parentDoc = + let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in + match Parens.unaryExprOperand parentExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc parentExpr braces + | Nothing -> doc + in + let member = + let memberDoc = + match memberExpr.pexp_desc with + | Pexp_ident lident -> + printComments + (printLongident lident.txt) + cmtTbl memberExpr.pexp_loc + | _ -> printExpressionWithComments ~customLayout memberExpr cmtTbl + in + Doc.concat [ Doc.text "\""; memberDoc; Doc.text "\"" ] in - Doc.concat [Doc.text "\""; memberDoc; Doc.text "\""] - in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - parentDoc; - Doc.lbracket; - member; - Doc.rbracket; - ]) - | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}}, - [(Nolabel, lhs); (Nolabel, rhs)] ) -> ( - let rhsDoc = - let doc = printExpressionWithComments ~customLayout rhs cmtTbl in - match Parens.expr rhs with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc rhs braces - | Nothing -> doc - in - (* TODO: unify indentation of "=" *) - let shouldIndent = - (not (ParsetreeViewer.isBracedExpr rhs)) - && ParsetreeViewer.isBinaryExpression rhs - in - let doc = Doc.group (Doc.concat [ - printExpressionWithComments ~customLayout lhs cmtTbl; - Doc.text " ="; - (if shouldIndent then - Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) - else Doc.concat [Doc.space; rhsDoc]); + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + parentDoc; + Doc.lbracket; + member; + Doc.rbracket; ]) - in - match expr.pexp_attributes with - | [] -> doc - | attrs -> - Doc.group (Doc.concat [printAttributes ~customLayout attrs cmtTbl; doc])) | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "get")}}, - [(Nolabel, parentExpr); (Nolabel, memberExpr)] ) - when not (ParsetreeViewer.isRewrittenUnderscoreApplySugar parentExpr) -> - (* Don't print the Array.get(_, 0) sugar a.k.a. (__x) => Array.get(__x, 0) as _[0] *) - let member = - let memberDoc = - let doc = printExpressionWithComments ~customLayout memberExpr cmtTbl in - match Parens.expr memberExpr with + ( { pexp_desc = Pexp_ident { txt = Longident.Lident "#=" } }, + [ (Nolabel, lhs); (Nolabel, rhs) ] ) -> ( + let rhsDoc = + let doc = printExpressionWithComments ~customLayout rhs cmtTbl in + match Parens.expr rhs with | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc memberExpr braces + | Braced braces -> printBraces doc rhs braces | Nothing -> doc in - let shouldInline = - match memberExpr.pexp_desc with - | Pexp_constant _ | Pexp_ident _ -> true - | _ -> false + (* TODO: unify indentation of "=" *) + let shouldIndent = + (not (ParsetreeViewer.isBracedExpr rhs)) + && ParsetreeViewer.isBinaryExpression rhs in - if shouldInline then memberDoc - else - Doc.concat - [Doc.indent (Doc.concat [Doc.softLine; memberDoc]); Doc.softLine] - in - let parentDoc = - let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces - | Nothing -> doc - in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - parentDoc; - Doc.lbracket; - member; - Doc.rbracket; - ]) + let doc = + Doc.group + (Doc.concat + [ + printExpressionWithComments ~customLayout lhs cmtTbl; + Doc.text " ="; + (if shouldIndent then + Doc.group (Doc.indent (Doc.concat [ Doc.line; rhsDoc ])) + else Doc.concat [ Doc.space; rhsDoc ]); + ]) + in + match expr.pexp_attributes with + | [] -> doc + | attrs -> + Doc.group + (Doc.concat [ printAttributes ~customLayout attrs cmtTbl; doc ])) | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "set")}}, - [(Nolabel, parentExpr); (Nolabel, memberExpr); (Nolabel, targetExpr)] ) - -> - let member = - let memberDoc = - let doc = printExpressionWithComments ~customLayout memberExpr cmtTbl in - match Parens.expr memberExpr with + ( { + pexp_desc = Pexp_ident { txt = Longident.Ldot (Lident "Array", "get") }; + }, + [ (Nolabel, parentExpr); (Nolabel, memberExpr) ] ) + when not (ParsetreeViewer.isRewrittenUnderscoreApplySugar parentExpr) -> + (* Don't print the Array.get(_, 0) sugar a.k.a. (__x) => Array.get(__x, 0) as _[0] *) + let member = + let memberDoc = + let doc = + printExpressionWithComments ~customLayout memberExpr cmtTbl + in + match Parens.expr memberExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc memberExpr braces + | Nothing -> doc + in + let shouldInline = + match memberExpr.pexp_desc with + | Pexp_constant _ | Pexp_ident _ -> true + | _ -> false + in + if shouldInline then memberDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [ Doc.softLine; memberDoc ]); Doc.softLine; + ] + in + let parentDoc = + let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in + match Parens.unaryExprOperand parentExpr with | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc memberExpr braces + | Braced braces -> printBraces doc parentExpr braces | Nothing -> doc in - let shouldInline = - match memberExpr.pexp_desc with - | Pexp_constant _ | Pexp_ident _ -> true - | _ -> false + Doc.group + (Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + parentDoc; + Doc.lbracket; + member; + Doc.rbracket; + ]) + | Pexp_apply + ( { + pexp_desc = Pexp_ident { txt = Longident.Ldot (Lident "Array", "set") }; + }, + [ (Nolabel, parentExpr); (Nolabel, memberExpr); (Nolabel, targetExpr) ] + ) -> + let member = + let memberDoc = + let doc = + printExpressionWithComments ~customLayout memberExpr cmtTbl + in + match Parens.expr memberExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc memberExpr braces + | Nothing -> doc + in + let shouldInline = + match memberExpr.pexp_desc with + | Pexp_constant _ | Pexp_ident _ -> true + | _ -> false + in + if shouldInline then memberDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [ Doc.softLine; memberDoc ]); Doc.softLine; + ] in - if shouldInline then memberDoc - else - Doc.concat - [Doc.indent (Doc.concat [Doc.softLine; memberDoc]); Doc.softLine] - in - let shouldIndentTargetExpr = - if ParsetreeViewer.isBracedExpr targetExpr then false - else - ParsetreeViewer.isBinaryExpression targetExpr - || - match targetExpr with - | { - pexp_attributes = [({Location.txt = "ns.ternary"}, _)]; - pexp_desc = Pexp_ifthenelse (ifExpr, _, _); - } -> - ParsetreeViewer.isBinaryExpression ifExpr - || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes - | {pexp_desc = Pexp_newtype _} -> false - | e -> - ParsetreeViewer.hasAttributes e.pexp_attributes - || ParsetreeViewer.isArrayAccess e - in - let targetExpr = - let doc = printExpressionWithComments ~customLayout targetExpr cmtTbl in - match Parens.expr targetExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc targetExpr braces - | Nothing -> doc - in - let parentDoc = - let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces - | Nothing -> doc - in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - parentDoc; - Doc.lbracket; - member; - Doc.rbracket; - Doc.text " ="; - (if shouldIndentTargetExpr then - Doc.indent (Doc.concat [Doc.line; targetExpr]) - else Doc.concat [Doc.space; targetExpr]); - ]) + let shouldIndentTargetExpr = + if ParsetreeViewer.isBracedExpr targetExpr then false + else + ParsetreeViewer.isBinaryExpression targetExpr + || + match targetExpr with + | { + pexp_attributes = [ ({ Location.txt = "ns.ternary" }, _) ]; + pexp_desc = Pexp_ifthenelse (ifExpr, _, _); + } -> + ParsetreeViewer.isBinaryExpression ifExpr + || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes + | { pexp_desc = Pexp_newtype _ } -> false + | e -> + ParsetreeViewer.hasAttributes e.pexp_attributes + || ParsetreeViewer.isArrayAccess e + in + let targetExpr = + let doc = printExpressionWithComments ~customLayout targetExpr cmtTbl in + match Parens.expr targetExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc targetExpr braces + | Nothing -> doc + in + let parentDoc = + let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in + match Parens.unaryExprOperand parentExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc parentExpr braces + | Nothing -> doc + in + Doc.group + (Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + parentDoc; + Doc.lbracket; + member; + Doc.rbracket; + Doc.text " ="; + (if shouldIndentTargetExpr then + Doc.indent (Doc.concat [ Doc.line; targetExpr ]) + else Doc.concat [ Doc.space; targetExpr ]); + ]) (* TODO: cleanup, are those branches even remotely performant? *) - | Pexp_apply ({pexp_desc = Pexp_ident lident}, args) + | Pexp_apply ({ pexp_desc = Pexp_ident lident }, args) when ParsetreeViewer.isJsxExpression expr -> - printJsxExpression ~customLayout lident args cmtTbl + printJsxExpression ~customLayout lident args cmtTbl | Pexp_apply (callExpr, args) -> - let args = - List.map - (fun (lbl, arg) -> (lbl, ParsetreeViewer.rewriteUnderscoreApply arg)) - args - in - let uncurried, attrs = - ParsetreeViewer.processUncurriedAttribute expr.pexp_attributes - in - let callExprDoc = - let doc = printExpressionWithComments ~customLayout callExpr cmtTbl in - match Parens.callExpr callExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc callExpr braces - | Nothing -> doc - in - if ParsetreeViewer.requiresSpecialCallbackPrintingFirstArg args then - let argsDoc = - printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args - cmtTbl + let args = + List.map + (fun (lbl, arg) -> (lbl, ParsetreeViewer.rewriteUnderscoreApply arg)) + args in - Doc.concat - [printAttributes ~customLayout attrs cmtTbl; callExprDoc; argsDoc] - else if ParsetreeViewer.requiresSpecialCallbackPrintingLastArg args then - let argsDoc = - printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args - cmtTbl + let uncurried, attrs = + ParsetreeViewer.processUncurriedAttribute expr.pexp_attributes in - (* - * Fixes the following layout (the `[` and `]` should break): - * [fn(x => { - * let _ = x - * }), fn(y => { - * let _ = y - * }), fn(z => { - * let _ = z - * })] - * See `Doc.willBreak documentation in interface file for more context. - * Context: - * https://github.com/rescript-lang/syntax/issues/111 - * https://github.com/rescript-lang/syntax/issues/166 - *) - let maybeBreakParent = - if Doc.willBreak argsDoc then Doc.breakParent else Doc.nil + let callExprDoc = + let doc = printExpressionWithComments ~customLayout callExpr cmtTbl in + match Parens.callExpr callExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc callExpr braces + | Nothing -> doc in - Doc.concat - [ - maybeBreakParent; - printAttributes ~customLayout attrs cmtTbl; - callExprDoc; - argsDoc; - ] - else - let argsDoc = printArguments ~customLayout ~uncurried args cmtTbl in - Doc.concat - [printAttributes ~customLayout attrs cmtTbl; callExprDoc; argsDoc] + if ParsetreeViewer.requiresSpecialCallbackPrintingFirstArg args then + let argsDoc = + printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout + args cmtTbl + in + Doc.concat + [ printAttributes ~customLayout attrs cmtTbl; callExprDoc; argsDoc ] + else if ParsetreeViewer.requiresSpecialCallbackPrintingLastArg args then + let argsDoc = + printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args + cmtTbl + in + (* + * Fixes the following layout (the `[` and `]` should break): + * [fn(x => { + * let _ = x + * }), fn(y => { + * let _ = y + * }), fn(z => { + * let _ = z + * })] + * See `Doc.willBreak documentation in interface file for more context. + * Context: + * https://github.com/rescript-lang/syntax/issues/111 + * https://github.com/rescript-lang/syntax/issues/166 + *) + let maybeBreakParent = + if Doc.willBreak argsDoc then Doc.breakParent else Doc.nil + in + Doc.concat + [ + maybeBreakParent; + printAttributes ~customLayout attrs cmtTbl; + callExprDoc; + argsDoc; + ] + else + let argsDoc = printArguments ~customLayout ~uncurried args cmtTbl in + Doc.concat + [ printAttributes ~customLayout attrs cmtTbl; callExprDoc; argsDoc ] | _ -> assert false and printJsxExpression ~customLayout lident args cmtTbl = @@ -56855,9 +57090,9 @@ and printJsxExpression ~customLayout lident args cmtTbl = | Some { Parsetree.pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"}, None); + Pexp_construct ({ txt = Longident.Lident "[]" }, None); } -> - false + false | None -> false | _ -> true in @@ -56866,17 +57101,17 @@ and printJsxExpression ~customLayout lident args cmtTbl = | Some { Parsetree.pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"}, None); + Pexp_construct ({ txt = Longident.Lident "[]" }, None); pexp_loc = loc; } -> - not (hasCommentsInside cmtTbl loc) + not (hasCommentsInside cmtTbl loc) | _ -> false in let printChildren children = let lineSep = match children with | Some expr -> - if hasNestedJsxOrMoreThanOneChild expr then Doc.hardLine else Doc.line + if hasNestedJsxOrMoreThanOneChild expr then Doc.hardLine else Doc.line | None -> Doc.line in Doc.concat @@ -56887,8 +57122,8 @@ and printJsxExpression ~customLayout lident args cmtTbl = Doc.line; (match children with | Some childrenExpression -> - printJsxChildren ~customLayout childrenExpression ~sep:lineSep - cmtTbl + printJsxChildren ~customLayout childrenExpression + ~sep:lineSep cmtTbl | None -> Doc.nil); ]); lineSep; @@ -56901,27 +57136,27 @@ and printJsxExpression ~customLayout lident args cmtTbl = (Doc.concat [ printComments - (Doc.concat [Doc.lessThan; name]) + (Doc.concat [ Doc.lessThan; name ]) cmtTbl lident.Asttypes.loc; formattedProps; (match children with | Some { Parsetree.pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"}, None); + Pexp_construct ({ txt = Longident.Lident "[]" }, None); } when isSelfClosing -> - Doc.text "/>" + Doc.text "/>" | _ -> - (* if tag A has trailing comments then put > on the next line - - - *) - if hasTrailingComments cmtTbl lident.Asttypes.loc then - Doc.concat [Doc.softLine; Doc.greaterThan] - else Doc.greaterThan); + (* if tag A has trailing comments then put > on the next line + + + *) + if hasTrailingComments cmtTbl lident.Asttypes.loc then + Doc.concat [ Doc.softLine; Doc.greaterThan ] + else Doc.greaterThan); ]); (if isSelfClosing then Doc.nil else @@ -56933,10 +57168,10 @@ and printJsxExpression ~customLayout lident args cmtTbl = | Some { Parsetree.pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"}, None); + Pexp_construct ({ txt = Longident.Lident "[]" }, None); pexp_loc = loc; } -> - printCommentsInside cmtTbl loc + printCommentsInside cmtTbl loc | _ -> Doc.nil); Doc.text " Doc.nil + | Pexp_construct ({ txt = Longident.Lident "[]" }, None) -> Doc.nil | _ -> - Doc.indent - (Doc.concat - [ - Doc.line; - printJsxChildren ~customLayout expr ~sep:lineSep cmtTbl; - ])); + Doc.indent + (Doc.concat + [ + Doc.line; + printJsxChildren ~customLayout expr ~sep:lineSep cmtTbl; + ])); lineSep; closing; ]) @@ -56970,52 +57205,53 @@ and printJsxFragment ~customLayout expr cmtTbl = and printJsxChildren ~customLayout (childrenExpr : Parsetree.expression) ~sep cmtTbl = match childrenExpr.pexp_desc with - | Pexp_construct ({txt = Longident.Lident "::"}, _) -> - let children, _ = ParsetreeViewer.collectListExpressions childrenExpr in - Doc.group - (Doc.join ~sep - (List.map - (fun (expr : Parsetree.expression) -> - let leadingLineCommentPresent = - hasLeadingLineComment cmtTbl expr.pexp_loc - in - let exprDoc = - printExpressionWithComments ~customLayout expr cmtTbl - in - let addParensOrBraces exprDoc = - (* {(20: int)} make sure that we also protect the expression inside *) - let innerDoc = - if Parens.bracedExpr expr then addParens exprDoc else exprDoc + | Pexp_construct ({ txt = Longident.Lident "::" }, _) -> + let children, _ = ParsetreeViewer.collectListExpressions childrenExpr in + Doc.group + (Doc.join ~sep + (List.map + (fun (expr : Parsetree.expression) -> + let leadingLineCommentPresent = + hasLeadingLineComment cmtTbl expr.pexp_loc in - if leadingLineCommentPresent then addBraces innerDoc - else Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace] - in - match Parens.jsxChildExpr expr with - | Nothing -> exprDoc - | Parenthesized -> addParensOrBraces exprDoc - | Braced bracesLoc -> - printComments (addParensOrBraces exprDoc) cmtTbl bracesLoc) - children)) + let exprDoc = + printExpressionWithComments ~customLayout expr cmtTbl + in + let addParensOrBraces exprDoc = + (* {(20: int)} make sure that we also protect the expression inside *) + let innerDoc = + if Parens.bracedExpr expr then addParens exprDoc + else exprDoc + in + if leadingLineCommentPresent then addBraces innerDoc + else Doc.concat [ Doc.lbrace; innerDoc; Doc.rbrace ] + in + match Parens.jsxChildExpr expr with + | Nothing -> exprDoc + | Parenthesized -> addParensOrBraces exprDoc + | Braced bracesLoc -> + printComments (addParensOrBraces exprDoc) cmtTbl bracesLoc) + children)) | _ -> - let leadingLineCommentPresent = - hasLeadingLineComment cmtTbl childrenExpr.pexp_loc - in - let exprDoc = - printExpressionWithComments ~customLayout childrenExpr cmtTbl - in - Doc.concat - [ - Doc.dotdotdot; - (match Parens.jsxChildExpr childrenExpr with - | Parenthesized | Braced _ -> - let innerDoc = - if Parens.bracedExpr childrenExpr then addParens exprDoc - else exprDoc - in - if leadingLineCommentPresent then addBraces innerDoc - else Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace] - | Nothing -> exprDoc); - ] + let leadingLineCommentPresent = + hasLeadingLineComment cmtTbl childrenExpr.pexp_loc + in + let exprDoc = + printExpressionWithComments ~customLayout childrenExpr cmtTbl + in + Doc.concat + [ + Doc.dotdotdot; + (match Parens.jsxChildExpr childrenExpr with + | Parenthesized | Braced _ -> + let innerDoc = + if Parens.bracedExpr childrenExpr then addParens exprDoc + else exprDoc + in + if leadingLineCommentPresent then addBraces innerDoc + else Doc.concat [ Doc.lbrace; innerDoc; Doc.rbrace ] + | Nothing -> exprDoc); + ] and printJsxProps ~customLayout args cmtTbl : Doc.t * Parsetree.expression option = @@ -57034,10 +57270,10 @@ and printJsxProps ~customLayout args cmtTbl : let isSelfClosing children = match children with | { - Parsetree.pexp_desc = Pexp_construct ({txt = Longident.Lident "[]"}, None); + Parsetree.pexp_desc = Pexp_construct ({ txt = Longident.Lident "[]" }, None); pexp_loc = loc; } -> - not (hasCommentsInside cmtTbl loc) + not (hasCommentsInside cmtTbl loc) | _ -> false in let rec loop props args = @@ -57048,50 +57284,50 @@ and printJsxProps ~customLayout args cmtTbl : ( Asttypes.Nolabel, { Parsetree.pexp_desc = - Pexp_construct ({txt = Longident.Lident "()"}, None); + Pexp_construct ({ txt = Longident.Lident "()" }, None); } ); ] -> - let doc = if isSelfClosing children then Doc.line else Doc.nil in - (doc, Some children) + let doc = if isSelfClosing children then Doc.line else Doc.nil in + (doc, Some children) | ((_, expr) as lastProp) :: [ (Asttypes.Labelled "children", children); ( Asttypes.Nolabel, { Parsetree.pexp_desc = - Pexp_construct ({txt = Longident.Lident "()"}, None); + Pexp_construct ({ txt = Longident.Lident "()" }, None); } ); ] -> - let loc = - match expr.Parsetree.pexp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _attrs -> - {loc with loc_end = expr.pexp_loc.loc_end} - | _ -> expr.pexp_loc - in - let trailingCommentsPresent = hasTrailingComments cmtTbl loc in - let propDoc = printJsxProp ~customLayout lastProp cmtTbl in - let formattedProps = - Doc.concat - [ - Doc.indent - (Doc.concat - [ - Doc.line; - Doc.group - (Doc.join ~sep:Doc.line (propDoc :: props |> List.rev)); - ]); - (* print > on new line if the last prop has trailing comments *) - (match (isSelfClosing children, trailingCommentsPresent) with - (* we always put /> on a new line when a self-closing tag breaks *) - | true, _ -> Doc.line - | false, true -> Doc.softLine - | false, false -> Doc.nil); - ] - in - (formattedProps, Some children) + let loc = + match expr.Parsetree.pexp_attributes with + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _attrs -> + { loc with loc_end = expr.pexp_loc.loc_end } + | _ -> expr.pexp_loc + in + let trailingCommentsPresent = hasTrailingComments cmtTbl loc in + let propDoc = printJsxProp ~customLayout lastProp cmtTbl in + let formattedProps = + Doc.concat + [ + Doc.indent + (Doc.concat + [ + Doc.line; + Doc.group + (Doc.join ~sep:Doc.line (propDoc :: props |> List.rev)); + ]); + (* print > on new line if the last prop has trailing comments *) + (match (isSelfClosing children, trailingCommentsPresent) with + (* we always put /> on a new line when a self-closing tag breaks *) + | true, _ -> Doc.line + | false, true -> Doc.softLine + | false, false -> Doc.nil); + ] + in + (formattedProps, Some children) | arg :: args -> - let propDoc = printJsxProp ~customLayout arg cmtTbl in - loop (propDoc :: props) args + let propDoc = printJsxProp ~customLayout arg cmtTbl in + loop (propDoc :: props) args in loop [] args @@ -57100,79 +57336,81 @@ and printJsxProp ~customLayout arg cmtTbl = | ( ((Asttypes.Labelled lblTxt | Optional lblTxt) as lbl), { Parsetree.pexp_attributes = - [({Location.txt = "ns.namedArgLoc"; loc = argLoc}, _)]; - pexp_desc = Pexp_ident {txt = Longident.Lident ident}; + [ ({ Location.txt = "ns.namedArgLoc"; loc = argLoc }, _) ]; + pexp_desc = Pexp_ident { txt = Longident.Lident ident }; } ) when lblTxt = ident (* jsx punning *) -> ( - match lbl with - | Nolabel -> Doc.nil - | Labelled _lbl -> printComments (printIdentLike ident) cmtTbl argLoc - | Optional _lbl -> - let doc = Doc.concat [Doc.question; printIdentLike ident] in - printComments doc cmtTbl argLoc) + match lbl with + | Nolabel -> Doc.nil + | Labelled _lbl -> printComments (printIdentLike ident) cmtTbl argLoc + | Optional _lbl -> + let doc = Doc.concat [ Doc.question; printIdentLike ident ] in + printComments doc cmtTbl argLoc) | ( ((Asttypes.Labelled lblTxt | Optional lblTxt) as lbl), { Parsetree.pexp_attributes = []; - pexp_desc = Pexp_ident {txt = Longident.Lident ident}; + pexp_desc = Pexp_ident { txt = Longident.Lident ident }; } ) when lblTxt = ident (* jsx punning when printing from Reason *) -> ( - match lbl with - | Nolabel -> Doc.nil - | Labelled _lbl -> printIdentLike ident - | Optional _lbl -> Doc.concat [Doc.question; printIdentLike ident]) - | Asttypes.Labelled "_spreadProps", expr -> - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - Doc.concat [Doc.lbrace; Doc.dotdotdot; Doc.softLine; doc; Doc.rbrace] - | lbl, expr -> - let argLoc, expr = - match expr.pexp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: attrs -> - (loc, {expr with pexp_attributes = attrs}) - | _ -> (Location.none, expr) - in - let lblDoc = match lbl with - | Asttypes.Labelled lbl -> - let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in - Doc.concat [lbl; Doc.equal] - | Asttypes.Optional lbl -> - let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in - Doc.concat [lbl; Doc.equal; Doc.question] | Nolabel -> Doc.nil - in - let exprDoc = - let leadingLineCommentPresent = - hasLeadingLineComment cmtTbl expr.pexp_loc - in + | Labelled _lbl -> printIdentLike ident + | Optional _lbl -> Doc.concat [ Doc.question; printIdentLike ident ]) + | Asttypes.Labelled "_spreadProps", expr -> let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.jsxPropExpr expr with - | Parenthesized | Braced _ -> - (* {(20: int)} make sure that we also protect the expression inside *) - let innerDoc = if Parens.bracedExpr expr then addParens doc else doc in - if leadingLineCommentPresent then addBraces innerDoc - else Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace] - | _ -> doc - in - let fullLoc = {argLoc with loc_end = expr.pexp_loc.loc_end} in - printComments (Doc.concat [lblDoc; exprDoc]) cmtTbl fullLoc + Doc.concat [ Doc.lbrace; Doc.dotdotdot; Doc.softLine; doc; Doc.rbrace ] + | lbl, expr -> + let argLoc, expr = + match expr.pexp_attributes with + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: attrs -> + (loc, { expr with pexp_attributes = attrs }) + | _ -> (Location.none, expr) + in + let lblDoc = + match lbl with + | Asttypes.Labelled lbl -> + let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in + Doc.concat [ lbl; Doc.equal ] + | Asttypes.Optional lbl -> + let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in + Doc.concat [ lbl; Doc.equal; Doc.question ] + | Nolabel -> Doc.nil + in + let exprDoc = + let leadingLineCommentPresent = + hasLeadingLineComment cmtTbl expr.pexp_loc + in + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.jsxPropExpr expr with + | Parenthesized | Braced _ -> + (* {(20: int)} make sure that we also protect the expression inside *) + let innerDoc = + if Parens.bracedExpr expr then addParens doc else doc + in + if leadingLineCommentPresent then addBraces innerDoc + else Doc.concat [ Doc.lbrace; innerDoc; Doc.rbrace ] + | _ -> doc + in + let fullLoc = { argLoc with loc_end = expr.pexp_loc.loc_end } in + printComments (Doc.concat [ lblDoc; exprDoc ]) cmtTbl fullLoc (* div -> div. * Navabar.createElement -> Navbar * Staff.Users.createElement -> Staff.Users *) -and printJsxName {txt = lident} = +and printJsxName { txt = lident } = let rec flatten acc lident = match lident with | Longident.Lident txt -> txt :: acc | Ldot (lident, txt) -> - let acc = if txt = "createElement" then acc else txt :: acc in - flatten acc lident + let acc = if txt = "createElement" then acc else txt :: acc in + flatten acc lident | _ -> acc in match lident with | Longident.Lident txt -> Doc.text txt | _ as lident -> - let segments = flatten [] lident in - Doc.join ~sep:Doc.dot (List.map Doc.text segments) + let segments = flatten [] lident in + Doc.join ~sep:Doc.dot (List.map Doc.text segments) and printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args cmtTbl = @@ -57184,29 +57422,32 @@ and printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args let callback, printedArgs = match args with | (lbl, expr) :: args -> - let lblDoc = - match lbl with - | Asttypes.Nolabel -> Doc.nil - | Asttypes.Labelled txt -> - Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal] - | Asttypes.Optional txt -> - Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal; Doc.question] - in - let callback = - Doc.concat - [ - lblDoc; - printPexpFun ~customLayout ~inCallback:FitsOnOneLine expr cmtTbl; - ] - in - let callback = lazy (printComments callback cmtTbl expr.pexp_loc) in - let printedArgs = - lazy - (Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map (fun arg -> printArgument ~customLayout arg cmtTbl) args)) - in - (callback, printedArgs) + let lblDoc = + match lbl with + | Asttypes.Nolabel -> Doc.nil + | Asttypes.Labelled txt -> + Doc.concat [ Doc.tilde; printIdentLike txt; Doc.equal ] + | Asttypes.Optional txt -> + Doc.concat + [ Doc.tilde; printIdentLike txt; Doc.equal; Doc.question ] + in + let callback = + Doc.concat + [ + lblDoc; + printPexpFun ~customLayout ~inCallback:FitsOnOneLine expr cmtTbl; + ] + in + let callback = lazy (printComments callback cmtTbl expr.pexp_loc) in + let printedArgs = + lazy + (Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun arg -> printArgument ~customLayout arg cmtTbl) + args)) + in + (callback, printedArgs) | _ -> assert false in @@ -57256,7 +57497,7 @@ and printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args *) if customLayout > customLayoutThreshold then Lazy.force breakAllArgs else if Doc.willBreak (Lazy.force printedArgs) then Lazy.force breakAllArgs - else Doc.customLayout [Lazy.force fitsOnOneLine; Lazy.force breakAllArgs] + else Doc.customLayout [ Lazy.force fitsOnOneLine; Lazy.force breakAllArgs ] and printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args cmtTbl = @@ -57269,38 +57510,39 @@ and printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args let rec loop acc args = match args with | [] -> (lazy Doc.nil, lazy Doc.nil, lazy Doc.nil) - | [(lbl, expr)] -> - let lblDoc = - match lbl with - | Asttypes.Nolabel -> Doc.nil - | Asttypes.Labelled txt -> - Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal] - | Asttypes.Optional txt -> - Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal; Doc.question] - in - let callbackFitsOnOneLine = - lazy - (let pexpFunDoc = - printPexpFun ~customLayout ~inCallback:FitsOnOneLine expr cmtTbl - in - let doc = Doc.concat [lblDoc; pexpFunDoc] in - printComments doc cmtTbl expr.pexp_loc) - in - let callbackArgumentsFitsOnOneLine = - lazy - (let pexpFunDoc = - printPexpFun ~customLayout ~inCallback:ArgumentsFitOnOneLine expr - cmtTblCopy - in - let doc = Doc.concat [lblDoc; pexpFunDoc] in - printComments doc cmtTblCopy expr.pexp_loc) - in - ( lazy (Doc.concat (List.rev acc)), - callbackFitsOnOneLine, - callbackArgumentsFitsOnOneLine ) + | [ (lbl, expr) ] -> + let lblDoc = + match lbl with + | Asttypes.Nolabel -> Doc.nil + | Asttypes.Labelled txt -> + Doc.concat [ Doc.tilde; printIdentLike txt; Doc.equal ] + | Asttypes.Optional txt -> + Doc.concat + [ Doc.tilde; printIdentLike txt; Doc.equal; Doc.question ] + in + let callbackFitsOnOneLine = + lazy + (let pexpFunDoc = + printPexpFun ~customLayout ~inCallback:FitsOnOneLine expr cmtTbl + in + let doc = Doc.concat [ lblDoc; pexpFunDoc ] in + printComments doc cmtTbl expr.pexp_loc) + in + let callbackArgumentsFitsOnOneLine = + lazy + (let pexpFunDoc = + printPexpFun ~customLayout ~inCallback:ArgumentsFitOnOneLine expr + cmtTblCopy + in + let doc = Doc.concat [ lblDoc; pexpFunDoc ] in + printComments doc cmtTblCopy expr.pexp_loc) + in + ( lazy (Doc.concat (List.rev acc)), + callbackFitsOnOneLine, + callbackArgumentsFitsOnOneLine ) | arg :: args -> - let argDoc = printArgument ~customLayout arg cmtTbl in - loop (Doc.line :: Doc.comma :: argDoc :: acc) args + let argDoc = printArgument ~customLayout arg cmtTbl in + loop (Doc.line :: Doc.comma :: argDoc :: acc) args in let printedArgs, callback, callback2 = loop [] args in @@ -57373,46 +57615,48 @@ and printArguments ~customLayout ~uncurried | [ ( Nolabel, { - pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _); + pexp_desc = Pexp_construct ({ txt = Longident.Lident "()" }, _); pexp_loc = loc; } ); ] -> ( - (* See "parseCallExpr", ghost unit expression is used the implement - * arity zero vs arity one syntax. - * Related: https://github.com/rescript-lang/syntax/issues/138 *) - match (uncurried, loc.loc_ghost) with - | true, true -> Doc.text "(.)" (* arity zero *) - | true, false -> Doc.text "(. ())" (* arity one *) - | _ -> Doc.text "()") - | [(Nolabel, arg)] when ParsetreeViewer.isHuggableExpression arg -> - let argDoc = - let doc = printExpressionWithComments ~customLayout arg cmtTbl in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc - in - Doc.concat - [(if uncurried then Doc.text "(. " else Doc.lparen); argDoc; Doc.rparen] + (* See "parseCallExpr", ghost unit expression is used the implement + * arity zero vs arity one syntax. + * Related: https://github.com/rescript-lang/syntax/issues/138 *) + match (uncurried, loc.loc_ghost) with + | true, true -> Doc.text "(.)" (* arity zero *) + | true, false -> Doc.text "(. ())" (* arity one *) + | _ -> Doc.text "()") + | [ (Nolabel, arg) ] when ParsetreeViewer.isHuggableExpression arg -> + let argDoc = + let doc = printExpressionWithComments ~customLayout arg cmtTbl in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc + in + Doc.concat + [ + (if uncurried then Doc.text "(. " else Doc.lparen); argDoc; Doc.rparen; + ] | args -> - Doc.group - (Doc.concat - [ - (if uncurried then Doc.text "(." else Doc.lparen); - Doc.indent - (Doc.concat - [ - (if uncurried then Doc.line else Doc.softLine); - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun arg -> printArgument ~customLayout arg cmtTbl) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + (if uncurried then Doc.text "(." else Doc.lparen); + Doc.indent + (Doc.concat + [ + (if uncurried then Doc.line else Doc.softLine); + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun arg -> printArgument ~customLayout arg cmtTbl) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) (* * argument ::= @@ -57433,88 +57677,90 @@ and printArgument ~customLayout (argLbl, arg) cmtTbl = (* ~a (punned)*) | ( Asttypes.Labelled lbl, ({ - pexp_desc = Pexp_ident {txt = Longident.Lident name}; - pexp_attributes = [] | [({Location.txt = "ns.namedArgLoc"}, _)]; + pexp_desc = Pexp_ident { txt = Longident.Lident name }; + pexp_attributes = [] | [ ({ Location.txt = "ns.namedArgLoc" }, _) ]; } as argExpr) ) when lbl = name && not (ParsetreeViewer.isBracedExpr argExpr) -> - let loc = - match arg.pexp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> loc - | _ -> arg.pexp_loc - in - let doc = Doc.concat [Doc.tilde; printIdentLike lbl] in - printComments doc cmtTbl loc + let loc = + match arg.pexp_attributes with + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _ -> loc + | _ -> arg.pexp_loc + in + let doc = Doc.concat [ Doc.tilde; printIdentLike lbl ] in + printComments doc cmtTbl loc (* ~a: int (punned)*) | ( Asttypes.Labelled lbl, { pexp_desc = Pexp_constraint - ( ({pexp_desc = Pexp_ident {txt = Longident.Lident name}} as argExpr), + ( ({ pexp_desc = Pexp_ident { txt = Longident.Lident name } } as + argExpr), typ ); pexp_loc; pexp_attributes = - ([] | [({Location.txt = "ns.namedArgLoc"}, _)]) as attrs; + ([] | [ ({ Location.txt = "ns.namedArgLoc" }, _) ]) as attrs; } ) when lbl = name && not (ParsetreeViewer.isBracedExpr argExpr) -> - let loc = - match attrs with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> - {loc with loc_end = pexp_loc.loc_end} - | _ -> arg.pexp_loc - in - let doc = - Doc.concat - [ - Doc.tilde; - printIdentLike lbl; - Doc.text ": "; - printTypExpr ~customLayout typ cmtTbl; - ] - in - printComments doc cmtTbl loc + let loc = + match attrs with + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _ -> + { loc with loc_end = pexp_loc.loc_end } + | _ -> arg.pexp_loc + in + let doc = + Doc.concat + [ + Doc.tilde; + printIdentLike lbl; + Doc.text ": "; + printTypExpr ~customLayout typ cmtTbl; + ] + in + printComments doc cmtTbl loc (* ~a? (optional lbl punned)*) | ( Asttypes.Optional lbl, { - pexp_desc = Pexp_ident {txt = Longident.Lident name}; - pexp_attributes = [] | [({Location.txt = "ns.namedArgLoc"}, _)]; + pexp_desc = Pexp_ident { txt = Longident.Lident name }; + pexp_attributes = [] | [ ({ Location.txt = "ns.namedArgLoc" }, _) ]; } ) when lbl = name -> - let loc = - match arg.pexp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> loc - | _ -> arg.pexp_loc - in - let doc = Doc.concat [Doc.tilde; printIdentLike lbl; Doc.question] in - printComments doc cmtTbl loc + let loc = + match arg.pexp_attributes with + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _ -> loc + | _ -> arg.pexp_loc + in + let doc = Doc.concat [ Doc.tilde; printIdentLike lbl; Doc.question ] in + printComments doc cmtTbl loc | _lbl, expr -> - let argLoc, expr = - match expr.pexp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: attrs -> - (loc, {expr with pexp_attributes = attrs}) - | _ -> (expr.pexp_loc, expr) - in - let printedLbl = - match argLbl with - | Asttypes.Nolabel -> Doc.nil - | Asttypes.Labelled lbl -> - let doc = Doc.concat [Doc.tilde; printIdentLike lbl; Doc.equal] in - printComments doc cmtTbl argLoc - | Asttypes.Optional lbl -> - let doc = - Doc.concat [Doc.tilde; printIdentLike lbl; Doc.equal; Doc.question] - in - printComments doc cmtTbl argLoc - in - let printedExpr = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - let loc = {argLoc with loc_end = expr.pexp_loc.loc_end} in - let doc = Doc.concat [printedLbl; printedExpr] in - printComments doc cmtTbl loc + let argLoc, expr = + match expr.pexp_attributes with + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: attrs -> + (loc, { expr with pexp_attributes = attrs }) + | _ -> (expr.pexp_loc, expr) + in + let printedLbl = + match argLbl with + | Asttypes.Nolabel -> Doc.nil + | Asttypes.Labelled lbl -> + let doc = Doc.concat [ Doc.tilde; printIdentLike lbl; Doc.equal ] in + printComments doc cmtTbl argLoc + | Asttypes.Optional lbl -> + let doc = + Doc.concat + [ Doc.tilde; printIdentLike lbl; Doc.equal; Doc.question ] + in + printComments doc cmtTbl argLoc + in + let printedExpr = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + let loc = { argLoc with loc_end = expr.pexp_loc.loc_end } in + let doc = Doc.concat [ printedLbl; printedExpr ] in + printComments doc cmtTbl loc and printCases ~customLayout (cases : Parsetree.case list) cmtTbl = Doc.breakableGroup ~forceBreak:true @@ -57541,40 +57787,40 @@ and printCase ~customLayout (case : Parsetree.case) cmtTbl = match case.pc_rhs.pexp_desc with | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ | Pexp_sequence _ -> - printExpressionBlock ~customLayout - ~braces:(ParsetreeViewer.isBracedExpr case.pc_rhs) - case.pc_rhs cmtTbl + printExpressionBlock ~customLayout + ~braces:(ParsetreeViewer.isBracedExpr case.pc_rhs) + case.pc_rhs cmtTbl | _ -> ( - let doc = printExpressionWithComments ~customLayout case.pc_rhs cmtTbl in - match Parens.expr case.pc_rhs with - | Parenthesized -> addParens doc - | _ -> doc) + let doc = + printExpressionWithComments ~customLayout case.pc_rhs cmtTbl + in + match Parens.expr case.pc_rhs with + | Parenthesized -> addParens doc + | _ -> doc) in let guard = match case.pc_guard with | None -> Doc.nil | Some expr -> - Doc.group - (Doc.concat - [ - Doc.line; - Doc.text "if "; - printExpressionWithComments ~customLayout expr cmtTbl; - ]) + Doc.group + (Doc.concat + [ + Doc.line; + Doc.text "if "; + printExpressionWithComments ~customLayout expr cmtTbl; + ]) in let shouldInlineRhs = match case.pc_rhs.pexp_desc with - | Pexp_construct ({txt = Longident.Lident ("()" | "true" | "false")}, _) + | Pexp_construct ({ txt = Longident.Lident ("()" | "true" | "false") }, _) | Pexp_constant _ | Pexp_ident _ -> - true + true | _ when ParsetreeViewer.isHuggableRhs case.pc_rhs -> true | _ -> false in let shouldIndentPattern = - match case.pc_lhs.ppat_desc with - | Ppat_or _ -> false - | _ -> true + match case.pc_lhs.ppat_desc with Ppat_or _ -> false | _ -> true in let patternDoc = let doc = printPattern ~customLayout case.pc_lhs cmtTbl in @@ -57589,10 +57835,11 @@ and printCase ~customLayout (case : Parsetree.case) cmtTbl = Doc.indent guard; Doc.text " =>"; Doc.indent - (Doc.concat [(if shouldInlineRhs then Doc.space else Doc.line); rhs]); + (Doc.concat + [ (if shouldInlineRhs then Doc.space else Doc.line); rhs ]); ] in - Doc.group (Doc.concat [Doc.text "| "; content]) + Doc.group (Doc.concat [ Doc.text "| "; content ]) and printExprFunParameters ~customLayout ~inCallback ~async ~uncurried ~hasConstraint parameters cmtTbl = @@ -57604,15 +57851,15 @@ and printExprFunParameters ~customLayout ~inCallback ~async ~uncurried attrs = []; lbl = Asttypes.Nolabel; defaultExpr = None; - pat = {Parsetree.ppat_desc = Ppat_any; ppat_loc}; + pat = { Parsetree.ppat_desc = Ppat_any; ppat_loc }; }; ] when not uncurried -> - let any = - let doc = if hasConstraint then Doc.text "(_)" else Doc.text "_" in - printComments doc cmtTbl ppat_loc - in - if async then addAsync any else any + let any = + let doc = if hasConstraint then Doc.text "(_)" else Doc.text "_" in + printComments doc cmtTbl ppat_loc + in + if async then addAsync any else any (* let f = a => () *) | [ ParsetreeViewer.Parameter @@ -57620,16 +57867,16 @@ and printExprFunParameters ~customLayout ~inCallback ~async ~uncurried attrs = []; lbl = Asttypes.Nolabel; defaultExpr = None; - pat = {Parsetree.ppat_desc = Ppat_var stringLoc}; + pat = { Parsetree.ppat_desc = Ppat_var stringLoc }; }; ] when not uncurried -> - let txtDoc = - let var = printIdentLike stringLoc.txt in - let var = if hasConstraint then addParens var else var in - if async then addAsync var else var - in - printComments txtDoc cmtTbl stringLoc.loc + let txtDoc = + let var = printIdentLike stringLoc.txt in + let var = if hasConstraint then addParens var else var in + if async then addAsync var else var + in + printComments txtDoc cmtTbl stringLoc.loc (* let f = () => () *) | [ ParsetreeViewer.Parameter @@ -57638,250 +57885,264 @@ and printExprFunParameters ~customLayout ~inCallback ~async ~uncurried lbl = Asttypes.Nolabel; defaultExpr = None; pat = - {ppat_desc = Ppat_construct ({txt = Longident.Lident "()"; loc}, None)}; + { + ppat_desc = + Ppat_construct ({ txt = Longident.Lident "()"; loc }, None); + }; }; ] when not uncurried -> - let doc = - let lparenRparen = Doc.text "()" in - if async then addAsync lparenRparen else lparenRparen - in - printComments doc cmtTbl loc + let doc = + let lparenRparen = Doc.text "()" in + if async then addAsync lparenRparen else lparenRparen + in + printComments doc cmtTbl loc (* let f = (~greeting, ~from as hometown, ~x=?) => () *) | parameters -> - let inCallback = - match inCallback with - | FitsOnOneLine -> true - | _ -> false - in - let maybeAsyncLparen = - let lparen = if uncurried then Doc.text "(. " else Doc.lparen in - if async then addAsync lparen else lparen - in - let shouldHug = ParsetreeViewer.parametersShouldHug parameters in - let printedParamaters = - Doc.concat - [ - (if shouldHug || inCallback then Doc.nil else Doc.softLine); - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun p -> printExpFunParameter ~customLayout p cmtTbl) - parameters); - ] - in - Doc.group - (Doc.concat - [ - maybeAsyncLparen; - (if shouldHug || inCallback then printedParamaters - else - Doc.concat - [Doc.indent printedParamaters; Doc.trailingComma; Doc.softLine]); - Doc.rparen; - ]) - -and printExpFunParameter ~customLayout parameter cmtTbl = - match parameter with - | ParsetreeViewer.NewTypes {attrs; locs = lbls} -> - Doc.group - (Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - Doc.text "type "; - Doc.join ~sep:Doc.space - (List.map - (fun lbl -> - printComments - (printIdentLike lbl.Asttypes.txt) - cmtTbl lbl.Asttypes.loc) - lbls); - ]) - | Parameter {attrs; lbl; defaultExpr; pat = pattern} -> - let isUncurried, attrs = ParsetreeViewer.processUncurriedAttribute attrs in - let uncurried = - if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil - in - let attrs = printAttributes ~customLayout attrs cmtTbl in - (* =defaultValue *) - let defaultExprDoc = - match defaultExpr with - | Some expr -> - Doc.concat - [Doc.text "="; printExpressionWithComments ~customLayout expr cmtTbl] - | None -> Doc.nil - in - (* ~from as hometown - * ~from -> punning *) - let labelWithPattern = - match (lbl, pattern) with - | Asttypes.Nolabel, pattern -> printPattern ~customLayout pattern cmtTbl - | ( (Asttypes.Labelled lbl | Optional lbl), - { - ppat_desc = Ppat_var stringLoc; - ppat_attributes = [] | [({Location.txt = "ns.namedArgLoc"}, _)]; - } ) - when lbl = stringLoc.txt -> - (* ~d *) - Doc.concat [Doc.text "~"; printIdentLike lbl] - | ( (Asttypes.Labelled lbl | Optional lbl), - { - ppat_desc = Ppat_constraint ({ppat_desc = Ppat_var {txt}}, typ); - ppat_attributes = [] | [({Location.txt = "ns.namedArgLoc"}, _)]; - } ) - when lbl = txt -> - (* ~d: e *) - Doc.concat - [ - Doc.text "~"; - printIdentLike lbl; - Doc.text ": "; - printTypExpr ~customLayout typ cmtTbl; - ] - | (Asttypes.Labelled lbl | Optional lbl), pattern -> - (* ~b as c *) + let inCallback = + match inCallback with FitsOnOneLine -> true | _ -> false + in + let maybeAsyncLparen = + let lparen = if uncurried then Doc.text "(. " else Doc.lparen in + if async then addAsync lparen else lparen + in + let shouldHug = ParsetreeViewer.parametersShouldHug parameters in + let printedParamaters = Doc.concat [ - Doc.text "~"; - printIdentLike lbl; - Doc.text " as "; - printPattern ~customLayout pattern cmtTbl; + (if shouldHug || inCallback then Doc.nil else Doc.softLine); + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun p -> printExpFunParameter ~customLayout p cmtTbl) + parameters); ] - in - let optionalLabelSuffix = - match (lbl, defaultExpr) with - | Asttypes.Optional _, None -> Doc.text "=?" - | _ -> Doc.nil - in - let doc = + in Doc.group (Doc.concat [ - uncurried; - attrs; - labelWithPattern; - defaultExprDoc; - optionalLabelSuffix; + maybeAsyncLparen; + (if shouldHug || inCallback then printedParamaters + else + Doc.concat + [ + Doc.indent printedParamaters; Doc.trailingComma; Doc.softLine; + ]); + Doc.rparen; ]) - in - let cmtLoc = - match defaultExpr with - | None -> ( - match pattern.ppat_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> - {loc with loc_end = pattern.ppat_loc.loc_end} - | _ -> pattern.ppat_loc) - | Some expr -> - let startPos = - match pattern.ppat_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> loc.loc_start - | _ -> pattern.ppat_loc.loc_start - in - { - pattern.ppat_loc with - loc_start = startPos; - loc_end = expr.pexp_loc.loc_end; - } - in - printComments doc cmtTbl cmtLoc + +and printExpFunParameter ~customLayout parameter cmtTbl = + match parameter with + | ParsetreeViewer.NewTypes { attrs; locs = lbls } -> + Doc.group + (Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + Doc.text "type "; + Doc.join ~sep:Doc.space + (List.map + (fun lbl -> + printComments + (printIdentLike lbl.Asttypes.txt) + cmtTbl lbl.Asttypes.loc) + lbls); + ]) + | Parameter { attrs; lbl; defaultExpr; pat = pattern } -> + let isUncurried, attrs = + ParsetreeViewer.processUncurriedAttribute attrs + in + let uncurried = + if isUncurried then Doc.concat [ Doc.dot; Doc.space ] else Doc.nil + in + let attrs = printAttributes ~customLayout attrs cmtTbl in + (* =defaultValue *) + let defaultExprDoc = + match defaultExpr with + | Some expr -> + Doc.concat + [ + Doc.text "="; + printExpressionWithComments ~customLayout expr cmtTbl; + ] + | None -> Doc.nil + in + (* ~from as hometown + * ~from -> punning *) + let labelWithPattern = + match (lbl, pattern) with + | Asttypes.Nolabel, pattern -> printPattern ~customLayout pattern cmtTbl + | ( (Asttypes.Labelled lbl | Optional lbl), + { + ppat_desc = Ppat_var stringLoc; + ppat_attributes = + [] | [ ({ Location.txt = "ns.namedArgLoc" }, _) ]; + } ) + when lbl = stringLoc.txt -> + (* ~d *) + Doc.concat [ Doc.text "~"; printIdentLike lbl ] + | ( (Asttypes.Labelled lbl | Optional lbl), + { + ppat_desc = Ppat_constraint ({ ppat_desc = Ppat_var { txt } }, typ); + ppat_attributes = + [] | [ ({ Location.txt = "ns.namedArgLoc" }, _) ]; + } ) + when lbl = txt -> + (* ~d: e *) + Doc.concat + [ + Doc.text "~"; + printIdentLike lbl; + Doc.text ": "; + printTypExpr ~customLayout typ cmtTbl; + ] + | (Asttypes.Labelled lbl | Optional lbl), pattern -> + (* ~b as c *) + Doc.concat + [ + Doc.text "~"; + printIdentLike lbl; + Doc.text " as "; + printPattern ~customLayout pattern cmtTbl; + ] + in + let optionalLabelSuffix = + match (lbl, defaultExpr) with + | Asttypes.Optional _, None -> Doc.text "=?" + | _ -> Doc.nil + in + let doc = + Doc.group + (Doc.concat + [ + uncurried; + attrs; + labelWithPattern; + defaultExprDoc; + optionalLabelSuffix; + ]) + in + let cmtLoc = + match defaultExpr with + | None -> ( + match pattern.ppat_attributes with + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _ -> + { loc with loc_end = pattern.ppat_loc.loc_end } + | _ -> pattern.ppat_loc) + | Some expr -> + let startPos = + match pattern.ppat_attributes with + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _ -> + loc.loc_start + | _ -> pattern.ppat_loc.loc_start + in + { + pattern.ppat_loc with + loc_start = startPos; + loc_end = expr.pexp_loc.loc_end; + } + in + printComments doc cmtTbl cmtLoc and printExpressionBlock ~customLayout ~braces expr cmtTbl = let rec collectRows acc expr = match expr.Parsetree.pexp_desc with | Parsetree.Pexp_letmodule (modName, modExpr, expr2) -> - let name = - let doc = Doc.text modName.txt in - printComments doc cmtTbl modName.loc - in - let letModuleDoc = - Doc.concat - [ - Doc.text "module "; - name; - Doc.text " = "; - printModExpr ~customLayout modExpr cmtTbl; - ] - in - let loc = {expr.pexp_loc with loc_end = modExpr.pmod_loc.loc_end} in - collectRows ((loc, letModuleDoc) :: acc) expr2 + let name = + let doc = Doc.text modName.txt in + printComments doc cmtTbl modName.loc + in + let letModuleDoc = + Doc.concat + [ + Doc.text "module "; + name; + Doc.text " = "; + printModExpr ~customLayout modExpr cmtTbl; + ] + in + let loc = { expr.pexp_loc with loc_end = modExpr.pmod_loc.loc_end } in + collectRows ((loc, letModuleDoc) :: acc) expr2 | Pexp_letexception (extensionConstructor, expr2) -> - let loc = let loc = - {expr.pexp_loc with loc_end = extensionConstructor.pext_loc.loc_end} + let loc = + { + expr.pexp_loc with + loc_end = extensionConstructor.pext_loc.loc_end; + } + in + match getFirstLeadingComment cmtTbl loc with + | None -> loc + | Some comment -> + let cmtLoc = Comment.loc comment in + { cmtLoc with loc_end = loc.loc_end } in - match getFirstLeadingComment cmtTbl loc with - | None -> loc - | Some comment -> - let cmtLoc = Comment.loc comment in - {cmtLoc with loc_end = loc.loc_end} - in - let letExceptionDoc = - printExceptionDef ~customLayout extensionConstructor cmtTbl - in - collectRows ((loc, letExceptionDoc) :: acc) expr2 + let letExceptionDoc = + printExceptionDef ~customLayout extensionConstructor cmtTbl + in + collectRows ((loc, letExceptionDoc) :: acc) expr2 | Pexp_open (overrideFlag, longidentLoc, expr2) -> - let openDoc = - Doc.concat - [ - Doc.text "open"; - printOverrideFlag overrideFlag; - Doc.space; - printLongidentLocation longidentLoc cmtTbl; - ] - in - let loc = {expr.pexp_loc with loc_end = longidentLoc.loc.loc_end} in - collectRows ((loc, openDoc) :: acc) expr2 + let openDoc = + Doc.concat + [ + Doc.text "open"; + printOverrideFlag overrideFlag; + Doc.space; + printLongidentLocation longidentLoc cmtTbl; + ] + in + let loc = { expr.pexp_loc with loc_end = longidentLoc.loc.loc_end } in + collectRows ((loc, openDoc) :: acc) expr2 | Pexp_sequence (expr1, expr2) -> - let exprDoc = - let doc = printExpression ~customLayout expr1 cmtTbl in - match Parens.expr expr1 with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr1 braces - | Nothing -> doc - in - let loc = expr1.pexp_loc in - collectRows ((loc, exprDoc) :: acc) expr2 + let exprDoc = + let doc = printExpression ~customLayout expr1 cmtTbl in + match Parens.expr expr1 with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr1 braces + | Nothing -> doc + in + let loc = expr1.pexp_loc in + collectRows ((loc, exprDoc) :: acc) expr2 | Pexp_let (recFlag, valueBindings, expr2) -> ( - let loc = let loc = - match (valueBindings, List.rev valueBindings) with - | vb :: _, lastVb :: _ -> - {vb.pvb_loc with loc_end = lastVb.pvb_loc.loc_end} - | _ -> Location.none + let loc = + match (valueBindings, List.rev valueBindings) with + | vb :: _, lastVb :: _ -> + { vb.pvb_loc with loc_end = lastVb.pvb_loc.loc_end } + | _ -> Location.none + in + match getFirstLeadingComment cmtTbl loc with + | None -> loc + | Some comment -> + let cmtLoc = Comment.loc comment in + { cmtLoc with loc_end = loc.loc_end } in - match getFirstLeadingComment cmtTbl loc with - | None -> loc - | Some comment -> - let cmtLoc = Comment.loc comment in - {cmtLoc with loc_end = loc.loc_end} - in - let recFlag = - match recFlag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - let letDoc = - printValueBindings ~customLayout ~recFlag valueBindings cmtTbl - in - (* let () = { - * let () = foo() - * () - * } - * We don't need to print the () on the last line of the block - *) - match expr2.pexp_desc with - | Pexp_construct ({txt = Longident.Lident "()"}, _) -> - List.rev ((loc, letDoc) :: acc) - | _ -> collectRows ((loc, letDoc) :: acc) expr2) + let recFlag = + match recFlag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + let letDoc = + printValueBindings ~customLayout ~recFlag valueBindings cmtTbl + in + (* let () = { + * let () = foo() + * () + * } + * We don't need to print the () on the last line of the block + *) + match expr2.pexp_desc with + | Pexp_construct ({ txt = Longident.Lident "()" }, _) -> + List.rev ((loc, letDoc) :: acc) + | _ -> collectRows ((loc, letDoc) :: acc) expr2) | _ -> - let exprDoc = - let doc = printExpression ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - List.rev ((expr.pexp_loc, exprDoc) :: acc) + let exprDoc = + let doc = printExpression ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + List.rev ((expr.pexp_loc, exprDoc) :: acc) in let rows = collectRows [] expr in let block = @@ -57894,7 +58155,7 @@ and printExpressionBlock ~customLayout ~braces expr cmtTbl = Doc.concat [ Doc.lbrace; - Doc.indent (Doc.concat [Doc.line; block]); + Doc.indent (Doc.concat [ Doc.line; block ]); Doc.line; Doc.rbrace; ] @@ -57925,27 +58186,25 @@ and printBraces doc expr bracesLoc = match expr.Parsetree.pexp_desc with | Pexp_letmodule _ | Pexp_letexception _ | Pexp_let _ | Pexp_open _ | Pexp_sequence _ -> - (* already has braces *) - doc + (* already has braces *) + doc | _ -> - Doc.breakableGroup ~forceBreak:overMultipleLines - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - (if Parens.bracedExpr expr then addParens doc else doc); - ]); - Doc.softLine; - Doc.rbrace; - ]) + Doc.breakableGroup ~forceBreak:overMultipleLines + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.softLine; + (if Parens.bracedExpr expr then addParens doc else doc); + ]); + Doc.softLine; + Doc.rbrace; + ]) and printOverrideFlag overrideFlag = - match overrideFlag with - | Asttypes.Override -> Doc.text "!" - | Fresh -> Doc.nil + match overrideFlag with Asttypes.Override -> Doc.text "!" | Fresh -> Doc.nil and printDirectionFlag flag = match flag with @@ -57953,39 +58212,41 @@ and printDirectionFlag flag = | Asttypes.Upto -> Doc.text " to " and printExpressionRecordRow ~customLayout (lbl, expr) cmtTbl punningAllowed = - let cmtLoc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in + let cmtLoc = { lbl.loc with loc_end = expr.pexp_loc.loc_end } in let doc = Doc.group (match expr.pexp_desc with - | Pexp_ident {txt = Lident key; loc = _keyLoc} + | Pexp_ident { txt = Lident key; loc = _keyLoc } when punningAllowed && Longident.last lbl.txt = key -> - (* print punned field *) - Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - printOptionalLabel expr.pexp_attributes; - printLidentPath lbl cmtTbl; - ] + (* print punned field *) + Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + printOptionalLabel expr.pexp_attributes; + printLidentPath lbl cmtTbl; + ] | _ -> - Doc.concat - [ - printLidentPath lbl cmtTbl; - Doc.text ": "; - printOptionalLabel expr.pexp_attributes; - (let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); - ]) + Doc.concat + [ + printLidentPath lbl cmtTbl; + Doc.text ": "; + printOptionalLabel expr.pexp_attributes; + (let doc = + printExpressionWithComments ~customLayout expr cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + ]) in printComments doc cmtTbl cmtLoc and printBsObjectRow ~customLayout (lbl, expr) cmtTbl = - let cmtLoc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in + let cmtLoc = { lbl.loc with loc_end = expr.pexp_loc.loc_end } in let lblDoc = let doc = - Doc.concat [Doc.text "\""; printLongident lbl.txt; Doc.text "\""] + Doc.concat [ Doc.text "\""; printLongident lbl.txt; Doc.text "\"" ] in printComments doc cmtTbl lbl.loc in @@ -58014,46 +58275,80 @@ and printAttributes ?loc ?(inline = false) ~customLayout match ParsetreeViewer.filterParsingAttrs attrs with | [] -> Doc.nil | attrs -> - let lineBreak = - match loc with - | None -> Doc.line - | Some loc -> ( - match List.rev attrs with - | ({loc = firstLoc}, _) :: _ - when loc.loc_start.pos_lnum > firstLoc.loc_end.pos_lnum -> - Doc.hardLine - | _ -> Doc.line) - in - Doc.concat - [ - Doc.group - (Doc.joinWithSep - (List.map - (fun attr -> printAttribute ~customLayout attr cmtTbl) - attrs)); - (if inline then Doc.space else lineBreak); - ] + let lineBreak = + match loc with + | None -> Doc.line + | Some loc -> ( + match List.rev attrs with + | ({ loc = firstLoc }, _) :: _ + when loc.loc_start.pos_lnum > firstLoc.loc_end.pos_lnum -> + Doc.hardLine + | _ -> Doc.line) + in + Doc.concat + [ + Doc.group + (Doc.joinWithSep + (List.map + (fun attr -> printAttribute ~customLayout attr cmtTbl) + attrs)); + (if inline then Doc.space else lineBreak); + ] and printPayload ~customLayout (payload : Parsetree.payload) cmtTbl = match payload with | PStr [] -> Doc.nil - | PStr [{pstr_desc = Pstr_eval (expr, attrs)}] -> - let exprDoc = printExpressionWithComments ~customLayout expr cmtTbl in - let needsParens = - match attrs with - | [] -> false - | _ -> true - in - let shouldHug = ParsetreeViewer.isHuggableExpression expr in - if shouldHug then + | PStr [ { pstr_desc = Pstr_eval (expr, attrs) } ] -> + let exprDoc = printExpressionWithComments ~customLayout expr cmtTbl in + let needsParens = match attrs with [] -> false | _ -> true in + let shouldHug = ParsetreeViewer.isHuggableExpression expr in + if shouldHug then + Doc.concat + [ + Doc.lparen; + printAttributes ~customLayout attrs cmtTbl; + (if needsParens then addParens exprDoc else exprDoc); + Doc.rparen; + ] + else + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + printAttributes ~customLayout attrs cmtTbl; + (if needsParens then addParens exprDoc else exprDoc); + ]); + Doc.softLine; + Doc.rparen; + ] + | PStr [ ({ pstr_desc = Pstr_value (_recFlag, _bindings) } as si) ] -> + addParens (printStructureItem ~customLayout si cmtTbl) + | PStr structure -> addParens (printStructure ~customLayout structure cmtTbl) + | PTyp typ -> Doc.concat [ Doc.lparen; - printAttributes ~customLayout attrs cmtTbl; - (if needsParens then addParens exprDoc else exprDoc); + Doc.text ":"; + Doc.indent + (Doc.concat [ Doc.line; printTypExpr ~customLayout typ cmtTbl ]); + Doc.softLine; Doc.rparen; ] - else + | PPat (pat, optExpr) -> + let whenDoc = + match optExpr with + | Some expr -> + Doc.concat + [ + Doc.line; + Doc.text "if "; + printExpressionWithComments ~customLayout expr cmtTbl; + ] + | None -> Doc.nil + in Doc.concat [ Doc.lparen; @@ -58061,217 +58356,193 @@ and printPayload ~customLayout (payload : Parsetree.payload) cmtTbl = (Doc.concat [ Doc.softLine; - printAttributes ~customLayout attrs cmtTbl; - (if needsParens then addParens exprDoc else exprDoc); + Doc.text "? "; + printPattern ~customLayout pat cmtTbl; + whenDoc; ]); Doc.softLine; Doc.rparen; ] - | PStr [({pstr_desc = Pstr_value (_recFlag, _bindings)} as si)] -> - addParens (printStructureItem ~customLayout si cmtTbl) - | PStr structure -> addParens (printStructure ~customLayout structure cmtTbl) - | PTyp typ -> - Doc.concat - [ - Doc.lparen; - Doc.text ":"; - Doc.indent - (Doc.concat [Doc.line; printTypExpr ~customLayout typ cmtTbl]); - Doc.softLine; - Doc.rparen; - ] - | PPat (pat, optExpr) -> - let whenDoc = - match optExpr with - | Some expr -> - Doc.concat - [ - Doc.line; - Doc.text "if "; - printExpressionWithComments ~customLayout expr cmtTbl; - ] - | None -> Doc.nil - in - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.text "? "; - printPattern ~customLayout pat cmtTbl; - whenDoc; - ]); - Doc.softLine; - Doc.rparen; - ] | PSig signature -> - Doc.concat - [ - Doc.lparen; - Doc.text ":"; - Doc.indent - (Doc.concat [Doc.line; printSignature ~customLayout signature cmtTbl]); - Doc.softLine; - Doc.rparen; - ] + Doc.concat + [ + Doc.lparen; + Doc.text ":"; + Doc.indent + (Doc.concat + [ Doc.line; printSignature ~customLayout signature cmtTbl ]); + Doc.softLine; + Doc.rparen; + ] and printAttribute ?(standalone = false) ~customLayout ((id, payload) : Parsetree.attribute) cmtTbl = match (id, payload) with - | ( {txt = "ns.doc"}, + | ( { txt = "ns.doc" }, PStr [ { pstr_desc = - Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (txt, _))}, _); + Pstr_eval + ({ pexp_desc = Pexp_constant (Pconst_string (txt, _)) }, _); }; ] ) -> - ( Doc.concat - [ - Doc.text (if standalone then "/***" else "/**"); - Doc.text txt; - Doc.text "*/"; - ], - Doc.hardLine ) + ( Doc.concat + [ + Doc.text (if standalone then "/***" else "/**"); + Doc.text txt; + Doc.text "*/"; + ], + Doc.hardLine ) | _ -> - ( Doc.group - (Doc.concat - [ - Doc.text (if standalone then "@@" else "@"); - Doc.text (convertBsExternalAttribute id.txt); - printPayload ~customLayout payload cmtTbl; - ]), - Doc.line ) + ( Doc.group + (Doc.concat + [ + Doc.text (if standalone then "@@" else "@"); + Doc.text (convertBsExternalAttribute id.txt); + printPayload ~customLayout payload cmtTbl; + ]), + Doc.line ) and printModExpr ~customLayout modExpr cmtTbl = let doc = match modExpr.pmod_desc with | Pmod_ident longidentLoc -> printLongidentLocation longidentLoc cmtTbl | Pmod_structure [] -> - let shouldBreak = - modExpr.pmod_loc.loc_start.pos_lnum < modExpr.pmod_loc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak:shouldBreak - (Doc.concat - [Doc.lbrace; printCommentsInside cmtTbl modExpr.pmod_loc; Doc.rbrace]) + let shouldBreak = + modExpr.pmod_loc.loc_start.pos_lnum + < modExpr.pmod_loc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak:shouldBreak + (Doc.concat + [ + Doc.lbrace; + printCommentsInside cmtTbl modExpr.pmod_loc; + Doc.rbrace; + ]) | Pmod_structure structure -> - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [Doc.softLine; printStructure ~customLayout structure cmtTbl]); - Doc.softLine; - Doc.rbrace; - ]) + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.softLine; + printStructure ~customLayout structure cmtTbl; + ]); + Doc.softLine; + Doc.rbrace; + ]) | Pmod_unpack expr -> - let shouldHug = - match expr.pexp_desc with - | Pexp_let _ -> true - | Pexp_constraint - ({pexp_desc = Pexp_let _}, {ptyp_desc = Ptyp_package _packageType}) - -> - true - | _ -> false - in - let expr, moduleConstraint = - match expr.pexp_desc with - | Pexp_constraint - (expr, {ptyp_desc = Ptyp_package packageType; ptyp_loc}) -> - let packageDoc = - let doc = - printPackageType ~customLayout ~printModuleKeywordAndParens:false - packageType cmtTbl - in - printComments doc cmtTbl ptyp_loc - in - let typeDoc = - Doc.group - (Doc.concat - [Doc.text ":"; Doc.indent (Doc.concat [Doc.line; packageDoc])]) - in - (expr, typeDoc) - | _ -> (expr, Doc.nil) - in - let unpackDoc = + let shouldHug = + match expr.pexp_desc with + | Pexp_let _ -> true + | Pexp_constraint + ( { pexp_desc = Pexp_let _ }, + { ptyp_desc = Ptyp_package _packageType } ) -> + true + | _ -> false + in + let expr, moduleConstraint = + match expr.pexp_desc with + | Pexp_constraint + (expr, { ptyp_desc = Ptyp_package packageType; ptyp_loc }) -> + let packageDoc = + let doc = + printPackageType ~customLayout + ~printModuleKeywordAndParens:false packageType cmtTbl + in + printComments doc cmtTbl ptyp_loc + in + let typeDoc = + Doc.group + (Doc.concat + [ + Doc.text ":"; + Doc.indent (Doc.concat [ Doc.line; packageDoc ]); + ]) + in + (expr, typeDoc) + | _ -> (expr, Doc.nil) + in + let unpackDoc = + Doc.group + (Doc.concat + [ + printExpressionWithComments ~customLayout expr cmtTbl; + moduleConstraint; + ]) + in Doc.group (Doc.concat [ - printExpressionWithComments ~customLayout expr cmtTbl; - moduleConstraint; + Doc.text "unpack("; + (if shouldHug then unpackDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [ Doc.softLine; unpackDoc ]); + Doc.softLine; + ]); + Doc.rparen; ]) - in - Doc.group - (Doc.concat - [ - Doc.text "unpack("; - (if shouldHug then unpackDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [Doc.softLine; unpackDoc]); - Doc.softLine; - ]); - Doc.rparen; - ]) | Pmod_extension extension -> - printExtension ~customLayout ~atModuleLvl:false extension cmtTbl + printExtension ~customLayout ~atModuleLvl:false extension cmtTbl | Pmod_apply _ -> - let args, callExpr = ParsetreeViewer.modExprApply modExpr in - let isUnitSugar = - match args with - | [{pmod_desc = Pmod_structure []}] -> true - | _ -> false - in - let shouldHug = - match args with - | [{pmod_desc = Pmod_structure _}] -> true - | _ -> false - in - Doc.group - (Doc.concat - [ - printModExpr ~customLayout callExpr cmtTbl; - (if isUnitSugar then - printModApplyArg ~customLayout - (List.hd args [@doesNotRaise]) - cmtTbl - else - Doc.concat - [ - Doc.lparen; - (if shouldHug then - printModApplyArg ~customLayout - (List.hd args [@doesNotRaise]) - cmtTbl - else - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun modArg -> - printModApplyArg ~customLayout modArg cmtTbl) - args); - ])); - (if not shouldHug then - Doc.concat [Doc.trailingComma; Doc.softLine] - else Doc.nil); - Doc.rparen; - ]); - ]) + let args, callExpr = ParsetreeViewer.modExprApply modExpr in + let isUnitSugar = + match args with + | [ { pmod_desc = Pmod_structure [] } ] -> true + | _ -> false + in + let shouldHug = + match args with + | [ { pmod_desc = Pmod_structure _ } ] -> true + | _ -> false + in + Doc.group + (Doc.concat + [ + printModExpr ~customLayout callExpr cmtTbl; + (if isUnitSugar then + printModApplyArg ~customLayout + (List.hd args [@doesNotRaise]) + cmtTbl + else + Doc.concat + [ + Doc.lparen; + (if shouldHug then + printModApplyArg ~customLayout + (List.hd args [@doesNotRaise]) + cmtTbl + else + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun modArg -> + printModApplyArg ~customLayout modArg + cmtTbl) + args); + ])); + (if not shouldHug then + Doc.concat [ Doc.trailingComma; Doc.softLine ] + else Doc.nil); + Doc.rparen; + ]); + ]) | Pmod_constraint (modExpr, modType) -> - Doc.concat - [ - printModExpr ~customLayout modExpr cmtTbl; - Doc.text ": "; - printModType ~customLayout modType cmtTbl; - ] + Doc.concat + [ + printModExpr ~customLayout modExpr cmtTbl; + Doc.text ": "; + printModType ~customLayout modType cmtTbl; + ] | Pmod_functor _ -> printModFunctor ~customLayout modExpr cmtTbl in printComments doc cmtTbl modExpr.pmod_loc @@ -58286,51 +58557,52 @@ and printModFunctor ~customLayout modExpr cmtTbl = let returnConstraint, returnModExpr = match returnModExpr.pmod_desc with | Pmod_constraint (modExpr, modType) -> - let constraintDoc = - let doc = printModType ~customLayout modType cmtTbl in - if Parens.modExprFunctorConstraint modType then addParens doc else doc - in - let modConstraint = Doc.concat [Doc.text ": "; constraintDoc] in - (modConstraint, printModExpr ~customLayout modExpr cmtTbl) + let constraintDoc = + let doc = printModType ~customLayout modType cmtTbl in + if Parens.modExprFunctorConstraint modType then addParens doc else doc + in + let modConstraint = Doc.concat [ Doc.text ": "; constraintDoc ] in + (modConstraint, printModExpr ~customLayout modExpr cmtTbl) | _ -> (Doc.nil, printModExpr ~customLayout returnModExpr cmtTbl) in let parametersDoc = match parameters with - | [(attrs, {txt = "*"}, None)] -> - Doc.group - (Doc.concat [printAttributes ~customLayout attrs cmtTbl; Doc.text "()"]) - | [([], {txt = lbl}, None)] -> Doc.text lbl + | [ (attrs, { txt = "*" }, None) ] -> + Doc.group + (Doc.concat + [ printAttributes ~customLayout attrs cmtTbl; Doc.text "()" ]) + | [ ([], { txt = lbl }, None) ] -> Doc.text lbl | parameters -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun param -> - printModFunctorParam ~customLayout param cmtTbl) - parameters); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun param -> + printModFunctorParam ~customLayout param cmtTbl) + parameters); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) in Doc.group (Doc.concat - [parametersDoc; returnConstraint; Doc.text " => "; returnModExpr]) + [ parametersDoc; returnConstraint; Doc.text " => "; returnModExpr ]) and printModFunctorParam ~customLayout (attrs, lbl, optModType) cmtTbl = let cmtLoc = match optModType with | None -> lbl.Asttypes.loc | Some modType -> - {lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end} + { lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end } in let attrs = printAttributes ~customLayout attrs cmtTbl in let lblDoc = @@ -58346,8 +58618,8 @@ and printModFunctorParam ~customLayout (attrs, lbl, optModType) cmtTbl = (match optModType with | None -> Doc.nil | Some modType -> - Doc.concat - [Doc.text ": "; printModType ~customLayout modType cmtTbl]); + Doc.concat + [ Doc.text ": "; printModType ~customLayout modType cmtTbl ]); ]) in printComments doc cmtTbl cmtLoc @@ -58362,22 +58634,25 @@ and printExceptionDef ~customLayout (constr : Parsetree.extension_constructor) let kind = match constr.pext_kind with | Pext_rebind longident -> - Doc.indent - (Doc.concat - [Doc.text " ="; Doc.line; printLongidentLocation longident cmtTbl]) + Doc.indent + (Doc.concat + [ + Doc.text " ="; Doc.line; printLongidentLocation longident cmtTbl; + ]) | Pext_decl (Pcstr_tuple [], None) -> Doc.nil | Pext_decl (args, gadt) -> - let gadtDoc = - match gadt with - | Some typ -> - Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ cmtTbl] - | None -> Doc.nil - in - Doc.concat - [ - printConstructorArguments ~customLayout ~indent:false args cmtTbl; - gadtDoc; - ] + let gadtDoc = + match gadt with + | Some typ -> + Doc.concat + [ Doc.text ": "; printTypExpr ~customLayout typ cmtTbl ] + | None -> Doc.nil + in + Doc.concat + [ + printConstructorArguments ~customLayout ~indent:false args cmtTbl; + gadtDoc; + ] in let name = printComments (Doc.text constr.pext_name.txt) cmtTbl constr.pext_name.loc @@ -58403,27 +58678,30 @@ and printExtensionConstructor ~customLayout let kind = match constr.pext_kind with | Pext_rebind longident -> - Doc.indent - (Doc.concat - [Doc.text " ="; Doc.line; printLongidentLocation longident cmtTbl]) + Doc.indent + (Doc.concat + [ + Doc.text " ="; Doc.line; printLongidentLocation longident cmtTbl; + ]) | Pext_decl (Pcstr_tuple [], None) -> Doc.nil | Pext_decl (args, gadt) -> - let gadtDoc = - match gadt with - | Some typ -> - Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ cmtTbl] - | None -> Doc.nil - in - Doc.concat - [ - printConstructorArguments ~customLayout ~indent:false args cmtTbl; - gadtDoc; - ] + let gadtDoc = + match gadt with + | Some typ -> + Doc.concat + [ Doc.text ": "; printTypExpr ~customLayout typ cmtTbl ] + | None -> Doc.nil + in + Doc.concat + [ + printConstructorArguments ~customLayout ~indent:false args cmtTbl; + gadtDoc; + ] in let name = printComments (Doc.text constr.pext_name.txt) cmtTbl constr.pext_name.loc in - Doc.concat [bar; Doc.group (Doc.concat [attrs; name; kind])] + Doc.concat [ bar; Doc.group (Doc.concat [ attrs; name; kind ]) ] let printTypeParams = printTypeParams ~customLayout:0 let printTypExpr = printTypExpr ~customLayout:0 @@ -58502,82 +58780,6 @@ let print_pattern typed = let doc = Res_printer.printPattern pat Res_comments_table.empty in Res_doc.toString ~width:80 doc -end -module Ext_util : sig -#1 "ext_util.mli" -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val power_2_above : int -> int -> int - -val stats_to_string : Hashtbl.statistics -> string - -end = struct -#1 "ext_util.ml" -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** - {[ - (power_2_above 16 63 = 64) - (power_2_above 16 76 = 128) - ]} -*) -let rec power_2_above x n = - if x >= n then x - else if x * 2 > Sys.max_array_length then x - else power_2_above (x * 2) n - -let stats_to_string - ({ num_bindings; num_buckets; max_bucket_length; bucket_histogram } : - Hashtbl.statistics) = - Printf.sprintf "bindings: %d,buckets: %d, longest: %d, hist:[%s]" num_bindings - num_buckets max_bucket_length - (String.concat "," - (Array.to_list (Array.map string_of_int bucket_histogram))) - end module Hash_gen = struct @@ -81362,7 +81564,7 @@ and expression_desc cxt ~(level : int) f x : cxt = match v with | Float { f } -> Js_number.caml_float_literal_to_js_string f (* attach string here for float constant folding?*) - | Int { i; c = Some c } -> Format.asprintf "/* %s */%ld" (Pprintast.string_of_int_as_char c) i + | Int { i; c = Some c } -> Format.asprintf "/* %s */%ld" (Ext_util.string_of_int_as_char c) i | Int { i; c = None } -> Int32.to_string i (* check , js convention with ocaml lexical convention *) @@ -93784,13 +93986,6 @@ end = struct open Format open Asttypes -let string_of_int_as_char i = - if i >= 0 && i <= 255 - then - Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) - else - Printf.sprintf "\'\\%d\'" i - let rec struct_const ppf (cst : Lam_constant.t) = match cst with | Const_js_true -> fprintf ppf "#true" @@ -93799,7 +93994,7 @@ let rec struct_const ppf (cst : Lam_constant.t) = | Const_module_alias -> fprintf ppf "#alias" | Const_js_undefined -> fprintf ppf "#undefined" | Const_int { i } -> fprintf ppf "%ld" i - | Const_char i -> fprintf ppf "%s" (string_of_int_as_char i) + | Const_char i -> fprintf ppf "%s" (Ext_util.string_of_int_as_char i) | Const_string { s } -> fprintf ppf "%S" s | Const_float f -> fprintf ppf "%s" f | Const_int64 n -> fprintf ppf "%LiL" n @@ -273319,37 +273514,35 @@ open Asttypes open Parsetree type jsxConfig = { - mutable version: int; - mutable module_: string; - mutable mode: string; - mutable nestedModules: string list; - mutable hasReactComponent: bool; + mutable version : int; + mutable module_ : string; + mutable mode : string; + mutable nestedModules : string list; + mutable hasReactComponent : bool; } (* Helper method to look up the [@react.component] attribute *) let hasAttr (loc, _) = loc.txt = "react.component" (* Iterate over the attributes and try to find the [@react.component] attribute *) -let hasAttrOnBinding {pvb_attributes} = +let hasAttrOnBinding { pvb_attributes } = List.find_opt hasAttr pvb_attributes <> None let coreTypeOfAttrs attributes = List.find_map - (fun ({txt}, payload) -> + (fun ({ txt }, payload) -> match (txt, payload) with | "react.component", PTyp coreType -> Some coreType | _ -> None) attributes -let typVarsOfCoreType {ptyp_desc} = +let typVarsOfCoreType { ptyp_desc } = match ptyp_desc with | Ptyp_constr (_, coreTypes) -> - List.filter - (fun {ptyp_desc} -> - match ptyp_desc with - | Ptyp_var _ -> true - | _ -> false) - coreTypes + List.filter + (fun { ptyp_desc } -> + match ptyp_desc with Ptyp_var _ -> true | _ -> false) + coreTypes | _ -> [] let raiseError ~loc msg = Location.raise_errorf ~loc msg @@ -273370,25 +273563,13 @@ open Parsetree open Longident let nolabel = Nolabel - let labelled str = Labelled str - let optional str = Optional str - -let isOptional str = - match str with - | Optional _ -> true - | _ -> false - -let isLabelled str = - match str with - | Labelled _ -> true - | _ -> false +let isOptional str = match str with Optional _ -> true | _ -> false +let isLabelled str = match str with Labelled _ -> true | _ -> false let getLabel str = - match str with - | Optional str | Labelled str -> str - | Nolabel -> "" + match str with Optional str | Labelled str -> str | Nolabel -> "" let optionIdent = Lident "option" @@ -273401,12 +273582,11 @@ let safeTypeFromValue valueStr = else "T" ^ valueStr let keyType loc = - Typ.constr ~loc {loc; txt = optionIdent} - [Typ.constr ~loc {loc; txt = Lident "string"} []] + Typ.constr ~loc { loc; txt = optionIdent } + [ Typ.constr ~loc { loc; txt = Lident "string" } [] ] type 'a children = ListLiteral of 'a | Exact of 'a - -type componentConfig = {propsName: string} +type componentConfig = { propsName : string } (* if children is a list, convert it to an array while mapping each element. If not, just map over it, as usual *) let transformChildrenIfListUpper ~loc ~mapper theList = @@ -273414,16 +273594,16 @@ let transformChildrenIfListUpper ~loc ~mapper theList = (* not in the sense of converting a list to an array; convert the AST reprensentation of a list to the AST reprensentation of an array *) match theList with - | {pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} -> ( - match accum with - | [singleElement] -> Exact singleElement - | accum -> ListLiteral (Exp.array ~loc (List.rev accum))) + | { pexp_desc = Pexp_construct ({ txt = Lident "[]" }, None) } -> ( + match accum with + | [ singleElement ] -> Exact singleElement + | accum -> ListLiteral (Exp.array ~loc (List.rev accum))) | { pexp_desc = Pexp_construct - ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple [v; acc]}); + ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple [ v; acc ] }); } -> - transformChildren_ acc (mapper.expr mapper v :: accum) + transformChildren_ acc (mapper.expr mapper v :: accum) | notAList -> Exact (mapper.expr mapper notAList) in transformChildren_ theList [] @@ -273433,14 +273613,14 @@ let transformChildrenIfList ~loc ~mapper theList = (* not in the sense of converting a list to an array; convert the AST reprensentation of a list to the AST reprensentation of an array *) match theList with - | {pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} -> - Exp.array ~loc (List.rev accum) + | { pexp_desc = Pexp_construct ({ txt = Lident "[]" }, None) } -> + Exp.array ~loc (List.rev accum) | { pexp_desc = Pexp_construct - ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple [v; acc]}); + ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple [ v; acc ] }); } -> - transformChildren_ acc (mapper.expr mapper v :: accum) + transformChildren_ acc (mapper.expr mapper v :: accum) | notAList -> mapper.expr mapper notAList in transformChildren_ theList [] @@ -273449,11 +273629,13 @@ let extractChildren ?(removeLastPositionUnit = false) ~loc propsAndChildren = let rec allButLast_ lst acc = match lst with | [] -> [] - | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] -> - acc - | (Nolabel, {pexp_loc}) :: _rest -> - React_jsx_common.raiseError ~loc:pexp_loc - "JSX: found non-labelled argument before the last position" + | [ + (Nolabel, { pexp_desc = Pexp_construct ({ txt = Lident "()" }, None) }); + ] -> + acc + | (Nolabel, { pexp_loc }) :: _rest -> + React_jsx_common.raiseError ~loc:pexp_loc + "JSX: found non-labelled argument before the last position" | arg :: rest -> allButLast_ rest (arg :: acc) in let allButLast lst = allButLast_ lst [] |> List.rev in @@ -273463,20 +273645,20 @@ let extractChildren ?(removeLastPositionUnit = false) ~loc propsAndChildren = propsAndChildren with | [], props -> - (* no children provided? Place a placeholder list *) - ( Exp.construct ~loc {loc; txt = Lident "[]"} None, - if removeLastPositionUnit then allButLast props else props ) - | [(_, childrenExpr)], props -> - (childrenExpr, if removeLastPositionUnit then allButLast props else props) + (* no children provided? Place a placeholder list *) + ( Exp.construct ~loc { loc; txt = Lident "[]" } None, + if removeLastPositionUnit then allButLast props else props ) + | [ (_, childrenExpr) ], props -> + (childrenExpr, if removeLastPositionUnit then allButLast props else props) | _ -> - React_jsx_common.raiseError ~loc - "JSX: somehow there's more than one `children` label" + React_jsx_common.raiseError ~loc + "JSX: somehow there's more than one `children` label" let unerasableIgnore loc = - ( {loc; txt = "warning"}, - PStr [Str.eval (Exp.constant (Pconst_string ("-16", None)))] ) + ( { loc; txt = "warning" }, + PStr [ Str.eval (Exp.constant (Pconst_string ("-16", None))) ] ) -let merlinFocus = ({loc = Location.none; txt = "merlin.focus"}, PStr []) +let merlinFocus = ({ loc = Location.none; txt = "merlin.focus" }, PStr []) (* Helper method to filter out any attribute that isn't [@react.component] *) let otherAttrsPure (loc, _) = loc.txt <> "react.component" @@ -273484,59 +273666,59 @@ let otherAttrsPure (loc, _) = loc.txt <> "react.component" (* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *) let rec getFnName binding = match binding with - | {ppat_desc = Ppat_var {txt}} -> txt - | {ppat_desc = Ppat_constraint (pat, _)} -> getFnName pat - | {ppat_loc} -> - React_jsx_common.raiseError ~loc:ppat_loc - "react.component calls cannot be destructured." + | { ppat_desc = Ppat_var { txt } } -> txt + | { ppat_desc = Ppat_constraint (pat, _) } -> getFnName pat + | { ppat_loc } -> + React_jsx_common.raiseError ~loc:ppat_loc + "react.component calls cannot be destructured." let makeNewBinding binding expression newName = match binding with - | {pvb_pat = {ppat_desc = Ppat_var ppat_var} as pvb_pat} -> - { - binding with - pvb_pat = - {pvb_pat with ppat_desc = Ppat_var {ppat_var with txt = newName}}; - pvb_expr = expression; - pvb_attributes = [merlinFocus]; - } - | {pvb_loc} -> - React_jsx_common.raiseError ~loc:pvb_loc - "react.component calls cannot be destructured." + | { pvb_pat = { ppat_desc = Ppat_var ppat_var } as pvb_pat } -> + { + binding with + pvb_pat = + { pvb_pat with ppat_desc = Ppat_var { ppat_var with txt = newName } }; + pvb_expr = expression; + pvb_attributes = [ merlinFocus ]; + } + | { pvb_loc } -> + React_jsx_common.raiseError ~loc:pvb_loc + "react.component calls cannot be destructured." (* Lookup the value of `props` otherwise raise Invalid_argument error *) let getPropsNameValue _acc (loc, exp) = match (loc, exp) with - | {txt = Lident "props"}, {pexp_desc = Pexp_ident {txt = Lident str}} -> - {propsName = str} - | {txt; loc}, _ -> - React_jsx_common.raiseError ~loc - "react.component only accepts props as an option, given: { %s }" - (Longident.last txt) + | { txt = Lident "props" }, { pexp_desc = Pexp_ident { txt = Lident str } } -> + { propsName = str } + | { txt; loc }, _ -> + React_jsx_common.raiseError ~loc + "react.component only accepts props as an option, given: { %s }" + (Longident.last txt) (* Lookup the `props` record or string as part of [@react.component] and store the name for use when rewriting *) let getPropsAttr payload = - let defaultProps = {propsName = "Props"} in + let defaultProps = { propsName = "Props" } in match payload with | Some (PStr ({ pstr_desc = - Pstr_eval ({pexp_desc = Pexp_record (recordFields, None)}, _); + Pstr_eval ({ pexp_desc = Pexp_record (recordFields, None) }, _); } :: _rest)) -> - List.fold_left getPropsNameValue defaultProps recordFields + List.fold_left getPropsNameValue defaultProps recordFields | Some (PStr ({ pstr_desc = - Pstr_eval ({pexp_desc = Pexp_ident {txt = Lident "props"}}, _); + Pstr_eval ({ pexp_desc = Pexp_ident { txt = Lident "props" } }, _); } :: _rest)) -> - {propsName = "props"} - | Some (PStr ({pstr_desc = Pstr_eval (_, _); pstr_loc} :: _rest)) -> - React_jsx_common.raiseError ~loc:pstr_loc - "react.component accepts a record config with props as an options." + { propsName = "props" } + | Some (PStr ({ pstr_desc = Pstr_eval (_, _); pstr_loc } :: _rest)) -> + React_jsx_common.raiseError ~loc:pstr_loc + "react.component accepts a record config with props as an options." | _ -> defaultProps (* Plucks the label, loc, and type_ from an AST node *) @@ -273566,7 +273748,7 @@ let makeModuleName fileName nestedModules fnName = | "", nestedModules, fnName -> List.rev (fnName :: nestedModules) | fileName, nestedModules, "make" -> fileName :: List.rev nestedModules | fileName, nestedModules, fnName -> - fileName :: List.rev (fnName :: nestedModules) + fileName :: List.rev (fnName :: nestedModules) in let fullModuleName = String.concat "$" fullModuleName in fullModuleName @@ -273581,68 +273763,71 @@ let makeModuleName fileName nestedModules fnName = let rec recursivelyMakeNamedArgsForExternal list args = match list with | (label, default, loc, interiorType) :: tl -> - recursivelyMakeNamedArgsForExternal tl - (Typ.arrow ~loc label - (match (label, interiorType, default) with - (* ~foo=1 *) - | label, None, Some _ -> - { - ptyp_desc = Ptyp_var (safeTypeFromValue label); - ptyp_loc = loc; - ptyp_attributes = []; - } - (* ~foo: int=1 *) - | _label, Some type_, Some _ -> type_ - (* ~foo: option(int)=? *) - | ( label, - Some {ptyp_desc = Ptyp_constr ({txt = Lident "option"}, [type_])}, - _ ) - | ( label, - Some + recursivelyMakeNamedArgsForExternal tl + (Typ.arrow ~loc label + (match (label, interiorType, default) with + (* ~foo=1 *) + | label, None, Some _ -> { - ptyp_desc = - Ptyp_constr - ({txt = Ldot (Lident "*predef*", "option")}, [type_]); - }, - _ ) - (* ~foo: int=? - note this isnt valid. but we want to get a type error *) - | label, Some type_, _ - when isOptional label -> - type_ - (* ~foo=? *) - | label, None, _ when isOptional label -> - { - ptyp_desc = Ptyp_var (safeTypeFromValue label); - ptyp_loc = loc; - ptyp_attributes = []; - } - (* ~foo *) - | label, None, _ -> - { - ptyp_desc = Ptyp_var (safeTypeFromValue label); - ptyp_loc = loc; - ptyp_attributes = []; - } - | _label, Some type_, _ -> type_) - args) + ptyp_desc = Ptyp_var (safeTypeFromValue label); + ptyp_loc = loc; + ptyp_attributes = []; + } + (* ~foo: int=1 *) + | _label, Some type_, Some _ -> type_ + (* ~foo: option(int)=? *) + | ( label, + Some + { + ptyp_desc = Ptyp_constr ({ txt = Lident "option" }, [ type_ ]); + }, + _ ) + | ( label, + Some + { + ptyp_desc = + Ptyp_constr + ({ txt = Ldot (Lident "*predef*", "option") }, [ type_ ]); + }, + _ ) + (* ~foo: int=? - note this isnt valid. but we want to get a type error *) + | label, Some type_, _ + when isOptional label -> + type_ + (* ~foo=? *) + | label, None, _ when isOptional label -> + { + ptyp_desc = Ptyp_var (safeTypeFromValue label); + ptyp_loc = loc; + ptyp_attributes = []; + } + (* ~foo *) + | label, None, _ -> + { + ptyp_desc = Ptyp_var (safeTypeFromValue label); + ptyp_loc = loc; + ptyp_attributes = []; + } + | _label, Some type_, _ -> type_) + args) | [] -> args (* Build an AST node for the [@bs.obj] representing props for a component *) let makePropsValue fnName loc namedArgListWithKeyAndRef propsType = let propsName = fnName ^ "Props" in { - pval_name = {txt = propsName; loc}; + pval_name = { txt = propsName; loc }; pval_type = recursivelyMakeNamedArgsForExternal namedArgListWithKeyAndRef (Typ.arrow nolabel { - ptyp_desc = Ptyp_constr ({txt = Lident "unit"; loc}, []); + ptyp_desc = Ptyp_constr ({ txt = Lident "unit"; loc }, []); ptyp_loc = loc; ptyp_attributes = []; } propsType); - pval_prim = [""]; - pval_attributes = [({txt = "bs.obj"; loc}, PStr [])]; + pval_prim = [ "" ]; + pval_attributes = [ ({ txt = "bs.obj"; loc }, PStr []) ]; pval_loc = loc; } @@ -273665,10 +273850,14 @@ let makePropsExternalSig fnName loc namedArgListWithKeyAndRef propsType = (* Build an AST node for the props name when converted to an object inside the function signature *) let makePropsName ~loc name = - {ppat_desc = Ppat_var {txt = name; loc}; ppat_loc = loc; ppat_attributes = []} + { + ppat_desc = Ppat_var { txt = name; loc }; + ppat_loc = loc; + ppat_attributes = []; + } let makeObjectField loc (str, attrs, type_) = - Otag ({loc; txt = str}, attrs, type_) + Otag ({ loc; txt = str }, attrs, type_) (* Build an AST node representing a "closed" object representing a component's props *) let makePropsType ~loc namedTypeList = @@ -273685,11 +273874,11 @@ let newtypeToVar newtype type_ = let var_desc = Ptyp_var ("type-" ^ newtype) in let typ (mapper : Ast_mapper.mapper) typ = match typ.ptyp_desc with - | Ptyp_constr ({txt = Lident name}, _) when name = newtype -> - {typ with ptyp_desc = var_desc} + | Ptyp_constr ({ txt = Lident name }, _) when name = newtype -> + { typ with ptyp_desc = var_desc } | _ -> Ast_mapper.default_mapper.typ mapper typ in - let mapper = {Ast_mapper.default_mapper with typ} in + let mapper = { Ast_mapper.default_mapper with typ } in mapper.typ mapper type_ (* TODO: some line number might still be wrong *) @@ -273709,23 +273898,23 @@ let jsxMapper ~config = let args = recursivelyTransformedArgsForMake @ (match childrenExpr with - | Exact children -> [(labelled "children", children)] - | ListLiteral {pexp_desc = Pexp_array list} when list = [] -> [] + | Exact children -> [ (labelled "children", children) ] + | ListLiteral { pexp_desc = Pexp_array list } when list = [] -> [] | ListLiteral expression -> - (* this is a hack to support react components that introspect into their children *) - childrenArg := Some expression; - [ - ( labelled "children", - Exp.ident ~loc {loc; txt = Ldot (Lident "React", "null")} ); - ]) - @ [(nolabel, Exp.construct ~loc {loc; txt = Lident "()"} None)] + (* this is a hack to support react components that introspect into their children *) + childrenArg := Some expression; + [ + ( labelled "children", + Exp.ident ~loc { loc; txt = Ldot (Lident "React", "null") } ); + ]) + @ [ (nolabel, Exp.construct ~loc { loc; txt = Lident "()" } None) ] in let isCap str = String.capitalize_ascii str = str in let ident = match modulePath with | Lident _ -> Ldot (modulePath, "make") | Ldot (_modulePath, value) as fullPath when isCap value -> - Ldot (fullPath, "make") + Ldot (fullPath, "make") | modulePath -> modulePath in let propsIdent = @@ -273733,28 +273922,28 @@ let jsxMapper ~config = | Lident path -> Lident (path ^ "Props") | Ldot (ident, path) -> Ldot (ident, path ^ "Props") | _ -> - React_jsx_common.raiseError ~loc - "JSX name can't be the result of function applications" + React_jsx_common.raiseError ~loc + "JSX name can't be the result of function applications" in let props = - Exp.apply ~attrs ~loc (Exp.ident ~loc {loc; txt = propsIdent}) args + Exp.apply ~attrs ~loc (Exp.ident ~loc { loc; txt = propsIdent }) args in (* handle key, ref, children *) (* React.createElement(Component.make, props, ...children) *) match !childrenArg with | None -> - Exp.apply ~loc ~attrs - (Exp.ident ~loc {loc; txt = Ldot (Lident "React", "createElement")}) - [(nolabel, Exp.ident ~loc {txt = ident; loc}); (nolabel, props)] + Exp.apply ~loc ~attrs + (Exp.ident ~loc { loc; txt = Ldot (Lident "React", "createElement") }) + [ (nolabel, Exp.ident ~loc { txt = ident; loc }); (nolabel, props) ] | Some children -> - Exp.apply ~loc ~attrs - (Exp.ident ~loc - {loc; txt = Ldot (Lident "React", "createElementVariadic")}) - [ - (nolabel, Exp.ident ~loc {txt = ident; loc}); - (nolabel, props); - (nolabel, children); - ] + Exp.apply ~loc ~attrs + (Exp.ident ~loc + { loc; txt = Ldot (Lident "React", "createElementVariadic") }) + [ + (nolabel, Exp.ident ~loc { txt = ident; loc }); + (nolabel, props); + (nolabel, children); + ] in let transformLowercaseCall3 mapper loc attrs callArguments id = @@ -273766,48 +273955,50 @@ let jsxMapper ~config = (* [@JSX] div(~children=[a]), coming from
a
*) | { pexp_desc = - ( Pexp_construct ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple _}) - | Pexp_construct ({txt = Lident "[]"}, None) ); + ( Pexp_construct + ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple _ }) + | Pexp_construct ({ txt = Lident "[]" }, None) ); } -> - "createDOMElementVariadic" + "createDOMElementVariadic" (* [@JSX] div(~children= value), coming from
...(value)
*) - | {pexp_loc} -> - React_jsx_common.raiseError ~loc:pexp_loc - "A spread as a DOM element's children don't make sense written \ - together. You can simply remove the spread." + | { pexp_loc } -> + React_jsx_common.raiseError ~loc:pexp_loc + "A spread as a DOM element's children don't make sense written \ + together. You can simply remove the spread." in let args = match nonChildrenProps with - | [_justTheUnitArgumentAtEnd] -> - [ - (* "div" *) - (nolabel, componentNameExpr); - (* [|moreCreateElementCallsHere|] *) - (nolabel, childrenExpr); - ] + | [ _justTheUnitArgumentAtEnd ] -> + [ + (* "div" *) + (nolabel, componentNameExpr); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr); + ] | nonEmptyProps -> - let propsCall = - Exp.apply ~loc - (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOMRe", "domProps")}) - (nonEmptyProps - |> List.map (fun (label, expression) -> - (label, mapper.expr mapper expression))) - in - [ - (* "div" *) - (nolabel, componentNameExpr); - (* ReactDOMRe.props(~className=blabla, ~foo=bar, ()) *) - (labelled "props", propsCall); - (* [|moreCreateElementCallsHere|] *) - (nolabel, childrenExpr); - ] + let propsCall = + Exp.apply ~loc + (Exp.ident ~loc + { loc; txt = Ldot (Lident "ReactDOMRe", "domProps") }) + (nonEmptyProps + |> List.map (fun (label, expression) -> + (label, mapper.expr mapper expression))) + in + [ + (* "div" *) + (nolabel, componentNameExpr); + (* ReactDOMRe.props(~className=blabla, ~foo=bar, ()) *) + (labelled "props", propsCall); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr); + ] in Exp.apply ~loc (* throw away the [@JSX] attribute and keep the others, if any *) ~attrs (* ReactDOMRe.createElement *) (Exp.ident ~loc - {loc; txt = Ldot (Lident "ReactDOMRe", createElementCall)}) + { loc; txt = Ldot (Lident "ReactDOMRe", createElementCall) }) args in @@ -273816,128 +274007,132 @@ let jsxMapper ~config = match expr.pexp_desc with (* TODO: make this show up with a loc. *) | Pexp_fun (Labelled "key", _, _, _) | Pexp_fun (Optional "key", _, _, _) -> - React_jsx_common.raiseError ~loc:expr.pexp_loc - "Key cannot be accessed inside of a component. Don't worry - you can \ - always key a component from its parent!" + React_jsx_common.raiseError ~loc:expr.pexp_loc + "Key cannot be accessed inside of a component. Don't worry - you can \ + always key a component from its parent!" | Pexp_fun (Labelled "ref", _, _, _) | Pexp_fun (Optional "ref", _, _, _) -> - React_jsx_common.raiseError ~loc:expr.pexp_loc - "Ref cannot be passed as a normal prop. Either give the prop a \ - different name or use the `forwardRef` API instead." + React_jsx_common.raiseError ~loc:expr.pexp_loc + "Ref cannot be passed as a normal prop. Either give the prop a \ + different name or use the `forwardRef` API instead." | Pexp_fun (arg, default, pattern, expression) when isOptional arg || isLabelled arg -> - let () = - match (isOptional arg, pattern, default) with - | true, {ppat_desc = Ppat_constraint (_, {ptyp_desc})}, None -> ( - match ptyp_desc with - | Ptyp_constr ({txt = Lident "option"}, [_]) -> () - | _ -> - let currentType = + let () = + match (isOptional arg, pattern, default) with + | true, { ppat_desc = Ppat_constraint (_, { ptyp_desc }) }, None -> ( match ptyp_desc with - | Ptyp_constr ({txt}, []) -> - String.concat "." (Longident.flatten txt) - | Ptyp_constr ({txt}, _innerTypeArgs) -> - String.concat "." (Longident.flatten txt) ^ "(...)" - | _ -> "..." - in - Location.prerr_warning pattern.ppat_loc - (Preprocessor - (Printf.sprintf - "React: optional argument annotations must have explicit \ - `option`. Did you mean `option(%s)=?`?" - currentType))) - | _ -> () - in - let alias = - match pattern with - | {ppat_desc = Ppat_alias (_, {txt}) | Ppat_var {txt}} -> txt - | {ppat_desc = Ppat_any} -> "_" - | _ -> getLabel arg - in - let type_ = - match pattern with - | {ppat_desc = Ppat_constraint (_, type_)} -> Some type_ - | _ -> None - in + | Ptyp_constr ({ txt = Lident "option" }, [ _ ]) -> () + | _ -> + let currentType = + match ptyp_desc with + | Ptyp_constr ({ txt }, []) -> + String.concat "." (Longident.flatten txt) + | Ptyp_constr ({ txt }, _innerTypeArgs) -> + String.concat "." (Longident.flatten txt) ^ "(...)" + | _ -> "..." + in + Location.prerr_warning pattern.ppat_loc + (Preprocessor + (Printf.sprintf + "React: optional argument annotations must have \ + explicit `option`. Did you mean `option(%s)=?`?" + currentType))) + | _ -> () + in + let alias = + match pattern with + | { ppat_desc = Ppat_alias (_, { txt }) | Ppat_var { txt } } -> txt + | { ppat_desc = Ppat_any } -> "_" + | _ -> getLabel arg + in + let type_ = + match pattern with + | { ppat_desc = Ppat_constraint (_, type_) } -> Some type_ + | _ -> None + in - recursivelyTransformNamedArgsForMake mapper expression - ((arg, default, pattern, alias, pattern.ppat_loc, type_) :: args) - newtypes + recursivelyTransformNamedArgsForMake mapper expression + ((arg, default, pattern, alias, pattern.ppat_loc, type_) :: args) + newtypes | Pexp_fun ( Nolabel, _, - {ppat_desc = Ppat_construct ({txt = Lident "()"}, _) | Ppat_any}, + { ppat_desc = Ppat_construct ({ txt = Lident "()" }, _) | Ppat_any }, _expression ) -> - (args, newtypes, None) + (args, newtypes, None) | Pexp_fun ( Nolabel, _, { ppat_desc = - Ppat_var {txt} | Ppat_constraint ({ppat_desc = Ppat_var {txt}}, _); + ( Ppat_var { txt } + | Ppat_constraint ({ ppat_desc = Ppat_var { txt } }, _) ); }, _expression ) -> - (args, newtypes, Some txt) + (args, newtypes, Some txt) | Pexp_fun (Nolabel, _, pattern, _expression) -> - Location.raise_errorf ~loc:pattern.ppat_loc - "React: react.component refs only support plain arguments and type \ - annotations." + Location.raise_errorf ~loc:pattern.ppat_loc + "React: react.component refs only support plain arguments and type \ + annotations." | Pexp_newtype (label, expression) -> - recursivelyTransformNamedArgsForMake mapper expression args - (label :: newtypes) + recursivelyTransformNamedArgsForMake mapper expression args + (label :: newtypes) | Pexp_constraint (expression, _typ) -> - recursivelyTransformNamedArgsForMake mapper expression args newtypes + recursivelyTransformNamedArgsForMake mapper expression args newtypes | _ -> (args, newtypes, None) in let argToType types (name, default, _noLabelName, _alias, loc, type_) = match (type_, name, default) with - | Some {ptyp_desc = Ptyp_constr ({txt = Lident "option"}, [type_])}, name, _ + | ( Some { ptyp_desc = Ptyp_constr ({ txt = Lident "option" }, [ type_ ]) }, + name, + _ ) when isOptional name -> - ( getLabel name, - [], - { - type_ with - ptyp_desc = - Ptyp_constr ({loc = type_.ptyp_loc; txt = optionIdent}, [type_]); - } ) - :: types + ( getLabel name, + [], + { + type_ with + ptyp_desc = + Ptyp_constr + ({ loc = type_.ptyp_loc; txt = optionIdent }, [ type_ ]); + } ) + :: types | Some type_, name, Some _default -> - ( getLabel name, - [], - { - ptyp_desc = Ptyp_constr ({loc; txt = optionIdent}, [type_]); - ptyp_loc = loc; - ptyp_attributes = []; - } ) - :: types + ( getLabel name, + [], + { + ptyp_desc = Ptyp_constr ({ loc; txt = optionIdent }, [ type_ ]); + ptyp_loc = loc; + ptyp_attributes = []; + } ) + :: types | Some type_, name, _ -> (getLabel name, [], type_) :: types | None, name, _ when isOptional name -> - ( getLabel name, - [], - { - ptyp_desc = - Ptyp_constr - ( {loc; txt = optionIdent}, - [ - { - ptyp_desc = Ptyp_var (safeTypeFromValue name); - ptyp_loc = loc; - ptyp_attributes = []; - }; - ] ); - ptyp_loc = loc; - ptyp_attributes = []; - } ) - :: types + ( getLabel name, + [], + { + ptyp_desc = + Ptyp_constr + ( { loc; txt = optionIdent }, + [ + { + ptyp_desc = Ptyp_var (safeTypeFromValue name); + ptyp_loc = loc; + ptyp_attributes = []; + }; + ] ); + ptyp_loc = loc; + ptyp_attributes = []; + } ) + :: types | None, name, _ when isLabelled name -> - ( getLabel name, - [], - { - ptyp_desc = Ptyp_var (safeTypeFromValue name); - ptyp_loc = loc; - ptyp_attributes = []; - } ) - :: types + ( getLabel name, + [], + { + ptyp_desc = Ptyp_var (safeTypeFromValue name); + ptyp_loc = loc; + ptyp_attributes = []; + } ) + :: types | _ -> types in @@ -273945,8 +274140,8 @@ let jsxMapper ~config = match name with | name when isLabelled name -> (getLabel name, [], type_) :: types | name when isOptional name -> - (getLabel name, [], Typ.constr ~loc {loc; txt = optionIdent} [type_]) - :: types + (getLabel name, [], Typ.constr ~loc { loc; txt = optionIdent } [ type_ ]) + :: types | _ -> types in @@ -273958,432 +274153,458 @@ let jsxMapper ~config = pstr_loc; pstr_desc = Pstr_primitive - ({pval_name = {txt = fnName}; pval_attributes; pval_type} as + ({ pval_name = { txt = fnName }; pval_attributes; pval_type } as value_description); } as pstr -> ( - match List.filter React_jsx_common.hasAttr pval_attributes with - | [] -> [item] - | [_] -> - let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = - match ptyp_desc with - | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) - when isLabelled name || isOptional name -> - getPropTypes ((name, ptyp_loc, type_) :: types) rest - | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest - | Ptyp_arrow (name, type_, returnValue) - when isLabelled name || isOptional name -> - (returnValue, (name, returnValue.ptyp_loc, type_) :: types) - | _ -> (fullType, types) - in - let innerType, propTypes = getPropTypes [] pval_type in - let namedTypeList = List.fold_left argToConcreteType [] propTypes in - let pluckLabelAndLoc (label, loc, type_) = - (label, None (* default *), loc, Some type_) - in - let retPropsType = makePropsType ~loc:pstr_loc namedTypeList in - let externalPropsDecl = - makePropsExternal fnName pstr_loc - ((optional "key", None, pstr_loc, Some (keyType pstr_loc)) - :: List.map pluckLabelAndLoc propTypes) - retPropsType - in - (* can't be an arrow because it will defensively uncurry *) - let newExternalType = - Ptyp_constr - ( {loc = pstr_loc; txt = Ldot (Lident "React", "componentLike")}, - [retPropsType; innerType] ) - in - let newStructure = - { - pstr with - pstr_desc = - Pstr_primitive - { - value_description with - pval_type = {pval_type with ptyp_desc = newExternalType}; - pval_attributes = List.filter otherAttrsPure pval_attributes; - }; - } - in - [externalPropsDecl; newStructure] - | _ -> - React_jsx_common.raiseError ~loc:pstr_loc - "Only one react.component call can exist on a component at one time") - (* let component = ... *) - | {pstr_loc; pstr_desc = Pstr_value (recFlag, valueBindings)} -> ( - let fileName = filenameFromLoc pstr_loc in - let emptyLoc = Location.in_file fileName in - let mapBinding binding = - if React_jsx_common.hasAttrOnBinding binding then - let bindingLoc = binding.pvb_loc in - let bindingPatLoc = binding.pvb_pat.ppat_loc in - let binding = - { - binding with - pvb_pat = {binding.pvb_pat with ppat_loc = emptyLoc}; - pvb_loc = emptyLoc; - } - in - let fnName = getFnName binding.pvb_pat in - let internalFnName = fnName ^ "$Internal" in - let fullModuleName = makeModuleName fileName !nestedModules fnName in - let modifiedBindingOld binding = - let expression = binding.pvb_expr in - (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) - let rec spelunkForFunExpression expression = - match expression with - (* let make = (~prop) => ... *) - | {pexp_desc = Pexp_fun _} | {pexp_desc = Pexp_newtype _} -> - expression - (* let make = {let foo = bar in (~prop) => ...} *) - | {pexp_desc = Pexp_let (_recursive, _vbs, returnExpression)} -> - (* here's where we spelunk! *) - spelunkForFunExpression returnExpression - (* let make = React.forwardRef((~prop) => ...) *) - | { - pexp_desc = - Pexp_apply - (_wrapperExpression, [(Nolabel, innerFunctionExpression)]); - } -> - spelunkForFunExpression innerFunctionExpression - | { - pexp_desc = - Pexp_sequence (_wrapperExpression, innerFunctionExpression); - } -> - spelunkForFunExpression innerFunctionExpression - | {pexp_desc = Pexp_constraint (innerFunctionExpression, _typ)} -> - spelunkForFunExpression innerFunctionExpression - | {pexp_loc} -> - React_jsx_common.raiseError ~loc:pexp_loc - "react.component calls can only be on function definitions \ - or component wrappers (forwardRef, memo)." + match List.filter React_jsx_common.hasAttr pval_attributes with + | [] -> [ item ] + | [ _ ] -> + let rec getPropTypes types ({ ptyp_loc; ptyp_desc } as fullType) = + match ptyp_desc with + | Ptyp_arrow (name, type_, ({ ptyp_desc = Ptyp_arrow _ } as rest)) + when isLabelled name || isOptional name -> + getPropTypes ((name, ptyp_loc, type_) :: types) rest + | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest + | Ptyp_arrow (name, type_, returnValue) + when isLabelled name || isOptional name -> + (returnValue, (name, returnValue.ptyp_loc, type_) :: types) + | _ -> (fullType, types) in - spelunkForFunExpression expression - in - let modifiedBinding binding = - let hasApplication = ref false in - let wrapExpressionWithBinding expressionFn expression = - Vb.mk ~loc:bindingLoc - ~attrs:(List.filter otherAttrsPure binding.pvb_attributes) - (Pat.var ~loc:bindingPatLoc {loc = bindingPatLoc; txt = fnName}) - (expressionFn expression) + let innerType, propTypes = getPropTypes [] pval_type in + let namedTypeList = List.fold_left argToConcreteType [] propTypes in + let pluckLabelAndLoc (label, loc, type_) = + (label, None (* default *), loc, Some type_) + in + let retPropsType = makePropsType ~loc:pstr_loc namedTypeList in + let externalPropsDecl = + makePropsExternal fnName pstr_loc + ((optional "key", None, pstr_loc, Some (keyType pstr_loc)) + :: List.map pluckLabelAndLoc propTypes) + retPropsType + in + (* can't be an arrow because it will defensively uncurry *) + let newExternalType = + Ptyp_constr + ( { + loc = pstr_loc; + txt = Ldot (Lident "React", "componentLike"); + }, + [ retPropsType; innerType ] ) + in + let newStructure = + { + pstr with + pstr_desc = + Pstr_primitive + { + value_description with + pval_type = { pval_type with ptyp_desc = newExternalType }; + pval_attributes = + List.filter otherAttrsPure pval_attributes; + }; + } in - let expression = binding.pvb_expr in - let unerasableIgnoreExp exp = + [ externalPropsDecl; newStructure ] + | _ -> + React_jsx_common.raiseError ~loc:pstr_loc + "Only one react.component call can exist on a component at one \ + time") + (* let component = ... *) + | { pstr_loc; pstr_desc = Pstr_value (recFlag, valueBindings) } -> ( + let fileName = filenameFromLoc pstr_loc in + let emptyLoc = Location.in_file fileName in + let mapBinding binding = + if React_jsx_common.hasAttrOnBinding binding then + let bindingLoc = binding.pvb_loc in + let bindingPatLoc = binding.pvb_pat.ppat_loc in + let binding = { - exp with - pexp_attributes = - unerasableIgnore emptyLoc :: exp.pexp_attributes; + binding with + pvb_pat = { binding.pvb_pat with ppat_loc = emptyLoc }; + pvb_loc = emptyLoc; } in - (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) - let rec spelunkForFunExpression expression = - match expression with - (* let make = (~prop) => ... with no final unit *) - | { - pexp_desc = - Pexp_fun - ( ((Labelled _ | Optional _) as label), - default, - pattern, - ({pexp_desc = Pexp_fun _} as internalExpression) ); - } -> - let wrap, hasUnit, exp = - spelunkForFunExpression internalExpression - in - ( wrap, - hasUnit, - unerasableIgnoreExp - { - expression with - pexp_desc = Pexp_fun (label, default, pattern, exp); - } ) - (* let make = (()) => ... *) - (* let make = (_) => ... *) - | { - pexp_desc = - Pexp_fun - ( Nolabel, - _default, - { - ppat_desc = - Ppat_construct ({txt = Lident "()"}, _) | Ppat_any; - }, - _internalExpression ); - } -> - ((fun a -> a), true, expression) - (* let make = (~prop) => ... *) - | { - pexp_desc = - Pexp_fun - ( (Labelled _ | Optional _), - _default, - _pattern, - _internalExpression ); - } -> - ((fun a -> a), false, unerasableIgnoreExp expression) - (* let make = (prop) => ... *) - | { - pexp_desc = - Pexp_fun (_nolabel, _default, pattern, _internalExpression); - } -> - if hasApplication.contents then - ((fun a -> a), false, unerasableIgnoreExp expression) - else - Location.raise_errorf ~loc:pattern.ppat_loc - "React: props need to be labelled arguments.\n\ - \ If you are working with refs be sure to wrap with \ - React.forwardRef.\n\ - \ If your component doesn't have any props use () or _ \ - instead of a name." - (* let make = {let foo = bar in (~prop) => ...} *) - | {pexp_desc = Pexp_let (recursive, vbs, internalExpression)} -> - (* here's where we spelunk! *) - let wrap, hasUnit, exp = - spelunkForFunExpression internalExpression - in - ( wrap, - hasUnit, - {expression with pexp_desc = Pexp_let (recursive, vbs, exp)} - ) - (* let make = React.forwardRef((~prop) => ...) *) - | { - pexp_desc = - Pexp_apply (wrapperExpression, [(Nolabel, internalExpression)]); - } -> - let () = hasApplication := true in - let _, hasUnit, exp = - spelunkForFunExpression internalExpression - in - ( (fun exp -> Exp.apply wrapperExpression [(nolabel, exp)]), - hasUnit, - exp ) - | { - pexp_desc = Pexp_sequence (wrapperExpression, internalExpression); - } -> - let wrap, hasUnit, exp = - spelunkForFunExpression internalExpression - in - ( wrap, - hasUnit, - { - expression with - pexp_desc = Pexp_sequence (wrapperExpression, exp); - } ) - | e -> ((fun a -> a), false, e) + let fnName = getFnName binding.pvb_pat in + let internalFnName = fnName ^ "$Internal" in + let fullModuleName = + makeModuleName fileName !nestedModules fnName in - let wrapExpression, hasUnit, expression = + let modifiedBindingOld binding = + let expression = binding.pvb_expr in + (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) + let rec spelunkForFunExpression expression = + match expression with + (* let make = (~prop) => ... *) + | { pexp_desc = Pexp_fun _ } | { pexp_desc = Pexp_newtype _ } -> + expression + (* let make = {let foo = bar in (~prop) => ...} *) + | { pexp_desc = Pexp_let (_recursive, _vbs, returnExpression) } + -> + (* here's where we spelunk! *) + spelunkForFunExpression returnExpression + (* let make = React.forwardRef((~prop) => ...) *) + | { + pexp_desc = + Pexp_apply + (_wrapperExpression, [ (Nolabel, innerFunctionExpression) ]); + } -> + spelunkForFunExpression innerFunctionExpression + | { + pexp_desc = + Pexp_sequence (_wrapperExpression, innerFunctionExpression); + } -> + spelunkForFunExpression innerFunctionExpression + | { + pexp_desc = Pexp_constraint (innerFunctionExpression, _typ); + } -> + spelunkForFunExpression innerFunctionExpression + | { pexp_loc } -> + React_jsx_common.raiseError ~loc:pexp_loc + "react.component calls can only be on function \ + definitions or component wrappers (forwardRef, memo)." + in spelunkForFunExpression expression in - (wrapExpressionWithBinding wrapExpression, hasUnit, expression) - in - let bindingWrapper, hasUnit, expression = modifiedBinding binding in - let reactComponentAttribute = - try Some (List.find React_jsx_common.hasAttr binding.pvb_attributes) - with Not_found -> None - in - let _attr_loc, payload = - match reactComponentAttribute with - | Some (loc, payload) -> (loc.loc, Some payload) - | None -> (emptyLoc, None) - in - let props = getPropsAttr payload in - (* do stuff here! *) - let namedArgList, newtypes, forwardRef = - recursivelyTransformNamedArgsForMake mapper - (modifiedBindingOld binding) - [] [] - in - let namedArgListWithKeyAndRef = - ( optional "key", - None, - Pat.var {txt = "key"; loc = emptyLoc}, - "key", - emptyLoc, - Some (keyType emptyLoc) ) - :: namedArgList - in - let namedArgListWithKeyAndRef = - match forwardRef with - | Some _ -> - ( optional "ref", + let modifiedBinding binding = + let hasApplication = ref false in + let wrapExpressionWithBinding expressionFn expression = + Vb.mk ~loc:bindingLoc + ~attrs:(List.filter otherAttrsPure binding.pvb_attributes) + (Pat.var ~loc:bindingPatLoc + { loc = bindingPatLoc; txt = fnName }) + (expressionFn expression) + in + let expression = binding.pvb_expr in + let unerasableIgnoreExp exp = + { + exp with + pexp_attributes = + unerasableIgnore emptyLoc :: exp.pexp_attributes; + } + in + (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) + let rec spelunkForFunExpression expression = + match expression with + (* let make = (~prop) => ... with no final unit *) + | { + pexp_desc = + Pexp_fun + ( ((Labelled _ | Optional _) as label), + default, + pattern, + ({ pexp_desc = Pexp_fun _ } as internalExpression) ); + } -> + let wrap, hasUnit, exp = + spelunkForFunExpression internalExpression + in + ( wrap, + hasUnit, + unerasableIgnoreExp + { + expression with + pexp_desc = Pexp_fun (label, default, pattern, exp); + } ) + (* let make = (()) => ... *) + (* let make = (_) => ... *) + | { + pexp_desc = + Pexp_fun + ( Nolabel, + _default, + { + ppat_desc = + Ppat_construct ({ txt = Lident "()" }, _) | Ppat_any; + }, + _internalExpression ); + } -> + ((fun a -> a), true, expression) + (* let make = (~prop) => ... *) + | { + pexp_desc = + Pexp_fun + ( (Labelled _ | Optional _), + _default, + _pattern, + _internalExpression ); + } -> + ((fun a -> a), false, unerasableIgnoreExp expression) + (* let make = (prop) => ... *) + | { + pexp_desc = + Pexp_fun (_nolabel, _default, pattern, _internalExpression); + } -> + if hasApplication.contents then + ((fun a -> a), false, unerasableIgnoreExp expression) + else + Location.raise_errorf ~loc:pattern.ppat_loc + "React: props need to be labelled arguments.\n\ + \ If you are working with refs be sure to wrap with \ + React.forwardRef.\n\ + \ If your component doesn't have any props use () or \ + _ instead of a name." + (* let make = {let foo = bar in (~prop) => ...} *) + | { pexp_desc = Pexp_let (recursive, vbs, internalExpression) } + -> + (* here's where we spelunk! *) + let wrap, hasUnit, exp = + spelunkForFunExpression internalExpression + in + ( wrap, + hasUnit, + { + expression with + pexp_desc = Pexp_let (recursive, vbs, exp); + } ) + (* let make = React.forwardRef((~prop) => ...) *) + | { + pexp_desc = + Pexp_apply + (wrapperExpression, [ (Nolabel, internalExpression) ]); + } -> + let () = hasApplication := true in + let _, hasUnit, exp = + spelunkForFunExpression internalExpression + in + ( (fun exp -> Exp.apply wrapperExpression [ (nolabel, exp) ]), + hasUnit, + exp ) + | { + pexp_desc = + Pexp_sequence (wrapperExpression, internalExpression); + } -> + let wrap, hasUnit, exp = + spelunkForFunExpression internalExpression + in + ( wrap, + hasUnit, + { + expression with + pexp_desc = Pexp_sequence (wrapperExpression, exp); + } ) + | e -> ((fun a -> a), false, e) + in + let wrapExpression, hasUnit, expression = + spelunkForFunExpression expression + in + (wrapExpressionWithBinding wrapExpression, hasUnit, expression) + in + let bindingWrapper, hasUnit, expression = modifiedBinding binding in + let reactComponentAttribute = + try + Some (List.find React_jsx_common.hasAttr binding.pvb_attributes) + with Not_found -> None + in + let _attr_loc, payload = + match reactComponentAttribute with + | Some (loc, payload) -> (loc.loc, Some payload) + | None -> (emptyLoc, None) + in + let props = getPropsAttr payload in + (* do stuff here! *) + let namedArgList, newtypes, forwardRef = + recursivelyTransformNamedArgsForMake mapper + (modifiedBindingOld binding) + [] [] + in + let namedArgListWithKeyAndRef = + ( optional "key", None, - Pat.var {txt = "key"; loc = emptyLoc}, - "ref", + Pat.var { txt = "key"; loc = emptyLoc }, + "key", emptyLoc, - None ) - :: namedArgListWithKeyAndRef - | None -> namedArgListWithKeyAndRef - in - let namedArgListWithKeyAndRefForNew = - match forwardRef with - | Some txt -> - namedArgList - @ [ - ( nolabel, + Some (keyType emptyLoc) ) + :: namedArgList + in + let namedArgListWithKeyAndRef = + match forwardRef with + | Some _ -> + ( optional "ref", None, - Pat.var {txt; loc = emptyLoc}, - txt, + Pat.var { txt = "key"; loc = emptyLoc }, + "ref", emptyLoc, - None ); - ] - | None -> namedArgList - in - let pluckArg (label, _, _, alias, loc, _) = - let labelString = - match label with - | label when isOptional label || isLabelled label -> - getLabel label - | _ -> "" + None ) + :: namedArgListWithKeyAndRef + | None -> namedArgListWithKeyAndRef in - ( label, - match labelString with - | "" -> Exp.ident ~loc {txt = Lident alias; loc} - | labelString -> - Exp.apply ~loc - (Exp.ident ~loc {txt = Lident "##"; loc}) - [ - (nolabel, Exp.ident ~loc {txt = Lident props.propsName; loc}); - (nolabel, Exp.ident ~loc {txt = Lident labelString; loc}); - ] ) - in - let namedTypeList = List.fold_left argToType [] namedArgList in - let loc = emptyLoc in - let externalArgs = - (* translate newtypes to type variables *) - List.fold_left - (fun args newtype -> - List.map - (fun (a, b, c, d, e, maybeTyp) -> - match maybeTyp with - | Some typ -> - (a, b, c, d, e, Some (newtypeToVar newtype.txt typ)) - | None -> (a, b, c, d, e, None)) - args) - namedArgListWithKeyAndRef newtypes - in - let externalTypes = - (* translate newtypes to type variables *) - List.fold_left - (fun args newtype -> - List.map - (fun (a, b, typ) -> (a, b, newtypeToVar newtype.txt typ)) - args) - namedTypeList newtypes - in - let externalDecl = - makeExternalDecl fnName loc externalArgs externalTypes - in - let innerExpressionArgs = - List.map pluckArg namedArgListWithKeyAndRefForNew - @ - if hasUnit then - [(Nolabel, Exp.construct {loc; txt = Lident "()"} None)] - else [] - in - let innerExpression = - Exp.apply - (Exp.ident - { - loc; - txt = - Lident - (match recFlag with - | Recursive -> internalFnName - | Nonrecursive -> fnName); - }) - innerExpressionArgs - in - let innerExpressionWithRef = - match forwardRef with - | Some txt -> - { - innerExpression with - pexp_desc = - Pexp_fun - ( nolabel, - None, - { - ppat_desc = Ppat_var {txt; loc = emptyLoc}; - ppat_loc = emptyLoc; - ppat_attributes = []; - }, - innerExpression ); - } - | None -> innerExpression - in - let fullExpression = - Exp.fun_ nolabel None - { - ppat_desc = - Ppat_constraint - ( makePropsName ~loc:emptyLoc props.propsName, - makePropsType ~loc:emptyLoc externalTypes ); - ppat_loc = emptyLoc; - ppat_attributes = []; - } - innerExpressionWithRef - in - let fullExpression = - match fullModuleName with - | "" -> fullExpression - | txt -> - Exp.let_ Nonrecursive - [ - Vb.mk ~loc:emptyLoc - (Pat.var ~loc:emptyLoc {loc = emptyLoc; txt}) - fullExpression; - ] - (Exp.ident ~loc:emptyLoc {loc = emptyLoc; txt = Lident txt}) + let namedArgListWithKeyAndRefForNew = + match forwardRef with + | Some txt -> + namedArgList + @ [ + ( nolabel, + None, + Pat.var { txt; loc = emptyLoc }, + txt, + emptyLoc, + None ); + ] + | None -> namedArgList + in + let pluckArg (label, _, _, alias, loc, _) = + let labelString = + match label with + | label when isOptional label || isLabelled label -> + getLabel label + | _ -> "" + in + ( label, + match labelString with + | "" -> Exp.ident ~loc { txt = Lident alias; loc } + | labelString -> + Exp.apply ~loc + (Exp.ident ~loc { txt = Lident "##"; loc }) + [ + ( nolabel, + Exp.ident ~loc { txt = Lident props.propsName; loc } + ); + ( nolabel, + Exp.ident ~loc { txt = Lident labelString; loc } ); + ] ) + in + let namedTypeList = List.fold_left argToType [] namedArgList in + let loc = emptyLoc in + let externalArgs = + (* translate newtypes to type variables *) + List.fold_left + (fun args newtype -> + List.map + (fun (a, b, c, d, e, maybeTyp) -> + match maybeTyp with + | Some typ -> + (a, b, c, d, e, Some (newtypeToVar newtype.txt typ)) + | None -> (a, b, c, d, e, None)) + args) + namedArgListWithKeyAndRef newtypes + in + let externalTypes = + (* translate newtypes to type variables *) + List.fold_left + (fun args newtype -> + List.map + (fun (a, b, typ) -> (a, b, newtypeToVar newtype.txt typ)) + args) + namedTypeList newtypes + in + let externalDecl = + makeExternalDecl fnName loc externalArgs externalTypes + in + let innerExpressionArgs = + List.map pluckArg namedArgListWithKeyAndRefForNew + @ + if hasUnit then + [ (Nolabel, Exp.construct { loc; txt = Lident "()" } None) ] + else [] + in + let innerExpression = + Exp.apply + (Exp.ident + { + loc; + txt = + Lident + (match recFlag with + | Recursive -> internalFnName + | Nonrecursive -> fnName); + }) + innerExpressionArgs + in + let innerExpressionWithRef = + match forwardRef with + | Some txt -> + { + innerExpression with + pexp_desc = + Pexp_fun + ( nolabel, + None, + { + ppat_desc = Ppat_var { txt; loc = emptyLoc }; + ppat_loc = emptyLoc; + ppat_attributes = []; + }, + innerExpression ); + } + | None -> innerExpression + in + let fullExpression = + Exp.fun_ nolabel None + { + ppat_desc = + Ppat_constraint + ( makePropsName ~loc:emptyLoc props.propsName, + makePropsType ~loc:emptyLoc externalTypes ); + ppat_loc = emptyLoc; + ppat_attributes = []; + } + innerExpressionWithRef + in + let fullExpression = + match fullModuleName with + | "" -> fullExpression + | txt -> + Exp.let_ Nonrecursive + [ + Vb.mk ~loc:emptyLoc + (Pat.var ~loc:emptyLoc { loc = emptyLoc; txt }) + fullExpression; + ] + (Exp.ident ~loc:emptyLoc + { loc = emptyLoc; txt = Lident txt }) + in + let bindings, newBinding = + match recFlag with + | Recursive -> + ( [ + bindingWrapper + (Exp.let_ ~loc:emptyLoc Recursive + [ + makeNewBinding binding expression internalFnName; + Vb.mk + (Pat.var { loc = emptyLoc; txt = fnName }) + fullExpression; + ] + (Exp.ident { loc = emptyLoc; txt = Lident fnName })); + ], + None ) + | Nonrecursive -> + ( [ { binding with pvb_expr = expression } ], + Some (bindingWrapper fullExpression) ) + in + (Some externalDecl, bindings, newBinding) + else (None, [ binding ], None) + in + let structuresAndBinding = List.map mapBinding valueBindings in + let otherStructures (extern, binding, newBinding) + (externs, bindings, newBindings) = + let externs = + match extern with + | Some extern -> extern :: externs + | None -> externs in - let bindings, newBinding = - match recFlag with - | Recursive -> - ( [ - bindingWrapper - (Exp.let_ ~loc:emptyLoc Recursive - [ - makeNewBinding binding expression internalFnName; - Vb.mk - (Pat.var {loc = emptyLoc; txt = fnName}) - fullExpression; - ] - (Exp.ident {loc = emptyLoc; txt = Lident fnName})); - ], - None ) - | Nonrecursive -> - ( [{binding with pvb_expr = expression}], - Some (bindingWrapper fullExpression) ) + let newBindings = + match newBinding with + | Some newBinding -> newBinding :: newBindings + | None -> newBindings in - (Some externalDecl, bindings, newBinding) - else (None, [binding], None) - in - let structuresAndBinding = List.map mapBinding valueBindings in - let otherStructures (extern, binding, newBinding) - (externs, bindings, newBindings) = - let externs = - match extern with - | Some extern -> extern :: externs - | None -> externs + (externs, binding @ bindings, newBindings) in - let newBindings = - match newBinding with - | Some newBinding -> newBinding :: newBindings - | None -> newBindings + let externs, bindings, newBindings = + List.fold_right otherStructures structuresAndBinding ([], [], []) in - (externs, binding @ bindings, newBindings) - in - let externs, bindings, newBindings = - List.fold_right otherStructures structuresAndBinding ([], [], []) - in - externs - @ [{pstr_loc; pstr_desc = Pstr_value (recFlag, bindings)}] - @ - match newBindings with - | [] -> [] - | newBindings -> - [{pstr_loc = emptyLoc; pstr_desc = Pstr_value (recFlag, newBindings)}]) - | _ -> [item] + externs + @ [ { pstr_loc; pstr_desc = Pstr_value (recFlag, bindings) } ] + @ + match newBindings with + | [] -> [] + | newBindings -> + [ + { + pstr_loc = emptyLoc; + pstr_desc = Pstr_value (recFlag, newBindings); + }; + ]) + | _ -> [ item ] in let transformSignatureItem _mapper item = @@ -274392,152 +274613,164 @@ let jsxMapper ~config = psig_loc; psig_desc = Psig_value - ({pval_name = {txt = fnName}; pval_attributes; pval_type} as + ({ pval_name = { txt = fnName }; pval_attributes; pval_type } as psig_desc); } as psig -> ( - match List.filter React_jsx_common.hasAttr pval_attributes with - | [] -> [item] - | [_] -> - let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = - match ptyp_desc with - | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) - when isOptional name || isLabelled name -> - getPropTypes ((name, ptyp_loc, type_) :: types) rest - | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest - | Ptyp_arrow (name, type_, returnValue) - when isOptional name || isLabelled name -> - (returnValue, (name, returnValue.ptyp_loc, type_) :: types) - | _ -> (fullType, types) - in - let innerType, propTypes = getPropTypes [] pval_type in - let namedTypeList = List.fold_left argToConcreteType [] propTypes in - let pluckLabelAndLoc (label, loc, type_) = - (label, None, loc, Some type_) - in - let retPropsType = makePropsType ~loc:psig_loc namedTypeList in - let externalPropsDecl = - makePropsExternalSig fnName psig_loc - ((optional "key", None, psig_loc, Some (keyType psig_loc)) - :: List.map pluckLabelAndLoc propTypes) - retPropsType - in - (* can't be an arrow because it will defensively uncurry *) - let newExternalType = - Ptyp_constr - ( {loc = psig_loc; txt = Ldot (Lident "React", "componentLike")}, - [retPropsType; innerType] ) - in - let newStructure = - { - psig with - psig_desc = - Psig_value - { - psig_desc with - pval_type = {pval_type with ptyp_desc = newExternalType}; - pval_attributes = List.filter otherAttrsPure pval_attributes; - }; - } - in - [externalPropsDecl; newStructure] - | _ -> - React_jsx_common.raiseError ~loc:psig_loc - "Only one react.component call can exist on a component at one time") - | _ -> [item] + match List.filter React_jsx_common.hasAttr pval_attributes with + | [] -> [ item ] + | [ _ ] -> + let rec getPropTypes types ({ ptyp_loc; ptyp_desc } as fullType) = + match ptyp_desc with + | Ptyp_arrow (name, type_, ({ ptyp_desc = Ptyp_arrow _ } as rest)) + when isOptional name || isLabelled name -> + getPropTypes ((name, ptyp_loc, type_) :: types) rest + | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest + | Ptyp_arrow (name, type_, returnValue) + when isOptional name || isLabelled name -> + (returnValue, (name, returnValue.ptyp_loc, type_) :: types) + | _ -> (fullType, types) + in + let innerType, propTypes = getPropTypes [] pval_type in + let namedTypeList = List.fold_left argToConcreteType [] propTypes in + let pluckLabelAndLoc (label, loc, type_) = + (label, None, loc, Some type_) + in + let retPropsType = makePropsType ~loc:psig_loc namedTypeList in + let externalPropsDecl = + makePropsExternalSig fnName psig_loc + ((optional "key", None, psig_loc, Some (keyType psig_loc)) + :: List.map pluckLabelAndLoc propTypes) + retPropsType + in + (* can't be an arrow because it will defensively uncurry *) + let newExternalType = + Ptyp_constr + ( { + loc = psig_loc; + txt = Ldot (Lident "React", "componentLike"); + }, + [ retPropsType; innerType ] ) + in + let newStructure = + { + psig with + psig_desc = + Psig_value + { + psig_desc with + pval_type = { pval_type with ptyp_desc = newExternalType }; + pval_attributes = + List.filter otherAttrsPure pval_attributes; + }; + } + in + [ externalPropsDecl; newStructure ] + | _ -> + React_jsx_common.raiseError ~loc:psig_loc + "Only one react.component call can exist on a component at one \ + time") + | _ -> [ item ] in let transformJsxCall mapper callExpression callArguments attrs = match callExpression.pexp_desc with | Pexp_ident caller -> ( - match caller with - | {txt = Lident "createElement"; loc} -> - React_jsx_common.raiseError ~loc - "JSX: `createElement` should be preceeded by a module name." - (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *) - | {loc; txt = Ldot (modulePath, ("createElement" | "make"))} -> ( - match config.React_jsx_common.version with - | 3 -> - transformUppercaseCall3 modulePath mapper loc attrs callExpression - callArguments - | _ -> - React_jsx_common.raiseError ~loc "JSX: the JSX version must be 3") - (* div(~prop1=foo, ~prop2=bar, ~children=[bla], ()) *) - (* turn that into - ReactDOMRe.createElement(~props=ReactDOMRe.props(~props1=foo, ~props2=bar, ()), [|bla|]) *) - | {loc; txt = Lident id} -> ( - match config.version with - | 3 -> transformLowercaseCall3 mapper loc attrs callArguments id - | _ -> React_jsx_common.raiseError ~loc "JSX: the JSX version must be 3" - ) - | {txt = Ldot (_, anythingNotCreateElementOrMake); loc} -> - React_jsx_common.raiseError ~loc - "JSX: the JSX attribute should be attached to a \ - `YourModuleName.createElement` or `YourModuleName.make` call. We \ - saw `%s` instead" - anythingNotCreateElementOrMake - | {txt = Lapply _; loc} -> - (* don't think there's ever a case where this is reached *) - React_jsx_common.raiseError ~loc - "JSX: encountered a weird case while processing the code. Please \ - report this!") + match caller with + | { txt = Lident "createElement"; loc } -> + React_jsx_common.raiseError ~loc + "JSX: `createElement` should be preceeded by a module name." + (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *) + | { loc; txt = Ldot (modulePath, ("createElement" | "make")) } -> ( + match config.React_jsx_common.version with + | 3 -> + transformUppercaseCall3 modulePath mapper loc attrs + callExpression callArguments + | _ -> + React_jsx_common.raiseError ~loc + "JSX: the JSX version must be 3") + (* div(~prop1=foo, ~prop2=bar, ~children=[bla], ()) *) + (* turn that into + ReactDOMRe.createElement(~props=ReactDOMRe.props(~props1=foo, ~props2=bar, ()), [|bla|]) *) + | { loc; txt = Lident id } -> ( + match config.version with + | 3 -> transformLowercaseCall3 mapper loc attrs callArguments id + | _ -> + React_jsx_common.raiseError ~loc + "JSX: the JSX version must be 3") + | { txt = Ldot (_, anythingNotCreateElementOrMake); loc } -> + React_jsx_common.raiseError ~loc + "JSX: the JSX attribute should be attached to a \ + `YourModuleName.createElement` or `YourModuleName.make` call. \ + We saw `%s` instead" + anythingNotCreateElementOrMake + | { txt = Lapply _; loc } -> + (* don't think there's ever a case where this is reached *) + React_jsx_common.raiseError ~loc + "JSX: encountered a weird case while processing the code. Please \ + report this!") | _ -> - React_jsx_common.raiseError ~loc:callExpression.pexp_loc - "JSX: `createElement` should be preceeded by a simple, direct module \ - name." + React_jsx_common.raiseError ~loc:callExpression.pexp_loc + "JSX: `createElement` should be preceeded by a simple, direct module \ + name." in let expr mapper expression = match expression with (* Does the function application have the @JSX attribute? *) - | {pexp_desc = Pexp_apply (callExpression, callArguments); pexp_attributes} - -> ( - let jsxAttribute, nonJSXAttributes = - List.partition - (fun (attribute, _) -> attribute.txt = "JSX") - pexp_attributes - in - match (jsxAttribute, nonJSXAttributes) with - (* no JSX attribute *) - | [], _ -> default_mapper.expr mapper expression - | _, nonJSXAttributes -> - transformJsxCall mapper callExpression callArguments nonJSXAttributes) + | { + pexp_desc = Pexp_apply (callExpression, callArguments); + pexp_attributes; + } -> ( + let jsxAttribute, nonJSXAttributes = + List.partition + (fun (attribute, _) -> attribute.txt = "JSX") + pexp_attributes + in + match (jsxAttribute, nonJSXAttributes) with + (* no JSX attribute *) + | [], _ -> default_mapper.expr mapper expression + | _, nonJSXAttributes -> + transformJsxCall mapper callExpression callArguments + nonJSXAttributes) (* is it a list with jsx attribute? Reason <>foo desugars to [@JSX][foo]*) | { pexp_desc = ( Pexp_construct - ({txt = Lident "::"; loc}, Some {pexp_desc = Pexp_tuple _}) - | Pexp_construct ({txt = Lident "[]"; loc}, None) ); + ({ txt = Lident "::"; loc }, Some { pexp_desc = Pexp_tuple _ }) + | Pexp_construct ({ txt = Lident "[]"; loc }, None) ); pexp_attributes; } as listItems -> ( - let jsxAttribute, nonJSXAttributes = - List.partition - (fun (attribute, _) -> attribute.txt = "JSX") - pexp_attributes - in - match (jsxAttribute, nonJSXAttributes) with - (* no JSX attribute *) - | [], _ -> default_mapper.expr mapper expression - | _, nonJSXAttributes -> - let loc = {loc with loc_ghost = true} in - let fragment = - Exp.ident ~loc {loc; txt = Ldot (Lident "ReasonReact", "fragment")} - in - let childrenExpr = transformChildrenIfList ~loc ~mapper listItems in - let args = - [ - (* "div" *) - (nolabel, fragment); - (* [|moreCreateElementCallsHere|] *) - (nolabel, childrenExpr); - ] + let jsxAttribute, nonJSXAttributes = + List.partition + (fun (attribute, _) -> attribute.txt = "JSX") + pexp_attributes in - Exp.apply - ~loc (* throw away the [@JSX] attribute and keep the others, if any *) - ~attrs:nonJSXAttributes - (* ReactDOMRe.createElement *) - (Exp.ident ~loc - {loc; txt = Ldot (Lident "ReactDOMRe", "createElement")}) - args) + match (jsxAttribute, nonJSXAttributes) with + (* no JSX attribute *) + | [], _ -> default_mapper.expr mapper expression + | _, nonJSXAttributes -> + let loc = { loc with loc_ghost = true } in + let fragment = + Exp.ident ~loc + { loc; txt = Ldot (Lident "ReasonReact", "fragment") } + in + let childrenExpr = transformChildrenIfList ~loc ~mapper listItems in + let args = + [ + (* "div" *) + (nolabel, fragment); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr); + ] + in + Exp.apply + ~loc + (* throw away the [@JSX] attribute and keep the others, if any *) + ~attrs:nonJSXAttributes + (* ReactDOMRe.createElement *) + (Exp.ident ~loc + { loc; txt = Ldot (Lident "ReactDOMRe", "createElement") }) + args) (* Delegate to the default mapper, a deep identity traversal *) | e -> default_mapper.expr mapper e in @@ -274546,9 +274779,7 @@ let jsxMapper ~config = let _ = nestedModules := module_binding.pmb_name.txt :: !nestedModules in let mapped = default_mapper.module_binding mapper module_binding in let () = - match !nestedModules with - | _ :: rest -> nestedModules := rest - | [] -> () + match !nestedModules with _ :: rest -> nestedModules := rest | [] -> () in mapped in @@ -274565,37 +274796,26 @@ open Parsetree open Longident let nolabel = Nolabel - let labelled str = Labelled str - -let isOptional str = - match str with - | Optional _ -> true - | _ -> false - -let isLabelled str = - match str with - | Labelled _ -> true - | _ -> false +let isOptional str = match str with Optional _ -> true | _ -> false +let isLabelled str = match str with Labelled _ -> true | _ -> false let isForwardRef = function - | {pexp_desc = Pexp_ident {txt = Ldot (Lident "React", "forwardRef")}} -> true + | { pexp_desc = Pexp_ident { txt = Ldot (Lident "React", "forwardRef") } } -> + true | _ -> false let getLabel str = - match str with - | Optional str | Labelled str -> str - | Nolabel -> "" + match str with Optional str | Labelled str -> str | Nolabel -> "" -let optionalAttr = ({txt = "ns.optional"; loc = Location.none}, PStr []) -let optionalAttrs = [optionalAttr] +let optionalAttr = ({ txt = "ns.optional"; loc = Location.none }, PStr []) +let optionalAttrs = [ optionalAttr ] let constantString ~loc str = Ast_helper.Exp.constant ~loc (Pconst_string (str, None)) (* {} empty record *) let emptyRecord ~loc = Exp.record ~loc [] None - let unitExpr ~loc = Exp.construct ~loc (Location.mkloc (Lident "()") loc) None let safeTypeFromValue valueStr = @@ -274605,7 +274825,7 @@ let safeTypeFromValue valueStr = let refType loc = Typ.constr ~loc - {loc; txt = Ldot (Ldot (Lident "ReactDOM", "Ref"), "currentDomRef")} + { loc; txt = Ldot (Ldot (Lident "ReactDOM", "Ref"), "currentDomRef") } [] type 'a children = ListLiteral of 'a | Exact of 'a @@ -274616,16 +274836,16 @@ let transformChildrenIfListUpper ~mapper theList = (* not in the sense of converting a list to an array; convert the AST reprensentation of a list to the AST reprensentation of an array *) match theList with - | {pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} -> ( - match accum with - | [singleElement] -> Exact singleElement - | accum -> ListLiteral (Exp.array (List.rev accum))) + | { pexp_desc = Pexp_construct ({ txt = Lident "[]" }, None) } -> ( + match accum with + | [ singleElement ] -> Exact singleElement + | accum -> ListLiteral (Exp.array (List.rev accum))) | { pexp_desc = Pexp_construct - ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple [v; acc]}); + ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple [ v; acc ] }); } -> - transformChildren_ acc (mapper.expr mapper v :: accum) + transformChildren_ acc (mapper.expr mapper v :: accum) | notAList -> Exact (mapper.expr mapper notAList) in transformChildren_ theList [] @@ -274635,14 +274855,14 @@ let transformChildrenIfList ~mapper theList = (* not in the sense of converting a list to an array; convert the AST reprensentation of a list to the AST reprensentation of an array *) match theList with - | {pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} -> - Exp.array (List.rev accum) + | { pexp_desc = Pexp_construct ({ txt = Lident "[]" }, None) } -> + Exp.array (List.rev accum) | { pexp_desc = Pexp_construct - ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple [v; acc]}); + ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple [ v; acc ] }); } -> - transformChildren_ acc (mapper.expr mapper v :: accum) + transformChildren_ acc (mapper.expr mapper v :: accum) | notAList -> mapper.expr mapper notAList in transformChildren_ theList [] @@ -274651,11 +274871,13 @@ let extractChildren ?(removeLastPositionUnit = false) ~loc propsAndChildren = let rec allButLast_ lst acc = match lst with | [] -> [] - | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] -> - acc - | (Nolabel, {pexp_loc}) :: _rest -> - React_jsx_common.raiseError ~loc:pexp_loc - "JSX: found non-labelled argument before the last position" + | [ + (Nolabel, { pexp_desc = Pexp_construct ({ txt = Lident "()" }, None) }); + ] -> + acc + | (Nolabel, { pexp_loc }) :: _rest -> + React_jsx_common.raiseError ~loc:pexp_loc + "JSX: found non-labelled argument before the last position" | arg :: rest -> allButLast_ rest (arg :: acc) in let allButLast lst = allButLast_ lst [] |> List.rev in @@ -274665,16 +274887,16 @@ let extractChildren ?(removeLastPositionUnit = false) ~loc propsAndChildren = propsAndChildren with | [], props -> - (* no children provided? Place a placeholder list *) - ( Exp.construct {loc = Location.none; txt = Lident "[]"} None, - if removeLastPositionUnit then allButLast props else props ) - | [(_, childrenExpr)], props -> - (childrenExpr, if removeLastPositionUnit then allButLast props else props) + (* no children provided? Place a placeholder list *) + ( Exp.construct { loc = Location.none; txt = Lident "[]" } None, + if removeLastPositionUnit then allButLast props else props ) + | [ (_, childrenExpr) ], props -> + (childrenExpr, if removeLastPositionUnit then allButLast props else props) | _ -> - React_jsx_common.raiseError ~loc - "JSX: somehow there's more than one `children` label" + React_jsx_common.raiseError ~loc + "JSX: somehow there's more than one `children` label" -let merlinFocus = ({loc = Location.none; txt = "merlin.focus"}, PStr []) +let merlinFocus = ({ loc = Location.none; txt = "merlin.focus" }, PStr []) (* Helper method to filter out any attribute that isn't [@react.component] *) let otherAttrsPure (loc, _) = loc.txt <> "react.component" @@ -274682,25 +274904,25 @@ let otherAttrsPure (loc, _) = loc.txt <> "react.component" (* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *) let rec getFnName binding = match binding with - | {ppat_desc = Ppat_var {txt}} -> txt - | {ppat_desc = Ppat_constraint (pat, _)} -> getFnName pat - | {ppat_loc} -> - React_jsx_common.raiseError ~loc:ppat_loc - "react.component calls cannot be destructured." + | { ppat_desc = Ppat_var { txt } } -> txt + | { ppat_desc = Ppat_constraint (pat, _) } -> getFnName pat + | { ppat_loc } -> + React_jsx_common.raiseError ~loc:ppat_loc + "react.component calls cannot be destructured." let makeNewBinding binding expression newName = match binding with - | {pvb_pat = {ppat_desc = Ppat_var ppat_var} as pvb_pat} -> - { - binding with - pvb_pat = - {pvb_pat with ppat_desc = Ppat_var {ppat_var with txt = newName}}; - pvb_expr = expression; - pvb_attributes = [merlinFocus]; - } - | {pvb_loc} -> - React_jsx_common.raiseError ~loc:pvb_loc - "react.component calls cannot be destructured." + | { pvb_pat = { ppat_desc = Ppat_var ppat_var } as pvb_pat } -> + { + binding with + pvb_pat = + { pvb_pat with ppat_desc = Ppat_var { ppat_var with txt = newName } }; + pvb_expr = expression; + pvb_attributes = [ merlinFocus ]; + } + | { pvb_loc } -> + React_jsx_common.raiseError ~loc:pvb_loc + "react.component calls cannot be destructured." (* Lookup the filename from the location information on the AST node and turn it into a valid module identifier *) let filenameFromLoc (pstr_loc : Location.t) = @@ -274725,7 +274947,7 @@ let makeModuleName fileName nestedModules fnName = | "", nestedModules, fnName -> List.rev (fnName :: nestedModules) | fileName, nestedModules, "make" -> fileName :: List.rev nestedModules | fileName, nestedModules, fnName -> - fileName :: List.rev (fnName :: nestedModules) + fileName :: List.rev (fnName :: nestedModules) in let fullModuleName = String.concat "$" fullModuleName in fullModuleName @@ -274742,21 +274964,23 @@ let recordFromProps ~loc ~removeKey callArguments = let rec removeLastPositionUnitAux props acc = match props with | [] -> acc - | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] -> - acc - | (Nolabel, {pexp_loc}) :: _rest -> - React_jsx_common.raiseError ~loc:pexp_loc - "JSX: found non-labelled argument before the last position" - | ((Labelled txt, {pexp_loc}) as prop) :: rest - | ((Optional txt, {pexp_loc}) as prop) :: rest -> - if txt = spreadPropsLabel then - match acc with - | [] -> removeLastPositionUnitAux rest (prop :: acc) - | _ -> - React_jsx_common.raiseError ~loc:pexp_loc - "JSX: use {...p} {x: v} not {x: v} {...p} \n\ - \ multiple spreads {...p} {...p} not allowed." - else removeLastPositionUnitAux rest (prop :: acc) + | [ + (Nolabel, { pexp_desc = Pexp_construct ({ txt = Lident "()" }, None) }); + ] -> + acc + | (Nolabel, { pexp_loc }) :: _rest -> + React_jsx_common.raiseError ~loc:pexp_loc + "JSX: found non-labelled argument before the last position" + | ((Labelled txt, { pexp_loc }) as prop) :: rest + | ((Optional txt, { pexp_loc }) as prop) :: rest -> + if txt = spreadPropsLabel then + match acc with + | [] -> removeLastPositionUnitAux rest (prop :: acc) + | _ -> + React_jsx_common.raiseError ~loc:pexp_loc + "JSX: use {...p} {x: v} not {x: v} {...p} \n\ + \ multiple spreads {...p} {...p} not allowed." + else removeLastPositionUnitAux rest (prop :: acc) in let props, propsToSpread = removeLastPositionUnitAux callArguments [] @@ -274769,34 +274993,34 @@ let recordFromProps ~loc ~removeKey callArguments = else props in - let processProp (arg_label, ({pexp_loc} as pexpr)) = + let processProp (arg_label, ({ pexp_loc } as pexpr)) = (* In case filed label is "key" only then change expression to option *) let id = getLabel arg_label in if isOptional arg_label then - ( {txt = Lident id; loc = pexp_loc}, - {pexpr with pexp_attributes = optionalAttrs} ) - else ({txt = Lident id; loc = pexp_loc}, pexpr) + ( { txt = Lident id; loc = pexp_loc }, + { pexpr with pexp_attributes = optionalAttrs } ) + else ({ txt = Lident id; loc = pexp_loc }, pexpr) in let fields = props |> List.map processProp in let spreadFields = propsToSpread |> List.map (fun (_, expression) -> expression) in match (fields, spreadFields) with - | [], [spreadProps] | [], spreadProps :: _ -> spreadProps + | [], [ spreadProps ] | [], spreadProps :: _ -> spreadProps | _, [] -> - { - pexp_desc = Pexp_record (fields, None); - pexp_loc = loc; - pexp_attributes = []; - } - | _, [spreadProps] + { + pexp_desc = Pexp_record (fields, None); + pexp_loc = loc; + pexp_attributes = []; + } + | _, [ spreadProps ] (* take the first spreadProps only *) | _, spreadProps :: _ -> - { - pexp_desc = Pexp_record (fields, Some spreadProps); - pexp_loc = loc; - pexp_attributes = []; - } + { + pexp_desc = Pexp_record (fields, Some spreadProps); + pexp_loc = loc; + pexp_attributes = []; + } (* make type params for make fn arguments *) (* let make = ({id, name, children}: props<'id, 'name, 'children>) *) @@ -274808,17 +275032,18 @@ let makePropsTypeParamsTvar namedTypeList = let stripOption coreType = match coreType with - | {ptyp_desc = Ptyp_constr ({txt = Lident "option"}, coreTypes)} -> - List.nth_opt coreTypes 0 [@doesNotRaise] + | { ptyp_desc = Ptyp_constr ({ txt = Lident "option" }, coreTypes) } -> + List.nth_opt coreTypes 0 [@doesNotRaise] | _ -> Some coreType let stripJsNullable coreType = match coreType with | { ptyp_desc = - Ptyp_constr ({txt = Ldot (Ldot (Lident "Js", "Nullable"), "t")}, coreTypes); + Ptyp_constr + ({ txt = Ldot (Ldot (Lident "Js", "Nullable"), "t") }, coreTypes); } -> - List.nth_opt coreTypes 0 [@doesNotRaise] + List.nth_opt coreTypes 0 [@doesNotRaise] | _ -> Some coreType (* Make type params of the props type *) @@ -274837,11 +275062,11 @@ let makePropsTypeParams ?(stripExplicitOption = false) For example, if JSX ppx is used for React Native, type would be different. *) match interiorType with - | {ptyp_desc = Ptyp_var "ref"} -> Some (refType Location.none) + | { ptyp_desc = Ptyp_var "ref" } -> Some (refType Location.none) | _ -> - (* Strip explicit Js.Nullable.t in case of forwardRef *) - if stripExplicitJsNullableOfRef then stripJsNullable interiorType - else Some interiorType + (* Strip explicit Js.Nullable.t in case of forwardRef *) + if stripExplicitJsNullableOfRef then stripJsNullable interiorType + else Some interiorType (* Strip the explicit option type in implementation *) (* let make = (~x: option=?) => ... *) else if isOptional && stripExplicitOption then stripOption interiorType @@ -274851,12 +275076,13 @@ let makeLabelDecls ~loc namedTypeList = namedTypeList |> List.map (fun (isOptional, label, _, interiorType) -> if label = "key" then - Type.field ~loc ~attrs:optionalAttrs {txt = label; loc} interiorType + Type.field ~loc ~attrs:optionalAttrs { txt = label; loc } + interiorType else if isOptional then - Type.field ~loc ~attrs:optionalAttrs {txt = label; loc} + Type.field ~loc ~attrs:optionalAttrs { txt = label; loc } (Typ.var @@ safeTypeFromValue @@ Labelled label) else - Type.field ~loc {txt = label; loc} + Type.field ~loc { txt = label; loc } (Typ.var @@ safeTypeFromValue @@ Labelled label)) let makeTypeDecls propsName loc namedTypeList = @@ -274867,13 +275093,13 @@ let makeTypeDecls propsName loc namedTypeList = |> List.map (fun coreType -> (coreType, Invariant)) in [ - Type.mk ~loc ~params {txt = propsName; loc} + Type.mk ~loc ~params { txt = propsName; loc } ~kind:(Ptype_record labelDeclList); ] let makeTypeDeclsWithCoreType propsName loc coreType typVars = [ - Type.mk ~loc {txt = propsName; loc} ~kind:Ptype_abstract + Type.mk ~loc { txt = propsName; loc } ~kind:Ptype_abstract ~params:(typVars |> List.map (fun v -> (v, Invariant))) ~manifest:coreType; ] @@ -274885,7 +275111,7 @@ let makePropsRecordType ~coreTypeOfAttr ~typVarsOfCoreType propsName loc (match coreTypeOfAttr with | None -> makeTypeDecls propsName loc namedTypeList | Some coreType -> - makeTypeDeclsWithCoreType propsName loc coreType typVarsOfCoreType) + makeTypeDeclsWithCoreType propsName loc coreType typVarsOfCoreType) (* type props<'x, 'y, ...> = { x: 'x, y?: 'y, ... } *) let makePropsRecordTypeSig ~coreTypeOfAttr ~typVarsOfCoreType propsName loc @@ -274894,7 +275120,7 @@ let makePropsRecordTypeSig ~coreTypeOfAttr ~typVarsOfCoreType propsName loc (match coreTypeOfAttr with | None -> makeTypeDecls propsName loc namedTypeList | Some coreType -> - makeTypeDeclsWithCoreType propsName loc coreType typVarsOfCoreType) + makeTypeDeclsWithCoreType propsName loc coreType typVarsOfCoreType) let transformUppercaseCall3 ~config modulePath mapper jsxExprLoc callExprLoc attrs callArguments = @@ -274913,26 +275139,30 @@ let transformUppercaseCall3 ~config modulePath mapper jsxExprLoc callExprLoc recursivelyTransformedArgsForMake @ match childrenExpr with - | Exact children -> [(labelled "children", children)] - | ListLiteral {pexp_desc = Pexp_array list} when list = [] -> [] + | Exact children -> [ (labelled "children", children) ] + | ListLiteral { pexp_desc = Pexp_array list } when list = [] -> [] | ListLiteral expression -> ( - (* this is a hack to support react components that introspect into their children *) - childrenArg := Some expression; - match config.React_jsx_common.mode with - | "automatic" -> - [ - ( labelled "children", - Exp.apply - (Exp.ident - {txt = Ldot (Lident "React", "array"); loc = Location.none}) - [(Nolabel, expression)] ); - ] - | _ -> - [ - ( labelled "children", - Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "null")} - ); - ]) + (* this is a hack to support react components that introspect into their children *) + childrenArg := Some expression; + match config.React_jsx_common.mode with + | "automatic" -> + [ + ( labelled "children", + Exp.apply + (Exp.ident + { + txt = Ldot (Lident "React", "array"); + loc = Location.none; + }) + [ (Nolabel, expression) ] ); + ] + | _ -> + [ + ( labelled "children", + Exp.ident + { loc = Location.none; txt = Ldot (Lident "React", "null") } + ); + ]) in let isCap str = String.capitalize_ascii str = str in @@ -274940,10 +275170,10 @@ let transformUppercaseCall3 ~config modulePath mapper jsxExprLoc callExprLoc match modulePath with | Lident _ -> Ldot (modulePath, suffix) | Ldot (_modulePath, value) as fullPath when isCap value -> - Ldot (fullPath, suffix) + Ldot (fullPath, suffix) | modulePath -> modulePath in - let isEmptyRecord {pexp_desc} = + let isEmptyRecord { pexp_desc } = match pexp_desc with | Pexp_record (labelDecls, _) when List.length labelDecls = 0 -> true | _ -> false @@ -274959,59 +275189,69 @@ let transformUppercaseCall3 ~config modulePath mapper jsxExprLoc callExprLoc args |> List.filter (fun (arg_label, _) -> "key" = getLabel arg_label) in let makeID = - Exp.ident ~loc:callExprLoc {txt = ident ~suffix:"make"; loc = callExprLoc} + Exp.ident ~loc:callExprLoc { txt = ident ~suffix:"make"; loc = callExprLoc } in match config.mode with (* The new jsx transform *) | "automatic" -> - let jsxExpr, keyAndUnit = + let jsxExpr, keyAndUnit = + match (!childrenArg, keyProp) with + | None, key :: _ -> + ( Exp.ident + { loc = Location.none; txt = Ldot (Lident "React", "jsxKeyed") }, + [ key; (nolabel, unitExpr ~loc:Location.none) ] ) + | None, [] -> + ( Exp.ident + { loc = Location.none; txt = Ldot (Lident "React", "jsx") }, + [] ) + | Some _, key :: _ -> + ( Exp.ident + { + loc = Location.none; + txt = Ldot (Lident "React", "jsxsKeyed"); + }, + [ key; (nolabel, unitExpr ~loc:Location.none) ] ) + | Some _, [] -> + ( Exp.ident + { loc = Location.none; txt = Ldot (Lident "React", "jsxs") }, + [] ) + in + Exp.apply ~attrs jsxExpr + ([ (nolabel, makeID); (nolabel, props) ] @ keyAndUnit) + | _ -> ( match (!childrenArg, keyProp) with | None, key :: _ -> - ( Exp.ident - {loc = Location.none; txt = Ldot (Lident "React", "jsxKeyed")}, - [key; (nolabel, unitExpr ~loc:Location.none)] ) + Exp.apply ~attrs + (Exp.ident + { + loc = Location.none; + txt = Ldot (Lident "React", "createElementWithKey"); + }) + [ key; (nolabel, makeID); (nolabel, props) ] | None, [] -> - (Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "jsx")}, []) - | Some _, key :: _ -> - ( Exp.ident - {loc = Location.none; txt = Ldot (Lident "React", "jsxsKeyed")}, - [key; (nolabel, unitExpr ~loc:Location.none)] ) - | Some _, [] -> - ( Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "jsxs")}, - [] ) - in - Exp.apply ~attrs jsxExpr ([(nolabel, makeID); (nolabel, props)] @ keyAndUnit) - | _ -> ( - match (!childrenArg, keyProp) with - | None, key :: _ -> - Exp.apply ~attrs - (Exp.ident - { - loc = Location.none; - txt = Ldot (Lident "React", "createElementWithKey"); - }) - [key; (nolabel, makeID); (nolabel, props)] - | None, [] -> - Exp.apply ~attrs - (Exp.ident - {loc = Location.none; txt = Ldot (Lident "React", "createElement")}) - [(nolabel, makeID); (nolabel, props)] - | Some children, key :: _ -> - Exp.apply ~attrs - (Exp.ident - { - loc = Location.none; - txt = Ldot (Lident "React", "createElementVariadicWithKey"); - }) - [key; (nolabel, makeID); (nolabel, props); (nolabel, children)] - | Some children, [] -> - Exp.apply ~attrs - (Exp.ident - { - loc = Location.none; - txt = Ldot (Lident "React", "createElementVariadic"); - }) - [(nolabel, makeID); (nolabel, props); (nolabel, children)]) + Exp.apply ~attrs + (Exp.ident + { + loc = Location.none; + txt = Ldot (Lident "React", "createElement"); + }) + [ (nolabel, makeID); (nolabel, props) ] + | Some children, key :: _ -> + Exp.apply ~attrs + (Exp.ident + { + loc = Location.none; + txt = Ldot (Lident "React", "createElementVariadicWithKey"); + }) + [ key; (nolabel, makeID); (nolabel, props); (nolabel, children) ] + | Some children, [] -> + Exp.apply ~attrs + (Exp.ident + { + loc = Location.none; + txt = Ldot (Lident "React", "createElementVariadic"); + }) + [ (nolabel, makeID); (nolabel, props); (nolabel, children) ]) let transformLowercaseCall3 ~config mapper jsxExprLoc callExprLoc attrs callArguments id = @@ -275019,125 +275259,138 @@ let transformLowercaseCall3 ~config mapper jsxExprLoc callExprLoc attrs match config.React_jsx_common.mode with (* the new jsx transform *) | "automatic" -> - let children, nonChildrenProps = - extractChildren ~removeLastPositionUnit:true ~loc:jsxExprLoc callArguments - in - let argsForMake = nonChildrenProps in - let childrenExpr = transformChildrenIfListUpper ~mapper children in - let recursivelyTransformedArgsForMake = - argsForMake - |> List.map (fun (label, expression) -> - (label, mapper.expr mapper expression)) - in - let childrenArg = ref None in - let args = - recursivelyTransformedArgsForMake - @ - match childrenExpr with - | Exact children -> - [ - ( labelled "children", - Exp.apply ~attrs:optionalAttrs - (Exp.ident - { - txt = Ldot (Lident "ReactDOM", "someElement"); - loc = Location.none; - }) - [(Nolabel, children)] ); - ] - | ListLiteral {pexp_desc = Pexp_array list} when list = [] -> [] - | ListLiteral expression -> - (* this is a hack to support react components that introspect into their children *) - childrenArg := Some expression; - [ - ( labelled "children", - Exp.apply - (Exp.ident - {txt = Ldot (Lident "React", "array"); loc = Location.none}) - [(Nolabel, expression)] ); - ] - in - let isEmptyRecord {pexp_desc} = - match pexp_desc with - | Pexp_record (labelDecls, _) when List.length labelDecls = 0 -> true - | _ -> false - in - let record = recordFromProps ~loc:jsxExprLoc ~removeKey:true args in - let props = - if isEmptyRecord record then emptyRecord ~loc:jsxExprLoc else record - in - let keyProp = - args |> List.filter (fun (arg_label, _) -> "key" = getLabel arg_label) - in - let jsxExpr, keyAndUnit = - match (!childrenArg, keyProp) with - | None, key :: _ -> - ( Exp.ident - {loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsxKeyed")}, - [key; (nolabel, unitExpr ~loc:Location.none)] ) - | None, [] -> - ( Exp.ident {loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsx")}, - [] ) - | Some _, key :: _ -> - ( Exp.ident - {loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsxsKeyed")}, - [key; (nolabel, unitExpr ~loc:Location.none)] ) - | Some _, [] -> - ( Exp.ident {loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsxs")}, - [] ) - in - Exp.apply ~attrs jsxExpr - ([(nolabel, componentNameExpr); (nolabel, props)] @ keyAndUnit) + let children, nonChildrenProps = + extractChildren ~removeLastPositionUnit:true ~loc:jsxExprLoc + callArguments + in + let argsForMake = nonChildrenProps in + let childrenExpr = transformChildrenIfListUpper ~mapper children in + let recursivelyTransformedArgsForMake = + argsForMake + |> List.map (fun (label, expression) -> + (label, mapper.expr mapper expression)) + in + let childrenArg = ref None in + let args = + recursivelyTransformedArgsForMake + @ + match childrenExpr with + | Exact children -> + [ + ( labelled "children", + Exp.apply ~attrs:optionalAttrs + (Exp.ident + { + txt = Ldot (Lident "ReactDOM", "someElement"); + loc = Location.none; + }) + [ (Nolabel, children) ] ); + ] + | ListLiteral { pexp_desc = Pexp_array list } when list = [] -> [] + | ListLiteral expression -> + (* this is a hack to support react components that introspect into their children *) + childrenArg := Some expression; + [ + ( labelled "children", + Exp.apply + (Exp.ident + { + txt = Ldot (Lident "React", "array"); + loc = Location.none; + }) + [ (Nolabel, expression) ] ); + ] + in + let isEmptyRecord { pexp_desc } = + match pexp_desc with + | Pexp_record (labelDecls, _) when List.length labelDecls = 0 -> true + | _ -> false + in + let record = recordFromProps ~loc:jsxExprLoc ~removeKey:true args in + let props = + if isEmptyRecord record then emptyRecord ~loc:jsxExprLoc else record + in + let keyProp = + args |> List.filter (fun (arg_label, _) -> "key" = getLabel arg_label) + in + let jsxExpr, keyAndUnit = + match (!childrenArg, keyProp) with + | None, key :: _ -> + ( Exp.ident + { + loc = Location.none; + txt = Ldot (Lident "ReactDOM", "jsxKeyed"); + }, + [ key; (nolabel, unitExpr ~loc:Location.none) ] ) + | None, [] -> + ( Exp.ident + { loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsx") }, + [] ) + | Some _, key :: _ -> + ( Exp.ident + { + loc = Location.none; + txt = Ldot (Lident "ReactDOM", "jsxsKeyed"); + }, + [ key; (nolabel, unitExpr ~loc:Location.none) ] ) + | Some _, [] -> + ( Exp.ident + { loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsxs") }, + [] ) + in + Exp.apply ~attrs jsxExpr + ([ (nolabel, componentNameExpr); (nolabel, props) ] @ keyAndUnit) | _ -> - let children, nonChildrenProps = - extractChildren ~loc:jsxExprLoc callArguments - in - let childrenExpr = transformChildrenIfList ~mapper children in - let createElementCall = - match children with - (* [@JSX] div(~children=[a]), coming from
a
*) - | { - pexp_desc = - ( Pexp_construct ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple _}) - | Pexp_construct ({txt = Lident "[]"}, None) ); - } -> - "createDOMElementVariadic" - (* [@JSX] div(~children= value), coming from
...(value)
*) - | {pexp_loc} -> - React_jsx_common.raiseError ~loc:pexp_loc - "A spread as a DOM element's children don't make sense written \ - together. You can simply remove the spread." - in - let args = - match nonChildrenProps with - | [_justTheUnitArgumentAtEnd] -> - [ - (* "div" *) - (nolabel, componentNameExpr); - (* [|moreCreateElementCallsHere|] *) - (nolabel, childrenExpr); - ] - | nonEmptyProps -> - let propsRecord = - recordFromProps ~loc:Location.none ~removeKey:false nonEmptyProps - in - [ - (* "div" *) - (nolabel, componentNameExpr); - (* ReactDOM.domProps(~className=blabla, ~foo=bar, ()) *) - (labelled "props", propsRecord); - (* [|moreCreateElementCallsHere|] *) - (nolabel, childrenExpr); - ] - in - Exp.apply ~loc:jsxExprLoc ~attrs - (* ReactDOM.createElement *) - (Exp.ident - { - loc = Location.none; - txt = Ldot (Lident "ReactDOM", createElementCall); - }) - args + let children, nonChildrenProps = + extractChildren ~loc:jsxExprLoc callArguments + in + let childrenExpr = transformChildrenIfList ~mapper children in + let createElementCall = + match children with + (* [@JSX] div(~children=[a]), coming from
a
*) + | { + pexp_desc = + ( Pexp_construct + ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple _ }) + | Pexp_construct ({ txt = Lident "[]" }, None) ); + } -> + "createDOMElementVariadic" + (* [@JSX] div(~children= value), coming from
...(value)
*) + | { pexp_loc } -> + React_jsx_common.raiseError ~loc:pexp_loc + "A spread as a DOM element's children don't make sense written \ + together. You can simply remove the spread." + in + let args = + match nonChildrenProps with + | [ _justTheUnitArgumentAtEnd ] -> + [ + (* "div" *) + (nolabel, componentNameExpr); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr); + ] + | nonEmptyProps -> + let propsRecord = + recordFromProps ~loc:Location.none ~removeKey:false nonEmptyProps + in + [ + (* "div" *) + (nolabel, componentNameExpr); + (* ReactDOM.domProps(~className=blabla, ~foo=bar, ()) *) + (labelled "props", propsRecord); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr); + ] + in + Exp.apply ~loc:jsxExprLoc ~attrs + (* ReactDOM.createElement *) + (Exp.ident + { + loc = Location.none; + txt = Ldot (Lident "ReactDOM", createElementCall); + }) + args let rec recursivelyTransformNamedArgsForMake mapper expr args newtypes coreType = @@ -275145,106 +275398,107 @@ let rec recursivelyTransformNamedArgsForMake mapper expr args newtypes coreType match expr.pexp_desc with (* TODO: make this show up with a loc. *) | Pexp_fun (Labelled "key", _, _, _) | Pexp_fun (Optional "key", _, _, _) -> - React_jsx_common.raiseError ~loc:expr.pexp_loc - "Key cannot be accessed inside of a component. Don't worry - you can \ - always key a component from its parent!" + React_jsx_common.raiseError ~loc:expr.pexp_loc + "Key cannot be accessed inside of a component. Don't worry - you can \ + always key a component from its parent!" | Pexp_fun (Labelled "ref", _, _, _) | Pexp_fun (Optional "ref", _, _, _) -> - React_jsx_common.raiseError ~loc:expr.pexp_loc - "Ref cannot be passed as a normal prop. Please use `forwardRef` API \ - instead." + React_jsx_common.raiseError ~loc:expr.pexp_loc + "Ref cannot be passed as a normal prop. Please use `forwardRef` API \ + instead." | Pexp_fun (arg, default, pattern, expression) when isOptional arg || isLabelled arg -> - let () = - match (isOptional arg, pattern, default) with - | true, {ppat_desc = Ppat_constraint (_, {ptyp_desc})}, None -> ( - match ptyp_desc with - | Ptyp_constr ({txt = Lident "option"}, [_]) -> () - | _ -> - let currentType = + let () = + match (isOptional arg, pattern, default) with + | true, { ppat_desc = Ppat_constraint (_, { ptyp_desc }) }, None -> ( match ptyp_desc with - | Ptyp_constr ({txt}, []) -> - String.concat "." (Longident.flatten txt) - | Ptyp_constr ({txt}, _innerTypeArgs) -> - String.concat "." (Longident.flatten txt) ^ "(...)" - | _ -> "..." - in - Location.prerr_warning pattern.ppat_loc - (Preprocessor - (Printf.sprintf - "React: optional argument annotations must have explicit \ - `option`. Did you mean `option(%s)=?`?" - currentType))) - | _ -> () - in - let alias = - match pattern with - | {ppat_desc = Ppat_alias (_, {txt}) | Ppat_var {txt}} -> txt - | {ppat_desc = Ppat_any} -> "_" - | _ -> getLabel arg - in - let type_ = - match pattern with - | {ppat_desc = Ppat_constraint (_, type_)} -> Some type_ - | _ -> None - in + | Ptyp_constr ({ txt = Lident "option" }, [ _ ]) -> () + | _ -> + let currentType = + match ptyp_desc with + | Ptyp_constr ({ txt }, []) -> + String.concat "." (Longident.flatten txt) + | Ptyp_constr ({ txt }, _innerTypeArgs) -> + String.concat "." (Longident.flatten txt) ^ "(...)" + | _ -> "..." + in + Location.prerr_warning pattern.ppat_loc + (Preprocessor + (Printf.sprintf + "React: optional argument annotations must have \ + explicit `option`. Did you mean `option(%s)=?`?" + currentType))) + | _ -> () + in + let alias = + match pattern with + | { ppat_desc = Ppat_alias (_, { txt }) | Ppat_var { txt } } -> txt + | { ppat_desc = Ppat_any } -> "_" + | _ -> getLabel arg + in + let type_ = + match pattern with + | { ppat_desc = Ppat_constraint (_, type_) } -> Some type_ + | _ -> None + in - recursivelyTransformNamedArgsForMake mapper expression - ((arg, default, pattern, alias, pattern.ppat_loc, type_) :: args) - newtypes coreType + recursivelyTransformNamedArgsForMake mapper expression + ((arg, default, pattern, alias, pattern.ppat_loc, type_) :: args) + newtypes coreType | Pexp_fun ( Nolabel, _, - {ppat_desc = Ppat_construct ({txt = Lident "()"}, _) | Ppat_any}, + { ppat_desc = Ppat_construct ({ txt = Lident "()" }, _) | Ppat_any }, _expression ) -> - (args, newtypes, coreType) + (args, newtypes, coreType) | Pexp_fun ( Nolabel, _, ({ ppat_desc = - Ppat_var {txt} | Ppat_constraint ({ppat_desc = Ppat_var {txt}}, _); + ( Ppat_var { txt } + | Ppat_constraint ({ ppat_desc = Ppat_var { txt } }, _) ); } as pattern), _expression ) -> - if txt = "ref" then - let type_ = - match pattern with - | {ppat_desc = Ppat_constraint (_, type_)} -> Some type_ - | _ -> None - in - (* The ref arguement of forwardRef should be optional *) - ( (Optional "ref", None, pattern, txt, pattern.ppat_loc, type_) :: args, - newtypes, - coreType ) - else (args, newtypes, coreType) + if txt = "ref" then + let type_ = + match pattern with + | { ppat_desc = Ppat_constraint (_, type_) } -> Some type_ + | _ -> None + in + (* The ref arguement of forwardRef should be optional *) + ( (Optional "ref", None, pattern, txt, pattern.ppat_loc, type_) :: args, + newtypes, + coreType ) + else (args, newtypes, coreType) | Pexp_fun (Nolabel, _, pattern, _expression) -> - Location.raise_errorf ~loc:pattern.ppat_loc - "React: react.component refs only support plain arguments and type \ - annotations." + Location.raise_errorf ~loc:pattern.ppat_loc + "React: react.component refs only support plain arguments and type \ + annotations." | Pexp_newtype (label, expression) -> - recursivelyTransformNamedArgsForMake mapper expression args - (label :: newtypes) coreType + recursivelyTransformNamedArgsForMake mapper expression args + (label :: newtypes) coreType | Pexp_constraint (expression, coreType) -> - recursivelyTransformNamedArgsForMake mapper expression args newtypes - (Some coreType) + recursivelyTransformNamedArgsForMake mapper expression args newtypes + (Some coreType) | _ -> (args, newtypes, coreType) let newtypeToVar newtype type_ = let var_desc = Ptyp_var ("type-" ^ newtype) in let typ (mapper : Ast_mapper.mapper) typ = match typ.ptyp_desc with - | Ptyp_constr ({txt = Lident name}, _) when name = newtype -> - {typ with ptyp_desc = var_desc} + | Ptyp_constr ({ txt = Lident name }, _) when name = newtype -> + { typ with ptyp_desc = var_desc } | _ -> Ast_mapper.default_mapper.typ mapper typ in - let mapper = {Ast_mapper.default_mapper with typ} in + let mapper = { Ast_mapper.default_mapper with typ } in mapper.typ mapper type_ let argToType ~newtypes ~(typeConstraints : core_type option) types (name, default, _noLabelName, _alias, loc, type_) = let rec getType name coreType = match coreType with - | {ptyp_desc = Ptyp_arrow (arg, c1, c2)} -> - if name = arg then Some c1 else getType name c2 + | { ptyp_desc = Ptyp_arrow (arg, c1, c2) } -> + if name = arg then Some c1 else getType name c2 | _ -> None in let typeConst = Option.bind typeConstraints (getType name) in @@ -275258,17 +275512,17 @@ let argToType ~newtypes ~(typeConstraints : core_type option) types in match (type_, name, default) with | Some type_, name, _ when isOptional name -> - (true, getLabel name, [], {type_ with ptyp_attributes = optionalAttrs}) - :: types + (true, getLabel name, [], { type_ with ptyp_attributes = optionalAttrs }) + :: types | Some type_, name, _ -> (false, getLabel name, [], type_) :: types | None, name, _ when isOptional name -> - ( true, - getLabel name, - [], - Typ.var ~loc ~attrs:optionalAttrs (safeTypeFromValue name) ) - :: types + ( true, + getLabel name, + [], + Typ.var ~loc ~attrs:optionalAttrs (safeTypeFromValue name) ) + :: types | None, name, _ when isLabelled name -> - (false, getLabel name, [], Typ.var ~loc (safeTypeFromValue name)) :: types + (false, getLabel name, [], Typ.var ~loc (safeTypeFromValue name)) :: types | _ -> types let argWithDefaultValue (name, default, _, _, _, _) = @@ -275283,14 +275537,14 @@ let argToConcreteType types (name, _loc, type_) = | _ -> types let check_string_int_attribute_iter = - let attribute _ ({txt; loc}, _) = + let attribute _ ({ txt; loc }, _) = if txt = "string" || txt = "int" then React_jsx_common.raiseError ~loc "@string and @int attributes not supported. See \ https://github.com/rescript-lang/rescript-compiler/issues/5724" in - {Ast_iterator.default_iterator with attribute} + { Ast_iterator.default_iterator with attribute } let transformStructureItem ~config mapper item = match item with @@ -275298,590 +275552,625 @@ let transformStructureItem ~config mapper item = | { pstr_loc; pstr_desc = - Pstr_primitive ({pval_attributes; pval_type} as value_description); + Pstr_primitive ({ pval_attributes; pval_type } as value_description); } as pstr -> ( - match List.filter React_jsx_common.hasAttr pval_attributes with - | [] -> [item] - | [_] -> - (* If there is another @react.component, throw error *) - if config.React_jsx_common.hasReactComponent then - React_jsx_common.raiseErrorMultipleReactComponent ~loc:pstr_loc - else ( - config.hasReactComponent <- true; - check_string_int_attribute_iter.structure_item - check_string_int_attribute_iter item; - let coreTypeOfAttr = React_jsx_common.coreTypeOfAttrs pval_attributes in - let typVarsOfCoreType = - coreTypeOfAttr - |> Option.map React_jsx_common.typVarsOfCoreType - |> Option.value ~default:[] - in - let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = - match ptyp_desc with - | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) - when isLabelled name || isOptional name -> - getPropTypes ((name, ptyp_loc, type_) :: types) rest - | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest - | Ptyp_arrow (name, type_, returnValue) - when isLabelled name || isOptional name -> - (returnValue, (name, returnValue.ptyp_loc, type_) :: types) - | _ -> (fullType, types) - in - let innerType, propTypes = getPropTypes [] pval_type in - let namedTypeList = List.fold_left argToConcreteType [] propTypes in - let retPropsType = - Typ.constr ~loc:pstr_loc - (Location.mkloc (Lident "props") pstr_loc) - (match coreTypeOfAttr with - | None -> makePropsTypeParams namedTypeList - | Some _ -> typVarsOfCoreType) - in - (* type props<'x, 'y> = { x: 'x, y?: 'y, ... } *) - let propsRecordType = - makePropsRecordType ~coreTypeOfAttr ~typVarsOfCoreType "props" - pstr_loc namedTypeList - in - (* can't be an arrow because it will defensively uncurry *) - let newExternalType = - Ptyp_constr - ( {loc = pstr_loc; txt = Ldot (Lident "React", "componentLike")}, - [retPropsType; innerType] ) - in - let newStructure = - { - pstr with - pstr_desc = - Pstr_primitive - { - value_description with - pval_type = {pval_type with ptyp_desc = newExternalType}; - pval_attributes = List.filter otherAttrsPure pval_attributes; - }; - } - in - [propsRecordType; newStructure]) - | _ -> - React_jsx_common.raiseError ~loc:pstr_loc - "Only one react.component call can exist on a component at one time") + match List.filter React_jsx_common.hasAttr pval_attributes with + | [] -> [ item ] + | [ _ ] -> + (* If there is another @react.component, throw error *) + if config.React_jsx_common.hasReactComponent then + React_jsx_common.raiseErrorMultipleReactComponent ~loc:pstr_loc + else ( + config.hasReactComponent <- true; + check_string_int_attribute_iter.structure_item + check_string_int_attribute_iter item; + let coreTypeOfAttr = + React_jsx_common.coreTypeOfAttrs pval_attributes + in + let typVarsOfCoreType = + coreTypeOfAttr + |> Option.map React_jsx_common.typVarsOfCoreType + |> Option.value ~default:[] + in + let rec getPropTypes types ({ ptyp_loc; ptyp_desc } as fullType) = + match ptyp_desc with + | Ptyp_arrow (name, type_, ({ ptyp_desc = Ptyp_arrow _ } as rest)) + when isLabelled name || isOptional name -> + getPropTypes ((name, ptyp_loc, type_) :: types) rest + | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest + | Ptyp_arrow (name, type_, returnValue) + when isLabelled name || isOptional name -> + (returnValue, (name, returnValue.ptyp_loc, type_) :: types) + | _ -> (fullType, types) + in + let innerType, propTypes = getPropTypes [] pval_type in + let namedTypeList = List.fold_left argToConcreteType [] propTypes in + let retPropsType = + Typ.constr ~loc:pstr_loc + (Location.mkloc (Lident "props") pstr_loc) + (match coreTypeOfAttr with + | None -> makePropsTypeParams namedTypeList + | Some _ -> typVarsOfCoreType) + in + (* type props<'x, 'y> = { x: 'x, y?: 'y, ... } *) + let propsRecordType = + makePropsRecordType ~coreTypeOfAttr ~typVarsOfCoreType "props" + pstr_loc namedTypeList + in + (* can't be an arrow because it will defensively uncurry *) + let newExternalType = + Ptyp_constr + ( { + loc = pstr_loc; + txt = Ldot (Lident "React", "componentLike"); + }, + [ retPropsType; innerType ] ) + in + let newStructure = + { + pstr with + pstr_desc = + Pstr_primitive + { + value_description with + pval_type = { pval_type with ptyp_desc = newExternalType }; + pval_attributes = + List.filter otherAttrsPure pval_attributes; + }; + } + in + [ propsRecordType; newStructure ]) + | _ -> + React_jsx_common.raiseError ~loc:pstr_loc + "Only one react.component call can exist on a component at one time" + ) (* let component = ... *) - | {pstr_loc; pstr_desc = Pstr_value (recFlag, valueBindings)} -> ( - let fileName = filenameFromLoc pstr_loc in - let emptyLoc = Location.in_file fileName in - let mapBinding binding = - if React_jsx_common.hasAttrOnBinding binding then - if config.hasReactComponent then - React_jsx_common.raiseErrorMultipleReactComponent ~loc:pstr_loc - else ( - config.hasReactComponent <- true; - let coreTypeOfAttr = - React_jsx_common.coreTypeOfAttrs binding.pvb_attributes - in - let typVarsOfCoreType = - coreTypeOfAttr - |> Option.map React_jsx_common.typVarsOfCoreType - |> Option.value ~default:[] - in - let bindingLoc = binding.pvb_loc in - let bindingPatLoc = binding.pvb_pat.ppat_loc in - let binding = - { - binding with - pvb_pat = {binding.pvb_pat with ppat_loc = emptyLoc}; - pvb_loc = emptyLoc; - } - in - let fnName = getFnName binding.pvb_pat in - let internalFnName = fnName ^ "$Internal" in - let fullModuleName = - makeModuleName fileName config.nestedModules fnName - in - let modifiedBindingOld binding = - let expression = binding.pvb_expr in - (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) - let rec spelunkForFunExpression expression = - match expression with - (* let make = (~prop) => ... *) - | {pexp_desc = Pexp_fun _} | {pexp_desc = Pexp_newtype _} -> - expression - (* let make = {let foo = bar in (~prop) => ...} *) - | {pexp_desc = Pexp_let (_recursive, _vbs, returnExpression)} -> - (* here's where we spelunk! *) - spelunkForFunExpression returnExpression - (* let make = React.forwardRef((~prop) => ...) *) - | { - pexp_desc = - Pexp_apply - (_wrapperExpression, [(Nolabel, innerFunctionExpression)]); - } -> - spelunkForFunExpression innerFunctionExpression - | { - pexp_desc = - Pexp_sequence (_wrapperExpression, innerFunctionExpression); - } -> - spelunkForFunExpression innerFunctionExpression - | {pexp_desc = Pexp_constraint (innerFunctionExpression, _typ)} -> - spelunkForFunExpression innerFunctionExpression - | {pexp_loc} -> - React_jsx_common.raiseError ~loc:pexp_loc - "react.component calls can only be on function definitions \ - or component wrappers (forwardRef, memo)." + | { pstr_loc; pstr_desc = Pstr_value (recFlag, valueBindings) } -> ( + let fileName = filenameFromLoc pstr_loc in + let emptyLoc = Location.in_file fileName in + let mapBinding binding = + if React_jsx_common.hasAttrOnBinding binding then + if config.hasReactComponent then + React_jsx_common.raiseErrorMultipleReactComponent ~loc:pstr_loc + else ( + config.hasReactComponent <- true; + let coreTypeOfAttr = + React_jsx_common.coreTypeOfAttrs binding.pvb_attributes in - spelunkForFunExpression expression - in - let modifiedBinding binding = - let hasApplication = ref false in - let wrapExpressionWithBinding expressionFn expression = - Vb.mk ~loc:bindingLoc - ~attrs:(List.filter otherAttrsPure binding.pvb_attributes) - (Pat.var ~loc:bindingPatLoc {loc = bindingPatLoc; txt = fnName}) - (expressionFn expression) + let typVarsOfCoreType = + coreTypeOfAttr + |> Option.map React_jsx_common.typVarsOfCoreType + |> Option.value ~default:[] in - let expression = binding.pvb_expr in - (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) - let rec spelunkForFunExpression expression = - match expression with - (* let make = (~prop) => ... with no final unit *) - | { - pexp_desc = - Pexp_fun - ( ((Labelled _ | Optional _) as label), - default, - pattern, - ({pexp_desc = Pexp_fun _} as internalExpression) ); - } -> - let wrap, hasForwardRef, exp = - spelunkForFunExpression internalExpression - in - ( wrap, - hasForwardRef, - { - expression with - pexp_desc = Pexp_fun (label, default, pattern, exp); - } ) - (* let make = (()) => ... *) - (* let make = (_) => ... *) - | { - pexp_desc = - Pexp_fun - ( Nolabel, - _default, - { - ppat_desc = - Ppat_construct ({txt = Lident "()"}, _) | Ppat_any; - }, - _internalExpression ); - } -> - ((fun a -> a), false, expression) - (* let make = (~prop) => ... *) - | { - pexp_desc = - Pexp_fun - ( (Labelled _ | Optional _), - _default, - _pattern, - _internalExpression ); - } -> - ((fun a -> a), false, expression) - (* let make = (prop) => ... *) - | { - pexp_desc = - Pexp_fun (_nolabel, _default, pattern, _internalExpression); - } -> - if !hasApplication then ((fun a -> a), false, expression) - else - Location.raise_errorf ~loc:pattern.ppat_loc - "React: props need to be labelled arguments.\n\ - \ If you are working with refs be sure to wrap with \ - React.forwardRef.\n\ - \ If your component doesn't have any props use () or _ \ - instead of a name." - (* let make = {let foo = bar in (~prop) => ...} *) - | {pexp_desc = Pexp_let (recursive, vbs, internalExpression)} -> - (* here's where we spelunk! *) - let wrap, hasForwardRef, exp = - spelunkForFunExpression internalExpression - in - ( wrap, - hasForwardRef, - {expression with pexp_desc = Pexp_let (recursive, vbs, exp)} - ) - (* let make = React.forwardRef((~prop) => ...) *) - | { - pexp_desc = - Pexp_apply (wrapperExpression, [(Nolabel, internalExpression)]); - } -> - let () = hasApplication := true in - let _, _, exp = spelunkForFunExpression internalExpression in - let hasForwardRef = isForwardRef wrapperExpression in - ( (fun exp -> Exp.apply wrapperExpression [(nolabel, exp)]), - hasForwardRef, - exp ) - | { - pexp_desc = Pexp_sequence (wrapperExpression, internalExpression); - } -> - let wrap, hasForwardRef, exp = - spelunkForFunExpression internalExpression - in - ( wrap, - hasForwardRef, - { - expression with - pexp_desc = Pexp_sequence (wrapperExpression, exp); - } ) - | e -> ((fun a -> a), false, e) + let bindingLoc = binding.pvb_loc in + let bindingPatLoc = binding.pvb_pat.ppat_loc in + let binding = + { + binding with + pvb_pat = { binding.pvb_pat with ppat_loc = emptyLoc }; + pvb_loc = emptyLoc; + } in - let wrapExpression, hasForwardRef, expression = + let fnName = getFnName binding.pvb_pat in + let internalFnName = fnName ^ "$Internal" in + let fullModuleName = + makeModuleName fileName config.nestedModules fnName + in + let modifiedBindingOld binding = + let expression = binding.pvb_expr in + (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) + let rec spelunkForFunExpression expression = + match expression with + (* let make = (~prop) => ... *) + | { pexp_desc = Pexp_fun _ } | { pexp_desc = Pexp_newtype _ } -> + expression + (* let make = {let foo = bar in (~prop) => ...} *) + | { pexp_desc = Pexp_let (_recursive, _vbs, returnExpression) } + -> + (* here's where we spelunk! *) + spelunkForFunExpression returnExpression + (* let make = React.forwardRef((~prop) => ...) *) + | { + pexp_desc = + Pexp_apply + (_wrapperExpression, [ (Nolabel, innerFunctionExpression) ]); + } -> + spelunkForFunExpression innerFunctionExpression + | { + pexp_desc = + Pexp_sequence (_wrapperExpression, innerFunctionExpression); + } -> + spelunkForFunExpression innerFunctionExpression + | { + pexp_desc = Pexp_constraint (innerFunctionExpression, _typ); + } -> + spelunkForFunExpression innerFunctionExpression + | { pexp_loc } -> + React_jsx_common.raiseError ~loc:pexp_loc + "react.component calls can only be on function \ + definitions or component wrappers (forwardRef, memo)." + in spelunkForFunExpression expression in - (wrapExpressionWithBinding wrapExpression, hasForwardRef, expression) - in - let bindingWrapper, hasForwardRef, expression = - modifiedBinding binding - in - (* do stuff here! *) - let namedArgList, newtypes, typeConstraints = - recursivelyTransformNamedArgsForMake mapper - (modifiedBindingOld binding) - [] [] None - in - let namedTypeList = - List.fold_left - (argToType ~newtypes ~typeConstraints) - [] namedArgList - in - let namedArgWithDefaultValueList = - List.filter_map argWithDefaultValue namedArgList - in - let vbMatch (label, default) = - Vb.mk - (Pat.var (Location.mknoloc label)) - (Exp.match_ - (Exp.ident {txt = Lident label; loc = Location.none}) - [ - Exp.case - (Pat.construct - (Location.mknoloc @@ Lident "Some") - (Some (Pat.var (Location.mknoloc label)))) - (Exp.ident (Location.mknoloc @@ Lident label)); - Exp.case - (Pat.construct (Location.mknoloc @@ Lident "None") None) - default; - ]) - in - let vbMatchList = List.map vbMatch namedArgWithDefaultValueList in - (* type props = { ... } *) - let propsRecordType = - makePropsRecordType ~coreTypeOfAttr ~typVarsOfCoreType "props" - pstr_loc namedTypeList - in - let innerExpression = - Exp.apply - (Exp.ident (Location.mknoloc @@ Lident fnName)) - ([(Nolabel, Exp.ident (Location.mknoloc @@ Lident "props"))] - @ - match hasForwardRef with - | true -> - [(Nolabel, Exp.ident (Location.mknoloc @@ Lident "ref"))] - | false -> []) - in - let makePropsPattern = function - | [] -> Pat.var @@ Location.mknoloc "props" - | _ -> - Pat.constraint_ - (Pat.var @@ Location.mknoloc "props") - (Typ.constr (Location.mknoloc @@ Lident "props") [Typ.any ()]) - in - let fullExpression = - (* React component name should start with uppercase letter *) - (* let make = { let \"App" = props => make(props); \"App" } *) - (* let make = React.forwardRef({ - let \"App" = (props, ref) => make({...props, ref: @optional (Js.Nullabel.toOption(ref))}) - })*) - Exp.fun_ nolabel None - (match coreTypeOfAttr with - | None -> makePropsPattern namedTypeList - | Some _ -> makePropsPattern typVarsOfCoreType) - (if hasForwardRef then - Exp.fun_ nolabel None - (Pat.var @@ Location.mknoloc "ref") - innerExpression - else innerExpression) - in - let fullExpression = - match fullModuleName with - | "" -> fullExpression - | txt -> - Exp.let_ Nonrecursive - [ - Vb.mk ~loc:emptyLoc - (Pat.var ~loc:emptyLoc {loc = emptyLoc; txt}) - fullExpression; - ] - (Exp.ident ~loc:pstr_loc {loc = emptyLoc; txt = Lident txt}) - in - let rec stripConstraintUnpack ~label pattern = - match pattern with - | {ppat_desc = Ppat_constraint (pattern, _)} -> - stripConstraintUnpack ~label pattern - | {ppat_desc = Ppat_unpack _; ppat_loc} -> - (* remove unpack e.g. model: module(T) *) - Pat.var ~loc:ppat_loc {txt = label; loc = ppat_loc} - | _ -> pattern - in - let rec returnedExpression patternsWithLabel patternsWithNolabel - ({pexp_desc} as expr) = - match pexp_desc with - | Pexp_newtype (_, expr) -> - returnedExpression patternsWithLabel patternsWithNolabel expr - | Pexp_constraint (expr, _) -> - returnedExpression patternsWithLabel patternsWithNolabel expr - | Pexp_fun - ( _arg_label, - _default, - { - ppat_desc = - Ppat_construct ({txt = Lident "()"}, _) | Ppat_any; - }, - expr ) -> - (patternsWithLabel, patternsWithNolabel, expr) - | Pexp_fun - (arg_label, _default, ({ppat_loc; ppat_desc} as pattern), expr) - -> ( - let patternWithoutConstraint = - stripConstraintUnpack ~label:(getLabel arg_label) pattern + let modifiedBinding binding = + let hasApplication = ref false in + let wrapExpressionWithBinding expressionFn expression = + Vb.mk ~loc:bindingLoc + ~attrs:(List.filter otherAttrsPure binding.pvb_attributes) + (Pat.var ~loc:bindingPatLoc + { loc = bindingPatLoc; txt = fnName }) + (expressionFn expression) in - if isLabelled arg_label || isOptional arg_label then - returnedExpression - (( {loc = ppat_loc; txt = Lident (getLabel arg_label)}, - { - patternWithoutConstraint with - ppat_attributes = - (if isOptional arg_label then optionalAttrs else []) - @ pattern.ppat_attributes; - } ) - :: patternsWithLabel) - patternsWithNolabel expr - else - (* Special case of nolabel arg "ref" in forwardRef fn *) - (* let make = React.forwardRef(ref => body) *) - match ppat_desc with - | Ppat_var {txt} - | Ppat_constraint ({ppat_desc = Ppat_var {txt}}, _) -> - returnedExpression patternsWithLabel - (( {loc = ppat_loc; txt = Lident txt}, + let expression = binding.pvb_expr in + (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) + let rec spelunkForFunExpression expression = + match expression with + (* let make = (~prop) => ... with no final unit *) + | { + pexp_desc = + Pexp_fun + ( ((Labelled _ | Optional _) as label), + default, + pattern, + ({ pexp_desc = Pexp_fun _ } as internalExpression) ); + } -> + let wrap, hasForwardRef, exp = + spelunkForFunExpression internalExpression + in + ( wrap, + hasForwardRef, + { + expression with + pexp_desc = Pexp_fun (label, default, pattern, exp); + } ) + (* let make = (()) => ... *) + (* let make = (_) => ... *) + | { + pexp_desc = + Pexp_fun + ( Nolabel, + _default, { - pattern with - ppat_attributes = - optionalAttrs @ pattern.ppat_attributes; - } ) - :: patternsWithNolabel) - expr - | _ -> - returnedExpression patternsWithLabel patternsWithNolabel expr) - | _ -> (patternsWithLabel, patternsWithNolabel, expr) + ppat_desc = + Ppat_construct ({ txt = Lident "()" }, _) | Ppat_any; + }, + _internalExpression ); + } -> + ((fun a -> a), false, expression) + (* let make = (~prop) => ... *) + | { + pexp_desc = + Pexp_fun + ( (Labelled _ | Optional _), + _default, + _pattern, + _internalExpression ); + } -> + ((fun a -> a), false, expression) + (* let make = (prop) => ... *) + | { + pexp_desc = + Pexp_fun (_nolabel, _default, pattern, _internalExpression); + } -> + if !hasApplication then ((fun a -> a), false, expression) + else + Location.raise_errorf ~loc:pattern.ppat_loc + "React: props need to be labelled arguments.\n\ + \ If you are working with refs be sure to wrap with \ + React.forwardRef.\n\ + \ If your component doesn't have any props use () or \ + _ instead of a name." + (* let make = {let foo = bar in (~prop) => ...} *) + | { pexp_desc = Pexp_let (recursive, vbs, internalExpression) } + -> + (* here's where we spelunk! *) + let wrap, hasForwardRef, exp = + spelunkForFunExpression internalExpression + in + ( wrap, + hasForwardRef, + { + expression with + pexp_desc = Pexp_let (recursive, vbs, exp); + } ) + (* let make = React.forwardRef((~prop) => ...) *) + | { + pexp_desc = + Pexp_apply + (wrapperExpression, [ (Nolabel, internalExpression) ]); + } -> + let () = hasApplication := true in + let _, _, exp = + spelunkForFunExpression internalExpression + in + let hasForwardRef = isForwardRef wrapperExpression in + ( (fun exp -> Exp.apply wrapperExpression [ (nolabel, exp) ]), + hasForwardRef, + exp ) + | { + pexp_desc = + Pexp_sequence (wrapperExpression, internalExpression); + } -> + let wrap, hasForwardRef, exp = + spelunkForFunExpression internalExpression + in + ( wrap, + hasForwardRef, + { + expression with + pexp_desc = Pexp_sequence (wrapperExpression, exp); + } ) + | e -> ((fun a -> a), false, e) + in + let wrapExpression, hasForwardRef, expression = + spelunkForFunExpression expression + in + ( wrapExpressionWithBinding wrapExpression, + hasForwardRef, + expression ) + in + let bindingWrapper, hasForwardRef, expression = + modifiedBinding binding + in + (* do stuff here! *) + let namedArgList, newtypes, typeConstraints = + recursivelyTransformNamedArgsForMake mapper + (modifiedBindingOld binding) + [] [] None + in + let namedTypeList = + List.fold_left + (argToType ~newtypes ~typeConstraints) + [] namedArgList + in + let namedArgWithDefaultValueList = + List.filter_map argWithDefaultValue namedArgList + in + let vbMatch (label, default) = + Vb.mk + (Pat.var (Location.mknoloc label)) + (Exp.match_ + (Exp.ident { txt = Lident label; loc = Location.none }) + [ + Exp.case + (Pat.construct + (Location.mknoloc @@ Lident "Some") + (Some (Pat.var (Location.mknoloc label)))) + (Exp.ident (Location.mknoloc @@ Lident label)); + Exp.case + (Pat.construct (Location.mknoloc @@ Lident "None") None) + default; + ]) + in + let vbMatchList = List.map vbMatch namedArgWithDefaultValueList in + (* type props = { ... } *) + let propsRecordType = + makePropsRecordType ~coreTypeOfAttr ~typVarsOfCoreType "props" + pstr_loc namedTypeList + in + let innerExpression = + Exp.apply + (Exp.ident (Location.mknoloc @@ Lident fnName)) + ([ (Nolabel, Exp.ident (Location.mknoloc @@ Lident "props")) ] + @ + match hasForwardRef with + | true -> + [ (Nolabel, Exp.ident (Location.mknoloc @@ Lident "ref")) ] + | false -> []) + in + let makePropsPattern = function + | [] -> Pat.var @@ Location.mknoloc "props" + | _ -> + Pat.constraint_ + (Pat.var @@ Location.mknoloc "props") + (Typ.constr + (Location.mknoloc @@ Lident "props") + [ Typ.any () ]) + in + let fullExpression = + (* React component name should start with uppercase letter *) + (* let make = { let \"App" = props => make(props); \"App" } *) + (* let make = React.forwardRef({ + let \"App" = (props, ref) => make({...props, ref: @optional (Js.Nullabel.toOption(ref))}) + })*) + Exp.fun_ nolabel None + (match coreTypeOfAttr with + | None -> makePropsPattern namedTypeList + | Some _ -> makePropsPattern typVarsOfCoreType) + (if hasForwardRef then + Exp.fun_ nolabel None + (Pat.var @@ Location.mknoloc "ref") + innerExpression + else innerExpression) + in + let fullExpression = + match fullModuleName with + | "" -> fullExpression + | txt -> + Exp.let_ Nonrecursive + [ + Vb.mk ~loc:emptyLoc + (Pat.var ~loc:emptyLoc { loc = emptyLoc; txt }) + fullExpression; + ] + (Exp.ident ~loc:pstr_loc + { loc = emptyLoc; txt = Lident txt }) + in + let rec stripConstraintUnpack ~label pattern = + match pattern with + | { ppat_desc = Ppat_constraint (pattern, _) } -> + stripConstraintUnpack ~label pattern + | { ppat_desc = Ppat_unpack _; ppat_loc } -> + (* remove unpack e.g. model: module(T) *) + Pat.var ~loc:ppat_loc { txt = label; loc = ppat_loc } + | _ -> pattern + in + let rec returnedExpression patternsWithLabel patternsWithNolabel + ({ pexp_desc } as expr) = + match pexp_desc with + | Pexp_newtype (_, expr) -> + returnedExpression patternsWithLabel patternsWithNolabel expr + | Pexp_constraint (expr, _) -> + returnedExpression patternsWithLabel patternsWithNolabel expr + | Pexp_fun + ( _arg_label, + _default, + { + ppat_desc = + Ppat_construct ({ txt = Lident "()" }, _) | Ppat_any; + }, + expr ) -> + (patternsWithLabel, patternsWithNolabel, expr) + | Pexp_fun + ( arg_label, + _default, + ({ ppat_loc; ppat_desc } as pattern), + expr ) -> ( + let patternWithoutConstraint = + stripConstraintUnpack ~label:(getLabel arg_label) pattern + in + if isLabelled arg_label || isOptional arg_label then + returnedExpression + (( { loc = ppat_loc; txt = Lident (getLabel arg_label) }, + { + patternWithoutConstraint with + ppat_attributes = + (if isOptional arg_label then optionalAttrs + else []) + @ pattern.ppat_attributes; + } ) + :: patternsWithLabel) + patternsWithNolabel expr + else + (* Special case of nolabel arg "ref" in forwardRef fn *) + (* let make = React.forwardRef(ref => body) *) + match ppat_desc with + | Ppat_var { txt } + | Ppat_constraint ({ ppat_desc = Ppat_var { txt } }, _) -> + returnedExpression patternsWithLabel + (( { loc = ppat_loc; txt = Lident txt }, + { + pattern with + ppat_attributes = + optionalAttrs @ pattern.ppat_attributes; + } ) + :: patternsWithNolabel) + expr + | _ -> + returnedExpression patternsWithLabel patternsWithNolabel + expr) + | _ -> (patternsWithLabel, patternsWithNolabel, expr) + in + let patternsWithLabel, patternsWithNolabel, expression = + returnedExpression [] [] expression + in + (* add pattern matching for optional prop value *) + let expression = + if List.length vbMatchList = 0 then expression + else Exp.let_ Nonrecursive vbMatchList expression + in + (* (ref) => expr *) + let expression = + List.fold_left + (fun expr (_, pattern) -> Exp.fun_ Nolabel None pattern expr) + expression patternsWithNolabel + in + let recordPattern = + match patternsWithLabel with + | [] -> Pat.any () + | _ -> Pat.record (List.rev patternsWithLabel) Open + in + let expression = + Exp.fun_ Nolabel None + (Pat.constraint_ recordPattern + (Typ.constr ~loc:emptyLoc + { txt = Lident "props"; loc = emptyLoc } + (match coreTypeOfAttr with + | None -> + makePropsTypeParams ~stripExplicitOption:true + ~stripExplicitJsNullableOfRef:hasForwardRef + namedTypeList + | Some _ -> typVarsOfCoreType))) + expression + in + (* let make = ({id, name, ...}: props<'id, 'name, ...>) => { ... } *) + let bindings, newBinding = + match recFlag with + | Recursive -> + ( [ + bindingWrapper + (Exp.let_ ~loc:emptyLoc Recursive + [ + makeNewBinding binding expression internalFnName; + Vb.mk + (Pat.var { loc = emptyLoc; txt = fnName }) + fullExpression; + ] + (Exp.ident { loc = emptyLoc; txt = Lident fnName })); + ], + None ) + | Nonrecursive -> + ( [ + { + binding with + pvb_expr = expression; + pvb_pat = Pat.var { txt = fnName; loc = Location.none }; + }; + ], + Some (bindingWrapper fullExpression) ) + in + (Some propsRecordType, bindings, newBinding)) + else (None, [ binding ], None) + in + (* END of mapBinding fn *) + let structuresAndBinding = List.map mapBinding valueBindings in + let otherStructures (type_, binding, newBinding) + (types, bindings, newBindings) = + let types = + match type_ with Some type_ -> type_ :: types | None -> types + in + let newBindings = + match newBinding with + | Some newBinding -> newBinding :: newBindings + | None -> newBindings + in + (types, binding @ bindings, newBindings) + in + let types, bindings, newBindings = + List.fold_right otherStructures structuresAndBinding ([], [], []) + in + types + @ [ { pstr_loc; pstr_desc = Pstr_value (recFlag, bindings) } ] + @ + match newBindings with + | [] -> [] + | newBindings -> + [ + { + pstr_loc = emptyLoc; + pstr_desc = Pstr_value (recFlag, newBindings); + }; + ]) + | _ -> [ item ] + +let transformSignatureItem ~config _mapper item = + match item with + | { + psig_loc; + psig_desc = Psig_value ({ pval_attributes; pval_type } as psig_desc); + } as psig -> ( + match List.filter React_jsx_common.hasAttr pval_attributes with + | [] -> [ item ] + | [ _ ] -> + (* If there is another @react.component, throw error *) + if config.React_jsx_common.hasReactComponent then + React_jsx_common.raiseErrorMultipleReactComponent ~loc:psig_loc + else config.hasReactComponent <- true; + check_string_int_attribute_iter.signature_item + check_string_int_attribute_iter item; + let hasForwardRef = ref false in + let coreTypeOfAttr = + React_jsx_common.coreTypeOfAttrs pval_attributes in - let patternsWithLabel, patternsWithNolabel, expression = - returnedExpression [] [] expression + let typVarsOfCoreType = + coreTypeOfAttr + |> Option.map React_jsx_common.typVarsOfCoreType + |> Option.value ~default:[] in - (* add pattern matching for optional prop value *) - let expression = - if List.length vbMatchList = 0 then expression - else Exp.let_ Nonrecursive vbMatchList expression + let rec getPropTypes types ({ ptyp_loc; ptyp_desc } as fullType) = + match ptyp_desc with + | Ptyp_arrow (name, type_, ({ ptyp_desc = Ptyp_arrow _ } as rest)) + when isOptional name || isLabelled name -> + getPropTypes ((name, ptyp_loc, type_) :: types) rest + | Ptyp_arrow + ( Nolabel, + { ptyp_desc = Ptyp_constr ({ txt = Lident "unit" }, _) }, + rest ) -> + getPropTypes types rest + | Ptyp_arrow (Nolabel, _type, rest) -> + hasForwardRef := true; + getPropTypes types rest + | Ptyp_arrow (name, type_, returnValue) + when isOptional name || isLabelled name -> + (returnValue, (name, returnValue.ptyp_loc, type_) :: types) + | _ -> (fullType, types) in - (* (ref) => expr *) - let expression = - List.fold_left - (fun expr (_, pattern) -> Exp.fun_ Nolabel None pattern expr) - expression patternsWithNolabel + let innerType, propTypes = getPropTypes [] pval_type in + let namedTypeList = List.fold_left argToConcreteType [] propTypes in + let retPropsType = + Typ.constr + (Location.mkloc (Lident "props") psig_loc) + (match coreTypeOfAttr with + | None -> makePropsTypeParams namedTypeList + | Some _ -> typVarsOfCoreType) in - let recordPattern = - match patternsWithLabel with - | [] -> Pat.any () - | _ -> Pat.record (List.rev patternsWithLabel) Open + let propsRecordType = + makePropsRecordTypeSig ~coreTypeOfAttr ~typVarsOfCoreType "props" + psig_loc + ((* If there is Nolabel arg, regard the type as ref in forwardRef *) + (if !hasForwardRef then + [ (true, "ref", [], refType Location.none) ] + else []) + @ namedTypeList) in - let expression = - Exp.fun_ Nolabel None - (Pat.constraint_ recordPattern - (Typ.constr ~loc:emptyLoc - {txt = Lident "props"; loc = emptyLoc} - (match coreTypeOfAttr with - | None -> - makePropsTypeParams ~stripExplicitOption:true - ~stripExplicitJsNullableOfRef:hasForwardRef - namedTypeList - | Some _ -> typVarsOfCoreType))) - expression + (* can't be an arrow because it will defensively uncurry *) + let newExternalType = + Ptyp_constr + ( { loc = psig_loc; txt = Ldot (Lident "React", "componentLike") }, + [ retPropsType; innerType ] ) in - (* let make = ({id, name, ...}: props<'id, 'name, ...>) => { ... } *) - let bindings, newBinding = - match recFlag with - | Recursive -> - ( [ - bindingWrapper - (Exp.let_ ~loc:emptyLoc Recursive - [ - makeNewBinding binding expression internalFnName; - Vb.mk - (Pat.var {loc = emptyLoc; txt = fnName}) - fullExpression; - ] - (Exp.ident {loc = emptyLoc; txt = Lident fnName})); - ], - None ) - | Nonrecursive -> - ( [ + let newStructure = + { + psig with + psig_desc = + Psig_value { - binding with - pvb_expr = expression; - pvb_pat = Pat.var {txt = fnName; loc = Location.none}; + psig_desc with + pval_type = { pval_type with ptyp_desc = newExternalType }; + pval_attributes = List.filter otherAttrsPure pval_attributes; }; - ], - Some (bindingWrapper fullExpression) ) + } in - (Some propsRecordType, bindings, newBinding)) - else (None, [binding], None) - in - (* END of mapBinding fn *) - let structuresAndBinding = List.map mapBinding valueBindings in - let otherStructures (type_, binding, newBinding) - (types, bindings, newBindings) = - let types = - match type_ with - | Some type_ -> type_ :: types - | None -> types - in - let newBindings = - match newBinding with - | Some newBinding -> newBinding :: newBindings - | None -> newBindings - in - (types, binding @ bindings, newBindings) - in - let types, bindings, newBindings = - List.fold_right otherStructures structuresAndBinding ([], [], []) - in - types - @ [{pstr_loc; pstr_desc = Pstr_value (recFlag, bindings)}] - @ - match newBindings with - | [] -> [] - | newBindings -> - [{pstr_loc = emptyLoc; pstr_desc = Pstr_value (recFlag, newBindings)}]) - | _ -> [item] - -let transformSignatureItem ~config _mapper item = - match item with - | { - psig_loc; - psig_desc = Psig_value ({pval_attributes; pval_type} as psig_desc); - } as psig -> ( - match List.filter React_jsx_common.hasAttr pval_attributes with - | [] -> [item] - | [_] -> - (* If there is another @react.component, throw error *) - if config.React_jsx_common.hasReactComponent then - React_jsx_common.raiseErrorMultipleReactComponent ~loc:psig_loc - else config.hasReactComponent <- true; - check_string_int_attribute_iter.signature_item - check_string_int_attribute_iter item; - let hasForwardRef = ref false in - let coreTypeOfAttr = React_jsx_common.coreTypeOfAttrs pval_attributes in - let typVarsOfCoreType = - coreTypeOfAttr - |> Option.map React_jsx_common.typVarsOfCoreType - |> Option.value ~default:[] - in - let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = - match ptyp_desc with - | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) - when isOptional name || isLabelled name -> - getPropTypes ((name, ptyp_loc, type_) :: types) rest - | Ptyp_arrow - (Nolabel, {ptyp_desc = Ptyp_constr ({txt = Lident "unit"}, _)}, rest) - -> - getPropTypes types rest - | Ptyp_arrow (Nolabel, _type, rest) -> - hasForwardRef := true; - getPropTypes types rest - | Ptyp_arrow (name, type_, returnValue) - when isOptional name || isLabelled name -> - (returnValue, (name, returnValue.ptyp_loc, type_) :: types) - | _ -> (fullType, types) - in - let innerType, propTypes = getPropTypes [] pval_type in - let namedTypeList = List.fold_left argToConcreteType [] propTypes in - let retPropsType = - Typ.constr - (Location.mkloc (Lident "props") psig_loc) - (match coreTypeOfAttr with - | None -> makePropsTypeParams namedTypeList - | Some _ -> typVarsOfCoreType) - in - let propsRecordType = - makePropsRecordTypeSig ~coreTypeOfAttr ~typVarsOfCoreType "props" - psig_loc - ((* If there is Nolabel arg, regard the type as ref in forwardRef *) - (if !hasForwardRef then [(true, "ref", [], refType Location.none)] - else []) - @ namedTypeList) - in - (* can't be an arrow because it will defensively uncurry *) - let newExternalType = - Ptyp_constr - ( {loc = psig_loc; txt = Ldot (Lident "React", "componentLike")}, - [retPropsType; innerType] ) - in - let newStructure = - { - psig with - psig_desc = - Psig_value - { - psig_desc with - pval_type = {pval_type with ptyp_desc = newExternalType}; - pval_attributes = List.filter otherAttrsPure pval_attributes; - }; - } - in - [propsRecordType; newStructure] - | _ -> - React_jsx_common.raiseError ~loc:psig_loc - "Only one react.component call can exist on a component at one time") - | _ -> [item] + [ propsRecordType; newStructure ] + | _ -> + React_jsx_common.raiseError ~loc:psig_loc + "Only one react.component call can exist on a component at one time" + ) + | _ -> [ item ] let transformJsxCall ~config mapper callExpression callArguments jsxExprLoc attrs = match callExpression.pexp_desc with | Pexp_ident caller -> ( - match caller with - | {txt = Lident "createElement"; loc} -> - React_jsx_common.raiseError ~loc - "JSX: `createElement` should be preceeded by a module name." - (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *) - | {loc; txt = Ldot (modulePath, ("createElement" | "make"))} -> - transformUppercaseCall3 ~config modulePath mapper jsxExprLoc loc attrs - callArguments - (* div(~prop1=foo, ~prop2=bar, ~children=[bla], ()) *) - (* turn that into - ReactDOM.createElement(~props=ReactDOM.props(~props1=foo, ~props2=bar, ()), [|bla|]) *) - | {loc; txt = Lident id} -> - transformLowercaseCall3 ~config mapper jsxExprLoc loc attrs callArguments - id - | {txt = Ldot (_, anythingNotCreateElementOrMake); loc} -> - React_jsx_common.raiseError ~loc - "JSX: the JSX attribute should be attached to a \ - `YourModuleName.createElement` or `YourModuleName.make` call. We saw \ - `%s` instead" - anythingNotCreateElementOrMake - | {txt = Lapply _; loc} -> - (* don't think there's ever a case where this is reached *) - React_jsx_common.raiseError ~loc - "JSX: encountered a weird case while processing the code. Please \ - report this!") + match caller with + | { txt = Lident "createElement"; loc } -> + React_jsx_common.raiseError ~loc + "JSX: `createElement` should be preceeded by a module name." + (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *) + | { loc; txt = Ldot (modulePath, ("createElement" | "make")) } -> + transformUppercaseCall3 ~config modulePath mapper jsxExprLoc loc attrs + callArguments + (* div(~prop1=foo, ~prop2=bar, ~children=[bla], ()) *) + (* turn that into + ReactDOM.createElement(~props=ReactDOM.props(~props1=foo, ~props2=bar, ()), [|bla|]) *) + | { loc; txt = Lident id } -> + transformLowercaseCall3 ~config mapper jsxExprLoc loc attrs + callArguments id + | { txt = Ldot (_, anythingNotCreateElementOrMake); loc } -> + React_jsx_common.raiseError ~loc + "JSX: the JSX attribute should be attached to a \ + `YourModuleName.createElement` or `YourModuleName.make` call. We \ + saw `%s` instead" + anythingNotCreateElementOrMake + | { txt = Lapply _; loc } -> + (* don't think there's ever a case where this is reached *) + React_jsx_common.raiseError ~loc + "JSX: encountered a weird case while processing the code. Please \ + report this!") | _ -> - React_jsx_common.raiseError ~loc:callExpression.pexp_loc - "JSX: `createElement` should be preceeded by a simple, direct module \ - name." + React_jsx_common.raiseError ~loc:callExpression.pexp_loc + "JSX: `createElement` should be preceeded by a simple, direct module \ + name." let expr ~config mapper expression = match expression with @@ -275891,78 +276180,81 @@ let expr ~config mapper expression = pexp_attributes; pexp_loc; } -> ( - let jsxAttribute, nonJSXAttributes = - List.partition - (fun (attribute, _) -> attribute.txt = "JSX") - pexp_attributes - in - match (jsxAttribute, nonJSXAttributes) with - (* no JSX attribute *) - | [], _ -> default_mapper.expr mapper expression - | _, nonJSXAttributes -> - transformJsxCall ~config mapper callExpression callArguments pexp_loc - nonJSXAttributes) + let jsxAttribute, nonJSXAttributes = + List.partition + (fun (attribute, _) -> attribute.txt = "JSX") + pexp_attributes + in + match (jsxAttribute, nonJSXAttributes) with + (* no JSX attribute *) + | [], _ -> default_mapper.expr mapper expression + | _, nonJSXAttributes -> + transformJsxCall ~config mapper callExpression callArguments pexp_loc + nonJSXAttributes) (* is it a list with jsx attribute? Reason <>foo desugars to [@JSX][foo]*) | { pexp_desc = ( Pexp_construct - ({txt = Lident "::"; loc}, Some {pexp_desc = Pexp_tuple _}) - | Pexp_construct ({txt = Lident "[]"; loc}, None) ); + ({ txt = Lident "::"; loc }, Some { pexp_desc = Pexp_tuple _ }) + | Pexp_construct ({ txt = Lident "[]"; loc }, None) ); pexp_attributes; } as listItems -> ( - let jsxAttribute, nonJSXAttributes = - List.partition - (fun (attribute, _) -> attribute.txt = "JSX") - pexp_attributes - in - match (jsxAttribute, nonJSXAttributes) with - (* no JSX attribute *) - | [], _ -> default_mapper.expr mapper expression - | _, nonJSXAttributes -> - let loc = {loc with loc_ghost = true} in - let fragment = - match config.mode with - | "automatic" -> - Exp.ident ~loc {loc; txt = Ldot (Lident "React", "jsxFragment")} - | "classic" | _ -> - Exp.ident ~loc {loc; txt = Ldot (Lident "React", "fragment")} - in - let childrenExpr = transformChildrenIfList ~mapper listItems in - let recordOfChildren children = - Exp.record [(Location.mknoloc (Lident "children"), children)] None - in - let args = - [ - (nolabel, fragment); - (match config.mode with - | "automatic" -> ( - ( nolabel, - match childrenExpr with - | {pexp_desc = Pexp_array children} -> ( - match children with - | [] -> emptyRecord ~loc:Location.none - | [child] -> recordOfChildren child - | _ -> recordOfChildren childrenExpr) - | _ -> recordOfChildren childrenExpr )) - | "classic" | _ -> (nolabel, childrenExpr)); - ] - in - let countOfChildren = function - | {pexp_desc = Pexp_array children} -> List.length children - | _ -> 0 + let jsxAttribute, nonJSXAttributes = + List.partition + (fun (attribute, _) -> attribute.txt = "JSX") + pexp_attributes in - Exp.apply - ~loc (* throw away the [@JSX] attribute and keep the others, if any *) - ~attrs:nonJSXAttributes - (* ReactDOM.createElement *) - (match config.mode with - | "automatic" -> - if countOfChildren childrenExpr > 1 then - Exp.ident ~loc {loc; txt = Ldot (Lident "React", "jsxs")} - else Exp.ident ~loc {loc; txt = Ldot (Lident "React", "jsx")} - | "classic" | _ -> - Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOM", "createElement")}) - args) + match (jsxAttribute, nonJSXAttributes) with + (* no JSX attribute *) + | [], _ -> default_mapper.expr mapper expression + | _, nonJSXAttributes -> + let loc = { loc with loc_ghost = true } in + let fragment = + match config.mode with + | "automatic" -> + Exp.ident ~loc + { loc; txt = Ldot (Lident "React", "jsxFragment") } + | "classic" | _ -> + Exp.ident ~loc { loc; txt = Ldot (Lident "React", "fragment") } + in + let childrenExpr = transformChildrenIfList ~mapper listItems in + let recordOfChildren children = + Exp.record [ (Location.mknoloc (Lident "children"), children) ] None + in + let args = + [ + (nolabel, fragment); + (match config.mode with + | "automatic" -> ( + ( nolabel, + match childrenExpr with + | { pexp_desc = Pexp_array children } -> ( + match children with + | [] -> emptyRecord ~loc:Location.none + | [ child ] -> recordOfChildren child + | _ -> recordOfChildren childrenExpr) + | _ -> recordOfChildren childrenExpr )) + | "classic" | _ -> (nolabel, childrenExpr)); + ] + in + let countOfChildren = function + | { pexp_desc = Pexp_array children } -> List.length children + | _ -> 0 + in + Exp.apply + ~loc + (* throw away the [@JSX] attribute and keep the others, if any *) + ~attrs:nonJSXAttributes + (* ReactDOM.createElement *) + (match config.mode with + | "automatic" -> + if countOfChildren childrenExpr > 1 then + Exp.ident ~loc { loc; txt = Ldot (Lident "React", "jsxs") } + else Exp.ident ~loc { loc; txt = Ldot (Lident "React", "jsx") } + | "classic" | _ -> + Exp.ident ~loc + { loc; txt = Ldot (Lident "ReactDOM", "createElement") }) + args) (* Delegate to the default mapper, a deep identity traversal *) | e -> default_mapper.expr mapper e @@ -276024,10 +276316,10 @@ let getPayloadFields payload = | PStr ({ pstr_desc = - Pstr_eval ({pexp_desc = Pexp_record (recordFields, None)}, _); + Pstr_eval ({ pexp_desc = Pexp_record (recordFields, None) }, _); } :: _rest) -> - recordFields + recordFields | _ -> [] type configKey = Int | String @@ -276038,21 +276330,19 @@ let getJsxConfigByKey ~key ~type_ recordFields = (fun ((lid, expr) : Longident.t Location.loc * expression) -> match (type_, lid, expr) with | ( Int, - {txt = Lident k}, - {pexp_desc = Pexp_constant (Pconst_integer (value, None))} ) + { txt = Lident k }, + { pexp_desc = Pexp_constant (Pconst_integer (value, None)) } ) when k = key -> - Some value + Some value | ( String, - {txt = Lident k}, - {pexp_desc = Pexp_constant (Pconst_string (value, None))} ) + { txt = Lident k }, + { pexp_desc = Pexp_constant (Pconst_string (value, None)) } ) when k = key -> - Some value + Some value | _ -> None) recordFields in - match values with - | [] -> None - | [v] | v :: _ -> Some v + match values with [] -> None | [ v ] | v :: _ -> Some v let getInt ~key fields = match fields |> getJsxConfigByKey ~key ~type_:Int with @@ -276125,7 +276415,7 @@ let getMapper ~config = let item = default_mapper.signature_item mapper item in if config.version = 3 then transformSignatureItem3 mapper item else if config.version = 4 then transformSignatureItem4 mapper item - else [item]) + else [ item ]) items |> List.flatten in @@ -276144,7 +276434,7 @@ let getMapper ~config = let item = default_mapper.structure_item mapper item in if config.version = 3 then transformStructureItem3 mapper item else if config.version = 4 then transformStructureItem4 mapper item - else [item]) + else [ item ]) items |> List.flatten in @@ -276152,7 +276442,7 @@ let getMapper ~config = result in - {default_mapper with expr; module_binding; signature; structure} + { default_mapper with expr; module_binding; signature; structure } let rewrite_implementation ~jsxVersion ~jsxModule ~jsxMode (code : Parsetree.structure) : Parsetree.structure = diff --git a/lib/4.06.1/unstable/js_playground_compiler.ml b/lib/4.06.1/unstable/js_playground_compiler.ml index eb9d0122d8..6f7feeb88a 100644 --- a/lib/4.06.1/unstable/js_playground_compiler.ml +++ b/lib/4.06.1/unstable/js_playground_compiler.ml @@ -24863,6 +24863,92 @@ let lam_of_loc kind loc = let reset () = raise_count := 0 +end +module Ext_util : sig +#1 "ext_util.mli" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +val power_2_above : int -> int -> int + +val stats_to_string : Hashtbl.statistics -> string + +val string_of_int_as_char : int -> string + + +end = struct +#1 "ext_util.ml" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +(** + {[ + (power_2_above 16 63 = 64) + (power_2_above 16 76 = 128) + ]} +*) +let rec power_2_above x n = + if x >= n then x + else if x * 2 > Sys.max_array_length then x + else power_2_above (x * 2) n + +let stats_to_string + ({ num_bindings; num_buckets; max_bucket_length; bucket_histogram } : + Hashtbl.statistics) = + Printf.sprintf "bindings: %d,buckets: %d, longest: %d, hist:[%s]" num_bindings + num_buckets max_bucket_length + (String.concat "," + (Array.to_list (Array.map string_of_int bucket_histogram))) + +let string_of_int_as_char i = + if i >= 0 && i <= 255 + then + Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) + else + Printf.sprintf "\'\\%d\'" i + end module Pprintast : sig #1 "pprintast.mli" @@ -25089,12 +25175,7 @@ let rec longident f = function let longident_loc f x = pp f "%a" longident x.txt -let string_of_int_as_char i = - if i >= 0 && i <= 255 - then - Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) - else - Printf.sprintf "\'\\%d\'" i +let string_of_int_as_char i = Ext_util.string_of_int_as_char i let constant f = function | Pconst_char i -> pp f "%s" (string_of_int_as_char i) @@ -48534,24 +48615,21 @@ module Res_comment : sig type t val toString : t -> string - val loc : t -> Location.t val txt : t -> string val prevTokEndPos : t -> Lexing.position - val setPrevTokEndPos : t -> Lexing.position -> unit - val isDocComment : t -> bool - val isModuleComment : t -> bool - val isSingleLineComment : t -> bool - val makeSingleLineComment : loc:Location.t -> string -> t + val makeMultiLineComment : loc:Location.t -> docComment:bool -> standalone:bool -> string -> t + val fromOcamlComment : loc:Location.t -> txt:string -> prevTokEndPos:Lexing.position -> t + val trimSpaces : string -> string end = struct @@ -48566,26 +48644,22 @@ let styleToString s = | ModuleComment -> "ModuleComment" type t = { - txt: string; - style: style; - loc: Location.t; - mutable prevTokEndPos: Lexing.position; + txt : string; + style : style; + loc : Location.t; + mutable prevTokEndPos : Lexing.position; } let loc t = t.loc let txt t = t.txt let prevTokEndPos t = t.prevTokEndPos - let setPrevTokEndPos t pos = t.prevTokEndPos <- pos - let isSingleLineComment t = t.style = SingleLine - let isDocComment t = t.style = DocComment - let isModuleComment t = t.style = ModuleComment let toString t = - let {Location.loc_start; loc_end} = t.loc in + let { Location.loc_start; loc_end } = t.loc in Format.sprintf "(txt: %s\nstyle: %s\nlocation: %d,%d-%d,%d)" t.txt (styleToString t.style) loc_start.pos_lnum (loc_start.pos_cnum - loc_start.pos_bol) @@ -48593,7 +48667,7 @@ let toString t = (loc_end.pos_cnum - loc_end.pos_bol) let makeSingleLineComment ~loc txt = - {txt; loc; style = SingleLine; prevTokEndPos = Lexing.dummy_pos} + { txt; loc; style = SingleLine; prevTokEndPos = Lexing.dummy_pos } let makeMultiLineComment ~loc ~docComment ~standalone txt = { @@ -48606,7 +48680,7 @@ let makeMultiLineComment ~loc ~docComment ~standalone txt = } let fromOcamlComment ~loc ~txt ~prevTokEndPos = - {txt; loc; style = MultiLine; prevTokEndPos} + { txt; loc; style = MultiLine; prevTokEndPos } let trimSpaces s = let len = String.length s in @@ -48628,6 +48702,7 @@ end module Res_minibuffer : sig #1 "res_minibuffer.mli" type t + val add_char : t -> char -> unit val add_string : t -> string -> unit val contents : t -> string @@ -48636,12 +48711,16 @@ val flush_newline : t -> unit end = struct #1 "res_minibuffer.ml" -type t = {mutable buffer: bytes; mutable position: int; mutable length: int} +type t = { + mutable buffer : bytes; + mutable position : int; + mutable length : int; +} let create n = let n = if n < 1 then 1 else n in let s = (Bytes.create [@doesNotRaise]) n in - {buffer = s; position = 0; length = n} + { buffer = s; position = 0; length = n } let contents b = (Bytes.sub_string [@doesNotRaise]) b.buffer 0 b.position @@ -48711,7 +48790,6 @@ val join : sep:t -> t list -> t (* [(doc1, sep1); (doc2,sep2)] joins as doc1 sep1 doc2 *) val joinWithSep : (t * t) list -> t - val space : t val comma : t val dot : t @@ -48751,7 +48829,6 @@ val doubleQuote : t [@@live] * force breaks from bottom to top. *) val willBreak : t -> bool - val toString : width:int -> t -> string val debug : t -> unit [@@live] @@ -48775,11 +48852,11 @@ type t = | Text of string | Concat of t list | Indent of t - | IfBreaks of {yes: t; no: t; mutable broken: bool} + | IfBreaks of { yes : t; no : t; mutable broken : bool } (* when broken is true, treat as the yes branch *) | LineSuffix of t | LineBreak of lineStyle - | Group of {mutable shouldBreak: bool; doc: t} + | Group of { mutable shouldBreak : bool; doc : t } | CustomLayout of t list | BreakParent @@ -48796,22 +48873,20 @@ let rec _concat acc l = | Text s1 :: Text s2 :: rest -> Text (s1 ^ s2) :: _concat acc rest | Nil :: rest -> _concat acc rest | Concat l2 :: rest -> - _concat (_concat acc rest) l2 (* notice the order here *) + _concat (_concat acc rest) l2 (* notice the order here *) | x :: rest -> - let rest1 = _concat acc rest in - if rest1 == rest then l else x :: rest1 + let rest1 = _concat acc rest in + if rest1 == rest then l else x :: rest1 | [] -> acc let concat l = Concat (_concat [] l) - let indent d = Indent d -let ifBreaks t f = IfBreaks {yes = t; no = f; broken = false} +let ifBreaks t f = IfBreaks { yes = t; no = f; broken = false } let lineSuffix d = LineSuffix d -let group d = Group {shouldBreak = false; doc = d} -let breakableGroup ~forceBreak d = Group {shouldBreak = forceBreak; doc = d} +let group d = Group { shouldBreak = false; doc = d } +let breakableGroup ~forceBreak d = Group { shouldBreak = forceBreak; doc = d } let customLayout gs = CustomLayout gs let breakParent = BreakParent - let space = Text " " let comma = Text "," let dot = Text "." @@ -48839,36 +48914,36 @@ let propagateForcedBreaks doc = | LineBreak (Hard | Literal) -> true | LineBreak (Classic | Soft) -> false | Indent children -> - let childForcesBreak = walk children in - childForcesBreak - | IfBreaks ({yes = trueDoc; no = falseDoc} as ib) -> - let falseForceBreak = walk falseDoc in - if falseForceBreak then ( - let _ = walk trueDoc in - ib.broken <- true; - true) - else - let forceBreak = walk trueDoc in - forceBreak - | Group ({shouldBreak = forceBreak; doc = children} as gr) -> - let childForcesBreak = walk children in - let shouldBreak = forceBreak || childForcesBreak in - gr.shouldBreak <- shouldBreak; - shouldBreak + let childForcesBreak = walk children in + childForcesBreak + | IfBreaks ({ yes = trueDoc; no = falseDoc } as ib) -> + let falseForceBreak = walk falseDoc in + if falseForceBreak then ( + let _ = walk trueDoc in + ib.broken <- true; + true) + else + let forceBreak = walk trueDoc in + forceBreak + | Group ({ shouldBreak = forceBreak; doc = children } as gr) -> + let childForcesBreak = walk children in + let shouldBreak = forceBreak || childForcesBreak in + gr.shouldBreak <- shouldBreak; + shouldBreak | Concat children -> - List.fold_left - (fun forceBreak child -> - let childForcesBreak = walk child in - forceBreak || childForcesBreak) - false children + List.fold_left + (fun forceBreak child -> + let childForcesBreak = walk child in + forceBreak || childForcesBreak) + false children | CustomLayout children -> - (* When using CustomLayout, we don't want to propagate forced breaks - * from the children up. By definition it picks the first layout that fits - * otherwise it takes the last of the list. - * However we do want to propagate forced breaks in the sublayouts. They - * might need to be broken. We just don't propagate them any higher here *) - let _ = walk (Concat children) in - false + (* When using CustomLayout, we don't want to propagate forced breaks + * from the children up. By definition it picks the first layout that fits + * otherwise it takes the last of the list. + * However we do want to propagate forced breaks in the sublayouts. They + * might need to be broken. We just don't propagate them any higher here *) + let _ = walk (Concat children) in + false in let _ = walk doc in () @@ -48876,18 +48951,18 @@ let propagateForcedBreaks doc = (* See documentation in interface file *) let rec willBreak doc = match doc with - | LineBreak (Hard | Literal) | BreakParent | Group {shouldBreak = true} -> - true - | Group {doc} | Indent doc | CustomLayout (doc :: _) -> willBreak doc + | LineBreak (Hard | Literal) | BreakParent | Group { shouldBreak = true } -> + true + | Group { doc } | Indent doc | CustomLayout (doc :: _) -> willBreak doc | Concat docs -> List.exists willBreak docs - | IfBreaks {yes; no} -> willBreak yes || willBreak no + | IfBreaks { yes; no } -> willBreak yes || willBreak no | _ -> false let join ~sep docs = let rec loop acc sep docs = match docs with | [] -> List.rev acc - | [x] -> List.rev (x :: acc) + | [ x ] -> List.rev (x :: acc) | x :: xs -> loop (sep :: x :: acc) sep xs in concat (loop [] sep docs) @@ -48896,7 +48971,7 @@ let joinWithSep docsWithSep = let rec loop acc docs = match docs with | [] -> List.rev acc - | [(x, _sep)] -> List.rev (x :: acc) + | [ (x, _sep) ] -> List.rev (x :: acc) | (x, sep) :: xs -> loop (sep :: x :: acc) xs in concat (loop [] docsWithSep) @@ -48916,32 +48991,32 @@ let fits w stack = | Flat, LineBreak Classic -> width := width.contents - 1 | Flat, LineBreak Soft -> () | Break, LineBreak _ -> result := Some true - | _, Group {shouldBreak = true; doc} -> calculate indent Break doc - | _, Group {doc} -> calculate indent mode doc - | _, IfBreaks {yes = breakDoc; broken = true} -> - calculate indent mode breakDoc - | Break, IfBreaks {yes = breakDoc} -> calculate indent mode breakDoc - | Flat, IfBreaks {no = flatDoc} -> calculate indent mode flatDoc + | _, Group { shouldBreak = true; doc } -> calculate indent Break doc + | _, Group { doc } -> calculate indent mode doc + | _, IfBreaks { yes = breakDoc; broken = true } -> + calculate indent mode breakDoc + | Break, IfBreaks { yes = breakDoc } -> calculate indent mode breakDoc + | Flat, IfBreaks { no = flatDoc } -> calculate indent mode flatDoc | _, Concat docs -> calculateConcat indent mode docs | _, CustomLayout (hd :: _) -> - (* TODO: if we have nested custom layouts, what we should do here? *) - calculate indent mode hd + (* TODO: if we have nested custom layouts, what we should do here? *) + calculate indent mode hd | _, CustomLayout [] -> () and calculateConcat indent mode docs = if result.contents == None then match docs with | [] -> () | doc :: rest -> - calculate indent mode doc; - calculateConcat indent mode rest + calculate indent mode doc; + calculateConcat indent mode rest in let rec calculateAll stack = match (result.contents, stack) with | Some r, _ -> r | None, [] -> !width >= 0 | None, (indent, mode, doc) :: rest -> - calculate indent mode doc; - calculateAll rest + calculate indent mode doc; + calculateAll rest in calculateAll stack @@ -48952,73 +49027,75 @@ let toString ~width doc = let rec process ~pos lineSuffices stack = match stack with | ((ind, mode, doc) as cmd) :: rest -> ( - match doc with - | Nil | BreakParent -> process ~pos lineSuffices rest - | Text txt -> - MiniBuffer.add_string buffer txt; - process ~pos:(String.length txt + pos) lineSuffices rest - | LineSuffix doc -> process ~pos ((ind, mode, doc) :: lineSuffices) rest - | Concat docs -> - let ops = List.map (fun doc -> (ind, mode, doc)) docs in - process ~pos lineSuffices (List.append ops rest) - | Indent doc -> process ~pos lineSuffices ((ind + 2, mode, doc) :: rest) - | IfBreaks {yes = breakDoc; broken = true} -> - process ~pos lineSuffices ((ind, mode, breakDoc) :: rest) - | IfBreaks {yes = breakDoc; no = flatDoc} -> - if mode = Break then - process ~pos lineSuffices ((ind, mode, breakDoc) :: rest) - else process ~pos lineSuffices ((ind, mode, flatDoc) :: rest) - | LineBreak lineStyle -> - if mode = Break then - match lineSuffices with - | [] -> - if lineStyle = Literal then ( - MiniBuffer.add_char buffer '\n'; - process ~pos:0 [] rest) - else ( - MiniBuffer.flush_newline buffer; - MiniBuffer.add_string buffer (String.make ind ' ' [@doesNotRaise]); - process ~pos:ind [] rest) - | _docs -> - process ~pos:ind [] - (List.concat [List.rev lineSuffices; cmd :: rest]) - else - (* mode = Flat *) - let pos = - match lineStyle with - | Classic -> - MiniBuffer.add_string buffer " "; - pos + 1 - | Hard -> - MiniBuffer.flush_newline buffer; - 0 - | Literal -> - MiniBuffer.add_char buffer '\n'; - 0 - | Soft -> pos - in - process ~pos lineSuffices rest - | Group {shouldBreak; doc} -> - if shouldBreak || not (fits (width - pos) ((ind, Flat, doc) :: rest)) - then process ~pos lineSuffices ((ind, Break, doc) :: rest) - else process ~pos lineSuffices ((ind, Flat, doc) :: rest) - | CustomLayout docs -> - let rec findGroupThatFits groups = - match groups with - | [] -> Nil - | [lastGroup] -> lastGroup - | doc :: docs -> - if fits (width - pos) ((ind, Flat, doc) :: rest) then doc - else findGroupThatFits docs - in - let doc = findGroupThatFits docs in - process ~pos lineSuffices ((ind, Flat, doc) :: rest)) + match doc with + | Nil | BreakParent -> process ~pos lineSuffices rest + | Text txt -> + MiniBuffer.add_string buffer txt; + process ~pos:(String.length txt + pos) lineSuffices rest + | LineSuffix doc -> process ~pos ((ind, mode, doc) :: lineSuffices) rest + | Concat docs -> + let ops = List.map (fun doc -> (ind, mode, doc)) docs in + process ~pos lineSuffices (List.append ops rest) + | Indent doc -> process ~pos lineSuffices ((ind + 2, mode, doc) :: rest) + | IfBreaks { yes = breakDoc; broken = true } -> + process ~pos lineSuffices ((ind, mode, breakDoc) :: rest) + | IfBreaks { yes = breakDoc; no = flatDoc } -> + if mode = Break then + process ~pos lineSuffices ((ind, mode, breakDoc) :: rest) + else process ~pos lineSuffices ((ind, mode, flatDoc) :: rest) + | LineBreak lineStyle -> + if mode = Break then + match lineSuffices with + | [] -> + if lineStyle = Literal then ( + MiniBuffer.add_char buffer '\n'; + process ~pos:0 [] rest) + else ( + MiniBuffer.flush_newline buffer; + MiniBuffer.add_string buffer + (String.make ind ' ' [@doesNotRaise]); + process ~pos:ind [] rest) + | _docs -> + process ~pos:ind [] + (List.concat [ List.rev lineSuffices; cmd :: rest ]) + else + (* mode = Flat *) + let pos = + match lineStyle with + | Classic -> + MiniBuffer.add_string buffer " "; + pos + 1 + | Hard -> + MiniBuffer.flush_newline buffer; + 0 + | Literal -> + MiniBuffer.add_char buffer '\n'; + 0 + | Soft -> pos + in + process ~pos lineSuffices rest + | Group { shouldBreak; doc } -> + if + shouldBreak || not (fits (width - pos) ((ind, Flat, doc) :: rest)) + then process ~pos lineSuffices ((ind, Break, doc) :: rest) + else process ~pos lineSuffices ((ind, Flat, doc) :: rest) + | CustomLayout docs -> + let rec findGroupThatFits groups = + match groups with + | [] -> Nil + | [ lastGroup ] -> lastGroup + | doc :: docs -> + if fits (width - pos) ((ind, Flat, doc) :: rest) then doc + else findGroupThatFits docs + in + let doc = findGroupThatFits docs in + process ~pos lineSuffices ((ind, Flat, doc) :: rest)) | [] -> ( - match lineSuffices with - | [] -> () - | suffices -> process ~pos:0 [] (List.rev suffices)) + match lineSuffices with + | [] -> () + | suffices -> process ~pos:0 [] (List.rev suffices)) in - process ~pos:0 [] [(0, Flat, doc)]; + process ~pos:0 [] [ (0, Flat, doc) ]; MiniBuffer.contents buffer let debug t = @@ -49027,82 +49104,91 @@ let debug t = | BreakParent -> text "breakparent" | Text txt -> text ("text(\"" ^ txt ^ "\")") | LineSuffix doc -> - group - (concat - [ - text "linesuffix("; - indent (concat [line; toDoc doc]); - line; - text ")"; - ]) + group + (concat + [ + text "linesuffix("; + indent (concat [ line; toDoc doc ]); + line; + text ")"; + ]) | Concat [] -> text "concat()" | Concat docs -> - group - (concat - [ - text "concat("; - indent - (concat - [ - line; - join ~sep:(concat [text ","; line]) (List.map toDoc docs); - ]); - line; - text ")"; - ]) + group + (concat + [ + text "concat("; + indent + (concat + [ + line; + join + ~sep:(concat [ text ","; line ]) + (List.map toDoc docs); + ]); + line; + text ")"; + ]) | CustomLayout docs -> - group - (concat - [ - text "customLayout("; - indent - (concat - [ - line; - join ~sep:(concat [text ","; line]) (List.map toDoc docs); - ]); - line; - text ")"; - ]) + group + (concat + [ + text "customLayout("; + indent + (concat + [ + line; + join + ~sep:(concat [ text ","; line ]) + (List.map toDoc docs); + ]); + line; + text ")"; + ]) | Indent doc -> - concat [text "indent("; softLine; toDoc doc; softLine; text ")"] - | IfBreaks {yes = trueDoc; broken = true} -> toDoc trueDoc - | IfBreaks {yes = trueDoc; no = falseDoc} -> - group - (concat - [ - text "ifBreaks("; - indent - (concat - [line; toDoc trueDoc; concat [text ","; line]; toDoc falseDoc]); - line; - text ")"; - ]) + concat [ text "indent("; softLine; toDoc doc; softLine; text ")" ] + | IfBreaks { yes = trueDoc; broken = true } -> toDoc trueDoc + | IfBreaks { yes = trueDoc; no = falseDoc } -> + group + (concat + [ + text "ifBreaks("; + indent + (concat + [ + line; + toDoc trueDoc; + concat [ text ","; line ]; + toDoc falseDoc; + ]); + line; + text ")"; + ]) | LineBreak break -> - let breakTxt = - match break with - | Classic -> "Classic" - | Soft -> "Soft" - | Hard -> "Hard" - | Literal -> "Liteal" - in - text ("LineBreak(" ^ breakTxt ^ ")") - | Group {shouldBreak; doc} -> - group - (concat - [ - text "Group("; - indent - (concat - [ - line; - text ("{shouldBreak: " ^ string_of_bool shouldBreak ^ "}"); - concat [text ","; line]; - toDoc doc; - ]); - line; - text ")"; - ]) + let breakTxt = + match break with + | Classic -> "Classic" + | Soft -> "Soft" + | Hard -> "Hard" + | Literal -> "Liteal" + in + text ("LineBreak(" ^ breakTxt ^ ")") + | Group { shouldBreak; doc } -> + group + (concat + [ + text "Group("; + indent + (concat + [ + line; + text ("{shouldBreak: " ^ string_of_bool shouldBreak ^ "}"); + concat [ text ","; line ]; + toDoc doc; + ]); + line; + text ")"; + ]) in let doc = toDoc t in toString ~width:10 doc |> print_endline @@ -49131,14 +49217,13 @@ val processUncurriedAttribute : Parsetree.attributes -> bool * Parsetree.attributes type functionAttributesInfo = { - async: bool; - uncurried: bool; - attributes: Parsetree.attributes; + async : bool; + uncurried : bool; + attributes : Parsetree.attributes; } (* determines whether a function is async and/or uncurried based on the given attributes *) val processFunctionAttributes : Parsetree.attributes -> functionAttributesInfo - val hasAwaitAttribute : Parsetree.attributes -> bool type ifConditionKind = @@ -49159,12 +49244,15 @@ val collectListExpressions : type funParamKind = | Parameter of { - attrs: Parsetree.attributes; - lbl: Asttypes.arg_label; - defaultExpr: Parsetree.expression option; - pat: Parsetree.pattern; + attrs : Parsetree.attributes; + lbl : Asttypes.arg_label; + defaultExpr : Parsetree.expression option; + pat : Parsetree.pattern; + } + | NewTypes of { + attrs : Parsetree.attributes; + locs : string Asttypes.loc list; } - | NewTypes of {attrs: Parsetree.attributes; locs: string Asttypes.loc list} val funExpr : Parsetree.expression -> @@ -49177,21 +49265,14 @@ val funExpr : * })` * Notice howe `({` and `})` "hug" or stick to each other *) val isHuggableExpression : Parsetree.expression -> bool - val isHuggablePattern : Parsetree.pattern -> bool - val isHuggableRhs : Parsetree.expression -> bool - val operatorPrecedence : string -> int - val isUnaryExpression : Parsetree.expression -> bool val isBinaryOperator : string -> bool val isBinaryExpression : Parsetree.expression -> bool - val flattenableOperators : string -> string -> bool - val hasAttributes : Parsetree.attributes -> bool - val isArrayAccess : Parsetree.expression -> bool val isTernaryExpr : Parsetree.expression -> bool val isIfLetExpr : Parsetree.expression -> bool @@ -49201,23 +49282,22 @@ val collectTernaryParts : (Parsetree.expression * Parsetree.expression) list * Parsetree.expression val parametersShouldHug : funParamKind list -> bool - val filterTernaryAttributes : Parsetree.attributes -> Parsetree.attributes val filterFragileMatchAttributes : Parsetree.attributes -> Parsetree.attributes - val isJsxExpression : Parsetree.expression -> bool val hasJsxAttribute : Parsetree.attributes -> bool val hasOptionalAttribute : Parsetree.attributes -> bool - val shouldIndentBinaryExpr : Parsetree.expression -> bool val shouldInlineRhsBinaryExpr : Parsetree.expression -> bool val hasPrintableAttributes : Parsetree.attributes -> bool val filterPrintableAttributes : Parsetree.attributes -> Parsetree.attributes + val partitionPrintableAttributes : Parsetree.attributes -> Parsetree.attributes * Parsetree.attributes val requiresSpecialCallbackPrintingLastArg : (Asttypes.arg_label * Parsetree.expression) list -> bool + val requiresSpecialCallbackPrintingFirstArg : (Asttypes.arg_label * Parsetree.expression) list -> bool @@ -49241,21 +49321,16 @@ val collectPatternsFromListConstruct : Parsetree.pattern list * Parsetree.pattern val isBlockExpr : Parsetree.expression -> bool - val isTemplateLiteral : Parsetree.expression -> bool val hasTemplateLiteralAttr : Parsetree.attributes -> bool - val isSpreadBeltListConcat : Parsetree.expression -> bool - val collectOrPatternChain : Parsetree.pattern -> Parsetree.pattern list val processBracesAttr : Parsetree.expression -> Parsetree.attribute option * Parsetree.expression val filterParsingAttrs : Parsetree.attributes -> Parsetree.attributes - val isBracedExpr : Parsetree.expression -> bool - val isSinglePipeExpr : Parsetree.expression -> bool (* (__x) => f(a, __x, c) -----> f(a, _, c) *) @@ -49263,9 +49338,7 @@ val rewriteUnderscoreApply : Parsetree.expression -> Parsetree.expression (* (__x) => f(a, __x, c) -----> f(a, _, c) *) val isUnderscoreApplySugar : Parsetree.expression -> bool - val hasIfLetAttribute : Parsetree.attributes -> bool - val isRewrittenUnderscoreApplySugar : Parsetree.expression -> bool end = struct @@ -49279,31 +49352,33 @@ let arrowType ct = ptyp_desc = Ptyp_arrow ((Nolabel as lbl), typ1, typ2); ptyp_attributes = []; } -> - let arg = ([], lbl, typ1) in - process attrsBefore (arg :: acc) typ2 + let arg = ([], lbl, typ1) in + process attrsBefore (arg :: acc) typ2 | { ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); - ptyp_attributes = [({txt = "bs"}, _)]; + ptyp_attributes = [ ({ txt = "bs" }, _) ]; } -> - (* stop here, the uncurried attribute always indicates the beginning of an arrow function - * e.g. `(. int) => (. int)` instead of `(. int, . int)` *) - (attrsBefore, List.rev acc, typ) - | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = _attrs} - as returnType -> - let args = List.rev acc in - (attrsBefore, args, returnType) + (* stop here, the uncurried attribute always indicates the beginning of an arrow function + * e.g. `(. int) => (. int)` instead of `(. int, . int)` *) + (attrsBefore, List.rev acc, typ) + | { + ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); + ptyp_attributes = _attrs; + } as returnType -> + let args = List.rev acc in + (attrsBefore, args, returnType) | { ptyp_desc = Ptyp_arrow (((Labelled _ | Optional _) as lbl), typ1, typ2); ptyp_attributes = attrs; } -> - let arg = (attrs, lbl, typ1) in - process attrsBefore (arg :: acc) typ2 + let arg = (attrs, lbl, typ1) in + process attrsBefore (arg :: acc) typ2 | typ -> (attrsBefore, List.rev acc, typ) in match ct with - | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = attrs} as - typ -> - process attrs [] {typ with ptyp_attributes = []} + | { ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = attrs } + as typ -> + process attrs [] { typ with ptyp_attributes = [] } | typ -> process [] [] typ let functorType modtype = @@ -49313,8 +49388,8 @@ let functorType modtype = pmty_desc = Pmty_functor (lbl, argType, returnType); pmty_attributes = attrs; } -> - let arg = (attrs, lbl, argType) in - process (arg :: acc) returnType + let arg = (attrs, lbl, argType) in + process (arg :: acc) returnType | modType -> (List.rev acc, modType) in process [] modtype @@ -49323,43 +49398,41 @@ let processUncurriedAttribute attrs = let rec process uncurriedSpotted acc attrs = match attrs with | [] -> (uncurriedSpotted, List.rev acc) - | ({Location.txt = "bs"}, _) :: rest -> process true acc rest + | ({ Location.txt = "bs" }, _) :: rest -> process true acc rest | attr :: rest -> process uncurriedSpotted (attr :: acc) rest in process false [] attrs type functionAttributesInfo = { - async: bool; - uncurried: bool; - attributes: Parsetree.attributes; + async : bool; + uncurried : bool; + attributes : Parsetree.attributes; } let processFunctionAttributes attrs = let rec process async uncurried acc attrs = match attrs with - | [] -> {async; uncurried; attributes = List.rev acc} - | ({Location.txt = "bs"}, _) :: rest -> process async true acc rest - | ({Location.txt = "res.async"}, _) :: rest -> - process true uncurried acc rest + | [] -> { async; uncurried; attributes = List.rev acc } + | ({ Location.txt = "bs" }, _) :: rest -> process async true acc rest + | ({ Location.txt = "res.async" }, _) :: rest -> + process true uncurried acc rest | attr :: rest -> process async uncurried (attr :: acc) rest in process false false [] attrs let hasAwaitAttribute attrs = List.exists - (function - | {Location.txt = "res.await"}, _ -> true - | _ -> false) + (function { Location.txt = "res.await" }, _ -> true | _ -> false) attrs let collectListExpressions expr = let rec collect acc expr = match expr.pexp_desc with - | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> (List.rev acc, None) + | Pexp_construct ({ txt = Longident.Lident "[]" }, _) -> (List.rev acc, None) | Pexp_construct - ( {txt = Longident.Lident "::"}, - Some {pexp_desc = Pexp_tuple (hd :: [tail])} ) -> - collect (hd :: acc) tail + ( { txt = Longident.Lident "::" }, + Some { pexp_desc = Pexp_tuple (hd :: [ tail ]) } ) -> + collect (hd :: acc) tail | _ -> (List.rev acc, Some expr) in collect [] expr @@ -49370,42 +49443,48 @@ let rewriteUnderscoreApply expr = | Pexp_fun ( Nolabel, None, - {ppat_desc = Ppat_var {txt = "__x"}}, - ({pexp_desc = Pexp_apply (callExpr, args)} as e) ) -> - let newArgs = - List.map - (fun arg -> - match arg with - | ( lbl, - ({pexp_desc = Pexp_ident ({txt = Longident.Lident "__x"} as lid)} - as argExpr) ) -> - ( lbl, - { - argExpr with - pexp_desc = Pexp_ident {lid with txt = Longident.Lident "_"}; - } ) - | arg -> arg) - args - in - {e with pexp_desc = Pexp_apply (callExpr, newArgs)} + { ppat_desc = Ppat_var { txt = "__x" } }, + ({ pexp_desc = Pexp_apply (callExpr, args) } as e) ) -> + let newArgs = + List.map + (fun arg -> + match arg with + | ( lbl, + ({ + pexp_desc = + Pexp_ident ({ txt = Longident.Lident "__x" } as lid); + } as argExpr) ) -> + ( lbl, + { + argExpr with + pexp_desc = + Pexp_ident { lid with txt = Longident.Lident "_" }; + } ) + | arg -> arg) + args + in + { e with pexp_desc = Pexp_apply (callExpr, newArgs) } | _ -> expr type funParamKind = | Parameter of { - attrs: Parsetree.attributes; - lbl: Asttypes.arg_label; - defaultExpr: Parsetree.expression option; - pat: Parsetree.pattern; + attrs : Parsetree.attributes; + lbl : Asttypes.arg_label; + defaultExpr : Parsetree.expression option; + pat : Parsetree.pattern; + } + | NewTypes of { + attrs : Parsetree.attributes; + locs : string Asttypes.loc list; } - | NewTypes of {attrs: Parsetree.attributes; locs: string Asttypes.loc list} let funExpr expr = (* Turns (type t, type u, type z) into "type t u z" *) let rec collectNewTypes acc returnExpr = match returnExpr with - | {pexp_desc = Pexp_newtype (stringLoc, returnExpr); pexp_attributes = []} + | { pexp_desc = Pexp_newtype (stringLoc, returnExpr); pexp_attributes = [] } -> - collectNewTypes (stringLoc :: acc) returnExpr + collectNewTypes (stringLoc :: acc) returnExpr | returnExpr -> (List.rev acc, returnExpr) in let rec collect n attrsBefore acc expr = @@ -49415,43 +49494,48 @@ let funExpr expr = Pexp_fun ( Nolabel, None, - {ppat_desc = Ppat_var {txt = "__x"}}, - {pexp_desc = Pexp_apply _} ); + { ppat_desc = Ppat_var { txt = "__x" } }, + { pexp_desc = Pexp_apply _ } ); } -> - (attrsBefore, List.rev acc, rewriteUnderscoreApply expr) + (attrsBefore, List.rev acc, rewriteUnderscoreApply expr) | { pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr); pexp_attributes = []; } -> - let parameter = Parameter {attrs = []; lbl; defaultExpr; pat = pattern} in - collect (n + 1) attrsBefore (parameter :: acc) returnExpr - | {pexp_desc = Pexp_newtype (stringLoc, rest); pexp_attributes = attrs} -> - let stringLocs, returnExpr = collectNewTypes [stringLoc] rest in - let param = NewTypes {attrs; locs = stringLocs} in - collect (n + 1) attrsBefore (param :: acc) returnExpr - | {pexp_desc = Pexp_fun _; pexp_attributes} + let parameter = + Parameter { attrs = []; lbl; defaultExpr; pat = pattern } + in + collect (n + 1) attrsBefore (parameter :: acc) returnExpr + | { pexp_desc = Pexp_newtype (stringLoc, rest); pexp_attributes = attrs } -> + let stringLocs, returnExpr = collectNewTypes [ stringLoc ] rest in + let param = NewTypes { attrs; locs = stringLocs } in + collect (n + 1) attrsBefore (param :: acc) returnExpr + | { pexp_desc = Pexp_fun _; pexp_attributes } when pexp_attributes - |> List.exists (fun ({Location.txt}, _) -> + |> List.exists (fun ({ Location.txt }, _) -> txt = "bs" || txt = "res.async") && n > 0 -> - (* stop here, the uncurried or async attribute always indicates the beginning of an arrow function - * e.g. `(. a) => (. b)` instead of `(. a, . b)` *) - (attrsBefore, List.rev acc, expr) + (* stop here, the uncurried or async attribute always indicates the beginning of an arrow function + * e.g. `(. a) => (. b)` instead of `(. a, . b)` *) + (attrsBefore, List.rev acc, expr) | { pexp_desc = Pexp_fun (((Labelled _ | Optional _) as lbl), defaultExpr, pattern, returnExpr); pexp_attributes = attrs; } -> - (* Normally attributes are attached to the labelled argument, e.g. (@foo ~x) => ... - In the case of `@res.async`, pass the attribute to the outside *) - let attrs_async, attrs_other = - attrs |> List.partition (fun ({Location.txt}, _) -> txt = "res.async") - in - let parameter = - Parameter {attrs = attrs_other; lbl; defaultExpr; pat = pattern} - in - collect (n + 1) (attrs_async @ attrsBefore) (parameter :: acc) returnExpr + (* Normally attributes are attached to the labelled argument, e.g. (@foo ~x) => ... + In the case of `@res.async`, pass the attribute to the outside *) + let attrs_async, attrs_other = + attrs + |> List.partition (fun ({ Location.txt }, _) -> txt = "res.async") + in + let parameter = + Parameter { attrs = attrs_other; lbl; defaultExpr; pat = pattern } + in + collect (n + 1) + (attrs_async @ attrsBefore) + (parameter :: acc) returnExpr | expr -> (attrsBefore, List.rev acc, expr) in match expr with @@ -49459,13 +49543,13 @@ let funExpr expr = pexp_desc = Pexp_fun (Nolabel, _defaultExpr, _pattern, _returnExpr); pexp_attributes = attrs; } as expr -> - collect 0 attrs [] {expr with pexp_attributes = []} + collect 0 attrs [] { expr with pexp_attributes = [] } | expr -> collect 0 [] [] expr let processBracesAttr expr = match expr.pexp_attributes with - | (({txt = "ns.braces"}, _) as attr) :: attrs -> - (Some attr, {expr with pexp_attributes = attrs}) + | (({ txt = "ns.braces" }, _) as attr) :: attrs -> + (Some attr, { expr with pexp_attributes = attrs }) | _ -> (None, expr) let filterParsingAttrs attrs = @@ -49479,7 +49563,7 @@ let filterParsingAttrs attrs = | "res.template" ); }, _ ) -> - false + false | _ -> true) attrs @@ -49487,13 +49571,11 @@ let isBlockExpr expr = match expr.pexp_desc with | Pexp_letmodule _ | Pexp_letexception _ | Pexp_let _ | Pexp_open _ | Pexp_sequence _ -> - true + true | _ -> false let isBracedExpr expr = - match processBracesAttr expr with - | Some _, _ -> true - | _ -> false + match processBracesAttr expr with Some _, _ -> true | _ -> false let isMultilineText txt = let len = String.length txt in @@ -49512,10 +49594,10 @@ let isHuggableExpression expr = match expr.pexp_desc with | Pexp_array _ | Pexp_tuple _ | Pexp_constant (Pconst_string (_, Some _)) - | Pexp_construct ({txt = Longident.Lident ("::" | "[]")}, _) - | Pexp_extension ({txt = "bs.obj" | "obj"}, _) + | Pexp_construct ({ txt = Longident.Lident ("::" | "[]") }, _) + | Pexp_extension ({ txt = "bs.obj" | "obj" }, _) | Pexp_record _ -> - true + true | _ when isBlockExpr expr -> true | _ when isBracedExpr expr -> true | Pexp_constant (Pconst_string (txt, None)) when isMultilineText txt -> true @@ -49524,9 +49606,9 @@ let isHuggableExpression expr = let isHuggableRhs expr = match expr.pexp_desc with | Pexp_array _ | Pexp_tuple _ - | Pexp_extension ({txt = "bs.obj" | "obj"}, _) + | Pexp_extension ({ txt = "bs.obj" | "obj" }, _) | Pexp_record _ -> - true + true | _ when isBracedExpr expr -> true | _ -> false @@ -49534,7 +49616,7 @@ let isHuggablePattern pattern = match pattern.ppat_desc with | Ppat_array _ | Ppat_tuple _ | Ppat_record _ | Ppat_variant _ | Ppat_construct _ -> - true + true | _ -> false let operatorPrecedence operator = @@ -49550,17 +49632,15 @@ let operatorPrecedence operator = | _ -> 0 let isUnaryOperator operator = - match operator with - | "~+" | "~+." | "~-" | "~-." | "not" -> true - | _ -> false + match operator with "~+" | "~+." | "~-" | "~-." | "not" -> true | _ -> false let isUnaryExpression expr = match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [(Nolabel, _arg)] ) + ( { pexp_desc = Pexp_ident { txt = Longident.Lident operator } }, + [ (Nolabel, _arg) ] ) when isUnaryOperator operator -> - true + true | _ -> false (* TODO: tweak this to check for ghost ^ as template literal *) @@ -49569,7 +49649,7 @@ let isBinaryOperator operator = | ":=" | "||" | "&&" | "=" | "==" | "<" | ">" | "!=" | "!==" | "<=" | ">=" | "|>" | "+" | "+." | "-" | "-." | "^" | "*" | "*." | "/" | "/." | "**" | "|." | "<>" -> - true + true | _ -> false let isBinaryExpression expr = @@ -49577,19 +49657,17 @@ let isBinaryExpression expr = | Pexp_apply ( { pexp_desc = - Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}; + Pexp_ident { txt = Longident.Lident operator; loc = operatorLoc }; }, - [(Nolabel, _operand1); (Nolabel, _operand2)] ) + [ (Nolabel, _operand1); (Nolabel, _operand2) ] ) when isBinaryOperator operator && not (operatorLoc.loc_ghost && operator = "^") (* template literal *) -> - true + true | _ -> false let isEqualityOperator operator = - match operator with - | "=" | "==" | "<>" | "!=" -> true - | _ -> false + match operator with "=" | "==" | "<>" | "!=" -> true | _ -> false let flattenableOperators parentOperator childOperator = let precParent = operatorPrecedence parentOperator in @@ -49601,20 +49679,20 @@ let flattenableOperators parentOperator childOperator = let rec hasIfLetAttribute attrs = match attrs with | [] -> false - | ({Location.txt = "ns.iflet"}, _) :: _ -> true + | ({ Location.txt = "ns.iflet" }, _) :: _ -> true | _ :: attrs -> hasIfLetAttribute attrs let isIfLetExpr expr = match expr with - | {pexp_attributes = attrs; pexp_desc = Pexp_match _} + | { pexp_attributes = attrs; pexp_desc = Pexp_match _ } when hasIfLetAttribute attrs -> - true + true | _ -> false let rec hasOptionalAttribute attrs = match attrs with | [] -> false - | ({Location.txt = "ns.optional"}, _) :: _ -> true + | ({ Location.txt = "ns.optional" }, _) :: _ -> true | _ :: attrs -> hasOptionalAttribute attrs let hasAttributes attrs = @@ -49627,27 +49705,30 @@ let hasAttributes attrs = | "res.await" | "res.template" ); }, _ ) -> - false + false (* Remove the fragile pattern warning for iflet expressions *) - | ( {Location.txt = "warning"}, + | ( { Location.txt = "warning" }, PStr [ { pstr_desc = Pstr_eval - ({pexp_desc = Pexp_constant (Pconst_string ("-4", None))}, _); + ( { pexp_desc = Pexp_constant (Pconst_string ("-4", None)) }, + _ ); }; ] ) -> - not (hasIfLetAttribute attrs) + not (hasIfLetAttribute attrs) | _ -> true) attrs let isArrayAccess expr = match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "get")}}, - [(Nolabel, _parentExpr); (Nolabel, _memberExpr)] ) -> - true + ( { + pexp_desc = Pexp_ident { txt = Longident.Ldot (Lident "Array", "get") }; + }, + [ (Nolabel, _parentExpr); (Nolabel, _memberExpr) ] ) -> + true | _ -> false type ifConditionKind = @@ -49659,32 +49740,36 @@ let collectIfExpressions expr = let exprLoc = expr.pexp_loc in match expr.pexp_desc with | Pexp_ifthenelse (ifExpr, thenExpr, Some elseExpr) -> - collect ((exprLoc, If ifExpr, thenExpr) :: acc) elseExpr + collect ((exprLoc, If ifExpr, thenExpr) :: acc) elseExpr | Pexp_ifthenelse (ifExpr, thenExpr, (None as elseExpr)) -> - let ifs = List.rev ((exprLoc, If ifExpr, thenExpr) :: acc) in - (ifs, elseExpr) + let ifs = List.rev ((exprLoc, If ifExpr, thenExpr) :: acc) in + (ifs, elseExpr) | Pexp_match ( condition, [ - {pc_lhs = pattern; pc_guard = None; pc_rhs = thenExpr}; + { pc_lhs = pattern; pc_guard = None; pc_rhs = thenExpr }; { pc_rhs = - {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)}; + { + pexp_desc = Pexp_construct ({ txt = Longident.Lident "()" }, _); + }; }; ] ) when isIfLetExpr expr -> - let ifs = - List.rev ((exprLoc, IfLet (pattern, condition), thenExpr) :: acc) - in - (ifs, None) + let ifs = + List.rev ((exprLoc, IfLet (pattern, condition), thenExpr) :: acc) + in + (ifs, None) | Pexp_match ( condition, [ - {pc_lhs = pattern; pc_guard = None; pc_rhs = thenExpr}; - {pc_rhs = elseExpr}; + { pc_lhs = pattern; pc_guard = None; pc_rhs = thenExpr }; + { pc_rhs = elseExpr }; ] ) when isIfLetExpr expr -> - collect ((exprLoc, IfLet (pattern, condition), thenExpr) :: acc) elseExpr + collect + ((exprLoc, IfLet (pattern, condition), thenExpr) :: acc) + elseExpr | _ -> (List.rev acc, Some expr) in collect [] expr @@ -49692,14 +49777,14 @@ let collectIfExpressions expr = let rec hasTernaryAttribute attrs = match attrs with | [] -> false - | ({Location.txt = "ns.ternary"}, _) :: _ -> true + | ({ Location.txt = "ns.ternary" }, _) :: _ -> true | _ :: attrs -> hasTernaryAttribute attrs let isTernaryExpr expr = match expr with - | {pexp_attributes = attrs; pexp_desc = Pexp_ifthenelse _} + | { pexp_attributes = attrs; pexp_desc = Pexp_ifthenelse _ } when hasTernaryAttribute attrs -> - true + true | _ -> false let collectTernaryParts expr = @@ -49710,40 +49795,40 @@ let collectTernaryParts expr = pexp_desc = Pexp_ifthenelse (condition, consequent, Some alternate); } when hasTernaryAttribute attrs -> - collect ((condition, consequent) :: acc) alternate + collect ((condition, consequent) :: acc) alternate | alternate -> (List.rev acc, alternate) in collect [] expr let parametersShouldHug parameters = match parameters with - | [Parameter {attrs = []; lbl = Asttypes.Nolabel; defaultExpr = None; pat}] + | [ + Parameter { attrs = []; lbl = Asttypes.Nolabel; defaultExpr = None; pat }; + ] when isHuggablePattern pat -> - true + true | _ -> false let filterTernaryAttributes attrs = List.filter (fun attr -> - match attr with - | {Location.txt = "ns.ternary"}, _ -> false - | _ -> true) + match attr with { Location.txt = "ns.ternary" }, _ -> false | _ -> true) attrs let filterFragileMatchAttributes attrs = List.filter (fun attr -> match attr with - | ( {Location.txt = "warning"}, + | ( { Location.txt = "warning" }, PStr [ { pstr_desc = Pstr_eval - ({pexp_desc = Pexp_constant (Pconst_string ("-4", _))}, _); + ({ pexp_desc = Pexp_constant (Pconst_string ("-4", _)) }, _); }; ] ) -> - false + false | _ -> true) attrs @@ -49751,7 +49836,7 @@ let isJsxExpression expr = let rec loop attrs = match attrs with | [] -> false - | ({Location.txt = "JSX"}, _) :: _ -> true + | ({ Location.txt = "JSX" }, _) :: _ -> true | _ :: attrs -> loop attrs in match expr.pexp_desc with @@ -49762,7 +49847,7 @@ let hasJsxAttribute attributes = let rec loop attrs = match attrs with | [] -> false - | ({Location.txt = "JSX"}, _) :: _ -> true + | ({ Location.txt = "JSX" }, _) :: _ -> true | _ :: attrs -> loop attrs in loop attributes @@ -49773,24 +49858,24 @@ let shouldIndentBinaryExpr expr = | { pexp_desc = Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident subOperator}}, - [(Nolabel, _lhs); (Nolabel, _rhs)] ); + ( { pexp_desc = Pexp_ident { txt = Longident.Lident subOperator } }, + [ (Nolabel, _lhs); (Nolabel, _rhs) ] ); } when isBinaryOperator subOperator -> - flattenableOperators operator subOperator + flattenableOperators operator subOperator | _ -> true in match expr with | { pexp_desc = Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [(Nolabel, lhs); (Nolabel, _rhs)] ); + ( { pexp_desc = Pexp_ident { txt = Longident.Lident operator } }, + [ (Nolabel, lhs); (Nolabel, _rhs) ] ); } when isBinaryOperator operator -> - isEqualityOperator operator - || (not (samePrecedenceSubExpression operator lhs)) - || operator = ":=" + isEqualityOperator operator + || (not (samePrecedenceSubExpression operator lhs)) + || operator = ":=" | _ -> false let shouldInlineRhsBinaryExpr rhs = @@ -49798,7 +49883,7 @@ let shouldInlineRhsBinaryExpr rhs = | Parsetree.Pexp_constant _ | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ | Pexp_sequence _ | Pexp_open _ | Pexp_ifthenelse _ | Pexp_for _ | Pexp_while _ | Pexp_try _ | Pexp_array _ | Pexp_record _ -> - true + true | _ -> false let isPrintableAttribute attr = @@ -49809,11 +49894,10 @@ let isPrintableAttribute attr = | "res.template" | "ns.ternary" ); }, _ ) -> - false + false | _ -> true let hasPrintableAttributes attrs = List.exists isPrintableAttribute attrs - let filterPrintableAttributes attrs = List.filter isPrintableAttribute attrs let partitionPrintableAttributes attrs = @@ -49823,8 +49907,8 @@ let requiresSpecialCallbackPrintingLastArg args = let rec loop args = match args with | [] -> false - | [(_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})] -> true - | (_, {pexp_desc = Pexp_fun _ | Pexp_newtype _}) :: _ -> false + | [ (_, { pexp_desc = Pexp_fun _ | Pexp_newtype _ }) ] -> true + | (_, { pexp_desc = Pexp_fun _ | Pexp_newtype _ }) :: _ -> false | _ :: rest -> loop rest in loop args @@ -49833,18 +49917,18 @@ let requiresSpecialCallbackPrintingFirstArg args = let rec loop args = match args with | [] -> true - | (_, {pexp_desc = Pexp_fun _ | Pexp_newtype _}) :: _ -> false + | (_, { pexp_desc = Pexp_fun _ | Pexp_newtype _ }) :: _ -> false | _ :: rest -> loop rest in match args with - | [(_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})] -> false - | (_, {pexp_desc = Pexp_fun _ | Pexp_newtype _}) :: rest -> loop rest + | [ (_, { pexp_desc = Pexp_fun _ | Pexp_newtype _ }) ] -> false + | (_, { pexp_desc = Pexp_fun _ | Pexp_newtype _ }) :: rest -> loop rest | _ -> false let modExprApply modExpr = let rec loop acc modExpr = match modExpr with - | {pmod_desc = Pmod_apply (next, arg)} -> loop (arg :: acc) next + | { pmod_desc = Pmod_apply (next, arg) } -> loop (arg :: acc) next | _ -> (acc, modExpr) in loop [] modExpr @@ -49856,8 +49940,8 @@ let modExprFunctor modExpr = pmod_desc = Pmod_functor (lbl, modType, returnModExpr); pmod_attributes = attrs; } -> - let param = (attrs, lbl, modType) in - loop (param :: acc) returnModExpr + let param = (attrs, lbl, modType) in + loop (param :: acc) returnModExpr | returnModExpr -> (List.rev acc, returnModExpr) in loop [] modExpr @@ -49866,26 +49950,26 @@ let rec collectPatternsFromListConstruct acc pattern = let open Parsetree in match pattern.ppat_desc with | Ppat_construct - ({txt = Longident.Lident "::"}, Some {ppat_desc = Ppat_tuple [pat; rest]}) - -> - collectPatternsFromListConstruct (pat :: acc) rest + ( { txt = Longident.Lident "::" }, + Some { ppat_desc = Ppat_tuple [ pat; rest ] } ) -> + collectPatternsFromListConstruct (pat :: acc) rest | _ -> (List.rev acc, pattern) let hasTemplateLiteralAttr attrs = List.exists (fun attr -> match attr with - | {Location.txt = "res.template"}, _ -> true + | { Location.txt = "res.template" }, _ -> true | _ -> false) attrs let isTemplateLiteral expr = match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident "^"}}, - [(Nolabel, _); (Nolabel, _)] ) + ( { pexp_desc = Pexp_ident { txt = Longident.Lident "^" } }, + [ (Nolabel, _); (Nolabel, _) ] ) when hasTemplateLiteralAttr expr.pexp_attributes -> - true + true | Pexp_constant (Pconst_string (_, Some "")) -> true | Pexp_constant _ when hasTemplateLiteralAttr expr.pexp_attributes -> true | _ -> false @@ -49893,9 +49977,7 @@ let isTemplateLiteral expr = let hasSpreadAttr attrs = List.exists (fun attr -> - match attr with - | {Location.txt = "res.spread"}, _ -> true - | _ -> false) + match attr with { Location.txt = "res.spread" }, _ -> true | _ -> false) attrs let isSpreadBeltListConcat expr = @@ -49906,7 +49988,7 @@ let isSpreadBeltListConcat expr = Longident.Ldot (Longident.Ldot (Longident.Lident "Belt", "List"), "concatMany"); } -> - hasSpreadAttr expr.pexp_attributes + hasSpreadAttr expr.pexp_attributes | _ -> false (* Blue | Red | Green -> [Blue; Red; Green] *) @@ -49934,17 +50016,17 @@ let isSinglePipeExpr expr = let isPipeExpr expr = match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident ("|." | "|>")}}, - [(Nolabel, _operand1); (Nolabel, _operand2)] ) -> - true + ( { pexp_desc = Pexp_ident { txt = Longident.Lident ("|." | "|>") } }, + [ (Nolabel, _operand1); (Nolabel, _operand2) ] ) -> + true | _ -> false in match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident ("|." | "|>")}}, - [(Nolabel, operand1); (Nolabel, _operand2)] ) + ( { pexp_desc = Pexp_ident { txt = Longident.Lident ("|." | "|>") } }, + [ (Nolabel, operand1); (Nolabel, _operand2) ] ) when not (isPipeExpr operand1) -> - true + true | _ -> false let isUnderscoreApplySugar expr = @@ -49952,14 +50034,14 @@ let isUnderscoreApplySugar expr = | Pexp_fun ( Nolabel, None, - {ppat_desc = Ppat_var {txt = "__x"}}, - {pexp_desc = Pexp_apply _} ) -> - true + { ppat_desc = Ppat_var { txt = "__x" } }, + { pexp_desc = Pexp_apply _ } ) -> + true | _ -> false let isRewrittenUnderscoreApplySugar expr = match expr.pexp_desc with - | Pexp_ident {txt = Longident.Lident "_"} -> true + | Pexp_ident { txt = Longident.Lident "_" } -> true | _ -> false end @@ -49971,9 +50053,9 @@ module Doc = Res_doc module ParsetreeViewer = Res_parsetree_viewer type t = { - leading: (Location.t, Comment.t list) Hashtbl.t; - inside: (Location.t, Comment.t list) Hashtbl.t; - trailing: (Location.t, Comment.t list) Hashtbl.t; + leading : (Location.t, Comment.t list) Hashtbl.t; + inside : (Location.t, Comment.t list) Hashtbl.t; + trailing : (Location.t, Comment.t list) Hashtbl.t; } let make () = @@ -50021,7 +50103,7 @@ let printEntries tbl = [ Doc.line; Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) (List.map (fun c -> Doc.text (Comment.txt c)) v); ]); Doc.line; @@ -50038,33 +50120,31 @@ let log t = (Doc.concat [ Doc.text "leading comments:"; - Doc.indent (Doc.concat [Doc.line; Doc.concat leadingStuff]); + Doc.indent (Doc.concat [ Doc.line; Doc.concat leadingStuff ]); Doc.line; Doc.text "comments inside:"; - Doc.indent (Doc.concat [Doc.line; Doc.concat stuffInside]); + Doc.indent (Doc.concat [ Doc.line; Doc.concat stuffInside ]); Doc.line; Doc.text "trailing comments:"; - Doc.indent (Doc.concat [Doc.line; Doc.concat trailingStuff]); + Doc.indent (Doc.concat [ Doc.line; Doc.concat trailingStuff ]); Doc.line; ]) |> Doc.toString ~width:80 |> print_endline let attach tbl loc comments = - match comments with - | [] -> () - | comments -> Hashtbl.replace tbl loc comments + match comments with [] -> () | comments -> Hashtbl.replace tbl loc comments let partitionByLoc comments loc = let rec loop (leading, inside, trailing) comments = let open Location in match comments with | comment :: rest -> - let cmtLoc = Comment.loc comment in - if cmtLoc.loc_end.pos_cnum <= loc.loc_start.pos_cnum then - loop (comment :: leading, inside, trailing) rest - else if cmtLoc.loc_start.pos_cnum >= loc.loc_end.pos_cnum then - loop (leading, inside, comment :: trailing) rest - else loop (leading, comment :: inside, trailing) rest + let cmtLoc = Comment.loc comment in + if cmtLoc.loc_end.pos_cnum <= loc.loc_start.pos_cnum then + loop (comment :: leading, inside, trailing) rest + else if cmtLoc.loc_start.pos_cnum >= loc.loc_end.pos_cnum then + loop (leading, inside, comment :: trailing) rest + else loop (leading, comment :: inside, trailing) rest | [] -> (List.rev leading, List.rev inside, List.rev trailing) in loop ([], [], []) comments @@ -50074,10 +50154,10 @@ let partitionLeadingTrailing comments loc = let open Location in match comments with | comment :: rest -> - let cmtLoc = Comment.loc comment in - if cmtLoc.loc_end.pos_cnum <= loc.loc_start.pos_cnum then - loop (comment :: leading, trailing) rest - else loop (leading, comment :: trailing) rest + let cmtLoc = Comment.loc comment in + if cmtLoc.loc_end.pos_cnum <= loc.loc_start.pos_cnum then + loop (comment :: leading, trailing) rest + else loop (leading, comment :: trailing) rest | [] -> (List.rev leading, List.rev trailing) in loop ([], []) comments @@ -50088,10 +50168,10 @@ let partitionByOnSameLine loc comments = match comments with | [] -> (List.rev onSameLine, List.rev onOtherLine) | comment :: rest -> - let cmtLoc = Comment.loc comment in - if cmtLoc.loc_start.pos_lnum == loc.loc_end.pos_lnum then - loop (comment :: onSameLine, onOtherLine) rest - else loop (onSameLine, comment :: onOtherLine) rest + let cmtLoc = Comment.loc comment in + if cmtLoc.loc_start.pos_lnum == loc.loc_end.pos_lnum then + loop (comment :: onSameLine, onOtherLine) rest + else loop (onSameLine, comment :: onOtherLine) rest in loop ([], []) comments @@ -50102,11 +50182,11 @@ let partitionAdjacentTrailing loc1 comments = match comments with | [] -> (List.rev afterLoc1, []) | comment :: rest as comments -> - let cmtPrevEndPos = Comment.prevTokEndPos comment in - if prevEndPos.Lexing.pos_cnum == cmtPrevEndPos.pos_cnum then - let commentEnd = (Comment.loc comment).loc_end in - loop ~prevEndPos:commentEnd (comment :: afterLoc1) rest - else (List.rev afterLoc1, comments) + let cmtPrevEndPos = Comment.prevTokEndPos comment in + if prevEndPos.Lexing.pos_cnum == cmtPrevEndPos.pos_cnum then + let commentEnd = (Comment.loc comment).loc_end in + loop ~prevEndPos:commentEnd (comment :: afterLoc1) rest + else (List.rev afterLoc1, comments) in loop ~prevEndPos:loc1.loc_end [] comments @@ -50114,20 +50194,20 @@ let rec collectListPatterns acc pattern = let open Parsetree in match pattern.ppat_desc with | Ppat_construct - ({txt = Longident.Lident "::"}, Some {ppat_desc = Ppat_tuple [pat; rest]}) - -> - collectListPatterns (pat :: acc) rest - | Ppat_construct ({txt = Longident.Lident "[]"}, None) -> List.rev acc + ( { txt = Longident.Lident "::" }, + Some { ppat_desc = Ppat_tuple [ pat; rest ] } ) -> + collectListPatterns (pat :: acc) rest + | Ppat_construct ({ txt = Longident.Lident "[]" }, None) -> List.rev acc | _ -> List.rev (pattern :: acc) let rec collectListExprs acc expr = let open Parsetree in match expr.pexp_desc with | Pexp_construct - ({txt = Longident.Lident "::"}, Some {pexp_desc = Pexp_tuple [expr; rest]}) - -> - collectListExprs (expr :: acc) rest - | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> List.rev acc + ( { txt = Longident.Lident "::" }, + Some { pexp_desc = Pexp_tuple [ expr; rest ] } ) -> + collectListExprs (expr :: acc) rest + | Pexp_construct ({ txt = Longident.Lident "[]" }, _) -> List.rev acc | _ -> List.rev (expr :: acc) (* TODO: use ParsetreeViewer *) @@ -50139,37 +50219,39 @@ let arrowType ct = ptyp_desc = Ptyp_arrow ((Nolabel as lbl), typ1, typ2); ptyp_attributes = []; } -> - let arg = ([], lbl, typ1) in - process attrsBefore (arg :: acc) typ2 + let arg = ([], lbl, typ1) in + process attrsBefore (arg :: acc) typ2 | { ptyp_desc = Ptyp_arrow ((Nolabel as lbl), typ1, typ2); - ptyp_attributes = [({txt = "bs"}, _)] as attrs; + ptyp_attributes = [ ({ txt = "bs" }, _) ] as attrs; } -> - let arg = (attrs, lbl, typ1) in - process attrsBefore (arg :: acc) typ2 - | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = _attrs} - as returnType -> - let args = List.rev acc in - (attrsBefore, args, returnType) + let arg = (attrs, lbl, typ1) in + process attrsBefore (arg :: acc) typ2 + | { + ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); + ptyp_attributes = _attrs; + } as returnType -> + let args = List.rev acc in + (attrsBefore, args, returnType) | { ptyp_desc = Ptyp_arrow (((Labelled _ | Optional _) as lbl), typ1, typ2); ptyp_attributes = attrs; } -> - let arg = (attrs, lbl, typ1) in - process attrsBefore (arg :: acc) typ2 + let arg = (attrs, lbl, typ1) in + process attrsBefore (arg :: acc) typ2 | typ -> (attrsBefore, List.rev acc, typ) in match ct with - | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = attrs} as - typ -> - process attrs [] {typ with ptyp_attributes = []} + | { ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = attrs } + as typ -> + process attrs [] { typ with ptyp_attributes = [] } | typ -> process [] [] typ (* TODO: avoiding the dependency on ParsetreeViewer here, is this a good idea? *) let modExprApply modExpr = let rec loop acc modExpr = match modExpr with - | {Parsetree.pmod_desc = Pmod_apply (next, arg)} -> loop (arg :: acc) next + | { Parsetree.pmod_desc = Pmod_apply (next, arg) } -> loop (arg :: acc) next | _ -> modExpr :: acc in loop [] modExpr @@ -50182,8 +50264,8 @@ let modExprFunctor modExpr = Parsetree.pmod_desc = Pmod_functor (lbl, modType, returnModExpr); pmod_attributes = attrs; } -> - let param = (attrs, lbl, modType) in - loop (param :: acc) returnModExpr + let param = (attrs, lbl, modType) in + loop (param :: acc) returnModExpr | returnModExpr -> (List.rev acc, returnModExpr) in loop [] modExpr @@ -50195,8 +50277,8 @@ let functorType modtype = Parsetree.pmty_desc = Pmty_functor (lbl, argType, returnType); pmty_attributes = attrs; } -> - let arg = (attrs, lbl, argType) in - process (arg :: acc) returnType + let arg = (attrs, lbl, argType) in + process (arg :: acc) returnType | modType -> (List.rev acc, modType) in process [] modtype @@ -50206,22 +50288,22 @@ let funExpr expr = (* Turns (type t, type u, type z) into "type t u z" *) let rec collectNewTypes acc returnExpr = match returnExpr with - | {pexp_desc = Pexp_newtype (stringLoc, returnExpr); pexp_attributes = []} + | { pexp_desc = Pexp_newtype (stringLoc, returnExpr); pexp_attributes = [] } -> - collectNewTypes (stringLoc :: acc) returnExpr + collectNewTypes (stringLoc :: acc) returnExpr | returnExpr -> - let loc = - match (acc, List.rev acc) with - | _startLoc :: _, endLoc :: _ -> - {endLoc.loc with loc_end = endLoc.loc.loc_end} - | _ -> Location.none - in - let txt = - List.fold_right - (fun curr acc -> acc ^ " " ^ curr.Location.txt) - acc "type" - in - (Location.mkloc txt loc, returnExpr) + let loc = + match (acc, List.rev acc) with + | _startLoc :: _, endLoc :: _ -> + { endLoc.loc with loc_end = endLoc.loc.loc_end } + | _ -> Location.none + in + let txt = + List.fold_right + (fun curr acc -> acc ^ " " ^ curr.Location.txt) + acc "type" + in + (Location.mkloc txt loc, returnExpr) in (* For simplicity reason Pexp_newtype gets converted to a Nolabel parameter, * otherwise this function would need to return a variant: @@ -50235,31 +50317,31 @@ let funExpr expr = pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr); pexp_attributes = []; } -> - let parameter = ([], lbl, defaultExpr, pattern) in - collect attrsBefore (parameter :: acc) returnExpr - | {pexp_desc = Pexp_newtype (stringLoc, rest); pexp_attributes = attrs} -> - let var, returnExpr = collectNewTypes [stringLoc] rest in - let parameter = - ( attrs, - Asttypes.Nolabel, - None, - Ast_helper.Pat.var ~loc:stringLoc.loc var ) - in - collect attrsBefore (parameter :: acc) returnExpr + let parameter = ([], lbl, defaultExpr, pattern) in + collect attrsBefore (parameter :: acc) returnExpr + | { pexp_desc = Pexp_newtype (stringLoc, rest); pexp_attributes = attrs } -> + let var, returnExpr = collectNewTypes [ stringLoc ] rest in + let parameter = + ( attrs, + Asttypes.Nolabel, + None, + Ast_helper.Pat.var ~loc:stringLoc.loc var ) + in + collect attrsBefore (parameter :: acc) returnExpr | { pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr); - pexp_attributes = [({txt = "bs"}, _)] as attrs; + pexp_attributes = [ ({ txt = "bs" }, _) ] as attrs; } -> - let parameter = (attrs, lbl, defaultExpr, pattern) in - collect attrsBefore (parameter :: acc) returnExpr + let parameter = (attrs, lbl, defaultExpr, pattern) in + collect attrsBefore (parameter :: acc) returnExpr | { pexp_desc = Pexp_fun (((Labelled _ | Optional _) as lbl), defaultExpr, pattern, returnExpr); pexp_attributes = attrs; } -> - let parameter = (attrs, lbl, defaultExpr, pattern) in - collect attrsBefore (parameter :: acc) returnExpr + let parameter = (attrs, lbl, defaultExpr, pattern) in + collect attrsBefore (parameter :: acc) returnExpr | expr -> (attrsBefore, List.rev acc, expr) in match expr with @@ -50267,7 +50349,7 @@ let funExpr expr = pexp_desc = Pexp_fun (Nolabel, _defaultExpr, _pattern, _returnExpr); pexp_attributes = attrs; } as expr -> - collect attrs [] {expr with pexp_attributes = []} + collect attrs [] { expr with pexp_attributes = [] } | expr -> collect [] [] expr let rec isBlockExpr expr = @@ -50275,7 +50357,7 @@ let rec isBlockExpr expr = match expr.pexp_desc with | Pexp_letmodule _ | Pexp_letexception _ | Pexp_let _ | Pexp_open _ | Pexp_sequence _ -> - true + true | Pexp_apply (callExpr, _) when isBlockExpr callExpr -> true | Pexp_constraint (expr, _) when isBlockExpr expr -> true | Pexp_field (expr, _) when isBlockExpr expr -> true @@ -50284,9 +50366,7 @@ let rec isBlockExpr expr = let isIfThenElseExpr expr = let open Parsetree in - match expr.pexp_desc with - | Pexp_ifthenelse _ -> true - | _ -> false + match expr.pexp_desc with Pexp_ifthenelse _ -> true | _ -> false type node = | Case of Parsetree.case @@ -50313,35 +50393,35 @@ let getLoc node = let open Parsetree in match node with | Case case -> - {case.pc_lhs.ppat_loc with loc_end = case.pc_rhs.pexp_loc.loc_end} + { case.pc_lhs.ppat_loc with loc_end = case.pc_rhs.pexp_loc.loc_end } | CoreType ct -> ct.ptyp_loc | ExprArgument expr -> ( - match expr.Parsetree.pexp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _attrs -> - {loc with loc_end = expr.pexp_loc.loc_end} - | _ -> expr.pexp_loc) + match expr.Parsetree.pexp_attributes with + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _attrs -> + { loc with loc_end = expr.pexp_loc.loc_end } + | _ -> expr.pexp_loc) | Expression e -> ( - match e.pexp_attributes with - | ({txt = "ns.braces"; loc}, _) :: _ -> loc - | _ -> e.pexp_loc) - | ExprRecordRow (li, e) -> {li.loc with loc_end = e.pexp_loc.loc_end} + match e.pexp_attributes with + | ({ txt = "ns.braces"; loc }, _) :: _ -> loc + | _ -> e.pexp_loc) + | ExprRecordRow (li, e) -> { li.loc with loc_end = e.pexp_loc.loc_end } | ExtensionConstructor ec -> ec.pext_loc | LabelDeclaration ld -> ld.pld_loc | ModuleBinding mb -> mb.pmb_loc | ModuleDeclaration md -> md.pmd_loc | ModuleExpr me -> me.pmod_loc | ObjectField field -> ( - match field with - | Parsetree.Otag (lbl, _, typ) -> - {lbl.loc with loc_end = typ.ptyp_loc.loc_end} - | _ -> Location.none) - | PackageConstraint (li, te) -> {li.loc with loc_end = te.ptyp_loc.loc_end} + match field with + | Parsetree.Otag (lbl, _, typ) -> + { lbl.loc with loc_end = typ.ptyp_loc.loc_end } + | _ -> Location.none) + | PackageConstraint (li, te) -> { li.loc with loc_end = te.ptyp_loc.loc_end } | Pattern p -> p.ppat_loc - | PatternRecordRow (li, p) -> {li.loc with loc_end = p.ppat_loc.loc_end} + | PatternRecordRow (li, p) -> { li.loc with loc_end = p.ppat_loc.loc_end } | RowField rf -> ( - match rf with - | Parsetree.Rtag ({loc}, _, _, _) -> loc - | Rinherit {ptyp_loc} -> ptyp_loc) + match rf with + | Parsetree.Rtag ({ loc }, _, _, _) -> loc + | Rinherit { ptyp_loc } -> ptyp_loc) | SignatureItem si -> si.psig_loc | StructureItem si -> si.pstr_loc | TypeDeclaration td -> td.ptype_loc @@ -50357,24 +50437,24 @@ and walkStructureItem si t comments = match si.Parsetree.pstr_desc with | _ when comments = [] -> () | Pstr_primitive valueDescription -> - walkValueDescription valueDescription t comments + walkValueDescription valueDescription t comments | Pstr_open openDescription -> walkOpenDescription openDescription t comments | Pstr_value (_, valueBindings) -> walkValueBindings valueBindings t comments | Pstr_type (_, typeDeclarations) -> - walkTypeDeclarations typeDeclarations t comments + walkTypeDeclarations typeDeclarations t comments | Pstr_eval (expr, _) -> walkExpression expr t comments | Pstr_module moduleBinding -> walkModuleBinding moduleBinding t comments | Pstr_recmodule moduleBindings -> - walkList - (moduleBindings |> List.map (fun mb -> ModuleBinding mb)) - t comments + walkList + (moduleBindings |> List.map (fun mb -> ModuleBinding mb)) + t comments | Pstr_modtype modTypDecl -> walkModuleTypeDeclaration modTypDecl t comments | Pstr_attribute attribute -> walkAttribute attribute t comments | Pstr_extension (extension, _) -> walkExtension extension t comments | Pstr_include includeDeclaration -> - walkIncludeDeclaration includeDeclaration t comments + walkIncludeDeclaration includeDeclaration t comments | Pstr_exception extensionConstructor -> - walkExtensionConstructor extensionConstructor t comments + walkExtensionConstructor extensionConstructor t comments | Pstr_typext typeExtension -> walkTypeExtension typeExtension t comments | Pstr_class_type _ | Pstr_class _ -> () @@ -50401,9 +50481,9 @@ and walkTypeExtension te t comments = match te.ptyext_params with | [] -> rest | typeParams -> - visitListButContinueWithRemainingComments - ~getLoc:(fun (typexpr, _variance) -> typexpr.Parsetree.ptyp_loc) - ~walkNode:walkTypeParam ~newlineDelimited:false typeParams t rest + visitListButContinueWithRemainingComments + ~getLoc:(fun (typexpr, _variance) -> typexpr.Parsetree.ptyp_loc) + ~walkNode:walkTypeParam ~newlineDelimited:false typeParams t rest in walkList (te.ptyext_constructors |> List.map (fun ec -> ExtensionConstructor ec)) @@ -50423,14 +50503,14 @@ and walkModuleTypeDeclaration mtd t comments = match mtd.pmtd_type with | None -> attach t.trailing mtd.pmtd_name.loc trailing | Some modType -> - let afterName, rest = - partitionAdjacentTrailing mtd.pmtd_name.loc trailing - in - attach t.trailing mtd.pmtd_name.loc afterName; - let before, inside, after = partitionByLoc rest modType.pmty_loc in - attach t.leading modType.pmty_loc before; - walkModType modType t inside; - attach t.trailing modType.pmty_loc after + let afterName, rest = + partitionAdjacentTrailing mtd.pmtd_name.loc trailing + in + attach t.trailing mtd.pmtd_name.loc afterName; + let before, inside, after = partitionByLoc rest modType.pmty_loc in + attach t.leading modType.pmty_loc before; + walkModType modType t inside; + attach t.trailing modType.pmty_loc after and walkModuleBinding mb t comments = let leading, trailing = partitionLeadingTrailing comments mb.pmb_name.loc in @@ -50440,10 +50520,10 @@ and walkModuleBinding mb t comments = let leading, inside, trailing = partitionByLoc rest mb.pmb_expr.pmod_loc in (match mb.pmb_expr.pmod_desc with | Pmod_constraint _ -> - walkModuleExpr mb.pmb_expr t (List.concat [leading; inside]) + walkModuleExpr mb.pmb_expr t (List.concat [ leading; inside ]) | _ -> - attach t.leading mb.pmb_expr.pmod_loc leading; - walkModuleExpr mb.pmb_expr t inside); + attach t.leading mb.pmb_expr.pmod_loc leading; + walkModuleExpr mb.pmb_expr t inside); attach t.trailing mb.pmb_expr.pmod_loc trailing and walkSignature signature t comments = @@ -50451,29 +50531,29 @@ and walkSignature signature t comments = | _ when comments = [] -> () | [] -> attach t.inside Location.none comments | _s -> - walkList (signature |> List.map (fun si -> SignatureItem si)) t comments + walkList (signature |> List.map (fun si -> SignatureItem si)) t comments and walkSignatureItem (si : Parsetree.signature_item) t comments = match si.psig_desc with | _ when comments = [] -> () | Psig_value valueDescription -> - walkValueDescription valueDescription t comments + walkValueDescription valueDescription t comments | Psig_type (_, typeDeclarations) -> - walkTypeDeclarations typeDeclarations t comments + walkTypeDeclarations typeDeclarations t comments | Psig_typext typeExtension -> walkTypeExtension typeExtension t comments | Psig_exception extensionConstructor -> - walkExtensionConstructor extensionConstructor t comments + walkExtensionConstructor extensionConstructor t comments | Psig_module moduleDeclaration -> - walkModuleDeclaration moduleDeclaration t comments + walkModuleDeclaration moduleDeclaration t comments | Psig_recmodule moduleDeclarations -> - walkList - (moduleDeclarations |> List.map (fun md -> ModuleDeclaration md)) - t comments + walkList + (moduleDeclarations |> List.map (fun md -> ModuleDeclaration md)) + t comments | Psig_modtype moduleTypeDeclaration -> - walkModuleTypeDeclaration moduleTypeDeclaration t comments + walkModuleTypeDeclaration moduleTypeDeclaration t comments | Psig_open openDescription -> walkOpenDescription openDescription t comments | Psig_include includeDescription -> - walkIncludeDescription includeDescription t comments + walkIncludeDescription includeDescription t comments | Psig_attribute attribute -> walkAttribute attribute t comments | Psig_extension (extension, _) -> walkExtension extension t comments | Psig_class _ | Psig_class_type _ -> () @@ -50521,31 +50601,35 @@ and walkList : ?prevLoc:Location.t -> node list -> t -> Comment.t list -> unit = match l with | _ when comments = [] -> () | [] -> ( - match prevLoc with - | Some loc -> attach t.trailing loc comments - | None -> ()) + match prevLoc with + | Some loc -> attach t.trailing loc comments + | None -> ()) | node :: rest -> - let currLoc = getLoc node in - let leading, inside, trailing = partitionByLoc comments currLoc in - (match prevLoc with - | None -> - (* first node, all leading comments attach here *) - attach t.leading currLoc leading - | Some prevLoc -> - (* Same line *) - if prevLoc.loc_end.pos_lnum == currLoc.loc_start.pos_lnum then ( - let afterPrev, beforeCurr = partitionAdjacentTrailing prevLoc leading in - attach t.trailing prevLoc afterPrev; - attach t.leading currLoc beforeCurr) - else - let onSameLineAsPrev, afterPrev = - partitionByOnSameLine prevLoc leading - in - attach t.trailing prevLoc onSameLineAsPrev; - let leading, _inside, _trailing = partitionByLoc afterPrev currLoc in - attach t.leading currLoc leading); - walkNode node t inside; - walkList ~prevLoc:currLoc rest t trailing + let currLoc = getLoc node in + let leading, inside, trailing = partitionByLoc comments currLoc in + (match prevLoc with + | None -> + (* first node, all leading comments attach here *) + attach t.leading currLoc leading + | Some prevLoc -> + (* Same line *) + if prevLoc.loc_end.pos_lnum == currLoc.loc_start.pos_lnum then ( + let afterPrev, beforeCurr = + partitionAdjacentTrailing prevLoc leading + in + attach t.trailing prevLoc afterPrev; + attach t.leading currLoc beforeCurr) + else + let onSameLineAsPrev, afterPrev = + partitionByOnSameLine prevLoc leading + in + attach t.trailing prevLoc onSameLineAsPrev; + let leading, _inside, _trailing = + partitionByLoc afterPrev currLoc + in + attach t.leading currLoc leading); + walkNode node t inside; + walkList ~prevLoc:currLoc rest t trailing (* The parsetree doesn't always contain location info about the opening or * closing token of a "list-of-things". This routine visits the whole list, @@ -50565,45 +50649,47 @@ and visitListButContinueWithRemainingComments : match l with | _ when comments = [] -> [] | [] -> ( - match prevLoc with - | Some loc -> - let afterPrev, rest = - if newlineDelimited then partitionByOnSameLine loc comments - else partitionAdjacentTrailing loc comments - in - attach t.trailing loc afterPrev; - rest - | None -> comments) - | node :: rest -> - let currLoc = getLoc node in - let leading, inside, trailing = partitionByLoc comments currLoc in - let () = match prevLoc with - | None -> - (* first node, all leading comments attach here *) - attach t.leading currLoc leading; - () - | Some prevLoc -> - (* Same line *) - if prevLoc.loc_end.pos_lnum == currLoc.loc_start.pos_lnum then - let afterPrev, beforeCurr = - partitionAdjacentTrailing prevLoc leading - in - let () = attach t.trailing prevLoc afterPrev in - let () = attach t.leading currLoc beforeCurr in - () - else - let onSameLineAsPrev, afterPrev = - partitionByOnSameLine prevLoc leading + | Some loc -> + let afterPrev, rest = + if newlineDelimited then partitionByOnSameLine loc comments + else partitionAdjacentTrailing loc comments in - let () = attach t.trailing prevLoc onSameLineAsPrev in - let leading, _inside, _trailing = partitionByLoc afterPrev currLoc in - let () = attach t.leading currLoc leading in - () - in - walkNode node t inside; - visitListButContinueWithRemainingComments ~prevLoc:currLoc ~getLoc ~walkNode - ~newlineDelimited rest t trailing + attach t.trailing loc afterPrev; + rest + | None -> comments) + | node :: rest -> + let currLoc = getLoc node in + let leading, inside, trailing = partitionByLoc comments currLoc in + let () = + match prevLoc with + | None -> + (* first node, all leading comments attach here *) + attach t.leading currLoc leading; + () + | Some prevLoc -> + (* Same line *) + if prevLoc.loc_end.pos_lnum == currLoc.loc_start.pos_lnum then + let afterPrev, beforeCurr = + partitionAdjacentTrailing prevLoc leading + in + let () = attach t.trailing prevLoc afterPrev in + let () = attach t.leading currLoc beforeCurr in + () + else + let onSameLineAsPrev, afterPrev = + partitionByOnSameLine prevLoc leading + in + let () = attach t.trailing prevLoc onSameLineAsPrev in + let leading, _inside, _trailing = + partitionByLoc afterPrev currLoc + in + let () = attach t.leading currLoc leading in + () + in + walkNode node t inside; + visitListButContinueWithRemainingComments ~prevLoc:currLoc ~getLoc + ~walkNode ~newlineDelimited rest t trailing and walkValueBindings vbs t comments = walkList (vbs |> List.map (fun vb -> ValueBinding vb)) t comments @@ -50634,25 +50720,25 @@ and walkTypeDeclaration (td : Parsetree.type_declaration) t comments = match td.ptype_params with | [] -> rest | typeParams -> - visitListButContinueWithRemainingComments - ~getLoc:(fun (typexpr, _variance) -> typexpr.Parsetree.ptyp_loc) - ~walkNode:walkTypeParam ~newlineDelimited:false typeParams t rest + visitListButContinueWithRemainingComments + ~getLoc:(fun (typexpr, _variance) -> typexpr.Parsetree.ptyp_loc) + ~walkNode:walkTypeParam ~newlineDelimited:false typeParams t rest in (* manifest: = typexpr *) let rest = match td.ptype_manifest with | Some typexpr -> - let beforeTyp, insideTyp, afterTyp = - partitionByLoc rest typexpr.ptyp_loc - in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - let afterTyp, rest = - partitionAdjacentTrailing typexpr.Parsetree.ptyp_loc afterTyp - in - attach t.trailing typexpr.ptyp_loc afterTyp; - rest + let beforeTyp, insideTyp, afterTyp = + partitionByLoc rest typexpr.ptyp_loc + in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkCoreType typexpr t insideTyp; + let afterTyp, rest = + partitionAdjacentTrailing typexpr.Parsetree.ptyp_loc afterTyp + in + attach t.trailing typexpr.ptyp_loc afterTyp; + rest | None -> rest in @@ -50660,16 +50746,16 @@ and walkTypeDeclaration (td : Parsetree.type_declaration) t comments = match td.ptype_kind with | Ptype_abstract | Ptype_open -> rest | Ptype_record labelDeclarations -> - let () = - if labelDeclarations = [] then attach t.inside td.ptype_loc rest - else - walkList - (labelDeclarations |> List.map (fun ld -> LabelDeclaration ld)) - t rest - in - [] + let () = + if labelDeclarations = [] then attach t.inside td.ptype_loc rest + else + walkList + (labelDeclarations |> List.map (fun ld -> LabelDeclaration ld)) + t rest + in + [] | Ptype_variant constructorDeclarations -> - walkConstructorDeclarations constructorDeclarations t rest + walkConstructorDeclarations constructorDeclarations t rest in attach t.trailing td.ptype_loc rest @@ -50705,16 +50791,16 @@ and walkConstructorDeclaration cd t comments = let rest = match cd.pcd_res with | Some typexpr -> - let beforeTyp, insideTyp, afterTyp = - partitionByLoc rest typexpr.ptyp_loc - in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - let afterTyp, rest = - partitionAdjacentTrailing typexpr.Parsetree.ptyp_loc afterTyp - in - attach t.trailing typexpr.ptyp_loc afterTyp; - rest + let beforeTyp, insideTyp, afterTyp = + partitionByLoc rest typexpr.ptyp_loc + in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkCoreType typexpr t insideTyp; + let afterTyp, rest = + partitionAdjacentTrailing typexpr.Parsetree.ptyp_loc afterTyp + in + attach t.trailing typexpr.ptyp_loc afterTyp; + rest | None -> rest in attach t.trailing cd.pcd_loc rest @@ -50722,63 +50808,71 @@ and walkConstructorDeclaration cd t comments = and walkConstructorArguments args t comments = match args with | Pcstr_tuple typexprs -> - visitListButContinueWithRemainingComments - ~getLoc:(fun n -> n.Parsetree.ptyp_loc) - ~walkNode:walkCoreType ~newlineDelimited:false typexprs t comments + visitListButContinueWithRemainingComments + ~getLoc:(fun n -> n.Parsetree.ptyp_loc) + ~walkNode:walkCoreType ~newlineDelimited:false typexprs t comments | Pcstr_record labelDeclarations -> - walkLabelDeclarations labelDeclarations t comments + walkLabelDeclarations labelDeclarations t comments and walkValueBinding vb t comments = let open Location in let vb = let open Parsetree in match (vb.pvb_pat, vb.pvb_expr) with - | ( {ppat_desc = Ppat_constraint (pat, {ptyp_desc = Ptyp_poly ([], t)})}, - {pexp_desc = Pexp_constraint (expr, _typ)} ) -> - { - vb with - pvb_pat = - Ast_helper.Pat.constraint_ - ~loc:{pat.ppat_loc with loc_end = t.Parsetree.ptyp_loc.loc_end} - pat t; - pvb_expr = expr; - } - | ( {ppat_desc = Ppat_constraint (pat, {ptyp_desc = Ptyp_poly (_ :: _, t)})}, - {pexp_desc = Pexp_fun _} ) -> - { - vb with - pvb_pat = - { - vb.pvb_pat with - ppat_loc = {pat.ppat_loc with loc_end = t.ptyp_loc.loc_end}; - }; - } + | ( { ppat_desc = Ppat_constraint (pat, { ptyp_desc = Ptyp_poly ([], t) }) }, + { pexp_desc = Pexp_constraint (expr, _typ) } ) -> + { + vb with + pvb_pat = + Ast_helper.Pat.constraint_ + ~loc:{ pat.ppat_loc with loc_end = t.Parsetree.ptyp_loc.loc_end } + pat t; + pvb_expr = expr; + } + | ( { + ppat_desc = + Ppat_constraint (pat, { ptyp_desc = Ptyp_poly (_ :: _, t) }); + }, + { pexp_desc = Pexp_fun _ } ) -> + { + vb with + pvb_pat = + { + vb.pvb_pat with + ppat_loc = { pat.ppat_loc with loc_end = t.ptyp_loc.loc_end }; + }; + } | ( ({ ppat_desc = - Ppat_constraint (pat, ({ptyp_desc = Ptyp_poly (_ :: _, t)} as typ)); + Ppat_constraint + (pat, ({ ptyp_desc = Ptyp_poly (_ :: _, t) } as typ)); } as constrainedPattern), - {pexp_desc = Pexp_newtype (_, {pexp_desc = Pexp_constraint (expr, _)})} - ) -> - (* - * The location of the Ptyp_poly on the pattern is the whole thing. - * let x: - * type t. (int, int) => int = - * (a, b) => { - * // comment - * a + b - * } - *) - { - vb with - pvb_pat = - { - constrainedPattern with - ppat_desc = Ppat_constraint (pat, typ); - ppat_loc = - {constrainedPattern.ppat_loc with loc_end = t.ptyp_loc.loc_end}; - }; - pvb_expr = expr; - } + { + pexp_desc = Pexp_newtype (_, { pexp_desc = Pexp_constraint (expr, _) }); + } ) -> + (* + * The location of the Ptyp_poly on the pattern is the whole thing. + * let x: + * type t. (int, int) => int = + * (a, b) => { + * // comment + * a + b + * } + *) + { + vb with + pvb_pat = + { + constrainedPattern with + ppat_desc = Ppat_constraint (pat, typ); + ppat_loc = + { + constrainedPattern.ppat_loc with + loc_end = t.ptyp_loc.loc_end; + }; + }; + pvb_expr = expr; + } | _ -> vb in let patternLoc = vb.Parsetree.pvb_pat.ppat_loc in @@ -50799,7 +50893,7 @@ and walkValueBinding vb t comments = partitionByLoc surroundingExpr exprLoc in if isBlockExpr expr then - walkExpression expr t (List.concat [beforeExpr; insideExpr; afterExpr]) + walkExpression expr t (List.concat [ beforeExpr; insideExpr; afterExpr ]) else ( attach t.leading exprLoc beforeExpr; walkExpression expr t insideExpr; @@ -50810,421 +50904,441 @@ and walkExpression expr t comments = match expr.Parsetree.pexp_desc with | _ when comments = [] -> () | Pexp_constant _ -> - let leading, trailing = partitionLeadingTrailing comments expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - attach t.trailing expr.pexp_loc trailing + let leading, trailing = partitionLeadingTrailing comments expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + attach t.trailing expr.pexp_loc trailing | Pexp_ident longident -> - let leading, trailing = partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc leading; - attach t.trailing longident.loc trailing + let leading, trailing = partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc leading; + attach t.trailing longident.loc trailing | Pexp_let ( _recFlag, valueBindings, - {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, None)} ) -> - walkValueBindings valueBindings t comments + { pexp_desc = Pexp_construct ({ txt = Longident.Lident "()" }, None) } + ) -> + walkValueBindings valueBindings t comments | Pexp_let (_recFlag, valueBindings, expr2) -> - let comments = - visitListButContinueWithRemainingComments - ~getLoc:(fun n -> - if n.Parsetree.pvb_pat.ppat_loc.loc_ghost then n.pvb_expr.pexp_loc - else n.Parsetree.pvb_loc) - ~walkNode:walkValueBinding ~newlineDelimited:true valueBindings t - comments - in - if isBlockExpr expr2 then walkExpression expr2 t comments - else - let leading, inside, trailing = partitionByLoc comments expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; - attach t.trailing expr2.pexp_loc trailing - | Pexp_sequence (expr1, expr2) -> - let leading, inside, trailing = partitionByLoc comments expr1.pexp_loc in - let comments = - if isBlockExpr expr1 then ( - let afterExpr, comments = - partitionByOnSameLine expr1.pexp_loc trailing + let comments = + visitListButContinueWithRemainingComments + ~getLoc:(fun n -> + if n.Parsetree.pvb_pat.ppat_loc.loc_ghost then n.pvb_expr.pexp_loc + else n.Parsetree.pvb_loc) + ~walkNode:walkValueBinding ~newlineDelimited:true valueBindings t + comments + in + if isBlockExpr expr2 then walkExpression expr2 t comments + else + let leading, inside, trailing = + partitionByLoc comments expr2.pexp_loc in - walkExpression expr1 t (List.concat [leading; inside; afterExpr]); - comments) - else ( - attach t.leading expr1.pexp_loc leading; - walkExpression expr1 t inside; - let afterExpr, comments = - partitionByOnSameLine expr1.pexp_loc trailing + attach t.leading expr2.pexp_loc leading; + walkExpression expr2 t inside; + attach t.trailing expr2.pexp_loc trailing + | Pexp_sequence (expr1, expr2) -> + let leading, inside, trailing = partitionByLoc comments expr1.pexp_loc in + let comments = + if isBlockExpr expr1 then ( + let afterExpr, comments = + partitionByOnSameLine expr1.pexp_loc trailing + in + walkExpression expr1 t (List.concat [ leading; inside; afterExpr ]); + comments) + else ( + attach t.leading expr1.pexp_loc leading; + walkExpression expr1 t inside; + let afterExpr, comments = + partitionByOnSameLine expr1.pexp_loc trailing + in + attach t.trailing expr1.pexp_loc afterExpr; + comments) + in + if isBlockExpr expr2 then walkExpression expr2 t comments + else + let leading, inside, trailing = + partitionByLoc comments expr2.pexp_loc in - attach t.trailing expr1.pexp_loc afterExpr; - comments) - in - if isBlockExpr expr2 then walkExpression expr2 t comments - else - let leading, inside, trailing = partitionByLoc comments expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; - attach t.trailing expr2.pexp_loc trailing + attach t.leading expr2.pexp_loc leading; + walkExpression expr2 t inside; + attach t.trailing expr2.pexp_loc trailing | Pexp_open (_override, longident, expr2) -> - let leading, comments = partitionLeadingTrailing comments expr.pexp_loc in - attach t.leading - {expr.pexp_loc with loc_end = longident.loc.loc_end} - leading; - let leading, trailing = partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc leading; - let afterLongident, rest = partitionByOnSameLine longident.loc trailing in - attach t.trailing longident.loc afterLongident; - if isBlockExpr expr2 then walkExpression expr2 t rest - else - let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; - attach t.trailing expr2.pexp_loc trailing + let leading, comments = partitionLeadingTrailing comments expr.pexp_loc in + attach t.leading + { expr.pexp_loc with loc_end = longident.loc.loc_end } + leading; + let leading, trailing = partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc leading; + let afterLongident, rest = partitionByOnSameLine longident.loc trailing in + attach t.trailing longident.loc afterLongident; + if isBlockExpr expr2 then walkExpression expr2 t rest + else + let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walkExpression expr2 t inside; + attach t.trailing expr2.pexp_loc trailing | Pexp_extension - ( {txt = "bs.obj" | "obj"}, - PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_record (rows, _)}, [])}] - ) -> - walkList - (rows |> List.map (fun (li, e) -> ExprRecordRow (li, e))) - t comments + ( { txt = "bs.obj" | "obj" }, + PStr + [ + { + pstr_desc = Pstr_eval ({ pexp_desc = Pexp_record (rows, _) }, []); + }; + ] ) -> + walkList + (rows |> List.map (fun (li, e) -> ExprRecordRow (li, e))) + t comments | Pexp_extension extension -> walkExtension extension t comments | Pexp_letexception (extensionConstructor, expr2) -> - let leading, comments = partitionLeadingTrailing comments expr.pexp_loc in - attach t.leading - {expr.pexp_loc with loc_end = extensionConstructor.pext_loc.loc_end} - leading; - let leading, inside, trailing = - partitionByLoc comments extensionConstructor.pext_loc - in - attach t.leading extensionConstructor.pext_loc leading; - walkExtensionConstructor extensionConstructor t inside; - let afterExtConstr, rest = - partitionByOnSameLine extensionConstructor.pext_loc trailing - in - attach t.trailing extensionConstructor.pext_loc afterExtConstr; - if isBlockExpr expr2 then walkExpression expr2 t rest - else - let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; - attach t.trailing expr2.pexp_loc trailing + let leading, comments = partitionLeadingTrailing comments expr.pexp_loc in + attach t.leading + { expr.pexp_loc with loc_end = extensionConstructor.pext_loc.loc_end } + leading; + let leading, inside, trailing = + partitionByLoc comments extensionConstructor.pext_loc + in + attach t.leading extensionConstructor.pext_loc leading; + walkExtensionConstructor extensionConstructor t inside; + let afterExtConstr, rest = + partitionByOnSameLine extensionConstructor.pext_loc trailing + in + attach t.trailing extensionConstructor.pext_loc afterExtConstr; + if isBlockExpr expr2 then walkExpression expr2 t rest + else + let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walkExpression expr2 t inside; + attach t.trailing expr2.pexp_loc trailing | Pexp_letmodule (stringLoc, modExpr, expr2) -> - let leading, comments = partitionLeadingTrailing comments expr.pexp_loc in - attach t.leading - {expr.pexp_loc with loc_end = modExpr.pmod_loc.loc_end} - leading; - let leading, trailing = partitionLeadingTrailing comments stringLoc.loc in - attach t.leading stringLoc.loc leading; - let afterString, rest = partitionAdjacentTrailing stringLoc.loc trailing in - attach t.trailing stringLoc.loc afterString; - let beforeModExpr, insideModExpr, afterModExpr = - partitionByLoc rest modExpr.pmod_loc - in - attach t.leading modExpr.pmod_loc beforeModExpr; - walkModuleExpr modExpr t insideModExpr; - let afterModExpr, rest = - partitionByOnSameLine modExpr.pmod_loc afterModExpr - in - attach t.trailing modExpr.pmod_loc afterModExpr; - if isBlockExpr expr2 then walkExpression expr2 t rest - else - let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; - attach t.trailing expr2.pexp_loc trailing + let leading, comments = partitionLeadingTrailing comments expr.pexp_loc in + attach t.leading + { expr.pexp_loc with loc_end = modExpr.pmod_loc.loc_end } + leading; + let leading, trailing = partitionLeadingTrailing comments stringLoc.loc in + attach t.leading stringLoc.loc leading; + let afterString, rest = + partitionAdjacentTrailing stringLoc.loc trailing + in + attach t.trailing stringLoc.loc afterString; + let beforeModExpr, insideModExpr, afterModExpr = + partitionByLoc rest modExpr.pmod_loc + in + attach t.leading modExpr.pmod_loc beforeModExpr; + walkModuleExpr modExpr t insideModExpr; + let afterModExpr, rest = + partitionByOnSameLine modExpr.pmod_loc afterModExpr + in + attach t.trailing modExpr.pmod_loc afterModExpr; + if isBlockExpr expr2 then walkExpression expr2 t rest + else + let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walkExpression expr2 t inside; + attach t.trailing expr2.pexp_loc trailing | Pexp_assert expr | Pexp_lazy expr -> - if isBlockExpr expr then walkExpression expr t comments - else + if isBlockExpr expr then walkExpression expr t comments + else + let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + walkExpression expr t inside; + attach t.trailing expr.pexp_loc trailing + | Pexp_coerce (expr, optTypexpr, typexpr) -> let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in attach t.leading expr.pexp_loc leading; walkExpression expr t inside; - attach t.trailing expr.pexp_loc trailing - | Pexp_coerce (expr, optTypexpr, typexpr) -> - let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; - let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc trailing in - attach t.trailing expr.pexp_loc afterExpr; - let rest = - match optTypexpr with - | Some typexpr -> - let leading, inside, trailing = - partitionByLoc comments typexpr.ptyp_loc - in - attach t.leading typexpr.ptyp_loc leading; - walkCoreType typexpr t inside; - let afterTyp, rest = - partitionAdjacentTrailing typexpr.ptyp_loc trailing - in - attach t.trailing typexpr.ptyp_loc afterTyp; - rest - | None -> rest - in - let leading, inside, trailing = partitionByLoc rest typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc leading; - walkCoreType typexpr t inside; - attach t.trailing typexpr.ptyp_loc trailing + let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc trailing in + attach t.trailing expr.pexp_loc afterExpr; + let rest = + match optTypexpr with + | Some typexpr -> + let leading, inside, trailing = + partitionByLoc comments typexpr.ptyp_loc + in + attach t.leading typexpr.ptyp_loc leading; + walkCoreType typexpr t inside; + let afterTyp, rest = + partitionAdjacentTrailing typexpr.ptyp_loc trailing + in + attach t.trailing typexpr.ptyp_loc afterTyp; + rest + | None -> rest + in + let leading, inside, trailing = partitionByLoc rest typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc leading; + walkCoreType typexpr t inside; + attach t.trailing typexpr.ptyp_loc trailing | Pexp_constraint (expr, typexpr) -> - let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; - let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc trailing in - attach t.trailing expr.pexp_loc afterExpr; - let leading, inside, trailing = partitionByLoc rest typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc leading; - walkCoreType typexpr t inside; - attach t.trailing typexpr.ptyp_loc trailing + let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + walkExpression expr t inside; + let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc trailing in + attach t.trailing expr.pexp_loc afterExpr; + let leading, inside, trailing = partitionByLoc rest typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc leading; + walkCoreType typexpr t inside; + attach t.trailing typexpr.ptyp_loc trailing | Pexp_tuple [] | Pexp_array [] - | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> - attach t.inside expr.pexp_loc comments - | Pexp_construct ({txt = Longident.Lident "::"}, _) -> - walkList - (collectListExprs [] expr |> List.map (fun e -> Expression e)) - t comments + | Pexp_construct ({ txt = Longident.Lident "[]" }, _) -> + attach t.inside expr.pexp_loc comments + | Pexp_construct ({ txt = Longident.Lident "::" }, _) -> + walkList + (collectListExprs [] expr |> List.map (fun e -> Expression e)) + t comments | Pexp_construct (longident, args) -> ( - let leading, trailing = partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc leading; - match args with - | Some expr -> - let afterLongident, rest = - partitionAdjacentTrailing longident.loc trailing - in - attach t.trailing longident.loc afterLongident; - walkExpression expr t rest - | None -> attach t.trailing longident.loc trailing) + let leading, trailing = partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc leading; + match args with + | Some expr -> + let afterLongident, rest = + partitionAdjacentTrailing longident.loc trailing + in + attach t.trailing longident.loc afterLongident; + walkExpression expr t rest + | None -> attach t.trailing longident.loc trailing) | Pexp_variant (_label, None) -> () | Pexp_variant (_label, Some expr) -> walkExpression expr t comments | Pexp_array exprs | Pexp_tuple exprs -> - walkList (exprs |> List.map (fun e -> Expression e)) t comments + walkList (exprs |> List.map (fun e -> Expression e)) t comments | Pexp_record (rows, spreadExpr) -> - if rows = [] then attach t.inside expr.pexp_loc comments - else - let comments = - match spreadExpr with - | None -> comments - | Some expr -> - let leading, inside, trailing = - partitionByLoc comments expr.pexp_loc + if rows = [] then attach t.inside expr.pexp_loc comments + else + let comments = + match spreadExpr with + | None -> comments + | Some expr -> + let leading, inside, trailing = + partitionByLoc comments expr.pexp_loc + in + attach t.leading expr.pexp_loc leading; + walkExpression expr t inside; + let afterExpr, rest = + partitionAdjacentTrailing expr.pexp_loc trailing + in + attach t.trailing expr.pexp_loc afterExpr; + rest + in + walkList + (rows |> List.map (fun (li, e) -> ExprRecordRow (li, e))) + t comments + | Pexp_field (expr, longident) -> + let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in + let trailing = + if isBlockExpr expr then ( + let afterExpr, rest = + partitionAdjacentTrailing expr.pexp_loc trailing in + walkExpression expr t (List.concat [ leading; inside; afterExpr ]); + rest) + else ( attach t.leading expr.pexp_loc leading; walkExpression expr t inside; + trailing) + in + let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc trailing in + attach t.trailing expr.pexp_loc afterExpr; + let leading, trailing = partitionLeadingTrailing rest longident.loc in + attach t.leading longident.loc leading; + attach t.trailing longident.loc trailing + | Pexp_setfield (expr1, longident, expr2) -> + let leading, inside, trailing = partitionByLoc comments expr1.pexp_loc in + let rest = + if isBlockExpr expr1 then ( let afterExpr, rest = - partitionAdjacentTrailing expr.pexp_loc trailing + partitionAdjacentTrailing expr1.pexp_loc trailing + in + walkExpression expr1 t (List.concat [ leading; inside; afterExpr ]); + rest) + else + let afterExpr, rest = + partitionAdjacentTrailing expr1.pexp_loc trailing in - attach t.trailing expr.pexp_loc afterExpr; + attach t.leading expr1.pexp_loc leading; + walkExpression expr1 t inside; + attach t.trailing expr1.pexp_loc afterExpr; rest in - walkList - (rows |> List.map (fun (li, e) -> ExprRecordRow (li, e))) - t comments - | Pexp_field (expr, longident) -> - let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in - let trailing = - if isBlockExpr expr then ( - let afterExpr, rest = - partitionAdjacentTrailing expr.pexp_loc trailing - in - walkExpression expr t (List.concat [leading; inside; afterExpr]); - rest) - else ( - attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; - trailing) - in - let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc trailing in - attach t.trailing expr.pexp_loc afterExpr; - let leading, trailing = partitionLeadingTrailing rest longident.loc in - attach t.leading longident.loc leading; - attach t.trailing longident.loc trailing - | Pexp_setfield (expr1, longident, expr2) -> - let leading, inside, trailing = partitionByLoc comments expr1.pexp_loc in - let rest = - if isBlockExpr expr1 then ( - let afterExpr, rest = - partitionAdjacentTrailing expr1.pexp_loc trailing - in - walkExpression expr1 t (List.concat [leading; inside; afterExpr]); - rest) + let beforeLongident, afterLongident = + partitionLeadingTrailing rest longident.loc + in + attach t.leading longident.loc beforeLongident; + let afterLongident, rest = + partitionAdjacentTrailing longident.loc afterLongident + in + attach t.trailing longident.loc afterLongident; + if isBlockExpr expr2 then walkExpression expr2 t rest else - let afterExpr, rest = - partitionAdjacentTrailing expr1.pexp_loc trailing - in - attach t.leading expr1.pexp_loc leading; - walkExpression expr1 t inside; - attach t.trailing expr1.pexp_loc afterExpr; - rest - in - let beforeLongident, afterLongident = - partitionLeadingTrailing rest longident.loc - in - attach t.leading longident.loc beforeLongident; - let afterLongident, rest = - partitionAdjacentTrailing longident.loc afterLongident - in - attach t.trailing longident.loc afterLongident; - if isBlockExpr expr2 then walkExpression expr2 t rest - else - let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; - attach t.trailing expr2.pexp_loc trailing + let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walkExpression expr2 t inside; + attach t.trailing expr2.pexp_loc trailing | Pexp_ifthenelse (ifExpr, thenExpr, elseExpr) -> ( - let leading, rest = partitionLeadingTrailing comments expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - let leading, inside, trailing = partitionByLoc rest ifExpr.pexp_loc in - let comments = - if isBlockExpr ifExpr then ( - let afterExpr, comments = - partitionAdjacentTrailing ifExpr.pexp_loc trailing - in - walkExpression ifExpr t (List.concat [leading; inside; afterExpr]); - comments) - else ( - attach t.leading ifExpr.pexp_loc leading; - walkExpression ifExpr t inside; - let afterExpr, comments = - partitionAdjacentTrailing ifExpr.pexp_loc trailing - in - attach t.trailing ifExpr.pexp_loc afterExpr; - comments) - in - let leading, inside, trailing = partitionByLoc comments thenExpr.pexp_loc in - let comments = - if isBlockExpr thenExpr then ( - let afterExpr, trailing = - partitionAdjacentTrailing thenExpr.pexp_loc trailing - in - walkExpression thenExpr t (List.concat [leading; inside; afterExpr]); - trailing) - else ( - attach t.leading thenExpr.pexp_loc leading; - walkExpression thenExpr t inside; - let afterExpr, comments = - partitionAdjacentTrailing thenExpr.pexp_loc trailing - in - attach t.trailing thenExpr.pexp_loc afterExpr; - comments) - in - match elseExpr with - | None -> () - | Some expr -> - if isBlockExpr expr || isIfThenElseExpr expr then - walkExpression expr t comments - else - let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; - attach t.trailing expr.pexp_loc trailing) + let leading, rest = partitionLeadingTrailing comments expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + let leading, inside, trailing = partitionByLoc rest ifExpr.pexp_loc in + let comments = + if isBlockExpr ifExpr then ( + let afterExpr, comments = + partitionAdjacentTrailing ifExpr.pexp_loc trailing + in + walkExpression ifExpr t (List.concat [ leading; inside; afterExpr ]); + comments) + else ( + attach t.leading ifExpr.pexp_loc leading; + walkExpression ifExpr t inside; + let afterExpr, comments = + partitionAdjacentTrailing ifExpr.pexp_loc trailing + in + attach t.trailing ifExpr.pexp_loc afterExpr; + comments) + in + let leading, inside, trailing = + partitionByLoc comments thenExpr.pexp_loc + in + let comments = + if isBlockExpr thenExpr then ( + let afterExpr, trailing = + partitionAdjacentTrailing thenExpr.pexp_loc trailing + in + walkExpression thenExpr t (List.concat [ leading; inside; afterExpr ]); + trailing) + else ( + attach t.leading thenExpr.pexp_loc leading; + walkExpression thenExpr t inside; + let afterExpr, comments = + partitionAdjacentTrailing thenExpr.pexp_loc trailing + in + attach t.trailing thenExpr.pexp_loc afterExpr; + comments) + in + match elseExpr with + | None -> () + | Some expr -> + if isBlockExpr expr || isIfThenElseExpr expr then + walkExpression expr t comments + else + let leading, inside, trailing = + partitionByLoc comments expr.pexp_loc + in + attach t.leading expr.pexp_loc leading; + walkExpression expr t inside; + attach t.trailing expr.pexp_loc trailing) | Pexp_while (expr1, expr2) -> - let leading, inside, trailing = partitionByLoc comments expr1.pexp_loc in - let rest = - if isBlockExpr expr1 then ( - let afterExpr, rest = - partitionAdjacentTrailing expr1.pexp_loc trailing - in - walkExpression expr1 t (List.concat [leading; inside; afterExpr]); - rest) - else ( - attach t.leading expr1.pexp_loc leading; - walkExpression expr1 t inside; - let afterExpr, rest = - partitionAdjacentTrailing expr1.pexp_loc trailing - in - attach t.trailing expr1.pexp_loc afterExpr; - rest) - in - if isBlockExpr expr2 then walkExpression expr2 t rest - else + let leading, inside, trailing = partitionByLoc comments expr1.pexp_loc in + let rest = + if isBlockExpr expr1 then ( + let afterExpr, rest = + partitionAdjacentTrailing expr1.pexp_loc trailing + in + walkExpression expr1 t (List.concat [ leading; inside; afterExpr ]); + rest) + else ( + attach t.leading expr1.pexp_loc leading; + walkExpression expr1 t inside; + let afterExpr, rest = + partitionAdjacentTrailing expr1.pexp_loc trailing + in + attach t.trailing expr1.pexp_loc afterExpr; + rest) + in + if isBlockExpr expr2 then walkExpression expr2 t rest + else + let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walkExpression expr2 t inside; + attach t.trailing expr2.pexp_loc trailing + | Pexp_for (pat, expr1, expr2, _, expr3) -> + let leading, inside, trailing = partitionByLoc comments pat.ppat_loc in + attach t.leading pat.ppat_loc leading; + walkPattern pat t inside; + let afterPat, rest = partitionAdjacentTrailing pat.ppat_loc trailing in + attach t.trailing pat.ppat_loc afterPat; + let leading, inside, trailing = partitionByLoc rest expr1.pexp_loc in + attach t.leading expr1.pexp_loc leading; + walkExpression expr1 t inside; + let afterExpr, rest = partitionAdjacentTrailing expr1.pexp_loc trailing in + attach t.trailing expr1.pexp_loc afterExpr; let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in attach t.leading expr2.pexp_loc leading; walkExpression expr2 t inside; - attach t.trailing expr2.pexp_loc trailing - | Pexp_for (pat, expr1, expr2, _, expr3) -> - let leading, inside, trailing = partitionByLoc comments pat.ppat_loc in - attach t.leading pat.ppat_loc leading; - walkPattern pat t inside; - let afterPat, rest = partitionAdjacentTrailing pat.ppat_loc trailing in - attach t.trailing pat.ppat_loc afterPat; - let leading, inside, trailing = partitionByLoc rest expr1.pexp_loc in - attach t.leading expr1.pexp_loc leading; - walkExpression expr1 t inside; - let afterExpr, rest = partitionAdjacentTrailing expr1.pexp_loc trailing in - attach t.trailing expr1.pexp_loc afterExpr; - let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; - let afterExpr, rest = partitionAdjacentTrailing expr2.pexp_loc trailing in - attach t.trailing expr2.pexp_loc afterExpr; - if isBlockExpr expr3 then walkExpression expr3 t rest - else - let leading, inside, trailing = partitionByLoc rest expr3.pexp_loc in - attach t.leading expr3.pexp_loc leading; - walkExpression expr3 t inside; - attach t.trailing expr3.pexp_loc trailing + let afterExpr, rest = partitionAdjacentTrailing expr2.pexp_loc trailing in + attach t.trailing expr2.pexp_loc afterExpr; + if isBlockExpr expr3 then walkExpression expr3 t rest + else + let leading, inside, trailing = partitionByLoc rest expr3.pexp_loc in + attach t.leading expr3.pexp_loc leading; + walkExpression expr3 t inside; + attach t.trailing expr3.pexp_loc trailing | Pexp_pack modExpr -> - let before, inside, after = partitionByLoc comments modExpr.pmod_loc in - attach t.leading modExpr.pmod_loc before; - walkModuleExpr modExpr t inside; - attach t.trailing modExpr.pmod_loc after - | Pexp_match (expr1, [case; elseBranch]) + let before, inside, after = partitionByLoc comments modExpr.pmod_loc in + attach t.leading modExpr.pmod_loc before; + walkModuleExpr modExpr t inside; + attach t.trailing modExpr.pmod_loc after + | Pexp_match (expr1, [ case; elseBranch ]) when Res_parsetree_viewer.hasIfLetAttribute expr.pexp_attributes -> - let before, inside, after = partitionByLoc comments case.pc_lhs.ppat_loc in - attach t.leading case.pc_lhs.ppat_loc before; - walkPattern case.pc_lhs t inside; - let afterPat, rest = partitionAdjacentTrailing case.pc_lhs.ppat_loc after in - attach t.trailing case.pc_lhs.ppat_loc afterPat; - let before, inside, after = partitionByLoc rest expr1.pexp_loc in - attach t.leading expr1.pexp_loc before; - walkExpression expr1 t inside; - let afterExpr, rest = partitionAdjacentTrailing expr1.pexp_loc after in - attach t.trailing expr1.pexp_loc afterExpr; - let before, inside, after = partitionByLoc rest case.pc_rhs.pexp_loc in - let after = - if isBlockExpr case.pc_rhs then ( - let afterExpr, rest = - partitionAdjacentTrailing case.pc_rhs.pexp_loc after - in - walkExpression case.pc_rhs t (List.concat [before; inside; afterExpr]); - rest) - else ( - attach t.leading case.pc_rhs.pexp_loc before; - walkExpression case.pc_rhs t inside; - after) - in - let afterExpr, rest = - partitionAdjacentTrailing case.pc_rhs.pexp_loc after - in - attach t.trailing case.pc_rhs.pexp_loc afterExpr; - let before, inside, after = - partitionByLoc rest elseBranch.pc_rhs.pexp_loc - in - let after = - if isBlockExpr elseBranch.pc_rhs then ( - let afterExpr, rest = - partitionAdjacentTrailing elseBranch.pc_rhs.pexp_loc after - in - walkExpression elseBranch.pc_rhs t - (List.concat [before; inside; afterExpr]); - rest) - else ( - attach t.leading elseBranch.pc_rhs.pexp_loc before; - walkExpression elseBranch.pc_rhs t inside; - after) - in - attach t.trailing elseBranch.pc_rhs.pexp_loc after + let before, inside, after = + partitionByLoc comments case.pc_lhs.ppat_loc + in + attach t.leading case.pc_lhs.ppat_loc before; + walkPattern case.pc_lhs t inside; + let afterPat, rest = + partitionAdjacentTrailing case.pc_lhs.ppat_loc after + in + attach t.trailing case.pc_lhs.ppat_loc afterPat; + let before, inside, after = partitionByLoc rest expr1.pexp_loc in + attach t.leading expr1.pexp_loc before; + walkExpression expr1 t inside; + let afterExpr, rest = partitionAdjacentTrailing expr1.pexp_loc after in + attach t.trailing expr1.pexp_loc afterExpr; + let before, inside, after = partitionByLoc rest case.pc_rhs.pexp_loc in + let after = + if isBlockExpr case.pc_rhs then ( + let afterExpr, rest = + partitionAdjacentTrailing case.pc_rhs.pexp_loc after + in + walkExpression case.pc_rhs t + (List.concat [ before; inside; afterExpr ]); + rest) + else ( + attach t.leading case.pc_rhs.pexp_loc before; + walkExpression case.pc_rhs t inside; + after) + in + let afterExpr, rest = + partitionAdjacentTrailing case.pc_rhs.pexp_loc after + in + attach t.trailing case.pc_rhs.pexp_loc afterExpr; + let before, inside, after = + partitionByLoc rest elseBranch.pc_rhs.pexp_loc + in + let after = + if isBlockExpr elseBranch.pc_rhs then ( + let afterExpr, rest = + partitionAdjacentTrailing elseBranch.pc_rhs.pexp_loc after + in + walkExpression elseBranch.pc_rhs t + (List.concat [ before; inside; afterExpr ]); + rest) + else ( + attach t.leading elseBranch.pc_rhs.pexp_loc before; + walkExpression elseBranch.pc_rhs t inside; + after) + in + attach t.trailing elseBranch.pc_rhs.pexp_loc after | Pexp_match (expr, cases) | Pexp_try (expr, cases) -> - let before, inside, after = partitionByLoc comments expr.pexp_loc in - let after = - if isBlockExpr expr then ( - let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc after in - walkExpression expr t (List.concat [before; inside; afterExpr]); - rest) - else ( - attach t.leading expr.pexp_loc before; - walkExpression expr t inside; - after) - in - let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc after in - attach t.trailing expr.pexp_loc afterExpr; - walkList (cases |> List.map (fun case -> Case case)) t rest - (* unary expression: todo use parsetreeviewer *) + let before, inside, after = partitionByLoc comments expr.pexp_loc in + let after = + if isBlockExpr expr then ( + let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc after in + walkExpression expr t (List.concat [ before; inside; afterExpr ]); + rest) + else ( + attach t.leading expr.pexp_loc before; + walkExpression expr t inside; + after) + in + let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc after in + attach t.trailing expr.pexp_loc afterExpr; + walkList (cases |> List.map (fun case -> Case case)) t rest + (* unary expression: todo use parsetreeviewer *) | Pexp_apply ( { pexp_desc = @@ -51234,11 +51348,11 @@ and walkExpression expr t comments = Longident.Lident ("~+" | "~+." | "~-" | "~-." | "not" | "!"); }; }, - [(Nolabel, argExpr)] ) -> - let before, inside, after = partitionByLoc comments argExpr.pexp_loc in - attach t.leading argExpr.pexp_loc before; - walkExpression argExpr t inside; - attach t.trailing argExpr.pexp_loc after + [ (Nolabel, argExpr) ] ) -> + let before, inside, after = partitionByLoc comments argExpr.pexp_loc in + attach t.leading argExpr.pexp_loc before; + walkExpression argExpr t inside; + attach t.trailing argExpr.pexp_loc after (* binary expression *) | Pexp_apply ( { @@ -51252,118 +51366,127 @@ and walkExpression expr t comments = | "*" | "*." | "/" | "/." | "**" | "|." | "<>" ); }; }, - [(Nolabel, operand1); (Nolabel, operand2)] ) -> - let before, inside, after = partitionByLoc comments operand1.pexp_loc in - attach t.leading operand1.pexp_loc before; - walkExpression operand1 t inside; - let afterOperand1, rest = - partitionAdjacentTrailing operand1.pexp_loc after - in - attach t.trailing operand1.pexp_loc afterOperand1; - let before, inside, after = partitionByLoc rest operand2.pexp_loc in - attach t.leading operand2.pexp_loc before; - walkExpression operand2 t inside; - (* (List.concat [inside; after]); *) - attach t.trailing operand2.pexp_loc after + [ (Nolabel, operand1); (Nolabel, operand2) ] ) -> + let before, inside, after = partitionByLoc comments operand1.pexp_loc in + attach t.leading operand1.pexp_loc before; + walkExpression operand1 t inside; + let afterOperand1, rest = + partitionAdjacentTrailing operand1.pexp_loc after + in + attach t.trailing operand1.pexp_loc afterOperand1; + let before, inside, after = partitionByLoc rest operand2.pexp_loc in + attach t.leading operand2.pexp_loc before; + walkExpression operand2 t inside; + (* (List.concat [inside; after]); *) + attach t.trailing operand2.pexp_loc after | Pexp_apply (callExpr, arguments) -> - let before, inside, after = partitionByLoc comments callExpr.pexp_loc in - let after = - if isBlockExpr callExpr then ( + let before, inside, after = partitionByLoc comments callExpr.pexp_loc in + let after = + if isBlockExpr callExpr then ( + let afterExpr, rest = + partitionAdjacentTrailing callExpr.pexp_loc after + in + walkExpression callExpr t (List.concat [ before; inside; afterExpr ]); + rest) + else ( + attach t.leading callExpr.pexp_loc before; + walkExpression callExpr t inside; + after) + in + if ParsetreeViewer.isJsxExpression expr then ( + let props = + arguments + |> List.filter (fun (label, _) -> + match label with + | Asttypes.Labelled "children" -> false + | Asttypes.Nolabel -> false + | _ -> true) + in + let maybeChildren = + arguments + |> List.find_opt (fun (label, _) -> + label = Asttypes.Labelled "children") + in + match maybeChildren with + (* There is no need to deal with this situation as the children cannot be NONE *) + | None -> () + | Some (_, children) -> + let leading, inside, _ = partitionByLoc after children.pexp_loc in + if props = [] then + (* All comments inside a tag are trailing comments of the tag if there are no props + + *) + let afterExpr, _ = + partitionAdjacentTrailing callExpr.pexp_loc after + in + attach t.trailing callExpr.pexp_loc afterExpr + else + walkList + (props |> List.map (fun (_, e) -> ExprArgument e)) + t leading; + walkExpression children t inside) + else let afterExpr, rest = partitionAdjacentTrailing callExpr.pexp_loc after in - walkExpression callExpr t (List.concat [before; inside; afterExpr]); - rest) - else ( - attach t.leading callExpr.pexp_loc before; - walkExpression callExpr t inside; - after) - in - if ParsetreeViewer.isJsxExpression expr then ( - let props = - arguments - |> List.filter (fun (label, _) -> - match label with - | Asttypes.Labelled "children" -> false - | Asttypes.Nolabel -> false - | _ -> true) - in - let maybeChildren = - arguments - |> List.find_opt (fun (label, _) -> - label = Asttypes.Labelled "children") + attach t.trailing callExpr.pexp_loc afterExpr; + walkList (arguments |> List.map (fun (_, e) -> ExprArgument e)) t rest + | Pexp_fun (_, _, _, _) | Pexp_newtype _ -> ( + let _, parameters, returnExpr = funExpr expr in + let comments = + visitListButContinueWithRemainingComments ~newlineDelimited:false + ~walkNode:walkExprPararameter + ~getLoc:(fun (_attrs, _argLbl, exprOpt, pattern) -> + let open Parsetree in + let startPos = + match pattern.ppat_attributes with + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _attrs -> + loc.loc_start + | _ -> pattern.ppat_loc.loc_start + in + match exprOpt with + | None -> { pattern.ppat_loc with loc_start = startPos } + | Some expr -> + { + pattern.ppat_loc with + loc_start = startPos; + loc_end = expr.pexp_loc.loc_end; + }) + parameters t comments in - match maybeChildren with - (* There is no need to deal with this situation as the children cannot be NONE *) - | None -> () - | Some (_, children) -> - let leading, inside, _ = partitionByLoc after children.pexp_loc in - if props = [] then - (* All comments inside a tag are trailing comments of the tag if there are no props - - *) - let afterExpr, _ = - partitionAdjacentTrailing callExpr.pexp_loc after + match returnExpr.pexp_desc with + | Pexp_constraint (expr, typ) + when expr.pexp_loc.loc_start.pos_cnum >= typ.ptyp_loc.loc_end.pos_cnum + -> + let leading, inside, trailing = + partitionByLoc comments typ.ptyp_loc in - attach t.trailing callExpr.pexp_loc afterExpr - else - walkList (props |> List.map (fun (_, e) -> ExprArgument e)) t leading; - walkExpression children t inside) - else - let afterExpr, rest = partitionAdjacentTrailing callExpr.pexp_loc after in - attach t.trailing callExpr.pexp_loc afterExpr; - walkList (arguments |> List.map (fun (_, e) -> ExprArgument e)) t rest - | Pexp_fun (_, _, _, _) | Pexp_newtype _ -> ( - let _, parameters, returnExpr = funExpr expr in - let comments = - visitListButContinueWithRemainingComments ~newlineDelimited:false - ~walkNode:walkExprPararameter - ~getLoc:(fun (_attrs, _argLbl, exprOpt, pattern) -> - let open Parsetree in - let startPos = - match pattern.ppat_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _attrs -> - loc.loc_start - | _ -> pattern.ppat_loc.loc_start + attach t.leading typ.ptyp_loc leading; + walkCoreType typ t inside; + let afterTyp, comments = + partitionAdjacentTrailing typ.ptyp_loc trailing in - match exprOpt with - | None -> {pattern.ppat_loc with loc_start = startPos} - | Some expr -> - { - pattern.ppat_loc with - loc_start = startPos; - loc_end = expr.pexp_loc.loc_end; - }) - parameters t comments - in - match returnExpr.pexp_desc with - | Pexp_constraint (expr, typ) - when expr.pexp_loc.loc_start.pos_cnum >= typ.ptyp_loc.loc_end.pos_cnum -> - let leading, inside, trailing = partitionByLoc comments typ.ptyp_loc in - attach t.leading typ.ptyp_loc leading; - walkCoreType typ t inside; - let afterTyp, comments = - partitionAdjacentTrailing typ.ptyp_loc trailing - in - attach t.trailing typ.ptyp_loc afterTyp; - if isBlockExpr expr then walkExpression expr t comments - else - let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; - attach t.trailing expr.pexp_loc trailing - | _ -> - if isBlockExpr returnExpr then walkExpression returnExpr t comments - else - let leading, inside, trailing = - partitionByLoc comments returnExpr.pexp_loc - in - attach t.leading returnExpr.pexp_loc leading; - walkExpression returnExpr t inside; - attach t.trailing returnExpr.pexp_loc trailing) + attach t.trailing typ.ptyp_loc afterTyp; + if isBlockExpr expr then walkExpression expr t comments + else + let leading, inside, trailing = + partitionByLoc comments expr.pexp_loc + in + attach t.leading expr.pexp_loc leading; + walkExpression expr t inside; + attach t.trailing expr.pexp_loc trailing + | _ -> + if isBlockExpr returnExpr then walkExpression returnExpr t comments + else + let leading, inside, trailing = + partitionByLoc comments returnExpr.pexp_loc + in + attach t.leading returnExpr.pexp_loc leading; + walkExpression returnExpr t inside; + attach t.trailing returnExpr.pexp_loc trailing) | _ -> () and walkExprPararameter (_attrs, _argLbl, exprOpt, pattern) t comments = @@ -51372,52 +51495,54 @@ and walkExprPararameter (_attrs, _argLbl, exprOpt, pattern) t comments = walkPattern pattern t inside; match exprOpt with | Some expr -> - let _afterPat, rest = partitionAdjacentTrailing pattern.ppat_loc trailing in - attach t.trailing pattern.ppat_loc trailing; - if isBlockExpr expr then walkExpression expr t rest - else - let leading, inside, trailing = partitionByLoc rest expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; - attach t.trailing expr.pexp_loc trailing + let _afterPat, rest = + partitionAdjacentTrailing pattern.ppat_loc trailing + in + attach t.trailing pattern.ppat_loc trailing; + if isBlockExpr expr then walkExpression expr t rest + else + let leading, inside, trailing = partitionByLoc rest expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + walkExpression expr t inside; + attach t.trailing expr.pexp_loc trailing | None -> attach t.trailing pattern.ppat_loc trailing and walkExprArgument expr t comments = match expr.Parsetree.pexp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _attrs -> - let leading, trailing = partitionLeadingTrailing comments loc in - attach t.leading loc leading; - let afterLabel, rest = partitionAdjacentTrailing loc trailing in - attach t.trailing loc afterLabel; - let before, inside, after = partitionByLoc rest expr.pexp_loc in - attach t.leading expr.pexp_loc before; - walkExpression expr t inside; - attach t.trailing expr.pexp_loc after + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _attrs -> + let leading, trailing = partitionLeadingTrailing comments loc in + attach t.leading loc leading; + let afterLabel, rest = partitionAdjacentTrailing loc trailing in + attach t.trailing loc afterLabel; + let before, inside, after = partitionByLoc rest expr.pexp_loc in + attach t.leading expr.pexp_loc before; + walkExpression expr t inside; + attach t.trailing expr.pexp_loc after | _ -> - let before, inside, after = partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc before; - walkExpression expr t inside; - attach t.trailing expr.pexp_loc after + let before, inside, after = partitionByLoc comments expr.pexp_loc in + attach t.leading expr.pexp_loc before; + walkExpression expr t inside; + attach t.trailing expr.pexp_loc after and walkCase (case : Parsetree.case) t comments = let before, inside, after = partitionByLoc comments case.pc_lhs.ppat_loc in (* cases don't have a location on their own, leading comments should go * after the bar on the pattern *) - walkPattern case.pc_lhs t (List.concat [before; inside]); + walkPattern case.pc_lhs t (List.concat [ before; inside ]); let afterPat, rest = partitionAdjacentTrailing case.pc_lhs.ppat_loc after in attach t.trailing case.pc_lhs.ppat_loc afterPat; let comments = match case.pc_guard with | Some expr -> - let before, inside, after = partitionByLoc rest expr.pexp_loc in - let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc after in - if isBlockExpr expr then - walkExpression expr t (List.concat [before; inside; afterExpr]) - else ( - attach t.leading expr.pexp_loc before; - walkExpression expr t inside; - attach t.trailing expr.pexp_loc afterExpr); - rest + let before, inside, after = partitionByLoc rest expr.pexp_loc in + let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc after in + if isBlockExpr expr then + walkExpression expr t (List.concat [ before; inside; afterExpr ]) + else ( + attach t.leading expr.pexp_loc before; + walkExpression expr t inside; + attach t.trailing expr.pexp_loc afterExpr); + rest | None -> rest in if isBlockExpr case.pc_rhs then walkExpression case.pc_rhs t comments @@ -51455,89 +51580,91 @@ and walkExtensionConstructor extConstr t comments = and walkExtensionConstructorKind kind t comments = match kind with | Pext_rebind longident -> - let leading, trailing = partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc leading; - attach t.trailing longident.loc trailing + let leading, trailing = partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc leading; + attach t.trailing longident.loc trailing | Pext_decl (constructorArguments, maybeTypExpr) -> ( - let rest = walkConstructorArguments constructorArguments t comments in - match maybeTypExpr with - | None -> () - | Some typexpr -> - let before, inside, after = partitionByLoc rest typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc before; - walkCoreType typexpr t inside; - attach t.trailing typexpr.ptyp_loc after) + let rest = walkConstructorArguments constructorArguments t comments in + match maybeTypExpr with + | None -> () + | Some typexpr -> + let before, inside, after = partitionByLoc rest typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc before; + walkCoreType typexpr t inside; + attach t.trailing typexpr.ptyp_loc after) and walkModuleExpr modExpr t comments = match modExpr.pmod_desc with | Pmod_ident longident -> - let before, after = partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc before; - attach t.trailing longident.loc after + let before, after = partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc before; + attach t.trailing longident.loc after | Pmod_structure [] -> attach t.inside modExpr.pmod_loc comments | Pmod_structure structure -> walkStructure structure t comments | Pmod_extension extension -> walkExtension extension t comments | Pmod_unpack expr -> - let before, inside, after = partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc before; - walkExpression expr t inside; - attach t.trailing expr.pexp_loc after + let before, inside, after = partitionByLoc comments expr.pexp_loc in + attach t.leading expr.pexp_loc before; + walkExpression expr t inside; + attach t.trailing expr.pexp_loc after | Pmod_constraint (modexpr, modtype) -> - if modtype.pmty_loc.loc_start >= modexpr.pmod_loc.loc_end then ( - let before, inside, after = partitionByLoc comments modexpr.pmod_loc in - attach t.leading modexpr.pmod_loc before; - walkModuleExpr modexpr t inside; - let after, rest = partitionAdjacentTrailing modexpr.pmod_loc after in - attach t.trailing modexpr.pmod_loc after; - let before, inside, after = partitionByLoc rest modtype.pmty_loc in - attach t.leading modtype.pmty_loc before; - walkModType modtype t inside; - attach t.trailing modtype.pmty_loc after) - else - let before, inside, after = partitionByLoc comments modtype.pmty_loc in - attach t.leading modtype.pmty_loc before; - walkModType modtype t inside; - let after, rest = partitionAdjacentTrailing modtype.pmty_loc after in - attach t.trailing modtype.pmty_loc after; - let before, inside, after = partitionByLoc rest modexpr.pmod_loc in - attach t.leading modexpr.pmod_loc before; - walkModuleExpr modexpr t inside; - attach t.trailing modexpr.pmod_loc after + if modtype.pmty_loc.loc_start >= modexpr.pmod_loc.loc_end then ( + let before, inside, after = partitionByLoc comments modexpr.pmod_loc in + attach t.leading modexpr.pmod_loc before; + walkModuleExpr modexpr t inside; + let after, rest = partitionAdjacentTrailing modexpr.pmod_loc after in + attach t.trailing modexpr.pmod_loc after; + let before, inside, after = partitionByLoc rest modtype.pmty_loc in + attach t.leading modtype.pmty_loc before; + walkModType modtype t inside; + attach t.trailing modtype.pmty_loc after) + else + let before, inside, after = partitionByLoc comments modtype.pmty_loc in + attach t.leading modtype.pmty_loc before; + walkModType modtype t inside; + let after, rest = partitionAdjacentTrailing modtype.pmty_loc after in + attach t.trailing modtype.pmty_loc after; + let before, inside, after = partitionByLoc rest modexpr.pmod_loc in + attach t.leading modexpr.pmod_loc before; + walkModuleExpr modexpr t inside; + attach t.trailing modexpr.pmod_loc after | Pmod_apply (_callModExpr, _argModExpr) -> - let modExprs = modExprApply modExpr in - walkList (modExprs |> List.map (fun me -> ModuleExpr me)) t comments + let modExprs = modExprApply modExpr in + walkList (modExprs |> List.map (fun me -> ModuleExpr me)) t comments | Pmod_functor _ -> ( - let parameters, returnModExpr = modExprFunctor modExpr in - let comments = - visitListButContinueWithRemainingComments - ~getLoc:(fun (_, lbl, modTypeOption) -> - match modTypeOption with - | None -> lbl.Asttypes.loc - | Some modType -> - {lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end}) - ~walkNode:walkModExprParameter ~newlineDelimited:false parameters t - comments - in - match returnModExpr.pmod_desc with - | Pmod_constraint (modExpr, modType) - when modType.pmty_loc.loc_end.pos_cnum - <= modExpr.pmod_loc.loc_start.pos_cnum -> - let before, inside, after = partitionByLoc comments modType.pmty_loc in - attach t.leading modType.pmty_loc before; - walkModType modType t inside; - let after, rest = partitionAdjacentTrailing modType.pmty_loc after in - attach t.trailing modType.pmty_loc after; - let before, inside, after = partitionByLoc rest modExpr.pmod_loc in - attach t.leading modExpr.pmod_loc before; - walkModuleExpr modExpr t inside; - attach t.trailing modExpr.pmod_loc after - | _ -> - let before, inside, after = - partitionByLoc comments returnModExpr.pmod_loc + let parameters, returnModExpr = modExprFunctor modExpr in + let comments = + visitListButContinueWithRemainingComments + ~getLoc:(fun (_, lbl, modTypeOption) -> + match modTypeOption with + | None -> lbl.Asttypes.loc + | Some modType -> + { lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end }) + ~walkNode:walkModExprParameter ~newlineDelimited:false parameters t + comments in - attach t.leading returnModExpr.pmod_loc before; - walkModuleExpr returnModExpr t inside; - attach t.trailing returnModExpr.pmod_loc after) + match returnModExpr.pmod_desc with + | Pmod_constraint (modExpr, modType) + when modType.pmty_loc.loc_end.pos_cnum + <= modExpr.pmod_loc.loc_start.pos_cnum -> + let before, inside, after = + partitionByLoc comments modType.pmty_loc + in + attach t.leading modType.pmty_loc before; + walkModType modType t inside; + let after, rest = partitionAdjacentTrailing modType.pmty_loc after in + attach t.trailing modType.pmty_loc after; + let before, inside, after = partitionByLoc rest modExpr.pmod_loc in + attach t.leading modExpr.pmod_loc before; + walkModuleExpr modExpr t inside; + attach t.trailing modExpr.pmod_loc after + | _ -> + let before, inside, after = + partitionByLoc comments returnModExpr.pmod_loc + in + attach t.leading returnModExpr.pmod_loc before; + walkModuleExpr returnModExpr t inside; + attach t.trailing returnModExpr.pmod_loc after) and walkModExprParameter parameter t comments = let _attrs, lbl, modTypeOption = parameter in @@ -51546,52 +51673,53 @@ and walkModExprParameter parameter t comments = match modTypeOption with | None -> attach t.trailing lbl.loc trailing | Some modType -> - let afterLbl, rest = partitionAdjacentTrailing lbl.loc trailing in - attach t.trailing lbl.loc afterLbl; - let before, inside, after = partitionByLoc rest modType.pmty_loc in - attach t.leading modType.pmty_loc before; - walkModType modType t inside; - attach t.trailing modType.pmty_loc after + let afterLbl, rest = partitionAdjacentTrailing lbl.loc trailing in + attach t.trailing lbl.loc afterLbl; + let before, inside, after = partitionByLoc rest modType.pmty_loc in + attach t.leading modType.pmty_loc before; + walkModType modType t inside; + attach t.trailing modType.pmty_loc after and walkModType modType t comments = match modType.pmty_desc with | Pmty_ident longident | Pmty_alias longident -> - let leading, trailing = partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc leading; - attach t.trailing longident.loc trailing + let leading, trailing = partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc leading; + attach t.trailing longident.loc trailing | Pmty_signature [] -> attach t.inside modType.pmty_loc comments | Pmty_signature signature -> walkSignature signature t comments | Pmty_extension extension -> walkExtension extension t comments | Pmty_typeof modExpr -> - let before, inside, after = partitionByLoc comments modExpr.pmod_loc in - attach t.leading modExpr.pmod_loc before; - walkModuleExpr modExpr t inside; - attach t.trailing modExpr.pmod_loc after + let before, inside, after = partitionByLoc comments modExpr.pmod_loc in + attach t.leading modExpr.pmod_loc before; + walkModuleExpr modExpr t inside; + attach t.trailing modExpr.pmod_loc after | Pmty_with (modType, _withConstraints) -> - let before, inside, after = partitionByLoc comments modType.pmty_loc in - attach t.leading modType.pmty_loc before; - walkModType modType t inside; - attach t.trailing modType.pmty_loc after - (* TODO: withConstraints*) + let before, inside, after = partitionByLoc comments modType.pmty_loc in + attach t.leading modType.pmty_loc before; + walkModType modType t inside; + attach t.trailing modType.pmty_loc after + (* TODO: withConstraints*) | Pmty_functor _ -> - let parameters, returnModType = functorType modType in - let comments = - visitListButContinueWithRemainingComments - ~getLoc:(fun (_, lbl, modTypeOption) -> - match modTypeOption with - | None -> lbl.Asttypes.loc - | Some modType -> - if lbl.txt = "_" then modType.Parsetree.pmty_loc - else {lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end}) - ~walkNode:walkModTypeParameter ~newlineDelimited:false parameters t - comments - in - let before, inside, after = - partitionByLoc comments returnModType.pmty_loc - in - attach t.leading returnModType.pmty_loc before; - walkModType returnModType t inside; - attach t.trailing returnModType.pmty_loc after + let parameters, returnModType = functorType modType in + let comments = + visitListButContinueWithRemainingComments + ~getLoc:(fun (_, lbl, modTypeOption) -> + match modTypeOption with + | None -> lbl.Asttypes.loc + | Some modType -> + if lbl.txt = "_" then modType.Parsetree.pmty_loc + else + { lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end }) + ~walkNode:walkModTypeParameter ~newlineDelimited:false parameters t + comments + in + let before, inside, after = + partitionByLoc comments returnModType.pmty_loc + in + attach t.leading returnModType.pmty_loc before; + walkModType returnModType t inside; + attach t.trailing returnModType.pmty_loc after and walkModTypeParameter (_, lbl, modTypeOption) t comments = let leading, trailing = partitionLeadingTrailing comments lbl.loc in @@ -51599,92 +51727,94 @@ and walkModTypeParameter (_, lbl, modTypeOption) t comments = match modTypeOption with | None -> attach t.trailing lbl.loc trailing | Some modType -> - let afterLbl, rest = partitionAdjacentTrailing lbl.loc trailing in - attach t.trailing lbl.loc afterLbl; - let before, inside, after = partitionByLoc rest modType.pmty_loc in - attach t.leading modType.pmty_loc before; - walkModType modType t inside; - attach t.trailing modType.pmty_loc after + let afterLbl, rest = partitionAdjacentTrailing lbl.loc trailing in + attach t.trailing lbl.loc afterLbl; + let before, inside, after = partitionByLoc rest modType.pmty_loc in + attach t.leading modType.pmty_loc before; + walkModType modType t inside; + attach t.trailing modType.pmty_loc after and walkPattern pat t comments = let open Location in match pat.Parsetree.ppat_desc with | _ when comments = [] -> () | Ppat_alias (pat, alias) -> - let leading, inside, trailing = partitionByLoc comments pat.ppat_loc in - attach t.leading pat.ppat_loc leading; - walkPattern pat t inside; - let afterPat, rest = partitionAdjacentTrailing pat.ppat_loc trailing in - attach t.leading pat.ppat_loc leading; - attach t.trailing pat.ppat_loc afterPat; - let beforeAlias, afterAlias = partitionLeadingTrailing rest alias.loc in - attach t.leading alias.loc beforeAlias; - attach t.trailing alias.loc afterAlias + let leading, inside, trailing = partitionByLoc comments pat.ppat_loc in + attach t.leading pat.ppat_loc leading; + walkPattern pat t inside; + let afterPat, rest = partitionAdjacentTrailing pat.ppat_loc trailing in + attach t.leading pat.ppat_loc leading; + attach t.trailing pat.ppat_loc afterPat; + let beforeAlias, afterAlias = partitionLeadingTrailing rest alias.loc in + attach t.leading alias.loc beforeAlias; + attach t.trailing alias.loc afterAlias | Ppat_tuple [] | Ppat_array [] - | Ppat_construct ({txt = Longident.Lident "()"}, _) - | Ppat_construct ({txt = Longident.Lident "[]"}, _) -> - attach t.inside pat.ppat_loc comments + | Ppat_construct ({ txt = Longident.Lident "()" }, _) + | Ppat_construct ({ txt = Longident.Lident "[]" }, _) -> + attach t.inside pat.ppat_loc comments | Ppat_array patterns -> - walkList (patterns |> List.map (fun p -> Pattern p)) t comments + walkList (patterns |> List.map (fun p -> Pattern p)) t comments | Ppat_tuple patterns -> - walkList (patterns |> List.map (fun p -> Pattern p)) t comments - | Ppat_construct ({txt = Longident.Lident "::"}, _) -> - walkList - (collectListPatterns [] pat |> List.map (fun p -> Pattern p)) - t comments + walkList (patterns |> List.map (fun p -> Pattern p)) t comments + | Ppat_construct ({ txt = Longident.Lident "::" }, _) -> + walkList + (collectListPatterns [] pat |> List.map (fun p -> Pattern p)) + t comments | Ppat_construct (constr, None) -> - let beforeConstr, afterConstr = - partitionLeadingTrailing comments constr.loc - in - attach t.leading constr.loc beforeConstr; - attach t.trailing constr.loc afterConstr + let beforeConstr, afterConstr = + partitionLeadingTrailing comments constr.loc + in + attach t.leading constr.loc beforeConstr; + attach t.trailing constr.loc afterConstr | Ppat_construct (constr, Some pat) -> - let leading, trailing = partitionLeadingTrailing comments constr.loc in - attach t.leading constr.loc leading; - let afterConstructor, rest = - partitionAdjacentTrailing constr.loc trailing - in - attach t.trailing constr.loc afterConstructor; - let leading, inside, trailing = partitionByLoc rest pat.ppat_loc in - attach t.leading pat.ppat_loc leading; - walkPattern pat t inside; - attach t.trailing pat.ppat_loc trailing + let leading, trailing = partitionLeadingTrailing comments constr.loc in + attach t.leading constr.loc leading; + let afterConstructor, rest = + partitionAdjacentTrailing constr.loc trailing + in + attach t.trailing constr.loc afterConstructor; + let leading, inside, trailing = partitionByLoc rest pat.ppat_loc in + attach t.leading pat.ppat_loc leading; + walkPattern pat t inside; + attach t.trailing pat.ppat_loc trailing | Ppat_variant (_label, None) -> () | Ppat_variant (_label, Some pat) -> walkPattern pat t comments | Ppat_type _ -> () | Ppat_record (recordRows, _) -> - walkList - (recordRows |> List.map (fun (li, p) -> PatternRecordRow (li, p))) - t comments + walkList + (recordRows |> List.map (fun (li, p) -> PatternRecordRow (li, p))) + t comments | Ppat_or _ -> - walkList - (Res_parsetree_viewer.collectOrPatternChain pat - |> List.map (fun pat -> Pattern pat)) - t comments + walkList + (Res_parsetree_viewer.collectOrPatternChain pat + |> List.map (fun pat -> Pattern pat)) + t comments | Ppat_constraint (pattern, typ) -> - let beforePattern, insidePattern, afterPattern = - partitionByLoc comments pattern.ppat_loc - in - attach t.leading pattern.ppat_loc beforePattern; - walkPattern pattern t insidePattern; - let afterPattern, rest = - partitionAdjacentTrailing pattern.ppat_loc afterPattern - in - attach t.trailing pattern.ppat_loc afterPattern; - let beforeTyp, insideTyp, afterTyp = partitionByLoc rest typ.ptyp_loc in - attach t.leading typ.ptyp_loc beforeTyp; - walkCoreType typ t insideTyp; - attach t.trailing typ.ptyp_loc afterTyp + let beforePattern, insidePattern, afterPattern = + partitionByLoc comments pattern.ppat_loc + in + attach t.leading pattern.ppat_loc beforePattern; + walkPattern pattern t insidePattern; + let afterPattern, rest = + partitionAdjacentTrailing pattern.ppat_loc afterPattern + in + attach t.trailing pattern.ppat_loc afterPattern; + let beforeTyp, insideTyp, afterTyp = partitionByLoc rest typ.ptyp_loc in + attach t.leading typ.ptyp_loc beforeTyp; + walkCoreType typ t insideTyp; + attach t.trailing typ.ptyp_loc afterTyp | Ppat_lazy pattern | Ppat_exception pattern -> - let leading, inside, trailing = partitionByLoc comments pattern.ppat_loc in - attach t.leading pattern.ppat_loc leading; - walkPattern pattern t inside; - attach t.trailing pattern.ppat_loc trailing + let leading, inside, trailing = + partitionByLoc comments pattern.ppat_loc + in + attach t.leading pattern.ppat_loc leading; + walkPattern pattern t inside; + attach t.trailing pattern.ppat_loc trailing | Ppat_unpack stringLoc -> - let leading, trailing = partitionLeadingTrailing comments stringLoc.loc in - attach t.leading stringLoc.loc leading; - attach t.trailing stringLoc.loc trailing + let leading, trailing = partitionLeadingTrailing comments stringLoc.loc in + attach t.leading stringLoc.loc leading; + attach t.trailing stringLoc.loc trailing | Ppat_extension extension -> walkExtension extension t comments | _ -> () @@ -51692,83 +51822,87 @@ and walkPattern pat t comments = and walkPatternRecordRow row t comments = match row with (* punned {x}*) - | ( {Location.txt = Longident.Lident ident; loc = longidentLoc}, - {Parsetree.ppat_desc = Ppat_var {txt; _}} ) + | ( { Location.txt = Longident.Lident ident; loc = longidentLoc }, + { Parsetree.ppat_desc = Ppat_var { txt; _ } } ) when ident = txt -> - let beforeLbl, afterLbl = partitionLeadingTrailing comments longidentLoc in - attach t.leading longidentLoc beforeLbl; - attach t.trailing longidentLoc afterLbl + let beforeLbl, afterLbl = + partitionLeadingTrailing comments longidentLoc + in + attach t.leading longidentLoc beforeLbl; + attach t.trailing longidentLoc afterLbl | longident, pattern -> - let beforeLbl, afterLbl = partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc beforeLbl; - let afterLbl, rest = partitionAdjacentTrailing longident.loc afterLbl in - attach t.trailing longident.loc afterLbl; - let leading, inside, trailing = partitionByLoc rest pattern.ppat_loc in - attach t.leading pattern.ppat_loc leading; - walkPattern pattern t inside; - attach t.trailing pattern.ppat_loc trailing + let beforeLbl, afterLbl = + partitionLeadingTrailing comments longident.loc + in + attach t.leading longident.loc beforeLbl; + let afterLbl, rest = partitionAdjacentTrailing longident.loc afterLbl in + attach t.trailing longident.loc afterLbl; + let leading, inside, trailing = partitionByLoc rest pattern.ppat_loc in + attach t.leading pattern.ppat_loc leading; + walkPattern pattern t inside; + attach t.trailing pattern.ppat_loc trailing and walkRowField (rowField : Parsetree.row_field) t comments = match rowField with - | Parsetree.Rtag ({loc}, _, _, _) -> - let before, after = partitionLeadingTrailing comments loc in - attach t.leading loc before; - attach t.trailing loc after + | Parsetree.Rtag ({ loc }, _, _, _) -> + let before, after = partitionLeadingTrailing comments loc in + attach t.leading loc before; + attach t.trailing loc after | Rinherit _ -> () and walkCoreType typ t comments = match typ.Parsetree.ptyp_desc with | _ when comments = [] -> () | Ptyp_tuple typexprs -> - walkList (typexprs |> List.map (fun ct -> CoreType ct)) t comments + walkList (typexprs |> List.map (fun ct -> CoreType ct)) t comments | Ptyp_extension extension -> walkExtension extension t comments | Ptyp_package packageType -> walkPackageType packageType t comments | Ptyp_alias (typexpr, _alias) -> - let beforeTyp, insideTyp, afterTyp = - partitionByLoc comments typexpr.ptyp_loc - in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - attach t.trailing typexpr.ptyp_loc afterTyp + let beforeTyp, insideTyp, afterTyp = + partitionByLoc comments typexpr.ptyp_loc + in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkCoreType typexpr t insideTyp; + attach t.trailing typexpr.ptyp_loc afterTyp | Ptyp_poly (strings, typexpr) -> - let comments = - visitListButContinueWithRemainingComments - ~getLoc:(fun n -> n.Asttypes.loc) - ~walkNode:(fun longident t comments -> - let beforeLongident, afterLongident = - partitionLeadingTrailing comments longident.loc - in - attach t.leading longident.loc beforeLongident; - attach t.trailing longident.loc afterLongident) - ~newlineDelimited:false strings t comments - in - let beforeTyp, insideTyp, afterTyp = - partitionByLoc comments typexpr.ptyp_loc - in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - attach t.trailing typexpr.ptyp_loc afterTyp + let comments = + visitListButContinueWithRemainingComments + ~getLoc:(fun n -> n.Asttypes.loc) + ~walkNode:(fun longident t comments -> + let beforeLongident, afterLongident = + partitionLeadingTrailing comments longident.loc + in + attach t.leading longident.loc beforeLongident; + attach t.trailing longident.loc afterLongident) + ~newlineDelimited:false strings t comments + in + let beforeTyp, insideTyp, afterTyp = + partitionByLoc comments typexpr.ptyp_loc + in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkCoreType typexpr t insideTyp; + attach t.trailing typexpr.ptyp_loc afterTyp | Ptyp_variant (rowFields, _, _) -> - walkList (rowFields |> List.map (fun rf -> RowField rf)) t comments + walkList (rowFields |> List.map (fun rf -> RowField rf)) t comments | Ptyp_constr (longident, typexprs) -> - let beforeLongident, _afterLongident = - partitionLeadingTrailing comments longident.loc - in - let afterLongident, rest = - partitionAdjacentTrailing longident.loc comments - in - attach t.leading longident.loc beforeLongident; - attach t.trailing longident.loc afterLongident; - walkList (typexprs |> List.map (fun ct -> CoreType ct)) t rest + let beforeLongident, _afterLongident = + partitionLeadingTrailing comments longident.loc + in + let afterLongident, rest = + partitionAdjacentTrailing longident.loc comments + in + attach t.leading longident.loc beforeLongident; + attach t.trailing longident.loc afterLongident; + walkList (typexprs |> List.map (fun ct -> CoreType ct)) t rest | Ptyp_arrow _ -> - let _, parameters, typexpr = arrowType typ in - let comments = walkTypeParameters parameters t comments in - let beforeTyp, insideTyp, afterTyp = - partitionByLoc comments typexpr.ptyp_loc - in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - attach t.trailing typexpr.ptyp_loc afterTyp + let _, parameters, typexpr = arrowType typ in + let comments = walkTypeParameters parameters t comments in + let beforeTyp, insideTyp, afterTyp = + partitionByLoc comments typexpr.ptyp_loc + in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkCoreType typexpr t insideTyp; + attach t.trailing typexpr.ptyp_loc afterTyp | Ptyp_object (fields, _) -> walkTypObjectFields fields t comments | _ -> () @@ -51778,22 +51912,24 @@ and walkTypObjectFields fields t comments = and walkObjectField field t comments = match field with | Otag (lbl, _, typexpr) -> - let beforeLbl, afterLbl = partitionLeadingTrailing comments lbl.loc in - attach t.leading lbl.loc beforeLbl; - let afterLbl, rest = partitionAdjacentTrailing lbl.loc afterLbl in - attach t.trailing lbl.loc afterLbl; - let beforeTyp, insideTyp, afterTyp = partitionByLoc rest typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - attach t.trailing typexpr.ptyp_loc afterTyp + let beforeLbl, afterLbl = partitionLeadingTrailing comments lbl.loc in + attach t.leading lbl.loc beforeLbl; + let afterLbl, rest = partitionAdjacentTrailing lbl.loc afterLbl in + attach t.trailing lbl.loc afterLbl; + let beforeTyp, insideTyp, afterTyp = + partitionByLoc rest typexpr.ptyp_loc + in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkCoreType typexpr t insideTyp; + attach t.trailing typexpr.ptyp_loc afterTyp | _ -> () and walkTypeParameters typeParameters t comments = visitListButContinueWithRemainingComments ~getLoc:(fun (_, _, typexpr) -> match typexpr.Parsetree.ptyp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _attrs -> - {loc with loc_end = typexpr.ptyp_loc.loc_end} + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _attrs -> + { loc with loc_end = typexpr.ptyp_loc.loc_end } | _ -> typexpr.ptyp_loc) ~walkNode:walkTypeParameter ~newlineDelimited:false typeParameters t comments @@ -51854,9 +51990,7 @@ and walkAttribute (id, payload) t comments = walkPayload payload t rest and walkPayload payload t comments = - match payload with - | PStr s -> walkStructure s t comments - | _ -> () + match payload with PStr s -> walkStructure s t comments | _ -> () end module Res_parens : sig @@ -51865,172 +51999,166 @@ type kind = Parenthesized | Braced of Location.t | Nothing val expr : Parsetree.expression -> kind val structureExpr : Parsetree.expression -> kind - val unaryExprOperand : Parsetree.expression -> kind - val binaryExprOperand : isLhs:bool -> Parsetree.expression -> kind val subBinaryExprOperand : string -> string -> bool val rhsBinaryExprOperand : string -> Parsetree.expression -> bool val flattenOperandRhs : string -> Parsetree.expression -> bool - val lazyOrAssertOrAwaitExprRhs : Parsetree.expression -> kind - val fieldExpr : Parsetree.expression -> kind - val setFieldExprRhs : Parsetree.expression -> kind - val ternaryOperand : Parsetree.expression -> kind - val jsxPropExpr : Parsetree.expression -> kind val jsxChildExpr : Parsetree.expression -> kind - val binaryExpr : Parsetree.expression -> kind val modTypeFunctorReturn : Parsetree.module_type -> bool val modTypeWithOperand : Parsetree.module_type -> bool val modExprFunctorConstraint : Parsetree.module_type -> bool - val bracedExpr : Parsetree.expression -> bool val callExpr : Parsetree.expression -> kind - val includeModExpr : Parsetree.module_expr -> bool - val arrowReturnTypExpr : Parsetree.core_type -> bool - val patternRecordRowRhs : Parsetree.pattern -> bool end = struct #1 "res_parens.ml" module ParsetreeViewer = Res_parsetree_viewer + type kind = Parenthesized | Braced of Location.t | Nothing let expr expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc | _ -> ( - match expr with - | { - Parsetree.pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_constraint _} -> Parenthesized - | _ -> Nothing) + match expr with + | { + Parsetree.pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + } -> + Nothing + | { pexp_desc = Pexp_constraint _ } -> Parenthesized + | _ -> Nothing) let callExpr expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc | _ -> ( - match expr with - | {Parsetree.pexp_attributes = attrs} - when match ParsetreeViewer.filterParsingAttrs attrs with - | _ :: _ -> true - | [] -> false -> - Parenthesized - | _ - when ParsetreeViewer.isUnaryExpression expr - || ParsetreeViewer.isBinaryExpression expr -> - Parenthesized - | { - Parsetree.pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_fun _} when ParsetreeViewer.isUnderscoreApplySugar expr - -> - Nothing - | { - pexp_desc = - ( Pexp_lazy _ | Pexp_assert _ | Pexp_fun _ | Pexp_newtype _ - | Pexp_function _ | Pexp_constraint _ | Pexp_setfield _ | Pexp_match _ - | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_ifthenelse _ ); - } -> - Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> - Parenthesized - | _ -> Nothing) + match expr with + | { Parsetree.pexp_attributes = attrs } + when match ParsetreeViewer.filterParsingAttrs attrs with + | _ :: _ -> true + | [] -> false -> + Parenthesized + | _ + when ParsetreeViewer.isUnaryExpression expr + || ParsetreeViewer.isBinaryExpression expr -> + Parenthesized + | { + Parsetree.pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + } -> + Nothing + | { pexp_desc = Pexp_fun _ } + when ParsetreeViewer.isUnderscoreApplySugar expr -> + Nothing + | { + pexp_desc = + ( Pexp_lazy _ | Pexp_assert _ | Pexp_fun _ | Pexp_newtype _ + | Pexp_function _ | Pexp_constraint _ | Pexp_setfield _ | Pexp_match _ + | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_ifthenelse _ ); + } -> + Parenthesized + | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> + Parenthesized + | _ -> Nothing) let structureExpr expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc | None -> ( - match expr with - | _ - when ParsetreeViewer.hasAttributes expr.pexp_attributes - && not (ParsetreeViewer.isJsxExpression expr) -> - Parenthesized - | { - Parsetree.pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_constraint _} -> Parenthesized - | _ -> Nothing) + match expr with + | _ + when ParsetreeViewer.hasAttributes expr.pexp_attributes + && not (ParsetreeViewer.isJsxExpression expr) -> + Parenthesized + | { + Parsetree.pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + } -> + Nothing + | { pexp_desc = Pexp_constraint _ } -> Parenthesized + | _ -> Nothing) let unaryExprOperand expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc | None -> ( - match expr with - | {Parsetree.pexp_attributes = attrs} - when match ParsetreeViewer.filterParsingAttrs attrs with - | _ :: _ -> true - | [] -> false -> - Parenthesized - | expr - when ParsetreeViewer.isUnaryExpression expr - || ParsetreeViewer.isBinaryExpression expr -> - Parenthesized - | { - pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_fun _} when ParsetreeViewer.isUnderscoreApplySugar expr - -> - Nothing - | { - pexp_desc = - ( Pexp_lazy _ | Pexp_assert _ | Pexp_fun _ | Pexp_newtype _ - | Pexp_function _ | Pexp_constraint _ | Pexp_setfield _ - | Pexp_extension _ (* readability? maybe remove *) | Pexp_match _ - | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_ifthenelse _ ); - } -> - Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> - Parenthesized - | _ -> Nothing) + match expr with + | { Parsetree.pexp_attributes = attrs } + when match ParsetreeViewer.filterParsingAttrs attrs with + | _ :: _ -> true + | [] -> false -> + Parenthesized + | expr + when ParsetreeViewer.isUnaryExpression expr + || ParsetreeViewer.isBinaryExpression expr -> + Parenthesized + | { + pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + } -> + Nothing + | { pexp_desc = Pexp_fun _ } + when ParsetreeViewer.isUnderscoreApplySugar expr -> + Nothing + | { + pexp_desc = + ( Pexp_lazy _ | Pexp_assert _ | Pexp_fun _ | Pexp_newtype _ + | Pexp_function _ | Pexp_constraint _ | Pexp_setfield _ + | Pexp_extension _ (* readability? maybe remove *) | Pexp_match _ + | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_ifthenelse _ ); + } -> + Parenthesized + | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> + Parenthesized + | _ -> Nothing) let binaryExprOperand ~isLhs expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc | None -> ( - match expr with - | { - Parsetree.pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_fun _} when ParsetreeViewer.isUnderscoreApplySugar expr - -> - Nothing - | { - pexp_desc = - Pexp_constraint _ | Pexp_fun _ | Pexp_function _ | Pexp_newtype _; - } -> - Parenthesized - | expr when ParsetreeViewer.isBinaryExpression expr -> Parenthesized - | expr when ParsetreeViewer.isTernaryExpr expr -> Parenthesized - | {pexp_desc = Pexp_lazy _ | Pexp_assert _} when isLhs -> Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> - Parenthesized - | {Parsetree.pexp_attributes = attrs} -> - if ParsetreeViewer.hasPrintableAttributes attrs then Parenthesized - else Nothing) + match expr with + | { + Parsetree.pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + } -> + Nothing + | { pexp_desc = Pexp_fun _ } + when ParsetreeViewer.isUnderscoreApplySugar expr -> + Nothing + | { + pexp_desc = + Pexp_constraint _ | Pexp_fun _ | Pexp_function _ | Pexp_newtype _; + } -> + Parenthesized + | expr when ParsetreeViewer.isBinaryExpression expr -> Parenthesized + | expr when ParsetreeViewer.isTernaryExpr expr -> Parenthesized + | { pexp_desc = Pexp_lazy _ | Pexp_assert _ } when isLhs -> Parenthesized + | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> + Parenthesized + | { Parsetree.pexp_attributes = attrs } -> + if ParsetreeViewer.hasPrintableAttributes attrs then Parenthesized + else Nothing) let subBinaryExprOperand parentOperator childOperator = let precParent = ParsetreeViewer.operatorPrecedence parentOperator in @@ -52047,14 +52175,14 @@ let rhsBinaryExprOperand parentOperator rhs = ( { pexp_attributes = []; pexp_desc = - Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}; + Pexp_ident { txt = Longident.Lident operator; loc = operatorLoc }; }, - [(_, _left); (_, _right)] ) + [ (_, _left); (_, _right) ] ) when ParsetreeViewer.isBinaryOperator operator && not (operatorLoc.loc_ghost && operator = "^") -> - let precParent = ParsetreeViewer.operatorPrecedence parentOperator in - let precChild = ParsetreeViewer.operatorPrecedence operator in - precParent == precChild + let precParent = ParsetreeViewer.operatorPrecedence parentOperator in + let precChild = ParsetreeViewer.operatorPrecedence operator in + precParent == precChild | _ -> false let flattenOperandRhs parentOperator rhs = @@ -52062,16 +52190,17 @@ let flattenOperandRhs parentOperator rhs = | Parsetree.Pexp_apply ( { pexp_desc = - Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}; + Pexp_ident { txt = Longident.Lident operator; loc = operatorLoc }; }, - [(_, _left); (_, _right)] ) + [ (_, _left); (_, _right) ] ) when ParsetreeViewer.isBinaryOperator operator && not (operatorLoc.loc_ghost && operator = "^") -> - let precParent = ParsetreeViewer.operatorPrecedence parentOperator in - let precChild = ParsetreeViewer.operatorPrecedence operator in - precParent >= precChild || rhs.pexp_attributes <> [] - | Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}) -> - false + let precParent = ParsetreeViewer.operatorPrecedence parentOperator in + let precChild = ParsetreeViewer.operatorPrecedence operator in + precParent >= precChild || rhs.pexp_attributes <> [] + | Pexp_constraint ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }) + -> + false | Pexp_fun _ when ParsetreeViewer.isUnderscoreApplySugar rhs -> false | Pexp_fun _ | Pexp_newtype _ | Pexp_setfield _ | Pexp_constraint _ -> true | _ when ParsetreeViewer.isTernaryExpr rhs -> true @@ -52080,33 +52209,34 @@ let flattenOperandRhs parentOperator rhs = let lazyOrAssertOrAwaitExprRhs expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc | None -> ( - match expr with - | {Parsetree.pexp_attributes = attrs} - when match ParsetreeViewer.filterParsingAttrs attrs with - | _ :: _ -> true - | [] -> false -> - Parenthesized - | expr when ParsetreeViewer.isBinaryExpression expr -> Parenthesized - | { - pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_fun _} when ParsetreeViewer.isUnderscoreApplySugar expr - -> - Nothing - | { - pexp_desc = - ( Pexp_lazy _ | Pexp_assert _ | Pexp_fun _ | Pexp_newtype _ - | Pexp_function _ | Pexp_constraint _ | Pexp_setfield _ | Pexp_match _ - | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_ifthenelse _ ); - } -> - Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> - Parenthesized - | _ -> Nothing) + match expr with + | { Parsetree.pexp_attributes = attrs } + when match ParsetreeViewer.filterParsingAttrs attrs with + | _ :: _ -> true + | [] -> false -> + Parenthesized + | expr when ParsetreeViewer.isBinaryExpression expr -> Parenthesized + | { + pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + } -> + Nothing + | { pexp_desc = Pexp_fun _ } + when ParsetreeViewer.isUnderscoreApplySugar expr -> + Nothing + | { + pexp_desc = + ( Pexp_lazy _ | Pexp_assert _ | Pexp_fun _ | Pexp_newtype _ + | Pexp_function _ | Pexp_constraint _ | Pexp_setfield _ | Pexp_match _ + | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_ifthenelse _ ); + } -> + Parenthesized + | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> + Parenthesized + | _ -> Nothing) let isNegativeConstant constant = let isNeg txt = @@ -52120,74 +52250,78 @@ let isNegativeConstant constant = let fieldExpr expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc | None -> ( - match expr with - | {Parsetree.pexp_attributes = attrs} - when match ParsetreeViewer.filterParsingAttrs attrs with - | _ :: _ -> true - | [] -> false -> - Parenthesized - | expr - when ParsetreeViewer.isBinaryExpression expr - || ParsetreeViewer.isUnaryExpression expr -> - Parenthesized - | { - pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_constant c} when isNegativeConstant c -> Parenthesized - | {pexp_desc = Pexp_fun _} when ParsetreeViewer.isUnderscoreApplySugar expr - -> - Nothing - | { - pexp_desc = - ( Pexp_lazy _ | Pexp_assert _ - | Pexp_extension _ (* %extension.x vs (%extension).x *) | Pexp_fun _ - | Pexp_newtype _ | Pexp_function _ | Pexp_constraint _ | Pexp_setfield _ - | Pexp_match _ | Pexp_try _ | Pexp_while _ | Pexp_for _ - | Pexp_ifthenelse _ ); - } -> - Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> - Parenthesized - | _ -> Nothing) + match expr with + | { Parsetree.pexp_attributes = attrs } + when match ParsetreeViewer.filterParsingAttrs attrs with + | _ :: _ -> true + | [] -> false -> + Parenthesized + | expr + when ParsetreeViewer.isBinaryExpression expr + || ParsetreeViewer.isUnaryExpression expr -> + Parenthesized + | { + pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + } -> + Nothing + | { pexp_desc = Pexp_constant c } when isNegativeConstant c -> + Parenthesized + | { pexp_desc = Pexp_fun _ } + when ParsetreeViewer.isUnderscoreApplySugar expr -> + Nothing + | { + pexp_desc = + ( Pexp_lazy _ | Pexp_assert _ + | Pexp_extension _ (* %extension.x vs (%extension).x *) | Pexp_fun _ + | Pexp_newtype _ | Pexp_function _ | Pexp_constraint _ + | Pexp_setfield _ | Pexp_match _ | Pexp_try _ | Pexp_while _ + | Pexp_for _ | Pexp_ifthenelse _ ); + } -> + Parenthesized + | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> + Parenthesized + | _ -> Nothing) let setFieldExprRhs expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc | None -> ( - match expr with - | { - Parsetree.pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_constraint _} -> Parenthesized - | _ -> Nothing) + match expr with + | { + Parsetree.pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + } -> + Nothing + | { pexp_desc = Pexp_constraint _ } -> Parenthesized + | _ -> Nothing) let ternaryOperand expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc | None -> ( - match expr with - | { - Parsetree.pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_constraint _} -> Parenthesized - | {pexp_desc = Pexp_fun _ | Pexp_newtype _} -> ( - let _attrsOnArrow, _parameters, returnExpr = - ParsetreeViewer.funExpr expr - in - match returnExpr.pexp_desc with - | Pexp_constraint _ -> Parenthesized + match expr with + | { + Parsetree.pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + } -> + Nothing + | { pexp_desc = Pexp_constraint _ } -> Parenthesized + | { pexp_desc = Pexp_fun _ | Pexp_newtype _ } -> ( + let _attrsOnArrow, _parameters, returnExpr = + ParsetreeViewer.funExpr expr + in + match returnExpr.pexp_desc with + | Pexp_constraint _ -> Parenthesized + | _ -> Nothing) | _ -> Nothing) - | _ -> Nothing) let startsWithMinus txt = let len = String.length txt in @@ -52200,93 +52334,93 @@ let jsxPropExpr expr = match expr.Parsetree.pexp_desc with | Parsetree.Pexp_let _ | Pexp_sequence _ | Pexp_letexception _ | Pexp_letmodule _ | Pexp_open _ -> - Nothing + Nothing | _ -> ( - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc - | None -> ( - match expr with - | { - Parsetree.pexp_desc = - Pexp_constant (Pconst_integer (x, _) | Pconst_float (x, _)); - pexp_attributes = []; - } - when startsWithMinus x -> - Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> - Parenthesized - | { - Parsetree.pexp_desc = - ( Pexp_ident _ | Pexp_constant _ | Pexp_field _ | Pexp_construct _ - | Pexp_variant _ | Pexp_array _ | Pexp_pack _ | Pexp_record _ - | Pexp_extension _ | Pexp_letmodule _ | Pexp_letexception _ - | Pexp_open _ | Pexp_sequence _ | Pexp_let _ | Pexp_tuple _ ); - pexp_attributes = []; - } -> - Nothing - | { - Parsetree.pexp_desc = - Pexp_constraint - ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - pexp_attributes = []; - } -> - Nothing - | _ -> Parenthesized)) + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc + | None -> ( + match expr with + | { + Parsetree.pexp_desc = + Pexp_constant (Pconst_integer (x, _) | Pconst_float (x, _)); + pexp_attributes = []; + } + when startsWithMinus x -> + Parenthesized + | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> + Parenthesized + | { + Parsetree.pexp_desc = + ( Pexp_ident _ | Pexp_constant _ | Pexp_field _ | Pexp_construct _ + | Pexp_variant _ | Pexp_array _ | Pexp_pack _ | Pexp_record _ + | Pexp_extension _ | Pexp_letmodule _ | Pexp_letexception _ + | Pexp_open _ | Pexp_sequence _ | Pexp_let _ | Pexp_tuple _ ); + pexp_attributes = []; + } -> + Nothing + | { + Parsetree.pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + pexp_attributes = []; + } -> + Nothing + | _ -> Parenthesized)) let jsxChildExpr expr = match expr.Parsetree.pexp_desc with | Parsetree.Pexp_let _ | Pexp_sequence _ | Pexp_letexception _ | Pexp_letmodule _ | Pexp_open _ -> - Nothing + Nothing | _ -> ( - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc - | _ -> ( - match expr with - | { - Parsetree.pexp_desc = - Pexp_constant (Pconst_integer (x, _) | Pconst_float (x, _)); - pexp_attributes = []; - } - when startsWithMinus x -> - Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> - Parenthesized - | { - Parsetree.pexp_desc = - ( Pexp_ident _ | Pexp_constant _ | Pexp_field _ | Pexp_construct _ - | Pexp_variant _ | Pexp_array _ | Pexp_pack _ | Pexp_record _ - | Pexp_extension _ | Pexp_letmodule _ | Pexp_letexception _ - | Pexp_open _ | Pexp_sequence _ | Pexp_let _ ); - pexp_attributes = []; - } -> - Nothing - | { - Parsetree.pexp_desc = - Pexp_constraint - ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - pexp_attributes = []; - } -> - Nothing - | expr when ParsetreeViewer.isJsxExpression expr -> Nothing - | _ -> Parenthesized)) + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc + | _ -> ( + match expr with + | { + Parsetree.pexp_desc = + Pexp_constant (Pconst_integer (x, _) | Pconst_float (x, _)); + pexp_attributes = []; + } + when startsWithMinus x -> + Parenthesized + | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> + Parenthesized + | { + Parsetree.pexp_desc = + ( Pexp_ident _ | Pexp_constant _ | Pexp_field _ | Pexp_construct _ + | Pexp_variant _ | Pexp_array _ | Pexp_pack _ | Pexp_record _ + | Pexp_extension _ | Pexp_letmodule _ | Pexp_letexception _ + | Pexp_open _ | Pexp_sequence _ | Pexp_let _ ); + pexp_attributes = []; + } -> + Nothing + | { + Parsetree.pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + pexp_attributes = []; + } -> + Nothing + | expr when ParsetreeViewer.isJsxExpression expr -> Nothing + | _ -> Parenthesized)) let binaryExpr expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc | None -> ( - match expr with - | {Parsetree.pexp_attributes = _ :: _} as expr - when ParsetreeViewer.isBinaryExpression expr -> - Parenthesized - | _ -> Nothing) + match expr with + | { Parsetree.pexp_attributes = _ :: _ } as expr + when ParsetreeViewer.isBinaryExpression expr -> + Parenthesized + | _ -> Nothing) let modTypeFunctorReturn modType = match modType with - | {Parsetree.pmty_desc = Pmty_with _} -> true + | { Parsetree.pmty_desc = Pmty_with _ } -> true | _ -> false (* Add parens for readability: @@ -52296,18 +52430,19 @@ let modTypeFunctorReturn modType = *) let modTypeWithOperand modType = match modType with - | {Parsetree.pmty_desc = Pmty_functor _ | Pmty_with _} -> true + | { Parsetree.pmty_desc = Pmty_functor _ | Pmty_with _ } -> true | _ -> false let modExprFunctorConstraint modType = match modType with - | {Parsetree.pmty_desc = Pmty_functor _ | Pmty_with _} -> true + | { Parsetree.pmty_desc = Pmty_functor _ | Pmty_with _ } -> true | _ -> false let bracedExpr expr = match expr.Parsetree.pexp_desc with - | Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}) -> - false + | Pexp_constraint ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }) + -> + false | Pexp_constraint _ -> true | _ -> false @@ -52323,9 +52458,9 @@ let arrowReturnTypExpr typExpr = let patternRecordRowRhs (pattern : Parsetree.pattern) = match pattern.ppat_desc with - | Ppat_constraint ({ppat_desc = Ppat_unpack _}, {ptyp_desc = Ptyp_package _}) - -> - false + | Ppat_constraint + ({ ppat_desc = Ppat_unpack _ }, { ptyp_desc = Ptyp_package _ }) -> + false | Ppat_constraint _ -> true | _ -> false @@ -52340,9 +52475,9 @@ type t = | Open | True | False - | Codepoint of {c: int; original: string} - | Int of {i: string; suffix: char option} - | Float of {f: string; suffix: char option} + | Codepoint of { c : int; original : string } + | Int of { i : string; suffix : char option } + | Float of { f : string; suffix : char option } | String of string | Lident of string | Uident of string @@ -52438,7 +52573,7 @@ let precedence = function | Land -> 3 | Equal | EqualEqual | EqualEqualEqual | LessThan | GreaterThan | BangEqual | BangEqualEqual | LessEqual | GreaterEqual | BarGreater -> - 4 + 4 | Plus | PlusDot | Minus | MinusDot | PlusPlus -> 5 | Asterisk | AsteriskDot | Forwardslash | ForwardslashDot -> 6 | Exponentiation -> 7 @@ -52451,15 +52586,15 @@ let toString = function | Open -> "open" | True -> "true" | False -> "false" - | Codepoint {original} -> "codepoint '" ^ original ^ "'" + | Codepoint { original } -> "codepoint '" ^ original ^ "'" | String s -> "string \"" ^ s ^ "\"" | Lident str -> str | Uident str -> str | Dot -> "." | DotDot -> ".." | DotDotDot -> "..." - | Int {i} -> "int " ^ i - | Float {f} -> "Float: " ^ f + | Int { i } -> "int " ^ i + | Float { f } -> "Float: " ^ f | Bang -> "!" | Semicolon -> ";" | Let -> "let" @@ -52579,7 +52714,7 @@ let isKeyword = function | Await | And | As | Assert | Constraint | Else | Exception | External | False | For | If | In | Include | Land | Lazy | Let | List | Lor | Module | Mutable | Of | Open | Private | Rec | Switch | True | Try | Typ | When | While -> - true + true | _ -> false let lookupKeyword str = @@ -52601,13 +52736,9 @@ end module Res_utf8 : sig #1 "res_utf8.mli" val repl : int - val max : int - val decodeCodePoint : int -> string -> int -> int * int - val encodeCodePoint : int -> string - val isValidCodePoint : int -> bool end = struct @@ -52619,7 +52750,6 @@ let repl = 0xFFFD (* let min = 0x0000 *) let max = 0x10FFFF - let surrogateMin = 0xD800 let surrogateMax = 0xDFFF @@ -52635,10 +52765,9 @@ let surrogateMax = 0xDFFF let h2 = 0b1100_0000 let h3 = 0b1110_0000 let h4 = 0b1111_0000 - let cont_mask = 0b0011_1111 -type category = {low: int; high: int; size: int} +type category = { low : int; high : int; size : int } let locb = 0b1000_0000 let hicb = 0b1011_1111 @@ -52768,11 +52897,8 @@ val printTypeParams : Res_doc.t val printLongident : Longident.t -> Res_doc.t - val printTypExpr : Parsetree.core_type -> Res_comments_table.t -> Res_doc.t - val addParens : Res_doc.t -> Res_doc.t - val printExpression : Parsetree.expression -> Res_comments_table.t -> Res_doc.t val printPattern : Parsetree.pattern -> Res_comments_table.t -> Res_doc.t @@ -52783,6 +52909,7 @@ val printStructure : Parsetree.structure -> Res_comments_table.t -> Res_doc.t val printImplementation : width:int -> Parsetree.structure -> comments:Res_comment.t list -> string + val printInterface : width:int -> Parsetree.signature -> comments:Res_comment.t list -> string @@ -52854,7 +52981,7 @@ let addParens doc = (Doc.concat [ Doc.lparen; - Doc.indent (Doc.concat [Doc.softLine; doc]); + Doc.indent (Doc.concat [ Doc.softLine; doc ]); Doc.softLine; Doc.rparen; ]) @@ -52864,12 +52991,12 @@ let addBraces doc = (Doc.concat [ Doc.lbrace; - Doc.indent (Doc.concat [Doc.softLine; doc]); + Doc.indent (Doc.concat [ Doc.softLine; doc ]); Doc.softLine; Doc.rbrace; ]) -let addAsync doc = Doc.concat [Doc.text "async "; doc] +let addAsync doc = Doc.concat [ Doc.text "async "; doc ] let getFirstLeadingComment tbl loc = match Hashtbl.find tbl.CommentTable.leading loc with @@ -52886,8 +53013,8 @@ let hasLeadingLineComment tbl loc = let hasCommentBelow tbl loc = match Hashtbl.find tbl.CommentTable.trailing loc with | comment :: _ -> - let commentLoc = Comment.loc comment in - commentLoc.Location.loc_start.pos_lnum > loc.Location.loc_end.pos_lnum + let commentLoc = Comment.loc comment in + commentLoc.Location.loc_start.pos_lnum > loc.Location.loc_end.pos_lnum | [] -> false | exception Not_found -> false @@ -52895,10 +53022,10 @@ let hasNestedJsxOrMoreThanOneChild expr = let rec loop inRecursion expr = match expr.Parsetree.pexp_desc with | Pexp_construct - ({txt = Longident.Lident "::"}, Some {pexp_desc = Pexp_tuple [hd; tail]}) - -> - if inRecursion || ParsetreeViewer.isJsxExpression hd then true - else loop true tail + ( { txt = Longident.Lident "::" }, + Some { pexp_desc = Pexp_tuple [ hd; tail ] } ) -> + if inRecursion || ParsetreeViewer.isJsxExpression hd then true + else loop true tail | _ -> false in loop false expr @@ -52929,42 +53056,40 @@ let printMultilineCommentContent txt = let rec indentStars lines acc = match lines with | [] -> Doc.nil - | [lastLine] -> - let line = String.trim lastLine in - let doc = Doc.text (" " ^ line) in - let trailingSpace = if line = "" then Doc.nil else Doc.space in - List.rev (trailingSpace :: doc :: acc) |> Doc.concat - | line :: lines -> - let line = String.trim line in - if line != "" && String.unsafe_get line 0 == '*' then + | [ lastLine ] -> + let line = String.trim lastLine in let doc = Doc.text (" " ^ line) in - indentStars lines (Doc.hardLine :: doc :: acc) - else - let trailingSpace = - let len = String.length txt in - if len > 0 && String.unsafe_get txt (len - 1) = ' ' then Doc.space - else Doc.nil - in - let content = Comment.trimSpaces txt in - Doc.concat [Doc.text content; trailingSpace] + let trailingSpace = if line = "" then Doc.nil else Doc.space in + List.rev (trailingSpace :: doc :: acc) |> Doc.concat + | line :: lines -> + let line = String.trim line in + if line != "" && String.unsafe_get line 0 == '*' then + let doc = Doc.text (" " ^ line) in + indentStars lines (Doc.hardLine :: doc :: acc) + else + let trailingSpace = + let len = String.length txt in + if len > 0 && String.unsafe_get txt (len - 1) = ' ' then Doc.space + else Doc.nil + in + let content = Comment.trimSpaces txt in + Doc.concat [ Doc.text content; trailingSpace ] in let lines = String.split_on_char '\n' txt in match lines with | [] -> Doc.text "/* */" - | [line] -> - Doc.concat - [Doc.text "/* "; Doc.text (Comment.trimSpaces line); Doc.text " */"] + | [ line ] -> + Doc.concat + [ Doc.text "/* "; Doc.text (Comment.trimSpaces line); Doc.text " */" ] | first :: rest -> - let firstLine = Comment.trimSpaces first in - Doc.concat - [ - Doc.text "/*"; - (match firstLine with - | "" | "*" -> Doc.nil - | _ -> Doc.space); - indentStars rest [Doc.hardLine; Doc.text firstLine]; - Doc.text "*/"; - ] + let firstLine = Comment.trimSpaces first in + Doc.concat + [ + Doc.text "/*"; + (match firstLine with "" | "*" -> Doc.nil | _ -> Doc.space); + indentStars rest [ Doc.hardLine; Doc.text firstLine ]; + Doc.text "*/"; + ] let printTrailingComment (prevLoc : Location.t) (nodeLoc : Location.t) comment = let singleLine = Comment.isSingleLineComment comment in @@ -52992,8 +53117,8 @@ let printTrailingComment (prevLoc : Location.t) (nodeLoc : Location.t) comment = content; ]); ] - else if not singleLine then Doc.concat [Doc.space; content] - else Doc.lineSuffix (Doc.concat [Doc.space; content]) + else if not singleLine then Doc.concat [ Doc.space; content ] + else Doc.lineSuffix (Doc.concat [ Doc.space; content ]) let printLeadingComment ?nextComment comment = let singleLine = Comment.isSingleLineComment comment in @@ -53005,28 +53130,28 @@ let printLeadingComment ?nextComment comment = let separator = Doc.concat [ - (if singleLine then Doc.concat [Doc.hardLine; Doc.breakParent] + (if singleLine then Doc.concat [ Doc.hardLine; Doc.breakParent ] else Doc.nil); (match nextComment with | Some next -> - let nextLoc = Comment.loc next in - let currLoc = Comment.loc comment in - let diff = - nextLoc.Location.loc_start.pos_lnum - - currLoc.Location.loc_end.pos_lnum - in - let nextSingleLine = Comment.isSingleLineComment next in - if singleLine && nextSingleLine then - if diff > 1 then Doc.hardLine else Doc.nil - else if singleLine && not nextSingleLine then - if diff > 1 then Doc.hardLine else Doc.nil - else if diff > 1 then Doc.concat [Doc.hardLine; Doc.hardLine] - else if diff == 1 then Doc.hardLine - else Doc.space + let nextLoc = Comment.loc next in + let currLoc = Comment.loc comment in + let diff = + nextLoc.Location.loc_start.pos_lnum + - currLoc.Location.loc_end.pos_lnum + in + let nextSingleLine = Comment.isSingleLineComment next in + if singleLine && nextSingleLine then + if diff > 1 then Doc.hardLine else Doc.nil + else if singleLine && not nextSingleLine then + if diff > 1 then Doc.hardLine else Doc.nil + else if diff > 1 then Doc.concat [ Doc.hardLine; Doc.hardLine ] + else if diff == 1 then Doc.hardLine + else Doc.space | None -> Doc.nil); ] in - Doc.concat [content; separator] + Doc.concat [ content; separator ] (* This function is used for printing comments inside an empty block *) let printCommentsInside cmtTbl loc = @@ -53042,96 +53167,98 @@ let printCommentsInside cmtTbl loc = let rec loop acc comments = match comments with | [] -> Doc.nil - | [comment] -> - let cmtDoc = printComment comment in - let cmtsDoc = Doc.concat (Doc.softLine :: List.rev (cmtDoc :: acc)) in - let doc = - Doc.breakableGroup ~forceBreak - (Doc.concat [Doc.ifBreaks (Doc.indent cmtsDoc) cmtsDoc; Doc.softLine]) - in - doc + | [ comment ] -> + let cmtDoc = printComment comment in + let cmtsDoc = Doc.concat (Doc.softLine :: List.rev (cmtDoc :: acc)) in + let doc = + Doc.breakableGroup ~forceBreak + (Doc.concat + [ Doc.ifBreaks (Doc.indent cmtsDoc) cmtsDoc; Doc.softLine ]) + in + doc | comment :: rest -> - let cmtDoc = Doc.concat [printComment comment; Doc.line] in - loop (cmtDoc :: acc) rest + let cmtDoc = Doc.concat [ printComment comment; Doc.line ] in + loop (cmtDoc :: acc) rest in match Hashtbl.find cmtTbl.CommentTable.inside loc with | exception Not_found -> Doc.nil | comments -> - Hashtbl.remove cmtTbl.inside loc; - loop [] comments + Hashtbl.remove cmtTbl.inside loc; + loop [] comments (* This function is used for printing comments inside an empty file *) let printCommentsInsideFile cmtTbl = let rec loop acc comments = match comments with | [] -> Doc.nil - | [comment] -> - let cmtDoc = printLeadingComment comment in - let doc = - Doc.group (Doc.concat [Doc.concat (List.rev (cmtDoc :: acc))]) - in - doc + | [ comment ] -> + let cmtDoc = printLeadingComment comment in + let doc = + Doc.group (Doc.concat [ Doc.concat (List.rev (cmtDoc :: acc)) ]) + in + doc | comment :: (nextComment :: _comments as rest) -> - let cmtDoc = printLeadingComment ~nextComment comment in - loop (cmtDoc :: acc) rest + let cmtDoc = printLeadingComment ~nextComment comment in + loop (cmtDoc :: acc) rest in match Hashtbl.find cmtTbl.CommentTable.inside Location.none with | exception Not_found -> Doc.nil | comments -> - Hashtbl.remove cmtTbl.inside Location.none; - Doc.group (loop [] comments) + Hashtbl.remove cmtTbl.inside Location.none; + Doc.group (loop [] comments) let printLeadingComments node tbl loc = let rec loop acc comments = match comments with | [] -> node - | [comment] -> - let cmtDoc = printLeadingComment comment in - let diff = - loc.Location.loc_start.pos_lnum - - (Comment.loc comment).Location.loc_end.pos_lnum - in - let separator = - if Comment.isSingleLineComment comment then - if diff > 1 then Doc.hardLine else Doc.nil - else if diff == 0 then Doc.space - else if diff > 1 then Doc.concat [Doc.hardLine; Doc.hardLine] - else Doc.hardLine - in - let doc = - Doc.group - (Doc.concat [Doc.concat (List.rev (cmtDoc :: acc)); separator; node]) - in - doc + | [ comment ] -> + let cmtDoc = printLeadingComment comment in + let diff = + loc.Location.loc_start.pos_lnum + - (Comment.loc comment).Location.loc_end.pos_lnum + in + let separator = + if Comment.isSingleLineComment comment then + if diff > 1 then Doc.hardLine else Doc.nil + else if diff == 0 then Doc.space + else if diff > 1 then Doc.concat [ Doc.hardLine; Doc.hardLine ] + else Doc.hardLine + in + let doc = + Doc.group + (Doc.concat + [ Doc.concat (List.rev (cmtDoc :: acc)); separator; node ]) + in + doc | comment :: (nextComment :: _comments as rest) -> - let cmtDoc = printLeadingComment ~nextComment comment in - loop (cmtDoc :: acc) rest + let cmtDoc = printLeadingComment ~nextComment comment in + loop (cmtDoc :: acc) rest in match Hashtbl.find tbl loc with | exception Not_found -> node | comments -> - (* Remove comments from tbl: Some ast nodes have the same location. - * We only want to print comments once *) - Hashtbl.remove tbl loc; - loop [] comments + (* Remove comments from tbl: Some ast nodes have the same location. + * We only want to print comments once *) + Hashtbl.remove tbl loc; + loop [] comments let printTrailingComments node tbl loc = let rec loop prev acc comments = match comments with | [] -> Doc.concat (List.rev acc) | comment :: comments -> - let cmtDoc = printTrailingComment prev loc comment in - loop (Comment.loc comment) (cmtDoc :: acc) comments + let cmtDoc = printTrailingComment prev loc comment in + loop (Comment.loc comment) (cmtDoc :: acc) comments in match Hashtbl.find tbl loc with | exception Not_found -> node | [] -> node | _first :: _ as comments -> - (* Remove comments from tbl: Some ast nodes have the same location. - * We only want to print comments once *) - Hashtbl.remove tbl loc; - let cmtsDoc = loop loc [] comments in - Doc.concat [node; cmtsDoc] + (* Remove comments from tbl: Some ast nodes have the same location. + * We only want to print comments once *) + Hashtbl.remove tbl loc; + let cmtsDoc = loop loc [] comments in + Doc.concat [ node; cmtsDoc ] let printComments doc (tbl : CommentTable.t) loc = let docWithLeadingComments = printLeadingComments doc tbl.leading loc in @@ -53142,68 +53269,68 @@ let printList ~getLoc ~nodes ~print ?(forceBreak = false) t = match nodes with | [] -> (prevLoc, Doc.concat (List.rev acc)) | node :: nodes -> - let loc = getLoc node in - let startPos = - match getFirstLeadingComment t loc with - | None -> loc.loc_start - | Some comment -> (Comment.loc comment).loc_start - in - let sep = - if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then - Doc.concat [Doc.hardLine; Doc.hardLine] - else Doc.hardLine - in - let doc = printComments (print node t) t loc in - loop loc (doc :: sep :: acc) nodes + let loc = getLoc node in + let startPos = + match getFirstLeadingComment t loc with + | None -> loc.loc_start + | Some comment -> (Comment.loc comment).loc_start + in + let sep = + if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then + Doc.concat [ Doc.hardLine; Doc.hardLine ] + else Doc.hardLine + in + let doc = printComments (print node t) t loc in + loop loc (doc :: sep :: acc) nodes in match nodes with | [] -> Doc.nil | node :: nodes -> - let firstLoc = getLoc node in - let doc = printComments (print node t) t firstLoc in - let lastLoc, docs = loop firstLoc [doc] nodes in - let forceBreak = - forceBreak || firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak docs + let firstLoc = getLoc node in + let doc = printComments (print node t) t firstLoc in + let lastLoc, docs = loop firstLoc [ doc ] nodes in + let forceBreak = + forceBreak || firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak docs let printListi ~getLoc ~nodes ~print ?(forceBreak = false) t = let rec loop i (prevLoc : Location.t) acc nodes = match nodes with | [] -> (prevLoc, Doc.concat (List.rev acc)) | node :: nodes -> - let loc = getLoc node in - let startPos = - match getFirstLeadingComment t loc with - | None -> loc.loc_start - | Some comment -> (Comment.loc comment).loc_start - in - let sep = - if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then - Doc.concat [Doc.hardLine; Doc.hardLine] - else Doc.line - in - let doc = printComments (print node t i) t loc in - loop (i + 1) loc (doc :: sep :: acc) nodes + let loc = getLoc node in + let startPos = + match getFirstLeadingComment t loc with + | None -> loc.loc_start + | Some comment -> (Comment.loc comment).loc_start + in + let sep = + if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then + Doc.concat [ Doc.hardLine; Doc.hardLine ] + else Doc.line + in + let doc = printComments (print node t i) t loc in + loop (i + 1) loc (doc :: sep :: acc) nodes in match nodes with | [] -> Doc.nil | node :: nodes -> - let firstLoc = getLoc node in - let doc = printComments (print node t 0) t firstLoc in - let lastLoc, docs = loop 1 firstLoc [doc] nodes in - let forceBreak = - forceBreak || firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak docs + let firstLoc = getLoc node in + let doc = printComments (print node t 0) t firstLoc in + let lastLoc, docs = loop 1 firstLoc [ doc ] nodes in + let forceBreak = + forceBreak || firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak docs let rec printLongidentAux accu = function | Longident.Lident s -> Doc.text s :: accu | Ldot (lid, s) -> printLongidentAux (Doc.text s :: accu) lid | Lapply (lid1, lid2) -> - let d1 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid1) in - let d2 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid2) in - Doc.concat [d1; Doc.lparen; d2; Doc.rparen] :: accu + let d1 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid1) in + let d2 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid2) in + Doc.concat [ d1; Doc.lparen; d2; Doc.rparen ] :: accu let printLongident = function | Longident.Lident txt -> Doc.text txt @@ -53231,7 +53358,7 @@ let classifyIdentContent ?(allowUident = false) txt = let printIdentLike ?allowUident txt = match classifyIdentContent ?allowUident txt with - | ExoticIdent -> Doc.concat [Doc.text "\\\""; Doc.text txt; Doc.text "\""] + | ExoticIdent -> Doc.concat [ Doc.text "\\\""; Doc.text txt; Doc.text "\"" ] | NormalIdent -> Doc.text txt let rec unsafe_for_all_range s ~start ~finish p = @@ -53252,10 +53379,7 @@ let isValidNumericPolyvarNumber (x : string) = a <= 57 && if len > 1 then - a > 48 - && for_all_from x 1 (function - | '0' .. '9' -> true - | _ -> false) + a > 48 && for_all_from x 1 (function '0' .. '9' -> true | _ -> false) else a >= 48 (* Exotic identifiers in poly-vars have a "lighter" syntax: #"ease-in" *) @@ -53264,11 +53388,11 @@ let printPolyVarIdent txt = if isValidNumericPolyvarNumber txt then Doc.text txt else match classifyIdentContent ~allowUident:true txt with - | ExoticIdent -> Doc.concat [Doc.text "\""; Doc.text txt; Doc.text "\""] + | ExoticIdent -> Doc.concat [ Doc.text "\""; Doc.text txt; Doc.text "\"" ] | NormalIdent -> ( - match txt with - | "" -> Doc.concat [Doc.text "\""; Doc.text txt; Doc.text "\""] - | _ -> Doc.text txt) + match txt with + | "" -> Doc.concat [ Doc.text "\""; Doc.text txt; Doc.text "\"" ] + | _ -> Doc.text txt) let printLident l = let flatLidOpt lid = @@ -53282,18 +53406,18 @@ let printLident l = match l with | Longident.Lident txt -> printIdentLike txt | Longident.Ldot (path, txt) -> - let doc = - match flatLidOpt path with - | Some txts -> - Doc.concat - [ - Doc.join ~sep:Doc.dot (List.map Doc.text txts); - Doc.dot; - printIdentLike txt; - ] - | None -> Doc.text "printLident: Longident.Lapply is not supported" - in - doc + let doc = + match flatLidOpt path with + | Some txts -> + Doc.concat + [ + Doc.join ~sep:Doc.dot (List.map Doc.text txts); + Doc.dot; + printIdentLike txt; + ] + | None -> Doc.text "printLident: Longident.Lapply is not supported" + in + doc | Lapply (_, _) -> Doc.text "printLident: Longident.Lapply is not supported" let printLongidentLocation l cmtTbl = @@ -53321,42 +53445,42 @@ let printStringContents txt = let printConstant ?(templateLiteral = false) c = match c with | Parsetree.Pconst_integer (s, suffix) -> ( - match suffix with - | Some c -> Doc.text (s ^ Char.escaped c) - | None -> Doc.text s) + match suffix with + | Some c -> Doc.text (s ^ Char.escaped c) + | None -> Doc.text s) | Pconst_string (txt, None) -> - Doc.concat [Doc.text "\""; printStringContents txt; Doc.text "\""] + Doc.concat [ Doc.text "\""; printStringContents txt; Doc.text "\"" ] | Pconst_string (txt, Some prefix) -> - if prefix = "INTERNAL_RES_CHAR_CONTENTS" then - Doc.concat [Doc.text "'"; Doc.text txt; Doc.text "'"] - else - let lquote, rquote = - if templateLiteral then ("`", "`") else ("\"", "\"") - in - Doc.concat - [ - (if prefix = "js" then Doc.nil else Doc.text prefix); - Doc.text lquote; - printStringContents txt; - Doc.text rquote; - ] + if prefix = "INTERNAL_RES_CHAR_CONTENTS" then + Doc.concat [ Doc.text "'"; Doc.text txt; Doc.text "'" ] + else + let lquote, rquote = + if templateLiteral then ("`", "`") else ("\"", "\"") + in + Doc.concat + [ + (if prefix = "js" then Doc.nil else Doc.text prefix); + Doc.text lquote; + printStringContents txt; + Doc.text rquote; + ] | Pconst_float (s, _) -> Doc.text s | Pconst_char c -> - let str = - match Char.unsafe_chr c with - | '\'' -> "\\'" - | '\\' -> "\\\\" - | '\n' -> "\\n" - | '\t' -> "\\t" - | '\r' -> "\\r" - | '\b' -> "\\b" - | ' ' .. '~' as c -> - let s = (Bytes.create [@doesNotRaise]) 1 in - Bytes.unsafe_set s 0 c; - Bytes.unsafe_to_string s - | _ -> Res_utf8.encodeCodePoint c - in - Doc.text ("'" ^ str ^ "'") + let str = + match Char.unsafe_chr c with + | '\'' -> "\\'" + | '\\' -> "\\\\" + | '\n' -> "\\n" + | '\t' -> "\\t" + | '\r' -> "\\r" + | '\b' -> "\\b" + | ' ' .. '~' as c -> + let s = (Bytes.create [@doesNotRaise]) 1 in + Bytes.unsafe_set s 0 c; + Bytes.unsafe_to_string s + | _ -> Res_utf8.encodeCodePoint c + in + Doc.text ("'" ^ str ^ "'") let printOptionalLabel attrs = if Res_parsetree_viewer.hasOptionalAttribute attrs then Doc.text "?" @@ -53368,66 +53492,66 @@ let rec printStructure ~customLayout (s : Parsetree.structure) t = match s with | [] -> printCommentsInsideFile t | structure -> - printList - ~getLoc:(fun s -> s.Parsetree.pstr_loc) - ~nodes:structure - ~print:(printStructureItem ~customLayout) - t + printList + ~getLoc:(fun s -> s.Parsetree.pstr_loc) + ~nodes:structure + ~print:(printStructureItem ~customLayout) + t and printStructureItem ~customLayout (si : Parsetree.structure_item) cmtTbl = match si.pstr_desc with | Pstr_value (rec_flag, valueBindings) -> - let recFlag = - match rec_flag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - printValueBindings ~customLayout ~recFlag valueBindings cmtTbl + let recFlag = + match rec_flag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + printValueBindings ~customLayout ~recFlag valueBindings cmtTbl | Pstr_type (recFlag, typeDeclarations) -> - let recFlag = - match recFlag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - printTypeDeclarations ~customLayout ~recFlag typeDeclarations cmtTbl + let recFlag = + match recFlag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + printTypeDeclarations ~customLayout ~recFlag typeDeclarations cmtTbl | Pstr_primitive valueDescription -> - printValueDescription ~customLayout valueDescription cmtTbl + printValueDescription ~customLayout valueDescription cmtTbl | Pstr_eval (expr, attrs) -> - let exprDoc = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.structureExpr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat [printAttributes ~customLayout attrs cmtTbl; exprDoc] + let exprDoc = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.structureExpr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [ printAttributes ~customLayout attrs cmtTbl; exprDoc ] | Pstr_attribute attr -> - fst (printAttribute ~customLayout ~standalone:true attr cmtTbl) + fst (printAttribute ~customLayout ~standalone:true attr cmtTbl) | Pstr_extension (extension, attrs) -> - Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - Doc.concat - [printExtension ~customLayout ~atModuleLvl:true extension cmtTbl]; - ] + Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + Doc.concat + [ printExtension ~customLayout ~atModuleLvl:true extension cmtTbl ]; + ] | Pstr_include includeDeclaration -> - printIncludeDeclaration ~customLayout includeDeclaration cmtTbl + printIncludeDeclaration ~customLayout includeDeclaration cmtTbl | Pstr_open openDescription -> - printOpenDescription ~customLayout openDescription cmtTbl + printOpenDescription ~customLayout openDescription cmtTbl | Pstr_modtype modTypeDecl -> - printModuleTypeDeclaration ~customLayout modTypeDecl cmtTbl + printModuleTypeDeclaration ~customLayout modTypeDecl cmtTbl | Pstr_module moduleBinding -> - printModuleBinding ~customLayout ~isRec:false moduleBinding cmtTbl 0 + printModuleBinding ~customLayout ~isRec:false moduleBinding cmtTbl 0 | Pstr_recmodule moduleBindings -> - printListi - ~getLoc:(fun mb -> mb.Parsetree.pmb_loc) - ~nodes:moduleBindings - ~print:(printModuleBinding ~customLayout ~isRec:true) - cmtTbl + printListi + ~getLoc:(fun mb -> mb.Parsetree.pmb_loc) + ~nodes:moduleBindings + ~print:(printModuleBinding ~customLayout ~isRec:true) + cmtTbl | Pstr_exception extensionConstructor -> - printExceptionDef ~customLayout extensionConstructor cmtTbl + printExceptionDef ~customLayout extensionConstructor cmtTbl | Pstr_typext typeExtension -> - printTypeExtension ~customLayout typeExtension cmtTbl + printTypeExtension ~customLayout typeExtension cmtTbl | Pstr_class _ | Pstr_class_type _ -> Doc.nil and printTypeExtension ~customLayout (te : Parsetree.type_extension) cmtTbl = @@ -53439,13 +53563,14 @@ and printTypeExtension ~customLayout (te : Parsetree.type_extension) cmtTbl = let forceBreak = match (ecs, List.rev ecs) with | first :: _, last :: _ -> - first.pext_loc.loc_start.pos_lnum > te.ptyext_path.loc.loc_end.pos_lnum - || first.pext_loc.loc_start.pos_lnum < last.pext_loc.loc_end.pos_lnum + first.pext_loc.loc_start.pos_lnum + > te.ptyext_path.loc.loc_end.pos_lnum + || first.pext_loc.loc_start.pos_lnum < last.pext_loc.loc_end.pos_lnum | _ -> false in let privateFlag = match te.ptyext_private with - | Asttypes.Private -> Doc.concat [Doc.text "private"; Doc.line] + | Asttypes.Private -> Doc.concat [ Doc.text "private"; Doc.line ] | Public -> Doc.nil in let rows = @@ -53482,14 +53607,15 @@ and printModuleBinding ~customLayout ~isRec moduleBinding cmtTbl i = let prefix = if i = 0 then Doc.concat - [Doc.text "module "; (if isRec then Doc.text "rec " else Doc.nil)] + [ Doc.text "module "; (if isRec then Doc.text "rec " else Doc.nil) ] else Doc.text "and " in let modExprDoc, modConstraintDoc = match moduleBinding.pmb_expr with - | {pmod_desc = Pmod_constraint (modExpr, modType)} -> - ( printModExpr ~customLayout modExpr cmtTbl, - Doc.concat [Doc.text ": "; printModType ~customLayout modType cmtTbl] ) + | { pmod_desc = Pmod_constraint (modExpr, modType) } -> + ( printModExpr ~customLayout modExpr cmtTbl, + Doc.concat + [ Doc.text ": "; printModType ~customLayout modType cmtTbl ] ) | modExpr -> (printModExpr ~customLayout modExpr cmtTbl, Doc.nil) in let modName = @@ -53524,153 +53650,160 @@ and printModuleTypeDeclaration ~customLayout (match modTypeDecl.pmtd_type with | None -> Doc.nil | Some modType -> - Doc.concat [Doc.text " = "; printModType ~customLayout modType cmtTbl]); + Doc.concat + [ Doc.text " = "; printModType ~customLayout modType cmtTbl ]); ] and printModType ~customLayout modType cmtTbl = let modTypeDoc = match modType.pmty_desc with | Parsetree.Pmty_ident longident -> - Doc.concat - [ - printAttributes ~customLayout ~loc:longident.loc - modType.pmty_attributes cmtTbl; - printLongidentLocation longident cmtTbl; - ] + Doc.concat + [ + printAttributes ~customLayout ~loc:longident.loc + modType.pmty_attributes cmtTbl; + printLongidentLocation longident cmtTbl; + ] | Pmty_signature [] -> - if hasCommentsInside cmtTbl modType.pmty_loc then - let doc = printCommentsInside cmtTbl modType.pmty_loc in - Doc.concat [Doc.lbrace; doc; Doc.rbrace] - else - let shouldBreak = - modType.pmty_loc.loc_start.pos_lnum - < modType.pmty_loc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak:shouldBreak - (Doc.concat [Doc.lbrace; Doc.softLine; Doc.softLine; Doc.rbrace]) - | Pmty_signature signature -> - let signatureDoc = - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [Doc.line; printSignature ~customLayout signature cmtTbl]); - Doc.line; - Doc.rbrace; - ]) - in - Doc.concat - [ - printAttributes ~customLayout modType.pmty_attributes cmtTbl; - signatureDoc; - ] - | Pmty_functor _ -> - let parameters, returnType = ParsetreeViewer.functorType modType in - let parametersDoc = - match parameters with - | [] -> Doc.nil - | [(attrs, {Location.txt = "_"; loc}, Some modType)] -> - let cmtLoc = - {loc with loc_end = modType.Parsetree.pmty_loc.loc_end} - in - let attrs = printAttributes ~customLayout attrs cmtTbl in - let doc = - Doc.concat [attrs; printModType ~customLayout modType cmtTbl] + if hasCommentsInside cmtTbl modType.pmty_loc then + let doc = printCommentsInside cmtTbl modType.pmty_loc in + Doc.concat [ Doc.lbrace; doc; Doc.rbrace ] + else + let shouldBreak = + modType.pmty_loc.loc_start.pos_lnum + < modType.pmty_loc.loc_end.pos_lnum in - printComments doc cmtTbl cmtLoc - | params -> - Doc.group + Doc.breakableGroup ~forceBreak:shouldBreak + (Doc.concat [ Doc.lbrace; Doc.softLine; Doc.softLine; Doc.rbrace ]) + | Pmty_signature signature -> + let signatureDoc = + Doc.breakableGroup ~forceBreak:true (Doc.concat [ - Doc.lparen; + Doc.lbrace; Doc.indent (Doc.concat [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun (attrs, lbl, modType) -> - let cmtLoc = - match modType with - | None -> lbl.Asttypes.loc - | Some modType -> - { - lbl.Asttypes.loc with - loc_end = - modType.Parsetree.pmty_loc.loc_end; - } - in - let attrs = - printAttributes ~customLayout attrs cmtTbl - in - let lblDoc = - if lbl.Location.txt = "_" || lbl.txt = "*" then - Doc.nil - else - let doc = Doc.text lbl.txt in - printComments doc cmtTbl lbl.loc - in - let doc = - Doc.concat - [ - attrs; - lblDoc; - (match modType with - | None -> Doc.nil - | Some modType -> - Doc.concat - [ - (if lbl.txt = "_" then Doc.nil - else Doc.text ": "); - printModType ~customLayout modType - cmtTbl; - ]); - ] - in - printComments doc cmtTbl cmtLoc) - params); + Doc.line; printSignature ~customLayout signature cmtTbl; ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; + Doc.line; + Doc.rbrace; ]) - in - let returnDoc = - let doc = printModType ~customLayout returnType cmtTbl in - if Parens.modTypeFunctorReturn returnType then addParens doc else doc - in - Doc.group - (Doc.concat - [ - parametersDoc; - Doc.group (Doc.concat [Doc.text " =>"; Doc.line; returnDoc]); - ]) + in + Doc.concat + [ + printAttributes ~customLayout modType.pmty_attributes cmtTbl; + signatureDoc; + ] + | Pmty_functor _ -> + let parameters, returnType = ParsetreeViewer.functorType modType in + let parametersDoc = + match parameters with + | [] -> Doc.nil + | [ (attrs, { Location.txt = "_"; loc }, Some modType) ] -> + let cmtLoc = + { loc with loc_end = modType.Parsetree.pmty_loc.loc_end } + in + let attrs = printAttributes ~customLayout attrs cmtTbl in + let doc = + Doc.concat [ attrs; printModType ~customLayout modType cmtTbl ] + in + printComments doc cmtTbl cmtLoc + | params -> + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun (attrs, lbl, modType) -> + let cmtLoc = + match modType with + | None -> lbl.Asttypes.loc + | Some modType -> + { + lbl.Asttypes.loc with + loc_end = + modType.Parsetree.pmty_loc.loc_end; + } + in + let attrs = + printAttributes ~customLayout attrs cmtTbl + in + let lblDoc = + if lbl.Location.txt = "_" || lbl.txt = "*" + then Doc.nil + else + let doc = Doc.text lbl.txt in + printComments doc cmtTbl lbl.loc + in + let doc = + Doc.concat + [ + attrs; + lblDoc; + (match modType with + | None -> Doc.nil + | Some modType -> + Doc.concat + [ + (if lbl.txt = "_" then Doc.nil + else Doc.text ": "); + printModType ~customLayout + modType cmtTbl; + ]); + ] + in + printComments doc cmtTbl cmtLoc) + params); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) + in + let returnDoc = + let doc = printModType ~customLayout returnType cmtTbl in + if Parens.modTypeFunctorReturn returnType then addParens doc else doc + in + Doc.group + (Doc.concat + [ + parametersDoc; + Doc.group (Doc.concat [ Doc.text " =>"; Doc.line; returnDoc ]); + ]) | Pmty_typeof modExpr -> - Doc.concat - [Doc.text "module type of "; printModExpr ~customLayout modExpr cmtTbl] + Doc.concat + [ + Doc.text "module type of "; + printModExpr ~customLayout modExpr cmtTbl; + ] | Pmty_extension extension -> - printExtension ~customLayout ~atModuleLvl:false extension cmtTbl + printExtension ~customLayout ~atModuleLvl:false extension cmtTbl | Pmty_alias longident -> - Doc.concat [Doc.text "module "; printLongidentLocation longident cmtTbl] + Doc.concat + [ Doc.text "module "; printLongidentLocation longident cmtTbl ] | Pmty_with (modType, withConstraints) -> - let operand = - let doc = printModType ~customLayout modType cmtTbl in - if Parens.modTypeWithOperand modType then addParens doc else doc - in - Doc.group - (Doc.concat - [ - operand; - Doc.indent - (Doc.concat - [ - Doc.line; - printWithConstraints ~customLayout withConstraints cmtTbl; - ]); - ]) + let operand = + let doc = printModType ~customLayout modType cmtTbl in + if Parens.modTypeWithOperand modType then addParens doc else doc + in + Doc.group + (Doc.concat + [ + operand; + Doc.indent + (Doc.concat + [ + Doc.line; + printWithConstraints ~customLayout withConstraints cmtTbl; + ]); + ]) in let attrsAlreadyPrinted = match modType.pmty_desc with @@ -53706,78 +53839,78 @@ and printWithConstraint ~customLayout match withConstraint with (* with type X.t = ... *) | Pwith_type (longident, typeDeclaration) -> - Doc.group - (printTypeDeclaration ~customLayout - ~name:(printLidentPath longident cmtTbl) - ~equalSign:"=" ~recFlag:Doc.nil 0 typeDeclaration CommentTable.empty) + Doc.group + (printTypeDeclaration ~customLayout + ~name:(printLidentPath longident cmtTbl) + ~equalSign:"=" ~recFlag:Doc.nil 0 typeDeclaration CommentTable.empty) (* with module X.Y = Z *) - | Pwith_module ({txt = longident1}, {txt = longident2}) -> - Doc.concat - [ - Doc.text "module "; - printLongident longident1; - Doc.text " ="; - Doc.indent (Doc.concat [Doc.line; printLongident longident2]); - ] + | Pwith_module ({ txt = longident1 }, { txt = longident2 }) -> + Doc.concat + [ + Doc.text "module "; + printLongident longident1; + Doc.text " ="; + Doc.indent (Doc.concat [ Doc.line; printLongident longident2 ]); + ] (* with type X.t := ..., same format as [Pwith_type] *) | Pwith_typesubst (longident, typeDeclaration) -> - Doc.group - (printTypeDeclaration ~customLayout - ~name:(printLidentPath longident cmtTbl) - ~equalSign:":=" ~recFlag:Doc.nil 0 typeDeclaration CommentTable.empty) - | Pwith_modsubst ({txt = longident1}, {txt = longident2}) -> - Doc.concat - [ - Doc.text "module "; - printLongident longident1; - Doc.text " :="; - Doc.indent (Doc.concat [Doc.line; printLongident longident2]); - ] + Doc.group + (printTypeDeclaration ~customLayout + ~name:(printLidentPath longident cmtTbl) + ~equalSign:":=" ~recFlag:Doc.nil 0 typeDeclaration CommentTable.empty) + | Pwith_modsubst ({ txt = longident1 }, { txt = longident2 }) -> + Doc.concat + [ + Doc.text "module "; + printLongident longident1; + Doc.text " :="; + Doc.indent (Doc.concat [ Doc.line; printLongident longident2 ]); + ] and printSignature ~customLayout signature cmtTbl = match signature with | [] -> printCommentsInsideFile cmtTbl | signature -> - printList - ~getLoc:(fun s -> s.Parsetree.psig_loc) - ~nodes:signature - ~print:(printSignatureItem ~customLayout) - cmtTbl + printList + ~getLoc:(fun s -> s.Parsetree.psig_loc) + ~nodes:signature + ~print:(printSignatureItem ~customLayout) + cmtTbl and printSignatureItem ~customLayout (si : Parsetree.signature_item) cmtTbl = match si.psig_desc with | Parsetree.Psig_value valueDescription -> - printValueDescription ~customLayout valueDescription cmtTbl + printValueDescription ~customLayout valueDescription cmtTbl | Psig_type (recFlag, typeDeclarations) -> - let recFlag = - match recFlag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - printTypeDeclarations ~customLayout ~recFlag typeDeclarations cmtTbl + let recFlag = + match recFlag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + printTypeDeclarations ~customLayout ~recFlag typeDeclarations cmtTbl | Psig_typext typeExtension -> - printTypeExtension ~customLayout typeExtension cmtTbl + printTypeExtension ~customLayout typeExtension cmtTbl | Psig_exception extensionConstructor -> - printExceptionDef ~customLayout extensionConstructor cmtTbl + printExceptionDef ~customLayout extensionConstructor cmtTbl | Psig_module moduleDeclaration -> - printModuleDeclaration ~customLayout moduleDeclaration cmtTbl + printModuleDeclaration ~customLayout moduleDeclaration cmtTbl | Psig_recmodule moduleDeclarations -> - printRecModuleDeclarations ~customLayout moduleDeclarations cmtTbl + printRecModuleDeclarations ~customLayout moduleDeclarations cmtTbl | Psig_modtype modTypeDecl -> - printModuleTypeDeclaration ~customLayout modTypeDecl cmtTbl + printModuleTypeDeclaration ~customLayout modTypeDecl cmtTbl | Psig_open openDescription -> - printOpenDescription ~customLayout openDescription cmtTbl + printOpenDescription ~customLayout openDescription cmtTbl | Psig_include includeDescription -> - printIncludeDescription ~customLayout includeDescription cmtTbl + printIncludeDescription ~customLayout includeDescription cmtTbl | Psig_attribute attr -> - fst (printAttribute ~customLayout ~standalone:true attr cmtTbl) + fst (printAttribute ~customLayout ~standalone:true attr cmtTbl) | Psig_extension (extension, attrs) -> - Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - Doc.concat - [printExtension ~customLayout ~atModuleLvl:true extension cmtTbl]; - ] + Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + Doc.concat + [ printExtension ~customLayout ~atModuleLvl:true extension cmtTbl ]; + ] | Psig_class _ | Psig_class_type _ -> Doc.nil and printRecModuleDeclarations ~customLayout moduleDeclarations cmtTbl = @@ -53791,23 +53924,22 @@ and printRecModuleDeclaration ~customLayout md cmtTbl i = let body = match md.pmd_type.pmty_desc with | Parsetree.Pmty_alias longident -> - Doc.concat [Doc.text " = "; printLongidentLocation longident cmtTbl] + Doc.concat [ Doc.text " = "; printLongidentLocation longident cmtTbl ] | _ -> - let needsParens = - match md.pmd_type.pmty_desc with - | Pmty_with _ -> true - | _ -> false - in - let modTypeDoc = - let doc = printModType ~customLayout md.pmd_type cmtTbl in - if needsParens then addParens doc else doc - in - Doc.concat [Doc.text ": "; modTypeDoc] + let needsParens = + match md.pmd_type.pmty_desc with Pmty_with _ -> true | _ -> false + in + let modTypeDoc = + let doc = printModType ~customLayout md.pmd_type cmtTbl in + if needsParens then addParens doc else doc + in + Doc.concat [ Doc.text ": "; modTypeDoc ] in let prefix = if i < 1 then "module rec " else "and " in Doc.concat [ - printAttributes ~customLayout ~loc:md.pmd_name.loc md.pmd_attributes cmtTbl; + printAttributes ~customLayout ~loc:md.pmd_name.loc md.pmd_attributes + cmtTbl; Doc.text prefix; printComments (Doc.text md.pmd_name.txt) cmtTbl md.pmd_name.loc; body; @@ -53818,13 +53950,15 @@ and printModuleDeclaration ~customLayout (md : Parsetree.module_declaration) let body = match md.pmd_type.pmty_desc with | Parsetree.Pmty_alias longident -> - Doc.concat [Doc.text " = "; printLongidentLocation longident cmtTbl] + Doc.concat [ Doc.text " = "; printLongidentLocation longident cmtTbl ] | _ -> - Doc.concat [Doc.text ": "; printModType ~customLayout md.pmd_type cmtTbl] + Doc.concat + [ Doc.text ": "; printModType ~customLayout md.pmd_type cmtTbl ] in Doc.concat [ - printAttributes ~customLayout ~loc:md.pmd_name.loc md.pmd_attributes cmtTbl; + printAttributes ~customLayout ~loc:md.pmd_name.loc md.pmd_attributes + cmtTbl; Doc.text "module "; printComments (Doc.text md.pmd_name.txt) cmtTbl md.pmd_name.loc; body; @@ -53875,9 +54009,7 @@ and printValueBindings ~customLayout ~recFlag and printValueDescription ~customLayout valueDescription cmtTbl = let isExternal = - match valueDescription.pval_prim with - | [] -> false - | _ -> true + match valueDescription.pval_prim with [] -> false | _ -> true in let attrs = printAttributes ~customLayout ~loc:valueDescription.pval_name.loc @@ -53907,7 +54039,7 @@ and printValueDescription ~customLayout valueDescription cmtTbl = (List.map (fun s -> Doc.concat - [Doc.text "\""; Doc.text s; Doc.text "\""]) + [ Doc.text "\""; Doc.text s; Doc.text "\"" ]) valueDescription.pval_prim); ]); ]) @@ -53959,72 +54091,72 @@ and printTypeDeclaration ~customLayout ~name ~equalSign ~recFlag i printAttributes ~customLayout ~loc:td.ptype_loc td.ptype_attributes cmtTbl in let prefix = - if i > 0 then Doc.text "and " else Doc.concat [Doc.text "type "; recFlag] + if i > 0 then Doc.text "and " else Doc.concat [ Doc.text "type "; recFlag ] in let typeName = name in let typeParams = printTypeParams ~customLayout td.ptype_params cmtTbl in let manifestAndKind = match td.ptype_kind with | Ptype_abstract -> ( - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> + Doc.concat + [ + Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + printPrivateFlag td.ptype_private; + printTypExpr ~customLayout typ cmtTbl; + ]) + | Ptype_open -> Doc.concat [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; printPrivateFlag td.ptype_private; - printTypExpr ~customLayout typ cmtTbl; - ]) - | Ptype_open -> - Doc.concat - [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - Doc.text ".."; - ] + Doc.text ".."; + ] | Ptype_record lds -> - let manifest = - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr ~customLayout typ cmtTbl; - ] - in - Doc.concat - [ - manifest; - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - printRecordDeclaration ~customLayout lds cmtTbl; - ] + let manifest = + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> + Doc.concat + [ + Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + printTypExpr ~customLayout typ cmtTbl; + ] + in + Doc.concat + [ + manifest; + Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + printPrivateFlag td.ptype_private; + printRecordDeclaration ~customLayout lds cmtTbl; + ] | Ptype_variant cds -> - let manifest = - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr ~customLayout typ cmtTbl; - ] - in - Doc.concat - [ - manifest; - Doc.concat [Doc.space; Doc.text equalSign]; - printConstructorDeclarations ~customLayout - ~privateFlag:td.ptype_private cds cmtTbl; - ] + let manifest = + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> + Doc.concat + [ + Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + printTypExpr ~customLayout typ cmtTbl; + ] + in + Doc.concat + [ + manifest; + Doc.concat [ Doc.space; Doc.text equalSign ]; + printConstructorDeclarations ~customLayout + ~privateFlag:td.ptype_private cds cmtTbl; + ] in let constraints = printTypeDefinitionConstraints ~customLayout td.ptype_cstrs in Doc.group (Doc.concat - [attrs; prefix; typeName; typeParams; manifestAndKind; constraints]) + [ attrs; prefix; typeName; typeParams; manifestAndKind; constraints ]) and printTypeDeclaration2 ~customLayout ~recFlag (td : Parsetree.type_declaration) cmtTbl i = @@ -54037,99 +54169,99 @@ and printTypeDeclaration2 ~customLayout ~recFlag printAttributes ~customLayout ~loc:td.ptype_loc td.ptype_attributes cmtTbl in let prefix = - if i > 0 then Doc.text "and " else Doc.concat [Doc.text "type "; recFlag] + if i > 0 then Doc.text "and " else Doc.concat [ Doc.text "type "; recFlag ] in let typeName = name in let typeParams = printTypeParams ~customLayout td.ptype_params cmtTbl in let manifestAndKind = match td.ptype_kind with | Ptype_abstract -> ( - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - printTypExpr ~customLayout typ cmtTbl; - ]) + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> + Doc.concat + [ + Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + printPrivateFlag td.ptype_private; + printTypExpr ~customLayout typ cmtTbl; + ]) | Ptype_open -> - Doc.concat - [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - Doc.text ".."; - ] - | Ptype_record lds -> - if lds = [] then Doc.concat [ - Doc.space; - Doc.text equalSign; - Doc.space; - Doc.lbrace; - printCommentsInside cmtTbl td.ptype_loc; - Doc.rbrace; + Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + printPrivateFlag td.ptype_private; + Doc.text ".."; ] - else + | Ptype_record lds -> + if lds = [] then + Doc.concat + [ + Doc.space; + Doc.text equalSign; + Doc.space; + Doc.lbrace; + printCommentsInside cmtTbl td.ptype_loc; + Doc.rbrace; + ] + else + let manifest = + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> + Doc.concat + [ + Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + printTypExpr ~customLayout typ cmtTbl; + ] + in + Doc.concat + [ + manifest; + Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + printPrivateFlag td.ptype_private; + printRecordDeclaration ~customLayout lds cmtTbl; + ] + | Ptype_variant cds -> let manifest = match td.ptype_manifest with | None -> Doc.nil | Some typ -> - Doc.concat - [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr ~customLayout typ cmtTbl; - ] + Doc.concat + [ + Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + printTypExpr ~customLayout typ cmtTbl; + ] in Doc.concat [ manifest; - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - printRecordDeclaration ~customLayout lds cmtTbl; + Doc.concat [ Doc.space; Doc.text equalSign ]; + printConstructorDeclarations ~customLayout + ~privateFlag:td.ptype_private cds cmtTbl; ] - | Ptype_variant cds -> - let manifest = - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr ~customLayout typ cmtTbl; - ] - in - Doc.concat - [ - manifest; - Doc.concat [Doc.space; Doc.text equalSign]; - printConstructorDeclarations ~customLayout - ~privateFlag:td.ptype_private cds cmtTbl; - ] in let constraints = printTypeDefinitionConstraints ~customLayout td.ptype_cstrs in Doc.group (Doc.concat - [attrs; prefix; typeName; typeParams; manifestAndKind; constraints]) + [ attrs; prefix; typeName; typeParams; manifestAndKind; constraints ]) and printTypeDefinitionConstraints ~customLayout cstrs = match cstrs with | [] -> Doc.nil | cstrs -> - Doc.indent - (Doc.group - (Doc.concat - [ - Doc.line; - Doc.group - (Doc.join ~sep:Doc.line - (List.map - (printTypeDefinitionConstraint ~customLayout) - cstrs)); - ])) + Doc.indent + (Doc.group + (Doc.concat + [ + Doc.line; + Doc.group + (Doc.join ~sep:Doc.line + (List.map + (printTypeDefinitionConstraint ~customLayout) + cstrs)); + ])) and printTypeDefinitionConstraint ~customLayout ((typ1, typ2, _loc) : @@ -54143,37 +54275,35 @@ and printTypeDefinitionConstraint ~customLayout ] and printPrivateFlag (flag : Asttypes.private_flag) = - match flag with - | Private -> Doc.text "private " - | Public -> Doc.nil + match flag with Private -> Doc.text "private " | Public -> Doc.nil and printTypeParams ~customLayout typeParams cmtTbl = match typeParams with | [] -> Doc.nil | typeParams -> - Doc.group - (Doc.concat - [ - Doc.lessThan; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun typeParam -> - let doc = - printTypeParam ~customLayout typeParam cmtTbl - in - printComments doc cmtTbl - (fst typeParam).Parsetree.ptyp_loc) - typeParams); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.greaterThan; - ]) + Doc.group + (Doc.concat + [ + Doc.lessThan; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun typeParam -> + let doc = + printTypeParam ~customLayout typeParam cmtTbl + in + printComments doc cmtTbl + (fst typeParam).Parsetree.ptyp_loc) + typeParams); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.greaterThan; + ]) and printTypeParam ~customLayout (param : Parsetree.core_type * Asttypes.variance) cmtTbl = @@ -54184,14 +54314,14 @@ and printTypeParam ~customLayout | Contravariant -> Doc.text "-" | Invariant -> Doc.nil in - Doc.concat [printedVariance; printTypExpr ~customLayout typ cmtTbl] + Doc.concat [ printedVariance; printTypExpr ~customLayout typ cmtTbl ] and printRecordDeclaration ~customLayout (lds : Parsetree.label_declaration list) cmtTbl = let forceBreak = match (lds, List.rev lds) with | first :: _, last :: _ -> - first.pld_loc.loc_start.pos_lnum < last.pld_loc.loc_end.pos_lnum + first.pld_loc.loc_start.pos_lnum < last.pld_loc.loc_end.pos_lnum | _ -> false in Doc.breakableGroup ~forceBreak @@ -54203,7 +54333,7 @@ and printRecordDeclaration ~customLayout [ Doc.softLine; Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) (List.map (fun ld -> let doc = @@ -54222,12 +54352,12 @@ and printConstructorDeclarations ~customLayout ~privateFlag let forceBreak = match (cds, List.rev cds) with | first :: _, last :: _ -> - first.pcd_loc.loc_start.pos_lnum < last.pcd_loc.loc_end.pos_lnum + first.pcd_loc.loc_start.pos_lnum < last.pcd_loc.loc_end.pos_lnum | _ -> false in let privateFlag = match privateFlag with - | Asttypes.Private -> Doc.concat [Doc.text "private"; Doc.line] + | Asttypes.Private -> Doc.concat [ Doc.text "private"; Doc.line ] | Public -> Doc.nil in let rows = @@ -54240,7 +54370,7 @@ and printConstructorDeclarations ~customLayout ~privateFlag ~forceBreak cmtTbl in Doc.breakableGroup ~forceBreak - (Doc.indent (Doc.concat [Doc.line; privateFlag; rows])) + (Doc.indent (Doc.concat [ Doc.line; privateFlag; rows ])) and printConstructorDeclaration2 ~customLayout i (cd : Parsetree.constructor_declaration) cmtTbl = @@ -54260,8 +54390,8 @@ and printConstructorDeclaration2 ~customLayout i match cd.pcd_res with | None -> Doc.nil | Some typ -> - Doc.indent - (Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ cmtTbl]) + Doc.indent + (Doc.concat [ Doc.text ": "; printTypExpr ~customLayout typ cmtTbl ]) in Doc.concat [ @@ -54282,54 +54412,55 @@ and printConstructorArguments ~customLayout ~indent match cdArgs with | Pcstr_tuple [] -> Doc.nil | Pcstr_tuple types -> - let args = - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun typexpr -> printTypExpr ~customLayout typexpr cmtTbl) - types); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - in - Doc.group (if indent then Doc.indent args else args) + let args = + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun typexpr -> + printTypExpr ~customLayout typexpr cmtTbl) + types); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + in + Doc.group (if indent then Doc.indent args else args) | Pcstr_record lds -> - let args = - Doc.concat - [ - Doc.lparen; - (* manually inline the printRecordDeclaration, gives better layout *) - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun ld -> - let doc = - printLabelDeclaration ~customLayout ld cmtTbl - in - printComments doc cmtTbl ld.Parsetree.pld_loc) - lds); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - Doc.rparen; - ] - in - if indent then Doc.indent args else args + let args = + Doc.concat + [ + Doc.lparen; + (* manually inline the printRecordDeclaration, gives better layout *) + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun ld -> + let doc = + printLabelDeclaration ~customLayout ld cmtTbl + in + printComments doc cmtTbl ld.Parsetree.pld_loc) + lds); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + Doc.rparen; + ] + in + if indent then Doc.indent args else args and printLabelDeclaration ~customLayout (ld : Parsetree.label_declaration) cmtTbl = @@ -54362,242 +54493,261 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = match typExpr.ptyp_desc with | Ptyp_any -> Doc.text "_" | Ptyp_var var -> - Doc.concat [Doc.text "'"; printIdentLike ~allowUident:true var] + Doc.concat [ Doc.text "'"; printIdentLike ~allowUident:true var ] | Ptyp_extension extension -> - printExtension ~customLayout ~atModuleLvl:false extension cmtTbl + printExtension ~customLayout ~atModuleLvl:false extension cmtTbl | Ptyp_alias (typ, alias) -> - let typ = - (* Technically type t = (string, float) => unit as 'x, doesn't require - * parens around the arrow expression. This is very confusing though. - * Is the "as" part of "unit" or "(string, float) => unit". By printing - * parens we guide the user towards its meaning.*) - let needsParens = - match typ.ptyp_desc with - | Ptyp_arrow _ -> true - | _ -> false + let typ = + (* Technically type t = (string, float) => unit as 'x, doesn't require + * parens around the arrow expression. This is very confusing though. + * Is the "as" part of "unit" or "(string, float) => unit". By printing + * parens we guide the user towards its meaning.*) + let needsParens = + match typ.ptyp_desc with Ptyp_arrow _ -> true | _ -> false + in + let doc = printTypExpr ~customLayout typ cmtTbl in + if needsParens then Doc.concat [ Doc.lparen; doc; Doc.rparen ] + else doc in - let doc = printTypExpr ~customLayout typ cmtTbl in - if needsParens then Doc.concat [Doc.lparen; doc; Doc.rparen] else doc - in - Doc.concat - [typ; Doc.text " as "; Doc.concat [Doc.text "'"; printIdentLike alias]] + Doc.concat + [ + typ; + Doc.text " as "; + Doc.concat [ Doc.text "'"; printIdentLike alias ]; + ] (* object printings *) | Ptyp_object (fields, openFlag) -> - printObject ~customLayout ~inline:false fields openFlag cmtTbl - | Ptyp_constr (longidentLoc, [{ptyp_desc = Ptyp_object (fields, openFlag)}]) + printObject ~customLayout ~inline:false fields openFlag cmtTbl + | Ptyp_constr + (longidentLoc, [ { ptyp_desc = Ptyp_object (fields, openFlag) } ]) -> + (* for foo<{"a": b}>, when the object is long and needs a line break, we + want the <{ and }> to stay hugged together *) + let constrName = printLidentPath longidentLoc cmtTbl in + Doc.concat + [ + constrName; + Doc.lessThan; + printObject ~customLayout ~inline:true fields openFlag cmtTbl; + Doc.greaterThan; + ] + | Ptyp_constr (longidentLoc, [ { ptyp_desc = Parsetree.Ptyp_tuple tuple } ]) -> - (* for foo<{"a": b}>, when the object is long and needs a line break, we - want the <{ and }> to stay hugged together *) - let constrName = printLidentPath longidentLoc cmtTbl in - Doc.concat - [ - constrName; - Doc.lessThan; - printObject ~customLayout ~inline:true fields openFlag cmtTbl; - Doc.greaterThan; - ] - | Ptyp_constr (longidentLoc, [{ptyp_desc = Parsetree.Ptyp_tuple tuple}]) -> - let constrName = printLidentPath longidentLoc cmtTbl in - Doc.group - (Doc.concat - [ - constrName; - Doc.lessThan; - printTupleType ~customLayout ~inline:true tuple cmtTbl; - Doc.greaterThan; - ]) - | Ptyp_constr (longidentLoc, constrArgs) -> ( - let constrName = printLidentPath longidentLoc cmtTbl in - match constrArgs with - | [] -> constrName - | _args -> + let constrName = printLidentPath longidentLoc cmtTbl in Doc.group (Doc.concat [ constrName; Doc.lessThan; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun typexpr -> - printTypExpr ~customLayout typexpr cmtTbl) - constrArgs); - ]); - Doc.trailingComma; - Doc.softLine; + printTupleType ~customLayout ~inline:true tuple cmtTbl; Doc.greaterThan; - ])) + ]) + | Ptyp_constr (longidentLoc, constrArgs) -> ( + let constrName = printLidentPath longidentLoc cmtTbl in + match constrArgs with + | [] -> constrName + | _args -> + Doc.group + (Doc.concat + [ + constrName; + Doc.lessThan; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun typexpr -> + printTypExpr ~customLayout typexpr cmtTbl) + constrArgs); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.greaterThan; + ])) | Ptyp_arrow _ -> ( - let attrsBefore, args, returnType = ParsetreeViewer.arrowType typExpr in - let returnTypeNeedsParens = - match returnType.ptyp_desc with - | Ptyp_alias _ -> true - | _ -> false - in - let returnDoc = - let doc = printTypExpr ~customLayout returnType cmtTbl in - if returnTypeNeedsParens then Doc.concat [Doc.lparen; doc; Doc.rparen] - else doc - in - let isUncurried, attrs = - ParsetreeViewer.processUncurriedAttribute attrsBefore - in - match args with - | [] -> Doc.nil - | [([], Nolabel, n)] when not isUncurried -> - let hasAttrsBefore = not (attrs = []) in - let attrs = - if hasAttrsBefore then - printAttributes ~customLayout ~inline:true attrsBefore cmtTbl - else Doc.nil + let attrsBefore, args, returnType = ParsetreeViewer.arrowType typExpr in + let returnTypeNeedsParens = + match returnType.ptyp_desc with Ptyp_alias _ -> true | _ -> false in - let typDoc = - let doc = printTypExpr ~customLayout n cmtTbl in - match n.ptyp_desc with - | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> addParens doc - | _ -> doc + let returnDoc = + let doc = printTypExpr ~customLayout returnType cmtTbl in + if returnTypeNeedsParens then + Doc.concat [ Doc.lparen; doc; Doc.rparen ] + else doc in - Doc.group - (Doc.concat - [ - Doc.group attrs; - Doc.group - (if hasAttrsBefore then - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [Doc.softLine; typDoc; Doc.text " => "; returnDoc]); - Doc.softLine; - Doc.rparen; - ] - else Doc.concat [typDoc; Doc.text " => "; returnDoc]); - ]) - | args -> - let attrs = printAttributes ~customLayout ~inline:true attrs cmtTbl in - let renderedArgs = - Doc.concat - [ - attrs; - Doc.text "("; - Doc.indent - (Doc.concat - [ - Doc.softLine; - (if isUncurried then Doc.concat [Doc.dot; Doc.space] - else Doc.nil); - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun tp -> printTypeParameter ~customLayout tp cmtTbl) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.text ")"; - ] + let isUncurried, attrs = + ParsetreeViewer.processUncurriedAttribute attrsBefore in - Doc.group (Doc.concat [renderedArgs; Doc.text " => "; returnDoc])) + match args with + | [] -> Doc.nil + | [ ([], Nolabel, n) ] when not isUncurried -> + let hasAttrsBefore = not (attrs = []) in + let attrs = + if hasAttrsBefore then + printAttributes ~customLayout ~inline:true attrsBefore cmtTbl + else Doc.nil + in + let typDoc = + let doc = printTypExpr ~customLayout n cmtTbl in + match n.ptyp_desc with + | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> addParens doc + | _ -> doc + in + Doc.group + (Doc.concat + [ + Doc.group attrs; + Doc.group + (if hasAttrsBefore then + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + typDoc; + Doc.text " => "; + returnDoc; + ]); + Doc.softLine; + Doc.rparen; + ] + else Doc.concat [ typDoc; Doc.text " => "; returnDoc ]); + ]) + | args -> + let attrs = + printAttributes ~customLayout ~inline:true attrs cmtTbl + in + let renderedArgs = + Doc.concat + [ + attrs; + Doc.text "("; + Doc.indent + (Doc.concat + [ + Doc.softLine; + (if isUncurried then Doc.concat [ Doc.dot; Doc.space ] + else Doc.nil); + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun tp -> + printTypeParameter ~customLayout tp cmtTbl) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.text ")"; + ] + in + Doc.group (Doc.concat [ renderedArgs; Doc.text " => "; returnDoc ])) | Ptyp_tuple types -> - printTupleType ~customLayout ~inline:false types cmtTbl + printTupleType ~customLayout ~inline:false types cmtTbl | Ptyp_poly ([], typ) -> printTypExpr ~customLayout typ cmtTbl | Ptyp_poly (stringLocs, typ) -> - Doc.concat - [ - Doc.join ~sep:Doc.space - (List.map - (fun {Location.txt; loc} -> - let doc = Doc.concat [Doc.text "'"; Doc.text txt] in - printComments doc cmtTbl loc) - stringLocs); - Doc.dot; - Doc.space; - printTypExpr ~customLayout typ cmtTbl; - ] + Doc.concat + [ + Doc.join ~sep:Doc.space + (List.map + (fun { Location.txt; loc } -> + let doc = Doc.concat [ Doc.text "'"; Doc.text txt ] in + printComments doc cmtTbl loc) + stringLocs); + Doc.dot; + Doc.space; + printTypExpr ~customLayout typ cmtTbl; + ] | Ptyp_package packageType -> - printPackageType ~customLayout ~printModuleKeywordAndParens:true - packageType cmtTbl + printPackageType ~customLayout ~printModuleKeywordAndParens:true + packageType cmtTbl | Ptyp_class _ -> Doc.text "classes are not supported in types" | Ptyp_variant (rowFields, closedFlag, labelsOpt) -> - let forceBreak = - typExpr.ptyp_loc.Location.loc_start.pos_lnum - < typExpr.ptyp_loc.loc_end.pos_lnum - in - let printRowField = function - | Parsetree.Rtag ({txt; loc}, attrs, true, []) -> - let doc = - Doc.group - (Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - Doc.concat [Doc.text "#"; printPolyVarIdent txt]; - ]) - in - printComments doc cmtTbl loc - | Rtag ({txt}, attrs, truth, types) -> - let doType t = - match t.Parsetree.ptyp_desc with - | Ptyp_tuple _ -> printTypExpr ~customLayout t cmtTbl - | _ -> + let forceBreak = + typExpr.ptyp_loc.Location.loc_start.pos_lnum + < typExpr.ptyp_loc.loc_end.pos_lnum + in + let printRowField = function + | Parsetree.Rtag ({ txt; loc }, attrs, true, []) -> + let doc = + Doc.group + (Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + Doc.concat [ Doc.text "#"; printPolyVarIdent txt ]; + ]) + in + printComments doc cmtTbl loc + | Rtag ({ txt }, attrs, truth, types) -> + let doType t = + match t.Parsetree.ptyp_desc with + | Ptyp_tuple _ -> printTypExpr ~customLayout t cmtTbl + | _ -> + Doc.concat + [ + Doc.lparen; + printTypExpr ~customLayout t cmtTbl; + Doc.rparen; + ] + in + let printedTypes = List.map doType types in + let cases = + Doc.join + ~sep:(Doc.concat [ Doc.line; Doc.text "& " ]) + printedTypes + in + let cases = + if truth then Doc.concat [ Doc.line; Doc.text "& "; cases ] + else cases + in + Doc.group + (Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + Doc.concat [ Doc.text "#"; printPolyVarIdent txt ]; + cases; + ]) + | Rinherit coreType -> printTypExpr ~customLayout coreType cmtTbl + in + let docs = List.map printRowField rowFields in + let cases = + Doc.join ~sep:(Doc.concat [ Doc.line; Doc.text "| " ]) docs + in + let cases = + if docs = [] then cases + else Doc.concat [ Doc.ifBreaks (Doc.text "| ") Doc.nil; cases ] + in + let openingSymbol = + if closedFlag = Open then Doc.concat [ Doc.greaterThan; Doc.line ] + else if labelsOpt = None then Doc.softLine + else Doc.concat [ Doc.lessThan; Doc.line ] + in + let labels = + match labelsOpt with + | None | Some [] -> Doc.nil + | Some labels -> Doc.concat - [Doc.lparen; printTypExpr ~customLayout t cmtTbl; Doc.rparen] - in - let printedTypes = List.map doType types in - let cases = - Doc.join ~sep:(Doc.concat [Doc.line; Doc.text "& "]) printedTypes - in - let cases = - if truth then Doc.concat [Doc.line; Doc.text "& "; cases] else cases - in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - Doc.concat [Doc.text "#"; printPolyVarIdent txt]; - cases; - ]) - | Rinherit coreType -> printTypExpr ~customLayout coreType cmtTbl - in - let docs = List.map printRowField rowFields in - let cases = Doc.join ~sep:(Doc.concat [Doc.line; Doc.text "| "]) docs in - let cases = - if docs = [] then cases - else Doc.concat [Doc.ifBreaks (Doc.text "| ") Doc.nil; cases] - in - let openingSymbol = - if closedFlag = Open then Doc.concat [Doc.greaterThan; Doc.line] - else if labelsOpt = None then Doc.softLine - else Doc.concat [Doc.lessThan; Doc.line] - in - let labels = - match labelsOpt with - | None | Some [] -> Doc.nil - | Some labels -> - Doc.concat - (List.map - (fun label -> - Doc.concat [Doc.line; Doc.text "#"; printPolyVarIdent label]) - labels) - in - let closingSymbol = - match labelsOpt with - | None | Some [] -> Doc.nil - | _ -> Doc.text " >" - in - Doc.breakableGroup ~forceBreak - (Doc.concat - [ - Doc.lbracket; - Doc.indent - (Doc.concat [openingSymbol; cases; closingSymbol; labels]); - Doc.softLine; - Doc.rbracket; - ]) + (List.map + (fun label -> + Doc.concat + [ Doc.line; Doc.text "#"; printPolyVarIdent label ]) + labels) + in + let closingSymbol = + match labelsOpt with None | Some [] -> Doc.nil | _ -> Doc.text " >" + in + Doc.breakableGroup ~forceBreak + (Doc.concat + [ + Doc.lbracket; + Doc.indent + (Doc.concat [ openingSymbol; cases; closingSymbol; labels ]); + Doc.softLine; + Doc.rbracket; + ]) in let shouldPrintItsOwnAttributes = match typExpr.ptyp_desc with @@ -54607,8 +54757,9 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = let doc = match typExpr.ptyp_attributes with | _ :: _ as attrs when not shouldPrintItsOwnAttributes -> - Doc.group - (Doc.concat [printAttributes ~customLayout attrs cmtTbl; renderedType]) + Doc.group + (Doc.concat + [ printAttributes ~customLayout attrs cmtTbl; renderedType ]) | _ -> renderedType in printComments doc cmtTbl typExpr.ptyp_loc @@ -54617,40 +54768,41 @@ and printObject ~customLayout ~inline fields openFlag cmtTbl = let doc = match fields with | [] -> - Doc.concat - [ - Doc.lbrace; - (match openFlag with - | Asttypes.Closed -> Doc.dot - | Open -> Doc.dotdot); - Doc.rbrace; - ] + Doc.concat + [ + Doc.lbrace; + (match openFlag with + | Asttypes.Closed -> Doc.dot + | Open -> Doc.dotdot); + Doc.rbrace; + ] | fields -> - Doc.concat - [ - Doc.lbrace; - (match openFlag with - | Asttypes.Closed -> Doc.nil - | Open -> ( - match fields with - (* handle `type t = {.. ...objType, "x": int}` - * .. and ... should have a space in between *) - | Oinherit _ :: _ -> Doc.text ".. " - | _ -> Doc.dotdot)); - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun field -> printObjectField ~customLayout field cmtTbl) - fields); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ] + Doc.concat + [ + Doc.lbrace; + (match openFlag with + | Asttypes.Closed -> Doc.nil + | Open -> ( + match fields with + (* handle `type t = {.. ...objType, "x": int}` + * .. and ... should have a space in between *) + | Oinherit _ :: _ -> Doc.text ".. " + | _ -> Doc.dotdot)); + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun field -> + printObjectField ~customLayout field cmtTbl) + fields); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ] in if inline then doc else Doc.group doc @@ -54665,7 +54817,7 @@ and printTupleType ~customLayout ~inline (types : Parsetree.core_type list) [ Doc.softLine; Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) (List.map (fun typexpr -> printTypExpr ~customLayout typexpr cmtTbl) types); @@ -54680,23 +54832,23 @@ and printTupleType ~customLayout ~inline (types : Parsetree.core_type list) and printObjectField ~customLayout (field : Parsetree.object_field) cmtTbl = match field with | Otag (labelLoc, attrs, typ) -> - let lbl = - let doc = Doc.text ("\"" ^ labelLoc.txt ^ "\"") in - printComments doc cmtTbl labelLoc.loc - in - let doc = - Doc.concat - [ - printAttributes ~customLayout ~loc:labelLoc.loc attrs cmtTbl; - lbl; - Doc.text ": "; - printTypExpr ~customLayout typ cmtTbl; - ] - in - let cmtLoc = {labelLoc.loc with loc_end = typ.ptyp_loc.loc_end} in - printComments doc cmtTbl cmtLoc + let lbl = + let doc = Doc.text ("\"" ^ labelLoc.txt ^ "\"") in + printComments doc cmtTbl labelLoc.loc + in + let doc = + Doc.concat + [ + printAttributes ~customLayout ~loc:labelLoc.loc attrs cmtTbl; + lbl; + Doc.text ": "; + printTypExpr ~customLayout typ cmtTbl; + ] + in + let cmtLoc = { labelLoc.loc with loc_end = typ.ptyp_loc.loc_end } in + printComments doc cmtTbl cmtLoc | Oinherit typexpr -> - Doc.concat [Doc.dotdotdot; printTypExpr ~customLayout typexpr cmtTbl] + Doc.concat [ Doc.dotdotdot; printTypExpr ~customLayout typexpr cmtTbl ] (* es6 arrow type arg * type t = (~foo: string, ~bar: float=?, unit) => unit @@ -54704,16 +54856,16 @@ and printObjectField ~customLayout (field : Parsetree.object_field) cmtTbl = and printTypeParameter ~customLayout (attrs, lbl, typ) cmtTbl = let isUncurried, attrs = ParsetreeViewer.processUncurriedAttribute attrs in let uncurried = - if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil + if isUncurried then Doc.concat [ Doc.dot; Doc.space ] else Doc.nil in let attrs = printAttributes ~customLayout attrs cmtTbl in let label = match lbl with | Asttypes.Nolabel -> Doc.nil | Labelled lbl -> - Doc.concat [Doc.text "~"; printIdentLike lbl; Doc.text ": "] + Doc.concat [ Doc.text "~"; printIdentLike lbl; Doc.text ": " ] | Optional lbl -> - Doc.concat [Doc.text "~"; printIdentLike lbl; Doc.text ": "] + Doc.concat [ Doc.text "~"; printIdentLike lbl; Doc.text ": " ] in let optionalIndicator = match lbl with @@ -54722,9 +54874,9 @@ and printTypeParameter ~customLayout (attrs, lbl, typ) cmtTbl = in let loc, typ = match typ.ptyp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: attrs -> - ( {loc with loc_end = typ.ptyp_loc.loc_end}, - {typ with ptyp_attributes = attrs} ) + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: attrs -> + ( { loc with loc_end = typ.ptyp_loc.loc_end }, + { typ with ptyp_attributes = attrs } ) | _ -> (typ.ptyp_loc, typ) in let doc = @@ -54747,169 +54899,178 @@ and printValueBinding ~customLayout ~recFlag (vb : Parsetree.value_binding) cmtTbl in let header = - if i == 0 then Doc.concat [Doc.text "let "; recFlag] else Doc.text "and " + if i == 0 then Doc.concat [ Doc.text "let "; recFlag ] else Doc.text "and " in match vb with | { pvb_pat = { ppat_desc = - Ppat_constraint (pattern, ({ptyp_desc = Ptyp_poly _} as patTyp)); + Ppat_constraint (pattern, ({ ptyp_desc = Ptyp_poly _ } as patTyp)); }; - pvb_expr = {pexp_desc = Pexp_newtype _} as expr; + pvb_expr = { pexp_desc = Pexp_newtype _ } as expr; } -> ( - let _attrs, parameters, returnExpr = ParsetreeViewer.funExpr expr in - let abstractType = - match parameters with - | [NewTypes {locs = vars}] -> - Doc.concat - [ - Doc.text "type "; - Doc.join ~sep:Doc.space - (List.map (fun var -> Doc.text var.Asttypes.txt) vars); - Doc.dot; - ] - | _ -> Doc.nil - in - match returnExpr.pexp_desc with - | Pexp_constraint (expr, typ) -> - Doc.group - (Doc.concat - [ - attrs; - header; - printPattern ~customLayout pattern cmtTbl; - Doc.text ":"; - Doc.indent - (Doc.concat - [ - Doc.line; - abstractType; - Doc.space; - printTypExpr ~customLayout typ cmtTbl; - Doc.text " ="; - Doc.concat - [ - Doc.line; - printExpressionWithComments ~customLayout expr cmtTbl; - ]; - ]); - ]) - | _ -> - (* Example: - * let cancel_and_collect_callbacks: - * 'a 'u 'c. (list, promise<'a, 'u, 'c>) => list = * (type x, callbacks_accumulator, p: promise<_, _, c>) - *) - Doc.group - (Doc.concat - [ - attrs; - header; - printPattern ~customLayout pattern cmtTbl; - Doc.text ":"; - Doc.indent - (Doc.concat - [ - Doc.line; - abstractType; - Doc.space; - printTypExpr ~customLayout patTyp cmtTbl; - Doc.text " ="; - Doc.concat - [ - Doc.line; - printExpressionWithComments ~customLayout expr cmtTbl; - ]; - ]); - ])) - | _ -> - let optBraces, expr = ParsetreeViewer.processBracesAttr vb.pvb_expr in - let printedExpr = - let doc = printExpressionWithComments ~customLayout vb.pvb_expr cmtTbl in - match Parens.expr vb.pvb_expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - let patternDoc = printPattern ~customLayout vb.pvb_pat cmtTbl in - (* - * we want to optimize the layout of one pipe: - * let tbl = data->Js.Array2.reduce((map, curr) => { - * ... - * }) - * important is that we don't do this for multiple pipes: - * let decoratorTags = - * items - * ->Js.Array2.filter(items => {items.category === Decorators}) - * ->Belt.Array.map(...) - * Multiple pipes chained together lend themselves more towards the last layout. - *) - if ParsetreeViewer.isSinglePipeExpr vb.pvb_expr then - Doc.customLayout - [ + let _attrs, parameters, returnExpr = ParsetreeViewer.funExpr expr in + let abstractType = + match parameters with + | [ NewTypes { locs = vars } ] -> + Doc.concat + [ + Doc.text "type "; + Doc.join ~sep:Doc.space + (List.map (fun var -> Doc.text var.Asttypes.txt) vars); + Doc.dot; + ] + | _ -> Doc.nil + in + match returnExpr.pexp_desc with + | Pexp_constraint (expr, typ) -> Doc.group (Doc.concat [ - attrs; header; patternDoc; Doc.text " ="; Doc.space; printedExpr; - ]); + attrs; + header; + printPattern ~customLayout pattern cmtTbl; + Doc.text ":"; + Doc.indent + (Doc.concat + [ + Doc.line; + abstractType; + Doc.space; + printTypExpr ~customLayout typ cmtTbl; + Doc.text " ="; + Doc.concat + [ + Doc.line; + printExpressionWithComments ~customLayout expr + cmtTbl; + ]; + ]); + ]) + | _ -> + (* Example: + * let cancel_and_collect_callbacks: + * 'a 'u 'c. (list, promise<'a, 'u, 'c>) => list = * (type x, callbacks_accumulator, p: promise<_, _, c>) + *) Doc.group (Doc.concat [ attrs; header; - patternDoc; - Doc.text " ="; - Doc.indent (Doc.concat [Doc.line; printedExpr]); - ]); - ] - else - let shouldIndent = - match optBraces with - | Some _ -> false - | _ -> ( - ParsetreeViewer.isBinaryExpression expr - || - match vb.pvb_expr with - | { - pexp_attributes = [({Location.txt = "ns.ternary"}, _)]; - pexp_desc = Pexp_ifthenelse (ifExpr, _, _); - } -> - ParsetreeViewer.isBinaryExpression ifExpr - || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes - | {pexp_desc = Pexp_newtype _} -> false - | e -> - ParsetreeViewer.hasAttributes e.pexp_attributes - || ParsetreeViewer.isArrayAccess e) + printPattern ~customLayout pattern cmtTbl; + Doc.text ":"; + Doc.indent + (Doc.concat + [ + Doc.line; + abstractType; + Doc.space; + printTypExpr ~customLayout patTyp cmtTbl; + Doc.text " ="; + Doc.concat + [ + Doc.line; + printExpressionWithComments ~customLayout expr + cmtTbl; + ]; + ]); + ])) + | _ -> + let optBraces, expr = ParsetreeViewer.processBracesAttr vb.pvb_expr in + let printedExpr = + let doc = + printExpressionWithComments ~customLayout vb.pvb_expr cmtTbl + in + match Parens.expr vb.pvb_expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc in - Doc.group - (Doc.concat - [ - attrs; - header; - patternDoc; - Doc.text " ="; - (if shouldIndent then - Doc.indent (Doc.concat [Doc.line; printedExpr]) - else Doc.concat [Doc.space; printedExpr]); - ]) + let patternDoc = printPattern ~customLayout vb.pvb_pat cmtTbl in + (* + * we want to optimize the layout of one pipe: + * let tbl = data->Js.Array2.reduce((map, curr) => { + * ... + * }) + * important is that we don't do this for multiple pipes: + * let decoratorTags = + * items + * ->Js.Array2.filter(items => {items.category === Decorators}) + * ->Belt.Array.map(...) + * Multiple pipes chained together lend themselves more towards the last layout. + *) + if ParsetreeViewer.isSinglePipeExpr vb.pvb_expr then + Doc.customLayout + [ + Doc.group + (Doc.concat + [ + attrs; + header; + patternDoc; + Doc.text " ="; + Doc.space; + printedExpr; + ]); + Doc.group + (Doc.concat + [ + attrs; + header; + patternDoc; + Doc.text " ="; + Doc.indent (Doc.concat [ Doc.line; printedExpr ]); + ]); + ] + else + let shouldIndent = + match optBraces with + | Some _ -> false + | _ -> ( + ParsetreeViewer.isBinaryExpression expr + || + match vb.pvb_expr with + | { + pexp_attributes = [ ({ Location.txt = "ns.ternary" }, _) ]; + pexp_desc = Pexp_ifthenelse (ifExpr, _, _); + } -> + ParsetreeViewer.isBinaryExpression ifExpr + || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes + | { pexp_desc = Pexp_newtype _ } -> false + | e -> + ParsetreeViewer.hasAttributes e.pexp_attributes + || ParsetreeViewer.isArrayAccess e) + in + Doc.group + (Doc.concat + [ + attrs; + header; + patternDoc; + Doc.text " ="; + (if shouldIndent then + Doc.indent (Doc.concat [ Doc.line; printedExpr ]) + else Doc.concat [ Doc.space; printedExpr ]); + ]) and printPackageType ~customLayout ~printModuleKeywordAndParens (packageType : Parsetree.package_type) cmtTbl = let doc = match packageType with | longidentLoc, [] -> - Doc.group (Doc.concat [printLongidentLocation longidentLoc cmtTbl]) + Doc.group (Doc.concat [ printLongidentLocation longidentLoc cmtTbl ]) | longidentLoc, packageConstraints -> - Doc.group - (Doc.concat - [ - printLongidentLocation longidentLoc cmtTbl; - printPackageConstraints ~customLayout packageConstraints cmtTbl; - Doc.softLine; - ]) + Doc.group + (Doc.concat + [ + printLongidentLocation longidentLoc cmtTbl; + printPackageConstraints ~customLayout packageConstraints cmtTbl; + Doc.softLine; + ]) in if printModuleKeywordAndParens then - Doc.concat [Doc.text "module("; doc; Doc.rparen] + Doc.concat [ Doc.text "module("; doc; Doc.rparen ] else doc and printPackageConstraints ~customLayout packageConstraints cmtTbl = @@ -54961,7 +55122,7 @@ and printExtension ~customLayout ~atModuleLvl (stringLoc, payload) cmtTbl = in printComments doc cmtTbl stringLoc.Location.loc in - Doc.group (Doc.concat [extName; printPayload ~customLayout payload cmtTbl]) + Doc.group (Doc.concat [ extName; printPayload ~customLayout payload cmtTbl ]) and printPattern ~customLayout (p : Parsetree.pattern) cmtTbl = let patternWithoutAttributes = @@ -54969,376 +55130,404 @@ and printPattern ~customLayout (p : Parsetree.pattern) cmtTbl = | Ppat_any -> Doc.text "_" | Ppat_var var -> printIdentLike var.txt | Ppat_constant c -> - let templateLiteral = - ParsetreeViewer.hasTemplateLiteralAttr p.ppat_attributes - in - printConstant ~templateLiteral c + let templateLiteral = + ParsetreeViewer.hasTemplateLiteralAttr p.ppat_attributes + in + printConstant ~templateLiteral c | Ppat_tuple patterns -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) - patterns); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) | Ppat_array [] -> - Doc.concat - [Doc.lbracket; printCommentsInside cmtTbl p.ppat_loc; Doc.rbracket] + Doc.concat + [ Doc.lbracket; printCommentsInside cmtTbl p.ppat_loc; Doc.rbracket ] | Ppat_array patterns -> - Doc.group - (Doc.concat - [ - Doc.text "["; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) - patterns); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.text "]"; - ]) - | Ppat_construct ({txt = Longident.Lident "()"}, _) -> - Doc.concat [Doc.lparen; printCommentsInside cmtTbl p.ppat_loc; Doc.rparen] - | Ppat_construct ({txt = Longident.Lident "[]"}, _) -> - Doc.concat - [Doc.text "list{"; printCommentsInside cmtTbl p.ppat_loc; Doc.rbrace] - | Ppat_construct ({txt = Longident.Lident "::"}, _) -> - let patterns, tail = - ParsetreeViewer.collectPatternsFromListConstruct [] p - in - let shouldHug = - match (patterns, tail) with - | [pat], {ppat_desc = Ppat_construct ({txt = Longident.Lident "[]"}, _)} - when ParsetreeViewer.isHuggablePattern pat -> - true - | _ -> false - in - let children = + Doc.group + (Doc.concat + [ + Doc.text "["; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.text "]"; + ]) + | Ppat_construct ({ txt = Longident.Lident "()" }, _) -> + Doc.concat + [ Doc.lparen; printCommentsInside cmtTbl p.ppat_loc; Doc.rparen ] + | Ppat_construct ({ txt = Longident.Lident "[]" }, _) -> Doc.concat [ - (if shouldHug then Doc.nil else Doc.softLine); - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) - patterns); - (match tail.Parsetree.ppat_desc with - | Ppat_construct ({txt = Longident.Lident "[]"}, _) -> Doc.nil - | _ -> - let doc = - Doc.concat - [Doc.text "..."; printPattern ~customLayout tail cmtTbl] - in - let tail = printComments doc cmtTbl tail.ppat_loc in - Doc.concat [Doc.text ","; Doc.line; tail]); + Doc.text "list{"; printCommentsInside cmtTbl p.ppat_loc; Doc.rbrace; ] - in - Doc.group - (Doc.concat - [ - Doc.text "list{"; - (if shouldHug then children - else - Doc.concat - [ - Doc.indent children; - Doc.ifBreaks (Doc.text ",") Doc.nil; - Doc.softLine; - ]); - Doc.rbrace; - ]) - | Ppat_construct (constrName, constructorArgs) -> - let constrName = printLongidentLocation constrName cmtTbl in - let argsDoc = - match constructorArgs with - | None -> Doc.nil - | Some - { - ppat_loc; - ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _); - } -> - Doc.concat - [Doc.lparen; printCommentsInside cmtTbl ppat_loc; Doc.rparen] - | Some {ppat_desc = Ppat_tuple []; ppat_loc = loc} -> - Doc.concat [Doc.lparen; printCommentsInside cmtTbl loc; Doc.rparen] - (* Some((1, 2) *) - | Some {ppat_desc = Ppat_tuple [({ppat_desc = Ppat_tuple _} as arg)]} -> - Doc.concat - [Doc.lparen; printPattern ~customLayout arg cmtTbl; Doc.rparen] - | Some {ppat_desc = Ppat_tuple patterns} -> + | Ppat_construct ({ txt = Longident.Lident "::" }, _) -> + let patterns, tail = + ParsetreeViewer.collectPatternsFromListConstruct [] p + in + let shouldHug = + match (patterns, tail) with + | ( [ pat ], + { + ppat_desc = Ppat_construct ({ txt = Longident.Lident "[]" }, _); + } ) + when ParsetreeViewer.isHuggablePattern pat -> + true + | _ -> false + in + let children = Doc.concat [ - Doc.lparen; - Doc.indent - (Doc.concat + (if shouldHug then Doc.nil else Doc.softLine); + Doc.join + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); + (match tail.Parsetree.ppat_desc with + | Ppat_construct ({ txt = Longident.Lident "[]" }, _) -> Doc.nil + | _ -> + let doc = + Doc.concat + [ Doc.text "..."; printPattern ~customLayout tail cmtTbl ] + in + let tail = printComments doc cmtTbl tail.ppat_loc in + Doc.concat [ Doc.text ","; Doc.line; tail ]); + ] + in + Doc.group + (Doc.concat + [ + Doc.text "list{"; + (if shouldHug then children + else + Doc.concat [ + Doc.indent children; + Doc.ifBreaks (Doc.text ",") Doc.nil; Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) - patterns); ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some arg -> - let argDoc = printPattern ~customLayout arg cmtTbl in - let shouldHug = ParsetreeViewer.isHuggablePattern arg in - Doc.concat - [ - Doc.lparen; - (if shouldHug then argDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [Doc.softLine; argDoc]); - Doc.trailingComma; - Doc.softLine; - ]); - Doc.rparen; - ] - in - Doc.group (Doc.concat [constrName; argsDoc]) + Doc.rbrace; + ]) + | Ppat_construct (constrName, constructorArgs) -> + let constrName = printLongidentLocation constrName cmtTbl in + let argsDoc = + match constructorArgs with + | None -> Doc.nil + | Some + { + ppat_loc; + ppat_desc = Ppat_construct ({ txt = Longident.Lident "()" }, _); + } -> + Doc.concat + [ Doc.lparen; printCommentsInside cmtTbl ppat_loc; Doc.rparen ] + | Some { ppat_desc = Ppat_tuple []; ppat_loc = loc } -> + Doc.concat + [ Doc.lparen; printCommentsInside cmtTbl loc; Doc.rparen ] + (* Some((1, 2) *) + | Some + { + ppat_desc = Ppat_tuple [ ({ ppat_desc = Ppat_tuple _ } as arg) ]; + } -> + Doc.concat + [ + Doc.lparen; printPattern ~customLayout arg cmtTbl; Doc.rparen; + ] + | Some { ppat_desc = Ppat_tuple patterns } -> + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + | Some arg -> + let argDoc = printPattern ~customLayout arg cmtTbl in + let shouldHug = ParsetreeViewer.isHuggablePattern arg in + Doc.concat + [ + Doc.lparen; + (if shouldHug then argDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [ Doc.softLine; argDoc ]); + Doc.trailingComma; + Doc.softLine; + ]); + Doc.rparen; + ] + in + Doc.group (Doc.concat [ constrName; argsDoc ]) | Ppat_variant (label, None) -> - Doc.concat [Doc.text "#"; printPolyVarIdent label] + Doc.concat [ Doc.text "#"; printPolyVarIdent label ] | Ppat_variant (label, variantArgs) -> - let variantName = Doc.concat [Doc.text "#"; printPolyVarIdent label] in - let argsDoc = - match variantArgs with - | None -> Doc.nil - | Some {ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _)} - -> - Doc.text "()" - | Some {ppat_desc = Ppat_tuple []; ppat_loc = loc} -> - Doc.concat [Doc.lparen; printCommentsInside cmtTbl loc; Doc.rparen] - (* Some((1, 2) *) - | Some {ppat_desc = Ppat_tuple [({ppat_desc = Ppat_tuple _} as arg)]} -> - Doc.concat - [Doc.lparen; printPattern ~customLayout arg cmtTbl; Doc.rparen] - | Some {ppat_desc = Ppat_tuple patterns} -> - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) - patterns); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some arg -> - let argDoc = printPattern ~customLayout arg cmtTbl in - let shouldHug = ParsetreeViewer.isHuggablePattern arg in - Doc.concat - [ - Doc.lparen; - (if shouldHug then argDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [Doc.softLine; argDoc]); - Doc.trailingComma; - Doc.softLine; - ]); - Doc.rparen; - ] - in - Doc.group (Doc.concat [variantName; argsDoc]) + let variantName = + Doc.concat [ Doc.text "#"; printPolyVarIdent label ] + in + let argsDoc = + match variantArgs with + | None -> Doc.nil + | Some + { + ppat_desc = Ppat_construct ({ txt = Longident.Lident "()" }, _); + } -> + Doc.text "()" + | Some { ppat_desc = Ppat_tuple []; ppat_loc = loc } -> + Doc.concat + [ Doc.lparen; printCommentsInside cmtTbl loc; Doc.rparen ] + (* Some((1, 2) *) + | Some + { + ppat_desc = Ppat_tuple [ ({ ppat_desc = Ppat_tuple _ } as arg) ]; + } -> + Doc.concat + [ + Doc.lparen; printPattern ~customLayout arg cmtTbl; Doc.rparen; + ] + | Some { ppat_desc = Ppat_tuple patterns } -> + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + | Some arg -> + let argDoc = printPattern ~customLayout arg cmtTbl in + let shouldHug = ParsetreeViewer.isHuggablePattern arg in + Doc.concat + [ + Doc.lparen; + (if shouldHug then argDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [ Doc.softLine; argDoc ]); + Doc.trailingComma; + Doc.softLine; + ]); + Doc.rparen; + ] + in + Doc.group (Doc.concat [ variantName; argsDoc ]) | Ppat_type ident -> - Doc.concat [Doc.text "#..."; printIdentPath ident cmtTbl] + Doc.concat [ Doc.text "#..."; printIdentPath ident cmtTbl ] | Ppat_record (rows, openFlag) -> - Doc.group - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun row -> - printPatternRecordRow ~customLayout row cmtTbl) - rows); - (match openFlag with - | Open -> Doc.concat [Doc.text ","; Doc.line; Doc.text "_"] - | Closed -> Doc.nil); - ]); - Doc.ifBreaks (Doc.text ",") Doc.nil; - Doc.softLine; - Doc.rbrace; - ]) + Doc.group + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) + (List.map + (fun row -> + printPatternRecordRow ~customLayout row cmtTbl) + rows); + (match openFlag with + | Open -> + Doc.concat [ Doc.text ","; Doc.line; Doc.text "_" ] + | Closed -> Doc.nil); + ]); + Doc.ifBreaks (Doc.text ",") Doc.nil; + Doc.softLine; + Doc.rbrace; + ]) | Ppat_exception p -> - let needsParens = - match p.ppat_desc with - | Ppat_or (_, _) | Ppat_alias (_, _) -> true - | _ -> false - in - let pat = - let p = printPattern ~customLayout p cmtTbl in - if needsParens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p - in - Doc.group (Doc.concat [Doc.text "exception"; Doc.line; pat]) + let needsParens = + match p.ppat_desc with + | Ppat_or (_, _) | Ppat_alias (_, _) -> true + | _ -> false + in + let pat = + let p = printPattern ~customLayout p cmtTbl in + if needsParens then Doc.concat [ Doc.text "("; p; Doc.text ")" ] + else p + in + Doc.group (Doc.concat [ Doc.text "exception"; Doc.line; pat ]) | Ppat_or _ -> - (* Blue | Red | Green -> [Blue; Red; Green] *) - let orChain = ParsetreeViewer.collectOrPatternChain p in - let docs = - List.mapi - (fun i pat -> - let patternDoc = printPattern ~customLayout pat cmtTbl in - Doc.concat - [ - (if i == 0 then Doc.nil - else Doc.concat [Doc.line; Doc.text "| "]); - (match pat.ppat_desc with - (* (Blue | Red) | (Green | Black) | White *) - | Ppat_or _ -> addParens patternDoc - | _ -> patternDoc); - ]) - orChain - in - let isSpreadOverMultipleLines = - match (orChain, List.rev orChain) with - | first :: _, last :: _ -> - first.ppat_loc.loc_start.pos_lnum < last.ppat_loc.loc_end.pos_lnum - | _ -> false - in - Doc.breakableGroup ~forceBreak:isSpreadOverMultipleLines (Doc.concat docs) + (* Blue | Red | Green -> [Blue; Red; Green] *) + let orChain = ParsetreeViewer.collectOrPatternChain p in + let docs = + List.mapi + (fun i pat -> + let patternDoc = printPattern ~customLayout pat cmtTbl in + Doc.concat + [ + (if i == 0 then Doc.nil + else Doc.concat [ Doc.line; Doc.text "| " ]); + (match pat.ppat_desc with + (* (Blue | Red) | (Green | Black) | White *) + | Ppat_or _ -> addParens patternDoc + | _ -> patternDoc); + ]) + orChain + in + let isSpreadOverMultipleLines = + match (orChain, List.rev orChain) with + | first :: _, last :: _ -> + first.ppat_loc.loc_start.pos_lnum < last.ppat_loc.loc_end.pos_lnum + | _ -> false + in + Doc.breakableGroup ~forceBreak:isSpreadOverMultipleLines + (Doc.concat docs) | Ppat_extension ext -> - printExtension ~customLayout ~atModuleLvl:false ext cmtTbl + printExtension ~customLayout ~atModuleLvl:false ext cmtTbl | Ppat_lazy p -> - let needsParens = - match p.ppat_desc with - | Ppat_or (_, _) | Ppat_alias (_, _) -> true - | _ -> false - in - let pat = - let p = printPattern ~customLayout p cmtTbl in - if needsParens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p - in - Doc.concat [Doc.text "lazy "; pat] + let needsParens = + match p.ppat_desc with + | Ppat_or (_, _) | Ppat_alias (_, _) -> true + | _ -> false + in + let pat = + let p = printPattern ~customLayout p cmtTbl in + if needsParens then Doc.concat [ Doc.text "("; p; Doc.text ")" ] + else p + in + Doc.concat [ Doc.text "lazy "; pat ] | Ppat_alias (p, aliasLoc) -> - let needsParens = - match p.ppat_desc with - | Ppat_or (_, _) | Ppat_alias (_, _) -> true - | _ -> false - in - let renderedPattern = - let p = printPattern ~customLayout p cmtTbl in - if needsParens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p - in - Doc.concat - [renderedPattern; Doc.text " as "; printStringLoc aliasLoc cmtTbl] + let needsParens = + match p.ppat_desc with + | Ppat_or (_, _) | Ppat_alias (_, _) -> true + | _ -> false + in + let renderedPattern = + let p = printPattern ~customLayout p cmtTbl in + if needsParens then Doc.concat [ Doc.text "("; p; Doc.text ")" ] + else p + in + Doc.concat + [ renderedPattern; Doc.text " as "; printStringLoc aliasLoc cmtTbl ] (* Note: module(P : S) is represented as *) (* Ppat_constraint(Ppat_unpack, Ptyp_package) *) | Ppat_constraint - ( {ppat_desc = Ppat_unpack stringLoc}, - {ptyp_desc = Ptyp_package packageType; ptyp_loc} ) -> - Doc.concat - [ - Doc.text "module("; - printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; - Doc.text ": "; - printComments - (printPackageType ~customLayout ~printModuleKeywordAndParens:false - packageType cmtTbl) - cmtTbl ptyp_loc; - Doc.rparen; - ] + ( { ppat_desc = Ppat_unpack stringLoc }, + { ptyp_desc = Ptyp_package packageType; ptyp_loc } ) -> + Doc.concat + [ + Doc.text "module("; + printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; + Doc.text ": "; + printComments + (printPackageType ~customLayout ~printModuleKeywordAndParens:false + packageType cmtTbl) + cmtTbl ptyp_loc; + Doc.rparen; + ] | Ppat_constraint (pattern, typ) -> - Doc.concat - [ - printPattern ~customLayout pattern cmtTbl; - Doc.text ": "; - printTypExpr ~customLayout typ cmtTbl; - ] + Doc.concat + [ + printPattern ~customLayout pattern cmtTbl; + Doc.text ": "; + printTypExpr ~customLayout typ cmtTbl; + ] (* Note: module(P : S) is represented as *) (* Ppat_constraint(Ppat_unpack, Ptyp_package) *) | Ppat_unpack stringLoc -> - Doc.concat - [ - Doc.text "module("; - printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; - Doc.rparen; - ] + Doc.concat + [ + Doc.text "module("; + printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; + Doc.rparen; + ] | Ppat_interval (a, b) -> - Doc.concat [printConstant a; Doc.text " .. "; printConstant b] + Doc.concat [ printConstant a; Doc.text " .. "; printConstant b ] | Ppat_open _ -> Doc.nil in let doc = match p.ppat_attributes with | [] -> patternWithoutAttributes | attrs -> - Doc.group - (Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; patternWithoutAttributes; - ]) + Doc.group + (Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + patternWithoutAttributes; + ]) in printComments doc cmtTbl p.ppat_loc and printPatternRecordRow ~customLayout row cmtTbl = match row with (* punned {x}*) - | ( ({Location.txt = Longident.Lident ident} as longident), - {Parsetree.ppat_desc = Ppat_var {txt; _}; ppat_attributes} ) + | ( ({ Location.txt = Longident.Lident ident } as longident), + { Parsetree.ppat_desc = Ppat_var { txt; _ }; ppat_attributes } ) when ident = txt -> - Doc.concat - [ - printOptionalLabel ppat_attributes; - printAttributes ~customLayout ppat_attributes cmtTbl; - printLidentPath longident cmtTbl; - ] + Doc.concat + [ + printOptionalLabel ppat_attributes; + printAttributes ~customLayout ppat_attributes cmtTbl; + printLidentPath longident cmtTbl; + ] | longident, pattern -> - let locForComments = - {longident.loc with loc_end = pattern.Parsetree.ppat_loc.loc_end} - in - let rhsDoc = - let doc = printPattern ~customLayout pattern cmtTbl in + let locForComments = + { longident.loc with loc_end = pattern.Parsetree.ppat_loc.loc_end } + in + let rhsDoc = + let doc = printPattern ~customLayout pattern cmtTbl in + let doc = + if Parens.patternRecordRowRhs pattern then addParens doc else doc + in + Doc.concat [ printOptionalLabel pattern.ppat_attributes; doc ] + in let doc = - if Parens.patternRecordRowRhs pattern then addParens doc else doc + Doc.group + (Doc.concat + [ + printLidentPath longident cmtTbl; + Doc.text ":"; + (if ParsetreeViewer.isHuggablePattern pattern then + Doc.concat [ Doc.space; rhsDoc ] + else Doc.indent (Doc.concat [ Doc.line; rhsDoc ])); + ]) in - Doc.concat [printOptionalLabel pattern.ppat_attributes; doc] - in - let doc = - Doc.group - (Doc.concat - [ - printLidentPath longident cmtTbl; - Doc.text ":"; - (if ParsetreeViewer.isHuggablePattern pattern then - Doc.concat [Doc.space; rhsDoc] - else Doc.indent (Doc.concat [Doc.line; rhsDoc])); - ]) - in - printComments doc cmtTbl locForComments + printComments doc cmtTbl locForComments and printExpressionWithComments ~customLayout expr cmtTbl : Doc.t = let doc = printExpression ~customLayout expr cmtTbl in @@ -55353,54 +55542,55 @@ and printIfChain ~customLayout pexp_attributes ifs elseExpr cmtTbl = let doc = match ifExpr with | ParsetreeViewer.If ifExpr -> - let condition = - if ParsetreeViewer.isBlockExpr ifExpr then - printExpressionBlock ~customLayout ~braces:true ifExpr cmtTbl - else + let condition = + if ParsetreeViewer.isBlockExpr ifExpr then + printExpressionBlock ~customLayout ~braces:true ifExpr + cmtTbl + else + let doc = + printExpressionWithComments ~customLayout ifExpr cmtTbl + in + match Parens.expr ifExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc ifExpr braces + | Nothing -> Doc.ifBreaks (addParens doc) doc + in + Doc.concat + [ + ifTxt; + Doc.group condition; + Doc.space; + (let thenExpr = + match ParsetreeViewer.processBracesAttr thenExpr with + (* This case only happens when coming from Reason, we strip braces *) + | Some _, expr -> expr + | _ -> thenExpr + in + printExpressionBlock ~customLayout ~braces:true thenExpr + cmtTbl); + ] + | IfLet (pattern, conditionExpr) -> + let conditionDoc = let doc = - printExpressionWithComments ~customLayout ifExpr cmtTbl + printExpressionWithComments ~customLayout conditionExpr + cmtTbl in - match Parens.expr ifExpr with + match Parens.expr conditionExpr with | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc ifExpr braces - | Nothing -> Doc.ifBreaks (addParens doc) doc - in - Doc.concat - [ - ifTxt; - Doc.group condition; - Doc.space; - (let thenExpr = - match ParsetreeViewer.processBracesAttr thenExpr with - (* This case only happens when coming from Reason, we strip braces *) - | Some _, expr -> expr - | _ -> thenExpr - in - printExpressionBlock ~customLayout ~braces:true thenExpr - cmtTbl); - ] - | IfLet (pattern, conditionExpr) -> - let conditionDoc = - let doc = - printExpressionWithComments ~customLayout conditionExpr - cmtTbl + | Braced braces -> printBraces doc conditionExpr braces + | Nothing -> doc in - match Parens.expr conditionExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc conditionExpr braces - | Nothing -> doc - in - Doc.concat - [ - ifTxt; - Doc.text "let "; - printPattern ~customLayout pattern cmtTbl; - Doc.text " = "; - conditionDoc; - Doc.space; - printExpressionBlock ~customLayout ~braces:true thenExpr - cmtTbl; - ] + Doc.concat + [ + ifTxt; + Doc.text "let "; + printPattern ~customLayout pattern cmtTbl; + Doc.text " = "; + conditionDoc; + Doc.space; + printExpressionBlock ~customLayout ~braces:true thenExpr + cmtTbl; + ] in printLeadingComments doc cmtTbl.leading outerLoc) ifs) @@ -55409,707 +55599,736 @@ and printIfChain ~customLayout pexp_attributes ifs elseExpr cmtTbl = match elseExpr with | None -> Doc.nil | Some expr -> - Doc.concat - [ - Doc.text " else "; - printExpressionBlock ~customLayout ~braces:true expr cmtTbl; - ] + Doc.concat + [ + Doc.text " else "; + printExpressionBlock ~customLayout ~braces:true expr cmtTbl; + ] in let attrs = ParsetreeViewer.filterFragileMatchAttributes pexp_attributes in - Doc.concat [printAttributes ~customLayout attrs cmtTbl; ifDocs; elseDoc] + Doc.concat [ printAttributes ~customLayout attrs cmtTbl; ifDocs; elseDoc ] and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = let printedExpression = match e.pexp_desc with | Parsetree.Pexp_constant c -> - printConstant ~templateLiteral:(ParsetreeViewer.isTemplateLiteral e) c + printConstant ~templateLiteral:(ParsetreeViewer.isTemplateLiteral e) c | Pexp_construct _ when ParsetreeViewer.hasJsxAttribute e.pexp_attributes -> - printJsxFragment ~customLayout e cmtTbl - | Pexp_construct ({txt = Longident.Lident "()"}, _) -> Doc.text "()" - | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> - Doc.concat - [Doc.text "list{"; printCommentsInside cmtTbl e.pexp_loc; Doc.rbrace] - | Pexp_construct ({txt = Longident.Lident "::"}, _) -> - let expressions, spread = ParsetreeViewer.collectListExpressions e in - let spreadDoc = - match spread with - | Some expr -> - Doc.concat - [ - Doc.text ","; - Doc.line; - Doc.dotdotdot; - (let doc = - printExpressionWithComments ~customLayout expr cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); - ] - | None -> Doc.nil - in - Doc.group - (Doc.concat - [ - Doc.text "list{"; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun expr -> - let doc = - printExpressionWithComments ~customLayout expr - cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - expressions); - spreadDoc; - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ]) + printJsxFragment ~customLayout e cmtTbl + | Pexp_construct ({ txt = Longident.Lident "()" }, _) -> Doc.text "()" + | Pexp_construct ({ txt = Longident.Lident "[]" }, _) -> + Doc.concat + [ + Doc.text "list{"; printCommentsInside cmtTbl e.pexp_loc; Doc.rbrace; + ] + | Pexp_construct ({ txt = Longident.Lident "::" }, _) -> + let expressions, spread = ParsetreeViewer.collectListExpressions e in + let spreadDoc = + match spread with + | Some expr -> + Doc.concat + [ + Doc.text ","; + Doc.line; + Doc.dotdotdot; + (let doc = + printExpressionWithComments ~customLayout expr cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + ] + | None -> Doc.nil + in + Doc.group + (Doc.concat + [ + Doc.text "list{"; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) + (List.map + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + expressions); + spreadDoc; + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ]) | Pexp_construct (longidentLoc, args) -> - let constr = printLongidentLocation longidentLoc cmtTbl in - let args = - match args with - | None -> Doc.nil - | Some {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)} - -> - Doc.text "()" - (* Some((1, 2)) *) - | Some {pexp_desc = Pexp_tuple [({pexp_desc = Pexp_tuple _} as arg)]} -> - Doc.concat - [ - Doc.lparen; - (let doc = printExpressionWithComments ~customLayout arg cmtTbl in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc); - Doc.rparen; - ] - | Some {pexp_desc = Pexp_tuple args} -> - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun expr -> - let doc = - printExpressionWithComments ~customLayout expr - cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some arg -> - let argDoc = - let doc = printExpressionWithComments ~customLayout arg cmtTbl in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc - in - let shouldHug = ParsetreeViewer.isHuggableExpression arg in - Doc.concat - [ - Doc.lparen; - (if shouldHug then argDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [Doc.softLine; argDoc]); - Doc.trailingComma; - Doc.softLine; - ]); - Doc.rparen; - ] - in - Doc.group (Doc.concat [constr; args]) + let constr = printLongidentLocation longidentLoc cmtTbl in + let args = + match args with + | None -> Doc.nil + | Some + { + pexp_desc = Pexp_construct ({ txt = Longident.Lident "()" }, _); + } -> + Doc.text "()" + (* Some((1, 2)) *) + | Some + { + pexp_desc = Pexp_tuple [ ({ pexp_desc = Pexp_tuple _ } as arg) ]; + } -> + Doc.concat + [ + Doc.lparen; + (let doc = + printExpressionWithComments ~customLayout arg cmtTbl + in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc); + Doc.rparen; + ] + | Some { pexp_desc = Pexp_tuple args } -> + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + | Some arg -> + let argDoc = + let doc = + printExpressionWithComments ~customLayout arg cmtTbl + in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc + in + let shouldHug = ParsetreeViewer.isHuggableExpression arg in + Doc.concat + [ + Doc.lparen; + (if shouldHug then argDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [ Doc.softLine; argDoc ]); + Doc.trailingComma; + Doc.softLine; + ]); + Doc.rparen; + ] + in + Doc.group (Doc.concat [ constr; args ]) | Pexp_ident path -> printLidentPath path cmtTbl | Pexp_tuple exprs -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun expr -> - let doc = - printExpressionWithComments ~customLayout expr - cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - exprs); - ]); - Doc.ifBreaks (Doc.text ",") Doc.nil; - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) + (List.map + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + exprs); + ]); + Doc.ifBreaks (Doc.text ",") Doc.nil; + Doc.softLine; + Doc.rparen; + ]) | Pexp_array [] -> - Doc.concat - [Doc.lbracket; printCommentsInside cmtTbl e.pexp_loc; Doc.rbracket] - | Pexp_array exprs -> - Doc.group - (Doc.concat - [ - Doc.lbracket; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun expr -> - let doc = - printExpressionWithComments ~customLayout expr - cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - exprs); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbracket; - ]) - | Pexp_variant (label, args) -> - let variantName = Doc.concat [Doc.text "#"; printPolyVarIdent label] in - let args = - match args with - | None -> Doc.nil - | Some {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)} - -> - Doc.text "()" - (* #poly((1, 2) *) - | Some {pexp_desc = Pexp_tuple [({pexp_desc = Pexp_tuple _} as arg)]} -> - Doc.concat - [ - Doc.lparen; - (let doc = printExpressionWithComments ~customLayout arg cmtTbl in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc); - Doc.rparen; - ] - | Some {pexp_desc = Pexp_tuple args} -> - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun expr -> - let doc = - printExpressionWithComments ~customLayout expr - cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some arg -> - let argDoc = - let doc = printExpressionWithComments ~customLayout arg cmtTbl in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc - in - let shouldHug = ParsetreeViewer.isHuggableExpression arg in - Doc.concat - [ - Doc.lparen; - (if shouldHug then argDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [Doc.softLine; argDoc]); - Doc.trailingComma; - Doc.softLine; - ]); - Doc.rparen; - ] - in - Doc.group (Doc.concat [variantName; args]) - | Pexp_record (rows, spreadExpr) -> - if rows = [] then Doc.concat - [Doc.lbrace; printCommentsInside cmtTbl e.pexp_loc; Doc.rbrace] - else - let spread = - match spreadExpr with - | None -> Doc.nil - | Some expr -> - Doc.concat - [ - Doc.dotdotdot; - (let doc = - printExpressionWithComments ~customLayout expr cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); - Doc.comma; - Doc.line; - ] - in - (* If the record is written over multiple lines, break automatically - * `let x = {a: 1, b: 3}` -> same line, break when line-width exceeded - * `let x = { - * a: 1, - * b: 2, - * }` -> record is written on multiple lines, break the group *) - let forceBreak = - e.pexp_loc.loc_start.pos_lnum < e.pexp_loc.loc_end.pos_lnum - in - let punningAllowed = - match (spreadExpr, rows) with - | None, [_] -> false (* disallow punning for single-element records *) - | _ -> true - in - Doc.breakableGroup ~forceBreak + [ Doc.lbracket; printCommentsInside cmtTbl e.pexp_loc; Doc.rbracket ] + | Pexp_array exprs -> + Doc.group (Doc.concat [ - Doc.lbrace; + Doc.lbracket; Doc.indent (Doc.concat [ Doc.softLine; - spread; Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) (List.map - (fun row -> - printExpressionRecordRow ~customLayout row cmtTbl - punningAllowed) - rows); + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + exprs); ]); Doc.trailingComma; Doc.softLine; - Doc.rbrace; + Doc.rbracket; + ]) + | Pexp_variant (label, args) -> + let variantName = + Doc.concat [ Doc.text "#"; printPolyVarIdent label ] + in + let args = + match args with + | None -> Doc.nil + | Some + { + pexp_desc = Pexp_construct ({ txt = Longident.Lident "()" }, _); + } -> + Doc.text "()" + (* #poly((1, 2) *) + | Some + { + pexp_desc = Pexp_tuple [ ({ pexp_desc = Pexp_tuple _ } as arg) ]; + } -> + Doc.concat + [ + Doc.lparen; + (let doc = + printExpressionWithComments ~customLayout arg cmtTbl + in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc); + Doc.rparen; + ] + | Some { pexp_desc = Pexp_tuple args } -> + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + | Some arg -> + let argDoc = + let doc = + printExpressionWithComments ~customLayout arg cmtTbl + in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc + in + let shouldHug = ParsetreeViewer.isHuggableExpression arg in + Doc.concat + [ + Doc.lparen; + (if shouldHug then argDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [ Doc.softLine; argDoc ]); + Doc.trailingComma; + Doc.softLine; + ]); + Doc.rparen; + ] + in + Doc.group (Doc.concat [ variantName; args ]) + | Pexp_record (rows, spreadExpr) -> + if rows = [] then + Doc.concat + [ Doc.lbrace; printCommentsInside cmtTbl e.pexp_loc; Doc.rbrace ] + else + let spread = + match spreadExpr with + | None -> Doc.nil + | Some expr -> + Doc.concat + [ + Doc.dotdotdot; + (let doc = + printExpressionWithComments ~customLayout expr cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + Doc.comma; + Doc.line; + ] + in + (* If the record is written over multiple lines, break automatically + * `let x = {a: 1, b: 3}` -> same line, break when line-width exceeded + * `let x = { + * a: 1, + * b: 2, + * }` -> record is written on multiple lines, break the group *) + let forceBreak = + e.pexp_loc.loc_start.pos_lnum < e.pexp_loc.loc_end.pos_lnum + in + let punningAllowed = + match (spreadExpr, rows) with + | None, [ _ ] -> + false (* disallow punning for single-element records *) + | _ -> true + in + Doc.breakableGroup ~forceBreak + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.softLine; + spread; + Doc.join + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) + (List.map + (fun row -> + printExpressionRecordRow ~customLayout row cmtTbl + punningAllowed) + rows); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ]) + | Pexp_extension extension -> ( + match extension with + | ( { txt = "bs.obj" | "obj" }, + PStr + [ + { + pstr_loc = loc; + pstr_desc = + Pstr_eval ({ pexp_desc = Pexp_record (rows, _) }, []); + }; + ] ) -> + (* If the object is written over multiple lines, break automatically + * `let x = {"a": 1, "b": 3}` -> same line, break when line-width exceeded + * `let x = { + * "a": 1, + * "b": 2, + * }` -> object is written on multiple lines, break the group *) + let forceBreak = loc.loc_start.pos_lnum < loc.loc_end.pos_lnum in + Doc.breakableGroup ~forceBreak + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) + (List.map + (fun row -> + printBsObjectRow ~customLayout row cmtTbl) + rows); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ]) + | extension -> + printExtension ~customLayout ~atModuleLvl:false extension cmtTbl) + | Pexp_apply (e, [ (Nolabel, { pexp_desc = Pexp_array subLists }) ]) + when ParsetreeViewer.isSpreadBeltListConcat e -> + printBeltListConcatApply ~customLayout subLists cmtTbl + | Pexp_apply _ -> + if ParsetreeViewer.isUnaryExpression e then + printUnaryExpression ~customLayout e cmtTbl + else if ParsetreeViewer.isTemplateLiteral e then + printTemplateLiteral ~customLayout e cmtTbl + else if ParsetreeViewer.isBinaryExpression e then + printBinaryExpression ~customLayout e cmtTbl + else printPexpApply ~customLayout e cmtTbl + | Pexp_unreachable -> Doc.dot + | Pexp_field (expr, longidentLoc) -> + let lhs = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.fieldExpr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [ lhs; Doc.dot; printLidentPath longidentLoc cmtTbl ] + | Pexp_setfield (expr1, longidentLoc, expr2) -> + printSetFieldExpr ~customLayout e.pexp_attributes expr1 longidentLoc + expr2 e.pexp_loc cmtTbl + | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) + when ParsetreeViewer.isTernaryExpr e -> + let parts, alternate = ParsetreeViewer.collectTernaryParts e in + let ternaryDoc = + match parts with + | (condition1, consequent1) :: rest -> + Doc.group + (Doc.concat + [ + printTernaryOperand ~customLayout condition1 cmtTbl; + Doc.indent + (Doc.concat + [ + Doc.line; + Doc.indent + (Doc.concat + [ + Doc.text "? "; + printTernaryOperand ~customLayout consequent1 + cmtTbl; + ]); + Doc.concat + (List.map + (fun (condition, consequent) -> + Doc.concat + [ + Doc.line; + Doc.text ": "; + printTernaryOperand ~customLayout + condition cmtTbl; + Doc.line; + Doc.text "? "; + printTernaryOperand ~customLayout + consequent cmtTbl; + ]) + rest); + Doc.line; + Doc.text ": "; + Doc.indent + (printTernaryOperand ~customLayout alternate + cmtTbl); + ]); + ]) + | _ -> Doc.nil + in + let attrs = ParsetreeViewer.filterTernaryAttributes e.pexp_attributes in + let needsParens = + match ParsetreeViewer.filterParsingAttrs attrs with + | [] -> false + | _ -> true + in + Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + (if needsParens then addParens ternaryDoc else ternaryDoc); + ] + | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) -> + let ifs, elseExpr = ParsetreeViewer.collectIfExpressions e in + printIfChain ~customLayout e.pexp_attributes ifs elseExpr cmtTbl + | Pexp_while (expr1, expr2) -> + let condition = + let doc = printExpressionWithComments ~customLayout expr1 cmtTbl in + match Parens.expr expr1 with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr1 braces + | Nothing -> doc + in + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.text "while "; + (if ParsetreeViewer.isBlockExpr expr1 then condition + else Doc.group (Doc.ifBreaks (addParens condition) condition)); + Doc.space; + printExpressionBlock ~customLayout ~braces:true expr2 cmtTbl; + ]) + | Pexp_for (pattern, fromExpr, toExpr, directionFlag, body) -> + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.text "for "; + printPattern ~customLayout pattern cmtTbl; + Doc.text " in "; + (let doc = + printExpressionWithComments ~customLayout fromExpr cmtTbl + in + match Parens.expr fromExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc fromExpr braces + | Nothing -> doc); + printDirectionFlag directionFlag; + (let doc = + printExpressionWithComments ~customLayout toExpr cmtTbl + in + match Parens.expr toExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc toExpr braces + | Nothing -> doc); + Doc.space; + printExpressionBlock ~customLayout ~braces:true body cmtTbl; ]) - | Pexp_extension extension -> ( - match extension with - | ( {txt = "bs.obj" | "obj"}, - PStr - [ - { - pstr_loc = loc; - pstr_desc = Pstr_eval ({pexp_desc = Pexp_record (rows, _)}, []); - }; - ] ) -> - (* If the object is written over multiple lines, break automatically - * `let x = {"a": 1, "b": 3}` -> same line, break when line-width exceeded - * `let x = { - * "a": 1, - * "b": 2, - * }` -> object is written on multiple lines, break the group *) - let forceBreak = loc.loc_start.pos_lnum < loc.loc_end.pos_lnum in - Doc.breakableGroup ~forceBreak + | Pexp_constraint + ( { pexp_desc = Pexp_pack modExpr }, + { ptyp_desc = Ptyp_package packageType; ptyp_loc } ) -> + Doc.group (Doc.concat [ - Doc.lbrace; + Doc.text "module("; Doc.indent (Doc.concat [ Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun row -> - printBsObjectRow ~customLayout row cmtTbl) - rows); + printModExpr ~customLayout modExpr cmtTbl; + Doc.text ": "; + printComments + (printPackageType ~customLayout + ~printModuleKeywordAndParens:false packageType cmtTbl) + cmtTbl ptyp_loc; ]); - Doc.trailingComma; Doc.softLine; - Doc.rbrace; + Doc.rparen; ]) - | extension -> - printExtension ~customLayout ~atModuleLvl:false extension cmtTbl) - | Pexp_apply (e, [(Nolabel, {pexp_desc = Pexp_array subLists})]) - when ParsetreeViewer.isSpreadBeltListConcat e -> - printBeltListConcatApply ~customLayout subLists cmtTbl - | Pexp_apply _ -> - if ParsetreeViewer.isUnaryExpression e then - printUnaryExpression ~customLayout e cmtTbl - else if ParsetreeViewer.isTemplateLiteral e then - printTemplateLiteral ~customLayout e cmtTbl - else if ParsetreeViewer.isBinaryExpression e then - printBinaryExpression ~customLayout e cmtTbl - else printPexpApply ~customLayout e cmtTbl - | Pexp_unreachable -> Doc.dot - | Pexp_field (expr, longidentLoc) -> - let lhs = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.fieldExpr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat [lhs; Doc.dot; printLidentPath longidentLoc cmtTbl] - | Pexp_setfield (expr1, longidentLoc, expr2) -> - printSetFieldExpr ~customLayout e.pexp_attributes expr1 longidentLoc expr2 - e.pexp_loc cmtTbl - | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) - when ParsetreeViewer.isTernaryExpr e -> - let parts, alternate = ParsetreeViewer.collectTernaryParts e in - let ternaryDoc = - match parts with - | (condition1, consequent1) :: rest -> - Doc.group - (Doc.concat - [ - printTernaryOperand ~customLayout condition1 cmtTbl; - Doc.indent - (Doc.concat - [ - Doc.line; - Doc.indent - (Doc.concat - [ - Doc.text "? "; - printTernaryOperand ~customLayout consequent1 - cmtTbl; - ]); - Doc.concat - (List.map - (fun (condition, consequent) -> - Doc.concat - [ - Doc.line; - Doc.text ": "; - printTernaryOperand ~customLayout condition - cmtTbl; - Doc.line; - Doc.text "? "; - printTernaryOperand ~customLayout consequent - cmtTbl; - ]) - rest); - Doc.line; - Doc.text ": "; - Doc.indent - (printTernaryOperand ~customLayout alternate cmtTbl); - ]); - ]) - | _ -> Doc.nil - in - let attrs = ParsetreeViewer.filterTernaryAttributes e.pexp_attributes in - let needsParens = - match ParsetreeViewer.filterParsingAttrs attrs with - | [] -> false - | _ -> true - in - Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - (if needsParens then addParens ternaryDoc else ternaryDoc); - ] - | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) -> - let ifs, elseExpr = ParsetreeViewer.collectIfExpressions e in - printIfChain ~customLayout e.pexp_attributes ifs elseExpr cmtTbl - | Pexp_while (expr1, expr2) -> - let condition = - let doc = printExpressionWithComments ~customLayout expr1 cmtTbl in - match Parens.expr expr1 with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr1 braces - | Nothing -> doc - in - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.text "while "; - (if ParsetreeViewer.isBlockExpr expr1 then condition - else Doc.group (Doc.ifBreaks (addParens condition) condition)); - Doc.space; - printExpressionBlock ~customLayout ~braces:true expr2 cmtTbl; - ]) - | Pexp_for (pattern, fromExpr, toExpr, directionFlag, body) -> - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.text "for "; - printPattern ~customLayout pattern cmtTbl; - Doc.text " in "; - (let doc = - printExpressionWithComments ~customLayout fromExpr cmtTbl - in - match Parens.expr fromExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc fromExpr braces - | Nothing -> doc); - printDirectionFlag directionFlag; - (let doc = - printExpressionWithComments ~customLayout toExpr cmtTbl - in - match Parens.expr toExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc toExpr braces - | Nothing -> doc); - Doc.space; - printExpressionBlock ~customLayout ~braces:true body cmtTbl; - ]) - | Pexp_constraint - ( {pexp_desc = Pexp_pack modExpr}, - {ptyp_desc = Ptyp_package packageType; ptyp_loc} ) -> - Doc.group - (Doc.concat - [ - Doc.text "module("; - Doc.indent - (Doc.concat - [ - Doc.softLine; - printModExpr ~customLayout modExpr cmtTbl; - Doc.text ": "; - printComments - (printPackageType ~customLayout - ~printModuleKeywordAndParens:false packageType cmtTbl) - cmtTbl ptyp_loc; - ]); - Doc.softLine; - Doc.rparen; - ]) | Pexp_constraint (expr, typ) -> - let exprDoc = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat [exprDoc; Doc.text ": "; printTypExpr ~customLayout typ cmtTbl] - | Pexp_letmodule ({txt = _modName}, _modExpr, _expr) -> - printExpressionBlock ~customLayout ~braces:true e cmtTbl + let exprDoc = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat + [ exprDoc; Doc.text ": "; printTypExpr ~customLayout typ cmtTbl ] + | Pexp_letmodule ({ txt = _modName }, _modExpr, _expr) -> + printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_letexception (_extensionConstructor, _expr) -> - printExpressionBlock ~customLayout ~braces:true e cmtTbl + printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_assert expr -> - let rhs = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.lazyOrAssertOrAwaitExprRhs expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat [Doc.text "assert "; rhs] + let rhs = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.lazyOrAssertOrAwaitExprRhs expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [ Doc.text "assert "; rhs ] | Pexp_lazy expr -> - let rhs = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.lazyOrAssertOrAwaitExprRhs expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.group (Doc.concat [Doc.text "lazy "; rhs]) + let rhs = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.lazyOrAssertOrAwaitExprRhs expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.group (Doc.concat [ Doc.text "lazy "; rhs ]) | Pexp_open (_overrideFlag, _longidentLoc, _expr) -> - printExpressionBlock ~customLayout ~braces:true e cmtTbl + printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_pack modExpr -> - Doc.group - (Doc.concat - [ - Doc.text "module("; - Doc.indent - (Doc.concat - [Doc.softLine; printModExpr ~customLayout modExpr cmtTbl]); - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + Doc.text "module("; + Doc.indent + (Doc.concat + [ Doc.softLine; printModExpr ~customLayout modExpr cmtTbl ]); + Doc.softLine; + Doc.rparen; + ]) | Pexp_sequence _ -> - printExpressionBlock ~customLayout ~braces:true e cmtTbl + printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_let _ -> printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_fun ( Nolabel, None, - {ppat_desc = Ppat_var {txt = "__x"}}, - {pexp_desc = Pexp_apply _} ) -> - (* (__x) => f(a, __x, c) -----> f(a, _, c) *) - printExpressionWithComments ~customLayout - (ParsetreeViewer.rewriteUnderscoreApply e) - cmtTbl + { ppat_desc = Ppat_var { txt = "__x" } }, + { pexp_desc = Pexp_apply _ } ) -> + (* (__x) => f(a, __x, c) -----> f(a, _, c) *) + printExpressionWithComments ~customLayout + (ParsetreeViewer.rewriteUnderscoreApply e) + cmtTbl | Pexp_fun _ | Pexp_newtype _ -> - let attrsOnArrow, parameters, returnExpr = ParsetreeViewer.funExpr e in - let ParsetreeViewer.{async; uncurried; attributes = attrs} = - ParsetreeViewer.processFunctionAttributes attrsOnArrow - in - let returnExpr, typConstraint = - match returnExpr.pexp_desc with - | Pexp_constraint (expr, typ) -> - ( { - expr with - pexp_attributes = - List.concat [expr.pexp_attributes; returnExpr.pexp_attributes]; - }, - Some typ ) - | _ -> (returnExpr, None) - in - let hasConstraint = - match typConstraint with - | Some _ -> true - | None -> false - in - let parametersDoc = - printExprFunParameters ~customLayout ~inCallback:NoCallback ~uncurried - ~async ~hasConstraint parameters cmtTbl - in - let returnExprDoc = - let optBraces, _ = ParsetreeViewer.processBracesAttr returnExpr in - let shouldInline = - match (returnExpr.pexp_desc, optBraces) with - | _, Some _ -> true - | ( ( Pexp_array _ | Pexp_tuple _ - | Pexp_construct (_, Some _) - | Pexp_record _ ), - _ ) -> - true - | _ -> false + let attrsOnArrow, parameters, returnExpr = ParsetreeViewer.funExpr e in + let ParsetreeViewer.{ async; uncurried; attributes = attrs } = + ParsetreeViewer.processFunctionAttributes attrsOnArrow in - let shouldIndent = + let returnExpr, typConstraint = match returnExpr.pexp_desc with - | Pexp_sequence _ | Pexp_let _ | Pexp_letmodule _ - | Pexp_letexception _ | Pexp_open _ -> - false - | _ -> true + | Pexp_constraint (expr, typ) -> + ( { + expr with + pexp_attributes = + List.concat + [ expr.pexp_attributes; returnExpr.pexp_attributes ]; + }, + Some typ ) + | _ -> (returnExpr, None) in - let returnDoc = - let doc = - printExpressionWithComments ~customLayout returnExpr cmtTbl + let hasConstraint = + match typConstraint with Some _ -> true | None -> false + in + let parametersDoc = + printExprFunParameters ~customLayout ~inCallback:NoCallback ~uncurried + ~async ~hasConstraint parameters cmtTbl + in + let returnExprDoc = + let optBraces, _ = ParsetreeViewer.processBracesAttr returnExpr in + let shouldInline = + match (returnExpr.pexp_desc, optBraces) with + | _, Some _ -> true + | ( ( Pexp_array _ | Pexp_tuple _ + | Pexp_construct (_, Some _) + | Pexp_record _ ), + _ ) -> + true + | _ -> false + in + let shouldIndent = + match returnExpr.pexp_desc with + | Pexp_sequence _ | Pexp_let _ | Pexp_letmodule _ + | Pexp_letexception _ | Pexp_open _ -> + false + | _ -> true + in + let returnDoc = + let doc = + printExpressionWithComments ~customLayout returnExpr cmtTbl + in + match Parens.expr returnExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc returnExpr braces + | Nothing -> doc in - match Parens.expr returnExpr with + if shouldInline then Doc.concat [ Doc.space; returnDoc ] + else + Doc.group + (if shouldIndent then + Doc.indent (Doc.concat [ Doc.line; returnDoc ]) + else Doc.concat [ Doc.space; returnDoc ]) + in + let typConstraintDoc = + match typConstraint with + | Some typ -> + let typDoc = + let doc = printTypExpr ~customLayout typ cmtTbl in + if Parens.arrowReturnTypExpr typ then addParens doc else doc + in + Doc.concat [ Doc.text ": "; typDoc ] + | _ -> Doc.nil + in + let attrs = printAttributes ~customLayout attrs cmtTbl in + Doc.group + (Doc.concat + [ + attrs; + parametersDoc; + typConstraintDoc; + Doc.text " =>"; + returnExprDoc; + ]) + | Pexp_try (expr, cases) -> + let exprDoc = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc returnExpr braces + | Braced braces -> printBraces doc expr braces | Nothing -> doc in - if shouldInline then Doc.concat [Doc.space; returnDoc] - else - Doc.group - (if shouldIndent then Doc.indent (Doc.concat [Doc.line; returnDoc]) - else Doc.concat [Doc.space; returnDoc]) - in - let typConstraintDoc = - match typConstraint with - | Some typ -> - let typDoc = - let doc = printTypExpr ~customLayout typ cmtTbl in - if Parens.arrowReturnTypExpr typ then addParens doc else doc - in - Doc.concat [Doc.text ": "; typDoc] - | _ -> Doc.nil - in - let attrs = printAttributes ~customLayout attrs cmtTbl in - Doc.group - (Doc.concat - [ - attrs; - parametersDoc; - typConstraintDoc; - Doc.text " =>"; - returnExprDoc; - ]) - | Pexp_try (expr, cases) -> - let exprDoc = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat - [ - Doc.text "try "; - exprDoc; - Doc.text " catch "; - printCases ~customLayout cases cmtTbl; - ] - | Pexp_match (_, [_; _]) when ParsetreeViewer.isIfLetExpr e -> - let ifs, elseExpr = ParsetreeViewer.collectIfExpressions e in - printIfChain ~customLayout e.pexp_attributes ifs elseExpr cmtTbl + Doc.concat + [ + Doc.text "try "; + exprDoc; + Doc.text " catch "; + printCases ~customLayout cases cmtTbl; + ] + | Pexp_match (_, [ _; _ ]) when ParsetreeViewer.isIfLetExpr e -> + let ifs, elseExpr = ParsetreeViewer.collectIfExpressions e in + printIfChain ~customLayout e.pexp_attributes ifs elseExpr cmtTbl | Pexp_match (expr, cases) -> - let exprDoc = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat - [ - Doc.text "switch "; - exprDoc; - Doc.space; - printCases ~customLayout cases cmtTbl; - ] + let exprDoc = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat + [ + Doc.text "switch "; + exprDoc; + Doc.space; + printCases ~customLayout cases cmtTbl; + ] | Pexp_function cases -> - Doc.concat - [Doc.text "x => switch x "; printCases ~customLayout cases cmtTbl] + Doc.concat + [ Doc.text "x => switch x "; printCases ~customLayout cases cmtTbl ] | Pexp_coerce (expr, typOpt, typ) -> - let docExpr = printExpressionWithComments ~customLayout expr cmtTbl in - let docTyp = printTypExpr ~customLayout typ cmtTbl in - let ofType = - match typOpt with - | None -> Doc.nil - | Some typ1 -> - Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ1 cmtTbl] - in - Doc.concat - [Doc.lparen; docExpr; ofType; Doc.text " :> "; docTyp; Doc.rparen] + let docExpr = printExpressionWithComments ~customLayout expr cmtTbl in + let docTyp = printTypExpr ~customLayout typ cmtTbl in + let ofType = + match typOpt with + | None -> Doc.nil + | Some typ1 -> + Doc.concat + [ Doc.text ": "; printTypExpr ~customLayout typ1 cmtTbl ] + in + Doc.concat + [ Doc.lparen; docExpr; ofType; Doc.text " :> "; docTyp; Doc.rparen ] | Pexp_send (parentExpr, label) -> - let parentDoc = - let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces - | Nothing -> doc - in - let member = - let memberDoc = printComments (Doc.text label.txt) cmtTbl label.loc in - Doc.concat [Doc.text "\""; memberDoc; Doc.text "\""] - in - Doc.group (Doc.concat [parentDoc; Doc.lbracket; member; Doc.rbracket]) + let parentDoc = + let doc = + printExpressionWithComments ~customLayout parentExpr cmtTbl + in + match Parens.unaryExprOperand parentExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc parentExpr braces + | Nothing -> doc + in + let member = + let memberDoc = printComments (Doc.text label.txt) cmtTbl label.loc in + Doc.concat [ Doc.text "\""; memberDoc; Doc.text "\"" ] + in + Doc.group (Doc.concat [ parentDoc; Doc.lbracket; member; Doc.rbracket ]) | Pexp_new _ -> Doc.text "Pexp_new not impemented in printer" | Pexp_setinstvar _ -> Doc.text "Pexp_setinstvar not impemented in printer" | Pexp_override _ -> Doc.text "Pexp_override not impemented in printer" @@ -56126,7 +56345,7 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = pexp_attributes = List.filter (function - | {Location.txt = "res.await" | "ns.braces"}, _ -> false + | { Location.txt = "res.await" | "ns.braces" }, _ -> false | _ -> true) e.pexp_attributes; } @@ -56135,55 +56354,53 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = | Braced braces -> printBraces printedExpression e braces | Nothing -> printedExpression in - Doc.concat [Doc.text "await "; rhs] + Doc.concat [ Doc.text "await "; rhs ] else printedExpression in let shouldPrintItsOwnAttributes = match e.pexp_desc with | Pexp_apply _ | Pexp_fun _ | Pexp_newtype _ | Pexp_setfield _ | Pexp_ifthenelse _ -> - true + true | Pexp_match _ when ParsetreeViewer.isIfLetExpr e -> true | Pexp_construct _ when ParsetreeViewer.hasJsxAttribute e.pexp_attributes -> - true + true | _ -> false in match e.pexp_attributes with | [] -> exprWithAwait | attrs when not shouldPrintItsOwnAttributes -> - Doc.group - (Doc.concat [printAttributes ~customLayout attrs cmtTbl; exprWithAwait]) + Doc.group + (Doc.concat + [ printAttributes ~customLayout attrs cmtTbl; exprWithAwait ]) | _ -> exprWithAwait and printPexpFun ~customLayout ~inCallback e cmtTbl = let attrsOnArrow, parameters, returnExpr = ParsetreeViewer.funExpr e in - let ParsetreeViewer.{async; uncurried; attributes = attrs} = + let ParsetreeViewer.{ async; uncurried; attributes = attrs } = ParsetreeViewer.processFunctionAttributes attrsOnArrow in let returnExpr, typConstraint = match returnExpr.pexp_desc with | Pexp_constraint (expr, typ) -> - ( { - expr with - pexp_attributes = - List.concat [expr.pexp_attributes; returnExpr.pexp_attributes]; - }, - Some typ ) + ( { + expr with + pexp_attributes = + List.concat [ expr.pexp_attributes; returnExpr.pexp_attributes ]; + }, + Some typ ) | _ -> (returnExpr, None) in let parametersDoc = printExprFunParameters ~customLayout ~inCallback ~async ~uncurried - ~hasConstraint: - (match typConstraint with - | Some _ -> true - | None -> false) + ~hasConstraint:(match typConstraint with Some _ -> true | None -> false) parameters cmtTbl in let returnShouldIndent = match returnExpr.pexp_desc with | Pexp_sequence _ | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ -> - false + false | _ -> true in let returnExprDoc = @@ -56195,7 +56412,7 @@ and printPexpFun ~customLayout ~inCallback e cmtTbl = | Pexp_construct (_, Some _) | Pexp_record _ ), _ ) -> - true + true | _ -> false in let returnDoc = @@ -56205,23 +56422,23 @@ and printPexpFun ~customLayout ~inCallback e cmtTbl = | Braced braces -> printBraces doc returnExpr braces | Nothing -> doc in - if shouldInline then Doc.concat [Doc.space; returnDoc] + if shouldInline then Doc.concat [ Doc.space; returnDoc ] else Doc.group (if returnShouldIndent then Doc.concat [ - Doc.indent (Doc.concat [Doc.line; returnDoc]); + Doc.indent (Doc.concat [ Doc.line; returnDoc ]); (match inCallback with | FitsOnOneLine | ArgumentsFitOnOneLine -> Doc.softLine | _ -> Doc.nil); ] - else Doc.concat [Doc.space; returnDoc]) + else Doc.concat [ Doc.space; returnDoc ]) in let typConstraintDoc = match typConstraint with | Some typ -> - Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ cmtTbl] + Doc.concat [ Doc.text ": "; printTypExpr ~customLayout typ cmtTbl ] | _ -> Doc.nil in Doc.concat @@ -56265,15 +56482,16 @@ and printSetFieldExpr ~customLayout attrs lhs longidentLoc rhs loc cmtTbl = printLidentPath longidentLoc cmtTbl; Doc.text " ="; (if shouldIndent then - Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) - else Doc.concat [Doc.space; rhsDoc]); + Doc.group (Doc.indent (Doc.concat [ Doc.line; rhsDoc ])) + else Doc.concat [ Doc.space; rhsDoc ]); ]) in let doc = match attrs with | [] -> doc | attrs -> - Doc.group (Doc.concat [printAttributes ~customLayout attrs cmtTbl; doc]) + Doc.group + (Doc.concat [ printAttributes ~customLayout attrs cmtTbl; doc ]) in printComments doc cmtTbl loc @@ -56283,17 +56501,17 @@ and printTemplateLiteral ~customLayout expr cmtTbl = let open Parsetree in match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident "^"}}, - [(Nolabel, arg1); (Nolabel, arg2)] ) -> - let lhs = walkExpr arg1 in - let rhs = walkExpr arg2 in - Doc.concat [lhs; rhs] + ( { pexp_desc = Pexp_ident { txt = Longident.Lident "^" } }, + [ (Nolabel, arg1); (Nolabel, arg2) ] ) -> + let lhs = walkExpr arg1 in + let rhs = walkExpr arg2 in + Doc.concat [ lhs; rhs ] | Pexp_constant (Pconst_string (txt, Some prefix)) -> - tag := prefix; - printStringContents txt + tag := prefix; + printStringContents txt | _ -> - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - Doc.group (Doc.concat [Doc.text "${"; Doc.indent doc; Doc.rbrace]) + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + Doc.group (Doc.concat [ Doc.text "${"; Doc.indent doc; Doc.rbrace ]) in let content = walkExpr expr in Doc.concat @@ -56317,17 +56535,17 @@ and printUnaryExpression ~customLayout expr cmtTbl = in match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [(Nolabel, operand)] ) -> - let printedOperand = - let doc = printExpressionWithComments ~customLayout operand cmtTbl in - match Parens.unaryExprOperand operand with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc operand braces - | Nothing -> doc - in - let doc = Doc.concat [printUnaryOperator operator; printedOperand] in - printComments doc cmtTbl expr.pexp_loc + ( { pexp_desc = Pexp_ident { txt = Longident.Lident operator } }, + [ (Nolabel, operand) ] ) -> + let printedOperand = + let doc = printExpressionWithComments ~customLayout operand cmtTbl in + match Parens.unaryExprOperand operand with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc operand braces + | Nothing -> doc + in + let doc = Doc.concat [ printUnaryOperator operator; printedOperand ] in + printComments doc cmtTbl expr.pexp_loc | _ -> assert false and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = @@ -56354,7 +56572,7 @@ and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = else Doc.line in Doc.concat - [spacingBeforeOperator; Doc.text operatorTxt; spacingAfterOperator] + [ spacingBeforeOperator; Doc.text operatorTxt; spacingAfterOperator ] in let printOperand ~isLhs expr parentOperator = let rec flatten ~isLhs expr parentOperator = @@ -56363,230 +56581,232 @@ and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = | { pexp_desc = Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [(_, left); (_, right)] ); + ( { pexp_desc = Pexp_ident { txt = Longident.Lident operator } }, + [ (_, left); (_, right) ] ); } -> - if - ParsetreeViewer.flattenableOperators parentOperator operator - && not (ParsetreeViewer.hasAttributes expr.pexp_attributes) - then - let leftPrinted = flatten ~isLhs:true left operator in - let rightPrinted = - let rightPrinteableAttrs, rightInternalAttrs = + if + ParsetreeViewer.flattenableOperators parentOperator operator + && not (ParsetreeViewer.hasAttributes expr.pexp_attributes) + then + let leftPrinted = flatten ~isLhs:true left operator in + let rightPrinted = + let rightPrinteableAttrs, rightInternalAttrs = + ParsetreeViewer.partitionPrintableAttributes + right.pexp_attributes + in + let doc = + printExpressionWithComments ~customLayout + { right with pexp_attributes = rightInternalAttrs } + cmtTbl + in + let doc = + if Parens.flattenOperandRhs parentOperator right then + Doc.concat [ Doc.lparen; doc; Doc.rparen ] + else doc + in + let doc = + Doc.concat + [ + printAttributes ~customLayout rightPrinteableAttrs cmtTbl; + doc; + ] + in + match rightPrinteableAttrs with [] -> doc | _ -> addParens doc + in + let isAwait = + ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes + in + let doc = + if isAwait then + Doc.concat + [ + Doc.text "await "; + Doc.lparen; + leftPrinted; + printBinaryOperator ~inlineRhs:false operator; + rightPrinted; + Doc.rparen; + ] + else + Doc.concat + [ + leftPrinted; + printBinaryOperator ~inlineRhs:false operator; + rightPrinted; + ] + in + + let doc = + if (not isLhs) && Parens.rhsBinaryExprOperand operator expr then + Doc.concat [ Doc.lparen; doc; Doc.rparen ] + else doc + in + printComments doc cmtTbl expr.pexp_loc + else + let printeableAttrs, internalAttrs = ParsetreeViewer.partitionPrintableAttributes - right.pexp_attributes + expr.pexp_attributes in let doc = printExpressionWithComments ~customLayout - {right with pexp_attributes = rightInternalAttrs} + { expr with pexp_attributes = internalAttrs } cmtTbl in let doc = - if Parens.flattenOperandRhs parentOperator right then - Doc.concat [Doc.lparen; doc; Doc.rparen] + if + Parens.subBinaryExprOperand parentOperator operator + || printeableAttrs <> [] + && (ParsetreeViewer.isBinaryExpression expr + || ParsetreeViewer.isTernaryExpr expr) + then Doc.concat [ Doc.lparen; doc; Doc.rparen ] else doc in - let doc = - Doc.concat - [ - printAttributes ~customLayout rightPrinteableAttrs cmtTbl; - doc; - ] - in - match rightPrinteableAttrs with - | [] -> doc - | _ -> addParens doc - in - let isAwait = - ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes - in - let doc = - if isAwait then - Doc.concat - [ - Doc.text "await "; - Doc.lparen; - leftPrinted; - printBinaryOperator ~inlineRhs:false operator; - rightPrinted; - Doc.rparen; - ] - else - Doc.concat - [ - leftPrinted; - printBinaryOperator ~inlineRhs:false operator; - rightPrinted; - ] - in - - let doc = - if (not isLhs) && Parens.rhsBinaryExprOperand operator expr then - Doc.concat [Doc.lparen; doc; Doc.rparen] - else doc - in - printComments doc cmtTbl expr.pexp_loc - else - let printeableAttrs, internalAttrs = - ParsetreeViewer.partitionPrintableAttributes expr.pexp_attributes - in - let doc = - printExpressionWithComments ~customLayout - {expr with pexp_attributes = internalAttrs} - cmtTbl - in - let doc = - if - Parens.subBinaryExprOperand parentOperator operator - || printeableAttrs <> [] - && (ParsetreeViewer.isBinaryExpression expr - || ParsetreeViewer.isTernaryExpr expr) - then Doc.concat [Doc.lparen; doc; Doc.rparen] - else doc - in - Doc.concat - [printAttributes ~customLayout printeableAttrs cmtTbl; doc] + Doc.concat + [ printAttributes ~customLayout printeableAttrs cmtTbl; doc ] | _ -> assert false else match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident "^"; loc}}, - [(Nolabel, _); (Nolabel, _)] ) + ( { pexp_desc = Pexp_ident { txt = Longident.Lident "^"; loc } }, + [ (Nolabel, _); (Nolabel, _) ] ) when loc.loc_ghost -> - let doc = printTemplateLiteral ~customLayout expr cmtTbl in - printComments doc cmtTbl expr.Parsetree.pexp_loc + let doc = printTemplateLiteral ~customLayout expr cmtTbl in + printComments doc cmtTbl expr.Parsetree.pexp_loc | Pexp_setfield (lhs, field, rhs) -> - let doc = - printSetFieldExpr ~customLayout expr.pexp_attributes lhs field rhs - expr.pexp_loc cmtTbl - in - if isLhs then addParens doc else doc + let doc = + printSetFieldExpr ~customLayout expr.pexp_attributes lhs field rhs + expr.pexp_loc cmtTbl + in + if isLhs then addParens doc else doc | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}}, - [(Nolabel, lhs); (Nolabel, rhs)] ) -> - let rhsDoc = printExpressionWithComments ~customLayout rhs cmtTbl in - let lhsDoc = printExpressionWithComments ~customLayout lhs cmtTbl in - (* TODO: unify indentation of "=" *) - let shouldIndent = ParsetreeViewer.isBinaryExpression rhs in - let doc = - Doc.group - (Doc.concat - [ - lhsDoc; - Doc.text " ="; - (if shouldIndent then - Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) - else Doc.concat [Doc.space; rhsDoc]); - ]) - in - let doc = - match expr.pexp_attributes with - | [] -> doc - | attrs -> + ( { pexp_desc = Pexp_ident { txt = Longident.Lident "#=" } }, + [ (Nolabel, lhs); (Nolabel, rhs) ] ) -> + let rhsDoc = printExpressionWithComments ~customLayout rhs cmtTbl in + let lhsDoc = printExpressionWithComments ~customLayout lhs cmtTbl in + (* TODO: unify indentation of "=" *) + let shouldIndent = ParsetreeViewer.isBinaryExpression rhs in + let doc = Doc.group - (Doc.concat [printAttributes ~customLayout attrs cmtTbl; doc]) - in - if isLhs then addParens doc else doc + (Doc.concat + [ + lhsDoc; + Doc.text " ="; + (if shouldIndent then + Doc.group (Doc.indent (Doc.concat [ Doc.line; rhsDoc ])) + else Doc.concat [ Doc.space; rhsDoc ]); + ]) + in + let doc = + match expr.pexp_attributes with + | [] -> doc + | attrs -> + Doc.group + (Doc.concat + [ printAttributes ~customLayout attrs cmtTbl; doc ]) + in + if isLhs then addParens doc else doc | _ -> ( - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.binaryExprOperand ~isLhs expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.binaryExprOperand ~isLhs expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) in flatten ~isLhs expr parentOperator in match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident (("|." | "|>") as op)}}, - [(Nolabel, lhs); (Nolabel, rhs)] ) + ( { + pexp_desc = Pexp_ident { txt = Longident.Lident (("|." | "|>") as op) }; + }, + [ (Nolabel, lhs); (Nolabel, rhs) ] ) when not (ParsetreeViewer.isBinaryExpression lhs || ParsetreeViewer.isBinaryExpression rhs || printAttributes ~customLayout expr.pexp_attributes cmtTbl <> Doc.nil) -> - let lhsHasCommentBelow = hasCommentBelow cmtTbl lhs.pexp_loc in - let lhsDoc = printOperand ~isLhs:true lhs op in - let rhsDoc = printOperand ~isLhs:false rhs op in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - lhsDoc; - (match (lhsHasCommentBelow, op) with - | true, "|." -> Doc.concat [Doc.softLine; Doc.text "->"] - | false, "|." -> Doc.text "->" - | true, "|>" -> Doc.concat [Doc.line; Doc.text "|> "] - | false, "|>" -> Doc.text " |> " - | _ -> Doc.nil); - rhsDoc; - ]) + let lhsHasCommentBelow = hasCommentBelow cmtTbl lhs.pexp_loc in + let lhsDoc = printOperand ~isLhs:true lhs op in + let rhsDoc = printOperand ~isLhs:false rhs op in + Doc.group + (Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + lhsDoc; + (match (lhsHasCommentBelow, op) with + | true, "|." -> Doc.concat [ Doc.softLine; Doc.text "->" ] + | false, "|." -> Doc.text "->" + | true, "|>" -> Doc.concat [ Doc.line; Doc.text "|> " ] + | false, "|>" -> Doc.text " |> " + | _ -> Doc.nil); + rhsDoc; + ]) | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [(Nolabel, lhs); (Nolabel, rhs)] ) -> - let right = - let operatorWithRhs = - let rhsDoc = printOperand ~isLhs:false rhs operator in - Doc.concat - [ - printBinaryOperator - ~inlineRhs:(ParsetreeViewer.shouldInlineRhsBinaryExpr rhs) - operator; - rhsDoc; - ] + ( { pexp_desc = Pexp_ident { txt = Longident.Lident operator } }, + [ (Nolabel, lhs); (Nolabel, rhs) ] ) -> + let right = + let operatorWithRhs = + let rhsDoc = printOperand ~isLhs:false rhs operator in + Doc.concat + [ + printBinaryOperator + ~inlineRhs:(ParsetreeViewer.shouldInlineRhsBinaryExpr rhs) + operator; + rhsDoc; + ] + in + if ParsetreeViewer.shouldIndentBinaryExpr expr then + Doc.group (Doc.indent operatorWithRhs) + else operatorWithRhs in - if ParsetreeViewer.shouldIndentBinaryExpr expr then - Doc.group (Doc.indent operatorWithRhs) - else operatorWithRhs - in - let doc = - Doc.group (Doc.concat [printOperand ~isLhs:true lhs operator; right]) - in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - (match - Parens.binaryExpr - { - expr with - pexp_attributes = - ParsetreeViewer.filterPrintableAttributes - expr.pexp_attributes; - } - with - | Braced bracesLoc -> printBraces doc expr bracesLoc - | Parenthesized -> addParens doc - | Nothing -> doc); - ]) + let doc = + Doc.group (Doc.concat [ printOperand ~isLhs:true lhs operator; right ]) + in + Doc.group + (Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + (match + Parens.binaryExpr + { + expr with + pexp_attributes = + ParsetreeViewer.filterPrintableAttributes + expr.pexp_attributes; + } + with + | Braced bracesLoc -> printBraces doc expr bracesLoc + | Parenthesized -> addParens doc + | Nothing -> doc); + ]) | _ -> Doc.nil and printBeltListConcatApply ~customLayout subLists cmtTbl = let makeSpreadDoc commaBeforeSpread = function | Some expr -> - Doc.concat - [ - commaBeforeSpread; - Doc.dotdotdot; - (let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); - ] + Doc.concat + [ + commaBeforeSpread; + Doc.dotdotdot; + (let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + ] | None -> Doc.nil in let makeSubListDoc (expressions, spread) = let commaBeforeSpread = match expressions with | [] -> Doc.nil - | _ -> Doc.concat [Doc.text ","; Doc.line] + | _ -> Doc.concat [ Doc.text ","; Doc.line ] in let spreadDoc = makeSpreadDoc commaBeforeSpread spread in Doc.concat [ Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) (List.map (fun expr -> let doc = @@ -56609,7 +56829,7 @@ and printBeltListConcatApply ~customLayout subLists cmtTbl = [ Doc.softLine; Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) (List.map makeSubListDoc (List.map ParsetreeViewer.collectListExpressions subLists)); ]); @@ -56622,228 +56842,243 @@ and printBeltListConcatApply ~customLayout subLists cmtTbl = and printPexpApply ~customLayout expr cmtTbl = match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident "##"}}, - [(Nolabel, parentExpr); (Nolabel, memberExpr)] ) -> - let parentDoc = - let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces - | Nothing -> doc - in - let member = - let memberDoc = - match memberExpr.pexp_desc with - | Pexp_ident lident -> - printComments (printLongident lident.txt) cmtTbl memberExpr.pexp_loc - | _ -> printExpressionWithComments ~customLayout memberExpr cmtTbl + ( { pexp_desc = Pexp_ident { txt = Longident.Lident "##" } }, + [ (Nolabel, parentExpr); (Nolabel, memberExpr) ] ) -> + let parentDoc = + let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in + match Parens.unaryExprOperand parentExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc parentExpr braces + | Nothing -> doc + in + let member = + let memberDoc = + match memberExpr.pexp_desc with + | Pexp_ident lident -> + printComments + (printLongident lident.txt) + cmtTbl memberExpr.pexp_loc + | _ -> printExpressionWithComments ~customLayout memberExpr cmtTbl + in + Doc.concat [ Doc.text "\""; memberDoc; Doc.text "\"" ] in - Doc.concat [Doc.text "\""; memberDoc; Doc.text "\""] - in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - parentDoc; - Doc.lbracket; - member; - Doc.rbracket; - ]) - | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}}, - [(Nolabel, lhs); (Nolabel, rhs)] ) -> ( - let rhsDoc = - let doc = printExpressionWithComments ~customLayout rhs cmtTbl in - match Parens.expr rhs with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc rhs braces - | Nothing -> doc - in - (* TODO: unify indentation of "=" *) - let shouldIndent = - (not (ParsetreeViewer.isBracedExpr rhs)) - && ParsetreeViewer.isBinaryExpression rhs - in - let doc = Doc.group (Doc.concat [ - printExpressionWithComments ~customLayout lhs cmtTbl; - Doc.text " ="; - (if shouldIndent then - Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) - else Doc.concat [Doc.space; rhsDoc]); + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + parentDoc; + Doc.lbracket; + member; + Doc.rbracket; ]) - in - match expr.pexp_attributes with - | [] -> doc - | attrs -> - Doc.group (Doc.concat [printAttributes ~customLayout attrs cmtTbl; doc])) | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "get")}}, - [(Nolabel, parentExpr); (Nolabel, memberExpr)] ) - when not (ParsetreeViewer.isRewrittenUnderscoreApplySugar parentExpr) -> - (* Don't print the Array.get(_, 0) sugar a.k.a. (__x) => Array.get(__x, 0) as _[0] *) - let member = - let memberDoc = - let doc = printExpressionWithComments ~customLayout memberExpr cmtTbl in - match Parens.expr memberExpr with + ( { pexp_desc = Pexp_ident { txt = Longident.Lident "#=" } }, + [ (Nolabel, lhs); (Nolabel, rhs) ] ) -> ( + let rhsDoc = + let doc = printExpressionWithComments ~customLayout rhs cmtTbl in + match Parens.expr rhs with | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc memberExpr braces + | Braced braces -> printBraces doc rhs braces | Nothing -> doc in - let shouldInline = - match memberExpr.pexp_desc with - | Pexp_constant _ | Pexp_ident _ -> true - | _ -> false + (* TODO: unify indentation of "=" *) + let shouldIndent = + (not (ParsetreeViewer.isBracedExpr rhs)) + && ParsetreeViewer.isBinaryExpression rhs in - if shouldInline then memberDoc - else - Doc.concat - [Doc.indent (Doc.concat [Doc.softLine; memberDoc]); Doc.softLine] - in - let parentDoc = - let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces - | Nothing -> doc - in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - parentDoc; - Doc.lbracket; - member; - Doc.rbracket; - ]) + let doc = + Doc.group + (Doc.concat + [ + printExpressionWithComments ~customLayout lhs cmtTbl; + Doc.text " ="; + (if shouldIndent then + Doc.group (Doc.indent (Doc.concat [ Doc.line; rhsDoc ])) + else Doc.concat [ Doc.space; rhsDoc ]); + ]) + in + match expr.pexp_attributes with + | [] -> doc + | attrs -> + Doc.group + (Doc.concat [ printAttributes ~customLayout attrs cmtTbl; doc ])) | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "set")}}, - [(Nolabel, parentExpr); (Nolabel, memberExpr); (Nolabel, targetExpr)] ) - -> - let member = - let memberDoc = - let doc = printExpressionWithComments ~customLayout memberExpr cmtTbl in - match Parens.expr memberExpr with + ( { + pexp_desc = Pexp_ident { txt = Longident.Ldot (Lident "Array", "get") }; + }, + [ (Nolabel, parentExpr); (Nolabel, memberExpr) ] ) + when not (ParsetreeViewer.isRewrittenUnderscoreApplySugar parentExpr) -> + (* Don't print the Array.get(_, 0) sugar a.k.a. (__x) => Array.get(__x, 0) as _[0] *) + let member = + let memberDoc = + let doc = + printExpressionWithComments ~customLayout memberExpr cmtTbl + in + match Parens.expr memberExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc memberExpr braces + | Nothing -> doc + in + let shouldInline = + match memberExpr.pexp_desc with + | Pexp_constant _ | Pexp_ident _ -> true + | _ -> false + in + if shouldInline then memberDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [ Doc.softLine; memberDoc ]); Doc.softLine; + ] + in + let parentDoc = + let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in + match Parens.unaryExprOperand parentExpr with | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc memberExpr braces + | Braced braces -> printBraces doc parentExpr braces | Nothing -> doc in - let shouldInline = - match memberExpr.pexp_desc with - | Pexp_constant _ | Pexp_ident _ -> true - | _ -> false + Doc.group + (Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + parentDoc; + Doc.lbracket; + member; + Doc.rbracket; + ]) + | Pexp_apply + ( { + pexp_desc = Pexp_ident { txt = Longident.Ldot (Lident "Array", "set") }; + }, + [ (Nolabel, parentExpr); (Nolabel, memberExpr); (Nolabel, targetExpr) ] + ) -> + let member = + let memberDoc = + let doc = + printExpressionWithComments ~customLayout memberExpr cmtTbl + in + match Parens.expr memberExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc memberExpr braces + | Nothing -> doc + in + let shouldInline = + match memberExpr.pexp_desc with + | Pexp_constant _ | Pexp_ident _ -> true + | _ -> false + in + if shouldInline then memberDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [ Doc.softLine; memberDoc ]); Doc.softLine; + ] in - if shouldInline then memberDoc - else - Doc.concat - [Doc.indent (Doc.concat [Doc.softLine; memberDoc]); Doc.softLine] - in - let shouldIndentTargetExpr = - if ParsetreeViewer.isBracedExpr targetExpr then false - else - ParsetreeViewer.isBinaryExpression targetExpr - || - match targetExpr with - | { - pexp_attributes = [({Location.txt = "ns.ternary"}, _)]; - pexp_desc = Pexp_ifthenelse (ifExpr, _, _); - } -> - ParsetreeViewer.isBinaryExpression ifExpr - || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes - | {pexp_desc = Pexp_newtype _} -> false - | e -> - ParsetreeViewer.hasAttributes e.pexp_attributes - || ParsetreeViewer.isArrayAccess e - in - let targetExpr = - let doc = printExpressionWithComments ~customLayout targetExpr cmtTbl in - match Parens.expr targetExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc targetExpr braces - | Nothing -> doc - in - let parentDoc = - let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces - | Nothing -> doc - in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - parentDoc; - Doc.lbracket; - member; - Doc.rbracket; - Doc.text " ="; - (if shouldIndentTargetExpr then - Doc.indent (Doc.concat [Doc.line; targetExpr]) - else Doc.concat [Doc.space; targetExpr]); - ]) + let shouldIndentTargetExpr = + if ParsetreeViewer.isBracedExpr targetExpr then false + else + ParsetreeViewer.isBinaryExpression targetExpr + || + match targetExpr with + | { + pexp_attributes = [ ({ Location.txt = "ns.ternary" }, _) ]; + pexp_desc = Pexp_ifthenelse (ifExpr, _, _); + } -> + ParsetreeViewer.isBinaryExpression ifExpr + || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes + | { pexp_desc = Pexp_newtype _ } -> false + | e -> + ParsetreeViewer.hasAttributes e.pexp_attributes + || ParsetreeViewer.isArrayAccess e + in + let targetExpr = + let doc = printExpressionWithComments ~customLayout targetExpr cmtTbl in + match Parens.expr targetExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc targetExpr braces + | Nothing -> doc + in + let parentDoc = + let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in + match Parens.unaryExprOperand parentExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc parentExpr braces + | Nothing -> doc + in + Doc.group + (Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + parentDoc; + Doc.lbracket; + member; + Doc.rbracket; + Doc.text " ="; + (if shouldIndentTargetExpr then + Doc.indent (Doc.concat [ Doc.line; targetExpr ]) + else Doc.concat [ Doc.space; targetExpr ]); + ]) (* TODO: cleanup, are those branches even remotely performant? *) - | Pexp_apply ({pexp_desc = Pexp_ident lident}, args) + | Pexp_apply ({ pexp_desc = Pexp_ident lident }, args) when ParsetreeViewer.isJsxExpression expr -> - printJsxExpression ~customLayout lident args cmtTbl + printJsxExpression ~customLayout lident args cmtTbl | Pexp_apply (callExpr, args) -> - let args = - List.map - (fun (lbl, arg) -> (lbl, ParsetreeViewer.rewriteUnderscoreApply arg)) - args - in - let uncurried, attrs = - ParsetreeViewer.processUncurriedAttribute expr.pexp_attributes - in - let callExprDoc = - let doc = printExpressionWithComments ~customLayout callExpr cmtTbl in - match Parens.callExpr callExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc callExpr braces - | Nothing -> doc - in - if ParsetreeViewer.requiresSpecialCallbackPrintingFirstArg args then - let argsDoc = - printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args - cmtTbl + let args = + List.map + (fun (lbl, arg) -> (lbl, ParsetreeViewer.rewriteUnderscoreApply arg)) + args in - Doc.concat - [printAttributes ~customLayout attrs cmtTbl; callExprDoc; argsDoc] - else if ParsetreeViewer.requiresSpecialCallbackPrintingLastArg args then - let argsDoc = - printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args - cmtTbl + let uncurried, attrs = + ParsetreeViewer.processUncurriedAttribute expr.pexp_attributes in - (* - * Fixes the following layout (the `[` and `]` should break): - * [fn(x => { - * let _ = x - * }), fn(y => { - * let _ = y - * }), fn(z => { - * let _ = z - * })] - * See `Doc.willBreak documentation in interface file for more context. - * Context: - * https://github.com/rescript-lang/syntax/issues/111 - * https://github.com/rescript-lang/syntax/issues/166 - *) - let maybeBreakParent = - if Doc.willBreak argsDoc then Doc.breakParent else Doc.nil + let callExprDoc = + let doc = printExpressionWithComments ~customLayout callExpr cmtTbl in + match Parens.callExpr callExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc callExpr braces + | Nothing -> doc in - Doc.concat - [ - maybeBreakParent; - printAttributes ~customLayout attrs cmtTbl; - callExprDoc; - argsDoc; - ] - else - let argsDoc = printArguments ~customLayout ~uncurried args cmtTbl in - Doc.concat - [printAttributes ~customLayout attrs cmtTbl; callExprDoc; argsDoc] + if ParsetreeViewer.requiresSpecialCallbackPrintingFirstArg args then + let argsDoc = + printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout + args cmtTbl + in + Doc.concat + [ printAttributes ~customLayout attrs cmtTbl; callExprDoc; argsDoc ] + else if ParsetreeViewer.requiresSpecialCallbackPrintingLastArg args then + let argsDoc = + printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args + cmtTbl + in + (* + * Fixes the following layout (the `[` and `]` should break): + * [fn(x => { + * let _ = x + * }), fn(y => { + * let _ = y + * }), fn(z => { + * let _ = z + * })] + * See `Doc.willBreak documentation in interface file for more context. + * Context: + * https://github.com/rescript-lang/syntax/issues/111 + * https://github.com/rescript-lang/syntax/issues/166 + *) + let maybeBreakParent = + if Doc.willBreak argsDoc then Doc.breakParent else Doc.nil + in + Doc.concat + [ + maybeBreakParent; + printAttributes ~customLayout attrs cmtTbl; + callExprDoc; + argsDoc; + ] + else + let argsDoc = printArguments ~customLayout ~uncurried args cmtTbl in + Doc.concat + [ printAttributes ~customLayout attrs cmtTbl; callExprDoc; argsDoc ] | _ -> assert false and printJsxExpression ~customLayout lident args cmtTbl = @@ -56855,9 +57090,9 @@ and printJsxExpression ~customLayout lident args cmtTbl = | Some { Parsetree.pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"}, None); + Pexp_construct ({ txt = Longident.Lident "[]" }, None); } -> - false + false | None -> false | _ -> true in @@ -56866,17 +57101,17 @@ and printJsxExpression ~customLayout lident args cmtTbl = | Some { Parsetree.pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"}, None); + Pexp_construct ({ txt = Longident.Lident "[]" }, None); pexp_loc = loc; } -> - not (hasCommentsInside cmtTbl loc) + not (hasCommentsInside cmtTbl loc) | _ -> false in let printChildren children = let lineSep = match children with | Some expr -> - if hasNestedJsxOrMoreThanOneChild expr then Doc.hardLine else Doc.line + if hasNestedJsxOrMoreThanOneChild expr then Doc.hardLine else Doc.line | None -> Doc.line in Doc.concat @@ -56887,8 +57122,8 @@ and printJsxExpression ~customLayout lident args cmtTbl = Doc.line; (match children with | Some childrenExpression -> - printJsxChildren ~customLayout childrenExpression ~sep:lineSep - cmtTbl + printJsxChildren ~customLayout childrenExpression + ~sep:lineSep cmtTbl | None -> Doc.nil); ]); lineSep; @@ -56901,27 +57136,27 @@ and printJsxExpression ~customLayout lident args cmtTbl = (Doc.concat [ printComments - (Doc.concat [Doc.lessThan; name]) + (Doc.concat [ Doc.lessThan; name ]) cmtTbl lident.Asttypes.loc; formattedProps; (match children with | Some { Parsetree.pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"}, None); + Pexp_construct ({ txt = Longident.Lident "[]" }, None); } when isSelfClosing -> - Doc.text "/>" + Doc.text "/>" | _ -> - (* if tag A has trailing comments then put > on the next line - - - *) - if hasTrailingComments cmtTbl lident.Asttypes.loc then - Doc.concat [Doc.softLine; Doc.greaterThan] - else Doc.greaterThan); + (* if tag A has trailing comments then put > on the next line + + + *) + if hasTrailingComments cmtTbl lident.Asttypes.loc then + Doc.concat [ Doc.softLine; Doc.greaterThan ] + else Doc.greaterThan); ]); (if isSelfClosing then Doc.nil else @@ -56933,10 +57168,10 @@ and printJsxExpression ~customLayout lident args cmtTbl = | Some { Parsetree.pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"}, None); + Pexp_construct ({ txt = Longident.Lident "[]" }, None); pexp_loc = loc; } -> - printCommentsInside cmtTbl loc + printCommentsInside cmtTbl loc | _ -> Doc.nil); Doc.text " Doc.nil + | Pexp_construct ({ txt = Longident.Lident "[]" }, None) -> Doc.nil | _ -> - Doc.indent - (Doc.concat - [ - Doc.line; - printJsxChildren ~customLayout expr ~sep:lineSep cmtTbl; - ])); + Doc.indent + (Doc.concat + [ + Doc.line; + printJsxChildren ~customLayout expr ~sep:lineSep cmtTbl; + ])); lineSep; closing; ]) @@ -56970,52 +57205,53 @@ and printJsxFragment ~customLayout expr cmtTbl = and printJsxChildren ~customLayout (childrenExpr : Parsetree.expression) ~sep cmtTbl = match childrenExpr.pexp_desc with - | Pexp_construct ({txt = Longident.Lident "::"}, _) -> - let children, _ = ParsetreeViewer.collectListExpressions childrenExpr in - Doc.group - (Doc.join ~sep - (List.map - (fun (expr : Parsetree.expression) -> - let leadingLineCommentPresent = - hasLeadingLineComment cmtTbl expr.pexp_loc - in - let exprDoc = - printExpressionWithComments ~customLayout expr cmtTbl - in - let addParensOrBraces exprDoc = - (* {(20: int)} make sure that we also protect the expression inside *) - let innerDoc = - if Parens.bracedExpr expr then addParens exprDoc else exprDoc + | Pexp_construct ({ txt = Longident.Lident "::" }, _) -> + let children, _ = ParsetreeViewer.collectListExpressions childrenExpr in + Doc.group + (Doc.join ~sep + (List.map + (fun (expr : Parsetree.expression) -> + let leadingLineCommentPresent = + hasLeadingLineComment cmtTbl expr.pexp_loc in - if leadingLineCommentPresent then addBraces innerDoc - else Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace] - in - match Parens.jsxChildExpr expr with - | Nothing -> exprDoc - | Parenthesized -> addParensOrBraces exprDoc - | Braced bracesLoc -> - printComments (addParensOrBraces exprDoc) cmtTbl bracesLoc) - children)) + let exprDoc = + printExpressionWithComments ~customLayout expr cmtTbl + in + let addParensOrBraces exprDoc = + (* {(20: int)} make sure that we also protect the expression inside *) + let innerDoc = + if Parens.bracedExpr expr then addParens exprDoc + else exprDoc + in + if leadingLineCommentPresent then addBraces innerDoc + else Doc.concat [ Doc.lbrace; innerDoc; Doc.rbrace ] + in + match Parens.jsxChildExpr expr with + | Nothing -> exprDoc + | Parenthesized -> addParensOrBraces exprDoc + | Braced bracesLoc -> + printComments (addParensOrBraces exprDoc) cmtTbl bracesLoc) + children)) | _ -> - let leadingLineCommentPresent = - hasLeadingLineComment cmtTbl childrenExpr.pexp_loc - in - let exprDoc = - printExpressionWithComments ~customLayout childrenExpr cmtTbl - in - Doc.concat - [ - Doc.dotdotdot; - (match Parens.jsxChildExpr childrenExpr with - | Parenthesized | Braced _ -> - let innerDoc = - if Parens.bracedExpr childrenExpr then addParens exprDoc - else exprDoc - in - if leadingLineCommentPresent then addBraces innerDoc - else Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace] - | Nothing -> exprDoc); - ] + let leadingLineCommentPresent = + hasLeadingLineComment cmtTbl childrenExpr.pexp_loc + in + let exprDoc = + printExpressionWithComments ~customLayout childrenExpr cmtTbl + in + Doc.concat + [ + Doc.dotdotdot; + (match Parens.jsxChildExpr childrenExpr with + | Parenthesized | Braced _ -> + let innerDoc = + if Parens.bracedExpr childrenExpr then addParens exprDoc + else exprDoc + in + if leadingLineCommentPresent then addBraces innerDoc + else Doc.concat [ Doc.lbrace; innerDoc; Doc.rbrace ] + | Nothing -> exprDoc); + ] and printJsxProps ~customLayout args cmtTbl : Doc.t * Parsetree.expression option = @@ -57034,10 +57270,10 @@ and printJsxProps ~customLayout args cmtTbl : let isSelfClosing children = match children with | { - Parsetree.pexp_desc = Pexp_construct ({txt = Longident.Lident "[]"}, None); + Parsetree.pexp_desc = Pexp_construct ({ txt = Longident.Lident "[]" }, None); pexp_loc = loc; } -> - not (hasCommentsInside cmtTbl loc) + not (hasCommentsInside cmtTbl loc) | _ -> false in let rec loop props args = @@ -57048,50 +57284,50 @@ and printJsxProps ~customLayout args cmtTbl : ( Asttypes.Nolabel, { Parsetree.pexp_desc = - Pexp_construct ({txt = Longident.Lident "()"}, None); + Pexp_construct ({ txt = Longident.Lident "()" }, None); } ); ] -> - let doc = if isSelfClosing children then Doc.line else Doc.nil in - (doc, Some children) + let doc = if isSelfClosing children then Doc.line else Doc.nil in + (doc, Some children) | ((_, expr) as lastProp) :: [ (Asttypes.Labelled "children", children); ( Asttypes.Nolabel, { Parsetree.pexp_desc = - Pexp_construct ({txt = Longident.Lident "()"}, None); + Pexp_construct ({ txt = Longident.Lident "()" }, None); } ); ] -> - let loc = - match expr.Parsetree.pexp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _attrs -> - {loc with loc_end = expr.pexp_loc.loc_end} - | _ -> expr.pexp_loc - in - let trailingCommentsPresent = hasTrailingComments cmtTbl loc in - let propDoc = printJsxProp ~customLayout lastProp cmtTbl in - let formattedProps = - Doc.concat - [ - Doc.indent - (Doc.concat - [ - Doc.line; - Doc.group - (Doc.join ~sep:Doc.line (propDoc :: props |> List.rev)); - ]); - (* print > on new line if the last prop has trailing comments *) - (match (isSelfClosing children, trailingCommentsPresent) with - (* we always put /> on a new line when a self-closing tag breaks *) - | true, _ -> Doc.line - | false, true -> Doc.softLine - | false, false -> Doc.nil); - ] - in - (formattedProps, Some children) + let loc = + match expr.Parsetree.pexp_attributes with + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _attrs -> + { loc with loc_end = expr.pexp_loc.loc_end } + | _ -> expr.pexp_loc + in + let trailingCommentsPresent = hasTrailingComments cmtTbl loc in + let propDoc = printJsxProp ~customLayout lastProp cmtTbl in + let formattedProps = + Doc.concat + [ + Doc.indent + (Doc.concat + [ + Doc.line; + Doc.group + (Doc.join ~sep:Doc.line (propDoc :: props |> List.rev)); + ]); + (* print > on new line if the last prop has trailing comments *) + (match (isSelfClosing children, trailingCommentsPresent) with + (* we always put /> on a new line when a self-closing tag breaks *) + | true, _ -> Doc.line + | false, true -> Doc.softLine + | false, false -> Doc.nil); + ] + in + (formattedProps, Some children) | arg :: args -> - let propDoc = printJsxProp ~customLayout arg cmtTbl in - loop (propDoc :: props) args + let propDoc = printJsxProp ~customLayout arg cmtTbl in + loop (propDoc :: props) args in loop [] args @@ -57100,79 +57336,81 @@ and printJsxProp ~customLayout arg cmtTbl = | ( ((Asttypes.Labelled lblTxt | Optional lblTxt) as lbl), { Parsetree.pexp_attributes = - [({Location.txt = "ns.namedArgLoc"; loc = argLoc}, _)]; - pexp_desc = Pexp_ident {txt = Longident.Lident ident}; + [ ({ Location.txt = "ns.namedArgLoc"; loc = argLoc }, _) ]; + pexp_desc = Pexp_ident { txt = Longident.Lident ident }; } ) when lblTxt = ident (* jsx punning *) -> ( - match lbl with - | Nolabel -> Doc.nil - | Labelled _lbl -> printComments (printIdentLike ident) cmtTbl argLoc - | Optional _lbl -> - let doc = Doc.concat [Doc.question; printIdentLike ident] in - printComments doc cmtTbl argLoc) + match lbl with + | Nolabel -> Doc.nil + | Labelled _lbl -> printComments (printIdentLike ident) cmtTbl argLoc + | Optional _lbl -> + let doc = Doc.concat [ Doc.question; printIdentLike ident ] in + printComments doc cmtTbl argLoc) | ( ((Asttypes.Labelled lblTxt | Optional lblTxt) as lbl), { Parsetree.pexp_attributes = []; - pexp_desc = Pexp_ident {txt = Longident.Lident ident}; + pexp_desc = Pexp_ident { txt = Longident.Lident ident }; } ) when lblTxt = ident (* jsx punning when printing from Reason *) -> ( - match lbl with - | Nolabel -> Doc.nil - | Labelled _lbl -> printIdentLike ident - | Optional _lbl -> Doc.concat [Doc.question; printIdentLike ident]) - | Asttypes.Labelled "_spreadProps", expr -> - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - Doc.concat [Doc.lbrace; Doc.dotdotdot; Doc.softLine; doc; Doc.rbrace] - | lbl, expr -> - let argLoc, expr = - match expr.pexp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: attrs -> - (loc, {expr with pexp_attributes = attrs}) - | _ -> (Location.none, expr) - in - let lblDoc = match lbl with - | Asttypes.Labelled lbl -> - let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in - Doc.concat [lbl; Doc.equal] - | Asttypes.Optional lbl -> - let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in - Doc.concat [lbl; Doc.equal; Doc.question] | Nolabel -> Doc.nil - in - let exprDoc = - let leadingLineCommentPresent = - hasLeadingLineComment cmtTbl expr.pexp_loc - in + | Labelled _lbl -> printIdentLike ident + | Optional _lbl -> Doc.concat [ Doc.question; printIdentLike ident ]) + | Asttypes.Labelled "_spreadProps", expr -> let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.jsxPropExpr expr with - | Parenthesized | Braced _ -> - (* {(20: int)} make sure that we also protect the expression inside *) - let innerDoc = if Parens.bracedExpr expr then addParens doc else doc in - if leadingLineCommentPresent then addBraces innerDoc - else Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace] - | _ -> doc - in - let fullLoc = {argLoc with loc_end = expr.pexp_loc.loc_end} in - printComments (Doc.concat [lblDoc; exprDoc]) cmtTbl fullLoc + Doc.concat [ Doc.lbrace; Doc.dotdotdot; Doc.softLine; doc; Doc.rbrace ] + | lbl, expr -> + let argLoc, expr = + match expr.pexp_attributes with + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: attrs -> + (loc, { expr with pexp_attributes = attrs }) + | _ -> (Location.none, expr) + in + let lblDoc = + match lbl with + | Asttypes.Labelled lbl -> + let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in + Doc.concat [ lbl; Doc.equal ] + | Asttypes.Optional lbl -> + let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in + Doc.concat [ lbl; Doc.equal; Doc.question ] + | Nolabel -> Doc.nil + in + let exprDoc = + let leadingLineCommentPresent = + hasLeadingLineComment cmtTbl expr.pexp_loc + in + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.jsxPropExpr expr with + | Parenthesized | Braced _ -> + (* {(20: int)} make sure that we also protect the expression inside *) + let innerDoc = + if Parens.bracedExpr expr then addParens doc else doc + in + if leadingLineCommentPresent then addBraces innerDoc + else Doc.concat [ Doc.lbrace; innerDoc; Doc.rbrace ] + | _ -> doc + in + let fullLoc = { argLoc with loc_end = expr.pexp_loc.loc_end } in + printComments (Doc.concat [ lblDoc; exprDoc ]) cmtTbl fullLoc (* div -> div. * Navabar.createElement -> Navbar * Staff.Users.createElement -> Staff.Users *) -and printJsxName {txt = lident} = +and printJsxName { txt = lident } = let rec flatten acc lident = match lident with | Longident.Lident txt -> txt :: acc | Ldot (lident, txt) -> - let acc = if txt = "createElement" then acc else txt :: acc in - flatten acc lident + let acc = if txt = "createElement" then acc else txt :: acc in + flatten acc lident | _ -> acc in match lident with | Longident.Lident txt -> Doc.text txt | _ as lident -> - let segments = flatten [] lident in - Doc.join ~sep:Doc.dot (List.map Doc.text segments) + let segments = flatten [] lident in + Doc.join ~sep:Doc.dot (List.map Doc.text segments) and printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args cmtTbl = @@ -57184,29 +57422,32 @@ and printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args let callback, printedArgs = match args with | (lbl, expr) :: args -> - let lblDoc = - match lbl with - | Asttypes.Nolabel -> Doc.nil - | Asttypes.Labelled txt -> - Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal] - | Asttypes.Optional txt -> - Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal; Doc.question] - in - let callback = - Doc.concat - [ - lblDoc; - printPexpFun ~customLayout ~inCallback:FitsOnOneLine expr cmtTbl; - ] - in - let callback = lazy (printComments callback cmtTbl expr.pexp_loc) in - let printedArgs = - lazy - (Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map (fun arg -> printArgument ~customLayout arg cmtTbl) args)) - in - (callback, printedArgs) + let lblDoc = + match lbl with + | Asttypes.Nolabel -> Doc.nil + | Asttypes.Labelled txt -> + Doc.concat [ Doc.tilde; printIdentLike txt; Doc.equal ] + | Asttypes.Optional txt -> + Doc.concat + [ Doc.tilde; printIdentLike txt; Doc.equal; Doc.question ] + in + let callback = + Doc.concat + [ + lblDoc; + printPexpFun ~customLayout ~inCallback:FitsOnOneLine expr cmtTbl; + ] + in + let callback = lazy (printComments callback cmtTbl expr.pexp_loc) in + let printedArgs = + lazy + (Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun arg -> printArgument ~customLayout arg cmtTbl) + args)) + in + (callback, printedArgs) | _ -> assert false in @@ -57256,7 +57497,7 @@ and printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args *) if customLayout > customLayoutThreshold then Lazy.force breakAllArgs else if Doc.willBreak (Lazy.force printedArgs) then Lazy.force breakAllArgs - else Doc.customLayout [Lazy.force fitsOnOneLine; Lazy.force breakAllArgs] + else Doc.customLayout [ Lazy.force fitsOnOneLine; Lazy.force breakAllArgs ] and printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args cmtTbl = @@ -57269,38 +57510,39 @@ and printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args let rec loop acc args = match args with | [] -> (lazy Doc.nil, lazy Doc.nil, lazy Doc.nil) - | [(lbl, expr)] -> - let lblDoc = - match lbl with - | Asttypes.Nolabel -> Doc.nil - | Asttypes.Labelled txt -> - Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal] - | Asttypes.Optional txt -> - Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal; Doc.question] - in - let callbackFitsOnOneLine = - lazy - (let pexpFunDoc = - printPexpFun ~customLayout ~inCallback:FitsOnOneLine expr cmtTbl - in - let doc = Doc.concat [lblDoc; pexpFunDoc] in - printComments doc cmtTbl expr.pexp_loc) - in - let callbackArgumentsFitsOnOneLine = - lazy - (let pexpFunDoc = - printPexpFun ~customLayout ~inCallback:ArgumentsFitOnOneLine expr - cmtTblCopy - in - let doc = Doc.concat [lblDoc; pexpFunDoc] in - printComments doc cmtTblCopy expr.pexp_loc) - in - ( lazy (Doc.concat (List.rev acc)), - callbackFitsOnOneLine, - callbackArgumentsFitsOnOneLine ) + | [ (lbl, expr) ] -> + let lblDoc = + match lbl with + | Asttypes.Nolabel -> Doc.nil + | Asttypes.Labelled txt -> + Doc.concat [ Doc.tilde; printIdentLike txt; Doc.equal ] + | Asttypes.Optional txt -> + Doc.concat + [ Doc.tilde; printIdentLike txt; Doc.equal; Doc.question ] + in + let callbackFitsOnOneLine = + lazy + (let pexpFunDoc = + printPexpFun ~customLayout ~inCallback:FitsOnOneLine expr cmtTbl + in + let doc = Doc.concat [ lblDoc; pexpFunDoc ] in + printComments doc cmtTbl expr.pexp_loc) + in + let callbackArgumentsFitsOnOneLine = + lazy + (let pexpFunDoc = + printPexpFun ~customLayout ~inCallback:ArgumentsFitOnOneLine expr + cmtTblCopy + in + let doc = Doc.concat [ lblDoc; pexpFunDoc ] in + printComments doc cmtTblCopy expr.pexp_loc) + in + ( lazy (Doc.concat (List.rev acc)), + callbackFitsOnOneLine, + callbackArgumentsFitsOnOneLine ) | arg :: args -> - let argDoc = printArgument ~customLayout arg cmtTbl in - loop (Doc.line :: Doc.comma :: argDoc :: acc) args + let argDoc = printArgument ~customLayout arg cmtTbl in + loop (Doc.line :: Doc.comma :: argDoc :: acc) args in let printedArgs, callback, callback2 = loop [] args in @@ -57373,46 +57615,48 @@ and printArguments ~customLayout ~uncurried | [ ( Nolabel, { - pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _); + pexp_desc = Pexp_construct ({ txt = Longident.Lident "()" }, _); pexp_loc = loc; } ); ] -> ( - (* See "parseCallExpr", ghost unit expression is used the implement - * arity zero vs arity one syntax. - * Related: https://github.com/rescript-lang/syntax/issues/138 *) - match (uncurried, loc.loc_ghost) with - | true, true -> Doc.text "(.)" (* arity zero *) - | true, false -> Doc.text "(. ())" (* arity one *) - | _ -> Doc.text "()") - | [(Nolabel, arg)] when ParsetreeViewer.isHuggableExpression arg -> - let argDoc = - let doc = printExpressionWithComments ~customLayout arg cmtTbl in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc - in - Doc.concat - [(if uncurried then Doc.text "(. " else Doc.lparen); argDoc; Doc.rparen] + (* See "parseCallExpr", ghost unit expression is used the implement + * arity zero vs arity one syntax. + * Related: https://github.com/rescript-lang/syntax/issues/138 *) + match (uncurried, loc.loc_ghost) with + | true, true -> Doc.text "(.)" (* arity zero *) + | true, false -> Doc.text "(. ())" (* arity one *) + | _ -> Doc.text "()") + | [ (Nolabel, arg) ] when ParsetreeViewer.isHuggableExpression arg -> + let argDoc = + let doc = printExpressionWithComments ~customLayout arg cmtTbl in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc + in + Doc.concat + [ + (if uncurried then Doc.text "(. " else Doc.lparen); argDoc; Doc.rparen; + ] | args -> - Doc.group - (Doc.concat - [ - (if uncurried then Doc.text "(." else Doc.lparen); - Doc.indent - (Doc.concat - [ - (if uncurried then Doc.line else Doc.softLine); - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun arg -> printArgument ~customLayout arg cmtTbl) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + (if uncurried then Doc.text "(." else Doc.lparen); + Doc.indent + (Doc.concat + [ + (if uncurried then Doc.line else Doc.softLine); + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun arg -> printArgument ~customLayout arg cmtTbl) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) (* * argument ::= @@ -57433,88 +57677,90 @@ and printArgument ~customLayout (argLbl, arg) cmtTbl = (* ~a (punned)*) | ( Asttypes.Labelled lbl, ({ - pexp_desc = Pexp_ident {txt = Longident.Lident name}; - pexp_attributes = [] | [({Location.txt = "ns.namedArgLoc"}, _)]; + pexp_desc = Pexp_ident { txt = Longident.Lident name }; + pexp_attributes = [] | [ ({ Location.txt = "ns.namedArgLoc" }, _) ]; } as argExpr) ) when lbl = name && not (ParsetreeViewer.isBracedExpr argExpr) -> - let loc = - match arg.pexp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> loc - | _ -> arg.pexp_loc - in - let doc = Doc.concat [Doc.tilde; printIdentLike lbl] in - printComments doc cmtTbl loc + let loc = + match arg.pexp_attributes with + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _ -> loc + | _ -> arg.pexp_loc + in + let doc = Doc.concat [ Doc.tilde; printIdentLike lbl ] in + printComments doc cmtTbl loc (* ~a: int (punned)*) | ( Asttypes.Labelled lbl, { pexp_desc = Pexp_constraint - ( ({pexp_desc = Pexp_ident {txt = Longident.Lident name}} as argExpr), + ( ({ pexp_desc = Pexp_ident { txt = Longident.Lident name } } as + argExpr), typ ); pexp_loc; pexp_attributes = - ([] | [({Location.txt = "ns.namedArgLoc"}, _)]) as attrs; + ([] | [ ({ Location.txt = "ns.namedArgLoc" }, _) ]) as attrs; } ) when lbl = name && not (ParsetreeViewer.isBracedExpr argExpr) -> - let loc = - match attrs with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> - {loc with loc_end = pexp_loc.loc_end} - | _ -> arg.pexp_loc - in - let doc = - Doc.concat - [ - Doc.tilde; - printIdentLike lbl; - Doc.text ": "; - printTypExpr ~customLayout typ cmtTbl; - ] - in - printComments doc cmtTbl loc + let loc = + match attrs with + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _ -> + { loc with loc_end = pexp_loc.loc_end } + | _ -> arg.pexp_loc + in + let doc = + Doc.concat + [ + Doc.tilde; + printIdentLike lbl; + Doc.text ": "; + printTypExpr ~customLayout typ cmtTbl; + ] + in + printComments doc cmtTbl loc (* ~a? (optional lbl punned)*) | ( Asttypes.Optional lbl, { - pexp_desc = Pexp_ident {txt = Longident.Lident name}; - pexp_attributes = [] | [({Location.txt = "ns.namedArgLoc"}, _)]; + pexp_desc = Pexp_ident { txt = Longident.Lident name }; + pexp_attributes = [] | [ ({ Location.txt = "ns.namedArgLoc" }, _) ]; } ) when lbl = name -> - let loc = - match arg.pexp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> loc - | _ -> arg.pexp_loc - in - let doc = Doc.concat [Doc.tilde; printIdentLike lbl; Doc.question] in - printComments doc cmtTbl loc + let loc = + match arg.pexp_attributes with + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _ -> loc + | _ -> arg.pexp_loc + in + let doc = Doc.concat [ Doc.tilde; printIdentLike lbl; Doc.question ] in + printComments doc cmtTbl loc | _lbl, expr -> - let argLoc, expr = - match expr.pexp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: attrs -> - (loc, {expr with pexp_attributes = attrs}) - | _ -> (expr.pexp_loc, expr) - in - let printedLbl = - match argLbl with - | Asttypes.Nolabel -> Doc.nil - | Asttypes.Labelled lbl -> - let doc = Doc.concat [Doc.tilde; printIdentLike lbl; Doc.equal] in - printComments doc cmtTbl argLoc - | Asttypes.Optional lbl -> - let doc = - Doc.concat [Doc.tilde; printIdentLike lbl; Doc.equal; Doc.question] - in - printComments doc cmtTbl argLoc - in - let printedExpr = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - let loc = {argLoc with loc_end = expr.pexp_loc.loc_end} in - let doc = Doc.concat [printedLbl; printedExpr] in - printComments doc cmtTbl loc + let argLoc, expr = + match expr.pexp_attributes with + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: attrs -> + (loc, { expr with pexp_attributes = attrs }) + | _ -> (expr.pexp_loc, expr) + in + let printedLbl = + match argLbl with + | Asttypes.Nolabel -> Doc.nil + | Asttypes.Labelled lbl -> + let doc = Doc.concat [ Doc.tilde; printIdentLike lbl; Doc.equal ] in + printComments doc cmtTbl argLoc + | Asttypes.Optional lbl -> + let doc = + Doc.concat + [ Doc.tilde; printIdentLike lbl; Doc.equal; Doc.question ] + in + printComments doc cmtTbl argLoc + in + let printedExpr = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + let loc = { argLoc with loc_end = expr.pexp_loc.loc_end } in + let doc = Doc.concat [ printedLbl; printedExpr ] in + printComments doc cmtTbl loc and printCases ~customLayout (cases : Parsetree.case list) cmtTbl = Doc.breakableGroup ~forceBreak:true @@ -57541,40 +57787,40 @@ and printCase ~customLayout (case : Parsetree.case) cmtTbl = match case.pc_rhs.pexp_desc with | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ | Pexp_sequence _ -> - printExpressionBlock ~customLayout - ~braces:(ParsetreeViewer.isBracedExpr case.pc_rhs) - case.pc_rhs cmtTbl + printExpressionBlock ~customLayout + ~braces:(ParsetreeViewer.isBracedExpr case.pc_rhs) + case.pc_rhs cmtTbl | _ -> ( - let doc = printExpressionWithComments ~customLayout case.pc_rhs cmtTbl in - match Parens.expr case.pc_rhs with - | Parenthesized -> addParens doc - | _ -> doc) + let doc = + printExpressionWithComments ~customLayout case.pc_rhs cmtTbl + in + match Parens.expr case.pc_rhs with + | Parenthesized -> addParens doc + | _ -> doc) in let guard = match case.pc_guard with | None -> Doc.nil | Some expr -> - Doc.group - (Doc.concat - [ - Doc.line; - Doc.text "if "; - printExpressionWithComments ~customLayout expr cmtTbl; - ]) + Doc.group + (Doc.concat + [ + Doc.line; + Doc.text "if "; + printExpressionWithComments ~customLayout expr cmtTbl; + ]) in let shouldInlineRhs = match case.pc_rhs.pexp_desc with - | Pexp_construct ({txt = Longident.Lident ("()" | "true" | "false")}, _) + | Pexp_construct ({ txt = Longident.Lident ("()" | "true" | "false") }, _) | Pexp_constant _ | Pexp_ident _ -> - true + true | _ when ParsetreeViewer.isHuggableRhs case.pc_rhs -> true | _ -> false in let shouldIndentPattern = - match case.pc_lhs.ppat_desc with - | Ppat_or _ -> false - | _ -> true + match case.pc_lhs.ppat_desc with Ppat_or _ -> false | _ -> true in let patternDoc = let doc = printPattern ~customLayout case.pc_lhs cmtTbl in @@ -57589,10 +57835,11 @@ and printCase ~customLayout (case : Parsetree.case) cmtTbl = Doc.indent guard; Doc.text " =>"; Doc.indent - (Doc.concat [(if shouldInlineRhs then Doc.space else Doc.line); rhs]); + (Doc.concat + [ (if shouldInlineRhs then Doc.space else Doc.line); rhs ]); ] in - Doc.group (Doc.concat [Doc.text "| "; content]) + Doc.group (Doc.concat [ Doc.text "| "; content ]) and printExprFunParameters ~customLayout ~inCallback ~async ~uncurried ~hasConstraint parameters cmtTbl = @@ -57604,15 +57851,15 @@ and printExprFunParameters ~customLayout ~inCallback ~async ~uncurried attrs = []; lbl = Asttypes.Nolabel; defaultExpr = None; - pat = {Parsetree.ppat_desc = Ppat_any; ppat_loc}; + pat = { Parsetree.ppat_desc = Ppat_any; ppat_loc }; }; ] when not uncurried -> - let any = - let doc = if hasConstraint then Doc.text "(_)" else Doc.text "_" in - printComments doc cmtTbl ppat_loc - in - if async then addAsync any else any + let any = + let doc = if hasConstraint then Doc.text "(_)" else Doc.text "_" in + printComments doc cmtTbl ppat_loc + in + if async then addAsync any else any (* let f = a => () *) | [ ParsetreeViewer.Parameter @@ -57620,16 +57867,16 @@ and printExprFunParameters ~customLayout ~inCallback ~async ~uncurried attrs = []; lbl = Asttypes.Nolabel; defaultExpr = None; - pat = {Parsetree.ppat_desc = Ppat_var stringLoc}; + pat = { Parsetree.ppat_desc = Ppat_var stringLoc }; }; ] when not uncurried -> - let txtDoc = - let var = printIdentLike stringLoc.txt in - let var = if hasConstraint then addParens var else var in - if async then addAsync var else var - in - printComments txtDoc cmtTbl stringLoc.loc + let txtDoc = + let var = printIdentLike stringLoc.txt in + let var = if hasConstraint then addParens var else var in + if async then addAsync var else var + in + printComments txtDoc cmtTbl stringLoc.loc (* let f = () => () *) | [ ParsetreeViewer.Parameter @@ -57638,250 +57885,264 @@ and printExprFunParameters ~customLayout ~inCallback ~async ~uncurried lbl = Asttypes.Nolabel; defaultExpr = None; pat = - {ppat_desc = Ppat_construct ({txt = Longident.Lident "()"; loc}, None)}; + { + ppat_desc = + Ppat_construct ({ txt = Longident.Lident "()"; loc }, None); + }; }; ] when not uncurried -> - let doc = - let lparenRparen = Doc.text "()" in - if async then addAsync lparenRparen else lparenRparen - in - printComments doc cmtTbl loc + let doc = + let lparenRparen = Doc.text "()" in + if async then addAsync lparenRparen else lparenRparen + in + printComments doc cmtTbl loc (* let f = (~greeting, ~from as hometown, ~x=?) => () *) | parameters -> - let inCallback = - match inCallback with - | FitsOnOneLine -> true - | _ -> false - in - let maybeAsyncLparen = - let lparen = if uncurried then Doc.text "(. " else Doc.lparen in - if async then addAsync lparen else lparen - in - let shouldHug = ParsetreeViewer.parametersShouldHug parameters in - let printedParamaters = - Doc.concat - [ - (if shouldHug || inCallback then Doc.nil else Doc.softLine); - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun p -> printExpFunParameter ~customLayout p cmtTbl) - parameters); - ] - in - Doc.group - (Doc.concat - [ - maybeAsyncLparen; - (if shouldHug || inCallback then printedParamaters - else - Doc.concat - [Doc.indent printedParamaters; Doc.trailingComma; Doc.softLine]); - Doc.rparen; - ]) - -and printExpFunParameter ~customLayout parameter cmtTbl = - match parameter with - | ParsetreeViewer.NewTypes {attrs; locs = lbls} -> - Doc.group - (Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - Doc.text "type "; - Doc.join ~sep:Doc.space - (List.map - (fun lbl -> - printComments - (printIdentLike lbl.Asttypes.txt) - cmtTbl lbl.Asttypes.loc) - lbls); - ]) - | Parameter {attrs; lbl; defaultExpr; pat = pattern} -> - let isUncurried, attrs = ParsetreeViewer.processUncurriedAttribute attrs in - let uncurried = - if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil - in - let attrs = printAttributes ~customLayout attrs cmtTbl in - (* =defaultValue *) - let defaultExprDoc = - match defaultExpr with - | Some expr -> - Doc.concat - [Doc.text "="; printExpressionWithComments ~customLayout expr cmtTbl] - | None -> Doc.nil - in - (* ~from as hometown - * ~from -> punning *) - let labelWithPattern = - match (lbl, pattern) with - | Asttypes.Nolabel, pattern -> printPattern ~customLayout pattern cmtTbl - | ( (Asttypes.Labelled lbl | Optional lbl), - { - ppat_desc = Ppat_var stringLoc; - ppat_attributes = [] | [({Location.txt = "ns.namedArgLoc"}, _)]; - } ) - when lbl = stringLoc.txt -> - (* ~d *) - Doc.concat [Doc.text "~"; printIdentLike lbl] - | ( (Asttypes.Labelled lbl | Optional lbl), - { - ppat_desc = Ppat_constraint ({ppat_desc = Ppat_var {txt}}, typ); - ppat_attributes = [] | [({Location.txt = "ns.namedArgLoc"}, _)]; - } ) - when lbl = txt -> - (* ~d: e *) - Doc.concat - [ - Doc.text "~"; - printIdentLike lbl; - Doc.text ": "; - printTypExpr ~customLayout typ cmtTbl; - ] - | (Asttypes.Labelled lbl | Optional lbl), pattern -> - (* ~b as c *) + let inCallback = + match inCallback with FitsOnOneLine -> true | _ -> false + in + let maybeAsyncLparen = + let lparen = if uncurried then Doc.text "(. " else Doc.lparen in + if async then addAsync lparen else lparen + in + let shouldHug = ParsetreeViewer.parametersShouldHug parameters in + let printedParamaters = Doc.concat [ - Doc.text "~"; - printIdentLike lbl; - Doc.text " as "; - printPattern ~customLayout pattern cmtTbl; + (if shouldHug || inCallback then Doc.nil else Doc.softLine); + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun p -> printExpFunParameter ~customLayout p cmtTbl) + parameters); ] - in - let optionalLabelSuffix = - match (lbl, defaultExpr) with - | Asttypes.Optional _, None -> Doc.text "=?" - | _ -> Doc.nil - in - let doc = + in Doc.group (Doc.concat [ - uncurried; - attrs; - labelWithPattern; - defaultExprDoc; - optionalLabelSuffix; + maybeAsyncLparen; + (if shouldHug || inCallback then printedParamaters + else + Doc.concat + [ + Doc.indent printedParamaters; Doc.trailingComma; Doc.softLine; + ]); + Doc.rparen; ]) - in - let cmtLoc = - match defaultExpr with - | None -> ( - match pattern.ppat_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> - {loc with loc_end = pattern.ppat_loc.loc_end} - | _ -> pattern.ppat_loc) - | Some expr -> - let startPos = - match pattern.ppat_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> loc.loc_start - | _ -> pattern.ppat_loc.loc_start - in - { - pattern.ppat_loc with - loc_start = startPos; - loc_end = expr.pexp_loc.loc_end; - } - in - printComments doc cmtTbl cmtLoc + +and printExpFunParameter ~customLayout parameter cmtTbl = + match parameter with + | ParsetreeViewer.NewTypes { attrs; locs = lbls } -> + Doc.group + (Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + Doc.text "type "; + Doc.join ~sep:Doc.space + (List.map + (fun lbl -> + printComments + (printIdentLike lbl.Asttypes.txt) + cmtTbl lbl.Asttypes.loc) + lbls); + ]) + | Parameter { attrs; lbl; defaultExpr; pat = pattern } -> + let isUncurried, attrs = + ParsetreeViewer.processUncurriedAttribute attrs + in + let uncurried = + if isUncurried then Doc.concat [ Doc.dot; Doc.space ] else Doc.nil + in + let attrs = printAttributes ~customLayout attrs cmtTbl in + (* =defaultValue *) + let defaultExprDoc = + match defaultExpr with + | Some expr -> + Doc.concat + [ + Doc.text "="; + printExpressionWithComments ~customLayout expr cmtTbl; + ] + | None -> Doc.nil + in + (* ~from as hometown + * ~from -> punning *) + let labelWithPattern = + match (lbl, pattern) with + | Asttypes.Nolabel, pattern -> printPattern ~customLayout pattern cmtTbl + | ( (Asttypes.Labelled lbl | Optional lbl), + { + ppat_desc = Ppat_var stringLoc; + ppat_attributes = + [] | [ ({ Location.txt = "ns.namedArgLoc" }, _) ]; + } ) + when lbl = stringLoc.txt -> + (* ~d *) + Doc.concat [ Doc.text "~"; printIdentLike lbl ] + | ( (Asttypes.Labelled lbl | Optional lbl), + { + ppat_desc = Ppat_constraint ({ ppat_desc = Ppat_var { txt } }, typ); + ppat_attributes = + [] | [ ({ Location.txt = "ns.namedArgLoc" }, _) ]; + } ) + when lbl = txt -> + (* ~d: e *) + Doc.concat + [ + Doc.text "~"; + printIdentLike lbl; + Doc.text ": "; + printTypExpr ~customLayout typ cmtTbl; + ] + | (Asttypes.Labelled lbl | Optional lbl), pattern -> + (* ~b as c *) + Doc.concat + [ + Doc.text "~"; + printIdentLike lbl; + Doc.text " as "; + printPattern ~customLayout pattern cmtTbl; + ] + in + let optionalLabelSuffix = + match (lbl, defaultExpr) with + | Asttypes.Optional _, None -> Doc.text "=?" + | _ -> Doc.nil + in + let doc = + Doc.group + (Doc.concat + [ + uncurried; + attrs; + labelWithPattern; + defaultExprDoc; + optionalLabelSuffix; + ]) + in + let cmtLoc = + match defaultExpr with + | None -> ( + match pattern.ppat_attributes with + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _ -> + { loc with loc_end = pattern.ppat_loc.loc_end } + | _ -> pattern.ppat_loc) + | Some expr -> + let startPos = + match pattern.ppat_attributes with + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _ -> + loc.loc_start + | _ -> pattern.ppat_loc.loc_start + in + { + pattern.ppat_loc with + loc_start = startPos; + loc_end = expr.pexp_loc.loc_end; + } + in + printComments doc cmtTbl cmtLoc and printExpressionBlock ~customLayout ~braces expr cmtTbl = let rec collectRows acc expr = match expr.Parsetree.pexp_desc with | Parsetree.Pexp_letmodule (modName, modExpr, expr2) -> - let name = - let doc = Doc.text modName.txt in - printComments doc cmtTbl modName.loc - in - let letModuleDoc = - Doc.concat - [ - Doc.text "module "; - name; - Doc.text " = "; - printModExpr ~customLayout modExpr cmtTbl; - ] - in - let loc = {expr.pexp_loc with loc_end = modExpr.pmod_loc.loc_end} in - collectRows ((loc, letModuleDoc) :: acc) expr2 + let name = + let doc = Doc.text modName.txt in + printComments doc cmtTbl modName.loc + in + let letModuleDoc = + Doc.concat + [ + Doc.text "module "; + name; + Doc.text " = "; + printModExpr ~customLayout modExpr cmtTbl; + ] + in + let loc = { expr.pexp_loc with loc_end = modExpr.pmod_loc.loc_end } in + collectRows ((loc, letModuleDoc) :: acc) expr2 | Pexp_letexception (extensionConstructor, expr2) -> - let loc = let loc = - {expr.pexp_loc with loc_end = extensionConstructor.pext_loc.loc_end} + let loc = + { + expr.pexp_loc with + loc_end = extensionConstructor.pext_loc.loc_end; + } + in + match getFirstLeadingComment cmtTbl loc with + | None -> loc + | Some comment -> + let cmtLoc = Comment.loc comment in + { cmtLoc with loc_end = loc.loc_end } in - match getFirstLeadingComment cmtTbl loc with - | None -> loc - | Some comment -> - let cmtLoc = Comment.loc comment in - {cmtLoc with loc_end = loc.loc_end} - in - let letExceptionDoc = - printExceptionDef ~customLayout extensionConstructor cmtTbl - in - collectRows ((loc, letExceptionDoc) :: acc) expr2 + let letExceptionDoc = + printExceptionDef ~customLayout extensionConstructor cmtTbl + in + collectRows ((loc, letExceptionDoc) :: acc) expr2 | Pexp_open (overrideFlag, longidentLoc, expr2) -> - let openDoc = - Doc.concat - [ - Doc.text "open"; - printOverrideFlag overrideFlag; - Doc.space; - printLongidentLocation longidentLoc cmtTbl; - ] - in - let loc = {expr.pexp_loc with loc_end = longidentLoc.loc.loc_end} in - collectRows ((loc, openDoc) :: acc) expr2 + let openDoc = + Doc.concat + [ + Doc.text "open"; + printOverrideFlag overrideFlag; + Doc.space; + printLongidentLocation longidentLoc cmtTbl; + ] + in + let loc = { expr.pexp_loc with loc_end = longidentLoc.loc.loc_end } in + collectRows ((loc, openDoc) :: acc) expr2 | Pexp_sequence (expr1, expr2) -> - let exprDoc = - let doc = printExpression ~customLayout expr1 cmtTbl in - match Parens.expr expr1 with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr1 braces - | Nothing -> doc - in - let loc = expr1.pexp_loc in - collectRows ((loc, exprDoc) :: acc) expr2 + let exprDoc = + let doc = printExpression ~customLayout expr1 cmtTbl in + match Parens.expr expr1 with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr1 braces + | Nothing -> doc + in + let loc = expr1.pexp_loc in + collectRows ((loc, exprDoc) :: acc) expr2 | Pexp_let (recFlag, valueBindings, expr2) -> ( - let loc = let loc = - match (valueBindings, List.rev valueBindings) with - | vb :: _, lastVb :: _ -> - {vb.pvb_loc with loc_end = lastVb.pvb_loc.loc_end} - | _ -> Location.none + let loc = + match (valueBindings, List.rev valueBindings) with + | vb :: _, lastVb :: _ -> + { vb.pvb_loc with loc_end = lastVb.pvb_loc.loc_end } + | _ -> Location.none + in + match getFirstLeadingComment cmtTbl loc with + | None -> loc + | Some comment -> + let cmtLoc = Comment.loc comment in + { cmtLoc with loc_end = loc.loc_end } in - match getFirstLeadingComment cmtTbl loc with - | None -> loc - | Some comment -> - let cmtLoc = Comment.loc comment in - {cmtLoc with loc_end = loc.loc_end} - in - let recFlag = - match recFlag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - let letDoc = - printValueBindings ~customLayout ~recFlag valueBindings cmtTbl - in - (* let () = { - * let () = foo() - * () - * } - * We don't need to print the () on the last line of the block - *) - match expr2.pexp_desc with - | Pexp_construct ({txt = Longident.Lident "()"}, _) -> - List.rev ((loc, letDoc) :: acc) - | _ -> collectRows ((loc, letDoc) :: acc) expr2) + let recFlag = + match recFlag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + let letDoc = + printValueBindings ~customLayout ~recFlag valueBindings cmtTbl + in + (* let () = { + * let () = foo() + * () + * } + * We don't need to print the () on the last line of the block + *) + match expr2.pexp_desc with + | Pexp_construct ({ txt = Longident.Lident "()" }, _) -> + List.rev ((loc, letDoc) :: acc) + | _ -> collectRows ((loc, letDoc) :: acc) expr2) | _ -> - let exprDoc = - let doc = printExpression ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - List.rev ((expr.pexp_loc, exprDoc) :: acc) + let exprDoc = + let doc = printExpression ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + List.rev ((expr.pexp_loc, exprDoc) :: acc) in let rows = collectRows [] expr in let block = @@ -57894,7 +58155,7 @@ and printExpressionBlock ~customLayout ~braces expr cmtTbl = Doc.concat [ Doc.lbrace; - Doc.indent (Doc.concat [Doc.line; block]); + Doc.indent (Doc.concat [ Doc.line; block ]); Doc.line; Doc.rbrace; ] @@ -57925,27 +58186,25 @@ and printBraces doc expr bracesLoc = match expr.Parsetree.pexp_desc with | Pexp_letmodule _ | Pexp_letexception _ | Pexp_let _ | Pexp_open _ | Pexp_sequence _ -> - (* already has braces *) - doc + (* already has braces *) + doc | _ -> - Doc.breakableGroup ~forceBreak:overMultipleLines - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - (if Parens.bracedExpr expr then addParens doc else doc); - ]); - Doc.softLine; - Doc.rbrace; - ]) + Doc.breakableGroup ~forceBreak:overMultipleLines + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.softLine; + (if Parens.bracedExpr expr then addParens doc else doc); + ]); + Doc.softLine; + Doc.rbrace; + ]) and printOverrideFlag overrideFlag = - match overrideFlag with - | Asttypes.Override -> Doc.text "!" - | Fresh -> Doc.nil + match overrideFlag with Asttypes.Override -> Doc.text "!" | Fresh -> Doc.nil and printDirectionFlag flag = match flag with @@ -57953,39 +58212,41 @@ and printDirectionFlag flag = | Asttypes.Upto -> Doc.text " to " and printExpressionRecordRow ~customLayout (lbl, expr) cmtTbl punningAllowed = - let cmtLoc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in + let cmtLoc = { lbl.loc with loc_end = expr.pexp_loc.loc_end } in let doc = Doc.group (match expr.pexp_desc with - | Pexp_ident {txt = Lident key; loc = _keyLoc} + | Pexp_ident { txt = Lident key; loc = _keyLoc } when punningAllowed && Longident.last lbl.txt = key -> - (* print punned field *) - Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - printOptionalLabel expr.pexp_attributes; - printLidentPath lbl cmtTbl; - ] + (* print punned field *) + Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + printOptionalLabel expr.pexp_attributes; + printLidentPath lbl cmtTbl; + ] | _ -> - Doc.concat - [ - printLidentPath lbl cmtTbl; - Doc.text ": "; - printOptionalLabel expr.pexp_attributes; - (let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); - ]) + Doc.concat + [ + printLidentPath lbl cmtTbl; + Doc.text ": "; + printOptionalLabel expr.pexp_attributes; + (let doc = + printExpressionWithComments ~customLayout expr cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + ]) in printComments doc cmtTbl cmtLoc and printBsObjectRow ~customLayout (lbl, expr) cmtTbl = - let cmtLoc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in + let cmtLoc = { lbl.loc with loc_end = expr.pexp_loc.loc_end } in let lblDoc = let doc = - Doc.concat [Doc.text "\""; printLongident lbl.txt; Doc.text "\""] + Doc.concat [ Doc.text "\""; printLongident lbl.txt; Doc.text "\"" ] in printComments doc cmtTbl lbl.loc in @@ -58014,46 +58275,80 @@ and printAttributes ?loc ?(inline = false) ~customLayout match ParsetreeViewer.filterParsingAttrs attrs with | [] -> Doc.nil | attrs -> - let lineBreak = - match loc with - | None -> Doc.line - | Some loc -> ( - match List.rev attrs with - | ({loc = firstLoc}, _) :: _ - when loc.loc_start.pos_lnum > firstLoc.loc_end.pos_lnum -> - Doc.hardLine - | _ -> Doc.line) - in - Doc.concat - [ - Doc.group - (Doc.joinWithSep - (List.map - (fun attr -> printAttribute ~customLayout attr cmtTbl) - attrs)); - (if inline then Doc.space else lineBreak); - ] + let lineBreak = + match loc with + | None -> Doc.line + | Some loc -> ( + match List.rev attrs with + | ({ loc = firstLoc }, _) :: _ + when loc.loc_start.pos_lnum > firstLoc.loc_end.pos_lnum -> + Doc.hardLine + | _ -> Doc.line) + in + Doc.concat + [ + Doc.group + (Doc.joinWithSep + (List.map + (fun attr -> printAttribute ~customLayout attr cmtTbl) + attrs)); + (if inline then Doc.space else lineBreak); + ] and printPayload ~customLayout (payload : Parsetree.payload) cmtTbl = match payload with | PStr [] -> Doc.nil - | PStr [{pstr_desc = Pstr_eval (expr, attrs)}] -> - let exprDoc = printExpressionWithComments ~customLayout expr cmtTbl in - let needsParens = - match attrs with - | [] -> false - | _ -> true - in - let shouldHug = ParsetreeViewer.isHuggableExpression expr in - if shouldHug then + | PStr [ { pstr_desc = Pstr_eval (expr, attrs) } ] -> + let exprDoc = printExpressionWithComments ~customLayout expr cmtTbl in + let needsParens = match attrs with [] -> false | _ -> true in + let shouldHug = ParsetreeViewer.isHuggableExpression expr in + if shouldHug then + Doc.concat + [ + Doc.lparen; + printAttributes ~customLayout attrs cmtTbl; + (if needsParens then addParens exprDoc else exprDoc); + Doc.rparen; + ] + else + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + printAttributes ~customLayout attrs cmtTbl; + (if needsParens then addParens exprDoc else exprDoc); + ]); + Doc.softLine; + Doc.rparen; + ] + | PStr [ ({ pstr_desc = Pstr_value (_recFlag, _bindings) } as si) ] -> + addParens (printStructureItem ~customLayout si cmtTbl) + | PStr structure -> addParens (printStructure ~customLayout structure cmtTbl) + | PTyp typ -> Doc.concat [ Doc.lparen; - printAttributes ~customLayout attrs cmtTbl; - (if needsParens then addParens exprDoc else exprDoc); + Doc.text ":"; + Doc.indent + (Doc.concat [ Doc.line; printTypExpr ~customLayout typ cmtTbl ]); + Doc.softLine; Doc.rparen; ] - else + | PPat (pat, optExpr) -> + let whenDoc = + match optExpr with + | Some expr -> + Doc.concat + [ + Doc.line; + Doc.text "if "; + printExpressionWithComments ~customLayout expr cmtTbl; + ] + | None -> Doc.nil + in Doc.concat [ Doc.lparen; @@ -58061,217 +58356,193 @@ and printPayload ~customLayout (payload : Parsetree.payload) cmtTbl = (Doc.concat [ Doc.softLine; - printAttributes ~customLayout attrs cmtTbl; - (if needsParens then addParens exprDoc else exprDoc); + Doc.text "? "; + printPattern ~customLayout pat cmtTbl; + whenDoc; ]); Doc.softLine; Doc.rparen; ] - | PStr [({pstr_desc = Pstr_value (_recFlag, _bindings)} as si)] -> - addParens (printStructureItem ~customLayout si cmtTbl) - | PStr structure -> addParens (printStructure ~customLayout structure cmtTbl) - | PTyp typ -> - Doc.concat - [ - Doc.lparen; - Doc.text ":"; - Doc.indent - (Doc.concat [Doc.line; printTypExpr ~customLayout typ cmtTbl]); - Doc.softLine; - Doc.rparen; - ] - | PPat (pat, optExpr) -> - let whenDoc = - match optExpr with - | Some expr -> - Doc.concat - [ - Doc.line; - Doc.text "if "; - printExpressionWithComments ~customLayout expr cmtTbl; - ] - | None -> Doc.nil - in - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.text "? "; - printPattern ~customLayout pat cmtTbl; - whenDoc; - ]); - Doc.softLine; - Doc.rparen; - ] | PSig signature -> - Doc.concat - [ - Doc.lparen; - Doc.text ":"; - Doc.indent - (Doc.concat [Doc.line; printSignature ~customLayout signature cmtTbl]); - Doc.softLine; - Doc.rparen; - ] + Doc.concat + [ + Doc.lparen; + Doc.text ":"; + Doc.indent + (Doc.concat + [ Doc.line; printSignature ~customLayout signature cmtTbl ]); + Doc.softLine; + Doc.rparen; + ] and printAttribute ?(standalone = false) ~customLayout ((id, payload) : Parsetree.attribute) cmtTbl = match (id, payload) with - | ( {txt = "ns.doc"}, + | ( { txt = "ns.doc" }, PStr [ { pstr_desc = - Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (txt, _))}, _); + Pstr_eval + ({ pexp_desc = Pexp_constant (Pconst_string (txt, _)) }, _); }; ] ) -> - ( Doc.concat - [ - Doc.text (if standalone then "/***" else "/**"); - Doc.text txt; - Doc.text "*/"; - ], - Doc.hardLine ) + ( Doc.concat + [ + Doc.text (if standalone then "/***" else "/**"); + Doc.text txt; + Doc.text "*/"; + ], + Doc.hardLine ) | _ -> - ( Doc.group - (Doc.concat - [ - Doc.text (if standalone then "@@" else "@"); - Doc.text (convertBsExternalAttribute id.txt); - printPayload ~customLayout payload cmtTbl; - ]), - Doc.line ) + ( Doc.group + (Doc.concat + [ + Doc.text (if standalone then "@@" else "@"); + Doc.text (convertBsExternalAttribute id.txt); + printPayload ~customLayout payload cmtTbl; + ]), + Doc.line ) and printModExpr ~customLayout modExpr cmtTbl = let doc = match modExpr.pmod_desc with | Pmod_ident longidentLoc -> printLongidentLocation longidentLoc cmtTbl | Pmod_structure [] -> - let shouldBreak = - modExpr.pmod_loc.loc_start.pos_lnum < modExpr.pmod_loc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak:shouldBreak - (Doc.concat - [Doc.lbrace; printCommentsInside cmtTbl modExpr.pmod_loc; Doc.rbrace]) + let shouldBreak = + modExpr.pmod_loc.loc_start.pos_lnum + < modExpr.pmod_loc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak:shouldBreak + (Doc.concat + [ + Doc.lbrace; + printCommentsInside cmtTbl modExpr.pmod_loc; + Doc.rbrace; + ]) | Pmod_structure structure -> - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [Doc.softLine; printStructure ~customLayout structure cmtTbl]); - Doc.softLine; - Doc.rbrace; - ]) + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.softLine; + printStructure ~customLayout structure cmtTbl; + ]); + Doc.softLine; + Doc.rbrace; + ]) | Pmod_unpack expr -> - let shouldHug = - match expr.pexp_desc with - | Pexp_let _ -> true - | Pexp_constraint - ({pexp_desc = Pexp_let _}, {ptyp_desc = Ptyp_package _packageType}) - -> - true - | _ -> false - in - let expr, moduleConstraint = - match expr.pexp_desc with - | Pexp_constraint - (expr, {ptyp_desc = Ptyp_package packageType; ptyp_loc}) -> - let packageDoc = - let doc = - printPackageType ~customLayout ~printModuleKeywordAndParens:false - packageType cmtTbl - in - printComments doc cmtTbl ptyp_loc - in - let typeDoc = - Doc.group - (Doc.concat - [Doc.text ":"; Doc.indent (Doc.concat [Doc.line; packageDoc])]) - in - (expr, typeDoc) - | _ -> (expr, Doc.nil) - in - let unpackDoc = + let shouldHug = + match expr.pexp_desc with + | Pexp_let _ -> true + | Pexp_constraint + ( { pexp_desc = Pexp_let _ }, + { ptyp_desc = Ptyp_package _packageType } ) -> + true + | _ -> false + in + let expr, moduleConstraint = + match expr.pexp_desc with + | Pexp_constraint + (expr, { ptyp_desc = Ptyp_package packageType; ptyp_loc }) -> + let packageDoc = + let doc = + printPackageType ~customLayout + ~printModuleKeywordAndParens:false packageType cmtTbl + in + printComments doc cmtTbl ptyp_loc + in + let typeDoc = + Doc.group + (Doc.concat + [ + Doc.text ":"; + Doc.indent (Doc.concat [ Doc.line; packageDoc ]); + ]) + in + (expr, typeDoc) + | _ -> (expr, Doc.nil) + in + let unpackDoc = + Doc.group + (Doc.concat + [ + printExpressionWithComments ~customLayout expr cmtTbl; + moduleConstraint; + ]) + in Doc.group (Doc.concat [ - printExpressionWithComments ~customLayout expr cmtTbl; - moduleConstraint; + Doc.text "unpack("; + (if shouldHug then unpackDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [ Doc.softLine; unpackDoc ]); + Doc.softLine; + ]); + Doc.rparen; ]) - in - Doc.group - (Doc.concat - [ - Doc.text "unpack("; - (if shouldHug then unpackDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [Doc.softLine; unpackDoc]); - Doc.softLine; - ]); - Doc.rparen; - ]) | Pmod_extension extension -> - printExtension ~customLayout ~atModuleLvl:false extension cmtTbl + printExtension ~customLayout ~atModuleLvl:false extension cmtTbl | Pmod_apply _ -> - let args, callExpr = ParsetreeViewer.modExprApply modExpr in - let isUnitSugar = - match args with - | [{pmod_desc = Pmod_structure []}] -> true - | _ -> false - in - let shouldHug = - match args with - | [{pmod_desc = Pmod_structure _}] -> true - | _ -> false - in - Doc.group - (Doc.concat - [ - printModExpr ~customLayout callExpr cmtTbl; - (if isUnitSugar then - printModApplyArg ~customLayout - (List.hd args [@doesNotRaise]) - cmtTbl - else - Doc.concat - [ - Doc.lparen; - (if shouldHug then - printModApplyArg ~customLayout - (List.hd args [@doesNotRaise]) - cmtTbl - else - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun modArg -> - printModApplyArg ~customLayout modArg cmtTbl) - args); - ])); - (if not shouldHug then - Doc.concat [Doc.trailingComma; Doc.softLine] - else Doc.nil); - Doc.rparen; - ]); - ]) + let args, callExpr = ParsetreeViewer.modExprApply modExpr in + let isUnitSugar = + match args with + | [ { pmod_desc = Pmod_structure [] } ] -> true + | _ -> false + in + let shouldHug = + match args with + | [ { pmod_desc = Pmod_structure _ } ] -> true + | _ -> false + in + Doc.group + (Doc.concat + [ + printModExpr ~customLayout callExpr cmtTbl; + (if isUnitSugar then + printModApplyArg ~customLayout + (List.hd args [@doesNotRaise]) + cmtTbl + else + Doc.concat + [ + Doc.lparen; + (if shouldHug then + printModApplyArg ~customLayout + (List.hd args [@doesNotRaise]) + cmtTbl + else + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun modArg -> + printModApplyArg ~customLayout modArg + cmtTbl) + args); + ])); + (if not shouldHug then + Doc.concat [ Doc.trailingComma; Doc.softLine ] + else Doc.nil); + Doc.rparen; + ]); + ]) | Pmod_constraint (modExpr, modType) -> - Doc.concat - [ - printModExpr ~customLayout modExpr cmtTbl; - Doc.text ": "; - printModType ~customLayout modType cmtTbl; - ] + Doc.concat + [ + printModExpr ~customLayout modExpr cmtTbl; + Doc.text ": "; + printModType ~customLayout modType cmtTbl; + ] | Pmod_functor _ -> printModFunctor ~customLayout modExpr cmtTbl in printComments doc cmtTbl modExpr.pmod_loc @@ -58286,51 +58557,52 @@ and printModFunctor ~customLayout modExpr cmtTbl = let returnConstraint, returnModExpr = match returnModExpr.pmod_desc with | Pmod_constraint (modExpr, modType) -> - let constraintDoc = - let doc = printModType ~customLayout modType cmtTbl in - if Parens.modExprFunctorConstraint modType then addParens doc else doc - in - let modConstraint = Doc.concat [Doc.text ": "; constraintDoc] in - (modConstraint, printModExpr ~customLayout modExpr cmtTbl) + let constraintDoc = + let doc = printModType ~customLayout modType cmtTbl in + if Parens.modExprFunctorConstraint modType then addParens doc else doc + in + let modConstraint = Doc.concat [ Doc.text ": "; constraintDoc ] in + (modConstraint, printModExpr ~customLayout modExpr cmtTbl) | _ -> (Doc.nil, printModExpr ~customLayout returnModExpr cmtTbl) in let parametersDoc = match parameters with - | [(attrs, {txt = "*"}, None)] -> - Doc.group - (Doc.concat [printAttributes ~customLayout attrs cmtTbl; Doc.text "()"]) - | [([], {txt = lbl}, None)] -> Doc.text lbl + | [ (attrs, { txt = "*" }, None) ] -> + Doc.group + (Doc.concat + [ printAttributes ~customLayout attrs cmtTbl; Doc.text "()" ]) + | [ ([], { txt = lbl }, None) ] -> Doc.text lbl | parameters -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun param -> - printModFunctorParam ~customLayout param cmtTbl) - parameters); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun param -> + printModFunctorParam ~customLayout param cmtTbl) + parameters); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) in Doc.group (Doc.concat - [parametersDoc; returnConstraint; Doc.text " => "; returnModExpr]) + [ parametersDoc; returnConstraint; Doc.text " => "; returnModExpr ]) and printModFunctorParam ~customLayout (attrs, lbl, optModType) cmtTbl = let cmtLoc = match optModType with | None -> lbl.Asttypes.loc | Some modType -> - {lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end} + { lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end } in let attrs = printAttributes ~customLayout attrs cmtTbl in let lblDoc = @@ -58346,8 +58618,8 @@ and printModFunctorParam ~customLayout (attrs, lbl, optModType) cmtTbl = (match optModType with | None -> Doc.nil | Some modType -> - Doc.concat - [Doc.text ": "; printModType ~customLayout modType cmtTbl]); + Doc.concat + [ Doc.text ": "; printModType ~customLayout modType cmtTbl ]); ]) in printComments doc cmtTbl cmtLoc @@ -58362,22 +58634,25 @@ and printExceptionDef ~customLayout (constr : Parsetree.extension_constructor) let kind = match constr.pext_kind with | Pext_rebind longident -> - Doc.indent - (Doc.concat - [Doc.text " ="; Doc.line; printLongidentLocation longident cmtTbl]) + Doc.indent + (Doc.concat + [ + Doc.text " ="; Doc.line; printLongidentLocation longident cmtTbl; + ]) | Pext_decl (Pcstr_tuple [], None) -> Doc.nil | Pext_decl (args, gadt) -> - let gadtDoc = - match gadt with - | Some typ -> - Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ cmtTbl] - | None -> Doc.nil - in - Doc.concat - [ - printConstructorArguments ~customLayout ~indent:false args cmtTbl; - gadtDoc; - ] + let gadtDoc = + match gadt with + | Some typ -> + Doc.concat + [ Doc.text ": "; printTypExpr ~customLayout typ cmtTbl ] + | None -> Doc.nil + in + Doc.concat + [ + printConstructorArguments ~customLayout ~indent:false args cmtTbl; + gadtDoc; + ] in let name = printComments (Doc.text constr.pext_name.txt) cmtTbl constr.pext_name.loc @@ -58403,27 +58678,30 @@ and printExtensionConstructor ~customLayout let kind = match constr.pext_kind with | Pext_rebind longident -> - Doc.indent - (Doc.concat - [Doc.text " ="; Doc.line; printLongidentLocation longident cmtTbl]) + Doc.indent + (Doc.concat + [ + Doc.text " ="; Doc.line; printLongidentLocation longident cmtTbl; + ]) | Pext_decl (Pcstr_tuple [], None) -> Doc.nil | Pext_decl (args, gadt) -> - let gadtDoc = - match gadt with - | Some typ -> - Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ cmtTbl] - | None -> Doc.nil - in - Doc.concat - [ - printConstructorArguments ~customLayout ~indent:false args cmtTbl; - gadtDoc; - ] + let gadtDoc = + match gadt with + | Some typ -> + Doc.concat + [ Doc.text ": "; printTypExpr ~customLayout typ cmtTbl ] + | None -> Doc.nil + in + Doc.concat + [ + printConstructorArguments ~customLayout ~indent:false args cmtTbl; + gadtDoc; + ] in let name = printComments (Doc.text constr.pext_name.txt) cmtTbl constr.pext_name.loc in - Doc.concat [bar; Doc.group (Doc.concat [attrs; name; kind])] + Doc.concat [ bar; Doc.group (Doc.concat [ attrs; name; kind ]) ] let printTypeParams = printTypeParams ~customLayout:0 let printTypExpr = printTypExpr ~customLayout:0 @@ -58502,82 +58780,6 @@ let print_pattern typed = let doc = Res_printer.printPattern pat Res_comments_table.empty in Res_doc.toString ~width:80 doc -end -module Ext_util : sig -#1 "ext_util.mli" -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val power_2_above : int -> int -> int - -val stats_to_string : Hashtbl.statistics -> string - -end = struct -#1 "ext_util.ml" -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** - {[ - (power_2_above 16 63 = 64) - (power_2_above 16 76 = 128) - ]} -*) -let rec power_2_above x n = - if x >= n then x - else if x * 2 > Sys.max_array_length then x - else power_2_above (x * 2) n - -let stats_to_string - ({ num_bindings; num_buckets; max_bucket_length; bucket_histogram } : - Hashtbl.statistics) = - Printf.sprintf "bindings: %d,buckets: %d, longest: %d, hist:[%s]" num_bindings - num_buckets max_bucket_length - (String.concat "," - (Array.to_list (Array.map string_of_int bucket_histogram))) - end module Hash_gen = struct @@ -81362,7 +81564,7 @@ and expression_desc cxt ~(level : int) f x : cxt = match v with | Float { f } -> Js_number.caml_float_literal_to_js_string f (* attach string here for float constant folding?*) - | Int { i; c = Some c } -> Format.asprintf "/* %s */%ld" (Pprintast.string_of_int_as_char c) i + | Int { i; c = Some c } -> Format.asprintf "/* %s */%ld" (Ext_util.string_of_int_as_char c) i | Int { i; c = None } -> Int32.to_string i (* check , js convention with ocaml lexical convention *) @@ -93784,13 +93986,6 @@ end = struct open Format open Asttypes -let string_of_int_as_char i = - if i >= 0 && i <= 255 - then - Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) - else - Printf.sprintf "\'\\%d\'" i - let rec struct_const ppf (cst : Lam_constant.t) = match cst with | Const_js_true -> fprintf ppf "#true" @@ -93799,7 +93994,7 @@ let rec struct_const ppf (cst : Lam_constant.t) = | Const_module_alias -> fprintf ppf "#alias" | Const_js_undefined -> fprintf ppf "#undefined" | Const_int { i } -> fprintf ppf "%ld" i - | Const_char i -> fprintf ppf "%s" (string_of_int_as_char i) + | Const_char i -> fprintf ppf "%s" (Ext_util.string_of_int_as_char i) | Const_string { s } -> fprintf ppf "%S" s | Const_float f -> fprintf ppf "%s" f | Const_int64 n -> fprintf ppf "%LiL" n @@ -273319,37 +273514,35 @@ open Asttypes open Parsetree type jsxConfig = { - mutable version: int; - mutable module_: string; - mutable mode: string; - mutable nestedModules: string list; - mutable hasReactComponent: bool; + mutable version : int; + mutable module_ : string; + mutable mode : string; + mutable nestedModules : string list; + mutable hasReactComponent : bool; } (* Helper method to look up the [@react.component] attribute *) let hasAttr (loc, _) = loc.txt = "react.component" (* Iterate over the attributes and try to find the [@react.component] attribute *) -let hasAttrOnBinding {pvb_attributes} = +let hasAttrOnBinding { pvb_attributes } = List.find_opt hasAttr pvb_attributes <> None let coreTypeOfAttrs attributes = List.find_map - (fun ({txt}, payload) -> + (fun ({ txt }, payload) -> match (txt, payload) with | "react.component", PTyp coreType -> Some coreType | _ -> None) attributes -let typVarsOfCoreType {ptyp_desc} = +let typVarsOfCoreType { ptyp_desc } = match ptyp_desc with | Ptyp_constr (_, coreTypes) -> - List.filter - (fun {ptyp_desc} -> - match ptyp_desc with - | Ptyp_var _ -> true - | _ -> false) - coreTypes + List.filter + (fun { ptyp_desc } -> + match ptyp_desc with Ptyp_var _ -> true | _ -> false) + coreTypes | _ -> [] let raiseError ~loc msg = Location.raise_errorf ~loc msg @@ -273370,25 +273563,13 @@ open Parsetree open Longident let nolabel = Nolabel - let labelled str = Labelled str - let optional str = Optional str - -let isOptional str = - match str with - | Optional _ -> true - | _ -> false - -let isLabelled str = - match str with - | Labelled _ -> true - | _ -> false +let isOptional str = match str with Optional _ -> true | _ -> false +let isLabelled str = match str with Labelled _ -> true | _ -> false let getLabel str = - match str with - | Optional str | Labelled str -> str - | Nolabel -> "" + match str with Optional str | Labelled str -> str | Nolabel -> "" let optionIdent = Lident "option" @@ -273401,12 +273582,11 @@ let safeTypeFromValue valueStr = else "T" ^ valueStr let keyType loc = - Typ.constr ~loc {loc; txt = optionIdent} - [Typ.constr ~loc {loc; txt = Lident "string"} []] + Typ.constr ~loc { loc; txt = optionIdent } + [ Typ.constr ~loc { loc; txt = Lident "string" } [] ] type 'a children = ListLiteral of 'a | Exact of 'a - -type componentConfig = {propsName: string} +type componentConfig = { propsName : string } (* if children is a list, convert it to an array while mapping each element. If not, just map over it, as usual *) let transformChildrenIfListUpper ~loc ~mapper theList = @@ -273414,16 +273594,16 @@ let transformChildrenIfListUpper ~loc ~mapper theList = (* not in the sense of converting a list to an array; convert the AST reprensentation of a list to the AST reprensentation of an array *) match theList with - | {pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} -> ( - match accum with - | [singleElement] -> Exact singleElement - | accum -> ListLiteral (Exp.array ~loc (List.rev accum))) + | { pexp_desc = Pexp_construct ({ txt = Lident "[]" }, None) } -> ( + match accum with + | [ singleElement ] -> Exact singleElement + | accum -> ListLiteral (Exp.array ~loc (List.rev accum))) | { pexp_desc = Pexp_construct - ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple [v; acc]}); + ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple [ v; acc ] }); } -> - transformChildren_ acc (mapper.expr mapper v :: accum) + transformChildren_ acc (mapper.expr mapper v :: accum) | notAList -> Exact (mapper.expr mapper notAList) in transformChildren_ theList [] @@ -273433,14 +273613,14 @@ let transformChildrenIfList ~loc ~mapper theList = (* not in the sense of converting a list to an array; convert the AST reprensentation of a list to the AST reprensentation of an array *) match theList with - | {pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} -> - Exp.array ~loc (List.rev accum) + | { pexp_desc = Pexp_construct ({ txt = Lident "[]" }, None) } -> + Exp.array ~loc (List.rev accum) | { pexp_desc = Pexp_construct - ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple [v; acc]}); + ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple [ v; acc ] }); } -> - transformChildren_ acc (mapper.expr mapper v :: accum) + transformChildren_ acc (mapper.expr mapper v :: accum) | notAList -> mapper.expr mapper notAList in transformChildren_ theList [] @@ -273449,11 +273629,13 @@ let extractChildren ?(removeLastPositionUnit = false) ~loc propsAndChildren = let rec allButLast_ lst acc = match lst with | [] -> [] - | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] -> - acc - | (Nolabel, {pexp_loc}) :: _rest -> - React_jsx_common.raiseError ~loc:pexp_loc - "JSX: found non-labelled argument before the last position" + | [ + (Nolabel, { pexp_desc = Pexp_construct ({ txt = Lident "()" }, None) }); + ] -> + acc + | (Nolabel, { pexp_loc }) :: _rest -> + React_jsx_common.raiseError ~loc:pexp_loc + "JSX: found non-labelled argument before the last position" | arg :: rest -> allButLast_ rest (arg :: acc) in let allButLast lst = allButLast_ lst [] |> List.rev in @@ -273463,20 +273645,20 @@ let extractChildren ?(removeLastPositionUnit = false) ~loc propsAndChildren = propsAndChildren with | [], props -> - (* no children provided? Place a placeholder list *) - ( Exp.construct ~loc {loc; txt = Lident "[]"} None, - if removeLastPositionUnit then allButLast props else props ) - | [(_, childrenExpr)], props -> - (childrenExpr, if removeLastPositionUnit then allButLast props else props) + (* no children provided? Place a placeholder list *) + ( Exp.construct ~loc { loc; txt = Lident "[]" } None, + if removeLastPositionUnit then allButLast props else props ) + | [ (_, childrenExpr) ], props -> + (childrenExpr, if removeLastPositionUnit then allButLast props else props) | _ -> - React_jsx_common.raiseError ~loc - "JSX: somehow there's more than one `children` label" + React_jsx_common.raiseError ~loc + "JSX: somehow there's more than one `children` label" let unerasableIgnore loc = - ( {loc; txt = "warning"}, - PStr [Str.eval (Exp.constant (Pconst_string ("-16", None)))] ) + ( { loc; txt = "warning" }, + PStr [ Str.eval (Exp.constant (Pconst_string ("-16", None))) ] ) -let merlinFocus = ({loc = Location.none; txt = "merlin.focus"}, PStr []) +let merlinFocus = ({ loc = Location.none; txt = "merlin.focus" }, PStr []) (* Helper method to filter out any attribute that isn't [@react.component] *) let otherAttrsPure (loc, _) = loc.txt <> "react.component" @@ -273484,59 +273666,59 @@ let otherAttrsPure (loc, _) = loc.txt <> "react.component" (* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *) let rec getFnName binding = match binding with - | {ppat_desc = Ppat_var {txt}} -> txt - | {ppat_desc = Ppat_constraint (pat, _)} -> getFnName pat - | {ppat_loc} -> - React_jsx_common.raiseError ~loc:ppat_loc - "react.component calls cannot be destructured." + | { ppat_desc = Ppat_var { txt } } -> txt + | { ppat_desc = Ppat_constraint (pat, _) } -> getFnName pat + | { ppat_loc } -> + React_jsx_common.raiseError ~loc:ppat_loc + "react.component calls cannot be destructured." let makeNewBinding binding expression newName = match binding with - | {pvb_pat = {ppat_desc = Ppat_var ppat_var} as pvb_pat} -> - { - binding with - pvb_pat = - {pvb_pat with ppat_desc = Ppat_var {ppat_var with txt = newName}}; - pvb_expr = expression; - pvb_attributes = [merlinFocus]; - } - | {pvb_loc} -> - React_jsx_common.raiseError ~loc:pvb_loc - "react.component calls cannot be destructured." + | { pvb_pat = { ppat_desc = Ppat_var ppat_var } as pvb_pat } -> + { + binding with + pvb_pat = + { pvb_pat with ppat_desc = Ppat_var { ppat_var with txt = newName } }; + pvb_expr = expression; + pvb_attributes = [ merlinFocus ]; + } + | { pvb_loc } -> + React_jsx_common.raiseError ~loc:pvb_loc + "react.component calls cannot be destructured." (* Lookup the value of `props` otherwise raise Invalid_argument error *) let getPropsNameValue _acc (loc, exp) = match (loc, exp) with - | {txt = Lident "props"}, {pexp_desc = Pexp_ident {txt = Lident str}} -> - {propsName = str} - | {txt; loc}, _ -> - React_jsx_common.raiseError ~loc - "react.component only accepts props as an option, given: { %s }" - (Longident.last txt) + | { txt = Lident "props" }, { pexp_desc = Pexp_ident { txt = Lident str } } -> + { propsName = str } + | { txt; loc }, _ -> + React_jsx_common.raiseError ~loc + "react.component only accepts props as an option, given: { %s }" + (Longident.last txt) (* Lookup the `props` record or string as part of [@react.component] and store the name for use when rewriting *) let getPropsAttr payload = - let defaultProps = {propsName = "Props"} in + let defaultProps = { propsName = "Props" } in match payload with | Some (PStr ({ pstr_desc = - Pstr_eval ({pexp_desc = Pexp_record (recordFields, None)}, _); + Pstr_eval ({ pexp_desc = Pexp_record (recordFields, None) }, _); } :: _rest)) -> - List.fold_left getPropsNameValue defaultProps recordFields + List.fold_left getPropsNameValue defaultProps recordFields | Some (PStr ({ pstr_desc = - Pstr_eval ({pexp_desc = Pexp_ident {txt = Lident "props"}}, _); + Pstr_eval ({ pexp_desc = Pexp_ident { txt = Lident "props" } }, _); } :: _rest)) -> - {propsName = "props"} - | Some (PStr ({pstr_desc = Pstr_eval (_, _); pstr_loc} :: _rest)) -> - React_jsx_common.raiseError ~loc:pstr_loc - "react.component accepts a record config with props as an options." + { propsName = "props" } + | Some (PStr ({ pstr_desc = Pstr_eval (_, _); pstr_loc } :: _rest)) -> + React_jsx_common.raiseError ~loc:pstr_loc + "react.component accepts a record config with props as an options." | _ -> defaultProps (* Plucks the label, loc, and type_ from an AST node *) @@ -273566,7 +273748,7 @@ let makeModuleName fileName nestedModules fnName = | "", nestedModules, fnName -> List.rev (fnName :: nestedModules) | fileName, nestedModules, "make" -> fileName :: List.rev nestedModules | fileName, nestedModules, fnName -> - fileName :: List.rev (fnName :: nestedModules) + fileName :: List.rev (fnName :: nestedModules) in let fullModuleName = String.concat "$" fullModuleName in fullModuleName @@ -273581,68 +273763,71 @@ let makeModuleName fileName nestedModules fnName = let rec recursivelyMakeNamedArgsForExternal list args = match list with | (label, default, loc, interiorType) :: tl -> - recursivelyMakeNamedArgsForExternal tl - (Typ.arrow ~loc label - (match (label, interiorType, default) with - (* ~foo=1 *) - | label, None, Some _ -> - { - ptyp_desc = Ptyp_var (safeTypeFromValue label); - ptyp_loc = loc; - ptyp_attributes = []; - } - (* ~foo: int=1 *) - | _label, Some type_, Some _ -> type_ - (* ~foo: option(int)=? *) - | ( label, - Some {ptyp_desc = Ptyp_constr ({txt = Lident "option"}, [type_])}, - _ ) - | ( label, - Some + recursivelyMakeNamedArgsForExternal tl + (Typ.arrow ~loc label + (match (label, interiorType, default) with + (* ~foo=1 *) + | label, None, Some _ -> { - ptyp_desc = - Ptyp_constr - ({txt = Ldot (Lident "*predef*", "option")}, [type_]); - }, - _ ) - (* ~foo: int=? - note this isnt valid. but we want to get a type error *) - | label, Some type_, _ - when isOptional label -> - type_ - (* ~foo=? *) - | label, None, _ when isOptional label -> - { - ptyp_desc = Ptyp_var (safeTypeFromValue label); - ptyp_loc = loc; - ptyp_attributes = []; - } - (* ~foo *) - | label, None, _ -> - { - ptyp_desc = Ptyp_var (safeTypeFromValue label); - ptyp_loc = loc; - ptyp_attributes = []; - } - | _label, Some type_, _ -> type_) - args) + ptyp_desc = Ptyp_var (safeTypeFromValue label); + ptyp_loc = loc; + ptyp_attributes = []; + } + (* ~foo: int=1 *) + | _label, Some type_, Some _ -> type_ + (* ~foo: option(int)=? *) + | ( label, + Some + { + ptyp_desc = Ptyp_constr ({ txt = Lident "option" }, [ type_ ]); + }, + _ ) + | ( label, + Some + { + ptyp_desc = + Ptyp_constr + ({ txt = Ldot (Lident "*predef*", "option") }, [ type_ ]); + }, + _ ) + (* ~foo: int=? - note this isnt valid. but we want to get a type error *) + | label, Some type_, _ + when isOptional label -> + type_ + (* ~foo=? *) + | label, None, _ when isOptional label -> + { + ptyp_desc = Ptyp_var (safeTypeFromValue label); + ptyp_loc = loc; + ptyp_attributes = []; + } + (* ~foo *) + | label, None, _ -> + { + ptyp_desc = Ptyp_var (safeTypeFromValue label); + ptyp_loc = loc; + ptyp_attributes = []; + } + | _label, Some type_, _ -> type_) + args) | [] -> args (* Build an AST node for the [@bs.obj] representing props for a component *) let makePropsValue fnName loc namedArgListWithKeyAndRef propsType = let propsName = fnName ^ "Props" in { - pval_name = {txt = propsName; loc}; + pval_name = { txt = propsName; loc }; pval_type = recursivelyMakeNamedArgsForExternal namedArgListWithKeyAndRef (Typ.arrow nolabel { - ptyp_desc = Ptyp_constr ({txt = Lident "unit"; loc}, []); + ptyp_desc = Ptyp_constr ({ txt = Lident "unit"; loc }, []); ptyp_loc = loc; ptyp_attributes = []; } propsType); - pval_prim = [""]; - pval_attributes = [({txt = "bs.obj"; loc}, PStr [])]; + pval_prim = [ "" ]; + pval_attributes = [ ({ txt = "bs.obj"; loc }, PStr []) ]; pval_loc = loc; } @@ -273665,10 +273850,14 @@ let makePropsExternalSig fnName loc namedArgListWithKeyAndRef propsType = (* Build an AST node for the props name when converted to an object inside the function signature *) let makePropsName ~loc name = - {ppat_desc = Ppat_var {txt = name; loc}; ppat_loc = loc; ppat_attributes = []} + { + ppat_desc = Ppat_var { txt = name; loc }; + ppat_loc = loc; + ppat_attributes = []; + } let makeObjectField loc (str, attrs, type_) = - Otag ({loc; txt = str}, attrs, type_) + Otag ({ loc; txt = str }, attrs, type_) (* Build an AST node representing a "closed" object representing a component's props *) let makePropsType ~loc namedTypeList = @@ -273685,11 +273874,11 @@ let newtypeToVar newtype type_ = let var_desc = Ptyp_var ("type-" ^ newtype) in let typ (mapper : Ast_mapper.mapper) typ = match typ.ptyp_desc with - | Ptyp_constr ({txt = Lident name}, _) when name = newtype -> - {typ with ptyp_desc = var_desc} + | Ptyp_constr ({ txt = Lident name }, _) when name = newtype -> + { typ with ptyp_desc = var_desc } | _ -> Ast_mapper.default_mapper.typ mapper typ in - let mapper = {Ast_mapper.default_mapper with typ} in + let mapper = { Ast_mapper.default_mapper with typ } in mapper.typ mapper type_ (* TODO: some line number might still be wrong *) @@ -273709,23 +273898,23 @@ let jsxMapper ~config = let args = recursivelyTransformedArgsForMake @ (match childrenExpr with - | Exact children -> [(labelled "children", children)] - | ListLiteral {pexp_desc = Pexp_array list} when list = [] -> [] + | Exact children -> [ (labelled "children", children) ] + | ListLiteral { pexp_desc = Pexp_array list } when list = [] -> [] | ListLiteral expression -> - (* this is a hack to support react components that introspect into their children *) - childrenArg := Some expression; - [ - ( labelled "children", - Exp.ident ~loc {loc; txt = Ldot (Lident "React", "null")} ); - ]) - @ [(nolabel, Exp.construct ~loc {loc; txt = Lident "()"} None)] + (* this is a hack to support react components that introspect into their children *) + childrenArg := Some expression; + [ + ( labelled "children", + Exp.ident ~loc { loc; txt = Ldot (Lident "React", "null") } ); + ]) + @ [ (nolabel, Exp.construct ~loc { loc; txt = Lident "()" } None) ] in let isCap str = String.capitalize_ascii str = str in let ident = match modulePath with | Lident _ -> Ldot (modulePath, "make") | Ldot (_modulePath, value) as fullPath when isCap value -> - Ldot (fullPath, "make") + Ldot (fullPath, "make") | modulePath -> modulePath in let propsIdent = @@ -273733,28 +273922,28 @@ let jsxMapper ~config = | Lident path -> Lident (path ^ "Props") | Ldot (ident, path) -> Ldot (ident, path ^ "Props") | _ -> - React_jsx_common.raiseError ~loc - "JSX name can't be the result of function applications" + React_jsx_common.raiseError ~loc + "JSX name can't be the result of function applications" in let props = - Exp.apply ~attrs ~loc (Exp.ident ~loc {loc; txt = propsIdent}) args + Exp.apply ~attrs ~loc (Exp.ident ~loc { loc; txt = propsIdent }) args in (* handle key, ref, children *) (* React.createElement(Component.make, props, ...children) *) match !childrenArg with | None -> - Exp.apply ~loc ~attrs - (Exp.ident ~loc {loc; txt = Ldot (Lident "React", "createElement")}) - [(nolabel, Exp.ident ~loc {txt = ident; loc}); (nolabel, props)] + Exp.apply ~loc ~attrs + (Exp.ident ~loc { loc; txt = Ldot (Lident "React", "createElement") }) + [ (nolabel, Exp.ident ~loc { txt = ident; loc }); (nolabel, props) ] | Some children -> - Exp.apply ~loc ~attrs - (Exp.ident ~loc - {loc; txt = Ldot (Lident "React", "createElementVariadic")}) - [ - (nolabel, Exp.ident ~loc {txt = ident; loc}); - (nolabel, props); - (nolabel, children); - ] + Exp.apply ~loc ~attrs + (Exp.ident ~loc + { loc; txt = Ldot (Lident "React", "createElementVariadic") }) + [ + (nolabel, Exp.ident ~loc { txt = ident; loc }); + (nolabel, props); + (nolabel, children); + ] in let transformLowercaseCall3 mapper loc attrs callArguments id = @@ -273766,48 +273955,50 @@ let jsxMapper ~config = (* [@JSX] div(~children=[a]), coming from
a
*) | { pexp_desc = - ( Pexp_construct ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple _}) - | Pexp_construct ({txt = Lident "[]"}, None) ); + ( Pexp_construct + ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple _ }) + | Pexp_construct ({ txt = Lident "[]" }, None) ); } -> - "createDOMElementVariadic" + "createDOMElementVariadic" (* [@JSX] div(~children= value), coming from
...(value)
*) - | {pexp_loc} -> - React_jsx_common.raiseError ~loc:pexp_loc - "A spread as a DOM element's children don't make sense written \ - together. You can simply remove the spread." + | { pexp_loc } -> + React_jsx_common.raiseError ~loc:pexp_loc + "A spread as a DOM element's children don't make sense written \ + together. You can simply remove the spread." in let args = match nonChildrenProps with - | [_justTheUnitArgumentAtEnd] -> - [ - (* "div" *) - (nolabel, componentNameExpr); - (* [|moreCreateElementCallsHere|] *) - (nolabel, childrenExpr); - ] + | [ _justTheUnitArgumentAtEnd ] -> + [ + (* "div" *) + (nolabel, componentNameExpr); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr); + ] | nonEmptyProps -> - let propsCall = - Exp.apply ~loc - (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOMRe", "domProps")}) - (nonEmptyProps - |> List.map (fun (label, expression) -> - (label, mapper.expr mapper expression))) - in - [ - (* "div" *) - (nolabel, componentNameExpr); - (* ReactDOMRe.props(~className=blabla, ~foo=bar, ()) *) - (labelled "props", propsCall); - (* [|moreCreateElementCallsHere|] *) - (nolabel, childrenExpr); - ] + let propsCall = + Exp.apply ~loc + (Exp.ident ~loc + { loc; txt = Ldot (Lident "ReactDOMRe", "domProps") }) + (nonEmptyProps + |> List.map (fun (label, expression) -> + (label, mapper.expr mapper expression))) + in + [ + (* "div" *) + (nolabel, componentNameExpr); + (* ReactDOMRe.props(~className=blabla, ~foo=bar, ()) *) + (labelled "props", propsCall); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr); + ] in Exp.apply ~loc (* throw away the [@JSX] attribute and keep the others, if any *) ~attrs (* ReactDOMRe.createElement *) (Exp.ident ~loc - {loc; txt = Ldot (Lident "ReactDOMRe", createElementCall)}) + { loc; txt = Ldot (Lident "ReactDOMRe", createElementCall) }) args in @@ -273816,128 +274007,132 @@ let jsxMapper ~config = match expr.pexp_desc with (* TODO: make this show up with a loc. *) | Pexp_fun (Labelled "key", _, _, _) | Pexp_fun (Optional "key", _, _, _) -> - React_jsx_common.raiseError ~loc:expr.pexp_loc - "Key cannot be accessed inside of a component. Don't worry - you can \ - always key a component from its parent!" + React_jsx_common.raiseError ~loc:expr.pexp_loc + "Key cannot be accessed inside of a component. Don't worry - you can \ + always key a component from its parent!" | Pexp_fun (Labelled "ref", _, _, _) | Pexp_fun (Optional "ref", _, _, _) -> - React_jsx_common.raiseError ~loc:expr.pexp_loc - "Ref cannot be passed as a normal prop. Either give the prop a \ - different name or use the `forwardRef` API instead." + React_jsx_common.raiseError ~loc:expr.pexp_loc + "Ref cannot be passed as a normal prop. Either give the prop a \ + different name or use the `forwardRef` API instead." | Pexp_fun (arg, default, pattern, expression) when isOptional arg || isLabelled arg -> - let () = - match (isOptional arg, pattern, default) with - | true, {ppat_desc = Ppat_constraint (_, {ptyp_desc})}, None -> ( - match ptyp_desc with - | Ptyp_constr ({txt = Lident "option"}, [_]) -> () - | _ -> - let currentType = + let () = + match (isOptional arg, pattern, default) with + | true, { ppat_desc = Ppat_constraint (_, { ptyp_desc }) }, None -> ( match ptyp_desc with - | Ptyp_constr ({txt}, []) -> - String.concat "." (Longident.flatten txt) - | Ptyp_constr ({txt}, _innerTypeArgs) -> - String.concat "." (Longident.flatten txt) ^ "(...)" - | _ -> "..." - in - Location.prerr_warning pattern.ppat_loc - (Preprocessor - (Printf.sprintf - "React: optional argument annotations must have explicit \ - `option`. Did you mean `option(%s)=?`?" - currentType))) - | _ -> () - in - let alias = - match pattern with - | {ppat_desc = Ppat_alias (_, {txt}) | Ppat_var {txt}} -> txt - | {ppat_desc = Ppat_any} -> "_" - | _ -> getLabel arg - in - let type_ = - match pattern with - | {ppat_desc = Ppat_constraint (_, type_)} -> Some type_ - | _ -> None - in + | Ptyp_constr ({ txt = Lident "option" }, [ _ ]) -> () + | _ -> + let currentType = + match ptyp_desc with + | Ptyp_constr ({ txt }, []) -> + String.concat "." (Longident.flatten txt) + | Ptyp_constr ({ txt }, _innerTypeArgs) -> + String.concat "." (Longident.flatten txt) ^ "(...)" + | _ -> "..." + in + Location.prerr_warning pattern.ppat_loc + (Preprocessor + (Printf.sprintf + "React: optional argument annotations must have \ + explicit `option`. Did you mean `option(%s)=?`?" + currentType))) + | _ -> () + in + let alias = + match pattern with + | { ppat_desc = Ppat_alias (_, { txt }) | Ppat_var { txt } } -> txt + | { ppat_desc = Ppat_any } -> "_" + | _ -> getLabel arg + in + let type_ = + match pattern with + | { ppat_desc = Ppat_constraint (_, type_) } -> Some type_ + | _ -> None + in - recursivelyTransformNamedArgsForMake mapper expression - ((arg, default, pattern, alias, pattern.ppat_loc, type_) :: args) - newtypes + recursivelyTransformNamedArgsForMake mapper expression + ((arg, default, pattern, alias, pattern.ppat_loc, type_) :: args) + newtypes | Pexp_fun ( Nolabel, _, - {ppat_desc = Ppat_construct ({txt = Lident "()"}, _) | Ppat_any}, + { ppat_desc = Ppat_construct ({ txt = Lident "()" }, _) | Ppat_any }, _expression ) -> - (args, newtypes, None) + (args, newtypes, None) | Pexp_fun ( Nolabel, _, { ppat_desc = - Ppat_var {txt} | Ppat_constraint ({ppat_desc = Ppat_var {txt}}, _); + ( Ppat_var { txt } + | Ppat_constraint ({ ppat_desc = Ppat_var { txt } }, _) ); }, _expression ) -> - (args, newtypes, Some txt) + (args, newtypes, Some txt) | Pexp_fun (Nolabel, _, pattern, _expression) -> - Location.raise_errorf ~loc:pattern.ppat_loc - "React: react.component refs only support plain arguments and type \ - annotations." + Location.raise_errorf ~loc:pattern.ppat_loc + "React: react.component refs only support plain arguments and type \ + annotations." | Pexp_newtype (label, expression) -> - recursivelyTransformNamedArgsForMake mapper expression args - (label :: newtypes) + recursivelyTransformNamedArgsForMake mapper expression args + (label :: newtypes) | Pexp_constraint (expression, _typ) -> - recursivelyTransformNamedArgsForMake mapper expression args newtypes + recursivelyTransformNamedArgsForMake mapper expression args newtypes | _ -> (args, newtypes, None) in let argToType types (name, default, _noLabelName, _alias, loc, type_) = match (type_, name, default) with - | Some {ptyp_desc = Ptyp_constr ({txt = Lident "option"}, [type_])}, name, _ + | ( Some { ptyp_desc = Ptyp_constr ({ txt = Lident "option" }, [ type_ ]) }, + name, + _ ) when isOptional name -> - ( getLabel name, - [], - { - type_ with - ptyp_desc = - Ptyp_constr ({loc = type_.ptyp_loc; txt = optionIdent}, [type_]); - } ) - :: types + ( getLabel name, + [], + { + type_ with + ptyp_desc = + Ptyp_constr + ({ loc = type_.ptyp_loc; txt = optionIdent }, [ type_ ]); + } ) + :: types | Some type_, name, Some _default -> - ( getLabel name, - [], - { - ptyp_desc = Ptyp_constr ({loc; txt = optionIdent}, [type_]); - ptyp_loc = loc; - ptyp_attributes = []; - } ) - :: types + ( getLabel name, + [], + { + ptyp_desc = Ptyp_constr ({ loc; txt = optionIdent }, [ type_ ]); + ptyp_loc = loc; + ptyp_attributes = []; + } ) + :: types | Some type_, name, _ -> (getLabel name, [], type_) :: types | None, name, _ when isOptional name -> - ( getLabel name, - [], - { - ptyp_desc = - Ptyp_constr - ( {loc; txt = optionIdent}, - [ - { - ptyp_desc = Ptyp_var (safeTypeFromValue name); - ptyp_loc = loc; - ptyp_attributes = []; - }; - ] ); - ptyp_loc = loc; - ptyp_attributes = []; - } ) - :: types + ( getLabel name, + [], + { + ptyp_desc = + Ptyp_constr + ( { loc; txt = optionIdent }, + [ + { + ptyp_desc = Ptyp_var (safeTypeFromValue name); + ptyp_loc = loc; + ptyp_attributes = []; + }; + ] ); + ptyp_loc = loc; + ptyp_attributes = []; + } ) + :: types | None, name, _ when isLabelled name -> - ( getLabel name, - [], - { - ptyp_desc = Ptyp_var (safeTypeFromValue name); - ptyp_loc = loc; - ptyp_attributes = []; - } ) - :: types + ( getLabel name, + [], + { + ptyp_desc = Ptyp_var (safeTypeFromValue name); + ptyp_loc = loc; + ptyp_attributes = []; + } ) + :: types | _ -> types in @@ -273945,8 +274140,8 @@ let jsxMapper ~config = match name with | name when isLabelled name -> (getLabel name, [], type_) :: types | name when isOptional name -> - (getLabel name, [], Typ.constr ~loc {loc; txt = optionIdent} [type_]) - :: types + (getLabel name, [], Typ.constr ~loc { loc; txt = optionIdent } [ type_ ]) + :: types | _ -> types in @@ -273958,432 +274153,458 @@ let jsxMapper ~config = pstr_loc; pstr_desc = Pstr_primitive - ({pval_name = {txt = fnName}; pval_attributes; pval_type} as + ({ pval_name = { txt = fnName }; pval_attributes; pval_type } as value_description); } as pstr -> ( - match List.filter React_jsx_common.hasAttr pval_attributes with - | [] -> [item] - | [_] -> - let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = - match ptyp_desc with - | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) - when isLabelled name || isOptional name -> - getPropTypes ((name, ptyp_loc, type_) :: types) rest - | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest - | Ptyp_arrow (name, type_, returnValue) - when isLabelled name || isOptional name -> - (returnValue, (name, returnValue.ptyp_loc, type_) :: types) - | _ -> (fullType, types) - in - let innerType, propTypes = getPropTypes [] pval_type in - let namedTypeList = List.fold_left argToConcreteType [] propTypes in - let pluckLabelAndLoc (label, loc, type_) = - (label, None (* default *), loc, Some type_) - in - let retPropsType = makePropsType ~loc:pstr_loc namedTypeList in - let externalPropsDecl = - makePropsExternal fnName pstr_loc - ((optional "key", None, pstr_loc, Some (keyType pstr_loc)) - :: List.map pluckLabelAndLoc propTypes) - retPropsType - in - (* can't be an arrow because it will defensively uncurry *) - let newExternalType = - Ptyp_constr - ( {loc = pstr_loc; txt = Ldot (Lident "React", "componentLike")}, - [retPropsType; innerType] ) - in - let newStructure = - { - pstr with - pstr_desc = - Pstr_primitive - { - value_description with - pval_type = {pval_type with ptyp_desc = newExternalType}; - pval_attributes = List.filter otherAttrsPure pval_attributes; - }; - } - in - [externalPropsDecl; newStructure] - | _ -> - React_jsx_common.raiseError ~loc:pstr_loc - "Only one react.component call can exist on a component at one time") - (* let component = ... *) - | {pstr_loc; pstr_desc = Pstr_value (recFlag, valueBindings)} -> ( - let fileName = filenameFromLoc pstr_loc in - let emptyLoc = Location.in_file fileName in - let mapBinding binding = - if React_jsx_common.hasAttrOnBinding binding then - let bindingLoc = binding.pvb_loc in - let bindingPatLoc = binding.pvb_pat.ppat_loc in - let binding = - { - binding with - pvb_pat = {binding.pvb_pat with ppat_loc = emptyLoc}; - pvb_loc = emptyLoc; - } - in - let fnName = getFnName binding.pvb_pat in - let internalFnName = fnName ^ "$Internal" in - let fullModuleName = makeModuleName fileName !nestedModules fnName in - let modifiedBindingOld binding = - let expression = binding.pvb_expr in - (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) - let rec spelunkForFunExpression expression = - match expression with - (* let make = (~prop) => ... *) - | {pexp_desc = Pexp_fun _} | {pexp_desc = Pexp_newtype _} -> - expression - (* let make = {let foo = bar in (~prop) => ...} *) - | {pexp_desc = Pexp_let (_recursive, _vbs, returnExpression)} -> - (* here's where we spelunk! *) - spelunkForFunExpression returnExpression - (* let make = React.forwardRef((~prop) => ...) *) - | { - pexp_desc = - Pexp_apply - (_wrapperExpression, [(Nolabel, innerFunctionExpression)]); - } -> - spelunkForFunExpression innerFunctionExpression - | { - pexp_desc = - Pexp_sequence (_wrapperExpression, innerFunctionExpression); - } -> - spelunkForFunExpression innerFunctionExpression - | {pexp_desc = Pexp_constraint (innerFunctionExpression, _typ)} -> - spelunkForFunExpression innerFunctionExpression - | {pexp_loc} -> - React_jsx_common.raiseError ~loc:pexp_loc - "react.component calls can only be on function definitions \ - or component wrappers (forwardRef, memo)." + match List.filter React_jsx_common.hasAttr pval_attributes with + | [] -> [ item ] + | [ _ ] -> + let rec getPropTypes types ({ ptyp_loc; ptyp_desc } as fullType) = + match ptyp_desc with + | Ptyp_arrow (name, type_, ({ ptyp_desc = Ptyp_arrow _ } as rest)) + when isLabelled name || isOptional name -> + getPropTypes ((name, ptyp_loc, type_) :: types) rest + | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest + | Ptyp_arrow (name, type_, returnValue) + when isLabelled name || isOptional name -> + (returnValue, (name, returnValue.ptyp_loc, type_) :: types) + | _ -> (fullType, types) in - spelunkForFunExpression expression - in - let modifiedBinding binding = - let hasApplication = ref false in - let wrapExpressionWithBinding expressionFn expression = - Vb.mk ~loc:bindingLoc - ~attrs:(List.filter otherAttrsPure binding.pvb_attributes) - (Pat.var ~loc:bindingPatLoc {loc = bindingPatLoc; txt = fnName}) - (expressionFn expression) + let innerType, propTypes = getPropTypes [] pval_type in + let namedTypeList = List.fold_left argToConcreteType [] propTypes in + let pluckLabelAndLoc (label, loc, type_) = + (label, None (* default *), loc, Some type_) + in + let retPropsType = makePropsType ~loc:pstr_loc namedTypeList in + let externalPropsDecl = + makePropsExternal fnName pstr_loc + ((optional "key", None, pstr_loc, Some (keyType pstr_loc)) + :: List.map pluckLabelAndLoc propTypes) + retPropsType + in + (* can't be an arrow because it will defensively uncurry *) + let newExternalType = + Ptyp_constr + ( { + loc = pstr_loc; + txt = Ldot (Lident "React", "componentLike"); + }, + [ retPropsType; innerType ] ) in - let expression = binding.pvb_expr in - let unerasableIgnoreExp exp = + let newStructure = { - exp with - pexp_attributes = - unerasableIgnore emptyLoc :: exp.pexp_attributes; + pstr with + pstr_desc = + Pstr_primitive + { + value_description with + pval_type = { pval_type with ptyp_desc = newExternalType }; + pval_attributes = + List.filter otherAttrsPure pval_attributes; + }; } in - (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) - let rec spelunkForFunExpression expression = - match expression with - (* let make = (~prop) => ... with no final unit *) - | { - pexp_desc = - Pexp_fun - ( ((Labelled _ | Optional _) as label), - default, - pattern, - ({pexp_desc = Pexp_fun _} as internalExpression) ); - } -> - let wrap, hasUnit, exp = - spelunkForFunExpression internalExpression - in - ( wrap, - hasUnit, - unerasableIgnoreExp - { - expression with - pexp_desc = Pexp_fun (label, default, pattern, exp); - } ) - (* let make = (()) => ... *) - (* let make = (_) => ... *) - | { - pexp_desc = - Pexp_fun - ( Nolabel, - _default, - { - ppat_desc = - Ppat_construct ({txt = Lident "()"}, _) | Ppat_any; - }, - _internalExpression ); - } -> - ((fun a -> a), true, expression) - (* let make = (~prop) => ... *) - | { - pexp_desc = - Pexp_fun - ( (Labelled _ | Optional _), - _default, - _pattern, - _internalExpression ); - } -> - ((fun a -> a), false, unerasableIgnoreExp expression) - (* let make = (prop) => ... *) - | { - pexp_desc = - Pexp_fun (_nolabel, _default, pattern, _internalExpression); - } -> - if hasApplication.contents then - ((fun a -> a), false, unerasableIgnoreExp expression) - else - Location.raise_errorf ~loc:pattern.ppat_loc - "React: props need to be labelled arguments.\n\ - \ If you are working with refs be sure to wrap with \ - React.forwardRef.\n\ - \ If your component doesn't have any props use () or _ \ - instead of a name." - (* let make = {let foo = bar in (~prop) => ...} *) - | {pexp_desc = Pexp_let (recursive, vbs, internalExpression)} -> - (* here's where we spelunk! *) - let wrap, hasUnit, exp = - spelunkForFunExpression internalExpression - in - ( wrap, - hasUnit, - {expression with pexp_desc = Pexp_let (recursive, vbs, exp)} - ) - (* let make = React.forwardRef((~prop) => ...) *) - | { - pexp_desc = - Pexp_apply (wrapperExpression, [(Nolabel, internalExpression)]); - } -> - let () = hasApplication := true in - let _, hasUnit, exp = - spelunkForFunExpression internalExpression - in - ( (fun exp -> Exp.apply wrapperExpression [(nolabel, exp)]), - hasUnit, - exp ) - | { - pexp_desc = Pexp_sequence (wrapperExpression, internalExpression); - } -> - let wrap, hasUnit, exp = - spelunkForFunExpression internalExpression - in - ( wrap, - hasUnit, - { - expression with - pexp_desc = Pexp_sequence (wrapperExpression, exp); - } ) - | e -> ((fun a -> a), false, e) + [ externalPropsDecl; newStructure ] + | _ -> + React_jsx_common.raiseError ~loc:pstr_loc + "Only one react.component call can exist on a component at one \ + time") + (* let component = ... *) + | { pstr_loc; pstr_desc = Pstr_value (recFlag, valueBindings) } -> ( + let fileName = filenameFromLoc pstr_loc in + let emptyLoc = Location.in_file fileName in + let mapBinding binding = + if React_jsx_common.hasAttrOnBinding binding then + let bindingLoc = binding.pvb_loc in + let bindingPatLoc = binding.pvb_pat.ppat_loc in + let binding = + { + binding with + pvb_pat = { binding.pvb_pat with ppat_loc = emptyLoc }; + pvb_loc = emptyLoc; + } + in + let fnName = getFnName binding.pvb_pat in + let internalFnName = fnName ^ "$Internal" in + let fullModuleName = + makeModuleName fileName !nestedModules fnName in - let wrapExpression, hasUnit, expression = + let modifiedBindingOld binding = + let expression = binding.pvb_expr in + (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) + let rec spelunkForFunExpression expression = + match expression with + (* let make = (~prop) => ... *) + | { pexp_desc = Pexp_fun _ } | { pexp_desc = Pexp_newtype _ } -> + expression + (* let make = {let foo = bar in (~prop) => ...} *) + | { pexp_desc = Pexp_let (_recursive, _vbs, returnExpression) } + -> + (* here's where we spelunk! *) + spelunkForFunExpression returnExpression + (* let make = React.forwardRef((~prop) => ...) *) + | { + pexp_desc = + Pexp_apply + (_wrapperExpression, [ (Nolabel, innerFunctionExpression) ]); + } -> + spelunkForFunExpression innerFunctionExpression + | { + pexp_desc = + Pexp_sequence (_wrapperExpression, innerFunctionExpression); + } -> + spelunkForFunExpression innerFunctionExpression + | { + pexp_desc = Pexp_constraint (innerFunctionExpression, _typ); + } -> + spelunkForFunExpression innerFunctionExpression + | { pexp_loc } -> + React_jsx_common.raiseError ~loc:pexp_loc + "react.component calls can only be on function \ + definitions or component wrappers (forwardRef, memo)." + in spelunkForFunExpression expression in - (wrapExpressionWithBinding wrapExpression, hasUnit, expression) - in - let bindingWrapper, hasUnit, expression = modifiedBinding binding in - let reactComponentAttribute = - try Some (List.find React_jsx_common.hasAttr binding.pvb_attributes) - with Not_found -> None - in - let _attr_loc, payload = - match reactComponentAttribute with - | Some (loc, payload) -> (loc.loc, Some payload) - | None -> (emptyLoc, None) - in - let props = getPropsAttr payload in - (* do stuff here! *) - let namedArgList, newtypes, forwardRef = - recursivelyTransformNamedArgsForMake mapper - (modifiedBindingOld binding) - [] [] - in - let namedArgListWithKeyAndRef = - ( optional "key", - None, - Pat.var {txt = "key"; loc = emptyLoc}, - "key", - emptyLoc, - Some (keyType emptyLoc) ) - :: namedArgList - in - let namedArgListWithKeyAndRef = - match forwardRef with - | Some _ -> - ( optional "ref", + let modifiedBinding binding = + let hasApplication = ref false in + let wrapExpressionWithBinding expressionFn expression = + Vb.mk ~loc:bindingLoc + ~attrs:(List.filter otherAttrsPure binding.pvb_attributes) + (Pat.var ~loc:bindingPatLoc + { loc = bindingPatLoc; txt = fnName }) + (expressionFn expression) + in + let expression = binding.pvb_expr in + let unerasableIgnoreExp exp = + { + exp with + pexp_attributes = + unerasableIgnore emptyLoc :: exp.pexp_attributes; + } + in + (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) + let rec spelunkForFunExpression expression = + match expression with + (* let make = (~prop) => ... with no final unit *) + | { + pexp_desc = + Pexp_fun + ( ((Labelled _ | Optional _) as label), + default, + pattern, + ({ pexp_desc = Pexp_fun _ } as internalExpression) ); + } -> + let wrap, hasUnit, exp = + spelunkForFunExpression internalExpression + in + ( wrap, + hasUnit, + unerasableIgnoreExp + { + expression with + pexp_desc = Pexp_fun (label, default, pattern, exp); + } ) + (* let make = (()) => ... *) + (* let make = (_) => ... *) + | { + pexp_desc = + Pexp_fun + ( Nolabel, + _default, + { + ppat_desc = + Ppat_construct ({ txt = Lident "()" }, _) | Ppat_any; + }, + _internalExpression ); + } -> + ((fun a -> a), true, expression) + (* let make = (~prop) => ... *) + | { + pexp_desc = + Pexp_fun + ( (Labelled _ | Optional _), + _default, + _pattern, + _internalExpression ); + } -> + ((fun a -> a), false, unerasableIgnoreExp expression) + (* let make = (prop) => ... *) + | { + pexp_desc = + Pexp_fun (_nolabel, _default, pattern, _internalExpression); + } -> + if hasApplication.contents then + ((fun a -> a), false, unerasableIgnoreExp expression) + else + Location.raise_errorf ~loc:pattern.ppat_loc + "React: props need to be labelled arguments.\n\ + \ If you are working with refs be sure to wrap with \ + React.forwardRef.\n\ + \ If your component doesn't have any props use () or \ + _ instead of a name." + (* let make = {let foo = bar in (~prop) => ...} *) + | { pexp_desc = Pexp_let (recursive, vbs, internalExpression) } + -> + (* here's where we spelunk! *) + let wrap, hasUnit, exp = + spelunkForFunExpression internalExpression + in + ( wrap, + hasUnit, + { + expression with + pexp_desc = Pexp_let (recursive, vbs, exp); + } ) + (* let make = React.forwardRef((~prop) => ...) *) + | { + pexp_desc = + Pexp_apply + (wrapperExpression, [ (Nolabel, internalExpression) ]); + } -> + let () = hasApplication := true in + let _, hasUnit, exp = + spelunkForFunExpression internalExpression + in + ( (fun exp -> Exp.apply wrapperExpression [ (nolabel, exp) ]), + hasUnit, + exp ) + | { + pexp_desc = + Pexp_sequence (wrapperExpression, internalExpression); + } -> + let wrap, hasUnit, exp = + spelunkForFunExpression internalExpression + in + ( wrap, + hasUnit, + { + expression with + pexp_desc = Pexp_sequence (wrapperExpression, exp); + } ) + | e -> ((fun a -> a), false, e) + in + let wrapExpression, hasUnit, expression = + spelunkForFunExpression expression + in + (wrapExpressionWithBinding wrapExpression, hasUnit, expression) + in + let bindingWrapper, hasUnit, expression = modifiedBinding binding in + let reactComponentAttribute = + try + Some (List.find React_jsx_common.hasAttr binding.pvb_attributes) + with Not_found -> None + in + let _attr_loc, payload = + match reactComponentAttribute with + | Some (loc, payload) -> (loc.loc, Some payload) + | None -> (emptyLoc, None) + in + let props = getPropsAttr payload in + (* do stuff here! *) + let namedArgList, newtypes, forwardRef = + recursivelyTransformNamedArgsForMake mapper + (modifiedBindingOld binding) + [] [] + in + let namedArgListWithKeyAndRef = + ( optional "key", None, - Pat.var {txt = "key"; loc = emptyLoc}, - "ref", + Pat.var { txt = "key"; loc = emptyLoc }, + "key", emptyLoc, - None ) - :: namedArgListWithKeyAndRef - | None -> namedArgListWithKeyAndRef - in - let namedArgListWithKeyAndRefForNew = - match forwardRef with - | Some txt -> - namedArgList - @ [ - ( nolabel, + Some (keyType emptyLoc) ) + :: namedArgList + in + let namedArgListWithKeyAndRef = + match forwardRef with + | Some _ -> + ( optional "ref", None, - Pat.var {txt; loc = emptyLoc}, - txt, + Pat.var { txt = "key"; loc = emptyLoc }, + "ref", emptyLoc, - None ); - ] - | None -> namedArgList - in - let pluckArg (label, _, _, alias, loc, _) = - let labelString = - match label with - | label when isOptional label || isLabelled label -> - getLabel label - | _ -> "" + None ) + :: namedArgListWithKeyAndRef + | None -> namedArgListWithKeyAndRef in - ( label, - match labelString with - | "" -> Exp.ident ~loc {txt = Lident alias; loc} - | labelString -> - Exp.apply ~loc - (Exp.ident ~loc {txt = Lident "##"; loc}) - [ - (nolabel, Exp.ident ~loc {txt = Lident props.propsName; loc}); - (nolabel, Exp.ident ~loc {txt = Lident labelString; loc}); - ] ) - in - let namedTypeList = List.fold_left argToType [] namedArgList in - let loc = emptyLoc in - let externalArgs = - (* translate newtypes to type variables *) - List.fold_left - (fun args newtype -> - List.map - (fun (a, b, c, d, e, maybeTyp) -> - match maybeTyp with - | Some typ -> - (a, b, c, d, e, Some (newtypeToVar newtype.txt typ)) - | None -> (a, b, c, d, e, None)) - args) - namedArgListWithKeyAndRef newtypes - in - let externalTypes = - (* translate newtypes to type variables *) - List.fold_left - (fun args newtype -> - List.map - (fun (a, b, typ) -> (a, b, newtypeToVar newtype.txt typ)) - args) - namedTypeList newtypes - in - let externalDecl = - makeExternalDecl fnName loc externalArgs externalTypes - in - let innerExpressionArgs = - List.map pluckArg namedArgListWithKeyAndRefForNew - @ - if hasUnit then - [(Nolabel, Exp.construct {loc; txt = Lident "()"} None)] - else [] - in - let innerExpression = - Exp.apply - (Exp.ident - { - loc; - txt = - Lident - (match recFlag with - | Recursive -> internalFnName - | Nonrecursive -> fnName); - }) - innerExpressionArgs - in - let innerExpressionWithRef = - match forwardRef with - | Some txt -> - { - innerExpression with - pexp_desc = - Pexp_fun - ( nolabel, - None, - { - ppat_desc = Ppat_var {txt; loc = emptyLoc}; - ppat_loc = emptyLoc; - ppat_attributes = []; - }, - innerExpression ); - } - | None -> innerExpression - in - let fullExpression = - Exp.fun_ nolabel None - { - ppat_desc = - Ppat_constraint - ( makePropsName ~loc:emptyLoc props.propsName, - makePropsType ~loc:emptyLoc externalTypes ); - ppat_loc = emptyLoc; - ppat_attributes = []; - } - innerExpressionWithRef - in - let fullExpression = - match fullModuleName with - | "" -> fullExpression - | txt -> - Exp.let_ Nonrecursive - [ - Vb.mk ~loc:emptyLoc - (Pat.var ~loc:emptyLoc {loc = emptyLoc; txt}) - fullExpression; - ] - (Exp.ident ~loc:emptyLoc {loc = emptyLoc; txt = Lident txt}) + let namedArgListWithKeyAndRefForNew = + match forwardRef with + | Some txt -> + namedArgList + @ [ + ( nolabel, + None, + Pat.var { txt; loc = emptyLoc }, + txt, + emptyLoc, + None ); + ] + | None -> namedArgList + in + let pluckArg (label, _, _, alias, loc, _) = + let labelString = + match label with + | label when isOptional label || isLabelled label -> + getLabel label + | _ -> "" + in + ( label, + match labelString with + | "" -> Exp.ident ~loc { txt = Lident alias; loc } + | labelString -> + Exp.apply ~loc + (Exp.ident ~loc { txt = Lident "##"; loc }) + [ + ( nolabel, + Exp.ident ~loc { txt = Lident props.propsName; loc } + ); + ( nolabel, + Exp.ident ~loc { txt = Lident labelString; loc } ); + ] ) + in + let namedTypeList = List.fold_left argToType [] namedArgList in + let loc = emptyLoc in + let externalArgs = + (* translate newtypes to type variables *) + List.fold_left + (fun args newtype -> + List.map + (fun (a, b, c, d, e, maybeTyp) -> + match maybeTyp with + | Some typ -> + (a, b, c, d, e, Some (newtypeToVar newtype.txt typ)) + | None -> (a, b, c, d, e, None)) + args) + namedArgListWithKeyAndRef newtypes + in + let externalTypes = + (* translate newtypes to type variables *) + List.fold_left + (fun args newtype -> + List.map + (fun (a, b, typ) -> (a, b, newtypeToVar newtype.txt typ)) + args) + namedTypeList newtypes + in + let externalDecl = + makeExternalDecl fnName loc externalArgs externalTypes + in + let innerExpressionArgs = + List.map pluckArg namedArgListWithKeyAndRefForNew + @ + if hasUnit then + [ (Nolabel, Exp.construct { loc; txt = Lident "()" } None) ] + else [] + in + let innerExpression = + Exp.apply + (Exp.ident + { + loc; + txt = + Lident + (match recFlag with + | Recursive -> internalFnName + | Nonrecursive -> fnName); + }) + innerExpressionArgs + in + let innerExpressionWithRef = + match forwardRef with + | Some txt -> + { + innerExpression with + pexp_desc = + Pexp_fun + ( nolabel, + None, + { + ppat_desc = Ppat_var { txt; loc = emptyLoc }; + ppat_loc = emptyLoc; + ppat_attributes = []; + }, + innerExpression ); + } + | None -> innerExpression + in + let fullExpression = + Exp.fun_ nolabel None + { + ppat_desc = + Ppat_constraint + ( makePropsName ~loc:emptyLoc props.propsName, + makePropsType ~loc:emptyLoc externalTypes ); + ppat_loc = emptyLoc; + ppat_attributes = []; + } + innerExpressionWithRef + in + let fullExpression = + match fullModuleName with + | "" -> fullExpression + | txt -> + Exp.let_ Nonrecursive + [ + Vb.mk ~loc:emptyLoc + (Pat.var ~loc:emptyLoc { loc = emptyLoc; txt }) + fullExpression; + ] + (Exp.ident ~loc:emptyLoc + { loc = emptyLoc; txt = Lident txt }) + in + let bindings, newBinding = + match recFlag with + | Recursive -> + ( [ + bindingWrapper + (Exp.let_ ~loc:emptyLoc Recursive + [ + makeNewBinding binding expression internalFnName; + Vb.mk + (Pat.var { loc = emptyLoc; txt = fnName }) + fullExpression; + ] + (Exp.ident { loc = emptyLoc; txt = Lident fnName })); + ], + None ) + | Nonrecursive -> + ( [ { binding with pvb_expr = expression } ], + Some (bindingWrapper fullExpression) ) + in + (Some externalDecl, bindings, newBinding) + else (None, [ binding ], None) + in + let structuresAndBinding = List.map mapBinding valueBindings in + let otherStructures (extern, binding, newBinding) + (externs, bindings, newBindings) = + let externs = + match extern with + | Some extern -> extern :: externs + | None -> externs in - let bindings, newBinding = - match recFlag with - | Recursive -> - ( [ - bindingWrapper - (Exp.let_ ~loc:emptyLoc Recursive - [ - makeNewBinding binding expression internalFnName; - Vb.mk - (Pat.var {loc = emptyLoc; txt = fnName}) - fullExpression; - ] - (Exp.ident {loc = emptyLoc; txt = Lident fnName})); - ], - None ) - | Nonrecursive -> - ( [{binding with pvb_expr = expression}], - Some (bindingWrapper fullExpression) ) + let newBindings = + match newBinding with + | Some newBinding -> newBinding :: newBindings + | None -> newBindings in - (Some externalDecl, bindings, newBinding) - else (None, [binding], None) - in - let structuresAndBinding = List.map mapBinding valueBindings in - let otherStructures (extern, binding, newBinding) - (externs, bindings, newBindings) = - let externs = - match extern with - | Some extern -> extern :: externs - | None -> externs + (externs, binding @ bindings, newBindings) in - let newBindings = - match newBinding with - | Some newBinding -> newBinding :: newBindings - | None -> newBindings + let externs, bindings, newBindings = + List.fold_right otherStructures structuresAndBinding ([], [], []) in - (externs, binding @ bindings, newBindings) - in - let externs, bindings, newBindings = - List.fold_right otherStructures structuresAndBinding ([], [], []) - in - externs - @ [{pstr_loc; pstr_desc = Pstr_value (recFlag, bindings)}] - @ - match newBindings with - | [] -> [] - | newBindings -> - [{pstr_loc = emptyLoc; pstr_desc = Pstr_value (recFlag, newBindings)}]) - | _ -> [item] + externs + @ [ { pstr_loc; pstr_desc = Pstr_value (recFlag, bindings) } ] + @ + match newBindings with + | [] -> [] + | newBindings -> + [ + { + pstr_loc = emptyLoc; + pstr_desc = Pstr_value (recFlag, newBindings); + }; + ]) + | _ -> [ item ] in let transformSignatureItem _mapper item = @@ -274392,152 +274613,164 @@ let jsxMapper ~config = psig_loc; psig_desc = Psig_value - ({pval_name = {txt = fnName}; pval_attributes; pval_type} as + ({ pval_name = { txt = fnName }; pval_attributes; pval_type } as psig_desc); } as psig -> ( - match List.filter React_jsx_common.hasAttr pval_attributes with - | [] -> [item] - | [_] -> - let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = - match ptyp_desc with - | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) - when isOptional name || isLabelled name -> - getPropTypes ((name, ptyp_loc, type_) :: types) rest - | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest - | Ptyp_arrow (name, type_, returnValue) - when isOptional name || isLabelled name -> - (returnValue, (name, returnValue.ptyp_loc, type_) :: types) - | _ -> (fullType, types) - in - let innerType, propTypes = getPropTypes [] pval_type in - let namedTypeList = List.fold_left argToConcreteType [] propTypes in - let pluckLabelAndLoc (label, loc, type_) = - (label, None, loc, Some type_) - in - let retPropsType = makePropsType ~loc:psig_loc namedTypeList in - let externalPropsDecl = - makePropsExternalSig fnName psig_loc - ((optional "key", None, psig_loc, Some (keyType psig_loc)) - :: List.map pluckLabelAndLoc propTypes) - retPropsType - in - (* can't be an arrow because it will defensively uncurry *) - let newExternalType = - Ptyp_constr - ( {loc = psig_loc; txt = Ldot (Lident "React", "componentLike")}, - [retPropsType; innerType] ) - in - let newStructure = - { - psig with - psig_desc = - Psig_value - { - psig_desc with - pval_type = {pval_type with ptyp_desc = newExternalType}; - pval_attributes = List.filter otherAttrsPure pval_attributes; - }; - } - in - [externalPropsDecl; newStructure] - | _ -> - React_jsx_common.raiseError ~loc:psig_loc - "Only one react.component call can exist on a component at one time") - | _ -> [item] + match List.filter React_jsx_common.hasAttr pval_attributes with + | [] -> [ item ] + | [ _ ] -> + let rec getPropTypes types ({ ptyp_loc; ptyp_desc } as fullType) = + match ptyp_desc with + | Ptyp_arrow (name, type_, ({ ptyp_desc = Ptyp_arrow _ } as rest)) + when isOptional name || isLabelled name -> + getPropTypes ((name, ptyp_loc, type_) :: types) rest + | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest + | Ptyp_arrow (name, type_, returnValue) + when isOptional name || isLabelled name -> + (returnValue, (name, returnValue.ptyp_loc, type_) :: types) + | _ -> (fullType, types) + in + let innerType, propTypes = getPropTypes [] pval_type in + let namedTypeList = List.fold_left argToConcreteType [] propTypes in + let pluckLabelAndLoc (label, loc, type_) = + (label, None, loc, Some type_) + in + let retPropsType = makePropsType ~loc:psig_loc namedTypeList in + let externalPropsDecl = + makePropsExternalSig fnName psig_loc + ((optional "key", None, psig_loc, Some (keyType psig_loc)) + :: List.map pluckLabelAndLoc propTypes) + retPropsType + in + (* can't be an arrow because it will defensively uncurry *) + let newExternalType = + Ptyp_constr + ( { + loc = psig_loc; + txt = Ldot (Lident "React", "componentLike"); + }, + [ retPropsType; innerType ] ) + in + let newStructure = + { + psig with + psig_desc = + Psig_value + { + psig_desc with + pval_type = { pval_type with ptyp_desc = newExternalType }; + pval_attributes = + List.filter otherAttrsPure pval_attributes; + }; + } + in + [ externalPropsDecl; newStructure ] + | _ -> + React_jsx_common.raiseError ~loc:psig_loc + "Only one react.component call can exist on a component at one \ + time") + | _ -> [ item ] in let transformJsxCall mapper callExpression callArguments attrs = match callExpression.pexp_desc with | Pexp_ident caller -> ( - match caller with - | {txt = Lident "createElement"; loc} -> - React_jsx_common.raiseError ~loc - "JSX: `createElement` should be preceeded by a module name." - (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *) - | {loc; txt = Ldot (modulePath, ("createElement" | "make"))} -> ( - match config.React_jsx_common.version with - | 3 -> - transformUppercaseCall3 modulePath mapper loc attrs callExpression - callArguments - | _ -> - React_jsx_common.raiseError ~loc "JSX: the JSX version must be 3") - (* div(~prop1=foo, ~prop2=bar, ~children=[bla], ()) *) - (* turn that into - ReactDOMRe.createElement(~props=ReactDOMRe.props(~props1=foo, ~props2=bar, ()), [|bla|]) *) - | {loc; txt = Lident id} -> ( - match config.version with - | 3 -> transformLowercaseCall3 mapper loc attrs callArguments id - | _ -> React_jsx_common.raiseError ~loc "JSX: the JSX version must be 3" - ) - | {txt = Ldot (_, anythingNotCreateElementOrMake); loc} -> - React_jsx_common.raiseError ~loc - "JSX: the JSX attribute should be attached to a \ - `YourModuleName.createElement` or `YourModuleName.make` call. We \ - saw `%s` instead" - anythingNotCreateElementOrMake - | {txt = Lapply _; loc} -> - (* don't think there's ever a case where this is reached *) - React_jsx_common.raiseError ~loc - "JSX: encountered a weird case while processing the code. Please \ - report this!") + match caller with + | { txt = Lident "createElement"; loc } -> + React_jsx_common.raiseError ~loc + "JSX: `createElement` should be preceeded by a module name." + (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *) + | { loc; txt = Ldot (modulePath, ("createElement" | "make")) } -> ( + match config.React_jsx_common.version with + | 3 -> + transformUppercaseCall3 modulePath mapper loc attrs + callExpression callArguments + | _ -> + React_jsx_common.raiseError ~loc + "JSX: the JSX version must be 3") + (* div(~prop1=foo, ~prop2=bar, ~children=[bla], ()) *) + (* turn that into + ReactDOMRe.createElement(~props=ReactDOMRe.props(~props1=foo, ~props2=bar, ()), [|bla|]) *) + | { loc; txt = Lident id } -> ( + match config.version with + | 3 -> transformLowercaseCall3 mapper loc attrs callArguments id + | _ -> + React_jsx_common.raiseError ~loc + "JSX: the JSX version must be 3") + | { txt = Ldot (_, anythingNotCreateElementOrMake); loc } -> + React_jsx_common.raiseError ~loc + "JSX: the JSX attribute should be attached to a \ + `YourModuleName.createElement` or `YourModuleName.make` call. \ + We saw `%s` instead" + anythingNotCreateElementOrMake + | { txt = Lapply _; loc } -> + (* don't think there's ever a case where this is reached *) + React_jsx_common.raiseError ~loc + "JSX: encountered a weird case while processing the code. Please \ + report this!") | _ -> - React_jsx_common.raiseError ~loc:callExpression.pexp_loc - "JSX: `createElement` should be preceeded by a simple, direct module \ - name." + React_jsx_common.raiseError ~loc:callExpression.pexp_loc + "JSX: `createElement` should be preceeded by a simple, direct module \ + name." in let expr mapper expression = match expression with (* Does the function application have the @JSX attribute? *) - | {pexp_desc = Pexp_apply (callExpression, callArguments); pexp_attributes} - -> ( - let jsxAttribute, nonJSXAttributes = - List.partition - (fun (attribute, _) -> attribute.txt = "JSX") - pexp_attributes - in - match (jsxAttribute, nonJSXAttributes) with - (* no JSX attribute *) - | [], _ -> default_mapper.expr mapper expression - | _, nonJSXAttributes -> - transformJsxCall mapper callExpression callArguments nonJSXAttributes) + | { + pexp_desc = Pexp_apply (callExpression, callArguments); + pexp_attributes; + } -> ( + let jsxAttribute, nonJSXAttributes = + List.partition + (fun (attribute, _) -> attribute.txt = "JSX") + pexp_attributes + in + match (jsxAttribute, nonJSXAttributes) with + (* no JSX attribute *) + | [], _ -> default_mapper.expr mapper expression + | _, nonJSXAttributes -> + transformJsxCall mapper callExpression callArguments + nonJSXAttributes) (* is it a list with jsx attribute? Reason <>foo desugars to [@JSX][foo]*) | { pexp_desc = ( Pexp_construct - ({txt = Lident "::"; loc}, Some {pexp_desc = Pexp_tuple _}) - | Pexp_construct ({txt = Lident "[]"; loc}, None) ); + ({ txt = Lident "::"; loc }, Some { pexp_desc = Pexp_tuple _ }) + | Pexp_construct ({ txt = Lident "[]"; loc }, None) ); pexp_attributes; } as listItems -> ( - let jsxAttribute, nonJSXAttributes = - List.partition - (fun (attribute, _) -> attribute.txt = "JSX") - pexp_attributes - in - match (jsxAttribute, nonJSXAttributes) with - (* no JSX attribute *) - | [], _ -> default_mapper.expr mapper expression - | _, nonJSXAttributes -> - let loc = {loc with loc_ghost = true} in - let fragment = - Exp.ident ~loc {loc; txt = Ldot (Lident "ReasonReact", "fragment")} - in - let childrenExpr = transformChildrenIfList ~loc ~mapper listItems in - let args = - [ - (* "div" *) - (nolabel, fragment); - (* [|moreCreateElementCallsHere|] *) - (nolabel, childrenExpr); - ] + let jsxAttribute, nonJSXAttributes = + List.partition + (fun (attribute, _) -> attribute.txt = "JSX") + pexp_attributes in - Exp.apply - ~loc (* throw away the [@JSX] attribute and keep the others, if any *) - ~attrs:nonJSXAttributes - (* ReactDOMRe.createElement *) - (Exp.ident ~loc - {loc; txt = Ldot (Lident "ReactDOMRe", "createElement")}) - args) + match (jsxAttribute, nonJSXAttributes) with + (* no JSX attribute *) + | [], _ -> default_mapper.expr mapper expression + | _, nonJSXAttributes -> + let loc = { loc with loc_ghost = true } in + let fragment = + Exp.ident ~loc + { loc; txt = Ldot (Lident "ReasonReact", "fragment") } + in + let childrenExpr = transformChildrenIfList ~loc ~mapper listItems in + let args = + [ + (* "div" *) + (nolabel, fragment); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr); + ] + in + Exp.apply + ~loc + (* throw away the [@JSX] attribute and keep the others, if any *) + ~attrs:nonJSXAttributes + (* ReactDOMRe.createElement *) + (Exp.ident ~loc + { loc; txt = Ldot (Lident "ReactDOMRe", "createElement") }) + args) (* Delegate to the default mapper, a deep identity traversal *) | e -> default_mapper.expr mapper e in @@ -274546,9 +274779,7 @@ let jsxMapper ~config = let _ = nestedModules := module_binding.pmb_name.txt :: !nestedModules in let mapped = default_mapper.module_binding mapper module_binding in let () = - match !nestedModules with - | _ :: rest -> nestedModules := rest - | [] -> () + match !nestedModules with _ :: rest -> nestedModules := rest | [] -> () in mapped in @@ -274565,37 +274796,26 @@ open Parsetree open Longident let nolabel = Nolabel - let labelled str = Labelled str - -let isOptional str = - match str with - | Optional _ -> true - | _ -> false - -let isLabelled str = - match str with - | Labelled _ -> true - | _ -> false +let isOptional str = match str with Optional _ -> true | _ -> false +let isLabelled str = match str with Labelled _ -> true | _ -> false let isForwardRef = function - | {pexp_desc = Pexp_ident {txt = Ldot (Lident "React", "forwardRef")}} -> true + | { pexp_desc = Pexp_ident { txt = Ldot (Lident "React", "forwardRef") } } -> + true | _ -> false let getLabel str = - match str with - | Optional str | Labelled str -> str - | Nolabel -> "" + match str with Optional str | Labelled str -> str | Nolabel -> "" -let optionalAttr = ({txt = "ns.optional"; loc = Location.none}, PStr []) -let optionalAttrs = [optionalAttr] +let optionalAttr = ({ txt = "ns.optional"; loc = Location.none }, PStr []) +let optionalAttrs = [ optionalAttr ] let constantString ~loc str = Ast_helper.Exp.constant ~loc (Pconst_string (str, None)) (* {} empty record *) let emptyRecord ~loc = Exp.record ~loc [] None - let unitExpr ~loc = Exp.construct ~loc (Location.mkloc (Lident "()") loc) None let safeTypeFromValue valueStr = @@ -274605,7 +274825,7 @@ let safeTypeFromValue valueStr = let refType loc = Typ.constr ~loc - {loc; txt = Ldot (Ldot (Lident "ReactDOM", "Ref"), "currentDomRef")} + { loc; txt = Ldot (Ldot (Lident "ReactDOM", "Ref"), "currentDomRef") } [] type 'a children = ListLiteral of 'a | Exact of 'a @@ -274616,16 +274836,16 @@ let transformChildrenIfListUpper ~mapper theList = (* not in the sense of converting a list to an array; convert the AST reprensentation of a list to the AST reprensentation of an array *) match theList with - | {pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} -> ( - match accum with - | [singleElement] -> Exact singleElement - | accum -> ListLiteral (Exp.array (List.rev accum))) + | { pexp_desc = Pexp_construct ({ txt = Lident "[]" }, None) } -> ( + match accum with + | [ singleElement ] -> Exact singleElement + | accum -> ListLiteral (Exp.array (List.rev accum))) | { pexp_desc = Pexp_construct - ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple [v; acc]}); + ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple [ v; acc ] }); } -> - transformChildren_ acc (mapper.expr mapper v :: accum) + transformChildren_ acc (mapper.expr mapper v :: accum) | notAList -> Exact (mapper.expr mapper notAList) in transformChildren_ theList [] @@ -274635,14 +274855,14 @@ let transformChildrenIfList ~mapper theList = (* not in the sense of converting a list to an array; convert the AST reprensentation of a list to the AST reprensentation of an array *) match theList with - | {pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} -> - Exp.array (List.rev accum) + | { pexp_desc = Pexp_construct ({ txt = Lident "[]" }, None) } -> + Exp.array (List.rev accum) | { pexp_desc = Pexp_construct - ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple [v; acc]}); + ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple [ v; acc ] }); } -> - transformChildren_ acc (mapper.expr mapper v :: accum) + transformChildren_ acc (mapper.expr mapper v :: accum) | notAList -> mapper.expr mapper notAList in transformChildren_ theList [] @@ -274651,11 +274871,13 @@ let extractChildren ?(removeLastPositionUnit = false) ~loc propsAndChildren = let rec allButLast_ lst acc = match lst with | [] -> [] - | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] -> - acc - | (Nolabel, {pexp_loc}) :: _rest -> - React_jsx_common.raiseError ~loc:pexp_loc - "JSX: found non-labelled argument before the last position" + | [ + (Nolabel, { pexp_desc = Pexp_construct ({ txt = Lident "()" }, None) }); + ] -> + acc + | (Nolabel, { pexp_loc }) :: _rest -> + React_jsx_common.raiseError ~loc:pexp_loc + "JSX: found non-labelled argument before the last position" | arg :: rest -> allButLast_ rest (arg :: acc) in let allButLast lst = allButLast_ lst [] |> List.rev in @@ -274665,16 +274887,16 @@ let extractChildren ?(removeLastPositionUnit = false) ~loc propsAndChildren = propsAndChildren with | [], props -> - (* no children provided? Place a placeholder list *) - ( Exp.construct {loc = Location.none; txt = Lident "[]"} None, - if removeLastPositionUnit then allButLast props else props ) - | [(_, childrenExpr)], props -> - (childrenExpr, if removeLastPositionUnit then allButLast props else props) + (* no children provided? Place a placeholder list *) + ( Exp.construct { loc = Location.none; txt = Lident "[]" } None, + if removeLastPositionUnit then allButLast props else props ) + | [ (_, childrenExpr) ], props -> + (childrenExpr, if removeLastPositionUnit then allButLast props else props) | _ -> - React_jsx_common.raiseError ~loc - "JSX: somehow there's more than one `children` label" + React_jsx_common.raiseError ~loc + "JSX: somehow there's more than one `children` label" -let merlinFocus = ({loc = Location.none; txt = "merlin.focus"}, PStr []) +let merlinFocus = ({ loc = Location.none; txt = "merlin.focus" }, PStr []) (* Helper method to filter out any attribute that isn't [@react.component] *) let otherAttrsPure (loc, _) = loc.txt <> "react.component" @@ -274682,25 +274904,25 @@ let otherAttrsPure (loc, _) = loc.txt <> "react.component" (* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *) let rec getFnName binding = match binding with - | {ppat_desc = Ppat_var {txt}} -> txt - | {ppat_desc = Ppat_constraint (pat, _)} -> getFnName pat - | {ppat_loc} -> - React_jsx_common.raiseError ~loc:ppat_loc - "react.component calls cannot be destructured." + | { ppat_desc = Ppat_var { txt } } -> txt + | { ppat_desc = Ppat_constraint (pat, _) } -> getFnName pat + | { ppat_loc } -> + React_jsx_common.raiseError ~loc:ppat_loc + "react.component calls cannot be destructured." let makeNewBinding binding expression newName = match binding with - | {pvb_pat = {ppat_desc = Ppat_var ppat_var} as pvb_pat} -> - { - binding with - pvb_pat = - {pvb_pat with ppat_desc = Ppat_var {ppat_var with txt = newName}}; - pvb_expr = expression; - pvb_attributes = [merlinFocus]; - } - | {pvb_loc} -> - React_jsx_common.raiseError ~loc:pvb_loc - "react.component calls cannot be destructured." + | { pvb_pat = { ppat_desc = Ppat_var ppat_var } as pvb_pat } -> + { + binding with + pvb_pat = + { pvb_pat with ppat_desc = Ppat_var { ppat_var with txt = newName } }; + pvb_expr = expression; + pvb_attributes = [ merlinFocus ]; + } + | { pvb_loc } -> + React_jsx_common.raiseError ~loc:pvb_loc + "react.component calls cannot be destructured." (* Lookup the filename from the location information on the AST node and turn it into a valid module identifier *) let filenameFromLoc (pstr_loc : Location.t) = @@ -274725,7 +274947,7 @@ let makeModuleName fileName nestedModules fnName = | "", nestedModules, fnName -> List.rev (fnName :: nestedModules) | fileName, nestedModules, "make" -> fileName :: List.rev nestedModules | fileName, nestedModules, fnName -> - fileName :: List.rev (fnName :: nestedModules) + fileName :: List.rev (fnName :: nestedModules) in let fullModuleName = String.concat "$" fullModuleName in fullModuleName @@ -274742,21 +274964,23 @@ let recordFromProps ~loc ~removeKey callArguments = let rec removeLastPositionUnitAux props acc = match props with | [] -> acc - | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] -> - acc - | (Nolabel, {pexp_loc}) :: _rest -> - React_jsx_common.raiseError ~loc:pexp_loc - "JSX: found non-labelled argument before the last position" - | ((Labelled txt, {pexp_loc}) as prop) :: rest - | ((Optional txt, {pexp_loc}) as prop) :: rest -> - if txt = spreadPropsLabel then - match acc with - | [] -> removeLastPositionUnitAux rest (prop :: acc) - | _ -> - React_jsx_common.raiseError ~loc:pexp_loc - "JSX: use {...p} {x: v} not {x: v} {...p} \n\ - \ multiple spreads {...p} {...p} not allowed." - else removeLastPositionUnitAux rest (prop :: acc) + | [ + (Nolabel, { pexp_desc = Pexp_construct ({ txt = Lident "()" }, None) }); + ] -> + acc + | (Nolabel, { pexp_loc }) :: _rest -> + React_jsx_common.raiseError ~loc:pexp_loc + "JSX: found non-labelled argument before the last position" + | ((Labelled txt, { pexp_loc }) as prop) :: rest + | ((Optional txt, { pexp_loc }) as prop) :: rest -> + if txt = spreadPropsLabel then + match acc with + | [] -> removeLastPositionUnitAux rest (prop :: acc) + | _ -> + React_jsx_common.raiseError ~loc:pexp_loc + "JSX: use {...p} {x: v} not {x: v} {...p} \n\ + \ multiple spreads {...p} {...p} not allowed." + else removeLastPositionUnitAux rest (prop :: acc) in let props, propsToSpread = removeLastPositionUnitAux callArguments [] @@ -274769,34 +274993,34 @@ let recordFromProps ~loc ~removeKey callArguments = else props in - let processProp (arg_label, ({pexp_loc} as pexpr)) = + let processProp (arg_label, ({ pexp_loc } as pexpr)) = (* In case filed label is "key" only then change expression to option *) let id = getLabel arg_label in if isOptional arg_label then - ( {txt = Lident id; loc = pexp_loc}, - {pexpr with pexp_attributes = optionalAttrs} ) - else ({txt = Lident id; loc = pexp_loc}, pexpr) + ( { txt = Lident id; loc = pexp_loc }, + { pexpr with pexp_attributes = optionalAttrs } ) + else ({ txt = Lident id; loc = pexp_loc }, pexpr) in let fields = props |> List.map processProp in let spreadFields = propsToSpread |> List.map (fun (_, expression) -> expression) in match (fields, spreadFields) with - | [], [spreadProps] | [], spreadProps :: _ -> spreadProps + | [], [ spreadProps ] | [], spreadProps :: _ -> spreadProps | _, [] -> - { - pexp_desc = Pexp_record (fields, None); - pexp_loc = loc; - pexp_attributes = []; - } - | _, [spreadProps] + { + pexp_desc = Pexp_record (fields, None); + pexp_loc = loc; + pexp_attributes = []; + } + | _, [ spreadProps ] (* take the first spreadProps only *) | _, spreadProps :: _ -> - { - pexp_desc = Pexp_record (fields, Some spreadProps); - pexp_loc = loc; - pexp_attributes = []; - } + { + pexp_desc = Pexp_record (fields, Some spreadProps); + pexp_loc = loc; + pexp_attributes = []; + } (* make type params for make fn arguments *) (* let make = ({id, name, children}: props<'id, 'name, 'children>) *) @@ -274808,17 +275032,18 @@ let makePropsTypeParamsTvar namedTypeList = let stripOption coreType = match coreType with - | {ptyp_desc = Ptyp_constr ({txt = Lident "option"}, coreTypes)} -> - List.nth_opt coreTypes 0 [@doesNotRaise] + | { ptyp_desc = Ptyp_constr ({ txt = Lident "option" }, coreTypes) } -> + List.nth_opt coreTypes 0 [@doesNotRaise] | _ -> Some coreType let stripJsNullable coreType = match coreType with | { ptyp_desc = - Ptyp_constr ({txt = Ldot (Ldot (Lident "Js", "Nullable"), "t")}, coreTypes); + Ptyp_constr + ({ txt = Ldot (Ldot (Lident "Js", "Nullable"), "t") }, coreTypes); } -> - List.nth_opt coreTypes 0 [@doesNotRaise] + List.nth_opt coreTypes 0 [@doesNotRaise] | _ -> Some coreType (* Make type params of the props type *) @@ -274837,11 +275062,11 @@ let makePropsTypeParams ?(stripExplicitOption = false) For example, if JSX ppx is used for React Native, type would be different. *) match interiorType with - | {ptyp_desc = Ptyp_var "ref"} -> Some (refType Location.none) + | { ptyp_desc = Ptyp_var "ref" } -> Some (refType Location.none) | _ -> - (* Strip explicit Js.Nullable.t in case of forwardRef *) - if stripExplicitJsNullableOfRef then stripJsNullable interiorType - else Some interiorType + (* Strip explicit Js.Nullable.t in case of forwardRef *) + if stripExplicitJsNullableOfRef then stripJsNullable interiorType + else Some interiorType (* Strip the explicit option type in implementation *) (* let make = (~x: option=?) => ... *) else if isOptional && stripExplicitOption then stripOption interiorType @@ -274851,12 +275076,13 @@ let makeLabelDecls ~loc namedTypeList = namedTypeList |> List.map (fun (isOptional, label, _, interiorType) -> if label = "key" then - Type.field ~loc ~attrs:optionalAttrs {txt = label; loc} interiorType + Type.field ~loc ~attrs:optionalAttrs { txt = label; loc } + interiorType else if isOptional then - Type.field ~loc ~attrs:optionalAttrs {txt = label; loc} + Type.field ~loc ~attrs:optionalAttrs { txt = label; loc } (Typ.var @@ safeTypeFromValue @@ Labelled label) else - Type.field ~loc {txt = label; loc} + Type.field ~loc { txt = label; loc } (Typ.var @@ safeTypeFromValue @@ Labelled label)) let makeTypeDecls propsName loc namedTypeList = @@ -274867,13 +275093,13 @@ let makeTypeDecls propsName loc namedTypeList = |> List.map (fun coreType -> (coreType, Invariant)) in [ - Type.mk ~loc ~params {txt = propsName; loc} + Type.mk ~loc ~params { txt = propsName; loc } ~kind:(Ptype_record labelDeclList); ] let makeTypeDeclsWithCoreType propsName loc coreType typVars = [ - Type.mk ~loc {txt = propsName; loc} ~kind:Ptype_abstract + Type.mk ~loc { txt = propsName; loc } ~kind:Ptype_abstract ~params:(typVars |> List.map (fun v -> (v, Invariant))) ~manifest:coreType; ] @@ -274885,7 +275111,7 @@ let makePropsRecordType ~coreTypeOfAttr ~typVarsOfCoreType propsName loc (match coreTypeOfAttr with | None -> makeTypeDecls propsName loc namedTypeList | Some coreType -> - makeTypeDeclsWithCoreType propsName loc coreType typVarsOfCoreType) + makeTypeDeclsWithCoreType propsName loc coreType typVarsOfCoreType) (* type props<'x, 'y, ...> = { x: 'x, y?: 'y, ... } *) let makePropsRecordTypeSig ~coreTypeOfAttr ~typVarsOfCoreType propsName loc @@ -274894,7 +275120,7 @@ let makePropsRecordTypeSig ~coreTypeOfAttr ~typVarsOfCoreType propsName loc (match coreTypeOfAttr with | None -> makeTypeDecls propsName loc namedTypeList | Some coreType -> - makeTypeDeclsWithCoreType propsName loc coreType typVarsOfCoreType) + makeTypeDeclsWithCoreType propsName loc coreType typVarsOfCoreType) let transformUppercaseCall3 ~config modulePath mapper jsxExprLoc callExprLoc attrs callArguments = @@ -274913,26 +275139,30 @@ let transformUppercaseCall3 ~config modulePath mapper jsxExprLoc callExprLoc recursivelyTransformedArgsForMake @ match childrenExpr with - | Exact children -> [(labelled "children", children)] - | ListLiteral {pexp_desc = Pexp_array list} when list = [] -> [] + | Exact children -> [ (labelled "children", children) ] + | ListLiteral { pexp_desc = Pexp_array list } when list = [] -> [] | ListLiteral expression -> ( - (* this is a hack to support react components that introspect into their children *) - childrenArg := Some expression; - match config.React_jsx_common.mode with - | "automatic" -> - [ - ( labelled "children", - Exp.apply - (Exp.ident - {txt = Ldot (Lident "React", "array"); loc = Location.none}) - [(Nolabel, expression)] ); - ] - | _ -> - [ - ( labelled "children", - Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "null")} - ); - ]) + (* this is a hack to support react components that introspect into their children *) + childrenArg := Some expression; + match config.React_jsx_common.mode with + | "automatic" -> + [ + ( labelled "children", + Exp.apply + (Exp.ident + { + txt = Ldot (Lident "React", "array"); + loc = Location.none; + }) + [ (Nolabel, expression) ] ); + ] + | _ -> + [ + ( labelled "children", + Exp.ident + { loc = Location.none; txt = Ldot (Lident "React", "null") } + ); + ]) in let isCap str = String.capitalize_ascii str = str in @@ -274940,10 +275170,10 @@ let transformUppercaseCall3 ~config modulePath mapper jsxExprLoc callExprLoc match modulePath with | Lident _ -> Ldot (modulePath, suffix) | Ldot (_modulePath, value) as fullPath when isCap value -> - Ldot (fullPath, suffix) + Ldot (fullPath, suffix) | modulePath -> modulePath in - let isEmptyRecord {pexp_desc} = + let isEmptyRecord { pexp_desc } = match pexp_desc with | Pexp_record (labelDecls, _) when List.length labelDecls = 0 -> true | _ -> false @@ -274959,59 +275189,69 @@ let transformUppercaseCall3 ~config modulePath mapper jsxExprLoc callExprLoc args |> List.filter (fun (arg_label, _) -> "key" = getLabel arg_label) in let makeID = - Exp.ident ~loc:callExprLoc {txt = ident ~suffix:"make"; loc = callExprLoc} + Exp.ident ~loc:callExprLoc { txt = ident ~suffix:"make"; loc = callExprLoc } in match config.mode with (* The new jsx transform *) | "automatic" -> - let jsxExpr, keyAndUnit = + let jsxExpr, keyAndUnit = + match (!childrenArg, keyProp) with + | None, key :: _ -> + ( Exp.ident + { loc = Location.none; txt = Ldot (Lident "React", "jsxKeyed") }, + [ key; (nolabel, unitExpr ~loc:Location.none) ] ) + | None, [] -> + ( Exp.ident + { loc = Location.none; txt = Ldot (Lident "React", "jsx") }, + [] ) + | Some _, key :: _ -> + ( Exp.ident + { + loc = Location.none; + txt = Ldot (Lident "React", "jsxsKeyed"); + }, + [ key; (nolabel, unitExpr ~loc:Location.none) ] ) + | Some _, [] -> + ( Exp.ident + { loc = Location.none; txt = Ldot (Lident "React", "jsxs") }, + [] ) + in + Exp.apply ~attrs jsxExpr + ([ (nolabel, makeID); (nolabel, props) ] @ keyAndUnit) + | _ -> ( match (!childrenArg, keyProp) with | None, key :: _ -> - ( Exp.ident - {loc = Location.none; txt = Ldot (Lident "React", "jsxKeyed")}, - [key; (nolabel, unitExpr ~loc:Location.none)] ) + Exp.apply ~attrs + (Exp.ident + { + loc = Location.none; + txt = Ldot (Lident "React", "createElementWithKey"); + }) + [ key; (nolabel, makeID); (nolabel, props) ] | None, [] -> - (Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "jsx")}, []) - | Some _, key :: _ -> - ( Exp.ident - {loc = Location.none; txt = Ldot (Lident "React", "jsxsKeyed")}, - [key; (nolabel, unitExpr ~loc:Location.none)] ) - | Some _, [] -> - ( Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "jsxs")}, - [] ) - in - Exp.apply ~attrs jsxExpr ([(nolabel, makeID); (nolabel, props)] @ keyAndUnit) - | _ -> ( - match (!childrenArg, keyProp) with - | None, key :: _ -> - Exp.apply ~attrs - (Exp.ident - { - loc = Location.none; - txt = Ldot (Lident "React", "createElementWithKey"); - }) - [key; (nolabel, makeID); (nolabel, props)] - | None, [] -> - Exp.apply ~attrs - (Exp.ident - {loc = Location.none; txt = Ldot (Lident "React", "createElement")}) - [(nolabel, makeID); (nolabel, props)] - | Some children, key :: _ -> - Exp.apply ~attrs - (Exp.ident - { - loc = Location.none; - txt = Ldot (Lident "React", "createElementVariadicWithKey"); - }) - [key; (nolabel, makeID); (nolabel, props); (nolabel, children)] - | Some children, [] -> - Exp.apply ~attrs - (Exp.ident - { - loc = Location.none; - txt = Ldot (Lident "React", "createElementVariadic"); - }) - [(nolabel, makeID); (nolabel, props); (nolabel, children)]) + Exp.apply ~attrs + (Exp.ident + { + loc = Location.none; + txt = Ldot (Lident "React", "createElement"); + }) + [ (nolabel, makeID); (nolabel, props) ] + | Some children, key :: _ -> + Exp.apply ~attrs + (Exp.ident + { + loc = Location.none; + txt = Ldot (Lident "React", "createElementVariadicWithKey"); + }) + [ key; (nolabel, makeID); (nolabel, props); (nolabel, children) ] + | Some children, [] -> + Exp.apply ~attrs + (Exp.ident + { + loc = Location.none; + txt = Ldot (Lident "React", "createElementVariadic"); + }) + [ (nolabel, makeID); (nolabel, props); (nolabel, children) ]) let transformLowercaseCall3 ~config mapper jsxExprLoc callExprLoc attrs callArguments id = @@ -275019,125 +275259,138 @@ let transformLowercaseCall3 ~config mapper jsxExprLoc callExprLoc attrs match config.React_jsx_common.mode with (* the new jsx transform *) | "automatic" -> - let children, nonChildrenProps = - extractChildren ~removeLastPositionUnit:true ~loc:jsxExprLoc callArguments - in - let argsForMake = nonChildrenProps in - let childrenExpr = transformChildrenIfListUpper ~mapper children in - let recursivelyTransformedArgsForMake = - argsForMake - |> List.map (fun (label, expression) -> - (label, mapper.expr mapper expression)) - in - let childrenArg = ref None in - let args = - recursivelyTransformedArgsForMake - @ - match childrenExpr with - | Exact children -> - [ - ( labelled "children", - Exp.apply ~attrs:optionalAttrs - (Exp.ident - { - txt = Ldot (Lident "ReactDOM", "someElement"); - loc = Location.none; - }) - [(Nolabel, children)] ); - ] - | ListLiteral {pexp_desc = Pexp_array list} when list = [] -> [] - | ListLiteral expression -> - (* this is a hack to support react components that introspect into their children *) - childrenArg := Some expression; - [ - ( labelled "children", - Exp.apply - (Exp.ident - {txt = Ldot (Lident "React", "array"); loc = Location.none}) - [(Nolabel, expression)] ); - ] - in - let isEmptyRecord {pexp_desc} = - match pexp_desc with - | Pexp_record (labelDecls, _) when List.length labelDecls = 0 -> true - | _ -> false - in - let record = recordFromProps ~loc:jsxExprLoc ~removeKey:true args in - let props = - if isEmptyRecord record then emptyRecord ~loc:jsxExprLoc else record - in - let keyProp = - args |> List.filter (fun (arg_label, _) -> "key" = getLabel arg_label) - in - let jsxExpr, keyAndUnit = - match (!childrenArg, keyProp) with - | None, key :: _ -> - ( Exp.ident - {loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsxKeyed")}, - [key; (nolabel, unitExpr ~loc:Location.none)] ) - | None, [] -> - ( Exp.ident {loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsx")}, - [] ) - | Some _, key :: _ -> - ( Exp.ident - {loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsxsKeyed")}, - [key; (nolabel, unitExpr ~loc:Location.none)] ) - | Some _, [] -> - ( Exp.ident {loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsxs")}, - [] ) - in - Exp.apply ~attrs jsxExpr - ([(nolabel, componentNameExpr); (nolabel, props)] @ keyAndUnit) + let children, nonChildrenProps = + extractChildren ~removeLastPositionUnit:true ~loc:jsxExprLoc + callArguments + in + let argsForMake = nonChildrenProps in + let childrenExpr = transformChildrenIfListUpper ~mapper children in + let recursivelyTransformedArgsForMake = + argsForMake + |> List.map (fun (label, expression) -> + (label, mapper.expr mapper expression)) + in + let childrenArg = ref None in + let args = + recursivelyTransformedArgsForMake + @ + match childrenExpr with + | Exact children -> + [ + ( labelled "children", + Exp.apply ~attrs:optionalAttrs + (Exp.ident + { + txt = Ldot (Lident "ReactDOM", "someElement"); + loc = Location.none; + }) + [ (Nolabel, children) ] ); + ] + | ListLiteral { pexp_desc = Pexp_array list } when list = [] -> [] + | ListLiteral expression -> + (* this is a hack to support react components that introspect into their children *) + childrenArg := Some expression; + [ + ( labelled "children", + Exp.apply + (Exp.ident + { + txt = Ldot (Lident "React", "array"); + loc = Location.none; + }) + [ (Nolabel, expression) ] ); + ] + in + let isEmptyRecord { pexp_desc } = + match pexp_desc with + | Pexp_record (labelDecls, _) when List.length labelDecls = 0 -> true + | _ -> false + in + let record = recordFromProps ~loc:jsxExprLoc ~removeKey:true args in + let props = + if isEmptyRecord record then emptyRecord ~loc:jsxExprLoc else record + in + let keyProp = + args |> List.filter (fun (arg_label, _) -> "key" = getLabel arg_label) + in + let jsxExpr, keyAndUnit = + match (!childrenArg, keyProp) with + | None, key :: _ -> + ( Exp.ident + { + loc = Location.none; + txt = Ldot (Lident "ReactDOM", "jsxKeyed"); + }, + [ key; (nolabel, unitExpr ~loc:Location.none) ] ) + | None, [] -> + ( Exp.ident + { loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsx") }, + [] ) + | Some _, key :: _ -> + ( Exp.ident + { + loc = Location.none; + txt = Ldot (Lident "ReactDOM", "jsxsKeyed"); + }, + [ key; (nolabel, unitExpr ~loc:Location.none) ] ) + | Some _, [] -> + ( Exp.ident + { loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsxs") }, + [] ) + in + Exp.apply ~attrs jsxExpr + ([ (nolabel, componentNameExpr); (nolabel, props) ] @ keyAndUnit) | _ -> - let children, nonChildrenProps = - extractChildren ~loc:jsxExprLoc callArguments - in - let childrenExpr = transformChildrenIfList ~mapper children in - let createElementCall = - match children with - (* [@JSX] div(~children=[a]), coming from
a
*) - | { - pexp_desc = - ( Pexp_construct ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple _}) - | Pexp_construct ({txt = Lident "[]"}, None) ); - } -> - "createDOMElementVariadic" - (* [@JSX] div(~children= value), coming from
...(value)
*) - | {pexp_loc} -> - React_jsx_common.raiseError ~loc:pexp_loc - "A spread as a DOM element's children don't make sense written \ - together. You can simply remove the spread." - in - let args = - match nonChildrenProps with - | [_justTheUnitArgumentAtEnd] -> - [ - (* "div" *) - (nolabel, componentNameExpr); - (* [|moreCreateElementCallsHere|] *) - (nolabel, childrenExpr); - ] - | nonEmptyProps -> - let propsRecord = - recordFromProps ~loc:Location.none ~removeKey:false nonEmptyProps - in - [ - (* "div" *) - (nolabel, componentNameExpr); - (* ReactDOM.domProps(~className=blabla, ~foo=bar, ()) *) - (labelled "props", propsRecord); - (* [|moreCreateElementCallsHere|] *) - (nolabel, childrenExpr); - ] - in - Exp.apply ~loc:jsxExprLoc ~attrs - (* ReactDOM.createElement *) - (Exp.ident - { - loc = Location.none; - txt = Ldot (Lident "ReactDOM", createElementCall); - }) - args + let children, nonChildrenProps = + extractChildren ~loc:jsxExprLoc callArguments + in + let childrenExpr = transformChildrenIfList ~mapper children in + let createElementCall = + match children with + (* [@JSX] div(~children=[a]), coming from
a
*) + | { + pexp_desc = + ( Pexp_construct + ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple _ }) + | Pexp_construct ({ txt = Lident "[]" }, None) ); + } -> + "createDOMElementVariadic" + (* [@JSX] div(~children= value), coming from
...(value)
*) + | { pexp_loc } -> + React_jsx_common.raiseError ~loc:pexp_loc + "A spread as a DOM element's children don't make sense written \ + together. You can simply remove the spread." + in + let args = + match nonChildrenProps with + | [ _justTheUnitArgumentAtEnd ] -> + [ + (* "div" *) + (nolabel, componentNameExpr); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr); + ] + | nonEmptyProps -> + let propsRecord = + recordFromProps ~loc:Location.none ~removeKey:false nonEmptyProps + in + [ + (* "div" *) + (nolabel, componentNameExpr); + (* ReactDOM.domProps(~className=blabla, ~foo=bar, ()) *) + (labelled "props", propsRecord); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr); + ] + in + Exp.apply ~loc:jsxExprLoc ~attrs + (* ReactDOM.createElement *) + (Exp.ident + { + loc = Location.none; + txt = Ldot (Lident "ReactDOM", createElementCall); + }) + args let rec recursivelyTransformNamedArgsForMake mapper expr args newtypes coreType = @@ -275145,106 +275398,107 @@ let rec recursivelyTransformNamedArgsForMake mapper expr args newtypes coreType match expr.pexp_desc with (* TODO: make this show up with a loc. *) | Pexp_fun (Labelled "key", _, _, _) | Pexp_fun (Optional "key", _, _, _) -> - React_jsx_common.raiseError ~loc:expr.pexp_loc - "Key cannot be accessed inside of a component. Don't worry - you can \ - always key a component from its parent!" + React_jsx_common.raiseError ~loc:expr.pexp_loc + "Key cannot be accessed inside of a component. Don't worry - you can \ + always key a component from its parent!" | Pexp_fun (Labelled "ref", _, _, _) | Pexp_fun (Optional "ref", _, _, _) -> - React_jsx_common.raiseError ~loc:expr.pexp_loc - "Ref cannot be passed as a normal prop. Please use `forwardRef` API \ - instead." + React_jsx_common.raiseError ~loc:expr.pexp_loc + "Ref cannot be passed as a normal prop. Please use `forwardRef` API \ + instead." | Pexp_fun (arg, default, pattern, expression) when isOptional arg || isLabelled arg -> - let () = - match (isOptional arg, pattern, default) with - | true, {ppat_desc = Ppat_constraint (_, {ptyp_desc})}, None -> ( - match ptyp_desc with - | Ptyp_constr ({txt = Lident "option"}, [_]) -> () - | _ -> - let currentType = + let () = + match (isOptional arg, pattern, default) with + | true, { ppat_desc = Ppat_constraint (_, { ptyp_desc }) }, None -> ( match ptyp_desc with - | Ptyp_constr ({txt}, []) -> - String.concat "." (Longident.flatten txt) - | Ptyp_constr ({txt}, _innerTypeArgs) -> - String.concat "." (Longident.flatten txt) ^ "(...)" - | _ -> "..." - in - Location.prerr_warning pattern.ppat_loc - (Preprocessor - (Printf.sprintf - "React: optional argument annotations must have explicit \ - `option`. Did you mean `option(%s)=?`?" - currentType))) - | _ -> () - in - let alias = - match pattern with - | {ppat_desc = Ppat_alias (_, {txt}) | Ppat_var {txt}} -> txt - | {ppat_desc = Ppat_any} -> "_" - | _ -> getLabel arg - in - let type_ = - match pattern with - | {ppat_desc = Ppat_constraint (_, type_)} -> Some type_ - | _ -> None - in + | Ptyp_constr ({ txt = Lident "option" }, [ _ ]) -> () + | _ -> + let currentType = + match ptyp_desc with + | Ptyp_constr ({ txt }, []) -> + String.concat "." (Longident.flatten txt) + | Ptyp_constr ({ txt }, _innerTypeArgs) -> + String.concat "." (Longident.flatten txt) ^ "(...)" + | _ -> "..." + in + Location.prerr_warning pattern.ppat_loc + (Preprocessor + (Printf.sprintf + "React: optional argument annotations must have \ + explicit `option`. Did you mean `option(%s)=?`?" + currentType))) + | _ -> () + in + let alias = + match pattern with + | { ppat_desc = Ppat_alias (_, { txt }) | Ppat_var { txt } } -> txt + | { ppat_desc = Ppat_any } -> "_" + | _ -> getLabel arg + in + let type_ = + match pattern with + | { ppat_desc = Ppat_constraint (_, type_) } -> Some type_ + | _ -> None + in - recursivelyTransformNamedArgsForMake mapper expression - ((arg, default, pattern, alias, pattern.ppat_loc, type_) :: args) - newtypes coreType + recursivelyTransformNamedArgsForMake mapper expression + ((arg, default, pattern, alias, pattern.ppat_loc, type_) :: args) + newtypes coreType | Pexp_fun ( Nolabel, _, - {ppat_desc = Ppat_construct ({txt = Lident "()"}, _) | Ppat_any}, + { ppat_desc = Ppat_construct ({ txt = Lident "()" }, _) | Ppat_any }, _expression ) -> - (args, newtypes, coreType) + (args, newtypes, coreType) | Pexp_fun ( Nolabel, _, ({ ppat_desc = - Ppat_var {txt} | Ppat_constraint ({ppat_desc = Ppat_var {txt}}, _); + ( Ppat_var { txt } + | Ppat_constraint ({ ppat_desc = Ppat_var { txt } }, _) ); } as pattern), _expression ) -> - if txt = "ref" then - let type_ = - match pattern with - | {ppat_desc = Ppat_constraint (_, type_)} -> Some type_ - | _ -> None - in - (* The ref arguement of forwardRef should be optional *) - ( (Optional "ref", None, pattern, txt, pattern.ppat_loc, type_) :: args, - newtypes, - coreType ) - else (args, newtypes, coreType) + if txt = "ref" then + let type_ = + match pattern with + | { ppat_desc = Ppat_constraint (_, type_) } -> Some type_ + | _ -> None + in + (* The ref arguement of forwardRef should be optional *) + ( (Optional "ref", None, pattern, txt, pattern.ppat_loc, type_) :: args, + newtypes, + coreType ) + else (args, newtypes, coreType) | Pexp_fun (Nolabel, _, pattern, _expression) -> - Location.raise_errorf ~loc:pattern.ppat_loc - "React: react.component refs only support plain arguments and type \ - annotations." + Location.raise_errorf ~loc:pattern.ppat_loc + "React: react.component refs only support plain arguments and type \ + annotations." | Pexp_newtype (label, expression) -> - recursivelyTransformNamedArgsForMake mapper expression args - (label :: newtypes) coreType + recursivelyTransformNamedArgsForMake mapper expression args + (label :: newtypes) coreType | Pexp_constraint (expression, coreType) -> - recursivelyTransformNamedArgsForMake mapper expression args newtypes - (Some coreType) + recursivelyTransformNamedArgsForMake mapper expression args newtypes + (Some coreType) | _ -> (args, newtypes, coreType) let newtypeToVar newtype type_ = let var_desc = Ptyp_var ("type-" ^ newtype) in let typ (mapper : Ast_mapper.mapper) typ = match typ.ptyp_desc with - | Ptyp_constr ({txt = Lident name}, _) when name = newtype -> - {typ with ptyp_desc = var_desc} + | Ptyp_constr ({ txt = Lident name }, _) when name = newtype -> + { typ with ptyp_desc = var_desc } | _ -> Ast_mapper.default_mapper.typ mapper typ in - let mapper = {Ast_mapper.default_mapper with typ} in + let mapper = { Ast_mapper.default_mapper with typ } in mapper.typ mapper type_ let argToType ~newtypes ~(typeConstraints : core_type option) types (name, default, _noLabelName, _alias, loc, type_) = let rec getType name coreType = match coreType with - | {ptyp_desc = Ptyp_arrow (arg, c1, c2)} -> - if name = arg then Some c1 else getType name c2 + | { ptyp_desc = Ptyp_arrow (arg, c1, c2) } -> + if name = arg then Some c1 else getType name c2 | _ -> None in let typeConst = Option.bind typeConstraints (getType name) in @@ -275258,17 +275512,17 @@ let argToType ~newtypes ~(typeConstraints : core_type option) types in match (type_, name, default) with | Some type_, name, _ when isOptional name -> - (true, getLabel name, [], {type_ with ptyp_attributes = optionalAttrs}) - :: types + (true, getLabel name, [], { type_ with ptyp_attributes = optionalAttrs }) + :: types | Some type_, name, _ -> (false, getLabel name, [], type_) :: types | None, name, _ when isOptional name -> - ( true, - getLabel name, - [], - Typ.var ~loc ~attrs:optionalAttrs (safeTypeFromValue name) ) - :: types + ( true, + getLabel name, + [], + Typ.var ~loc ~attrs:optionalAttrs (safeTypeFromValue name) ) + :: types | None, name, _ when isLabelled name -> - (false, getLabel name, [], Typ.var ~loc (safeTypeFromValue name)) :: types + (false, getLabel name, [], Typ.var ~loc (safeTypeFromValue name)) :: types | _ -> types let argWithDefaultValue (name, default, _, _, _, _) = @@ -275283,14 +275537,14 @@ let argToConcreteType types (name, _loc, type_) = | _ -> types let check_string_int_attribute_iter = - let attribute _ ({txt; loc}, _) = + let attribute _ ({ txt; loc }, _) = if txt = "string" || txt = "int" then React_jsx_common.raiseError ~loc "@string and @int attributes not supported. See \ https://github.com/rescript-lang/rescript-compiler/issues/5724" in - {Ast_iterator.default_iterator with attribute} + { Ast_iterator.default_iterator with attribute } let transformStructureItem ~config mapper item = match item with @@ -275298,590 +275552,625 @@ let transformStructureItem ~config mapper item = | { pstr_loc; pstr_desc = - Pstr_primitive ({pval_attributes; pval_type} as value_description); + Pstr_primitive ({ pval_attributes; pval_type } as value_description); } as pstr -> ( - match List.filter React_jsx_common.hasAttr pval_attributes with - | [] -> [item] - | [_] -> - (* If there is another @react.component, throw error *) - if config.React_jsx_common.hasReactComponent then - React_jsx_common.raiseErrorMultipleReactComponent ~loc:pstr_loc - else ( - config.hasReactComponent <- true; - check_string_int_attribute_iter.structure_item - check_string_int_attribute_iter item; - let coreTypeOfAttr = React_jsx_common.coreTypeOfAttrs pval_attributes in - let typVarsOfCoreType = - coreTypeOfAttr - |> Option.map React_jsx_common.typVarsOfCoreType - |> Option.value ~default:[] - in - let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = - match ptyp_desc with - | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) - when isLabelled name || isOptional name -> - getPropTypes ((name, ptyp_loc, type_) :: types) rest - | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest - | Ptyp_arrow (name, type_, returnValue) - when isLabelled name || isOptional name -> - (returnValue, (name, returnValue.ptyp_loc, type_) :: types) - | _ -> (fullType, types) - in - let innerType, propTypes = getPropTypes [] pval_type in - let namedTypeList = List.fold_left argToConcreteType [] propTypes in - let retPropsType = - Typ.constr ~loc:pstr_loc - (Location.mkloc (Lident "props") pstr_loc) - (match coreTypeOfAttr with - | None -> makePropsTypeParams namedTypeList - | Some _ -> typVarsOfCoreType) - in - (* type props<'x, 'y> = { x: 'x, y?: 'y, ... } *) - let propsRecordType = - makePropsRecordType ~coreTypeOfAttr ~typVarsOfCoreType "props" - pstr_loc namedTypeList - in - (* can't be an arrow because it will defensively uncurry *) - let newExternalType = - Ptyp_constr - ( {loc = pstr_loc; txt = Ldot (Lident "React", "componentLike")}, - [retPropsType; innerType] ) - in - let newStructure = - { - pstr with - pstr_desc = - Pstr_primitive - { - value_description with - pval_type = {pval_type with ptyp_desc = newExternalType}; - pval_attributes = List.filter otherAttrsPure pval_attributes; - }; - } - in - [propsRecordType; newStructure]) - | _ -> - React_jsx_common.raiseError ~loc:pstr_loc - "Only one react.component call can exist on a component at one time") + match List.filter React_jsx_common.hasAttr pval_attributes with + | [] -> [ item ] + | [ _ ] -> + (* If there is another @react.component, throw error *) + if config.React_jsx_common.hasReactComponent then + React_jsx_common.raiseErrorMultipleReactComponent ~loc:pstr_loc + else ( + config.hasReactComponent <- true; + check_string_int_attribute_iter.structure_item + check_string_int_attribute_iter item; + let coreTypeOfAttr = + React_jsx_common.coreTypeOfAttrs pval_attributes + in + let typVarsOfCoreType = + coreTypeOfAttr + |> Option.map React_jsx_common.typVarsOfCoreType + |> Option.value ~default:[] + in + let rec getPropTypes types ({ ptyp_loc; ptyp_desc } as fullType) = + match ptyp_desc with + | Ptyp_arrow (name, type_, ({ ptyp_desc = Ptyp_arrow _ } as rest)) + when isLabelled name || isOptional name -> + getPropTypes ((name, ptyp_loc, type_) :: types) rest + | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest + | Ptyp_arrow (name, type_, returnValue) + when isLabelled name || isOptional name -> + (returnValue, (name, returnValue.ptyp_loc, type_) :: types) + | _ -> (fullType, types) + in + let innerType, propTypes = getPropTypes [] pval_type in + let namedTypeList = List.fold_left argToConcreteType [] propTypes in + let retPropsType = + Typ.constr ~loc:pstr_loc + (Location.mkloc (Lident "props") pstr_loc) + (match coreTypeOfAttr with + | None -> makePropsTypeParams namedTypeList + | Some _ -> typVarsOfCoreType) + in + (* type props<'x, 'y> = { x: 'x, y?: 'y, ... } *) + let propsRecordType = + makePropsRecordType ~coreTypeOfAttr ~typVarsOfCoreType "props" + pstr_loc namedTypeList + in + (* can't be an arrow because it will defensively uncurry *) + let newExternalType = + Ptyp_constr + ( { + loc = pstr_loc; + txt = Ldot (Lident "React", "componentLike"); + }, + [ retPropsType; innerType ] ) + in + let newStructure = + { + pstr with + pstr_desc = + Pstr_primitive + { + value_description with + pval_type = { pval_type with ptyp_desc = newExternalType }; + pval_attributes = + List.filter otherAttrsPure pval_attributes; + }; + } + in + [ propsRecordType; newStructure ]) + | _ -> + React_jsx_common.raiseError ~loc:pstr_loc + "Only one react.component call can exist on a component at one time" + ) (* let component = ... *) - | {pstr_loc; pstr_desc = Pstr_value (recFlag, valueBindings)} -> ( - let fileName = filenameFromLoc pstr_loc in - let emptyLoc = Location.in_file fileName in - let mapBinding binding = - if React_jsx_common.hasAttrOnBinding binding then - if config.hasReactComponent then - React_jsx_common.raiseErrorMultipleReactComponent ~loc:pstr_loc - else ( - config.hasReactComponent <- true; - let coreTypeOfAttr = - React_jsx_common.coreTypeOfAttrs binding.pvb_attributes - in - let typVarsOfCoreType = - coreTypeOfAttr - |> Option.map React_jsx_common.typVarsOfCoreType - |> Option.value ~default:[] - in - let bindingLoc = binding.pvb_loc in - let bindingPatLoc = binding.pvb_pat.ppat_loc in - let binding = - { - binding with - pvb_pat = {binding.pvb_pat with ppat_loc = emptyLoc}; - pvb_loc = emptyLoc; - } - in - let fnName = getFnName binding.pvb_pat in - let internalFnName = fnName ^ "$Internal" in - let fullModuleName = - makeModuleName fileName config.nestedModules fnName - in - let modifiedBindingOld binding = - let expression = binding.pvb_expr in - (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) - let rec spelunkForFunExpression expression = - match expression with - (* let make = (~prop) => ... *) - | {pexp_desc = Pexp_fun _} | {pexp_desc = Pexp_newtype _} -> - expression - (* let make = {let foo = bar in (~prop) => ...} *) - | {pexp_desc = Pexp_let (_recursive, _vbs, returnExpression)} -> - (* here's where we spelunk! *) - spelunkForFunExpression returnExpression - (* let make = React.forwardRef((~prop) => ...) *) - | { - pexp_desc = - Pexp_apply - (_wrapperExpression, [(Nolabel, innerFunctionExpression)]); - } -> - spelunkForFunExpression innerFunctionExpression - | { - pexp_desc = - Pexp_sequence (_wrapperExpression, innerFunctionExpression); - } -> - spelunkForFunExpression innerFunctionExpression - | {pexp_desc = Pexp_constraint (innerFunctionExpression, _typ)} -> - spelunkForFunExpression innerFunctionExpression - | {pexp_loc} -> - React_jsx_common.raiseError ~loc:pexp_loc - "react.component calls can only be on function definitions \ - or component wrappers (forwardRef, memo)." + | { pstr_loc; pstr_desc = Pstr_value (recFlag, valueBindings) } -> ( + let fileName = filenameFromLoc pstr_loc in + let emptyLoc = Location.in_file fileName in + let mapBinding binding = + if React_jsx_common.hasAttrOnBinding binding then + if config.hasReactComponent then + React_jsx_common.raiseErrorMultipleReactComponent ~loc:pstr_loc + else ( + config.hasReactComponent <- true; + let coreTypeOfAttr = + React_jsx_common.coreTypeOfAttrs binding.pvb_attributes in - spelunkForFunExpression expression - in - let modifiedBinding binding = - let hasApplication = ref false in - let wrapExpressionWithBinding expressionFn expression = - Vb.mk ~loc:bindingLoc - ~attrs:(List.filter otherAttrsPure binding.pvb_attributes) - (Pat.var ~loc:bindingPatLoc {loc = bindingPatLoc; txt = fnName}) - (expressionFn expression) + let typVarsOfCoreType = + coreTypeOfAttr + |> Option.map React_jsx_common.typVarsOfCoreType + |> Option.value ~default:[] in - let expression = binding.pvb_expr in - (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) - let rec spelunkForFunExpression expression = - match expression with - (* let make = (~prop) => ... with no final unit *) - | { - pexp_desc = - Pexp_fun - ( ((Labelled _ | Optional _) as label), - default, - pattern, - ({pexp_desc = Pexp_fun _} as internalExpression) ); - } -> - let wrap, hasForwardRef, exp = - spelunkForFunExpression internalExpression - in - ( wrap, - hasForwardRef, - { - expression with - pexp_desc = Pexp_fun (label, default, pattern, exp); - } ) - (* let make = (()) => ... *) - (* let make = (_) => ... *) - | { - pexp_desc = - Pexp_fun - ( Nolabel, - _default, - { - ppat_desc = - Ppat_construct ({txt = Lident "()"}, _) | Ppat_any; - }, - _internalExpression ); - } -> - ((fun a -> a), false, expression) - (* let make = (~prop) => ... *) - | { - pexp_desc = - Pexp_fun - ( (Labelled _ | Optional _), - _default, - _pattern, - _internalExpression ); - } -> - ((fun a -> a), false, expression) - (* let make = (prop) => ... *) - | { - pexp_desc = - Pexp_fun (_nolabel, _default, pattern, _internalExpression); - } -> - if !hasApplication then ((fun a -> a), false, expression) - else - Location.raise_errorf ~loc:pattern.ppat_loc - "React: props need to be labelled arguments.\n\ - \ If you are working with refs be sure to wrap with \ - React.forwardRef.\n\ - \ If your component doesn't have any props use () or _ \ - instead of a name." - (* let make = {let foo = bar in (~prop) => ...} *) - | {pexp_desc = Pexp_let (recursive, vbs, internalExpression)} -> - (* here's where we spelunk! *) - let wrap, hasForwardRef, exp = - spelunkForFunExpression internalExpression - in - ( wrap, - hasForwardRef, - {expression with pexp_desc = Pexp_let (recursive, vbs, exp)} - ) - (* let make = React.forwardRef((~prop) => ...) *) - | { - pexp_desc = - Pexp_apply (wrapperExpression, [(Nolabel, internalExpression)]); - } -> - let () = hasApplication := true in - let _, _, exp = spelunkForFunExpression internalExpression in - let hasForwardRef = isForwardRef wrapperExpression in - ( (fun exp -> Exp.apply wrapperExpression [(nolabel, exp)]), - hasForwardRef, - exp ) - | { - pexp_desc = Pexp_sequence (wrapperExpression, internalExpression); - } -> - let wrap, hasForwardRef, exp = - spelunkForFunExpression internalExpression - in - ( wrap, - hasForwardRef, - { - expression with - pexp_desc = Pexp_sequence (wrapperExpression, exp); - } ) - | e -> ((fun a -> a), false, e) + let bindingLoc = binding.pvb_loc in + let bindingPatLoc = binding.pvb_pat.ppat_loc in + let binding = + { + binding with + pvb_pat = { binding.pvb_pat with ppat_loc = emptyLoc }; + pvb_loc = emptyLoc; + } + in + let fnName = getFnName binding.pvb_pat in + let internalFnName = fnName ^ "$Internal" in + let fullModuleName = + makeModuleName fileName config.nestedModules fnName in - let wrapExpression, hasForwardRef, expression = + let modifiedBindingOld binding = + let expression = binding.pvb_expr in + (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) + let rec spelunkForFunExpression expression = + match expression with + (* let make = (~prop) => ... *) + | { pexp_desc = Pexp_fun _ } | { pexp_desc = Pexp_newtype _ } -> + expression + (* let make = {let foo = bar in (~prop) => ...} *) + | { pexp_desc = Pexp_let (_recursive, _vbs, returnExpression) } + -> + (* here's where we spelunk! *) + spelunkForFunExpression returnExpression + (* let make = React.forwardRef((~prop) => ...) *) + | { + pexp_desc = + Pexp_apply + (_wrapperExpression, [ (Nolabel, innerFunctionExpression) ]); + } -> + spelunkForFunExpression innerFunctionExpression + | { + pexp_desc = + Pexp_sequence (_wrapperExpression, innerFunctionExpression); + } -> + spelunkForFunExpression innerFunctionExpression + | { + pexp_desc = Pexp_constraint (innerFunctionExpression, _typ); + } -> + spelunkForFunExpression innerFunctionExpression + | { pexp_loc } -> + React_jsx_common.raiseError ~loc:pexp_loc + "react.component calls can only be on function \ + definitions or component wrappers (forwardRef, memo)." + in spelunkForFunExpression expression in - (wrapExpressionWithBinding wrapExpression, hasForwardRef, expression) - in - let bindingWrapper, hasForwardRef, expression = - modifiedBinding binding - in - (* do stuff here! *) - let namedArgList, newtypes, typeConstraints = - recursivelyTransformNamedArgsForMake mapper - (modifiedBindingOld binding) - [] [] None - in - let namedTypeList = - List.fold_left - (argToType ~newtypes ~typeConstraints) - [] namedArgList - in - let namedArgWithDefaultValueList = - List.filter_map argWithDefaultValue namedArgList - in - let vbMatch (label, default) = - Vb.mk - (Pat.var (Location.mknoloc label)) - (Exp.match_ - (Exp.ident {txt = Lident label; loc = Location.none}) - [ - Exp.case - (Pat.construct - (Location.mknoloc @@ Lident "Some") - (Some (Pat.var (Location.mknoloc label)))) - (Exp.ident (Location.mknoloc @@ Lident label)); - Exp.case - (Pat.construct (Location.mknoloc @@ Lident "None") None) - default; - ]) - in - let vbMatchList = List.map vbMatch namedArgWithDefaultValueList in - (* type props = { ... } *) - let propsRecordType = - makePropsRecordType ~coreTypeOfAttr ~typVarsOfCoreType "props" - pstr_loc namedTypeList - in - let innerExpression = - Exp.apply - (Exp.ident (Location.mknoloc @@ Lident fnName)) - ([(Nolabel, Exp.ident (Location.mknoloc @@ Lident "props"))] - @ - match hasForwardRef with - | true -> - [(Nolabel, Exp.ident (Location.mknoloc @@ Lident "ref"))] - | false -> []) - in - let makePropsPattern = function - | [] -> Pat.var @@ Location.mknoloc "props" - | _ -> - Pat.constraint_ - (Pat.var @@ Location.mknoloc "props") - (Typ.constr (Location.mknoloc @@ Lident "props") [Typ.any ()]) - in - let fullExpression = - (* React component name should start with uppercase letter *) - (* let make = { let \"App" = props => make(props); \"App" } *) - (* let make = React.forwardRef({ - let \"App" = (props, ref) => make({...props, ref: @optional (Js.Nullabel.toOption(ref))}) - })*) - Exp.fun_ nolabel None - (match coreTypeOfAttr with - | None -> makePropsPattern namedTypeList - | Some _ -> makePropsPattern typVarsOfCoreType) - (if hasForwardRef then - Exp.fun_ nolabel None - (Pat.var @@ Location.mknoloc "ref") - innerExpression - else innerExpression) - in - let fullExpression = - match fullModuleName with - | "" -> fullExpression - | txt -> - Exp.let_ Nonrecursive - [ - Vb.mk ~loc:emptyLoc - (Pat.var ~loc:emptyLoc {loc = emptyLoc; txt}) - fullExpression; - ] - (Exp.ident ~loc:pstr_loc {loc = emptyLoc; txt = Lident txt}) - in - let rec stripConstraintUnpack ~label pattern = - match pattern with - | {ppat_desc = Ppat_constraint (pattern, _)} -> - stripConstraintUnpack ~label pattern - | {ppat_desc = Ppat_unpack _; ppat_loc} -> - (* remove unpack e.g. model: module(T) *) - Pat.var ~loc:ppat_loc {txt = label; loc = ppat_loc} - | _ -> pattern - in - let rec returnedExpression patternsWithLabel patternsWithNolabel - ({pexp_desc} as expr) = - match pexp_desc with - | Pexp_newtype (_, expr) -> - returnedExpression patternsWithLabel patternsWithNolabel expr - | Pexp_constraint (expr, _) -> - returnedExpression patternsWithLabel patternsWithNolabel expr - | Pexp_fun - ( _arg_label, - _default, - { - ppat_desc = - Ppat_construct ({txt = Lident "()"}, _) | Ppat_any; - }, - expr ) -> - (patternsWithLabel, patternsWithNolabel, expr) - | Pexp_fun - (arg_label, _default, ({ppat_loc; ppat_desc} as pattern), expr) - -> ( - let patternWithoutConstraint = - stripConstraintUnpack ~label:(getLabel arg_label) pattern + let modifiedBinding binding = + let hasApplication = ref false in + let wrapExpressionWithBinding expressionFn expression = + Vb.mk ~loc:bindingLoc + ~attrs:(List.filter otherAttrsPure binding.pvb_attributes) + (Pat.var ~loc:bindingPatLoc + { loc = bindingPatLoc; txt = fnName }) + (expressionFn expression) in - if isLabelled arg_label || isOptional arg_label then - returnedExpression - (( {loc = ppat_loc; txt = Lident (getLabel arg_label)}, - { - patternWithoutConstraint with - ppat_attributes = - (if isOptional arg_label then optionalAttrs else []) - @ pattern.ppat_attributes; - } ) - :: patternsWithLabel) - patternsWithNolabel expr - else - (* Special case of nolabel arg "ref" in forwardRef fn *) - (* let make = React.forwardRef(ref => body) *) - match ppat_desc with - | Ppat_var {txt} - | Ppat_constraint ({ppat_desc = Ppat_var {txt}}, _) -> - returnedExpression patternsWithLabel - (( {loc = ppat_loc; txt = Lident txt}, + let expression = binding.pvb_expr in + (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) + let rec spelunkForFunExpression expression = + match expression with + (* let make = (~prop) => ... with no final unit *) + | { + pexp_desc = + Pexp_fun + ( ((Labelled _ | Optional _) as label), + default, + pattern, + ({ pexp_desc = Pexp_fun _ } as internalExpression) ); + } -> + let wrap, hasForwardRef, exp = + spelunkForFunExpression internalExpression + in + ( wrap, + hasForwardRef, + { + expression with + pexp_desc = Pexp_fun (label, default, pattern, exp); + } ) + (* let make = (()) => ... *) + (* let make = (_) => ... *) + | { + pexp_desc = + Pexp_fun + ( Nolabel, + _default, { - pattern with - ppat_attributes = - optionalAttrs @ pattern.ppat_attributes; - } ) - :: patternsWithNolabel) - expr - | _ -> - returnedExpression patternsWithLabel patternsWithNolabel expr) - | _ -> (patternsWithLabel, patternsWithNolabel, expr) + ppat_desc = + Ppat_construct ({ txt = Lident "()" }, _) | Ppat_any; + }, + _internalExpression ); + } -> + ((fun a -> a), false, expression) + (* let make = (~prop) => ... *) + | { + pexp_desc = + Pexp_fun + ( (Labelled _ | Optional _), + _default, + _pattern, + _internalExpression ); + } -> + ((fun a -> a), false, expression) + (* let make = (prop) => ... *) + | { + pexp_desc = + Pexp_fun (_nolabel, _default, pattern, _internalExpression); + } -> + if !hasApplication then ((fun a -> a), false, expression) + else + Location.raise_errorf ~loc:pattern.ppat_loc + "React: props need to be labelled arguments.\n\ + \ If you are working with refs be sure to wrap with \ + React.forwardRef.\n\ + \ If your component doesn't have any props use () or \ + _ instead of a name." + (* let make = {let foo = bar in (~prop) => ...} *) + | { pexp_desc = Pexp_let (recursive, vbs, internalExpression) } + -> + (* here's where we spelunk! *) + let wrap, hasForwardRef, exp = + spelunkForFunExpression internalExpression + in + ( wrap, + hasForwardRef, + { + expression with + pexp_desc = Pexp_let (recursive, vbs, exp); + } ) + (* let make = React.forwardRef((~prop) => ...) *) + | { + pexp_desc = + Pexp_apply + (wrapperExpression, [ (Nolabel, internalExpression) ]); + } -> + let () = hasApplication := true in + let _, _, exp = + spelunkForFunExpression internalExpression + in + let hasForwardRef = isForwardRef wrapperExpression in + ( (fun exp -> Exp.apply wrapperExpression [ (nolabel, exp) ]), + hasForwardRef, + exp ) + | { + pexp_desc = + Pexp_sequence (wrapperExpression, internalExpression); + } -> + let wrap, hasForwardRef, exp = + spelunkForFunExpression internalExpression + in + ( wrap, + hasForwardRef, + { + expression with + pexp_desc = Pexp_sequence (wrapperExpression, exp); + } ) + | e -> ((fun a -> a), false, e) + in + let wrapExpression, hasForwardRef, expression = + spelunkForFunExpression expression + in + ( wrapExpressionWithBinding wrapExpression, + hasForwardRef, + expression ) + in + let bindingWrapper, hasForwardRef, expression = + modifiedBinding binding + in + (* do stuff here! *) + let namedArgList, newtypes, typeConstraints = + recursivelyTransformNamedArgsForMake mapper + (modifiedBindingOld binding) + [] [] None + in + let namedTypeList = + List.fold_left + (argToType ~newtypes ~typeConstraints) + [] namedArgList + in + let namedArgWithDefaultValueList = + List.filter_map argWithDefaultValue namedArgList + in + let vbMatch (label, default) = + Vb.mk + (Pat.var (Location.mknoloc label)) + (Exp.match_ + (Exp.ident { txt = Lident label; loc = Location.none }) + [ + Exp.case + (Pat.construct + (Location.mknoloc @@ Lident "Some") + (Some (Pat.var (Location.mknoloc label)))) + (Exp.ident (Location.mknoloc @@ Lident label)); + Exp.case + (Pat.construct (Location.mknoloc @@ Lident "None") None) + default; + ]) + in + let vbMatchList = List.map vbMatch namedArgWithDefaultValueList in + (* type props = { ... } *) + let propsRecordType = + makePropsRecordType ~coreTypeOfAttr ~typVarsOfCoreType "props" + pstr_loc namedTypeList + in + let innerExpression = + Exp.apply + (Exp.ident (Location.mknoloc @@ Lident fnName)) + ([ (Nolabel, Exp.ident (Location.mknoloc @@ Lident "props")) ] + @ + match hasForwardRef with + | true -> + [ (Nolabel, Exp.ident (Location.mknoloc @@ Lident "ref")) ] + | false -> []) + in + let makePropsPattern = function + | [] -> Pat.var @@ Location.mknoloc "props" + | _ -> + Pat.constraint_ + (Pat.var @@ Location.mknoloc "props") + (Typ.constr + (Location.mknoloc @@ Lident "props") + [ Typ.any () ]) + in + let fullExpression = + (* React component name should start with uppercase letter *) + (* let make = { let \"App" = props => make(props); \"App" } *) + (* let make = React.forwardRef({ + let \"App" = (props, ref) => make({...props, ref: @optional (Js.Nullabel.toOption(ref))}) + })*) + Exp.fun_ nolabel None + (match coreTypeOfAttr with + | None -> makePropsPattern namedTypeList + | Some _ -> makePropsPattern typVarsOfCoreType) + (if hasForwardRef then + Exp.fun_ nolabel None + (Pat.var @@ Location.mknoloc "ref") + innerExpression + else innerExpression) + in + let fullExpression = + match fullModuleName with + | "" -> fullExpression + | txt -> + Exp.let_ Nonrecursive + [ + Vb.mk ~loc:emptyLoc + (Pat.var ~loc:emptyLoc { loc = emptyLoc; txt }) + fullExpression; + ] + (Exp.ident ~loc:pstr_loc + { loc = emptyLoc; txt = Lident txt }) + in + let rec stripConstraintUnpack ~label pattern = + match pattern with + | { ppat_desc = Ppat_constraint (pattern, _) } -> + stripConstraintUnpack ~label pattern + | { ppat_desc = Ppat_unpack _; ppat_loc } -> + (* remove unpack e.g. model: module(T) *) + Pat.var ~loc:ppat_loc { txt = label; loc = ppat_loc } + | _ -> pattern + in + let rec returnedExpression patternsWithLabel patternsWithNolabel + ({ pexp_desc } as expr) = + match pexp_desc with + | Pexp_newtype (_, expr) -> + returnedExpression patternsWithLabel patternsWithNolabel expr + | Pexp_constraint (expr, _) -> + returnedExpression patternsWithLabel patternsWithNolabel expr + | Pexp_fun + ( _arg_label, + _default, + { + ppat_desc = + Ppat_construct ({ txt = Lident "()" }, _) | Ppat_any; + }, + expr ) -> + (patternsWithLabel, patternsWithNolabel, expr) + | Pexp_fun + ( arg_label, + _default, + ({ ppat_loc; ppat_desc } as pattern), + expr ) -> ( + let patternWithoutConstraint = + stripConstraintUnpack ~label:(getLabel arg_label) pattern + in + if isLabelled arg_label || isOptional arg_label then + returnedExpression + (( { loc = ppat_loc; txt = Lident (getLabel arg_label) }, + { + patternWithoutConstraint with + ppat_attributes = + (if isOptional arg_label then optionalAttrs + else []) + @ pattern.ppat_attributes; + } ) + :: patternsWithLabel) + patternsWithNolabel expr + else + (* Special case of nolabel arg "ref" in forwardRef fn *) + (* let make = React.forwardRef(ref => body) *) + match ppat_desc with + | Ppat_var { txt } + | Ppat_constraint ({ ppat_desc = Ppat_var { txt } }, _) -> + returnedExpression patternsWithLabel + (( { loc = ppat_loc; txt = Lident txt }, + { + pattern with + ppat_attributes = + optionalAttrs @ pattern.ppat_attributes; + } ) + :: patternsWithNolabel) + expr + | _ -> + returnedExpression patternsWithLabel patternsWithNolabel + expr) + | _ -> (patternsWithLabel, patternsWithNolabel, expr) + in + let patternsWithLabel, patternsWithNolabel, expression = + returnedExpression [] [] expression + in + (* add pattern matching for optional prop value *) + let expression = + if List.length vbMatchList = 0 then expression + else Exp.let_ Nonrecursive vbMatchList expression + in + (* (ref) => expr *) + let expression = + List.fold_left + (fun expr (_, pattern) -> Exp.fun_ Nolabel None pattern expr) + expression patternsWithNolabel + in + let recordPattern = + match patternsWithLabel with + | [] -> Pat.any () + | _ -> Pat.record (List.rev patternsWithLabel) Open + in + let expression = + Exp.fun_ Nolabel None + (Pat.constraint_ recordPattern + (Typ.constr ~loc:emptyLoc + { txt = Lident "props"; loc = emptyLoc } + (match coreTypeOfAttr with + | None -> + makePropsTypeParams ~stripExplicitOption:true + ~stripExplicitJsNullableOfRef:hasForwardRef + namedTypeList + | Some _ -> typVarsOfCoreType))) + expression + in + (* let make = ({id, name, ...}: props<'id, 'name, ...>) => { ... } *) + let bindings, newBinding = + match recFlag with + | Recursive -> + ( [ + bindingWrapper + (Exp.let_ ~loc:emptyLoc Recursive + [ + makeNewBinding binding expression internalFnName; + Vb.mk + (Pat.var { loc = emptyLoc; txt = fnName }) + fullExpression; + ] + (Exp.ident { loc = emptyLoc; txt = Lident fnName })); + ], + None ) + | Nonrecursive -> + ( [ + { + binding with + pvb_expr = expression; + pvb_pat = Pat.var { txt = fnName; loc = Location.none }; + }; + ], + Some (bindingWrapper fullExpression) ) + in + (Some propsRecordType, bindings, newBinding)) + else (None, [ binding ], None) + in + (* END of mapBinding fn *) + let structuresAndBinding = List.map mapBinding valueBindings in + let otherStructures (type_, binding, newBinding) + (types, bindings, newBindings) = + let types = + match type_ with Some type_ -> type_ :: types | None -> types + in + let newBindings = + match newBinding with + | Some newBinding -> newBinding :: newBindings + | None -> newBindings + in + (types, binding @ bindings, newBindings) + in + let types, bindings, newBindings = + List.fold_right otherStructures structuresAndBinding ([], [], []) + in + types + @ [ { pstr_loc; pstr_desc = Pstr_value (recFlag, bindings) } ] + @ + match newBindings with + | [] -> [] + | newBindings -> + [ + { + pstr_loc = emptyLoc; + pstr_desc = Pstr_value (recFlag, newBindings); + }; + ]) + | _ -> [ item ] + +let transformSignatureItem ~config _mapper item = + match item with + | { + psig_loc; + psig_desc = Psig_value ({ pval_attributes; pval_type } as psig_desc); + } as psig -> ( + match List.filter React_jsx_common.hasAttr pval_attributes with + | [] -> [ item ] + | [ _ ] -> + (* If there is another @react.component, throw error *) + if config.React_jsx_common.hasReactComponent then + React_jsx_common.raiseErrorMultipleReactComponent ~loc:psig_loc + else config.hasReactComponent <- true; + check_string_int_attribute_iter.signature_item + check_string_int_attribute_iter item; + let hasForwardRef = ref false in + let coreTypeOfAttr = + React_jsx_common.coreTypeOfAttrs pval_attributes in - let patternsWithLabel, patternsWithNolabel, expression = - returnedExpression [] [] expression + let typVarsOfCoreType = + coreTypeOfAttr + |> Option.map React_jsx_common.typVarsOfCoreType + |> Option.value ~default:[] in - (* add pattern matching for optional prop value *) - let expression = - if List.length vbMatchList = 0 then expression - else Exp.let_ Nonrecursive vbMatchList expression + let rec getPropTypes types ({ ptyp_loc; ptyp_desc } as fullType) = + match ptyp_desc with + | Ptyp_arrow (name, type_, ({ ptyp_desc = Ptyp_arrow _ } as rest)) + when isOptional name || isLabelled name -> + getPropTypes ((name, ptyp_loc, type_) :: types) rest + | Ptyp_arrow + ( Nolabel, + { ptyp_desc = Ptyp_constr ({ txt = Lident "unit" }, _) }, + rest ) -> + getPropTypes types rest + | Ptyp_arrow (Nolabel, _type, rest) -> + hasForwardRef := true; + getPropTypes types rest + | Ptyp_arrow (name, type_, returnValue) + when isOptional name || isLabelled name -> + (returnValue, (name, returnValue.ptyp_loc, type_) :: types) + | _ -> (fullType, types) in - (* (ref) => expr *) - let expression = - List.fold_left - (fun expr (_, pattern) -> Exp.fun_ Nolabel None pattern expr) - expression patternsWithNolabel + let innerType, propTypes = getPropTypes [] pval_type in + let namedTypeList = List.fold_left argToConcreteType [] propTypes in + let retPropsType = + Typ.constr + (Location.mkloc (Lident "props") psig_loc) + (match coreTypeOfAttr with + | None -> makePropsTypeParams namedTypeList + | Some _ -> typVarsOfCoreType) in - let recordPattern = - match patternsWithLabel with - | [] -> Pat.any () - | _ -> Pat.record (List.rev patternsWithLabel) Open + let propsRecordType = + makePropsRecordTypeSig ~coreTypeOfAttr ~typVarsOfCoreType "props" + psig_loc + ((* If there is Nolabel arg, regard the type as ref in forwardRef *) + (if !hasForwardRef then + [ (true, "ref", [], refType Location.none) ] + else []) + @ namedTypeList) in - let expression = - Exp.fun_ Nolabel None - (Pat.constraint_ recordPattern - (Typ.constr ~loc:emptyLoc - {txt = Lident "props"; loc = emptyLoc} - (match coreTypeOfAttr with - | None -> - makePropsTypeParams ~stripExplicitOption:true - ~stripExplicitJsNullableOfRef:hasForwardRef - namedTypeList - | Some _ -> typVarsOfCoreType))) - expression + (* can't be an arrow because it will defensively uncurry *) + let newExternalType = + Ptyp_constr + ( { loc = psig_loc; txt = Ldot (Lident "React", "componentLike") }, + [ retPropsType; innerType ] ) in - (* let make = ({id, name, ...}: props<'id, 'name, ...>) => { ... } *) - let bindings, newBinding = - match recFlag with - | Recursive -> - ( [ - bindingWrapper - (Exp.let_ ~loc:emptyLoc Recursive - [ - makeNewBinding binding expression internalFnName; - Vb.mk - (Pat.var {loc = emptyLoc; txt = fnName}) - fullExpression; - ] - (Exp.ident {loc = emptyLoc; txt = Lident fnName})); - ], - None ) - | Nonrecursive -> - ( [ + let newStructure = + { + psig with + psig_desc = + Psig_value { - binding with - pvb_expr = expression; - pvb_pat = Pat.var {txt = fnName; loc = Location.none}; + psig_desc with + pval_type = { pval_type with ptyp_desc = newExternalType }; + pval_attributes = List.filter otherAttrsPure pval_attributes; }; - ], - Some (bindingWrapper fullExpression) ) + } in - (Some propsRecordType, bindings, newBinding)) - else (None, [binding], None) - in - (* END of mapBinding fn *) - let structuresAndBinding = List.map mapBinding valueBindings in - let otherStructures (type_, binding, newBinding) - (types, bindings, newBindings) = - let types = - match type_ with - | Some type_ -> type_ :: types - | None -> types - in - let newBindings = - match newBinding with - | Some newBinding -> newBinding :: newBindings - | None -> newBindings - in - (types, binding @ bindings, newBindings) - in - let types, bindings, newBindings = - List.fold_right otherStructures structuresAndBinding ([], [], []) - in - types - @ [{pstr_loc; pstr_desc = Pstr_value (recFlag, bindings)}] - @ - match newBindings with - | [] -> [] - | newBindings -> - [{pstr_loc = emptyLoc; pstr_desc = Pstr_value (recFlag, newBindings)}]) - | _ -> [item] - -let transformSignatureItem ~config _mapper item = - match item with - | { - psig_loc; - psig_desc = Psig_value ({pval_attributes; pval_type} as psig_desc); - } as psig -> ( - match List.filter React_jsx_common.hasAttr pval_attributes with - | [] -> [item] - | [_] -> - (* If there is another @react.component, throw error *) - if config.React_jsx_common.hasReactComponent then - React_jsx_common.raiseErrorMultipleReactComponent ~loc:psig_loc - else config.hasReactComponent <- true; - check_string_int_attribute_iter.signature_item - check_string_int_attribute_iter item; - let hasForwardRef = ref false in - let coreTypeOfAttr = React_jsx_common.coreTypeOfAttrs pval_attributes in - let typVarsOfCoreType = - coreTypeOfAttr - |> Option.map React_jsx_common.typVarsOfCoreType - |> Option.value ~default:[] - in - let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = - match ptyp_desc with - | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) - when isOptional name || isLabelled name -> - getPropTypes ((name, ptyp_loc, type_) :: types) rest - | Ptyp_arrow - (Nolabel, {ptyp_desc = Ptyp_constr ({txt = Lident "unit"}, _)}, rest) - -> - getPropTypes types rest - | Ptyp_arrow (Nolabel, _type, rest) -> - hasForwardRef := true; - getPropTypes types rest - | Ptyp_arrow (name, type_, returnValue) - when isOptional name || isLabelled name -> - (returnValue, (name, returnValue.ptyp_loc, type_) :: types) - | _ -> (fullType, types) - in - let innerType, propTypes = getPropTypes [] pval_type in - let namedTypeList = List.fold_left argToConcreteType [] propTypes in - let retPropsType = - Typ.constr - (Location.mkloc (Lident "props") psig_loc) - (match coreTypeOfAttr with - | None -> makePropsTypeParams namedTypeList - | Some _ -> typVarsOfCoreType) - in - let propsRecordType = - makePropsRecordTypeSig ~coreTypeOfAttr ~typVarsOfCoreType "props" - psig_loc - ((* If there is Nolabel arg, regard the type as ref in forwardRef *) - (if !hasForwardRef then [(true, "ref", [], refType Location.none)] - else []) - @ namedTypeList) - in - (* can't be an arrow because it will defensively uncurry *) - let newExternalType = - Ptyp_constr - ( {loc = psig_loc; txt = Ldot (Lident "React", "componentLike")}, - [retPropsType; innerType] ) - in - let newStructure = - { - psig with - psig_desc = - Psig_value - { - psig_desc with - pval_type = {pval_type with ptyp_desc = newExternalType}; - pval_attributes = List.filter otherAttrsPure pval_attributes; - }; - } - in - [propsRecordType; newStructure] - | _ -> - React_jsx_common.raiseError ~loc:psig_loc - "Only one react.component call can exist on a component at one time") - | _ -> [item] + [ propsRecordType; newStructure ] + | _ -> + React_jsx_common.raiseError ~loc:psig_loc + "Only one react.component call can exist on a component at one time" + ) + | _ -> [ item ] let transformJsxCall ~config mapper callExpression callArguments jsxExprLoc attrs = match callExpression.pexp_desc with | Pexp_ident caller -> ( - match caller with - | {txt = Lident "createElement"; loc} -> - React_jsx_common.raiseError ~loc - "JSX: `createElement` should be preceeded by a module name." - (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *) - | {loc; txt = Ldot (modulePath, ("createElement" | "make"))} -> - transformUppercaseCall3 ~config modulePath mapper jsxExprLoc loc attrs - callArguments - (* div(~prop1=foo, ~prop2=bar, ~children=[bla], ()) *) - (* turn that into - ReactDOM.createElement(~props=ReactDOM.props(~props1=foo, ~props2=bar, ()), [|bla|]) *) - | {loc; txt = Lident id} -> - transformLowercaseCall3 ~config mapper jsxExprLoc loc attrs callArguments - id - | {txt = Ldot (_, anythingNotCreateElementOrMake); loc} -> - React_jsx_common.raiseError ~loc - "JSX: the JSX attribute should be attached to a \ - `YourModuleName.createElement` or `YourModuleName.make` call. We saw \ - `%s` instead" - anythingNotCreateElementOrMake - | {txt = Lapply _; loc} -> - (* don't think there's ever a case where this is reached *) - React_jsx_common.raiseError ~loc - "JSX: encountered a weird case while processing the code. Please \ - report this!") + match caller with + | { txt = Lident "createElement"; loc } -> + React_jsx_common.raiseError ~loc + "JSX: `createElement` should be preceeded by a module name." + (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *) + | { loc; txt = Ldot (modulePath, ("createElement" | "make")) } -> + transformUppercaseCall3 ~config modulePath mapper jsxExprLoc loc attrs + callArguments + (* div(~prop1=foo, ~prop2=bar, ~children=[bla], ()) *) + (* turn that into + ReactDOM.createElement(~props=ReactDOM.props(~props1=foo, ~props2=bar, ()), [|bla|]) *) + | { loc; txt = Lident id } -> + transformLowercaseCall3 ~config mapper jsxExprLoc loc attrs + callArguments id + | { txt = Ldot (_, anythingNotCreateElementOrMake); loc } -> + React_jsx_common.raiseError ~loc + "JSX: the JSX attribute should be attached to a \ + `YourModuleName.createElement` or `YourModuleName.make` call. We \ + saw `%s` instead" + anythingNotCreateElementOrMake + | { txt = Lapply _; loc } -> + (* don't think there's ever a case where this is reached *) + React_jsx_common.raiseError ~loc + "JSX: encountered a weird case while processing the code. Please \ + report this!") | _ -> - React_jsx_common.raiseError ~loc:callExpression.pexp_loc - "JSX: `createElement` should be preceeded by a simple, direct module \ - name." + React_jsx_common.raiseError ~loc:callExpression.pexp_loc + "JSX: `createElement` should be preceeded by a simple, direct module \ + name." let expr ~config mapper expression = match expression with @@ -275891,78 +276180,81 @@ let expr ~config mapper expression = pexp_attributes; pexp_loc; } -> ( - let jsxAttribute, nonJSXAttributes = - List.partition - (fun (attribute, _) -> attribute.txt = "JSX") - pexp_attributes - in - match (jsxAttribute, nonJSXAttributes) with - (* no JSX attribute *) - | [], _ -> default_mapper.expr mapper expression - | _, nonJSXAttributes -> - transformJsxCall ~config mapper callExpression callArguments pexp_loc - nonJSXAttributes) + let jsxAttribute, nonJSXAttributes = + List.partition + (fun (attribute, _) -> attribute.txt = "JSX") + pexp_attributes + in + match (jsxAttribute, nonJSXAttributes) with + (* no JSX attribute *) + | [], _ -> default_mapper.expr mapper expression + | _, nonJSXAttributes -> + transformJsxCall ~config mapper callExpression callArguments pexp_loc + nonJSXAttributes) (* is it a list with jsx attribute? Reason <>foo desugars to [@JSX][foo]*) | { pexp_desc = ( Pexp_construct - ({txt = Lident "::"; loc}, Some {pexp_desc = Pexp_tuple _}) - | Pexp_construct ({txt = Lident "[]"; loc}, None) ); + ({ txt = Lident "::"; loc }, Some { pexp_desc = Pexp_tuple _ }) + | Pexp_construct ({ txt = Lident "[]"; loc }, None) ); pexp_attributes; } as listItems -> ( - let jsxAttribute, nonJSXAttributes = - List.partition - (fun (attribute, _) -> attribute.txt = "JSX") - pexp_attributes - in - match (jsxAttribute, nonJSXAttributes) with - (* no JSX attribute *) - | [], _ -> default_mapper.expr mapper expression - | _, nonJSXAttributes -> - let loc = {loc with loc_ghost = true} in - let fragment = - match config.mode with - | "automatic" -> - Exp.ident ~loc {loc; txt = Ldot (Lident "React", "jsxFragment")} - | "classic" | _ -> - Exp.ident ~loc {loc; txt = Ldot (Lident "React", "fragment")} - in - let childrenExpr = transformChildrenIfList ~mapper listItems in - let recordOfChildren children = - Exp.record [(Location.mknoloc (Lident "children"), children)] None - in - let args = - [ - (nolabel, fragment); - (match config.mode with - | "automatic" -> ( - ( nolabel, - match childrenExpr with - | {pexp_desc = Pexp_array children} -> ( - match children with - | [] -> emptyRecord ~loc:Location.none - | [child] -> recordOfChildren child - | _ -> recordOfChildren childrenExpr) - | _ -> recordOfChildren childrenExpr )) - | "classic" | _ -> (nolabel, childrenExpr)); - ] - in - let countOfChildren = function - | {pexp_desc = Pexp_array children} -> List.length children - | _ -> 0 + let jsxAttribute, nonJSXAttributes = + List.partition + (fun (attribute, _) -> attribute.txt = "JSX") + pexp_attributes in - Exp.apply - ~loc (* throw away the [@JSX] attribute and keep the others, if any *) - ~attrs:nonJSXAttributes - (* ReactDOM.createElement *) - (match config.mode with - | "automatic" -> - if countOfChildren childrenExpr > 1 then - Exp.ident ~loc {loc; txt = Ldot (Lident "React", "jsxs")} - else Exp.ident ~loc {loc; txt = Ldot (Lident "React", "jsx")} - | "classic" | _ -> - Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOM", "createElement")}) - args) + match (jsxAttribute, nonJSXAttributes) with + (* no JSX attribute *) + | [], _ -> default_mapper.expr mapper expression + | _, nonJSXAttributes -> + let loc = { loc with loc_ghost = true } in + let fragment = + match config.mode with + | "automatic" -> + Exp.ident ~loc + { loc; txt = Ldot (Lident "React", "jsxFragment") } + | "classic" | _ -> + Exp.ident ~loc { loc; txt = Ldot (Lident "React", "fragment") } + in + let childrenExpr = transformChildrenIfList ~mapper listItems in + let recordOfChildren children = + Exp.record [ (Location.mknoloc (Lident "children"), children) ] None + in + let args = + [ + (nolabel, fragment); + (match config.mode with + | "automatic" -> ( + ( nolabel, + match childrenExpr with + | { pexp_desc = Pexp_array children } -> ( + match children with + | [] -> emptyRecord ~loc:Location.none + | [ child ] -> recordOfChildren child + | _ -> recordOfChildren childrenExpr) + | _ -> recordOfChildren childrenExpr )) + | "classic" | _ -> (nolabel, childrenExpr)); + ] + in + let countOfChildren = function + | { pexp_desc = Pexp_array children } -> List.length children + | _ -> 0 + in + Exp.apply + ~loc + (* throw away the [@JSX] attribute and keep the others, if any *) + ~attrs:nonJSXAttributes + (* ReactDOM.createElement *) + (match config.mode with + | "automatic" -> + if countOfChildren childrenExpr > 1 then + Exp.ident ~loc { loc; txt = Ldot (Lident "React", "jsxs") } + else Exp.ident ~loc { loc; txt = Ldot (Lident "React", "jsx") } + | "classic" | _ -> + Exp.ident ~loc + { loc; txt = Ldot (Lident "ReactDOM", "createElement") }) + args) (* Delegate to the default mapper, a deep identity traversal *) | e -> default_mapper.expr mapper e @@ -276024,10 +276316,10 @@ let getPayloadFields payload = | PStr ({ pstr_desc = - Pstr_eval ({pexp_desc = Pexp_record (recordFields, None)}, _); + Pstr_eval ({ pexp_desc = Pexp_record (recordFields, None) }, _); } :: _rest) -> - recordFields + recordFields | _ -> [] type configKey = Int | String @@ -276038,21 +276330,19 @@ let getJsxConfigByKey ~key ~type_ recordFields = (fun ((lid, expr) : Longident.t Location.loc * expression) -> match (type_, lid, expr) with | ( Int, - {txt = Lident k}, - {pexp_desc = Pexp_constant (Pconst_integer (value, None))} ) + { txt = Lident k }, + { pexp_desc = Pexp_constant (Pconst_integer (value, None)) } ) when k = key -> - Some value + Some value | ( String, - {txt = Lident k}, - {pexp_desc = Pexp_constant (Pconst_string (value, None))} ) + { txt = Lident k }, + { pexp_desc = Pexp_constant (Pconst_string (value, None)) } ) when k = key -> - Some value + Some value | _ -> None) recordFields in - match values with - | [] -> None - | [v] | v :: _ -> Some v + match values with [] -> None | [ v ] | v :: _ -> Some v let getInt ~key fields = match fields |> getJsxConfigByKey ~key ~type_:Int with @@ -276125,7 +276415,7 @@ let getMapper ~config = let item = default_mapper.signature_item mapper item in if config.version = 3 then transformSignatureItem3 mapper item else if config.version = 4 then transformSignatureItem4 mapper item - else [item]) + else [ item ]) items |> List.flatten in @@ -276144,7 +276434,7 @@ let getMapper ~config = let item = default_mapper.structure_item mapper item in if config.version = 3 then transformStructureItem3 mapper item else if config.version = 4 then transformStructureItem4 mapper item - else [item]) + else [ item ]) items |> List.flatten in @@ -276152,7 +276442,7 @@ let getMapper ~config = result in - {default_mapper with expr; module_binding; signature; structure} + { default_mapper with expr; module_binding; signature; structure } let rewrite_implementation ~jsxVersion ~jsxModule ~jsxMode (code : Parsetree.structure) : Parsetree.structure = @@ -280951,7 +281241,7 @@ module Super_code_frame = struct else match src.[current_char] [@doesNotRaise] with | '\n' when current_line = original_line + 2 -> - (current_char, current_line) + (current_char, current_line) | '\n' -> loop (current_line + 1) (current_char + 1) | _ -> loop current_line (current_char + 1) in @@ -280980,12 +281270,10 @@ module Super_code_frame = struct match l with | [] -> accum | head :: rest -> - let accum = - match f i head with - | None -> accum - | Some result -> result :: accum - in - loop f rest (i + 1) accum + let accum = + match f i head with None -> accum | Some result -> result :: accum + in + loop f rest (i + 1) accum in loop f l 0 [] |> List.rev @@ -281034,8 +281322,8 @@ module Super_code_frame = struct let setup = Color.setup type gutter = Number of int | Elided - type highlighted_string = {s: string; start: int; end_: int} - type line = {gutter: gutter; content: highlighted_string list} + type highlighted_string = { s : string; start : int; end_ : int } + type line = { gutter : gutter; content : highlighted_string list } (* Features: @@ -281097,47 +281385,49 @@ module Super_code_frame = struct |> List.map (fun (gutter, line) -> let new_content = if String.length line <= leading_space_to_cut then - [{s = ""; start = 0; end_ = 0}] + [ { s = ""; start = 0; end_ = 0 } ] else (String.sub [@doesNotRaise]) line leading_space_to_cut (String.length line - leading_space_to_cut) |> break_long_line line_width |> List.mapi (fun i line -> match gutter with - | Elided -> {s = line; start = 0; end_ = 0} + | Elided -> { s = line; start = 0; end_ = 0 } | Number line_number -> - let highlight_line_start_offset = - startPos.pos_cnum - startPos.pos_bol - in - let highlight_line_end_offset = - endPos.pos_cnum - endPos.pos_bol - in - let start = - if i = 0 && line_number = highlight_line_start_line - then - highlight_line_start_offset - leading_space_to_cut - else 0 - in - let end_ = - if line_number < highlight_line_start_line then 0 - else if - line_number = highlight_line_start_line - && line_number = highlight_line_end_line - then - highlight_line_end_offset - leading_space_to_cut - else if line_number = highlight_line_start_line then - String.length line - else if - line_number > highlight_line_start_line - && line_number < highlight_line_end_line - then String.length line - else if line_number = highlight_line_end_line then - highlight_line_end_offset - leading_space_to_cut - else 0 - in - {s = line; start; end_}) + let highlight_line_start_offset = + startPos.pos_cnum - startPos.pos_bol + in + let highlight_line_end_offset = + endPos.pos_cnum - endPos.pos_bol + in + let start = + if + i = 0 && line_number = highlight_line_start_line + then + highlight_line_start_offset + - leading_space_to_cut + else 0 + in + let end_ = + if line_number < highlight_line_start_line then 0 + else if + line_number = highlight_line_start_line + && line_number = highlight_line_end_line + then + highlight_line_end_offset - leading_space_to_cut + else if line_number = highlight_line_start_line + then String.length line + else if + line_number > highlight_line_start_line + && line_number < highlight_line_end_line + then String.length line + else if line_number = highlight_line_end_line then + highlight_line_end_offset - leading_space_to_cut + else 0 + in + { s = line; start; end_ }) in - {gutter; content = new_content}) + { gutter; content = new_content }) in let buf = Buffer.create 100 in let open Color in @@ -281173,39 +281463,39 @@ module Super_code_frame = struct add_ch NoColor ' ' in stripped_lines - |> List.iter (fun {gutter; content} -> + |> List.iter (fun { gutter; content } -> match gutter with | Elided -> - draw_gutter Dim "."; - add_ch Dim '.'; - add_ch Dim '.'; - add_ch Dim '.'; - add_ch NoColor '\n' + draw_gutter Dim "."; + add_ch Dim '.'; + add_ch Dim '.'; + add_ch Dim '.'; + add_ch NoColor '\n' | Number line_number -> - content - |> List.iteri (fun i line -> - let gutter_content = - if i = 0 then string_of_int line_number else "" - in - let gutter_color = - if - i = 0 - && line_number >= highlight_line_start_line - && line_number <= highlight_line_end_line - then if is_warning then Warn else Err - else NoColor - in - draw_gutter gutter_color gutter_content; - - line.s - |> String.iteri (fun ii ch -> - let c = - if ii >= line.start && ii < line.end_ then - if is_warning then Warn else Err - else NoColor - in - add_ch c ch); - add_ch NoColor '\n')); + content + |> List.iteri (fun i line -> + let gutter_content = + if i = 0 then string_of_int line_number else "" + in + let gutter_color = + if + i = 0 + && line_number >= highlight_line_start_line + && line_number <= highlight_line_end_line + then if is_warning then Warn else Err + else NoColor + in + draw_gutter gutter_color gutter_content; + + line.s + |> String.iteri (fun ii ch -> + let c = + if ii >= line.start && ii < line.end_ then + if is_warning then Warn else Err + else NoColor + in + add_ch c ch); + add_ch NoColor '\n')); Buffer.contents buf end @@ -281225,15 +281515,15 @@ module Super_location = struct | None -> () | Some ((start_line, start_line_start_char), (end_line, end_line_end_char)) -> - if start_line = end_line then - if start_line_start_char = end_line_end_char then - fprintf ppf ":@{%i:%i@}" start_line start_line_start_char + if start_line = end_line then + if start_line_start_char = end_line_end_char then + fprintf ppf ":@{%i:%i@}" start_line start_line_start_char + else + fprintf ppf ":@{%i:%i-%i@}" start_line start_line_start_char + end_line_end_char else - fprintf ppf ":@{%i:%i-%i@}" start_line start_line_start_char - end_line_end_char - else - fprintf ppf ":@{%i:%i-%i:%i@}" start_line start_line_start_char - end_line end_line_end_char + fprintf ppf ":@{%i:%i-%i:%i@}" start_line start_line_start_char + end_line end_line_end_char in fprintf ppf "@{%a@}%a" print_filename loc.loc_start.pos_fname dim_loc normalizedRange @@ -281243,7 +281533,7 @@ module Super_location = struct (match message_kind with | `warning -> fprintf ppf "@[@{%s@}@]@," intro | `warning_as_error -> - fprintf ppf "@[@{%s@} (configured as error) @]@," intro + fprintf ppf "@[@{%s@} (configured as error) @]@," intro | `error -> fprintf ppf "@[@{%s@}@]@," intro); (* ocaml's reported line/col numbering is horrible and super error-prone when being handled programmatically (or humanly for that matter. If you're @@ -281276,24 +281566,24 @@ module Super_location = struct match normalizedRange with | None -> () | Some _ -> ( - try - (* let src = Ext_io.load_file file in *) - (* we're putting the line break `@,` here rather than above, because this - branch might not be reached (aka no inline file content display) so - we don't wanna end up with two line breaks in the the consequent *) - fprintf ppf "@,%s" - (Super_code_frame.print ~is_warning:(message_kind = `warning) ~src - ~startPos:loc.loc_start ~endPos:loc.loc_end) - with - (* this might happen if the file is e.g. "", "_none_" or any of the fake file name placeholders. - we've already printed the location above, so nothing more to do here. *) - | Sys_error _ -> - ()) + try + (* let src = Ext_io.load_file file in *) + (* we're putting the line break `@,` here rather than above, because this + branch might not be reached (aka no inline file content display) so + we don't wanna end up with two line breaks in the the consequent *) + fprintf ppf "@,%s" + (Super_code_frame.print ~is_warning:(message_kind = `warning) ~src + ~startPos:loc.loc_start ~endPos:loc.loc_end) + with + (* this might happen if the file is e.g. "", "_none_" or any of the fake file name placeholders. + we've already printed the location above, so nothing more to do here. *) + | Sys_error _ -> + ()) (* taken from https://github.com/rescript-lang/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/parsing/location.ml#L380 *) (* This is the error report entry point. We'll replace the default reporter with this one. *) (* let rec super_error_reporter ppf ({loc; msg; sub} : Location.error) = *) - let super_error_reporter ppf src ({loc; msg} : Location.error) = + let super_error_reporter ppf src ({ loc; msg } : Location.error) = setup_colors (); (* open a vertical box. Everything in our message is indented 2 spaces *) (* Format.fprintf ppf "@[@, %a@, %s@,@]" (print ~message_kind:`error "We've found a bug for you!") src loc msg; *) @@ -281380,7 +281670,7 @@ let toString = function | ExprOperand -> "a basic expression" | ExprUnary -> "a unary expression" | ExprBinaryAfterOp op -> - "an expression after the operator \"" ^ Token.toString op ^ "\"" + "an expression after the operator \"" ^ Token.toString op ^ "\"" | ExprIf -> "an if expression" | IfCondition -> "the condition of an if expression" | IfBranch -> "the true-branch of an if expression" @@ -281434,26 +281724,26 @@ let toString = function let isSignatureItemStart = function | Token.At | Let | Typ | External | Exception | Open | Include | Module | AtAt | PercentPercent -> - true + true | _ -> false let isAtomicPatternStart = function | Token.Int _ | String _ | Codepoint _ | Backtick | Lparen | Lbracket | Lbrace | Underscore | Lident _ | Uident _ | List | Exception | Lazy | Percent -> - true + true | _ -> false let isAtomicExprStart = function | Token.True | False | Int _ | String _ | Float _ | Codepoint _ | Backtick | Uident _ | Lident _ | Hash | Lparen | List | Lbracket | Lbrace | LessThan | Module | Percent -> - true + true | _ -> false let isAtomicTypExprStart = function | Token.SingleQuote | Underscore | Lparen | Lbrace | Uident _ | Lident _ | Percent -> - true + true | _ -> false let isExprStart = function @@ -281462,7 +281752,7 @@ let isExprStart = function | List | Lparen | Minus | MinusDot | Module | Percent | Plus | PlusDot | String _ | Switch | True | Try | Uident _ | Underscore (* _ => doThings() *) | While -> - true + true | _ -> false let isJsxAttributeStart = function @@ -281472,7 +281762,7 @@ let isJsxAttributeStart = function let isStructureItemStart = function | Token.Open | Let | Typ | External | Exception | Include | Module | AtAt | PercentPercent | At -> - true + true | t when isExprStart t -> true | _ -> false @@ -281480,7 +281770,7 @@ let isPatternStart = function | Token.Int _ | Float _ | String _ | Codepoint _ | Backtick | True | False | Minus | Plus | Lparen | Lbracket | Lbrace | List | Underscore | Lident _ | Uident _ | Hash | Exception | Lazy | Percent | Module | At -> - true + true | _ -> false let isParameterStart = function @@ -281508,7 +281798,7 @@ let isRecordDeclStart = function let isTypExprStart = function | Token.At | SingleQuote | Underscore | Lparen | Lbracket | Uident _ | Lident _ | Module | Percent | Lbrace -> - true + true | _ -> false let isTypeParameterStart = function @@ -281535,9 +281825,7 @@ let isRecordRowStart = function | t when Token.isKeyword t -> true | _ -> false -let isRecordRowStringKeyStart = function - | Token.String _ -> true - | _ -> false +let isRecordRowStringKeyStart = function Token.String _ -> true | _ -> false let isArgumentStart = function | Token.Tilde | Dot | Underscore -> true @@ -281558,10 +281846,7 @@ let isPatternRecordItemStart = function | Token.DotDotDot | Uident _ | Lident _ | Underscore -> true | _ -> false -let isAttributeStart = function - | Token.At -> true - | _ -> false - +let isAttributeStart = function Token.At -> true | _ -> false let isJsxChildStart = isAtomicExprStart let isBlockExprStart = function @@ -281570,7 +281855,7 @@ let isBlockExprStart = function | Lbracket | LessThan | Let | Lident _ | List | Lparen | Minus | MinusDot | Module | Open | Percent | Plus | PlusDot | String _ | Switch | True | Try | Uident _ | Underscore | While -> - true + true | _ -> false let isListElement grammar token = @@ -281622,7 +281907,7 @@ let isListTerminator grammar token = | ParameterList, (EqualGreater | Lbrace) | JsxAttribute, (Forwardslash | GreaterThan) | StringFieldDeclarations, Rbrace -> - true + true | Attribute, token when token <> At -> true | TypeConstraint, token when token <> Constraint -> true | PackageConstraint, token when token <> And -> true @@ -281646,9 +281931,7 @@ type report val getStartPos : t -> Lexing.position [@@live] (* for playground *) val getEndPos : t -> Lexing.position [@@live] (* for playground *) - val explain : t -> string [@@live] (* for playground *) - val unexpected : Token.t -> (Grammar.t * Lexing.position) list -> category val expected : ?grammar:Grammar.t -> Lexing.position -> Token.t -> category val uident : Token.t -> category @@ -281658,9 +281941,7 @@ val unclosedTemplate : category val unclosedComment : category val unknownUchar : Char.t -> category val message : string -> category - val make : startPos:Lexing.position -> endPos:Lexing.position -> category -> t - val printReport : t list -> string -> unit end = struct @@ -281669,11 +281950,14 @@ module Grammar = Res_grammar module Token = Res_token type category = - | Unexpected of {token: Token.t; context: (Grammar.t * Lexing.position) list} + | Unexpected of { + token : Token.t; + context : (Grammar.t * Lexing.position) list; + } | Expected of { - context: Grammar.t option; - pos: Lexing.position; (* prev token end*) - token: Token.t; + context : Grammar.t option; + pos : Lexing.position; (* prev token end*) + token : Token.t; } | Message of string | Uident of Token.t @@ -281684,9 +281968,9 @@ type category = | UnknownUchar of Char.t type t = { - startPos: Lexing.position; - endPos: Lexing.position; - category: category; + startPos : Lexing.position; + endPos : Lexing.position; + category : category; } type report = t list @@ -281706,131 +281990,140 @@ let reservedKeyword token = let explain t = match t.category with | Uident currentToken -> ( - match currentToken with - | Lident lident -> - let guess = String.capitalize_ascii lident in - "Did you mean `" ^ guess ^ "` instead of `" ^ lident ^ "`?" - | t when Token.isKeyword t -> - let token = Token.toString t in - "`" ^ token ^ "` is a reserved keyword." - | _ -> - "At this point, I'm looking for an uppercased name like `Belt` or `Array`" - ) + match currentToken with + | Lident lident -> + let guess = String.capitalize_ascii lident in + "Did you mean `" ^ guess ^ "` instead of `" ^ lident ^ "`?" + | t when Token.isKeyword t -> + let token = Token.toString t in + "`" ^ token ^ "` is a reserved keyword." + | _ -> + "At this point, I'm looking for an uppercased name like `Belt` or \ + `Array`") | Lident currentToken -> ( - match currentToken with - | Uident uident -> - let guess = String.uncapitalize_ascii uident in - "Did you mean `" ^ guess ^ "` instead of `" ^ uident ^ "`?" - | t when Token.isKeyword t -> - let token = Token.toString t in - "`" ^ token ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" - ^ token ^ "\"" - | Underscore -> "`_` isn't a valid name." - | _ -> "I'm expecting a lowercase name like `user or `age`") + match currentToken with + | Uident uident -> + let guess = String.uncapitalize_ascii uident in + "Did you mean `" ^ guess ^ "` instead of `" ^ uident ^ "`?" + | t when Token.isKeyword t -> + let token = Token.toString t in + "`" ^ token + ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" ^ token + ^ "\"" + | Underscore -> "`_` isn't a valid name." + | _ -> "I'm expecting a lowercase name like `user or `age`") | Message txt -> txt | UnclosedString -> "This string is missing a double quote at the end" | UnclosedTemplate -> - "Did you forget to close this template expression with a backtick?" + "Did you forget to close this template expression with a backtick?" | UnclosedComment -> "This comment seems to be missing a closing `*/`" | UnknownUchar uchar -> ( - match uchar with - | '^' -> - "Not sure what to do with this character.\n" - ^ " If you're trying to dereference a mutable value, use \ - `myValue.contents` instead.\n" - ^ " To concatenate strings, use `\"a\" ++ \"b\"` instead." - | _ -> "Not sure what to do with this character.") - | Expected {context; token = t} -> - let hint = - match context with - | Some grammar -> " It signals the start of " ^ Grammar.toString grammar - | None -> "" - in - "Did you forget a `" ^ Token.toString t ^ "` here?" ^ hint - | Unexpected {token = t; context = breadcrumbs} -> ( - let name = Token.toString t in - match breadcrumbs with - | (AtomicTypExpr, _) :: breadcrumbs -> ( - match (breadcrumbs, t) with - | ( ((StringFieldDeclarations | FieldDeclarations), _) :: _, - (String _ | At | Rbrace | Comma | Eof) ) -> - "I'm missing a type here" - | _, t when Grammar.isStructureItemStart t || t = Eof -> - "Missing a type here" - | _ -> defaultUnexpected t) - | (ExprOperand, _) :: breadcrumbs -> ( - match (breadcrumbs, t) with - | (ExprBlock, _) :: _, Rbrace -> - "It seems that this expression block is empty" - | (ExprBlock, _) :: _, Bar -> - (* Pattern matching *) - "Looks like there might be an expression missing here" - | (ExprSetField, _) :: _, _ -> - "It seems that this record field mutation misses an expression" - | (ExprArrayMutation, _) :: _, _ -> - "Seems that an expression is missing, with what do I mutate the array?" - | ((ExprBinaryAfterOp _ | ExprUnary), _) :: _, _ -> - "Did you forget to write an expression here?" - | (Grammar.LetBinding, _) :: _, _ -> - "This let-binding misses an expression" - | _ :: _, (Rbracket | Rbrace | Eof) -> "Missing expression" - | _ -> "I'm not sure what to parse here when looking at \"" ^ name ^ "\"." - ) - | (TypeParam, _) :: _ -> ( - match t with - | Lident ident -> - "Did you mean '" ^ ident ^ "? A Type parameter starts with a quote." - | _ -> "I'm not sure what to parse here when looking at \"" ^ name ^ "\"." - ) - | (Pattern, _) :: breadcrumbs -> ( - match (t, breadcrumbs) with - | Equal, (LetBinding, _) :: _ -> - "I was expecting a name for this let-binding. Example: `let message = \ - \"hello\"`" - | In, (ExprFor, _) :: _ -> - "A for-loop has the following form: `for i in 0 to 10`. Did you forget \ - to supply a name before `in`?" - | EqualGreater, (PatternMatchCase, _) :: _ -> - "I was expecting a pattern to match on before the `=>`" - | token, _ when Token.isKeyword t -> reservedKeyword token - | token, _ -> defaultUnexpected token) - | _ -> - (* TODO: match on circumstance to verify Lident needed ? *) - if Token.isKeyword t then - "`" ^ name - ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" - ^ Token.toString t ^ "\"" - else "I'm not sure what to parse here when looking at \"" ^ name ^ "\".") + match uchar with + | '^' -> + "Not sure what to do with this character.\n" + ^ " If you're trying to dereference a mutable value, use \ + `myValue.contents` instead.\n" + ^ " To concatenate strings, use `\"a\" ++ \"b\"` instead." + | _ -> "Not sure what to do with this character.") + | Expected { context; token = t } -> + let hint = + match context with + | Some grammar -> " It signals the start of " ^ Grammar.toString grammar + | None -> "" + in + "Did you forget a `" ^ Token.toString t ^ "` here?" ^ hint + | Unexpected { token = t; context = breadcrumbs } -> ( + let name = Token.toString t in + match breadcrumbs with + | (AtomicTypExpr, _) :: breadcrumbs -> ( + match (breadcrumbs, t) with + | ( ((StringFieldDeclarations | FieldDeclarations), _) :: _, + (String _ | At | Rbrace | Comma | Eof) ) -> + "I'm missing a type here" + | _, t when Grammar.isStructureItemStart t || t = Eof -> + "Missing a type here" + | _ -> defaultUnexpected t) + | (ExprOperand, _) :: breadcrumbs -> ( + match (breadcrumbs, t) with + | (ExprBlock, _) :: _, Rbrace -> + "It seems that this expression block is empty" + | (ExprBlock, _) :: _, Bar -> + (* Pattern matching *) + "Looks like there might be an expression missing here" + | (ExprSetField, _) :: _, _ -> + "It seems that this record field mutation misses an expression" + | (ExprArrayMutation, _) :: _, _ -> + "Seems that an expression is missing, with what do I mutate the \ + array?" + | ((ExprBinaryAfterOp _ | ExprUnary), _) :: _, _ -> + "Did you forget to write an expression here?" + | (Grammar.LetBinding, _) :: _, _ -> + "This let-binding misses an expression" + | _ :: _, (Rbracket | Rbrace | Eof) -> "Missing expression" + | _ -> + "I'm not sure what to parse here when looking at \"" ^ name + ^ "\".") + | (TypeParam, _) :: _ -> ( + match t with + | Lident ident -> + "Did you mean '" ^ ident + ^ "? A Type parameter starts with a quote." + | _ -> + "I'm not sure what to parse here when looking at \"" ^ name + ^ "\".") + | (Pattern, _) :: breadcrumbs -> ( + match (t, breadcrumbs) with + | Equal, (LetBinding, _) :: _ -> + "I was expecting a name for this let-binding. Example: `let \ + message = \"hello\"`" + | In, (ExprFor, _) :: _ -> + "A for-loop has the following form: `for i in 0 to 10`. Did you \ + forget to supply a name before `in`?" + | EqualGreater, (PatternMatchCase, _) :: _ -> + "I was expecting a pattern to match on before the `=>`" + | token, _ when Token.isKeyword t -> reservedKeyword token + | token, _ -> defaultUnexpected token) + | _ -> + (* TODO: match on circumstance to verify Lident needed ? *) + if Token.isKeyword t then + "`" ^ name + ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" + ^ Token.toString t ^ "\"" + else + "I'm not sure what to parse here when looking at \"" ^ name ^ "\".") -let make ~startPos ~endPos category = {startPos; endPos; category} +let make ~startPos ~endPos category = { startPos; endPos; category } let printReport diagnostics src = let rec print diagnostics src = match diagnostics with | [] -> () | d :: rest -> - Res_diagnostics_printing_utils.Super_location.super_error_reporter - Format.err_formatter src - Location. - { - loc = {loc_start = d.startPos; loc_end = d.endPos; loc_ghost = false}; - msg = explain d; - sub = []; - if_highlight = ""; - }; - (match rest with - | [] -> () - | _ -> Format.fprintf Format.err_formatter "@."); - print rest src + Res_diagnostics_printing_utils.Super_location.super_error_reporter + Format.err_formatter src + Location. + { + loc = + { + loc_start = d.startPos; + loc_end = d.endPos; + loc_ghost = false; + }; + msg = explain d; + sub = []; + if_highlight = ""; + }; + (match rest with + | [] -> () + | _ -> Format.fprintf Format.err_formatter "@."); + print rest src in Format.fprintf Format.err_formatter "@["; print (List.rev diagnostics) src; Format.fprintf Format.err_formatter "@]@." -let unexpected token context = Unexpected {token; context} - -let expected ?grammar pos token = Expected {context = grammar; pos; token} - +let unexpected token context = Unexpected { token; context } +let expected ?grammar pos token = Expected { context = grammar; pos; token } let uident currentToken = Uident currentToken let lident currentToken = Lident currentToken let unclosedString = UnclosedString @@ -281849,9 +282142,9 @@ module Grammar = Res_grammar type problem = | Unexpected of Token.t [@live] | Expected of { - token: Token.t; - pos: Lexing.position; - context: Grammar.t option; + token : Token.t; + pos : Lexing.position; + context : Grammar.t option; } [@live] | Message of string [@live] | Uident [@live] @@ -281873,42 +282166,38 @@ let convertDecimalToHex ~strDecimal = let intNum = int_of_string strDecimal in let c1 = Array.get hexTable (intNum lsr 4) in let c2 = Array.get hexTable (intNum land 15) in - "x" ^ String.concat "" [String.make 1 c1; String.make 1 c2] + "x" ^ String.concat "" [ String.make 1 c1; String.make 1 c2 ] with Invalid_argument _ | Failure _ -> strDecimal end module Res_scanner : sig #1 "res_scanner.mli" type mode = Jsx | Diamond - type charEncoding type t = { - filename: string; - src: string; - mutable err: + filename : string; + src : string; + mutable err : startPos:Lexing.position -> endPos:Lexing.position -> Res_diagnostics.category -> unit; - mutable ch: charEncoding; (* current character *) - mutable offset: int; (* character offset *) - mutable lineOffset: int; (* current line offset *) - mutable lnum: int; (* current line number *) - mutable mode: mode list; + mutable ch : charEncoding; (* current character *) + mutable offset : int; (* character offset *) + mutable lineOffset : int; (* current line offset *) + mutable lnum : int; (* current line number *) + mutable mode : mode list; } val make : filename:string -> string -> t (* TODO: make this a record *) val scan : t -> Lexing.position * Lexing.position * Res_token.t - val isBinaryOp : string -> int -> int -> bool - val setJsxMode : t -> unit val setDiamondMode : t -> unit val popMode : t -> mode -> unit - val reconsiderLessThan : t -> Res_token.t val scanTemplateLiteralToken : @@ -281928,25 +282217,25 @@ type mode = Jsx | Diamond will also contain the special -1 value to indicate end-of-file. This isn't ideal; we should clean this up *) let hackyEOFChar = Char.unsafe_chr (-1) + type charEncoding = Char.t type t = { - filename: string; - src: string; - mutable err: + filename : string; + src : string; + mutable err : startPos:Lexing.position -> endPos:Lexing.position -> Diagnostics.category -> unit; - mutable ch: charEncoding; (* current character *) - mutable offset: int; (* character offset *) - mutable lineOffset: int; (* current line offset *) - mutable lnum: int; (* current line number *) - mutable mode: mode list; + mutable ch : charEncoding; (* current character *) + mutable offset : int; (* character offset *) + mutable lineOffset : int; (* current line offset *) + mutable lnum : int; (* current line number *) + mutable mode : mode list; } let setDiamondMode scanner = scanner.mode <- Diamond :: scanner.mode - let setJsxMode scanner = scanner.mode <- Jsx :: scanner.mode let popMode scanner mode = @@ -281955,14 +282244,9 @@ let popMode scanner mode = | _ -> () let inDiamondMode scanner = - match scanner.mode with - | Diamond :: _ -> true - | _ -> false + match scanner.mode with Diamond :: _ -> true | _ -> false -let inJsxMode scanner = - match scanner.mode with - | Jsx :: _ -> true - | _ -> false +let inJsxMode scanner = match scanner.mode with Jsx :: _ -> true | _ -> false let position scanner = Lexing. @@ -282002,8 +282286,8 @@ let _printDebug ~startPos ~endPos scanner token = | 0 -> if token = Token.Eof then () else assert false | 1 -> () | n -> - print_string ((String.make [@doesNotRaise]) (n - 2) '-'); - print_char '^'); + print_string ((String.make [@doesNotRaise]) (n - 2) '-'); + print_char '^'); print_char ' '; print_string (Res_token.toString token); print_char ' '; @@ -282017,11 +282301,11 @@ let next scanner = let nextOffset = scanner.offset + 1 in (match scanner.ch with | '\n' -> - scanner.lineOffset <- nextOffset; - scanner.lnum <- scanner.lnum + 1 - (* What about CRLF (\r + \n) on windows? - * \r\n will always be terminated by a \n - * -> we can just bump the line count on \n *) + scanner.lineOffset <- nextOffset; + scanner.lnum <- scanner.lnum + 1 + (* What about CRLF (\r + \n) on windows? + * \r\n will always be terminated by a \n + * -> we can just bump the line count on \n *) | _ -> ()); if nextOffset < String.length scanner.src then ( scanner.offset <- nextOffset; @@ -282069,9 +282353,7 @@ let make ~filename src = (* generic helpers *) let isWhitespace ch = - match ch with - | ' ' | '\t' | '\n' | '\r' -> true - | _ -> false + match ch with ' ' | '\t' | '\n' | '\r' -> true | _ -> false let rec skipWhitespace scanner = if isWhitespace scanner.ch then ( @@ -282088,8 +282370,8 @@ let digitValue ch = let rec skipLowerCaseChars scanner = match scanner.ch with | 'a' .. 'z' -> - next scanner; - skipLowerCaseChars scanner + next scanner; + skipLowerCaseChars scanner | _ -> () (* scanning helpers *) @@ -282099,8 +282381,8 @@ let scanIdentifier scanner = let rec skipGoodChars scanner = match scanner.ch with | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' | '\'' -> - next scanner; - skipGoodChars scanner + next scanner; + skipGoodChars scanner | _ -> () in skipGoodChars scanner; @@ -282118,8 +282400,8 @@ let scanDigits scanner ~base = let rec loop scanner = match scanner.ch with | '0' .. '9' | '_' -> - next scanner; - loop scanner + next scanner; + loop scanner | _ -> () in loop scanner @@ -282128,8 +282410,8 @@ let scanDigits scanner ~base = match scanner.ch with (* hex *) | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_' -> - next scanner; - loop scanner + next scanner; + loop scanner | _ -> () in loop scanner @@ -282142,19 +282424,19 @@ let scanNumber scanner = let base = match scanner.ch with | '0' -> ( - match peek scanner with - | 'x' | 'X' -> - next2 scanner; - 16 - | 'o' | 'O' -> - next2 scanner; - 8 - | 'b' | 'B' -> - next2 scanner; - 2 - | _ -> - next scanner; - 8) + match peek scanner with + | 'x' | 'X' -> + next2 scanner; + 16 + | 'o' | 'O' -> + next2 scanner; + 8 + | 'b' | 'B' -> + next2 scanner; + 2 + | _ -> + next scanner; + 8) | _ -> 10 in scanDigits scanner ~base; @@ -282172,11 +282454,11 @@ let scanNumber scanner = let isFloat = match scanner.ch with | 'e' | 'E' | 'p' | 'P' -> - (match peek scanner with - | '+' | '-' -> next2 scanner - | _ -> next scanner); - scanDigits scanner ~base; - true + (match peek scanner with + | '+' | '-' -> next2 scanner + | _ -> next scanner); + scanDigits scanner ~base; + true | _ -> isFloat in let literal = @@ -282187,20 +282469,20 @@ let scanNumber scanner = let suffix = match scanner.ch with | 'n' -> - let msg = - "Unsupported number type (nativeint). Did you mean `" ^ literal ^ "`?" - in - let pos = position scanner in - scanner.err ~startPos:pos ~endPos:pos (Diagnostics.message msg); - next scanner; - Some 'n' + let msg = + "Unsupported number type (nativeint). Did you mean `" ^ literal ^ "`?" + in + let pos = position scanner in + scanner.err ~startPos:pos ~endPos:pos (Diagnostics.message msg); + next scanner; + Some 'n' | ('g' .. 'z' | 'G' .. 'Z') as ch -> - next scanner; - Some ch + next scanner; + Some ch | _ -> None in - if isFloat then Token.Float {f = literal; suffix} - else Token.Int {i = literal; suffix} + if isFloat then Token.Float { f = literal; suffix } + else Token.Int { i = literal; suffix } let scanExoticIdentifier scanner = (* TODO: are we disregarding the current char...? Should be a quote *) @@ -282212,19 +282494,19 @@ let scanExoticIdentifier scanner = match scanner.ch with | '"' -> next scanner | '\n' | '\r' -> - (* line break *) - let endPos = position scanner in - scanner.err ~startPos ~endPos - (Diagnostics.message "A quoted identifier can't contain line breaks."); - next scanner + (* line break *) + let endPos = position scanner in + scanner.err ~startPos ~endPos + (Diagnostics.message "A quoted identifier can't contain line breaks."); + next scanner | ch when ch == hackyEOFChar -> - let endPos = position scanner in - scanner.err ~startPos ~endPos - (Diagnostics.message "Did you forget a \" here?") + let endPos = position scanner in + scanner.err ~startPos ~endPos + (Diagnostics.message "Did you forget a \" here?") | ch -> - Buffer.add_char buffer ch; - next scanner; - scan () + Buffer.add_char buffer ch; + next scanner; + scan () in scan (); (* TODO: do we really need to create a new buffer instead of substring once? *) @@ -282260,37 +282542,35 @@ let scanStringEscapeSequence ~startPos scanner = | '0' when let c = peek scanner in c < '0' || c > '9' -> - (* Allow \0 *) - next scanner + (* Allow \0 *) + next scanner | '0' .. '9' -> scan ~n:3 ~base:10 ~max:255 | 'x' -> - (* hex *) - next scanner; - scan ~n:2 ~base:16 ~max:255 + (* hex *) + next scanner; + scan ~n:2 ~base:16 ~max:255 | 'u' -> ( - next scanner; - match scanner.ch with - | '{' -> ( - (* unicode code point escape sequence: '\u{7A}', one or more hex digits *) next scanner; - let x = ref 0 in - while - match scanner.ch with - | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true - | _ -> false - do - x := (!x * 16) + digitValue scanner.ch; - next scanner - done; - (* consume '}' in '\u{7A}' *) match scanner.ch with - | '}' -> next scanner - | _ -> ()) - | _ -> scan ~n:4 ~base:16 ~max:Res_utf8.max) + | '{' -> ( + (* unicode code point escape sequence: '\u{7A}', one or more hex digits *) + next scanner; + let x = ref 0 in + while + match scanner.ch with + | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true + | _ -> false + do + x := (!x * 16) + digitValue scanner.ch; + next scanner + done; + (* consume '}' in '\u{7A}' *) + match scanner.ch with '}' -> next scanner | _ -> ()) + | _ -> scan ~n:4 ~base:16 ~max:Res_utf8.max) | _ -> - (* unknown escape sequence - * TODO: we should warn the user here. Let's not make it a hard error for now, for reason compat *) - (* + (* unknown escape sequence + * TODO: we should warn the user here. Let's not make it a hard error for now, for reason compat *) + (* let pos = position scanner in let msg = if ch == -1 then "unclosed escape sequence" @@ -282298,7 +282578,7 @@ let scanStringEscapeSequence ~startPos scanner = in scanner.err ~startPos ~endPos:pos (Diagnostics.message msg) *) - () + () let scanString scanner = (* assumption: we've just matched a quote *) @@ -282331,30 +282611,28 @@ let scanString scanner = let rec scan () = match scanner.ch with | '"' -> - let lastCharOffset = scanner.offset in - next scanner; - result ~firstCharOffset ~lastCharOffset + let lastCharOffset = scanner.offset in + next scanner; + result ~firstCharOffset ~lastCharOffset | '\\' -> - let startPos = position scanner in - let startOffset = scanner.offset + 1 in - next scanner; - scanStringEscapeSequence ~startPos scanner; - let endOffset = scanner.offset in - convertOctalToHex ~startOffset ~endOffset + let startPos = position scanner in + let startOffset = scanner.offset + 1 in + next scanner; + scanStringEscapeSequence ~startPos scanner; + let endOffset = scanner.offset in + convertOctalToHex ~startOffset ~endOffset | ch when ch == hackyEOFChar -> - let endPos = position scanner in - scanner.err ~startPos:startPosWithQuote ~endPos Diagnostics.unclosedString; - let lastCharOffset = scanner.offset in - result ~firstCharOffset ~lastCharOffset + let endPos = position scanner in + scanner.err ~startPos:startPosWithQuote ~endPos + Diagnostics.unclosedString; + let lastCharOffset = scanner.offset in + result ~firstCharOffset ~lastCharOffset | _ -> - next scanner; - scan () + next scanner; + scan () and convertOctalToHex ~startOffset ~endOffset = let len = endOffset - startOffset in - let isDigit = function - | '0' .. '9' -> true - | _ -> false - in + let isDigit = function '0' .. '9' -> true | _ -> false in let txt = scanner.src in let isNumericEscape = len = 3 @@ -282390,50 +282668,48 @@ let scanEscape scanner = match scanner.ch with | '0' .. '9' -> convertNumber scanner ~n:3 ~base:10 | 'b' -> - next scanner; - 8 + next scanner; + 8 | 'n' -> - next scanner; - 10 + next scanner; + 10 | 'r' -> - next scanner; - 13 + next scanner; + 13 | 't' -> - next scanner; - 009 + next scanner; + 009 | 'x' -> - next scanner; - convertNumber scanner ~n:2 ~base:16 + next scanner; + convertNumber scanner ~n:2 ~base:16 | 'o' -> - next scanner; - convertNumber scanner ~n:3 ~base:8 + next scanner; + convertNumber scanner ~n:3 ~base:8 | 'u' -> ( - next scanner; - match scanner.ch with - | '{' -> - (* unicode code point escape sequence: '\u{7A}', one or more hex digits *) next scanner; - let x = ref 0 in - while - match scanner.ch with - | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true - | _ -> false - do - x := (!x * 16) + digitValue scanner.ch; - next scanner - done; - (* consume '}' in '\u{7A}' *) - (match scanner.ch with - | '}' -> next scanner - | _ -> ()); - let c = !x in - if Res_utf8.isValidCodePoint c then c else Res_utf8.repl - | _ -> - (* unicode escape sequence: '\u007A', exactly 4 hex digits *) - convertNumber scanner ~n:4 ~base:16) + match scanner.ch with + | '{' -> + (* unicode code point escape sequence: '\u{7A}', one or more hex digits *) + next scanner; + let x = ref 0 in + while + match scanner.ch with + | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true + | _ -> false + do + x := (!x * 16) + digitValue scanner.ch; + next scanner + done; + (* consume '}' in '\u{7A}' *) + (match scanner.ch with '}' -> next scanner | _ -> ()); + let c = !x in + if Res_utf8.isValidCodePoint c then c else Res_utf8.repl + | _ -> + (* unicode escape sequence: '\u007A', exactly 4 hex digits *) + convertNumber scanner ~n:4 ~base:16) | ch -> - next scanner; - Char.code ch + next scanner; + Char.code ch in let contents = (String.sub [@doesNotRaise]) scanner.src offset (scanner.offset - offset) @@ -282441,7 +282717,7 @@ let scanEscape scanner = next scanner; (* Consume \' *) (* TODO: do we know it's \' ? *) - Token.Codepoint {c = codepoint; original = contents} + Token.Codepoint { c = codepoint; original = contents } let scanSingleLineComment scanner = let startOff = scanner.offset in @@ -282451,14 +282727,15 @@ let scanSingleLineComment scanner = | '\n' | '\r' -> () | ch when ch == hackyEOFChar -> () | _ -> - next scanner; - skip scanner + next scanner; + skip scanner in skip scanner; let endPos = position scanner in Token.Comment (Comment.makeSingleLineComment - ~loc:Location.{loc_start = startPos; loc_end = endPos; loc_ghost = false} + ~loc: + Location.{ loc_start = startPos; loc_end = endPos; loc_ghost = false } ((String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - startOff))) @@ -282474,17 +282751,17 @@ let scanMultiLineComment scanner = (* invariant: depth > 0 right after this match. See assumption *) match (scanner.ch, peek scanner) with | '/', '*' -> - next2 scanner; - scan ~depth:(depth + 1) + next2 scanner; + scan ~depth:(depth + 1) | '*', '/' -> - next2 scanner; - if depth > 1 then scan ~depth:(depth - 1) + next2 scanner; + if depth > 1 then scan ~depth:(depth - 1) | ch, _ when ch == hackyEOFChar -> - let endPos = position scanner in - scanner.err ~startPos ~endPos Diagnostics.unclosedComment + let endPos = position scanner in + scanner.err ~startPos ~endPos Diagnostics.unclosedComment | _ -> - next scanner; - scan ~depth + next scanner; + scan ~depth in scan ~depth:0; let length = scanner.offset - 2 - contentStartOff in @@ -282493,7 +282770,11 @@ let scanMultiLineComment scanner = (Comment.makeMultiLineComment ~docComment ~standalone ~loc: Location. - {loc_start = startPos; loc_end = position scanner; loc_ghost = false} + { + loc_start = startPos; + loc_end = position scanner; + loc_ghost = false; + } ((String.sub [@doesNotRaise]) scanner.src contentStartOff length)) let scanTemplateLiteralToken scanner = @@ -282508,44 +282789,44 @@ let scanTemplateLiteralToken scanner = let lastPos = position scanner in match scanner.ch with | '`' -> - next scanner; - let contents = - (String.sub [@doesNotRaise]) scanner.src startOff - (scanner.offset - 1 - startOff) - in - Token.TemplateTail (contents, lastPos) - | '$' -> ( - match peek scanner with - | '{' -> - next2 scanner; + next scanner; let contents = (String.sub [@doesNotRaise]) scanner.src startOff - (scanner.offset - 2 - startOff) + (scanner.offset - 1 - startOff) in - Token.TemplatePart (contents, lastPos) - | _ -> - next scanner; - scan ()) + Token.TemplateTail (contents, lastPos) + | '$' -> ( + match peek scanner with + | '{' -> + next2 scanner; + let contents = + (String.sub [@doesNotRaise]) scanner.src startOff + (scanner.offset - 2 - startOff) + in + Token.TemplatePart (contents, lastPos) + | _ -> + next scanner; + scan ()) | '\\' -> ( - match peek scanner with - | '`' | '\\' | '$' | '\n' | '\r' -> - (* line break *) - next2 scanner; - scan () - | _ -> - next scanner; - scan ()) + match peek scanner with + | '`' | '\\' | '$' | '\n' | '\r' -> + (* line break *) + next2 scanner; + scan () + | _ -> + next scanner; + scan ()) | ch when ch = hackyEOFChar -> - let endPos = position scanner in - scanner.err ~startPos ~endPos Diagnostics.unclosedTemplate; - let contents = - (String.sub [@doesNotRaise]) scanner.src startOff - (max (scanner.offset - 1 - startOff) 0) - in - Token.TemplateTail (contents, lastPos) + let endPos = position scanner in + scanner.err ~startPos ~endPos Diagnostics.unclosedTemplate; + let contents = + (String.sub [@doesNotRaise]) scanner.src startOff + (max (scanner.offset - 1 - startOff) 0) + in + Token.TemplateTail (contents, lastPos) | _ -> - next scanner; - scan () + next scanner; + scan () in let token = scan () in let endPos = position scanner in @@ -282561,273 +282842,273 @@ let rec scan scanner = | 'A' .. 'Z' | 'a' .. 'z' -> scanIdentifier scanner | '0' .. '9' -> scanNumber scanner | '`' -> - next scanner; - Token.Backtick + next scanner; + Token.Backtick | '~' -> - next scanner; - Token.Tilde + next scanner; + Token.Tilde | '?' -> - next scanner; - Token.Question + next scanner; + Token.Question | ';' -> - next scanner; - Token.Semicolon + next scanner; + Token.Semicolon | '(' -> - next scanner; - Token.Lparen + next scanner; + Token.Lparen | ')' -> - next scanner; - Token.Rparen + next scanner; + Token.Rparen | '[' -> - next scanner; - Token.Lbracket + next scanner; + Token.Lbracket | ']' -> - next scanner; - Token.Rbracket + next scanner; + Token.Rbracket | '{' -> - next scanner; - Token.Lbrace + next scanner; + Token.Lbrace | '}' -> - next scanner; - Token.Rbrace + next scanner; + Token.Rbrace | ',' -> - next scanner; - Token.Comma + next scanner; + Token.Comma | '"' -> scanString scanner (* peeking 1 char *) | '_' -> ( - match peek scanner with - | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' -> scanIdentifier scanner - | _ -> - next scanner; - Token.Underscore) + match peek scanner with + | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' -> scanIdentifier scanner + | _ -> + next scanner; + Token.Underscore) | '#' -> ( - match peek scanner with - | '=' -> - next2 scanner; - Token.HashEqual - | _ -> - next scanner; - Token.Hash) + match peek scanner with + | '=' -> + next2 scanner; + Token.HashEqual + | _ -> + next scanner; + Token.Hash) | '*' -> ( - match peek scanner with - | '*' -> - next2 scanner; - Token.Exponentiation - | '.' -> - next2 scanner; - Token.AsteriskDot - | _ -> - next scanner; - Token.Asterisk) + match peek scanner with + | '*' -> + next2 scanner; + Token.Exponentiation + | '.' -> + next2 scanner; + Token.AsteriskDot + | _ -> + next scanner; + Token.Asterisk) | '@' -> ( - match peek scanner with - | '@' -> - next2 scanner; - Token.AtAt - | _ -> - next scanner; - Token.At) + match peek scanner with + | '@' -> + next2 scanner; + Token.AtAt + | _ -> + next scanner; + Token.At) | '%' -> ( - match peek scanner with - | '%' -> - next2 scanner; - Token.PercentPercent - | _ -> - next scanner; - Token.Percent) + match peek scanner with + | '%' -> + next2 scanner; + Token.PercentPercent + | _ -> + next scanner; + Token.Percent) | '|' -> ( - match peek scanner with - | '|' -> - next2 scanner; - Token.Lor - | '>' -> - next2 scanner; - Token.BarGreater - | _ -> - next scanner; - Token.Bar) + match peek scanner with + | '|' -> + next2 scanner; + Token.Lor + | '>' -> + next2 scanner; + Token.BarGreater + | _ -> + next scanner; + Token.Bar) | '&' -> ( - match peek scanner with - | '&' -> - next2 scanner; - Token.Land - | _ -> - next scanner; - Token.Band) + match peek scanner with + | '&' -> + next2 scanner; + Token.Land + | _ -> + next scanner; + Token.Band) | ':' -> ( - match peek scanner with - | '=' -> - next2 scanner; - Token.ColonEqual - | '>' -> - next2 scanner; - Token.ColonGreaterThan - | _ -> - next scanner; - Token.Colon) + match peek scanner with + | '=' -> + next2 scanner; + Token.ColonEqual + | '>' -> + next2 scanner; + Token.ColonGreaterThan + | _ -> + next scanner; + Token.Colon) | '\\' -> - next scanner; - scanExoticIdentifier scanner - | '/' -> ( - match peek scanner with - | '/' -> - next2 scanner; - scanSingleLineComment scanner - | '*' -> scanMultiLineComment scanner - | '.' -> - next2 scanner; - Token.ForwardslashDot - | _ -> next scanner; - Token.Forwardslash) + scanExoticIdentifier scanner + | '/' -> ( + match peek scanner with + | '/' -> + next2 scanner; + scanSingleLineComment scanner + | '*' -> scanMultiLineComment scanner + | '.' -> + next2 scanner; + Token.ForwardslashDot + | _ -> + next scanner; + Token.Forwardslash) | '-' -> ( - match peek scanner with - | '.' -> - next2 scanner; - Token.MinusDot - | '>' -> - next2 scanner; - Token.MinusGreater - | _ -> - next scanner; - Token.Minus) + match peek scanner with + | '.' -> + next2 scanner; + Token.MinusDot + | '>' -> + next2 scanner; + Token.MinusGreater + | _ -> + next scanner; + Token.Minus) | '+' -> ( - match peek scanner with - | '.' -> - next2 scanner; - Token.PlusDot - | '+' -> - next2 scanner; - Token.PlusPlus - | '=' -> - next2 scanner; - Token.PlusEqual - | _ -> - next scanner; - Token.Plus) + match peek scanner with + | '.' -> + next2 scanner; + Token.PlusDot + | '+' -> + next2 scanner; + Token.PlusPlus + | '=' -> + next2 scanner; + Token.PlusEqual + | _ -> + next scanner; + Token.Plus) | '>' -> ( - match peek scanner with - | '=' when not (inDiamondMode scanner) -> - next2 scanner; - Token.GreaterEqual - | _ -> - next scanner; - Token.GreaterThan) + match peek scanner with + | '=' when not (inDiamondMode scanner) -> + next2 scanner; + Token.GreaterEqual + | _ -> + next scanner; + Token.GreaterThan) | '<' when not (inJsxMode scanner) -> ( - match peek scanner with - | '=' -> - next2 scanner; - Token.LessEqual - | _ -> - next scanner; - Token.LessThan) + match peek scanner with + | '=' -> + next2 scanner; + Token.LessEqual + | _ -> + next scanner; + Token.LessThan) (* special handling for JSX < *) | '<' -> ( - (* Imagine the following:
< - * < indicates the start of a new jsx-element, the parser expects - * the name of a new element after the < - * Example:
- * This signals a closing element. To simulate the two-token lookahead, - * the + (* Imagine the following:
< + * < indicates the start of a new jsx-element, the parser expects + * the name of a new element after the < + * Example:
+ * This signals a closing element. To simulate the two-token lookahead, + * the - next scanner; - Token.LessEqual - | _ -> Token.LessThan) + skipWhitespace scanner; + match scanner.ch with + | '/' -> + next scanner; + Token.LessThanSlash + | '=' -> + next scanner; + Token.LessEqual + | _ -> Token.LessThan) (* peeking 2 chars *) | '.' -> ( - match (peek scanner, peek2 scanner) with - | '.', '.' -> - next3 scanner; - Token.DotDotDot - | '.', _ -> - next2 scanner; - Token.DotDot - | _ -> - next scanner; - Token.Dot) + match (peek scanner, peek2 scanner) with + | '.', '.' -> + next3 scanner; + Token.DotDotDot + | '.', _ -> + next2 scanner; + Token.DotDot + | _ -> + next scanner; + Token.Dot) | '\'' -> ( - match (peek scanner, peek2 scanner) with - | '\\', '"' -> - (* careful with this one! We're next-ing _once_ (not twice), - then relying on matching on the quote *) - next scanner; - SingleQuote - | '\\', _ -> - next2 scanner; - scanEscape scanner - | ch, '\'' -> - let offset = scanner.offset + 1 in - next3 scanner; - Token.Codepoint - { - c = Char.code ch; - original = (String.sub [@doesNotRaise]) scanner.src offset 1; - } - | ch, _ -> - next scanner; - let offset = scanner.offset in - let codepoint, length = - Res_utf8.decodeCodePoint scanner.offset scanner.src - (String.length scanner.src) - in - for _ = 0 to length - 1 do - next scanner - done; - if scanner.ch = '\'' then ( - let contents = - (String.sub [@doesNotRaise]) scanner.src offset length - in - next scanner; - Token.Codepoint {c = codepoint; original = contents}) - else ( - scanner.ch <- ch; - scanner.offset <- offset; - SingleQuote)) + match (peek scanner, peek2 scanner) with + | '\\', '"' -> + (* careful with this one! We're next-ing _once_ (not twice), + then relying on matching on the quote *) + next scanner; + SingleQuote + | '\\', _ -> + next2 scanner; + scanEscape scanner + | ch, '\'' -> + let offset = scanner.offset + 1 in + next3 scanner; + Token.Codepoint + { + c = Char.code ch; + original = (String.sub [@doesNotRaise]) scanner.src offset 1; + } + | ch, _ -> + next scanner; + let offset = scanner.offset in + let codepoint, length = + Res_utf8.decodeCodePoint scanner.offset scanner.src + (String.length scanner.src) + in + for _ = 0 to length - 1 do + next scanner + done; + if scanner.ch = '\'' then ( + let contents = + (String.sub [@doesNotRaise]) scanner.src offset length + in + next scanner; + Token.Codepoint { c = codepoint; original = contents }) + else ( + scanner.ch <- ch; + scanner.offset <- offset; + SingleQuote)) | '!' -> ( - match (peek scanner, peek2 scanner) with - | '=', '=' -> - next3 scanner; - Token.BangEqualEqual - | '=', _ -> - next2 scanner; - Token.BangEqual - | _ -> - next scanner; - Token.Bang) + match (peek scanner, peek2 scanner) with + | '=', '=' -> + next3 scanner; + Token.BangEqualEqual + | '=', _ -> + next2 scanner; + Token.BangEqual + | _ -> + next scanner; + Token.Bang) | '=' -> ( - match (peek scanner, peek2 scanner) with - | '=', '=' -> - next3 scanner; - Token.EqualEqualEqual - | '=', _ -> - next2 scanner; - Token.EqualEqual - | '>', _ -> - next2 scanner; - Token.EqualGreater - | _ -> - next scanner; - Token.Equal) + match (peek scanner, peek2 scanner) with + | '=', '=' -> + next3 scanner; + Token.EqualEqualEqual + | '=', _ -> + next2 scanner; + Token.EqualEqual + | '>', _ -> + next2 scanner; + Token.EqualGreater + | _ -> + next scanner; + Token.Equal) (* special cases *) | ch when ch == hackyEOFChar -> - next scanner; - Token.Eof + next scanner; + Token.Eof | ch -> - (* if we arrive here, we're dealing with an unknown character, - * report the error and continue scanning… *) - next scanner; - let endPos = position scanner in - scanner.err ~startPos ~endPos (Diagnostics.unknownUchar ch); - let _, _, token = scan scanner in - token + (* if we arrive here, we're dealing with an unknown character, + * report the error and continue scanning… *) + next scanner; + let endPos = position scanner in + scanner.err ~startPos ~endPos (Diagnostics.unknownUchar ch); + let _, _, token = scan scanner in + token in let endPos = position scanner in (* _printDebug ~startPos ~endPos scanner token; *) @@ -282871,36 +283152,36 @@ let tryAdvanceQuotedString scanner = let rec scanContents tag = match scanner.ch with | '|' -> ( - next scanner; - match scanner.ch with - | 'a' .. 'z' -> - let startOff = scanner.offset in - skipLowerCaseChars scanner; - let suffix = - (String.sub [@doesNotRaise]) scanner.src startOff - (scanner.offset - startOff) - in - if tag = suffix then - if scanner.ch = '}' then next scanner else scanContents tag - else scanContents tag - | '}' -> next scanner - | _ -> scanContents tag) + next scanner; + match scanner.ch with + | 'a' .. 'z' -> + let startOff = scanner.offset in + skipLowerCaseChars scanner; + let suffix = + (String.sub [@doesNotRaise]) scanner.src startOff + (scanner.offset - startOff) + in + if tag = suffix then + if scanner.ch = '}' then next scanner else scanContents tag + else scanContents tag + | '}' -> next scanner + | _ -> scanContents tag) | ch when ch == hackyEOFChar -> - (* TODO: why is this place checking EOF and not others? *) - () + (* TODO: why is this place checking EOF and not others? *) + () | _ -> - next scanner; - scanContents tag + next scanner; + scanContents tag in match scanner.ch with | 'a' .. 'z' -> - let startOff = scanner.offset in - skipLowerCaseChars scanner; - let tag = - (String.sub [@doesNotRaise]) scanner.src startOff - (scanner.offset - startOff) - in - if scanner.ch = '|' then scanContents tag + let startOff = scanner.offset in + skipLowerCaseChars scanner; + let tag = + (String.sub [@doesNotRaise]) scanner.src startOff + (scanner.offset - startOff) + in + if scanner.ch = '|' then scanContents tag | '|' -> scanContents "" | _ -> () @@ -282915,31 +283196,30 @@ module Diagnostics = Res_diagnostics module Comment = Res_comment type mode = ParseForTypeChecker | Default - type regionStatus = Report | Silent type t = { - mode: mode; - mutable scanner: Scanner.t; - mutable token: Token.t; - mutable startPos: Lexing.position; - mutable endPos: Lexing.position; - mutable prevEndPos: Lexing.position; - mutable breadcrumbs: (Grammar.t * Lexing.position) list; - mutable errors: Reporting.parseError list; - mutable diagnostics: Diagnostics.t list; - mutable comments: Comment.t list; - mutable regions: regionStatus ref list; + mode : mode; + mutable scanner : Scanner.t; + mutable token : Token.t; + mutable startPos : Lexing.position; + mutable endPos : Lexing.position; + mutable prevEndPos : Lexing.position; + mutable breadcrumbs : (Grammar.t * Lexing.position) list; + mutable errors : Reporting.parseError list; + mutable diagnostics : Diagnostics.t list; + mutable comments : Comment.t list; + mutable regions : regionStatus ref list; } val make : ?mode:mode -> string -> string -> t - val expect : ?grammar:Grammar.t -> Token.t -> t -> unit val optional : t -> Token.t -> bool val next : ?prevEndPos:Lexing.position -> t -> unit val nextUnsafe : t -> unit (* Does not assert on Eof, makes no progress *) val nextTemplateLiteralToken : t -> unit val lookahead : t -> (t -> 'a) -> 'a + val err : ?startPos:Lexing.position -> ?endPos:Lexing.position -> @@ -282949,10 +283229,8 @@ val err : val leaveBreadcrumb : t -> Grammar.t -> unit val eatBreadcrumb : t -> unit - val beginRegion : t -> unit val endRegion : t -> unit - val checkProgress : prevEndPos:Lexing.position -> result:'a -> t -> 'a option end = struct @@ -282962,51 +283240,42 @@ module Diagnostics = Res_diagnostics module Token = Res_token module Grammar = Res_grammar module Reporting = Res_reporting - module Comment = Res_comment type mode = ParseForTypeChecker | Default - type regionStatus = Report | Silent type t = { - mode: mode; - mutable scanner: Scanner.t; - mutable token: Token.t; - mutable startPos: Lexing.position; - mutable endPos: Lexing.position; - mutable prevEndPos: Lexing.position; - mutable breadcrumbs: (Grammar.t * Lexing.position) list; - mutable errors: Reporting.parseError list; - mutable diagnostics: Diagnostics.t list; - mutable comments: Comment.t list; - mutable regions: regionStatus ref list; + mode : mode; + mutable scanner : Scanner.t; + mutable token : Token.t; + mutable startPos : Lexing.position; + mutable endPos : Lexing.position; + mutable prevEndPos : Lexing.position; + mutable breadcrumbs : (Grammar.t * Lexing.position) list; + mutable errors : Reporting.parseError list; + mutable diagnostics : Diagnostics.t list; + mutable comments : Comment.t list; + mutable regions : regionStatus ref list; } let err ?startPos ?endPos p error = match p.regions with - | ({contents = Report} as region) :: _ -> - let d = - Diagnostics.make - ~startPos: - (match startPos with - | Some pos -> pos - | None -> p.startPos) - ~endPos: - (match endPos with - | Some pos -> pos - | None -> p.endPos) - error - in - p.diagnostics <- d :: p.diagnostics; - region := Silent + | ({ contents = Report } as region) :: _ -> + let d = + Diagnostics.make + ~startPos:(match startPos with Some pos -> pos | None -> p.startPos) + ~endPos:(match endPos with Some pos -> pos | None -> p.endPos) + error + in + p.diagnostics <- d :: p.diagnostics; + region := Silent | _ -> () let beginRegion p = p.regions <- ref Report :: p.regions + let endRegion p = - match p.regions with - | [] -> () - | _ :: rest -> p.regions <- rest + match p.regions with [] -> () | _ :: rest -> p.regions <- rest let docCommentToAttributeToken comment = let txt = Comment.txt comment in @@ -283023,35 +283292,31 @@ let moduleCommentToAttributeToken comment = * previous token to facilite comment interleaving *) let rec next ?prevEndPos p = if p.token = Eof then assert false; - let prevEndPos = - match prevEndPos with - | Some pos -> pos - | None -> p.endPos - in + let prevEndPos = match prevEndPos with Some pos -> pos | None -> p.endPos in let startPos, endPos, token = Scanner.scan p.scanner in match token with | Comment c -> - if Comment.isDocComment c then ( - p.token <- docCommentToAttributeToken c; - p.prevEndPos <- prevEndPos; - p.startPos <- startPos; - p.endPos <- endPos) - else if Comment.isModuleComment c then ( - p.token <- moduleCommentToAttributeToken c; + if Comment.isDocComment c then ( + p.token <- docCommentToAttributeToken c; + p.prevEndPos <- prevEndPos; + p.startPos <- startPos; + p.endPos <- endPos) + else if Comment.isModuleComment c then ( + p.token <- moduleCommentToAttributeToken c; + p.prevEndPos <- prevEndPos; + p.startPos <- startPos; + p.endPos <- endPos) + else ( + Comment.setPrevTokEndPos c p.endPos; + p.comments <- c :: p.comments; + p.prevEndPos <- p.endPos; + p.endPos <- endPos; + next ~prevEndPos p) + | _ -> + p.token <- token; p.prevEndPos <- prevEndPos; p.startPos <- startPos; - p.endPos <- endPos) - else ( - Comment.setPrevTokEndPos c p.endPos; - p.comments <- c :: p.comments; - p.prevEndPos <- p.endPos; - p.endPos <- endPos; - next ~prevEndPos p) - | _ -> - p.token <- token; - p.prevEndPos <- prevEndPos; - p.startPos <- startPos; - p.endPos <- endPos + p.endPos <- endPos let nextUnsafe p = if p.token <> Eof then next p @@ -283079,7 +283344,7 @@ let make ?(mode = ParseForTypeChecker) src filename = errors = []; diagnostics = []; comments = []; - regions = [ref Report]; + regions = [ ref Report ]; } in parserState.scanner.err <- @@ -283094,9 +283359,7 @@ let leaveBreadcrumb p circumstance = p.breadcrumbs <- crumb :: p.breadcrumbs let eatBreadcrumb p = - match p.breadcrumbs with - | [] -> () - | _ :: crumbs -> p.breadcrumbs <- crumbs + match p.breadcrumbs with [] -> () | _ :: crumbs -> p.breadcrumbs <- crumbs let optional p token = if p.token = token then @@ -283165,7 +283428,7 @@ module Scanner = Res_scanner module Parser = Res_parser let mkLoc startLoc endLoc = - Location.{loc_start = startLoc; loc_end = endLoc; loc_ghost = false} + Location.{ loc_start = startLoc; loc_end = endLoc; loc_ghost = false } module Recover = struct let defaultExpr () = @@ -283189,16 +283452,15 @@ module Recover = struct let recoverEqualGreater p = Parser.expect EqualGreater p; - match p.Parser.token with - | MinusGreater -> Parser.next p - | _ -> () + match p.Parser.token with MinusGreater -> Parser.next p | _ -> () let shouldAbortListParse p = let rec check breadcrumbs = match breadcrumbs with | [] -> false | (grammar, _) :: rest -> - if Grammar.isPartOfList grammar p.Parser.token then true else check rest + if Grammar.isPartOfList grammar p.Parser.token then true + else check rest in check p.breadcrumbs end @@ -283243,7 +283505,7 @@ module ErrorMessages = struct or be a number (e.g. #742)" let experimentalIfLet expr = - let switchExpr = {expr with Parsetree.pexp_attributes = []} in + let switchExpr = { expr with Parsetree.pexp_attributes = [] } in Doc.concat [ Doc.text "If-let is currently highly experimental."; @@ -283261,12 +283523,13 @@ module ErrorMessages = struct let typeParam = "A type param consists of a singlequote followed by a name like `'a` or \ `'A`" + let typeVar = "A type variable consists of a singlequote followed by a name like `'a` or \ `'A`" let attributeWithoutNode (attr : Parsetree.attribute) = - let {Asttypes.txt = attrName}, _ = attr in + let { Asttypes.txt = attrName }, _ = attr in "Did you forget to attach `" ^ attrName ^ "` to an item?\n Standalone attributes start with `@@` like: `@@" ^ attrName ^ "`" @@ -283313,10 +283576,13 @@ let makeAwaitAttr loc = (Location.mkloc "res.await" loc, Parsetree.PStr []) let makeAsyncAttr loc = (Location.mkloc "res.async" loc, Parsetree.PStr []) let makeExpressionOptional ~optional (e : Parsetree.expression) = - if optional then {e with pexp_attributes = optionalAttr :: e.pexp_attributes} + if optional then + { e with pexp_attributes = optionalAttr :: e.pexp_attributes } else e + let makePatternOptional ~optional (p : Parsetree.pattern) = - if optional then {p with ppat_attributes = optionalAttr :: p.ppat_attributes} + if optional then + { p with ppat_attributes = optionalAttr :: p.ppat_attributes } else p let suppressFragileMatchWarningAttr = @@ -283326,32 +283592,32 @@ let suppressFragileMatchWarningAttr = Ast_helper.Str.eval (Ast_helper.Exp.constant (Pconst_string ("-4", None))); ] ) + let makeBracesAttr loc = (Location.mkloc "ns.braces" loc, Parsetree.PStr []) let templateLiteralAttr = (Location.mknoloc "res.template", Parsetree.PStr []) - let spreadAttr = (Location.mknoloc "res.spread", Parsetree.PStr []) type typDefOrExt = | TypeDef of { - recFlag: Asttypes.rec_flag; - types: Parsetree.type_declaration list; + recFlag : Asttypes.rec_flag; + types : Parsetree.type_declaration list; } | TypeExt of Parsetree.type_extension type labelledParameter = | TermParameter of { - uncurried: bool; - attrs: Parsetree.attributes; - label: Asttypes.arg_label; - expr: Parsetree.expression option; - pat: Parsetree.pattern; - pos: Lexing.position; + uncurried : bool; + attrs : Parsetree.attributes; + label : Asttypes.arg_label; + expr : Parsetree.expression option; + pat : Parsetree.pattern; + pos : Lexing.position; } | TypeParameter of { - uncurried: bool; - attrs: Parsetree.attributes; - locs: string Location.loc list; - pos: Lexing.position; + uncurried : bool; + attrs : Parsetree.attributes; + locs : string Location.loc list; + pos : Lexing.position; } type recordPatternItem = @@ -283374,17 +283640,17 @@ let rec goToClosing closingToken state = | Rbrace, Rbrace | Rbracket, Rbracket | GreaterThan, GreaterThan -> - Parser.next state; - () + Parser.next state; + () | ((Token.Lbracket | Lparen | Lbrace | List | LessThan) as t), _ -> - Parser.next state; - goToClosing (getClosingToken t) state; - goToClosing closingToken state + Parser.next state; + goToClosing (getClosingToken t) state; + goToClosing closingToken state | (Rparen | Token.Rbrace | Rbracket | Eof), _ -> - () (* TODO: how do report errors here? *) + () (* TODO: how do report errors here? *) | _ -> - Parser.next state; - goToClosing closingToken state + Parser.next state; + goToClosing closingToken state (* Madness *) let isEs6ArrowExpression ~inTernary p = @@ -283394,75 +283660,75 @@ let isEs6ArrowExpression ~inTernary p = | _ -> ()); match state.Parser.token with | Lident _ | Underscore -> ( - Parser.next state; - match state.Parser.token with - (* Don't think that this valid - * Imagine: let x = (a: int) - * This is a parenthesized expression with a type constraint, wait for - * the arrow *) - (* | Colon when not inTernary -> true *) - | EqualGreater -> true - | _ -> false) - | Lparen -> ( - let prevEndPos = state.prevEndPos in - Parser.next state; - match state.token with - (* arrived at `()` here *) - | Rparen -> ( Parser.next state; match state.Parser.token with - (* arrived at `() :` here *) - | Colon when not inTernary -> ( - Parser.next state; - match state.Parser.token with - (* arrived at `() :typ` here *) - | Lident _ -> ( + (* Don't think that this valid + * Imagine: let x = (a: int) + * This is a parenthesized expression with a type constraint, wait for + * the arrow *) + (* | Colon when not inTernary -> true *) + | EqualGreater -> true + | _ -> false) + | Lparen -> ( + let prevEndPos = state.prevEndPos in + Parser.next state; + match state.token with + (* arrived at `()` here *) + | Rparen -> ( Parser.next state; - (match state.Parser.token with - (* arrived at `() :typ<` here *) - | LessThan -> - Parser.next state; - goToClosing GreaterThan state - | _ -> ()); match state.Parser.token with - (* arrived at `() :typ =>` or `() :typ<'a,'b> =>` here *) + (* arrived at `() :` here *) + | Colon when not inTernary -> ( + Parser.next state; + match state.Parser.token with + (* arrived at `() :typ` here *) + | Lident _ -> ( + Parser.next state; + (match state.Parser.token with + (* arrived at `() :typ<` here *) + | LessThan -> + Parser.next state; + goToClosing GreaterThan state + | _ -> ()); + match state.Parser.token with + (* arrived at `() :typ =>` or `() :typ<'a,'b> =>` here *) + | EqualGreater -> true + | _ -> false) + | _ -> true) | EqualGreater -> true | _ -> false) - | _ -> true) - | EqualGreater -> true - | _ -> false) - | Dot (* uncurried *) -> true - | Tilde -> true - | Backtick -> - false - (* (` always indicates the start of an expr, can't be es6 parameter *) - | _ -> ( - goToClosing Rparen state; - match state.Parser.token with - | EqualGreater -> true - (* | Lbrace TODO: detect missing =>, is this possible? *) - | Colon when not inTernary -> true - | Rparen -> - (* imagine having something as : - * switch colour { - * | Red - * when l == l' - * || (&Clflags.classic && (l == Nolabel && !is_optional(l'))) => (t1, t2) - * We'll arrive at the outer rparen just before the =>. - * This is not an es6 arrow. - * *) - false + | Dot (* uncurried *) -> true + | Tilde -> true + | Backtick -> + false + (* (` always indicates the start of an expr, can't be es6 parameter *) | _ -> ( - Parser.nextUnsafe state; - (* error recovery, peek at the next token, - * (elements, providerId] => { - * in the example above, we have an unbalanced ] here - *) - match state.Parser.token with - | EqualGreater when state.startPos.pos_lnum == prevEndPos.pos_lnum - -> - true - | _ -> false))) + goToClosing Rparen state; + match state.Parser.token with + | EqualGreater -> true + (* | Lbrace TODO: detect missing =>, is this possible? *) + | Colon when not inTernary -> true + | Rparen -> + (* imagine having something as : + * switch colour { + * | Red + * when l == l' + * || (&Clflags.classic && (l == Nolabel && !is_optional(l'))) => (t1, t2) + * We'll arrive at the outer rparen just before the =>. + * This is not an es6 arrow. + * *) + false + | _ -> ( + Parser.nextUnsafe state; + (* error recovery, peek at the next token, + * (elements, providerId] => { + * in the example above, we have an unbalanced ] here + *) + match state.Parser.token with + | EqualGreater + when state.startPos.pos_lnum == prevEndPos.pos_lnum -> + true + | _ -> false))) | _ -> false) let isEs6ArrowFunctor p = @@ -283475,38 +283741,32 @@ let isEs6ArrowFunctor p = (* | _ -> false *) (* end *) | Lparen -> ( - Parser.next state; - match state.token with - | Rparen -> ( Parser.next state; match state.token with - | Colon | EqualGreater -> true - | _ -> false) - | _ -> ( - goToClosing Rparen state; - match state.Parser.token with - | EqualGreater | Lbrace -> true - | Colon -> true - | _ -> false)) + | Rparen -> ( + Parser.next state; + match state.token with Colon | EqualGreater -> true | _ -> false) + | _ -> ( + goToClosing Rparen state; + match state.Parser.token with + | EqualGreater | Lbrace -> true + | Colon -> true + | _ -> false)) | _ -> false) let isEs6ArrowType p = Parser.lookahead p (fun state -> match state.Parser.token with | Lparen -> ( - Parser.next state; - match state.Parser.token with - | Rparen -> ( Parser.next state; match state.Parser.token with - | EqualGreater -> true - | _ -> false) - | Tilde | Dot -> true - | _ -> ( - goToClosing Rparen state; - match state.Parser.token with - | EqualGreater -> true - | _ -> false)) + | Rparen -> ( + Parser.next state; + match state.Parser.token with EqualGreater -> true | _ -> false) + | Tilde | Dot -> true + | _ -> ( + goToClosing Rparen state; + match state.Parser.token with EqualGreater -> true | _ -> false)) | Tilde -> true | _ -> false) @@ -283542,71 +283802,76 @@ let negateString s = let makeUnaryExpr startPos tokenEnd token operand = match (token, operand.Parsetree.pexp_desc) with | (Token.Plus | PlusDot), Pexp_constant (Pconst_integer _ | Pconst_float _) -> - operand + operand | Minus, Pexp_constant (Pconst_integer (n, m)) -> - { - operand with - pexp_desc = Pexp_constant (Pconst_integer (negateString n, m)); - } + { + operand with + pexp_desc = Pexp_constant (Pconst_integer (negateString n, m)); + } | (Minus | MinusDot), Pexp_constant (Pconst_float (n, m)) -> - {operand with pexp_desc = Pexp_constant (Pconst_float (negateString n, m))} + { + operand with + pexp_desc = Pexp_constant (Pconst_float (negateString n, m)); + } | (Token.Plus | PlusDot | Minus | MinusDot), _ -> - let tokenLoc = mkLoc startPos tokenEnd in - let operator = "~" ^ Token.toString token in - Ast_helper.Exp.apply - ~loc:(mkLoc startPos operand.Parsetree.pexp_loc.loc_end) - (Ast_helper.Exp.ident ~loc:tokenLoc - (Location.mkloc (Longident.Lident operator) tokenLoc)) - [(Nolabel, operand)] + let tokenLoc = mkLoc startPos tokenEnd in + let operator = "~" ^ Token.toString token in + Ast_helper.Exp.apply + ~loc:(mkLoc startPos operand.Parsetree.pexp_loc.loc_end) + (Ast_helper.Exp.ident ~loc:tokenLoc + (Location.mkloc (Longident.Lident operator) tokenLoc)) + [ (Nolabel, operand) ] | Token.Bang, _ -> - let tokenLoc = mkLoc startPos tokenEnd in - Ast_helper.Exp.apply - ~loc:(mkLoc startPos operand.Parsetree.pexp_loc.loc_end) - (Ast_helper.Exp.ident ~loc:tokenLoc - (Location.mkloc (Longident.Lident "not") tokenLoc)) - [(Nolabel, operand)] + let tokenLoc = mkLoc startPos tokenEnd in + Ast_helper.Exp.apply + ~loc:(mkLoc startPos operand.Parsetree.pexp_loc.loc_end) + (Ast_helper.Exp.ident ~loc:tokenLoc + (Location.mkloc (Longident.Lident "not") tokenLoc)) + [ (Nolabel, operand) ] | _ -> operand let makeListExpression loc seq extOpt = let rec handleSeq = function | [] -> ( - match extOpt with - | Some ext -> ext - | None -> - let loc = {loc with Location.loc_ghost = true} in - let nil = Location.mkloc (Longident.Lident "[]") loc in - Ast_helper.Exp.construct ~loc nil None) + match extOpt with + | Some ext -> ext + | None -> + let loc = { loc with Location.loc_ghost = true } in + let nil = Location.mkloc (Longident.Lident "[]") loc in + Ast_helper.Exp.construct ~loc nil None) | e1 :: el -> - let exp_el = handleSeq el in - let loc = - mkLoc e1.Parsetree.pexp_loc.Location.loc_start exp_el.pexp_loc.loc_end - in - let arg = Ast_helper.Exp.tuple ~loc [e1; exp_el] in - Ast_helper.Exp.construct ~loc - (Location.mkloc (Longident.Lident "::") loc) - (Some arg) + let exp_el = handleSeq el in + let loc = + mkLoc e1.Parsetree.pexp_loc.Location.loc_start exp_el.pexp_loc.loc_end + in + let arg = Ast_helper.Exp.tuple ~loc [ e1; exp_el ] in + Ast_helper.Exp.construct ~loc + (Location.mkloc (Longident.Lident "::") loc) + (Some arg) in let expr = handleSeq seq in - {expr with pexp_loc = loc} + { expr with pexp_loc = loc } let makeListPattern loc seq ext_opt = let rec handle_seq = function | [] -> - let base_case = - match ext_opt with - | Some ext -> ext - | None -> - let loc = {loc with Location.loc_ghost = true} in - let nil = {Location.txt = Longident.Lident "[]"; loc} in - Ast_helper.Pat.construct ~loc nil None - in - base_case + let base_case = + match ext_opt with + | Some ext -> ext + | None -> + let loc = { loc with Location.loc_ghost = true } in + let nil = { Location.txt = Longident.Lident "[]"; loc } in + Ast_helper.Pat.construct ~loc nil None + in + base_case | p1 :: pl -> - let pat_pl = handle_seq pl in - let loc = mkLoc p1.Parsetree.ppat_loc.loc_start pat_pl.ppat_loc.loc_end in - let arg = Ast_helper.Pat.mk ~loc (Ppat_tuple [p1; pat_pl]) in - Ast_helper.Pat.mk ~loc - (Ppat_construct (Location.mkloc (Longident.Lident "::") loc, Some arg)) + let pat_pl = handle_seq pl in + let loc = + mkLoc p1.Parsetree.ppat_loc.loc_start pat_pl.ppat_loc.loc_end + in + let arg = Ast_helper.Pat.mk ~loc (Ppat_tuple [ p1; pat_pl ]) in + Ast_helper.Pat.mk ~loc + (Ppat_construct (Location.mkloc (Longident.Lident "::") loc, Some arg)) in handle_seq seq @@ -283622,7 +283887,7 @@ let makeNewtypes ~attrs ~loc newtypes exp = (fun newtype exp -> Ast_helper.Exp.mk ~loc (Pexp_newtype (newtype, exp))) newtypes exp in - {expr with pexp_attributes = attrs} + { expr with pexp_attributes = attrs } (* locally abstract types syntax sugar * Transforms @@ -283652,23 +283917,23 @@ let processUnderscoreApplication args = let hidden_var = "__x" in let check_arg ((lab, exp) as arg) = match exp.Parsetree.pexp_desc with - | Pexp_ident ({txt = Lident "_"} as id) -> - let new_id = Location.mkloc (Longident.Lident hidden_var) id.loc in - let new_exp = Ast_helper.Exp.mk (Pexp_ident new_id) ~loc:exp.pexp_loc in - exp_question := Some new_exp; - (lab, new_exp) + | Pexp_ident ({ txt = Lident "_" } as id) -> + let new_id = Location.mkloc (Longident.Lident hidden_var) id.loc in + let new_exp = Ast_helper.Exp.mk (Pexp_ident new_id) ~loc:exp.pexp_loc in + exp_question := Some new_exp; + (lab, new_exp) | _ -> arg in let args = List.map check_arg args in let wrap (exp_apply : Parsetree.expression) = match !exp_question with - | Some {pexp_loc = loc} -> - let pattern = - Ast_helper.Pat.mk - (Ppat_var (Location.mkloc hidden_var loc)) - ~loc:Location.none - in - Ast_helper.Exp.mk (Pexp_fun (Nolabel, None, pattern, exp_apply)) ~loc + | Some { pexp_loc = loc } -> + let pattern = + Ast_helper.Pat.mk + (Ppat_var (Location.mkloc hidden_var loc)) + ~loc:Location.none + in + Ast_helper.Exp.mk (Pexp_fun (Nolabel, None, pattern, exp_apply)) ~loc | None -> exp_apply in (args, wrap) @@ -283677,11 +283942,12 @@ let processUnderscoreApplication args = let removeModuleNameFromPunnedFieldValue exp = match exp.Parsetree.pexp_desc with | Pexp_ident pathIdent -> - { - exp with - pexp_desc = - Pexp_ident {pathIdent with txt = Lident (Longident.last pathIdent.txt)}; - } + { + exp with + pexp_desc = + Pexp_ident + { pathIdent with txt = Lident (Longident.last pathIdent.txt) }; + } | _ -> exp let rec parseLident p = @@ -283702,66 +283968,65 @@ let rec parseLident p = Parser.err p (Diagnostics.lident p.Parser.token); Parser.next p; loop p; - match p.Parser.token with - | Lident _ -> Some () - | _ -> None + match p.Parser.token with Lident _ -> Some () | _ -> None in let startPos = p.Parser.startPos in match p.Parser.token with | Lident ident -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - (ident, loc) + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + (ident, loc) | Eof -> - Parser.err ~startPos p (Diagnostics.unexpected p.Parser.token p.breadcrumbs); - ("_", mkLoc startPos p.prevEndPos) + Parser.err ~startPos p + (Diagnostics.unexpected p.Parser.token p.breadcrumbs); + ("_", mkLoc startPos p.prevEndPos) | _ -> ( - match recoverLident p with - | Some () -> parseLident p - | None -> ("_", mkLoc startPos p.prevEndPos)) + match recoverLident p with + | Some () -> parseLident p + | None -> ("_", mkLoc startPos p.prevEndPos)) let parseIdent ~msg ~startPos p = match p.Parser.token with | Lident ident | Uident ident -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - (ident, loc) + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + (ident, loc) | token when Token.isKeyword token && p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> - let tokenTxt = Token.toString token in - let msg = - "`" ^ tokenTxt - ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" ^ tokenTxt - ^ "\"" - in - Parser.err ~startPos p (Diagnostics.message msg); - Parser.next p; - (tokenTxt, mkLoc startPos p.prevEndPos) + let tokenTxt = Token.toString token in + let msg = + "`" ^ tokenTxt + ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" + ^ tokenTxt ^ "\"" + in + Parser.err ~startPos p (Diagnostics.message msg); + Parser.next p; + (tokenTxt, mkLoc startPos p.prevEndPos) | _token -> - Parser.err ~startPos p (Diagnostics.message msg); - Parser.next p; - ("", mkLoc startPos p.prevEndPos) + Parser.err ~startPos p (Diagnostics.message msg); + Parser.next p; + ("", mkLoc startPos p.prevEndPos) let parseHashIdent ~startPos p = Parser.expect Hash p; match p.token with | String text -> - Parser.next p; - (text, mkLoc startPos p.prevEndPos) - | Int {i; suffix} -> - let () = - match suffix with - | Some _ -> - Parser.err p - (Diagnostics.message (ErrorMessages.polyVarIntWithSuffix i)) - | None -> () - in - Parser.next p; - (i, mkLoc startPos p.prevEndPos) + Parser.next p; + (text, mkLoc startPos p.prevEndPos) + | Int { i; suffix } -> + let () = + match suffix with + | Some _ -> + Parser.err p + (Diagnostics.message (ErrorMessages.polyVarIntWithSuffix i)) + | None -> () + in + Parser.next p; + (i, mkLoc startPos p.prevEndPos) | Eof -> - Parser.err ~startPos p (Diagnostics.unexpected p.token p.breadcrumbs); - ("", mkLoc startPos p.prevEndPos) + Parser.err ~startPos p (Diagnostics.unexpected p.token p.breadcrumbs); + ("", mkLoc startPos p.prevEndPos) | _ -> parseIdent ~startPos ~msg:ErrorMessages.variantIdent p (* Ldot (Ldot (Lident "Foo", "Bar"), "baz") *) @@ -283779,8 +284044,8 @@ let parseValuePath p = | Lident ident -> Longident.Ldot (path, ident) | Uident uident -> aux p (Ldot (path, uident)) | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Longident.Ldot (path, "_")) + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Longident.Ldot (path, "_")) else ( Parser.err p ~startPos ~endPos:p.prevEndPos (Diagnostics.lident token); path) @@ -283788,16 +284053,16 @@ let parseValuePath p = let ident = match p.Parser.token with | Lident ident -> - Parser.next p; - Longident.Lident ident + Parser.next p; + Longident.Lident ident | Uident ident -> - let res = aux p (Lident ident) in - Parser.nextUnsafe p; - res + let res = aux p (Lident ident) in + Parser.nextUnsafe p; + res | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Parser.nextUnsafe p; - Longident.Lident "_" + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Parser.nextUnsafe p; + Longident.Lident "_" in Location.mkloc ident (mkLoc startPos p.prevEndPos) @@ -283806,24 +284071,26 @@ let parseValuePathAfterDot p = match p.Parser.token with | Lident _ | Uident _ -> parseValuePath p | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Location.mkloc (Longident.Lident "_") (mkLoc startPos p.prevEndPos) + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Location.mkloc (Longident.Lident "_") (mkLoc startPos p.prevEndPos) let parseValuePathTail p startPos ident = let rec loop p path = match p.Parser.token with | Lident ident -> - Parser.next p; - Location.mkloc - (Longident.Ldot (path, ident)) - (mkLoc startPos p.prevEndPos) + Parser.next p; + Location.mkloc + (Longident.Ldot (path, ident)) + (mkLoc startPos p.prevEndPos) | Uident ident -> - Parser.next p; - Parser.expect Dot p; - loop p (Longident.Ldot (path, ident)) + Parser.next p; + Parser.expect Dot p; + loop p (Longident.Ldot (path, ident)) | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Location.mkloc (Longident.Ldot (path, "_")) (mkLoc startPos p.prevEndPos) + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Location.mkloc + (Longident.Ldot (path, "_")) + (mkLoc startPos p.prevEndPos) in loop p ident @@ -283831,21 +284098,21 @@ let parseModuleLongIdentTail ~lowercase p startPos ident = let rec loop p acc = match p.Parser.token with | Lident ident when lowercase -> - Parser.next p; - let lident = Longident.Ldot (acc, ident) in - Location.mkloc lident (mkLoc startPos p.prevEndPos) + Parser.next p; + let lident = Longident.Ldot (acc, ident) in + Location.mkloc lident (mkLoc startPos p.prevEndPos) | Uident ident -> ( - Parser.next p; - let endPos = p.prevEndPos in - let lident = Longident.Ldot (acc, ident) in - match p.Parser.token with - | Dot -> Parser.next p; - loop p lident - | _ -> Location.mkloc lident (mkLoc startPos endPos)) + let endPos = p.prevEndPos in + let lident = Longident.Ldot (acc, ident) in + match p.Parser.token with + | Dot -> + Parser.next p; + loop p lident + | _ -> Location.mkloc lident (mkLoc startPos endPos)) | t -> - Parser.err p (Diagnostics.uident t); - Location.mkloc (Longident.Ldot (acc, "_")) (mkLoc startPos p.prevEndPos) + Parser.err p (Diagnostics.uident t); + Location.mkloc (Longident.Ldot (acc, "_")) (mkLoc startPos p.prevEndPos) in loop p ident @@ -283858,22 +284125,22 @@ let parseModuleLongIdent ~lowercase p = let moduleIdent = match p.Parser.token with | Lident ident when lowercase -> - let loc = mkLoc startPos p.endPos in - let lident = Longident.Lident ident in - Parser.next p; - Location.mkloc lident loc + let loc = mkLoc startPos p.endPos in + let lident = Longident.Lident ident in + Parser.next p; + Location.mkloc lident loc | Uident ident -> ( - let lident = Longident.Lident ident in - let endPos = p.endPos in - Parser.next p; - match p.Parser.token with - | Dot -> + let lident = Longident.Lident ident in + let endPos = p.endPos in Parser.next p; - parseModuleLongIdentTail ~lowercase p startPos lident - | _ -> Location.mkloc lident (mkLoc startPos endPos)) + match p.Parser.token with + | Dot -> + Parser.next p; + parseModuleLongIdentTail ~lowercase p startPos lident + | _ -> Location.mkloc lident (mkLoc startPos endPos)) | t -> - Parser.err p (Diagnostics.uident t); - Location.mkloc (Longident.Lident "_") (mkLoc startPos p.prevEndPos) + Parser.err p (Diagnostics.uident t); + Location.mkloc (Longident.Lident "_") (mkLoc startPos p.prevEndPos) in (* Parser.eatBreadcrumb p; *) moduleIdent @@ -283882,31 +284149,31 @@ let verifyJsxOpeningClosingName p nameExpr = let closing = match p.Parser.token with | Lident lident -> - Parser.next p; - Longident.Lident lident + Parser.next p; + Longident.Lident lident | Uident _ -> (parseModuleLongIdent ~lowercase:true p).txt | _ -> Longident.Lident "" in match nameExpr.Parsetree.pexp_desc with | Pexp_ident openingIdent -> - let opening = - let withoutCreateElement = - Longident.flatten openingIdent.txt - |> List.filter (fun s -> s <> "createElement") + let opening = + let withoutCreateElement = + Longident.flatten openingIdent.txt + |> List.filter (fun s -> s <> "createElement") + in + match Longident.unflatten withoutCreateElement with + | Some li -> li + | None -> Longident.Lident "" in - match Longident.unflatten withoutCreateElement with - | Some li -> li - | None -> Longident.Lident "" - in - opening = closing + opening = closing | _ -> assert false let string_of_pexp_ident nameExpr = match nameExpr.Parsetree.pexp_desc with | Pexp_ident openingIdent -> - Longident.flatten openingIdent.txt - |> List.filter (fun s -> s <> "createElement") - |> String.concat "." + Longident.flatten openingIdent.txt + |> List.filter (fun s -> s <> "createElement") + |> String.concat "." | _ -> "" (* open-def ::= @@ -283931,33 +284198,34 @@ let parseConstant p = let isNegative = match p.Parser.token with | Token.Minus -> - Parser.next p; - true + Parser.next p; + true | Plus -> - Parser.next p; - false + Parser.next p; + false | _ -> false in let constant = match p.Parser.token with - | Int {i; suffix} -> - let intTxt = if isNegative then "-" ^ i else i in - Parsetree.Pconst_integer (intTxt, suffix) - | Float {f; suffix} -> - let floatTxt = if isNegative then "-" ^ f else f in - Parsetree.Pconst_float (floatTxt, suffix) + | Int { i; suffix } -> + let intTxt = if isNegative then "-" ^ i else i in + Parsetree.Pconst_integer (intTxt, suffix) + | Float { f; suffix } -> + let floatTxt = if isNegative then "-" ^ f else f in + Parsetree.Pconst_float (floatTxt, suffix) | String s -> - Pconst_string (s, if p.mode = ParseForTypeChecker then Some "js" else None) - | Codepoint {c; original} -> - if p.mode = ParseForTypeChecker then Pconst_char c - else - (* Pconst_char char does not have enough information for formatting. - * When parsing for the printer, we encode the char contents as a string - * with a special prefix. *) - Pconst_string (original, Some "INTERNAL_RES_CHAR_CONTENTS") + Pconst_string + (s, if p.mode = ParseForTypeChecker then Some "js" else None) + | Codepoint { c; original } -> + if p.mode = ParseForTypeChecker then Pconst_char c + else + (* Pconst_char char does not have enough information for formatting. + * When parsing for the printer, we encode the char contents as a string + * with a special prefix. *) + Pconst_string (original, Some "INTERNAL_RES_CHAR_CONTENTS") | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Pconst_string ("", None) + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Pconst_string ("", None) in Parser.nextUnsafe p; constant @@ -283968,63 +284236,63 @@ let parseTemplateConstant ~prefix (p : Parser.t) = Parser.nextTemplateLiteralToken p; match p.token with | TemplateTail (txt, _) -> - Parser.next p; - Parsetree.Pconst_string (txt, prefix) + Parser.next p; + Parsetree.Pconst_string (txt, prefix) | _ -> - let rec skipTokens () = - if p.token <> Eof then ( - Parser.next p; - match p.token with - | Backtick -> + let rec skipTokens () = + if p.token <> Eof then ( Parser.next p; - () - | _ -> skipTokens ()) - in - skipTokens (); - Parser.err ~startPos ~endPos:p.prevEndPos p - (Diagnostics.message ErrorMessages.stringInterpolationInPattern); - Pconst_string ("", None) + match p.token with + | Backtick -> + Parser.next p; + () + | _ -> skipTokens ()) + in + skipTokens (); + Parser.err ~startPos ~endPos:p.prevEndPos p + (Diagnostics.message ErrorMessages.stringInterpolationInPattern); + Pconst_string ("", None) let parseCommaDelimitedRegion p ~grammar ~closing ~f = Parser.leaveBreadcrumb p grammar; let rec loop nodes = match f p with | Some node -> ( - match p.Parser.token with - | Comma -> - Parser.next p; - loop (node :: nodes) - | token when token = closing || token = Eof -> List.rev (node :: nodes) - | _ when Grammar.isListElement grammar p.token -> - (* missing comma between nodes in the region and the current token - * looks like the start of something valid in the current region. - * Example: - * type student<'extraInfo> = { - * name: string, - * age: int - * otherInfo: 'extraInfo - * } - * There is a missing comma between `int` and `otherInfo`. - * `otherInfo` looks like a valid start of the record declaration. - * We report the error here and then continue parsing the region. - *) - Parser.expect Comma p; - loop (node :: nodes) - | _ -> - if - not - (p.token = Eof || p.token = closing - || Recover.shouldAbortListParse p) - then Parser.expect Comma p; - if p.token = Semicolon then Parser.next p; - loop (node :: nodes)) + match p.Parser.token with + | Comma -> + Parser.next p; + loop (node :: nodes) + | token when token = closing || token = Eof -> List.rev (node :: nodes) + | _ when Grammar.isListElement grammar p.token -> + (* missing comma between nodes in the region and the current token + * looks like the start of something valid in the current region. + * Example: + * type student<'extraInfo> = { + * name: string, + * age: int + * otherInfo: 'extraInfo + * } + * There is a missing comma between `int` and `otherInfo`. + * `otherInfo` looks like a valid start of the record declaration. + * We report the error here and then continue parsing the region. + *) + Parser.expect Comma p; + loop (node :: nodes) + | _ -> + if + not + (p.token = Eof || p.token = closing + || Recover.shouldAbortListParse p) + then Parser.expect Comma p; + if p.token = Semicolon then Parser.next p; + loop (node :: nodes)) | None -> - if p.token = Eof || p.token = closing || Recover.shouldAbortListParse p - then List.rev nodes - else ( - Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); - Parser.next p; - loop nodes) + if p.token = Eof || p.token = closing || Recover.shouldAbortListParse p + then List.rev nodes + else ( + Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); + Parser.next p; + loop nodes) in let nodes = loop [] in Parser.eatBreadcrumb p; @@ -284035,41 +284303,41 @@ let parseCommaDelimitedReversedList p ~grammar ~closing ~f = let rec loop nodes = match f p with | Some node -> ( - match p.Parser.token with - | Comma -> - Parser.next p; - loop (node :: nodes) - | token when token = closing || token = Eof -> node :: nodes - | _ when Grammar.isListElement grammar p.token -> - (* missing comma between nodes in the region and the current token - * looks like the start of something valid in the current region. - * Example: - * type student<'extraInfo> = { - * name: string, - * age: int - * otherInfo: 'extraInfo - * } - * There is a missing comma between `int` and `otherInfo`. - * `otherInfo` looks like a valid start of the record declaration. - * We report the error here and then continue parsing the region. - *) - Parser.expect Comma p; - loop (node :: nodes) - | _ -> - if - not - (p.token = Eof || p.token = closing - || Recover.shouldAbortListParse p) - then Parser.expect Comma p; - if p.token = Semicolon then Parser.next p; - loop (node :: nodes)) + match p.Parser.token with + | Comma -> + Parser.next p; + loop (node :: nodes) + | token when token = closing || token = Eof -> node :: nodes + | _ when Grammar.isListElement grammar p.token -> + (* missing comma between nodes in the region and the current token + * looks like the start of something valid in the current region. + * Example: + * type student<'extraInfo> = { + * name: string, + * age: int + * otherInfo: 'extraInfo + * } + * There is a missing comma between `int` and `otherInfo`. + * `otherInfo` looks like a valid start of the record declaration. + * We report the error here and then continue parsing the region. + *) + Parser.expect Comma p; + loop (node :: nodes) + | _ -> + if + not + (p.token = Eof || p.token = closing + || Recover.shouldAbortListParse p) + then Parser.expect Comma p; + if p.token = Semicolon then Parser.next p; + loop (node :: nodes)) | None -> - if p.token = Eof || p.token = closing || Recover.shouldAbortListParse p - then nodes - else ( - Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); - Parser.next p; - loop nodes) + if p.token = Eof || p.token = closing || Recover.shouldAbortListParse p + then nodes + else ( + Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); + Parser.next p; + loop nodes) in let nodes = loop [] in Parser.eatBreadcrumb p; @@ -284081,14 +284349,14 @@ let parseDelimitedRegion p ~grammar ~closing ~f = match f p with | Some node -> loop (node :: nodes) | None -> - if - p.Parser.token = Token.Eof || p.token = closing - || Recover.shouldAbortListParse p - then List.rev nodes - else ( - Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); - Parser.next p; - loop nodes) + if + p.Parser.token = Token.Eof || p.token = closing + || Recover.shouldAbortListParse p + then List.rev nodes + else ( + Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); + Parser.next p; + loop nodes) in let nodes = loop [] in Parser.eatBreadcrumb p; @@ -284100,12 +284368,12 @@ let parseRegion p ~grammar ~f = match f p with | Some node -> loop (node :: nodes) | None -> - if p.Parser.token = Token.Eof || Recover.shouldAbortListParse p then - List.rev nodes - else ( - Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); - Parser.next p; - loop nodes) + if p.Parser.token = Token.Eof || Recover.shouldAbortListParse p then + List.rev nodes + else ( + Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); + Parser.next p; + loop nodes) in let nodes = loop [] in Parser.eatBreadcrumb p; @@ -284138,128 +284406,130 @@ let rec parsePattern ?(alias = true) ?(or_ = true) p = let pat = match p.Parser.token with | (True | False) as token -> - let endPos = p.endPos in - Parser.next p; - let loc = mkLoc startPos endPos in - Ast_helper.Pat.construct ~loc - (Location.mkloc (Longident.Lident (Token.toString token)) loc) - None - | Int _ | String _ | Float _ | Codepoint _ | Minus | Plus -> ( - let c = parseConstant p in - match p.token with - | DotDot -> + let endPos = p.endPos in Parser.next p; - let c2 = parseConstant p in - Ast_helper.Pat.interval ~loc:(mkLoc startPos p.prevEndPos) c c2 - | _ -> Ast_helper.Pat.constant ~loc:(mkLoc startPos p.prevEndPos) c) + let loc = mkLoc startPos endPos in + Ast_helper.Pat.construct ~loc + (Location.mkloc (Longident.Lident (Token.toString token)) loc) + None + | Int _ | String _ | Float _ | Codepoint _ | Minus | Plus -> ( + let c = parseConstant p in + match p.token with + | DotDot -> + Parser.next p; + let c2 = parseConstant p in + Ast_helper.Pat.interval ~loc:(mkLoc startPos p.prevEndPos) c c2 + | _ -> Ast_helper.Pat.constant ~loc:(mkLoc startPos p.prevEndPos) c) | Backtick -> - let constant = parseTemplateConstant ~prefix:(Some "js") p in - Ast_helper.Pat.constant ~attrs:[templateLiteralAttr] - ~loc:(mkLoc startPos p.prevEndPos) - constant + let constant = parseTemplateConstant ~prefix:(Some "js") p in + Ast_helper.Pat.constant ~attrs:[ templateLiteralAttr ] + ~loc:(mkLoc startPos p.prevEndPos) + constant | Lparen -> ( - Parser.next p; - match p.token with - | Rparen -> Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let lid = Location.mkloc (Longident.Lident "()") loc in - Ast_helper.Pat.construct ~loc lid None - | _ -> ( - let pat = parseConstrainedPattern p in match p.token with - | Comma -> - Parser.next p; - parseTuplePattern ~attrs ~first:pat ~startPos p - | _ -> - Parser.expect Rparen p; - let loc = mkLoc startPos p.prevEndPos in - { - pat with - ppat_loc = loc; - ppat_attributes = attrs @ pat.Parsetree.ppat_attributes; - })) + | Rparen -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let lid = Location.mkloc (Longident.Lident "()") loc in + Ast_helper.Pat.construct ~loc lid None + | _ -> ( + let pat = parseConstrainedPattern p in + match p.token with + | Comma -> + Parser.next p; + parseTuplePattern ~attrs ~first:pat ~startPos p + | _ -> + Parser.expect Rparen p; + let loc = mkLoc startPos p.prevEndPos in + { + pat with + ppat_loc = loc; + ppat_attributes = attrs @ pat.Parsetree.ppat_attributes; + })) | Lbracket -> parseArrayPattern ~attrs p | Lbrace -> parseRecordPattern ~attrs p | Underscore -> - let endPos = p.endPos in - let loc = mkLoc startPos endPos in - Parser.next p; - Ast_helper.Pat.any ~loc ~attrs () + let endPos = p.endPos in + let loc = mkLoc startPos endPos in + Parser.next p; + Ast_helper.Pat.any ~loc ~attrs () | Lident ident -> ( - let endPos = p.endPos in - let loc = mkLoc startPos endPos in - Parser.next p; - match p.token with - | Backtick -> - let constant = parseTemplateConstant ~prefix:(Some ident) p in - Ast_helper.Pat.constant ~loc:(mkLoc startPos p.prevEndPos) constant - | _ -> Ast_helper.Pat.var ~loc ~attrs (Location.mkloc ident loc)) + let endPos = p.endPos in + let loc = mkLoc startPos endPos in + Parser.next p; + match p.token with + | Backtick -> + let constant = parseTemplateConstant ~prefix:(Some ident) p in + Ast_helper.Pat.constant ~loc:(mkLoc startPos p.prevEndPos) constant + | _ -> Ast_helper.Pat.var ~loc ~attrs (Location.mkloc ident loc)) | Uident _ -> ( - let constr = parseModuleLongIdent ~lowercase:false p in - match p.Parser.token with - | Lparen -> parseConstructorPatternArgs p constr startPos attrs - | _ -> Ast_helper.Pat.construct ~loc:constr.loc ~attrs constr None) + let constr = parseModuleLongIdent ~lowercase:false p in + match p.Parser.token with + | Lparen -> parseConstructorPatternArgs p constr startPos attrs + | _ -> Ast_helper.Pat.construct ~loc:constr.loc ~attrs constr None) | Hash -> ( - Parser.next p; - if p.Parser.token == DotDotDot then ( Parser.next p; - let ident = parseValuePath p in - let loc = mkLoc startPos ident.loc.loc_end in - Ast_helper.Pat.type_ ~loc ~attrs ident) - else - let ident, loc = - match p.token with - | String text -> - Parser.next p; - (text, mkLoc startPos p.prevEndPos) - | Int {i; suffix} -> - let () = - match suffix with - | Some _ -> - Parser.err p - (Diagnostics.message (ErrorMessages.polyVarIntWithSuffix i)) - | None -> () - in - Parser.next p; - (i, mkLoc startPos p.prevEndPos) - | Eof -> - Parser.err ~startPos p - (Diagnostics.unexpected p.token p.breadcrumbs); - ("", mkLoc startPos p.prevEndPos) - | _ -> parseIdent ~msg:ErrorMessages.variantIdent ~startPos p - in - match p.Parser.token with - | Lparen -> parseVariantPatternArgs p ident startPos attrs - | _ -> Ast_helper.Pat.variant ~loc ~attrs ident None) + if p.Parser.token == DotDotDot then ( + Parser.next p; + let ident = parseValuePath p in + let loc = mkLoc startPos ident.loc.loc_end in + Ast_helper.Pat.type_ ~loc ~attrs ident) + else + let ident, loc = + match p.token with + | String text -> + Parser.next p; + (text, mkLoc startPos p.prevEndPos) + | Int { i; suffix } -> + let () = + match suffix with + | Some _ -> + Parser.err p + (Diagnostics.message + (ErrorMessages.polyVarIntWithSuffix i)) + | None -> () + in + Parser.next p; + (i, mkLoc startPos p.prevEndPos) + | Eof -> + Parser.err ~startPos p + (Diagnostics.unexpected p.token p.breadcrumbs); + ("", mkLoc startPos p.prevEndPos) + | _ -> parseIdent ~msg:ErrorMessages.variantIdent ~startPos p + in + match p.Parser.token with + | Lparen -> parseVariantPatternArgs p ident startPos attrs + | _ -> Ast_helper.Pat.variant ~loc ~attrs ident None) | Exception -> - Parser.next p; - let pat = parsePattern ~alias:false ~or_:false p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.exception_ ~loc ~attrs pat + Parser.next p; + let pat = parsePattern ~alias:false ~or_:false p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Pat.exception_ ~loc ~attrs pat | Lazy -> - Parser.next p; - let pat = parsePattern ~alias:false ~or_:false p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.lazy_ ~loc ~attrs pat + Parser.next p; + let pat = parsePattern ~alias:false ~or_:false p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Pat.lazy_ ~loc ~attrs pat | List -> - Parser.next p; - parseListPattern ~startPos ~attrs p + Parser.next p; + parseListPattern ~startPos ~attrs p | Module -> parseModulePattern ~attrs p | Percent -> - let extension = parseExtension p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.extension ~loc ~attrs extension + let extension = parseExtension p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Pat.extension ~loc ~attrs extension | Eof -> - Parser.err p (Diagnostics.unexpected p.Parser.token p.breadcrumbs); - Recover.defaultPattern () + Parser.err p (Diagnostics.unexpected p.Parser.token p.breadcrumbs); + Recover.defaultPattern () | token -> ( - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - match - skipTokensAndMaybeRetry p ~isStartOfGrammar:Grammar.isAtomicPatternStart - with - | None -> Recover.defaultPattern () - | Some () -> parsePattern p) + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + match + skipTokensAndMaybeRetry p + ~isStartOfGrammar:Grammar.isAtomicPatternStart + with + | None -> Recover.defaultPattern () + | Some () -> parsePattern p) in let pat = if alias then parseAliasPattern ~attrs pat p else pat in if or_ then parseOrPattern pat p else pat @@ -284290,12 +284560,12 @@ and skipTokensAndMaybeRetry p ~isStartOfGrammar = and parseAliasPattern ~attrs pattern p = match p.Parser.token with | As -> - Parser.next p; - let name, loc = parseLident p in - let name = Location.mkloc name loc in - Ast_helper.Pat.alias - ~loc:{pattern.ppat_loc with loc_end = p.prevEndPos} - ~attrs pattern name + Parser.next p; + let name, loc = parseLident p in + let name = Location.mkloc name loc in + Ast_helper.Pat.alias + ~loc:{ pattern.ppat_loc with loc_end = p.prevEndPos } + ~attrs pattern name | _ -> pattern (* or ::= pattern | pattern @@ -284304,12 +284574,15 @@ and parseOrPattern pattern1 p = let rec loop pattern1 = match p.Parser.token with | Bar -> - Parser.next p; - let pattern2 = parsePattern ~or_:false p in - let loc = - {pattern1.Parsetree.ppat_loc with loc_end = pattern2.ppat_loc.loc_end} - in - loop (Ast_helper.Pat.or_ ~loc pattern1 pattern2) + Parser.next p; + let pattern2 = parsePattern ~or_:false p in + let loc = + { + pattern1.Parsetree.ppat_loc with + loc_end = pattern2.ppat_loc.loc_end; + } + in + loop (Ast_helper.Pat.or_ ~loc pattern1 pattern2) | _ -> pattern1 in loop pattern1 @@ -284318,30 +284591,32 @@ and parseNonSpreadPattern ~msg p = let () = match p.Parser.token with | DotDotDot -> - Parser.err p (Diagnostics.message msg); - Parser.next p + Parser.err p (Diagnostics.message msg); + Parser.next p | _ -> () in match p.Parser.token with | token when Grammar.isPatternStart token -> ( - let pat = parsePattern p in - match p.Parser.token with - | Colon -> - Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc pat.ppat_loc.loc_start typ.Parsetree.ptyp_loc.loc_end in - Some (Ast_helper.Pat.constraint_ ~loc pat typ) - | _ -> Some pat) + let pat = parsePattern p in + match p.Parser.token with + | Colon -> + Parser.next p; + let typ = parseTypExpr p in + let loc = + mkLoc pat.ppat_loc.loc_start typ.Parsetree.ptyp_loc.loc_end + in + Some (Ast_helper.Pat.constraint_ ~loc pat typ) + | _ -> Some pat) | _ -> None and parseConstrainedPattern p = let pat = parsePattern p in match p.Parser.token with | Colon -> - Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc pat.ppat_loc.loc_start typ.Parsetree.ptyp_loc.loc_end in - Ast_helper.Pat.constraint_ ~loc pat typ + Parser.next p; + let typ = parseTypExpr p in + let loc = mkLoc pat.ppat_loc.loc_start typ.Parsetree.ptyp_loc.loc_end in + Ast_helper.Pat.constraint_ ~loc pat typ | _ -> pat and parseConstrainedPatternRegion p = @@ -284352,8 +284627,8 @@ and parseConstrainedPatternRegion p = and parseOptionalLabel p = match p.Parser.token with | Question -> - Parser.next p; - true + Parser.next p; + true | _ -> false (* field ::= @@ -284371,13 +284646,13 @@ and parseRecordPatternRowField ~attrs p = let pattern = match p.Parser.token with | Colon -> - Parser.next p; - let optional = parseOptionalLabel p in - let pat = parsePattern p in - makePatternOptional ~optional pat + Parser.next p; + let optional = parseOptionalLabel p in + let pat = parsePattern p in + makePatternOptional ~optional pat | _ -> - Ast_helper.Pat.var ~loc:label.loc ~attrs - (Location.mkloc (Longident.last label.txt) label.loc) + Ast_helper.Pat.var ~loc:label.loc ~attrs + (Location.mkloc (Longident.last label.txt) label.loc) in (label, pattern) @@ -284386,20 +284661,20 @@ and parseRecordPatternRow p = let attrs = parseAttributes p in match p.Parser.token with | DotDotDot -> - Parser.next p; - Some (true, PatField (parseRecordPatternRowField ~attrs p)) + Parser.next p; + Some (true, PatField (parseRecordPatternRowField ~attrs p)) | Uident _ | Lident _ -> - Some (false, PatField (parseRecordPatternRowField ~attrs p)) + Some (false, PatField (parseRecordPatternRowField ~attrs p)) | Question -> ( - Parser.next p; - match p.token with - | Uident _ | Lident _ -> - let lid, pat = parseRecordPatternRowField ~attrs p in - Some (false, PatField (lid, makePatternOptional ~optional:true pat)) - | _ -> None) + Parser.next p; + match p.token with + | Uident _ | Lident _ -> + let lid, pat = parseRecordPatternRowField ~attrs p in + Some (false, PatField (lid, makePatternOptional ~optional:true pat)) + | _ -> None) | Underscore -> - Parser.next p; - Some (false, PatUnderscore) + Parser.next p; + Some (false, PatUnderscore) | _ -> None and parseRecordPattern ~attrs p = @@ -284421,11 +284696,11 @@ and parseRecordPattern ~attrs p = let hasSpread, field = curr in match field with | PatField field -> - (if hasSpread then - let _, pattern = field in - Parser.err ~startPos:pattern.Parsetree.ppat_loc.loc_start p - (Diagnostics.message ErrorMessages.recordPatternSpread)); - (field :: fields, flag) + (if hasSpread then + let _, pattern = field in + Parser.err ~startPos:pattern.Parsetree.ppat_loc.loc_start p + (Diagnostics.message ErrorMessages.recordPatternSpread)); + (field :: fields, flag) | PatUnderscore -> (fields, flag)) ([], flag) rawFields in @@ -284441,9 +284716,9 @@ and parseTuplePattern ~attrs ~first ~startPos p = Parser.expect Rparen p; let () = match patterns with - | [_] -> - Parser.err ~startPos ~endPos:p.prevEndPos p - (Diagnostics.message ErrorMessages.tupleSingleElement) + | [ _ ] -> + Parser.err ~startPos ~endPos:p.prevEndPos p + (Diagnostics.message ErrorMessages.tupleSingleElement) | _ -> () in let loc = mkLoc startPos p.prevEndPos in @@ -284452,10 +284727,10 @@ and parseTuplePattern ~attrs ~first ~startPos p = and parsePatternRegion p = match p.Parser.token with | DotDotDot -> - Parser.next p; - Some (true, parseConstrainedPattern p) + Parser.next p; + Some (true, parseConstrainedPattern p) | token when Grammar.isPatternStart token -> - Some (false, parseConstrainedPattern p) + Some (false, parseConstrainedPattern p) | _ -> None and parseModulePattern ~attrs p = @@ -284465,29 +284740,29 @@ and parseModulePattern ~attrs p = let uident = match p.token with | Uident uident -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Location.mkloc uident loc + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc uident loc | _ -> - (* TODO: error recovery *) - Location.mknoloc "_" + (* TODO: error recovery *) + Location.mknoloc "_" in match p.token with | Colon -> - let colonStart = p.Parser.startPos in - Parser.next p; - let packageTypAttrs = parseAttributes p in - let packageType = - parsePackageType ~startPos:colonStart ~attrs:packageTypAttrs p - in - Parser.expect Rparen p; - let loc = mkLoc startPos p.prevEndPos in - let unpack = Ast_helper.Pat.unpack ~loc:uident.loc uident in - Ast_helper.Pat.constraint_ ~loc ~attrs unpack packageType + let colonStart = p.Parser.startPos in + Parser.next p; + let packageTypAttrs = parseAttributes p in + let packageType = + parsePackageType ~startPos:colonStart ~attrs:packageTypAttrs p + in + Parser.expect Rparen p; + let loc = mkLoc startPos p.prevEndPos in + let unpack = Ast_helper.Pat.unpack ~loc:uident.loc uident in + Ast_helper.Pat.constraint_ ~loc ~attrs unpack packageType | _ -> - Parser.expect Rparen p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.unpack ~loc ~attrs uident + Parser.expect Rparen p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Pat.unpack ~loc ~attrs uident and parseListPattern ~startPos ~attrs p = let listPatterns = @@ -284505,13 +284780,13 @@ and parseListPattern ~startPos ~attrs p = in match listPatterns with | (true, pattern) :: patterns -> - let patterns = patterns |> List.map filterSpread |> List.rev in - let pat = makeListPattern loc patterns (Some pattern) in - {pat with ppat_loc = loc; ppat_attributes = attrs} + let patterns = patterns |> List.map filterSpread |> List.rev in + let pat = makeListPattern loc patterns (Some pattern) in + { pat with ppat_loc = loc; ppat_attributes = attrs } | patterns -> - let patterns = patterns |> List.map filterSpread |> List.rev in - let pat = makeListPattern loc patterns None in - {pat with ppat_loc = loc; ppat_attributes = attrs} + let patterns = patterns |> List.map filterSpread |> List.rev in + let pat = makeListPattern loc patterns None in + { pat with ppat_loc = loc; ppat_attributes = attrs } and parseArrayPattern ~attrs p = let startPos = p.startPos in @@ -284535,21 +284810,21 @@ and parseConstructorPatternArgs p constr startPos attrs = let args = match args with | [] -> - let loc = mkLoc lparen p.prevEndPos in - Some - (Ast_helper.Pat.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - None) - | [({ppat_desc = Ppat_tuple _} as pat)] as patterns -> - if p.mode = ParseForTypeChecker then - (* Some(1, 2) for type-checker *) - Some pat - else - (* Some((1, 2)) for printer *) - Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) - | [pattern] -> Some pattern + let loc = mkLoc lparen p.prevEndPos in + Some + (Ast_helper.Pat.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None) + | [ ({ ppat_desc = Ppat_tuple _ } as pat) ] as patterns -> + if p.mode = ParseForTypeChecker then + (* Some(1, 2) for type-checker *) + Some pat + else + (* Some((1, 2)) for printer *) + Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) + | [ pattern ] -> Some pattern | patterns -> - Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) + Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) in Ast_helper.Pat.construct ~loc:(mkLoc startPos p.prevEndPos) ~attrs constr args @@ -284563,21 +284838,21 @@ and parseVariantPatternArgs p ident startPos attrs = let args = match patterns with | [] -> - let loc = mkLoc lparen p.prevEndPos in - Some - (Ast_helper.Pat.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - None) - | [({ppat_desc = Ppat_tuple _} as pat)] as patterns -> - if p.mode = ParseForTypeChecker then - (* #ident(1, 2) for type-checker *) - Some pat - else - (* #ident((1, 2)) for printer *) - Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) - | [pattern] -> Some pattern + let loc = mkLoc lparen p.prevEndPos in + Some + (Ast_helper.Pat.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None) + | [ ({ ppat_desc = Ppat_tuple _ } as pat) ] as patterns -> + if p.mode = ParseForTypeChecker then + (* #ident(1, 2) for type-checker *) + Some pat + else + (* #ident((1, 2)) for printer *) + Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) + | [ pattern ] -> Some pattern | patterns -> - Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) + Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) in Parser.expect Rparen p; Ast_helper.Pat.variant ~loc:(mkLoc startPos p.prevEndPos) ~attrs ident args @@ -284591,36 +284866,34 @@ and parseExpr ?(context = OrdinaryExpr) p = and parseTernaryExpr leftOperand p = match p.Parser.token with | Question -> - Parser.leaveBreadcrumb p Grammar.Ternary; - Parser.next p; - let trueBranch = parseExpr ~context:TernaryTrueBranchExpr p in - Parser.expect Colon p; - let falseBranch = parseExpr p in - Parser.eatBreadcrumb p; - let loc = - { - leftOperand.Parsetree.pexp_loc with - loc_start = leftOperand.pexp_loc.loc_start; - loc_end = falseBranch.Parsetree.pexp_loc.loc_end; - } - in - Ast_helper.Exp.ifthenelse ~attrs:[ternaryAttr] ~loc leftOperand trueBranch - (Some falseBranch) + Parser.leaveBreadcrumb p Grammar.Ternary; + Parser.next p; + let trueBranch = parseExpr ~context:TernaryTrueBranchExpr p in + Parser.expect Colon p; + let falseBranch = parseExpr p in + Parser.eatBreadcrumb p; + let loc = + { + leftOperand.Parsetree.pexp_loc with + loc_start = leftOperand.pexp_loc.loc_start; + loc_end = falseBranch.Parsetree.pexp_loc.loc_end; + } + in + Ast_helper.Exp.ifthenelse ~attrs:[ ternaryAttr ] ~loc leftOperand + trueBranch (Some falseBranch) | _ -> leftOperand and parseEs6ArrowExpression ?context ?parameters p = let startPos = p.Parser.startPos in Parser.leaveBreadcrumb p Grammar.Es6ArrowExpr; let parameters = - match parameters with - | Some params -> params - | None -> parseParameters p + match parameters with Some params -> params | None -> parseParameters p in let returnType = match p.Parser.token with | Colon -> - Parser.next p; - Some (parseTypExpr ~es6Arrow:false p) + Parser.next p; + Some (parseTypExpr ~es6Arrow:false p) | _ -> None in Parser.expect EqualGreater p; @@ -284628,9 +284901,9 @@ and parseEs6ArrowExpression ?context ?parameters p = let expr = parseExpr ?context p in match returnType with | Some typ -> - Ast_helper.Exp.constraint_ - ~loc:(mkLoc expr.pexp_loc.loc_start typ.Parsetree.ptyp_loc.loc_end) - expr typ + Ast_helper.Exp.constraint_ + ~loc:(mkLoc expr.pexp_loc.loc_start typ.Parsetree.ptyp_loc.loc_end) + expr typ | None -> expr in Parser.eatBreadcrumb p; @@ -284648,15 +284921,15 @@ and parseEs6ArrowExpression ?context ?parameters p = pat; pos = startPos; } -> - let attrs = if uncurried then uncurryAttr :: attrs else attrs in - Ast_helper.Exp.fun_ ~loc:(mkLoc startPos endPos) ~attrs lbl - defaultExpr pat expr - | TypeParameter {uncurried; attrs; locs = newtypes; pos = startPos} -> - let attrs = if uncurried then uncurryAttr :: attrs else attrs in - makeNewtypes ~attrs ~loc:(mkLoc startPos endPos) newtypes expr) + let attrs = if uncurried then uncurryAttr :: attrs else attrs in + Ast_helper.Exp.fun_ ~loc:(mkLoc startPos endPos) ~attrs lbl + defaultExpr pat expr + | TypeParameter { uncurried; attrs; locs = newtypes; pos = startPos } -> + let attrs = if uncurried then uncurryAttr :: attrs else attrs in + makeNewtypes ~attrs ~loc:(mkLoc startPos endPos) newtypes expr) parameters body in - {arrowExpr with pexp_loc = {arrowExpr.pexp_loc with loc_start = startPos}} + { arrowExpr with pexp_loc = { arrowExpr.pexp_loc with loc_start = startPos } } (* * uncurried_parameter ::= @@ -284694,92 +284967,109 @@ and parseParameter p = if p.Parser.token = Typ then ( Parser.next p; let lidents = parseLidentList p in - Some (TypeParameter {uncurried; attrs; locs = lidents; pos = startPos})) + Some (TypeParameter { uncurried; attrs; locs = lidents; pos = startPos })) else let attrs, lbl, pat = match p.Parser.token with | Tilde -> ( - Parser.next p; - let lblName, loc = parseLident p in - let propLocAttr = - (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) - in - match p.Parser.token with - | Comma | Equal | Rparen -> - let loc = mkLoc startPos p.prevEndPos in - ( attrs, - Asttypes.Labelled lblName, - Ast_helper.Pat.var ~attrs:[propLocAttr] ~loc - (Location.mkloc lblName loc) ) - | Colon -> - let lblEnd = p.prevEndPos in Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc startPos lblEnd in - let pat = - let pat = Ast_helper.Pat.var ~loc (Location.mkloc lblName loc) in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.constraint_ ~attrs:[propLocAttr] ~loc pat typ + let lblName, loc = parseLident p in + let propLocAttr = + (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) in - (attrs, Asttypes.Labelled lblName, pat) - | As -> - Parser.next p; - let pat = - let pat = parseConstrainedPattern p in - {pat with ppat_attributes = propLocAttr :: pat.ppat_attributes} - in - (attrs, Asttypes.Labelled lblName, pat) - | t -> - Parser.err p (Diagnostics.unexpected t p.breadcrumbs); - let loc = mkLoc startPos p.prevEndPos in - ( attrs, - Asttypes.Labelled lblName, - Ast_helper.Pat.var ~loc (Location.mkloc lblName loc) )) + match p.Parser.token with + | Comma | Equal | Rparen -> + let loc = mkLoc startPos p.prevEndPos in + ( attrs, + Asttypes.Labelled lblName, + Ast_helper.Pat.var ~attrs:[ propLocAttr ] ~loc + (Location.mkloc lblName loc) ) + | Colon -> + let lblEnd = p.prevEndPos in + Parser.next p; + let typ = parseTypExpr p in + let loc = mkLoc startPos lblEnd in + let pat = + let pat = + Ast_helper.Pat.var ~loc (Location.mkloc lblName loc) + in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Pat.constraint_ ~attrs:[ propLocAttr ] ~loc pat typ + in + (attrs, Asttypes.Labelled lblName, pat) + | As -> + Parser.next p; + let pat = + let pat = parseConstrainedPattern p in + { + pat with + ppat_attributes = propLocAttr :: pat.ppat_attributes; + } + in + (attrs, Asttypes.Labelled lblName, pat) + | t -> + Parser.err p (Diagnostics.unexpected t p.breadcrumbs); + let loc = mkLoc startPos p.prevEndPos in + ( attrs, + Asttypes.Labelled lblName, + Ast_helper.Pat.var ~loc (Location.mkloc lblName loc) )) | _ -> - let pattern = parseConstrainedPattern p in - let attrs = List.concat [attrs; pattern.ppat_attributes] in - ([], Asttypes.Nolabel, {pattern with ppat_attributes = attrs}) + let pattern = parseConstrainedPattern p in + let attrs = List.concat [ attrs; pattern.ppat_attributes ] in + ([], Asttypes.Nolabel, { pattern with ppat_attributes = attrs }) in match p.Parser.token with | Equal -> ( - Parser.next p; - let lbl = - match lbl with - | Asttypes.Labelled lblName -> Asttypes.Optional lblName - | Asttypes.Nolabel -> - let lblName = - match pat.ppat_desc with - | Ppat_var var -> var.txt - | _ -> "" - in - Parser.err ~startPos ~endPos:p.prevEndPos p - (Diagnostics.message - (ErrorMessages.missingTildeLabeledParameter lblName)); - Asttypes.Optional lblName - | lbl -> lbl - in - match p.Parser.token with - | Question -> Parser.next p; - Some - (TermParameter - {uncurried; attrs; label = lbl; expr = None; pat; pos = startPos}) - | _ -> - let expr = parseConstrainedOrCoercedExpr p in + let lbl = + match lbl with + | Asttypes.Labelled lblName -> Asttypes.Optional lblName + | Asttypes.Nolabel -> + let lblName = + match pat.ppat_desc with Ppat_var var -> var.txt | _ -> "" + in + Parser.err ~startPos ~endPos:p.prevEndPos p + (Diagnostics.message + (ErrorMessages.missingTildeLabeledParameter lblName)); + Asttypes.Optional lblName + | lbl -> lbl + in + match p.Parser.token with + | Question -> + Parser.next p; + Some + (TermParameter + { + uncurried; + attrs; + label = lbl; + expr = None; + pat; + pos = startPos; + }) + | _ -> + let expr = parseConstrainedOrCoercedExpr p in + Some + (TermParameter + { + uncurried; + attrs; + label = lbl; + expr = Some expr; + pat; + pos = startPos; + })) + | _ -> Some (TermParameter { uncurried; attrs; label = lbl; - expr = Some expr; + expr = None; pat; pos = startPos; - })) - | _ -> - Some - (TermParameter - {uncurried; attrs; label = lbl; expr = None; pat; pos = startPos}) + }) else None and parseParameterList p = @@ -284801,44 +285091,22 @@ and parseParameters p = let startPos = p.Parser.startPos in match p.Parser.token with | Lident ident -> - Parser.next p; - let loc = mkLoc startPos p.Parser.prevEndPos in - [ - TermParameter - { - uncurried = false; - attrs = []; - label = Asttypes.Nolabel; - expr = None; - pat = Ast_helper.Pat.var ~loc (Location.mkloc ident loc); - pos = startPos; - }; - ] + Parser.next p; + let loc = mkLoc startPos p.Parser.prevEndPos in + [ + TermParameter + { + uncurried = false; + attrs = []; + label = Asttypes.Nolabel; + expr = None; + pat = Ast_helper.Pat.var ~loc (Location.mkloc ident loc); + pos = startPos; + }; + ] | Underscore -> - Parser.next p; - let loc = mkLoc startPos p.Parser.prevEndPos in - [ - TermParameter - { - uncurried = false; - attrs = []; - label = Asttypes.Nolabel; - expr = None; - pat = Ast_helper.Pat.any ~loc (); - pos = startPos; - }; - ] - | Lparen -> ( - Parser.next p; - match p.Parser.token with - | Rparen -> Parser.next p; let loc = mkLoc startPos p.Parser.prevEndPos in - let unitPattern = - Ast_helper.Pat.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - None - in [ TermParameter { @@ -284846,58 +285114,80 @@ and parseParameters p = attrs = []; label = Asttypes.Nolabel; expr = None; - pat = unitPattern; + pat = Ast_helper.Pat.any ~loc (); pos = startPos; }; ] - | Dot -> ( + | Lparen -> ( Parser.next p; - match p.token with + match p.Parser.token with | Rparen -> - Parser.next p; - let loc = mkLoc startPos p.Parser.prevEndPos in - let unitPattern = - Ast_helper.Pat.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - None - in - [ - TermParameter - { - uncurried = true; - attrs = []; - label = Asttypes.Nolabel; - expr = None; - pat = unitPattern; - pos = startPos; - }; - ] - | _ -> ( - match parseParameterList p with - | TermParameter - { - attrs; - label = lbl; - expr = defaultExpr; - pat = pattern; - pos = startPos; - } - :: rest -> - TermParameter - { - uncurried = true; - attrs; - label = lbl; - expr = defaultExpr; - pat = pattern; - pos = startPos; - } - :: rest - | parameters -> parameters)) - | _ -> parseParameterList p) + Parser.next p; + let loc = mkLoc startPos p.Parser.prevEndPos in + let unitPattern = + Ast_helper.Pat.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None + in + [ + TermParameter + { + uncurried = false; + attrs = []; + label = Asttypes.Nolabel; + expr = None; + pat = unitPattern; + pos = startPos; + }; + ] + | Dot -> ( + Parser.next p; + match p.token with + | Rparen -> + Parser.next p; + let loc = mkLoc startPos p.Parser.prevEndPos in + let unitPattern = + Ast_helper.Pat.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None + in + [ + TermParameter + { + uncurried = true; + attrs = []; + label = Asttypes.Nolabel; + expr = None; + pat = unitPattern; + pos = startPos; + }; + ] + | _ -> ( + match parseParameterList p with + | TermParameter + { + attrs; + label = lbl; + expr = defaultExpr; + pat = pattern; + pos = startPos; + } + :: rest -> + TermParameter + { + uncurried = true; + attrs; + label = lbl; + expr = defaultExpr; + pat = pattern; + pos = startPos; + } + :: rest + | parameters -> parameters)) + | _ -> parseParameterList p) | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - [] + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + [] and parseCoercedExpr ~(expr : Parsetree.expression) p = Parser.expect ColonGreaterThan p; @@ -284910,28 +285200,28 @@ and parseConstrainedOrCoercedExpr p = match p.Parser.token with | ColonGreaterThan -> parseCoercedExpr ~expr p | Colon -> ( - Parser.next p; - match p.token with - | _ -> ( - let typ = parseTypExpr p in - let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in - let expr = Ast_helper.Exp.constraint_ ~loc expr typ in + Parser.next p; match p.token with - | ColonGreaterThan -> parseCoercedExpr ~expr p - | _ -> expr)) + | _ -> ( + let typ = parseTypExpr p in + let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in + let expr = Ast_helper.Exp.constraint_ ~loc expr typ in + match p.token with + | ColonGreaterThan -> parseCoercedExpr ~expr p + | _ -> expr)) | _ -> expr and parseConstrainedExprRegion p = match p.Parser.token with | token when Grammar.isExprStart token -> ( - let expr = parseExpr p in - match p.Parser.token with - | Colon -> - Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in - Some (Ast_helper.Exp.constraint_ ~loc expr typ) - | _ -> Some expr) + let expr = parseExpr p in + match p.Parser.token with + | Colon -> + Parser.next p; + let typ = parseTypExpr p in + let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in + Some (Ast_helper.Exp.constraint_ ~loc expr typ) + | _ -> Some expr) | _ -> None (* Atomic expressions represent unambiguous expressions. @@ -284943,74 +285233,75 @@ and parseAtomicExpr p = let expr = match p.Parser.token with | (True | False) as token -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.construct ~loc - (Location.mkloc (Longident.Lident (Token.toString token)) loc) - None + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.construct ~loc + (Location.mkloc (Longident.Lident (Token.toString token)) loc) + None | Int _ | String _ | Float _ | Codepoint _ -> - let c = parseConstant p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.constant ~loc c + let c = parseConstant p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.constant ~loc c | Backtick -> - let expr = parseTemplateExpr p in - {expr with pexp_loc = mkLoc startPos p.prevEndPos} + let expr = parseTemplateExpr p in + { expr with pexp_loc = mkLoc startPos p.prevEndPos } | Uident _ | Lident _ -> parseValueOrConstructor p | Hash -> parsePolyVariantExpr p | Lparen -> ( - Parser.next p; - match p.Parser.token with - | Rparen -> Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - None - | _t -> ( - let expr = parseConstrainedOrCoercedExpr p in - match p.token with - | Comma -> - Parser.next p; - parseTupleExpr ~startPos ~first:expr p - | _ -> - Parser.expect Rparen p; - expr - (* {expr with pexp_loc = mkLoc startPos p.prevEndPos} - * What does this location mean here? It means that when there's - * a parenthesized we keep the location here for whitespace interleaving. - * Without the closing paren in the location there will always be an extra - * line. For now we don't include it, because it does weird things - * with for comments. *))) + match p.Parser.token with + | Rparen -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None + | _t -> ( + let expr = parseConstrainedOrCoercedExpr p in + match p.token with + | Comma -> + Parser.next p; + parseTupleExpr ~startPos ~first:expr p + | _ -> + Parser.expect Rparen p; + expr + (* {expr with pexp_loc = mkLoc startPos p.prevEndPos} + * What does this location mean here? It means that when there's + * a parenthesized we keep the location here for whitespace interleaving. + * Without the closing paren in the location there will always be an extra + * line. For now we don't include it, because it does weird things + * with for comments. *))) | List -> - Parser.next p; - parseListExpr ~startPos p + Parser.next p; + parseListExpr ~startPos p | Module -> - Parser.next p; - parseFirstClassModuleExpr ~startPos p + Parser.next p; + parseFirstClassModuleExpr ~startPos p | Lbracket -> parseArrayExp p | Lbrace -> parseBracedOrRecordExpr p | LessThan -> parseJsx p | Percent -> - let extension = parseExtension p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.extension ~loc extension + let extension = parseExtension p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.extension ~loc extension | Underscore as token -> - (* This case is for error recovery. Not sure if it's the correct place *) - Parser.err p (Diagnostics.lident token); - Parser.next p; - Recover.defaultExpr () + (* This case is for error recovery. Not sure if it's the correct place *) + Parser.err p (Diagnostics.lident token); + Parser.next p; + Recover.defaultExpr () | Eof -> - Parser.err ~startPos:p.prevEndPos p - (Diagnostics.unexpected p.Parser.token p.breadcrumbs); - Recover.defaultExpr () + Parser.err ~startPos:p.prevEndPos p + (Diagnostics.unexpected p.Parser.token p.breadcrumbs); + Recover.defaultExpr () | token -> ( - let errPos = p.prevEndPos in - Parser.err ~startPos:errPos p (Diagnostics.unexpected token p.breadcrumbs); - match - skipTokensAndMaybeRetry p ~isStartOfGrammar:Grammar.isAtomicExprStart - with - | None -> Recover.defaultExpr () - | Some () -> parseAtomicExpr p) + let errPos = p.prevEndPos in + Parser.err ~startPos:errPos p + (Diagnostics.unexpected token p.breadcrumbs); + match + skipTokensAndMaybeRetry p ~isStartOfGrammar:Grammar.isAtomicExprStart + with + | None -> Recover.defaultExpr () + | Some () -> parseAtomicExpr p) in Parser.eatBreadcrumb p; expr @@ -285024,19 +285315,19 @@ and parseFirstClassModuleExpr ~startPos p = let modEndLoc = p.prevEndPos in match p.Parser.token with | Colon -> - let colonStart = p.Parser.startPos in - Parser.next p; - let attrs = parseAttributes p in - let packageType = parsePackageType ~startPos:colonStart ~attrs p in - Parser.expect Rparen p; - let loc = mkLoc startPos modEndLoc in - let firstClassModule = Ast_helper.Exp.pack ~loc modExpr in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.constraint_ ~loc firstClassModule packageType + let colonStart = p.Parser.startPos in + Parser.next p; + let attrs = parseAttributes p in + let packageType = parsePackageType ~startPos:colonStart ~attrs p in + Parser.expect Rparen p; + let loc = mkLoc startPos modEndLoc in + let firstClassModule = Ast_helper.Exp.pack ~loc modExpr in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.constraint_ ~loc firstClassModule packageType | _ -> - Parser.expect Rparen p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.pack ~loc modExpr + Parser.expect Rparen p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.pack ~loc modExpr and parseBracketAccess p expr startPos = Parser.leaveBreadcrumb p Grammar.ExprArrayAccess; @@ -285045,61 +285336,63 @@ and parseBracketAccess p expr startPos = let stringStart = p.startPos in match p.Parser.token with | String s -> ( - Parser.next p; - let stringEnd = p.prevEndPos in - Parser.expect Rbracket p; - Parser.eatBreadcrumb p; - let rbracket = p.prevEndPos in - let e = - let identLoc = mkLoc stringStart stringEnd in - let loc = mkLoc startPos rbracket in - Ast_helper.Exp.send ~loc expr (Location.mkloc s identLoc) - in - let e = parsePrimaryExpr ~operand:e p in - let equalStart = p.startPos in - match p.token with - | Equal -> Parser.next p; - let equalEnd = p.prevEndPos in - let rhsExpr = parseExpr p in - let loc = mkLoc startPos rhsExpr.pexp_loc.loc_end in - let operatorLoc = mkLoc equalStart equalEnd in - Ast_helper.Exp.apply ~loc - (Ast_helper.Exp.ident ~loc:operatorLoc - (Location.mkloc (Longident.Lident "#=") operatorLoc)) - [(Nolabel, e); (Nolabel, rhsExpr)] - | _ -> e) - | _ -> ( - let accessExpr = parseConstrainedOrCoercedExpr p in - Parser.expect Rbracket p; - Parser.eatBreadcrumb p; - let rbracket = p.prevEndPos in - let arrayLoc = mkLoc lbracket rbracket in - match p.token with - | Equal -> - Parser.leaveBreadcrumb p ExprArrayMutation; - Parser.next p; - let rhsExpr = parseExpr p in - let arraySet = - Location.mkloc (Longident.Ldot (Lident "Array", "set")) arrayLoc - in - let endPos = p.prevEndPos in - let arraySet = - Ast_helper.Exp.apply ~loc:(mkLoc startPos endPos) - (Ast_helper.Exp.ident ~loc:arrayLoc arraySet) - [(Nolabel, expr); (Nolabel, accessExpr); (Nolabel, rhsExpr)] - in + let stringEnd = p.prevEndPos in + Parser.expect Rbracket p; Parser.eatBreadcrumb p; - arraySet - | _ -> - let endPos = p.prevEndPos in + let rbracket = p.prevEndPos in let e = - Ast_helper.Exp.apply ~loc:(mkLoc startPos endPos) - (Ast_helper.Exp.ident ~loc:arrayLoc - (Location.mkloc (Longident.Ldot (Lident "Array", "get")) arrayLoc)) - [(Nolabel, expr); (Nolabel, accessExpr)] + let identLoc = mkLoc stringStart stringEnd in + let loc = mkLoc startPos rbracket in + Ast_helper.Exp.send ~loc expr (Location.mkloc s identLoc) in - parsePrimaryExpr ~operand:e p) + let e = parsePrimaryExpr ~operand:e p in + let equalStart = p.startPos in + match p.token with + | Equal -> + Parser.next p; + let equalEnd = p.prevEndPos in + let rhsExpr = parseExpr p in + let loc = mkLoc startPos rhsExpr.pexp_loc.loc_end in + let operatorLoc = mkLoc equalStart equalEnd in + Ast_helper.Exp.apply ~loc + (Ast_helper.Exp.ident ~loc:operatorLoc + (Location.mkloc (Longident.Lident "#=") operatorLoc)) + [ (Nolabel, e); (Nolabel, rhsExpr) ] + | _ -> e) + | _ -> ( + let accessExpr = parseConstrainedOrCoercedExpr p in + Parser.expect Rbracket p; + Parser.eatBreadcrumb p; + let rbracket = p.prevEndPos in + let arrayLoc = mkLoc lbracket rbracket in + match p.token with + | Equal -> + Parser.leaveBreadcrumb p ExprArrayMutation; + Parser.next p; + let rhsExpr = parseExpr p in + let arraySet = + Location.mkloc (Longident.Ldot (Lident "Array", "set")) arrayLoc + in + let endPos = p.prevEndPos in + let arraySet = + Ast_helper.Exp.apply ~loc:(mkLoc startPos endPos) + (Ast_helper.Exp.ident ~loc:arrayLoc arraySet) + [ (Nolabel, expr); (Nolabel, accessExpr); (Nolabel, rhsExpr) ] + in + Parser.eatBreadcrumb p; + arraySet + | _ -> + let endPos = p.prevEndPos in + let e = + Ast_helper.Exp.apply ~loc:(mkLoc startPos endPos) + (Ast_helper.Exp.ident ~loc:arrayLoc + (Location.mkloc + (Longident.Ldot (Lident "Array", "get")) + arrayLoc)) + [ (Nolabel, expr); (Nolabel, accessExpr) ] + in + parsePrimaryExpr ~operand:e p) (* * A primary expression represents * - atomic-expr @@ -285114,39 +285407,41 @@ and parsePrimaryExpr ~operand ?(noCall = false) p = let rec loop p expr = match p.Parser.token with | Dot -> ( - Parser.next p; - let lident = parseValuePathAfterDot p in - match p.Parser.token with - | Equal when noCall = false -> - Parser.leaveBreadcrumb p Grammar.ExprSetField; Parser.next p; - let targetExpr = parseExpr p in - let loc = mkLoc startPos p.prevEndPos in - let setfield = Ast_helper.Exp.setfield ~loc expr lident targetExpr in - Parser.eatBreadcrumb p; - setfield - | _ -> - let endPos = p.prevEndPos in - let loc = mkLoc startPos endPos in - loop p (Ast_helper.Exp.field ~loc expr lident)) + let lident = parseValuePathAfterDot p in + match p.Parser.token with + | Equal when noCall = false -> + Parser.leaveBreadcrumb p Grammar.ExprSetField; + Parser.next p; + let targetExpr = parseExpr p in + let loc = mkLoc startPos p.prevEndPos in + let setfield = + Ast_helper.Exp.setfield ~loc expr lident targetExpr + in + Parser.eatBreadcrumb p; + setfield + | _ -> + let endPos = p.prevEndPos in + let loc = mkLoc startPos endPos in + loop p (Ast_helper.Exp.field ~loc expr lident)) | Lbracket when noCall = false && p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> - parseBracketAccess p expr startPos + parseBracketAccess p expr startPos | Lparen when noCall = false && p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> - loop p (parseCallExpr p expr) + loop p (parseCallExpr p expr) | Backtick when noCall = false && p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> ( - match expr.pexp_desc with - | Pexp_ident {txt = Longident.Lident ident} -> - parseTemplateExpr ~prefix:ident p - | _ -> - Parser.err ~startPos:expr.pexp_loc.loc_start - ~endPos:expr.pexp_loc.loc_end p - (Diagnostics.message - "Tagged template literals are currently restricted to names like: \ - json`null`."); - parseTemplateExpr p) + match expr.pexp_desc with + | Pexp_ident { txt = Longident.Lident ident } -> + parseTemplateExpr ~prefix:ident p + | _ -> + Parser.err ~startPos:expr.pexp_loc.loc_start + ~endPos:expr.pexp_loc.loc_end p + (Diagnostics.message + "Tagged template literals are currently restricted to names \ + like: json`null`."); + parseTemplateExpr p) | _ -> expr in loop p operand @@ -285161,13 +285456,13 @@ and parseUnaryExpr p = let startPos = p.Parser.startPos in match p.Parser.token with | (Minus | MinusDot | Plus | PlusDot | Bang) as token -> - Parser.leaveBreadcrumb p Grammar.ExprUnary; - let tokenEnd = p.endPos in - Parser.next p; - let operand = parseUnaryExpr p in - let unaryExpr = makeUnaryExpr startPos tokenEnd token operand in - Parser.eatBreadcrumb p; - unaryExpr + Parser.leaveBreadcrumb p Grammar.ExprUnary; + let tokenEnd = p.endPos in + Parser.next p; + let operand = parseUnaryExpr p in + let unaryExpr = makeUnaryExpr startPos tokenEnd token operand in + Parser.eatBreadcrumb p; + unaryExpr | _ -> parsePrimaryExpr ~operand:(parseAtomicExpr p) p (* Represents an "operand" in a binary expression. @@ -285179,10 +285474,10 @@ and parseOperandExpr ~context p = let expr = match p.Parser.token with | Assert -> - Parser.next p; - let expr = parseUnaryExpr p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.assert_ ~loc expr + Parser.next p; + let expr = parseUnaryExpr p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.assert_ ~loc expr | Lident "async" (* we need to be careful when we're in a ternary true branch: `condition ? ternary-true-branch : false-branch` @@ -285191,29 +285486,29 @@ and parseOperandExpr ~context p = *) when isEs6ArrowExpression ~inTernary:(context = TernaryTrueBranchExpr) p -> - parseAsyncArrowExpression p + parseAsyncArrowExpression p | Await -> parseAwaitExpression p | Lazy -> - Parser.next p; - let expr = parseUnaryExpr p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.lazy_ ~loc expr + Parser.next p; + let expr = parseUnaryExpr p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.lazy_ ~loc expr | Try -> parseTryExpression p | If -> parseIfOrIfLetExpression p | For -> parseForExpression p | While -> parseWhileExpression p | Switch -> parseSwitchExpression p | _ -> - if - context != WhenExpr - && isEs6ArrowExpression ~inTernary:(context = TernaryTrueBranchExpr) p - then parseEs6ArrowExpression ~context p - else parseUnaryExpr p + if + context != WhenExpr + && isEs6ArrowExpression ~inTernary:(context = TernaryTrueBranchExpr) p + then parseEs6ArrowExpression ~context p + else parseUnaryExpr p in (* let endPos = p.Parser.prevEndPos in *) { expr with - pexp_attributes = List.concat [expr.Parsetree.pexp_attributes; attrs]; + pexp_attributes = List.concat [ expr.Parsetree.pexp_attributes; attrs ]; (* pexp_loc = mkLoc startPos endPos *) } @@ -285223,11 +285518,7 @@ and parseOperandExpr ~context p = * f(x) |> g(y) *) and parseBinaryExpr ?(context = OrdinaryExpr) ?a p prec = - let a = - match a with - | Some e -> e - | None -> parseOperandExpr ~context p - in + let a = match a with Some e -> e | None -> parseOperandExpr ~context p in let rec loop a = let token = p.Parser.token in let tokenPrec = @@ -285250,7 +285541,7 @@ and parseBinaryExpr ?(context = OrdinaryExpr) ?a p prec = (Scanner.isBinaryOp p.scanner.src p.startPos.pos_cnum p.endPos.pos_cnum)) && p.startPos.pos_lnum > p.prevEndPos.pos_lnum -> - -1 + -1 | token -> Token.precedence token in if tokenPrec < prec then a @@ -285264,7 +285555,7 @@ and parseBinaryExpr ?(context = OrdinaryExpr) ?a p prec = let expr = Ast_helper.Exp.apply ~loc (makeInfixOperator p token startPos endPos) - [(Nolabel, a); (Nolabel, b)] + [ (Nolabel, a); (Nolabel, b) ] in Parser.eatBreadcrumb p; loop expr) @@ -285311,59 +285602,59 @@ and parseTemplateExpr ?(prefix = "js") p = in let concat (e1 : Parsetree.expression) (e2 : Parsetree.expression) = let loc = mkLoc e1.pexp_loc.loc_start e2.pexp_loc.loc_end in - Ast_helper.Exp.apply ~attrs:[templateLiteralAttr] ~loc hiddenOperator - [(Nolabel, e1); (Nolabel, e2)] + Ast_helper.Exp.apply ~attrs:[ templateLiteralAttr ] ~loc hiddenOperator + [ (Nolabel, e1); (Nolabel, e2) ] in let rec parseParts (acc : Parsetree.expression) = let startPos = p.Parser.startPos in Parser.nextTemplateLiteralToken p; match p.token with | TemplateTail (txt, lastPos) -> - Parser.next p; - let loc = mkLoc startPos lastPos in - let str = - Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] ~loc - (Pconst_string (txt, Some prefix)) - in - concat acc str + Parser.next p; + let loc = mkLoc startPos lastPos in + let str = + Ast_helper.Exp.constant ~attrs:[ templateLiteralAttr ] ~loc + (Pconst_string (txt, Some prefix)) + in + concat acc str | TemplatePart (txt, lastPos) -> - Parser.next p; - let loc = mkLoc startPos lastPos in - let expr = parseExprBlock p in - let str = - Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] ~loc - (Pconst_string (txt, Some prefix)) - in - let next = - let a = concat acc str in - concat a expr - in - parseParts next + Parser.next p; + let loc = mkLoc startPos lastPos in + let expr = parseExprBlock p in + let str = + Ast_helper.Exp.constant ~attrs:[ templateLiteralAttr ] ~loc + (Pconst_string (txt, Some prefix)) + in + let next = + let a = concat acc str in + concat a expr + in + parseParts next | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Ast_helper.Exp.constant (Pconst_string ("", None)) + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Ast_helper.Exp.constant (Pconst_string ("", None)) in let startPos = p.startPos in Parser.nextTemplateLiteralToken p; match p.token with | TemplateTail (txt, lastPos) -> - Parser.next p; - Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] - ~loc:(mkLoc startPos lastPos) - (Pconst_string (txt, Some prefix)) - | TemplatePart (txt, lastPos) -> - Parser.next p; - let constantLoc = mkLoc startPos lastPos in - let expr = parseExprBlock p in - let str = - Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] ~loc:constantLoc + Parser.next p; + Ast_helper.Exp.constant ~attrs:[ templateLiteralAttr ] + ~loc:(mkLoc startPos lastPos) (Pconst_string (txt, Some prefix)) - in - let next = concat str expr in - parseParts next + | TemplatePart (txt, lastPos) -> + Parser.next p; + let constantLoc = mkLoc startPos lastPos in + let expr = parseExprBlock p in + let str = + Ast_helper.Exp.constant ~attrs:[ templateLiteralAttr ] ~loc:constantLoc + (Pconst_string (txt, Some prefix)) + in + let next = concat str expr in + parseParts next | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Ast_helper.Exp.constant (Pconst_string ("", None)) + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Ast_helper.Exp.constant (Pconst_string ("", None)) (* Overparse: let f = a : int => a + 1, is it (a : int) => or (a): int => * Also overparse constraints: @@ -285378,85 +285669,85 @@ and overParseConstrainedOrCoercedOrArrowExpression p expr = match p.Parser.token with | ColonGreaterThan -> parseCoercedExpr ~expr p | Colon -> ( - Parser.next p; - let typ = parseTypExpr ~es6Arrow:false p in - match p.Parser.token with - | EqualGreater -> Parser.next p; - let body = parseExpr p in - let pat = - match expr.pexp_desc with - | Pexp_ident longident -> - Ast_helper.Pat.var ~loc:expr.pexp_loc - (Location.mkloc - (Longident.flatten longident.txt |> String.concat ".") - longident.loc) - (* TODO: can we convert more expressions to patterns?*) - | _ -> - Ast_helper.Pat.var ~loc:expr.pexp_loc - (Location.mkloc "pattern" expr.pexp_loc) - in - let arrow1 = - Ast_helper.Exp.fun_ - ~loc:(mkLoc expr.pexp_loc.loc_start body.pexp_loc.loc_end) - Asttypes.Nolabel None pat - (Ast_helper.Exp.constraint_ body typ) - in - let arrow2 = - Ast_helper.Exp.fun_ - ~loc:(mkLoc expr.pexp_loc.loc_start body.pexp_loc.loc_end) - Asttypes.Nolabel None - (Ast_helper.Pat.constraint_ pat typ) - body - in - let msg = - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.text - "Did you mean to annotate the parameter type or the return \ - type?"; - Doc.indent - (Doc.concat - [ - Doc.line; - Doc.text "1) "; - ResPrinter.printExpression arrow1 CommentTable.empty; - Doc.line; - Doc.text "2) "; - ResPrinter.printExpression arrow2 CommentTable.empty; - ]); - ]) - |> Doc.toString ~width:80 - in - Parser.err ~startPos:expr.pexp_loc.loc_start ~endPos:body.pexp_loc.loc_end - p (Diagnostics.message msg); - arrow1 - | _ -> - let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in - let expr = Ast_helper.Exp.constraint_ ~loc expr typ in - let () = - Parser.err ~startPos:expr.pexp_loc.loc_start - ~endPos:typ.ptyp_loc.loc_end p - (Diagnostics.message - (Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.text - "Expressions with type constraints need to be wrapped \ - in parens:"; - Doc.indent - (Doc.concat - [ - Doc.line; - ResPrinter.addParens - (ResPrinter.printExpression expr - CommentTable.empty); - ]); - ]) - |> Doc.toString ~width:80)) - in - expr) + let typ = parseTypExpr ~es6Arrow:false p in + match p.Parser.token with + | EqualGreater -> + Parser.next p; + let body = parseExpr p in + let pat = + match expr.pexp_desc with + | Pexp_ident longident -> + Ast_helper.Pat.var ~loc:expr.pexp_loc + (Location.mkloc + (Longident.flatten longident.txt |> String.concat ".") + longident.loc) + (* TODO: can we convert more expressions to patterns?*) + | _ -> + Ast_helper.Pat.var ~loc:expr.pexp_loc + (Location.mkloc "pattern" expr.pexp_loc) + in + let arrow1 = + Ast_helper.Exp.fun_ + ~loc:(mkLoc expr.pexp_loc.loc_start body.pexp_loc.loc_end) + Asttypes.Nolabel None pat + (Ast_helper.Exp.constraint_ body typ) + in + let arrow2 = + Ast_helper.Exp.fun_ + ~loc:(mkLoc expr.pexp_loc.loc_start body.pexp_loc.loc_end) + Asttypes.Nolabel None + (Ast_helper.Pat.constraint_ pat typ) + body + in + let msg = + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.text + "Did you mean to annotate the parameter type or the \ + return type?"; + Doc.indent + (Doc.concat + [ + Doc.line; + Doc.text "1) "; + ResPrinter.printExpression arrow1 CommentTable.empty; + Doc.line; + Doc.text "2) "; + ResPrinter.printExpression arrow2 CommentTable.empty; + ]); + ]) + |> Doc.toString ~width:80 + in + Parser.err ~startPos:expr.pexp_loc.loc_start + ~endPos:body.pexp_loc.loc_end p (Diagnostics.message msg); + arrow1 + | _ -> + let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in + let expr = Ast_helper.Exp.constraint_ ~loc expr typ in + let () = + Parser.err ~startPos:expr.pexp_loc.loc_start + ~endPos:typ.ptyp_loc.loc_end p + (Diagnostics.message + (Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.text + "Expressions with type constraints need to be \ + wrapped in parens:"; + Doc.indent + (Doc.concat + [ + Doc.line; + ResPrinter.addParens + (ResPrinter.printExpression expr + CommentTable.empty); + ]); + ]) + |> Doc.toString ~width:80)) + in + expr) | _ -> expr and parseLetBindingBody ~startPos ~attrs p = @@ -285468,36 +285759,39 @@ and parseLetBindingBody ~startPos ~attrs p = Parser.eatBreadcrumb p; match p.Parser.token with | Colon -> ( - Parser.next p; - match p.token with - | Typ -> - (* locally abstract types *) Parser.next p; - let newtypes = parseLidentList p in - Parser.expect Dot p; - let typ = parseTypExpr p in - Parser.expect Equal p; - let expr = parseExpr p in - let loc = mkLoc startPos p.prevEndPos in - let exp, poly = wrapTypeAnnotation ~loc newtypes typ expr in - let pat = Ast_helper.Pat.constraint_ ~loc pat poly in - (pat, exp) - | _ -> - let polyType = parsePolyTypeExpr p in - let loc = - {pat.ppat_loc with loc_end = polyType.Parsetree.ptyp_loc.loc_end} - in - let pat = Ast_helper.Pat.constraint_ ~loc pat polyType in - Parser.expect Token.Equal p; - let exp = parseExpr p in - let exp = overParseConstrainedOrCoercedOrArrowExpression p exp in - (pat, exp)) + match p.token with + | Typ -> + (* locally abstract types *) + Parser.next p; + let newtypes = parseLidentList p in + Parser.expect Dot p; + let typ = parseTypExpr p in + Parser.expect Equal p; + let expr = parseExpr p in + let loc = mkLoc startPos p.prevEndPos in + let exp, poly = wrapTypeAnnotation ~loc newtypes typ expr in + let pat = Ast_helper.Pat.constraint_ ~loc pat poly in + (pat, exp) + | _ -> + let polyType = parsePolyTypeExpr p in + let loc = + { + pat.ppat_loc with + loc_end = polyType.Parsetree.ptyp_loc.loc_end; + } + in + let pat = Ast_helper.Pat.constraint_ ~loc pat polyType in + Parser.expect Token.Equal p; + let exp = parseExpr p in + let exp = overParseConstrainedOrCoercedOrArrowExpression p exp in + (pat, exp)) | _ -> - Parser.expect Token.Equal p; - let exp = - overParseConstrainedOrCoercedOrArrowExpression p (parseExpr p) - in - (pat, exp) + Parser.expect Token.Equal p; + let exp = + overParseConstrainedOrCoercedOrArrowExpression p (parseExpr p) + in + (pat, exp) in let loc = mkLoc startPos p.prevEndPos in let vb = Ast_helper.Vb.mk ~loc ~attrs pat exp in @@ -285538,25 +285832,25 @@ and parseAttributesAndBinding (p : Parser.t) = match p.Parser.token with | At -> ( - let attrs = parseAttributes p in - match p.Parser.token with - | And -> attrs - | _ -> - p.scanner.err <- err; - p.scanner.ch <- ch; - p.scanner.offset <- offset; - p.scanner.lineOffset <- lineOffset; - p.scanner.lnum <- lnum; - p.scanner.mode <- mode; - p.token <- token; - p.startPos <- startPos; - p.endPos <- endPos; - p.prevEndPos <- prevEndPos; - p.breadcrumbs <- breadcrumbs; - p.errors <- errors; - p.diagnostics <- diagnostics; - p.comments <- comments; - []) + let attrs = parseAttributes p in + match p.Parser.token with + | And -> attrs + | _ -> + p.scanner.err <- err; + p.scanner.ch <- ch; + p.scanner.offset <- offset; + p.scanner.lineOffset <- lineOffset; + p.scanner.lnum <- lnum; + p.scanner.mode <- mode; + p.token <- token; + p.startPos <- startPos; + p.endPos <- endPos; + p.prevEndPos <- prevEndPos; + p.breadcrumbs <- breadcrumbs; + p.errors <- errors; + p.diagnostics <- diagnostics; + p.comments <- comments; + []) | _ -> [] (* definition ::= let [rec] let-binding { and let-binding } *) @@ -285574,14 +285868,14 @@ and parseLetBindings ~attrs p = let attrs = parseAttributesAndBinding p in match p.Parser.token with | And -> - Parser.next p; - ignore (Parser.optional p Let); - (* overparse for fault tolerance *) - let letBinding = parseLetBindingBody ~startPos ~attrs p in - loop p (letBinding :: bindings) + Parser.next p; + ignore (Parser.optional p Let); + (* overparse for fault tolerance *) + let letBinding = parseLetBindingBody ~startPos ~attrs p in + loop p (letBinding :: bindings) | _ -> List.rev bindings in - (recFlag, loop p [first]) + (recFlag, loop p [ first ]) (* * div -> div @@ -285592,23 +285886,23 @@ and parseJsxName p = let longident = match p.Parser.token with | Lident ident -> - let identStart = p.startPos in - let identEnd = p.endPos in - Parser.next p; - let loc = mkLoc identStart identEnd in - Location.mkloc (Longident.Lident ident) loc + let identStart = p.startPos in + let identEnd = p.endPos in + Parser.next p; + let loc = mkLoc identStart identEnd in + Location.mkloc (Longident.Lident ident) loc | Uident _ -> - let longident = parseModuleLongIdent ~lowercase:true p in - Location.mkloc - (Longident.Ldot (longident.txt, "createElement")) - longident.loc + let longident = parseModuleLongIdent ~lowercase:true p in + Location.mkloc + (Longident.Ldot (longident.txt, "createElement")) + longident.loc | _ -> - let msg = - "A jsx name must be a lowercase or uppercase name, like: div in
or Navbar in " - in - Parser.err p (Diagnostics.message msg); - Location.mknoloc (Longident.Lident "_") + let msg = + "A jsx name must be a lowercase or uppercase name, like: div in
or Navbar in " + in + Parser.err p (Diagnostics.message msg); + Location.mknoloc (Longident.Lident "_") in Ast_helper.Exp.ident ~loc:longident.loc longident @@ -285619,59 +285913,59 @@ and parseJsxOpeningOrSelfClosingElement ~startPos p = let children = match p.Parser.token with | Forwardslash -> - (* *) - let childrenStartPos = p.Parser.startPos in - Parser.next p; - let childrenEndPos = p.Parser.startPos in - Parser.expect GreaterThan p; - let loc = mkLoc childrenStartPos childrenEndPos in - makeListExpression loc [] None (* no children *) - | GreaterThan -> ( - (* bar *) - let childrenStartPos = p.Parser.startPos in - Scanner.setJsxMode p.scanner; - Parser.next p; - let spread, children = parseJsxChildren p in - let childrenEndPos = p.Parser.startPos in - let () = - match p.token with - | LessThanSlash -> Parser.next p - | LessThan -> - Parser.next p; - Parser.expect Forwardslash p - | token when Grammar.isStructureItemStart token -> () - | _ -> Parser.expect LessThanSlash p - in - match p.Parser.token with - | (Lident _ | Uident _) when verifyJsxOpeningClosingName p name -> ( + (* *) + let childrenStartPos = p.Parser.startPos in + Parser.next p; + let childrenEndPos = p.Parser.startPos in Parser.expect GreaterThan p; let loc = mkLoc childrenStartPos childrenEndPos in - match (spread, children) with - | true, child :: _ -> child - | _ -> makeListExpression loc children None) - | token -> ( + makeListExpression loc [] None (* no children *) + | GreaterThan -> ( + (* bar *) + let childrenStartPos = p.Parser.startPos in + Scanner.setJsxMode p.scanner; + Parser.next p; + let spread, children = parseJsxChildren p in + let childrenEndPos = p.Parser.startPos in let () = - if Grammar.isStructureItemStart token then - let closing = "" in - let msg = Diagnostics.message ("Missing " ^ closing) in - Parser.err ~startPos ~endPos:p.prevEndPos p msg - else - let opening = "" in - let msg = - "Closing jsx name should be the same as the opening name. Did \ - you mean " ^ opening ^ " ?" - in - Parser.err ~startPos ~endPos:p.prevEndPos p - (Diagnostics.message msg); - Parser.expect GreaterThan p + match p.token with + | LessThanSlash -> Parser.next p + | LessThan -> + Parser.next p; + Parser.expect Forwardslash p + | token when Grammar.isStructureItemStart token -> () + | _ -> Parser.expect LessThanSlash p in - let loc = mkLoc childrenStartPos childrenEndPos in - match (spread, children) with - | true, child :: _ -> child - | _ -> makeListExpression loc children None)) + match p.Parser.token with + | (Lident _ | Uident _) when verifyJsxOpeningClosingName p name -> ( + Parser.expect GreaterThan p; + let loc = mkLoc childrenStartPos childrenEndPos in + match (spread, children) with + | true, child :: _ -> child + | _ -> makeListExpression loc children None) + | token -> ( + let () = + if Grammar.isStructureItemStart token then + let closing = "" in + let msg = Diagnostics.message ("Missing " ^ closing) in + Parser.err ~startPos ~endPos:p.prevEndPos p msg + else + let opening = "" in + let msg = + "Closing jsx name should be the same as the opening name. \ + Did you mean " ^ opening ^ " ?" + in + Parser.err ~startPos ~endPos:p.prevEndPos p + (Diagnostics.message msg); + Parser.expect GreaterThan p + in + let loc = mkLoc childrenStartPos childrenEndPos in + match (spread, children) with + | true, child :: _ -> child + | _ -> makeListExpression loc children None)) | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - makeListExpression Location.none [] None + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + makeListExpression Location.none [] None in let jsxEndPos = p.prevEndPos in let loc = mkLoc jsxStartPos jsxEndPos in @@ -285704,12 +285998,12 @@ and parseJsx p = match p.Parser.token with | Lident _ | Uident _ -> parseJsxOpeningOrSelfClosingElement ~startPos p | GreaterThan -> - (* fragment: <> foo *) - parseJsxFragment p + (* fragment: <> foo *) + parseJsxFragment p | _ -> parseJsxName p in Parser.eatBreadcrumb p; - {jsxExpr with pexp_attributes = [jsxAttr]} + { jsxExpr with pexp_attributes = [ jsxAttr ] } (* * jsx-fragment ::= @@ -285738,62 +286032,64 @@ and parseJsxFragment p = and parseJsxProp p = match p.Parser.token with | Question | Lident _ -> ( - let optional = Parser.optional p Question in - let name, loc = parseLident p in - let propLocAttr = - (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) - in - (* optional punning: *) - if optional then - Some - ( Asttypes.Optional name, - Ast_helper.Exp.ident ~attrs:[propLocAttr] ~loc - (Location.mkloc (Longident.Lident name) loc) ) - else - match p.Parser.token with - | Equal -> - Parser.next p; - (* no punning *) - let optional = Parser.optional p Question in - let attrExpr = - let e = parsePrimaryExpr ~operand:(parseAtomicExpr p) p in - {e with pexp_attributes = propLocAttr :: e.pexp_attributes} - in - let label = - if optional then Asttypes.Optional name else Asttypes.Labelled name - in - Some (label, attrExpr) - | _ -> - let attrExpr = - Ast_helper.Exp.ident ~loc ~attrs:[propLocAttr] - (Location.mkloc (Longident.Lident name) loc) - in - let label = - if optional then Asttypes.Optional name else Asttypes.Labelled name - in - Some (label, attrExpr)) - (* {...props} *) - | Lbrace -> ( - Parser.next p; - match p.Parser.token with - | DotDotDot -> ( - Parser.next p; - let loc = mkLoc p.Parser.startPos p.prevEndPos in + let optional = Parser.optional p Question in + let name, loc = parseLident p in let propLocAttr = (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) in - let attrExpr = - let e = parsePrimaryExpr ~operand:(parseAtomicExpr p) p in - {e with pexp_attributes = propLocAttr :: e.pexp_attributes} - in - (* using label "spreadProps" to distinguish from others *) - let label = Asttypes.Labelled "_spreadProps" in + (* optional punning: *) + if optional then + Some + ( Asttypes.Optional name, + Ast_helper.Exp.ident ~attrs:[ propLocAttr ] ~loc + (Location.mkloc (Longident.Lident name) loc) ) + else + match p.Parser.token with + | Equal -> + Parser.next p; + (* no punning *) + let optional = Parser.optional p Question in + let attrExpr = + let e = parsePrimaryExpr ~operand:(parseAtomicExpr p) p in + { e with pexp_attributes = propLocAttr :: e.pexp_attributes } + in + let label = + if optional then Asttypes.Optional name + else Asttypes.Labelled name + in + Some (label, attrExpr) + | _ -> + let attrExpr = + Ast_helper.Exp.ident ~loc ~attrs:[ propLocAttr ] + (Location.mkloc (Longident.Lident name) loc) + in + let label = + if optional then Asttypes.Optional name + else Asttypes.Labelled name + in + Some (label, attrExpr)) + (* {...props} *) + | Lbrace -> ( + Parser.next p; match p.Parser.token with - | Rbrace -> - Parser.next p; - Some (label, attrExpr) + | DotDotDot -> ( + Parser.next p; + let loc = mkLoc p.Parser.startPos p.prevEndPos in + let propLocAttr = + (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) + in + let attrExpr = + let e = parsePrimaryExpr ~operand:(parseAtomicExpr p) p in + { e with pexp_attributes = propLocAttr :: e.pexp_attributes } + in + (* using label "spreadProps" to distinguish from others *) + let label = Asttypes.Labelled "_spreadProps" in + match p.Parser.token with + | Rbrace -> + Parser.next p; + Some (label, attrExpr) + | _ -> None) | _ -> None) - | _ -> None) | _ -> None and parseJsxProps p = @@ -285803,39 +286099,39 @@ and parseJsxChildren p = let rec loop p children = match p.Parser.token with | Token.Eof | LessThanSlash -> - Scanner.popMode p.scanner Jsx; - List.rev children + Scanner.popMode p.scanner Jsx; + List.rev children | LessThan -> - (* Imagine:
< - * is `<` the start of a jsx-child?
- * reconsiderLessThan peeks at the next token and - * determines the correct token to disambiguate *) - let token = Scanner.reconsiderLessThan p.scanner in - if token = LessThan then + (* Imagine:
< + * is `<` the start of a jsx-child?
+ * reconsiderLessThan peeks at the next token and + * determines the correct token to disambiguate *) + let token = Scanner.reconsiderLessThan p.scanner in + if token = LessThan then + let child = + parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p + in + loop p (child :: children) + else + (* LessThanSlash *) + let () = p.token <- token in + let () = Scanner.popMode p.scanner Jsx in + List.rev children + | token when Grammar.isJsxChildStart token -> + let () = Scanner.popMode p.scanner Jsx in let child = parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p in loop p (child :: children) - else - (* LessThanSlash *) - let () = p.token <- token in - let () = Scanner.popMode p.scanner Jsx in - List.rev children - | token when Grammar.isJsxChildStart token -> - let () = Scanner.popMode p.scanner Jsx in - let child = - parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p - in - loop p (child :: children) | _ -> - Scanner.popMode p.scanner Jsx; - List.rev children + Scanner.popMode p.scanner Jsx; + List.rev children in match p.Parser.token with | DotDotDot -> - Parser.next p; - (true, [parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p]) + Parser.next p; + (true, [ parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p ]) | _ -> (false, loop p []) and parseBracedOrRecordExpr p = @@ -285843,65 +286139,68 @@ and parseBracedOrRecordExpr p = Parser.expect Lbrace p; match p.Parser.token with | Rbrace -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.record ~loc [] None - | DotDotDot -> - (* beginning of record spread, parse record *) - Parser.next p; - let spreadExpr = parseConstrainedOrCoercedExpr p in - Parser.expect Comma p; - let expr = parseRecordExpr ~startPos ~spread:(Some spreadExpr) [] p in - Parser.expect Rbrace p; - expr - | String s -> ( - let field = - let loc = mkLoc p.startPos p.endPos in Parser.next p; - Location.mkloc (Longident.Lident s) loc - in - match p.Parser.token with - | Colon -> + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.record ~loc [] None + | DotDotDot -> + (* beginning of record spread, parse record *) Parser.next p; - let fieldExpr = parseExpr p in - Parser.optional p Comma |> ignore; - let expr = parseRecordExprWithStringKeys ~startPos (field, fieldExpr) p in + let spreadExpr = parseConstrainedOrCoercedExpr p in + Parser.expect Comma p; + let expr = parseRecordExpr ~startPos ~spread:(Some spreadExpr) [] p in Parser.expect Rbrace p; expr - | _ -> ( - let tag = if p.mode = ParseForTypeChecker then Some "js" else None in - let constant = - Ast_helper.Exp.constant ~loc:field.loc - (Parsetree.Pconst_string (s, tag)) + | String s -> ( + let field = + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc (Longident.Lident s) loc in - let a = parsePrimaryExpr ~operand:constant p in - let e = parseBinaryExpr ~a p 1 in - let e = parseTernaryExpr e p in match p.Parser.token with - | Semicolon -> - let expr = parseExprBlock ~first:e p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - { - expr with - Parsetree.pexp_attributes = braces :: expr.Parsetree.pexp_attributes; - } - | Rbrace -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {e with pexp_attributes = braces :: e.pexp_attributes} - | _ -> - let expr = parseExprBlock ~first:e p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes})) + | Colon -> + Parser.next p; + let fieldExpr = parseExpr p in + Parser.optional p Comma |> ignore; + let expr = + parseRecordExprWithStringKeys ~startPos (field, fieldExpr) p + in + Parser.expect Rbrace p; + expr + | _ -> ( + let tag = if p.mode = ParseForTypeChecker then Some "js" else None in + let constant = + Ast_helper.Exp.constant ~loc:field.loc + (Parsetree.Pconst_string (s, tag)) + in + let a = parsePrimaryExpr ~operand:constant p in + let e = parseBinaryExpr ~a p 1 in + let e = parseTernaryExpr e p in + match p.Parser.token with + | Semicolon -> + let expr = parseExprBlock ~first:e p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + { + expr with + Parsetree.pexp_attributes = + braces :: expr.Parsetree.pexp_attributes; + } + | Rbrace -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + { e with pexp_attributes = braces :: e.pexp_attributes } + | _ -> + let expr = parseExprBlock ~first:e p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + { expr with pexp_attributes = braces :: expr.pexp_attributes })) | Question -> - let expr = parseRecordExpr ~startPos [] p in - Parser.expect Rbrace p; - expr + let expr = parseRecordExpr ~startPos [] p in + Parser.expect Rbrace p; + expr (* The branch below takes care of the "braced" expression {async}. The big reason that we need all these branches is that {x} isn't a record with a punned field x, but a braced expression… There's lots of "ambiguity" between a record with a single punned field and a braced expression… @@ -285911,184 +286210,195 @@ and parseBracedOrRecordExpr p = Due to historical reasons, we always follow 2 *) | Lident "async" when isEs6ArrowExpression ~inTernary:false p -> - let expr = parseAsyncArrowExpression p in - let expr = parseExprBlock ~first:expr p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes} + let expr = parseAsyncArrowExpression p in + let expr = parseExprBlock ~first:expr p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + { expr with pexp_attributes = braces :: expr.pexp_attributes } | Uident _ | Lident _ -> ( - let startToken = p.token in - let valueOrConstructor = parseValueOrConstructor p in - match valueOrConstructor.pexp_desc with - | Pexp_ident pathIdent -> ( - let identEndPos = p.prevEndPos in - match p.Parser.token with - | Comma -> - Parser.next p; - let valueOrConstructor = - match startToken with - | Uident _ -> removeModuleNameFromPunnedFieldValue valueOrConstructor - | _ -> valueOrConstructor - in - let expr = - parseRecordExpr ~startPos [(pathIdent, valueOrConstructor)] p - in - Parser.expect Rbrace p; - expr - | Colon -> ( - Parser.next p; - let optional = parseOptionalLabel p in - let fieldExpr = parseExpr p in - let fieldExpr = makeExpressionOptional ~optional fieldExpr in - match p.token with - | Rbrace -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.record ~loc [(pathIdent, fieldExpr)] None - | _ -> - Parser.expect Comma p; - let expr = parseRecordExpr ~startPos [(pathIdent, fieldExpr)] p in - Parser.expect Rbrace p; - expr) - (* error case *) - | Lident _ -> - if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then ( - Parser.expect Comma p; - let expr = - parseRecordExpr ~startPos [(pathIdent, valueOrConstructor)] p - in - Parser.expect Rbrace p; - expr) - else ( - Parser.expect Colon p; - let expr = - parseRecordExpr ~startPos [(pathIdent, valueOrConstructor)] p - in - Parser.expect Rbrace p; - expr) - | Semicolon -> - let expr = parseExprBlock ~first:(Ast_helper.Exp.ident pathIdent) p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes} - | Rbrace -> - Parser.next p; - let expr = Ast_helper.Exp.ident ~loc:pathIdent.loc pathIdent in - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes} - | EqualGreater -> ( - let loc = mkLoc startPos identEndPos in - let ident = Location.mkloc (Longident.last pathIdent.txt) loc in - let a = - parseEs6ArrowExpression - ~parameters: - [ - TermParameter - { - uncurried = false; - attrs = []; - label = Asttypes.Nolabel; - expr = None; - pat = Ast_helper.Pat.var ident; - pos = startPos; - }; - ] - p - in - let e = parseBinaryExpr ~a p 1 in - let e = parseTernaryExpr e p in - match p.Parser.token with - | Semicolon -> - let expr = parseExprBlock ~first:e p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes} - | Rbrace -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {e with pexp_attributes = braces :: e.pexp_attributes} - | _ -> - let expr = parseExprBlock ~first:e p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes}) + let startToken = p.token in + let valueOrConstructor = parseValueOrConstructor p in + match valueOrConstructor.pexp_desc with + | Pexp_ident pathIdent -> ( + let identEndPos = p.prevEndPos in + match p.Parser.token with + | Comma -> + Parser.next p; + let valueOrConstructor = + match startToken with + | Uident _ -> + removeModuleNameFromPunnedFieldValue valueOrConstructor + | _ -> valueOrConstructor + in + let expr = + parseRecordExpr ~startPos [ (pathIdent, valueOrConstructor) ] p + in + Parser.expect Rbrace p; + expr + | Colon -> ( + Parser.next p; + let optional = parseOptionalLabel p in + let fieldExpr = parseExpr p in + let fieldExpr = makeExpressionOptional ~optional fieldExpr in + match p.token with + | Rbrace -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.record ~loc [ (pathIdent, fieldExpr) ] None + | _ -> + Parser.expect Comma p; + let expr = + parseRecordExpr ~startPos [ (pathIdent, fieldExpr) ] p + in + Parser.expect Rbrace p; + expr) + (* error case *) + | Lident _ -> + if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then ( + Parser.expect Comma p; + let expr = + parseRecordExpr ~startPos + [ (pathIdent, valueOrConstructor) ] + p + in + Parser.expect Rbrace p; + expr) + else ( + Parser.expect Colon p; + let expr = + parseRecordExpr ~startPos + [ (pathIdent, valueOrConstructor) ] + p + in + Parser.expect Rbrace p; + expr) + | Semicolon -> + let expr = + parseExprBlock ~first:(Ast_helper.Exp.ident pathIdent) p + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + { expr with pexp_attributes = braces :: expr.pexp_attributes } + | Rbrace -> + Parser.next p; + let expr = Ast_helper.Exp.ident ~loc:pathIdent.loc pathIdent in + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + { expr with pexp_attributes = braces :: expr.pexp_attributes } + | EqualGreater -> ( + let loc = mkLoc startPos identEndPos in + let ident = Location.mkloc (Longident.last pathIdent.txt) loc in + let a = + parseEs6ArrowExpression + ~parameters: + [ + TermParameter + { + uncurried = false; + attrs = []; + label = Asttypes.Nolabel; + expr = None; + pat = Ast_helper.Pat.var ident; + pos = startPos; + }; + ] + p + in + let e = parseBinaryExpr ~a p 1 in + let e = parseTernaryExpr e p in + match p.Parser.token with + | Semicolon -> + let expr = parseExprBlock ~first:e p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + { expr with pexp_attributes = braces :: expr.pexp_attributes } + | Rbrace -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + { e with pexp_attributes = braces :: e.pexp_attributes } + | _ -> + let expr = parseExprBlock ~first:e p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + { expr with pexp_attributes = braces :: expr.pexp_attributes } + ) + | _ -> ( + Parser.leaveBreadcrumb p Grammar.ExprBlock; + let a = + parsePrimaryExpr + ~operand:(Ast_helper.Exp.ident ~loc:pathIdent.loc pathIdent) + p + in + let e = parseBinaryExpr ~a p 1 in + let e = parseTernaryExpr e p in + Parser.eatBreadcrumb p; + match p.Parser.token with + | Semicolon -> + let expr = parseExprBlock ~first:e p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + { expr with pexp_attributes = braces :: expr.pexp_attributes } + | Rbrace -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + { e with pexp_attributes = braces :: e.pexp_attributes } + | _ -> + let expr = parseExprBlock ~first:e p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + { expr with pexp_attributes = braces :: expr.pexp_attributes } + )) | _ -> ( - Parser.leaveBreadcrumb p Grammar.ExprBlock; - let a = - parsePrimaryExpr - ~operand:(Ast_helper.Exp.ident ~loc:pathIdent.loc pathIdent) - p - in - let e = parseBinaryExpr ~a p 1 in - let e = parseTernaryExpr e p in - Parser.eatBreadcrumb p; - match p.Parser.token with - | Semicolon -> - let expr = parseExprBlock ~first:e p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes} - | Rbrace -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {e with pexp_attributes = braces :: e.pexp_attributes} - | _ -> - let expr = parseExprBlock ~first:e p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes})) - | _ -> ( - Parser.leaveBreadcrumb p Grammar.ExprBlock; - let a = parsePrimaryExpr ~operand:valueOrConstructor p in - let e = parseBinaryExpr ~a p 1 in - let e = parseTernaryExpr e p in - Parser.eatBreadcrumb p; - match p.Parser.token with - | Semicolon -> - let expr = parseExprBlock ~first:e p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes} - | Rbrace -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {e with pexp_attributes = braces :: e.pexp_attributes} - | _ -> - let expr = parseExprBlock ~first:e p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes})) + Parser.leaveBreadcrumb p Grammar.ExprBlock; + let a = parsePrimaryExpr ~operand:valueOrConstructor p in + let e = parseBinaryExpr ~a p 1 in + let e = parseTernaryExpr e p in + Parser.eatBreadcrumb p; + match p.Parser.token with + | Semicolon -> + let expr = parseExprBlock ~first:e p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + { expr with pexp_attributes = braces :: expr.pexp_attributes } + | Rbrace -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + { e with pexp_attributes = braces :: e.pexp_attributes } + | _ -> + let expr = parseExprBlock ~first:e p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + { expr with pexp_attributes = braces :: expr.pexp_attributes })) | _ -> - let expr = parseExprBlock p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes} + let expr = parseExprBlock p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + { expr with pexp_attributes = braces :: expr.pexp_attributes } and parseRecordExprRowWithStringKey p = match p.Parser.token with | String s -> ( - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - let field = Location.mkloc (Longident.Lident s) loc in - match p.Parser.token with - | Colon -> + let loc = mkLoc p.startPos p.endPos in Parser.next p; - let fieldExpr = parseExpr p in - Some (field, fieldExpr) - | _ -> Some (field, Ast_helper.Exp.ident ~loc:field.loc field)) + let field = Location.mkloc (Longident.Lident s) loc in + match p.Parser.token with + | Colon -> + Parser.next p; + let fieldExpr = parseExpr p in + Some (field, fieldExpr) + | _ -> Some (field, Ast_helper.Exp.ident ~loc:field.loc field)) | _ -> None and parseRecordExprRow p = @@ -286096,43 +286406,43 @@ and parseRecordExprRow p = let () = match p.Parser.token with | Token.DotDotDot -> - Parser.err p (Diagnostics.message ErrorMessages.recordExprSpread); - Parser.next p + Parser.err p (Diagnostics.message ErrorMessages.recordExprSpread); + Parser.next p | _ -> () in match p.Parser.token with | Lident _ | Uident _ -> ( - let startToken = p.token in - let field = parseValuePath p in - match p.Parser.token with - | Colon -> - Parser.next p; - let optional = parseOptionalLabel p in - let fieldExpr = parseExpr p in - let fieldExpr = makeExpressionOptional ~optional fieldExpr in - Some (field, fieldExpr) - | _ -> - let value = Ast_helper.Exp.ident ~loc:field.loc ~attrs field in - let value = - match startToken with - | Uident _ -> removeModuleNameFromPunnedFieldValue value - | _ -> value - in - Some (field, value)) - | Question -> ( - Parser.next p; - match p.Parser.token with - | Lident _ | Uident _ -> let startToken = p.token in let field = parseValuePath p in - let value = Ast_helper.Exp.ident ~loc:field.loc ~attrs field in - let value = - match startToken with - | Uident _ -> removeModuleNameFromPunnedFieldValue value - | _ -> value - in - Some (field, makeExpressionOptional ~optional:true value) - | _ -> None) + match p.Parser.token with + | Colon -> + Parser.next p; + let optional = parseOptionalLabel p in + let fieldExpr = parseExpr p in + let fieldExpr = makeExpressionOptional ~optional fieldExpr in + Some (field, fieldExpr) + | _ -> + let value = Ast_helper.Exp.ident ~loc:field.loc ~attrs field in + let value = + match startToken with + | Uident _ -> removeModuleNameFromPunnedFieldValue value + | _ -> value + in + Some (field, value)) + | Question -> ( + Parser.next p; + match p.Parser.token with + | Lident _ | Uident _ -> + let startToken = p.token in + let field = parseValuePath p in + let value = Ast_helper.Exp.ident ~loc:field.loc ~attrs field in + let value = + match startToken with + | Uident _ -> removeModuleNameFromPunnedFieldValue value + | _ -> value + in + Some (field, makeExpressionOptional ~optional:true value) + | _ -> None) | _ -> None and parseRecordExprWithStringKeys ~startPos firstRow p = @@ -286146,19 +286456,19 @@ and parseRecordExprWithStringKeys ~startPos firstRow p = Ast_helper.Str.eval ~loc (Ast_helper.Exp.record ~loc rows None) in Ast_helper.Exp.extension ~loc - (Location.mkloc "obj" loc, Parsetree.PStr [recordStrExpr]) + (Location.mkloc "obj" loc, Parsetree.PStr [ recordStrExpr ]) and parseRecordExpr ~startPos ?(spread = None) rows p = let exprs = parseCommaDelimitedRegion ~grammar:Grammar.RecordRows ~closing:Rbrace ~f:parseRecordExprRow p in - let rows = List.concat [rows; exprs] in + let rows = List.concat [ rows; exprs ] in let () = match rows with | [] -> - let msg = "Record spread needs at least one field that's updated" in - Parser.err p (Diagnostics.message msg) + let msg = "Record spread needs at least one field that's updated" in + Parser.err p (Diagnostics.message msg) | _rows -> () in let loc = mkLoc startPos p.endPos in @@ -286168,12 +286478,12 @@ and parseNewlineOrSemicolonExprBlock p = match p.Parser.token with | Semicolon -> Parser.next p | token when Grammar.isBlockExprStart token -> - if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then () - else - Parser.err ~startPos:p.prevEndPos ~endPos:p.endPos p - (Diagnostics.message - "consecutive expressions on a line must be separated by ';' or a \ - newline") + if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then () + else + Parser.err ~startPos:p.prevEndPos ~endPos:p.endPos p + (Diagnostics.message + "consecutive expressions on a line must be separated by ';' or a \ + newline") | _ -> () and parseExprBlockItem p = @@ -286181,65 +286491,68 @@ and parseExprBlockItem p = let attrs = parseAttributes p in match p.Parser.token with | Module -> ( - Parser.next p; - match p.token with - | Lparen -> - let expr = parseFirstClassModuleExpr ~startPos p in - let a = parsePrimaryExpr ~operand:expr p in - let expr = parseBinaryExpr ~a p 1 in - parseTernaryExpr expr p - | _ -> - let name = - match p.Parser.token with - | Uident ident -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Location.mkloc ident loc - | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" - in - let body = parseModuleBindingBody p in + Parser.next p; + match p.token with + | Lparen -> + let expr = parseFirstClassModuleExpr ~startPos p in + let a = parsePrimaryExpr ~operand:expr p in + let expr = parseBinaryExpr ~a p 1 in + parseTernaryExpr expr p + | _ -> + let name = + match p.Parser.token with + | Uident ident -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc ident loc + | t -> + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" + in + let body = parseModuleBindingBody p in + parseNewlineOrSemicolonExprBlock p; + let expr = parseExprBlock p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.letmodule ~loc name body expr) + | Exception -> + let extensionConstructor = parseExceptionDef ~attrs p in parseNewlineOrSemicolonExprBlock p; - let expr = parseExprBlock p in + let blockExpr = parseExprBlock p in let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.letmodule ~loc name body expr) - | Exception -> - let extensionConstructor = parseExceptionDef ~attrs p in - parseNewlineOrSemicolonExprBlock p; - let blockExpr = parseExprBlock p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.letexception ~loc extensionConstructor blockExpr + Ast_helper.Exp.letexception ~loc extensionConstructor blockExpr | Open -> - let od = parseOpenDescription ~attrs p in - parseNewlineOrSemicolonExprBlock p; - let blockExpr = parseExprBlock p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.open_ ~loc od.popen_override od.popen_lid blockExpr + let od = parseOpenDescription ~attrs p in + parseNewlineOrSemicolonExprBlock p; + let blockExpr = parseExprBlock p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.open_ ~loc od.popen_override od.popen_lid blockExpr | Let -> - let recFlag, letBindings = parseLetBindings ~attrs p in - parseNewlineOrSemicolonExprBlock p; - let next = - if Grammar.isBlockExprStart p.Parser.token then parseExprBlock p - else - let loc = mkLoc p.startPos p.endPos in - Ast_helper.Exp.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - None - in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.let_ ~loc recFlag letBindings next + let recFlag, letBindings = parseLetBindings ~attrs p in + parseNewlineOrSemicolonExprBlock p; + let next = + if Grammar.isBlockExprStart p.Parser.token then parseExprBlock p + else + let loc = mkLoc p.startPos p.endPos in + Ast_helper.Exp.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None + in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.let_ ~loc recFlag letBindings next | _ -> - let e1 = - let expr = parseExpr p in - {expr with pexp_attributes = List.concat [attrs; expr.pexp_attributes]} - in - parseNewlineOrSemicolonExprBlock p; - if Grammar.isBlockExprStart p.Parser.token then - let e2 = parseExprBlock p in - let loc = {e1.pexp_loc with loc_end = e2.pexp_loc.loc_end} in - Ast_helper.Exp.sequence ~loc e1 e2 - else e1 + let e1 = + let expr = parseExpr p in + { + expr with + pexp_attributes = List.concat [ attrs; expr.pexp_attributes ]; + } + in + parseNewlineOrSemicolonExprBlock p; + if Grammar.isBlockExprStart p.Parser.token then + let e2 = parseExprBlock p in + let loc = { e1.pexp_loc with loc_end = e2.pexp_loc.loc_end } in + Ast_helper.Exp.sequence ~loc e1 e2 + else e1 (* blockExpr ::= expr * | expr ; @@ -286256,16 +286569,12 @@ and parseExprBlockItem p = *) and parseExprBlock ?first p = Parser.leaveBreadcrumb p Grammar.ExprBlock; - let item = - match first with - | Some e -> e - | None -> parseExprBlockItem p - in + let item = match first with Some e -> e | None -> parseExprBlockItem p in parseNewlineOrSemicolonExprBlock p; let blockExpr = if Grammar.isBlockExprStart p.Parser.token then let next = parseExprBlockItem p in - let loc = {item.pexp_loc with loc_end = next.pexp_loc.loc_end} in + let loc = { item.pexp_loc with loc_end = next.pexp_loc.loc_end } in Ast_helper.Exp.sequence ~loc item next else item in @@ -286280,7 +286589,7 @@ and parseAsyncArrowExpression p = { expr with pexp_attributes = asyncAttr :: expr.pexp_attributes; - pexp_loc = {expr.pexp_loc with loc_start = startPos}; + pexp_loc = { expr.pexp_loc with loc_start = startPos }; } and parseAwaitExpression p = @@ -286291,7 +286600,7 @@ and parseAwaitExpression p = { expr with pexp_attributes = awaitAttr :: expr.pexp_attributes; - pexp_loc = {expr.pexp_loc with loc_start = awaitLoc.loc_start}; + pexp_loc = { expr.pexp_loc with loc_start = awaitLoc.loc_start }; } and parseTryExpression p = @@ -286332,21 +286641,21 @@ and parseIfExpr startPos p = let elseExpr = match p.Parser.token with | Else -> - Parser.endRegion p; - Parser.leaveBreadcrumb p Grammar.ElseBranch; - Parser.next p; - Parser.beginRegion p; - let elseExpr = - match p.token with - | If -> parseIfOrIfLetExpression p - | _ -> parseElseBranch p - in - Parser.eatBreadcrumb p; - Parser.endRegion p; - Some elseExpr + Parser.endRegion p; + Parser.leaveBreadcrumb p Grammar.ElseBranch; + Parser.next p; + Parser.beginRegion p; + let elseExpr = + match p.token with + | If -> parseIfOrIfLetExpression p + | _ -> parseElseBranch p + in + Parser.eatBreadcrumb p; + Parser.endRegion p; + Some elseExpr | _ -> - Parser.endRegion p; - None + Parser.endRegion p; + None in let loc = mkLoc startPos p.prevEndPos in Ast_helper.Exp.ifthenelse ~loc conditionExpr thenExpr elseExpr @@ -286359,29 +286668,29 @@ and parseIfLetExpr startPos p = let elseExpr = match p.Parser.token with | Else -> - Parser.endRegion p; - Parser.leaveBreadcrumb p Grammar.ElseBranch; - Parser.next p; - Parser.beginRegion p; - let elseExpr = - match p.token with - | If -> parseIfOrIfLetExpression p - | _ -> parseElseBranch p - in - Parser.eatBreadcrumb p; - Parser.endRegion p; - elseExpr + Parser.endRegion p; + Parser.leaveBreadcrumb p Grammar.ElseBranch; + Parser.next p; + Parser.beginRegion p; + let elseExpr = + match p.token with + | If -> parseIfOrIfLetExpression p + | _ -> parseElseBranch p + in + Parser.eatBreadcrumb p; + Parser.endRegion p; + elseExpr | _ -> - Parser.endRegion p; - let startPos = p.Parser.startPos in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - None + Parser.endRegion p; + let startPos = p.Parser.startPos in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None in let loc = mkLoc startPos p.prevEndPos in Ast_helper.Exp.match_ - ~attrs:[ifLetAttr; suppressFragileMatchWarningAttr] + ~attrs:[ ifLetAttr; suppressFragileMatchWarningAttr ] ~loc conditionExpr [ Ast_helper.Exp.case pattern thenExpr; @@ -286396,12 +286705,12 @@ and parseIfOrIfLetExpression p = let expr = match p.Parser.token with | Let -> - Parser.next p; - let ifLetExpr = parseIfLetExpr startPos p in - Parser.err ~startPos:ifLetExpr.pexp_loc.loc_start - ~endPos:ifLetExpr.pexp_loc.loc_end p - (Diagnostics.message (ErrorMessages.experimentalIfLet ifLetExpr)); - ifLetExpr + Parser.next p; + let ifLetExpr = parseIfLetExpr startPos p in + Parser.err ~startPos:ifLetExpr.pexp_loc.loc_start + ~endPos:ifLetExpr.pexp_loc.loc_end p + (Diagnostics.message (ErrorMessages.experimentalIfLet ifLetExpr)); + ifLetExpr | _ -> parseIfExpr startPos p in Parser.eatBreadcrumb p; @@ -286415,8 +286724,8 @@ and parseForRest hasOpeningParen pattern startPos p = | Lident "to" -> Asttypes.Upto | Lident "downto" -> Asttypes.Downto | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Asttypes.Upto + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Asttypes.Upto in if p.Parser.token = Eof then Parser.err ~startPos:p.startPos p @@ -286438,37 +286747,37 @@ and parseForExpression p = let forExpr = match p.token with | Lparen -> ( - let lparen = p.startPos in - Parser.next p; - match p.token with - | Rparen -> + let lparen = p.startPos in Parser.next p; - let unitPattern = - let loc = mkLoc lparen p.prevEndPos in - let lid = Location.mkloc (Longident.Lident "()") loc in - Ast_helper.Pat.construct lid None - in - parseForRest false - (parseAliasPattern ~attrs:[] unitPattern p) - startPos p - | _ -> ( + match p.token with + | Rparen -> + Parser.next p; + let unitPattern = + let loc = mkLoc lparen p.prevEndPos in + let lid = Location.mkloc (Longident.Lident "()") loc in + Ast_helper.Pat.construct lid None + in + parseForRest false + (parseAliasPattern ~attrs:[] unitPattern p) + startPos p + | _ -> ( + Parser.leaveBreadcrumb p Grammar.Pattern; + let pat = parsePattern p in + Parser.eatBreadcrumb p; + match p.token with + | Comma -> + Parser.next p; + let tuplePattern = + parseTuplePattern ~attrs:[] ~startPos:lparen ~first:pat p + in + let pattern = parseAliasPattern ~attrs:[] tuplePattern p in + parseForRest false pattern startPos p + | _ -> parseForRest true pat startPos p)) + | _ -> Parser.leaveBreadcrumb p Grammar.Pattern; let pat = parsePattern p in Parser.eatBreadcrumb p; - match p.token with - | Comma -> - Parser.next p; - let tuplePattern = - parseTuplePattern ~attrs:[] ~startPos:lparen ~first:pat p - in - let pattern = parseAliasPattern ~attrs:[] tuplePattern p in - parseForRest false pattern startPos p - | _ -> parseForRest true pat startPos p)) - | _ -> - Parser.leaveBreadcrumb p Grammar.Pattern; - let pat = parsePattern p in - Parser.eatBreadcrumb p; - parseForRest false pat startPos p + parseForRest false pat startPos p in Parser.eatBreadcrumb p; Parser.endRegion p; @@ -286487,8 +286796,8 @@ and parseWhileExpression p = and parsePatternGuard p = match p.Parser.token with | When | If -> - Parser.next p; - Some (parseExpr ~context:WhenExpr p) + Parser.next p; + Some (parseExpr ~context:WhenExpr p) | _ -> None and parsePatternMatchCase p = @@ -286496,24 +286805,24 @@ and parsePatternMatchCase p = Parser.leaveBreadcrumb p Grammar.PatternMatchCase; match p.Parser.token with | Token.Bar -> - Parser.next p; - Parser.leaveBreadcrumb p Grammar.Pattern; - let lhs = parsePattern p in - Parser.eatBreadcrumb p; - let guard = parsePatternGuard p in - let () = - match p.token with - | EqualGreater -> Parser.next p - | _ -> Recover.recoverEqualGreater p - in - let rhs = parseExprBlock p in - Parser.endRegion p; - Parser.eatBreadcrumb p; - Some (Ast_helper.Exp.case lhs ?guard rhs) + Parser.next p; + Parser.leaveBreadcrumb p Grammar.Pattern; + let lhs = parsePattern p in + Parser.eatBreadcrumb p; + let guard = parsePatternGuard p in + let () = + match p.token with + | EqualGreater -> Parser.next p + | _ -> Recover.recoverEqualGreater p + in + let rhs = parseExprBlock p in + Parser.endRegion p; + Parser.eatBreadcrumb p; + Some (Ast_helper.Exp.case lhs ?guard rhs) | _ -> - Parser.endRegion p; - Parser.eatBreadcrumb p; - None + Parser.endRegion p; + Parser.eatBreadcrumb p; + None and parsePatternMatching p = let cases = @@ -286523,8 +286832,8 @@ and parsePatternMatching p = let () = match cases with | [] -> - Parser.err ~startPos:p.prevEndPos p - (Diagnostics.message "Pattern matching needs at least one case") + Parser.err ~startPos:p.prevEndPos p + (Diagnostics.message "Pattern matching needs at least one case") | _ -> () in cases @@ -286565,18 +286874,18 @@ and parseArgument p = then match p.Parser.token with | Dot -> ( - let uncurried = true in - Parser.next p; - match p.token with - (* apply(.) *) - | Rparen -> - let unitExpr = - Ast_helper.Exp.construct - (Location.mknoloc (Longident.Lident "()")) - None - in - Some (uncurried, Asttypes.Nolabel, unitExpr) - | _ -> parseArgument2 p ~uncurried) + let uncurried = true in + Parser.next p; + match p.token with + (* apply(.) *) + | Rparen -> + let unitExpr = + Ast_helper.Exp.construct + (Location.mknoloc (Longident.Lident "()")) + None + in + Some (uncurried, Asttypes.Nolabel, unitExpr) + | _ -> parseArgument2 p ~uncurried) | _ -> parseArgument2 p ~uncurried:false else None @@ -286584,65 +286893,70 @@ and parseArgument2 p ~uncurried = match p.Parser.token with (* foo(_), do not confuse with foo(_ => x), TODO: performance *) | Underscore when not (isEs6ArrowExpression ~inTernary:false p) -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - let exp = - Ast_helper.Exp.ident ~loc (Location.mkloc (Longident.Lident "_") loc) - in - Some (uncurried, Asttypes.Nolabel, exp) - | Tilde -> ( - Parser.next p; - (* TODO: nesting of pattern matches not intuitive for error recovery *) - match p.Parser.token with - | Lident ident -> ( - let startPos = p.startPos in + let loc = mkLoc p.startPos p.endPos in Parser.next p; - let endPos = p.prevEndPos in - let loc = mkLoc startPos endPos in - let propLocAttr = - (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) - in - let identExpr = - Ast_helper.Exp.ident ~attrs:[propLocAttr] ~loc - (Location.mkloc (Longident.Lident ident) loc) + let exp = + Ast_helper.Exp.ident ~loc (Location.mkloc (Longident.Lident "_") loc) in + Some (uncurried, Asttypes.Nolabel, exp) + | Tilde -> ( + Parser.next p; + (* TODO: nesting of pattern matches not intuitive for error recovery *) match p.Parser.token with - | Question -> - Parser.next p; - Some (uncurried, Asttypes.Optional ident, identExpr) - | Equal -> - Parser.next p; - let label = + | Lident ident -> ( + let startPos = p.startPos in + Parser.next p; + let endPos = p.prevEndPos in + let loc = mkLoc startPos endPos in + let propLocAttr = + (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) + in + let identExpr = + Ast_helper.Exp.ident ~attrs:[ propLocAttr ] ~loc + (Location.mkloc (Longident.Lident ident) loc) + in match p.Parser.token with | Question -> - Parser.next p; - Asttypes.Optional ident - | _ -> Labelled ident - in - let expr = - match p.Parser.token with - | Underscore when not (isEs6ArrowExpression ~inTernary:false p) -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Ast_helper.Exp.ident ~loc - (Location.mkloc (Longident.Lident "_") loc) - | _ -> - let expr = parseConstrainedOrCoercedExpr p in - {expr with pexp_attributes = propLocAttr :: expr.pexp_attributes} - in - Some (uncurried, label, expr) - | Colon -> - Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc startPos p.prevEndPos in - let expr = - Ast_helper.Exp.constraint_ ~attrs:[propLocAttr] ~loc identExpr typ - in - Some (uncurried, Labelled ident, expr) - | _ -> Some (uncurried, Labelled ident, identExpr)) - | t -> - Parser.err p (Diagnostics.lident t); - Some (uncurried, Nolabel, Recover.defaultExpr ())) + Parser.next p; + Some (uncurried, Asttypes.Optional ident, identExpr) + | Equal -> + Parser.next p; + let label = + match p.Parser.token with + | Question -> + Parser.next p; + Asttypes.Optional ident + | _ -> Labelled ident + in + let expr = + match p.Parser.token with + | Underscore when not (isEs6ArrowExpression ~inTernary:false p) + -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Ast_helper.Exp.ident ~loc + (Location.mkloc (Longident.Lident "_") loc) + | _ -> + let expr = parseConstrainedOrCoercedExpr p in + { + expr with + pexp_attributes = propLocAttr :: expr.pexp_attributes; + } + in + Some (uncurried, label, expr) + | Colon -> + Parser.next p; + let typ = parseTypExpr p in + let loc = mkLoc startPos p.prevEndPos in + let expr = + Ast_helper.Exp.constraint_ ~attrs:[ propLocAttr ] ~loc identExpr + typ + in + Some (uncurried, Labelled ident, expr) + | _ -> Some (uncurried, Labelled ident, identExpr)) + | t -> + Parser.err p (Diagnostics.lident t); + Some (uncurried, Nolabel, Recover.defaultExpr ())) | _ -> Some (uncurried, Nolabel, parseConstrainedOrCoercedExpr p) and parseCallExpr p funExpr = @@ -286657,63 +286971,65 @@ and parseCallExpr p funExpr = let args = match args with | [] -> - let loc = mkLoc startPos p.prevEndPos in - (* No args -> unit sugar: `foo()` *) - [ - ( false, - Asttypes.Nolabel, - Ast_helper.Exp.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - None ); - ] + let loc = mkLoc startPos p.prevEndPos in + (* No args -> unit sugar: `foo()` *) + [ + ( false, + Asttypes.Nolabel, + Ast_helper.Exp.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None ); + ] | [ ( true, Asttypes.Nolabel, ({ - pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, None); + pexp_desc = Pexp_construct ({ txt = Longident.Lident "()" }, None); pexp_loc = loc; pexp_attributes = []; } as expr) ); ] when (not loc.loc_ghost) && p.mode = ParseForTypeChecker -> - (* Since there is no syntax space for arity zero vs arity one, - * we expand - * `fn(. ())` into - * `fn(. {let __res_unit = (); __res_unit})` - * when the parsetree is intended for type checking - * - * Note: - * `fn(.)` is treated as zero arity application. - * The invisible unit expression here has loc_ghost === true - * - * Related: https://github.com/rescript-lang/syntax/issues/138 - *) - [ - ( true, - Asttypes.Nolabel, - Ast_helper.Exp.let_ Asttypes.Nonrecursive - [ - Ast_helper.Vb.mk - (Ast_helper.Pat.var (Location.mknoloc "__res_unit")) - expr; - ] - (Ast_helper.Exp.ident - (Location.mknoloc (Longident.Lident "__res_unit"))) ); - ] + (* Since there is no syntax space for arity zero vs arity one, + * we expand + * `fn(. ())` into + * `fn(. {let __res_unit = (); __res_unit})` + * when the parsetree is intended for type checking + * + * Note: + * `fn(.)` is treated as zero arity application. + * The invisible unit expression here has loc_ghost === true + * + * Related: https://github.com/rescript-lang/syntax/issues/138 + *) + [ + ( true, + Asttypes.Nolabel, + Ast_helper.Exp.let_ Asttypes.Nonrecursive + [ + Ast_helper.Vb.mk + (Ast_helper.Pat.var (Location.mknoloc "__res_unit")) + expr; + ] + (Ast_helper.Exp.ident + (Location.mknoloc (Longident.Lident "__res_unit"))) ); + ] | args -> args in - let loc = {funExpr.pexp_loc with loc_end = p.prevEndPos} in + let loc = { funExpr.pexp_loc with loc_end = p.prevEndPos } in let args = match args with | (u, lbl, expr) :: args -> - let group (grp, acc) (uncurried, lbl, expr) = - let _u, grp = grp in - if uncurried == true then - ((true, [(lbl, expr)]), (_u, List.rev grp) :: acc) - else ((_u, (lbl, expr) :: grp), acc) - in - let (_u, grp), acc = List.fold_left group ((u, [(lbl, expr)]), []) args in - List.rev ((_u, List.rev grp) :: acc) + let group (grp, acc) (uncurried, lbl, expr) = + let _u, grp = grp in + if uncurried == true then + ((true, [ (lbl, expr) ]), (_u, List.rev grp) :: acc) + else ((_u, (lbl, expr) :: grp), acc) + in + let (_u, grp), acc = + List.fold_left group ((u, [ (lbl, expr) ]), []) args + in + List.rev ((_u, List.rev grp) :: acc) | [] -> [] in let apply = @@ -286723,7 +287039,7 @@ and parseCallExpr p funExpr = let args, wrap = processUnderscoreApplication args in let exp = if uncurried then - let attrs = [uncurryAttr] in + let attrs = [ uncurryAttr ] in Ast_helper.Exp.apply ~loc ~attrs callBody args else Ast_helper.Exp.apply ~loc callBody args in @@ -286738,55 +287054,55 @@ and parseValueOrConstructor p = let rec aux p acc = match p.Parser.token with | Uident ident -> ( - let endPosLident = p.endPos in - Parser.next p; - match p.Parser.token with - | Dot -> + let endPosLident = p.endPos in Parser.next p; - aux p (ident :: acc) - | Lparen when p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> - let lparen = p.startPos in - let args = parseConstructorArgs p in - let rparen = p.prevEndPos in - let lident = buildLongident (ident :: acc) in - let tail = - match args with - | [] -> None - | [({Parsetree.pexp_desc = Pexp_tuple _} as arg)] as args -> - let loc = mkLoc lparen rparen in - if p.mode = ParseForTypeChecker then - (* Some(1, 2) for type-checker *) - Some arg - else - (* Some((1, 2)) for printer *) - Some (Ast_helper.Exp.tuple ~loc args) - | [arg] -> Some arg - | args -> - let loc = mkLoc lparen rparen in - Some (Ast_helper.Exp.tuple ~loc args) - in - let loc = mkLoc startPos p.prevEndPos in - let identLoc = mkLoc startPos endPosLident in - Ast_helper.Exp.construct ~loc (Location.mkloc lident identLoc) tail - | _ -> - let loc = mkLoc startPos p.prevEndPos in - let lident = buildLongident (ident :: acc) in - Ast_helper.Exp.construct ~loc (Location.mkloc lident loc) None) + match p.Parser.token with + | Dot -> + Parser.next p; + aux p (ident :: acc) + | Lparen when p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> + let lparen = p.startPos in + let args = parseConstructorArgs p in + let rparen = p.prevEndPos in + let lident = buildLongident (ident :: acc) in + let tail = + match args with + | [] -> None + | [ ({ Parsetree.pexp_desc = Pexp_tuple _ } as arg) ] as args -> + let loc = mkLoc lparen rparen in + if p.mode = ParseForTypeChecker then + (* Some(1, 2) for type-checker *) + Some arg + else + (* Some((1, 2)) for printer *) + Some (Ast_helper.Exp.tuple ~loc args) + | [ arg ] -> Some arg + | args -> + let loc = mkLoc lparen rparen in + Some (Ast_helper.Exp.tuple ~loc args) + in + let loc = mkLoc startPos p.prevEndPos in + let identLoc = mkLoc startPos endPosLident in + Ast_helper.Exp.construct ~loc (Location.mkloc lident identLoc) tail + | _ -> + let loc = mkLoc startPos p.prevEndPos in + let lident = buildLongident (ident :: acc) in + Ast_helper.Exp.construct ~loc (Location.mkloc lident loc) None) | Lident ident -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let lident = buildLongident (ident :: acc) in - Ast_helper.Exp.ident ~loc (Location.mkloc lident loc) - | token -> - if acc = [] then ( - Parser.nextUnsafe p; - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Recover.defaultExpr ()) - else + Parser.next p; let loc = mkLoc startPos p.prevEndPos in - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - let lident = buildLongident ("_" :: acc) in + let lident = buildLongident (ident :: acc) in Ast_helper.Exp.ident ~loc (Location.mkloc lident loc) + | token -> + if acc = [] then ( + Parser.nextUnsafe p; + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Recover.defaultExpr ()) + else + let loc = mkLoc startPos p.prevEndPos in + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + let lident = buildLongident ("_" :: acc) in + Ast_helper.Exp.ident ~loc (Location.mkloc lident loc) in aux p [] @@ -286795,30 +287111,30 @@ and parsePolyVariantExpr p = let ident, _loc = parseHashIdent ~startPos p in match p.Parser.token with | Lparen when p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> - let lparen = p.startPos in - let args = parseConstructorArgs p in - let rparen = p.prevEndPos in - let loc_paren = mkLoc lparen rparen in - let tail = - match args with - | [] -> None - | [({Parsetree.pexp_desc = Pexp_tuple _} as expr)] as args -> - if p.mode = ParseForTypeChecker then - (* #a(1, 2) for type-checker *) - Some expr - else - (* #a((1, 2)) for type-checker *) - Some (Ast_helper.Exp.tuple ~loc:loc_paren args) - | [arg] -> Some arg - | args -> - (* #a((1, 2)) for printer *) - Some (Ast_helper.Exp.tuple ~loc:loc_paren args) - in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.variant ~loc ident tail + let lparen = p.startPos in + let args = parseConstructorArgs p in + let rparen = p.prevEndPos in + let loc_paren = mkLoc lparen rparen in + let tail = + match args with + | [] -> None + | [ ({ Parsetree.pexp_desc = Pexp_tuple _ } as expr) ] as args -> + if p.mode = ParseForTypeChecker then + (* #a(1, 2) for type-checker *) + Some expr + else + (* #a((1, 2)) for type-checker *) + Some (Ast_helper.Exp.tuple ~loc:loc_paren args) + | [ arg ] -> Some arg + | args -> + (* #a((1, 2)) for printer *) + Some (Ast_helper.Exp.tuple ~loc:loc_paren args) + in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.variant ~loc ident tail | _ -> - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.variant ~loc ident None + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.variant ~loc ident None and parseConstructorArgs p = let lparen = p.Parser.startPos in @@ -286830,12 +287146,12 @@ and parseConstructorArgs p = Parser.expect Rparen p; match args with | [] -> - let loc = mkLoc lparen p.prevEndPos in - [ - Ast_helper.Exp.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - None; - ] + let loc = mkLoc lparen p.prevEndPos in + [ + Ast_helper.Exp.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None; + ] | args -> args and parseTupleExpr ~first ~startPos p = @@ -286847,9 +287163,9 @@ and parseTupleExpr ~first ~startPos p = Parser.expect Rparen p; let () = match exprs with - | [_] -> - Parser.err ~startPos ~endPos:p.prevEndPos p - (Diagnostics.message ErrorMessages.tupleSingleElement) + | [ _ ] -> + Parser.err ~startPos ~endPos:p.prevEndPos p + (Diagnostics.message ErrorMessages.tupleSingleElement) | _ -> () in let loc = mkLoc startPos p.prevEndPos in @@ -286859,11 +287175,11 @@ and parseSpreadExprRegionWithLoc p = let startPos = p.Parser.prevEndPos in match p.Parser.token with | DotDotDot -> - Parser.next p; - let expr = parseConstrainedOrCoercedExpr p in - Some (true, expr, startPos, p.prevEndPos) + Parser.next p; + let expr = parseConstrainedOrCoercedExpr p in + Some (true, expr, startPos, p.prevEndPos) | token when Grammar.isExprStart token -> - Some (false, parseConstrainedOrCoercedExpr p, startPos, p.prevEndPos) + Some (false, parseConstrainedOrCoercedExpr p, startPos, p.prevEndPos) | _ -> None and parseListExpr ~startPos p = @@ -286872,23 +287188,23 @@ and parseListExpr ~startPos p = (fun acc curr -> match (curr, acc) with | (true, expr, startPos, endPos), _ -> - (* find a spread expression, prepend a new sublist *) - ([], Some expr, startPos, endPos) :: acc + (* find a spread expression, prepend a new sublist *) + ([], Some expr, startPos, endPos) :: acc | ( (false, expr, startPos, _endPos), (no_spreads, spread, _accStartPos, accEndPos) :: acc ) -> - (* find a non-spread expression, and the accumulated is not empty, - * prepend to the first sublist, and update the loc of the first sublist *) - (expr :: no_spreads, spread, startPos, accEndPos) :: acc + (* find a non-spread expression, and the accumulated is not empty, + * prepend to the first sublist, and update the loc of the first sublist *) + (expr :: no_spreads, spread, startPos, accEndPos) :: acc | (false, expr, startPos, endPos), [] -> - (* find a non-spread expression, and the accumulated is empty *) - [([expr], None, startPos, endPos)]) + (* find a non-spread expression, and the accumulated is empty *) + [ ([ expr ], None, startPos, endPos) ]) [] exprs in let make_sub_expr = function | exprs, Some spread, startPos, endPos -> - makeListExpression (mkLoc startPos endPos) exprs (Some spread) + makeListExpression (mkLoc startPos endPos) exprs (Some spread) | exprs, None, startPos, endPos -> - makeListExpression (mkLoc startPos endPos) exprs None + makeListExpression (mkLoc startPos endPos) exprs None in let listExprsRev = parseCommaDelimitedReversedList p ~grammar:Grammar.ListExpr ~closing:Rbrace @@ -286898,37 +287214,37 @@ and parseListExpr ~startPos p = let loc = mkLoc startPos p.prevEndPos in match split_by_spread listExprsRev with | [] -> makeListExpression loc [] None - | [(exprs, Some spread, _, _)] -> makeListExpression loc exprs (Some spread) - | [(exprs, None, _, _)] -> makeListExpression loc exprs None + | [ (exprs, Some spread, _, _) ] -> makeListExpression loc exprs (Some spread) + | [ (exprs, None, _, _) ] -> makeListExpression loc exprs None | exprs -> - let listExprs = List.map make_sub_expr exprs in - Ast_helper.Exp.apply ~loc - (Ast_helper.Exp.ident ~loc ~attrs:[spreadAttr] - (Location.mkloc - (Longident.Ldot - (Longident.Ldot (Longident.Lident "Belt", "List"), "concatMany")) - loc)) - [(Asttypes.Nolabel, Ast_helper.Exp.array ~loc listExprs)] + let listExprs = List.map make_sub_expr exprs in + Ast_helper.Exp.apply ~loc + (Ast_helper.Exp.ident ~loc ~attrs:[ spreadAttr ] + (Location.mkloc + (Longident.Ldot + (Longident.Ldot (Longident.Lident "Belt", "List"), "concatMany")) + loc)) + [ (Asttypes.Nolabel, Ast_helper.Exp.array ~loc listExprs) ] (* Overparse ... and give a nice error message *) and parseNonSpreadExp ~msg p = let () = match p.Parser.token with | DotDotDot -> - Parser.err p (Diagnostics.message msg); - Parser.next p + Parser.err p (Diagnostics.message msg); + Parser.next p | _ -> () in match p.Parser.token with | token when Grammar.isExprStart token -> ( - let expr = parseExpr p in - match p.Parser.token with - | Colon -> - Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in - Some (Ast_helper.Exp.constraint_ ~loc expr typ) - | _ -> Some expr) + let expr = parseExpr p in + match p.Parser.token with + | Colon -> + Parser.next p; + let typ = parseTypExpr p in + let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in + Some (Ast_helper.Exp.constraint_ ~loc expr typ) + | _ -> Some expr) | _ -> None and parseArrayExp p = @@ -286947,28 +287263,28 @@ and parsePolyTypeExpr p = let startPos = p.Parser.startPos in match p.Parser.token with | SingleQuote -> ( - let vars = parseTypeVarList p in - match vars with - | _v1 :: _v2 :: _ -> - Parser.expect Dot p; - let typ = parseTypExpr p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.poly ~loc vars typ - | [var] -> ( - match p.Parser.token with - | Dot -> - Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.poly ~loc vars typ - | EqualGreater -> - Parser.next p; - let typ = Ast_helper.Typ.var ~loc:var.loc var.txt in - let returnType = parseTypExpr ~alias:false p in - let loc = mkLoc typ.Parsetree.ptyp_loc.loc_start p.prevEndPos in - Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType - | _ -> Ast_helper.Typ.var ~loc:var.loc var.txt) - | _ -> assert false) + let vars = parseTypeVarList p in + match vars with + | _v1 :: _v2 :: _ -> + Parser.expect Dot p; + let typ = parseTypExpr p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.poly ~loc vars typ + | [ var ] -> ( + match p.Parser.token with + | Dot -> + Parser.next p; + let typ = parseTypExpr p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.poly ~loc vars typ + | EqualGreater -> + Parser.next p; + let typ = Ast_helper.Typ.var ~loc:var.loc var.txt in + let returnType = parseTypExpr ~alias:false p in + let loc = mkLoc typ.Parsetree.ptyp_loc.loc_start p.prevEndPos in + Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType + | _ -> Ast_helper.Typ.var ~loc:var.loc var.txt) + | _ -> assert false) | _ -> parseTypExpr p (* 'a 'b 'c *) @@ -286976,10 +287292,10 @@ and parseTypeVarList p = let rec loop p vars = match p.Parser.token with | SingleQuote -> - Parser.next p; - let lident, loc = parseLident p in - let var = Location.mkloc lident loc in - loop p (var :: vars) + Parser.next p; + let lident, loc = parseLident p in + let var = Location.mkloc lident loc in + loop p (var :: vars) | _ -> List.rev vars in loop p [] @@ -286988,9 +287304,9 @@ and parseLidentList p = let rec loop p ls = match p.Parser.token with | Lident lident -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - loop p (Location.mkloc lident loc :: ls) + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + loop p (Location.mkloc lident loc :: ls) | _ -> List.rev ls in loop p [] @@ -287001,71 +287317,72 @@ and parseAtomicTypExpr ~attrs p = let typ = match p.Parser.token with | SingleQuote -> - Parser.next p; - let ident, loc = - if p.Parser.token = Eof then ( - Parser.err ~startPos:p.startPos p - (Diagnostics.unexpected p.Parser.token p.breadcrumbs); - ("", mkLoc p.startPos p.prevEndPos)) - else parseIdent ~msg:ErrorMessages.typeVar ~startPos:p.startPos p - in - Ast_helper.Typ.var ~loc ~attrs ident + Parser.next p; + let ident, loc = + if p.Parser.token = Eof then ( + Parser.err ~startPos:p.startPos p + (Diagnostics.unexpected p.Parser.token p.breadcrumbs); + ("", mkLoc p.startPos p.prevEndPos)) + else parseIdent ~msg:ErrorMessages.typeVar ~startPos:p.startPos p + in + Ast_helper.Typ.var ~loc ~attrs ident | Underscore -> - let endPos = p.endPos in - Parser.next p; - Ast_helper.Typ.any ~loc:(mkLoc startPos endPos) ~attrs () + let endPos = p.endPos in + Parser.next p; + Ast_helper.Typ.any ~loc:(mkLoc startPos endPos) ~attrs () | Lparen -> ( - Parser.next p; - match p.Parser.token with - | Rparen -> Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let unitConstr = Location.mkloc (Longident.Lident "unit") loc in - Ast_helper.Typ.constr ~attrs unitConstr [] - | _ -> ( - let t = parseTypExpr p in - match p.token with - | Comma -> - Parser.next p; - parseTupleType ~attrs ~first:t ~startPos p - | _ -> - Parser.expect Rparen p; - { - t with - ptyp_loc = mkLoc startPos p.prevEndPos; - ptyp_attributes = List.concat [attrs; t.ptyp_attributes]; - })) + match p.Parser.token with + | Rparen -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let unitConstr = Location.mkloc (Longident.Lident "unit") loc in + Ast_helper.Typ.constr ~attrs unitConstr [] + | _ -> ( + let t = parseTypExpr p in + match p.token with + | Comma -> + Parser.next p; + parseTupleType ~attrs ~first:t ~startPos p + | _ -> + Parser.expect Rparen p; + { + t with + ptyp_loc = mkLoc startPos p.prevEndPos; + ptyp_attributes = List.concat [ attrs; t.ptyp_attributes ]; + })) | Lbracket -> parsePolymorphicVariantType ~attrs p | Uident _ | Lident _ -> - let constr = parseValuePath p in - let args = parseTypeConstructorArgs ~constrName:constr p in - Ast_helper.Typ.constr - ~loc:(mkLoc startPos p.prevEndPos) - ~attrs constr args + let constr = parseValuePath p in + let args = parseTypeConstructorArgs ~constrName:constr p in + Ast_helper.Typ.constr + ~loc:(mkLoc startPos p.prevEndPos) + ~attrs constr args | Module -> - Parser.next p; - Parser.expect Lparen p; - let packageType = parsePackageType ~startPos ~attrs p in - Parser.expect Rparen p; - {packageType with ptyp_loc = mkLoc startPos p.prevEndPos} + Parser.next p; + Parser.expect Lparen p; + let packageType = parsePackageType ~startPos ~attrs p in + Parser.expect Rparen p; + { packageType with ptyp_loc = mkLoc startPos p.prevEndPos } | Percent -> - let extension = parseExtension p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.extension ~attrs ~loc extension + let extension = parseExtension p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.extension ~attrs ~loc extension | Lbrace -> parseRecordOrObjectType ~attrs p | Eof -> - Parser.err p (Diagnostics.unexpected p.Parser.token p.breadcrumbs); - Recover.defaultType () + Parser.err p (Diagnostics.unexpected p.Parser.token p.breadcrumbs); + Recover.defaultType () | token -> ( - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - match - skipTokensAndMaybeRetry p ~isStartOfGrammar:Grammar.isAtomicTypExprStart - with - | Some () -> parseAtomicTypExpr ~attrs p - | None -> - Parser.err ~startPos:p.prevEndPos p - (Diagnostics.unexpected token p.breadcrumbs); - Recover.defaultType ()) + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + match + skipTokensAndMaybeRetry p + ~isStartOfGrammar:Grammar.isAtomicTypExprStart + with + | Some () -> parseAtomicTypExpr ~attrs p + | None -> + Parser.err ~startPos:p.prevEndPos p + (Diagnostics.unexpected token p.breadcrumbs); + Recover.defaultType ()) in Parser.eatBreadcrumb p; typ @@ -287078,13 +287395,13 @@ and parsePackageType ~startPos ~attrs p = let modTypePath = parseModuleLongIdent ~lowercase:true p in match p.Parser.token with | Lident "with" -> - Parser.next p; - let constraints = parsePackageConstraints p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.package ~loc ~attrs modTypePath constraints + Parser.next p; + let constraints = parsePackageConstraints p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.package ~loc ~attrs modTypePath constraints | _ -> - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.package ~loc ~attrs modTypePath [] + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.package ~loc ~attrs modTypePath [] (* package-constraint { and package-constraint } *) and parsePackageConstraints p = @@ -287104,12 +287421,12 @@ and parsePackageConstraints p = and parsePackageConstraint p = match p.Parser.token with | And -> - Parser.next p; - Parser.expect Typ p; - let typeConstr = parseValuePath p in - Parser.expect Equal p; - let typ = parseTypExpr p in - Some (typeConstr, typ) + Parser.next p; + Parser.expect Typ p; + let typeConstr = parseValuePath p in + Parser.expect Equal p; + let typ = parseTypExpr p in + Some (typeConstr, typ) | _ -> None and parseRecordOrObjectType ~attrs p = @@ -287119,18 +287436,18 @@ and parseRecordOrObjectType ~attrs p = let closedFlag = match p.token with | DotDot -> - Parser.next p; - Asttypes.Open + Parser.next p; + Asttypes.Open | Dot -> - Parser.next p; - Asttypes.Closed + Parser.next p; + Asttypes.Closed | _ -> Asttypes.Closed in let () = match p.token with | Lident _ -> - Parser.err p - (Diagnostics.message ErrorMessages.forbiddenInlineRecordDeclaration) + Parser.err p + (Diagnostics.message ErrorMessages.forbiddenInlineRecordDeclaration) | _ -> () in let startFirstField = p.startPos in @@ -287140,10 +287457,10 @@ and parseRecordOrObjectType ~attrs p = in let () = match fields with - | [Parsetree.Oinherit {ptyp_loc}] -> - (* {...x}, spread without extra fields *) - Parser.err p ~startPos:startFirstField ~endPos:ptyp_loc.loc_end - (Diagnostics.message ErrorMessages.sameTypeSpread) + | [ Parsetree.Oinherit { ptyp_loc } ] -> + (* {...x}, spread without extra fields *) + Parser.err p ~startPos:startFirstField ~endPos:ptyp_loc.loc_end + (Diagnostics.message ErrorMessages.sameTypeSpread) | _ -> () in Parser.expect Rbrace p; @@ -287154,13 +287471,13 @@ and parseRecordOrObjectType ~attrs p = and parseTypeAlias p typ = match p.Parser.token with | As -> - Parser.next p; - Parser.expect SingleQuote p; - let ident, _loc = parseLident p in - (* TODO: how do we parse attributes here? *) - Ast_helper.Typ.alias - ~loc:(mkLoc typ.Parsetree.ptyp_loc.loc_start p.prevEndPos) - typ ident + Parser.next p; + Parser.expect SingleQuote p; + let ident, _loc = parseLident p in + (* TODO: how do we parse attributes here? *) + Ast_helper.Typ.alias + ~loc:(mkLoc typ.Parsetree.ptyp_loc.loc_start p.prevEndPos) + typ ident | _ -> typ (* type_parameter ::= @@ -287186,59 +287503,63 @@ and parseTypeParameter p = let attrs = parseAttributes p in match p.Parser.token with | Tilde -> ( - Parser.next p; - let name, loc = parseLident p in - let lblLocAttr = - (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) - in - Parser.expect ~grammar:Grammar.TypeExpression Colon p; - let typ = - let typ = parseTypExpr p in - {typ with ptyp_attributes = lblLocAttr :: typ.ptyp_attributes} - in - match p.Parser.token with - | Equal -> Parser.next p; - Parser.expect Question p; - Some (uncurried, attrs, Asttypes.Optional name, typ, startPos) - | _ -> Some (uncurried, attrs, Asttypes.Labelled name, typ, startPos)) - | Lident _ -> ( - let name, loc = parseLident p in - match p.token with - | Colon -> ( - let () = - let error = - Diagnostics.message - (ErrorMessages.missingTildeLabeledParameter name) - in - Parser.err ~startPos:loc.loc_start ~endPos:loc.loc_end p error + let name, loc = parseLident p in + let lblLocAttr = + (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) + in + Parser.expect ~grammar:Grammar.TypeExpression Colon p; + let typ = + let typ = parseTypExpr p in + { typ with ptyp_attributes = lblLocAttr :: typ.ptyp_attributes } in - Parser.next p; - let typ = parseTypExpr p in match p.Parser.token with | Equal -> - Parser.next p; - Parser.expect Question p; - Some (uncurried, attrs, Asttypes.Optional name, typ, startPos) + Parser.next p; + Parser.expect Question p; + Some (uncurried, attrs, Asttypes.Optional name, typ, startPos) | _ -> Some (uncurried, attrs, Asttypes.Labelled name, typ, startPos)) - | _ -> - let constr = Location.mkloc (Longident.Lident name) loc in - let args = parseTypeConstructorArgs ~constrName:constr p in - let typ = - Ast_helper.Typ.constr - ~loc:(mkLoc startPos p.prevEndPos) - ~attrs constr args - in + | Lident _ -> ( + let name, loc = parseLident p in + match p.token with + | Colon -> ( + let () = + let error = + Diagnostics.message + (ErrorMessages.missingTildeLabeledParameter name) + in + Parser.err ~startPos:loc.loc_start ~endPos:loc.loc_end p error + in + Parser.next p; + let typ = parseTypExpr p in + match p.Parser.token with + | Equal -> + Parser.next p; + Parser.expect Question p; + Some (uncurried, attrs, Asttypes.Optional name, typ, startPos) + | _ -> Some (uncurried, attrs, Asttypes.Labelled name, typ, startPos) + ) + | _ -> + let constr = Location.mkloc (Longident.Lident name) loc in + let args = parseTypeConstructorArgs ~constrName:constr p in + let typ = + Ast_helper.Typ.constr + ~loc:(mkLoc startPos p.prevEndPos) + ~attrs constr args + in - let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in - let typ = parseTypeAlias p typ in - Some (uncurried, [], Asttypes.Nolabel, typ, startPos)) + let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in + let typ = parseTypeAlias p typ in + Some (uncurried, [], Asttypes.Nolabel, typ, startPos)) | _ -> - let typ = parseTypExpr p in - let typWithAttributes = - {typ with ptyp_attributes = List.concat [attrs; typ.ptyp_attributes]} - in - Some (uncurried, [], Asttypes.Nolabel, typWithAttributes, startPos) + let typ = parseTypExpr p in + let typWithAttributes = + { + typ with + ptyp_attributes = List.concat [ attrs; typ.ptyp_attributes ]; + } + in + Some (uncurried, [], Asttypes.Nolabel, typWithAttributes, startPos) else None (* (int, ~x:string, float) *) @@ -287247,60 +287568,63 @@ and parseTypeParameters p = Parser.expect Lparen p; match p.Parser.token with | Rparen -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let unitConstr = Location.mkloc (Longident.Lident "unit") loc in - let typ = Ast_helper.Typ.constr unitConstr [] in - [(false, [], Asttypes.Nolabel, typ, startPos)] + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let unitConstr = Location.mkloc (Longident.Lident "unit") loc in + let typ = Ast_helper.Typ.constr unitConstr [] in + [ (false, [], Asttypes.Nolabel, typ, startPos) ] | _ -> - let params = - parseCommaDelimitedRegion ~grammar:Grammar.TypeParameters ~closing:Rparen - ~f:parseTypeParameter p - in - Parser.expect Rparen p; - params + let params = + parseCommaDelimitedRegion ~grammar:Grammar.TypeParameters + ~closing:Rparen ~f:parseTypeParameter p + in + Parser.expect Rparen p; + params and parseEs6ArrowType ~attrs p = let startPos = p.Parser.startPos in match p.Parser.token with | Tilde -> - Parser.next p; - let name, loc = parseLident p in - let lblLocAttr = (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) in - Parser.expect ~grammar:Grammar.TypeExpression Colon p; - let typ = - let typ = parseTypExpr ~alias:false ~es6Arrow:false p in - {typ with ptyp_attributes = lblLocAttr :: typ.ptyp_attributes} - in - let arg = - match p.Parser.token with - | Equal -> - Parser.next p; - Parser.expect Question p; - Asttypes.Optional name - | _ -> Asttypes.Labelled name - in - Parser.expect EqualGreater p; - let returnType = parseTypExpr ~alias:false p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.arrow ~loc ~attrs arg typ returnType + Parser.next p; + let name, loc = parseLident p in + let lblLocAttr = + (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) + in + Parser.expect ~grammar:Grammar.TypeExpression Colon p; + let typ = + let typ = parseTypExpr ~alias:false ~es6Arrow:false p in + { typ with ptyp_attributes = lblLocAttr :: typ.ptyp_attributes } + in + let arg = + match p.Parser.token with + | Equal -> + Parser.next p; + Parser.expect Question p; + Asttypes.Optional name + | _ -> Asttypes.Labelled name + in + Parser.expect EqualGreater p; + let returnType = parseTypExpr ~alias:false p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.arrow ~loc ~attrs arg typ returnType | _ -> - let parameters = parseTypeParameters p in - Parser.expect EqualGreater p; - let returnType = parseTypExpr ~alias:false p in - let endPos = p.prevEndPos in - let typ = - List.fold_right - (fun (uncurried, attrs, argLbl, typ, startPos) t -> - let attrs = if uncurried then uncurryAttr :: attrs else attrs in - Ast_helper.Typ.arrow ~loc:(mkLoc startPos endPos) ~attrs argLbl typ t) - parameters returnType - in - { - typ with - ptyp_attributes = List.concat [typ.ptyp_attributes; attrs]; - ptyp_loc = mkLoc startPos p.prevEndPos; - } + let parameters = parseTypeParameters p in + Parser.expect EqualGreater p; + let returnType = parseTypExpr ~alias:false p in + let endPos = p.prevEndPos in + let typ = + List.fold_right + (fun (uncurried, attrs, argLbl, typ, startPos) t -> + let attrs = if uncurried then uncurryAttr :: attrs else attrs in + Ast_helper.Typ.arrow ~loc:(mkLoc startPos endPos) ~attrs argLbl typ + t) + parameters returnType + in + { + typ with + ptyp_attributes = List.concat [ typ.ptyp_attributes; attrs ]; + ptyp_loc = mkLoc startPos p.prevEndPos; + } (* * typexpr ::= @@ -287326,9 +287650,7 @@ and parseTypExpr ?attrs ?(es6Arrow = true) ?(alias = true) p = (* Parser.leaveBreadcrumb p Grammar.TypeExpression; *) let startPos = p.Parser.startPos in let attrs = - match attrs with - | Some attrs -> attrs - | None -> parseAttributes p + match attrs with Some attrs -> attrs | None -> parseAttributes p in let typ = if es6Arrow && isEs6ArrowType p then parseEs6ArrowType ~attrs p @@ -287343,12 +287665,12 @@ and parseTypExpr ?attrs ?(es6Arrow = true) ?(alias = true) p = and parseArrowTypeRest ~es6Arrow ~startPos typ p = match p.Parser.token with | (EqualGreater | MinusGreater) as token when es6Arrow == true -> - (* error recovery *) - if token = MinusGreater then Parser.expect EqualGreater p; - Parser.next p; - let returnType = parseTypExpr ~alias:false p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType + (* error recovery *) + if token = MinusGreater then Parser.expect EqualGreater p; + Parser.next p; + let returnType = parseTypExpr ~alias:false p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType | _ -> typ and parseTypExprRegion p = @@ -287363,9 +287685,9 @@ and parseTupleType ~attrs ~first ~startPos p = Parser.expect Rparen p; let () = match typexprs with - | [_] -> - Parser.err ~startPos ~endPos:p.prevEndPos p - (Diagnostics.message ErrorMessages.tupleSingleElement) + | [ _ ] -> + Parser.err ~startPos ~endPos:p.prevEndPos p + (Diagnostics.message ErrorMessages.tupleSingleElement) | _ -> () in let tupleLoc = mkLoc startPos p.prevEndPos in @@ -287384,34 +287706,37 @@ and parseTypeConstructorArgs ~constrName p = let openingStartPos = p.startPos in match opening with | LessThan | Lparen -> - Scanner.setDiamondMode p.scanner; - Parser.next p; - let typeArgs = - (* TODO: change Grammar.TypExprList to TypArgList!!! Why did I wrote this? *) - parseCommaDelimitedRegion ~grammar:Grammar.TypExprList - ~closing:GreaterThan ~f:parseTypeConstructorArgRegion p - in - let () = - match p.token with - | Rparen when opening = Token.Lparen -> - let typ = Ast_helper.Typ.constr constrName typeArgs in - let msg = - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.text "Type parameters require angle brackets:"; - Doc.indent - (Doc.concat - [Doc.line; ResPrinter.printTypExpr typ CommentTable.empty]); - ]) - |> Doc.toString ~width:80 - in - Parser.err ~startPos:openingStartPos p (Diagnostics.message msg); - Parser.next p - | _ -> Parser.expect GreaterThan p - in - Scanner.popMode p.scanner Diamond; - typeArgs + Scanner.setDiamondMode p.scanner; + Parser.next p; + let typeArgs = + (* TODO: change Grammar.TypExprList to TypArgList!!! Why did I wrote this? *) + parseCommaDelimitedRegion ~grammar:Grammar.TypExprList + ~closing:GreaterThan ~f:parseTypeConstructorArgRegion p + in + let () = + match p.token with + | Rparen when opening = Token.Lparen -> + let typ = Ast_helper.Typ.constr constrName typeArgs in + let msg = + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.text "Type parameters require angle brackets:"; + Doc.indent + (Doc.concat + [ + Doc.line; + ResPrinter.printTypExpr typ CommentTable.empty; + ]); + ]) + |> Doc.toString ~width:80 + in + Parser.err ~startPos:openingStartPos p (Diagnostics.message msg); + Parser.next p + | _ -> Parser.expect GreaterThan p + in + Scanner.popMode p.scanner Diamond; + typeArgs | _ -> [] (* string-field-decl ::= @@ -287421,26 +287746,26 @@ and parseStringFieldDeclaration p = let attrs = parseAttributes p in match p.Parser.token with | String name -> - let nameStartPos = p.startPos in - let nameEndPos = p.endPos in - Parser.next p; - let fieldName = Location.mkloc name (mkLoc nameStartPos nameEndPos) in - Parser.expect ~grammar:Grammar.TypeExpression Colon p; - let typ = parsePolyTypeExpr p in - Some (Parsetree.Otag (fieldName, attrs, typ)) + let nameStartPos = p.startPos in + let nameEndPos = p.endPos in + Parser.next p; + let fieldName = Location.mkloc name (mkLoc nameStartPos nameEndPos) in + Parser.expect ~grammar:Grammar.TypeExpression Colon p; + let typ = parsePolyTypeExpr p in + Some (Parsetree.Otag (fieldName, attrs, typ)) | DotDotDot -> - Parser.next p; - let typ = parseTypExpr p in - Some (Parsetree.Oinherit typ) + Parser.next p; + let typ = parseTypExpr p in + Some (Parsetree.Oinherit typ) | Lident name -> - let nameLoc = mkLoc p.startPos p.endPos in - Parser.err p - (Diagnostics.message (ErrorMessages.objectQuotedFieldName name)); - Parser.next p; - let fieldName = Location.mkloc name nameLoc in - Parser.expect ~grammar:Grammar.TypeExpression Colon p; - let typ = parsePolyTypeExpr p in - Some (Parsetree.Otag (fieldName, attrs, typ)) + let nameLoc = mkLoc p.startPos p.endPos in + Parser.err p + (Diagnostics.message (ErrorMessages.objectQuotedFieldName name)); + Parser.next p; + let fieldName = Location.mkloc name nameLoc in + Parser.expect ~grammar:Grammar.TypeExpression Colon p; + let typ = parsePolyTypeExpr p in + Some (Parsetree.Otag (fieldName, attrs, typ)) | _token -> None (* field-decl ::= @@ -287453,19 +287778,18 @@ and parseFieldDeclaration p = if Parser.optional p Token.Mutable then Asttypes.Mutable else Asttypes.Immutable in - let lident, loc = - match p.token with - | _ -> parseLident p - in + let lident, loc = match p.token with _ -> parseLident p in let optional = parseOptionalLabel p in let name = Location.mkloc lident loc in let typ = match p.Parser.token with | Colon -> - Parser.next p; - parsePolyTypeExpr p + Parser.next p; + parsePolyTypeExpr p | _ -> - Ast_helper.Typ.constr ~loc:name.loc {name with txt = Lident name.txt} [] + Ast_helper.Typ.constr ~loc:name.loc + { name with txt = Lident name.txt } + [] in let loc = mkLoc startPos typ.ptyp_loc.loc_end in (optional, Ast_helper.Type.field ~attrs ~loc ~mut name typ) @@ -287479,22 +287803,22 @@ and parseFieldDeclarationRegion p = in match p.token with | Lident _ -> - let lident, loc = parseLident p in - let name = Location.mkloc lident loc in - let optional = parseOptionalLabel p in - let typ = - match p.Parser.token with - | Colon -> - Parser.next p; - parsePolyTypeExpr p - | _ -> - Ast_helper.Typ.constr ~loc:name.loc ~attrs - {name with txt = Lident name.txt} - [] - in - let loc = mkLoc startPos typ.ptyp_loc.loc_end in - let attrs = if optional then optionalAttr :: attrs else attrs in - Some (Ast_helper.Type.field ~attrs ~loc ~mut name typ) + let lident, loc = parseLident p in + let name = Location.mkloc lident loc in + let optional = parseOptionalLabel p in + let typ = + match p.Parser.token with + | Colon -> + Parser.next p; + parsePolyTypeExpr p + | _ -> + Ast_helper.Typ.constr ~loc:name.loc ~attrs + { name with txt = Lident name.txt } + [] + in + let loc = mkLoc startPos typ.ptyp_loc.loc_end in + let attrs = if optional then optionalAttr :: attrs else attrs in + Some (Ast_helper.Type.field ~attrs ~loc ~mut name typ) | _ -> None (* record-decl ::= @@ -287526,177 +287850,187 @@ and parseConstrDeclArgs p = let constrArgs = match p.Parser.token with | Lparen -> ( - Parser.next p; - (* TODO: this could use some cleanup/stratification *) - match p.Parser.token with - | Lbrace -> ( - let lbrace = p.startPos in Parser.next p; - let startPos = p.Parser.startPos in + (* TODO: this could use some cleanup/stratification *) match p.Parser.token with - | DotDot | Dot -> - let closedFlag = - match p.token with - | DotDot -> - Parser.next p; - Asttypes.Open - | Dot -> - Parser.next p; - Asttypes.Closed - | _ -> Asttypes.Closed - in - let fields = - parseCommaDelimitedRegion ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace ~f:parseStringFieldDeclaration p - in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let typ = Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag in - Parser.optional p Comma |> ignore; - let moreArgs = - parseCommaDelimitedRegion ~grammar:Grammar.TypExprList - ~closing:Rparen ~f:parseTypExprRegion p - in - Parser.expect Rparen p; - Parsetree.Pcstr_tuple (typ :: moreArgs) - | DotDotDot -> - let dotdotdotStart = p.startPos in - let dotdotdotEnd = p.endPos in - (* start of object type spreading, e.g. `User({...a, "u": int})` *) - Parser.next p; - let typ = parseTypExpr p in - let () = - match p.token with - | Rbrace -> - (* {...x}, spread without extra fields *) - Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p - (Diagnostics.message ErrorMessages.sameTypeSpread); - Parser.next p - | _ -> Parser.expect Comma p - in - let () = - match p.token with - | Lident _ -> - Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p - (Diagnostics.message ErrorMessages.spreadInRecordDeclaration) - | _ -> () - in - let fields = - Parsetree.Oinherit typ - :: parseCommaDelimitedRegion - ~grammar:Grammar.StringFieldDeclarations ~closing:Rbrace - ~f:parseStringFieldDeclaration p - in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let typ = - Ast_helper.Typ.object_ ~loc fields Asttypes.Closed - |> parseTypeAlias p - in - let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in - Parser.optional p Comma |> ignore; - let moreArgs = - parseCommaDelimitedRegion ~grammar:Grammar.TypExprList - ~closing:Rparen ~f:parseTypExprRegion p - in - Parser.expect Rparen p; - Parsetree.Pcstr_tuple (typ :: moreArgs) - | _ -> ( - let attrs = parseAttributes p in - match p.Parser.token with - | String _ -> - let closedFlag = Asttypes.Closed in - let fields = - match attrs with - | [] -> - parseCommaDelimitedRegion - ~grammar:Grammar.StringFieldDeclarations ~closing:Rbrace - ~f:parseStringFieldDeclaration p - | attrs -> - let first = - Parser.leaveBreadcrumb p Grammar.StringFieldDeclarations; - let field = - match parseStringFieldDeclaration p with - | Some field -> field - | None -> assert false - in - (* parse comma after first *) - let () = - match p.Parser.token with - | Rbrace | Eof -> () - | Comma -> Parser.next p - | _ -> Parser.expect Comma p - in - Parser.eatBreadcrumb p; - match field with - | Parsetree.Otag (label, _, ct) -> - Parsetree.Otag (label, attrs, ct) - | Oinherit ct -> Oinherit ct + | Lbrace -> ( + let lbrace = p.startPos in + Parser.next p; + let startPos = p.Parser.startPos in + match p.Parser.token with + | DotDot | Dot -> + let closedFlag = + match p.token with + | DotDot -> + Parser.next p; + Asttypes.Open + | Dot -> + Parser.next p; + Asttypes.Closed + | _ -> Asttypes.Closed in - first - :: parseCommaDelimitedRegion - ~grammar:Grammar.StringFieldDeclarations ~closing:Rbrace - ~f:parseStringFieldDeclaration p - in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let typ = - Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag - |> parseTypeAlias p - in - let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in - Parser.optional p Comma |> ignore; - let moreArgs = + let fields = + parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations ~closing:Rbrace + ~f:parseStringFieldDeclaration p + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let typ = + Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag + in + Parser.optional p Comma |> ignore; + let moreArgs = + parseCommaDelimitedRegion ~grammar:Grammar.TypExprList + ~closing:Rparen ~f:parseTypExprRegion p + in + Parser.expect Rparen p; + Parsetree.Pcstr_tuple (typ :: moreArgs) + | DotDotDot -> + let dotdotdotStart = p.startPos in + let dotdotdotEnd = p.endPos in + (* start of object type spreading, e.g. `User({...a, "u": int})` *) + Parser.next p; + let typ = parseTypExpr p in + let () = + match p.token with + | Rbrace -> + (* {...x}, spread without extra fields *) + Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p + (Diagnostics.message ErrorMessages.sameTypeSpread); + Parser.next p + | _ -> Parser.expect Comma p + in + let () = + match p.token with + | Lident _ -> + Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p + (Diagnostics.message + ErrorMessages.spreadInRecordDeclaration) + | _ -> () + in + let fields = + Parsetree.Oinherit typ + :: parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations ~closing:Rbrace + ~f:parseStringFieldDeclaration p + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let typ = + Ast_helper.Typ.object_ ~loc fields Asttypes.Closed + |> parseTypeAlias p + in + let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in + Parser.optional p Comma |> ignore; + let moreArgs = + parseCommaDelimitedRegion ~grammar:Grammar.TypExprList + ~closing:Rparen ~f:parseTypExprRegion p + in + Parser.expect Rparen p; + Parsetree.Pcstr_tuple (typ :: moreArgs) + | _ -> ( + let attrs = parseAttributes p in + match p.Parser.token with + | String _ -> + let closedFlag = Asttypes.Closed in + let fields = + match attrs with + | [] -> + parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace ~f:parseStringFieldDeclaration p + | attrs -> + let first = + Parser.leaveBreadcrumb p + Grammar.StringFieldDeclarations; + let field = + match parseStringFieldDeclaration p with + | Some field -> field + | None -> assert false + in + (* parse comma after first *) + let () = + match p.Parser.token with + | Rbrace | Eof -> () + | Comma -> Parser.next p + | _ -> Parser.expect Comma p + in + Parser.eatBreadcrumb p; + match field with + | Parsetree.Otag (label, _, ct) -> + Parsetree.Otag (label, attrs, ct) + | Oinherit ct -> Oinherit ct + in + first + :: parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace ~f:parseStringFieldDeclaration p + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let typ = + Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag + |> parseTypeAlias p + in + let typ = + parseArrowTypeRest ~es6Arrow:true ~startPos typ p + in + Parser.optional p Comma |> ignore; + let moreArgs = + parseCommaDelimitedRegion ~grammar:Grammar.TypExprList + ~closing:Rparen ~f:parseTypExprRegion p + in + Parser.expect Rparen p; + Parsetree.Pcstr_tuple (typ :: moreArgs) + | _ -> + let fields = + match attrs with + | [] -> + parseCommaDelimitedRegion + ~grammar:Grammar.FieldDeclarations ~closing:Rbrace + ~f:parseFieldDeclarationRegion p + | attrs -> + let first = + let optional, field = parseFieldDeclaration p in + let attrs = + if optional then optionalAttr :: attrs else attrs + in + Parser.expect Comma p; + { field with Parsetree.pld_attributes = attrs } + in + first + :: parseCommaDelimitedRegion + ~grammar:Grammar.FieldDeclarations + ~closing:Rbrace ~f:parseFieldDeclarationRegion p + in + let () = + match fields with + | [] -> + Parser.err ~startPos:lbrace p + (Diagnostics.message + "An inline record declaration needs at least \ + one field") + | _ -> () + in + Parser.expect Rbrace p; + Parser.optional p Comma |> ignore; + Parser.expect Rparen p; + Parsetree.Pcstr_record fields)) + | _ -> + let args = parseCommaDelimitedRegion ~grammar:Grammar.TypExprList ~closing:Rparen ~f:parseTypExprRegion p in Parser.expect Rparen p; - Parsetree.Pcstr_tuple (typ :: moreArgs) - | _ -> - let fields = - match attrs with - | [] -> - parseCommaDelimitedRegion ~grammar:Grammar.FieldDeclarations - ~closing:Rbrace ~f:parseFieldDeclarationRegion p - | attrs -> - let first = - let optional, field = parseFieldDeclaration p in - let attrs = - if optional then optionalAttr :: attrs else attrs - in - Parser.expect Comma p; - {field with Parsetree.pld_attributes = attrs} - in - first - :: parseCommaDelimitedRegion ~grammar:Grammar.FieldDeclarations - ~closing:Rbrace ~f:parseFieldDeclarationRegion p - in - let () = - match fields with - | [] -> - Parser.err ~startPos:lbrace p - (Diagnostics.message - "An inline record declaration needs at least one field") - | _ -> () - in - Parser.expect Rbrace p; - Parser.optional p Comma |> ignore; - Parser.expect Rparen p; - Parsetree.Pcstr_record fields)) - | _ -> - let args = - parseCommaDelimitedRegion ~grammar:Grammar.TypExprList ~closing:Rparen - ~f:parseTypExprRegion p - in - Parser.expect Rparen p; - Parsetree.Pcstr_tuple args) + Parsetree.Pcstr_tuple args) | _ -> Pcstr_tuple [] in let res = match p.Parser.token with | Colon -> - Parser.next p; - Some (parseTypExpr p) + Parser.next p; + Some (parseTypExpr p) | _ -> None in (constrArgs, res) @@ -287709,9 +288043,9 @@ and parseConstrDeclArgs p = and parseTypeConstructorDeclarationWithBar p = match p.Parser.token with | Bar -> - let startPos = p.Parser.startPos in - Parser.next p; - Some (parseTypeConstructorDeclaration ~startPos p) + let startPos = p.Parser.startPos in + Parser.next p; + Some (parseTypeConstructorDeclaration ~startPos p) | _ -> None and parseTypeConstructorDeclaration ~startPos p = @@ -287719,25 +288053,25 @@ and parseTypeConstructorDeclaration ~startPos p = let attrs = parseAttributes p in match p.Parser.token with | Uident uident -> - let uidentLoc = mkLoc p.startPos p.endPos in - Parser.next p; - let args, res = parseConstrDeclArgs p in - Parser.eatBreadcrumb p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Type.constructor ~loc ~attrs ?res ~args - (Location.mkloc uident uidentLoc) + let uidentLoc = mkLoc p.startPos p.endPos in + Parser.next p; + let args, res = parseConstrDeclArgs p in + Parser.eatBreadcrumb p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Type.constructor ~loc ~attrs ?res ~args + (Location.mkloc uident uidentLoc) | t -> - Parser.err p (Diagnostics.uident t); - Ast_helper.Type.constructor (Location.mknoloc "_") + Parser.err p (Diagnostics.uident t); + Ast_helper.Type.constructor (Location.mknoloc "_") (* [|] constr-decl { | constr-decl } *) and parseTypeConstructorDeclarations ?first p = let firstConstrDecl = match first with | None -> - let startPos = p.Parser.startPos in - ignore (Parser.optional p Token.Bar); - parseTypeConstructorDeclaration ~startPos p + let startPos = p.Parser.startPos in + ignore (Parser.optional p Token.Bar); + parseTypeConstructorDeclaration ~startPos p | Some firstConstrDecl -> firstConstrDecl in firstConstrDecl @@ -287764,15 +288098,15 @@ and parseTypeRepresentation p = let kind = match p.Parser.token with | Bar | Uident _ -> - Parsetree.Ptype_variant (parseTypeConstructorDeclarations p) + Parsetree.Ptype_variant (parseTypeConstructorDeclarations p) | Lbrace -> Parsetree.Ptype_record (parseRecordDeclaration p) | DotDot -> - Parser.next p; - Ptype_open + Parser.next p; + Ptype_open | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - (* TODO: I have no idea if this is even remotely a good idea *) - Parsetree.Ptype_variant [] + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + (* TODO: I have no idea if this is even remotely a good idea *) + Parsetree.Ptype_variant [] in Parser.eatBreadcrumb p; (privateFlag, kind) @@ -287791,36 +288125,36 @@ and parseTypeParam p = let variance = match p.Parser.token with | Plus -> - Parser.next p; - Asttypes.Covariant + Parser.next p; + Asttypes.Covariant | Minus -> - Parser.next p; - Contravariant + Parser.next p; + Contravariant | _ -> Invariant in match p.Parser.token with | SingleQuote -> - Parser.next p; - let ident, loc = - if p.Parser.token = Eof then ( - Parser.err ~startPos:p.startPos p - (Diagnostics.unexpected p.Parser.token p.breadcrumbs); - ("", mkLoc p.startPos p.prevEndPos)) - else parseIdent ~msg:ErrorMessages.typeParam ~startPos:p.startPos p - in - Some (Ast_helper.Typ.var ~loc ident, variance) + Parser.next p; + let ident, loc = + if p.Parser.token = Eof then ( + Parser.err ~startPos:p.startPos p + (Diagnostics.unexpected p.Parser.token p.breadcrumbs); + ("", mkLoc p.startPos p.prevEndPos)) + else parseIdent ~msg:ErrorMessages.typeParam ~startPos:p.startPos p + in + Some (Ast_helper.Typ.var ~loc ident, variance) | Underscore -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Some (Ast_helper.Typ.any ~loc (), variance) + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Some (Ast_helper.Typ.any ~loc (), variance) | (Uident _ | Lident _) as token -> - Parser.err p - (Diagnostics.message - ("Type params start with a singlequote: '" ^ Token.toString token)); - let ident, loc = - parseIdent ~msg:ErrorMessages.typeParam ~startPos:p.startPos p - in - Some (Ast_helper.Typ.var ~loc ident, variance) + Parser.err p + (Diagnostics.message + ("Type params start with a singlequote: '" ^ Token.toString token)); + let ident, loc = + parseIdent ~msg:ErrorMessages.typeParam ~startPos:p.startPos p + in + Some (Ast_helper.Typ.var ~loc ident, variance) | _token -> None (* type-params ::= @@ -287835,42 +288169,43 @@ and parseTypeParams ~parent p = let opening = p.Parser.token in match opening with | (LessThan | Lparen) when p.startPos.pos_lnum == p.prevEndPos.pos_lnum -> - Scanner.setDiamondMode p.scanner; - let openingStartPos = p.startPos in - Parser.leaveBreadcrumb p Grammar.TypeParams; - Parser.next p; - let params = - parseCommaDelimitedRegion ~grammar:Grammar.TypeParams ~closing:GreaterThan - ~f:parseTypeParam p - in - let () = - match p.token with - | Rparen when opening = Token.Lparen -> - let msg = - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.text "Type parameters require angle brackets:"; - Doc.indent - (Doc.concat - [ - Doc.line; - Doc.concat + Scanner.setDiamondMode p.scanner; + let openingStartPos = p.startPos in + Parser.leaveBreadcrumb p Grammar.TypeParams; + Parser.next p; + let params = + parseCommaDelimitedRegion ~grammar:Grammar.TypeParams + ~closing:GreaterThan ~f:parseTypeParam p + in + let () = + match p.token with + | Rparen when opening = Token.Lparen -> + let msg = + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.text "Type parameters require angle brackets:"; + Doc.indent + (Doc.concat [ - ResPrinter.printLongident parent.Location.txt; - ResPrinter.printTypeParams params CommentTable.empty; - ]; - ]); - ]) - |> Doc.toString ~width:80 - in - Parser.err ~startPos:openingStartPos p (Diagnostics.message msg); - Parser.next p - | _ -> Parser.expect GreaterThan p - in - Scanner.popMode p.scanner Diamond; - Parser.eatBreadcrumb p; - params + Doc.line; + Doc.concat + [ + ResPrinter.printLongident parent.Location.txt; + ResPrinter.printTypeParams params + CommentTable.empty; + ]; + ]); + ]) + |> Doc.toString ~width:80 + in + Parser.err ~startPos:openingStartPos p (Diagnostics.message msg); + Parser.next p + | _ -> Parser.expect GreaterThan p + in + Scanner.popMode p.scanner Diamond; + Parser.eatBreadcrumb p; + params | _ -> [] (* type-constraint ::= constraint ' ident = typexpr *) @@ -287878,20 +288213,20 @@ and parseTypeConstraint p = let startPos = p.Parser.startPos in match p.Parser.token with | Token.Constraint -> ( - Parser.next p; - Parser.expect SingleQuote p; - match p.Parser.token with - | Lident ident -> - let identLoc = mkLoc startPos p.endPos in Parser.next p; - Parser.expect Equal p; - let typ = parseTypExpr p in - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Typ.var ~loc:identLoc ident, typ, loc) - | t -> - Parser.err p (Diagnostics.lident t); - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Typ.any (), parseTypExpr p, loc)) + Parser.expect SingleQuote p; + match p.Parser.token with + | Lident ident -> + let identLoc = mkLoc startPos p.endPos in + Parser.next p; + Parser.expect Equal p; + let typ = parseTypExpr p in + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Typ.var ~loc:identLoc ident, typ, loc) + | t -> + Parser.err p (Diagnostics.lident t); + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Typ.any (), parseTypExpr p, loc)) | _ -> None (* type-constraints ::= @@ -287907,147 +288242,72 @@ and parseTypeEquationOrConstrDecl p = let uidentStartPos = p.Parser.startPos in match p.Parser.token with | Uident uident -> ( - Parser.next p; - match p.Parser.token with - | Dot -> ( Parser.next p; - let typeConstr = - parseValuePathTail p uidentStartPos (Longident.Lident uident) - in - let loc = mkLoc uidentStartPos p.prevEndPos in - let typ = - parseTypeAlias p - (Ast_helper.Typ.constr ~loc typeConstr - (parseTypeConstructorArgs ~constrName:typeConstr p)) - in - match p.token with - | Equal -> - Parser.next p; - let priv, kind = parseTypeRepresentation p in - (Some typ, priv, kind) - | EqualGreater -> - Parser.next p; - let returnType = parseTypExpr ~alias:false p in - let loc = mkLoc uidentStartPos p.prevEndPos in - let arrowType = - Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType - in - let typ = parseTypeAlias p arrowType in - (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) - | _ -> (Some typ, Asttypes.Public, Parsetree.Ptype_abstract)) - | _ -> - let uidentEndPos = p.prevEndPos in - let args, res = parseConstrDeclArgs p in - let first = - Some - (let uidentLoc = mkLoc uidentStartPos uidentEndPos in - Ast_helper.Type.constructor - ~loc:(mkLoc uidentStartPos p.prevEndPos) - ?res ~args - (Location.mkloc uident uidentLoc)) - in - ( None, - Asttypes.Public, - Parsetree.Ptype_variant (parseTypeConstructorDeclarations p ?first) )) + match p.Parser.token with + | Dot -> ( + Parser.next p; + let typeConstr = + parseValuePathTail p uidentStartPos (Longident.Lident uident) + in + let loc = mkLoc uidentStartPos p.prevEndPos in + let typ = + parseTypeAlias p + (Ast_helper.Typ.constr ~loc typeConstr + (parseTypeConstructorArgs ~constrName:typeConstr p)) + in + match p.token with + | Equal -> + Parser.next p; + let priv, kind = parseTypeRepresentation p in + (Some typ, priv, kind) + | EqualGreater -> + Parser.next p; + let returnType = parseTypExpr ~alias:false p in + let loc = mkLoc uidentStartPos p.prevEndPos in + let arrowType = + Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType + in + let typ = parseTypeAlias p arrowType in + (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) + | _ -> (Some typ, Asttypes.Public, Parsetree.Ptype_abstract)) + | _ -> + let uidentEndPos = p.prevEndPos in + let args, res = parseConstrDeclArgs p in + let first = + Some + (let uidentLoc = mkLoc uidentStartPos uidentEndPos in + Ast_helper.Type.constructor + ~loc:(mkLoc uidentStartPos p.prevEndPos) + ?res ~args + (Location.mkloc uident uidentLoc)) + in + ( None, + Asttypes.Public, + Parsetree.Ptype_variant (parseTypeConstructorDeclarations p ?first) + )) | t -> - Parser.err p (Diagnostics.uident t); - (* TODO: is this a good idea? *) - (None, Asttypes.Public, Parsetree.Ptype_abstract) + Parser.err p (Diagnostics.uident t); + (* TODO: is this a good idea? *) + (None, Asttypes.Public, Parsetree.Ptype_abstract) and parseRecordOrObjectDecl p = let startPos = p.Parser.startPos in Parser.expect Lbrace p; match p.Parser.token with | DotDot | Dot -> - let closedFlag = - match p.token with - | DotDot -> - Parser.next p; - Asttypes.Open - | Dot -> - Parser.next p; - Asttypes.Closed - | _ -> Asttypes.Closed - in - let fields = - parseCommaDelimitedRegion ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace ~f:parseStringFieldDeclaration p - in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let typ = - Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag - |> parseTypeAlias p - in - let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in - (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) - | DotDotDot -> - let dotdotdotStart = p.startPos in - let dotdotdotEnd = p.endPos in - (* start of object type spreading, e.g. `type u = {...a, "u": int}` *) - Parser.next p; - let typ = parseTypExpr p in - let () = - match p.token with - | Rbrace -> - (* {...x}, spread without extra fields *) - Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p - (Diagnostics.message ErrorMessages.sameTypeSpread); - Parser.next p - | _ -> Parser.expect Comma p - in - let () = - match p.token with - | Lident _ -> - Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p - (Diagnostics.message ErrorMessages.spreadInRecordDeclaration) - | _ -> () - in - let fields = - Parsetree.Oinherit typ - :: parseCommaDelimitedRegion ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace ~f:parseStringFieldDeclaration p - in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let typ = - Ast_helper.Typ.object_ ~loc fields Asttypes.Closed |> parseTypeAlias p - in - let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in - (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) - | _ -> ( - let attrs = parseAttributes p in - match p.Parser.token with - | String _ -> - let closedFlag = Asttypes.Closed in + let closedFlag = + match p.token with + | DotDot -> + Parser.next p; + Asttypes.Open + | Dot -> + Parser.next p; + Asttypes.Closed + | _ -> Asttypes.Closed + in let fields = - match attrs with - | [] -> - parseCommaDelimitedRegion ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace ~f:parseStringFieldDeclaration p - | attrs -> - let first = - Parser.leaveBreadcrumb p Grammar.StringFieldDeclarations; - let field = - match parseStringFieldDeclaration p with - | Some field -> field - | None -> assert false - in - (* parse comma after first *) - let () = - match p.Parser.token with - | Rbrace | Eof -> () - | Comma -> Parser.next p - | _ -> Parser.expect Comma p - in - Parser.eatBreadcrumb p; - match field with - | Parsetree.Otag (label, _, ct) -> Parsetree.Otag (label, attrs, ct) - | Oinherit ct -> Oinherit ct - in - first - :: parseCommaDelimitedRegion ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace ~f:parseStringFieldDeclaration p + parseCommaDelimitedRegion ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace ~f:parseStringFieldDeclaration p in Parser.expect Rbrace p; let loc = mkLoc startPos p.prevEndPos in @@ -288057,54 +288317,135 @@ and parseRecordOrObjectDecl p = in let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) - | _ -> - Parser.leaveBreadcrumb p Grammar.RecordDecl; + | DotDotDot -> + let dotdotdotStart = p.startPos in + let dotdotdotEnd = p.endPos in + (* start of object type spreading, e.g. `type u = {...a, "u": int}` *) + Parser.next p; + let typ = parseTypExpr p in + let () = + match p.token with + | Rbrace -> + (* {...x}, spread without extra fields *) + Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p + (Diagnostics.message ErrorMessages.sameTypeSpread); + Parser.next p + | _ -> Parser.expect Comma p + in + let () = + match p.token with + | Lident _ -> + Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p + (Diagnostics.message ErrorMessages.spreadInRecordDeclaration) + | _ -> () + in let fields = - (* XXX *) - match attrs with - | [] -> - parseCommaDelimitedRegion ~grammar:Grammar.FieldDeclarations - ~closing:Rbrace ~f:parseFieldDeclarationRegion p - | attr :: _ as attrs -> - let first = - let optional, field = parseFieldDeclaration p in - let attrs = if optional then optionalAttr :: attrs else attrs in - Parser.optional p Comma |> ignore; - { - field with - Parsetree.pld_attributes = attrs; - pld_loc = - { - field.Parsetree.pld_loc with - loc_start = (attr |> fst).loc.loc_start; - }; - } - in - first - :: parseCommaDelimitedRegion ~grammar:Grammar.FieldDeclarations - ~closing:Rbrace ~f:parseFieldDeclarationRegion p + Parsetree.Oinherit typ + :: parseCommaDelimitedRegion ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace ~f:parseStringFieldDeclaration p in Parser.expect Rbrace p; - Parser.eatBreadcrumb p; - (None, Asttypes.Public, Parsetree.Ptype_record fields)) + let loc = mkLoc startPos p.prevEndPos in + let typ = + Ast_helper.Typ.object_ ~loc fields Asttypes.Closed |> parseTypeAlias p + in + let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in + (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) + | _ -> ( + let attrs = parseAttributes p in + match p.Parser.token with + | String _ -> + let closedFlag = Asttypes.Closed in + let fields = + match attrs with + | [] -> + parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations ~closing:Rbrace + ~f:parseStringFieldDeclaration p + | attrs -> + let first = + Parser.leaveBreadcrumb p Grammar.StringFieldDeclarations; + let field = + match parseStringFieldDeclaration p with + | Some field -> field + | None -> assert false + in + (* parse comma after first *) + let () = + match p.Parser.token with + | Rbrace | Eof -> () + | Comma -> Parser.next p + | _ -> Parser.expect Comma p + in + Parser.eatBreadcrumb p; + match field with + | Parsetree.Otag (label, _, ct) -> + Parsetree.Otag (label, attrs, ct) + | Oinherit ct -> Oinherit ct + in + first + :: parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations ~closing:Rbrace + ~f:parseStringFieldDeclaration p + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let typ = + Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag + |> parseTypeAlias p + in + let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in + (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) + | _ -> + Parser.leaveBreadcrumb p Grammar.RecordDecl; + let fields = + (* XXX *) + match attrs with + | [] -> + parseCommaDelimitedRegion ~grammar:Grammar.FieldDeclarations + ~closing:Rbrace ~f:parseFieldDeclarationRegion p + | attr :: _ as attrs -> + let first = + let optional, field = parseFieldDeclaration p in + let attrs = + if optional then optionalAttr :: attrs else attrs + in + Parser.optional p Comma |> ignore; + { + field with + Parsetree.pld_attributes = attrs; + pld_loc = + { + field.Parsetree.pld_loc with + loc_start = (attr |> fst).loc.loc_start; + }; + } + in + first + :: parseCommaDelimitedRegion ~grammar:Grammar.FieldDeclarations + ~closing:Rbrace ~f:parseFieldDeclarationRegion p + in + Parser.expect Rbrace p; + Parser.eatBreadcrumb p; + (None, Asttypes.Public, Parsetree.Ptype_record fields)) and parsePrivateEqOrRepr p = Parser.expect Private p; match p.Parser.token with | Lbrace -> - let manifest, _, kind = parseRecordOrObjectDecl p in - (manifest, Asttypes.Private, kind) + let manifest, _, kind = parseRecordOrObjectDecl p in + (manifest, Asttypes.Private, kind) | Uident _ -> - let manifest, _, kind = parseTypeEquationOrConstrDecl p in - (manifest, Asttypes.Private, kind) + let manifest, _, kind = parseTypeEquationOrConstrDecl p in + (manifest, Asttypes.Private, kind) | Bar | DotDot -> - let _, kind = parseTypeRepresentation p in - (None, Asttypes.Private, kind) + let _, kind = parseTypeRepresentation p in + (None, Asttypes.Private, kind) | t when Grammar.isTypExprStart t -> - (Some (parseTypExpr p), Asttypes.Private, Parsetree.Ptype_abstract) + (Some (parseTypExpr p), Asttypes.Private, Parsetree.Ptype_abstract) | _ -> - let _, kind = parseTypeRepresentation p in - (None, Asttypes.Private, kind) + let _, kind = parseTypeRepresentation p in + (None, Asttypes.Private, kind) (* polymorphic-variant-type ::= @@ -288126,49 +288467,49 @@ and parsePolymorphicVariantType ~attrs p = Parser.expect Lbracket p; match p.token with | GreaterThan -> - Parser.next p; - let rowFields = - match p.token with - | Rbracket -> [] - | Bar -> parseTagSpecs p - | _ -> - let rowField = parseTagSpec p in - rowField :: parseTagSpecs p - in - let variant = - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.variant ~attrs ~loc rowFields Open None - in - Parser.expect Rbracket p; - variant + Parser.next p; + let rowFields = + match p.token with + | Rbracket -> [] + | Bar -> parseTagSpecs p + | _ -> + let rowField = parseTagSpec p in + rowField :: parseTagSpecs p + in + let variant = + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.variant ~attrs ~loc rowFields Open None + in + Parser.expect Rbracket p; + variant | LessThan -> - Parser.next p; - Parser.optional p Bar |> ignore; - let rowField = parseTagSpecFull p in - let rowFields = parseTagSpecFulls p in - let tagNames = parseTagNames p in - let variant = - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.variant ~attrs ~loc (rowField :: rowFields) Closed - (Some tagNames) - in - Parser.expect Rbracket p; - variant + Parser.next p; + Parser.optional p Bar |> ignore; + let rowField = parseTagSpecFull p in + let rowFields = parseTagSpecFulls p in + let tagNames = parseTagNames p in + let variant = + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.variant ~attrs ~loc (rowField :: rowFields) Closed + (Some tagNames) + in + Parser.expect Rbracket p; + variant | _ -> - let rowFields1 = parseTagSpecFirst p in - let rowFields2 = parseTagSpecs p in - let variant = - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.variant ~attrs ~loc (rowFields1 @ rowFields2) Closed None - in - Parser.expect Rbracket p; - variant + let rowFields1 = parseTagSpecFirst p in + let rowFields2 = parseTagSpecs p in + let variant = + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.variant ~attrs ~loc (rowFields1 @ rowFields2) Closed None + in + Parser.expect Rbracket p; + variant and parseTagName p = match p.Parser.token with | Hash -> - let ident, _loc = parseHashIdent ~startPos:p.startPos p in - Some ident + let ident, _loc = parseHashIdent ~startPos:p.startPos p in + Some ident | _ -> None and parseTagNames p = @@ -288182,9 +288523,9 @@ and parseTagSpecFulls p = | Rbracket -> [] | GreaterThan -> [] | Bar -> - Parser.next p; - let rowField = parseTagSpecFull p in - rowField :: parseTagSpecFulls p + Parser.next p; + let rowField = parseTagSpecFull p in + rowField :: parseTagSpecFulls p | _ -> [] and parseTagSpecFull p = @@ -288192,15 +288533,15 @@ and parseTagSpecFull p = match p.Parser.token with | Hash -> parsePolymorphicVariantTypeSpecHash ~attrs ~full:true p | _ -> - let typ = parseTypExpr ~attrs p in - Parsetree.Rinherit typ + let typ = parseTypExpr ~attrs p in + Parsetree.Rinherit typ and parseTagSpecs p = match p.Parser.token with | Bar -> - Parser.next p; - let rowField = parseTagSpec p in - rowField :: parseTagSpecs p + Parser.next p; + let rowField = parseTagSpec p in + rowField :: parseTagSpecs p | _ -> [] and parseTagSpec p = @@ -288208,25 +288549,25 @@ and parseTagSpec p = match p.Parser.token with | Hash -> parsePolymorphicVariantTypeSpecHash ~attrs ~full:false p | _ -> - let typ = parseTypExpr ~attrs p in - Parsetree.Rinherit typ + let typ = parseTypExpr ~attrs p in + Parsetree.Rinherit typ and parseTagSpecFirst p = let attrs = parseAttributes p in match p.Parser.token with | Bar -> - Parser.next p; - [parseTagSpec p] - | Hash -> [parsePolymorphicVariantTypeSpecHash ~attrs ~full:false p] + Parser.next p; + [ parseTagSpec p ] + | Hash -> [ parsePolymorphicVariantTypeSpecHash ~attrs ~full:false p ] | _ -> ( - let typ = parseTypExpr ~attrs p in - match p.token with - | Rbracket -> - (* example: [ListStyleType.t] *) - [Parsetree.Rinherit typ] - | _ -> - Parser.expect Bar p; - [Parsetree.Rinherit typ; parseTagSpec p]) + let typ = parseTypExpr ~attrs p in + match p.token with + | Rbracket -> + (* example: [ListStyleType.t] *) + [ Parsetree.Rinherit typ ] + | _ -> + Parser.expect Bar p; + [ Parsetree.Rinherit typ; parseTagSpec p ]) and parsePolymorphicVariantTypeSpecHash ~attrs ~full p : Parsetree.row_field = let startPos = p.Parser.startPos in @@ -288234,17 +288575,17 @@ and parsePolymorphicVariantTypeSpecHash ~attrs ~full p : Parsetree.row_field = let rec loop p = match p.Parser.token with | Band when full -> - Parser.next p; - let rowField = parsePolymorphicVariantTypeArgs p in - rowField :: loop p + Parser.next p; + let rowField = parsePolymorphicVariantTypeArgs p in + rowField :: loop p | _ -> [] in let firstTuple, tagContainsAConstantEmptyConstructor = match p.Parser.token with | Band when full -> - Parser.next p; - ([parsePolymorphicVariantTypeArgs p], true) - | Lparen -> ([parsePolymorphicVariantTypeArgs p], false) + Parser.next p; + ([ parsePolymorphicVariantTypeArgs p ], true) + | Lparen -> ([ parsePolymorphicVariantTypeArgs p ], false) | _ -> ([], true) in let tuples = firstTuple @ loop p in @@ -288265,32 +288606,32 @@ and parsePolymorphicVariantTypeArgs p = let attrs = [] in let loc = mkLoc startPos p.prevEndPos in match args with - | [({ptyp_desc = Ptyp_tuple _} as typ)] as types -> - if p.mode = ParseForTypeChecker then typ - else Ast_helper.Typ.tuple ~loc ~attrs types - | [typ] -> typ + | [ ({ ptyp_desc = Ptyp_tuple _ } as typ) ] as types -> + if p.mode = ParseForTypeChecker then typ + else Ast_helper.Typ.tuple ~loc ~attrs types + | [ typ ] -> typ | types -> Ast_helper.Typ.tuple ~loc ~attrs types and parseTypeEquationAndRepresentation p = match p.Parser.token with | (Equal | Bar) as token -> ( - if token = Bar then Parser.expect Equal p; - Parser.next p; - match p.Parser.token with - | Uident _ -> parseTypeEquationOrConstrDecl p - | Lbrace -> parseRecordOrObjectDecl p - | Private -> parsePrivateEqOrRepr p - | Bar | DotDot -> - let priv, kind = parseTypeRepresentation p in - (None, priv, kind) - | _ -> ( - let manifest = Some (parseTypExpr p) in + if token = Bar then Parser.expect Equal p; + Parser.next p; match p.Parser.token with - | Equal -> - Parser.next p; - let priv, kind = parseTypeRepresentation p in - (manifest, priv, kind) - | _ -> (manifest, Public, Parsetree.Ptype_abstract))) + | Uident _ -> parseTypeEquationOrConstrDecl p + | Lbrace -> parseRecordOrObjectDecl p + | Private -> parsePrivateEqOrRepr p + | Bar | DotDot -> + let priv, kind = parseTypeRepresentation p in + (None, priv, kind) + | _ -> ( + let manifest = Some (parseTypExpr p) in + match p.Parser.token with + | Equal -> + Parser.next p; + let priv, kind = parseTypeRepresentation p in + (manifest, priv, kind) + | _ -> (manifest, Public, Parsetree.Ptype_abstract))) | _ -> (None, Public, Parsetree.Ptype_abstract) (* type-definition ::= type [rec] typedef { and typedef } @@ -288330,8 +288671,8 @@ and parseTypeExtension ~params ~attrs ~name p = let attrs, name, kind = match p.Parser.token with | Bar -> - Parser.next p; - parseConstrDef ~parseAttrs:true p + Parser.next p; + parseConstrDef ~parseAttrs:true p | _ -> parseConstrDef ~parseAttrs:true p in let loc = mkLoc constrStart p.prevEndPos in @@ -288340,18 +288681,18 @@ and parseTypeExtension ~params ~attrs ~name p = let rec loop p cs = match p.Parser.token with | Bar -> - let startPos = p.Parser.startPos in - Parser.next p; - let attrs, name, kind = parseConstrDef ~parseAttrs:true p in - let extConstr = - Ast_helper.Te.constructor ~attrs - ~loc:(mkLoc startPos p.prevEndPos) - name kind - in - loop p (extConstr :: cs) + let startPos = p.Parser.startPos in + Parser.next p; + let attrs, name, kind = parseConstrDef ~parseAttrs:true p in + let extConstr = + Ast_helper.Te.constructor ~attrs + ~loc:(mkLoc startPos p.prevEndPos) + name kind + in + loop p (extConstr :: cs) | _ -> List.rev cs in - let constructors = loop p [first] in + let constructors = loop p [ first ] in Ast_helper.Te.mk ~attrs ~params ~priv name constructors and parseTypeDefinitions ~attrs ~name ~params ~startPos p = @@ -288360,19 +288701,19 @@ and parseTypeDefinitions ~attrs ~name ~params ~startPos p = let cstrs = parseTypeConstraints p in let loc = mkLoc startPos p.prevEndPos in Ast_helper.Type.mk ~loc ~attrs ~priv ~kind ~params ~cstrs ?manifest - {name with txt = lidentOfPath name.Location.txt} + { name with txt = lidentOfPath name.Location.txt } in let rec loop p defs = let startPos = p.Parser.startPos in let attrs = parseAttributesAndBinding p in match p.Parser.token with | And -> - Parser.next p; - let typeDef = parseTypeDef ~attrs ~startPos p in - loop p (typeDef :: defs) + Parser.next p; + let typeDef = parseTypeDef ~attrs ~startPos p in + loop p (typeDef :: defs) | _ -> List.rev defs in - loop p [typeDef] + loop p [ typeDef ] (* TODO: decide if we really want type extensions (eg. type x += Blue) * It adds quite a bit of complexity that can be avoided, @@ -288384,11 +288725,11 @@ and parseTypeDefinitionOrExtension ~attrs p = let recFlag = match p.token with | Rec -> - Parser.next p; - Asttypes.Recursive + Parser.next p; + Asttypes.Recursive | Lident "nonrec" -> - Parser.next p; - Asttypes.Nonrecursive + Parser.next p; + Asttypes.Nonrecursive | _ -> Asttypes.Nonrecursive in let name = parseValuePath p in @@ -288396,17 +288737,17 @@ and parseTypeDefinitionOrExtension ~attrs p = match p.Parser.token with | PlusEqual -> TypeExt (parseTypeExtension ~params ~attrs ~name p) | _ -> - (* shape of type name should be Lident, i.e. `t` is accepted. `User.t` not *) - let () = - match name.Location.txt with - | Lident _ -> () - | longident -> - Parser.err ~startPos:name.loc.loc_start ~endPos:name.loc.loc_end p - (longident |> ErrorMessages.typeDeclarationNameLongident - |> Diagnostics.message) - in - let typeDefs = parseTypeDefinitions ~attrs ~name ~params ~startPos p in - TypeDef {recFlag; types = typeDefs} + (* shape of type name should be Lident, i.e. `t` is accepted. `User.t` not *) + let () = + match name.Location.txt with + | Lident _ -> () + | longident -> + Parser.err ~startPos:name.loc.loc_start ~endPos:name.loc.loc_end p + (longident |> ErrorMessages.typeDeclarationNameLongident + |> Diagnostics.message) + in + let typeDefs = parseTypeDefinitions ~attrs ~name ~params ~startPos p in + TypeDef { recFlag; types = typeDefs } (* external value-name : typexp = external-declaration *) and parseExternalDef ~attrs ~startPos p = @@ -288422,14 +288763,14 @@ and parseExternalDef ~attrs ~startPos p = let prim = match p.token with | String s -> - Parser.next p; - [s] + Parser.next p; + [ s ] | _ -> - Parser.err ~startPos:equalStart ~endPos:equalEnd p - (Diagnostics.message - ("An external requires the name of the JS value you're referring \ - to, like \"" ^ name.txt ^ "\".")); - [] + Parser.err ~startPos:equalStart ~endPos:equalEnd p + (Diagnostics.message + ("An external requires the name of the JS value you're referring \ + to, like \"" ^ name.txt ^ "\".")); + [] in let loc = mkLoc startPos p.prevEndPos in let vb = Ast_helper.Val.mk ~loc ~attrs ~prim name typExpr in @@ -288448,26 +288789,26 @@ and parseConstrDef ~parseAttrs p = let name = match p.Parser.token with | Uident name -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Location.mkloc name loc + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc name loc | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" in let kind = match p.Parser.token with | Lparen -> - let args, res = parseConstrDeclArgs p in - Parsetree.Pext_decl (args, res) + let args, res = parseConstrDeclArgs p in + Parsetree.Pext_decl (args, res) | Equal -> - Parser.next p; - let longident = parseModuleLongIdent ~lowercase:false p in - Parsetree.Pext_rebind longident + Parser.next p; + let longident = parseModuleLongIdent ~lowercase:false p in + Parsetree.Pext_rebind longident | Colon -> - Parser.next p; - let typ = parseTypExpr p in - Parsetree.Pext_decl (Pcstr_tuple [], Some typ) + Parser.next p; + let typ = parseTypExpr p in + Parsetree.Pext_decl (Pcstr_tuple [], Some typ) | _ -> Parsetree.Pext_decl (Pcstr_tuple [], None) in (attrs, name, kind) @@ -288490,12 +288831,12 @@ and parseNewlineOrSemicolonStructure p = match p.Parser.token with | Semicolon -> Parser.next p | token when Grammar.isStructureItemStart token -> - if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then () - else - Parser.err ~startPos:p.prevEndPos ~endPos:p.endPos p - (Diagnostics.message - "consecutive statements on a line must be separated by ';' or a \ - newline") + if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then () + else + Parser.err ~startPos:p.prevEndPos ~endPos:p.endPos p + (Diagnostics.message + "consecutive statements on a line must be separated by ';' or a \ + newline") | _ -> () and parseStructureItemRegion p = @@ -288503,87 +288844,89 @@ and parseStructureItemRegion p = let attrs = parseAttributes p in match p.Parser.token with | Open -> - let openDescription = parseOpenDescription ~attrs p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.open_ ~loc openDescription) - | Let -> - let recFlag, letBindings = parseLetBindings ~attrs p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.value ~loc recFlag letBindings) - | Typ -> ( - Parser.beginRegion p; - match parseTypeDefinitionOrExtension ~attrs p with - | TypeDef {recFlag; types} -> + let openDescription = parseOpenDescription ~attrs p in parseNewlineOrSemicolonStructure p; let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Str.type_ ~loc recFlag types) - | TypeExt ext -> + Some (Ast_helper.Str.open_ ~loc openDescription) + | Let -> + let recFlag, letBindings = parseLetBindings ~attrs p in parseNewlineOrSemicolonStructure p; let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Str.type_extension ~loc ext)) + Some (Ast_helper.Str.value ~loc recFlag letBindings) + | Typ -> ( + Parser.beginRegion p; + match parseTypeDefinitionOrExtension ~attrs p with + | TypeDef { recFlag; types } -> + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some (Ast_helper.Str.type_ ~loc recFlag types) + | TypeExt ext -> + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some (Ast_helper.Str.type_extension ~loc ext)) | External -> - let externalDef = parseExternalDef ~attrs ~startPos p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.primitive ~loc externalDef) + let externalDef = parseExternalDef ~attrs ~startPos p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Str.primitive ~loc externalDef) | Exception -> - let exceptionDef = parseExceptionDef ~attrs p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.exception_ ~loc exceptionDef) + let exceptionDef = parseExceptionDef ~attrs p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Str.exception_ ~loc exceptionDef) | Include -> - let includeStatement = parseIncludeStatement ~attrs p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.include_ ~loc includeStatement) + let includeStatement = parseIncludeStatement ~attrs p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Str.include_ ~loc includeStatement) | Module -> - Parser.beginRegion p; - let structureItem = parseModuleOrModuleTypeImplOrPackExpr ~attrs p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some {structureItem with pstr_loc = loc} + Parser.beginRegion p; + let structureItem = parseModuleOrModuleTypeImplOrPackExpr ~attrs p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some { structureItem with pstr_loc = loc } | ModuleComment (loc, s) -> - Parser.next p; - Some - (Ast_helper.Str.attribute ~loc - ( {txt = "ns.doc"; loc}, - PStr - [ - Ast_helper.Str.eval ~loc - (Ast_helper.Exp.constant ~loc (Pconst_string (s, None))); - ] )) + Parser.next p; + Some + (Ast_helper.Str.attribute ~loc + ( { txt = "ns.doc"; loc }, + PStr + [ + Ast_helper.Str.eval ~loc + (Ast_helper.Exp.constant ~loc (Pconst_string (s, None))); + ] )) | AtAt -> - let attr = parseStandaloneAttribute p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.attribute ~loc attr) + let attr = parseStandaloneAttribute p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Str.attribute ~loc attr) | PercentPercent -> - let extension = parseExtension ~moduleLanguage:true p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.extension ~attrs ~loc extension) + let extension = parseExtension ~moduleLanguage:true p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Str.extension ~attrs ~loc extension) | token when Grammar.isExprStart token -> - let prevEndPos = p.Parser.endPos in - let exp = parseExpr p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Parser.checkProgress ~prevEndPos - ~result:(Ast_helper.Str.eval ~loc ~attrs exp) - p + let prevEndPos = p.Parser.endPos in + let exp = parseExpr p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Parser.checkProgress ~prevEndPos + ~result:(Ast_helper.Str.eval ~loc ~attrs exp) + p | _ -> ( - match attrs with - | (({Asttypes.loc = attrLoc}, _) as attr) :: _ -> - Parser.err ~startPos:attrLoc.loc_start ~endPos:attrLoc.loc_end p - (Diagnostics.message (ErrorMessages.attributeWithoutNode attr)); - let expr = parseExpr p in - Some - (Ast_helper.Str.eval ~loc:(mkLoc p.startPos p.prevEndPos) ~attrs expr) - | _ -> None) + match attrs with + | (({ Asttypes.loc = attrLoc }, _) as attr) :: _ -> + Parser.err ~startPos:attrLoc.loc_start ~endPos:attrLoc.loc_end p + (Diagnostics.message (ErrorMessages.attributeWithoutNode attr)); + let expr = parseExpr p in + Some + (Ast_helper.Str.eval + ~loc:(mkLoc p.startPos p.prevEndPos) + ~attrs expr) + | _ -> None) [@@progress Parser.next, Parser.expect] (* include-statement ::= include module-expr *) @@ -288598,53 +288941,56 @@ and parseAtomicModuleExpr p = let startPos = p.Parser.startPos in match p.Parser.token with | Uident _ident -> - let longident = parseModuleLongIdent ~lowercase:false p in - Ast_helper.Mod.ident ~loc:longident.loc longident + let longident = parseModuleLongIdent ~lowercase:false p in + Ast_helper.Mod.ident ~loc:longident.loc longident | Lbrace -> - Parser.next p; - let structure = - Ast_helper.Mod.structure - (parseDelimitedRegion ~grammar:Grammar.Structure ~closing:Rbrace - ~f:parseStructureItemRegion p) - in - Parser.expect Rbrace p; - let endPos = p.prevEndPos in - {structure with pmod_loc = mkLoc startPos endPos} + Parser.next p; + let structure = + Ast_helper.Mod.structure + (parseDelimitedRegion ~grammar:Grammar.Structure ~closing:Rbrace + ~f:parseStructureItemRegion p) + in + Parser.expect Rbrace p; + let endPos = p.prevEndPos in + { structure with pmod_loc = mkLoc startPos endPos } | Lparen -> - Parser.next p; - let modExpr = - match p.token with - | Rparen -> Ast_helper.Mod.structure ~loc:(mkLoc startPos p.prevEndPos) [] - | _ -> parseConstrainedModExpr p - in - Parser.expect Rparen p; - modExpr - | Lident "unpack" -> ( - (* TODO: should this be made a keyword?? *) - Parser.next p; - Parser.expect Lparen p; - let expr = parseExpr p in - match p.Parser.token with - | Colon -> - let colonStart = p.Parser.startPos in Parser.next p; - let attrs = parseAttributes p in - let packageType = parsePackageType ~startPos:colonStart ~attrs p in - Parser.expect Rparen p; - let loc = mkLoc startPos p.prevEndPos in - let constraintExpr = Ast_helper.Exp.constraint_ ~loc expr packageType in - Ast_helper.Mod.unpack ~loc constraintExpr - | _ -> + let modExpr = + match p.token with + | Rparen -> + Ast_helper.Mod.structure ~loc:(mkLoc startPos p.prevEndPos) [] + | _ -> parseConstrainedModExpr p + in Parser.expect Rparen p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Mod.unpack ~loc expr) + modExpr + | Lident "unpack" -> ( + (* TODO: should this be made a keyword?? *) + Parser.next p; + Parser.expect Lparen p; + let expr = parseExpr p in + match p.Parser.token with + | Colon -> + let colonStart = p.Parser.startPos in + Parser.next p; + let attrs = parseAttributes p in + let packageType = parsePackageType ~startPos:colonStart ~attrs p in + Parser.expect Rparen p; + let loc = mkLoc startPos p.prevEndPos in + let constraintExpr = + Ast_helper.Exp.constraint_ ~loc expr packageType + in + Ast_helper.Mod.unpack ~loc constraintExpr + | _ -> + Parser.expect Rparen p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Mod.unpack ~loc expr) | Percent -> - let extension = parseExtension p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Mod.extension ~loc extension + let extension = parseExtension p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Mod.extension ~loc extension | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Recover.defaultModuleExpr () + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Recover.defaultModuleExpr () and parsePrimaryModExpr p = let startPos = p.Parser.startPos in @@ -288652,11 +288998,11 @@ and parsePrimaryModExpr p = let rec loop p modExpr = match p.Parser.token with | Lparen when p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> - loop p (parseModuleApplication p modExpr) + loop p (parseModuleApplication p modExpr) | _ -> modExpr in let modExpr = loop p modExpr in - {modExpr with pmod_loc = mkLoc startPos p.prevEndPos} + { modExpr with pmod_loc = mkLoc startPos p.prevEndPos } (* * functor-arg ::= @@ -288670,43 +289016,43 @@ and parseFunctorArg p = let attrs = parseAttributes p in match p.Parser.token with | Uident ident -> ( - Parser.next p; - let uidentEndPos = p.prevEndPos in - match p.Parser.token with - | Colon -> Parser.next p; - let moduleType = parseModuleType p in - let loc = mkLoc startPos uidentEndPos in - let argName = Location.mkloc ident loc in - Some (attrs, argName, Some moduleType, startPos) - | Dot -> + let uidentEndPos = p.prevEndPos in + match p.Parser.token with + | Colon -> + Parser.next p; + let moduleType = parseModuleType p in + let loc = mkLoc startPos uidentEndPos in + let argName = Location.mkloc ident loc in + Some (attrs, argName, Some moduleType, startPos) + | Dot -> + Parser.next p; + let moduleType = + let moduleLongIdent = + parseModuleLongIdentTail ~lowercase:false p startPos + (Longident.Lident ident) + in + Ast_helper.Mty.ident ~loc:moduleLongIdent.loc moduleLongIdent + in + let argName = Location.mknoloc "_" in + Some (attrs, argName, Some moduleType, startPos) + | _ -> + let loc = mkLoc startPos uidentEndPos in + let modIdent = Location.mkloc (Longident.Lident ident) loc in + let moduleType = Ast_helper.Mty.ident ~loc modIdent in + let argName = Location.mknoloc "_" in + Some (attrs, argName, Some moduleType, startPos)) + | Underscore -> Parser.next p; - let moduleType = - let moduleLongIdent = - parseModuleLongIdentTail ~lowercase:false p startPos - (Longident.Lident ident) - in - Ast_helper.Mty.ident ~loc:moduleLongIdent.loc moduleLongIdent - in - let argName = Location.mknoloc "_" in + let argName = Location.mkloc "_" (mkLoc startPos p.prevEndPos) in + Parser.expect Colon p; + let moduleType = parseModuleType p in Some (attrs, argName, Some moduleType, startPos) - | _ -> - let loc = mkLoc startPos uidentEndPos in - let modIdent = Location.mkloc (Longident.Lident ident) loc in - let moduleType = Ast_helper.Mty.ident ~loc modIdent in - let argName = Location.mknoloc "_" in - Some (attrs, argName, Some moduleType, startPos)) - | Underscore -> - Parser.next p; - let argName = Location.mkloc "_" (mkLoc startPos p.prevEndPos) in - Parser.expect Colon p; - let moduleType = parseModuleType p in - Some (attrs, argName, Some moduleType, startPos) | Lparen -> - Parser.next p; - Parser.expect Rparen p; - let argName = Location.mkloc "*" (mkLoc startPos p.prevEndPos) in - Some (attrs, argName, None, startPos) + Parser.next p; + Parser.expect Rparen p; + let argName = Location.mkloc "*" (mkLoc startPos p.prevEndPos) in + Some (attrs, argName, None, startPos) | _ -> None and parseFunctorArgs p = @@ -288719,7 +289065,7 @@ and parseFunctorArgs p = Parser.expect Rparen p; match args with | [] -> - [([], Location.mkloc "*" (mkLoc startPos p.prevEndPos), None, startPos)] + [ ([], Location.mkloc "*" (mkLoc startPos p.prevEndPos), None, startPos) ] | args -> args and parseFunctorModuleExpr p = @@ -288728,8 +289074,8 @@ and parseFunctorModuleExpr p = let returnType = match p.Parser.token with | Colon -> - Parser.next p; - Some (parseModuleType ~es6Arrow:false p) + Parser.next p; + Some (parseModuleType ~es6Arrow:false p) | _ -> None in Parser.expect EqualGreater p; @@ -288737,10 +289083,10 @@ and parseFunctorModuleExpr p = let modExpr = parseModuleExpr p in match returnType with | Some modType -> - Ast_helper.Mod.constraint_ - ~loc: - (mkLoc modExpr.pmod_loc.loc_start modType.Parsetree.pmty_loc.loc_end) - modExpr modType + Ast_helper.Mod.constraint_ + ~loc: + (mkLoc modExpr.pmod_loc.loc_start modType.Parsetree.pmty_loc.loc_end) + modExpr modType | None -> modExpr in let endPos = p.prevEndPos in @@ -288751,7 +289097,7 @@ and parseFunctorModuleExpr p = moduleType acc) args rhsModuleExpr in - {modExpr with pmod_loc = mkLoc startPos endPos} + { modExpr with pmod_loc = mkLoc startPos endPos } (* module-expr ::= * | module-path @@ -288768,16 +289114,19 @@ and parseModuleExpr p = if isEs6ArrowFunctor p then parseFunctorModuleExpr p else parsePrimaryModExpr p in - {modExpr with pmod_attributes = List.concat [modExpr.pmod_attributes; attrs]} + { + modExpr with + pmod_attributes = List.concat [ modExpr.pmod_attributes; attrs ]; + } and parseConstrainedModExpr p = let modExpr = parseModuleExpr p in match p.Parser.token with | Colon -> - Parser.next p; - let modType = parseModuleType p in - let loc = mkLoc modExpr.pmod_loc.loc_start modType.pmty_loc.loc_end in - Ast_helper.Mod.constraint_ ~loc modExpr modType + Parser.next p; + let modType = parseModuleType p in + let loc = mkLoc modExpr.pmod_loc.loc_start modType.pmty_loc.loc_end in + Ast_helper.Mod.constraint_ ~loc modExpr modType | _ -> modExpr and parseConstrainedModExprRegion p = @@ -288795,8 +289144,8 @@ and parseModuleApplication p modExpr = let args = match args with | [] -> - let loc = mkLoc startPos p.prevEndPos in - [Ast_helper.Mod.structure ~loc []] + let loc = mkLoc startPos p.prevEndPos in + [ Ast_helper.Mod.structure ~loc [] ] | args -> args in List.fold_left @@ -288814,11 +289163,11 @@ and parseModuleOrModuleTypeImplOrPackExpr ~attrs p = match p.Parser.token with | Typ -> parseModuleTypeImpl ~attrs startPos p | Lparen -> - let expr = parseFirstClassModuleExpr ~startPos p in - let a = parsePrimaryExpr ~operand:expr p in - let expr = parseBinaryExpr ~a p 1 in - let expr = parseTernaryExpr expr p in - Ast_helper.Str.eval ~attrs expr + let expr = parseFirstClassModuleExpr ~startPos p in + let a = parsePrimaryExpr ~operand:expr p in + let expr = parseBinaryExpr ~a p 1 in + let expr = parseTernaryExpr expr p in + Ast_helper.Str.eval ~attrs expr | _ -> parseMaybeRecModuleBinding ~attrs ~startPos p and parseModuleTypeImpl ~attrs startPos p = @@ -288827,16 +289176,16 @@ and parseModuleTypeImpl ~attrs startPos p = let name = match p.Parser.token with | Lident ident -> - Parser.next p; - let loc = mkLoc nameStart p.prevEndPos in - Location.mkloc ident loc + Parser.next p; + let loc = mkLoc nameStart p.prevEndPos in + Location.mkloc ident loc | Uident ident -> - Parser.next p; - let loc = mkLoc nameStart p.prevEndPos in - Location.mkloc ident loc + Parser.next p; + let loc = mkLoc nameStart p.prevEndPos in + Location.mkloc ident loc | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" in Parser.expect Equal p; let moduleType = parseModuleType p in @@ -288854,23 +289203,23 @@ and parseModuleTypeImpl ~attrs startPos p = and parseMaybeRecModuleBinding ~attrs ~startPos p = match p.Parser.token with | Token.Rec -> - Parser.next p; - Ast_helper.Str.rec_module (parseModuleBindings ~startPos ~attrs p) + Parser.next p; + Ast_helper.Str.rec_module (parseModuleBindings ~startPos ~attrs p) | _ -> - Ast_helper.Str.module_ - (parseModuleBinding ~attrs ~startPos:p.Parser.startPos p) + Ast_helper.Str.module_ + (parseModuleBinding ~attrs ~startPos:p.Parser.startPos p) and parseModuleBinding ~attrs ~startPos p = let name = match p.Parser.token with | Uident ident -> - let startPos = p.Parser.startPos in - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - Location.mkloc ident loc + let startPos = p.Parser.startPos in + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + Location.mkloc ident loc | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" in let body = parseModuleBindingBody p in let loc = mkLoc startPos p.prevEndPos in @@ -288881,17 +289230,17 @@ and parseModuleBindingBody p = let returnModType = match p.Parser.token with | Colon -> - Parser.next p; - Some (parseModuleType p) + Parser.next p; + Some (parseModuleType p) | _ -> None in Parser.expect Equal p; let modExpr = parseModuleExpr p in match returnModType with | Some modType -> - Ast_helper.Mod.constraint_ - ~loc:(mkLoc modType.pmty_loc.loc_start modExpr.pmod_loc.loc_end) - modExpr modType + Ast_helper.Mod.constraint_ + ~loc:(mkLoc modType.pmty_loc.loc_start modExpr.pmod_loc.loc_end) + modExpr modType | None -> modExpr (* module-name : module-type = module-expr @@ -288902,52 +289251,52 @@ and parseModuleBindings ~attrs ~startPos p = let attrs = parseAttributesAndBinding p in match p.Parser.token with | And -> - Parser.next p; - ignore (Parser.optional p Module); - (* over-parse for fault-tolerance *) - let modBinding = parseModuleBinding ~attrs ~startPos p in - loop p (modBinding :: acc) + Parser.next p; + ignore (Parser.optional p Module); + (* over-parse for fault-tolerance *) + let modBinding = parseModuleBinding ~attrs ~startPos p in + loop p (modBinding :: acc) | _ -> List.rev acc in let first = parseModuleBinding ~attrs ~startPos p in - loop p [first] + loop p [ first ] and parseAtomicModuleType p = let startPos = p.Parser.startPos in let moduleType = match p.Parser.token with | Uident _ | Lident _ -> - (* Ocaml allows module types to end with lowercase: module Foo : bar = { ... } - * lets go with uppercase terminal for now *) - let moduleLongIdent = parseModuleLongIdent ~lowercase:true p in - Ast_helper.Mty.ident ~loc:moduleLongIdent.loc moduleLongIdent + (* Ocaml allows module types to end with lowercase: module Foo : bar = { ... } + * lets go with uppercase terminal for now *) + let moduleLongIdent = parseModuleLongIdent ~lowercase:true p in + Ast_helper.Mty.ident ~loc:moduleLongIdent.loc moduleLongIdent | Lparen -> - Parser.next p; - let mty = parseModuleType p in - Parser.expect Rparen p; - {mty with pmty_loc = mkLoc startPos p.prevEndPos} + Parser.next p; + let mty = parseModuleType p in + Parser.expect Rparen p; + { mty with pmty_loc = mkLoc startPos p.prevEndPos } | Lbrace -> - Parser.next p; - let spec = - parseDelimitedRegion ~grammar:Grammar.Signature ~closing:Rbrace - ~f:parseSignatureItemRegion p - in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Mty.signature ~loc spec + Parser.next p; + let spec = + parseDelimitedRegion ~grammar:Grammar.Signature ~closing:Rbrace + ~f:parseSignatureItemRegion p + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Mty.signature ~loc spec | Module -> - (* TODO: check if this is still atomic when implementing first class modules*) - parseModuleTypeOf p + (* TODO: check if this is still atomic when implementing first class modules*) + parseModuleTypeOf p | Percent -> - let extension = parseExtension p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Mty.extension ~loc extension + let extension = parseExtension p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Mty.extension ~loc extension | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Recover.defaultModuleType () + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Recover.defaultModuleType () in let moduleTypeLoc = mkLoc startPos p.prevEndPos in - {moduleType with pmty_loc = moduleTypeLoc} + { moduleType with pmty_loc = moduleTypeLoc } and parseFunctorModuleType p = let startPos = p.Parser.startPos in @@ -288962,7 +289311,7 @@ and parseFunctorModuleType p = moduleType acc) args rhs in - {modType with pmty_loc = mkLoc startPos endPos} + { modType with pmty_loc = mkLoc startPos endPos } (* Module types are the module-level equivalent of type expressions: they * specify the general shape and type properties of modules. @@ -288986,33 +289335,36 @@ and parseModuleType ?(es6Arrow = true) ?(with_ = true) p = let modty = parseAtomicModuleType p in match p.Parser.token with | EqualGreater when es6Arrow == true -> - Parser.next p; - let rhs = parseModuleType ~with_:false p in - let str = Location.mknoloc "_" in - let loc = mkLoc modty.pmty_loc.loc_start p.prevEndPos in - Ast_helper.Mty.functor_ ~loc str (Some modty) rhs + Parser.next p; + let rhs = parseModuleType ~with_:false p in + let str = Location.mknoloc "_" in + let loc = mkLoc modty.pmty_loc.loc_start p.prevEndPos in + Ast_helper.Mty.functor_ ~loc str (Some modty) rhs | _ -> modty in let moduleType = - {modty with pmty_attributes = List.concat [modty.pmty_attributes; attrs]} + { + modty with + pmty_attributes = List.concat [ modty.pmty_attributes; attrs ]; + } in if with_ then parseWithConstraints moduleType p else moduleType and parseWithConstraints moduleType p = match p.Parser.token with | Lident "with" -> - Parser.next p; - let first = parseWithConstraint p in - let rec loop p acc = - match p.Parser.token with - | And -> - Parser.next p; - loop p (parseWithConstraint p :: acc) - | _ -> List.rev acc - in - let constraints = loop p [first] in - let loc = mkLoc moduleType.pmty_loc.loc_start p.prevEndPos in - Ast_helper.Mty.with_ ~loc moduleType constraints + Parser.next p; + let first = parseWithConstraint p in + let rec loop p acc = + match p.Parser.token with + | And -> + Parser.next p; + loop p (parseWithConstraint p :: acc) + | _ -> List.rev acc + in + let constraints = loop p [ first ] in + let loc = mkLoc moduleType.pmty_loc.loc_start p.prevEndPos in + Ast_helper.Mty.with_ ~loc moduleType constraints | _ -> moduleType (* mod-constraint ::= @@ -289025,60 +289377,63 @@ and parseWithConstraints moduleType p = and parseWithConstraint p = match p.Parser.token with | Module -> ( - Parser.next p; - let modulePath = parseModuleLongIdent ~lowercase:false p in - match p.Parser.token with - | ColonEqual -> - Parser.next p; - let lident = parseModuleLongIdent ~lowercase:false p in - Parsetree.Pwith_modsubst (modulePath, lident) - | Equal -> Parser.next p; - let lident = parseModuleLongIdent ~lowercase:false p in - Parsetree.Pwith_module (modulePath, lident) - | token -> - (* TODO: revisit *) - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - let lident = parseModuleLongIdent ~lowercase:false p in - Parsetree.Pwith_modsubst (modulePath, lident)) + let modulePath = parseModuleLongIdent ~lowercase:false p in + match p.Parser.token with + | ColonEqual -> + Parser.next p; + let lident = parseModuleLongIdent ~lowercase:false p in + Parsetree.Pwith_modsubst (modulePath, lident) + | Equal -> + Parser.next p; + let lident = parseModuleLongIdent ~lowercase:false p in + Parsetree.Pwith_module (modulePath, lident) + | token -> + (* TODO: revisit *) + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + let lident = parseModuleLongIdent ~lowercase:false p in + Parsetree.Pwith_modsubst (modulePath, lident)) | Typ -> ( - Parser.next p; - let typeConstr = parseValuePath p in - let params = parseTypeParams ~parent:typeConstr p in - match p.Parser.token with - | ColonEqual -> - Parser.next p; - let typExpr = parseTypExpr p in - Parsetree.Pwith_typesubst - ( typeConstr, - Ast_helper.Type.mk ~loc:typeConstr.loc ~params ~manifest:typExpr - (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) ) - | Equal -> Parser.next p; - let typExpr = parseTypExpr p in - let typeConstraints = parseTypeConstraints p in - Parsetree.Pwith_type - ( typeConstr, - Ast_helper.Type.mk ~loc:typeConstr.loc ~params ~manifest:typExpr - ~cstrs:typeConstraints - (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) ) - | token -> - (* TODO: revisit *) + let typeConstr = parseValuePath p in + let params = parseTypeParams ~parent:typeConstr p in + match p.Parser.token with + | ColonEqual -> + Parser.next p; + let typExpr = parseTypExpr p in + Parsetree.Pwith_typesubst + ( typeConstr, + Ast_helper.Type.mk ~loc:typeConstr.loc ~params ~manifest:typExpr + (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) + ) + | Equal -> + Parser.next p; + let typExpr = parseTypExpr p in + let typeConstraints = parseTypeConstraints p in + Parsetree.Pwith_type + ( typeConstr, + Ast_helper.Type.mk ~loc:typeConstr.loc ~params ~manifest:typExpr + ~cstrs:typeConstraints + (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) + ) + | token -> + (* TODO: revisit *) + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + let typExpr = parseTypExpr p in + let typeConstraints = parseTypeConstraints p in + Parsetree.Pwith_type + ( typeConstr, + Ast_helper.Type.mk ~loc:typeConstr.loc ~params ~manifest:typExpr + ~cstrs:typeConstraints + (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) + )) + | token -> + (* TODO: implement recovery strategy *) Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - let typExpr = parseTypExpr p in - let typeConstraints = parseTypeConstraints p in Parsetree.Pwith_type - ( typeConstr, - Ast_helper.Type.mk ~loc:typeConstr.loc ~params ~manifest:typExpr - ~cstrs:typeConstraints - (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) )) - | token -> - (* TODO: implement recovery strategy *) - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Parsetree.Pwith_type - ( Location.mknoloc (Longident.Lident ""), - Ast_helper.Type.mk ~params:[] ~manifest:(Recover.defaultType ()) - ~cstrs:[] (Location.mknoloc "") ) + ( Location.mknoloc (Longident.Lident ""), + Ast_helper.Type.mk ~params:[] ~manifest:(Recover.defaultType ()) + ~cstrs:[] (Location.mknoloc "") ) and parseModuleTypeOf p = let startPos = p.Parser.startPos in @@ -289092,12 +289447,12 @@ and parseNewlineOrSemicolonSignature p = match p.Parser.token with | Semicolon -> Parser.next p | token when Grammar.isSignatureItemStart token -> - if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then () - else - Parser.err ~startPos:p.prevEndPos ~endPos:p.endPos p - (Diagnostics.message - "consecutive specifications on a line must be separated by ';' or a \ - newline") + if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then () + else + Parser.err ~startPos:p.prevEndPos ~endPos:p.endPos p + (Diagnostics.message + "consecutive specifications on a line must be separated by ';' or \ + a newline") | _ -> () and parseSignatureItemRegion p = @@ -289105,102 +289460,102 @@ and parseSignatureItemRegion p = let attrs = parseAttributes p in match p.Parser.token with | Let -> - Parser.beginRegion p; - let valueDesc = parseSignLetDesc ~attrs p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Sig.value ~loc valueDesc) - | Typ -> ( - Parser.beginRegion p; - match parseTypeDefinitionOrExtension ~attrs p with - | TypeDef {recFlag; types} -> + Parser.beginRegion p; + let valueDesc = parseSignLetDesc ~attrs p in parseNewlineOrSemicolonSignature p; let loc = mkLoc startPos p.prevEndPos in Parser.endRegion p; - Some (Ast_helper.Sig.type_ ~loc recFlag types) - | TypeExt ext -> + Some (Ast_helper.Sig.value ~loc valueDesc) + | Typ -> ( + Parser.beginRegion p; + match parseTypeDefinitionOrExtension ~attrs p with + | TypeDef { recFlag; types } -> + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some (Ast_helper.Sig.type_ ~loc recFlag types) + | TypeExt ext -> + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some (Ast_helper.Sig.type_extension ~loc ext)) + | External -> + let externalDef = parseExternalDef ~attrs ~startPos p in parseNewlineOrSemicolonSignature p; let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Sig.type_extension ~loc ext)) - | External -> - let externalDef = parseExternalDef ~attrs ~startPos p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.value ~loc externalDef) + Some (Ast_helper.Sig.value ~loc externalDef) | Exception -> - let exceptionDef = parseExceptionDef ~attrs p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.exception_ ~loc exceptionDef) - | Open -> - let openDescription = parseOpenDescription ~attrs p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.open_ ~loc openDescription) - | Include -> - Parser.next p; - let moduleType = parseModuleType p in - let includeDescription = - Ast_helper.Incl.mk ~loc:(mkLoc startPos p.prevEndPos) ~attrs moduleType - in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.include_ ~loc includeDescription) - | Module -> ( - Parser.beginRegion p; - Parser.next p; - match p.Parser.token with - | Uident _ -> - let modDecl = parseModuleDeclarationOrAlias ~attrs p in + let exceptionDef = parseExceptionDef ~attrs p in parseNewlineOrSemicolonSignature p; let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Sig.module_ ~loc modDecl) - | Rec -> - let recModule = parseRecModuleSpec ~attrs ~startPos p in + Some (Ast_helper.Sig.exception_ ~loc exceptionDef) + | Open -> + let openDescription = parseOpenDescription ~attrs p in parseNewlineOrSemicolonSignature p; let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Sig.rec_module ~loc recModule) - | Typ -> - let modTypeDecl = parseModuleTypeDeclaration ~attrs ~startPos p in - Parser.endRegion p; - Some modTypeDecl - | _t -> - let modDecl = parseModuleDeclarationOrAlias ~attrs p in + Some (Ast_helper.Sig.open_ ~loc openDescription) + | Include -> + Parser.next p; + let moduleType = parseModuleType p in + let includeDescription = + Ast_helper.Incl.mk ~loc:(mkLoc startPos p.prevEndPos) ~attrs moduleType + in parseNewlineOrSemicolonSignature p; let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Sig.module_ ~loc modDecl)) + Some (Ast_helper.Sig.include_ ~loc includeDescription) + | Module -> ( + Parser.beginRegion p; + Parser.next p; + match p.Parser.token with + | Uident _ -> + let modDecl = parseModuleDeclarationOrAlias ~attrs p in + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some (Ast_helper.Sig.module_ ~loc modDecl) + | Rec -> + let recModule = parseRecModuleSpec ~attrs ~startPos p in + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some (Ast_helper.Sig.rec_module ~loc recModule) + | Typ -> + let modTypeDecl = parseModuleTypeDeclaration ~attrs ~startPos p in + Parser.endRegion p; + Some modTypeDecl + | _t -> + let modDecl = parseModuleDeclarationOrAlias ~attrs p in + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some (Ast_helper.Sig.module_ ~loc modDecl)) | AtAt -> - let attr = parseStandaloneAttribute p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.attribute ~loc attr) + let attr = parseStandaloneAttribute p in + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Sig.attribute ~loc attr) | ModuleComment (loc, s) -> - Parser.next p; - Some - (Ast_helper.Sig.attribute ~loc - ( {txt = "ns.doc"; loc}, - PStr - [ - Ast_helper.Str.eval ~loc - (Ast_helper.Exp.constant ~loc (Pconst_string (s, None))); - ] )) + Parser.next p; + Some + (Ast_helper.Sig.attribute ~loc + ( { txt = "ns.doc"; loc }, + PStr + [ + Ast_helper.Str.eval ~loc + (Ast_helper.Exp.constant ~loc (Pconst_string (s, None))); + ] )) | PercentPercent -> - let extension = parseExtension ~moduleLanguage:true p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.extension ~attrs ~loc extension) + let extension = parseExtension ~moduleLanguage:true p in + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Sig.extension ~attrs ~loc extension) | _ -> ( - match attrs with - | (({Asttypes.loc = attrLoc}, _) as attr) :: _ -> - Parser.err ~startPos:attrLoc.loc_start ~endPos:attrLoc.loc_end p - (Diagnostics.message (ErrorMessages.attributeWithoutNode attr)); - Some Recover.defaultSignatureItem - | _ -> None) + match attrs with + | (({ Asttypes.loc = attrLoc }, _) as attr) :: _ -> + Parser.err ~startPos:attrLoc.loc_start ~endPos:attrLoc.loc_end p + (Diagnostics.message (ErrorMessages.attributeWithoutNode attr)); + Some Recover.defaultSignatureItem + | _ -> None) [@@progress Parser.next, Parser.expect] (* module rec module-name : module-type { and module-name: module-type } *) @@ -289211,31 +289566,31 @@ and parseRecModuleSpec ~attrs ~startPos p = let attrs = parseAttributesAndBinding p in match p.Parser.token with | And -> - (* TODO: give a good error message when with constraint, no parens - * and ASet: (Set.S with type elt = A.t) - * and BTree: (Btree.S with type elt = A.t) - * Without parens, the `and` signals the start of another - * `with-constraint` - *) - Parser.expect And p; - let decl = parseRecModuleDeclaration ~attrs ~startPos p in - loop p (decl :: spec) + (* TODO: give a good error message when with constraint, no parens + * and ASet: (Set.S with type elt = A.t) + * and BTree: (Btree.S with type elt = A.t) + * Without parens, the `and` signals the start of another + * `with-constraint` + *) + Parser.expect And p; + let decl = parseRecModuleDeclaration ~attrs ~startPos p in + loop p (decl :: spec) | _ -> List.rev spec in let first = parseRecModuleDeclaration ~attrs ~startPos p in - loop p [first] + loop p [ first ] (* module-name : module-type *) and parseRecModuleDeclaration ~attrs ~startPos p = let name = match p.Parser.token with | Uident modName -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Location.mkloc modName loc + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc modName loc | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" in Parser.expect Colon p; let modType = parseModuleType p in @@ -289246,25 +289601,25 @@ and parseModuleDeclarationOrAlias ~attrs p = let moduleName = match p.Parser.token with | Uident ident -> - let loc = mkLoc p.Parser.startPos p.endPos in - Parser.next p; - Location.mkloc ident loc + let loc = mkLoc p.Parser.startPos p.endPos in + Parser.next p; + Location.mkloc ident loc | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" in let body = match p.Parser.token with | Colon -> - Parser.next p; - parseModuleType p + Parser.next p; + parseModuleType p | Equal -> - Parser.next p; - let lident = parseModuleLongIdent ~lowercase:false p in - Ast_helper.Mty.alias lident + Parser.next p; + let lident = parseModuleLongIdent ~lowercase:false p in + Ast_helper.Mty.alias lident | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Recover.defaultModuleType () + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Recover.defaultModuleType () in let loc = mkLoc startPos p.prevEndPos in Ast_helper.Md.mk ~loc ~attrs moduleName body @@ -289274,22 +289629,22 @@ and parseModuleTypeDeclaration ~attrs ~startPos p = let moduleName = match p.Parser.token with | Uident ident -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Location.mkloc ident loc + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc ident loc | Lident ident -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Location.mkloc ident loc + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc ident loc | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" in let typ = match p.Parser.token with | Equal -> - Parser.next p; - Some (parseModuleType p) + Parser.next p; + Some (parseModuleType p) | _ -> None in let moduleDecl = Ast_helper.Mtd.mk ~attrs ?typ moduleName in @@ -289312,24 +289667,24 @@ and parseAttributeId ~startPos p = let rec loop p acc = match p.Parser.token with | Lident ident | Uident ident -> ( - Parser.next p; - let id = acc ^ ident in - match p.Parser.token with - | Dot -> Parser.next p; - loop p (id ^ ".") - | _ -> id) + let id = acc ^ ident in + match p.Parser.token with + | Dot -> + Parser.next p; + loop p (id ^ ".") + | _ -> id) | token when Token.isKeyword token -> ( - Parser.next p; - let id = acc ^ Token.toString token in - match p.Parser.token with - | Dot -> Parser.next p; - loop p (id ^ ".") - | _ -> id) + let id = acc ^ Token.toString token in + match p.Parser.token with + | Dot -> + Parser.next p; + loop p (id ^ ".") + | _ -> id) | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - acc + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + acc in let id = loop p "" in let endPos = p.prevEndPos in @@ -289348,62 +289703,62 @@ and parseAttributeId ~startPos p = and parsePayload p = match p.Parser.token with | Lparen when p.startPos.pos_cnum = p.prevEndPos.pos_cnum -> ( - Parser.leaveBreadcrumb p Grammar.AttributePayload; - Parser.next p; - match p.token with - | Colon -> - Parser.next p; - let payload = - if Grammar.isSignatureItemStart p.token then - Parsetree.PSig - (parseDelimitedRegion ~grammar:Grammar.Signature ~closing:Rparen - ~f:parseSignatureItemRegion p) - else Parsetree.PTyp (parseTypExpr p) - in - Parser.expect Rparen p; - Parser.eatBreadcrumb p; - payload - | Question -> + Parser.leaveBreadcrumb p Grammar.AttributePayload; Parser.next p; - let pattern = parsePattern p in - let expr = - match p.token with - | When | If -> + match p.token with + | Colon -> Parser.next p; - Some (parseExpr p) - | _ -> None - in - Parser.expect Rparen p; - Parser.eatBreadcrumb p; - Parsetree.PPat (pattern, expr) - | _ -> - let items = - parseDelimitedRegion ~grammar:Grammar.Structure ~closing:Rparen - ~f:parseStructureItemRegion p - in - Parser.expect Rparen p; - Parser.eatBreadcrumb p; - Parsetree.PStr items) + let payload = + if Grammar.isSignatureItemStart p.token then + Parsetree.PSig + (parseDelimitedRegion ~grammar:Grammar.Signature ~closing:Rparen + ~f:parseSignatureItemRegion p) + else Parsetree.PTyp (parseTypExpr p) + in + Parser.expect Rparen p; + Parser.eatBreadcrumb p; + payload + | Question -> + Parser.next p; + let pattern = parsePattern p in + let expr = + match p.token with + | When | If -> + Parser.next p; + Some (parseExpr p) + | _ -> None + in + Parser.expect Rparen p; + Parser.eatBreadcrumb p; + Parsetree.PPat (pattern, expr) + | _ -> + let items = + parseDelimitedRegion ~grammar:Grammar.Structure ~closing:Rparen + ~f:parseStructureItemRegion p + in + Parser.expect Rparen p; + Parser.eatBreadcrumb p; + Parsetree.PStr items) | _ -> Parsetree.PStr [] (* type attribute = string loc * payload *) and parseAttribute p = match p.Parser.token with | At -> - let startPos = p.startPos in - Parser.next p; - let attrId = parseAttributeId ~startPos p in - let payload = parsePayload p in - Some (attrId, payload) + let startPos = p.startPos in + Parser.next p; + let attrId = parseAttributeId ~startPos p in + let payload = parsePayload p in + Some (attrId, payload) | DocComment (loc, s) -> - Parser.next p; - Some - ( {txt = "ns.doc"; loc}, - PStr - [ - Ast_helper.Str.eval ~loc - (Ast_helper.Exp.constant ~loc (Pconst_string (s, None))); - ] ) + Parser.next p; + Some + ( { txt = "ns.doc"; loc }, + PStr + [ + Ast_helper.Str.eval ~loc + (Ast_helper.Exp.constant ~loc (Pconst_string (s, None))); + ] ) | _ -> None and parseAttributes p = @@ -289503,24 +289858,24 @@ end module Res_driver : sig #1 "res_driver.mli" type ('ast, 'diagnostics) parseResult = { - filename: string; [@live] - source: string; - parsetree: 'ast; - diagnostics: 'diagnostics; - invalid: bool; - comments: Res_comment.t list; + filename : string; [@live] + source : string; + parsetree : 'ast; + diagnostics : 'diagnostics; + invalid : bool; + comments : Res_comment.t list; } type 'diagnostics parsingEngine = { - parseImplementation: + parseImplementation : forPrinter:bool -> filename:string -> (Parsetree.structure, 'diagnostics) parseResult; - parseInterface: + parseInterface : forPrinter:bool -> filename:string -> (Parsetree.signature, 'diagnostics) parseResult; - stringOfDiagnostics: source:string -> filename:string -> 'diagnostics -> unit; + stringOfDiagnostics : source:string -> filename:string -> 'diagnostics -> unit; } val parseImplementationFromSource : @@ -289538,13 +289893,13 @@ val parseInterfaceFromSource : [@@live] type printEngine = { - printImplementation: + printImplementation : width:int -> filename:string -> comments:Res_comment.t list -> Parsetree.structure -> unit; - printInterface: + printInterface : width:int -> filename:string -> comments:Res_comment.t list -> @@ -289553,7 +289908,6 @@ type printEngine = { } val parsingEngine : Res_diagnostics.t list parsingEngine - val printEngine : printEngine (* ReScript implementation parsing compatible with ocaml pparse driver. Used by the compiler. *) @@ -289569,34 +289923,34 @@ end = struct module IO = Res_io type ('ast, 'diagnostics) parseResult = { - filename: string; [@live] - source: string; - parsetree: 'ast; - diagnostics: 'diagnostics; - invalid: bool; - comments: Res_comment.t list; + filename : string; [@live] + source : string; + parsetree : 'ast; + diagnostics : 'diagnostics; + invalid : bool; + comments : Res_comment.t list; } type 'diagnostics parsingEngine = { - parseImplementation: + parseImplementation : forPrinter:bool -> filename:string -> (Parsetree.structure, 'diagnostics) parseResult; - parseInterface: + parseInterface : forPrinter:bool -> filename:string -> (Parsetree.signature, 'diagnostics) parseResult; - stringOfDiagnostics: source:string -> filename:string -> 'diagnostics -> unit; + stringOfDiagnostics : source:string -> filename:string -> 'diagnostics -> unit; } type printEngine = { - printImplementation: + printImplementation : width:int -> filename:string -> comments:Res_comment.t list -> Parsetree.structure -> unit; - printInterface: + printInterface : width:int -> filename:string -> comments:Res_comment.t list -> @@ -289734,11 +290088,11 @@ module Res_outcome_printer : sig * In general it represent messages to show results or errors to the user. *) val parenthesized_ident : string -> bool [@@live] - val setup : unit lazy_t [@@live] (* Needed for e.g. the playground to print typedtree data *) val printOutTypeDoc : Outcometree.out_type -> Res_doc.t [@@live] + val printOutSigItemDoc : ?printNameAsIs:bool -> Outcometree.out_sig_item -> Res_doc.t [@@live] @@ -289775,10 +290129,7 @@ let isValidNumericPolyvarNumber (x : string) = a <= 57 && if len > 1 then - a > 48 - && for_all_from x 1 (function - | '0' .. '9' -> true - | _ -> false) + a > 48 && for_all_from x 1 (function '0' .. '9' -> true | _ -> false) else a >= 48 (* checks if ident contains "arity", like in "arity1", "arity2", "arity3" etc. *) @@ -289815,7 +290166,7 @@ let classifyIdentContent ~allowUident txt = let printIdentLike ~allowUident txt = match classifyIdentContent ~allowUident txt with - | ExoticIdent -> Doc.concat [Doc.text "\\\""; Doc.text txt; Doc.text "\""] + | ExoticIdent -> Doc.concat [ Doc.text "\\\""; Doc.text txt; Doc.text "\"" ] | NormalIdent -> Doc.text txt let printPolyVarIdent txt = @@ -289823,7 +290174,7 @@ let printPolyVarIdent txt = if isValidNumericPolyvarNumber txt then Doc.text txt else match classifyIdentContent ~allowUident:true txt with - | ExoticIdent -> Doc.concat [Doc.text "\""; Doc.text txt; Doc.text "\""] + | ExoticIdent -> Doc.concat [ Doc.text "\""; Doc.text txt; Doc.text "\"" ] | NormalIdent -> Doc.text txt (* ReScript doesn't have parenthesized identifiers. @@ -289874,208 +290225,211 @@ let rec printOutIdentDoc ?(allowUident = true) (ident : Outcometree.out_ident) = match ident with | Oide_ident s -> printIdentLike ~allowUident s | Oide_dot (ident, s) -> - Doc.concat [printOutIdentDoc ident; Doc.dot; Doc.text s] + Doc.concat [ printOutIdentDoc ident; Doc.dot; Doc.text s ] | Oide_apply (call, arg) -> - Doc.concat - [printOutIdentDoc call; Doc.lparen; printOutIdentDoc arg; Doc.rparen] + Doc.concat + [ printOutIdentDoc call; Doc.lparen; printOutIdentDoc arg; Doc.rparen ] let printOutAttributeDoc (outAttribute : Outcometree.out_attribute) = - Doc.concat [Doc.text "@"; Doc.text outAttribute.oattr_name] + Doc.concat [ Doc.text "@"; Doc.text outAttribute.oattr_name ] let printOutAttributesDoc (attrs : Outcometree.out_attribute list) = match attrs with | [] -> Doc.nil | attrs -> - Doc.concat - [ - Doc.group (Doc.join ~sep:Doc.line (List.map printOutAttributeDoc attrs)); - Doc.line; - ] + Doc.concat + [ + Doc.group + (Doc.join ~sep:Doc.line (List.map printOutAttributeDoc attrs)); + Doc.line; + ] let rec collectArrowArgs (outType : Outcometree.out_type) args = match outType with | Otyp_arrow (label, argType, returnType) -> - let arg = (label, argType) in - collectArrowArgs returnType (arg :: args) + let arg = (label, argType) in + collectArrowArgs returnType (arg :: args) | _ as returnType -> (List.rev args, returnType) let rec collectFunctorArgs (outModuleType : Outcometree.out_module_type) args = match outModuleType with | Omty_functor (lbl, optModType, returnModType) -> - let arg = (lbl, optModType) in - collectFunctorArgs returnModType (arg :: args) + let arg = (lbl, optModType) in + collectFunctorArgs returnModType (arg :: args) | _ -> (List.rev args, outModuleType) let rec printOutTypeDoc (outType : Outcometree.out_type) = match outType with | Otyp_abstract | Otyp_open -> Doc.nil | Otyp_variant (nonGen, outVariant, closed, labels) -> - (* bool * out_variant * bool * (string list) option *) - let opening = - match (closed, labels) with - | true, None -> (* [#A | #B] *) Doc.softLine - | false, None -> - (* [> #A | #B] *) - Doc.concat [Doc.greaterThan; Doc.line] - | true, Some [] -> - (* [< #A | #B] *) - Doc.concat [Doc.lessThan; Doc.line] - | true, Some _ -> - (* [< #A | #B > #X #Y ] *) - Doc.concat [Doc.lessThan; Doc.line] - | false, Some _ -> - (* impossible!? ocaml seems to print ?, see oprint.ml in 4.06 *) - Doc.concat [Doc.text "?"; Doc.line] - in - Doc.group - (Doc.concat - [ - (if nonGen then Doc.text "_" else Doc.nil); - Doc.lbracket; - Doc.indent (Doc.concat [opening; printOutVariant outVariant]); - (match labels with - | None | Some [] -> Doc.nil - | Some tags -> - Doc.group - (Doc.concat - [ - Doc.space; - Doc.join ~sep:Doc.space - (List.map - (fun lbl -> printIdentLike ~allowUident:true lbl) - tags); - ])); - Doc.softLine; - Doc.rbracket; - ]) + (* bool * out_variant * bool * (string list) option *) + let opening = + match (closed, labels) with + | true, None -> (* [#A | #B] *) Doc.softLine + | false, None -> + (* [> #A | #B] *) + Doc.concat [ Doc.greaterThan; Doc.line ] + | true, Some [] -> + (* [< #A | #B] *) + Doc.concat [ Doc.lessThan; Doc.line ] + | true, Some _ -> + (* [< #A | #B > #X #Y ] *) + Doc.concat [ Doc.lessThan; Doc.line ] + | false, Some _ -> + (* impossible!? ocaml seems to print ?, see oprint.ml in 4.06 *) + Doc.concat [ Doc.text "?"; Doc.line ] + in + Doc.group + (Doc.concat + [ + (if nonGen then Doc.text "_" else Doc.nil); + Doc.lbracket; + Doc.indent (Doc.concat [ opening; printOutVariant outVariant ]); + (match labels with + | None | Some [] -> Doc.nil + | Some tags -> + Doc.group + (Doc.concat + [ + Doc.space; + Doc.join ~sep:Doc.space + (List.map + (fun lbl -> printIdentLike ~allowUident:true lbl) + tags); + ])); + Doc.softLine; + Doc.rbracket; + ]) | Otyp_alias (typ, aliasTxt) -> - Doc.concat - [ - Doc.lparen; - printOutTypeDoc typ; - Doc.text " as '"; - Doc.text aliasTxt; - Doc.rparen; - ] + Doc.concat + [ + Doc.lparen; + printOutTypeDoc typ; + Doc.text " as '"; + Doc.text aliasTxt; + Doc.rparen; + ] | Otyp_constr ( Oide_dot (Oide_dot (Oide_ident "Js", "Fn"), "arity0"), (* Js.Fn.arity0 *) - [typ] ) -> - (* Js.Fn.arity0 -> (.) => t *) - Doc.concat [Doc.text "(. ()) => "; printOutTypeDoc typ] + [ typ ] ) -> + (* Js.Fn.arity0 -> (.) => t *) + Doc.concat [ Doc.text "(. ()) => "; printOutTypeDoc typ ] | Otyp_constr ( Oide_dot (Oide_dot (Oide_ident "Js", "Fn"), ident), (* Js.Fn.arity2 *) - [(Otyp_arrow _ as arrowType)] (* (int, int) => int *) ) + [ (Otyp_arrow _ as arrowType) ] + (* (int, int) => int *) ) when isArityIdent ident -> - (* Js.Fn.arity2<(int, int) => int> -> (. int, int) => int*) - printOutArrowType ~uncurried:true arrowType + (* Js.Fn.arity2<(int, int) => int> -> (. int, int) => int*) + printOutArrowType ~uncurried:true arrowType | Otyp_constr (outIdent, []) -> printOutIdentDoc ~allowUident:false outIdent | Otyp_manifest (typ1, typ2) -> - Doc.concat [printOutTypeDoc typ1; Doc.text " = "; printOutTypeDoc typ2] + Doc.concat [ printOutTypeDoc typ1; Doc.text " = "; printOutTypeDoc typ2 ] | Otyp_record record -> printRecordDeclarationDoc ~inline:true record | Otyp_stuff txt -> Doc.text txt | Otyp_var (ng, s) -> - Doc.concat [Doc.text ("'" ^ if ng then "_" else ""); Doc.text s] + Doc.concat [ Doc.text ("'" ^ if ng then "_" else ""); Doc.text s ] | Otyp_object (fields, rest) -> printObjectFields fields rest | Otyp_class _ -> Doc.nil | Otyp_attribute (typ, attribute) -> - Doc.group - (Doc.concat - [printOutAttributeDoc attribute; Doc.line; printOutTypeDoc typ]) + Doc.group + (Doc.concat + [ printOutAttributeDoc attribute; Doc.line; printOutTypeDoc typ ]) (* example: Red | Blue | Green | CustomColour(float, float, float) *) | Otyp_sum constructors -> printOutConstructorsDoc constructors (* example: {"name": string, "age": int} *) - | Otyp_constr (Oide_dot (Oide_ident "Js", "t"), [Otyp_object (fields, rest)]) + | Otyp_constr (Oide_dot (Oide_ident "Js", "t"), [ Otyp_object (fields, rest) ]) -> - printObjectFields fields rest + printObjectFields fields rest (* example: node *) | Otyp_constr (outIdent, args) -> - let argsDoc = - match args with - | [] -> Doc.nil - | args -> - Doc.concat - [ - Doc.lessThan; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printOutTypeDoc args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.greaterThan; - ] - in - Doc.group (Doc.concat [printOutIdentDoc outIdent; argsDoc]) + let argsDoc = + match args with + | [] -> Doc.nil + | args -> + Doc.concat + [ + Doc.lessThan; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map printOutTypeDoc args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.greaterThan; + ] + in + Doc.group (Doc.concat [ printOutIdentDoc outIdent; argsDoc ]) | Otyp_tuple tupleArgs -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printOutTypeDoc tupleArgs); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map printOutTypeDoc tupleArgs); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) | Otyp_poly (vars, outType) -> - Doc.group - (Doc.concat - [ - Doc.join ~sep:Doc.space - (List.map (fun var -> Doc.text ("'" ^ var)) vars); - Doc.dot; - Doc.space; - printOutTypeDoc outType; - ]) + Doc.group + (Doc.concat + [ + Doc.join ~sep:Doc.space + (List.map (fun var -> Doc.text ("'" ^ var)) vars); + Doc.dot; + Doc.space; + printOutTypeDoc outType; + ]) | Otyp_arrow _ as typ -> printOutArrowType ~uncurried:false typ | Otyp_module (modName, stringList, outTypes) -> - let packageTypeDoc = - match (stringList, outTypes) with - | [], [] -> Doc.nil - | labels, types -> - let i = ref 0 in - let package = - Doc.join ~sep:Doc.line - ((List.map2 [@doesNotRaise]) - (fun lbl typ -> - Doc.concat - [ - Doc.text - (if i.contents > 0 then "and type " else "with type "); - Doc.text lbl; - Doc.text " = "; - printOutTypeDoc typ; - ]) - labels types) - in - Doc.indent (Doc.concat [Doc.line; package]) - in - Doc.concat - [ - Doc.text "module"; - Doc.lparen; - Doc.text modName; - packageTypeDoc; - Doc.rparen; - ] + let packageTypeDoc = + match (stringList, outTypes) with + | [], [] -> Doc.nil + | labels, types -> + let i = ref 0 in + let package = + Doc.join ~sep:Doc.line + ((List.map2 [@doesNotRaise]) + (fun lbl typ -> + Doc.concat + [ + Doc.text + (if i.contents > 0 then "and type " + else "with type "); + Doc.text lbl; + Doc.text " = "; + printOutTypeDoc typ; + ]) + labels types) + in + Doc.indent (Doc.concat [ Doc.line; package ]) + in + Doc.concat + [ + Doc.text "module"; + Doc.lparen; + Doc.text modName; + packageTypeDoc; + Doc.rparen; + ] and printOutArrowType ~uncurried typ = let typArgs, typ = collectArrowArgs typ [] in let args = Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) (List.map (fun (lbl, typ) -> let lblLen = String.length lbl in @@ -290085,7 +290439,8 @@ and printOutArrowType ~uncurried typ = (* the ocaml compiler hardcodes the optional label inside the string of the label in printtyp.ml *) match String.unsafe_get lbl 0 with | '?' -> - ((String.sub [@doesNotRaise]) lbl 1 (lblLen - 1), Doc.text "=?") + ( (String.sub [@doesNotRaise]) lbl 1 (lblLen - 1), + Doc.text "=?" ) | _ -> (lbl, Doc.nil) in Doc.group @@ -290101,9 +290456,9 @@ and printOutArrowType ~uncurried typ = let needsParens = match typArgs with | _ when uncurried -> true - | [(_, (Otyp_tuple _ | Otyp_arrow _))] -> true + | [ (_, (Otyp_tuple _ | Otyp_arrow _)) ] -> true (* single argument should not be wrapped *) - | [("", _)] -> false + | [ ("", _) ] -> false | _ -> true in if needsParens then @@ -290111,70 +290466,72 @@ and printOutArrowType ~uncurried typ = (Doc.concat [ (if uncurried then Doc.text "(. " else Doc.lparen); - Doc.indent (Doc.concat [Doc.softLine; args]); + Doc.indent (Doc.concat [ Doc.softLine; args ]); Doc.trailingComma; Doc.softLine; Doc.rparen; ]) else args in - Doc.concat [argsDoc; Doc.text " => "; printOutTypeDoc typ] + Doc.concat [ argsDoc; Doc.text " => "; printOutTypeDoc typ ] and printOutVariant variant = match variant with | Ovar_fields fields -> - (* (string * bool * out_type list) list *) - Doc.join ~sep:Doc.line - ((* - * [< | #T([< u2]) & ([< u2]) & ([< u1])] --> no ampersand - * [< | #S & ([< u2]) & ([< u2]) & ([< u1])] --> ampersand - *) - List.mapi - (fun i (name, ampersand, types) -> - let needsParens = - match types with - | [Outcometree.Otyp_tuple _] -> false - | _ -> true - in - Doc.concat - [ - (if i > 0 then Doc.text "| " - else Doc.ifBreaks (Doc.text "| ") Doc.nil); - Doc.group - (Doc.concat - [ - Doc.text "#"; - printPolyVarIdent name; - (match types with - | [] -> Doc.nil - | types -> - Doc.concat - [ - (if ampersand then Doc.text " & " else Doc.nil); - Doc.indent - (Doc.concat - [ - Doc.join - ~sep:(Doc.concat [Doc.text " &"; Doc.line]) - (List.map - (fun typ -> - let outTypeDoc = - printOutTypeDoc typ - in - if needsParens then - Doc.concat - [ - Doc.lparen; - outTypeDoc; - Doc.rparen; - ] - else outTypeDoc) - types); - ]); - ]); - ]); - ]) - fields) + (* (string * bool * out_type list) list *) + Doc.join ~sep:Doc.line + ((* + * [< | #T([< u2]) & ([< u2]) & ([< u1])] --> no ampersand + * [< | #S & ([< u2]) & ([< u2]) & ([< u1])] --> ampersand + *) + List.mapi + (fun i (name, ampersand, types) -> + let needsParens = + match types with + | [ Outcometree.Otyp_tuple _ ] -> false + | _ -> true + in + Doc.concat + [ + (if i > 0 then Doc.text "| " + else Doc.ifBreaks (Doc.text "| ") Doc.nil); + Doc.group + (Doc.concat + [ + Doc.text "#"; + printPolyVarIdent name; + (match types with + | [] -> Doc.nil + | types -> + Doc.concat + [ + (if ampersand then Doc.text " & " else Doc.nil); + Doc.indent + (Doc.concat + [ + Doc.join + ~sep: + (Doc.concat + [ Doc.text " &"; Doc.line ]) + (List.map + (fun typ -> + let outTypeDoc = + printOutTypeDoc typ + in + if needsParens then + Doc.concat + [ + Doc.lparen; + outTypeDoc; + Doc.rparen; + ] + else outTypeDoc) + types); + ]); + ]); + ]); + ]) + fields) | Ovar_typ typ -> printOutTypeDoc typ and printObjectFields fields rest = @@ -290193,7 +290550,7 @@ and printObjectFields fields rest = [ Doc.softLine; Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) (List.map (fun (lbl, outType) -> Doc.group @@ -290230,44 +290587,44 @@ and printOutConstructorsDoc constructors = and printOutConstructorDoc (name, args, gadt) = let gadtDoc = match gadt with - | Some outType -> Doc.concat [Doc.text ": "; printOutTypeDoc outType] + | Some outType -> Doc.concat [ Doc.text ": "; printOutTypeDoc outType ] | None -> Doc.nil in let argsDoc = match args with | [] -> Doc.nil - | [Otyp_record record] -> - (* inline records - * | Root({ - * mutable value: 'value, - * mutable updatedTime: float, - * }) - *) - Doc.concat - [ - Doc.lparen; - Doc.indent (printRecordDeclarationDoc ~inline:true record); - Doc.rparen; - ] + | [ Otyp_record record ] -> + (* inline records + * | Root({ + * mutable value: 'value, + * mutable updatedTime: float, + * }) + *) + Doc.concat + [ + Doc.lparen; + Doc.indent (printRecordDeclarationDoc ~inline:true record); + Doc.rparen; + ] | _types -> - Doc.indent - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printOutTypeDoc args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) + Doc.indent + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map printOutTypeDoc args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) in - Doc.group (Doc.concat [Doc.text name; argsDoc; gadtDoc]) + Doc.group (Doc.concat [ Doc.text name; argsDoc; gadtDoc ]) and printRecordDeclRowDoc (name, mut, opt, arg) = Doc.group @@ -290290,7 +290647,7 @@ and printRecordDeclarationDoc ~inline rows = [ Doc.softLine; Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) (List.map printRecordDeclRowDoc rows); ]); Doc.trailingComma; @@ -290306,7 +290663,9 @@ let printOutType fmt outType = let printTypeParameterDoc (typ, (co, cn)) = Doc.concat [ - (if not cn then Doc.text "+" else if not co then Doc.text "-" else Doc.nil); + (if not cn then Doc.text "+" + else if not co then Doc.text "-" + else Doc.nil); (if typ = "_" then Doc.text "_" else Doc.text ("'" ^ typ)); ] @@ -290316,173 +290675,175 @@ let rec printOutSigItemDoc ?(printNameAsIs = false) | Osig_class _ | Osig_class_type _ -> Doc.nil | Osig_ellipsis -> Doc.dotdotdot | Osig_value valueDecl -> - Doc.group - (Doc.concat - [ - printOutAttributesDoc valueDecl.oval_attributes; - Doc.text + Doc.group + (Doc.concat + [ + printOutAttributesDoc valueDecl.oval_attributes; + Doc.text + (match valueDecl.oval_prims with + | [] -> "let " + | _ -> "external "); + Doc.text valueDecl.oval_name; + Doc.text ":"; + Doc.space; + printOutTypeDoc valueDecl.oval_type; (match valueDecl.oval_prims with - | [] -> "let " - | _ -> "external "); - Doc.text valueDecl.oval_name; - Doc.text ":"; - Doc.space; - printOutTypeDoc valueDecl.oval_type; - (match valueDecl.oval_prims with - | [] -> Doc.nil - | primitives -> - Doc.indent - (Doc.concat - [ - Doc.text " ="; - Doc.line; - Doc.group - (Doc.join ~sep:Doc.line - (List.map - (fun prim -> - let prim = - if - prim <> "" - && (prim.[0] [@doesNotRaise]) = '\132' - then "#rescript-external" - else prim - in - (* not display those garbage '\132' is a magic number for marshal *) - Doc.text ("\"" ^ prim ^ "\"")) - primitives)); - ])); - ]) + | [] -> Doc.nil + | primitives -> + Doc.indent + (Doc.concat + [ + Doc.text " ="; + Doc.line; + Doc.group + (Doc.join ~sep:Doc.line + (List.map + (fun prim -> + let prim = + if + prim <> "" + && (prim.[0] [@doesNotRaise]) = '\132' + then "#rescript-external" + else prim + in + (* not display those garbage '\132' is a magic number for marshal *) + Doc.text ("\"" ^ prim ^ "\"")) + primitives)); + ])); + ]) | Osig_typext (outExtensionConstructor, _outExtStatus) -> - printOutExtensionConstructorDoc outExtensionConstructor + printOutExtensionConstructorDoc outExtensionConstructor | Osig_modtype (modName, Omty_signature []) -> - Doc.concat [Doc.text "module type "; Doc.text modName] + Doc.concat [ Doc.text "module type "; Doc.text modName ] | Osig_modtype (modName, outModuleType) -> - Doc.group - (Doc.concat - [ - Doc.text "module type "; - Doc.text modName; - Doc.text " = "; - printOutModuleTypeDoc outModuleType; - ]) + Doc.group + (Doc.concat + [ + Doc.text "module type "; + Doc.text modName; + Doc.text " = "; + printOutModuleTypeDoc outModuleType; + ]) | Osig_module (modName, Omty_alias ident, _) -> - Doc.group - (Doc.concat - [ - Doc.text "module "; - Doc.text modName; - Doc.text " ="; - Doc.line; - printOutIdentDoc ident; - ]) + Doc.group + (Doc.concat + [ + Doc.text "module "; + Doc.text modName; + Doc.text " ="; + Doc.line; + printOutIdentDoc ident; + ]) | Osig_module (modName, outModType, outRecStatus) -> - Doc.group - (Doc.concat - [ - Doc.text - (match outRecStatus with - | Orec_not -> "module " - | Orec_first -> "module rec " - | Orec_next -> "and "); - Doc.text modName; - Doc.text ": "; - printOutModuleTypeDoc outModType; - ]) + Doc.group + (Doc.concat + [ + Doc.text + (match outRecStatus with + | Orec_not -> "module " + | Orec_first -> "module rec " + | Orec_next -> "and "); + Doc.text modName; + Doc.text ": "; + printOutModuleTypeDoc outModType; + ]) | Osig_type (outTypeDecl, outRecStatus) -> - (* TODO: manifest ? *) - let attrs = - match (outTypeDecl.otype_immediate, outTypeDecl.otype_unboxed) with - | false, false -> Doc.nil - | true, false -> Doc.concat [Doc.text "@immediate"; Doc.line] - | false, true -> Doc.concat [Doc.text "@unboxed"; Doc.line] - | true, true -> Doc.concat [Doc.text "@immediate @unboxed"; Doc.line] - in - let kw = - Doc.text - (match outRecStatus with - | Orec_not -> "type " - | Orec_first -> "type rec " - | Orec_next -> "and ") - in - let typeParams = - match outTypeDecl.otype_params with - | [] -> Doc.nil - | _params -> - Doc.group - (Doc.concat - [ - Doc.lessThan; - Doc.indent + (* TODO: manifest ? *) + let attrs = + match (outTypeDecl.otype_immediate, outTypeDecl.otype_unboxed) with + | false, false -> Doc.nil + | true, false -> Doc.concat [ Doc.text "@immediate"; Doc.line ] + | false, true -> Doc.concat [ Doc.text "@unboxed"; Doc.line ] + | true, true -> Doc.concat [ Doc.text "@immediate @unboxed"; Doc.line ] + in + let kw = + Doc.text + (match outRecStatus with + | Orec_not -> "type " + | Orec_first -> "type rec " + | Orec_next -> "and ") + in + let typeParams = + match outTypeDecl.otype_params with + | [] -> Doc.nil + | _params -> + Doc.group + (Doc.concat + [ + Doc.lessThan; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map printTypeParameterDoc + outTypeDecl.otype_params); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.greaterThan; + ]) + in + let privateDoc = + match outTypeDecl.otype_private with + | Asttypes.Private -> Doc.text "private " + | Public -> Doc.nil + in + let kind = + match outTypeDecl.otype_type with + | Otyp_open -> Doc.concat [ Doc.text " = "; privateDoc; Doc.text ".." ] + | Otyp_abstract -> Doc.nil + | Otyp_record record -> + Doc.concat + [ + Doc.text " = "; + privateDoc; + printRecordDeclarationDoc ~inline:false record; + ] + | typ -> Doc.concat [ Doc.text " = "; printOutTypeDoc typ ] + in + let constraints = + match outTypeDecl.otype_cstrs with + | [] -> Doc.nil + | _ -> + Doc.group + (Doc.indent (Doc.concat [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printTypeParameterDoc outTypeDecl.otype_params); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.greaterThan; - ]) - in - let privateDoc = - match outTypeDecl.otype_private with - | Asttypes.Private -> Doc.text "private " - | Public -> Doc.nil - in - let kind = - match outTypeDecl.otype_type with - | Otyp_open -> Doc.concat [Doc.text " = "; privateDoc; Doc.text ".."] - | Otyp_abstract -> Doc.nil - | Otyp_record record -> - Doc.concat - [ - Doc.text " = "; - privateDoc; - printRecordDeclarationDoc ~inline:false record; - ] - | typ -> Doc.concat [Doc.text " = "; printOutTypeDoc typ] - in - let constraints = - match outTypeDecl.otype_cstrs with - | [] -> Doc.nil - | _ -> - Doc.group - (Doc.indent - (Doc.concat - [ - Doc.hardLine; - Doc.join ~sep:Doc.line - (List.map - (fun (typ1, typ2) -> - Doc.group - (Doc.concat - [ - Doc.text "constraint "; - printOutTypeDoc typ1; - Doc.text " ="; - Doc.space; - printOutTypeDoc typ2; - ])) - outTypeDecl.otype_cstrs); - ])) - in - Doc.group - (Doc.concat - [ - attrs; - Doc.group - (Doc.concat - [ - attrs; - kw; - (if printNameAsIs then Doc.text outTypeDecl.otype_name - else printIdentLike ~allowUident:false outTypeDecl.otype_name); - typeParams; - kind; - ]); - constraints; - ]) + Doc.hardLine; + Doc.join ~sep:Doc.line + (List.map + (fun (typ1, typ2) -> + Doc.group + (Doc.concat + [ + Doc.text "constraint "; + printOutTypeDoc typ1; + Doc.text " ="; + Doc.space; + printOutTypeDoc typ2; + ])) + outTypeDecl.otype_cstrs); + ])) + in + Doc.group + (Doc.concat + [ + attrs; + Doc.group + (Doc.concat + [ + attrs; + kw; + (if printNameAsIs then Doc.text outTypeDecl.otype_name + else + printIdentLike ~allowUident:false outTypeDecl.otype_name); + typeParams; + kind; + ]); + constraints; + ]) and printOutModuleTypeDoc (outModType : Outcometree.out_module_type) = match outModType with @@ -290490,56 +290851,57 @@ and printOutModuleTypeDoc (outModType : Outcometree.out_module_type) = | Omty_ident ident -> printOutIdentDoc ident (* example: module Increment = (M: X_int) => X_int *) | Omty_functor _ -> - let args, returnModType = collectFunctorArgs outModType [] in - let argsDoc = - match args with - | [(_, None)] -> Doc.text "()" - | args -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun (lbl, optModType) -> - Doc.group - (Doc.concat - [ - Doc.text lbl; - (match optModType with - | None -> Doc.nil - | Some modType -> - Doc.concat - [ - Doc.text ": "; - printOutModuleTypeDoc modType; - ]); - ])) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) - in - Doc.group - (Doc.concat - [argsDoc; Doc.text " => "; printOutModuleTypeDoc returnModType]) + let args, returnModType = collectFunctorArgs outModType [] in + let argsDoc = + match args with + | [ (_, None) ] -> Doc.text "()" + | args -> + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun (lbl, optModType) -> + Doc.group + (Doc.concat + [ + Doc.text lbl; + (match optModType with + | None -> Doc.nil + | Some modType -> + Doc.concat + [ + Doc.text ": "; + printOutModuleTypeDoc modType; + ]); + ])) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) + in + Doc.group + (Doc.concat + [ argsDoc; Doc.text " => "; printOutModuleTypeDoc returnModType ]) | Omty_signature [] -> Doc.nil | Omty_signature signature -> - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.lbrace; - Doc.indent (Doc.concat [Doc.line; printOutSignatureDoc signature]); - Doc.softLine; - Doc.rbrace; - ]) + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat [ Doc.line; printOutSignatureDoc signature ]); + Doc.softLine; + Doc.rbrace; + ]) | Omty_alias _ident -> Doc.nil and printOutSignatureDoc (signature : Outcometree.out_sig_item list) = @@ -290547,36 +290909,36 @@ and printOutSignatureDoc (signature : Outcometree.out_sig_item list) = match signature with | [] -> List.rev acc | Outcometree.Osig_typext (ext, Oext_first) :: items -> - (* Gather together the extension constructors *) - let rec gather_extensions acc items = - match items with - | Outcometree.Osig_typext (ext, Oext_next) :: items -> + (* Gather together the extension constructors *) + let rec gather_extensions acc items = + match items with + | Outcometree.Osig_typext (ext, Oext_next) :: items -> + gather_extensions + ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc) + items + | _ -> (List.rev acc, items) + in + let exts, items = gather_extensions - ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc) + [ (ext.oext_name, ext.oext_args, ext.oext_ret_type) ] items - | _ -> (List.rev acc, items) - in - let exts, items = - gather_extensions - [(ext.oext_name, ext.oext_args, ext.oext_ret_type)] - items - in - let te = - { - Outcometree.otyext_name = ext.oext_type_name; - otyext_params = ext.oext_type_params; - otyext_constructors = exts; - otyext_private = ext.oext_private; - } - in - let doc = printOutTypeExtensionDoc te in - loop items (doc :: acc) + in + let te = + { + Outcometree.otyext_name = ext.oext_type_name; + otyext_params = ext.oext_type_params; + otyext_constructors = exts; + otyext_private = ext.oext_private; + } + in + let doc = printOutTypeExtensionDoc te in + loop items (doc :: acc) | item :: items -> - let doc = printOutSigItemDoc ~printNameAsIs:false item in - loop items (doc :: acc) + let doc = printOutSigItemDoc ~printNameAsIs:false item in + loop items (doc :: acc) in match loop signature [] with - | [doc] -> doc + | [ doc ] -> doc | docs -> Doc.breakableGroup ~forceBreak:true (Doc.join ~sep:Doc.line docs) and printOutExtensionConstructorDoc @@ -290585,24 +290947,24 @@ and printOutExtensionConstructorDoc match outExt.oext_type_params with | [] -> Doc.nil | params -> - Doc.group - (Doc.concat - [ - Doc.lessThan; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun ty -> - Doc.text (if ty = "_" then ty else "'" ^ ty)) - params); - ]); - Doc.softLine; - Doc.greaterThan; - ]) + Doc.group + (Doc.concat + [ + Doc.lessThan; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun ty -> + Doc.text (if ty = "_" then ty else "'" ^ ty)) + params); + ]); + Doc.softLine; + Doc.greaterThan; + ]) in Doc.group @@ -290624,24 +290986,24 @@ and printOutTypeExtensionDoc (typeExtension : Outcometree.out_type_extension) = match typeExtension.otyext_params with | [] -> Doc.nil | params -> - Doc.group - (Doc.concat - [ - Doc.lessThan; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun ty -> - Doc.text (if ty = "_" then ty else "'" ^ ty)) - params); - ]); - Doc.softLine; - Doc.greaterThan; - ]) + Doc.group + (Doc.concat + [ + Doc.lessThan; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun ty -> + Doc.text (if ty = "_" then ty else "'" ^ ty)) + params); + ]); + Doc.softLine; + Doc.greaterThan; + ]) in Doc.group @@ -290681,54 +291043,54 @@ let floatRepres f = | FP_nan -> "nan" | FP_infinite -> if f < 0.0 then "neg_infinity" else "infinity" | _ -> - let float_val = - let s1 = Printf.sprintf "%.12g" f in - if f = (float_of_string [@doesNotRaise]) s1 then s1 - else - let s2 = Printf.sprintf "%.15g" f in - if f = (float_of_string [@doesNotRaise]) s2 then s2 - else Printf.sprintf "%.18g" f - in - validFloatLexeme float_val + let float_val = + let s1 = Printf.sprintf "%.12g" f in + if f = (float_of_string [@doesNotRaise]) s1 then s1 + else + let s2 = Printf.sprintf "%.15g" f in + if f = (float_of_string [@doesNotRaise]) s2 then s2 + else Printf.sprintf "%.18g" f + in + validFloatLexeme float_val let rec printOutValueDoc (outValue : Outcometree.out_value) = match outValue with | Oval_array outValues -> - Doc.group - (Doc.concat - [ - Doc.lbracket; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printOutValueDoc outValues); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbracket; - ]) + Doc.group + (Doc.concat + [ + Doc.lbracket; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map printOutValueDoc outValues); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbracket; + ]) | Oval_char c -> Doc.text ("'" ^ Char.escaped c ^ "'") | Oval_constr (outIdent, outValues) -> - Doc.group - (Doc.concat - [ - printOutIdentDoc outIdent; - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printOutValueDoc outValues); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + printOutIdentDoc outIdent; + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map printOutValueDoc outValues); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) | Oval_ellipsis -> Doc.text "..." | Oval_int i -> Doc.text (Format.sprintf "%i" i) | Oval_int32 i -> Doc.text (Format.sprintf "%lil" i) @@ -290736,73 +291098,73 @@ let rec printOutValueDoc (outValue : Outcometree.out_value) = | Oval_nativeint i -> Doc.text (Format.sprintf "%nin" i) | Oval_float f -> Doc.text (floatRepres f) | Oval_list outValues -> - Doc.group - (Doc.concat - [ - Doc.text "list["; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printOutValueDoc outValues); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbracket; - ]) + Doc.group + (Doc.concat + [ + Doc.text "list["; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map printOutValueDoc outValues); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbracket; + ]) | Oval_printer fn -> - let fmt = Format.str_formatter in - fn fmt; - let str = Format.flush_str_formatter () in - Doc.text str + let fmt = Format.str_formatter in + fn fmt; + let str = Format.flush_str_formatter () in + Doc.text str | Oval_record rows -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun (outIdent, outValue) -> - Doc.group - (Doc.concat - [ - printOutIdentDoc outIdent; - Doc.text ": "; - printOutValueDoc outValue; - ])) - rows); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun (outIdent, outValue) -> + Doc.group + (Doc.concat + [ + printOutIdentDoc outIdent; + Doc.text ": "; + printOutValueDoc outValue; + ])) + rows); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) | Oval_string (txt, _sizeToPrint, _kind) -> - Doc.text (escapeStringContents txt) + Doc.text (escapeStringContents txt) | Oval_stuff txt -> Doc.text txt | Oval_tuple outValues -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printOutValueDoc outValues); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map printOutValueDoc outValues); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) (* Not supported by ReScript *) | Oval_variant _ -> Doc.nil @@ -290811,56 +291173,56 @@ let printOutExceptionDoc exc outValue = | Sys.Break -> Doc.text "Interrupted." | Out_of_memory -> Doc.text "Out of memory during evaluation." | Stack_overflow -> - Doc.text "Stack overflow during evaluation (looping recursion?)." + Doc.text "Stack overflow during evaluation (looping recursion?)." | _ -> - Doc.group - (Doc.indent - (Doc.concat - [Doc.text "Exception:"; Doc.line; printOutValueDoc outValue])) + Doc.group + (Doc.indent + (Doc.concat + [ Doc.text "Exception:"; Doc.line; printOutValueDoc outValue ])) let printOutPhraseSignature signature = let rec loop signature acc = match signature with | [] -> List.rev acc | (Outcometree.Osig_typext (ext, Oext_first), None) :: signature -> - (* Gather together extension constructors *) - let rec gather_extensions acc items = - match items with - | (Outcometree.Osig_typext (ext, Oext_next), None) :: items -> + (* Gather together extension constructors *) + let rec gather_extensions acc items = + match items with + | (Outcometree.Osig_typext (ext, Oext_next), None) :: items -> + gather_extensions + ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc) + items + | _ -> (List.rev acc, items) + in + let exts, signature = gather_extensions - ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc) - items - | _ -> (List.rev acc, items) - in - let exts, signature = - gather_extensions - [(ext.oext_name, ext.oext_args, ext.oext_ret_type)] - signature - in - let te = - { - Outcometree.otyext_name = ext.oext_type_name; - otyext_params = ext.oext_type_params; - otyext_constructors = exts; - otyext_private = ext.oext_private; - } - in - let doc = printOutTypeExtensionDoc te in - loop signature (doc :: acc) + [ (ext.oext_name, ext.oext_args, ext.oext_ret_type) ] + signature + in + let te = + { + Outcometree.otyext_name = ext.oext_type_name; + otyext_params = ext.oext_type_params; + otyext_constructors = exts; + otyext_private = ext.oext_private; + } + in + let doc = printOutTypeExtensionDoc te in + loop signature (doc :: acc) | (sigItem, optOutValue) :: signature -> - let doc = - match optOutValue with - | None -> printOutSigItemDoc sigItem - | Some outValue -> - Doc.group - (Doc.concat - [ - printOutSigItemDoc sigItem; - Doc.text " = "; - printOutValueDoc outValue; - ]) - in - loop signature (doc :: acc) + let doc = + match optOutValue with + | None -> printOutSigItemDoc sigItem + | Some outValue -> + Doc.group + (Doc.concat + [ + printOutSigItemDoc sigItem; + Doc.text " = "; + printOutValueDoc outValue; + ]) + in + loop signature (doc :: acc) in Doc.breakableGroup ~forceBreak:true (Doc.join ~sep:Doc.line (loop signature [])) @@ -290868,14 +291230,14 @@ let printOutPhraseSignature signature = let printOutPhraseDoc (outPhrase : Outcometree.out_phrase) = match outPhrase with | Ophr_eval (outValue, outType) -> - Doc.group - (Doc.concat - [ - Doc.text "- : "; - printOutTypeDoc outType; - Doc.text " ="; - Doc.indent (Doc.concat [Doc.line; printOutValueDoc outValue]); - ]) + Doc.group + (Doc.concat + [ + Doc.text "- : "; + printOutTypeDoc outType; + Doc.text " ="; + Doc.indent (Doc.concat [ Doc.line; printOutValueDoc outValue ]); + ]) | Ophr_signature [] -> Doc.nil | Ophr_signature signature -> printOutPhraseSignature signature | Ophr_exception (exc, outValue) -> printOutExceptionDoc exc outValue diff --git a/lib/4.06.1/whole_compiler.ml b/lib/4.06.1/whole_compiler.ml index d70b7c0f58..cdb5cd7f2d 100644 --- a/lib/4.06.1/whole_compiler.ml +++ b/lib/4.06.1/whole_compiler.ml @@ -179617,6 +179617,9 @@ val power_2_above : int -> int -> int val stats_to_string : Hashtbl.statistics -> string +val string_of_int_as_char : int -> string + + end = struct #1 "ext_util.ml" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. @@ -179662,6 +179665,13 @@ let stats_to_string (String.concat "," (Array.to_list (Array.map string_of_int bucket_histogram))) +let string_of_int_as_char i = + if i >= 0 && i <= 255 + then + Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) + else + Printf.sprintf "\'\\%d\'" i + end module Hash_set_gen = struct @@ -186886,12 +186896,7 @@ let rec longident f = function let longident_loc f x = pp f "%a" longident x.txt -let string_of_int_as_char i = - if i >= 0 && i <= 255 - then - Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) - else - Printf.sprintf "\'\\%d\'" i +let string_of_int_as_char i = Ext_util.string_of_int_as_char i let constant f = function | Pconst_char i -> pp f "%s" (string_of_int_as_char i) @@ -224721,24 +224726,21 @@ module Res_comment : sig type t val toString : t -> string - val loc : t -> Location.t val txt : t -> string val prevTokEndPos : t -> Lexing.position - val setPrevTokEndPos : t -> Lexing.position -> unit - val isDocComment : t -> bool - val isModuleComment : t -> bool - val isSingleLineComment : t -> bool - val makeSingleLineComment : loc:Location.t -> string -> t + val makeMultiLineComment : loc:Location.t -> docComment:bool -> standalone:bool -> string -> t + val fromOcamlComment : loc:Location.t -> txt:string -> prevTokEndPos:Lexing.position -> t + val trimSpaces : string -> string end = struct @@ -224753,26 +224755,22 @@ let styleToString s = | ModuleComment -> "ModuleComment" type t = { - txt: string; - style: style; - loc: Location.t; - mutable prevTokEndPos: Lexing.position; + txt : string; + style : style; + loc : Location.t; + mutable prevTokEndPos : Lexing.position; } let loc t = t.loc let txt t = t.txt let prevTokEndPos t = t.prevTokEndPos - let setPrevTokEndPos t pos = t.prevTokEndPos <- pos - let isSingleLineComment t = t.style = SingleLine - let isDocComment t = t.style = DocComment - let isModuleComment t = t.style = ModuleComment let toString t = - let {Location.loc_start; loc_end} = t.loc in + let { Location.loc_start; loc_end } = t.loc in Format.sprintf "(txt: %s\nstyle: %s\nlocation: %d,%d-%d,%d)" t.txt (styleToString t.style) loc_start.pos_lnum (loc_start.pos_cnum - loc_start.pos_bol) @@ -224780,7 +224778,7 @@ let toString t = (loc_end.pos_cnum - loc_end.pos_bol) let makeSingleLineComment ~loc txt = - {txt; loc; style = SingleLine; prevTokEndPos = Lexing.dummy_pos} + { txt; loc; style = SingleLine; prevTokEndPos = Lexing.dummy_pos } let makeMultiLineComment ~loc ~docComment ~standalone txt = { @@ -224793,7 +224791,7 @@ let makeMultiLineComment ~loc ~docComment ~standalone txt = } let fromOcamlComment ~loc ~txt ~prevTokEndPos = - {txt; loc; style = MultiLine; prevTokEndPos} + { txt; loc; style = MultiLine; prevTokEndPos } let trimSpaces s = let len = String.length s in @@ -224815,6 +224813,7 @@ end module Res_minibuffer : sig #1 "res_minibuffer.mli" type t + val add_char : t -> char -> unit val add_string : t -> string -> unit val contents : t -> string @@ -224823,12 +224822,16 @@ val flush_newline : t -> unit end = struct #1 "res_minibuffer.ml" -type t = {mutable buffer: bytes; mutable position: int; mutable length: int} +type t = { + mutable buffer : bytes; + mutable position : int; + mutable length : int; +} let create n = let n = if n < 1 then 1 else n in let s = (Bytes.create [@doesNotRaise]) n in - {buffer = s; position = 0; length = n} + { buffer = s; position = 0; length = n } let contents b = (Bytes.sub_string [@doesNotRaise]) b.buffer 0 b.position @@ -224898,7 +224901,6 @@ val join : sep:t -> t list -> t (* [(doc1, sep1); (doc2,sep2)] joins as doc1 sep1 doc2 *) val joinWithSep : (t * t) list -> t - val space : t val comma : t val dot : t @@ -224938,7 +224940,6 @@ val doubleQuote : t [@@live] * force breaks from bottom to top. *) val willBreak : t -> bool - val toString : width:int -> t -> string val debug : t -> unit [@@live] @@ -224962,11 +224963,11 @@ type t = | Text of string | Concat of t list | Indent of t - | IfBreaks of {yes: t; no: t; mutable broken: bool} + | IfBreaks of { yes : t; no : t; mutable broken : bool } (* when broken is true, treat as the yes branch *) | LineSuffix of t | LineBreak of lineStyle - | Group of {mutable shouldBreak: bool; doc: t} + | Group of { mutable shouldBreak : bool; doc : t } | CustomLayout of t list | BreakParent @@ -224983,22 +224984,20 @@ let rec _concat acc l = | Text s1 :: Text s2 :: rest -> Text (s1 ^ s2) :: _concat acc rest | Nil :: rest -> _concat acc rest | Concat l2 :: rest -> - _concat (_concat acc rest) l2 (* notice the order here *) + _concat (_concat acc rest) l2 (* notice the order here *) | x :: rest -> - let rest1 = _concat acc rest in - if rest1 == rest then l else x :: rest1 + let rest1 = _concat acc rest in + if rest1 == rest then l else x :: rest1 | [] -> acc let concat l = Concat (_concat [] l) - let indent d = Indent d -let ifBreaks t f = IfBreaks {yes = t; no = f; broken = false} +let ifBreaks t f = IfBreaks { yes = t; no = f; broken = false } let lineSuffix d = LineSuffix d -let group d = Group {shouldBreak = false; doc = d} -let breakableGroup ~forceBreak d = Group {shouldBreak = forceBreak; doc = d} +let group d = Group { shouldBreak = false; doc = d } +let breakableGroup ~forceBreak d = Group { shouldBreak = forceBreak; doc = d } let customLayout gs = CustomLayout gs let breakParent = BreakParent - let space = Text " " let comma = Text "," let dot = Text "." @@ -225026,36 +225025,36 @@ let propagateForcedBreaks doc = | LineBreak (Hard | Literal) -> true | LineBreak (Classic | Soft) -> false | Indent children -> - let childForcesBreak = walk children in - childForcesBreak - | IfBreaks ({yes = trueDoc; no = falseDoc} as ib) -> - let falseForceBreak = walk falseDoc in - if falseForceBreak then ( - let _ = walk trueDoc in - ib.broken <- true; - true) - else - let forceBreak = walk trueDoc in - forceBreak - | Group ({shouldBreak = forceBreak; doc = children} as gr) -> - let childForcesBreak = walk children in - let shouldBreak = forceBreak || childForcesBreak in - gr.shouldBreak <- shouldBreak; - shouldBreak + let childForcesBreak = walk children in + childForcesBreak + | IfBreaks ({ yes = trueDoc; no = falseDoc } as ib) -> + let falseForceBreak = walk falseDoc in + if falseForceBreak then ( + let _ = walk trueDoc in + ib.broken <- true; + true) + else + let forceBreak = walk trueDoc in + forceBreak + | Group ({ shouldBreak = forceBreak; doc = children } as gr) -> + let childForcesBreak = walk children in + let shouldBreak = forceBreak || childForcesBreak in + gr.shouldBreak <- shouldBreak; + shouldBreak | Concat children -> - List.fold_left - (fun forceBreak child -> - let childForcesBreak = walk child in - forceBreak || childForcesBreak) - false children + List.fold_left + (fun forceBreak child -> + let childForcesBreak = walk child in + forceBreak || childForcesBreak) + false children | CustomLayout children -> - (* When using CustomLayout, we don't want to propagate forced breaks - * from the children up. By definition it picks the first layout that fits - * otherwise it takes the last of the list. - * However we do want to propagate forced breaks in the sublayouts. They - * might need to be broken. We just don't propagate them any higher here *) - let _ = walk (Concat children) in - false + (* When using CustomLayout, we don't want to propagate forced breaks + * from the children up. By definition it picks the first layout that fits + * otherwise it takes the last of the list. + * However we do want to propagate forced breaks in the sublayouts. They + * might need to be broken. We just don't propagate them any higher here *) + let _ = walk (Concat children) in + false in let _ = walk doc in () @@ -225063,18 +225062,18 @@ let propagateForcedBreaks doc = (* See documentation in interface file *) let rec willBreak doc = match doc with - | LineBreak (Hard | Literal) | BreakParent | Group {shouldBreak = true} -> - true - | Group {doc} | Indent doc | CustomLayout (doc :: _) -> willBreak doc + | LineBreak (Hard | Literal) | BreakParent | Group { shouldBreak = true } -> + true + | Group { doc } | Indent doc | CustomLayout (doc :: _) -> willBreak doc | Concat docs -> List.exists willBreak docs - | IfBreaks {yes; no} -> willBreak yes || willBreak no + | IfBreaks { yes; no } -> willBreak yes || willBreak no | _ -> false let join ~sep docs = let rec loop acc sep docs = match docs with | [] -> List.rev acc - | [x] -> List.rev (x :: acc) + | [ x ] -> List.rev (x :: acc) | x :: xs -> loop (sep :: x :: acc) sep xs in concat (loop [] sep docs) @@ -225083,7 +225082,7 @@ let joinWithSep docsWithSep = let rec loop acc docs = match docs with | [] -> List.rev acc - | [(x, _sep)] -> List.rev (x :: acc) + | [ (x, _sep) ] -> List.rev (x :: acc) | (x, sep) :: xs -> loop (sep :: x :: acc) xs in concat (loop [] docsWithSep) @@ -225103,32 +225102,32 @@ let fits w stack = | Flat, LineBreak Classic -> width := width.contents - 1 | Flat, LineBreak Soft -> () | Break, LineBreak _ -> result := Some true - | _, Group {shouldBreak = true; doc} -> calculate indent Break doc - | _, Group {doc} -> calculate indent mode doc - | _, IfBreaks {yes = breakDoc; broken = true} -> - calculate indent mode breakDoc - | Break, IfBreaks {yes = breakDoc} -> calculate indent mode breakDoc - | Flat, IfBreaks {no = flatDoc} -> calculate indent mode flatDoc + | _, Group { shouldBreak = true; doc } -> calculate indent Break doc + | _, Group { doc } -> calculate indent mode doc + | _, IfBreaks { yes = breakDoc; broken = true } -> + calculate indent mode breakDoc + | Break, IfBreaks { yes = breakDoc } -> calculate indent mode breakDoc + | Flat, IfBreaks { no = flatDoc } -> calculate indent mode flatDoc | _, Concat docs -> calculateConcat indent mode docs | _, CustomLayout (hd :: _) -> - (* TODO: if we have nested custom layouts, what we should do here? *) - calculate indent mode hd + (* TODO: if we have nested custom layouts, what we should do here? *) + calculate indent mode hd | _, CustomLayout [] -> () and calculateConcat indent mode docs = if result.contents == None then match docs with | [] -> () | doc :: rest -> - calculate indent mode doc; - calculateConcat indent mode rest + calculate indent mode doc; + calculateConcat indent mode rest in let rec calculateAll stack = match (result.contents, stack) with | Some r, _ -> r | None, [] -> !width >= 0 | None, (indent, mode, doc) :: rest -> - calculate indent mode doc; - calculateAll rest + calculate indent mode doc; + calculateAll rest in calculateAll stack @@ -225139,73 +225138,75 @@ let toString ~width doc = let rec process ~pos lineSuffices stack = match stack with | ((ind, mode, doc) as cmd) :: rest -> ( - match doc with - | Nil | BreakParent -> process ~pos lineSuffices rest - | Text txt -> - MiniBuffer.add_string buffer txt; - process ~pos:(String.length txt + pos) lineSuffices rest - | LineSuffix doc -> process ~pos ((ind, mode, doc) :: lineSuffices) rest - | Concat docs -> - let ops = List.map (fun doc -> (ind, mode, doc)) docs in - process ~pos lineSuffices (List.append ops rest) - | Indent doc -> process ~pos lineSuffices ((ind + 2, mode, doc) :: rest) - | IfBreaks {yes = breakDoc; broken = true} -> - process ~pos lineSuffices ((ind, mode, breakDoc) :: rest) - | IfBreaks {yes = breakDoc; no = flatDoc} -> - if mode = Break then - process ~pos lineSuffices ((ind, mode, breakDoc) :: rest) - else process ~pos lineSuffices ((ind, mode, flatDoc) :: rest) - | LineBreak lineStyle -> - if mode = Break then - match lineSuffices with - | [] -> - if lineStyle = Literal then ( - MiniBuffer.add_char buffer '\n'; - process ~pos:0 [] rest) - else ( - MiniBuffer.flush_newline buffer; - MiniBuffer.add_string buffer (String.make ind ' ' [@doesNotRaise]); - process ~pos:ind [] rest) - | _docs -> - process ~pos:ind [] - (List.concat [List.rev lineSuffices; cmd :: rest]) - else - (* mode = Flat *) - let pos = - match lineStyle with - | Classic -> - MiniBuffer.add_string buffer " "; - pos + 1 - | Hard -> - MiniBuffer.flush_newline buffer; - 0 - | Literal -> - MiniBuffer.add_char buffer '\n'; - 0 - | Soft -> pos - in - process ~pos lineSuffices rest - | Group {shouldBreak; doc} -> - if shouldBreak || not (fits (width - pos) ((ind, Flat, doc) :: rest)) - then process ~pos lineSuffices ((ind, Break, doc) :: rest) - else process ~pos lineSuffices ((ind, Flat, doc) :: rest) - | CustomLayout docs -> - let rec findGroupThatFits groups = - match groups with - | [] -> Nil - | [lastGroup] -> lastGroup - | doc :: docs -> - if fits (width - pos) ((ind, Flat, doc) :: rest) then doc - else findGroupThatFits docs - in - let doc = findGroupThatFits docs in - process ~pos lineSuffices ((ind, Flat, doc) :: rest)) + match doc with + | Nil | BreakParent -> process ~pos lineSuffices rest + | Text txt -> + MiniBuffer.add_string buffer txt; + process ~pos:(String.length txt + pos) lineSuffices rest + | LineSuffix doc -> process ~pos ((ind, mode, doc) :: lineSuffices) rest + | Concat docs -> + let ops = List.map (fun doc -> (ind, mode, doc)) docs in + process ~pos lineSuffices (List.append ops rest) + | Indent doc -> process ~pos lineSuffices ((ind + 2, mode, doc) :: rest) + | IfBreaks { yes = breakDoc; broken = true } -> + process ~pos lineSuffices ((ind, mode, breakDoc) :: rest) + | IfBreaks { yes = breakDoc; no = flatDoc } -> + if mode = Break then + process ~pos lineSuffices ((ind, mode, breakDoc) :: rest) + else process ~pos lineSuffices ((ind, mode, flatDoc) :: rest) + | LineBreak lineStyle -> + if mode = Break then + match lineSuffices with + | [] -> + if lineStyle = Literal then ( + MiniBuffer.add_char buffer '\n'; + process ~pos:0 [] rest) + else ( + MiniBuffer.flush_newline buffer; + MiniBuffer.add_string buffer + (String.make ind ' ' [@doesNotRaise]); + process ~pos:ind [] rest) + | _docs -> + process ~pos:ind [] + (List.concat [ List.rev lineSuffices; cmd :: rest ]) + else + (* mode = Flat *) + let pos = + match lineStyle with + | Classic -> + MiniBuffer.add_string buffer " "; + pos + 1 + | Hard -> + MiniBuffer.flush_newline buffer; + 0 + | Literal -> + MiniBuffer.add_char buffer '\n'; + 0 + | Soft -> pos + in + process ~pos lineSuffices rest + | Group { shouldBreak; doc } -> + if + shouldBreak || not (fits (width - pos) ((ind, Flat, doc) :: rest)) + then process ~pos lineSuffices ((ind, Break, doc) :: rest) + else process ~pos lineSuffices ((ind, Flat, doc) :: rest) + | CustomLayout docs -> + let rec findGroupThatFits groups = + match groups with + | [] -> Nil + | [ lastGroup ] -> lastGroup + | doc :: docs -> + if fits (width - pos) ((ind, Flat, doc) :: rest) then doc + else findGroupThatFits docs + in + let doc = findGroupThatFits docs in + process ~pos lineSuffices ((ind, Flat, doc) :: rest)) | [] -> ( - match lineSuffices with - | [] -> () - | suffices -> process ~pos:0 [] (List.rev suffices)) + match lineSuffices with + | [] -> () + | suffices -> process ~pos:0 [] (List.rev suffices)) in - process ~pos:0 [] [(0, Flat, doc)]; + process ~pos:0 [] [ (0, Flat, doc) ]; MiniBuffer.contents buffer let debug t = @@ -225214,82 +225215,91 @@ let debug t = | BreakParent -> text "breakparent" | Text txt -> text ("text(\"" ^ txt ^ "\")") | LineSuffix doc -> - group - (concat - [ - text "linesuffix("; - indent (concat [line; toDoc doc]); - line; - text ")"; - ]) + group + (concat + [ + text "linesuffix("; + indent (concat [ line; toDoc doc ]); + line; + text ")"; + ]) | Concat [] -> text "concat()" | Concat docs -> - group - (concat - [ - text "concat("; - indent - (concat - [ - line; - join ~sep:(concat [text ","; line]) (List.map toDoc docs); - ]); - line; - text ")"; - ]) + group + (concat + [ + text "concat("; + indent + (concat + [ + line; + join + ~sep:(concat [ text ","; line ]) + (List.map toDoc docs); + ]); + line; + text ")"; + ]) | CustomLayout docs -> - group - (concat - [ - text "customLayout("; - indent - (concat - [ - line; - join ~sep:(concat [text ","; line]) (List.map toDoc docs); - ]); - line; - text ")"; - ]) + group + (concat + [ + text "customLayout("; + indent + (concat + [ + line; + join + ~sep:(concat [ text ","; line ]) + (List.map toDoc docs); + ]); + line; + text ")"; + ]) | Indent doc -> - concat [text "indent("; softLine; toDoc doc; softLine; text ")"] - | IfBreaks {yes = trueDoc; broken = true} -> toDoc trueDoc - | IfBreaks {yes = trueDoc; no = falseDoc} -> - group - (concat - [ - text "ifBreaks("; - indent - (concat - [line; toDoc trueDoc; concat [text ","; line]; toDoc falseDoc]); - line; - text ")"; - ]) + concat [ text "indent("; softLine; toDoc doc; softLine; text ")" ] + | IfBreaks { yes = trueDoc; broken = true } -> toDoc trueDoc + | IfBreaks { yes = trueDoc; no = falseDoc } -> + group + (concat + [ + text "ifBreaks("; + indent + (concat + [ + line; + toDoc trueDoc; + concat [ text ","; line ]; + toDoc falseDoc; + ]); + line; + text ")"; + ]) | LineBreak break -> - let breakTxt = - match break with - | Classic -> "Classic" - | Soft -> "Soft" - | Hard -> "Hard" - | Literal -> "Liteal" - in - text ("LineBreak(" ^ breakTxt ^ ")") - | Group {shouldBreak; doc} -> - group - (concat - [ - text "Group("; - indent - (concat - [ - line; - text ("{shouldBreak: " ^ string_of_bool shouldBreak ^ "}"); - concat [text ","; line]; - toDoc doc; - ]); - line; - text ")"; - ]) + let breakTxt = + match break with + | Classic -> "Classic" + | Soft -> "Soft" + | Hard -> "Hard" + | Literal -> "Liteal" + in + text ("LineBreak(" ^ breakTxt ^ ")") + | Group { shouldBreak; doc } -> + group + (concat + [ + text "Group("; + indent + (concat + [ + line; + text ("{shouldBreak: " ^ string_of_bool shouldBreak ^ "}"); + concat [ text ","; line ]; + toDoc doc; + ]); + line; + text ")"; + ]) in let doc = toDoc t in toString ~width:10 doc |> print_endline @@ -225318,14 +225328,13 @@ val processUncurriedAttribute : Parsetree.attributes -> bool * Parsetree.attributes type functionAttributesInfo = { - async: bool; - uncurried: bool; - attributes: Parsetree.attributes; + async : bool; + uncurried : bool; + attributes : Parsetree.attributes; } (* determines whether a function is async and/or uncurried based on the given attributes *) val processFunctionAttributes : Parsetree.attributes -> functionAttributesInfo - val hasAwaitAttribute : Parsetree.attributes -> bool type ifConditionKind = @@ -225346,12 +225355,15 @@ val collectListExpressions : type funParamKind = | Parameter of { - attrs: Parsetree.attributes; - lbl: Asttypes.arg_label; - defaultExpr: Parsetree.expression option; - pat: Parsetree.pattern; + attrs : Parsetree.attributes; + lbl : Asttypes.arg_label; + defaultExpr : Parsetree.expression option; + pat : Parsetree.pattern; + } + | NewTypes of { + attrs : Parsetree.attributes; + locs : string Asttypes.loc list; } - | NewTypes of {attrs: Parsetree.attributes; locs: string Asttypes.loc list} val funExpr : Parsetree.expression -> @@ -225364,21 +225376,14 @@ val funExpr : * })` * Notice howe `({` and `})` "hug" or stick to each other *) val isHuggableExpression : Parsetree.expression -> bool - val isHuggablePattern : Parsetree.pattern -> bool - val isHuggableRhs : Parsetree.expression -> bool - val operatorPrecedence : string -> int - val isUnaryExpression : Parsetree.expression -> bool val isBinaryOperator : string -> bool val isBinaryExpression : Parsetree.expression -> bool - val flattenableOperators : string -> string -> bool - val hasAttributes : Parsetree.attributes -> bool - val isArrayAccess : Parsetree.expression -> bool val isTernaryExpr : Parsetree.expression -> bool val isIfLetExpr : Parsetree.expression -> bool @@ -225388,23 +225393,22 @@ val collectTernaryParts : (Parsetree.expression * Parsetree.expression) list * Parsetree.expression val parametersShouldHug : funParamKind list -> bool - val filterTernaryAttributes : Parsetree.attributes -> Parsetree.attributes val filterFragileMatchAttributes : Parsetree.attributes -> Parsetree.attributes - val isJsxExpression : Parsetree.expression -> bool val hasJsxAttribute : Parsetree.attributes -> bool val hasOptionalAttribute : Parsetree.attributes -> bool - val shouldIndentBinaryExpr : Parsetree.expression -> bool val shouldInlineRhsBinaryExpr : Parsetree.expression -> bool val hasPrintableAttributes : Parsetree.attributes -> bool val filterPrintableAttributes : Parsetree.attributes -> Parsetree.attributes + val partitionPrintableAttributes : Parsetree.attributes -> Parsetree.attributes * Parsetree.attributes val requiresSpecialCallbackPrintingLastArg : (Asttypes.arg_label * Parsetree.expression) list -> bool + val requiresSpecialCallbackPrintingFirstArg : (Asttypes.arg_label * Parsetree.expression) list -> bool @@ -225428,21 +225432,16 @@ val collectPatternsFromListConstruct : Parsetree.pattern list * Parsetree.pattern val isBlockExpr : Parsetree.expression -> bool - val isTemplateLiteral : Parsetree.expression -> bool val hasTemplateLiteralAttr : Parsetree.attributes -> bool - val isSpreadBeltListConcat : Parsetree.expression -> bool - val collectOrPatternChain : Parsetree.pattern -> Parsetree.pattern list val processBracesAttr : Parsetree.expression -> Parsetree.attribute option * Parsetree.expression val filterParsingAttrs : Parsetree.attributes -> Parsetree.attributes - val isBracedExpr : Parsetree.expression -> bool - val isSinglePipeExpr : Parsetree.expression -> bool (* (__x) => f(a, __x, c) -----> f(a, _, c) *) @@ -225450,9 +225449,7 @@ val rewriteUnderscoreApply : Parsetree.expression -> Parsetree.expression (* (__x) => f(a, __x, c) -----> f(a, _, c) *) val isUnderscoreApplySugar : Parsetree.expression -> bool - val hasIfLetAttribute : Parsetree.attributes -> bool - val isRewrittenUnderscoreApplySugar : Parsetree.expression -> bool end = struct @@ -225466,31 +225463,33 @@ let arrowType ct = ptyp_desc = Ptyp_arrow ((Nolabel as lbl), typ1, typ2); ptyp_attributes = []; } -> - let arg = ([], lbl, typ1) in - process attrsBefore (arg :: acc) typ2 + let arg = ([], lbl, typ1) in + process attrsBefore (arg :: acc) typ2 | { ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); - ptyp_attributes = [({txt = "bs"}, _)]; + ptyp_attributes = [ ({ txt = "bs" }, _) ]; } -> - (* stop here, the uncurried attribute always indicates the beginning of an arrow function - * e.g. `(. int) => (. int)` instead of `(. int, . int)` *) - (attrsBefore, List.rev acc, typ) - | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = _attrs} - as returnType -> - let args = List.rev acc in - (attrsBefore, args, returnType) + (* stop here, the uncurried attribute always indicates the beginning of an arrow function + * e.g. `(. int) => (. int)` instead of `(. int, . int)` *) + (attrsBefore, List.rev acc, typ) + | { + ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); + ptyp_attributes = _attrs; + } as returnType -> + let args = List.rev acc in + (attrsBefore, args, returnType) | { ptyp_desc = Ptyp_arrow (((Labelled _ | Optional _) as lbl), typ1, typ2); ptyp_attributes = attrs; } -> - let arg = (attrs, lbl, typ1) in - process attrsBefore (arg :: acc) typ2 + let arg = (attrs, lbl, typ1) in + process attrsBefore (arg :: acc) typ2 | typ -> (attrsBefore, List.rev acc, typ) in match ct with - | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = attrs} as - typ -> - process attrs [] {typ with ptyp_attributes = []} + | { ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = attrs } + as typ -> + process attrs [] { typ with ptyp_attributes = [] } | typ -> process [] [] typ let functorType modtype = @@ -225500,8 +225499,8 @@ let functorType modtype = pmty_desc = Pmty_functor (lbl, argType, returnType); pmty_attributes = attrs; } -> - let arg = (attrs, lbl, argType) in - process (arg :: acc) returnType + let arg = (attrs, lbl, argType) in + process (arg :: acc) returnType | modType -> (List.rev acc, modType) in process [] modtype @@ -225510,43 +225509,41 @@ let processUncurriedAttribute attrs = let rec process uncurriedSpotted acc attrs = match attrs with | [] -> (uncurriedSpotted, List.rev acc) - | ({Location.txt = "bs"}, _) :: rest -> process true acc rest + | ({ Location.txt = "bs" }, _) :: rest -> process true acc rest | attr :: rest -> process uncurriedSpotted (attr :: acc) rest in process false [] attrs type functionAttributesInfo = { - async: bool; - uncurried: bool; - attributes: Parsetree.attributes; + async : bool; + uncurried : bool; + attributes : Parsetree.attributes; } let processFunctionAttributes attrs = let rec process async uncurried acc attrs = match attrs with - | [] -> {async; uncurried; attributes = List.rev acc} - | ({Location.txt = "bs"}, _) :: rest -> process async true acc rest - | ({Location.txt = "res.async"}, _) :: rest -> - process true uncurried acc rest + | [] -> { async; uncurried; attributes = List.rev acc } + | ({ Location.txt = "bs" }, _) :: rest -> process async true acc rest + | ({ Location.txt = "res.async" }, _) :: rest -> + process true uncurried acc rest | attr :: rest -> process async uncurried (attr :: acc) rest in process false false [] attrs let hasAwaitAttribute attrs = List.exists - (function - | {Location.txt = "res.await"}, _ -> true - | _ -> false) + (function { Location.txt = "res.await" }, _ -> true | _ -> false) attrs let collectListExpressions expr = let rec collect acc expr = match expr.pexp_desc with - | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> (List.rev acc, None) + | Pexp_construct ({ txt = Longident.Lident "[]" }, _) -> (List.rev acc, None) | Pexp_construct - ( {txt = Longident.Lident "::"}, - Some {pexp_desc = Pexp_tuple (hd :: [tail])} ) -> - collect (hd :: acc) tail + ( { txt = Longident.Lident "::" }, + Some { pexp_desc = Pexp_tuple (hd :: [ tail ]) } ) -> + collect (hd :: acc) tail | _ -> (List.rev acc, Some expr) in collect [] expr @@ -225557,42 +225554,48 @@ let rewriteUnderscoreApply expr = | Pexp_fun ( Nolabel, None, - {ppat_desc = Ppat_var {txt = "__x"}}, - ({pexp_desc = Pexp_apply (callExpr, args)} as e) ) -> - let newArgs = - List.map - (fun arg -> - match arg with - | ( lbl, - ({pexp_desc = Pexp_ident ({txt = Longident.Lident "__x"} as lid)} - as argExpr) ) -> - ( lbl, - { - argExpr with - pexp_desc = Pexp_ident {lid with txt = Longident.Lident "_"}; - } ) - | arg -> arg) - args - in - {e with pexp_desc = Pexp_apply (callExpr, newArgs)} + { ppat_desc = Ppat_var { txt = "__x" } }, + ({ pexp_desc = Pexp_apply (callExpr, args) } as e) ) -> + let newArgs = + List.map + (fun arg -> + match arg with + | ( lbl, + ({ + pexp_desc = + Pexp_ident ({ txt = Longident.Lident "__x" } as lid); + } as argExpr) ) -> + ( lbl, + { + argExpr with + pexp_desc = + Pexp_ident { lid with txt = Longident.Lident "_" }; + } ) + | arg -> arg) + args + in + { e with pexp_desc = Pexp_apply (callExpr, newArgs) } | _ -> expr type funParamKind = | Parameter of { - attrs: Parsetree.attributes; - lbl: Asttypes.arg_label; - defaultExpr: Parsetree.expression option; - pat: Parsetree.pattern; + attrs : Parsetree.attributes; + lbl : Asttypes.arg_label; + defaultExpr : Parsetree.expression option; + pat : Parsetree.pattern; + } + | NewTypes of { + attrs : Parsetree.attributes; + locs : string Asttypes.loc list; } - | NewTypes of {attrs: Parsetree.attributes; locs: string Asttypes.loc list} let funExpr expr = (* Turns (type t, type u, type z) into "type t u z" *) let rec collectNewTypes acc returnExpr = match returnExpr with - | {pexp_desc = Pexp_newtype (stringLoc, returnExpr); pexp_attributes = []} + | { pexp_desc = Pexp_newtype (stringLoc, returnExpr); pexp_attributes = [] } -> - collectNewTypes (stringLoc :: acc) returnExpr + collectNewTypes (stringLoc :: acc) returnExpr | returnExpr -> (List.rev acc, returnExpr) in let rec collect n attrsBefore acc expr = @@ -225602,43 +225605,48 @@ let funExpr expr = Pexp_fun ( Nolabel, None, - {ppat_desc = Ppat_var {txt = "__x"}}, - {pexp_desc = Pexp_apply _} ); + { ppat_desc = Ppat_var { txt = "__x" } }, + { pexp_desc = Pexp_apply _ } ); } -> - (attrsBefore, List.rev acc, rewriteUnderscoreApply expr) + (attrsBefore, List.rev acc, rewriteUnderscoreApply expr) | { pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr); pexp_attributes = []; } -> - let parameter = Parameter {attrs = []; lbl; defaultExpr; pat = pattern} in - collect (n + 1) attrsBefore (parameter :: acc) returnExpr - | {pexp_desc = Pexp_newtype (stringLoc, rest); pexp_attributes = attrs} -> - let stringLocs, returnExpr = collectNewTypes [stringLoc] rest in - let param = NewTypes {attrs; locs = stringLocs} in - collect (n + 1) attrsBefore (param :: acc) returnExpr - | {pexp_desc = Pexp_fun _; pexp_attributes} + let parameter = + Parameter { attrs = []; lbl; defaultExpr; pat = pattern } + in + collect (n + 1) attrsBefore (parameter :: acc) returnExpr + | { pexp_desc = Pexp_newtype (stringLoc, rest); pexp_attributes = attrs } -> + let stringLocs, returnExpr = collectNewTypes [ stringLoc ] rest in + let param = NewTypes { attrs; locs = stringLocs } in + collect (n + 1) attrsBefore (param :: acc) returnExpr + | { pexp_desc = Pexp_fun _; pexp_attributes } when pexp_attributes - |> List.exists (fun ({Location.txt}, _) -> + |> List.exists (fun ({ Location.txt }, _) -> txt = "bs" || txt = "res.async") && n > 0 -> - (* stop here, the uncurried or async attribute always indicates the beginning of an arrow function - * e.g. `(. a) => (. b)` instead of `(. a, . b)` *) - (attrsBefore, List.rev acc, expr) + (* stop here, the uncurried or async attribute always indicates the beginning of an arrow function + * e.g. `(. a) => (. b)` instead of `(. a, . b)` *) + (attrsBefore, List.rev acc, expr) | { pexp_desc = Pexp_fun (((Labelled _ | Optional _) as lbl), defaultExpr, pattern, returnExpr); pexp_attributes = attrs; } -> - (* Normally attributes are attached to the labelled argument, e.g. (@foo ~x) => ... - In the case of `@res.async`, pass the attribute to the outside *) - let attrs_async, attrs_other = - attrs |> List.partition (fun ({Location.txt}, _) -> txt = "res.async") - in - let parameter = - Parameter {attrs = attrs_other; lbl; defaultExpr; pat = pattern} - in - collect (n + 1) (attrs_async @ attrsBefore) (parameter :: acc) returnExpr + (* Normally attributes are attached to the labelled argument, e.g. (@foo ~x) => ... + In the case of `@res.async`, pass the attribute to the outside *) + let attrs_async, attrs_other = + attrs + |> List.partition (fun ({ Location.txt }, _) -> txt = "res.async") + in + let parameter = + Parameter { attrs = attrs_other; lbl; defaultExpr; pat = pattern } + in + collect (n + 1) + (attrs_async @ attrsBefore) + (parameter :: acc) returnExpr | expr -> (attrsBefore, List.rev acc, expr) in match expr with @@ -225646,13 +225654,13 @@ let funExpr expr = pexp_desc = Pexp_fun (Nolabel, _defaultExpr, _pattern, _returnExpr); pexp_attributes = attrs; } as expr -> - collect 0 attrs [] {expr with pexp_attributes = []} + collect 0 attrs [] { expr with pexp_attributes = [] } | expr -> collect 0 [] [] expr let processBracesAttr expr = match expr.pexp_attributes with - | (({txt = "ns.braces"}, _) as attr) :: attrs -> - (Some attr, {expr with pexp_attributes = attrs}) + | (({ txt = "ns.braces" }, _) as attr) :: attrs -> + (Some attr, { expr with pexp_attributes = attrs }) | _ -> (None, expr) let filterParsingAttrs attrs = @@ -225666,7 +225674,7 @@ let filterParsingAttrs attrs = | "res.template" ); }, _ ) -> - false + false | _ -> true) attrs @@ -225674,13 +225682,11 @@ let isBlockExpr expr = match expr.pexp_desc with | Pexp_letmodule _ | Pexp_letexception _ | Pexp_let _ | Pexp_open _ | Pexp_sequence _ -> - true + true | _ -> false let isBracedExpr expr = - match processBracesAttr expr with - | Some _, _ -> true - | _ -> false + match processBracesAttr expr with Some _, _ -> true | _ -> false let isMultilineText txt = let len = String.length txt in @@ -225699,10 +225705,10 @@ let isHuggableExpression expr = match expr.pexp_desc with | Pexp_array _ | Pexp_tuple _ | Pexp_constant (Pconst_string (_, Some _)) - | Pexp_construct ({txt = Longident.Lident ("::" | "[]")}, _) - | Pexp_extension ({txt = "bs.obj" | "obj"}, _) + | Pexp_construct ({ txt = Longident.Lident ("::" | "[]") }, _) + | Pexp_extension ({ txt = "bs.obj" | "obj" }, _) | Pexp_record _ -> - true + true | _ when isBlockExpr expr -> true | _ when isBracedExpr expr -> true | Pexp_constant (Pconst_string (txt, None)) when isMultilineText txt -> true @@ -225711,9 +225717,9 @@ let isHuggableExpression expr = let isHuggableRhs expr = match expr.pexp_desc with | Pexp_array _ | Pexp_tuple _ - | Pexp_extension ({txt = "bs.obj" | "obj"}, _) + | Pexp_extension ({ txt = "bs.obj" | "obj" }, _) | Pexp_record _ -> - true + true | _ when isBracedExpr expr -> true | _ -> false @@ -225721,7 +225727,7 @@ let isHuggablePattern pattern = match pattern.ppat_desc with | Ppat_array _ | Ppat_tuple _ | Ppat_record _ | Ppat_variant _ | Ppat_construct _ -> - true + true | _ -> false let operatorPrecedence operator = @@ -225737,17 +225743,15 @@ let operatorPrecedence operator = | _ -> 0 let isUnaryOperator operator = - match operator with - | "~+" | "~+." | "~-" | "~-." | "not" -> true - | _ -> false + match operator with "~+" | "~+." | "~-" | "~-." | "not" -> true | _ -> false let isUnaryExpression expr = match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [(Nolabel, _arg)] ) + ( { pexp_desc = Pexp_ident { txt = Longident.Lident operator } }, + [ (Nolabel, _arg) ] ) when isUnaryOperator operator -> - true + true | _ -> false (* TODO: tweak this to check for ghost ^ as template literal *) @@ -225756,7 +225760,7 @@ let isBinaryOperator operator = | ":=" | "||" | "&&" | "=" | "==" | "<" | ">" | "!=" | "!==" | "<=" | ">=" | "|>" | "+" | "+." | "-" | "-." | "^" | "*" | "*." | "/" | "/." | "**" | "|." | "<>" -> - true + true | _ -> false let isBinaryExpression expr = @@ -225764,19 +225768,17 @@ let isBinaryExpression expr = | Pexp_apply ( { pexp_desc = - Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}; + Pexp_ident { txt = Longident.Lident operator; loc = operatorLoc }; }, - [(Nolabel, _operand1); (Nolabel, _operand2)] ) + [ (Nolabel, _operand1); (Nolabel, _operand2) ] ) when isBinaryOperator operator && not (operatorLoc.loc_ghost && operator = "^") (* template literal *) -> - true + true | _ -> false let isEqualityOperator operator = - match operator with - | "=" | "==" | "<>" | "!=" -> true - | _ -> false + match operator with "=" | "==" | "<>" | "!=" -> true | _ -> false let flattenableOperators parentOperator childOperator = let precParent = operatorPrecedence parentOperator in @@ -225788,20 +225790,20 @@ let flattenableOperators parentOperator childOperator = let rec hasIfLetAttribute attrs = match attrs with | [] -> false - | ({Location.txt = "ns.iflet"}, _) :: _ -> true + | ({ Location.txt = "ns.iflet" }, _) :: _ -> true | _ :: attrs -> hasIfLetAttribute attrs let isIfLetExpr expr = match expr with - | {pexp_attributes = attrs; pexp_desc = Pexp_match _} + | { pexp_attributes = attrs; pexp_desc = Pexp_match _ } when hasIfLetAttribute attrs -> - true + true | _ -> false let rec hasOptionalAttribute attrs = match attrs with | [] -> false - | ({Location.txt = "ns.optional"}, _) :: _ -> true + | ({ Location.txt = "ns.optional" }, _) :: _ -> true | _ :: attrs -> hasOptionalAttribute attrs let hasAttributes attrs = @@ -225814,27 +225816,30 @@ let hasAttributes attrs = | "res.await" | "res.template" ); }, _ ) -> - false + false (* Remove the fragile pattern warning for iflet expressions *) - | ( {Location.txt = "warning"}, + | ( { Location.txt = "warning" }, PStr [ { pstr_desc = Pstr_eval - ({pexp_desc = Pexp_constant (Pconst_string ("-4", None))}, _); + ( { pexp_desc = Pexp_constant (Pconst_string ("-4", None)) }, + _ ); }; ] ) -> - not (hasIfLetAttribute attrs) + not (hasIfLetAttribute attrs) | _ -> true) attrs let isArrayAccess expr = match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "get")}}, - [(Nolabel, _parentExpr); (Nolabel, _memberExpr)] ) -> - true + ( { + pexp_desc = Pexp_ident { txt = Longident.Ldot (Lident "Array", "get") }; + }, + [ (Nolabel, _parentExpr); (Nolabel, _memberExpr) ] ) -> + true | _ -> false type ifConditionKind = @@ -225846,32 +225851,36 @@ let collectIfExpressions expr = let exprLoc = expr.pexp_loc in match expr.pexp_desc with | Pexp_ifthenelse (ifExpr, thenExpr, Some elseExpr) -> - collect ((exprLoc, If ifExpr, thenExpr) :: acc) elseExpr + collect ((exprLoc, If ifExpr, thenExpr) :: acc) elseExpr | Pexp_ifthenelse (ifExpr, thenExpr, (None as elseExpr)) -> - let ifs = List.rev ((exprLoc, If ifExpr, thenExpr) :: acc) in - (ifs, elseExpr) + let ifs = List.rev ((exprLoc, If ifExpr, thenExpr) :: acc) in + (ifs, elseExpr) | Pexp_match ( condition, [ - {pc_lhs = pattern; pc_guard = None; pc_rhs = thenExpr}; + { pc_lhs = pattern; pc_guard = None; pc_rhs = thenExpr }; { pc_rhs = - {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)}; + { + pexp_desc = Pexp_construct ({ txt = Longident.Lident "()" }, _); + }; }; ] ) when isIfLetExpr expr -> - let ifs = - List.rev ((exprLoc, IfLet (pattern, condition), thenExpr) :: acc) - in - (ifs, None) + let ifs = + List.rev ((exprLoc, IfLet (pattern, condition), thenExpr) :: acc) + in + (ifs, None) | Pexp_match ( condition, [ - {pc_lhs = pattern; pc_guard = None; pc_rhs = thenExpr}; - {pc_rhs = elseExpr}; + { pc_lhs = pattern; pc_guard = None; pc_rhs = thenExpr }; + { pc_rhs = elseExpr }; ] ) when isIfLetExpr expr -> - collect ((exprLoc, IfLet (pattern, condition), thenExpr) :: acc) elseExpr + collect + ((exprLoc, IfLet (pattern, condition), thenExpr) :: acc) + elseExpr | _ -> (List.rev acc, Some expr) in collect [] expr @@ -225879,14 +225888,14 @@ let collectIfExpressions expr = let rec hasTernaryAttribute attrs = match attrs with | [] -> false - | ({Location.txt = "ns.ternary"}, _) :: _ -> true + | ({ Location.txt = "ns.ternary" }, _) :: _ -> true | _ :: attrs -> hasTernaryAttribute attrs let isTernaryExpr expr = match expr with - | {pexp_attributes = attrs; pexp_desc = Pexp_ifthenelse _} + | { pexp_attributes = attrs; pexp_desc = Pexp_ifthenelse _ } when hasTernaryAttribute attrs -> - true + true | _ -> false let collectTernaryParts expr = @@ -225897,40 +225906,40 @@ let collectTernaryParts expr = pexp_desc = Pexp_ifthenelse (condition, consequent, Some alternate); } when hasTernaryAttribute attrs -> - collect ((condition, consequent) :: acc) alternate + collect ((condition, consequent) :: acc) alternate | alternate -> (List.rev acc, alternate) in collect [] expr let parametersShouldHug parameters = match parameters with - | [Parameter {attrs = []; lbl = Asttypes.Nolabel; defaultExpr = None; pat}] + | [ + Parameter { attrs = []; lbl = Asttypes.Nolabel; defaultExpr = None; pat }; + ] when isHuggablePattern pat -> - true + true | _ -> false let filterTernaryAttributes attrs = List.filter (fun attr -> - match attr with - | {Location.txt = "ns.ternary"}, _ -> false - | _ -> true) + match attr with { Location.txt = "ns.ternary" }, _ -> false | _ -> true) attrs let filterFragileMatchAttributes attrs = List.filter (fun attr -> match attr with - | ( {Location.txt = "warning"}, + | ( { Location.txt = "warning" }, PStr [ { pstr_desc = Pstr_eval - ({pexp_desc = Pexp_constant (Pconst_string ("-4", _))}, _); + ({ pexp_desc = Pexp_constant (Pconst_string ("-4", _)) }, _); }; ] ) -> - false + false | _ -> true) attrs @@ -225938,7 +225947,7 @@ let isJsxExpression expr = let rec loop attrs = match attrs with | [] -> false - | ({Location.txt = "JSX"}, _) :: _ -> true + | ({ Location.txt = "JSX" }, _) :: _ -> true | _ :: attrs -> loop attrs in match expr.pexp_desc with @@ -225949,7 +225958,7 @@ let hasJsxAttribute attributes = let rec loop attrs = match attrs with | [] -> false - | ({Location.txt = "JSX"}, _) :: _ -> true + | ({ Location.txt = "JSX" }, _) :: _ -> true | _ :: attrs -> loop attrs in loop attributes @@ -225960,24 +225969,24 @@ let shouldIndentBinaryExpr expr = | { pexp_desc = Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident subOperator}}, - [(Nolabel, _lhs); (Nolabel, _rhs)] ); + ( { pexp_desc = Pexp_ident { txt = Longident.Lident subOperator } }, + [ (Nolabel, _lhs); (Nolabel, _rhs) ] ); } when isBinaryOperator subOperator -> - flattenableOperators operator subOperator + flattenableOperators operator subOperator | _ -> true in match expr with | { pexp_desc = Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [(Nolabel, lhs); (Nolabel, _rhs)] ); + ( { pexp_desc = Pexp_ident { txt = Longident.Lident operator } }, + [ (Nolabel, lhs); (Nolabel, _rhs) ] ); } when isBinaryOperator operator -> - isEqualityOperator operator - || (not (samePrecedenceSubExpression operator lhs)) - || operator = ":=" + isEqualityOperator operator + || (not (samePrecedenceSubExpression operator lhs)) + || operator = ":=" | _ -> false let shouldInlineRhsBinaryExpr rhs = @@ -225985,7 +225994,7 @@ let shouldInlineRhsBinaryExpr rhs = | Parsetree.Pexp_constant _ | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ | Pexp_sequence _ | Pexp_open _ | Pexp_ifthenelse _ | Pexp_for _ | Pexp_while _ | Pexp_try _ | Pexp_array _ | Pexp_record _ -> - true + true | _ -> false let isPrintableAttribute attr = @@ -225996,11 +226005,10 @@ let isPrintableAttribute attr = | "res.template" | "ns.ternary" ); }, _ ) -> - false + false | _ -> true let hasPrintableAttributes attrs = List.exists isPrintableAttribute attrs - let filterPrintableAttributes attrs = List.filter isPrintableAttribute attrs let partitionPrintableAttributes attrs = @@ -226010,8 +226018,8 @@ let requiresSpecialCallbackPrintingLastArg args = let rec loop args = match args with | [] -> false - | [(_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})] -> true - | (_, {pexp_desc = Pexp_fun _ | Pexp_newtype _}) :: _ -> false + | [ (_, { pexp_desc = Pexp_fun _ | Pexp_newtype _ }) ] -> true + | (_, { pexp_desc = Pexp_fun _ | Pexp_newtype _ }) :: _ -> false | _ :: rest -> loop rest in loop args @@ -226020,18 +226028,18 @@ let requiresSpecialCallbackPrintingFirstArg args = let rec loop args = match args with | [] -> true - | (_, {pexp_desc = Pexp_fun _ | Pexp_newtype _}) :: _ -> false + | (_, { pexp_desc = Pexp_fun _ | Pexp_newtype _ }) :: _ -> false | _ :: rest -> loop rest in match args with - | [(_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})] -> false - | (_, {pexp_desc = Pexp_fun _ | Pexp_newtype _}) :: rest -> loop rest + | [ (_, { pexp_desc = Pexp_fun _ | Pexp_newtype _ }) ] -> false + | (_, { pexp_desc = Pexp_fun _ | Pexp_newtype _ }) :: rest -> loop rest | _ -> false let modExprApply modExpr = let rec loop acc modExpr = match modExpr with - | {pmod_desc = Pmod_apply (next, arg)} -> loop (arg :: acc) next + | { pmod_desc = Pmod_apply (next, arg) } -> loop (arg :: acc) next | _ -> (acc, modExpr) in loop [] modExpr @@ -226043,8 +226051,8 @@ let modExprFunctor modExpr = pmod_desc = Pmod_functor (lbl, modType, returnModExpr); pmod_attributes = attrs; } -> - let param = (attrs, lbl, modType) in - loop (param :: acc) returnModExpr + let param = (attrs, lbl, modType) in + loop (param :: acc) returnModExpr | returnModExpr -> (List.rev acc, returnModExpr) in loop [] modExpr @@ -226053,26 +226061,26 @@ let rec collectPatternsFromListConstruct acc pattern = let open Parsetree in match pattern.ppat_desc with | Ppat_construct - ({txt = Longident.Lident "::"}, Some {ppat_desc = Ppat_tuple [pat; rest]}) - -> - collectPatternsFromListConstruct (pat :: acc) rest + ( { txt = Longident.Lident "::" }, + Some { ppat_desc = Ppat_tuple [ pat; rest ] } ) -> + collectPatternsFromListConstruct (pat :: acc) rest | _ -> (List.rev acc, pattern) let hasTemplateLiteralAttr attrs = List.exists (fun attr -> match attr with - | {Location.txt = "res.template"}, _ -> true + | { Location.txt = "res.template" }, _ -> true | _ -> false) attrs let isTemplateLiteral expr = match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident "^"}}, - [(Nolabel, _); (Nolabel, _)] ) + ( { pexp_desc = Pexp_ident { txt = Longident.Lident "^" } }, + [ (Nolabel, _); (Nolabel, _) ] ) when hasTemplateLiteralAttr expr.pexp_attributes -> - true + true | Pexp_constant (Pconst_string (_, Some "")) -> true | Pexp_constant _ when hasTemplateLiteralAttr expr.pexp_attributes -> true | _ -> false @@ -226080,9 +226088,7 @@ let isTemplateLiteral expr = let hasSpreadAttr attrs = List.exists (fun attr -> - match attr with - | {Location.txt = "res.spread"}, _ -> true - | _ -> false) + match attr with { Location.txt = "res.spread" }, _ -> true | _ -> false) attrs let isSpreadBeltListConcat expr = @@ -226093,7 +226099,7 @@ let isSpreadBeltListConcat expr = Longident.Ldot (Longident.Ldot (Longident.Lident "Belt", "List"), "concatMany"); } -> - hasSpreadAttr expr.pexp_attributes + hasSpreadAttr expr.pexp_attributes | _ -> false (* Blue | Red | Green -> [Blue; Red; Green] *) @@ -226121,17 +226127,17 @@ let isSinglePipeExpr expr = let isPipeExpr expr = match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident ("|." | "|>")}}, - [(Nolabel, _operand1); (Nolabel, _operand2)] ) -> - true + ( { pexp_desc = Pexp_ident { txt = Longident.Lident ("|." | "|>") } }, + [ (Nolabel, _operand1); (Nolabel, _operand2) ] ) -> + true | _ -> false in match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident ("|." | "|>")}}, - [(Nolabel, operand1); (Nolabel, _operand2)] ) + ( { pexp_desc = Pexp_ident { txt = Longident.Lident ("|." | "|>") } }, + [ (Nolabel, operand1); (Nolabel, _operand2) ] ) when not (isPipeExpr operand1) -> - true + true | _ -> false let isUnderscoreApplySugar expr = @@ -226139,14 +226145,14 @@ let isUnderscoreApplySugar expr = | Pexp_fun ( Nolabel, None, - {ppat_desc = Ppat_var {txt = "__x"}}, - {pexp_desc = Pexp_apply _} ) -> - true + { ppat_desc = Ppat_var { txt = "__x" } }, + { pexp_desc = Pexp_apply _ } ) -> + true | _ -> false let isRewrittenUnderscoreApplySugar expr = match expr.pexp_desc with - | Pexp_ident {txt = Longident.Lident "_"} -> true + | Pexp_ident { txt = Longident.Lident "_" } -> true | _ -> false end @@ -226158,9 +226164,9 @@ module Doc = Res_doc module ParsetreeViewer = Res_parsetree_viewer type t = { - leading: (Location.t, Comment.t list) Hashtbl.t; - inside: (Location.t, Comment.t list) Hashtbl.t; - trailing: (Location.t, Comment.t list) Hashtbl.t; + leading : (Location.t, Comment.t list) Hashtbl.t; + inside : (Location.t, Comment.t list) Hashtbl.t; + trailing : (Location.t, Comment.t list) Hashtbl.t; } let make () = @@ -226208,7 +226214,7 @@ let printEntries tbl = [ Doc.line; Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) (List.map (fun c -> Doc.text (Comment.txt c)) v); ]); Doc.line; @@ -226225,33 +226231,31 @@ let log t = (Doc.concat [ Doc.text "leading comments:"; - Doc.indent (Doc.concat [Doc.line; Doc.concat leadingStuff]); + Doc.indent (Doc.concat [ Doc.line; Doc.concat leadingStuff ]); Doc.line; Doc.text "comments inside:"; - Doc.indent (Doc.concat [Doc.line; Doc.concat stuffInside]); + Doc.indent (Doc.concat [ Doc.line; Doc.concat stuffInside ]); Doc.line; Doc.text "trailing comments:"; - Doc.indent (Doc.concat [Doc.line; Doc.concat trailingStuff]); + Doc.indent (Doc.concat [ Doc.line; Doc.concat trailingStuff ]); Doc.line; ]) |> Doc.toString ~width:80 |> print_endline let attach tbl loc comments = - match comments with - | [] -> () - | comments -> Hashtbl.replace tbl loc comments + match comments with [] -> () | comments -> Hashtbl.replace tbl loc comments let partitionByLoc comments loc = let rec loop (leading, inside, trailing) comments = let open Location in match comments with | comment :: rest -> - let cmtLoc = Comment.loc comment in - if cmtLoc.loc_end.pos_cnum <= loc.loc_start.pos_cnum then - loop (comment :: leading, inside, trailing) rest - else if cmtLoc.loc_start.pos_cnum >= loc.loc_end.pos_cnum then - loop (leading, inside, comment :: trailing) rest - else loop (leading, comment :: inside, trailing) rest + let cmtLoc = Comment.loc comment in + if cmtLoc.loc_end.pos_cnum <= loc.loc_start.pos_cnum then + loop (comment :: leading, inside, trailing) rest + else if cmtLoc.loc_start.pos_cnum >= loc.loc_end.pos_cnum then + loop (leading, inside, comment :: trailing) rest + else loop (leading, comment :: inside, trailing) rest | [] -> (List.rev leading, List.rev inside, List.rev trailing) in loop ([], [], []) comments @@ -226261,10 +226265,10 @@ let partitionLeadingTrailing comments loc = let open Location in match comments with | comment :: rest -> - let cmtLoc = Comment.loc comment in - if cmtLoc.loc_end.pos_cnum <= loc.loc_start.pos_cnum then - loop (comment :: leading, trailing) rest - else loop (leading, comment :: trailing) rest + let cmtLoc = Comment.loc comment in + if cmtLoc.loc_end.pos_cnum <= loc.loc_start.pos_cnum then + loop (comment :: leading, trailing) rest + else loop (leading, comment :: trailing) rest | [] -> (List.rev leading, List.rev trailing) in loop ([], []) comments @@ -226275,10 +226279,10 @@ let partitionByOnSameLine loc comments = match comments with | [] -> (List.rev onSameLine, List.rev onOtherLine) | comment :: rest -> - let cmtLoc = Comment.loc comment in - if cmtLoc.loc_start.pos_lnum == loc.loc_end.pos_lnum then - loop (comment :: onSameLine, onOtherLine) rest - else loop (onSameLine, comment :: onOtherLine) rest + let cmtLoc = Comment.loc comment in + if cmtLoc.loc_start.pos_lnum == loc.loc_end.pos_lnum then + loop (comment :: onSameLine, onOtherLine) rest + else loop (onSameLine, comment :: onOtherLine) rest in loop ([], []) comments @@ -226289,11 +226293,11 @@ let partitionAdjacentTrailing loc1 comments = match comments with | [] -> (List.rev afterLoc1, []) | comment :: rest as comments -> - let cmtPrevEndPos = Comment.prevTokEndPos comment in - if prevEndPos.Lexing.pos_cnum == cmtPrevEndPos.pos_cnum then - let commentEnd = (Comment.loc comment).loc_end in - loop ~prevEndPos:commentEnd (comment :: afterLoc1) rest - else (List.rev afterLoc1, comments) + let cmtPrevEndPos = Comment.prevTokEndPos comment in + if prevEndPos.Lexing.pos_cnum == cmtPrevEndPos.pos_cnum then + let commentEnd = (Comment.loc comment).loc_end in + loop ~prevEndPos:commentEnd (comment :: afterLoc1) rest + else (List.rev afterLoc1, comments) in loop ~prevEndPos:loc1.loc_end [] comments @@ -226301,20 +226305,20 @@ let rec collectListPatterns acc pattern = let open Parsetree in match pattern.ppat_desc with | Ppat_construct - ({txt = Longident.Lident "::"}, Some {ppat_desc = Ppat_tuple [pat; rest]}) - -> - collectListPatterns (pat :: acc) rest - | Ppat_construct ({txt = Longident.Lident "[]"}, None) -> List.rev acc + ( { txt = Longident.Lident "::" }, + Some { ppat_desc = Ppat_tuple [ pat; rest ] } ) -> + collectListPatterns (pat :: acc) rest + | Ppat_construct ({ txt = Longident.Lident "[]" }, None) -> List.rev acc | _ -> List.rev (pattern :: acc) let rec collectListExprs acc expr = let open Parsetree in match expr.pexp_desc with | Pexp_construct - ({txt = Longident.Lident "::"}, Some {pexp_desc = Pexp_tuple [expr; rest]}) - -> - collectListExprs (expr :: acc) rest - | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> List.rev acc + ( { txt = Longident.Lident "::" }, + Some { pexp_desc = Pexp_tuple [ expr; rest ] } ) -> + collectListExprs (expr :: acc) rest + | Pexp_construct ({ txt = Longident.Lident "[]" }, _) -> List.rev acc | _ -> List.rev (expr :: acc) (* TODO: use ParsetreeViewer *) @@ -226326,37 +226330,39 @@ let arrowType ct = ptyp_desc = Ptyp_arrow ((Nolabel as lbl), typ1, typ2); ptyp_attributes = []; } -> - let arg = ([], lbl, typ1) in - process attrsBefore (arg :: acc) typ2 + let arg = ([], lbl, typ1) in + process attrsBefore (arg :: acc) typ2 | { ptyp_desc = Ptyp_arrow ((Nolabel as lbl), typ1, typ2); - ptyp_attributes = [({txt = "bs"}, _)] as attrs; + ptyp_attributes = [ ({ txt = "bs" }, _) ] as attrs; } -> - let arg = (attrs, lbl, typ1) in - process attrsBefore (arg :: acc) typ2 - | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = _attrs} - as returnType -> - let args = List.rev acc in - (attrsBefore, args, returnType) + let arg = (attrs, lbl, typ1) in + process attrsBefore (arg :: acc) typ2 + | { + ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); + ptyp_attributes = _attrs; + } as returnType -> + let args = List.rev acc in + (attrsBefore, args, returnType) | { ptyp_desc = Ptyp_arrow (((Labelled _ | Optional _) as lbl), typ1, typ2); ptyp_attributes = attrs; } -> - let arg = (attrs, lbl, typ1) in - process attrsBefore (arg :: acc) typ2 + let arg = (attrs, lbl, typ1) in + process attrsBefore (arg :: acc) typ2 | typ -> (attrsBefore, List.rev acc, typ) in match ct with - | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = attrs} as - typ -> - process attrs [] {typ with ptyp_attributes = []} + | { ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = attrs } + as typ -> + process attrs [] { typ with ptyp_attributes = [] } | typ -> process [] [] typ (* TODO: avoiding the dependency on ParsetreeViewer here, is this a good idea? *) let modExprApply modExpr = let rec loop acc modExpr = match modExpr with - | {Parsetree.pmod_desc = Pmod_apply (next, arg)} -> loop (arg :: acc) next + | { Parsetree.pmod_desc = Pmod_apply (next, arg) } -> loop (arg :: acc) next | _ -> modExpr :: acc in loop [] modExpr @@ -226369,8 +226375,8 @@ let modExprFunctor modExpr = Parsetree.pmod_desc = Pmod_functor (lbl, modType, returnModExpr); pmod_attributes = attrs; } -> - let param = (attrs, lbl, modType) in - loop (param :: acc) returnModExpr + let param = (attrs, lbl, modType) in + loop (param :: acc) returnModExpr | returnModExpr -> (List.rev acc, returnModExpr) in loop [] modExpr @@ -226382,8 +226388,8 @@ let functorType modtype = Parsetree.pmty_desc = Pmty_functor (lbl, argType, returnType); pmty_attributes = attrs; } -> - let arg = (attrs, lbl, argType) in - process (arg :: acc) returnType + let arg = (attrs, lbl, argType) in + process (arg :: acc) returnType | modType -> (List.rev acc, modType) in process [] modtype @@ -226393,22 +226399,22 @@ let funExpr expr = (* Turns (type t, type u, type z) into "type t u z" *) let rec collectNewTypes acc returnExpr = match returnExpr with - | {pexp_desc = Pexp_newtype (stringLoc, returnExpr); pexp_attributes = []} + | { pexp_desc = Pexp_newtype (stringLoc, returnExpr); pexp_attributes = [] } -> - collectNewTypes (stringLoc :: acc) returnExpr + collectNewTypes (stringLoc :: acc) returnExpr | returnExpr -> - let loc = - match (acc, List.rev acc) with - | _startLoc :: _, endLoc :: _ -> - {endLoc.loc with loc_end = endLoc.loc.loc_end} - | _ -> Location.none - in - let txt = - List.fold_right - (fun curr acc -> acc ^ " " ^ curr.Location.txt) - acc "type" - in - (Location.mkloc txt loc, returnExpr) + let loc = + match (acc, List.rev acc) with + | _startLoc :: _, endLoc :: _ -> + { endLoc.loc with loc_end = endLoc.loc.loc_end } + | _ -> Location.none + in + let txt = + List.fold_right + (fun curr acc -> acc ^ " " ^ curr.Location.txt) + acc "type" + in + (Location.mkloc txt loc, returnExpr) in (* For simplicity reason Pexp_newtype gets converted to a Nolabel parameter, * otherwise this function would need to return a variant: @@ -226422,31 +226428,31 @@ let funExpr expr = pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr); pexp_attributes = []; } -> - let parameter = ([], lbl, defaultExpr, pattern) in - collect attrsBefore (parameter :: acc) returnExpr - | {pexp_desc = Pexp_newtype (stringLoc, rest); pexp_attributes = attrs} -> - let var, returnExpr = collectNewTypes [stringLoc] rest in - let parameter = - ( attrs, - Asttypes.Nolabel, - None, - Ast_helper.Pat.var ~loc:stringLoc.loc var ) - in - collect attrsBefore (parameter :: acc) returnExpr + let parameter = ([], lbl, defaultExpr, pattern) in + collect attrsBefore (parameter :: acc) returnExpr + | { pexp_desc = Pexp_newtype (stringLoc, rest); pexp_attributes = attrs } -> + let var, returnExpr = collectNewTypes [ stringLoc ] rest in + let parameter = + ( attrs, + Asttypes.Nolabel, + None, + Ast_helper.Pat.var ~loc:stringLoc.loc var ) + in + collect attrsBefore (parameter :: acc) returnExpr | { pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr); - pexp_attributes = [({txt = "bs"}, _)] as attrs; + pexp_attributes = [ ({ txt = "bs" }, _) ] as attrs; } -> - let parameter = (attrs, lbl, defaultExpr, pattern) in - collect attrsBefore (parameter :: acc) returnExpr + let parameter = (attrs, lbl, defaultExpr, pattern) in + collect attrsBefore (parameter :: acc) returnExpr | { pexp_desc = Pexp_fun (((Labelled _ | Optional _) as lbl), defaultExpr, pattern, returnExpr); pexp_attributes = attrs; } -> - let parameter = (attrs, lbl, defaultExpr, pattern) in - collect attrsBefore (parameter :: acc) returnExpr + let parameter = (attrs, lbl, defaultExpr, pattern) in + collect attrsBefore (parameter :: acc) returnExpr | expr -> (attrsBefore, List.rev acc, expr) in match expr with @@ -226454,7 +226460,7 @@ let funExpr expr = pexp_desc = Pexp_fun (Nolabel, _defaultExpr, _pattern, _returnExpr); pexp_attributes = attrs; } as expr -> - collect attrs [] {expr with pexp_attributes = []} + collect attrs [] { expr with pexp_attributes = [] } | expr -> collect [] [] expr let rec isBlockExpr expr = @@ -226462,7 +226468,7 @@ let rec isBlockExpr expr = match expr.pexp_desc with | Pexp_letmodule _ | Pexp_letexception _ | Pexp_let _ | Pexp_open _ | Pexp_sequence _ -> - true + true | Pexp_apply (callExpr, _) when isBlockExpr callExpr -> true | Pexp_constraint (expr, _) when isBlockExpr expr -> true | Pexp_field (expr, _) when isBlockExpr expr -> true @@ -226471,9 +226477,7 @@ let rec isBlockExpr expr = let isIfThenElseExpr expr = let open Parsetree in - match expr.pexp_desc with - | Pexp_ifthenelse _ -> true - | _ -> false + match expr.pexp_desc with Pexp_ifthenelse _ -> true | _ -> false type node = | Case of Parsetree.case @@ -226500,35 +226504,35 @@ let getLoc node = let open Parsetree in match node with | Case case -> - {case.pc_lhs.ppat_loc with loc_end = case.pc_rhs.pexp_loc.loc_end} + { case.pc_lhs.ppat_loc with loc_end = case.pc_rhs.pexp_loc.loc_end } | CoreType ct -> ct.ptyp_loc | ExprArgument expr -> ( - match expr.Parsetree.pexp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _attrs -> - {loc with loc_end = expr.pexp_loc.loc_end} - | _ -> expr.pexp_loc) + match expr.Parsetree.pexp_attributes with + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _attrs -> + { loc with loc_end = expr.pexp_loc.loc_end } + | _ -> expr.pexp_loc) | Expression e -> ( - match e.pexp_attributes with - | ({txt = "ns.braces"; loc}, _) :: _ -> loc - | _ -> e.pexp_loc) - | ExprRecordRow (li, e) -> {li.loc with loc_end = e.pexp_loc.loc_end} + match e.pexp_attributes with + | ({ txt = "ns.braces"; loc }, _) :: _ -> loc + | _ -> e.pexp_loc) + | ExprRecordRow (li, e) -> { li.loc with loc_end = e.pexp_loc.loc_end } | ExtensionConstructor ec -> ec.pext_loc | LabelDeclaration ld -> ld.pld_loc | ModuleBinding mb -> mb.pmb_loc | ModuleDeclaration md -> md.pmd_loc | ModuleExpr me -> me.pmod_loc | ObjectField field -> ( - match field with - | Parsetree.Otag (lbl, _, typ) -> - {lbl.loc with loc_end = typ.ptyp_loc.loc_end} - | _ -> Location.none) - | PackageConstraint (li, te) -> {li.loc with loc_end = te.ptyp_loc.loc_end} + match field with + | Parsetree.Otag (lbl, _, typ) -> + { lbl.loc with loc_end = typ.ptyp_loc.loc_end } + | _ -> Location.none) + | PackageConstraint (li, te) -> { li.loc with loc_end = te.ptyp_loc.loc_end } | Pattern p -> p.ppat_loc - | PatternRecordRow (li, p) -> {li.loc with loc_end = p.ppat_loc.loc_end} + | PatternRecordRow (li, p) -> { li.loc with loc_end = p.ppat_loc.loc_end } | RowField rf -> ( - match rf with - | Parsetree.Rtag ({loc}, _, _, _) -> loc - | Rinherit {ptyp_loc} -> ptyp_loc) + match rf with + | Parsetree.Rtag ({ loc }, _, _, _) -> loc + | Rinherit { ptyp_loc } -> ptyp_loc) | SignatureItem si -> si.psig_loc | StructureItem si -> si.pstr_loc | TypeDeclaration td -> td.ptype_loc @@ -226544,24 +226548,24 @@ and walkStructureItem si t comments = match si.Parsetree.pstr_desc with | _ when comments = [] -> () | Pstr_primitive valueDescription -> - walkValueDescription valueDescription t comments + walkValueDescription valueDescription t comments | Pstr_open openDescription -> walkOpenDescription openDescription t comments | Pstr_value (_, valueBindings) -> walkValueBindings valueBindings t comments | Pstr_type (_, typeDeclarations) -> - walkTypeDeclarations typeDeclarations t comments + walkTypeDeclarations typeDeclarations t comments | Pstr_eval (expr, _) -> walkExpression expr t comments | Pstr_module moduleBinding -> walkModuleBinding moduleBinding t comments | Pstr_recmodule moduleBindings -> - walkList - (moduleBindings |> List.map (fun mb -> ModuleBinding mb)) - t comments + walkList + (moduleBindings |> List.map (fun mb -> ModuleBinding mb)) + t comments | Pstr_modtype modTypDecl -> walkModuleTypeDeclaration modTypDecl t comments | Pstr_attribute attribute -> walkAttribute attribute t comments | Pstr_extension (extension, _) -> walkExtension extension t comments | Pstr_include includeDeclaration -> - walkIncludeDeclaration includeDeclaration t comments + walkIncludeDeclaration includeDeclaration t comments | Pstr_exception extensionConstructor -> - walkExtensionConstructor extensionConstructor t comments + walkExtensionConstructor extensionConstructor t comments | Pstr_typext typeExtension -> walkTypeExtension typeExtension t comments | Pstr_class_type _ | Pstr_class _ -> () @@ -226588,9 +226592,9 @@ and walkTypeExtension te t comments = match te.ptyext_params with | [] -> rest | typeParams -> - visitListButContinueWithRemainingComments - ~getLoc:(fun (typexpr, _variance) -> typexpr.Parsetree.ptyp_loc) - ~walkNode:walkTypeParam ~newlineDelimited:false typeParams t rest + visitListButContinueWithRemainingComments + ~getLoc:(fun (typexpr, _variance) -> typexpr.Parsetree.ptyp_loc) + ~walkNode:walkTypeParam ~newlineDelimited:false typeParams t rest in walkList (te.ptyext_constructors |> List.map (fun ec -> ExtensionConstructor ec)) @@ -226610,14 +226614,14 @@ and walkModuleTypeDeclaration mtd t comments = match mtd.pmtd_type with | None -> attach t.trailing mtd.pmtd_name.loc trailing | Some modType -> - let afterName, rest = - partitionAdjacentTrailing mtd.pmtd_name.loc trailing - in - attach t.trailing mtd.pmtd_name.loc afterName; - let before, inside, after = partitionByLoc rest modType.pmty_loc in - attach t.leading modType.pmty_loc before; - walkModType modType t inside; - attach t.trailing modType.pmty_loc after + let afterName, rest = + partitionAdjacentTrailing mtd.pmtd_name.loc trailing + in + attach t.trailing mtd.pmtd_name.loc afterName; + let before, inside, after = partitionByLoc rest modType.pmty_loc in + attach t.leading modType.pmty_loc before; + walkModType modType t inside; + attach t.trailing modType.pmty_loc after and walkModuleBinding mb t comments = let leading, trailing = partitionLeadingTrailing comments mb.pmb_name.loc in @@ -226627,10 +226631,10 @@ and walkModuleBinding mb t comments = let leading, inside, trailing = partitionByLoc rest mb.pmb_expr.pmod_loc in (match mb.pmb_expr.pmod_desc with | Pmod_constraint _ -> - walkModuleExpr mb.pmb_expr t (List.concat [leading; inside]) + walkModuleExpr mb.pmb_expr t (List.concat [ leading; inside ]) | _ -> - attach t.leading mb.pmb_expr.pmod_loc leading; - walkModuleExpr mb.pmb_expr t inside); + attach t.leading mb.pmb_expr.pmod_loc leading; + walkModuleExpr mb.pmb_expr t inside); attach t.trailing mb.pmb_expr.pmod_loc trailing and walkSignature signature t comments = @@ -226638,29 +226642,29 @@ and walkSignature signature t comments = | _ when comments = [] -> () | [] -> attach t.inside Location.none comments | _s -> - walkList (signature |> List.map (fun si -> SignatureItem si)) t comments + walkList (signature |> List.map (fun si -> SignatureItem si)) t comments and walkSignatureItem (si : Parsetree.signature_item) t comments = match si.psig_desc with | _ when comments = [] -> () | Psig_value valueDescription -> - walkValueDescription valueDescription t comments + walkValueDescription valueDescription t comments | Psig_type (_, typeDeclarations) -> - walkTypeDeclarations typeDeclarations t comments + walkTypeDeclarations typeDeclarations t comments | Psig_typext typeExtension -> walkTypeExtension typeExtension t comments | Psig_exception extensionConstructor -> - walkExtensionConstructor extensionConstructor t comments + walkExtensionConstructor extensionConstructor t comments | Psig_module moduleDeclaration -> - walkModuleDeclaration moduleDeclaration t comments + walkModuleDeclaration moduleDeclaration t comments | Psig_recmodule moduleDeclarations -> - walkList - (moduleDeclarations |> List.map (fun md -> ModuleDeclaration md)) - t comments + walkList + (moduleDeclarations |> List.map (fun md -> ModuleDeclaration md)) + t comments | Psig_modtype moduleTypeDeclaration -> - walkModuleTypeDeclaration moduleTypeDeclaration t comments + walkModuleTypeDeclaration moduleTypeDeclaration t comments | Psig_open openDescription -> walkOpenDescription openDescription t comments | Psig_include includeDescription -> - walkIncludeDescription includeDescription t comments + walkIncludeDescription includeDescription t comments | Psig_attribute attribute -> walkAttribute attribute t comments | Psig_extension (extension, _) -> walkExtension extension t comments | Psig_class _ | Psig_class_type _ -> () @@ -226708,31 +226712,35 @@ and walkList : ?prevLoc:Location.t -> node list -> t -> Comment.t list -> unit = match l with | _ when comments = [] -> () | [] -> ( - match prevLoc with - | Some loc -> attach t.trailing loc comments - | None -> ()) + match prevLoc with + | Some loc -> attach t.trailing loc comments + | None -> ()) | node :: rest -> - let currLoc = getLoc node in - let leading, inside, trailing = partitionByLoc comments currLoc in - (match prevLoc with - | None -> - (* first node, all leading comments attach here *) - attach t.leading currLoc leading - | Some prevLoc -> - (* Same line *) - if prevLoc.loc_end.pos_lnum == currLoc.loc_start.pos_lnum then ( - let afterPrev, beforeCurr = partitionAdjacentTrailing prevLoc leading in - attach t.trailing prevLoc afterPrev; - attach t.leading currLoc beforeCurr) - else - let onSameLineAsPrev, afterPrev = - partitionByOnSameLine prevLoc leading - in - attach t.trailing prevLoc onSameLineAsPrev; - let leading, _inside, _trailing = partitionByLoc afterPrev currLoc in - attach t.leading currLoc leading); - walkNode node t inside; - walkList ~prevLoc:currLoc rest t trailing + let currLoc = getLoc node in + let leading, inside, trailing = partitionByLoc comments currLoc in + (match prevLoc with + | None -> + (* first node, all leading comments attach here *) + attach t.leading currLoc leading + | Some prevLoc -> + (* Same line *) + if prevLoc.loc_end.pos_lnum == currLoc.loc_start.pos_lnum then ( + let afterPrev, beforeCurr = + partitionAdjacentTrailing prevLoc leading + in + attach t.trailing prevLoc afterPrev; + attach t.leading currLoc beforeCurr) + else + let onSameLineAsPrev, afterPrev = + partitionByOnSameLine prevLoc leading + in + attach t.trailing prevLoc onSameLineAsPrev; + let leading, _inside, _trailing = + partitionByLoc afterPrev currLoc + in + attach t.leading currLoc leading); + walkNode node t inside; + walkList ~prevLoc:currLoc rest t trailing (* The parsetree doesn't always contain location info about the opening or * closing token of a "list-of-things". This routine visits the whole list, @@ -226752,45 +226760,47 @@ and visitListButContinueWithRemainingComments : match l with | _ when comments = [] -> [] | [] -> ( - match prevLoc with - | Some loc -> - let afterPrev, rest = - if newlineDelimited then partitionByOnSameLine loc comments - else partitionAdjacentTrailing loc comments - in - attach t.trailing loc afterPrev; - rest - | None -> comments) - | node :: rest -> - let currLoc = getLoc node in - let leading, inside, trailing = partitionByLoc comments currLoc in - let () = match prevLoc with - | None -> - (* first node, all leading comments attach here *) - attach t.leading currLoc leading; - () - | Some prevLoc -> - (* Same line *) - if prevLoc.loc_end.pos_lnum == currLoc.loc_start.pos_lnum then - let afterPrev, beforeCurr = - partitionAdjacentTrailing prevLoc leading + | Some loc -> + let afterPrev, rest = + if newlineDelimited then partitionByOnSameLine loc comments + else partitionAdjacentTrailing loc comments in - let () = attach t.trailing prevLoc afterPrev in - let () = attach t.leading currLoc beforeCurr in - () - else - let onSameLineAsPrev, afterPrev = - partitionByOnSameLine prevLoc leading - in - let () = attach t.trailing prevLoc onSameLineAsPrev in - let leading, _inside, _trailing = partitionByLoc afterPrev currLoc in - let () = attach t.leading currLoc leading in - () - in - walkNode node t inside; - visitListButContinueWithRemainingComments ~prevLoc:currLoc ~getLoc ~walkNode - ~newlineDelimited rest t trailing + attach t.trailing loc afterPrev; + rest + | None -> comments) + | node :: rest -> + let currLoc = getLoc node in + let leading, inside, trailing = partitionByLoc comments currLoc in + let () = + match prevLoc with + | None -> + (* first node, all leading comments attach here *) + attach t.leading currLoc leading; + () + | Some prevLoc -> + (* Same line *) + if prevLoc.loc_end.pos_lnum == currLoc.loc_start.pos_lnum then + let afterPrev, beforeCurr = + partitionAdjacentTrailing prevLoc leading + in + let () = attach t.trailing prevLoc afterPrev in + let () = attach t.leading currLoc beforeCurr in + () + else + let onSameLineAsPrev, afterPrev = + partitionByOnSameLine prevLoc leading + in + let () = attach t.trailing prevLoc onSameLineAsPrev in + let leading, _inside, _trailing = + partitionByLoc afterPrev currLoc + in + let () = attach t.leading currLoc leading in + () + in + walkNode node t inside; + visitListButContinueWithRemainingComments ~prevLoc:currLoc ~getLoc + ~walkNode ~newlineDelimited rest t trailing and walkValueBindings vbs t comments = walkList (vbs |> List.map (fun vb -> ValueBinding vb)) t comments @@ -226821,25 +226831,25 @@ and walkTypeDeclaration (td : Parsetree.type_declaration) t comments = match td.ptype_params with | [] -> rest | typeParams -> - visitListButContinueWithRemainingComments - ~getLoc:(fun (typexpr, _variance) -> typexpr.Parsetree.ptyp_loc) - ~walkNode:walkTypeParam ~newlineDelimited:false typeParams t rest + visitListButContinueWithRemainingComments + ~getLoc:(fun (typexpr, _variance) -> typexpr.Parsetree.ptyp_loc) + ~walkNode:walkTypeParam ~newlineDelimited:false typeParams t rest in (* manifest: = typexpr *) let rest = match td.ptype_manifest with | Some typexpr -> - let beforeTyp, insideTyp, afterTyp = - partitionByLoc rest typexpr.ptyp_loc - in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - let afterTyp, rest = - partitionAdjacentTrailing typexpr.Parsetree.ptyp_loc afterTyp - in - attach t.trailing typexpr.ptyp_loc afterTyp; - rest + let beforeTyp, insideTyp, afterTyp = + partitionByLoc rest typexpr.ptyp_loc + in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkCoreType typexpr t insideTyp; + let afterTyp, rest = + partitionAdjacentTrailing typexpr.Parsetree.ptyp_loc afterTyp + in + attach t.trailing typexpr.ptyp_loc afterTyp; + rest | None -> rest in @@ -226847,16 +226857,16 @@ and walkTypeDeclaration (td : Parsetree.type_declaration) t comments = match td.ptype_kind with | Ptype_abstract | Ptype_open -> rest | Ptype_record labelDeclarations -> - let () = - if labelDeclarations = [] then attach t.inside td.ptype_loc rest - else - walkList - (labelDeclarations |> List.map (fun ld -> LabelDeclaration ld)) - t rest - in - [] + let () = + if labelDeclarations = [] then attach t.inside td.ptype_loc rest + else + walkList + (labelDeclarations |> List.map (fun ld -> LabelDeclaration ld)) + t rest + in + [] | Ptype_variant constructorDeclarations -> - walkConstructorDeclarations constructorDeclarations t rest + walkConstructorDeclarations constructorDeclarations t rest in attach t.trailing td.ptype_loc rest @@ -226892,16 +226902,16 @@ and walkConstructorDeclaration cd t comments = let rest = match cd.pcd_res with | Some typexpr -> - let beforeTyp, insideTyp, afterTyp = - partitionByLoc rest typexpr.ptyp_loc - in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - let afterTyp, rest = - partitionAdjacentTrailing typexpr.Parsetree.ptyp_loc afterTyp - in - attach t.trailing typexpr.ptyp_loc afterTyp; - rest + let beforeTyp, insideTyp, afterTyp = + partitionByLoc rest typexpr.ptyp_loc + in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkCoreType typexpr t insideTyp; + let afterTyp, rest = + partitionAdjacentTrailing typexpr.Parsetree.ptyp_loc afterTyp + in + attach t.trailing typexpr.ptyp_loc afterTyp; + rest | None -> rest in attach t.trailing cd.pcd_loc rest @@ -226909,63 +226919,71 @@ and walkConstructorDeclaration cd t comments = and walkConstructorArguments args t comments = match args with | Pcstr_tuple typexprs -> - visitListButContinueWithRemainingComments - ~getLoc:(fun n -> n.Parsetree.ptyp_loc) - ~walkNode:walkCoreType ~newlineDelimited:false typexprs t comments + visitListButContinueWithRemainingComments + ~getLoc:(fun n -> n.Parsetree.ptyp_loc) + ~walkNode:walkCoreType ~newlineDelimited:false typexprs t comments | Pcstr_record labelDeclarations -> - walkLabelDeclarations labelDeclarations t comments + walkLabelDeclarations labelDeclarations t comments and walkValueBinding vb t comments = let open Location in let vb = let open Parsetree in match (vb.pvb_pat, vb.pvb_expr) with - | ( {ppat_desc = Ppat_constraint (pat, {ptyp_desc = Ptyp_poly ([], t)})}, - {pexp_desc = Pexp_constraint (expr, _typ)} ) -> - { - vb with - pvb_pat = - Ast_helper.Pat.constraint_ - ~loc:{pat.ppat_loc with loc_end = t.Parsetree.ptyp_loc.loc_end} - pat t; - pvb_expr = expr; - } - | ( {ppat_desc = Ppat_constraint (pat, {ptyp_desc = Ptyp_poly (_ :: _, t)})}, - {pexp_desc = Pexp_fun _} ) -> - { - vb with - pvb_pat = - { - vb.pvb_pat with - ppat_loc = {pat.ppat_loc with loc_end = t.ptyp_loc.loc_end}; - }; - } + | ( { ppat_desc = Ppat_constraint (pat, { ptyp_desc = Ptyp_poly ([], t) }) }, + { pexp_desc = Pexp_constraint (expr, _typ) } ) -> + { + vb with + pvb_pat = + Ast_helper.Pat.constraint_ + ~loc:{ pat.ppat_loc with loc_end = t.Parsetree.ptyp_loc.loc_end } + pat t; + pvb_expr = expr; + } + | ( { + ppat_desc = + Ppat_constraint (pat, { ptyp_desc = Ptyp_poly (_ :: _, t) }); + }, + { pexp_desc = Pexp_fun _ } ) -> + { + vb with + pvb_pat = + { + vb.pvb_pat with + ppat_loc = { pat.ppat_loc with loc_end = t.ptyp_loc.loc_end }; + }; + } | ( ({ ppat_desc = - Ppat_constraint (pat, ({ptyp_desc = Ptyp_poly (_ :: _, t)} as typ)); + Ppat_constraint + (pat, ({ ptyp_desc = Ptyp_poly (_ :: _, t) } as typ)); } as constrainedPattern), - {pexp_desc = Pexp_newtype (_, {pexp_desc = Pexp_constraint (expr, _)})} - ) -> - (* - * The location of the Ptyp_poly on the pattern is the whole thing. - * let x: - * type t. (int, int) => int = - * (a, b) => { - * // comment - * a + b - * } - *) - { - vb with - pvb_pat = - { - constrainedPattern with - ppat_desc = Ppat_constraint (pat, typ); - ppat_loc = - {constrainedPattern.ppat_loc with loc_end = t.ptyp_loc.loc_end}; - }; - pvb_expr = expr; - } + { + pexp_desc = Pexp_newtype (_, { pexp_desc = Pexp_constraint (expr, _) }); + } ) -> + (* + * The location of the Ptyp_poly on the pattern is the whole thing. + * let x: + * type t. (int, int) => int = + * (a, b) => { + * // comment + * a + b + * } + *) + { + vb with + pvb_pat = + { + constrainedPattern with + ppat_desc = Ppat_constraint (pat, typ); + ppat_loc = + { + constrainedPattern.ppat_loc with + loc_end = t.ptyp_loc.loc_end; + }; + }; + pvb_expr = expr; + } | _ -> vb in let patternLoc = vb.Parsetree.pvb_pat.ppat_loc in @@ -226986,7 +227004,7 @@ and walkValueBinding vb t comments = partitionByLoc surroundingExpr exprLoc in if isBlockExpr expr then - walkExpression expr t (List.concat [beforeExpr; insideExpr; afterExpr]) + walkExpression expr t (List.concat [ beforeExpr; insideExpr; afterExpr ]) else ( attach t.leading exprLoc beforeExpr; walkExpression expr t insideExpr; @@ -226997,421 +227015,441 @@ and walkExpression expr t comments = match expr.Parsetree.pexp_desc with | _ when comments = [] -> () | Pexp_constant _ -> - let leading, trailing = partitionLeadingTrailing comments expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - attach t.trailing expr.pexp_loc trailing + let leading, trailing = partitionLeadingTrailing comments expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + attach t.trailing expr.pexp_loc trailing | Pexp_ident longident -> - let leading, trailing = partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc leading; - attach t.trailing longident.loc trailing + let leading, trailing = partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc leading; + attach t.trailing longident.loc trailing | Pexp_let ( _recFlag, valueBindings, - {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, None)} ) -> - walkValueBindings valueBindings t comments + { pexp_desc = Pexp_construct ({ txt = Longident.Lident "()" }, None) } + ) -> + walkValueBindings valueBindings t comments | Pexp_let (_recFlag, valueBindings, expr2) -> - let comments = - visitListButContinueWithRemainingComments - ~getLoc:(fun n -> - if n.Parsetree.pvb_pat.ppat_loc.loc_ghost then n.pvb_expr.pexp_loc - else n.Parsetree.pvb_loc) - ~walkNode:walkValueBinding ~newlineDelimited:true valueBindings t - comments - in - if isBlockExpr expr2 then walkExpression expr2 t comments - else - let leading, inside, trailing = partitionByLoc comments expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; - attach t.trailing expr2.pexp_loc trailing - | Pexp_sequence (expr1, expr2) -> - let leading, inside, trailing = partitionByLoc comments expr1.pexp_loc in - let comments = - if isBlockExpr expr1 then ( - let afterExpr, comments = - partitionByOnSameLine expr1.pexp_loc trailing + let comments = + visitListButContinueWithRemainingComments + ~getLoc:(fun n -> + if n.Parsetree.pvb_pat.ppat_loc.loc_ghost then n.pvb_expr.pexp_loc + else n.Parsetree.pvb_loc) + ~walkNode:walkValueBinding ~newlineDelimited:true valueBindings t + comments + in + if isBlockExpr expr2 then walkExpression expr2 t comments + else + let leading, inside, trailing = + partitionByLoc comments expr2.pexp_loc in - walkExpression expr1 t (List.concat [leading; inside; afterExpr]); - comments) - else ( - attach t.leading expr1.pexp_loc leading; - walkExpression expr1 t inside; - let afterExpr, comments = - partitionByOnSameLine expr1.pexp_loc trailing + attach t.leading expr2.pexp_loc leading; + walkExpression expr2 t inside; + attach t.trailing expr2.pexp_loc trailing + | Pexp_sequence (expr1, expr2) -> + let leading, inside, trailing = partitionByLoc comments expr1.pexp_loc in + let comments = + if isBlockExpr expr1 then ( + let afterExpr, comments = + partitionByOnSameLine expr1.pexp_loc trailing + in + walkExpression expr1 t (List.concat [ leading; inside; afterExpr ]); + comments) + else ( + attach t.leading expr1.pexp_loc leading; + walkExpression expr1 t inside; + let afterExpr, comments = + partitionByOnSameLine expr1.pexp_loc trailing + in + attach t.trailing expr1.pexp_loc afterExpr; + comments) + in + if isBlockExpr expr2 then walkExpression expr2 t comments + else + let leading, inside, trailing = + partitionByLoc comments expr2.pexp_loc in - attach t.trailing expr1.pexp_loc afterExpr; - comments) - in - if isBlockExpr expr2 then walkExpression expr2 t comments - else - let leading, inside, trailing = partitionByLoc comments expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; - attach t.trailing expr2.pexp_loc trailing + attach t.leading expr2.pexp_loc leading; + walkExpression expr2 t inside; + attach t.trailing expr2.pexp_loc trailing | Pexp_open (_override, longident, expr2) -> - let leading, comments = partitionLeadingTrailing comments expr.pexp_loc in - attach t.leading - {expr.pexp_loc with loc_end = longident.loc.loc_end} - leading; - let leading, trailing = partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc leading; - let afterLongident, rest = partitionByOnSameLine longident.loc trailing in - attach t.trailing longident.loc afterLongident; - if isBlockExpr expr2 then walkExpression expr2 t rest - else - let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; - attach t.trailing expr2.pexp_loc trailing + let leading, comments = partitionLeadingTrailing comments expr.pexp_loc in + attach t.leading + { expr.pexp_loc with loc_end = longident.loc.loc_end } + leading; + let leading, trailing = partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc leading; + let afterLongident, rest = partitionByOnSameLine longident.loc trailing in + attach t.trailing longident.loc afterLongident; + if isBlockExpr expr2 then walkExpression expr2 t rest + else + let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walkExpression expr2 t inside; + attach t.trailing expr2.pexp_loc trailing | Pexp_extension - ( {txt = "bs.obj" | "obj"}, - PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_record (rows, _)}, [])}] - ) -> - walkList - (rows |> List.map (fun (li, e) -> ExprRecordRow (li, e))) - t comments + ( { txt = "bs.obj" | "obj" }, + PStr + [ + { + pstr_desc = Pstr_eval ({ pexp_desc = Pexp_record (rows, _) }, []); + }; + ] ) -> + walkList + (rows |> List.map (fun (li, e) -> ExprRecordRow (li, e))) + t comments | Pexp_extension extension -> walkExtension extension t comments | Pexp_letexception (extensionConstructor, expr2) -> - let leading, comments = partitionLeadingTrailing comments expr.pexp_loc in - attach t.leading - {expr.pexp_loc with loc_end = extensionConstructor.pext_loc.loc_end} - leading; - let leading, inside, trailing = - partitionByLoc comments extensionConstructor.pext_loc - in - attach t.leading extensionConstructor.pext_loc leading; - walkExtensionConstructor extensionConstructor t inside; - let afterExtConstr, rest = - partitionByOnSameLine extensionConstructor.pext_loc trailing - in - attach t.trailing extensionConstructor.pext_loc afterExtConstr; - if isBlockExpr expr2 then walkExpression expr2 t rest - else - let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; - attach t.trailing expr2.pexp_loc trailing + let leading, comments = partitionLeadingTrailing comments expr.pexp_loc in + attach t.leading + { expr.pexp_loc with loc_end = extensionConstructor.pext_loc.loc_end } + leading; + let leading, inside, trailing = + partitionByLoc comments extensionConstructor.pext_loc + in + attach t.leading extensionConstructor.pext_loc leading; + walkExtensionConstructor extensionConstructor t inside; + let afterExtConstr, rest = + partitionByOnSameLine extensionConstructor.pext_loc trailing + in + attach t.trailing extensionConstructor.pext_loc afterExtConstr; + if isBlockExpr expr2 then walkExpression expr2 t rest + else + let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walkExpression expr2 t inside; + attach t.trailing expr2.pexp_loc trailing | Pexp_letmodule (stringLoc, modExpr, expr2) -> - let leading, comments = partitionLeadingTrailing comments expr.pexp_loc in - attach t.leading - {expr.pexp_loc with loc_end = modExpr.pmod_loc.loc_end} - leading; - let leading, trailing = partitionLeadingTrailing comments stringLoc.loc in - attach t.leading stringLoc.loc leading; - let afterString, rest = partitionAdjacentTrailing stringLoc.loc trailing in - attach t.trailing stringLoc.loc afterString; - let beforeModExpr, insideModExpr, afterModExpr = - partitionByLoc rest modExpr.pmod_loc - in - attach t.leading modExpr.pmod_loc beforeModExpr; - walkModuleExpr modExpr t insideModExpr; - let afterModExpr, rest = - partitionByOnSameLine modExpr.pmod_loc afterModExpr - in - attach t.trailing modExpr.pmod_loc afterModExpr; - if isBlockExpr expr2 then walkExpression expr2 t rest - else - let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; - attach t.trailing expr2.pexp_loc trailing + let leading, comments = partitionLeadingTrailing comments expr.pexp_loc in + attach t.leading + { expr.pexp_loc with loc_end = modExpr.pmod_loc.loc_end } + leading; + let leading, trailing = partitionLeadingTrailing comments stringLoc.loc in + attach t.leading stringLoc.loc leading; + let afterString, rest = + partitionAdjacentTrailing stringLoc.loc trailing + in + attach t.trailing stringLoc.loc afterString; + let beforeModExpr, insideModExpr, afterModExpr = + partitionByLoc rest modExpr.pmod_loc + in + attach t.leading modExpr.pmod_loc beforeModExpr; + walkModuleExpr modExpr t insideModExpr; + let afterModExpr, rest = + partitionByOnSameLine modExpr.pmod_loc afterModExpr + in + attach t.trailing modExpr.pmod_loc afterModExpr; + if isBlockExpr expr2 then walkExpression expr2 t rest + else + let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walkExpression expr2 t inside; + attach t.trailing expr2.pexp_loc trailing | Pexp_assert expr | Pexp_lazy expr -> - if isBlockExpr expr then walkExpression expr t comments - else + if isBlockExpr expr then walkExpression expr t comments + else + let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + walkExpression expr t inside; + attach t.trailing expr.pexp_loc trailing + | Pexp_coerce (expr, optTypexpr, typexpr) -> let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in attach t.leading expr.pexp_loc leading; walkExpression expr t inside; - attach t.trailing expr.pexp_loc trailing - | Pexp_coerce (expr, optTypexpr, typexpr) -> - let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; - let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc trailing in - attach t.trailing expr.pexp_loc afterExpr; - let rest = - match optTypexpr with - | Some typexpr -> - let leading, inside, trailing = - partitionByLoc comments typexpr.ptyp_loc - in - attach t.leading typexpr.ptyp_loc leading; - walkCoreType typexpr t inside; - let afterTyp, rest = - partitionAdjacentTrailing typexpr.ptyp_loc trailing - in - attach t.trailing typexpr.ptyp_loc afterTyp; - rest - | None -> rest - in - let leading, inside, trailing = partitionByLoc rest typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc leading; - walkCoreType typexpr t inside; - attach t.trailing typexpr.ptyp_loc trailing + let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc trailing in + attach t.trailing expr.pexp_loc afterExpr; + let rest = + match optTypexpr with + | Some typexpr -> + let leading, inside, trailing = + partitionByLoc comments typexpr.ptyp_loc + in + attach t.leading typexpr.ptyp_loc leading; + walkCoreType typexpr t inside; + let afterTyp, rest = + partitionAdjacentTrailing typexpr.ptyp_loc trailing + in + attach t.trailing typexpr.ptyp_loc afterTyp; + rest + | None -> rest + in + let leading, inside, trailing = partitionByLoc rest typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc leading; + walkCoreType typexpr t inside; + attach t.trailing typexpr.ptyp_loc trailing | Pexp_constraint (expr, typexpr) -> - let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; - let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc trailing in - attach t.trailing expr.pexp_loc afterExpr; - let leading, inside, trailing = partitionByLoc rest typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc leading; - walkCoreType typexpr t inside; - attach t.trailing typexpr.ptyp_loc trailing + let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + walkExpression expr t inside; + let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc trailing in + attach t.trailing expr.pexp_loc afterExpr; + let leading, inside, trailing = partitionByLoc rest typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc leading; + walkCoreType typexpr t inside; + attach t.trailing typexpr.ptyp_loc trailing | Pexp_tuple [] | Pexp_array [] - | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> - attach t.inside expr.pexp_loc comments - | Pexp_construct ({txt = Longident.Lident "::"}, _) -> - walkList - (collectListExprs [] expr |> List.map (fun e -> Expression e)) - t comments + | Pexp_construct ({ txt = Longident.Lident "[]" }, _) -> + attach t.inside expr.pexp_loc comments + | Pexp_construct ({ txt = Longident.Lident "::" }, _) -> + walkList + (collectListExprs [] expr |> List.map (fun e -> Expression e)) + t comments | Pexp_construct (longident, args) -> ( - let leading, trailing = partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc leading; - match args with - | Some expr -> - let afterLongident, rest = - partitionAdjacentTrailing longident.loc trailing - in - attach t.trailing longident.loc afterLongident; - walkExpression expr t rest - | None -> attach t.trailing longident.loc trailing) + let leading, trailing = partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc leading; + match args with + | Some expr -> + let afterLongident, rest = + partitionAdjacentTrailing longident.loc trailing + in + attach t.trailing longident.loc afterLongident; + walkExpression expr t rest + | None -> attach t.trailing longident.loc trailing) | Pexp_variant (_label, None) -> () | Pexp_variant (_label, Some expr) -> walkExpression expr t comments | Pexp_array exprs | Pexp_tuple exprs -> - walkList (exprs |> List.map (fun e -> Expression e)) t comments + walkList (exprs |> List.map (fun e -> Expression e)) t comments | Pexp_record (rows, spreadExpr) -> - if rows = [] then attach t.inside expr.pexp_loc comments - else - let comments = - match spreadExpr with - | None -> comments - | Some expr -> - let leading, inside, trailing = - partitionByLoc comments expr.pexp_loc + if rows = [] then attach t.inside expr.pexp_loc comments + else + let comments = + match spreadExpr with + | None -> comments + | Some expr -> + let leading, inside, trailing = + partitionByLoc comments expr.pexp_loc + in + attach t.leading expr.pexp_loc leading; + walkExpression expr t inside; + let afterExpr, rest = + partitionAdjacentTrailing expr.pexp_loc trailing + in + attach t.trailing expr.pexp_loc afterExpr; + rest + in + walkList + (rows |> List.map (fun (li, e) -> ExprRecordRow (li, e))) + t comments + | Pexp_field (expr, longident) -> + let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in + let trailing = + if isBlockExpr expr then ( + let afterExpr, rest = + partitionAdjacentTrailing expr.pexp_loc trailing in + walkExpression expr t (List.concat [ leading; inside; afterExpr ]); + rest) + else ( attach t.leading expr.pexp_loc leading; walkExpression expr t inside; + trailing) + in + let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc trailing in + attach t.trailing expr.pexp_loc afterExpr; + let leading, trailing = partitionLeadingTrailing rest longident.loc in + attach t.leading longident.loc leading; + attach t.trailing longident.loc trailing + | Pexp_setfield (expr1, longident, expr2) -> + let leading, inside, trailing = partitionByLoc comments expr1.pexp_loc in + let rest = + if isBlockExpr expr1 then ( let afterExpr, rest = - partitionAdjacentTrailing expr.pexp_loc trailing + partitionAdjacentTrailing expr1.pexp_loc trailing in - attach t.trailing expr.pexp_loc afterExpr; + walkExpression expr1 t (List.concat [ leading; inside; afterExpr ]); + rest) + else + let afterExpr, rest = + partitionAdjacentTrailing expr1.pexp_loc trailing + in + attach t.leading expr1.pexp_loc leading; + walkExpression expr1 t inside; + attach t.trailing expr1.pexp_loc afterExpr; rest in - walkList - (rows |> List.map (fun (li, e) -> ExprRecordRow (li, e))) - t comments - | Pexp_field (expr, longident) -> - let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in - let trailing = - if isBlockExpr expr then ( - let afterExpr, rest = - partitionAdjacentTrailing expr.pexp_loc trailing - in - walkExpression expr t (List.concat [leading; inside; afterExpr]); - rest) - else ( - attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; - trailing) - in - let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc trailing in - attach t.trailing expr.pexp_loc afterExpr; - let leading, trailing = partitionLeadingTrailing rest longident.loc in - attach t.leading longident.loc leading; - attach t.trailing longident.loc trailing - | Pexp_setfield (expr1, longident, expr2) -> - let leading, inside, trailing = partitionByLoc comments expr1.pexp_loc in - let rest = - if isBlockExpr expr1 then ( - let afterExpr, rest = - partitionAdjacentTrailing expr1.pexp_loc trailing - in - walkExpression expr1 t (List.concat [leading; inside; afterExpr]); - rest) + let beforeLongident, afterLongident = + partitionLeadingTrailing rest longident.loc + in + attach t.leading longident.loc beforeLongident; + let afterLongident, rest = + partitionAdjacentTrailing longident.loc afterLongident + in + attach t.trailing longident.loc afterLongident; + if isBlockExpr expr2 then walkExpression expr2 t rest else - let afterExpr, rest = - partitionAdjacentTrailing expr1.pexp_loc trailing - in - attach t.leading expr1.pexp_loc leading; - walkExpression expr1 t inside; - attach t.trailing expr1.pexp_loc afterExpr; - rest - in - let beforeLongident, afterLongident = - partitionLeadingTrailing rest longident.loc - in - attach t.leading longident.loc beforeLongident; - let afterLongident, rest = - partitionAdjacentTrailing longident.loc afterLongident - in - attach t.trailing longident.loc afterLongident; - if isBlockExpr expr2 then walkExpression expr2 t rest - else - let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; - attach t.trailing expr2.pexp_loc trailing + let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walkExpression expr2 t inside; + attach t.trailing expr2.pexp_loc trailing | Pexp_ifthenelse (ifExpr, thenExpr, elseExpr) -> ( - let leading, rest = partitionLeadingTrailing comments expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - let leading, inside, trailing = partitionByLoc rest ifExpr.pexp_loc in - let comments = - if isBlockExpr ifExpr then ( - let afterExpr, comments = - partitionAdjacentTrailing ifExpr.pexp_loc trailing - in - walkExpression ifExpr t (List.concat [leading; inside; afterExpr]); - comments) - else ( - attach t.leading ifExpr.pexp_loc leading; - walkExpression ifExpr t inside; - let afterExpr, comments = - partitionAdjacentTrailing ifExpr.pexp_loc trailing - in - attach t.trailing ifExpr.pexp_loc afterExpr; - comments) - in - let leading, inside, trailing = partitionByLoc comments thenExpr.pexp_loc in - let comments = - if isBlockExpr thenExpr then ( - let afterExpr, trailing = - partitionAdjacentTrailing thenExpr.pexp_loc trailing - in - walkExpression thenExpr t (List.concat [leading; inside; afterExpr]); - trailing) - else ( - attach t.leading thenExpr.pexp_loc leading; - walkExpression thenExpr t inside; - let afterExpr, comments = - partitionAdjacentTrailing thenExpr.pexp_loc trailing - in - attach t.trailing thenExpr.pexp_loc afterExpr; - comments) - in - match elseExpr with - | None -> () - | Some expr -> - if isBlockExpr expr || isIfThenElseExpr expr then - walkExpression expr t comments - else - let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; - attach t.trailing expr.pexp_loc trailing) + let leading, rest = partitionLeadingTrailing comments expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + let leading, inside, trailing = partitionByLoc rest ifExpr.pexp_loc in + let comments = + if isBlockExpr ifExpr then ( + let afterExpr, comments = + partitionAdjacentTrailing ifExpr.pexp_loc trailing + in + walkExpression ifExpr t (List.concat [ leading; inside; afterExpr ]); + comments) + else ( + attach t.leading ifExpr.pexp_loc leading; + walkExpression ifExpr t inside; + let afterExpr, comments = + partitionAdjacentTrailing ifExpr.pexp_loc trailing + in + attach t.trailing ifExpr.pexp_loc afterExpr; + comments) + in + let leading, inside, trailing = + partitionByLoc comments thenExpr.pexp_loc + in + let comments = + if isBlockExpr thenExpr then ( + let afterExpr, trailing = + partitionAdjacentTrailing thenExpr.pexp_loc trailing + in + walkExpression thenExpr t (List.concat [ leading; inside; afterExpr ]); + trailing) + else ( + attach t.leading thenExpr.pexp_loc leading; + walkExpression thenExpr t inside; + let afterExpr, comments = + partitionAdjacentTrailing thenExpr.pexp_loc trailing + in + attach t.trailing thenExpr.pexp_loc afterExpr; + comments) + in + match elseExpr with + | None -> () + | Some expr -> + if isBlockExpr expr || isIfThenElseExpr expr then + walkExpression expr t comments + else + let leading, inside, trailing = + partitionByLoc comments expr.pexp_loc + in + attach t.leading expr.pexp_loc leading; + walkExpression expr t inside; + attach t.trailing expr.pexp_loc trailing) | Pexp_while (expr1, expr2) -> - let leading, inside, trailing = partitionByLoc comments expr1.pexp_loc in - let rest = - if isBlockExpr expr1 then ( - let afterExpr, rest = - partitionAdjacentTrailing expr1.pexp_loc trailing - in - walkExpression expr1 t (List.concat [leading; inside; afterExpr]); - rest) - else ( - attach t.leading expr1.pexp_loc leading; - walkExpression expr1 t inside; - let afterExpr, rest = - partitionAdjacentTrailing expr1.pexp_loc trailing - in - attach t.trailing expr1.pexp_loc afterExpr; - rest) - in - if isBlockExpr expr2 then walkExpression expr2 t rest - else + let leading, inside, trailing = partitionByLoc comments expr1.pexp_loc in + let rest = + if isBlockExpr expr1 then ( + let afterExpr, rest = + partitionAdjacentTrailing expr1.pexp_loc trailing + in + walkExpression expr1 t (List.concat [ leading; inside; afterExpr ]); + rest) + else ( + attach t.leading expr1.pexp_loc leading; + walkExpression expr1 t inside; + let afterExpr, rest = + partitionAdjacentTrailing expr1.pexp_loc trailing + in + attach t.trailing expr1.pexp_loc afterExpr; + rest) + in + if isBlockExpr expr2 then walkExpression expr2 t rest + else + let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walkExpression expr2 t inside; + attach t.trailing expr2.pexp_loc trailing + | Pexp_for (pat, expr1, expr2, _, expr3) -> + let leading, inside, trailing = partitionByLoc comments pat.ppat_loc in + attach t.leading pat.ppat_loc leading; + walkPattern pat t inside; + let afterPat, rest = partitionAdjacentTrailing pat.ppat_loc trailing in + attach t.trailing pat.ppat_loc afterPat; + let leading, inside, trailing = partitionByLoc rest expr1.pexp_loc in + attach t.leading expr1.pexp_loc leading; + walkExpression expr1 t inside; + let afterExpr, rest = partitionAdjacentTrailing expr1.pexp_loc trailing in + attach t.trailing expr1.pexp_loc afterExpr; let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in attach t.leading expr2.pexp_loc leading; walkExpression expr2 t inside; - attach t.trailing expr2.pexp_loc trailing - | Pexp_for (pat, expr1, expr2, _, expr3) -> - let leading, inside, trailing = partitionByLoc comments pat.ppat_loc in - attach t.leading pat.ppat_loc leading; - walkPattern pat t inside; - let afterPat, rest = partitionAdjacentTrailing pat.ppat_loc trailing in - attach t.trailing pat.ppat_loc afterPat; - let leading, inside, trailing = partitionByLoc rest expr1.pexp_loc in - attach t.leading expr1.pexp_loc leading; - walkExpression expr1 t inside; - let afterExpr, rest = partitionAdjacentTrailing expr1.pexp_loc trailing in - attach t.trailing expr1.pexp_loc afterExpr; - let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; - let afterExpr, rest = partitionAdjacentTrailing expr2.pexp_loc trailing in - attach t.trailing expr2.pexp_loc afterExpr; - if isBlockExpr expr3 then walkExpression expr3 t rest - else - let leading, inside, trailing = partitionByLoc rest expr3.pexp_loc in - attach t.leading expr3.pexp_loc leading; - walkExpression expr3 t inside; - attach t.trailing expr3.pexp_loc trailing + let afterExpr, rest = partitionAdjacentTrailing expr2.pexp_loc trailing in + attach t.trailing expr2.pexp_loc afterExpr; + if isBlockExpr expr3 then walkExpression expr3 t rest + else + let leading, inside, trailing = partitionByLoc rest expr3.pexp_loc in + attach t.leading expr3.pexp_loc leading; + walkExpression expr3 t inside; + attach t.trailing expr3.pexp_loc trailing | Pexp_pack modExpr -> - let before, inside, after = partitionByLoc comments modExpr.pmod_loc in - attach t.leading modExpr.pmod_loc before; - walkModuleExpr modExpr t inside; - attach t.trailing modExpr.pmod_loc after - | Pexp_match (expr1, [case; elseBranch]) + let before, inside, after = partitionByLoc comments modExpr.pmod_loc in + attach t.leading modExpr.pmod_loc before; + walkModuleExpr modExpr t inside; + attach t.trailing modExpr.pmod_loc after + | Pexp_match (expr1, [ case; elseBranch ]) when Res_parsetree_viewer.hasIfLetAttribute expr.pexp_attributes -> - let before, inside, after = partitionByLoc comments case.pc_lhs.ppat_loc in - attach t.leading case.pc_lhs.ppat_loc before; - walkPattern case.pc_lhs t inside; - let afterPat, rest = partitionAdjacentTrailing case.pc_lhs.ppat_loc after in - attach t.trailing case.pc_lhs.ppat_loc afterPat; - let before, inside, after = partitionByLoc rest expr1.pexp_loc in - attach t.leading expr1.pexp_loc before; - walkExpression expr1 t inside; - let afterExpr, rest = partitionAdjacentTrailing expr1.pexp_loc after in - attach t.trailing expr1.pexp_loc afterExpr; - let before, inside, after = partitionByLoc rest case.pc_rhs.pexp_loc in - let after = - if isBlockExpr case.pc_rhs then ( - let afterExpr, rest = - partitionAdjacentTrailing case.pc_rhs.pexp_loc after - in - walkExpression case.pc_rhs t (List.concat [before; inside; afterExpr]); - rest) - else ( - attach t.leading case.pc_rhs.pexp_loc before; - walkExpression case.pc_rhs t inside; - after) - in - let afterExpr, rest = - partitionAdjacentTrailing case.pc_rhs.pexp_loc after - in - attach t.trailing case.pc_rhs.pexp_loc afterExpr; - let before, inside, after = - partitionByLoc rest elseBranch.pc_rhs.pexp_loc - in - let after = - if isBlockExpr elseBranch.pc_rhs then ( - let afterExpr, rest = - partitionAdjacentTrailing elseBranch.pc_rhs.pexp_loc after - in - walkExpression elseBranch.pc_rhs t - (List.concat [before; inside; afterExpr]); - rest) - else ( - attach t.leading elseBranch.pc_rhs.pexp_loc before; - walkExpression elseBranch.pc_rhs t inside; - after) - in - attach t.trailing elseBranch.pc_rhs.pexp_loc after + let before, inside, after = + partitionByLoc comments case.pc_lhs.ppat_loc + in + attach t.leading case.pc_lhs.ppat_loc before; + walkPattern case.pc_lhs t inside; + let afterPat, rest = + partitionAdjacentTrailing case.pc_lhs.ppat_loc after + in + attach t.trailing case.pc_lhs.ppat_loc afterPat; + let before, inside, after = partitionByLoc rest expr1.pexp_loc in + attach t.leading expr1.pexp_loc before; + walkExpression expr1 t inside; + let afterExpr, rest = partitionAdjacentTrailing expr1.pexp_loc after in + attach t.trailing expr1.pexp_loc afterExpr; + let before, inside, after = partitionByLoc rest case.pc_rhs.pexp_loc in + let after = + if isBlockExpr case.pc_rhs then ( + let afterExpr, rest = + partitionAdjacentTrailing case.pc_rhs.pexp_loc after + in + walkExpression case.pc_rhs t + (List.concat [ before; inside; afterExpr ]); + rest) + else ( + attach t.leading case.pc_rhs.pexp_loc before; + walkExpression case.pc_rhs t inside; + after) + in + let afterExpr, rest = + partitionAdjacentTrailing case.pc_rhs.pexp_loc after + in + attach t.trailing case.pc_rhs.pexp_loc afterExpr; + let before, inside, after = + partitionByLoc rest elseBranch.pc_rhs.pexp_loc + in + let after = + if isBlockExpr elseBranch.pc_rhs then ( + let afterExpr, rest = + partitionAdjacentTrailing elseBranch.pc_rhs.pexp_loc after + in + walkExpression elseBranch.pc_rhs t + (List.concat [ before; inside; afterExpr ]); + rest) + else ( + attach t.leading elseBranch.pc_rhs.pexp_loc before; + walkExpression elseBranch.pc_rhs t inside; + after) + in + attach t.trailing elseBranch.pc_rhs.pexp_loc after | Pexp_match (expr, cases) | Pexp_try (expr, cases) -> - let before, inside, after = partitionByLoc comments expr.pexp_loc in - let after = - if isBlockExpr expr then ( - let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc after in - walkExpression expr t (List.concat [before; inside; afterExpr]); - rest) - else ( - attach t.leading expr.pexp_loc before; - walkExpression expr t inside; - after) - in - let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc after in - attach t.trailing expr.pexp_loc afterExpr; - walkList (cases |> List.map (fun case -> Case case)) t rest - (* unary expression: todo use parsetreeviewer *) + let before, inside, after = partitionByLoc comments expr.pexp_loc in + let after = + if isBlockExpr expr then ( + let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc after in + walkExpression expr t (List.concat [ before; inside; afterExpr ]); + rest) + else ( + attach t.leading expr.pexp_loc before; + walkExpression expr t inside; + after) + in + let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc after in + attach t.trailing expr.pexp_loc afterExpr; + walkList (cases |> List.map (fun case -> Case case)) t rest + (* unary expression: todo use parsetreeviewer *) | Pexp_apply ( { pexp_desc = @@ -227421,11 +227459,11 @@ and walkExpression expr t comments = Longident.Lident ("~+" | "~+." | "~-" | "~-." | "not" | "!"); }; }, - [(Nolabel, argExpr)] ) -> - let before, inside, after = partitionByLoc comments argExpr.pexp_loc in - attach t.leading argExpr.pexp_loc before; - walkExpression argExpr t inside; - attach t.trailing argExpr.pexp_loc after + [ (Nolabel, argExpr) ] ) -> + let before, inside, after = partitionByLoc comments argExpr.pexp_loc in + attach t.leading argExpr.pexp_loc before; + walkExpression argExpr t inside; + attach t.trailing argExpr.pexp_loc after (* binary expression *) | Pexp_apply ( { @@ -227439,118 +227477,127 @@ and walkExpression expr t comments = | "*" | "*." | "/" | "/." | "**" | "|." | "<>" ); }; }, - [(Nolabel, operand1); (Nolabel, operand2)] ) -> - let before, inside, after = partitionByLoc comments operand1.pexp_loc in - attach t.leading operand1.pexp_loc before; - walkExpression operand1 t inside; - let afterOperand1, rest = - partitionAdjacentTrailing operand1.pexp_loc after - in - attach t.trailing operand1.pexp_loc afterOperand1; - let before, inside, after = partitionByLoc rest operand2.pexp_loc in - attach t.leading operand2.pexp_loc before; - walkExpression operand2 t inside; - (* (List.concat [inside; after]); *) - attach t.trailing operand2.pexp_loc after + [ (Nolabel, operand1); (Nolabel, operand2) ] ) -> + let before, inside, after = partitionByLoc comments operand1.pexp_loc in + attach t.leading operand1.pexp_loc before; + walkExpression operand1 t inside; + let afterOperand1, rest = + partitionAdjacentTrailing operand1.pexp_loc after + in + attach t.trailing operand1.pexp_loc afterOperand1; + let before, inside, after = partitionByLoc rest operand2.pexp_loc in + attach t.leading operand2.pexp_loc before; + walkExpression operand2 t inside; + (* (List.concat [inside; after]); *) + attach t.trailing operand2.pexp_loc after | Pexp_apply (callExpr, arguments) -> - let before, inside, after = partitionByLoc comments callExpr.pexp_loc in - let after = - if isBlockExpr callExpr then ( + let before, inside, after = partitionByLoc comments callExpr.pexp_loc in + let after = + if isBlockExpr callExpr then ( + let afterExpr, rest = + partitionAdjacentTrailing callExpr.pexp_loc after + in + walkExpression callExpr t (List.concat [ before; inside; afterExpr ]); + rest) + else ( + attach t.leading callExpr.pexp_loc before; + walkExpression callExpr t inside; + after) + in + if ParsetreeViewer.isJsxExpression expr then ( + let props = + arguments + |> List.filter (fun (label, _) -> + match label with + | Asttypes.Labelled "children" -> false + | Asttypes.Nolabel -> false + | _ -> true) + in + let maybeChildren = + arguments + |> List.find_opt (fun (label, _) -> + label = Asttypes.Labelled "children") + in + match maybeChildren with + (* There is no need to deal with this situation as the children cannot be NONE *) + | None -> () + | Some (_, children) -> + let leading, inside, _ = partitionByLoc after children.pexp_loc in + if props = [] then + (* All comments inside a tag are trailing comments of the tag if there are no props + + *) + let afterExpr, _ = + partitionAdjacentTrailing callExpr.pexp_loc after + in + attach t.trailing callExpr.pexp_loc afterExpr + else + walkList + (props |> List.map (fun (_, e) -> ExprArgument e)) + t leading; + walkExpression children t inside) + else let afterExpr, rest = partitionAdjacentTrailing callExpr.pexp_loc after in - walkExpression callExpr t (List.concat [before; inside; afterExpr]); - rest) - else ( - attach t.leading callExpr.pexp_loc before; - walkExpression callExpr t inside; - after) - in - if ParsetreeViewer.isJsxExpression expr then ( - let props = - arguments - |> List.filter (fun (label, _) -> - match label with - | Asttypes.Labelled "children" -> false - | Asttypes.Nolabel -> false - | _ -> true) - in - let maybeChildren = - arguments - |> List.find_opt (fun (label, _) -> - label = Asttypes.Labelled "children") + attach t.trailing callExpr.pexp_loc afterExpr; + walkList (arguments |> List.map (fun (_, e) -> ExprArgument e)) t rest + | Pexp_fun (_, _, _, _) | Pexp_newtype _ -> ( + let _, parameters, returnExpr = funExpr expr in + let comments = + visitListButContinueWithRemainingComments ~newlineDelimited:false + ~walkNode:walkExprPararameter + ~getLoc:(fun (_attrs, _argLbl, exprOpt, pattern) -> + let open Parsetree in + let startPos = + match pattern.ppat_attributes with + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _attrs -> + loc.loc_start + | _ -> pattern.ppat_loc.loc_start + in + match exprOpt with + | None -> { pattern.ppat_loc with loc_start = startPos } + | Some expr -> + { + pattern.ppat_loc with + loc_start = startPos; + loc_end = expr.pexp_loc.loc_end; + }) + parameters t comments in - match maybeChildren with - (* There is no need to deal with this situation as the children cannot be NONE *) - | None -> () - | Some (_, children) -> - let leading, inside, _ = partitionByLoc after children.pexp_loc in - if props = [] then - (* All comments inside a tag are trailing comments of the tag if there are no props - - *) - let afterExpr, _ = - partitionAdjacentTrailing callExpr.pexp_loc after + match returnExpr.pexp_desc with + | Pexp_constraint (expr, typ) + when expr.pexp_loc.loc_start.pos_cnum >= typ.ptyp_loc.loc_end.pos_cnum + -> + let leading, inside, trailing = + partitionByLoc comments typ.ptyp_loc in - attach t.trailing callExpr.pexp_loc afterExpr - else - walkList (props |> List.map (fun (_, e) -> ExprArgument e)) t leading; - walkExpression children t inside) - else - let afterExpr, rest = partitionAdjacentTrailing callExpr.pexp_loc after in - attach t.trailing callExpr.pexp_loc afterExpr; - walkList (arguments |> List.map (fun (_, e) -> ExprArgument e)) t rest - | Pexp_fun (_, _, _, _) | Pexp_newtype _ -> ( - let _, parameters, returnExpr = funExpr expr in - let comments = - visitListButContinueWithRemainingComments ~newlineDelimited:false - ~walkNode:walkExprPararameter - ~getLoc:(fun (_attrs, _argLbl, exprOpt, pattern) -> - let open Parsetree in - let startPos = - match pattern.ppat_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _attrs -> - loc.loc_start - | _ -> pattern.ppat_loc.loc_start + attach t.leading typ.ptyp_loc leading; + walkCoreType typ t inside; + let afterTyp, comments = + partitionAdjacentTrailing typ.ptyp_loc trailing in - match exprOpt with - | None -> {pattern.ppat_loc with loc_start = startPos} - | Some expr -> - { - pattern.ppat_loc with - loc_start = startPos; - loc_end = expr.pexp_loc.loc_end; - }) - parameters t comments - in - match returnExpr.pexp_desc with - | Pexp_constraint (expr, typ) - when expr.pexp_loc.loc_start.pos_cnum >= typ.ptyp_loc.loc_end.pos_cnum -> - let leading, inside, trailing = partitionByLoc comments typ.ptyp_loc in - attach t.leading typ.ptyp_loc leading; - walkCoreType typ t inside; - let afterTyp, comments = - partitionAdjacentTrailing typ.ptyp_loc trailing - in - attach t.trailing typ.ptyp_loc afterTyp; - if isBlockExpr expr then walkExpression expr t comments - else - let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; - attach t.trailing expr.pexp_loc trailing - | _ -> - if isBlockExpr returnExpr then walkExpression returnExpr t comments - else - let leading, inside, trailing = - partitionByLoc comments returnExpr.pexp_loc - in - attach t.leading returnExpr.pexp_loc leading; - walkExpression returnExpr t inside; - attach t.trailing returnExpr.pexp_loc trailing) + attach t.trailing typ.ptyp_loc afterTyp; + if isBlockExpr expr then walkExpression expr t comments + else + let leading, inside, trailing = + partitionByLoc comments expr.pexp_loc + in + attach t.leading expr.pexp_loc leading; + walkExpression expr t inside; + attach t.trailing expr.pexp_loc trailing + | _ -> + if isBlockExpr returnExpr then walkExpression returnExpr t comments + else + let leading, inside, trailing = + partitionByLoc comments returnExpr.pexp_loc + in + attach t.leading returnExpr.pexp_loc leading; + walkExpression returnExpr t inside; + attach t.trailing returnExpr.pexp_loc trailing) | _ -> () and walkExprPararameter (_attrs, _argLbl, exprOpt, pattern) t comments = @@ -227559,52 +227606,54 @@ and walkExprPararameter (_attrs, _argLbl, exprOpt, pattern) t comments = walkPattern pattern t inside; match exprOpt with | Some expr -> - let _afterPat, rest = partitionAdjacentTrailing pattern.ppat_loc trailing in - attach t.trailing pattern.ppat_loc trailing; - if isBlockExpr expr then walkExpression expr t rest - else - let leading, inside, trailing = partitionByLoc rest expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; - attach t.trailing expr.pexp_loc trailing + let _afterPat, rest = + partitionAdjacentTrailing pattern.ppat_loc trailing + in + attach t.trailing pattern.ppat_loc trailing; + if isBlockExpr expr then walkExpression expr t rest + else + let leading, inside, trailing = partitionByLoc rest expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + walkExpression expr t inside; + attach t.trailing expr.pexp_loc trailing | None -> attach t.trailing pattern.ppat_loc trailing and walkExprArgument expr t comments = match expr.Parsetree.pexp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _attrs -> - let leading, trailing = partitionLeadingTrailing comments loc in - attach t.leading loc leading; - let afterLabel, rest = partitionAdjacentTrailing loc trailing in - attach t.trailing loc afterLabel; - let before, inside, after = partitionByLoc rest expr.pexp_loc in - attach t.leading expr.pexp_loc before; - walkExpression expr t inside; - attach t.trailing expr.pexp_loc after + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _attrs -> + let leading, trailing = partitionLeadingTrailing comments loc in + attach t.leading loc leading; + let afterLabel, rest = partitionAdjacentTrailing loc trailing in + attach t.trailing loc afterLabel; + let before, inside, after = partitionByLoc rest expr.pexp_loc in + attach t.leading expr.pexp_loc before; + walkExpression expr t inside; + attach t.trailing expr.pexp_loc after | _ -> - let before, inside, after = partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc before; - walkExpression expr t inside; - attach t.trailing expr.pexp_loc after + let before, inside, after = partitionByLoc comments expr.pexp_loc in + attach t.leading expr.pexp_loc before; + walkExpression expr t inside; + attach t.trailing expr.pexp_loc after and walkCase (case : Parsetree.case) t comments = let before, inside, after = partitionByLoc comments case.pc_lhs.ppat_loc in (* cases don't have a location on their own, leading comments should go * after the bar on the pattern *) - walkPattern case.pc_lhs t (List.concat [before; inside]); + walkPattern case.pc_lhs t (List.concat [ before; inside ]); let afterPat, rest = partitionAdjacentTrailing case.pc_lhs.ppat_loc after in attach t.trailing case.pc_lhs.ppat_loc afterPat; let comments = match case.pc_guard with | Some expr -> - let before, inside, after = partitionByLoc rest expr.pexp_loc in - let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc after in - if isBlockExpr expr then - walkExpression expr t (List.concat [before; inside; afterExpr]) - else ( - attach t.leading expr.pexp_loc before; - walkExpression expr t inside; - attach t.trailing expr.pexp_loc afterExpr); - rest + let before, inside, after = partitionByLoc rest expr.pexp_loc in + let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc after in + if isBlockExpr expr then + walkExpression expr t (List.concat [ before; inside; afterExpr ]) + else ( + attach t.leading expr.pexp_loc before; + walkExpression expr t inside; + attach t.trailing expr.pexp_loc afterExpr); + rest | None -> rest in if isBlockExpr case.pc_rhs then walkExpression case.pc_rhs t comments @@ -227642,89 +227691,91 @@ and walkExtensionConstructor extConstr t comments = and walkExtensionConstructorKind kind t comments = match kind with | Pext_rebind longident -> - let leading, trailing = partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc leading; - attach t.trailing longident.loc trailing + let leading, trailing = partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc leading; + attach t.trailing longident.loc trailing | Pext_decl (constructorArguments, maybeTypExpr) -> ( - let rest = walkConstructorArguments constructorArguments t comments in - match maybeTypExpr with - | None -> () - | Some typexpr -> - let before, inside, after = partitionByLoc rest typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc before; - walkCoreType typexpr t inside; - attach t.trailing typexpr.ptyp_loc after) + let rest = walkConstructorArguments constructorArguments t comments in + match maybeTypExpr with + | None -> () + | Some typexpr -> + let before, inside, after = partitionByLoc rest typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc before; + walkCoreType typexpr t inside; + attach t.trailing typexpr.ptyp_loc after) and walkModuleExpr modExpr t comments = match modExpr.pmod_desc with | Pmod_ident longident -> - let before, after = partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc before; - attach t.trailing longident.loc after + let before, after = partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc before; + attach t.trailing longident.loc after | Pmod_structure [] -> attach t.inside modExpr.pmod_loc comments | Pmod_structure structure -> walkStructure structure t comments | Pmod_extension extension -> walkExtension extension t comments | Pmod_unpack expr -> - let before, inside, after = partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc before; - walkExpression expr t inside; - attach t.trailing expr.pexp_loc after + let before, inside, after = partitionByLoc comments expr.pexp_loc in + attach t.leading expr.pexp_loc before; + walkExpression expr t inside; + attach t.trailing expr.pexp_loc after | Pmod_constraint (modexpr, modtype) -> - if modtype.pmty_loc.loc_start >= modexpr.pmod_loc.loc_end then ( - let before, inside, after = partitionByLoc comments modexpr.pmod_loc in - attach t.leading modexpr.pmod_loc before; - walkModuleExpr modexpr t inside; - let after, rest = partitionAdjacentTrailing modexpr.pmod_loc after in - attach t.trailing modexpr.pmod_loc after; - let before, inside, after = partitionByLoc rest modtype.pmty_loc in - attach t.leading modtype.pmty_loc before; - walkModType modtype t inside; - attach t.trailing modtype.pmty_loc after) - else - let before, inside, after = partitionByLoc comments modtype.pmty_loc in - attach t.leading modtype.pmty_loc before; - walkModType modtype t inside; - let after, rest = partitionAdjacentTrailing modtype.pmty_loc after in - attach t.trailing modtype.pmty_loc after; - let before, inside, after = partitionByLoc rest modexpr.pmod_loc in - attach t.leading modexpr.pmod_loc before; - walkModuleExpr modexpr t inside; - attach t.trailing modexpr.pmod_loc after + if modtype.pmty_loc.loc_start >= modexpr.pmod_loc.loc_end then ( + let before, inside, after = partitionByLoc comments modexpr.pmod_loc in + attach t.leading modexpr.pmod_loc before; + walkModuleExpr modexpr t inside; + let after, rest = partitionAdjacentTrailing modexpr.pmod_loc after in + attach t.trailing modexpr.pmod_loc after; + let before, inside, after = partitionByLoc rest modtype.pmty_loc in + attach t.leading modtype.pmty_loc before; + walkModType modtype t inside; + attach t.trailing modtype.pmty_loc after) + else + let before, inside, after = partitionByLoc comments modtype.pmty_loc in + attach t.leading modtype.pmty_loc before; + walkModType modtype t inside; + let after, rest = partitionAdjacentTrailing modtype.pmty_loc after in + attach t.trailing modtype.pmty_loc after; + let before, inside, after = partitionByLoc rest modexpr.pmod_loc in + attach t.leading modexpr.pmod_loc before; + walkModuleExpr modexpr t inside; + attach t.trailing modexpr.pmod_loc after | Pmod_apply (_callModExpr, _argModExpr) -> - let modExprs = modExprApply modExpr in - walkList (modExprs |> List.map (fun me -> ModuleExpr me)) t comments + let modExprs = modExprApply modExpr in + walkList (modExprs |> List.map (fun me -> ModuleExpr me)) t comments | Pmod_functor _ -> ( - let parameters, returnModExpr = modExprFunctor modExpr in - let comments = - visitListButContinueWithRemainingComments - ~getLoc:(fun (_, lbl, modTypeOption) -> - match modTypeOption with - | None -> lbl.Asttypes.loc - | Some modType -> - {lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end}) - ~walkNode:walkModExprParameter ~newlineDelimited:false parameters t - comments - in - match returnModExpr.pmod_desc with - | Pmod_constraint (modExpr, modType) - when modType.pmty_loc.loc_end.pos_cnum - <= modExpr.pmod_loc.loc_start.pos_cnum -> - let before, inside, after = partitionByLoc comments modType.pmty_loc in - attach t.leading modType.pmty_loc before; - walkModType modType t inside; - let after, rest = partitionAdjacentTrailing modType.pmty_loc after in - attach t.trailing modType.pmty_loc after; - let before, inside, after = partitionByLoc rest modExpr.pmod_loc in - attach t.leading modExpr.pmod_loc before; - walkModuleExpr modExpr t inside; - attach t.trailing modExpr.pmod_loc after - | _ -> - let before, inside, after = - partitionByLoc comments returnModExpr.pmod_loc + let parameters, returnModExpr = modExprFunctor modExpr in + let comments = + visitListButContinueWithRemainingComments + ~getLoc:(fun (_, lbl, modTypeOption) -> + match modTypeOption with + | None -> lbl.Asttypes.loc + | Some modType -> + { lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end }) + ~walkNode:walkModExprParameter ~newlineDelimited:false parameters t + comments in - attach t.leading returnModExpr.pmod_loc before; - walkModuleExpr returnModExpr t inside; - attach t.trailing returnModExpr.pmod_loc after) + match returnModExpr.pmod_desc with + | Pmod_constraint (modExpr, modType) + when modType.pmty_loc.loc_end.pos_cnum + <= modExpr.pmod_loc.loc_start.pos_cnum -> + let before, inside, after = + partitionByLoc comments modType.pmty_loc + in + attach t.leading modType.pmty_loc before; + walkModType modType t inside; + let after, rest = partitionAdjacentTrailing modType.pmty_loc after in + attach t.trailing modType.pmty_loc after; + let before, inside, after = partitionByLoc rest modExpr.pmod_loc in + attach t.leading modExpr.pmod_loc before; + walkModuleExpr modExpr t inside; + attach t.trailing modExpr.pmod_loc after + | _ -> + let before, inside, after = + partitionByLoc comments returnModExpr.pmod_loc + in + attach t.leading returnModExpr.pmod_loc before; + walkModuleExpr returnModExpr t inside; + attach t.trailing returnModExpr.pmod_loc after) and walkModExprParameter parameter t comments = let _attrs, lbl, modTypeOption = parameter in @@ -227733,52 +227784,53 @@ and walkModExprParameter parameter t comments = match modTypeOption with | None -> attach t.trailing lbl.loc trailing | Some modType -> - let afterLbl, rest = partitionAdjacentTrailing lbl.loc trailing in - attach t.trailing lbl.loc afterLbl; - let before, inside, after = partitionByLoc rest modType.pmty_loc in - attach t.leading modType.pmty_loc before; - walkModType modType t inside; - attach t.trailing modType.pmty_loc after + let afterLbl, rest = partitionAdjacentTrailing lbl.loc trailing in + attach t.trailing lbl.loc afterLbl; + let before, inside, after = partitionByLoc rest modType.pmty_loc in + attach t.leading modType.pmty_loc before; + walkModType modType t inside; + attach t.trailing modType.pmty_loc after and walkModType modType t comments = match modType.pmty_desc with | Pmty_ident longident | Pmty_alias longident -> - let leading, trailing = partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc leading; - attach t.trailing longident.loc trailing + let leading, trailing = partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc leading; + attach t.trailing longident.loc trailing | Pmty_signature [] -> attach t.inside modType.pmty_loc comments | Pmty_signature signature -> walkSignature signature t comments | Pmty_extension extension -> walkExtension extension t comments | Pmty_typeof modExpr -> - let before, inside, after = partitionByLoc comments modExpr.pmod_loc in - attach t.leading modExpr.pmod_loc before; - walkModuleExpr modExpr t inside; - attach t.trailing modExpr.pmod_loc after + let before, inside, after = partitionByLoc comments modExpr.pmod_loc in + attach t.leading modExpr.pmod_loc before; + walkModuleExpr modExpr t inside; + attach t.trailing modExpr.pmod_loc after | Pmty_with (modType, _withConstraints) -> - let before, inside, after = partitionByLoc comments modType.pmty_loc in - attach t.leading modType.pmty_loc before; - walkModType modType t inside; - attach t.trailing modType.pmty_loc after - (* TODO: withConstraints*) + let before, inside, after = partitionByLoc comments modType.pmty_loc in + attach t.leading modType.pmty_loc before; + walkModType modType t inside; + attach t.trailing modType.pmty_loc after + (* TODO: withConstraints*) | Pmty_functor _ -> - let parameters, returnModType = functorType modType in - let comments = - visitListButContinueWithRemainingComments - ~getLoc:(fun (_, lbl, modTypeOption) -> - match modTypeOption with - | None -> lbl.Asttypes.loc - | Some modType -> - if lbl.txt = "_" then modType.Parsetree.pmty_loc - else {lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end}) - ~walkNode:walkModTypeParameter ~newlineDelimited:false parameters t - comments - in - let before, inside, after = - partitionByLoc comments returnModType.pmty_loc - in - attach t.leading returnModType.pmty_loc before; - walkModType returnModType t inside; - attach t.trailing returnModType.pmty_loc after + let parameters, returnModType = functorType modType in + let comments = + visitListButContinueWithRemainingComments + ~getLoc:(fun (_, lbl, modTypeOption) -> + match modTypeOption with + | None -> lbl.Asttypes.loc + | Some modType -> + if lbl.txt = "_" then modType.Parsetree.pmty_loc + else + { lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end }) + ~walkNode:walkModTypeParameter ~newlineDelimited:false parameters t + comments + in + let before, inside, after = + partitionByLoc comments returnModType.pmty_loc + in + attach t.leading returnModType.pmty_loc before; + walkModType returnModType t inside; + attach t.trailing returnModType.pmty_loc after and walkModTypeParameter (_, lbl, modTypeOption) t comments = let leading, trailing = partitionLeadingTrailing comments lbl.loc in @@ -227786,92 +227838,94 @@ and walkModTypeParameter (_, lbl, modTypeOption) t comments = match modTypeOption with | None -> attach t.trailing lbl.loc trailing | Some modType -> - let afterLbl, rest = partitionAdjacentTrailing lbl.loc trailing in - attach t.trailing lbl.loc afterLbl; - let before, inside, after = partitionByLoc rest modType.pmty_loc in - attach t.leading modType.pmty_loc before; - walkModType modType t inside; - attach t.trailing modType.pmty_loc after + let afterLbl, rest = partitionAdjacentTrailing lbl.loc trailing in + attach t.trailing lbl.loc afterLbl; + let before, inside, after = partitionByLoc rest modType.pmty_loc in + attach t.leading modType.pmty_loc before; + walkModType modType t inside; + attach t.trailing modType.pmty_loc after and walkPattern pat t comments = let open Location in match pat.Parsetree.ppat_desc with | _ when comments = [] -> () | Ppat_alias (pat, alias) -> - let leading, inside, trailing = partitionByLoc comments pat.ppat_loc in - attach t.leading pat.ppat_loc leading; - walkPattern pat t inside; - let afterPat, rest = partitionAdjacentTrailing pat.ppat_loc trailing in - attach t.leading pat.ppat_loc leading; - attach t.trailing pat.ppat_loc afterPat; - let beforeAlias, afterAlias = partitionLeadingTrailing rest alias.loc in - attach t.leading alias.loc beforeAlias; - attach t.trailing alias.loc afterAlias + let leading, inside, trailing = partitionByLoc comments pat.ppat_loc in + attach t.leading pat.ppat_loc leading; + walkPattern pat t inside; + let afterPat, rest = partitionAdjacentTrailing pat.ppat_loc trailing in + attach t.leading pat.ppat_loc leading; + attach t.trailing pat.ppat_loc afterPat; + let beforeAlias, afterAlias = partitionLeadingTrailing rest alias.loc in + attach t.leading alias.loc beforeAlias; + attach t.trailing alias.loc afterAlias | Ppat_tuple [] | Ppat_array [] - | Ppat_construct ({txt = Longident.Lident "()"}, _) - | Ppat_construct ({txt = Longident.Lident "[]"}, _) -> - attach t.inside pat.ppat_loc comments + | Ppat_construct ({ txt = Longident.Lident "()" }, _) + | Ppat_construct ({ txt = Longident.Lident "[]" }, _) -> + attach t.inside pat.ppat_loc comments | Ppat_array patterns -> - walkList (patterns |> List.map (fun p -> Pattern p)) t comments + walkList (patterns |> List.map (fun p -> Pattern p)) t comments | Ppat_tuple patterns -> - walkList (patterns |> List.map (fun p -> Pattern p)) t comments - | Ppat_construct ({txt = Longident.Lident "::"}, _) -> - walkList - (collectListPatterns [] pat |> List.map (fun p -> Pattern p)) - t comments + walkList (patterns |> List.map (fun p -> Pattern p)) t comments + | Ppat_construct ({ txt = Longident.Lident "::" }, _) -> + walkList + (collectListPatterns [] pat |> List.map (fun p -> Pattern p)) + t comments | Ppat_construct (constr, None) -> - let beforeConstr, afterConstr = - partitionLeadingTrailing comments constr.loc - in - attach t.leading constr.loc beforeConstr; - attach t.trailing constr.loc afterConstr + let beforeConstr, afterConstr = + partitionLeadingTrailing comments constr.loc + in + attach t.leading constr.loc beforeConstr; + attach t.trailing constr.loc afterConstr | Ppat_construct (constr, Some pat) -> - let leading, trailing = partitionLeadingTrailing comments constr.loc in - attach t.leading constr.loc leading; - let afterConstructor, rest = - partitionAdjacentTrailing constr.loc trailing - in - attach t.trailing constr.loc afterConstructor; - let leading, inside, trailing = partitionByLoc rest pat.ppat_loc in - attach t.leading pat.ppat_loc leading; - walkPattern pat t inside; - attach t.trailing pat.ppat_loc trailing + let leading, trailing = partitionLeadingTrailing comments constr.loc in + attach t.leading constr.loc leading; + let afterConstructor, rest = + partitionAdjacentTrailing constr.loc trailing + in + attach t.trailing constr.loc afterConstructor; + let leading, inside, trailing = partitionByLoc rest pat.ppat_loc in + attach t.leading pat.ppat_loc leading; + walkPattern pat t inside; + attach t.trailing pat.ppat_loc trailing | Ppat_variant (_label, None) -> () | Ppat_variant (_label, Some pat) -> walkPattern pat t comments | Ppat_type _ -> () | Ppat_record (recordRows, _) -> - walkList - (recordRows |> List.map (fun (li, p) -> PatternRecordRow (li, p))) - t comments + walkList + (recordRows |> List.map (fun (li, p) -> PatternRecordRow (li, p))) + t comments | Ppat_or _ -> - walkList - (Res_parsetree_viewer.collectOrPatternChain pat - |> List.map (fun pat -> Pattern pat)) - t comments + walkList + (Res_parsetree_viewer.collectOrPatternChain pat + |> List.map (fun pat -> Pattern pat)) + t comments | Ppat_constraint (pattern, typ) -> - let beforePattern, insidePattern, afterPattern = - partitionByLoc comments pattern.ppat_loc - in - attach t.leading pattern.ppat_loc beforePattern; - walkPattern pattern t insidePattern; - let afterPattern, rest = - partitionAdjacentTrailing pattern.ppat_loc afterPattern - in - attach t.trailing pattern.ppat_loc afterPattern; - let beforeTyp, insideTyp, afterTyp = partitionByLoc rest typ.ptyp_loc in - attach t.leading typ.ptyp_loc beforeTyp; - walkCoreType typ t insideTyp; - attach t.trailing typ.ptyp_loc afterTyp + let beforePattern, insidePattern, afterPattern = + partitionByLoc comments pattern.ppat_loc + in + attach t.leading pattern.ppat_loc beforePattern; + walkPattern pattern t insidePattern; + let afterPattern, rest = + partitionAdjacentTrailing pattern.ppat_loc afterPattern + in + attach t.trailing pattern.ppat_loc afterPattern; + let beforeTyp, insideTyp, afterTyp = partitionByLoc rest typ.ptyp_loc in + attach t.leading typ.ptyp_loc beforeTyp; + walkCoreType typ t insideTyp; + attach t.trailing typ.ptyp_loc afterTyp | Ppat_lazy pattern | Ppat_exception pattern -> - let leading, inside, trailing = partitionByLoc comments pattern.ppat_loc in - attach t.leading pattern.ppat_loc leading; - walkPattern pattern t inside; - attach t.trailing pattern.ppat_loc trailing + let leading, inside, trailing = + partitionByLoc comments pattern.ppat_loc + in + attach t.leading pattern.ppat_loc leading; + walkPattern pattern t inside; + attach t.trailing pattern.ppat_loc trailing | Ppat_unpack stringLoc -> - let leading, trailing = partitionLeadingTrailing comments stringLoc.loc in - attach t.leading stringLoc.loc leading; - attach t.trailing stringLoc.loc trailing + let leading, trailing = partitionLeadingTrailing comments stringLoc.loc in + attach t.leading stringLoc.loc leading; + attach t.trailing stringLoc.loc trailing | Ppat_extension extension -> walkExtension extension t comments | _ -> () @@ -227879,83 +227933,87 @@ and walkPattern pat t comments = and walkPatternRecordRow row t comments = match row with (* punned {x}*) - | ( {Location.txt = Longident.Lident ident; loc = longidentLoc}, - {Parsetree.ppat_desc = Ppat_var {txt; _}} ) + | ( { Location.txt = Longident.Lident ident; loc = longidentLoc }, + { Parsetree.ppat_desc = Ppat_var { txt; _ } } ) when ident = txt -> - let beforeLbl, afterLbl = partitionLeadingTrailing comments longidentLoc in - attach t.leading longidentLoc beforeLbl; - attach t.trailing longidentLoc afterLbl + let beforeLbl, afterLbl = + partitionLeadingTrailing comments longidentLoc + in + attach t.leading longidentLoc beforeLbl; + attach t.trailing longidentLoc afterLbl | longident, pattern -> - let beforeLbl, afterLbl = partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc beforeLbl; - let afterLbl, rest = partitionAdjacentTrailing longident.loc afterLbl in - attach t.trailing longident.loc afterLbl; - let leading, inside, trailing = partitionByLoc rest pattern.ppat_loc in - attach t.leading pattern.ppat_loc leading; - walkPattern pattern t inside; - attach t.trailing pattern.ppat_loc trailing + let beforeLbl, afterLbl = + partitionLeadingTrailing comments longident.loc + in + attach t.leading longident.loc beforeLbl; + let afterLbl, rest = partitionAdjacentTrailing longident.loc afterLbl in + attach t.trailing longident.loc afterLbl; + let leading, inside, trailing = partitionByLoc rest pattern.ppat_loc in + attach t.leading pattern.ppat_loc leading; + walkPattern pattern t inside; + attach t.trailing pattern.ppat_loc trailing and walkRowField (rowField : Parsetree.row_field) t comments = match rowField with - | Parsetree.Rtag ({loc}, _, _, _) -> - let before, after = partitionLeadingTrailing comments loc in - attach t.leading loc before; - attach t.trailing loc after + | Parsetree.Rtag ({ loc }, _, _, _) -> + let before, after = partitionLeadingTrailing comments loc in + attach t.leading loc before; + attach t.trailing loc after | Rinherit _ -> () and walkCoreType typ t comments = match typ.Parsetree.ptyp_desc with | _ when comments = [] -> () | Ptyp_tuple typexprs -> - walkList (typexprs |> List.map (fun ct -> CoreType ct)) t comments + walkList (typexprs |> List.map (fun ct -> CoreType ct)) t comments | Ptyp_extension extension -> walkExtension extension t comments | Ptyp_package packageType -> walkPackageType packageType t comments | Ptyp_alias (typexpr, _alias) -> - let beforeTyp, insideTyp, afterTyp = - partitionByLoc comments typexpr.ptyp_loc - in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - attach t.trailing typexpr.ptyp_loc afterTyp + let beforeTyp, insideTyp, afterTyp = + partitionByLoc comments typexpr.ptyp_loc + in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkCoreType typexpr t insideTyp; + attach t.trailing typexpr.ptyp_loc afterTyp | Ptyp_poly (strings, typexpr) -> - let comments = - visitListButContinueWithRemainingComments - ~getLoc:(fun n -> n.Asttypes.loc) - ~walkNode:(fun longident t comments -> - let beforeLongident, afterLongident = - partitionLeadingTrailing comments longident.loc - in - attach t.leading longident.loc beforeLongident; - attach t.trailing longident.loc afterLongident) - ~newlineDelimited:false strings t comments - in - let beforeTyp, insideTyp, afterTyp = - partitionByLoc comments typexpr.ptyp_loc - in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - attach t.trailing typexpr.ptyp_loc afterTyp + let comments = + visitListButContinueWithRemainingComments + ~getLoc:(fun n -> n.Asttypes.loc) + ~walkNode:(fun longident t comments -> + let beforeLongident, afterLongident = + partitionLeadingTrailing comments longident.loc + in + attach t.leading longident.loc beforeLongident; + attach t.trailing longident.loc afterLongident) + ~newlineDelimited:false strings t comments + in + let beforeTyp, insideTyp, afterTyp = + partitionByLoc comments typexpr.ptyp_loc + in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkCoreType typexpr t insideTyp; + attach t.trailing typexpr.ptyp_loc afterTyp | Ptyp_variant (rowFields, _, _) -> - walkList (rowFields |> List.map (fun rf -> RowField rf)) t comments + walkList (rowFields |> List.map (fun rf -> RowField rf)) t comments | Ptyp_constr (longident, typexprs) -> - let beforeLongident, _afterLongident = - partitionLeadingTrailing comments longident.loc - in - let afterLongident, rest = - partitionAdjacentTrailing longident.loc comments - in - attach t.leading longident.loc beforeLongident; - attach t.trailing longident.loc afterLongident; - walkList (typexprs |> List.map (fun ct -> CoreType ct)) t rest + let beforeLongident, _afterLongident = + partitionLeadingTrailing comments longident.loc + in + let afterLongident, rest = + partitionAdjacentTrailing longident.loc comments + in + attach t.leading longident.loc beforeLongident; + attach t.trailing longident.loc afterLongident; + walkList (typexprs |> List.map (fun ct -> CoreType ct)) t rest | Ptyp_arrow _ -> - let _, parameters, typexpr = arrowType typ in - let comments = walkTypeParameters parameters t comments in - let beforeTyp, insideTyp, afterTyp = - partitionByLoc comments typexpr.ptyp_loc - in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - attach t.trailing typexpr.ptyp_loc afterTyp + let _, parameters, typexpr = arrowType typ in + let comments = walkTypeParameters parameters t comments in + let beforeTyp, insideTyp, afterTyp = + partitionByLoc comments typexpr.ptyp_loc + in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkCoreType typexpr t insideTyp; + attach t.trailing typexpr.ptyp_loc afterTyp | Ptyp_object (fields, _) -> walkTypObjectFields fields t comments | _ -> () @@ -227965,22 +228023,24 @@ and walkTypObjectFields fields t comments = and walkObjectField field t comments = match field with | Otag (lbl, _, typexpr) -> - let beforeLbl, afterLbl = partitionLeadingTrailing comments lbl.loc in - attach t.leading lbl.loc beforeLbl; - let afterLbl, rest = partitionAdjacentTrailing lbl.loc afterLbl in - attach t.trailing lbl.loc afterLbl; - let beforeTyp, insideTyp, afterTyp = partitionByLoc rest typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - attach t.trailing typexpr.ptyp_loc afterTyp + let beforeLbl, afterLbl = partitionLeadingTrailing comments lbl.loc in + attach t.leading lbl.loc beforeLbl; + let afterLbl, rest = partitionAdjacentTrailing lbl.loc afterLbl in + attach t.trailing lbl.loc afterLbl; + let beforeTyp, insideTyp, afterTyp = + partitionByLoc rest typexpr.ptyp_loc + in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkCoreType typexpr t insideTyp; + attach t.trailing typexpr.ptyp_loc afterTyp | _ -> () and walkTypeParameters typeParameters t comments = visitListButContinueWithRemainingComments ~getLoc:(fun (_, _, typexpr) -> match typexpr.Parsetree.ptyp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _attrs -> - {loc with loc_end = typexpr.ptyp_loc.loc_end} + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _attrs -> + { loc with loc_end = typexpr.ptyp_loc.loc_end } | _ -> typexpr.ptyp_loc) ~walkNode:walkTypeParameter ~newlineDelimited:false typeParameters t comments @@ -228041,9 +228101,7 @@ and walkAttribute (id, payload) t comments = walkPayload payload t rest and walkPayload payload t comments = - match payload with - | PStr s -> walkStructure s t comments - | _ -> () + match payload with PStr s -> walkStructure s t comments | _ -> () end module Res_parens : sig @@ -228052,172 +228110,166 @@ type kind = Parenthesized | Braced of Location.t | Nothing val expr : Parsetree.expression -> kind val structureExpr : Parsetree.expression -> kind - val unaryExprOperand : Parsetree.expression -> kind - val binaryExprOperand : isLhs:bool -> Parsetree.expression -> kind val subBinaryExprOperand : string -> string -> bool val rhsBinaryExprOperand : string -> Parsetree.expression -> bool val flattenOperandRhs : string -> Parsetree.expression -> bool - val lazyOrAssertOrAwaitExprRhs : Parsetree.expression -> kind - val fieldExpr : Parsetree.expression -> kind - val setFieldExprRhs : Parsetree.expression -> kind - val ternaryOperand : Parsetree.expression -> kind - val jsxPropExpr : Parsetree.expression -> kind val jsxChildExpr : Parsetree.expression -> kind - val binaryExpr : Parsetree.expression -> kind val modTypeFunctorReturn : Parsetree.module_type -> bool val modTypeWithOperand : Parsetree.module_type -> bool val modExprFunctorConstraint : Parsetree.module_type -> bool - val bracedExpr : Parsetree.expression -> bool val callExpr : Parsetree.expression -> kind - val includeModExpr : Parsetree.module_expr -> bool - val arrowReturnTypExpr : Parsetree.core_type -> bool - val patternRecordRowRhs : Parsetree.pattern -> bool end = struct #1 "res_parens.ml" module ParsetreeViewer = Res_parsetree_viewer + type kind = Parenthesized | Braced of Location.t | Nothing let expr expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc | _ -> ( - match expr with - | { - Parsetree.pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_constraint _} -> Parenthesized - | _ -> Nothing) + match expr with + | { + Parsetree.pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + } -> + Nothing + | { pexp_desc = Pexp_constraint _ } -> Parenthesized + | _ -> Nothing) let callExpr expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc | _ -> ( - match expr with - | {Parsetree.pexp_attributes = attrs} - when match ParsetreeViewer.filterParsingAttrs attrs with - | _ :: _ -> true - | [] -> false -> - Parenthesized - | _ - when ParsetreeViewer.isUnaryExpression expr - || ParsetreeViewer.isBinaryExpression expr -> - Parenthesized - | { - Parsetree.pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_fun _} when ParsetreeViewer.isUnderscoreApplySugar expr - -> - Nothing - | { - pexp_desc = - ( Pexp_lazy _ | Pexp_assert _ | Pexp_fun _ | Pexp_newtype _ - | Pexp_function _ | Pexp_constraint _ | Pexp_setfield _ | Pexp_match _ - | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_ifthenelse _ ); - } -> - Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> - Parenthesized - | _ -> Nothing) - + match expr with + | { Parsetree.pexp_attributes = attrs } + when match ParsetreeViewer.filterParsingAttrs attrs with + | _ :: _ -> true + | [] -> false -> + Parenthesized + | _ + when ParsetreeViewer.isUnaryExpression expr + || ParsetreeViewer.isBinaryExpression expr -> + Parenthesized + | { + Parsetree.pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + } -> + Nothing + | { pexp_desc = Pexp_fun _ } + when ParsetreeViewer.isUnderscoreApplySugar expr -> + Nothing + | { + pexp_desc = + ( Pexp_lazy _ | Pexp_assert _ | Pexp_fun _ | Pexp_newtype _ + | Pexp_function _ | Pexp_constraint _ | Pexp_setfield _ | Pexp_match _ + | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_ifthenelse _ ); + } -> + Parenthesized + | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> + Parenthesized + | _ -> Nothing) + let structureExpr expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc | None -> ( - match expr with - | _ - when ParsetreeViewer.hasAttributes expr.pexp_attributes - && not (ParsetreeViewer.isJsxExpression expr) -> - Parenthesized - | { - Parsetree.pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_constraint _} -> Parenthesized - | _ -> Nothing) + match expr with + | _ + when ParsetreeViewer.hasAttributes expr.pexp_attributes + && not (ParsetreeViewer.isJsxExpression expr) -> + Parenthesized + | { + Parsetree.pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + } -> + Nothing + | { pexp_desc = Pexp_constraint _ } -> Parenthesized + | _ -> Nothing) let unaryExprOperand expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc | None -> ( - match expr with - | {Parsetree.pexp_attributes = attrs} - when match ParsetreeViewer.filterParsingAttrs attrs with - | _ :: _ -> true - | [] -> false -> - Parenthesized - | expr - when ParsetreeViewer.isUnaryExpression expr - || ParsetreeViewer.isBinaryExpression expr -> - Parenthesized - | { - pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_fun _} when ParsetreeViewer.isUnderscoreApplySugar expr - -> - Nothing - | { - pexp_desc = - ( Pexp_lazy _ | Pexp_assert _ | Pexp_fun _ | Pexp_newtype _ - | Pexp_function _ | Pexp_constraint _ | Pexp_setfield _ - | Pexp_extension _ (* readability? maybe remove *) | Pexp_match _ - | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_ifthenelse _ ); - } -> - Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> - Parenthesized - | _ -> Nothing) + match expr with + | { Parsetree.pexp_attributes = attrs } + when match ParsetreeViewer.filterParsingAttrs attrs with + | _ :: _ -> true + | [] -> false -> + Parenthesized + | expr + when ParsetreeViewer.isUnaryExpression expr + || ParsetreeViewer.isBinaryExpression expr -> + Parenthesized + | { + pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + } -> + Nothing + | { pexp_desc = Pexp_fun _ } + when ParsetreeViewer.isUnderscoreApplySugar expr -> + Nothing + | { + pexp_desc = + ( Pexp_lazy _ | Pexp_assert _ | Pexp_fun _ | Pexp_newtype _ + | Pexp_function _ | Pexp_constraint _ | Pexp_setfield _ + | Pexp_extension _ (* readability? maybe remove *) | Pexp_match _ + | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_ifthenelse _ ); + } -> + Parenthesized + | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> + Parenthesized + | _ -> Nothing) let binaryExprOperand ~isLhs expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc | None -> ( - match expr with - | { - Parsetree.pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_fun _} when ParsetreeViewer.isUnderscoreApplySugar expr - -> - Nothing - | { - pexp_desc = - Pexp_constraint _ | Pexp_fun _ | Pexp_function _ | Pexp_newtype _; - } -> - Parenthesized - | expr when ParsetreeViewer.isBinaryExpression expr -> Parenthesized - | expr when ParsetreeViewer.isTernaryExpr expr -> Parenthesized - | {pexp_desc = Pexp_lazy _ | Pexp_assert _} when isLhs -> Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> - Parenthesized - | {Parsetree.pexp_attributes = attrs} -> - if ParsetreeViewer.hasPrintableAttributes attrs then Parenthesized - else Nothing) + match expr with + | { + Parsetree.pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + } -> + Nothing + | { pexp_desc = Pexp_fun _ } + when ParsetreeViewer.isUnderscoreApplySugar expr -> + Nothing + | { + pexp_desc = + Pexp_constraint _ | Pexp_fun _ | Pexp_function _ | Pexp_newtype _; + } -> + Parenthesized + | expr when ParsetreeViewer.isBinaryExpression expr -> Parenthesized + | expr when ParsetreeViewer.isTernaryExpr expr -> Parenthesized + | { pexp_desc = Pexp_lazy _ | Pexp_assert _ } when isLhs -> Parenthesized + | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> + Parenthesized + | { Parsetree.pexp_attributes = attrs } -> + if ParsetreeViewer.hasPrintableAttributes attrs then Parenthesized + else Nothing) let subBinaryExprOperand parentOperator childOperator = let precParent = ParsetreeViewer.operatorPrecedence parentOperator in @@ -228234,14 +228286,14 @@ let rhsBinaryExprOperand parentOperator rhs = ( { pexp_attributes = []; pexp_desc = - Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}; + Pexp_ident { txt = Longident.Lident operator; loc = operatorLoc }; }, - [(_, _left); (_, _right)] ) + [ (_, _left); (_, _right) ] ) when ParsetreeViewer.isBinaryOperator operator && not (operatorLoc.loc_ghost && operator = "^") -> - let precParent = ParsetreeViewer.operatorPrecedence parentOperator in - let precChild = ParsetreeViewer.operatorPrecedence operator in - precParent == precChild + let precParent = ParsetreeViewer.operatorPrecedence parentOperator in + let precChild = ParsetreeViewer.operatorPrecedence operator in + precParent == precChild | _ -> false let flattenOperandRhs parentOperator rhs = @@ -228249,16 +228301,17 @@ let flattenOperandRhs parentOperator rhs = | Parsetree.Pexp_apply ( { pexp_desc = - Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}; + Pexp_ident { txt = Longident.Lident operator; loc = operatorLoc }; }, - [(_, _left); (_, _right)] ) + [ (_, _left); (_, _right) ] ) when ParsetreeViewer.isBinaryOperator operator && not (operatorLoc.loc_ghost && operator = "^") -> - let precParent = ParsetreeViewer.operatorPrecedence parentOperator in - let precChild = ParsetreeViewer.operatorPrecedence operator in - precParent >= precChild || rhs.pexp_attributes <> [] - | Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}) -> - false + let precParent = ParsetreeViewer.operatorPrecedence parentOperator in + let precChild = ParsetreeViewer.operatorPrecedence operator in + precParent >= precChild || rhs.pexp_attributes <> [] + | Pexp_constraint ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }) + -> + false | Pexp_fun _ when ParsetreeViewer.isUnderscoreApplySugar rhs -> false | Pexp_fun _ | Pexp_newtype _ | Pexp_setfield _ | Pexp_constraint _ -> true | _ when ParsetreeViewer.isTernaryExpr rhs -> true @@ -228267,33 +228320,34 @@ let flattenOperandRhs parentOperator rhs = let lazyOrAssertOrAwaitExprRhs expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc | None -> ( - match expr with - | {Parsetree.pexp_attributes = attrs} - when match ParsetreeViewer.filterParsingAttrs attrs with - | _ :: _ -> true - | [] -> false -> - Parenthesized - | expr when ParsetreeViewer.isBinaryExpression expr -> Parenthesized - | { - pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_fun _} when ParsetreeViewer.isUnderscoreApplySugar expr - -> - Nothing - | { - pexp_desc = - ( Pexp_lazy _ | Pexp_assert _ | Pexp_fun _ | Pexp_newtype _ - | Pexp_function _ | Pexp_constraint _ | Pexp_setfield _ | Pexp_match _ - | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_ifthenelse _ ); - } -> - Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> - Parenthesized - | _ -> Nothing) + match expr with + | { Parsetree.pexp_attributes = attrs } + when match ParsetreeViewer.filterParsingAttrs attrs with + | _ :: _ -> true + | [] -> false -> + Parenthesized + | expr when ParsetreeViewer.isBinaryExpression expr -> Parenthesized + | { + pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + } -> + Nothing + | { pexp_desc = Pexp_fun _ } + when ParsetreeViewer.isUnderscoreApplySugar expr -> + Nothing + | { + pexp_desc = + ( Pexp_lazy _ | Pexp_assert _ | Pexp_fun _ | Pexp_newtype _ + | Pexp_function _ | Pexp_constraint _ | Pexp_setfield _ | Pexp_match _ + | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_ifthenelse _ ); + } -> + Parenthesized + | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> + Parenthesized + | _ -> Nothing) let isNegativeConstant constant = let isNeg txt = @@ -228307,74 +228361,78 @@ let isNegativeConstant constant = let fieldExpr expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc | None -> ( - match expr with - | {Parsetree.pexp_attributes = attrs} - when match ParsetreeViewer.filterParsingAttrs attrs with - | _ :: _ -> true - | [] -> false -> - Parenthesized - | expr - when ParsetreeViewer.isBinaryExpression expr - || ParsetreeViewer.isUnaryExpression expr -> - Parenthesized - | { - pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_constant c} when isNegativeConstant c -> Parenthesized - | {pexp_desc = Pexp_fun _} when ParsetreeViewer.isUnderscoreApplySugar expr - -> - Nothing - | { - pexp_desc = - ( Pexp_lazy _ | Pexp_assert _ - | Pexp_extension _ (* %extension.x vs (%extension).x *) | Pexp_fun _ - | Pexp_newtype _ | Pexp_function _ | Pexp_constraint _ | Pexp_setfield _ - | Pexp_match _ | Pexp_try _ | Pexp_while _ | Pexp_for _ - | Pexp_ifthenelse _ ); - } -> - Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> - Parenthesized - | _ -> Nothing) + match expr with + | { Parsetree.pexp_attributes = attrs } + when match ParsetreeViewer.filterParsingAttrs attrs with + | _ :: _ -> true + | [] -> false -> + Parenthesized + | expr + when ParsetreeViewer.isBinaryExpression expr + || ParsetreeViewer.isUnaryExpression expr -> + Parenthesized + | { + pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + } -> + Nothing + | { pexp_desc = Pexp_constant c } when isNegativeConstant c -> + Parenthesized + | { pexp_desc = Pexp_fun _ } + when ParsetreeViewer.isUnderscoreApplySugar expr -> + Nothing + | { + pexp_desc = + ( Pexp_lazy _ | Pexp_assert _ + | Pexp_extension _ (* %extension.x vs (%extension).x *) | Pexp_fun _ + | Pexp_newtype _ | Pexp_function _ | Pexp_constraint _ + | Pexp_setfield _ | Pexp_match _ | Pexp_try _ | Pexp_while _ + | Pexp_for _ | Pexp_ifthenelse _ ); + } -> + Parenthesized + | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> + Parenthesized + | _ -> Nothing) let setFieldExprRhs expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc | None -> ( - match expr with - | { - Parsetree.pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_constraint _} -> Parenthesized - | _ -> Nothing) + match expr with + | { + Parsetree.pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + } -> + Nothing + | { pexp_desc = Pexp_constraint _ } -> Parenthesized + | _ -> Nothing) let ternaryOperand expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc | None -> ( - match expr with - | { - Parsetree.pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_constraint _} -> Parenthesized - | {pexp_desc = Pexp_fun _ | Pexp_newtype _} -> ( - let _attrsOnArrow, _parameters, returnExpr = - ParsetreeViewer.funExpr expr - in - match returnExpr.pexp_desc with - | Pexp_constraint _ -> Parenthesized + match expr with + | { + Parsetree.pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + } -> + Nothing + | { pexp_desc = Pexp_constraint _ } -> Parenthesized + | { pexp_desc = Pexp_fun _ | Pexp_newtype _ } -> ( + let _attrsOnArrow, _parameters, returnExpr = + ParsetreeViewer.funExpr expr + in + match returnExpr.pexp_desc with + | Pexp_constraint _ -> Parenthesized + | _ -> Nothing) | _ -> Nothing) - | _ -> Nothing) let startsWithMinus txt = let len = String.length txt in @@ -228387,93 +228445,93 @@ let jsxPropExpr expr = match expr.Parsetree.pexp_desc with | Parsetree.Pexp_let _ | Pexp_sequence _ | Pexp_letexception _ | Pexp_letmodule _ | Pexp_open _ -> - Nothing + Nothing | _ -> ( - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc - | None -> ( - match expr with - | { - Parsetree.pexp_desc = - Pexp_constant (Pconst_integer (x, _) | Pconst_float (x, _)); - pexp_attributes = []; - } - when startsWithMinus x -> - Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> - Parenthesized - | { - Parsetree.pexp_desc = - ( Pexp_ident _ | Pexp_constant _ | Pexp_field _ | Pexp_construct _ - | Pexp_variant _ | Pexp_array _ | Pexp_pack _ | Pexp_record _ - | Pexp_extension _ | Pexp_letmodule _ | Pexp_letexception _ - | Pexp_open _ | Pexp_sequence _ | Pexp_let _ | Pexp_tuple _ ); - pexp_attributes = []; - } -> - Nothing - | { - Parsetree.pexp_desc = - Pexp_constraint - ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - pexp_attributes = []; - } -> - Nothing - | _ -> Parenthesized)) + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc + | None -> ( + match expr with + | { + Parsetree.pexp_desc = + Pexp_constant (Pconst_integer (x, _) | Pconst_float (x, _)); + pexp_attributes = []; + } + when startsWithMinus x -> + Parenthesized + | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> + Parenthesized + | { + Parsetree.pexp_desc = + ( Pexp_ident _ | Pexp_constant _ | Pexp_field _ | Pexp_construct _ + | Pexp_variant _ | Pexp_array _ | Pexp_pack _ | Pexp_record _ + | Pexp_extension _ | Pexp_letmodule _ | Pexp_letexception _ + | Pexp_open _ | Pexp_sequence _ | Pexp_let _ | Pexp_tuple _ ); + pexp_attributes = []; + } -> + Nothing + | { + Parsetree.pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + pexp_attributes = []; + } -> + Nothing + | _ -> Parenthesized)) let jsxChildExpr expr = match expr.Parsetree.pexp_desc with | Parsetree.Pexp_let _ | Pexp_sequence _ | Pexp_letexception _ | Pexp_letmodule _ | Pexp_open _ -> - Nothing + Nothing | _ -> ( - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc - | _ -> ( - match expr with - | { - Parsetree.pexp_desc = - Pexp_constant (Pconst_integer (x, _) | Pconst_float (x, _)); - pexp_attributes = []; - } - when startsWithMinus x -> - Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> - Parenthesized - | { - Parsetree.pexp_desc = - ( Pexp_ident _ | Pexp_constant _ | Pexp_field _ | Pexp_construct _ - | Pexp_variant _ | Pexp_array _ | Pexp_pack _ | Pexp_record _ - | Pexp_extension _ | Pexp_letmodule _ | Pexp_letexception _ - | Pexp_open _ | Pexp_sequence _ | Pexp_let _ ); - pexp_attributes = []; - } -> - Nothing - | { - Parsetree.pexp_desc = - Pexp_constraint - ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - pexp_attributes = []; - } -> - Nothing - | expr when ParsetreeViewer.isJsxExpression expr -> Nothing - | _ -> Parenthesized)) + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc + | _ -> ( + match expr with + | { + Parsetree.pexp_desc = + Pexp_constant (Pconst_integer (x, _) | Pconst_float (x, _)); + pexp_attributes = []; + } + when startsWithMinus x -> + Parenthesized + | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> + Parenthesized + | { + Parsetree.pexp_desc = + ( Pexp_ident _ | Pexp_constant _ | Pexp_field _ | Pexp_construct _ + | Pexp_variant _ | Pexp_array _ | Pexp_pack _ | Pexp_record _ + | Pexp_extension _ | Pexp_letmodule _ | Pexp_letexception _ + | Pexp_open _ | Pexp_sequence _ | Pexp_let _ ); + pexp_attributes = []; + } -> + Nothing + | { + Parsetree.pexp_desc = + Pexp_constraint + ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }); + pexp_attributes = []; + } -> + Nothing + | expr when ParsetreeViewer.isJsxExpression expr -> Nothing + | _ -> Parenthesized)) let binaryExpr expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + | Some ({ Location.loc = bracesLoc }, _) -> Braced bracesLoc | None -> ( - match expr with - | {Parsetree.pexp_attributes = _ :: _} as expr - when ParsetreeViewer.isBinaryExpression expr -> - Parenthesized - | _ -> Nothing) + match expr with + | { Parsetree.pexp_attributes = _ :: _ } as expr + when ParsetreeViewer.isBinaryExpression expr -> + Parenthesized + | _ -> Nothing) let modTypeFunctorReturn modType = match modType with - | {Parsetree.pmty_desc = Pmty_with _} -> true + | { Parsetree.pmty_desc = Pmty_with _ } -> true | _ -> false (* Add parens for readability: @@ -228483,18 +228541,19 @@ let modTypeFunctorReturn modType = *) let modTypeWithOperand modType = match modType with - | {Parsetree.pmty_desc = Pmty_functor _ | Pmty_with _} -> true + | { Parsetree.pmty_desc = Pmty_functor _ | Pmty_with _ } -> true | _ -> false let modExprFunctorConstraint modType = match modType with - | {Parsetree.pmty_desc = Pmty_functor _ | Pmty_with _} -> true + | { Parsetree.pmty_desc = Pmty_functor _ | Pmty_with _ } -> true | _ -> false let bracedExpr expr = match expr.Parsetree.pexp_desc with - | Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}) -> - false + | Pexp_constraint ({ pexp_desc = Pexp_pack _ }, { ptyp_desc = Ptyp_package _ }) + -> + false | Pexp_constraint _ -> true | _ -> false @@ -228510,9 +228569,9 @@ let arrowReturnTypExpr typExpr = let patternRecordRowRhs (pattern : Parsetree.pattern) = match pattern.ppat_desc with - | Ppat_constraint ({ppat_desc = Ppat_unpack _}, {ptyp_desc = Ptyp_package _}) - -> - false + | Ppat_constraint + ({ ppat_desc = Ppat_unpack _ }, { ptyp_desc = Ptyp_package _ }) -> + false | Ppat_constraint _ -> true | _ -> false @@ -228527,9 +228586,9 @@ type t = | Open | True | False - | Codepoint of {c: int; original: string} - | Int of {i: string; suffix: char option} - | Float of {f: string; suffix: char option} + | Codepoint of { c : int; original : string } + | Int of { i : string; suffix : char option } + | Float of { f : string; suffix : char option } | String of string | Lident of string | Uident of string @@ -228625,7 +228684,7 @@ let precedence = function | Land -> 3 | Equal | EqualEqual | EqualEqualEqual | LessThan | GreaterThan | BangEqual | BangEqualEqual | LessEqual | GreaterEqual | BarGreater -> - 4 + 4 | Plus | PlusDot | Minus | MinusDot | PlusPlus -> 5 | Asterisk | AsteriskDot | Forwardslash | ForwardslashDot -> 6 | Exponentiation -> 7 @@ -228638,15 +228697,15 @@ let toString = function | Open -> "open" | True -> "true" | False -> "false" - | Codepoint {original} -> "codepoint '" ^ original ^ "'" + | Codepoint { original } -> "codepoint '" ^ original ^ "'" | String s -> "string \"" ^ s ^ "\"" | Lident str -> str | Uident str -> str | Dot -> "." | DotDot -> ".." | DotDotDot -> "..." - | Int {i} -> "int " ^ i - | Float {f} -> "Float: " ^ f + | Int { i } -> "int " ^ i + | Float { f } -> "Float: " ^ f | Bang -> "!" | Semicolon -> ";" | Let -> "let" @@ -228766,7 +228825,7 @@ let isKeyword = function | Await | And | As | Assert | Constraint | Else | Exception | External | False | For | If | In | Include | Land | Lazy | Let | List | Lor | Module | Mutable | Of | Open | Private | Rec | Switch | True | Try | Typ | When | While -> - true + true | _ -> false let lookupKeyword str = @@ -228788,13 +228847,9 @@ end module Res_utf8 : sig #1 "res_utf8.mli" val repl : int - val max : int - val decodeCodePoint : int -> string -> int -> int * int - val encodeCodePoint : int -> string - val isValidCodePoint : int -> bool end = struct @@ -228806,7 +228861,6 @@ let repl = 0xFFFD (* let min = 0x0000 *) let max = 0x10FFFF - let surrogateMin = 0xD800 let surrogateMax = 0xDFFF @@ -228822,10 +228876,9 @@ let surrogateMax = 0xDFFF let h2 = 0b1100_0000 let h3 = 0b1110_0000 let h4 = 0b1111_0000 - let cont_mask = 0b0011_1111 -type category = {low: int; high: int; size: int} +type category = { low : int; high : int; size : int } let locb = 0b1000_0000 let hicb = 0b1011_1111 @@ -228955,11 +229008,8 @@ val printTypeParams : Res_doc.t val printLongident : Longident.t -> Res_doc.t - val printTypExpr : Parsetree.core_type -> Res_comments_table.t -> Res_doc.t - val addParens : Res_doc.t -> Res_doc.t - val printExpression : Parsetree.expression -> Res_comments_table.t -> Res_doc.t val printPattern : Parsetree.pattern -> Res_comments_table.t -> Res_doc.t @@ -228970,6 +229020,7 @@ val printStructure : Parsetree.structure -> Res_comments_table.t -> Res_doc.t val printImplementation : width:int -> Parsetree.structure -> comments:Res_comment.t list -> string + val printInterface : width:int -> Parsetree.signature -> comments:Res_comment.t list -> string @@ -229041,7 +229092,7 @@ let addParens doc = (Doc.concat [ Doc.lparen; - Doc.indent (Doc.concat [Doc.softLine; doc]); + Doc.indent (Doc.concat [ Doc.softLine; doc ]); Doc.softLine; Doc.rparen; ]) @@ -229051,12 +229102,12 @@ let addBraces doc = (Doc.concat [ Doc.lbrace; - Doc.indent (Doc.concat [Doc.softLine; doc]); + Doc.indent (Doc.concat [ Doc.softLine; doc ]); Doc.softLine; Doc.rbrace; ]) -let addAsync doc = Doc.concat [Doc.text "async "; doc] +let addAsync doc = Doc.concat [ Doc.text "async "; doc ] let getFirstLeadingComment tbl loc = match Hashtbl.find tbl.CommentTable.leading loc with @@ -229073,8 +229124,8 @@ let hasLeadingLineComment tbl loc = let hasCommentBelow tbl loc = match Hashtbl.find tbl.CommentTable.trailing loc with | comment :: _ -> - let commentLoc = Comment.loc comment in - commentLoc.Location.loc_start.pos_lnum > loc.Location.loc_end.pos_lnum + let commentLoc = Comment.loc comment in + commentLoc.Location.loc_start.pos_lnum > loc.Location.loc_end.pos_lnum | [] -> false | exception Not_found -> false @@ -229082,10 +229133,10 @@ let hasNestedJsxOrMoreThanOneChild expr = let rec loop inRecursion expr = match expr.Parsetree.pexp_desc with | Pexp_construct - ({txt = Longident.Lident "::"}, Some {pexp_desc = Pexp_tuple [hd; tail]}) - -> - if inRecursion || ParsetreeViewer.isJsxExpression hd then true - else loop true tail + ( { txt = Longident.Lident "::" }, + Some { pexp_desc = Pexp_tuple [ hd; tail ] } ) -> + if inRecursion || ParsetreeViewer.isJsxExpression hd then true + else loop true tail | _ -> false in loop false expr @@ -229116,42 +229167,40 @@ let printMultilineCommentContent txt = let rec indentStars lines acc = match lines with | [] -> Doc.nil - | [lastLine] -> - let line = String.trim lastLine in - let doc = Doc.text (" " ^ line) in - let trailingSpace = if line = "" then Doc.nil else Doc.space in - List.rev (trailingSpace :: doc :: acc) |> Doc.concat - | line :: lines -> - let line = String.trim line in - if line != "" && String.unsafe_get line 0 == '*' then + | [ lastLine ] -> + let line = String.trim lastLine in let doc = Doc.text (" " ^ line) in - indentStars lines (Doc.hardLine :: doc :: acc) - else - let trailingSpace = - let len = String.length txt in - if len > 0 && String.unsafe_get txt (len - 1) = ' ' then Doc.space - else Doc.nil - in - let content = Comment.trimSpaces txt in - Doc.concat [Doc.text content; trailingSpace] + let trailingSpace = if line = "" then Doc.nil else Doc.space in + List.rev (trailingSpace :: doc :: acc) |> Doc.concat + | line :: lines -> + let line = String.trim line in + if line != "" && String.unsafe_get line 0 == '*' then + let doc = Doc.text (" " ^ line) in + indentStars lines (Doc.hardLine :: doc :: acc) + else + let trailingSpace = + let len = String.length txt in + if len > 0 && String.unsafe_get txt (len - 1) = ' ' then Doc.space + else Doc.nil + in + let content = Comment.trimSpaces txt in + Doc.concat [ Doc.text content; trailingSpace ] in let lines = String.split_on_char '\n' txt in match lines with | [] -> Doc.text "/* */" - | [line] -> - Doc.concat - [Doc.text "/* "; Doc.text (Comment.trimSpaces line); Doc.text " */"] + | [ line ] -> + Doc.concat + [ Doc.text "/* "; Doc.text (Comment.trimSpaces line); Doc.text " */" ] | first :: rest -> - let firstLine = Comment.trimSpaces first in - Doc.concat - [ - Doc.text "/*"; - (match firstLine with - | "" | "*" -> Doc.nil - | _ -> Doc.space); - indentStars rest [Doc.hardLine; Doc.text firstLine]; - Doc.text "*/"; - ] + let firstLine = Comment.trimSpaces first in + Doc.concat + [ + Doc.text "/*"; + (match firstLine with "" | "*" -> Doc.nil | _ -> Doc.space); + indentStars rest [ Doc.hardLine; Doc.text firstLine ]; + Doc.text "*/"; + ] let printTrailingComment (prevLoc : Location.t) (nodeLoc : Location.t) comment = let singleLine = Comment.isSingleLineComment comment in @@ -229179,8 +229228,8 @@ let printTrailingComment (prevLoc : Location.t) (nodeLoc : Location.t) comment = content; ]); ] - else if not singleLine then Doc.concat [Doc.space; content] - else Doc.lineSuffix (Doc.concat [Doc.space; content]) + else if not singleLine then Doc.concat [ Doc.space; content ] + else Doc.lineSuffix (Doc.concat [ Doc.space; content ]) let printLeadingComment ?nextComment comment = let singleLine = Comment.isSingleLineComment comment in @@ -229192,28 +229241,28 @@ let printLeadingComment ?nextComment comment = let separator = Doc.concat [ - (if singleLine then Doc.concat [Doc.hardLine; Doc.breakParent] + (if singleLine then Doc.concat [ Doc.hardLine; Doc.breakParent ] else Doc.nil); (match nextComment with | Some next -> - let nextLoc = Comment.loc next in - let currLoc = Comment.loc comment in - let diff = - nextLoc.Location.loc_start.pos_lnum - - currLoc.Location.loc_end.pos_lnum - in - let nextSingleLine = Comment.isSingleLineComment next in - if singleLine && nextSingleLine then - if diff > 1 then Doc.hardLine else Doc.nil - else if singleLine && not nextSingleLine then - if diff > 1 then Doc.hardLine else Doc.nil - else if diff > 1 then Doc.concat [Doc.hardLine; Doc.hardLine] - else if diff == 1 then Doc.hardLine - else Doc.space + let nextLoc = Comment.loc next in + let currLoc = Comment.loc comment in + let diff = + nextLoc.Location.loc_start.pos_lnum + - currLoc.Location.loc_end.pos_lnum + in + let nextSingleLine = Comment.isSingleLineComment next in + if singleLine && nextSingleLine then + if diff > 1 then Doc.hardLine else Doc.nil + else if singleLine && not nextSingleLine then + if diff > 1 then Doc.hardLine else Doc.nil + else if diff > 1 then Doc.concat [ Doc.hardLine; Doc.hardLine ] + else if diff == 1 then Doc.hardLine + else Doc.space | None -> Doc.nil); ] in - Doc.concat [content; separator] + Doc.concat [ content; separator ] (* This function is used for printing comments inside an empty block *) let printCommentsInside cmtTbl loc = @@ -229229,96 +229278,98 @@ let printCommentsInside cmtTbl loc = let rec loop acc comments = match comments with | [] -> Doc.nil - | [comment] -> - let cmtDoc = printComment comment in - let cmtsDoc = Doc.concat (Doc.softLine :: List.rev (cmtDoc :: acc)) in - let doc = - Doc.breakableGroup ~forceBreak - (Doc.concat [Doc.ifBreaks (Doc.indent cmtsDoc) cmtsDoc; Doc.softLine]) - in - doc + | [ comment ] -> + let cmtDoc = printComment comment in + let cmtsDoc = Doc.concat (Doc.softLine :: List.rev (cmtDoc :: acc)) in + let doc = + Doc.breakableGroup ~forceBreak + (Doc.concat + [ Doc.ifBreaks (Doc.indent cmtsDoc) cmtsDoc; Doc.softLine ]) + in + doc | comment :: rest -> - let cmtDoc = Doc.concat [printComment comment; Doc.line] in - loop (cmtDoc :: acc) rest + let cmtDoc = Doc.concat [ printComment comment; Doc.line ] in + loop (cmtDoc :: acc) rest in match Hashtbl.find cmtTbl.CommentTable.inside loc with | exception Not_found -> Doc.nil | comments -> - Hashtbl.remove cmtTbl.inside loc; - loop [] comments + Hashtbl.remove cmtTbl.inside loc; + loop [] comments (* This function is used for printing comments inside an empty file *) let printCommentsInsideFile cmtTbl = let rec loop acc comments = match comments with | [] -> Doc.nil - | [comment] -> - let cmtDoc = printLeadingComment comment in - let doc = - Doc.group (Doc.concat [Doc.concat (List.rev (cmtDoc :: acc))]) - in - doc + | [ comment ] -> + let cmtDoc = printLeadingComment comment in + let doc = + Doc.group (Doc.concat [ Doc.concat (List.rev (cmtDoc :: acc)) ]) + in + doc | comment :: (nextComment :: _comments as rest) -> - let cmtDoc = printLeadingComment ~nextComment comment in - loop (cmtDoc :: acc) rest + let cmtDoc = printLeadingComment ~nextComment comment in + loop (cmtDoc :: acc) rest in match Hashtbl.find cmtTbl.CommentTable.inside Location.none with | exception Not_found -> Doc.nil | comments -> - Hashtbl.remove cmtTbl.inside Location.none; - Doc.group (loop [] comments) + Hashtbl.remove cmtTbl.inside Location.none; + Doc.group (loop [] comments) let printLeadingComments node tbl loc = let rec loop acc comments = match comments with | [] -> node - | [comment] -> - let cmtDoc = printLeadingComment comment in - let diff = - loc.Location.loc_start.pos_lnum - - (Comment.loc comment).Location.loc_end.pos_lnum - in - let separator = - if Comment.isSingleLineComment comment then - if diff > 1 then Doc.hardLine else Doc.nil - else if diff == 0 then Doc.space - else if diff > 1 then Doc.concat [Doc.hardLine; Doc.hardLine] - else Doc.hardLine - in - let doc = - Doc.group - (Doc.concat [Doc.concat (List.rev (cmtDoc :: acc)); separator; node]) - in - doc + | [ comment ] -> + let cmtDoc = printLeadingComment comment in + let diff = + loc.Location.loc_start.pos_lnum + - (Comment.loc comment).Location.loc_end.pos_lnum + in + let separator = + if Comment.isSingleLineComment comment then + if diff > 1 then Doc.hardLine else Doc.nil + else if diff == 0 then Doc.space + else if diff > 1 then Doc.concat [ Doc.hardLine; Doc.hardLine ] + else Doc.hardLine + in + let doc = + Doc.group + (Doc.concat + [ Doc.concat (List.rev (cmtDoc :: acc)); separator; node ]) + in + doc | comment :: (nextComment :: _comments as rest) -> - let cmtDoc = printLeadingComment ~nextComment comment in - loop (cmtDoc :: acc) rest + let cmtDoc = printLeadingComment ~nextComment comment in + loop (cmtDoc :: acc) rest in match Hashtbl.find tbl loc with | exception Not_found -> node | comments -> - (* Remove comments from tbl: Some ast nodes have the same location. - * We only want to print comments once *) - Hashtbl.remove tbl loc; - loop [] comments + (* Remove comments from tbl: Some ast nodes have the same location. + * We only want to print comments once *) + Hashtbl.remove tbl loc; + loop [] comments let printTrailingComments node tbl loc = let rec loop prev acc comments = match comments with | [] -> Doc.concat (List.rev acc) | comment :: comments -> - let cmtDoc = printTrailingComment prev loc comment in - loop (Comment.loc comment) (cmtDoc :: acc) comments + let cmtDoc = printTrailingComment prev loc comment in + loop (Comment.loc comment) (cmtDoc :: acc) comments in match Hashtbl.find tbl loc with | exception Not_found -> node | [] -> node | _first :: _ as comments -> - (* Remove comments from tbl: Some ast nodes have the same location. - * We only want to print comments once *) - Hashtbl.remove tbl loc; - let cmtsDoc = loop loc [] comments in - Doc.concat [node; cmtsDoc] + (* Remove comments from tbl: Some ast nodes have the same location. + * We only want to print comments once *) + Hashtbl.remove tbl loc; + let cmtsDoc = loop loc [] comments in + Doc.concat [ node; cmtsDoc ] let printComments doc (tbl : CommentTable.t) loc = let docWithLeadingComments = printLeadingComments doc tbl.leading loc in @@ -229329,68 +229380,68 @@ let printList ~getLoc ~nodes ~print ?(forceBreak = false) t = match nodes with | [] -> (prevLoc, Doc.concat (List.rev acc)) | node :: nodes -> - let loc = getLoc node in - let startPos = - match getFirstLeadingComment t loc with - | None -> loc.loc_start - | Some comment -> (Comment.loc comment).loc_start - in - let sep = - if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then - Doc.concat [Doc.hardLine; Doc.hardLine] - else Doc.hardLine - in - let doc = printComments (print node t) t loc in - loop loc (doc :: sep :: acc) nodes + let loc = getLoc node in + let startPos = + match getFirstLeadingComment t loc with + | None -> loc.loc_start + | Some comment -> (Comment.loc comment).loc_start + in + let sep = + if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then + Doc.concat [ Doc.hardLine; Doc.hardLine ] + else Doc.hardLine + in + let doc = printComments (print node t) t loc in + loop loc (doc :: sep :: acc) nodes in match nodes with | [] -> Doc.nil | node :: nodes -> - let firstLoc = getLoc node in - let doc = printComments (print node t) t firstLoc in - let lastLoc, docs = loop firstLoc [doc] nodes in - let forceBreak = - forceBreak || firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak docs + let firstLoc = getLoc node in + let doc = printComments (print node t) t firstLoc in + let lastLoc, docs = loop firstLoc [ doc ] nodes in + let forceBreak = + forceBreak || firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak docs let printListi ~getLoc ~nodes ~print ?(forceBreak = false) t = let rec loop i (prevLoc : Location.t) acc nodes = match nodes with | [] -> (prevLoc, Doc.concat (List.rev acc)) | node :: nodes -> - let loc = getLoc node in - let startPos = - match getFirstLeadingComment t loc with - | None -> loc.loc_start - | Some comment -> (Comment.loc comment).loc_start - in - let sep = - if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then - Doc.concat [Doc.hardLine; Doc.hardLine] - else Doc.line - in - let doc = printComments (print node t i) t loc in - loop (i + 1) loc (doc :: sep :: acc) nodes + let loc = getLoc node in + let startPos = + match getFirstLeadingComment t loc with + | None -> loc.loc_start + | Some comment -> (Comment.loc comment).loc_start + in + let sep = + if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then + Doc.concat [ Doc.hardLine; Doc.hardLine ] + else Doc.line + in + let doc = printComments (print node t i) t loc in + loop (i + 1) loc (doc :: sep :: acc) nodes in match nodes with | [] -> Doc.nil | node :: nodes -> - let firstLoc = getLoc node in - let doc = printComments (print node t 0) t firstLoc in - let lastLoc, docs = loop 1 firstLoc [doc] nodes in - let forceBreak = - forceBreak || firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak docs + let firstLoc = getLoc node in + let doc = printComments (print node t 0) t firstLoc in + let lastLoc, docs = loop 1 firstLoc [ doc ] nodes in + let forceBreak = + forceBreak || firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak docs let rec printLongidentAux accu = function | Longident.Lident s -> Doc.text s :: accu | Ldot (lid, s) -> printLongidentAux (Doc.text s :: accu) lid | Lapply (lid1, lid2) -> - let d1 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid1) in - let d2 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid2) in - Doc.concat [d1; Doc.lparen; d2; Doc.rparen] :: accu + let d1 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid1) in + let d2 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid2) in + Doc.concat [ d1; Doc.lparen; d2; Doc.rparen ] :: accu let printLongident = function | Longident.Lident txt -> Doc.text txt @@ -229418,7 +229469,7 @@ let classifyIdentContent ?(allowUident = false) txt = let printIdentLike ?allowUident txt = match classifyIdentContent ?allowUident txt with - | ExoticIdent -> Doc.concat [Doc.text "\\\""; Doc.text txt; Doc.text "\""] + | ExoticIdent -> Doc.concat [ Doc.text "\\\""; Doc.text txt; Doc.text "\"" ] | NormalIdent -> Doc.text txt let rec unsafe_for_all_range s ~start ~finish p = @@ -229439,10 +229490,7 @@ let isValidNumericPolyvarNumber (x : string) = a <= 57 && if len > 1 then - a > 48 - && for_all_from x 1 (function - | '0' .. '9' -> true - | _ -> false) + a > 48 && for_all_from x 1 (function '0' .. '9' -> true | _ -> false) else a >= 48 (* Exotic identifiers in poly-vars have a "lighter" syntax: #"ease-in" *) @@ -229451,11 +229499,11 @@ let printPolyVarIdent txt = if isValidNumericPolyvarNumber txt then Doc.text txt else match classifyIdentContent ~allowUident:true txt with - | ExoticIdent -> Doc.concat [Doc.text "\""; Doc.text txt; Doc.text "\""] + | ExoticIdent -> Doc.concat [ Doc.text "\""; Doc.text txt; Doc.text "\"" ] | NormalIdent -> ( - match txt with - | "" -> Doc.concat [Doc.text "\""; Doc.text txt; Doc.text "\""] - | _ -> Doc.text txt) + match txt with + | "" -> Doc.concat [ Doc.text "\""; Doc.text txt; Doc.text "\"" ] + | _ -> Doc.text txt) let printLident l = let flatLidOpt lid = @@ -229469,18 +229517,18 @@ let printLident l = match l with | Longident.Lident txt -> printIdentLike txt | Longident.Ldot (path, txt) -> - let doc = - match flatLidOpt path with - | Some txts -> - Doc.concat - [ - Doc.join ~sep:Doc.dot (List.map Doc.text txts); - Doc.dot; - printIdentLike txt; - ] - | None -> Doc.text "printLident: Longident.Lapply is not supported" - in - doc + let doc = + match flatLidOpt path with + | Some txts -> + Doc.concat + [ + Doc.join ~sep:Doc.dot (List.map Doc.text txts); + Doc.dot; + printIdentLike txt; + ] + | None -> Doc.text "printLident: Longident.Lapply is not supported" + in + doc | Lapply (_, _) -> Doc.text "printLident: Longident.Lapply is not supported" let printLongidentLocation l cmtTbl = @@ -229508,42 +229556,42 @@ let printStringContents txt = let printConstant ?(templateLiteral = false) c = match c with | Parsetree.Pconst_integer (s, suffix) -> ( - match suffix with - | Some c -> Doc.text (s ^ Char.escaped c) - | None -> Doc.text s) + match suffix with + | Some c -> Doc.text (s ^ Char.escaped c) + | None -> Doc.text s) | Pconst_string (txt, None) -> - Doc.concat [Doc.text "\""; printStringContents txt; Doc.text "\""] + Doc.concat [ Doc.text "\""; printStringContents txt; Doc.text "\"" ] | Pconst_string (txt, Some prefix) -> - if prefix = "INTERNAL_RES_CHAR_CONTENTS" then - Doc.concat [Doc.text "'"; Doc.text txt; Doc.text "'"] - else - let lquote, rquote = - if templateLiteral then ("`", "`") else ("\"", "\"") - in - Doc.concat - [ - (if prefix = "js" then Doc.nil else Doc.text prefix); - Doc.text lquote; - printStringContents txt; - Doc.text rquote; - ] + if prefix = "INTERNAL_RES_CHAR_CONTENTS" then + Doc.concat [ Doc.text "'"; Doc.text txt; Doc.text "'" ] + else + let lquote, rquote = + if templateLiteral then ("`", "`") else ("\"", "\"") + in + Doc.concat + [ + (if prefix = "js" then Doc.nil else Doc.text prefix); + Doc.text lquote; + printStringContents txt; + Doc.text rquote; + ] | Pconst_float (s, _) -> Doc.text s | Pconst_char c -> - let str = - match Char.unsafe_chr c with - | '\'' -> "\\'" - | '\\' -> "\\\\" - | '\n' -> "\\n" - | '\t' -> "\\t" - | '\r' -> "\\r" - | '\b' -> "\\b" - | ' ' .. '~' as c -> - let s = (Bytes.create [@doesNotRaise]) 1 in - Bytes.unsafe_set s 0 c; - Bytes.unsafe_to_string s - | _ -> Res_utf8.encodeCodePoint c - in - Doc.text ("'" ^ str ^ "'") + let str = + match Char.unsafe_chr c with + | '\'' -> "\\'" + | '\\' -> "\\\\" + | '\n' -> "\\n" + | '\t' -> "\\t" + | '\r' -> "\\r" + | '\b' -> "\\b" + | ' ' .. '~' as c -> + let s = (Bytes.create [@doesNotRaise]) 1 in + Bytes.unsafe_set s 0 c; + Bytes.unsafe_to_string s + | _ -> Res_utf8.encodeCodePoint c + in + Doc.text ("'" ^ str ^ "'") let printOptionalLabel attrs = if Res_parsetree_viewer.hasOptionalAttribute attrs then Doc.text "?" @@ -229555,66 +229603,66 @@ let rec printStructure ~customLayout (s : Parsetree.structure) t = match s with | [] -> printCommentsInsideFile t | structure -> - printList - ~getLoc:(fun s -> s.Parsetree.pstr_loc) - ~nodes:structure - ~print:(printStructureItem ~customLayout) - t + printList + ~getLoc:(fun s -> s.Parsetree.pstr_loc) + ~nodes:structure + ~print:(printStructureItem ~customLayout) + t and printStructureItem ~customLayout (si : Parsetree.structure_item) cmtTbl = match si.pstr_desc with | Pstr_value (rec_flag, valueBindings) -> - let recFlag = - match rec_flag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - printValueBindings ~customLayout ~recFlag valueBindings cmtTbl + let recFlag = + match rec_flag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + printValueBindings ~customLayout ~recFlag valueBindings cmtTbl | Pstr_type (recFlag, typeDeclarations) -> - let recFlag = - match recFlag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - printTypeDeclarations ~customLayout ~recFlag typeDeclarations cmtTbl + let recFlag = + match recFlag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + printTypeDeclarations ~customLayout ~recFlag typeDeclarations cmtTbl | Pstr_primitive valueDescription -> - printValueDescription ~customLayout valueDescription cmtTbl + printValueDescription ~customLayout valueDescription cmtTbl | Pstr_eval (expr, attrs) -> - let exprDoc = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.structureExpr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat [printAttributes ~customLayout attrs cmtTbl; exprDoc] + let exprDoc = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.structureExpr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [ printAttributes ~customLayout attrs cmtTbl; exprDoc ] | Pstr_attribute attr -> - fst (printAttribute ~customLayout ~standalone:true attr cmtTbl) + fst (printAttribute ~customLayout ~standalone:true attr cmtTbl) | Pstr_extension (extension, attrs) -> - Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - Doc.concat - [printExtension ~customLayout ~atModuleLvl:true extension cmtTbl]; - ] + Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + Doc.concat + [ printExtension ~customLayout ~atModuleLvl:true extension cmtTbl ]; + ] | Pstr_include includeDeclaration -> - printIncludeDeclaration ~customLayout includeDeclaration cmtTbl + printIncludeDeclaration ~customLayout includeDeclaration cmtTbl | Pstr_open openDescription -> - printOpenDescription ~customLayout openDescription cmtTbl + printOpenDescription ~customLayout openDescription cmtTbl | Pstr_modtype modTypeDecl -> - printModuleTypeDeclaration ~customLayout modTypeDecl cmtTbl + printModuleTypeDeclaration ~customLayout modTypeDecl cmtTbl | Pstr_module moduleBinding -> - printModuleBinding ~customLayout ~isRec:false moduleBinding cmtTbl 0 + printModuleBinding ~customLayout ~isRec:false moduleBinding cmtTbl 0 | Pstr_recmodule moduleBindings -> - printListi - ~getLoc:(fun mb -> mb.Parsetree.pmb_loc) - ~nodes:moduleBindings - ~print:(printModuleBinding ~customLayout ~isRec:true) - cmtTbl + printListi + ~getLoc:(fun mb -> mb.Parsetree.pmb_loc) + ~nodes:moduleBindings + ~print:(printModuleBinding ~customLayout ~isRec:true) + cmtTbl | Pstr_exception extensionConstructor -> - printExceptionDef ~customLayout extensionConstructor cmtTbl + printExceptionDef ~customLayout extensionConstructor cmtTbl | Pstr_typext typeExtension -> - printTypeExtension ~customLayout typeExtension cmtTbl + printTypeExtension ~customLayout typeExtension cmtTbl | Pstr_class _ | Pstr_class_type _ -> Doc.nil and printTypeExtension ~customLayout (te : Parsetree.type_extension) cmtTbl = @@ -229626,13 +229674,14 @@ and printTypeExtension ~customLayout (te : Parsetree.type_extension) cmtTbl = let forceBreak = match (ecs, List.rev ecs) with | first :: _, last :: _ -> - first.pext_loc.loc_start.pos_lnum > te.ptyext_path.loc.loc_end.pos_lnum - || first.pext_loc.loc_start.pos_lnum < last.pext_loc.loc_end.pos_lnum + first.pext_loc.loc_start.pos_lnum + > te.ptyext_path.loc.loc_end.pos_lnum + || first.pext_loc.loc_start.pos_lnum < last.pext_loc.loc_end.pos_lnum | _ -> false in let privateFlag = match te.ptyext_private with - | Asttypes.Private -> Doc.concat [Doc.text "private"; Doc.line] + | Asttypes.Private -> Doc.concat [ Doc.text "private"; Doc.line ] | Public -> Doc.nil in let rows = @@ -229669,14 +229718,15 @@ and printModuleBinding ~customLayout ~isRec moduleBinding cmtTbl i = let prefix = if i = 0 then Doc.concat - [Doc.text "module "; (if isRec then Doc.text "rec " else Doc.nil)] + [ Doc.text "module "; (if isRec then Doc.text "rec " else Doc.nil) ] else Doc.text "and " in let modExprDoc, modConstraintDoc = match moduleBinding.pmb_expr with - | {pmod_desc = Pmod_constraint (modExpr, modType)} -> - ( printModExpr ~customLayout modExpr cmtTbl, - Doc.concat [Doc.text ": "; printModType ~customLayout modType cmtTbl] ) + | { pmod_desc = Pmod_constraint (modExpr, modType) } -> + ( printModExpr ~customLayout modExpr cmtTbl, + Doc.concat + [ Doc.text ": "; printModType ~customLayout modType cmtTbl ] ) | modExpr -> (printModExpr ~customLayout modExpr cmtTbl, Doc.nil) in let modName = @@ -229711,153 +229761,160 @@ and printModuleTypeDeclaration ~customLayout (match modTypeDecl.pmtd_type with | None -> Doc.nil | Some modType -> - Doc.concat [Doc.text " = "; printModType ~customLayout modType cmtTbl]); + Doc.concat + [ Doc.text " = "; printModType ~customLayout modType cmtTbl ]); ] and printModType ~customLayout modType cmtTbl = let modTypeDoc = match modType.pmty_desc with | Parsetree.Pmty_ident longident -> - Doc.concat - [ - printAttributes ~customLayout ~loc:longident.loc - modType.pmty_attributes cmtTbl; - printLongidentLocation longident cmtTbl; - ] + Doc.concat + [ + printAttributes ~customLayout ~loc:longident.loc + modType.pmty_attributes cmtTbl; + printLongidentLocation longident cmtTbl; + ] | Pmty_signature [] -> - if hasCommentsInside cmtTbl modType.pmty_loc then - let doc = printCommentsInside cmtTbl modType.pmty_loc in - Doc.concat [Doc.lbrace; doc; Doc.rbrace] - else - let shouldBreak = - modType.pmty_loc.loc_start.pos_lnum - < modType.pmty_loc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak:shouldBreak - (Doc.concat [Doc.lbrace; Doc.softLine; Doc.softLine; Doc.rbrace]) - | Pmty_signature signature -> - let signatureDoc = - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [Doc.line; printSignature ~customLayout signature cmtTbl]); - Doc.line; - Doc.rbrace; - ]) - in - Doc.concat - [ - printAttributes ~customLayout modType.pmty_attributes cmtTbl; - signatureDoc; - ] - | Pmty_functor _ -> - let parameters, returnType = ParsetreeViewer.functorType modType in - let parametersDoc = - match parameters with - | [] -> Doc.nil - | [(attrs, {Location.txt = "_"; loc}, Some modType)] -> - let cmtLoc = - {loc with loc_end = modType.Parsetree.pmty_loc.loc_end} - in - let attrs = printAttributes ~customLayout attrs cmtTbl in - let doc = - Doc.concat [attrs; printModType ~customLayout modType cmtTbl] + if hasCommentsInside cmtTbl modType.pmty_loc then + let doc = printCommentsInside cmtTbl modType.pmty_loc in + Doc.concat [ Doc.lbrace; doc; Doc.rbrace ] + else + let shouldBreak = + modType.pmty_loc.loc_start.pos_lnum + < modType.pmty_loc.loc_end.pos_lnum in - printComments doc cmtTbl cmtLoc - | params -> - Doc.group + Doc.breakableGroup ~forceBreak:shouldBreak + (Doc.concat [ Doc.lbrace; Doc.softLine; Doc.softLine; Doc.rbrace ]) + | Pmty_signature signature -> + let signatureDoc = + Doc.breakableGroup ~forceBreak:true (Doc.concat [ - Doc.lparen; + Doc.lbrace; Doc.indent (Doc.concat [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun (attrs, lbl, modType) -> - let cmtLoc = - match modType with - | None -> lbl.Asttypes.loc - | Some modType -> - { - lbl.Asttypes.loc with - loc_end = - modType.Parsetree.pmty_loc.loc_end; - } - in - let attrs = - printAttributes ~customLayout attrs cmtTbl - in - let lblDoc = - if lbl.Location.txt = "_" || lbl.txt = "*" then - Doc.nil - else - let doc = Doc.text lbl.txt in - printComments doc cmtTbl lbl.loc - in - let doc = - Doc.concat - [ - attrs; - lblDoc; - (match modType with - | None -> Doc.nil - | Some modType -> - Doc.concat - [ - (if lbl.txt = "_" then Doc.nil - else Doc.text ": "); - printModType ~customLayout modType - cmtTbl; - ]); - ] - in - printComments doc cmtTbl cmtLoc) - params); + Doc.line; printSignature ~customLayout signature cmtTbl; ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; + Doc.line; + Doc.rbrace; ]) - in - let returnDoc = - let doc = printModType ~customLayout returnType cmtTbl in - if Parens.modTypeFunctorReturn returnType then addParens doc else doc - in - Doc.group - (Doc.concat - [ - parametersDoc; - Doc.group (Doc.concat [Doc.text " =>"; Doc.line; returnDoc]); - ]) + in + Doc.concat + [ + printAttributes ~customLayout modType.pmty_attributes cmtTbl; + signatureDoc; + ] + | Pmty_functor _ -> + let parameters, returnType = ParsetreeViewer.functorType modType in + let parametersDoc = + match parameters with + | [] -> Doc.nil + | [ (attrs, { Location.txt = "_"; loc }, Some modType) ] -> + let cmtLoc = + { loc with loc_end = modType.Parsetree.pmty_loc.loc_end } + in + let attrs = printAttributes ~customLayout attrs cmtTbl in + let doc = + Doc.concat [ attrs; printModType ~customLayout modType cmtTbl ] + in + printComments doc cmtTbl cmtLoc + | params -> + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun (attrs, lbl, modType) -> + let cmtLoc = + match modType with + | None -> lbl.Asttypes.loc + | Some modType -> + { + lbl.Asttypes.loc with + loc_end = + modType.Parsetree.pmty_loc.loc_end; + } + in + let attrs = + printAttributes ~customLayout attrs cmtTbl + in + let lblDoc = + if lbl.Location.txt = "_" || lbl.txt = "*" + then Doc.nil + else + let doc = Doc.text lbl.txt in + printComments doc cmtTbl lbl.loc + in + let doc = + Doc.concat + [ + attrs; + lblDoc; + (match modType with + | None -> Doc.nil + | Some modType -> + Doc.concat + [ + (if lbl.txt = "_" then Doc.nil + else Doc.text ": "); + printModType ~customLayout + modType cmtTbl; + ]); + ] + in + printComments doc cmtTbl cmtLoc) + params); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) + in + let returnDoc = + let doc = printModType ~customLayout returnType cmtTbl in + if Parens.modTypeFunctorReturn returnType then addParens doc else doc + in + Doc.group + (Doc.concat + [ + parametersDoc; + Doc.group (Doc.concat [ Doc.text " =>"; Doc.line; returnDoc ]); + ]) | Pmty_typeof modExpr -> - Doc.concat - [Doc.text "module type of "; printModExpr ~customLayout modExpr cmtTbl] + Doc.concat + [ + Doc.text "module type of "; + printModExpr ~customLayout modExpr cmtTbl; + ] | Pmty_extension extension -> - printExtension ~customLayout ~atModuleLvl:false extension cmtTbl + printExtension ~customLayout ~atModuleLvl:false extension cmtTbl | Pmty_alias longident -> - Doc.concat [Doc.text "module "; printLongidentLocation longident cmtTbl] + Doc.concat + [ Doc.text "module "; printLongidentLocation longident cmtTbl ] | Pmty_with (modType, withConstraints) -> - let operand = - let doc = printModType ~customLayout modType cmtTbl in - if Parens.modTypeWithOperand modType then addParens doc else doc - in - Doc.group - (Doc.concat - [ - operand; - Doc.indent - (Doc.concat - [ - Doc.line; - printWithConstraints ~customLayout withConstraints cmtTbl; - ]); - ]) + let operand = + let doc = printModType ~customLayout modType cmtTbl in + if Parens.modTypeWithOperand modType then addParens doc else doc + in + Doc.group + (Doc.concat + [ + operand; + Doc.indent + (Doc.concat + [ + Doc.line; + printWithConstraints ~customLayout withConstraints cmtTbl; + ]); + ]) in let attrsAlreadyPrinted = match modType.pmty_desc with @@ -229893,78 +229950,78 @@ and printWithConstraint ~customLayout match withConstraint with (* with type X.t = ... *) | Pwith_type (longident, typeDeclaration) -> - Doc.group - (printTypeDeclaration ~customLayout - ~name:(printLidentPath longident cmtTbl) - ~equalSign:"=" ~recFlag:Doc.nil 0 typeDeclaration CommentTable.empty) + Doc.group + (printTypeDeclaration ~customLayout + ~name:(printLidentPath longident cmtTbl) + ~equalSign:"=" ~recFlag:Doc.nil 0 typeDeclaration CommentTable.empty) (* with module X.Y = Z *) - | Pwith_module ({txt = longident1}, {txt = longident2}) -> - Doc.concat - [ - Doc.text "module "; - printLongident longident1; - Doc.text " ="; - Doc.indent (Doc.concat [Doc.line; printLongident longident2]); - ] + | Pwith_module ({ txt = longident1 }, { txt = longident2 }) -> + Doc.concat + [ + Doc.text "module "; + printLongident longident1; + Doc.text " ="; + Doc.indent (Doc.concat [ Doc.line; printLongident longident2 ]); + ] (* with type X.t := ..., same format as [Pwith_type] *) | Pwith_typesubst (longident, typeDeclaration) -> - Doc.group - (printTypeDeclaration ~customLayout - ~name:(printLidentPath longident cmtTbl) - ~equalSign:":=" ~recFlag:Doc.nil 0 typeDeclaration CommentTable.empty) - | Pwith_modsubst ({txt = longident1}, {txt = longident2}) -> - Doc.concat - [ - Doc.text "module "; - printLongident longident1; - Doc.text " :="; - Doc.indent (Doc.concat [Doc.line; printLongident longident2]); - ] + Doc.group + (printTypeDeclaration ~customLayout + ~name:(printLidentPath longident cmtTbl) + ~equalSign:":=" ~recFlag:Doc.nil 0 typeDeclaration CommentTable.empty) + | Pwith_modsubst ({ txt = longident1 }, { txt = longident2 }) -> + Doc.concat + [ + Doc.text "module "; + printLongident longident1; + Doc.text " :="; + Doc.indent (Doc.concat [ Doc.line; printLongident longident2 ]); + ] and printSignature ~customLayout signature cmtTbl = match signature with | [] -> printCommentsInsideFile cmtTbl | signature -> - printList - ~getLoc:(fun s -> s.Parsetree.psig_loc) - ~nodes:signature - ~print:(printSignatureItem ~customLayout) - cmtTbl + printList + ~getLoc:(fun s -> s.Parsetree.psig_loc) + ~nodes:signature + ~print:(printSignatureItem ~customLayout) + cmtTbl and printSignatureItem ~customLayout (si : Parsetree.signature_item) cmtTbl = match si.psig_desc with | Parsetree.Psig_value valueDescription -> - printValueDescription ~customLayout valueDescription cmtTbl + printValueDescription ~customLayout valueDescription cmtTbl | Psig_type (recFlag, typeDeclarations) -> - let recFlag = - match recFlag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - printTypeDeclarations ~customLayout ~recFlag typeDeclarations cmtTbl + let recFlag = + match recFlag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + printTypeDeclarations ~customLayout ~recFlag typeDeclarations cmtTbl | Psig_typext typeExtension -> - printTypeExtension ~customLayout typeExtension cmtTbl + printTypeExtension ~customLayout typeExtension cmtTbl | Psig_exception extensionConstructor -> - printExceptionDef ~customLayout extensionConstructor cmtTbl + printExceptionDef ~customLayout extensionConstructor cmtTbl | Psig_module moduleDeclaration -> - printModuleDeclaration ~customLayout moduleDeclaration cmtTbl + printModuleDeclaration ~customLayout moduleDeclaration cmtTbl | Psig_recmodule moduleDeclarations -> - printRecModuleDeclarations ~customLayout moduleDeclarations cmtTbl + printRecModuleDeclarations ~customLayout moduleDeclarations cmtTbl | Psig_modtype modTypeDecl -> - printModuleTypeDeclaration ~customLayout modTypeDecl cmtTbl + printModuleTypeDeclaration ~customLayout modTypeDecl cmtTbl | Psig_open openDescription -> - printOpenDescription ~customLayout openDescription cmtTbl + printOpenDescription ~customLayout openDescription cmtTbl | Psig_include includeDescription -> - printIncludeDescription ~customLayout includeDescription cmtTbl + printIncludeDescription ~customLayout includeDescription cmtTbl | Psig_attribute attr -> - fst (printAttribute ~customLayout ~standalone:true attr cmtTbl) + fst (printAttribute ~customLayout ~standalone:true attr cmtTbl) | Psig_extension (extension, attrs) -> - Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - Doc.concat - [printExtension ~customLayout ~atModuleLvl:true extension cmtTbl]; - ] + Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + Doc.concat + [ printExtension ~customLayout ~atModuleLvl:true extension cmtTbl ]; + ] | Psig_class _ | Psig_class_type _ -> Doc.nil and printRecModuleDeclarations ~customLayout moduleDeclarations cmtTbl = @@ -229978,23 +230035,22 @@ and printRecModuleDeclaration ~customLayout md cmtTbl i = let body = match md.pmd_type.pmty_desc with | Parsetree.Pmty_alias longident -> - Doc.concat [Doc.text " = "; printLongidentLocation longident cmtTbl] + Doc.concat [ Doc.text " = "; printLongidentLocation longident cmtTbl ] | _ -> - let needsParens = - match md.pmd_type.pmty_desc with - | Pmty_with _ -> true - | _ -> false - in - let modTypeDoc = - let doc = printModType ~customLayout md.pmd_type cmtTbl in - if needsParens then addParens doc else doc - in - Doc.concat [Doc.text ": "; modTypeDoc] + let needsParens = + match md.pmd_type.pmty_desc with Pmty_with _ -> true | _ -> false + in + let modTypeDoc = + let doc = printModType ~customLayout md.pmd_type cmtTbl in + if needsParens then addParens doc else doc + in + Doc.concat [ Doc.text ": "; modTypeDoc ] in let prefix = if i < 1 then "module rec " else "and " in Doc.concat [ - printAttributes ~customLayout ~loc:md.pmd_name.loc md.pmd_attributes cmtTbl; + printAttributes ~customLayout ~loc:md.pmd_name.loc md.pmd_attributes + cmtTbl; Doc.text prefix; printComments (Doc.text md.pmd_name.txt) cmtTbl md.pmd_name.loc; body; @@ -230005,13 +230061,15 @@ and printModuleDeclaration ~customLayout (md : Parsetree.module_declaration) let body = match md.pmd_type.pmty_desc with | Parsetree.Pmty_alias longident -> - Doc.concat [Doc.text " = "; printLongidentLocation longident cmtTbl] + Doc.concat [ Doc.text " = "; printLongidentLocation longident cmtTbl ] | _ -> - Doc.concat [Doc.text ": "; printModType ~customLayout md.pmd_type cmtTbl] + Doc.concat + [ Doc.text ": "; printModType ~customLayout md.pmd_type cmtTbl ] in Doc.concat [ - printAttributes ~customLayout ~loc:md.pmd_name.loc md.pmd_attributes cmtTbl; + printAttributes ~customLayout ~loc:md.pmd_name.loc md.pmd_attributes + cmtTbl; Doc.text "module "; printComments (Doc.text md.pmd_name.txt) cmtTbl md.pmd_name.loc; body; @@ -230062,9 +230120,7 @@ and printValueBindings ~customLayout ~recFlag and printValueDescription ~customLayout valueDescription cmtTbl = let isExternal = - match valueDescription.pval_prim with - | [] -> false - | _ -> true + match valueDescription.pval_prim with [] -> false | _ -> true in let attrs = printAttributes ~customLayout ~loc:valueDescription.pval_name.loc @@ -230094,7 +230150,7 @@ and printValueDescription ~customLayout valueDescription cmtTbl = (List.map (fun s -> Doc.concat - [Doc.text "\""; Doc.text s; Doc.text "\""]) + [ Doc.text "\""; Doc.text s; Doc.text "\"" ]) valueDescription.pval_prim); ]); ]) @@ -230146,72 +230202,72 @@ and printTypeDeclaration ~customLayout ~name ~equalSign ~recFlag i printAttributes ~customLayout ~loc:td.ptype_loc td.ptype_attributes cmtTbl in let prefix = - if i > 0 then Doc.text "and " else Doc.concat [Doc.text "type "; recFlag] + if i > 0 then Doc.text "and " else Doc.concat [ Doc.text "type "; recFlag ] in let typeName = name in let typeParams = printTypeParams ~customLayout td.ptype_params cmtTbl in let manifestAndKind = match td.ptype_kind with | Ptype_abstract -> ( - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> + Doc.concat + [ + Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + printPrivateFlag td.ptype_private; + printTypExpr ~customLayout typ cmtTbl; + ]) + | Ptype_open -> Doc.concat [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; printPrivateFlag td.ptype_private; - printTypExpr ~customLayout typ cmtTbl; - ]) - | Ptype_open -> - Doc.concat - [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - Doc.text ".."; - ] + Doc.text ".."; + ] | Ptype_record lds -> - let manifest = - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr ~customLayout typ cmtTbl; - ] - in - Doc.concat - [ - manifest; - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - printRecordDeclaration ~customLayout lds cmtTbl; - ] + let manifest = + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> + Doc.concat + [ + Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + printTypExpr ~customLayout typ cmtTbl; + ] + in + Doc.concat + [ + manifest; + Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + printPrivateFlag td.ptype_private; + printRecordDeclaration ~customLayout lds cmtTbl; + ] | Ptype_variant cds -> - let manifest = - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr ~customLayout typ cmtTbl; - ] - in - Doc.concat - [ - manifest; - Doc.concat [Doc.space; Doc.text equalSign]; - printConstructorDeclarations ~customLayout - ~privateFlag:td.ptype_private cds cmtTbl; - ] + let manifest = + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> + Doc.concat + [ + Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + printTypExpr ~customLayout typ cmtTbl; + ] + in + Doc.concat + [ + manifest; + Doc.concat [ Doc.space; Doc.text equalSign ]; + printConstructorDeclarations ~customLayout + ~privateFlag:td.ptype_private cds cmtTbl; + ] in let constraints = printTypeDefinitionConstraints ~customLayout td.ptype_cstrs in Doc.group (Doc.concat - [attrs; prefix; typeName; typeParams; manifestAndKind; constraints]) + [ attrs; prefix; typeName; typeParams; manifestAndKind; constraints ]) and printTypeDeclaration2 ~customLayout ~recFlag (td : Parsetree.type_declaration) cmtTbl i = @@ -230224,99 +230280,99 @@ and printTypeDeclaration2 ~customLayout ~recFlag printAttributes ~customLayout ~loc:td.ptype_loc td.ptype_attributes cmtTbl in let prefix = - if i > 0 then Doc.text "and " else Doc.concat [Doc.text "type "; recFlag] + if i > 0 then Doc.text "and " else Doc.concat [ Doc.text "type "; recFlag ] in let typeName = name in let typeParams = printTypeParams ~customLayout td.ptype_params cmtTbl in let manifestAndKind = match td.ptype_kind with | Ptype_abstract -> ( - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - printTypExpr ~customLayout typ cmtTbl; - ]) + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> + Doc.concat + [ + Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + printPrivateFlag td.ptype_private; + printTypExpr ~customLayout typ cmtTbl; + ]) | Ptype_open -> - Doc.concat - [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - Doc.text ".."; - ] - | Ptype_record lds -> - if lds = [] then Doc.concat [ - Doc.space; - Doc.text equalSign; - Doc.space; - Doc.lbrace; - printCommentsInside cmtTbl td.ptype_loc; - Doc.rbrace; + Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + printPrivateFlag td.ptype_private; + Doc.text ".."; ] - else + | Ptype_record lds -> + if lds = [] then + Doc.concat + [ + Doc.space; + Doc.text equalSign; + Doc.space; + Doc.lbrace; + printCommentsInside cmtTbl td.ptype_loc; + Doc.rbrace; + ] + else + let manifest = + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> + Doc.concat + [ + Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + printTypExpr ~customLayout typ cmtTbl; + ] + in + Doc.concat + [ + manifest; + Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + printPrivateFlag td.ptype_private; + printRecordDeclaration ~customLayout lds cmtTbl; + ] + | Ptype_variant cds -> let manifest = match td.ptype_manifest with | None -> Doc.nil | Some typ -> - Doc.concat - [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr ~customLayout typ cmtTbl; - ] + Doc.concat + [ + Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + printTypExpr ~customLayout typ cmtTbl; + ] in Doc.concat [ manifest; - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - printRecordDeclaration ~customLayout lds cmtTbl; + Doc.concat [ Doc.space; Doc.text equalSign ]; + printConstructorDeclarations ~customLayout + ~privateFlag:td.ptype_private cds cmtTbl; ] - | Ptype_variant cds -> - let manifest = - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr ~customLayout typ cmtTbl; - ] - in - Doc.concat - [ - manifest; - Doc.concat [Doc.space; Doc.text equalSign]; - printConstructorDeclarations ~customLayout - ~privateFlag:td.ptype_private cds cmtTbl; - ] in let constraints = printTypeDefinitionConstraints ~customLayout td.ptype_cstrs in Doc.group (Doc.concat - [attrs; prefix; typeName; typeParams; manifestAndKind; constraints]) + [ attrs; prefix; typeName; typeParams; manifestAndKind; constraints ]) and printTypeDefinitionConstraints ~customLayout cstrs = match cstrs with | [] -> Doc.nil | cstrs -> - Doc.indent - (Doc.group - (Doc.concat - [ - Doc.line; - Doc.group - (Doc.join ~sep:Doc.line - (List.map - (printTypeDefinitionConstraint ~customLayout) - cstrs)); - ])) + Doc.indent + (Doc.group + (Doc.concat + [ + Doc.line; + Doc.group + (Doc.join ~sep:Doc.line + (List.map + (printTypeDefinitionConstraint ~customLayout) + cstrs)); + ])) and printTypeDefinitionConstraint ~customLayout ((typ1, typ2, _loc) : @@ -230330,37 +230386,35 @@ and printTypeDefinitionConstraint ~customLayout ] and printPrivateFlag (flag : Asttypes.private_flag) = - match flag with - | Private -> Doc.text "private " - | Public -> Doc.nil + match flag with Private -> Doc.text "private " | Public -> Doc.nil and printTypeParams ~customLayout typeParams cmtTbl = match typeParams with | [] -> Doc.nil | typeParams -> - Doc.group - (Doc.concat - [ - Doc.lessThan; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun typeParam -> - let doc = - printTypeParam ~customLayout typeParam cmtTbl - in - printComments doc cmtTbl - (fst typeParam).Parsetree.ptyp_loc) - typeParams); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.greaterThan; - ]) + Doc.group + (Doc.concat + [ + Doc.lessThan; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun typeParam -> + let doc = + printTypeParam ~customLayout typeParam cmtTbl + in + printComments doc cmtTbl + (fst typeParam).Parsetree.ptyp_loc) + typeParams); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.greaterThan; + ]) and printTypeParam ~customLayout (param : Parsetree.core_type * Asttypes.variance) cmtTbl = @@ -230371,14 +230425,14 @@ and printTypeParam ~customLayout | Contravariant -> Doc.text "-" | Invariant -> Doc.nil in - Doc.concat [printedVariance; printTypExpr ~customLayout typ cmtTbl] + Doc.concat [ printedVariance; printTypExpr ~customLayout typ cmtTbl ] and printRecordDeclaration ~customLayout (lds : Parsetree.label_declaration list) cmtTbl = let forceBreak = match (lds, List.rev lds) with | first :: _, last :: _ -> - first.pld_loc.loc_start.pos_lnum < last.pld_loc.loc_end.pos_lnum + first.pld_loc.loc_start.pos_lnum < last.pld_loc.loc_end.pos_lnum | _ -> false in Doc.breakableGroup ~forceBreak @@ -230390,7 +230444,7 @@ and printRecordDeclaration ~customLayout [ Doc.softLine; Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) (List.map (fun ld -> let doc = @@ -230409,12 +230463,12 @@ and printConstructorDeclarations ~customLayout ~privateFlag let forceBreak = match (cds, List.rev cds) with | first :: _, last :: _ -> - first.pcd_loc.loc_start.pos_lnum < last.pcd_loc.loc_end.pos_lnum + first.pcd_loc.loc_start.pos_lnum < last.pcd_loc.loc_end.pos_lnum | _ -> false in let privateFlag = match privateFlag with - | Asttypes.Private -> Doc.concat [Doc.text "private"; Doc.line] + | Asttypes.Private -> Doc.concat [ Doc.text "private"; Doc.line ] | Public -> Doc.nil in let rows = @@ -230427,7 +230481,7 @@ and printConstructorDeclarations ~customLayout ~privateFlag ~forceBreak cmtTbl in Doc.breakableGroup ~forceBreak - (Doc.indent (Doc.concat [Doc.line; privateFlag; rows])) + (Doc.indent (Doc.concat [ Doc.line; privateFlag; rows ])) and printConstructorDeclaration2 ~customLayout i (cd : Parsetree.constructor_declaration) cmtTbl = @@ -230447,8 +230501,8 @@ and printConstructorDeclaration2 ~customLayout i match cd.pcd_res with | None -> Doc.nil | Some typ -> - Doc.indent - (Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ cmtTbl]) + Doc.indent + (Doc.concat [ Doc.text ": "; printTypExpr ~customLayout typ cmtTbl ]) in Doc.concat [ @@ -230469,54 +230523,55 @@ and printConstructorArguments ~customLayout ~indent match cdArgs with | Pcstr_tuple [] -> Doc.nil | Pcstr_tuple types -> - let args = - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun typexpr -> printTypExpr ~customLayout typexpr cmtTbl) - types); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - in - Doc.group (if indent then Doc.indent args else args) + let args = + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun typexpr -> + printTypExpr ~customLayout typexpr cmtTbl) + types); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + in + Doc.group (if indent then Doc.indent args else args) | Pcstr_record lds -> - let args = - Doc.concat - [ - Doc.lparen; - (* manually inline the printRecordDeclaration, gives better layout *) - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun ld -> - let doc = - printLabelDeclaration ~customLayout ld cmtTbl - in - printComments doc cmtTbl ld.Parsetree.pld_loc) - lds); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - Doc.rparen; - ] - in - if indent then Doc.indent args else args + let args = + Doc.concat + [ + Doc.lparen; + (* manually inline the printRecordDeclaration, gives better layout *) + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun ld -> + let doc = + printLabelDeclaration ~customLayout ld cmtTbl + in + printComments doc cmtTbl ld.Parsetree.pld_loc) + lds); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + Doc.rparen; + ] + in + if indent then Doc.indent args else args and printLabelDeclaration ~customLayout (ld : Parsetree.label_declaration) cmtTbl = @@ -230549,242 +230604,261 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = match typExpr.ptyp_desc with | Ptyp_any -> Doc.text "_" | Ptyp_var var -> - Doc.concat [Doc.text "'"; printIdentLike ~allowUident:true var] + Doc.concat [ Doc.text "'"; printIdentLike ~allowUident:true var ] | Ptyp_extension extension -> - printExtension ~customLayout ~atModuleLvl:false extension cmtTbl + printExtension ~customLayout ~atModuleLvl:false extension cmtTbl | Ptyp_alias (typ, alias) -> - let typ = - (* Technically type t = (string, float) => unit as 'x, doesn't require - * parens around the arrow expression. This is very confusing though. - * Is the "as" part of "unit" or "(string, float) => unit". By printing - * parens we guide the user towards its meaning.*) - let needsParens = - match typ.ptyp_desc with - | Ptyp_arrow _ -> true - | _ -> false + let typ = + (* Technically type t = (string, float) => unit as 'x, doesn't require + * parens around the arrow expression. This is very confusing though. + * Is the "as" part of "unit" or "(string, float) => unit". By printing + * parens we guide the user towards its meaning.*) + let needsParens = + match typ.ptyp_desc with Ptyp_arrow _ -> true | _ -> false + in + let doc = printTypExpr ~customLayout typ cmtTbl in + if needsParens then Doc.concat [ Doc.lparen; doc; Doc.rparen ] + else doc in - let doc = printTypExpr ~customLayout typ cmtTbl in - if needsParens then Doc.concat [Doc.lparen; doc; Doc.rparen] else doc - in - Doc.concat - [typ; Doc.text " as "; Doc.concat [Doc.text "'"; printIdentLike alias]] + Doc.concat + [ + typ; + Doc.text " as "; + Doc.concat [ Doc.text "'"; printIdentLike alias ]; + ] (* object printings *) | Ptyp_object (fields, openFlag) -> - printObject ~customLayout ~inline:false fields openFlag cmtTbl - | Ptyp_constr (longidentLoc, [{ptyp_desc = Ptyp_object (fields, openFlag)}]) + printObject ~customLayout ~inline:false fields openFlag cmtTbl + | Ptyp_constr + (longidentLoc, [ { ptyp_desc = Ptyp_object (fields, openFlag) } ]) -> + (* for foo<{"a": b}>, when the object is long and needs a line break, we + want the <{ and }> to stay hugged together *) + let constrName = printLidentPath longidentLoc cmtTbl in + Doc.concat + [ + constrName; + Doc.lessThan; + printObject ~customLayout ~inline:true fields openFlag cmtTbl; + Doc.greaterThan; + ] + | Ptyp_constr (longidentLoc, [ { ptyp_desc = Parsetree.Ptyp_tuple tuple } ]) -> - (* for foo<{"a": b}>, when the object is long and needs a line break, we - want the <{ and }> to stay hugged together *) - let constrName = printLidentPath longidentLoc cmtTbl in - Doc.concat - [ - constrName; - Doc.lessThan; - printObject ~customLayout ~inline:true fields openFlag cmtTbl; - Doc.greaterThan; - ] - | Ptyp_constr (longidentLoc, [{ptyp_desc = Parsetree.Ptyp_tuple tuple}]) -> - let constrName = printLidentPath longidentLoc cmtTbl in - Doc.group - (Doc.concat - [ - constrName; - Doc.lessThan; - printTupleType ~customLayout ~inline:true tuple cmtTbl; - Doc.greaterThan; - ]) - | Ptyp_constr (longidentLoc, constrArgs) -> ( - let constrName = printLidentPath longidentLoc cmtTbl in - match constrArgs with - | [] -> constrName - | _args -> + let constrName = printLidentPath longidentLoc cmtTbl in Doc.group (Doc.concat [ constrName; Doc.lessThan; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun typexpr -> - printTypExpr ~customLayout typexpr cmtTbl) - constrArgs); - ]); - Doc.trailingComma; - Doc.softLine; + printTupleType ~customLayout ~inline:true tuple cmtTbl; Doc.greaterThan; - ])) + ]) + | Ptyp_constr (longidentLoc, constrArgs) -> ( + let constrName = printLidentPath longidentLoc cmtTbl in + match constrArgs with + | [] -> constrName + | _args -> + Doc.group + (Doc.concat + [ + constrName; + Doc.lessThan; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun typexpr -> + printTypExpr ~customLayout typexpr cmtTbl) + constrArgs); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.greaterThan; + ])) | Ptyp_arrow _ -> ( - let attrsBefore, args, returnType = ParsetreeViewer.arrowType typExpr in - let returnTypeNeedsParens = - match returnType.ptyp_desc with - | Ptyp_alias _ -> true - | _ -> false - in - let returnDoc = - let doc = printTypExpr ~customLayout returnType cmtTbl in - if returnTypeNeedsParens then Doc.concat [Doc.lparen; doc; Doc.rparen] - else doc - in - let isUncurried, attrs = - ParsetreeViewer.processUncurriedAttribute attrsBefore - in - match args with - | [] -> Doc.nil - | [([], Nolabel, n)] when not isUncurried -> - let hasAttrsBefore = not (attrs = []) in - let attrs = - if hasAttrsBefore then - printAttributes ~customLayout ~inline:true attrsBefore cmtTbl - else Doc.nil + let attrsBefore, args, returnType = ParsetreeViewer.arrowType typExpr in + let returnTypeNeedsParens = + match returnType.ptyp_desc with Ptyp_alias _ -> true | _ -> false in - let typDoc = - let doc = printTypExpr ~customLayout n cmtTbl in - match n.ptyp_desc with - | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> addParens doc - | _ -> doc + let returnDoc = + let doc = printTypExpr ~customLayout returnType cmtTbl in + if returnTypeNeedsParens then + Doc.concat [ Doc.lparen; doc; Doc.rparen ] + else doc in - Doc.group - (Doc.concat - [ - Doc.group attrs; - Doc.group - (if hasAttrsBefore then - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [Doc.softLine; typDoc; Doc.text " => "; returnDoc]); - Doc.softLine; - Doc.rparen; - ] - else Doc.concat [typDoc; Doc.text " => "; returnDoc]); - ]) - | args -> - let attrs = printAttributes ~customLayout ~inline:true attrs cmtTbl in - let renderedArgs = - Doc.concat - [ - attrs; - Doc.text "("; - Doc.indent - (Doc.concat - [ - Doc.softLine; - (if isUncurried then Doc.concat [Doc.dot; Doc.space] - else Doc.nil); - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun tp -> printTypeParameter ~customLayout tp cmtTbl) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.text ")"; - ] + let isUncurried, attrs = + ParsetreeViewer.processUncurriedAttribute attrsBefore in - Doc.group (Doc.concat [renderedArgs; Doc.text " => "; returnDoc])) + match args with + | [] -> Doc.nil + | [ ([], Nolabel, n) ] when not isUncurried -> + let hasAttrsBefore = not (attrs = []) in + let attrs = + if hasAttrsBefore then + printAttributes ~customLayout ~inline:true attrsBefore cmtTbl + else Doc.nil + in + let typDoc = + let doc = printTypExpr ~customLayout n cmtTbl in + match n.ptyp_desc with + | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> addParens doc + | _ -> doc + in + Doc.group + (Doc.concat + [ + Doc.group attrs; + Doc.group + (if hasAttrsBefore then + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + typDoc; + Doc.text " => "; + returnDoc; + ]); + Doc.softLine; + Doc.rparen; + ] + else Doc.concat [ typDoc; Doc.text " => "; returnDoc ]); + ]) + | args -> + let attrs = + printAttributes ~customLayout ~inline:true attrs cmtTbl + in + let renderedArgs = + Doc.concat + [ + attrs; + Doc.text "("; + Doc.indent + (Doc.concat + [ + Doc.softLine; + (if isUncurried then Doc.concat [ Doc.dot; Doc.space ] + else Doc.nil); + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun tp -> + printTypeParameter ~customLayout tp cmtTbl) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.text ")"; + ] + in + Doc.group (Doc.concat [ renderedArgs; Doc.text " => "; returnDoc ])) | Ptyp_tuple types -> - printTupleType ~customLayout ~inline:false types cmtTbl + printTupleType ~customLayout ~inline:false types cmtTbl | Ptyp_poly ([], typ) -> printTypExpr ~customLayout typ cmtTbl | Ptyp_poly (stringLocs, typ) -> - Doc.concat - [ - Doc.join ~sep:Doc.space - (List.map - (fun {Location.txt; loc} -> - let doc = Doc.concat [Doc.text "'"; Doc.text txt] in - printComments doc cmtTbl loc) - stringLocs); - Doc.dot; - Doc.space; - printTypExpr ~customLayout typ cmtTbl; - ] + Doc.concat + [ + Doc.join ~sep:Doc.space + (List.map + (fun { Location.txt; loc } -> + let doc = Doc.concat [ Doc.text "'"; Doc.text txt ] in + printComments doc cmtTbl loc) + stringLocs); + Doc.dot; + Doc.space; + printTypExpr ~customLayout typ cmtTbl; + ] | Ptyp_package packageType -> - printPackageType ~customLayout ~printModuleKeywordAndParens:true - packageType cmtTbl + printPackageType ~customLayout ~printModuleKeywordAndParens:true + packageType cmtTbl | Ptyp_class _ -> Doc.text "classes are not supported in types" | Ptyp_variant (rowFields, closedFlag, labelsOpt) -> - let forceBreak = - typExpr.ptyp_loc.Location.loc_start.pos_lnum - < typExpr.ptyp_loc.loc_end.pos_lnum - in - let printRowField = function - | Parsetree.Rtag ({txt; loc}, attrs, true, []) -> - let doc = - Doc.group - (Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - Doc.concat [Doc.text "#"; printPolyVarIdent txt]; - ]) - in - printComments doc cmtTbl loc - | Rtag ({txt}, attrs, truth, types) -> - let doType t = - match t.Parsetree.ptyp_desc with - | Ptyp_tuple _ -> printTypExpr ~customLayout t cmtTbl - | _ -> + let forceBreak = + typExpr.ptyp_loc.Location.loc_start.pos_lnum + < typExpr.ptyp_loc.loc_end.pos_lnum + in + let printRowField = function + | Parsetree.Rtag ({ txt; loc }, attrs, true, []) -> + let doc = + Doc.group + (Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + Doc.concat [ Doc.text "#"; printPolyVarIdent txt ]; + ]) + in + printComments doc cmtTbl loc + | Rtag ({ txt }, attrs, truth, types) -> + let doType t = + match t.Parsetree.ptyp_desc with + | Ptyp_tuple _ -> printTypExpr ~customLayout t cmtTbl + | _ -> + Doc.concat + [ + Doc.lparen; + printTypExpr ~customLayout t cmtTbl; + Doc.rparen; + ] + in + let printedTypes = List.map doType types in + let cases = + Doc.join + ~sep:(Doc.concat [ Doc.line; Doc.text "& " ]) + printedTypes + in + let cases = + if truth then Doc.concat [ Doc.line; Doc.text "& "; cases ] + else cases + in + Doc.group + (Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + Doc.concat [ Doc.text "#"; printPolyVarIdent txt ]; + cases; + ]) + | Rinherit coreType -> printTypExpr ~customLayout coreType cmtTbl + in + let docs = List.map printRowField rowFields in + let cases = + Doc.join ~sep:(Doc.concat [ Doc.line; Doc.text "| " ]) docs + in + let cases = + if docs = [] then cases + else Doc.concat [ Doc.ifBreaks (Doc.text "| ") Doc.nil; cases ] + in + let openingSymbol = + if closedFlag = Open then Doc.concat [ Doc.greaterThan; Doc.line ] + else if labelsOpt = None then Doc.softLine + else Doc.concat [ Doc.lessThan; Doc.line ] + in + let labels = + match labelsOpt with + | None | Some [] -> Doc.nil + | Some labels -> Doc.concat - [Doc.lparen; printTypExpr ~customLayout t cmtTbl; Doc.rparen] - in - let printedTypes = List.map doType types in - let cases = - Doc.join ~sep:(Doc.concat [Doc.line; Doc.text "& "]) printedTypes - in - let cases = - if truth then Doc.concat [Doc.line; Doc.text "& "; cases] else cases - in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - Doc.concat [Doc.text "#"; printPolyVarIdent txt]; - cases; - ]) - | Rinherit coreType -> printTypExpr ~customLayout coreType cmtTbl - in - let docs = List.map printRowField rowFields in - let cases = Doc.join ~sep:(Doc.concat [Doc.line; Doc.text "| "]) docs in - let cases = - if docs = [] then cases - else Doc.concat [Doc.ifBreaks (Doc.text "| ") Doc.nil; cases] - in - let openingSymbol = - if closedFlag = Open then Doc.concat [Doc.greaterThan; Doc.line] - else if labelsOpt = None then Doc.softLine - else Doc.concat [Doc.lessThan; Doc.line] - in - let labels = - match labelsOpt with - | None | Some [] -> Doc.nil - | Some labels -> - Doc.concat - (List.map - (fun label -> - Doc.concat [Doc.line; Doc.text "#"; printPolyVarIdent label]) - labels) - in - let closingSymbol = - match labelsOpt with - | None | Some [] -> Doc.nil - | _ -> Doc.text " >" - in - Doc.breakableGroup ~forceBreak - (Doc.concat - [ - Doc.lbracket; - Doc.indent - (Doc.concat [openingSymbol; cases; closingSymbol; labels]); - Doc.softLine; - Doc.rbracket; - ]) + (List.map + (fun label -> + Doc.concat + [ Doc.line; Doc.text "#"; printPolyVarIdent label ]) + labels) + in + let closingSymbol = + match labelsOpt with None | Some [] -> Doc.nil | _ -> Doc.text " >" + in + Doc.breakableGroup ~forceBreak + (Doc.concat + [ + Doc.lbracket; + Doc.indent + (Doc.concat [ openingSymbol; cases; closingSymbol; labels ]); + Doc.softLine; + Doc.rbracket; + ]) in let shouldPrintItsOwnAttributes = match typExpr.ptyp_desc with @@ -230794,8 +230868,9 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = let doc = match typExpr.ptyp_attributes with | _ :: _ as attrs when not shouldPrintItsOwnAttributes -> - Doc.group - (Doc.concat [printAttributes ~customLayout attrs cmtTbl; renderedType]) + Doc.group + (Doc.concat + [ printAttributes ~customLayout attrs cmtTbl; renderedType ]) | _ -> renderedType in printComments doc cmtTbl typExpr.ptyp_loc @@ -230804,40 +230879,41 @@ and printObject ~customLayout ~inline fields openFlag cmtTbl = let doc = match fields with | [] -> - Doc.concat - [ - Doc.lbrace; - (match openFlag with - | Asttypes.Closed -> Doc.dot - | Open -> Doc.dotdot); - Doc.rbrace; - ] + Doc.concat + [ + Doc.lbrace; + (match openFlag with + | Asttypes.Closed -> Doc.dot + | Open -> Doc.dotdot); + Doc.rbrace; + ] | fields -> - Doc.concat - [ - Doc.lbrace; - (match openFlag with - | Asttypes.Closed -> Doc.nil - | Open -> ( - match fields with - (* handle `type t = {.. ...objType, "x": int}` - * .. and ... should have a space in between *) - | Oinherit _ :: _ -> Doc.text ".. " - | _ -> Doc.dotdot)); - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun field -> printObjectField ~customLayout field cmtTbl) - fields); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ] + Doc.concat + [ + Doc.lbrace; + (match openFlag with + | Asttypes.Closed -> Doc.nil + | Open -> ( + match fields with + (* handle `type t = {.. ...objType, "x": int}` + * .. and ... should have a space in between *) + | Oinherit _ :: _ -> Doc.text ".. " + | _ -> Doc.dotdot)); + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun field -> + printObjectField ~customLayout field cmtTbl) + fields); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ] in if inline then doc else Doc.group doc @@ -230852,7 +230928,7 @@ and printTupleType ~customLayout ~inline (types : Parsetree.core_type list) [ Doc.softLine; Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) (List.map (fun typexpr -> printTypExpr ~customLayout typexpr cmtTbl) types); @@ -230867,23 +230943,23 @@ and printTupleType ~customLayout ~inline (types : Parsetree.core_type list) and printObjectField ~customLayout (field : Parsetree.object_field) cmtTbl = match field with | Otag (labelLoc, attrs, typ) -> - let lbl = - let doc = Doc.text ("\"" ^ labelLoc.txt ^ "\"") in - printComments doc cmtTbl labelLoc.loc - in - let doc = - Doc.concat - [ - printAttributes ~customLayout ~loc:labelLoc.loc attrs cmtTbl; - lbl; - Doc.text ": "; - printTypExpr ~customLayout typ cmtTbl; - ] - in - let cmtLoc = {labelLoc.loc with loc_end = typ.ptyp_loc.loc_end} in - printComments doc cmtTbl cmtLoc + let lbl = + let doc = Doc.text ("\"" ^ labelLoc.txt ^ "\"") in + printComments doc cmtTbl labelLoc.loc + in + let doc = + Doc.concat + [ + printAttributes ~customLayout ~loc:labelLoc.loc attrs cmtTbl; + lbl; + Doc.text ": "; + printTypExpr ~customLayout typ cmtTbl; + ] + in + let cmtLoc = { labelLoc.loc with loc_end = typ.ptyp_loc.loc_end } in + printComments doc cmtTbl cmtLoc | Oinherit typexpr -> - Doc.concat [Doc.dotdotdot; printTypExpr ~customLayout typexpr cmtTbl] + Doc.concat [ Doc.dotdotdot; printTypExpr ~customLayout typexpr cmtTbl ] (* es6 arrow type arg * type t = (~foo: string, ~bar: float=?, unit) => unit @@ -230891,16 +230967,16 @@ and printObjectField ~customLayout (field : Parsetree.object_field) cmtTbl = and printTypeParameter ~customLayout (attrs, lbl, typ) cmtTbl = let isUncurried, attrs = ParsetreeViewer.processUncurriedAttribute attrs in let uncurried = - if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil + if isUncurried then Doc.concat [ Doc.dot; Doc.space ] else Doc.nil in let attrs = printAttributes ~customLayout attrs cmtTbl in let label = match lbl with | Asttypes.Nolabel -> Doc.nil | Labelled lbl -> - Doc.concat [Doc.text "~"; printIdentLike lbl; Doc.text ": "] + Doc.concat [ Doc.text "~"; printIdentLike lbl; Doc.text ": " ] | Optional lbl -> - Doc.concat [Doc.text "~"; printIdentLike lbl; Doc.text ": "] + Doc.concat [ Doc.text "~"; printIdentLike lbl; Doc.text ": " ] in let optionalIndicator = match lbl with @@ -230909,9 +230985,9 @@ and printTypeParameter ~customLayout (attrs, lbl, typ) cmtTbl = in let loc, typ = match typ.ptyp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: attrs -> - ( {loc with loc_end = typ.ptyp_loc.loc_end}, - {typ with ptyp_attributes = attrs} ) + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: attrs -> + ( { loc with loc_end = typ.ptyp_loc.loc_end }, + { typ with ptyp_attributes = attrs } ) | _ -> (typ.ptyp_loc, typ) in let doc = @@ -230934,169 +231010,178 @@ and printValueBinding ~customLayout ~recFlag (vb : Parsetree.value_binding) cmtTbl in let header = - if i == 0 then Doc.concat [Doc.text "let "; recFlag] else Doc.text "and " + if i == 0 then Doc.concat [ Doc.text "let "; recFlag ] else Doc.text "and " in match vb with | { pvb_pat = { ppat_desc = - Ppat_constraint (pattern, ({ptyp_desc = Ptyp_poly _} as patTyp)); + Ppat_constraint (pattern, ({ ptyp_desc = Ptyp_poly _ } as patTyp)); }; - pvb_expr = {pexp_desc = Pexp_newtype _} as expr; + pvb_expr = { pexp_desc = Pexp_newtype _ } as expr; } -> ( - let _attrs, parameters, returnExpr = ParsetreeViewer.funExpr expr in - let abstractType = - match parameters with - | [NewTypes {locs = vars}] -> - Doc.concat - [ - Doc.text "type "; - Doc.join ~sep:Doc.space - (List.map (fun var -> Doc.text var.Asttypes.txt) vars); - Doc.dot; - ] - | _ -> Doc.nil - in - match returnExpr.pexp_desc with - | Pexp_constraint (expr, typ) -> - Doc.group - (Doc.concat - [ - attrs; - header; - printPattern ~customLayout pattern cmtTbl; - Doc.text ":"; - Doc.indent - (Doc.concat - [ - Doc.line; - abstractType; - Doc.space; - printTypExpr ~customLayout typ cmtTbl; - Doc.text " ="; - Doc.concat - [ - Doc.line; - printExpressionWithComments ~customLayout expr cmtTbl; - ]; - ]); - ]) - | _ -> - (* Example: - * let cancel_and_collect_callbacks: - * 'a 'u 'c. (list, promise<'a, 'u, 'c>) => list = * (type x, callbacks_accumulator, p: promise<_, _, c>) - *) - Doc.group - (Doc.concat - [ - attrs; - header; - printPattern ~customLayout pattern cmtTbl; - Doc.text ":"; - Doc.indent - (Doc.concat - [ - Doc.line; - abstractType; - Doc.space; - printTypExpr ~customLayout patTyp cmtTbl; - Doc.text " ="; - Doc.concat - [ - Doc.line; - printExpressionWithComments ~customLayout expr cmtTbl; - ]; - ]); - ])) - | _ -> - let optBraces, expr = ParsetreeViewer.processBracesAttr vb.pvb_expr in - let printedExpr = - let doc = printExpressionWithComments ~customLayout vb.pvb_expr cmtTbl in - match Parens.expr vb.pvb_expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - let patternDoc = printPattern ~customLayout vb.pvb_pat cmtTbl in - (* - * we want to optimize the layout of one pipe: - * let tbl = data->Js.Array2.reduce((map, curr) => { - * ... - * }) - * important is that we don't do this for multiple pipes: - * let decoratorTags = - * items - * ->Js.Array2.filter(items => {items.category === Decorators}) - * ->Belt.Array.map(...) - * Multiple pipes chained together lend themselves more towards the last layout. - *) - if ParsetreeViewer.isSinglePipeExpr vb.pvb_expr then - Doc.customLayout - [ + let _attrs, parameters, returnExpr = ParsetreeViewer.funExpr expr in + let abstractType = + match parameters with + | [ NewTypes { locs = vars } ] -> + Doc.concat + [ + Doc.text "type "; + Doc.join ~sep:Doc.space + (List.map (fun var -> Doc.text var.Asttypes.txt) vars); + Doc.dot; + ] + | _ -> Doc.nil + in + match returnExpr.pexp_desc with + | Pexp_constraint (expr, typ) -> Doc.group (Doc.concat [ - attrs; header; patternDoc; Doc.text " ="; Doc.space; printedExpr; - ]); + attrs; + header; + printPattern ~customLayout pattern cmtTbl; + Doc.text ":"; + Doc.indent + (Doc.concat + [ + Doc.line; + abstractType; + Doc.space; + printTypExpr ~customLayout typ cmtTbl; + Doc.text " ="; + Doc.concat + [ + Doc.line; + printExpressionWithComments ~customLayout expr + cmtTbl; + ]; + ]); + ]) + | _ -> + (* Example: + * let cancel_and_collect_callbacks: + * 'a 'u 'c. (list, promise<'a, 'u, 'c>) => list = * (type x, callbacks_accumulator, p: promise<_, _, c>) + *) Doc.group (Doc.concat [ attrs; header; - patternDoc; - Doc.text " ="; - Doc.indent (Doc.concat [Doc.line; printedExpr]); - ]); - ] - else - let shouldIndent = - match optBraces with - | Some _ -> false - | _ -> ( - ParsetreeViewer.isBinaryExpression expr - || - match vb.pvb_expr with - | { - pexp_attributes = [({Location.txt = "ns.ternary"}, _)]; - pexp_desc = Pexp_ifthenelse (ifExpr, _, _); - } -> - ParsetreeViewer.isBinaryExpression ifExpr - || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes - | {pexp_desc = Pexp_newtype _} -> false - | e -> - ParsetreeViewer.hasAttributes e.pexp_attributes - || ParsetreeViewer.isArrayAccess e) + printPattern ~customLayout pattern cmtTbl; + Doc.text ":"; + Doc.indent + (Doc.concat + [ + Doc.line; + abstractType; + Doc.space; + printTypExpr ~customLayout patTyp cmtTbl; + Doc.text " ="; + Doc.concat + [ + Doc.line; + printExpressionWithComments ~customLayout expr + cmtTbl; + ]; + ]); + ])) + | _ -> + let optBraces, expr = ParsetreeViewer.processBracesAttr vb.pvb_expr in + let printedExpr = + let doc = + printExpressionWithComments ~customLayout vb.pvb_expr cmtTbl + in + match Parens.expr vb.pvb_expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc in - Doc.group - (Doc.concat - [ - attrs; - header; - patternDoc; - Doc.text " ="; - (if shouldIndent then - Doc.indent (Doc.concat [Doc.line; printedExpr]) - else Doc.concat [Doc.space; printedExpr]); - ]) + let patternDoc = printPattern ~customLayout vb.pvb_pat cmtTbl in + (* + * we want to optimize the layout of one pipe: + * let tbl = data->Js.Array2.reduce((map, curr) => { + * ... + * }) + * important is that we don't do this for multiple pipes: + * let decoratorTags = + * items + * ->Js.Array2.filter(items => {items.category === Decorators}) + * ->Belt.Array.map(...) + * Multiple pipes chained together lend themselves more towards the last layout. + *) + if ParsetreeViewer.isSinglePipeExpr vb.pvb_expr then + Doc.customLayout + [ + Doc.group + (Doc.concat + [ + attrs; + header; + patternDoc; + Doc.text " ="; + Doc.space; + printedExpr; + ]); + Doc.group + (Doc.concat + [ + attrs; + header; + patternDoc; + Doc.text " ="; + Doc.indent (Doc.concat [ Doc.line; printedExpr ]); + ]); + ] + else + let shouldIndent = + match optBraces with + | Some _ -> false + | _ -> ( + ParsetreeViewer.isBinaryExpression expr + || + match vb.pvb_expr with + | { + pexp_attributes = [ ({ Location.txt = "ns.ternary" }, _) ]; + pexp_desc = Pexp_ifthenelse (ifExpr, _, _); + } -> + ParsetreeViewer.isBinaryExpression ifExpr + || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes + | { pexp_desc = Pexp_newtype _ } -> false + | e -> + ParsetreeViewer.hasAttributes e.pexp_attributes + || ParsetreeViewer.isArrayAccess e) + in + Doc.group + (Doc.concat + [ + attrs; + header; + patternDoc; + Doc.text " ="; + (if shouldIndent then + Doc.indent (Doc.concat [ Doc.line; printedExpr ]) + else Doc.concat [ Doc.space; printedExpr ]); + ]) and printPackageType ~customLayout ~printModuleKeywordAndParens (packageType : Parsetree.package_type) cmtTbl = let doc = match packageType with | longidentLoc, [] -> - Doc.group (Doc.concat [printLongidentLocation longidentLoc cmtTbl]) + Doc.group (Doc.concat [ printLongidentLocation longidentLoc cmtTbl ]) | longidentLoc, packageConstraints -> - Doc.group - (Doc.concat - [ - printLongidentLocation longidentLoc cmtTbl; - printPackageConstraints ~customLayout packageConstraints cmtTbl; - Doc.softLine; - ]) + Doc.group + (Doc.concat + [ + printLongidentLocation longidentLoc cmtTbl; + printPackageConstraints ~customLayout packageConstraints cmtTbl; + Doc.softLine; + ]) in if printModuleKeywordAndParens then - Doc.concat [Doc.text "module("; doc; Doc.rparen] + Doc.concat [ Doc.text "module("; doc; Doc.rparen ] else doc and printPackageConstraints ~customLayout packageConstraints cmtTbl = @@ -231148,7 +231233,7 @@ and printExtension ~customLayout ~atModuleLvl (stringLoc, payload) cmtTbl = in printComments doc cmtTbl stringLoc.Location.loc in - Doc.group (Doc.concat [extName; printPayload ~customLayout payload cmtTbl]) + Doc.group (Doc.concat [ extName; printPayload ~customLayout payload cmtTbl ]) and printPattern ~customLayout (p : Parsetree.pattern) cmtTbl = let patternWithoutAttributes = @@ -231156,376 +231241,404 @@ and printPattern ~customLayout (p : Parsetree.pattern) cmtTbl = | Ppat_any -> Doc.text "_" | Ppat_var var -> printIdentLike var.txt | Ppat_constant c -> - let templateLiteral = - ParsetreeViewer.hasTemplateLiteralAttr p.ppat_attributes - in - printConstant ~templateLiteral c + let templateLiteral = + ParsetreeViewer.hasTemplateLiteralAttr p.ppat_attributes + in + printConstant ~templateLiteral c | Ppat_tuple patterns -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) - patterns); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) | Ppat_array [] -> - Doc.concat - [Doc.lbracket; printCommentsInside cmtTbl p.ppat_loc; Doc.rbracket] + Doc.concat + [ Doc.lbracket; printCommentsInside cmtTbl p.ppat_loc; Doc.rbracket ] | Ppat_array patterns -> - Doc.group - (Doc.concat - [ - Doc.text "["; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) - patterns); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.text "]"; - ]) - | Ppat_construct ({txt = Longident.Lident "()"}, _) -> - Doc.concat [Doc.lparen; printCommentsInside cmtTbl p.ppat_loc; Doc.rparen] - | Ppat_construct ({txt = Longident.Lident "[]"}, _) -> - Doc.concat - [Doc.text "list{"; printCommentsInside cmtTbl p.ppat_loc; Doc.rbrace] - | Ppat_construct ({txt = Longident.Lident "::"}, _) -> - let patterns, tail = - ParsetreeViewer.collectPatternsFromListConstruct [] p - in - let shouldHug = - match (patterns, tail) with - | [pat], {ppat_desc = Ppat_construct ({txt = Longident.Lident "[]"}, _)} - when ParsetreeViewer.isHuggablePattern pat -> - true - | _ -> false - in - let children = + Doc.group + (Doc.concat + [ + Doc.text "["; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.text "]"; + ]) + | Ppat_construct ({ txt = Longident.Lident "()" }, _) -> + Doc.concat + [ Doc.lparen; printCommentsInside cmtTbl p.ppat_loc; Doc.rparen ] + | Ppat_construct ({ txt = Longident.Lident "[]" }, _) -> Doc.concat [ - (if shouldHug then Doc.nil else Doc.softLine); - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) - patterns); - (match tail.Parsetree.ppat_desc with - | Ppat_construct ({txt = Longident.Lident "[]"}, _) -> Doc.nil - | _ -> - let doc = - Doc.concat - [Doc.text "..."; printPattern ~customLayout tail cmtTbl] - in - let tail = printComments doc cmtTbl tail.ppat_loc in - Doc.concat [Doc.text ","; Doc.line; tail]); + Doc.text "list{"; printCommentsInside cmtTbl p.ppat_loc; Doc.rbrace; ] - in - Doc.group - (Doc.concat - [ - Doc.text "list{"; - (if shouldHug then children - else - Doc.concat - [ - Doc.indent children; - Doc.ifBreaks (Doc.text ",") Doc.nil; - Doc.softLine; - ]); - Doc.rbrace; - ]) - | Ppat_construct (constrName, constructorArgs) -> - let constrName = printLongidentLocation constrName cmtTbl in - let argsDoc = - match constructorArgs with - | None -> Doc.nil - | Some - { - ppat_loc; - ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _); - } -> - Doc.concat - [Doc.lparen; printCommentsInside cmtTbl ppat_loc; Doc.rparen] - | Some {ppat_desc = Ppat_tuple []; ppat_loc = loc} -> - Doc.concat [Doc.lparen; printCommentsInside cmtTbl loc; Doc.rparen] - (* Some((1, 2) *) - | Some {ppat_desc = Ppat_tuple [({ppat_desc = Ppat_tuple _} as arg)]} -> - Doc.concat - [Doc.lparen; printPattern ~customLayout arg cmtTbl; Doc.rparen] - | Some {ppat_desc = Ppat_tuple patterns} -> + | Ppat_construct ({ txt = Longident.Lident "::" }, _) -> + let patterns, tail = + ParsetreeViewer.collectPatternsFromListConstruct [] p + in + let shouldHug = + match (patterns, tail) with + | ( [ pat ], + { + ppat_desc = Ppat_construct ({ txt = Longident.Lident "[]" }, _); + } ) + when ParsetreeViewer.isHuggablePattern pat -> + true + | _ -> false + in + let children = Doc.concat [ - Doc.lparen; - Doc.indent - (Doc.concat + (if shouldHug then Doc.nil else Doc.softLine); + Doc.join + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); + (match tail.Parsetree.ppat_desc with + | Ppat_construct ({ txt = Longident.Lident "[]" }, _) -> Doc.nil + | _ -> + let doc = + Doc.concat + [ Doc.text "..."; printPattern ~customLayout tail cmtTbl ] + in + let tail = printComments doc cmtTbl tail.ppat_loc in + Doc.concat [ Doc.text ","; Doc.line; tail ]); + ] + in + Doc.group + (Doc.concat + [ + Doc.text "list{"; + (if shouldHug then children + else + Doc.concat [ + Doc.indent children; + Doc.ifBreaks (Doc.text ",") Doc.nil; Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) - patterns); ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some arg -> - let argDoc = printPattern ~customLayout arg cmtTbl in - let shouldHug = ParsetreeViewer.isHuggablePattern arg in - Doc.concat - [ - Doc.lparen; - (if shouldHug then argDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [Doc.softLine; argDoc]); - Doc.trailingComma; - Doc.softLine; - ]); - Doc.rparen; - ] - in - Doc.group (Doc.concat [constrName; argsDoc]) + Doc.rbrace; + ]) + | Ppat_construct (constrName, constructorArgs) -> + let constrName = printLongidentLocation constrName cmtTbl in + let argsDoc = + match constructorArgs with + | None -> Doc.nil + | Some + { + ppat_loc; + ppat_desc = Ppat_construct ({ txt = Longident.Lident "()" }, _); + } -> + Doc.concat + [ Doc.lparen; printCommentsInside cmtTbl ppat_loc; Doc.rparen ] + | Some { ppat_desc = Ppat_tuple []; ppat_loc = loc } -> + Doc.concat + [ Doc.lparen; printCommentsInside cmtTbl loc; Doc.rparen ] + (* Some((1, 2) *) + | Some + { + ppat_desc = Ppat_tuple [ ({ ppat_desc = Ppat_tuple _ } as arg) ]; + } -> + Doc.concat + [ + Doc.lparen; printPattern ~customLayout arg cmtTbl; Doc.rparen; + ] + | Some { ppat_desc = Ppat_tuple patterns } -> + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + | Some arg -> + let argDoc = printPattern ~customLayout arg cmtTbl in + let shouldHug = ParsetreeViewer.isHuggablePattern arg in + Doc.concat + [ + Doc.lparen; + (if shouldHug then argDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [ Doc.softLine; argDoc ]); + Doc.trailingComma; + Doc.softLine; + ]); + Doc.rparen; + ] + in + Doc.group (Doc.concat [ constrName; argsDoc ]) | Ppat_variant (label, None) -> - Doc.concat [Doc.text "#"; printPolyVarIdent label] + Doc.concat [ Doc.text "#"; printPolyVarIdent label ] | Ppat_variant (label, variantArgs) -> - let variantName = Doc.concat [Doc.text "#"; printPolyVarIdent label] in - let argsDoc = - match variantArgs with - | None -> Doc.nil - | Some {ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _)} - -> - Doc.text "()" - | Some {ppat_desc = Ppat_tuple []; ppat_loc = loc} -> - Doc.concat [Doc.lparen; printCommentsInside cmtTbl loc; Doc.rparen] - (* Some((1, 2) *) - | Some {ppat_desc = Ppat_tuple [({ppat_desc = Ppat_tuple _} as arg)]} -> - Doc.concat - [Doc.lparen; printPattern ~customLayout arg cmtTbl; Doc.rparen] - | Some {ppat_desc = Ppat_tuple patterns} -> - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) - patterns); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some arg -> - let argDoc = printPattern ~customLayout arg cmtTbl in - let shouldHug = ParsetreeViewer.isHuggablePattern arg in - Doc.concat - [ - Doc.lparen; - (if shouldHug then argDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [Doc.softLine; argDoc]); - Doc.trailingComma; - Doc.softLine; - ]); - Doc.rparen; - ] - in - Doc.group (Doc.concat [variantName; argsDoc]) + let variantName = + Doc.concat [ Doc.text "#"; printPolyVarIdent label ] + in + let argsDoc = + match variantArgs with + | None -> Doc.nil + | Some + { + ppat_desc = Ppat_construct ({ txt = Longident.Lident "()" }, _); + } -> + Doc.text "()" + | Some { ppat_desc = Ppat_tuple []; ppat_loc = loc } -> + Doc.concat + [ Doc.lparen; printCommentsInside cmtTbl loc; Doc.rparen ] + (* Some((1, 2) *) + | Some + { + ppat_desc = Ppat_tuple [ ({ ppat_desc = Ppat_tuple _ } as arg) ]; + } -> + Doc.concat + [ + Doc.lparen; printPattern ~customLayout arg cmtTbl; Doc.rparen; + ] + | Some { ppat_desc = Ppat_tuple patterns } -> + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + | Some arg -> + let argDoc = printPattern ~customLayout arg cmtTbl in + let shouldHug = ParsetreeViewer.isHuggablePattern arg in + Doc.concat + [ + Doc.lparen; + (if shouldHug then argDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [ Doc.softLine; argDoc ]); + Doc.trailingComma; + Doc.softLine; + ]); + Doc.rparen; + ] + in + Doc.group (Doc.concat [ variantName; argsDoc ]) | Ppat_type ident -> - Doc.concat [Doc.text "#..."; printIdentPath ident cmtTbl] + Doc.concat [ Doc.text "#..."; printIdentPath ident cmtTbl ] | Ppat_record (rows, openFlag) -> - Doc.group - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun row -> - printPatternRecordRow ~customLayout row cmtTbl) - rows); - (match openFlag with - | Open -> Doc.concat [Doc.text ","; Doc.line; Doc.text "_"] - | Closed -> Doc.nil); - ]); - Doc.ifBreaks (Doc.text ",") Doc.nil; - Doc.softLine; - Doc.rbrace; - ]) + Doc.group + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) + (List.map + (fun row -> + printPatternRecordRow ~customLayout row cmtTbl) + rows); + (match openFlag with + | Open -> + Doc.concat [ Doc.text ","; Doc.line; Doc.text "_" ] + | Closed -> Doc.nil); + ]); + Doc.ifBreaks (Doc.text ",") Doc.nil; + Doc.softLine; + Doc.rbrace; + ]) | Ppat_exception p -> - let needsParens = - match p.ppat_desc with - | Ppat_or (_, _) | Ppat_alias (_, _) -> true - | _ -> false - in - let pat = - let p = printPattern ~customLayout p cmtTbl in - if needsParens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p - in - Doc.group (Doc.concat [Doc.text "exception"; Doc.line; pat]) + let needsParens = + match p.ppat_desc with + | Ppat_or (_, _) | Ppat_alias (_, _) -> true + | _ -> false + in + let pat = + let p = printPattern ~customLayout p cmtTbl in + if needsParens then Doc.concat [ Doc.text "("; p; Doc.text ")" ] + else p + in + Doc.group (Doc.concat [ Doc.text "exception"; Doc.line; pat ]) | Ppat_or _ -> - (* Blue | Red | Green -> [Blue; Red; Green] *) - let orChain = ParsetreeViewer.collectOrPatternChain p in - let docs = - List.mapi - (fun i pat -> - let patternDoc = printPattern ~customLayout pat cmtTbl in - Doc.concat - [ - (if i == 0 then Doc.nil - else Doc.concat [Doc.line; Doc.text "| "]); - (match pat.ppat_desc with - (* (Blue | Red) | (Green | Black) | White *) - | Ppat_or _ -> addParens patternDoc - | _ -> patternDoc); - ]) - orChain - in - let isSpreadOverMultipleLines = - match (orChain, List.rev orChain) with - | first :: _, last :: _ -> - first.ppat_loc.loc_start.pos_lnum < last.ppat_loc.loc_end.pos_lnum - | _ -> false - in - Doc.breakableGroup ~forceBreak:isSpreadOverMultipleLines (Doc.concat docs) + (* Blue | Red | Green -> [Blue; Red; Green] *) + let orChain = ParsetreeViewer.collectOrPatternChain p in + let docs = + List.mapi + (fun i pat -> + let patternDoc = printPattern ~customLayout pat cmtTbl in + Doc.concat + [ + (if i == 0 then Doc.nil + else Doc.concat [ Doc.line; Doc.text "| " ]); + (match pat.ppat_desc with + (* (Blue | Red) | (Green | Black) | White *) + | Ppat_or _ -> addParens patternDoc + | _ -> patternDoc); + ]) + orChain + in + let isSpreadOverMultipleLines = + match (orChain, List.rev orChain) with + | first :: _, last :: _ -> + first.ppat_loc.loc_start.pos_lnum < last.ppat_loc.loc_end.pos_lnum + | _ -> false + in + Doc.breakableGroup ~forceBreak:isSpreadOverMultipleLines + (Doc.concat docs) | Ppat_extension ext -> - printExtension ~customLayout ~atModuleLvl:false ext cmtTbl + printExtension ~customLayout ~atModuleLvl:false ext cmtTbl | Ppat_lazy p -> - let needsParens = - match p.ppat_desc with - | Ppat_or (_, _) | Ppat_alias (_, _) -> true - | _ -> false - in - let pat = - let p = printPattern ~customLayout p cmtTbl in - if needsParens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p - in - Doc.concat [Doc.text "lazy "; pat] + let needsParens = + match p.ppat_desc with + | Ppat_or (_, _) | Ppat_alias (_, _) -> true + | _ -> false + in + let pat = + let p = printPattern ~customLayout p cmtTbl in + if needsParens then Doc.concat [ Doc.text "("; p; Doc.text ")" ] + else p + in + Doc.concat [ Doc.text "lazy "; pat ] | Ppat_alias (p, aliasLoc) -> - let needsParens = - match p.ppat_desc with - | Ppat_or (_, _) | Ppat_alias (_, _) -> true - | _ -> false - in - let renderedPattern = - let p = printPattern ~customLayout p cmtTbl in - if needsParens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p - in - Doc.concat - [renderedPattern; Doc.text " as "; printStringLoc aliasLoc cmtTbl] + let needsParens = + match p.ppat_desc with + | Ppat_or (_, _) | Ppat_alias (_, _) -> true + | _ -> false + in + let renderedPattern = + let p = printPattern ~customLayout p cmtTbl in + if needsParens then Doc.concat [ Doc.text "("; p; Doc.text ")" ] + else p + in + Doc.concat + [ renderedPattern; Doc.text " as "; printStringLoc aliasLoc cmtTbl ] (* Note: module(P : S) is represented as *) (* Ppat_constraint(Ppat_unpack, Ptyp_package) *) | Ppat_constraint - ( {ppat_desc = Ppat_unpack stringLoc}, - {ptyp_desc = Ptyp_package packageType; ptyp_loc} ) -> - Doc.concat - [ - Doc.text "module("; - printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; - Doc.text ": "; - printComments - (printPackageType ~customLayout ~printModuleKeywordAndParens:false - packageType cmtTbl) - cmtTbl ptyp_loc; - Doc.rparen; - ] + ( { ppat_desc = Ppat_unpack stringLoc }, + { ptyp_desc = Ptyp_package packageType; ptyp_loc } ) -> + Doc.concat + [ + Doc.text "module("; + printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; + Doc.text ": "; + printComments + (printPackageType ~customLayout ~printModuleKeywordAndParens:false + packageType cmtTbl) + cmtTbl ptyp_loc; + Doc.rparen; + ] | Ppat_constraint (pattern, typ) -> - Doc.concat - [ - printPattern ~customLayout pattern cmtTbl; - Doc.text ": "; - printTypExpr ~customLayout typ cmtTbl; - ] + Doc.concat + [ + printPattern ~customLayout pattern cmtTbl; + Doc.text ": "; + printTypExpr ~customLayout typ cmtTbl; + ] (* Note: module(P : S) is represented as *) (* Ppat_constraint(Ppat_unpack, Ptyp_package) *) | Ppat_unpack stringLoc -> - Doc.concat - [ - Doc.text "module("; - printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; - Doc.rparen; - ] + Doc.concat + [ + Doc.text "module("; + printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; + Doc.rparen; + ] | Ppat_interval (a, b) -> - Doc.concat [printConstant a; Doc.text " .. "; printConstant b] + Doc.concat [ printConstant a; Doc.text " .. "; printConstant b ] | Ppat_open _ -> Doc.nil in let doc = match p.ppat_attributes with | [] -> patternWithoutAttributes | attrs -> - Doc.group - (Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; patternWithoutAttributes; - ]) + Doc.group + (Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + patternWithoutAttributes; + ]) in printComments doc cmtTbl p.ppat_loc and printPatternRecordRow ~customLayout row cmtTbl = match row with (* punned {x}*) - | ( ({Location.txt = Longident.Lident ident} as longident), - {Parsetree.ppat_desc = Ppat_var {txt; _}; ppat_attributes} ) + | ( ({ Location.txt = Longident.Lident ident } as longident), + { Parsetree.ppat_desc = Ppat_var { txt; _ }; ppat_attributes } ) when ident = txt -> - Doc.concat - [ - printOptionalLabel ppat_attributes; - printAttributes ~customLayout ppat_attributes cmtTbl; - printLidentPath longident cmtTbl; - ] + Doc.concat + [ + printOptionalLabel ppat_attributes; + printAttributes ~customLayout ppat_attributes cmtTbl; + printLidentPath longident cmtTbl; + ] | longident, pattern -> - let locForComments = - {longident.loc with loc_end = pattern.Parsetree.ppat_loc.loc_end} - in - let rhsDoc = - let doc = printPattern ~customLayout pattern cmtTbl in + let locForComments = + { longident.loc with loc_end = pattern.Parsetree.ppat_loc.loc_end } + in + let rhsDoc = + let doc = printPattern ~customLayout pattern cmtTbl in + let doc = + if Parens.patternRecordRowRhs pattern then addParens doc else doc + in + Doc.concat [ printOptionalLabel pattern.ppat_attributes; doc ] + in let doc = - if Parens.patternRecordRowRhs pattern then addParens doc else doc + Doc.group + (Doc.concat + [ + printLidentPath longident cmtTbl; + Doc.text ":"; + (if ParsetreeViewer.isHuggablePattern pattern then + Doc.concat [ Doc.space; rhsDoc ] + else Doc.indent (Doc.concat [ Doc.line; rhsDoc ])); + ]) in - Doc.concat [printOptionalLabel pattern.ppat_attributes; doc] - in - let doc = - Doc.group - (Doc.concat - [ - printLidentPath longident cmtTbl; - Doc.text ":"; - (if ParsetreeViewer.isHuggablePattern pattern then - Doc.concat [Doc.space; rhsDoc] - else Doc.indent (Doc.concat [Doc.line; rhsDoc])); - ]) - in - printComments doc cmtTbl locForComments + printComments doc cmtTbl locForComments and printExpressionWithComments ~customLayout expr cmtTbl : Doc.t = let doc = printExpression ~customLayout expr cmtTbl in @@ -231540,54 +231653,55 @@ and printIfChain ~customLayout pexp_attributes ifs elseExpr cmtTbl = let doc = match ifExpr with | ParsetreeViewer.If ifExpr -> - let condition = - if ParsetreeViewer.isBlockExpr ifExpr then - printExpressionBlock ~customLayout ~braces:true ifExpr cmtTbl - else + let condition = + if ParsetreeViewer.isBlockExpr ifExpr then + printExpressionBlock ~customLayout ~braces:true ifExpr + cmtTbl + else + let doc = + printExpressionWithComments ~customLayout ifExpr cmtTbl + in + match Parens.expr ifExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc ifExpr braces + | Nothing -> Doc.ifBreaks (addParens doc) doc + in + Doc.concat + [ + ifTxt; + Doc.group condition; + Doc.space; + (let thenExpr = + match ParsetreeViewer.processBracesAttr thenExpr with + (* This case only happens when coming from Reason, we strip braces *) + | Some _, expr -> expr + | _ -> thenExpr + in + printExpressionBlock ~customLayout ~braces:true thenExpr + cmtTbl); + ] + | IfLet (pattern, conditionExpr) -> + let conditionDoc = let doc = - printExpressionWithComments ~customLayout ifExpr cmtTbl + printExpressionWithComments ~customLayout conditionExpr + cmtTbl in - match Parens.expr ifExpr with + match Parens.expr conditionExpr with | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc ifExpr braces - | Nothing -> Doc.ifBreaks (addParens doc) doc - in - Doc.concat - [ - ifTxt; - Doc.group condition; - Doc.space; - (let thenExpr = - match ParsetreeViewer.processBracesAttr thenExpr with - (* This case only happens when coming from Reason, we strip braces *) - | Some _, expr -> expr - | _ -> thenExpr - in - printExpressionBlock ~customLayout ~braces:true thenExpr - cmtTbl); - ] - | IfLet (pattern, conditionExpr) -> - let conditionDoc = - let doc = - printExpressionWithComments ~customLayout conditionExpr - cmtTbl + | Braced braces -> printBraces doc conditionExpr braces + | Nothing -> doc in - match Parens.expr conditionExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc conditionExpr braces - | Nothing -> doc - in - Doc.concat - [ - ifTxt; - Doc.text "let "; - printPattern ~customLayout pattern cmtTbl; - Doc.text " = "; - conditionDoc; - Doc.space; - printExpressionBlock ~customLayout ~braces:true thenExpr - cmtTbl; - ] + Doc.concat + [ + ifTxt; + Doc.text "let "; + printPattern ~customLayout pattern cmtTbl; + Doc.text " = "; + conditionDoc; + Doc.space; + printExpressionBlock ~customLayout ~braces:true thenExpr + cmtTbl; + ] in printLeadingComments doc cmtTbl.leading outerLoc) ifs) @@ -231596,707 +231710,736 @@ and printIfChain ~customLayout pexp_attributes ifs elseExpr cmtTbl = match elseExpr with | None -> Doc.nil | Some expr -> - Doc.concat - [ - Doc.text " else "; - printExpressionBlock ~customLayout ~braces:true expr cmtTbl; - ] + Doc.concat + [ + Doc.text " else "; + printExpressionBlock ~customLayout ~braces:true expr cmtTbl; + ] in let attrs = ParsetreeViewer.filterFragileMatchAttributes pexp_attributes in - Doc.concat [printAttributes ~customLayout attrs cmtTbl; ifDocs; elseDoc] + Doc.concat [ printAttributes ~customLayout attrs cmtTbl; ifDocs; elseDoc ] and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = let printedExpression = match e.pexp_desc with | Parsetree.Pexp_constant c -> - printConstant ~templateLiteral:(ParsetreeViewer.isTemplateLiteral e) c + printConstant ~templateLiteral:(ParsetreeViewer.isTemplateLiteral e) c | Pexp_construct _ when ParsetreeViewer.hasJsxAttribute e.pexp_attributes -> - printJsxFragment ~customLayout e cmtTbl - | Pexp_construct ({txt = Longident.Lident "()"}, _) -> Doc.text "()" - | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> - Doc.concat - [Doc.text "list{"; printCommentsInside cmtTbl e.pexp_loc; Doc.rbrace] - | Pexp_construct ({txt = Longident.Lident "::"}, _) -> - let expressions, spread = ParsetreeViewer.collectListExpressions e in - let spreadDoc = - match spread with - | Some expr -> - Doc.concat - [ - Doc.text ","; - Doc.line; - Doc.dotdotdot; - (let doc = - printExpressionWithComments ~customLayout expr cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); - ] - | None -> Doc.nil - in - Doc.group - (Doc.concat - [ - Doc.text "list{"; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun expr -> - let doc = - printExpressionWithComments ~customLayout expr - cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - expressions); - spreadDoc; - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ]) + printJsxFragment ~customLayout e cmtTbl + | Pexp_construct ({ txt = Longident.Lident "()" }, _) -> Doc.text "()" + | Pexp_construct ({ txt = Longident.Lident "[]" }, _) -> + Doc.concat + [ + Doc.text "list{"; printCommentsInside cmtTbl e.pexp_loc; Doc.rbrace; + ] + | Pexp_construct ({ txt = Longident.Lident "::" }, _) -> + let expressions, spread = ParsetreeViewer.collectListExpressions e in + let spreadDoc = + match spread with + | Some expr -> + Doc.concat + [ + Doc.text ","; + Doc.line; + Doc.dotdotdot; + (let doc = + printExpressionWithComments ~customLayout expr cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + ] + | None -> Doc.nil + in + Doc.group + (Doc.concat + [ + Doc.text "list{"; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) + (List.map + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + expressions); + spreadDoc; + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ]) | Pexp_construct (longidentLoc, args) -> - let constr = printLongidentLocation longidentLoc cmtTbl in - let args = - match args with - | None -> Doc.nil - | Some {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)} - -> - Doc.text "()" - (* Some((1, 2)) *) - | Some {pexp_desc = Pexp_tuple [({pexp_desc = Pexp_tuple _} as arg)]} -> - Doc.concat - [ - Doc.lparen; - (let doc = printExpressionWithComments ~customLayout arg cmtTbl in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc); - Doc.rparen; - ] - | Some {pexp_desc = Pexp_tuple args} -> - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun expr -> - let doc = - printExpressionWithComments ~customLayout expr - cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some arg -> - let argDoc = - let doc = printExpressionWithComments ~customLayout arg cmtTbl in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc - in - let shouldHug = ParsetreeViewer.isHuggableExpression arg in - Doc.concat - [ - Doc.lparen; - (if shouldHug then argDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [Doc.softLine; argDoc]); - Doc.trailingComma; - Doc.softLine; - ]); - Doc.rparen; - ] - in - Doc.group (Doc.concat [constr; args]) + let constr = printLongidentLocation longidentLoc cmtTbl in + let args = + match args with + | None -> Doc.nil + | Some + { + pexp_desc = Pexp_construct ({ txt = Longident.Lident "()" }, _); + } -> + Doc.text "()" + (* Some((1, 2)) *) + | Some + { + pexp_desc = Pexp_tuple [ ({ pexp_desc = Pexp_tuple _ } as arg) ]; + } -> + Doc.concat + [ + Doc.lparen; + (let doc = + printExpressionWithComments ~customLayout arg cmtTbl + in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc); + Doc.rparen; + ] + | Some { pexp_desc = Pexp_tuple args } -> + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + | Some arg -> + let argDoc = + let doc = + printExpressionWithComments ~customLayout arg cmtTbl + in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc + in + let shouldHug = ParsetreeViewer.isHuggableExpression arg in + Doc.concat + [ + Doc.lparen; + (if shouldHug then argDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [ Doc.softLine; argDoc ]); + Doc.trailingComma; + Doc.softLine; + ]); + Doc.rparen; + ] + in + Doc.group (Doc.concat [ constr; args ]) | Pexp_ident path -> printLidentPath path cmtTbl | Pexp_tuple exprs -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun expr -> - let doc = - printExpressionWithComments ~customLayout expr - cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - exprs); - ]); - Doc.ifBreaks (Doc.text ",") Doc.nil; - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) + (List.map + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + exprs); + ]); + Doc.ifBreaks (Doc.text ",") Doc.nil; + Doc.softLine; + Doc.rparen; + ]) | Pexp_array [] -> - Doc.concat - [Doc.lbracket; printCommentsInside cmtTbl e.pexp_loc; Doc.rbracket] - | Pexp_array exprs -> - Doc.group - (Doc.concat - [ - Doc.lbracket; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun expr -> - let doc = - printExpressionWithComments ~customLayout expr - cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - exprs); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbracket; - ]) - | Pexp_variant (label, args) -> - let variantName = Doc.concat [Doc.text "#"; printPolyVarIdent label] in - let args = - match args with - | None -> Doc.nil - | Some {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)} - -> - Doc.text "()" - (* #poly((1, 2) *) - | Some {pexp_desc = Pexp_tuple [({pexp_desc = Pexp_tuple _} as arg)]} -> - Doc.concat - [ - Doc.lparen; - (let doc = printExpressionWithComments ~customLayout arg cmtTbl in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc); - Doc.rparen; - ] - | Some {pexp_desc = Pexp_tuple args} -> - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun expr -> - let doc = - printExpressionWithComments ~customLayout expr - cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some arg -> - let argDoc = - let doc = printExpressionWithComments ~customLayout arg cmtTbl in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc - in - let shouldHug = ParsetreeViewer.isHuggableExpression arg in - Doc.concat - [ - Doc.lparen; - (if shouldHug then argDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [Doc.softLine; argDoc]); - Doc.trailingComma; - Doc.softLine; - ]); - Doc.rparen; - ] - in - Doc.group (Doc.concat [variantName; args]) - | Pexp_record (rows, spreadExpr) -> - if rows = [] then Doc.concat - [Doc.lbrace; printCommentsInside cmtTbl e.pexp_loc; Doc.rbrace] - else - let spread = - match spreadExpr with - | None -> Doc.nil - | Some expr -> - Doc.concat - [ - Doc.dotdotdot; - (let doc = - printExpressionWithComments ~customLayout expr cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); - Doc.comma; - Doc.line; - ] - in - (* If the record is written over multiple lines, break automatically - * `let x = {a: 1, b: 3}` -> same line, break when line-width exceeded - * `let x = { - * a: 1, - * b: 2, - * }` -> record is written on multiple lines, break the group *) - let forceBreak = - e.pexp_loc.loc_start.pos_lnum < e.pexp_loc.loc_end.pos_lnum - in - let punningAllowed = - match (spreadExpr, rows) with - | None, [_] -> false (* disallow punning for single-element records *) - | _ -> true - in - Doc.breakableGroup ~forceBreak + [ Doc.lbracket; printCommentsInside cmtTbl e.pexp_loc; Doc.rbracket ] + | Pexp_array exprs -> + Doc.group (Doc.concat [ - Doc.lbrace; + Doc.lbracket; Doc.indent (Doc.concat [ Doc.softLine; - spread; Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) (List.map - (fun row -> - printExpressionRecordRow ~customLayout row cmtTbl - punningAllowed) - rows); + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + exprs); ]); Doc.trailingComma; Doc.softLine; - Doc.rbrace; + Doc.rbracket; ]) - | Pexp_extension extension -> ( - match extension with - | ( {txt = "bs.obj" | "obj"}, - PStr - [ + | Pexp_variant (label, args) -> + let variantName = + Doc.concat [ Doc.text "#"; printPolyVarIdent label ] + in + let args = + match args with + | None -> Doc.nil + | Some { - pstr_loc = loc; - pstr_desc = Pstr_eval ({pexp_desc = Pexp_record (rows, _)}, []); - }; - ] ) -> - (* If the object is written over multiple lines, break automatically - * `let x = {"a": 1, "b": 3}` -> same line, break when line-width exceeded - * `let x = { - * "a": 1, - * "b": 2, - * }` -> object is written on multiple lines, break the group *) - let forceBreak = loc.loc_start.pos_lnum < loc.loc_end.pos_lnum in - Doc.breakableGroup ~forceBreak + pexp_desc = Pexp_construct ({ txt = Longident.Lident "()" }, _); + } -> + Doc.text "()" + (* #poly((1, 2) *) + | Some + { + pexp_desc = Pexp_tuple [ ({ pexp_desc = Pexp_tuple _ } as arg) ]; + } -> + Doc.concat + [ + Doc.lparen; + (let doc = + printExpressionWithComments ~customLayout arg cmtTbl + in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc); + Doc.rparen; + ] + | Some { pexp_desc = Pexp_tuple args } -> + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + | Some arg -> + let argDoc = + let doc = + printExpressionWithComments ~customLayout arg cmtTbl + in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc + in + let shouldHug = ParsetreeViewer.isHuggableExpression arg in + Doc.concat + [ + Doc.lparen; + (if shouldHug then argDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [ Doc.softLine; argDoc ]); + Doc.trailingComma; + Doc.softLine; + ]); + Doc.rparen; + ] + in + Doc.group (Doc.concat [ variantName; args ]) + | Pexp_record (rows, spreadExpr) -> + if rows = [] then + Doc.concat + [ Doc.lbrace; printCommentsInside cmtTbl e.pexp_loc; Doc.rbrace ] + else + let spread = + match spreadExpr with + | None -> Doc.nil + | Some expr -> + Doc.concat + [ + Doc.dotdotdot; + (let doc = + printExpressionWithComments ~customLayout expr cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + Doc.comma; + Doc.line; + ] + in + (* If the record is written over multiple lines, break automatically + * `let x = {a: 1, b: 3}` -> same line, break when line-width exceeded + * `let x = { + * a: 1, + * b: 2, + * }` -> record is written on multiple lines, break the group *) + let forceBreak = + e.pexp_loc.loc_start.pos_lnum < e.pexp_loc.loc_end.pos_lnum + in + let punningAllowed = + match (spreadExpr, rows) with + | None, [ _ ] -> + false (* disallow punning for single-element records *) + | _ -> true + in + Doc.breakableGroup ~forceBreak + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.softLine; + spread; + Doc.join + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) + (List.map + (fun row -> + printExpressionRecordRow ~customLayout row cmtTbl + punningAllowed) + rows); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ]) + | Pexp_extension extension -> ( + match extension with + | ( { txt = "bs.obj" | "obj" }, + PStr + [ + { + pstr_loc = loc; + pstr_desc = + Pstr_eval ({ pexp_desc = Pexp_record (rows, _) }, []); + }; + ] ) -> + (* If the object is written over multiple lines, break automatically + * `let x = {"a": 1, "b": 3}` -> same line, break when line-width exceeded + * `let x = { + * "a": 1, + * "b": 2, + * }` -> object is written on multiple lines, break the group *) + let forceBreak = loc.loc_start.pos_lnum < loc.loc_end.pos_lnum in + Doc.breakableGroup ~forceBreak + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) + (List.map + (fun row -> + printBsObjectRow ~customLayout row cmtTbl) + rows); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ]) + | extension -> + printExtension ~customLayout ~atModuleLvl:false extension cmtTbl) + | Pexp_apply (e, [ (Nolabel, { pexp_desc = Pexp_array subLists }) ]) + when ParsetreeViewer.isSpreadBeltListConcat e -> + printBeltListConcatApply ~customLayout subLists cmtTbl + | Pexp_apply _ -> + if ParsetreeViewer.isUnaryExpression e then + printUnaryExpression ~customLayout e cmtTbl + else if ParsetreeViewer.isTemplateLiteral e then + printTemplateLiteral ~customLayout e cmtTbl + else if ParsetreeViewer.isBinaryExpression e then + printBinaryExpression ~customLayout e cmtTbl + else printPexpApply ~customLayout e cmtTbl + | Pexp_unreachable -> Doc.dot + | Pexp_field (expr, longidentLoc) -> + let lhs = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.fieldExpr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [ lhs; Doc.dot; printLidentPath longidentLoc cmtTbl ] + | Pexp_setfield (expr1, longidentLoc, expr2) -> + printSetFieldExpr ~customLayout e.pexp_attributes expr1 longidentLoc + expr2 e.pexp_loc cmtTbl + | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) + when ParsetreeViewer.isTernaryExpr e -> + let parts, alternate = ParsetreeViewer.collectTernaryParts e in + let ternaryDoc = + match parts with + | (condition1, consequent1) :: rest -> + Doc.group + (Doc.concat + [ + printTernaryOperand ~customLayout condition1 cmtTbl; + Doc.indent + (Doc.concat + [ + Doc.line; + Doc.indent + (Doc.concat + [ + Doc.text "? "; + printTernaryOperand ~customLayout consequent1 + cmtTbl; + ]); + Doc.concat + (List.map + (fun (condition, consequent) -> + Doc.concat + [ + Doc.line; + Doc.text ": "; + printTernaryOperand ~customLayout + condition cmtTbl; + Doc.line; + Doc.text "? "; + printTernaryOperand ~customLayout + consequent cmtTbl; + ]) + rest); + Doc.line; + Doc.text ": "; + Doc.indent + (printTernaryOperand ~customLayout alternate + cmtTbl); + ]); + ]) + | _ -> Doc.nil + in + let attrs = ParsetreeViewer.filterTernaryAttributes e.pexp_attributes in + let needsParens = + match ParsetreeViewer.filterParsingAttrs attrs with + | [] -> false + | _ -> true + in + Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + (if needsParens then addParens ternaryDoc else ternaryDoc); + ] + | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) -> + let ifs, elseExpr = ParsetreeViewer.collectIfExpressions e in + printIfChain ~customLayout e.pexp_attributes ifs elseExpr cmtTbl + | Pexp_while (expr1, expr2) -> + let condition = + let doc = printExpressionWithComments ~customLayout expr1 cmtTbl in + match Parens.expr expr1 with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr1 braces + | Nothing -> doc + in + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.text "while "; + (if ParsetreeViewer.isBlockExpr expr1 then condition + else Doc.group (Doc.ifBreaks (addParens condition) condition)); + Doc.space; + printExpressionBlock ~customLayout ~braces:true expr2 cmtTbl; + ]) + | Pexp_for (pattern, fromExpr, toExpr, directionFlag, body) -> + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.text "for "; + printPattern ~customLayout pattern cmtTbl; + Doc.text " in "; + (let doc = + printExpressionWithComments ~customLayout fromExpr cmtTbl + in + match Parens.expr fromExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc fromExpr braces + | Nothing -> doc); + printDirectionFlag directionFlag; + (let doc = + printExpressionWithComments ~customLayout toExpr cmtTbl + in + match Parens.expr toExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc toExpr braces + | Nothing -> doc); + Doc.space; + printExpressionBlock ~customLayout ~braces:true body cmtTbl; + ]) + | Pexp_constraint + ( { pexp_desc = Pexp_pack modExpr }, + { ptyp_desc = Ptyp_package packageType; ptyp_loc } ) -> + Doc.group (Doc.concat [ - Doc.lbrace; + Doc.text "module("; Doc.indent (Doc.concat [ Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun row -> - printBsObjectRow ~customLayout row cmtTbl) - rows); + printModExpr ~customLayout modExpr cmtTbl; + Doc.text ": "; + printComments + (printPackageType ~customLayout + ~printModuleKeywordAndParens:false packageType cmtTbl) + cmtTbl ptyp_loc; ]); - Doc.trailingComma; Doc.softLine; - Doc.rbrace; + Doc.rparen; ]) - | extension -> - printExtension ~customLayout ~atModuleLvl:false extension cmtTbl) - | Pexp_apply (e, [(Nolabel, {pexp_desc = Pexp_array subLists})]) - when ParsetreeViewer.isSpreadBeltListConcat e -> - printBeltListConcatApply ~customLayout subLists cmtTbl - | Pexp_apply _ -> - if ParsetreeViewer.isUnaryExpression e then - printUnaryExpression ~customLayout e cmtTbl - else if ParsetreeViewer.isTemplateLiteral e then - printTemplateLiteral ~customLayout e cmtTbl - else if ParsetreeViewer.isBinaryExpression e then - printBinaryExpression ~customLayout e cmtTbl - else printPexpApply ~customLayout e cmtTbl - | Pexp_unreachable -> Doc.dot - | Pexp_field (expr, longidentLoc) -> - let lhs = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.fieldExpr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat [lhs; Doc.dot; printLidentPath longidentLoc cmtTbl] - | Pexp_setfield (expr1, longidentLoc, expr2) -> - printSetFieldExpr ~customLayout e.pexp_attributes expr1 longidentLoc expr2 - e.pexp_loc cmtTbl - | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) - when ParsetreeViewer.isTernaryExpr e -> - let parts, alternate = ParsetreeViewer.collectTernaryParts e in - let ternaryDoc = - match parts with - | (condition1, consequent1) :: rest -> - Doc.group - (Doc.concat - [ - printTernaryOperand ~customLayout condition1 cmtTbl; - Doc.indent - (Doc.concat - [ - Doc.line; - Doc.indent - (Doc.concat - [ - Doc.text "? "; - printTernaryOperand ~customLayout consequent1 - cmtTbl; - ]); - Doc.concat - (List.map - (fun (condition, consequent) -> - Doc.concat - [ - Doc.line; - Doc.text ": "; - printTernaryOperand ~customLayout condition - cmtTbl; - Doc.line; - Doc.text "? "; - printTernaryOperand ~customLayout consequent - cmtTbl; - ]) - rest); - Doc.line; - Doc.text ": "; - Doc.indent - (printTernaryOperand ~customLayout alternate cmtTbl); - ]); - ]) - | _ -> Doc.nil - in - let attrs = ParsetreeViewer.filterTernaryAttributes e.pexp_attributes in - let needsParens = - match ParsetreeViewer.filterParsingAttrs attrs with - | [] -> false - | _ -> true - in - Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - (if needsParens then addParens ternaryDoc else ternaryDoc); - ] - | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) -> - let ifs, elseExpr = ParsetreeViewer.collectIfExpressions e in - printIfChain ~customLayout e.pexp_attributes ifs elseExpr cmtTbl - | Pexp_while (expr1, expr2) -> - let condition = - let doc = printExpressionWithComments ~customLayout expr1 cmtTbl in - match Parens.expr expr1 with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr1 braces - | Nothing -> doc - in - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.text "while "; - (if ParsetreeViewer.isBlockExpr expr1 then condition - else Doc.group (Doc.ifBreaks (addParens condition) condition)); - Doc.space; - printExpressionBlock ~customLayout ~braces:true expr2 cmtTbl; - ]) - | Pexp_for (pattern, fromExpr, toExpr, directionFlag, body) -> - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.text "for "; - printPattern ~customLayout pattern cmtTbl; - Doc.text " in "; - (let doc = - printExpressionWithComments ~customLayout fromExpr cmtTbl - in - match Parens.expr fromExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc fromExpr braces - | Nothing -> doc); - printDirectionFlag directionFlag; - (let doc = - printExpressionWithComments ~customLayout toExpr cmtTbl - in - match Parens.expr toExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc toExpr braces - | Nothing -> doc); - Doc.space; - printExpressionBlock ~customLayout ~braces:true body cmtTbl; - ]) - | Pexp_constraint - ( {pexp_desc = Pexp_pack modExpr}, - {ptyp_desc = Ptyp_package packageType; ptyp_loc} ) -> - Doc.group - (Doc.concat - [ - Doc.text "module("; - Doc.indent - (Doc.concat - [ - Doc.softLine; - printModExpr ~customLayout modExpr cmtTbl; - Doc.text ": "; - printComments - (printPackageType ~customLayout - ~printModuleKeywordAndParens:false packageType cmtTbl) - cmtTbl ptyp_loc; - ]); - Doc.softLine; - Doc.rparen; - ]) | Pexp_constraint (expr, typ) -> - let exprDoc = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat [exprDoc; Doc.text ": "; printTypExpr ~customLayout typ cmtTbl] - | Pexp_letmodule ({txt = _modName}, _modExpr, _expr) -> - printExpressionBlock ~customLayout ~braces:true e cmtTbl + let exprDoc = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat + [ exprDoc; Doc.text ": "; printTypExpr ~customLayout typ cmtTbl ] + | Pexp_letmodule ({ txt = _modName }, _modExpr, _expr) -> + printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_letexception (_extensionConstructor, _expr) -> - printExpressionBlock ~customLayout ~braces:true e cmtTbl + printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_assert expr -> - let rhs = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.lazyOrAssertOrAwaitExprRhs expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat [Doc.text "assert "; rhs] + let rhs = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.lazyOrAssertOrAwaitExprRhs expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [ Doc.text "assert "; rhs ] | Pexp_lazy expr -> - let rhs = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.lazyOrAssertOrAwaitExprRhs expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.group (Doc.concat [Doc.text "lazy "; rhs]) + let rhs = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.lazyOrAssertOrAwaitExprRhs expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.group (Doc.concat [ Doc.text "lazy "; rhs ]) | Pexp_open (_overrideFlag, _longidentLoc, _expr) -> - printExpressionBlock ~customLayout ~braces:true e cmtTbl + printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_pack modExpr -> - Doc.group - (Doc.concat - [ - Doc.text "module("; - Doc.indent - (Doc.concat - [Doc.softLine; printModExpr ~customLayout modExpr cmtTbl]); - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + Doc.text "module("; + Doc.indent + (Doc.concat + [ Doc.softLine; printModExpr ~customLayout modExpr cmtTbl ]); + Doc.softLine; + Doc.rparen; + ]) | Pexp_sequence _ -> - printExpressionBlock ~customLayout ~braces:true e cmtTbl + printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_let _ -> printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_fun ( Nolabel, None, - {ppat_desc = Ppat_var {txt = "__x"}}, - {pexp_desc = Pexp_apply _} ) -> - (* (__x) => f(a, __x, c) -----> f(a, _, c) *) - printExpressionWithComments ~customLayout - (ParsetreeViewer.rewriteUnderscoreApply e) - cmtTbl + { ppat_desc = Ppat_var { txt = "__x" } }, + { pexp_desc = Pexp_apply _ } ) -> + (* (__x) => f(a, __x, c) -----> f(a, _, c) *) + printExpressionWithComments ~customLayout + (ParsetreeViewer.rewriteUnderscoreApply e) + cmtTbl | Pexp_fun _ | Pexp_newtype _ -> - let attrsOnArrow, parameters, returnExpr = ParsetreeViewer.funExpr e in - let ParsetreeViewer.{async; uncurried; attributes = attrs} = - ParsetreeViewer.processFunctionAttributes attrsOnArrow - in - let returnExpr, typConstraint = - match returnExpr.pexp_desc with - | Pexp_constraint (expr, typ) -> - ( { - expr with - pexp_attributes = - List.concat [expr.pexp_attributes; returnExpr.pexp_attributes]; - }, - Some typ ) - | _ -> (returnExpr, None) - in - let hasConstraint = - match typConstraint with - | Some _ -> true - | None -> false - in - let parametersDoc = - printExprFunParameters ~customLayout ~inCallback:NoCallback ~uncurried - ~async ~hasConstraint parameters cmtTbl - in - let returnExprDoc = - let optBraces, _ = ParsetreeViewer.processBracesAttr returnExpr in - let shouldInline = - match (returnExpr.pexp_desc, optBraces) with - | _, Some _ -> true - | ( ( Pexp_array _ | Pexp_tuple _ - | Pexp_construct (_, Some _) - | Pexp_record _ ), - _ ) -> - true - | _ -> false + let attrsOnArrow, parameters, returnExpr = ParsetreeViewer.funExpr e in + let ParsetreeViewer.{ async; uncurried; attributes = attrs } = + ParsetreeViewer.processFunctionAttributes attrsOnArrow in - let shouldIndent = + let returnExpr, typConstraint = match returnExpr.pexp_desc with - | Pexp_sequence _ | Pexp_let _ | Pexp_letmodule _ - | Pexp_letexception _ | Pexp_open _ -> - false - | _ -> true + | Pexp_constraint (expr, typ) -> + ( { + expr with + pexp_attributes = + List.concat + [ expr.pexp_attributes; returnExpr.pexp_attributes ]; + }, + Some typ ) + | _ -> (returnExpr, None) in - let returnDoc = - let doc = - printExpressionWithComments ~customLayout returnExpr cmtTbl + let hasConstraint = + match typConstraint with Some _ -> true | None -> false + in + let parametersDoc = + printExprFunParameters ~customLayout ~inCallback:NoCallback ~uncurried + ~async ~hasConstraint parameters cmtTbl + in + let returnExprDoc = + let optBraces, _ = ParsetreeViewer.processBracesAttr returnExpr in + let shouldInline = + match (returnExpr.pexp_desc, optBraces) with + | _, Some _ -> true + | ( ( Pexp_array _ | Pexp_tuple _ + | Pexp_construct (_, Some _) + | Pexp_record _ ), + _ ) -> + true + | _ -> false + in + let shouldIndent = + match returnExpr.pexp_desc with + | Pexp_sequence _ | Pexp_let _ | Pexp_letmodule _ + | Pexp_letexception _ | Pexp_open _ -> + false + | _ -> true + in + let returnDoc = + let doc = + printExpressionWithComments ~customLayout returnExpr cmtTbl + in + match Parens.expr returnExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc returnExpr braces + | Nothing -> doc in - match Parens.expr returnExpr with + if shouldInline then Doc.concat [ Doc.space; returnDoc ] + else + Doc.group + (if shouldIndent then + Doc.indent (Doc.concat [ Doc.line; returnDoc ]) + else Doc.concat [ Doc.space; returnDoc ]) + in + let typConstraintDoc = + match typConstraint with + | Some typ -> + let typDoc = + let doc = printTypExpr ~customLayout typ cmtTbl in + if Parens.arrowReturnTypExpr typ then addParens doc else doc + in + Doc.concat [ Doc.text ": "; typDoc ] + | _ -> Doc.nil + in + let attrs = printAttributes ~customLayout attrs cmtTbl in + Doc.group + (Doc.concat + [ + attrs; + parametersDoc; + typConstraintDoc; + Doc.text " =>"; + returnExprDoc; + ]) + | Pexp_try (expr, cases) -> + let exprDoc = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc returnExpr braces + | Braced braces -> printBraces doc expr braces | Nothing -> doc in - if shouldInline then Doc.concat [Doc.space; returnDoc] - else - Doc.group - (if shouldIndent then Doc.indent (Doc.concat [Doc.line; returnDoc]) - else Doc.concat [Doc.space; returnDoc]) - in - let typConstraintDoc = - match typConstraint with - | Some typ -> - let typDoc = - let doc = printTypExpr ~customLayout typ cmtTbl in - if Parens.arrowReturnTypExpr typ then addParens doc else doc - in - Doc.concat [Doc.text ": "; typDoc] - | _ -> Doc.nil - in - let attrs = printAttributes ~customLayout attrs cmtTbl in - Doc.group - (Doc.concat - [ - attrs; - parametersDoc; - typConstraintDoc; - Doc.text " =>"; - returnExprDoc; - ]) - | Pexp_try (expr, cases) -> - let exprDoc = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat - [ - Doc.text "try "; - exprDoc; - Doc.text " catch "; - printCases ~customLayout cases cmtTbl; - ] - | Pexp_match (_, [_; _]) when ParsetreeViewer.isIfLetExpr e -> - let ifs, elseExpr = ParsetreeViewer.collectIfExpressions e in - printIfChain ~customLayout e.pexp_attributes ifs elseExpr cmtTbl + Doc.concat + [ + Doc.text "try "; + exprDoc; + Doc.text " catch "; + printCases ~customLayout cases cmtTbl; + ] + | Pexp_match (_, [ _; _ ]) when ParsetreeViewer.isIfLetExpr e -> + let ifs, elseExpr = ParsetreeViewer.collectIfExpressions e in + printIfChain ~customLayout e.pexp_attributes ifs elseExpr cmtTbl | Pexp_match (expr, cases) -> - let exprDoc = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat - [ - Doc.text "switch "; - exprDoc; - Doc.space; - printCases ~customLayout cases cmtTbl; - ] + let exprDoc = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat + [ + Doc.text "switch "; + exprDoc; + Doc.space; + printCases ~customLayout cases cmtTbl; + ] | Pexp_function cases -> - Doc.concat - [Doc.text "x => switch x "; printCases ~customLayout cases cmtTbl] + Doc.concat + [ Doc.text "x => switch x "; printCases ~customLayout cases cmtTbl ] | Pexp_coerce (expr, typOpt, typ) -> - let docExpr = printExpressionWithComments ~customLayout expr cmtTbl in - let docTyp = printTypExpr ~customLayout typ cmtTbl in - let ofType = - match typOpt with - | None -> Doc.nil - | Some typ1 -> - Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ1 cmtTbl] - in - Doc.concat - [Doc.lparen; docExpr; ofType; Doc.text " :> "; docTyp; Doc.rparen] + let docExpr = printExpressionWithComments ~customLayout expr cmtTbl in + let docTyp = printTypExpr ~customLayout typ cmtTbl in + let ofType = + match typOpt with + | None -> Doc.nil + | Some typ1 -> + Doc.concat + [ Doc.text ": "; printTypExpr ~customLayout typ1 cmtTbl ] + in + Doc.concat + [ Doc.lparen; docExpr; ofType; Doc.text " :> "; docTyp; Doc.rparen ] | Pexp_send (parentExpr, label) -> - let parentDoc = - let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces - | Nothing -> doc - in - let member = - let memberDoc = printComments (Doc.text label.txt) cmtTbl label.loc in - Doc.concat [Doc.text "\""; memberDoc; Doc.text "\""] - in - Doc.group (Doc.concat [parentDoc; Doc.lbracket; member; Doc.rbracket]) + let parentDoc = + let doc = + printExpressionWithComments ~customLayout parentExpr cmtTbl + in + match Parens.unaryExprOperand parentExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc parentExpr braces + | Nothing -> doc + in + let member = + let memberDoc = printComments (Doc.text label.txt) cmtTbl label.loc in + Doc.concat [ Doc.text "\""; memberDoc; Doc.text "\"" ] + in + Doc.group (Doc.concat [ parentDoc; Doc.lbracket; member; Doc.rbracket ]) | Pexp_new _ -> Doc.text "Pexp_new not impemented in printer" | Pexp_setinstvar _ -> Doc.text "Pexp_setinstvar not impemented in printer" | Pexp_override _ -> Doc.text "Pexp_override not impemented in printer" @@ -232313,7 +232456,7 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = pexp_attributes = List.filter (function - | {Location.txt = "res.await" | "ns.braces"}, _ -> false + | { Location.txt = "res.await" | "ns.braces" }, _ -> false | _ -> true) e.pexp_attributes; } @@ -232322,55 +232465,53 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = | Braced braces -> printBraces printedExpression e braces | Nothing -> printedExpression in - Doc.concat [Doc.text "await "; rhs] + Doc.concat [ Doc.text "await "; rhs ] else printedExpression in let shouldPrintItsOwnAttributes = match e.pexp_desc with | Pexp_apply _ | Pexp_fun _ | Pexp_newtype _ | Pexp_setfield _ | Pexp_ifthenelse _ -> - true + true | Pexp_match _ when ParsetreeViewer.isIfLetExpr e -> true | Pexp_construct _ when ParsetreeViewer.hasJsxAttribute e.pexp_attributes -> - true + true | _ -> false in match e.pexp_attributes with | [] -> exprWithAwait | attrs when not shouldPrintItsOwnAttributes -> - Doc.group - (Doc.concat [printAttributes ~customLayout attrs cmtTbl; exprWithAwait]) + Doc.group + (Doc.concat + [ printAttributes ~customLayout attrs cmtTbl; exprWithAwait ]) | _ -> exprWithAwait and printPexpFun ~customLayout ~inCallback e cmtTbl = let attrsOnArrow, parameters, returnExpr = ParsetreeViewer.funExpr e in - let ParsetreeViewer.{async; uncurried; attributes = attrs} = + let ParsetreeViewer.{ async; uncurried; attributes = attrs } = ParsetreeViewer.processFunctionAttributes attrsOnArrow in let returnExpr, typConstraint = match returnExpr.pexp_desc with | Pexp_constraint (expr, typ) -> - ( { - expr with - pexp_attributes = - List.concat [expr.pexp_attributes; returnExpr.pexp_attributes]; - }, - Some typ ) + ( { + expr with + pexp_attributes = + List.concat [ expr.pexp_attributes; returnExpr.pexp_attributes ]; + }, + Some typ ) | _ -> (returnExpr, None) in let parametersDoc = printExprFunParameters ~customLayout ~inCallback ~async ~uncurried - ~hasConstraint: - (match typConstraint with - | Some _ -> true - | None -> false) + ~hasConstraint:(match typConstraint with Some _ -> true | None -> false) parameters cmtTbl in let returnShouldIndent = match returnExpr.pexp_desc with | Pexp_sequence _ | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ -> - false + false | _ -> true in let returnExprDoc = @@ -232382,7 +232523,7 @@ and printPexpFun ~customLayout ~inCallback e cmtTbl = | Pexp_construct (_, Some _) | Pexp_record _ ), _ ) -> - true + true | _ -> false in let returnDoc = @@ -232392,23 +232533,23 @@ and printPexpFun ~customLayout ~inCallback e cmtTbl = | Braced braces -> printBraces doc returnExpr braces | Nothing -> doc in - if shouldInline then Doc.concat [Doc.space; returnDoc] + if shouldInline then Doc.concat [ Doc.space; returnDoc ] else Doc.group (if returnShouldIndent then Doc.concat [ - Doc.indent (Doc.concat [Doc.line; returnDoc]); + Doc.indent (Doc.concat [ Doc.line; returnDoc ]); (match inCallback with | FitsOnOneLine | ArgumentsFitOnOneLine -> Doc.softLine | _ -> Doc.nil); ] - else Doc.concat [Doc.space; returnDoc]) + else Doc.concat [ Doc.space; returnDoc ]) in let typConstraintDoc = match typConstraint with | Some typ -> - Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ cmtTbl] + Doc.concat [ Doc.text ": "; printTypExpr ~customLayout typ cmtTbl ] | _ -> Doc.nil in Doc.concat @@ -232452,15 +232593,16 @@ and printSetFieldExpr ~customLayout attrs lhs longidentLoc rhs loc cmtTbl = printLidentPath longidentLoc cmtTbl; Doc.text " ="; (if shouldIndent then - Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) - else Doc.concat [Doc.space; rhsDoc]); + Doc.group (Doc.indent (Doc.concat [ Doc.line; rhsDoc ])) + else Doc.concat [ Doc.space; rhsDoc ]); ]) in let doc = match attrs with | [] -> doc | attrs -> - Doc.group (Doc.concat [printAttributes ~customLayout attrs cmtTbl; doc]) + Doc.group + (Doc.concat [ printAttributes ~customLayout attrs cmtTbl; doc ]) in printComments doc cmtTbl loc @@ -232470,17 +232612,17 @@ and printTemplateLiteral ~customLayout expr cmtTbl = let open Parsetree in match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident "^"}}, - [(Nolabel, arg1); (Nolabel, arg2)] ) -> - let lhs = walkExpr arg1 in - let rhs = walkExpr arg2 in - Doc.concat [lhs; rhs] + ( { pexp_desc = Pexp_ident { txt = Longident.Lident "^" } }, + [ (Nolabel, arg1); (Nolabel, arg2) ] ) -> + let lhs = walkExpr arg1 in + let rhs = walkExpr arg2 in + Doc.concat [ lhs; rhs ] | Pexp_constant (Pconst_string (txt, Some prefix)) -> - tag := prefix; - printStringContents txt + tag := prefix; + printStringContents txt | _ -> - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - Doc.group (Doc.concat [Doc.text "${"; Doc.indent doc; Doc.rbrace]) + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + Doc.group (Doc.concat [ Doc.text "${"; Doc.indent doc; Doc.rbrace ]) in let content = walkExpr expr in Doc.concat @@ -232504,17 +232646,17 @@ and printUnaryExpression ~customLayout expr cmtTbl = in match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [(Nolabel, operand)] ) -> - let printedOperand = - let doc = printExpressionWithComments ~customLayout operand cmtTbl in - match Parens.unaryExprOperand operand with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc operand braces - | Nothing -> doc - in - let doc = Doc.concat [printUnaryOperator operator; printedOperand] in - printComments doc cmtTbl expr.pexp_loc + ( { pexp_desc = Pexp_ident { txt = Longident.Lident operator } }, + [ (Nolabel, operand) ] ) -> + let printedOperand = + let doc = printExpressionWithComments ~customLayout operand cmtTbl in + match Parens.unaryExprOperand operand with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc operand braces + | Nothing -> doc + in + let doc = Doc.concat [ printUnaryOperator operator; printedOperand ] in + printComments doc cmtTbl expr.pexp_loc | _ -> assert false and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = @@ -232541,7 +232683,7 @@ and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = else Doc.line in Doc.concat - [spacingBeforeOperator; Doc.text operatorTxt; spacingAfterOperator] + [ spacingBeforeOperator; Doc.text operatorTxt; spacingAfterOperator ] in let printOperand ~isLhs expr parentOperator = let rec flatten ~isLhs expr parentOperator = @@ -232550,230 +232692,232 @@ and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = | { pexp_desc = Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [(_, left); (_, right)] ); + ( { pexp_desc = Pexp_ident { txt = Longident.Lident operator } }, + [ (_, left); (_, right) ] ); } -> - if - ParsetreeViewer.flattenableOperators parentOperator operator - && not (ParsetreeViewer.hasAttributes expr.pexp_attributes) - then - let leftPrinted = flatten ~isLhs:true left operator in - let rightPrinted = - let rightPrinteableAttrs, rightInternalAttrs = + if + ParsetreeViewer.flattenableOperators parentOperator operator + && not (ParsetreeViewer.hasAttributes expr.pexp_attributes) + then + let leftPrinted = flatten ~isLhs:true left operator in + let rightPrinted = + let rightPrinteableAttrs, rightInternalAttrs = + ParsetreeViewer.partitionPrintableAttributes + right.pexp_attributes + in + let doc = + printExpressionWithComments ~customLayout + { right with pexp_attributes = rightInternalAttrs } + cmtTbl + in + let doc = + if Parens.flattenOperandRhs parentOperator right then + Doc.concat [ Doc.lparen; doc; Doc.rparen ] + else doc + in + let doc = + Doc.concat + [ + printAttributes ~customLayout rightPrinteableAttrs cmtTbl; + doc; + ] + in + match rightPrinteableAttrs with [] -> doc | _ -> addParens doc + in + let isAwait = + ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes + in + let doc = + if isAwait then + Doc.concat + [ + Doc.text "await "; + Doc.lparen; + leftPrinted; + printBinaryOperator ~inlineRhs:false operator; + rightPrinted; + Doc.rparen; + ] + else + Doc.concat + [ + leftPrinted; + printBinaryOperator ~inlineRhs:false operator; + rightPrinted; + ] + in + + let doc = + if (not isLhs) && Parens.rhsBinaryExprOperand operator expr then + Doc.concat [ Doc.lparen; doc; Doc.rparen ] + else doc + in + printComments doc cmtTbl expr.pexp_loc + else + let printeableAttrs, internalAttrs = ParsetreeViewer.partitionPrintableAttributes - right.pexp_attributes + expr.pexp_attributes in let doc = printExpressionWithComments ~customLayout - {right with pexp_attributes = rightInternalAttrs} + { expr with pexp_attributes = internalAttrs } cmtTbl in let doc = - if Parens.flattenOperandRhs parentOperator right then - Doc.concat [Doc.lparen; doc; Doc.rparen] + if + Parens.subBinaryExprOperand parentOperator operator + || printeableAttrs <> [] + && (ParsetreeViewer.isBinaryExpression expr + || ParsetreeViewer.isTernaryExpr expr) + then Doc.concat [ Doc.lparen; doc; Doc.rparen ] else doc in - let doc = - Doc.concat - [ - printAttributes ~customLayout rightPrinteableAttrs cmtTbl; - doc; - ] - in - match rightPrinteableAttrs with - | [] -> doc - | _ -> addParens doc - in - let isAwait = - ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes - in - let doc = - if isAwait then - Doc.concat - [ - Doc.text "await "; - Doc.lparen; - leftPrinted; - printBinaryOperator ~inlineRhs:false operator; - rightPrinted; - Doc.rparen; - ] - else - Doc.concat - [ - leftPrinted; - printBinaryOperator ~inlineRhs:false operator; - rightPrinted; - ] - in - - let doc = - if (not isLhs) && Parens.rhsBinaryExprOperand operator expr then - Doc.concat [Doc.lparen; doc; Doc.rparen] - else doc - in - printComments doc cmtTbl expr.pexp_loc - else - let printeableAttrs, internalAttrs = - ParsetreeViewer.partitionPrintableAttributes expr.pexp_attributes - in - let doc = - printExpressionWithComments ~customLayout - {expr with pexp_attributes = internalAttrs} - cmtTbl - in - let doc = - if - Parens.subBinaryExprOperand parentOperator operator - || printeableAttrs <> [] - && (ParsetreeViewer.isBinaryExpression expr - || ParsetreeViewer.isTernaryExpr expr) - then Doc.concat [Doc.lparen; doc; Doc.rparen] - else doc - in - Doc.concat - [printAttributes ~customLayout printeableAttrs cmtTbl; doc] + Doc.concat + [ printAttributes ~customLayout printeableAttrs cmtTbl; doc ] | _ -> assert false else match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident "^"; loc}}, - [(Nolabel, _); (Nolabel, _)] ) + ( { pexp_desc = Pexp_ident { txt = Longident.Lident "^"; loc } }, + [ (Nolabel, _); (Nolabel, _) ] ) when loc.loc_ghost -> - let doc = printTemplateLiteral ~customLayout expr cmtTbl in - printComments doc cmtTbl expr.Parsetree.pexp_loc + let doc = printTemplateLiteral ~customLayout expr cmtTbl in + printComments doc cmtTbl expr.Parsetree.pexp_loc | Pexp_setfield (lhs, field, rhs) -> - let doc = - printSetFieldExpr ~customLayout expr.pexp_attributes lhs field rhs - expr.pexp_loc cmtTbl - in - if isLhs then addParens doc else doc + let doc = + printSetFieldExpr ~customLayout expr.pexp_attributes lhs field rhs + expr.pexp_loc cmtTbl + in + if isLhs then addParens doc else doc | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}}, - [(Nolabel, lhs); (Nolabel, rhs)] ) -> - let rhsDoc = printExpressionWithComments ~customLayout rhs cmtTbl in - let lhsDoc = printExpressionWithComments ~customLayout lhs cmtTbl in - (* TODO: unify indentation of "=" *) - let shouldIndent = ParsetreeViewer.isBinaryExpression rhs in - let doc = - Doc.group - (Doc.concat - [ - lhsDoc; - Doc.text " ="; - (if shouldIndent then - Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) - else Doc.concat [Doc.space; rhsDoc]); - ]) - in - let doc = - match expr.pexp_attributes with - | [] -> doc - | attrs -> + ( { pexp_desc = Pexp_ident { txt = Longident.Lident "#=" } }, + [ (Nolabel, lhs); (Nolabel, rhs) ] ) -> + let rhsDoc = printExpressionWithComments ~customLayout rhs cmtTbl in + let lhsDoc = printExpressionWithComments ~customLayout lhs cmtTbl in + (* TODO: unify indentation of "=" *) + let shouldIndent = ParsetreeViewer.isBinaryExpression rhs in + let doc = Doc.group - (Doc.concat [printAttributes ~customLayout attrs cmtTbl; doc]) - in - if isLhs then addParens doc else doc + (Doc.concat + [ + lhsDoc; + Doc.text " ="; + (if shouldIndent then + Doc.group (Doc.indent (Doc.concat [ Doc.line; rhsDoc ])) + else Doc.concat [ Doc.space; rhsDoc ]); + ]) + in + let doc = + match expr.pexp_attributes with + | [] -> doc + | attrs -> + Doc.group + (Doc.concat + [ printAttributes ~customLayout attrs cmtTbl; doc ]) + in + if isLhs then addParens doc else doc | _ -> ( - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.binaryExprOperand ~isLhs expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.binaryExprOperand ~isLhs expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) in flatten ~isLhs expr parentOperator in match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident (("|." | "|>") as op)}}, - [(Nolabel, lhs); (Nolabel, rhs)] ) + ( { + pexp_desc = Pexp_ident { txt = Longident.Lident (("|." | "|>") as op) }; + }, + [ (Nolabel, lhs); (Nolabel, rhs) ] ) when not (ParsetreeViewer.isBinaryExpression lhs || ParsetreeViewer.isBinaryExpression rhs || printAttributes ~customLayout expr.pexp_attributes cmtTbl <> Doc.nil) -> - let lhsHasCommentBelow = hasCommentBelow cmtTbl lhs.pexp_loc in - let lhsDoc = printOperand ~isLhs:true lhs op in - let rhsDoc = printOperand ~isLhs:false rhs op in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - lhsDoc; - (match (lhsHasCommentBelow, op) with - | true, "|." -> Doc.concat [Doc.softLine; Doc.text "->"] - | false, "|." -> Doc.text "->" - | true, "|>" -> Doc.concat [Doc.line; Doc.text "|> "] - | false, "|>" -> Doc.text " |> " - | _ -> Doc.nil); - rhsDoc; - ]) + let lhsHasCommentBelow = hasCommentBelow cmtTbl lhs.pexp_loc in + let lhsDoc = printOperand ~isLhs:true lhs op in + let rhsDoc = printOperand ~isLhs:false rhs op in + Doc.group + (Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + lhsDoc; + (match (lhsHasCommentBelow, op) with + | true, "|." -> Doc.concat [ Doc.softLine; Doc.text "->" ] + | false, "|." -> Doc.text "->" + | true, "|>" -> Doc.concat [ Doc.line; Doc.text "|> " ] + | false, "|>" -> Doc.text " |> " + | _ -> Doc.nil); + rhsDoc; + ]) | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [(Nolabel, lhs); (Nolabel, rhs)] ) -> - let right = - let operatorWithRhs = - let rhsDoc = printOperand ~isLhs:false rhs operator in - Doc.concat - [ - printBinaryOperator - ~inlineRhs:(ParsetreeViewer.shouldInlineRhsBinaryExpr rhs) - operator; - rhsDoc; - ] + ( { pexp_desc = Pexp_ident { txt = Longident.Lident operator } }, + [ (Nolabel, lhs); (Nolabel, rhs) ] ) -> + let right = + let operatorWithRhs = + let rhsDoc = printOperand ~isLhs:false rhs operator in + Doc.concat + [ + printBinaryOperator + ~inlineRhs:(ParsetreeViewer.shouldInlineRhsBinaryExpr rhs) + operator; + rhsDoc; + ] + in + if ParsetreeViewer.shouldIndentBinaryExpr expr then + Doc.group (Doc.indent operatorWithRhs) + else operatorWithRhs in - if ParsetreeViewer.shouldIndentBinaryExpr expr then - Doc.group (Doc.indent operatorWithRhs) - else operatorWithRhs - in - let doc = - Doc.group (Doc.concat [printOperand ~isLhs:true lhs operator; right]) - in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - (match - Parens.binaryExpr - { - expr with - pexp_attributes = - ParsetreeViewer.filterPrintableAttributes - expr.pexp_attributes; - } - with - | Braced bracesLoc -> printBraces doc expr bracesLoc - | Parenthesized -> addParens doc - | Nothing -> doc); - ]) + let doc = + Doc.group (Doc.concat [ printOperand ~isLhs:true lhs operator; right ]) + in + Doc.group + (Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + (match + Parens.binaryExpr + { + expr with + pexp_attributes = + ParsetreeViewer.filterPrintableAttributes + expr.pexp_attributes; + } + with + | Braced bracesLoc -> printBraces doc expr bracesLoc + | Parenthesized -> addParens doc + | Nothing -> doc); + ]) | _ -> Doc.nil and printBeltListConcatApply ~customLayout subLists cmtTbl = let makeSpreadDoc commaBeforeSpread = function | Some expr -> - Doc.concat - [ - commaBeforeSpread; - Doc.dotdotdot; - (let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); - ] + Doc.concat + [ + commaBeforeSpread; + Doc.dotdotdot; + (let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + ] | None -> Doc.nil in let makeSubListDoc (expressions, spread) = let commaBeforeSpread = match expressions with | [] -> Doc.nil - | _ -> Doc.concat [Doc.text ","; Doc.line] + | _ -> Doc.concat [ Doc.text ","; Doc.line ] in let spreadDoc = makeSpreadDoc commaBeforeSpread spread in Doc.concat [ Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) (List.map (fun expr -> let doc = @@ -232796,7 +232940,7 @@ and printBeltListConcatApply ~customLayout subLists cmtTbl = [ Doc.softLine; Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) + ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) (List.map makeSubListDoc (List.map ParsetreeViewer.collectListExpressions subLists)); ]); @@ -232809,228 +232953,243 @@ and printBeltListConcatApply ~customLayout subLists cmtTbl = and printPexpApply ~customLayout expr cmtTbl = match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident "##"}}, - [(Nolabel, parentExpr); (Nolabel, memberExpr)] ) -> - let parentDoc = - let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces - | Nothing -> doc - in - let member = - let memberDoc = - match memberExpr.pexp_desc with - | Pexp_ident lident -> - printComments (printLongident lident.txt) cmtTbl memberExpr.pexp_loc - | _ -> printExpressionWithComments ~customLayout memberExpr cmtTbl + ( { pexp_desc = Pexp_ident { txt = Longident.Lident "##" } }, + [ (Nolabel, parentExpr); (Nolabel, memberExpr) ] ) -> + let parentDoc = + let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in + match Parens.unaryExprOperand parentExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc parentExpr braces + | Nothing -> doc + in + let member = + let memberDoc = + match memberExpr.pexp_desc with + | Pexp_ident lident -> + printComments + (printLongident lident.txt) + cmtTbl memberExpr.pexp_loc + | _ -> printExpressionWithComments ~customLayout memberExpr cmtTbl + in + Doc.concat [ Doc.text "\""; memberDoc; Doc.text "\"" ] in - Doc.concat [Doc.text "\""; memberDoc; Doc.text "\""] - in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - parentDoc; - Doc.lbracket; - member; - Doc.rbracket; - ]) - | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}}, - [(Nolabel, lhs); (Nolabel, rhs)] ) -> ( - let rhsDoc = - let doc = printExpressionWithComments ~customLayout rhs cmtTbl in - match Parens.expr rhs with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc rhs braces - | Nothing -> doc - in - (* TODO: unify indentation of "=" *) - let shouldIndent = - (not (ParsetreeViewer.isBracedExpr rhs)) - && ParsetreeViewer.isBinaryExpression rhs - in - let doc = Doc.group (Doc.concat [ - printExpressionWithComments ~customLayout lhs cmtTbl; - Doc.text " ="; - (if shouldIndent then - Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) - else Doc.concat [Doc.space; rhsDoc]); + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + parentDoc; + Doc.lbracket; + member; + Doc.rbracket; ]) - in - match expr.pexp_attributes with - | [] -> doc - | attrs -> - Doc.group (Doc.concat [printAttributes ~customLayout attrs cmtTbl; doc])) | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "get")}}, - [(Nolabel, parentExpr); (Nolabel, memberExpr)] ) - when not (ParsetreeViewer.isRewrittenUnderscoreApplySugar parentExpr) -> - (* Don't print the Array.get(_, 0) sugar a.k.a. (__x) => Array.get(__x, 0) as _[0] *) - let member = - let memberDoc = - let doc = printExpressionWithComments ~customLayout memberExpr cmtTbl in - match Parens.expr memberExpr with + ( { pexp_desc = Pexp_ident { txt = Longident.Lident "#=" } }, + [ (Nolabel, lhs); (Nolabel, rhs) ] ) -> ( + let rhsDoc = + let doc = printExpressionWithComments ~customLayout rhs cmtTbl in + match Parens.expr rhs with | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc memberExpr braces + | Braced braces -> printBraces doc rhs braces | Nothing -> doc in - let shouldInline = - match memberExpr.pexp_desc with - | Pexp_constant _ | Pexp_ident _ -> true - | _ -> false + (* TODO: unify indentation of "=" *) + let shouldIndent = + (not (ParsetreeViewer.isBracedExpr rhs)) + && ParsetreeViewer.isBinaryExpression rhs in - if shouldInline then memberDoc - else - Doc.concat - [Doc.indent (Doc.concat [Doc.softLine; memberDoc]); Doc.softLine] - in - let parentDoc = - let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces - | Nothing -> doc - in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - parentDoc; - Doc.lbracket; - member; - Doc.rbracket; - ]) + let doc = + Doc.group + (Doc.concat + [ + printExpressionWithComments ~customLayout lhs cmtTbl; + Doc.text " ="; + (if shouldIndent then + Doc.group (Doc.indent (Doc.concat [ Doc.line; rhsDoc ])) + else Doc.concat [ Doc.space; rhsDoc ]); + ]) + in + match expr.pexp_attributes with + | [] -> doc + | attrs -> + Doc.group + (Doc.concat [ printAttributes ~customLayout attrs cmtTbl; doc ])) | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "set")}}, - [(Nolabel, parentExpr); (Nolabel, memberExpr); (Nolabel, targetExpr)] ) - -> - let member = - let memberDoc = - let doc = printExpressionWithComments ~customLayout memberExpr cmtTbl in - match Parens.expr memberExpr with + ( { + pexp_desc = Pexp_ident { txt = Longident.Ldot (Lident "Array", "get") }; + }, + [ (Nolabel, parentExpr); (Nolabel, memberExpr) ] ) + when not (ParsetreeViewer.isRewrittenUnderscoreApplySugar parentExpr) -> + (* Don't print the Array.get(_, 0) sugar a.k.a. (__x) => Array.get(__x, 0) as _[0] *) + let member = + let memberDoc = + let doc = + printExpressionWithComments ~customLayout memberExpr cmtTbl + in + match Parens.expr memberExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc memberExpr braces + | Nothing -> doc + in + let shouldInline = + match memberExpr.pexp_desc with + | Pexp_constant _ | Pexp_ident _ -> true + | _ -> false + in + if shouldInline then memberDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [ Doc.softLine; memberDoc ]); Doc.softLine; + ] + in + let parentDoc = + let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in + match Parens.unaryExprOperand parentExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc parentExpr braces + | Nothing -> doc + in + Doc.group + (Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + parentDoc; + Doc.lbracket; + member; + Doc.rbracket; + ]) + | Pexp_apply + ( { + pexp_desc = Pexp_ident { txt = Longident.Ldot (Lident "Array", "set") }; + }, + [ (Nolabel, parentExpr); (Nolabel, memberExpr); (Nolabel, targetExpr) ] + ) -> + let member = + let memberDoc = + let doc = + printExpressionWithComments ~customLayout memberExpr cmtTbl + in + match Parens.expr memberExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc memberExpr braces + | Nothing -> doc + in + let shouldInline = + match memberExpr.pexp_desc with + | Pexp_constant _ | Pexp_ident _ -> true + | _ -> false + in + if shouldInline then memberDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [ Doc.softLine; memberDoc ]); Doc.softLine; + ] + in + let shouldIndentTargetExpr = + if ParsetreeViewer.isBracedExpr targetExpr then false + else + ParsetreeViewer.isBinaryExpression targetExpr + || + match targetExpr with + | { + pexp_attributes = [ ({ Location.txt = "ns.ternary" }, _) ]; + pexp_desc = Pexp_ifthenelse (ifExpr, _, _); + } -> + ParsetreeViewer.isBinaryExpression ifExpr + || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes + | { pexp_desc = Pexp_newtype _ } -> false + | e -> + ParsetreeViewer.hasAttributes e.pexp_attributes + || ParsetreeViewer.isArrayAccess e + in + let targetExpr = + let doc = printExpressionWithComments ~customLayout targetExpr cmtTbl in + match Parens.expr targetExpr with | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc memberExpr braces + | Braced braces -> printBraces doc targetExpr braces | Nothing -> doc in - let shouldInline = - match memberExpr.pexp_desc with - | Pexp_constant _ | Pexp_ident _ -> true - | _ -> false + let parentDoc = + let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in + match Parens.unaryExprOperand parentExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc parentExpr braces + | Nothing -> doc in - if shouldInline then memberDoc - else - Doc.concat - [Doc.indent (Doc.concat [Doc.softLine; memberDoc]); Doc.softLine] - in - let shouldIndentTargetExpr = - if ParsetreeViewer.isBracedExpr targetExpr then false - else - ParsetreeViewer.isBinaryExpression targetExpr - || - match targetExpr with - | { - pexp_attributes = [({Location.txt = "ns.ternary"}, _)]; - pexp_desc = Pexp_ifthenelse (ifExpr, _, _); - } -> - ParsetreeViewer.isBinaryExpression ifExpr - || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes - | {pexp_desc = Pexp_newtype _} -> false - | e -> - ParsetreeViewer.hasAttributes e.pexp_attributes - || ParsetreeViewer.isArrayAccess e - in - let targetExpr = - let doc = printExpressionWithComments ~customLayout targetExpr cmtTbl in - match Parens.expr targetExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc targetExpr braces - | Nothing -> doc - in - let parentDoc = - let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces - | Nothing -> doc - in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - parentDoc; - Doc.lbracket; - member; - Doc.rbracket; - Doc.text " ="; - (if shouldIndentTargetExpr then - Doc.indent (Doc.concat [Doc.line; targetExpr]) - else Doc.concat [Doc.space; targetExpr]); - ]) + Doc.group + (Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + parentDoc; + Doc.lbracket; + member; + Doc.rbracket; + Doc.text " ="; + (if shouldIndentTargetExpr then + Doc.indent (Doc.concat [ Doc.line; targetExpr ]) + else Doc.concat [ Doc.space; targetExpr ]); + ]) (* TODO: cleanup, are those branches even remotely performant? *) - | Pexp_apply ({pexp_desc = Pexp_ident lident}, args) + | Pexp_apply ({ pexp_desc = Pexp_ident lident }, args) when ParsetreeViewer.isJsxExpression expr -> - printJsxExpression ~customLayout lident args cmtTbl + printJsxExpression ~customLayout lident args cmtTbl | Pexp_apply (callExpr, args) -> - let args = - List.map - (fun (lbl, arg) -> (lbl, ParsetreeViewer.rewriteUnderscoreApply arg)) - args - in - let uncurried, attrs = - ParsetreeViewer.processUncurriedAttribute expr.pexp_attributes - in - let callExprDoc = - let doc = printExpressionWithComments ~customLayout callExpr cmtTbl in - match Parens.callExpr callExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc callExpr braces - | Nothing -> doc - in - if ParsetreeViewer.requiresSpecialCallbackPrintingFirstArg args then - let argsDoc = - printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args - cmtTbl + let args = + List.map + (fun (lbl, arg) -> (lbl, ParsetreeViewer.rewriteUnderscoreApply arg)) + args in - Doc.concat - [printAttributes ~customLayout attrs cmtTbl; callExprDoc; argsDoc] - else if ParsetreeViewer.requiresSpecialCallbackPrintingLastArg args then - let argsDoc = - printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args - cmtTbl + let uncurried, attrs = + ParsetreeViewer.processUncurriedAttribute expr.pexp_attributes in - (* - * Fixes the following layout (the `[` and `]` should break): - * [fn(x => { - * let _ = x - * }), fn(y => { - * let _ = y - * }), fn(z => { - * let _ = z - * })] - * See `Doc.willBreak documentation in interface file for more context. - * Context: - * https://github.com/rescript-lang/syntax/issues/111 - * https://github.com/rescript-lang/syntax/issues/166 - *) - let maybeBreakParent = - if Doc.willBreak argsDoc then Doc.breakParent else Doc.nil + let callExprDoc = + let doc = printExpressionWithComments ~customLayout callExpr cmtTbl in + match Parens.callExpr callExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc callExpr braces + | Nothing -> doc in - Doc.concat - [ - maybeBreakParent; - printAttributes ~customLayout attrs cmtTbl; - callExprDoc; - argsDoc; - ] - else - let argsDoc = printArguments ~customLayout ~uncurried args cmtTbl in - Doc.concat - [printAttributes ~customLayout attrs cmtTbl; callExprDoc; argsDoc] + if ParsetreeViewer.requiresSpecialCallbackPrintingFirstArg args then + let argsDoc = + printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout + args cmtTbl + in + Doc.concat + [ printAttributes ~customLayout attrs cmtTbl; callExprDoc; argsDoc ] + else if ParsetreeViewer.requiresSpecialCallbackPrintingLastArg args then + let argsDoc = + printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args + cmtTbl + in + (* + * Fixes the following layout (the `[` and `]` should break): + * [fn(x => { + * let _ = x + * }), fn(y => { + * let _ = y + * }), fn(z => { + * let _ = z + * })] + * See `Doc.willBreak documentation in interface file for more context. + * Context: + * https://github.com/rescript-lang/syntax/issues/111 + * https://github.com/rescript-lang/syntax/issues/166 + *) + let maybeBreakParent = + if Doc.willBreak argsDoc then Doc.breakParent else Doc.nil + in + Doc.concat + [ + maybeBreakParent; + printAttributes ~customLayout attrs cmtTbl; + callExprDoc; + argsDoc; + ] + else + let argsDoc = printArguments ~customLayout ~uncurried args cmtTbl in + Doc.concat + [ printAttributes ~customLayout attrs cmtTbl; callExprDoc; argsDoc ] | _ -> assert false and printJsxExpression ~customLayout lident args cmtTbl = @@ -233042,9 +233201,9 @@ and printJsxExpression ~customLayout lident args cmtTbl = | Some { Parsetree.pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"}, None); + Pexp_construct ({ txt = Longident.Lident "[]" }, None); } -> - false + false | None -> false | _ -> true in @@ -233053,17 +233212,17 @@ and printJsxExpression ~customLayout lident args cmtTbl = | Some { Parsetree.pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"}, None); + Pexp_construct ({ txt = Longident.Lident "[]" }, None); pexp_loc = loc; } -> - not (hasCommentsInside cmtTbl loc) + not (hasCommentsInside cmtTbl loc) | _ -> false in let printChildren children = let lineSep = match children with | Some expr -> - if hasNestedJsxOrMoreThanOneChild expr then Doc.hardLine else Doc.line + if hasNestedJsxOrMoreThanOneChild expr then Doc.hardLine else Doc.line | None -> Doc.line in Doc.concat @@ -233074,8 +233233,8 @@ and printJsxExpression ~customLayout lident args cmtTbl = Doc.line; (match children with | Some childrenExpression -> - printJsxChildren ~customLayout childrenExpression ~sep:lineSep - cmtTbl + printJsxChildren ~customLayout childrenExpression + ~sep:lineSep cmtTbl | None -> Doc.nil); ]); lineSep; @@ -233088,27 +233247,27 @@ and printJsxExpression ~customLayout lident args cmtTbl = (Doc.concat [ printComments - (Doc.concat [Doc.lessThan; name]) + (Doc.concat [ Doc.lessThan; name ]) cmtTbl lident.Asttypes.loc; formattedProps; (match children with | Some { Parsetree.pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"}, None); + Pexp_construct ({ txt = Longident.Lident "[]" }, None); } when isSelfClosing -> - Doc.text "/>" + Doc.text "/>" | _ -> - (* if tag A has trailing comments then put > on the next line - - - *) - if hasTrailingComments cmtTbl lident.Asttypes.loc then - Doc.concat [Doc.softLine; Doc.greaterThan] - else Doc.greaterThan); + (* if tag A has trailing comments then put > on the next line + + + *) + if hasTrailingComments cmtTbl lident.Asttypes.loc then + Doc.concat [ Doc.softLine; Doc.greaterThan ] + else Doc.greaterThan); ]); (if isSelfClosing then Doc.nil else @@ -233120,10 +233279,10 @@ and printJsxExpression ~customLayout lident args cmtTbl = | Some { Parsetree.pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"}, None); + Pexp_construct ({ txt = Longident.Lident "[]" }, None); pexp_loc = loc; } -> - printCommentsInside cmtTbl loc + printCommentsInside cmtTbl loc | _ -> Doc.nil); Doc.text " Doc.nil + | Pexp_construct ({ txt = Longident.Lident "[]" }, None) -> Doc.nil | _ -> - Doc.indent - (Doc.concat - [ - Doc.line; - printJsxChildren ~customLayout expr ~sep:lineSep cmtTbl; - ])); + Doc.indent + (Doc.concat + [ + Doc.line; + printJsxChildren ~customLayout expr ~sep:lineSep cmtTbl; + ])); lineSep; closing; ]) @@ -233157,52 +233316,53 @@ and printJsxFragment ~customLayout expr cmtTbl = and printJsxChildren ~customLayout (childrenExpr : Parsetree.expression) ~sep cmtTbl = match childrenExpr.pexp_desc with - | Pexp_construct ({txt = Longident.Lident "::"}, _) -> - let children, _ = ParsetreeViewer.collectListExpressions childrenExpr in - Doc.group - (Doc.join ~sep - (List.map - (fun (expr : Parsetree.expression) -> - let leadingLineCommentPresent = - hasLeadingLineComment cmtTbl expr.pexp_loc - in - let exprDoc = - printExpressionWithComments ~customLayout expr cmtTbl - in - let addParensOrBraces exprDoc = - (* {(20: int)} make sure that we also protect the expression inside *) - let innerDoc = - if Parens.bracedExpr expr then addParens exprDoc else exprDoc + | Pexp_construct ({ txt = Longident.Lident "::" }, _) -> + let children, _ = ParsetreeViewer.collectListExpressions childrenExpr in + Doc.group + (Doc.join ~sep + (List.map + (fun (expr : Parsetree.expression) -> + let leadingLineCommentPresent = + hasLeadingLineComment cmtTbl expr.pexp_loc in - if leadingLineCommentPresent then addBraces innerDoc - else Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace] - in - match Parens.jsxChildExpr expr with - | Nothing -> exprDoc - | Parenthesized -> addParensOrBraces exprDoc - | Braced bracesLoc -> - printComments (addParensOrBraces exprDoc) cmtTbl bracesLoc) - children)) + let exprDoc = + printExpressionWithComments ~customLayout expr cmtTbl + in + let addParensOrBraces exprDoc = + (* {(20: int)} make sure that we also protect the expression inside *) + let innerDoc = + if Parens.bracedExpr expr then addParens exprDoc + else exprDoc + in + if leadingLineCommentPresent then addBraces innerDoc + else Doc.concat [ Doc.lbrace; innerDoc; Doc.rbrace ] + in + match Parens.jsxChildExpr expr with + | Nothing -> exprDoc + | Parenthesized -> addParensOrBraces exprDoc + | Braced bracesLoc -> + printComments (addParensOrBraces exprDoc) cmtTbl bracesLoc) + children)) | _ -> - let leadingLineCommentPresent = - hasLeadingLineComment cmtTbl childrenExpr.pexp_loc - in - let exprDoc = - printExpressionWithComments ~customLayout childrenExpr cmtTbl - in - Doc.concat - [ - Doc.dotdotdot; - (match Parens.jsxChildExpr childrenExpr with - | Parenthesized | Braced _ -> - let innerDoc = - if Parens.bracedExpr childrenExpr then addParens exprDoc - else exprDoc - in - if leadingLineCommentPresent then addBraces innerDoc - else Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace] - | Nothing -> exprDoc); - ] + let leadingLineCommentPresent = + hasLeadingLineComment cmtTbl childrenExpr.pexp_loc + in + let exprDoc = + printExpressionWithComments ~customLayout childrenExpr cmtTbl + in + Doc.concat + [ + Doc.dotdotdot; + (match Parens.jsxChildExpr childrenExpr with + | Parenthesized | Braced _ -> + let innerDoc = + if Parens.bracedExpr childrenExpr then addParens exprDoc + else exprDoc + in + if leadingLineCommentPresent then addBraces innerDoc + else Doc.concat [ Doc.lbrace; innerDoc; Doc.rbrace ] + | Nothing -> exprDoc); + ] and printJsxProps ~customLayout args cmtTbl : Doc.t * Parsetree.expression option = @@ -233221,10 +233381,10 @@ and printJsxProps ~customLayout args cmtTbl : let isSelfClosing children = match children with | { - Parsetree.pexp_desc = Pexp_construct ({txt = Longident.Lident "[]"}, None); + Parsetree.pexp_desc = Pexp_construct ({ txt = Longident.Lident "[]" }, None); pexp_loc = loc; } -> - not (hasCommentsInside cmtTbl loc) + not (hasCommentsInside cmtTbl loc) | _ -> false in let rec loop props args = @@ -233235,50 +233395,50 @@ and printJsxProps ~customLayout args cmtTbl : ( Asttypes.Nolabel, { Parsetree.pexp_desc = - Pexp_construct ({txt = Longident.Lident "()"}, None); + Pexp_construct ({ txt = Longident.Lident "()" }, None); } ); ] -> - let doc = if isSelfClosing children then Doc.line else Doc.nil in - (doc, Some children) + let doc = if isSelfClosing children then Doc.line else Doc.nil in + (doc, Some children) | ((_, expr) as lastProp) :: [ (Asttypes.Labelled "children", children); ( Asttypes.Nolabel, { Parsetree.pexp_desc = - Pexp_construct ({txt = Longident.Lident "()"}, None); + Pexp_construct ({ txt = Longident.Lident "()" }, None); } ); ] -> - let loc = - match expr.Parsetree.pexp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _attrs -> - {loc with loc_end = expr.pexp_loc.loc_end} - | _ -> expr.pexp_loc - in - let trailingCommentsPresent = hasTrailingComments cmtTbl loc in - let propDoc = printJsxProp ~customLayout lastProp cmtTbl in - let formattedProps = - Doc.concat - [ - Doc.indent - (Doc.concat - [ - Doc.line; - Doc.group - (Doc.join ~sep:Doc.line (propDoc :: props |> List.rev)); - ]); - (* print > on new line if the last prop has trailing comments *) - (match (isSelfClosing children, trailingCommentsPresent) with - (* we always put /> on a new line when a self-closing tag breaks *) - | true, _ -> Doc.line - | false, true -> Doc.softLine - | false, false -> Doc.nil); - ] - in - (formattedProps, Some children) + let loc = + match expr.Parsetree.pexp_attributes with + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _attrs -> + { loc with loc_end = expr.pexp_loc.loc_end } + | _ -> expr.pexp_loc + in + let trailingCommentsPresent = hasTrailingComments cmtTbl loc in + let propDoc = printJsxProp ~customLayout lastProp cmtTbl in + let formattedProps = + Doc.concat + [ + Doc.indent + (Doc.concat + [ + Doc.line; + Doc.group + (Doc.join ~sep:Doc.line (propDoc :: props |> List.rev)); + ]); + (* print > on new line if the last prop has trailing comments *) + (match (isSelfClosing children, trailingCommentsPresent) with + (* we always put /> on a new line when a self-closing tag breaks *) + | true, _ -> Doc.line + | false, true -> Doc.softLine + | false, false -> Doc.nil); + ] + in + (formattedProps, Some children) | arg :: args -> - let propDoc = printJsxProp ~customLayout arg cmtTbl in - loop (propDoc :: props) args + let propDoc = printJsxProp ~customLayout arg cmtTbl in + loop (propDoc :: props) args in loop [] args @@ -233287,79 +233447,81 @@ and printJsxProp ~customLayout arg cmtTbl = | ( ((Asttypes.Labelled lblTxt | Optional lblTxt) as lbl), { Parsetree.pexp_attributes = - [({Location.txt = "ns.namedArgLoc"; loc = argLoc}, _)]; - pexp_desc = Pexp_ident {txt = Longident.Lident ident}; + [ ({ Location.txt = "ns.namedArgLoc"; loc = argLoc }, _) ]; + pexp_desc = Pexp_ident { txt = Longident.Lident ident }; } ) when lblTxt = ident (* jsx punning *) -> ( - match lbl with - | Nolabel -> Doc.nil - | Labelled _lbl -> printComments (printIdentLike ident) cmtTbl argLoc - | Optional _lbl -> - let doc = Doc.concat [Doc.question; printIdentLike ident] in - printComments doc cmtTbl argLoc) + match lbl with + | Nolabel -> Doc.nil + | Labelled _lbl -> printComments (printIdentLike ident) cmtTbl argLoc + | Optional _lbl -> + let doc = Doc.concat [ Doc.question; printIdentLike ident ] in + printComments doc cmtTbl argLoc) | ( ((Asttypes.Labelled lblTxt | Optional lblTxt) as lbl), { Parsetree.pexp_attributes = []; - pexp_desc = Pexp_ident {txt = Longident.Lident ident}; + pexp_desc = Pexp_ident { txt = Longident.Lident ident }; } ) when lblTxt = ident (* jsx punning when printing from Reason *) -> ( - match lbl with - | Nolabel -> Doc.nil - | Labelled _lbl -> printIdentLike ident - | Optional _lbl -> Doc.concat [Doc.question; printIdentLike ident]) - | Asttypes.Labelled "_spreadProps", expr -> - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - Doc.concat [Doc.lbrace; Doc.dotdotdot; Doc.softLine; doc; Doc.rbrace] - | lbl, expr -> - let argLoc, expr = - match expr.pexp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: attrs -> - (loc, {expr with pexp_attributes = attrs}) - | _ -> (Location.none, expr) - in - let lblDoc = match lbl with - | Asttypes.Labelled lbl -> - let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in - Doc.concat [lbl; Doc.equal] - | Asttypes.Optional lbl -> - let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in - Doc.concat [lbl; Doc.equal; Doc.question] | Nolabel -> Doc.nil - in - let exprDoc = - let leadingLineCommentPresent = - hasLeadingLineComment cmtTbl expr.pexp_loc - in + | Labelled _lbl -> printIdentLike ident + | Optional _lbl -> Doc.concat [ Doc.question; printIdentLike ident ]) + | Asttypes.Labelled "_spreadProps", expr -> let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.jsxPropExpr expr with - | Parenthesized | Braced _ -> - (* {(20: int)} make sure that we also protect the expression inside *) - let innerDoc = if Parens.bracedExpr expr then addParens doc else doc in - if leadingLineCommentPresent then addBraces innerDoc - else Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace] - | _ -> doc - in - let fullLoc = {argLoc with loc_end = expr.pexp_loc.loc_end} in - printComments (Doc.concat [lblDoc; exprDoc]) cmtTbl fullLoc + Doc.concat [ Doc.lbrace; Doc.dotdotdot; Doc.softLine; doc; Doc.rbrace ] + | lbl, expr -> + let argLoc, expr = + match expr.pexp_attributes with + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: attrs -> + (loc, { expr with pexp_attributes = attrs }) + | _ -> (Location.none, expr) + in + let lblDoc = + match lbl with + | Asttypes.Labelled lbl -> + let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in + Doc.concat [ lbl; Doc.equal ] + | Asttypes.Optional lbl -> + let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in + Doc.concat [ lbl; Doc.equal; Doc.question ] + | Nolabel -> Doc.nil + in + let exprDoc = + let leadingLineCommentPresent = + hasLeadingLineComment cmtTbl expr.pexp_loc + in + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.jsxPropExpr expr with + | Parenthesized | Braced _ -> + (* {(20: int)} make sure that we also protect the expression inside *) + let innerDoc = + if Parens.bracedExpr expr then addParens doc else doc + in + if leadingLineCommentPresent then addBraces innerDoc + else Doc.concat [ Doc.lbrace; innerDoc; Doc.rbrace ] + | _ -> doc + in + let fullLoc = { argLoc with loc_end = expr.pexp_loc.loc_end } in + printComments (Doc.concat [ lblDoc; exprDoc ]) cmtTbl fullLoc (* div -> div. * Navabar.createElement -> Navbar * Staff.Users.createElement -> Staff.Users *) -and printJsxName {txt = lident} = +and printJsxName { txt = lident } = let rec flatten acc lident = match lident with | Longident.Lident txt -> txt :: acc | Ldot (lident, txt) -> - let acc = if txt = "createElement" then acc else txt :: acc in - flatten acc lident + let acc = if txt = "createElement" then acc else txt :: acc in + flatten acc lident | _ -> acc in match lident with | Longident.Lident txt -> Doc.text txt | _ as lident -> - let segments = flatten [] lident in - Doc.join ~sep:Doc.dot (List.map Doc.text segments) + let segments = flatten [] lident in + Doc.join ~sep:Doc.dot (List.map Doc.text segments) and printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args cmtTbl = @@ -233371,29 +233533,32 @@ and printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args let callback, printedArgs = match args with | (lbl, expr) :: args -> - let lblDoc = - match lbl with - | Asttypes.Nolabel -> Doc.nil - | Asttypes.Labelled txt -> - Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal] - | Asttypes.Optional txt -> - Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal; Doc.question] - in - let callback = - Doc.concat - [ - lblDoc; - printPexpFun ~customLayout ~inCallback:FitsOnOneLine expr cmtTbl; - ] - in - let callback = lazy (printComments callback cmtTbl expr.pexp_loc) in - let printedArgs = - lazy - (Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map (fun arg -> printArgument ~customLayout arg cmtTbl) args)) - in - (callback, printedArgs) + let lblDoc = + match lbl with + | Asttypes.Nolabel -> Doc.nil + | Asttypes.Labelled txt -> + Doc.concat [ Doc.tilde; printIdentLike txt; Doc.equal ] + | Asttypes.Optional txt -> + Doc.concat + [ Doc.tilde; printIdentLike txt; Doc.equal; Doc.question ] + in + let callback = + Doc.concat + [ + lblDoc; + printPexpFun ~customLayout ~inCallback:FitsOnOneLine expr cmtTbl; + ] + in + let callback = lazy (printComments callback cmtTbl expr.pexp_loc) in + let printedArgs = + lazy + (Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun arg -> printArgument ~customLayout arg cmtTbl) + args)) + in + (callback, printedArgs) | _ -> assert false in @@ -233443,7 +233608,7 @@ and printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args *) if customLayout > customLayoutThreshold then Lazy.force breakAllArgs else if Doc.willBreak (Lazy.force printedArgs) then Lazy.force breakAllArgs - else Doc.customLayout [Lazy.force fitsOnOneLine; Lazy.force breakAllArgs] + else Doc.customLayout [ Lazy.force fitsOnOneLine; Lazy.force breakAllArgs ] and printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args cmtTbl = @@ -233456,38 +233621,39 @@ and printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args let rec loop acc args = match args with | [] -> (lazy Doc.nil, lazy Doc.nil, lazy Doc.nil) - | [(lbl, expr)] -> - let lblDoc = - match lbl with - | Asttypes.Nolabel -> Doc.nil - | Asttypes.Labelled txt -> - Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal] - | Asttypes.Optional txt -> - Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal; Doc.question] - in - let callbackFitsOnOneLine = - lazy - (let pexpFunDoc = - printPexpFun ~customLayout ~inCallback:FitsOnOneLine expr cmtTbl - in - let doc = Doc.concat [lblDoc; pexpFunDoc] in - printComments doc cmtTbl expr.pexp_loc) - in - let callbackArgumentsFitsOnOneLine = - lazy - (let pexpFunDoc = - printPexpFun ~customLayout ~inCallback:ArgumentsFitOnOneLine expr - cmtTblCopy - in - let doc = Doc.concat [lblDoc; pexpFunDoc] in - printComments doc cmtTblCopy expr.pexp_loc) - in - ( lazy (Doc.concat (List.rev acc)), - callbackFitsOnOneLine, - callbackArgumentsFitsOnOneLine ) + | [ (lbl, expr) ] -> + let lblDoc = + match lbl with + | Asttypes.Nolabel -> Doc.nil + | Asttypes.Labelled txt -> + Doc.concat [ Doc.tilde; printIdentLike txt; Doc.equal ] + | Asttypes.Optional txt -> + Doc.concat + [ Doc.tilde; printIdentLike txt; Doc.equal; Doc.question ] + in + let callbackFitsOnOneLine = + lazy + (let pexpFunDoc = + printPexpFun ~customLayout ~inCallback:FitsOnOneLine expr cmtTbl + in + let doc = Doc.concat [ lblDoc; pexpFunDoc ] in + printComments doc cmtTbl expr.pexp_loc) + in + let callbackArgumentsFitsOnOneLine = + lazy + (let pexpFunDoc = + printPexpFun ~customLayout ~inCallback:ArgumentsFitOnOneLine expr + cmtTblCopy + in + let doc = Doc.concat [ lblDoc; pexpFunDoc ] in + printComments doc cmtTblCopy expr.pexp_loc) + in + ( lazy (Doc.concat (List.rev acc)), + callbackFitsOnOneLine, + callbackArgumentsFitsOnOneLine ) | arg :: args -> - let argDoc = printArgument ~customLayout arg cmtTbl in - loop (Doc.line :: Doc.comma :: argDoc :: acc) args + let argDoc = printArgument ~customLayout arg cmtTbl in + loop (Doc.line :: Doc.comma :: argDoc :: acc) args in let printedArgs, callback, callback2 = loop [] args in @@ -233560,46 +233726,48 @@ and printArguments ~customLayout ~uncurried | [ ( Nolabel, { - pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _); + pexp_desc = Pexp_construct ({ txt = Longident.Lident "()" }, _); pexp_loc = loc; } ); ] -> ( - (* See "parseCallExpr", ghost unit expression is used the implement - * arity zero vs arity one syntax. - * Related: https://github.com/rescript-lang/syntax/issues/138 *) - match (uncurried, loc.loc_ghost) with - | true, true -> Doc.text "(.)" (* arity zero *) - | true, false -> Doc.text "(. ())" (* arity one *) - | _ -> Doc.text "()") - | [(Nolabel, arg)] when ParsetreeViewer.isHuggableExpression arg -> - let argDoc = - let doc = printExpressionWithComments ~customLayout arg cmtTbl in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc - in - Doc.concat - [(if uncurried then Doc.text "(. " else Doc.lparen); argDoc; Doc.rparen] + (* See "parseCallExpr", ghost unit expression is used the implement + * arity zero vs arity one syntax. + * Related: https://github.com/rescript-lang/syntax/issues/138 *) + match (uncurried, loc.loc_ghost) with + | true, true -> Doc.text "(.)" (* arity zero *) + | true, false -> Doc.text "(. ())" (* arity one *) + | _ -> Doc.text "()") + | [ (Nolabel, arg) ] when ParsetreeViewer.isHuggableExpression arg -> + let argDoc = + let doc = printExpressionWithComments ~customLayout arg cmtTbl in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc + in + Doc.concat + [ + (if uncurried then Doc.text "(. " else Doc.lparen); argDoc; Doc.rparen; + ] | args -> - Doc.group - (Doc.concat - [ - (if uncurried then Doc.text "(." else Doc.lparen); - Doc.indent - (Doc.concat - [ - (if uncurried then Doc.line else Doc.softLine); - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun arg -> printArgument ~customLayout arg cmtTbl) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + (if uncurried then Doc.text "(." else Doc.lparen); + Doc.indent + (Doc.concat + [ + (if uncurried then Doc.line else Doc.softLine); + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun arg -> printArgument ~customLayout arg cmtTbl) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) (* * argument ::= @@ -233620,88 +233788,90 @@ and printArgument ~customLayout (argLbl, arg) cmtTbl = (* ~a (punned)*) | ( Asttypes.Labelled lbl, ({ - pexp_desc = Pexp_ident {txt = Longident.Lident name}; - pexp_attributes = [] | [({Location.txt = "ns.namedArgLoc"}, _)]; + pexp_desc = Pexp_ident { txt = Longident.Lident name }; + pexp_attributes = [] | [ ({ Location.txt = "ns.namedArgLoc" }, _) ]; } as argExpr) ) when lbl = name && not (ParsetreeViewer.isBracedExpr argExpr) -> - let loc = - match arg.pexp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> loc - | _ -> arg.pexp_loc - in - let doc = Doc.concat [Doc.tilde; printIdentLike lbl] in - printComments doc cmtTbl loc + let loc = + match arg.pexp_attributes with + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _ -> loc + | _ -> arg.pexp_loc + in + let doc = Doc.concat [ Doc.tilde; printIdentLike lbl ] in + printComments doc cmtTbl loc (* ~a: int (punned)*) | ( Asttypes.Labelled lbl, { pexp_desc = Pexp_constraint - ( ({pexp_desc = Pexp_ident {txt = Longident.Lident name}} as argExpr), + ( ({ pexp_desc = Pexp_ident { txt = Longident.Lident name } } as + argExpr), typ ); pexp_loc; pexp_attributes = - ([] | [({Location.txt = "ns.namedArgLoc"}, _)]) as attrs; + ([] | [ ({ Location.txt = "ns.namedArgLoc" }, _) ]) as attrs; } ) when lbl = name && not (ParsetreeViewer.isBracedExpr argExpr) -> - let loc = - match attrs with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> - {loc with loc_end = pexp_loc.loc_end} - | _ -> arg.pexp_loc - in - let doc = - Doc.concat - [ - Doc.tilde; - printIdentLike lbl; - Doc.text ": "; - printTypExpr ~customLayout typ cmtTbl; - ] - in - printComments doc cmtTbl loc + let loc = + match attrs with + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _ -> + { loc with loc_end = pexp_loc.loc_end } + | _ -> arg.pexp_loc + in + let doc = + Doc.concat + [ + Doc.tilde; + printIdentLike lbl; + Doc.text ": "; + printTypExpr ~customLayout typ cmtTbl; + ] + in + printComments doc cmtTbl loc (* ~a? (optional lbl punned)*) | ( Asttypes.Optional lbl, { - pexp_desc = Pexp_ident {txt = Longident.Lident name}; - pexp_attributes = [] | [({Location.txt = "ns.namedArgLoc"}, _)]; + pexp_desc = Pexp_ident { txt = Longident.Lident name }; + pexp_attributes = [] | [ ({ Location.txt = "ns.namedArgLoc" }, _) ]; } ) when lbl = name -> - let loc = - match arg.pexp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> loc - | _ -> arg.pexp_loc - in - let doc = Doc.concat [Doc.tilde; printIdentLike lbl; Doc.question] in - printComments doc cmtTbl loc + let loc = + match arg.pexp_attributes with + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _ -> loc + | _ -> arg.pexp_loc + in + let doc = Doc.concat [ Doc.tilde; printIdentLike lbl; Doc.question ] in + printComments doc cmtTbl loc | _lbl, expr -> - let argLoc, expr = - match expr.pexp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: attrs -> - (loc, {expr with pexp_attributes = attrs}) - | _ -> (expr.pexp_loc, expr) - in - let printedLbl = - match argLbl with - | Asttypes.Nolabel -> Doc.nil - | Asttypes.Labelled lbl -> - let doc = Doc.concat [Doc.tilde; printIdentLike lbl; Doc.equal] in - printComments doc cmtTbl argLoc - | Asttypes.Optional lbl -> - let doc = - Doc.concat [Doc.tilde; printIdentLike lbl; Doc.equal; Doc.question] - in - printComments doc cmtTbl argLoc - in - let printedExpr = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - let loc = {argLoc with loc_end = expr.pexp_loc.loc_end} in - let doc = Doc.concat [printedLbl; printedExpr] in - printComments doc cmtTbl loc + let argLoc, expr = + match expr.pexp_attributes with + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: attrs -> + (loc, { expr with pexp_attributes = attrs }) + | _ -> (expr.pexp_loc, expr) + in + let printedLbl = + match argLbl with + | Asttypes.Nolabel -> Doc.nil + | Asttypes.Labelled lbl -> + let doc = Doc.concat [ Doc.tilde; printIdentLike lbl; Doc.equal ] in + printComments doc cmtTbl argLoc + | Asttypes.Optional lbl -> + let doc = + Doc.concat + [ Doc.tilde; printIdentLike lbl; Doc.equal; Doc.question ] + in + printComments doc cmtTbl argLoc + in + let printedExpr = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + let loc = { argLoc with loc_end = expr.pexp_loc.loc_end } in + let doc = Doc.concat [ printedLbl; printedExpr ] in + printComments doc cmtTbl loc and printCases ~customLayout (cases : Parsetree.case list) cmtTbl = Doc.breakableGroup ~forceBreak:true @@ -233728,40 +233898,40 @@ and printCase ~customLayout (case : Parsetree.case) cmtTbl = match case.pc_rhs.pexp_desc with | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ | Pexp_sequence _ -> - printExpressionBlock ~customLayout - ~braces:(ParsetreeViewer.isBracedExpr case.pc_rhs) - case.pc_rhs cmtTbl + printExpressionBlock ~customLayout + ~braces:(ParsetreeViewer.isBracedExpr case.pc_rhs) + case.pc_rhs cmtTbl | _ -> ( - let doc = printExpressionWithComments ~customLayout case.pc_rhs cmtTbl in - match Parens.expr case.pc_rhs with - | Parenthesized -> addParens doc - | _ -> doc) + let doc = + printExpressionWithComments ~customLayout case.pc_rhs cmtTbl + in + match Parens.expr case.pc_rhs with + | Parenthesized -> addParens doc + | _ -> doc) in let guard = match case.pc_guard with | None -> Doc.nil | Some expr -> - Doc.group - (Doc.concat - [ - Doc.line; - Doc.text "if "; - printExpressionWithComments ~customLayout expr cmtTbl; - ]) + Doc.group + (Doc.concat + [ + Doc.line; + Doc.text "if "; + printExpressionWithComments ~customLayout expr cmtTbl; + ]) in let shouldInlineRhs = match case.pc_rhs.pexp_desc with - | Pexp_construct ({txt = Longident.Lident ("()" | "true" | "false")}, _) + | Pexp_construct ({ txt = Longident.Lident ("()" | "true" | "false") }, _) | Pexp_constant _ | Pexp_ident _ -> - true + true | _ when ParsetreeViewer.isHuggableRhs case.pc_rhs -> true | _ -> false in let shouldIndentPattern = - match case.pc_lhs.ppat_desc with - | Ppat_or _ -> false - | _ -> true + match case.pc_lhs.ppat_desc with Ppat_or _ -> false | _ -> true in let patternDoc = let doc = printPattern ~customLayout case.pc_lhs cmtTbl in @@ -233776,10 +233946,11 @@ and printCase ~customLayout (case : Parsetree.case) cmtTbl = Doc.indent guard; Doc.text " =>"; Doc.indent - (Doc.concat [(if shouldInlineRhs then Doc.space else Doc.line); rhs]); + (Doc.concat + [ (if shouldInlineRhs then Doc.space else Doc.line); rhs ]); ] in - Doc.group (Doc.concat [Doc.text "| "; content]) + Doc.group (Doc.concat [ Doc.text "| "; content ]) and printExprFunParameters ~customLayout ~inCallback ~async ~uncurried ~hasConstraint parameters cmtTbl = @@ -233791,15 +233962,15 @@ and printExprFunParameters ~customLayout ~inCallback ~async ~uncurried attrs = []; lbl = Asttypes.Nolabel; defaultExpr = None; - pat = {Parsetree.ppat_desc = Ppat_any; ppat_loc}; + pat = { Parsetree.ppat_desc = Ppat_any; ppat_loc }; }; ] when not uncurried -> - let any = - let doc = if hasConstraint then Doc.text "(_)" else Doc.text "_" in - printComments doc cmtTbl ppat_loc - in - if async then addAsync any else any + let any = + let doc = if hasConstraint then Doc.text "(_)" else Doc.text "_" in + printComments doc cmtTbl ppat_loc + in + if async then addAsync any else any (* let f = a => () *) | [ ParsetreeViewer.Parameter @@ -233807,16 +233978,16 @@ and printExprFunParameters ~customLayout ~inCallback ~async ~uncurried attrs = []; lbl = Asttypes.Nolabel; defaultExpr = None; - pat = {Parsetree.ppat_desc = Ppat_var stringLoc}; + pat = { Parsetree.ppat_desc = Ppat_var stringLoc }; }; ] when not uncurried -> - let txtDoc = - let var = printIdentLike stringLoc.txt in - let var = if hasConstraint then addParens var else var in - if async then addAsync var else var - in - printComments txtDoc cmtTbl stringLoc.loc + let txtDoc = + let var = printIdentLike stringLoc.txt in + let var = if hasConstraint then addParens var else var in + if async then addAsync var else var + in + printComments txtDoc cmtTbl stringLoc.loc (* let f = () => () *) | [ ParsetreeViewer.Parameter @@ -233825,250 +233996,264 @@ and printExprFunParameters ~customLayout ~inCallback ~async ~uncurried lbl = Asttypes.Nolabel; defaultExpr = None; pat = - {ppat_desc = Ppat_construct ({txt = Longident.Lident "()"; loc}, None)}; + { + ppat_desc = + Ppat_construct ({ txt = Longident.Lident "()"; loc }, None); + }; }; ] when not uncurried -> - let doc = - let lparenRparen = Doc.text "()" in - if async then addAsync lparenRparen else lparenRparen - in - printComments doc cmtTbl loc + let doc = + let lparenRparen = Doc.text "()" in + if async then addAsync lparenRparen else lparenRparen + in + printComments doc cmtTbl loc (* let f = (~greeting, ~from as hometown, ~x=?) => () *) | parameters -> - let inCallback = - match inCallback with - | FitsOnOneLine -> true - | _ -> false - in - let maybeAsyncLparen = - let lparen = if uncurried then Doc.text "(. " else Doc.lparen in - if async then addAsync lparen else lparen - in - let shouldHug = ParsetreeViewer.parametersShouldHug parameters in - let printedParamaters = - Doc.concat - [ - (if shouldHug || inCallback then Doc.nil else Doc.softLine); - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun p -> printExpFunParameter ~customLayout p cmtTbl) - parameters); - ] - in - Doc.group - (Doc.concat - [ - maybeAsyncLparen; - (if shouldHug || inCallback then printedParamaters - else - Doc.concat - [Doc.indent printedParamaters; Doc.trailingComma; Doc.softLine]); - Doc.rparen; - ]) - -and printExpFunParameter ~customLayout parameter cmtTbl = - match parameter with - | ParsetreeViewer.NewTypes {attrs; locs = lbls} -> - Doc.group - (Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - Doc.text "type "; - Doc.join ~sep:Doc.space - (List.map - (fun lbl -> - printComments - (printIdentLike lbl.Asttypes.txt) - cmtTbl lbl.Asttypes.loc) - lbls); - ]) - | Parameter {attrs; lbl; defaultExpr; pat = pattern} -> - let isUncurried, attrs = ParsetreeViewer.processUncurriedAttribute attrs in - let uncurried = - if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil - in - let attrs = printAttributes ~customLayout attrs cmtTbl in - (* =defaultValue *) - let defaultExprDoc = - match defaultExpr with - | Some expr -> - Doc.concat - [Doc.text "="; printExpressionWithComments ~customLayout expr cmtTbl] - | None -> Doc.nil - in - (* ~from as hometown - * ~from -> punning *) - let labelWithPattern = - match (lbl, pattern) with - | Asttypes.Nolabel, pattern -> printPattern ~customLayout pattern cmtTbl - | ( (Asttypes.Labelled lbl | Optional lbl), - { - ppat_desc = Ppat_var stringLoc; - ppat_attributes = [] | [({Location.txt = "ns.namedArgLoc"}, _)]; - } ) - when lbl = stringLoc.txt -> - (* ~d *) - Doc.concat [Doc.text "~"; printIdentLike lbl] - | ( (Asttypes.Labelled lbl | Optional lbl), - { - ppat_desc = Ppat_constraint ({ppat_desc = Ppat_var {txt}}, typ); - ppat_attributes = [] | [({Location.txt = "ns.namedArgLoc"}, _)]; - } ) - when lbl = txt -> - (* ~d: e *) - Doc.concat - [ - Doc.text "~"; - printIdentLike lbl; - Doc.text ": "; - printTypExpr ~customLayout typ cmtTbl; - ] - | (Asttypes.Labelled lbl | Optional lbl), pattern -> - (* ~b as c *) + let inCallback = + match inCallback with FitsOnOneLine -> true | _ -> false + in + let maybeAsyncLparen = + let lparen = if uncurried then Doc.text "(. " else Doc.lparen in + if async then addAsync lparen else lparen + in + let shouldHug = ParsetreeViewer.parametersShouldHug parameters in + let printedParamaters = Doc.concat [ - Doc.text "~"; - printIdentLike lbl; - Doc.text " as "; - printPattern ~customLayout pattern cmtTbl; + (if shouldHug || inCallback then Doc.nil else Doc.softLine); + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun p -> printExpFunParameter ~customLayout p cmtTbl) + parameters); ] - in - let optionalLabelSuffix = - match (lbl, defaultExpr) with - | Asttypes.Optional _, None -> Doc.text "=?" - | _ -> Doc.nil - in - let doc = + in Doc.group (Doc.concat [ - uncurried; - attrs; - labelWithPattern; - defaultExprDoc; - optionalLabelSuffix; + maybeAsyncLparen; + (if shouldHug || inCallback then printedParamaters + else + Doc.concat + [ + Doc.indent printedParamaters; Doc.trailingComma; Doc.softLine; + ]); + Doc.rparen; ]) - in - let cmtLoc = - match defaultExpr with - | None -> ( - match pattern.ppat_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> - {loc with loc_end = pattern.ppat_loc.loc_end} - | _ -> pattern.ppat_loc) - | Some expr -> - let startPos = - match pattern.ppat_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> loc.loc_start - | _ -> pattern.ppat_loc.loc_start - in - { - pattern.ppat_loc with - loc_start = startPos; - loc_end = expr.pexp_loc.loc_end; - } - in - printComments doc cmtTbl cmtLoc + +and printExpFunParameter ~customLayout parameter cmtTbl = + match parameter with + | ParsetreeViewer.NewTypes { attrs; locs = lbls } -> + Doc.group + (Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + Doc.text "type "; + Doc.join ~sep:Doc.space + (List.map + (fun lbl -> + printComments + (printIdentLike lbl.Asttypes.txt) + cmtTbl lbl.Asttypes.loc) + lbls); + ]) + | Parameter { attrs; lbl; defaultExpr; pat = pattern } -> + let isUncurried, attrs = + ParsetreeViewer.processUncurriedAttribute attrs + in + let uncurried = + if isUncurried then Doc.concat [ Doc.dot; Doc.space ] else Doc.nil + in + let attrs = printAttributes ~customLayout attrs cmtTbl in + (* =defaultValue *) + let defaultExprDoc = + match defaultExpr with + | Some expr -> + Doc.concat + [ + Doc.text "="; + printExpressionWithComments ~customLayout expr cmtTbl; + ] + | None -> Doc.nil + in + (* ~from as hometown + * ~from -> punning *) + let labelWithPattern = + match (lbl, pattern) with + | Asttypes.Nolabel, pattern -> printPattern ~customLayout pattern cmtTbl + | ( (Asttypes.Labelled lbl | Optional lbl), + { + ppat_desc = Ppat_var stringLoc; + ppat_attributes = + [] | [ ({ Location.txt = "ns.namedArgLoc" }, _) ]; + } ) + when lbl = stringLoc.txt -> + (* ~d *) + Doc.concat [ Doc.text "~"; printIdentLike lbl ] + | ( (Asttypes.Labelled lbl | Optional lbl), + { + ppat_desc = Ppat_constraint ({ ppat_desc = Ppat_var { txt } }, typ); + ppat_attributes = + [] | [ ({ Location.txt = "ns.namedArgLoc" }, _) ]; + } ) + when lbl = txt -> + (* ~d: e *) + Doc.concat + [ + Doc.text "~"; + printIdentLike lbl; + Doc.text ": "; + printTypExpr ~customLayout typ cmtTbl; + ] + | (Asttypes.Labelled lbl | Optional lbl), pattern -> + (* ~b as c *) + Doc.concat + [ + Doc.text "~"; + printIdentLike lbl; + Doc.text " as "; + printPattern ~customLayout pattern cmtTbl; + ] + in + let optionalLabelSuffix = + match (lbl, defaultExpr) with + | Asttypes.Optional _, None -> Doc.text "=?" + | _ -> Doc.nil + in + let doc = + Doc.group + (Doc.concat + [ + uncurried; + attrs; + labelWithPattern; + defaultExprDoc; + optionalLabelSuffix; + ]) + in + let cmtLoc = + match defaultExpr with + | None -> ( + match pattern.ppat_attributes with + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _ -> + { loc with loc_end = pattern.ppat_loc.loc_end } + | _ -> pattern.ppat_loc) + | Some expr -> + let startPos = + match pattern.ppat_attributes with + | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _ -> + loc.loc_start + | _ -> pattern.ppat_loc.loc_start + in + { + pattern.ppat_loc with + loc_start = startPos; + loc_end = expr.pexp_loc.loc_end; + } + in + printComments doc cmtTbl cmtLoc and printExpressionBlock ~customLayout ~braces expr cmtTbl = let rec collectRows acc expr = match expr.Parsetree.pexp_desc with | Parsetree.Pexp_letmodule (modName, modExpr, expr2) -> - let name = - let doc = Doc.text modName.txt in - printComments doc cmtTbl modName.loc - in - let letModuleDoc = - Doc.concat - [ - Doc.text "module "; - name; - Doc.text " = "; - printModExpr ~customLayout modExpr cmtTbl; - ] - in - let loc = {expr.pexp_loc with loc_end = modExpr.pmod_loc.loc_end} in - collectRows ((loc, letModuleDoc) :: acc) expr2 + let name = + let doc = Doc.text modName.txt in + printComments doc cmtTbl modName.loc + in + let letModuleDoc = + Doc.concat + [ + Doc.text "module "; + name; + Doc.text " = "; + printModExpr ~customLayout modExpr cmtTbl; + ] + in + let loc = { expr.pexp_loc with loc_end = modExpr.pmod_loc.loc_end } in + collectRows ((loc, letModuleDoc) :: acc) expr2 | Pexp_letexception (extensionConstructor, expr2) -> - let loc = let loc = - {expr.pexp_loc with loc_end = extensionConstructor.pext_loc.loc_end} + let loc = + { + expr.pexp_loc with + loc_end = extensionConstructor.pext_loc.loc_end; + } + in + match getFirstLeadingComment cmtTbl loc with + | None -> loc + | Some comment -> + let cmtLoc = Comment.loc comment in + { cmtLoc with loc_end = loc.loc_end } in - match getFirstLeadingComment cmtTbl loc with - | None -> loc - | Some comment -> - let cmtLoc = Comment.loc comment in - {cmtLoc with loc_end = loc.loc_end} - in - let letExceptionDoc = - printExceptionDef ~customLayout extensionConstructor cmtTbl - in - collectRows ((loc, letExceptionDoc) :: acc) expr2 + let letExceptionDoc = + printExceptionDef ~customLayout extensionConstructor cmtTbl + in + collectRows ((loc, letExceptionDoc) :: acc) expr2 | Pexp_open (overrideFlag, longidentLoc, expr2) -> - let openDoc = - Doc.concat - [ - Doc.text "open"; - printOverrideFlag overrideFlag; - Doc.space; - printLongidentLocation longidentLoc cmtTbl; - ] - in - let loc = {expr.pexp_loc with loc_end = longidentLoc.loc.loc_end} in - collectRows ((loc, openDoc) :: acc) expr2 + let openDoc = + Doc.concat + [ + Doc.text "open"; + printOverrideFlag overrideFlag; + Doc.space; + printLongidentLocation longidentLoc cmtTbl; + ] + in + let loc = { expr.pexp_loc with loc_end = longidentLoc.loc.loc_end } in + collectRows ((loc, openDoc) :: acc) expr2 | Pexp_sequence (expr1, expr2) -> - let exprDoc = - let doc = printExpression ~customLayout expr1 cmtTbl in - match Parens.expr expr1 with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr1 braces - | Nothing -> doc - in - let loc = expr1.pexp_loc in - collectRows ((loc, exprDoc) :: acc) expr2 + let exprDoc = + let doc = printExpression ~customLayout expr1 cmtTbl in + match Parens.expr expr1 with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr1 braces + | Nothing -> doc + in + let loc = expr1.pexp_loc in + collectRows ((loc, exprDoc) :: acc) expr2 | Pexp_let (recFlag, valueBindings, expr2) -> ( - let loc = let loc = - match (valueBindings, List.rev valueBindings) with - | vb :: _, lastVb :: _ -> - {vb.pvb_loc with loc_end = lastVb.pvb_loc.loc_end} - | _ -> Location.none + let loc = + match (valueBindings, List.rev valueBindings) with + | vb :: _, lastVb :: _ -> + { vb.pvb_loc with loc_end = lastVb.pvb_loc.loc_end } + | _ -> Location.none + in + match getFirstLeadingComment cmtTbl loc with + | None -> loc + | Some comment -> + let cmtLoc = Comment.loc comment in + { cmtLoc with loc_end = loc.loc_end } in - match getFirstLeadingComment cmtTbl loc with - | None -> loc - | Some comment -> - let cmtLoc = Comment.loc comment in - {cmtLoc with loc_end = loc.loc_end} - in - let recFlag = - match recFlag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - let letDoc = - printValueBindings ~customLayout ~recFlag valueBindings cmtTbl - in - (* let () = { - * let () = foo() - * () - * } - * We don't need to print the () on the last line of the block - *) - match expr2.pexp_desc with - | Pexp_construct ({txt = Longident.Lident "()"}, _) -> - List.rev ((loc, letDoc) :: acc) - | _ -> collectRows ((loc, letDoc) :: acc) expr2) + let recFlag = + match recFlag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + let letDoc = + printValueBindings ~customLayout ~recFlag valueBindings cmtTbl + in + (* let () = { + * let () = foo() + * () + * } + * We don't need to print the () on the last line of the block + *) + match expr2.pexp_desc with + | Pexp_construct ({ txt = Longident.Lident "()" }, _) -> + List.rev ((loc, letDoc) :: acc) + | _ -> collectRows ((loc, letDoc) :: acc) expr2) | _ -> - let exprDoc = - let doc = printExpression ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - List.rev ((expr.pexp_loc, exprDoc) :: acc) + let exprDoc = + let doc = printExpression ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + List.rev ((expr.pexp_loc, exprDoc) :: acc) in let rows = collectRows [] expr in let block = @@ -234081,7 +234266,7 @@ and printExpressionBlock ~customLayout ~braces expr cmtTbl = Doc.concat [ Doc.lbrace; - Doc.indent (Doc.concat [Doc.line; block]); + Doc.indent (Doc.concat [ Doc.line; block ]); Doc.line; Doc.rbrace; ] @@ -234112,27 +234297,25 @@ and printBraces doc expr bracesLoc = match expr.Parsetree.pexp_desc with | Pexp_letmodule _ | Pexp_letexception _ | Pexp_let _ | Pexp_open _ | Pexp_sequence _ -> - (* already has braces *) - doc + (* already has braces *) + doc | _ -> - Doc.breakableGroup ~forceBreak:overMultipleLines - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - (if Parens.bracedExpr expr then addParens doc else doc); - ]); - Doc.softLine; - Doc.rbrace; - ]) + Doc.breakableGroup ~forceBreak:overMultipleLines + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.softLine; + (if Parens.bracedExpr expr then addParens doc else doc); + ]); + Doc.softLine; + Doc.rbrace; + ]) and printOverrideFlag overrideFlag = - match overrideFlag with - | Asttypes.Override -> Doc.text "!" - | Fresh -> Doc.nil + match overrideFlag with Asttypes.Override -> Doc.text "!" | Fresh -> Doc.nil and printDirectionFlag flag = match flag with @@ -234140,39 +234323,41 @@ and printDirectionFlag flag = | Asttypes.Upto -> Doc.text " to " and printExpressionRecordRow ~customLayout (lbl, expr) cmtTbl punningAllowed = - let cmtLoc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in + let cmtLoc = { lbl.loc with loc_end = expr.pexp_loc.loc_end } in let doc = Doc.group (match expr.pexp_desc with - | Pexp_ident {txt = Lident key; loc = _keyLoc} + | Pexp_ident { txt = Lident key; loc = _keyLoc } when punningAllowed && Longident.last lbl.txt = key -> - (* print punned field *) - Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - printOptionalLabel expr.pexp_attributes; - printLidentPath lbl cmtTbl; - ] + (* print punned field *) + Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + printOptionalLabel expr.pexp_attributes; + printLidentPath lbl cmtTbl; + ] | _ -> - Doc.concat - [ - printLidentPath lbl cmtTbl; - Doc.text ": "; - printOptionalLabel expr.pexp_attributes; - (let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); - ]) + Doc.concat + [ + printLidentPath lbl cmtTbl; + Doc.text ": "; + printOptionalLabel expr.pexp_attributes; + (let doc = + printExpressionWithComments ~customLayout expr cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + ]) in printComments doc cmtTbl cmtLoc and printBsObjectRow ~customLayout (lbl, expr) cmtTbl = - let cmtLoc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in + let cmtLoc = { lbl.loc with loc_end = expr.pexp_loc.loc_end } in let lblDoc = let doc = - Doc.concat [Doc.text "\""; printLongident lbl.txt; Doc.text "\""] + Doc.concat [ Doc.text "\""; printLongident lbl.txt; Doc.text "\"" ] in printComments doc cmtTbl lbl.loc in @@ -234201,46 +234386,80 @@ and printAttributes ?loc ?(inline = false) ~customLayout match ParsetreeViewer.filterParsingAttrs attrs with | [] -> Doc.nil | attrs -> - let lineBreak = - match loc with - | None -> Doc.line - | Some loc -> ( - match List.rev attrs with - | ({loc = firstLoc}, _) :: _ - when loc.loc_start.pos_lnum > firstLoc.loc_end.pos_lnum -> - Doc.hardLine - | _ -> Doc.line) - in - Doc.concat - [ - Doc.group - (Doc.joinWithSep - (List.map - (fun attr -> printAttribute ~customLayout attr cmtTbl) - attrs)); - (if inline then Doc.space else lineBreak); - ] + let lineBreak = + match loc with + | None -> Doc.line + | Some loc -> ( + match List.rev attrs with + | ({ loc = firstLoc }, _) :: _ + when loc.loc_start.pos_lnum > firstLoc.loc_end.pos_lnum -> + Doc.hardLine + | _ -> Doc.line) + in + Doc.concat + [ + Doc.group + (Doc.joinWithSep + (List.map + (fun attr -> printAttribute ~customLayout attr cmtTbl) + attrs)); + (if inline then Doc.space else lineBreak); + ] and printPayload ~customLayout (payload : Parsetree.payload) cmtTbl = match payload with | PStr [] -> Doc.nil - | PStr [{pstr_desc = Pstr_eval (expr, attrs)}] -> - let exprDoc = printExpressionWithComments ~customLayout expr cmtTbl in - let needsParens = - match attrs with - | [] -> false - | _ -> true - in - let shouldHug = ParsetreeViewer.isHuggableExpression expr in - if shouldHug then + | PStr [ { pstr_desc = Pstr_eval (expr, attrs) } ] -> + let exprDoc = printExpressionWithComments ~customLayout expr cmtTbl in + let needsParens = match attrs with [] -> false | _ -> true in + let shouldHug = ParsetreeViewer.isHuggableExpression expr in + if shouldHug then + Doc.concat + [ + Doc.lparen; + printAttributes ~customLayout attrs cmtTbl; + (if needsParens then addParens exprDoc else exprDoc); + Doc.rparen; + ] + else + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + printAttributes ~customLayout attrs cmtTbl; + (if needsParens then addParens exprDoc else exprDoc); + ]); + Doc.softLine; + Doc.rparen; + ] + | PStr [ ({ pstr_desc = Pstr_value (_recFlag, _bindings) } as si) ] -> + addParens (printStructureItem ~customLayout si cmtTbl) + | PStr structure -> addParens (printStructure ~customLayout structure cmtTbl) + | PTyp typ -> Doc.concat [ Doc.lparen; - printAttributes ~customLayout attrs cmtTbl; - (if needsParens then addParens exprDoc else exprDoc); + Doc.text ":"; + Doc.indent + (Doc.concat [ Doc.line; printTypExpr ~customLayout typ cmtTbl ]); + Doc.softLine; Doc.rparen; ] - else + | PPat (pat, optExpr) -> + let whenDoc = + match optExpr with + | Some expr -> + Doc.concat + [ + Doc.line; + Doc.text "if "; + printExpressionWithComments ~customLayout expr cmtTbl; + ] + | None -> Doc.nil + in Doc.concat [ Doc.lparen; @@ -234248,217 +234467,193 @@ and printPayload ~customLayout (payload : Parsetree.payload) cmtTbl = (Doc.concat [ Doc.softLine; - printAttributes ~customLayout attrs cmtTbl; - (if needsParens then addParens exprDoc else exprDoc); + Doc.text "? "; + printPattern ~customLayout pat cmtTbl; + whenDoc; ]); Doc.softLine; Doc.rparen; ] - | PStr [({pstr_desc = Pstr_value (_recFlag, _bindings)} as si)] -> - addParens (printStructureItem ~customLayout si cmtTbl) - | PStr structure -> addParens (printStructure ~customLayout structure cmtTbl) - | PTyp typ -> - Doc.concat - [ - Doc.lparen; - Doc.text ":"; - Doc.indent - (Doc.concat [Doc.line; printTypExpr ~customLayout typ cmtTbl]); - Doc.softLine; - Doc.rparen; - ] - | PPat (pat, optExpr) -> - let whenDoc = - match optExpr with - | Some expr -> - Doc.concat - [ - Doc.line; - Doc.text "if "; - printExpressionWithComments ~customLayout expr cmtTbl; - ] - | None -> Doc.nil - in - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.text "? "; - printPattern ~customLayout pat cmtTbl; - whenDoc; - ]); - Doc.softLine; - Doc.rparen; - ] | PSig signature -> - Doc.concat - [ - Doc.lparen; - Doc.text ":"; - Doc.indent - (Doc.concat [Doc.line; printSignature ~customLayout signature cmtTbl]); - Doc.softLine; - Doc.rparen; - ] + Doc.concat + [ + Doc.lparen; + Doc.text ":"; + Doc.indent + (Doc.concat + [ Doc.line; printSignature ~customLayout signature cmtTbl ]); + Doc.softLine; + Doc.rparen; + ] and printAttribute ?(standalone = false) ~customLayout ((id, payload) : Parsetree.attribute) cmtTbl = match (id, payload) with - | ( {txt = "ns.doc"}, + | ( { txt = "ns.doc" }, PStr [ { pstr_desc = - Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (txt, _))}, _); + Pstr_eval + ({ pexp_desc = Pexp_constant (Pconst_string (txt, _)) }, _); }; ] ) -> - ( Doc.concat - [ - Doc.text (if standalone then "/***" else "/**"); - Doc.text txt; - Doc.text "*/"; - ], - Doc.hardLine ) + ( Doc.concat + [ + Doc.text (if standalone then "/***" else "/**"); + Doc.text txt; + Doc.text "*/"; + ], + Doc.hardLine ) | _ -> - ( Doc.group - (Doc.concat - [ - Doc.text (if standalone then "@@" else "@"); - Doc.text (convertBsExternalAttribute id.txt); - printPayload ~customLayout payload cmtTbl; - ]), - Doc.line ) + ( Doc.group + (Doc.concat + [ + Doc.text (if standalone then "@@" else "@"); + Doc.text (convertBsExternalAttribute id.txt); + printPayload ~customLayout payload cmtTbl; + ]), + Doc.line ) and printModExpr ~customLayout modExpr cmtTbl = let doc = match modExpr.pmod_desc with | Pmod_ident longidentLoc -> printLongidentLocation longidentLoc cmtTbl | Pmod_structure [] -> - let shouldBreak = - modExpr.pmod_loc.loc_start.pos_lnum < modExpr.pmod_loc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak:shouldBreak - (Doc.concat - [Doc.lbrace; printCommentsInside cmtTbl modExpr.pmod_loc; Doc.rbrace]) + let shouldBreak = + modExpr.pmod_loc.loc_start.pos_lnum + < modExpr.pmod_loc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak:shouldBreak + (Doc.concat + [ + Doc.lbrace; + printCommentsInside cmtTbl modExpr.pmod_loc; + Doc.rbrace; + ]) | Pmod_structure structure -> - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [Doc.softLine; printStructure ~customLayout structure cmtTbl]); - Doc.softLine; - Doc.rbrace; - ]) + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.softLine; + printStructure ~customLayout structure cmtTbl; + ]); + Doc.softLine; + Doc.rbrace; + ]) | Pmod_unpack expr -> - let shouldHug = - match expr.pexp_desc with - | Pexp_let _ -> true - | Pexp_constraint - ({pexp_desc = Pexp_let _}, {ptyp_desc = Ptyp_package _packageType}) - -> - true - | _ -> false - in - let expr, moduleConstraint = - match expr.pexp_desc with - | Pexp_constraint - (expr, {ptyp_desc = Ptyp_package packageType; ptyp_loc}) -> - let packageDoc = - let doc = - printPackageType ~customLayout ~printModuleKeywordAndParens:false - packageType cmtTbl - in - printComments doc cmtTbl ptyp_loc - in - let typeDoc = - Doc.group - (Doc.concat - [Doc.text ":"; Doc.indent (Doc.concat [Doc.line; packageDoc])]) - in - (expr, typeDoc) - | _ -> (expr, Doc.nil) - in - let unpackDoc = + let shouldHug = + match expr.pexp_desc with + | Pexp_let _ -> true + | Pexp_constraint + ( { pexp_desc = Pexp_let _ }, + { ptyp_desc = Ptyp_package _packageType } ) -> + true + | _ -> false + in + let expr, moduleConstraint = + match expr.pexp_desc with + | Pexp_constraint + (expr, { ptyp_desc = Ptyp_package packageType; ptyp_loc }) -> + let packageDoc = + let doc = + printPackageType ~customLayout + ~printModuleKeywordAndParens:false packageType cmtTbl + in + printComments doc cmtTbl ptyp_loc + in + let typeDoc = + Doc.group + (Doc.concat + [ + Doc.text ":"; + Doc.indent (Doc.concat [ Doc.line; packageDoc ]); + ]) + in + (expr, typeDoc) + | _ -> (expr, Doc.nil) + in + let unpackDoc = + Doc.group + (Doc.concat + [ + printExpressionWithComments ~customLayout expr cmtTbl; + moduleConstraint; + ]) + in Doc.group (Doc.concat [ - printExpressionWithComments ~customLayout expr cmtTbl; - moduleConstraint; + Doc.text "unpack("; + (if shouldHug then unpackDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [ Doc.softLine; unpackDoc ]); + Doc.softLine; + ]); + Doc.rparen; ]) - in - Doc.group - (Doc.concat - [ - Doc.text "unpack("; - (if shouldHug then unpackDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [Doc.softLine; unpackDoc]); - Doc.softLine; - ]); - Doc.rparen; - ]) | Pmod_extension extension -> - printExtension ~customLayout ~atModuleLvl:false extension cmtTbl + printExtension ~customLayout ~atModuleLvl:false extension cmtTbl | Pmod_apply _ -> - let args, callExpr = ParsetreeViewer.modExprApply modExpr in - let isUnitSugar = - match args with - | [{pmod_desc = Pmod_structure []}] -> true - | _ -> false - in - let shouldHug = - match args with - | [{pmod_desc = Pmod_structure _}] -> true - | _ -> false - in - Doc.group - (Doc.concat - [ - printModExpr ~customLayout callExpr cmtTbl; - (if isUnitSugar then - printModApplyArg ~customLayout - (List.hd args [@doesNotRaise]) - cmtTbl - else - Doc.concat - [ - Doc.lparen; - (if shouldHug then - printModApplyArg ~customLayout - (List.hd args [@doesNotRaise]) - cmtTbl - else - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun modArg -> - printModApplyArg ~customLayout modArg cmtTbl) - args); - ])); - (if not shouldHug then - Doc.concat [Doc.trailingComma; Doc.softLine] - else Doc.nil); - Doc.rparen; - ]); - ]) + let args, callExpr = ParsetreeViewer.modExprApply modExpr in + let isUnitSugar = + match args with + | [ { pmod_desc = Pmod_structure [] } ] -> true + | _ -> false + in + let shouldHug = + match args with + | [ { pmod_desc = Pmod_structure _ } ] -> true + | _ -> false + in + Doc.group + (Doc.concat + [ + printModExpr ~customLayout callExpr cmtTbl; + (if isUnitSugar then + printModApplyArg ~customLayout + (List.hd args [@doesNotRaise]) + cmtTbl + else + Doc.concat + [ + Doc.lparen; + (if shouldHug then + printModApplyArg ~customLayout + (List.hd args [@doesNotRaise]) + cmtTbl + else + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun modArg -> + printModApplyArg ~customLayout modArg + cmtTbl) + args); + ])); + (if not shouldHug then + Doc.concat [ Doc.trailingComma; Doc.softLine ] + else Doc.nil); + Doc.rparen; + ]); + ]) | Pmod_constraint (modExpr, modType) -> - Doc.concat - [ - printModExpr ~customLayout modExpr cmtTbl; - Doc.text ": "; - printModType ~customLayout modType cmtTbl; - ] + Doc.concat + [ + printModExpr ~customLayout modExpr cmtTbl; + Doc.text ": "; + printModType ~customLayout modType cmtTbl; + ] | Pmod_functor _ -> printModFunctor ~customLayout modExpr cmtTbl in printComments doc cmtTbl modExpr.pmod_loc @@ -234473,51 +234668,52 @@ and printModFunctor ~customLayout modExpr cmtTbl = let returnConstraint, returnModExpr = match returnModExpr.pmod_desc with | Pmod_constraint (modExpr, modType) -> - let constraintDoc = - let doc = printModType ~customLayout modType cmtTbl in - if Parens.modExprFunctorConstraint modType then addParens doc else doc - in - let modConstraint = Doc.concat [Doc.text ": "; constraintDoc] in - (modConstraint, printModExpr ~customLayout modExpr cmtTbl) + let constraintDoc = + let doc = printModType ~customLayout modType cmtTbl in + if Parens.modExprFunctorConstraint modType then addParens doc else doc + in + let modConstraint = Doc.concat [ Doc.text ": "; constraintDoc ] in + (modConstraint, printModExpr ~customLayout modExpr cmtTbl) | _ -> (Doc.nil, printModExpr ~customLayout returnModExpr cmtTbl) in let parametersDoc = match parameters with - | [(attrs, {txt = "*"}, None)] -> - Doc.group - (Doc.concat [printAttributes ~customLayout attrs cmtTbl; Doc.text "()"]) - | [([], {txt = lbl}, None)] -> Doc.text lbl + | [ (attrs, { txt = "*" }, None) ] -> + Doc.group + (Doc.concat + [ printAttributes ~customLayout attrs cmtTbl; Doc.text "()" ]) + | [ ([], { txt = lbl }, None) ] -> Doc.text lbl | parameters -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun param -> - printModFunctorParam ~customLayout param cmtTbl) - parameters); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun param -> + printModFunctorParam ~customLayout param cmtTbl) + parameters); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) in Doc.group (Doc.concat - [parametersDoc; returnConstraint; Doc.text " => "; returnModExpr]) + [ parametersDoc; returnConstraint; Doc.text " => "; returnModExpr ]) and printModFunctorParam ~customLayout (attrs, lbl, optModType) cmtTbl = let cmtLoc = match optModType with | None -> lbl.Asttypes.loc | Some modType -> - {lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end} + { lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end } in let attrs = printAttributes ~customLayout attrs cmtTbl in let lblDoc = @@ -234533,8 +234729,8 @@ and printModFunctorParam ~customLayout (attrs, lbl, optModType) cmtTbl = (match optModType with | None -> Doc.nil | Some modType -> - Doc.concat - [Doc.text ": "; printModType ~customLayout modType cmtTbl]); + Doc.concat + [ Doc.text ": "; printModType ~customLayout modType cmtTbl ]); ]) in printComments doc cmtTbl cmtLoc @@ -234549,22 +234745,25 @@ and printExceptionDef ~customLayout (constr : Parsetree.extension_constructor) let kind = match constr.pext_kind with | Pext_rebind longident -> - Doc.indent - (Doc.concat - [Doc.text " ="; Doc.line; printLongidentLocation longident cmtTbl]) + Doc.indent + (Doc.concat + [ + Doc.text " ="; Doc.line; printLongidentLocation longident cmtTbl; + ]) | Pext_decl (Pcstr_tuple [], None) -> Doc.nil | Pext_decl (args, gadt) -> - let gadtDoc = - match gadt with - | Some typ -> - Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ cmtTbl] - | None -> Doc.nil - in - Doc.concat - [ - printConstructorArguments ~customLayout ~indent:false args cmtTbl; - gadtDoc; - ] + let gadtDoc = + match gadt with + | Some typ -> + Doc.concat + [ Doc.text ": "; printTypExpr ~customLayout typ cmtTbl ] + | None -> Doc.nil + in + Doc.concat + [ + printConstructorArguments ~customLayout ~indent:false args cmtTbl; + gadtDoc; + ] in let name = printComments (Doc.text constr.pext_name.txt) cmtTbl constr.pext_name.loc @@ -234590,27 +234789,30 @@ and printExtensionConstructor ~customLayout let kind = match constr.pext_kind with | Pext_rebind longident -> - Doc.indent - (Doc.concat - [Doc.text " ="; Doc.line; printLongidentLocation longident cmtTbl]) + Doc.indent + (Doc.concat + [ + Doc.text " ="; Doc.line; printLongidentLocation longident cmtTbl; + ]) | Pext_decl (Pcstr_tuple [], None) -> Doc.nil | Pext_decl (args, gadt) -> - let gadtDoc = - match gadt with - | Some typ -> - Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ cmtTbl] - | None -> Doc.nil - in - Doc.concat - [ - printConstructorArguments ~customLayout ~indent:false args cmtTbl; - gadtDoc; - ] + let gadtDoc = + match gadt with + | Some typ -> + Doc.concat + [ Doc.text ": "; printTypExpr ~customLayout typ cmtTbl ] + | None -> Doc.nil + in + Doc.concat + [ + printConstructorArguments ~customLayout ~indent:false args cmtTbl; + gadtDoc; + ] in let name = printComments (Doc.text constr.pext_name.txt) cmtTbl constr.pext_name.loc in - Doc.concat [bar; Doc.group (Doc.concat [attrs; name; kind])] + Doc.concat [ bar; Doc.group (Doc.concat [ attrs; name; kind ]) ] let printTypeParams = printTypeParams ~customLayout:0 let printTypExpr = printTypExpr ~customLayout:0 @@ -257331,7 +257533,7 @@ and expression_desc cxt ~(level : int) f x : cxt = match v with | Float { f } -> Js_number.caml_float_literal_to_js_string f (* attach string here for float constant folding?*) - | Int { i; c = Some c } -> Format.asprintf "/* %s */%ld" (Pprintast.string_of_int_as_char c) i + | Int { i; c = Some c } -> Format.asprintf "/* %s */%ld" (Ext_util.string_of_int_as_char c) i | Int { i; c = None } -> Int32.to_string i (* check , js convention with ocaml lexical convention *) @@ -263145,13 +263347,6 @@ end = struct open Format open Asttypes -let string_of_int_as_char i = - if i >= 0 && i <= 255 - then - Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) - else - Printf.sprintf "\'\\%d\'" i - let rec struct_const ppf (cst : Lam_constant.t) = match cst with | Const_js_true -> fprintf ppf "#true" @@ -263160,7 +263355,7 @@ let rec struct_const ppf (cst : Lam_constant.t) = | Const_module_alias -> fprintf ppf "#alias" | Const_js_undefined -> fprintf ppf "#undefined" | Const_int { i } -> fprintf ppf "%ld" i - | Const_char i -> fprintf ppf "%s" (string_of_int_as_char i) + | Const_char i -> fprintf ppf "%s" (Ext_util.string_of_int_as_char i) | Const_string { s } -> fprintf ppf "%S" s | Const_float f -> fprintf ppf "%s" f | Const_int64 n -> fprintf ppf "%LiL" n @@ -283703,37 +283898,35 @@ open Asttypes open Parsetree type jsxConfig = { - mutable version: int; - mutable module_: string; - mutable mode: string; - mutable nestedModules: string list; - mutable hasReactComponent: bool; + mutable version : int; + mutable module_ : string; + mutable mode : string; + mutable nestedModules : string list; + mutable hasReactComponent : bool; } (* Helper method to look up the [@react.component] attribute *) let hasAttr (loc, _) = loc.txt = "react.component" (* Iterate over the attributes and try to find the [@react.component] attribute *) -let hasAttrOnBinding {pvb_attributes} = +let hasAttrOnBinding { pvb_attributes } = List.find_opt hasAttr pvb_attributes <> None let coreTypeOfAttrs attributes = List.find_map - (fun ({txt}, payload) -> + (fun ({ txt }, payload) -> match (txt, payload) with | "react.component", PTyp coreType -> Some coreType | _ -> None) attributes -let typVarsOfCoreType {ptyp_desc} = +let typVarsOfCoreType { ptyp_desc } = match ptyp_desc with | Ptyp_constr (_, coreTypes) -> - List.filter - (fun {ptyp_desc} -> - match ptyp_desc with - | Ptyp_var _ -> true - | _ -> false) - coreTypes + List.filter + (fun { ptyp_desc } -> + match ptyp_desc with Ptyp_var _ -> true | _ -> false) + coreTypes | _ -> [] let raiseError ~loc msg = Location.raise_errorf ~loc msg @@ -283754,25 +283947,13 @@ open Parsetree open Longident let nolabel = Nolabel - let labelled str = Labelled str - let optional str = Optional str - -let isOptional str = - match str with - | Optional _ -> true - | _ -> false - -let isLabelled str = - match str with - | Labelled _ -> true - | _ -> false +let isOptional str = match str with Optional _ -> true | _ -> false +let isLabelled str = match str with Labelled _ -> true | _ -> false let getLabel str = - match str with - | Optional str | Labelled str -> str - | Nolabel -> "" + match str with Optional str | Labelled str -> str | Nolabel -> "" let optionIdent = Lident "option" @@ -283785,12 +283966,11 @@ let safeTypeFromValue valueStr = else "T" ^ valueStr let keyType loc = - Typ.constr ~loc {loc; txt = optionIdent} - [Typ.constr ~loc {loc; txt = Lident "string"} []] + Typ.constr ~loc { loc; txt = optionIdent } + [ Typ.constr ~loc { loc; txt = Lident "string" } [] ] type 'a children = ListLiteral of 'a | Exact of 'a - -type componentConfig = {propsName: string} +type componentConfig = { propsName : string } (* if children is a list, convert it to an array while mapping each element. If not, just map over it, as usual *) let transformChildrenIfListUpper ~loc ~mapper theList = @@ -283798,16 +283978,16 @@ let transformChildrenIfListUpper ~loc ~mapper theList = (* not in the sense of converting a list to an array; convert the AST reprensentation of a list to the AST reprensentation of an array *) match theList with - | {pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} -> ( - match accum with - | [singleElement] -> Exact singleElement - | accum -> ListLiteral (Exp.array ~loc (List.rev accum))) + | { pexp_desc = Pexp_construct ({ txt = Lident "[]" }, None) } -> ( + match accum with + | [ singleElement ] -> Exact singleElement + | accum -> ListLiteral (Exp.array ~loc (List.rev accum))) | { pexp_desc = Pexp_construct - ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple [v; acc]}); + ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple [ v; acc ] }); } -> - transformChildren_ acc (mapper.expr mapper v :: accum) + transformChildren_ acc (mapper.expr mapper v :: accum) | notAList -> Exact (mapper.expr mapper notAList) in transformChildren_ theList [] @@ -283817,14 +283997,14 @@ let transformChildrenIfList ~loc ~mapper theList = (* not in the sense of converting a list to an array; convert the AST reprensentation of a list to the AST reprensentation of an array *) match theList with - | {pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} -> - Exp.array ~loc (List.rev accum) + | { pexp_desc = Pexp_construct ({ txt = Lident "[]" }, None) } -> + Exp.array ~loc (List.rev accum) | { pexp_desc = Pexp_construct - ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple [v; acc]}); + ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple [ v; acc ] }); } -> - transformChildren_ acc (mapper.expr mapper v :: accum) + transformChildren_ acc (mapper.expr mapper v :: accum) | notAList -> mapper.expr mapper notAList in transformChildren_ theList [] @@ -283833,11 +284013,13 @@ let extractChildren ?(removeLastPositionUnit = false) ~loc propsAndChildren = let rec allButLast_ lst acc = match lst with | [] -> [] - | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] -> - acc - | (Nolabel, {pexp_loc}) :: _rest -> - React_jsx_common.raiseError ~loc:pexp_loc - "JSX: found non-labelled argument before the last position" + | [ + (Nolabel, { pexp_desc = Pexp_construct ({ txt = Lident "()" }, None) }); + ] -> + acc + | (Nolabel, { pexp_loc }) :: _rest -> + React_jsx_common.raiseError ~loc:pexp_loc + "JSX: found non-labelled argument before the last position" | arg :: rest -> allButLast_ rest (arg :: acc) in let allButLast lst = allButLast_ lst [] |> List.rev in @@ -283847,20 +284029,20 @@ let extractChildren ?(removeLastPositionUnit = false) ~loc propsAndChildren = propsAndChildren with | [], props -> - (* no children provided? Place a placeholder list *) - ( Exp.construct ~loc {loc; txt = Lident "[]"} None, - if removeLastPositionUnit then allButLast props else props ) - | [(_, childrenExpr)], props -> - (childrenExpr, if removeLastPositionUnit then allButLast props else props) + (* no children provided? Place a placeholder list *) + ( Exp.construct ~loc { loc; txt = Lident "[]" } None, + if removeLastPositionUnit then allButLast props else props ) + | [ (_, childrenExpr) ], props -> + (childrenExpr, if removeLastPositionUnit then allButLast props else props) | _ -> - React_jsx_common.raiseError ~loc - "JSX: somehow there's more than one `children` label" + React_jsx_common.raiseError ~loc + "JSX: somehow there's more than one `children` label" let unerasableIgnore loc = - ( {loc; txt = "warning"}, - PStr [Str.eval (Exp.constant (Pconst_string ("-16", None)))] ) + ( { loc; txt = "warning" }, + PStr [ Str.eval (Exp.constant (Pconst_string ("-16", None))) ] ) -let merlinFocus = ({loc = Location.none; txt = "merlin.focus"}, PStr []) +let merlinFocus = ({ loc = Location.none; txt = "merlin.focus" }, PStr []) (* Helper method to filter out any attribute that isn't [@react.component] *) let otherAttrsPure (loc, _) = loc.txt <> "react.component" @@ -283868,59 +284050,59 @@ let otherAttrsPure (loc, _) = loc.txt <> "react.component" (* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *) let rec getFnName binding = match binding with - | {ppat_desc = Ppat_var {txt}} -> txt - | {ppat_desc = Ppat_constraint (pat, _)} -> getFnName pat - | {ppat_loc} -> - React_jsx_common.raiseError ~loc:ppat_loc - "react.component calls cannot be destructured." + | { ppat_desc = Ppat_var { txt } } -> txt + | { ppat_desc = Ppat_constraint (pat, _) } -> getFnName pat + | { ppat_loc } -> + React_jsx_common.raiseError ~loc:ppat_loc + "react.component calls cannot be destructured." let makeNewBinding binding expression newName = match binding with - | {pvb_pat = {ppat_desc = Ppat_var ppat_var} as pvb_pat} -> - { - binding with - pvb_pat = - {pvb_pat with ppat_desc = Ppat_var {ppat_var with txt = newName}}; - pvb_expr = expression; - pvb_attributes = [merlinFocus]; - } - | {pvb_loc} -> - React_jsx_common.raiseError ~loc:pvb_loc - "react.component calls cannot be destructured." + | { pvb_pat = { ppat_desc = Ppat_var ppat_var } as pvb_pat } -> + { + binding with + pvb_pat = + { pvb_pat with ppat_desc = Ppat_var { ppat_var with txt = newName } }; + pvb_expr = expression; + pvb_attributes = [ merlinFocus ]; + } + | { pvb_loc } -> + React_jsx_common.raiseError ~loc:pvb_loc + "react.component calls cannot be destructured." (* Lookup the value of `props` otherwise raise Invalid_argument error *) let getPropsNameValue _acc (loc, exp) = match (loc, exp) with - | {txt = Lident "props"}, {pexp_desc = Pexp_ident {txt = Lident str}} -> - {propsName = str} - | {txt; loc}, _ -> - React_jsx_common.raiseError ~loc - "react.component only accepts props as an option, given: { %s }" - (Longident.last txt) + | { txt = Lident "props" }, { pexp_desc = Pexp_ident { txt = Lident str } } -> + { propsName = str } + | { txt; loc }, _ -> + React_jsx_common.raiseError ~loc + "react.component only accepts props as an option, given: { %s }" + (Longident.last txt) (* Lookup the `props` record or string as part of [@react.component] and store the name for use when rewriting *) let getPropsAttr payload = - let defaultProps = {propsName = "Props"} in + let defaultProps = { propsName = "Props" } in match payload with | Some (PStr ({ pstr_desc = - Pstr_eval ({pexp_desc = Pexp_record (recordFields, None)}, _); + Pstr_eval ({ pexp_desc = Pexp_record (recordFields, None) }, _); } :: _rest)) -> - List.fold_left getPropsNameValue defaultProps recordFields + List.fold_left getPropsNameValue defaultProps recordFields | Some (PStr ({ pstr_desc = - Pstr_eval ({pexp_desc = Pexp_ident {txt = Lident "props"}}, _); + Pstr_eval ({ pexp_desc = Pexp_ident { txt = Lident "props" } }, _); } :: _rest)) -> - {propsName = "props"} - | Some (PStr ({pstr_desc = Pstr_eval (_, _); pstr_loc} :: _rest)) -> - React_jsx_common.raiseError ~loc:pstr_loc - "react.component accepts a record config with props as an options." + { propsName = "props" } + | Some (PStr ({ pstr_desc = Pstr_eval (_, _); pstr_loc } :: _rest)) -> + React_jsx_common.raiseError ~loc:pstr_loc + "react.component accepts a record config with props as an options." | _ -> defaultProps (* Plucks the label, loc, and type_ from an AST node *) @@ -283950,7 +284132,7 @@ let makeModuleName fileName nestedModules fnName = | "", nestedModules, fnName -> List.rev (fnName :: nestedModules) | fileName, nestedModules, "make" -> fileName :: List.rev nestedModules | fileName, nestedModules, fnName -> - fileName :: List.rev (fnName :: nestedModules) + fileName :: List.rev (fnName :: nestedModules) in let fullModuleName = String.concat "$" fullModuleName in fullModuleName @@ -283965,68 +284147,71 @@ let makeModuleName fileName nestedModules fnName = let rec recursivelyMakeNamedArgsForExternal list args = match list with | (label, default, loc, interiorType) :: tl -> - recursivelyMakeNamedArgsForExternal tl - (Typ.arrow ~loc label - (match (label, interiorType, default) with - (* ~foo=1 *) - | label, None, Some _ -> - { - ptyp_desc = Ptyp_var (safeTypeFromValue label); - ptyp_loc = loc; - ptyp_attributes = []; - } - (* ~foo: int=1 *) - | _label, Some type_, Some _ -> type_ - (* ~foo: option(int)=? *) - | ( label, - Some {ptyp_desc = Ptyp_constr ({txt = Lident "option"}, [type_])}, - _ ) - | ( label, - Some + recursivelyMakeNamedArgsForExternal tl + (Typ.arrow ~loc label + (match (label, interiorType, default) with + (* ~foo=1 *) + | label, None, Some _ -> { - ptyp_desc = - Ptyp_constr - ({txt = Ldot (Lident "*predef*", "option")}, [type_]); - }, - _ ) - (* ~foo: int=? - note this isnt valid. but we want to get a type error *) - | label, Some type_, _ - when isOptional label -> - type_ - (* ~foo=? *) - | label, None, _ when isOptional label -> - { - ptyp_desc = Ptyp_var (safeTypeFromValue label); - ptyp_loc = loc; - ptyp_attributes = []; - } - (* ~foo *) - | label, None, _ -> - { - ptyp_desc = Ptyp_var (safeTypeFromValue label); - ptyp_loc = loc; - ptyp_attributes = []; - } - | _label, Some type_, _ -> type_) - args) + ptyp_desc = Ptyp_var (safeTypeFromValue label); + ptyp_loc = loc; + ptyp_attributes = []; + } + (* ~foo: int=1 *) + | _label, Some type_, Some _ -> type_ + (* ~foo: option(int)=? *) + | ( label, + Some + { + ptyp_desc = Ptyp_constr ({ txt = Lident "option" }, [ type_ ]); + }, + _ ) + | ( label, + Some + { + ptyp_desc = + Ptyp_constr + ({ txt = Ldot (Lident "*predef*", "option") }, [ type_ ]); + }, + _ ) + (* ~foo: int=? - note this isnt valid. but we want to get a type error *) + | label, Some type_, _ + when isOptional label -> + type_ + (* ~foo=? *) + | label, None, _ when isOptional label -> + { + ptyp_desc = Ptyp_var (safeTypeFromValue label); + ptyp_loc = loc; + ptyp_attributes = []; + } + (* ~foo *) + | label, None, _ -> + { + ptyp_desc = Ptyp_var (safeTypeFromValue label); + ptyp_loc = loc; + ptyp_attributes = []; + } + | _label, Some type_, _ -> type_) + args) | [] -> args (* Build an AST node for the [@bs.obj] representing props for a component *) let makePropsValue fnName loc namedArgListWithKeyAndRef propsType = let propsName = fnName ^ "Props" in { - pval_name = {txt = propsName; loc}; + pval_name = { txt = propsName; loc }; pval_type = recursivelyMakeNamedArgsForExternal namedArgListWithKeyAndRef (Typ.arrow nolabel { - ptyp_desc = Ptyp_constr ({txt = Lident "unit"; loc}, []); + ptyp_desc = Ptyp_constr ({ txt = Lident "unit"; loc }, []); ptyp_loc = loc; ptyp_attributes = []; } propsType); - pval_prim = [""]; - pval_attributes = [({txt = "bs.obj"; loc}, PStr [])]; + pval_prim = [ "" ]; + pval_attributes = [ ({ txt = "bs.obj"; loc }, PStr []) ]; pval_loc = loc; } @@ -284049,10 +284234,14 @@ let makePropsExternalSig fnName loc namedArgListWithKeyAndRef propsType = (* Build an AST node for the props name when converted to an object inside the function signature *) let makePropsName ~loc name = - {ppat_desc = Ppat_var {txt = name; loc}; ppat_loc = loc; ppat_attributes = []} + { + ppat_desc = Ppat_var { txt = name; loc }; + ppat_loc = loc; + ppat_attributes = []; + } let makeObjectField loc (str, attrs, type_) = - Otag ({loc; txt = str}, attrs, type_) + Otag ({ loc; txt = str }, attrs, type_) (* Build an AST node representing a "closed" object representing a component's props *) let makePropsType ~loc namedTypeList = @@ -284069,11 +284258,11 @@ let newtypeToVar newtype type_ = let var_desc = Ptyp_var ("type-" ^ newtype) in let typ (mapper : Ast_mapper.mapper) typ = match typ.ptyp_desc with - | Ptyp_constr ({txt = Lident name}, _) when name = newtype -> - {typ with ptyp_desc = var_desc} + | Ptyp_constr ({ txt = Lident name }, _) when name = newtype -> + { typ with ptyp_desc = var_desc } | _ -> Ast_mapper.default_mapper.typ mapper typ in - let mapper = {Ast_mapper.default_mapper with typ} in + let mapper = { Ast_mapper.default_mapper with typ } in mapper.typ mapper type_ (* TODO: some line number might still be wrong *) @@ -284093,23 +284282,23 @@ let jsxMapper ~config = let args = recursivelyTransformedArgsForMake @ (match childrenExpr with - | Exact children -> [(labelled "children", children)] - | ListLiteral {pexp_desc = Pexp_array list} when list = [] -> [] + | Exact children -> [ (labelled "children", children) ] + | ListLiteral { pexp_desc = Pexp_array list } when list = [] -> [] | ListLiteral expression -> - (* this is a hack to support react components that introspect into their children *) - childrenArg := Some expression; - [ - ( labelled "children", - Exp.ident ~loc {loc; txt = Ldot (Lident "React", "null")} ); - ]) - @ [(nolabel, Exp.construct ~loc {loc; txt = Lident "()"} None)] + (* this is a hack to support react components that introspect into their children *) + childrenArg := Some expression; + [ + ( labelled "children", + Exp.ident ~loc { loc; txt = Ldot (Lident "React", "null") } ); + ]) + @ [ (nolabel, Exp.construct ~loc { loc; txt = Lident "()" } None) ] in let isCap str = String.capitalize_ascii str = str in let ident = match modulePath with | Lident _ -> Ldot (modulePath, "make") | Ldot (_modulePath, value) as fullPath when isCap value -> - Ldot (fullPath, "make") + Ldot (fullPath, "make") | modulePath -> modulePath in let propsIdent = @@ -284117,28 +284306,28 @@ let jsxMapper ~config = | Lident path -> Lident (path ^ "Props") | Ldot (ident, path) -> Ldot (ident, path ^ "Props") | _ -> - React_jsx_common.raiseError ~loc - "JSX name can't be the result of function applications" + React_jsx_common.raiseError ~loc + "JSX name can't be the result of function applications" in let props = - Exp.apply ~attrs ~loc (Exp.ident ~loc {loc; txt = propsIdent}) args + Exp.apply ~attrs ~loc (Exp.ident ~loc { loc; txt = propsIdent }) args in (* handle key, ref, children *) (* React.createElement(Component.make, props, ...children) *) match !childrenArg with | None -> - Exp.apply ~loc ~attrs - (Exp.ident ~loc {loc; txt = Ldot (Lident "React", "createElement")}) - [(nolabel, Exp.ident ~loc {txt = ident; loc}); (nolabel, props)] + Exp.apply ~loc ~attrs + (Exp.ident ~loc { loc; txt = Ldot (Lident "React", "createElement") }) + [ (nolabel, Exp.ident ~loc { txt = ident; loc }); (nolabel, props) ] | Some children -> - Exp.apply ~loc ~attrs - (Exp.ident ~loc - {loc; txt = Ldot (Lident "React", "createElementVariadic")}) - [ - (nolabel, Exp.ident ~loc {txt = ident; loc}); - (nolabel, props); - (nolabel, children); - ] + Exp.apply ~loc ~attrs + (Exp.ident ~loc + { loc; txt = Ldot (Lident "React", "createElementVariadic") }) + [ + (nolabel, Exp.ident ~loc { txt = ident; loc }); + (nolabel, props); + (nolabel, children); + ] in let transformLowercaseCall3 mapper loc attrs callArguments id = @@ -284150,48 +284339,50 @@ let jsxMapper ~config = (* [@JSX] div(~children=[a]), coming from
a
*) | { pexp_desc = - ( Pexp_construct ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple _}) - | Pexp_construct ({txt = Lident "[]"}, None) ); + ( Pexp_construct + ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple _ }) + | Pexp_construct ({ txt = Lident "[]" }, None) ); } -> - "createDOMElementVariadic" + "createDOMElementVariadic" (* [@JSX] div(~children= value), coming from
...(value)
*) - | {pexp_loc} -> - React_jsx_common.raiseError ~loc:pexp_loc - "A spread as a DOM element's children don't make sense written \ - together. You can simply remove the spread." + | { pexp_loc } -> + React_jsx_common.raiseError ~loc:pexp_loc + "A spread as a DOM element's children don't make sense written \ + together. You can simply remove the spread." in let args = match nonChildrenProps with - | [_justTheUnitArgumentAtEnd] -> - [ - (* "div" *) - (nolabel, componentNameExpr); - (* [|moreCreateElementCallsHere|] *) - (nolabel, childrenExpr); - ] + | [ _justTheUnitArgumentAtEnd ] -> + [ + (* "div" *) + (nolabel, componentNameExpr); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr); + ] | nonEmptyProps -> - let propsCall = - Exp.apply ~loc - (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOMRe", "domProps")}) - (nonEmptyProps - |> List.map (fun (label, expression) -> - (label, mapper.expr mapper expression))) - in - [ - (* "div" *) - (nolabel, componentNameExpr); - (* ReactDOMRe.props(~className=blabla, ~foo=bar, ()) *) - (labelled "props", propsCall); - (* [|moreCreateElementCallsHere|] *) - (nolabel, childrenExpr); - ] + let propsCall = + Exp.apply ~loc + (Exp.ident ~loc + { loc; txt = Ldot (Lident "ReactDOMRe", "domProps") }) + (nonEmptyProps + |> List.map (fun (label, expression) -> + (label, mapper.expr mapper expression))) + in + [ + (* "div" *) + (nolabel, componentNameExpr); + (* ReactDOMRe.props(~className=blabla, ~foo=bar, ()) *) + (labelled "props", propsCall); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr); + ] in Exp.apply ~loc (* throw away the [@JSX] attribute and keep the others, if any *) ~attrs (* ReactDOMRe.createElement *) (Exp.ident ~loc - {loc; txt = Ldot (Lident "ReactDOMRe", createElementCall)}) + { loc; txt = Ldot (Lident "ReactDOMRe", createElementCall) }) args in @@ -284200,128 +284391,132 @@ let jsxMapper ~config = match expr.pexp_desc with (* TODO: make this show up with a loc. *) | Pexp_fun (Labelled "key", _, _, _) | Pexp_fun (Optional "key", _, _, _) -> - React_jsx_common.raiseError ~loc:expr.pexp_loc - "Key cannot be accessed inside of a component. Don't worry - you can \ - always key a component from its parent!" + React_jsx_common.raiseError ~loc:expr.pexp_loc + "Key cannot be accessed inside of a component. Don't worry - you can \ + always key a component from its parent!" | Pexp_fun (Labelled "ref", _, _, _) | Pexp_fun (Optional "ref", _, _, _) -> - React_jsx_common.raiseError ~loc:expr.pexp_loc - "Ref cannot be passed as a normal prop. Either give the prop a \ - different name or use the `forwardRef` API instead." + React_jsx_common.raiseError ~loc:expr.pexp_loc + "Ref cannot be passed as a normal prop. Either give the prop a \ + different name or use the `forwardRef` API instead." | Pexp_fun (arg, default, pattern, expression) when isOptional arg || isLabelled arg -> - let () = - match (isOptional arg, pattern, default) with - | true, {ppat_desc = Ppat_constraint (_, {ptyp_desc})}, None -> ( - match ptyp_desc with - | Ptyp_constr ({txt = Lident "option"}, [_]) -> () - | _ -> - let currentType = + let () = + match (isOptional arg, pattern, default) with + | true, { ppat_desc = Ppat_constraint (_, { ptyp_desc }) }, None -> ( match ptyp_desc with - | Ptyp_constr ({txt}, []) -> - String.concat "." (Longident.flatten txt) - | Ptyp_constr ({txt}, _innerTypeArgs) -> - String.concat "." (Longident.flatten txt) ^ "(...)" - | _ -> "..." - in - Location.prerr_warning pattern.ppat_loc - (Preprocessor - (Printf.sprintf - "React: optional argument annotations must have explicit \ - `option`. Did you mean `option(%s)=?`?" - currentType))) - | _ -> () - in - let alias = - match pattern with - | {ppat_desc = Ppat_alias (_, {txt}) | Ppat_var {txt}} -> txt - | {ppat_desc = Ppat_any} -> "_" - | _ -> getLabel arg - in - let type_ = - match pattern with - | {ppat_desc = Ppat_constraint (_, type_)} -> Some type_ - | _ -> None - in + | Ptyp_constr ({ txt = Lident "option" }, [ _ ]) -> () + | _ -> + let currentType = + match ptyp_desc with + | Ptyp_constr ({ txt }, []) -> + String.concat "." (Longident.flatten txt) + | Ptyp_constr ({ txt }, _innerTypeArgs) -> + String.concat "." (Longident.flatten txt) ^ "(...)" + | _ -> "..." + in + Location.prerr_warning pattern.ppat_loc + (Preprocessor + (Printf.sprintf + "React: optional argument annotations must have \ + explicit `option`. Did you mean `option(%s)=?`?" + currentType))) + | _ -> () + in + let alias = + match pattern with + | { ppat_desc = Ppat_alias (_, { txt }) | Ppat_var { txt } } -> txt + | { ppat_desc = Ppat_any } -> "_" + | _ -> getLabel arg + in + let type_ = + match pattern with + | { ppat_desc = Ppat_constraint (_, type_) } -> Some type_ + | _ -> None + in - recursivelyTransformNamedArgsForMake mapper expression - ((arg, default, pattern, alias, pattern.ppat_loc, type_) :: args) - newtypes + recursivelyTransformNamedArgsForMake mapper expression + ((arg, default, pattern, alias, pattern.ppat_loc, type_) :: args) + newtypes | Pexp_fun ( Nolabel, _, - {ppat_desc = Ppat_construct ({txt = Lident "()"}, _) | Ppat_any}, + { ppat_desc = Ppat_construct ({ txt = Lident "()" }, _) | Ppat_any }, _expression ) -> - (args, newtypes, None) + (args, newtypes, None) | Pexp_fun ( Nolabel, _, { ppat_desc = - Ppat_var {txt} | Ppat_constraint ({ppat_desc = Ppat_var {txt}}, _); + ( Ppat_var { txt } + | Ppat_constraint ({ ppat_desc = Ppat_var { txt } }, _) ); }, _expression ) -> - (args, newtypes, Some txt) + (args, newtypes, Some txt) | Pexp_fun (Nolabel, _, pattern, _expression) -> - Location.raise_errorf ~loc:pattern.ppat_loc - "React: react.component refs only support plain arguments and type \ - annotations." + Location.raise_errorf ~loc:pattern.ppat_loc + "React: react.component refs only support plain arguments and type \ + annotations." | Pexp_newtype (label, expression) -> - recursivelyTransformNamedArgsForMake mapper expression args - (label :: newtypes) + recursivelyTransformNamedArgsForMake mapper expression args + (label :: newtypes) | Pexp_constraint (expression, _typ) -> - recursivelyTransformNamedArgsForMake mapper expression args newtypes + recursivelyTransformNamedArgsForMake mapper expression args newtypes | _ -> (args, newtypes, None) in let argToType types (name, default, _noLabelName, _alias, loc, type_) = match (type_, name, default) with - | Some {ptyp_desc = Ptyp_constr ({txt = Lident "option"}, [type_])}, name, _ + | ( Some { ptyp_desc = Ptyp_constr ({ txt = Lident "option" }, [ type_ ]) }, + name, + _ ) when isOptional name -> - ( getLabel name, - [], - { - type_ with - ptyp_desc = - Ptyp_constr ({loc = type_.ptyp_loc; txt = optionIdent}, [type_]); - } ) - :: types - | Some type_, name, Some _default -> - ( getLabel name, - [], - { - ptyp_desc = Ptyp_constr ({loc; txt = optionIdent}, [type_]); - ptyp_loc = loc; - ptyp_attributes = []; - } ) - :: types + ( getLabel name, + [], + { + type_ with + ptyp_desc = + Ptyp_constr + ({ loc = type_.ptyp_loc; txt = optionIdent }, [ type_ ]); + } ) + :: types + | Some type_, name, Some _default -> + ( getLabel name, + [], + { + ptyp_desc = Ptyp_constr ({ loc; txt = optionIdent }, [ type_ ]); + ptyp_loc = loc; + ptyp_attributes = []; + } ) + :: types | Some type_, name, _ -> (getLabel name, [], type_) :: types | None, name, _ when isOptional name -> - ( getLabel name, - [], - { - ptyp_desc = - Ptyp_constr - ( {loc; txt = optionIdent}, - [ - { - ptyp_desc = Ptyp_var (safeTypeFromValue name); - ptyp_loc = loc; - ptyp_attributes = []; - }; - ] ); - ptyp_loc = loc; - ptyp_attributes = []; - } ) - :: types + ( getLabel name, + [], + { + ptyp_desc = + Ptyp_constr + ( { loc; txt = optionIdent }, + [ + { + ptyp_desc = Ptyp_var (safeTypeFromValue name); + ptyp_loc = loc; + ptyp_attributes = []; + }; + ] ); + ptyp_loc = loc; + ptyp_attributes = []; + } ) + :: types | None, name, _ when isLabelled name -> - ( getLabel name, - [], - { - ptyp_desc = Ptyp_var (safeTypeFromValue name); - ptyp_loc = loc; - ptyp_attributes = []; - } ) - :: types + ( getLabel name, + [], + { + ptyp_desc = Ptyp_var (safeTypeFromValue name); + ptyp_loc = loc; + ptyp_attributes = []; + } ) + :: types | _ -> types in @@ -284329,8 +284524,8 @@ let jsxMapper ~config = match name with | name when isLabelled name -> (getLabel name, [], type_) :: types | name when isOptional name -> - (getLabel name, [], Typ.constr ~loc {loc; txt = optionIdent} [type_]) - :: types + (getLabel name, [], Typ.constr ~loc { loc; txt = optionIdent } [ type_ ]) + :: types | _ -> types in @@ -284342,432 +284537,458 @@ let jsxMapper ~config = pstr_loc; pstr_desc = Pstr_primitive - ({pval_name = {txt = fnName}; pval_attributes; pval_type} as + ({ pval_name = { txt = fnName }; pval_attributes; pval_type } as value_description); } as pstr -> ( - match List.filter React_jsx_common.hasAttr pval_attributes with - | [] -> [item] - | [_] -> - let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = - match ptyp_desc with - | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) - when isLabelled name || isOptional name -> - getPropTypes ((name, ptyp_loc, type_) :: types) rest - | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest - | Ptyp_arrow (name, type_, returnValue) - when isLabelled name || isOptional name -> - (returnValue, (name, returnValue.ptyp_loc, type_) :: types) - | _ -> (fullType, types) - in - let innerType, propTypes = getPropTypes [] pval_type in - let namedTypeList = List.fold_left argToConcreteType [] propTypes in - let pluckLabelAndLoc (label, loc, type_) = - (label, None (* default *), loc, Some type_) - in - let retPropsType = makePropsType ~loc:pstr_loc namedTypeList in - let externalPropsDecl = - makePropsExternal fnName pstr_loc - ((optional "key", None, pstr_loc, Some (keyType pstr_loc)) - :: List.map pluckLabelAndLoc propTypes) - retPropsType - in - (* can't be an arrow because it will defensively uncurry *) - let newExternalType = - Ptyp_constr - ( {loc = pstr_loc; txt = Ldot (Lident "React", "componentLike")}, - [retPropsType; innerType] ) - in - let newStructure = - { - pstr with - pstr_desc = - Pstr_primitive - { - value_description with - pval_type = {pval_type with ptyp_desc = newExternalType}; - pval_attributes = List.filter otherAttrsPure pval_attributes; - }; - } - in - [externalPropsDecl; newStructure] - | _ -> - React_jsx_common.raiseError ~loc:pstr_loc - "Only one react.component call can exist on a component at one time") - (* let component = ... *) - | {pstr_loc; pstr_desc = Pstr_value (recFlag, valueBindings)} -> ( - let fileName = filenameFromLoc pstr_loc in - let emptyLoc = Location.in_file fileName in - let mapBinding binding = - if React_jsx_common.hasAttrOnBinding binding then - let bindingLoc = binding.pvb_loc in - let bindingPatLoc = binding.pvb_pat.ppat_loc in - let binding = - { - binding with - pvb_pat = {binding.pvb_pat with ppat_loc = emptyLoc}; - pvb_loc = emptyLoc; - } - in - let fnName = getFnName binding.pvb_pat in - let internalFnName = fnName ^ "$Internal" in - let fullModuleName = makeModuleName fileName !nestedModules fnName in - let modifiedBindingOld binding = - let expression = binding.pvb_expr in - (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) - let rec spelunkForFunExpression expression = - match expression with - (* let make = (~prop) => ... *) - | {pexp_desc = Pexp_fun _} | {pexp_desc = Pexp_newtype _} -> - expression - (* let make = {let foo = bar in (~prop) => ...} *) - | {pexp_desc = Pexp_let (_recursive, _vbs, returnExpression)} -> - (* here's where we spelunk! *) - spelunkForFunExpression returnExpression - (* let make = React.forwardRef((~prop) => ...) *) - | { - pexp_desc = - Pexp_apply - (_wrapperExpression, [(Nolabel, innerFunctionExpression)]); - } -> - spelunkForFunExpression innerFunctionExpression - | { - pexp_desc = - Pexp_sequence (_wrapperExpression, innerFunctionExpression); - } -> - spelunkForFunExpression innerFunctionExpression - | {pexp_desc = Pexp_constraint (innerFunctionExpression, _typ)} -> - spelunkForFunExpression innerFunctionExpression - | {pexp_loc} -> - React_jsx_common.raiseError ~loc:pexp_loc - "react.component calls can only be on function definitions \ - or component wrappers (forwardRef, memo)." + match List.filter React_jsx_common.hasAttr pval_attributes with + | [] -> [ item ] + | [ _ ] -> + let rec getPropTypes types ({ ptyp_loc; ptyp_desc } as fullType) = + match ptyp_desc with + | Ptyp_arrow (name, type_, ({ ptyp_desc = Ptyp_arrow _ } as rest)) + when isLabelled name || isOptional name -> + getPropTypes ((name, ptyp_loc, type_) :: types) rest + | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest + | Ptyp_arrow (name, type_, returnValue) + when isLabelled name || isOptional name -> + (returnValue, (name, returnValue.ptyp_loc, type_) :: types) + | _ -> (fullType, types) in - spelunkForFunExpression expression - in - let modifiedBinding binding = - let hasApplication = ref false in - let wrapExpressionWithBinding expressionFn expression = - Vb.mk ~loc:bindingLoc - ~attrs:(List.filter otherAttrsPure binding.pvb_attributes) - (Pat.var ~loc:bindingPatLoc {loc = bindingPatLoc; txt = fnName}) - (expressionFn expression) + let innerType, propTypes = getPropTypes [] pval_type in + let namedTypeList = List.fold_left argToConcreteType [] propTypes in + let pluckLabelAndLoc (label, loc, type_) = + (label, None (* default *), loc, Some type_) + in + let retPropsType = makePropsType ~loc:pstr_loc namedTypeList in + let externalPropsDecl = + makePropsExternal fnName pstr_loc + ((optional "key", None, pstr_loc, Some (keyType pstr_loc)) + :: List.map pluckLabelAndLoc propTypes) + retPropsType + in + (* can't be an arrow because it will defensively uncurry *) + let newExternalType = + Ptyp_constr + ( { + loc = pstr_loc; + txt = Ldot (Lident "React", "componentLike"); + }, + [ retPropsType; innerType ] ) in - let expression = binding.pvb_expr in - let unerasableIgnoreExp exp = + let newStructure = { - exp with - pexp_attributes = - unerasableIgnore emptyLoc :: exp.pexp_attributes; + pstr with + pstr_desc = + Pstr_primitive + { + value_description with + pval_type = { pval_type with ptyp_desc = newExternalType }; + pval_attributes = + List.filter otherAttrsPure pval_attributes; + }; } in - (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) - let rec spelunkForFunExpression expression = - match expression with - (* let make = (~prop) => ... with no final unit *) - | { - pexp_desc = - Pexp_fun - ( ((Labelled _ | Optional _) as label), - default, - pattern, - ({pexp_desc = Pexp_fun _} as internalExpression) ); - } -> - let wrap, hasUnit, exp = - spelunkForFunExpression internalExpression - in - ( wrap, - hasUnit, - unerasableIgnoreExp - { - expression with - pexp_desc = Pexp_fun (label, default, pattern, exp); - } ) - (* let make = (()) => ... *) - (* let make = (_) => ... *) - | { - pexp_desc = - Pexp_fun - ( Nolabel, - _default, - { - ppat_desc = - Ppat_construct ({txt = Lident "()"}, _) | Ppat_any; - }, - _internalExpression ); - } -> - ((fun a -> a), true, expression) - (* let make = (~prop) => ... *) - | { - pexp_desc = - Pexp_fun - ( (Labelled _ | Optional _), - _default, - _pattern, - _internalExpression ); - } -> - ((fun a -> a), false, unerasableIgnoreExp expression) - (* let make = (prop) => ... *) - | { - pexp_desc = - Pexp_fun (_nolabel, _default, pattern, _internalExpression); - } -> - if hasApplication.contents then - ((fun a -> a), false, unerasableIgnoreExp expression) - else - Location.raise_errorf ~loc:pattern.ppat_loc - "React: props need to be labelled arguments.\n\ - \ If you are working with refs be sure to wrap with \ - React.forwardRef.\n\ - \ If your component doesn't have any props use () or _ \ - instead of a name." - (* let make = {let foo = bar in (~prop) => ...} *) - | {pexp_desc = Pexp_let (recursive, vbs, internalExpression)} -> - (* here's where we spelunk! *) - let wrap, hasUnit, exp = - spelunkForFunExpression internalExpression - in - ( wrap, - hasUnit, - {expression with pexp_desc = Pexp_let (recursive, vbs, exp)} - ) - (* let make = React.forwardRef((~prop) => ...) *) - | { - pexp_desc = - Pexp_apply (wrapperExpression, [(Nolabel, internalExpression)]); - } -> - let () = hasApplication := true in - let _, hasUnit, exp = - spelunkForFunExpression internalExpression - in - ( (fun exp -> Exp.apply wrapperExpression [(nolabel, exp)]), - hasUnit, - exp ) - | { - pexp_desc = Pexp_sequence (wrapperExpression, internalExpression); - } -> - let wrap, hasUnit, exp = - spelunkForFunExpression internalExpression - in - ( wrap, - hasUnit, - { - expression with - pexp_desc = Pexp_sequence (wrapperExpression, exp); - } ) - | e -> ((fun a -> a), false, e) + [ externalPropsDecl; newStructure ] + | _ -> + React_jsx_common.raiseError ~loc:pstr_loc + "Only one react.component call can exist on a component at one \ + time") + (* let component = ... *) + | { pstr_loc; pstr_desc = Pstr_value (recFlag, valueBindings) } -> ( + let fileName = filenameFromLoc pstr_loc in + let emptyLoc = Location.in_file fileName in + let mapBinding binding = + if React_jsx_common.hasAttrOnBinding binding then + let bindingLoc = binding.pvb_loc in + let bindingPatLoc = binding.pvb_pat.ppat_loc in + let binding = + { + binding with + pvb_pat = { binding.pvb_pat with ppat_loc = emptyLoc }; + pvb_loc = emptyLoc; + } in - let wrapExpression, hasUnit, expression = + let fnName = getFnName binding.pvb_pat in + let internalFnName = fnName ^ "$Internal" in + let fullModuleName = + makeModuleName fileName !nestedModules fnName + in + let modifiedBindingOld binding = + let expression = binding.pvb_expr in + (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) + let rec spelunkForFunExpression expression = + match expression with + (* let make = (~prop) => ... *) + | { pexp_desc = Pexp_fun _ } | { pexp_desc = Pexp_newtype _ } -> + expression + (* let make = {let foo = bar in (~prop) => ...} *) + | { pexp_desc = Pexp_let (_recursive, _vbs, returnExpression) } + -> + (* here's where we spelunk! *) + spelunkForFunExpression returnExpression + (* let make = React.forwardRef((~prop) => ...) *) + | { + pexp_desc = + Pexp_apply + (_wrapperExpression, [ (Nolabel, innerFunctionExpression) ]); + } -> + spelunkForFunExpression innerFunctionExpression + | { + pexp_desc = + Pexp_sequence (_wrapperExpression, innerFunctionExpression); + } -> + spelunkForFunExpression innerFunctionExpression + | { + pexp_desc = Pexp_constraint (innerFunctionExpression, _typ); + } -> + spelunkForFunExpression innerFunctionExpression + | { pexp_loc } -> + React_jsx_common.raiseError ~loc:pexp_loc + "react.component calls can only be on function \ + definitions or component wrappers (forwardRef, memo)." + in spelunkForFunExpression expression in - (wrapExpressionWithBinding wrapExpression, hasUnit, expression) - in - let bindingWrapper, hasUnit, expression = modifiedBinding binding in - let reactComponentAttribute = - try Some (List.find React_jsx_common.hasAttr binding.pvb_attributes) - with Not_found -> None - in - let _attr_loc, payload = - match reactComponentAttribute with - | Some (loc, payload) -> (loc.loc, Some payload) - | None -> (emptyLoc, None) - in - let props = getPropsAttr payload in - (* do stuff here! *) - let namedArgList, newtypes, forwardRef = - recursivelyTransformNamedArgsForMake mapper - (modifiedBindingOld binding) - [] [] - in - let namedArgListWithKeyAndRef = - ( optional "key", - None, - Pat.var {txt = "key"; loc = emptyLoc}, - "key", - emptyLoc, - Some (keyType emptyLoc) ) - :: namedArgList - in - let namedArgListWithKeyAndRef = - match forwardRef with - | Some _ -> - ( optional "ref", + let modifiedBinding binding = + let hasApplication = ref false in + let wrapExpressionWithBinding expressionFn expression = + Vb.mk ~loc:bindingLoc + ~attrs:(List.filter otherAttrsPure binding.pvb_attributes) + (Pat.var ~loc:bindingPatLoc + { loc = bindingPatLoc; txt = fnName }) + (expressionFn expression) + in + let expression = binding.pvb_expr in + let unerasableIgnoreExp exp = + { + exp with + pexp_attributes = + unerasableIgnore emptyLoc :: exp.pexp_attributes; + } + in + (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) + let rec spelunkForFunExpression expression = + match expression with + (* let make = (~prop) => ... with no final unit *) + | { + pexp_desc = + Pexp_fun + ( ((Labelled _ | Optional _) as label), + default, + pattern, + ({ pexp_desc = Pexp_fun _ } as internalExpression) ); + } -> + let wrap, hasUnit, exp = + spelunkForFunExpression internalExpression + in + ( wrap, + hasUnit, + unerasableIgnoreExp + { + expression with + pexp_desc = Pexp_fun (label, default, pattern, exp); + } ) + (* let make = (()) => ... *) + (* let make = (_) => ... *) + | { + pexp_desc = + Pexp_fun + ( Nolabel, + _default, + { + ppat_desc = + Ppat_construct ({ txt = Lident "()" }, _) | Ppat_any; + }, + _internalExpression ); + } -> + ((fun a -> a), true, expression) + (* let make = (~prop) => ... *) + | { + pexp_desc = + Pexp_fun + ( (Labelled _ | Optional _), + _default, + _pattern, + _internalExpression ); + } -> + ((fun a -> a), false, unerasableIgnoreExp expression) + (* let make = (prop) => ... *) + | { + pexp_desc = + Pexp_fun (_nolabel, _default, pattern, _internalExpression); + } -> + if hasApplication.contents then + ((fun a -> a), false, unerasableIgnoreExp expression) + else + Location.raise_errorf ~loc:pattern.ppat_loc + "React: props need to be labelled arguments.\n\ + \ If you are working with refs be sure to wrap with \ + React.forwardRef.\n\ + \ If your component doesn't have any props use () or \ + _ instead of a name." + (* let make = {let foo = bar in (~prop) => ...} *) + | { pexp_desc = Pexp_let (recursive, vbs, internalExpression) } + -> + (* here's where we spelunk! *) + let wrap, hasUnit, exp = + spelunkForFunExpression internalExpression + in + ( wrap, + hasUnit, + { + expression with + pexp_desc = Pexp_let (recursive, vbs, exp); + } ) + (* let make = React.forwardRef((~prop) => ...) *) + | { + pexp_desc = + Pexp_apply + (wrapperExpression, [ (Nolabel, internalExpression) ]); + } -> + let () = hasApplication := true in + let _, hasUnit, exp = + spelunkForFunExpression internalExpression + in + ( (fun exp -> Exp.apply wrapperExpression [ (nolabel, exp) ]), + hasUnit, + exp ) + | { + pexp_desc = + Pexp_sequence (wrapperExpression, internalExpression); + } -> + let wrap, hasUnit, exp = + spelunkForFunExpression internalExpression + in + ( wrap, + hasUnit, + { + expression with + pexp_desc = Pexp_sequence (wrapperExpression, exp); + } ) + | e -> ((fun a -> a), false, e) + in + let wrapExpression, hasUnit, expression = + spelunkForFunExpression expression + in + (wrapExpressionWithBinding wrapExpression, hasUnit, expression) + in + let bindingWrapper, hasUnit, expression = modifiedBinding binding in + let reactComponentAttribute = + try + Some (List.find React_jsx_common.hasAttr binding.pvb_attributes) + with Not_found -> None + in + let _attr_loc, payload = + match reactComponentAttribute with + | Some (loc, payload) -> (loc.loc, Some payload) + | None -> (emptyLoc, None) + in + let props = getPropsAttr payload in + (* do stuff here! *) + let namedArgList, newtypes, forwardRef = + recursivelyTransformNamedArgsForMake mapper + (modifiedBindingOld binding) + [] [] + in + let namedArgListWithKeyAndRef = + ( optional "key", None, - Pat.var {txt = "key"; loc = emptyLoc}, - "ref", + Pat.var { txt = "key"; loc = emptyLoc }, + "key", emptyLoc, - None ) - :: namedArgListWithKeyAndRef - | None -> namedArgListWithKeyAndRef - in - let namedArgListWithKeyAndRefForNew = - match forwardRef with - | Some txt -> - namedArgList - @ [ - ( nolabel, + Some (keyType emptyLoc) ) + :: namedArgList + in + let namedArgListWithKeyAndRef = + match forwardRef with + | Some _ -> + ( optional "ref", None, - Pat.var {txt; loc = emptyLoc}, - txt, + Pat.var { txt = "key"; loc = emptyLoc }, + "ref", emptyLoc, - None ); - ] - | None -> namedArgList - in - let pluckArg (label, _, _, alias, loc, _) = - let labelString = - match label with - | label when isOptional label || isLabelled label -> - getLabel label - | _ -> "" + None ) + :: namedArgListWithKeyAndRef + | None -> namedArgListWithKeyAndRef in - ( label, - match labelString with - | "" -> Exp.ident ~loc {txt = Lident alias; loc} - | labelString -> - Exp.apply ~loc - (Exp.ident ~loc {txt = Lident "##"; loc}) - [ - (nolabel, Exp.ident ~loc {txt = Lident props.propsName; loc}); - (nolabel, Exp.ident ~loc {txt = Lident labelString; loc}); - ] ) - in - let namedTypeList = List.fold_left argToType [] namedArgList in - let loc = emptyLoc in - let externalArgs = - (* translate newtypes to type variables *) - List.fold_left - (fun args newtype -> - List.map - (fun (a, b, c, d, e, maybeTyp) -> - match maybeTyp with - | Some typ -> - (a, b, c, d, e, Some (newtypeToVar newtype.txt typ)) - | None -> (a, b, c, d, e, None)) - args) - namedArgListWithKeyAndRef newtypes - in - let externalTypes = - (* translate newtypes to type variables *) - List.fold_left - (fun args newtype -> - List.map - (fun (a, b, typ) -> (a, b, newtypeToVar newtype.txt typ)) - args) - namedTypeList newtypes - in - let externalDecl = - makeExternalDecl fnName loc externalArgs externalTypes - in - let innerExpressionArgs = - List.map pluckArg namedArgListWithKeyAndRefForNew - @ - if hasUnit then - [(Nolabel, Exp.construct {loc; txt = Lident "()"} None)] - else [] - in - let innerExpression = - Exp.apply - (Exp.ident - { - loc; - txt = - Lident - (match recFlag with - | Recursive -> internalFnName - | Nonrecursive -> fnName); - }) - innerExpressionArgs - in - let innerExpressionWithRef = - match forwardRef with - | Some txt -> - { - innerExpression with - pexp_desc = - Pexp_fun - ( nolabel, - None, - { - ppat_desc = Ppat_var {txt; loc = emptyLoc}; - ppat_loc = emptyLoc; - ppat_attributes = []; - }, - innerExpression ); - } - | None -> innerExpression - in - let fullExpression = - Exp.fun_ nolabel None - { - ppat_desc = - Ppat_constraint - ( makePropsName ~loc:emptyLoc props.propsName, - makePropsType ~loc:emptyLoc externalTypes ); - ppat_loc = emptyLoc; - ppat_attributes = []; - } - innerExpressionWithRef - in - let fullExpression = - match fullModuleName with - | "" -> fullExpression - | txt -> - Exp.let_ Nonrecursive - [ - Vb.mk ~loc:emptyLoc - (Pat.var ~loc:emptyLoc {loc = emptyLoc; txt}) - fullExpression; - ] - (Exp.ident ~loc:emptyLoc {loc = emptyLoc; txt = Lident txt}) + let namedArgListWithKeyAndRefForNew = + match forwardRef with + | Some txt -> + namedArgList + @ [ + ( nolabel, + None, + Pat.var { txt; loc = emptyLoc }, + txt, + emptyLoc, + None ); + ] + | None -> namedArgList + in + let pluckArg (label, _, _, alias, loc, _) = + let labelString = + match label with + | label when isOptional label || isLabelled label -> + getLabel label + | _ -> "" + in + ( label, + match labelString with + | "" -> Exp.ident ~loc { txt = Lident alias; loc } + | labelString -> + Exp.apply ~loc + (Exp.ident ~loc { txt = Lident "##"; loc }) + [ + ( nolabel, + Exp.ident ~loc { txt = Lident props.propsName; loc } + ); + ( nolabel, + Exp.ident ~loc { txt = Lident labelString; loc } ); + ] ) + in + let namedTypeList = List.fold_left argToType [] namedArgList in + let loc = emptyLoc in + let externalArgs = + (* translate newtypes to type variables *) + List.fold_left + (fun args newtype -> + List.map + (fun (a, b, c, d, e, maybeTyp) -> + match maybeTyp with + | Some typ -> + (a, b, c, d, e, Some (newtypeToVar newtype.txt typ)) + | None -> (a, b, c, d, e, None)) + args) + namedArgListWithKeyAndRef newtypes + in + let externalTypes = + (* translate newtypes to type variables *) + List.fold_left + (fun args newtype -> + List.map + (fun (a, b, typ) -> (a, b, newtypeToVar newtype.txt typ)) + args) + namedTypeList newtypes + in + let externalDecl = + makeExternalDecl fnName loc externalArgs externalTypes + in + let innerExpressionArgs = + List.map pluckArg namedArgListWithKeyAndRefForNew + @ + if hasUnit then + [ (Nolabel, Exp.construct { loc; txt = Lident "()" } None) ] + else [] + in + let innerExpression = + Exp.apply + (Exp.ident + { + loc; + txt = + Lident + (match recFlag with + | Recursive -> internalFnName + | Nonrecursive -> fnName); + }) + innerExpressionArgs + in + let innerExpressionWithRef = + match forwardRef with + | Some txt -> + { + innerExpression with + pexp_desc = + Pexp_fun + ( nolabel, + None, + { + ppat_desc = Ppat_var { txt; loc = emptyLoc }; + ppat_loc = emptyLoc; + ppat_attributes = []; + }, + innerExpression ); + } + | None -> innerExpression + in + let fullExpression = + Exp.fun_ nolabel None + { + ppat_desc = + Ppat_constraint + ( makePropsName ~loc:emptyLoc props.propsName, + makePropsType ~loc:emptyLoc externalTypes ); + ppat_loc = emptyLoc; + ppat_attributes = []; + } + innerExpressionWithRef + in + let fullExpression = + match fullModuleName with + | "" -> fullExpression + | txt -> + Exp.let_ Nonrecursive + [ + Vb.mk ~loc:emptyLoc + (Pat.var ~loc:emptyLoc { loc = emptyLoc; txt }) + fullExpression; + ] + (Exp.ident ~loc:emptyLoc + { loc = emptyLoc; txt = Lident txt }) + in + let bindings, newBinding = + match recFlag with + | Recursive -> + ( [ + bindingWrapper + (Exp.let_ ~loc:emptyLoc Recursive + [ + makeNewBinding binding expression internalFnName; + Vb.mk + (Pat.var { loc = emptyLoc; txt = fnName }) + fullExpression; + ] + (Exp.ident { loc = emptyLoc; txt = Lident fnName })); + ], + None ) + | Nonrecursive -> + ( [ { binding with pvb_expr = expression } ], + Some (bindingWrapper fullExpression) ) + in + (Some externalDecl, bindings, newBinding) + else (None, [ binding ], None) + in + let structuresAndBinding = List.map mapBinding valueBindings in + let otherStructures (extern, binding, newBinding) + (externs, bindings, newBindings) = + let externs = + match extern with + | Some extern -> extern :: externs + | None -> externs in - let bindings, newBinding = - match recFlag with - | Recursive -> - ( [ - bindingWrapper - (Exp.let_ ~loc:emptyLoc Recursive - [ - makeNewBinding binding expression internalFnName; - Vb.mk - (Pat.var {loc = emptyLoc; txt = fnName}) - fullExpression; - ] - (Exp.ident {loc = emptyLoc; txt = Lident fnName})); - ], - None ) - | Nonrecursive -> - ( [{binding with pvb_expr = expression}], - Some (bindingWrapper fullExpression) ) + let newBindings = + match newBinding with + | Some newBinding -> newBinding :: newBindings + | None -> newBindings in - (Some externalDecl, bindings, newBinding) - else (None, [binding], None) - in - let structuresAndBinding = List.map mapBinding valueBindings in - let otherStructures (extern, binding, newBinding) - (externs, bindings, newBindings) = - let externs = - match extern with - | Some extern -> extern :: externs - | None -> externs + (externs, binding @ bindings, newBindings) in - let newBindings = - match newBinding with - | Some newBinding -> newBinding :: newBindings - | None -> newBindings + let externs, bindings, newBindings = + List.fold_right otherStructures structuresAndBinding ([], [], []) in - (externs, binding @ bindings, newBindings) - in - let externs, bindings, newBindings = - List.fold_right otherStructures structuresAndBinding ([], [], []) - in - externs - @ [{pstr_loc; pstr_desc = Pstr_value (recFlag, bindings)}] - @ - match newBindings with - | [] -> [] - | newBindings -> - [{pstr_loc = emptyLoc; pstr_desc = Pstr_value (recFlag, newBindings)}]) - | _ -> [item] + externs + @ [ { pstr_loc; pstr_desc = Pstr_value (recFlag, bindings) } ] + @ + match newBindings with + | [] -> [] + | newBindings -> + [ + { + pstr_loc = emptyLoc; + pstr_desc = Pstr_value (recFlag, newBindings); + }; + ]) + | _ -> [ item ] in let transformSignatureItem _mapper item = @@ -284776,152 +284997,164 @@ let jsxMapper ~config = psig_loc; psig_desc = Psig_value - ({pval_name = {txt = fnName}; pval_attributes; pval_type} as + ({ pval_name = { txt = fnName }; pval_attributes; pval_type } as psig_desc); } as psig -> ( - match List.filter React_jsx_common.hasAttr pval_attributes with - | [] -> [item] - | [_] -> - let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = - match ptyp_desc with - | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) - when isOptional name || isLabelled name -> - getPropTypes ((name, ptyp_loc, type_) :: types) rest - | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest - | Ptyp_arrow (name, type_, returnValue) - when isOptional name || isLabelled name -> - (returnValue, (name, returnValue.ptyp_loc, type_) :: types) - | _ -> (fullType, types) - in - let innerType, propTypes = getPropTypes [] pval_type in - let namedTypeList = List.fold_left argToConcreteType [] propTypes in - let pluckLabelAndLoc (label, loc, type_) = - (label, None, loc, Some type_) - in - let retPropsType = makePropsType ~loc:psig_loc namedTypeList in - let externalPropsDecl = - makePropsExternalSig fnName psig_loc - ((optional "key", None, psig_loc, Some (keyType psig_loc)) - :: List.map pluckLabelAndLoc propTypes) - retPropsType - in - (* can't be an arrow because it will defensively uncurry *) - let newExternalType = - Ptyp_constr - ( {loc = psig_loc; txt = Ldot (Lident "React", "componentLike")}, - [retPropsType; innerType] ) - in - let newStructure = - { - psig with - psig_desc = - Psig_value - { - psig_desc with - pval_type = {pval_type with ptyp_desc = newExternalType}; - pval_attributes = List.filter otherAttrsPure pval_attributes; - }; - } - in - [externalPropsDecl; newStructure] - | _ -> - React_jsx_common.raiseError ~loc:psig_loc - "Only one react.component call can exist on a component at one time") - | _ -> [item] + match List.filter React_jsx_common.hasAttr pval_attributes with + | [] -> [ item ] + | [ _ ] -> + let rec getPropTypes types ({ ptyp_loc; ptyp_desc } as fullType) = + match ptyp_desc with + | Ptyp_arrow (name, type_, ({ ptyp_desc = Ptyp_arrow _ } as rest)) + when isOptional name || isLabelled name -> + getPropTypes ((name, ptyp_loc, type_) :: types) rest + | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest + | Ptyp_arrow (name, type_, returnValue) + when isOptional name || isLabelled name -> + (returnValue, (name, returnValue.ptyp_loc, type_) :: types) + | _ -> (fullType, types) + in + let innerType, propTypes = getPropTypes [] pval_type in + let namedTypeList = List.fold_left argToConcreteType [] propTypes in + let pluckLabelAndLoc (label, loc, type_) = + (label, None, loc, Some type_) + in + let retPropsType = makePropsType ~loc:psig_loc namedTypeList in + let externalPropsDecl = + makePropsExternalSig fnName psig_loc + ((optional "key", None, psig_loc, Some (keyType psig_loc)) + :: List.map pluckLabelAndLoc propTypes) + retPropsType + in + (* can't be an arrow because it will defensively uncurry *) + let newExternalType = + Ptyp_constr + ( { + loc = psig_loc; + txt = Ldot (Lident "React", "componentLike"); + }, + [ retPropsType; innerType ] ) + in + let newStructure = + { + psig with + psig_desc = + Psig_value + { + psig_desc with + pval_type = { pval_type with ptyp_desc = newExternalType }; + pval_attributes = + List.filter otherAttrsPure pval_attributes; + }; + } + in + [ externalPropsDecl; newStructure ] + | _ -> + React_jsx_common.raiseError ~loc:psig_loc + "Only one react.component call can exist on a component at one \ + time") + | _ -> [ item ] in let transformJsxCall mapper callExpression callArguments attrs = match callExpression.pexp_desc with | Pexp_ident caller -> ( - match caller with - | {txt = Lident "createElement"; loc} -> - React_jsx_common.raiseError ~loc - "JSX: `createElement` should be preceeded by a module name." - (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *) - | {loc; txt = Ldot (modulePath, ("createElement" | "make"))} -> ( - match config.React_jsx_common.version with - | 3 -> - transformUppercaseCall3 modulePath mapper loc attrs callExpression - callArguments - | _ -> - React_jsx_common.raiseError ~loc "JSX: the JSX version must be 3") - (* div(~prop1=foo, ~prop2=bar, ~children=[bla], ()) *) - (* turn that into - ReactDOMRe.createElement(~props=ReactDOMRe.props(~props1=foo, ~props2=bar, ()), [|bla|]) *) - | {loc; txt = Lident id} -> ( - match config.version with - | 3 -> transformLowercaseCall3 mapper loc attrs callArguments id - | _ -> React_jsx_common.raiseError ~loc "JSX: the JSX version must be 3" - ) - | {txt = Ldot (_, anythingNotCreateElementOrMake); loc} -> - React_jsx_common.raiseError ~loc - "JSX: the JSX attribute should be attached to a \ - `YourModuleName.createElement` or `YourModuleName.make` call. We \ - saw `%s` instead" - anythingNotCreateElementOrMake - | {txt = Lapply _; loc} -> - (* don't think there's ever a case where this is reached *) - React_jsx_common.raiseError ~loc - "JSX: encountered a weird case while processing the code. Please \ - report this!") + match caller with + | { txt = Lident "createElement"; loc } -> + React_jsx_common.raiseError ~loc + "JSX: `createElement` should be preceeded by a module name." + (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *) + | { loc; txt = Ldot (modulePath, ("createElement" | "make")) } -> ( + match config.React_jsx_common.version with + | 3 -> + transformUppercaseCall3 modulePath mapper loc attrs + callExpression callArguments + | _ -> + React_jsx_common.raiseError ~loc + "JSX: the JSX version must be 3") + (* div(~prop1=foo, ~prop2=bar, ~children=[bla], ()) *) + (* turn that into + ReactDOMRe.createElement(~props=ReactDOMRe.props(~props1=foo, ~props2=bar, ()), [|bla|]) *) + | { loc; txt = Lident id } -> ( + match config.version with + | 3 -> transformLowercaseCall3 mapper loc attrs callArguments id + | _ -> + React_jsx_common.raiseError ~loc + "JSX: the JSX version must be 3") + | { txt = Ldot (_, anythingNotCreateElementOrMake); loc } -> + React_jsx_common.raiseError ~loc + "JSX: the JSX attribute should be attached to a \ + `YourModuleName.createElement` or `YourModuleName.make` call. \ + We saw `%s` instead" + anythingNotCreateElementOrMake + | { txt = Lapply _; loc } -> + (* don't think there's ever a case where this is reached *) + React_jsx_common.raiseError ~loc + "JSX: encountered a weird case while processing the code. Please \ + report this!") | _ -> - React_jsx_common.raiseError ~loc:callExpression.pexp_loc - "JSX: `createElement` should be preceeded by a simple, direct module \ - name." + React_jsx_common.raiseError ~loc:callExpression.pexp_loc + "JSX: `createElement` should be preceeded by a simple, direct module \ + name." in let expr mapper expression = match expression with (* Does the function application have the @JSX attribute? *) - | {pexp_desc = Pexp_apply (callExpression, callArguments); pexp_attributes} - -> ( - let jsxAttribute, nonJSXAttributes = - List.partition - (fun (attribute, _) -> attribute.txt = "JSX") - pexp_attributes - in - match (jsxAttribute, nonJSXAttributes) with - (* no JSX attribute *) - | [], _ -> default_mapper.expr mapper expression - | _, nonJSXAttributes -> - transformJsxCall mapper callExpression callArguments nonJSXAttributes) + | { + pexp_desc = Pexp_apply (callExpression, callArguments); + pexp_attributes; + } -> ( + let jsxAttribute, nonJSXAttributes = + List.partition + (fun (attribute, _) -> attribute.txt = "JSX") + pexp_attributes + in + match (jsxAttribute, nonJSXAttributes) with + (* no JSX attribute *) + | [], _ -> default_mapper.expr mapper expression + | _, nonJSXAttributes -> + transformJsxCall mapper callExpression callArguments + nonJSXAttributes) (* is it a list with jsx attribute? Reason <>foo desugars to [@JSX][foo]*) | { pexp_desc = ( Pexp_construct - ({txt = Lident "::"; loc}, Some {pexp_desc = Pexp_tuple _}) - | Pexp_construct ({txt = Lident "[]"; loc}, None) ); + ({ txt = Lident "::"; loc }, Some { pexp_desc = Pexp_tuple _ }) + | Pexp_construct ({ txt = Lident "[]"; loc }, None) ); pexp_attributes; } as listItems -> ( - let jsxAttribute, nonJSXAttributes = - List.partition - (fun (attribute, _) -> attribute.txt = "JSX") - pexp_attributes - in - match (jsxAttribute, nonJSXAttributes) with - (* no JSX attribute *) - | [], _ -> default_mapper.expr mapper expression - | _, nonJSXAttributes -> - let loc = {loc with loc_ghost = true} in - let fragment = - Exp.ident ~loc {loc; txt = Ldot (Lident "ReasonReact", "fragment")} - in - let childrenExpr = transformChildrenIfList ~loc ~mapper listItems in - let args = - [ - (* "div" *) - (nolabel, fragment); - (* [|moreCreateElementCallsHere|] *) - (nolabel, childrenExpr); - ] + let jsxAttribute, nonJSXAttributes = + List.partition + (fun (attribute, _) -> attribute.txt = "JSX") + pexp_attributes in - Exp.apply - ~loc (* throw away the [@JSX] attribute and keep the others, if any *) - ~attrs:nonJSXAttributes - (* ReactDOMRe.createElement *) - (Exp.ident ~loc - {loc; txt = Ldot (Lident "ReactDOMRe", "createElement")}) - args) + match (jsxAttribute, nonJSXAttributes) with + (* no JSX attribute *) + | [], _ -> default_mapper.expr mapper expression + | _, nonJSXAttributes -> + let loc = { loc with loc_ghost = true } in + let fragment = + Exp.ident ~loc + { loc; txt = Ldot (Lident "ReasonReact", "fragment") } + in + let childrenExpr = transformChildrenIfList ~loc ~mapper listItems in + let args = + [ + (* "div" *) + (nolabel, fragment); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr); + ] + in + Exp.apply + ~loc + (* throw away the [@JSX] attribute and keep the others, if any *) + ~attrs:nonJSXAttributes + (* ReactDOMRe.createElement *) + (Exp.ident ~loc + { loc; txt = Ldot (Lident "ReactDOMRe", "createElement") }) + args) (* Delegate to the default mapper, a deep identity traversal *) | e -> default_mapper.expr mapper e in @@ -284930,9 +285163,7 @@ let jsxMapper ~config = let _ = nestedModules := module_binding.pmb_name.txt :: !nestedModules in let mapped = default_mapper.module_binding mapper module_binding in let () = - match !nestedModules with - | _ :: rest -> nestedModules := rest - | [] -> () + match !nestedModules with _ :: rest -> nestedModules := rest | [] -> () in mapped in @@ -284949,37 +285180,26 @@ open Parsetree open Longident let nolabel = Nolabel - let labelled str = Labelled str - -let isOptional str = - match str with - | Optional _ -> true - | _ -> false - -let isLabelled str = - match str with - | Labelled _ -> true - | _ -> false +let isOptional str = match str with Optional _ -> true | _ -> false +let isLabelled str = match str with Labelled _ -> true | _ -> false let isForwardRef = function - | {pexp_desc = Pexp_ident {txt = Ldot (Lident "React", "forwardRef")}} -> true + | { pexp_desc = Pexp_ident { txt = Ldot (Lident "React", "forwardRef") } } -> + true | _ -> false let getLabel str = - match str with - | Optional str | Labelled str -> str - | Nolabel -> "" + match str with Optional str | Labelled str -> str | Nolabel -> "" -let optionalAttr = ({txt = "ns.optional"; loc = Location.none}, PStr []) -let optionalAttrs = [optionalAttr] +let optionalAttr = ({ txt = "ns.optional"; loc = Location.none }, PStr []) +let optionalAttrs = [ optionalAttr ] let constantString ~loc str = Ast_helper.Exp.constant ~loc (Pconst_string (str, None)) (* {} empty record *) let emptyRecord ~loc = Exp.record ~loc [] None - let unitExpr ~loc = Exp.construct ~loc (Location.mkloc (Lident "()") loc) None let safeTypeFromValue valueStr = @@ -284989,7 +285209,7 @@ let safeTypeFromValue valueStr = let refType loc = Typ.constr ~loc - {loc; txt = Ldot (Ldot (Lident "ReactDOM", "Ref"), "currentDomRef")} + { loc; txt = Ldot (Ldot (Lident "ReactDOM", "Ref"), "currentDomRef") } [] type 'a children = ListLiteral of 'a | Exact of 'a @@ -285000,16 +285220,16 @@ let transformChildrenIfListUpper ~mapper theList = (* not in the sense of converting a list to an array; convert the AST reprensentation of a list to the AST reprensentation of an array *) match theList with - | {pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} -> ( - match accum with - | [singleElement] -> Exact singleElement - | accum -> ListLiteral (Exp.array (List.rev accum))) + | { pexp_desc = Pexp_construct ({ txt = Lident "[]" }, None) } -> ( + match accum with + | [ singleElement ] -> Exact singleElement + | accum -> ListLiteral (Exp.array (List.rev accum))) | { pexp_desc = Pexp_construct - ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple [v; acc]}); + ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple [ v; acc ] }); } -> - transformChildren_ acc (mapper.expr mapper v :: accum) + transformChildren_ acc (mapper.expr mapper v :: accum) | notAList -> Exact (mapper.expr mapper notAList) in transformChildren_ theList [] @@ -285019,14 +285239,14 @@ let transformChildrenIfList ~mapper theList = (* not in the sense of converting a list to an array; convert the AST reprensentation of a list to the AST reprensentation of an array *) match theList with - | {pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} -> - Exp.array (List.rev accum) + | { pexp_desc = Pexp_construct ({ txt = Lident "[]" }, None) } -> + Exp.array (List.rev accum) | { pexp_desc = Pexp_construct - ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple [v; acc]}); + ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple [ v; acc ] }); } -> - transformChildren_ acc (mapper.expr mapper v :: accum) + transformChildren_ acc (mapper.expr mapper v :: accum) | notAList -> mapper.expr mapper notAList in transformChildren_ theList [] @@ -285035,11 +285255,13 @@ let extractChildren ?(removeLastPositionUnit = false) ~loc propsAndChildren = let rec allButLast_ lst acc = match lst with | [] -> [] - | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] -> - acc - | (Nolabel, {pexp_loc}) :: _rest -> - React_jsx_common.raiseError ~loc:pexp_loc - "JSX: found non-labelled argument before the last position" + | [ + (Nolabel, { pexp_desc = Pexp_construct ({ txt = Lident "()" }, None) }); + ] -> + acc + | (Nolabel, { pexp_loc }) :: _rest -> + React_jsx_common.raiseError ~loc:pexp_loc + "JSX: found non-labelled argument before the last position" | arg :: rest -> allButLast_ rest (arg :: acc) in let allButLast lst = allButLast_ lst [] |> List.rev in @@ -285049,16 +285271,16 @@ let extractChildren ?(removeLastPositionUnit = false) ~loc propsAndChildren = propsAndChildren with | [], props -> - (* no children provided? Place a placeholder list *) - ( Exp.construct {loc = Location.none; txt = Lident "[]"} None, - if removeLastPositionUnit then allButLast props else props ) - | [(_, childrenExpr)], props -> - (childrenExpr, if removeLastPositionUnit then allButLast props else props) + (* no children provided? Place a placeholder list *) + ( Exp.construct { loc = Location.none; txt = Lident "[]" } None, + if removeLastPositionUnit then allButLast props else props ) + | [ (_, childrenExpr) ], props -> + (childrenExpr, if removeLastPositionUnit then allButLast props else props) | _ -> - React_jsx_common.raiseError ~loc - "JSX: somehow there's more than one `children` label" + React_jsx_common.raiseError ~loc + "JSX: somehow there's more than one `children` label" -let merlinFocus = ({loc = Location.none; txt = "merlin.focus"}, PStr []) +let merlinFocus = ({ loc = Location.none; txt = "merlin.focus" }, PStr []) (* Helper method to filter out any attribute that isn't [@react.component] *) let otherAttrsPure (loc, _) = loc.txt <> "react.component" @@ -285066,25 +285288,25 @@ let otherAttrsPure (loc, _) = loc.txt <> "react.component" (* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *) let rec getFnName binding = match binding with - | {ppat_desc = Ppat_var {txt}} -> txt - | {ppat_desc = Ppat_constraint (pat, _)} -> getFnName pat - | {ppat_loc} -> - React_jsx_common.raiseError ~loc:ppat_loc - "react.component calls cannot be destructured." + | { ppat_desc = Ppat_var { txt } } -> txt + | { ppat_desc = Ppat_constraint (pat, _) } -> getFnName pat + | { ppat_loc } -> + React_jsx_common.raiseError ~loc:ppat_loc + "react.component calls cannot be destructured." let makeNewBinding binding expression newName = match binding with - | {pvb_pat = {ppat_desc = Ppat_var ppat_var} as pvb_pat} -> - { - binding with - pvb_pat = - {pvb_pat with ppat_desc = Ppat_var {ppat_var with txt = newName}}; - pvb_expr = expression; - pvb_attributes = [merlinFocus]; - } - | {pvb_loc} -> - React_jsx_common.raiseError ~loc:pvb_loc - "react.component calls cannot be destructured." + | { pvb_pat = { ppat_desc = Ppat_var ppat_var } as pvb_pat } -> + { + binding with + pvb_pat = + { pvb_pat with ppat_desc = Ppat_var { ppat_var with txt = newName } }; + pvb_expr = expression; + pvb_attributes = [ merlinFocus ]; + } + | { pvb_loc } -> + React_jsx_common.raiseError ~loc:pvb_loc + "react.component calls cannot be destructured." (* Lookup the filename from the location information on the AST node and turn it into a valid module identifier *) let filenameFromLoc (pstr_loc : Location.t) = @@ -285109,7 +285331,7 @@ let makeModuleName fileName nestedModules fnName = | "", nestedModules, fnName -> List.rev (fnName :: nestedModules) | fileName, nestedModules, "make" -> fileName :: List.rev nestedModules | fileName, nestedModules, fnName -> - fileName :: List.rev (fnName :: nestedModules) + fileName :: List.rev (fnName :: nestedModules) in let fullModuleName = String.concat "$" fullModuleName in fullModuleName @@ -285126,21 +285348,23 @@ let recordFromProps ~loc ~removeKey callArguments = let rec removeLastPositionUnitAux props acc = match props with | [] -> acc - | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] -> - acc - | (Nolabel, {pexp_loc}) :: _rest -> - React_jsx_common.raiseError ~loc:pexp_loc - "JSX: found non-labelled argument before the last position" - | ((Labelled txt, {pexp_loc}) as prop) :: rest - | ((Optional txt, {pexp_loc}) as prop) :: rest -> - if txt = spreadPropsLabel then - match acc with - | [] -> removeLastPositionUnitAux rest (prop :: acc) - | _ -> - React_jsx_common.raiseError ~loc:pexp_loc - "JSX: use {...p} {x: v} not {x: v} {...p} \n\ - \ multiple spreads {...p} {...p} not allowed." - else removeLastPositionUnitAux rest (prop :: acc) + | [ + (Nolabel, { pexp_desc = Pexp_construct ({ txt = Lident "()" }, None) }); + ] -> + acc + | (Nolabel, { pexp_loc }) :: _rest -> + React_jsx_common.raiseError ~loc:pexp_loc + "JSX: found non-labelled argument before the last position" + | ((Labelled txt, { pexp_loc }) as prop) :: rest + | ((Optional txt, { pexp_loc }) as prop) :: rest -> + if txt = spreadPropsLabel then + match acc with + | [] -> removeLastPositionUnitAux rest (prop :: acc) + | _ -> + React_jsx_common.raiseError ~loc:pexp_loc + "JSX: use {...p} {x: v} not {x: v} {...p} \n\ + \ multiple spreads {...p} {...p} not allowed." + else removeLastPositionUnitAux rest (prop :: acc) in let props, propsToSpread = removeLastPositionUnitAux callArguments [] @@ -285153,34 +285377,34 @@ let recordFromProps ~loc ~removeKey callArguments = else props in - let processProp (arg_label, ({pexp_loc} as pexpr)) = + let processProp (arg_label, ({ pexp_loc } as pexpr)) = (* In case filed label is "key" only then change expression to option *) let id = getLabel arg_label in if isOptional arg_label then - ( {txt = Lident id; loc = pexp_loc}, - {pexpr with pexp_attributes = optionalAttrs} ) - else ({txt = Lident id; loc = pexp_loc}, pexpr) + ( { txt = Lident id; loc = pexp_loc }, + { pexpr with pexp_attributes = optionalAttrs } ) + else ({ txt = Lident id; loc = pexp_loc }, pexpr) in let fields = props |> List.map processProp in let spreadFields = propsToSpread |> List.map (fun (_, expression) -> expression) in match (fields, spreadFields) with - | [], [spreadProps] | [], spreadProps :: _ -> spreadProps + | [], [ spreadProps ] | [], spreadProps :: _ -> spreadProps | _, [] -> - { - pexp_desc = Pexp_record (fields, None); - pexp_loc = loc; - pexp_attributes = []; - } - | _, [spreadProps] + { + pexp_desc = Pexp_record (fields, None); + pexp_loc = loc; + pexp_attributes = []; + } + | _, [ spreadProps ] (* take the first spreadProps only *) | _, spreadProps :: _ -> - { - pexp_desc = Pexp_record (fields, Some spreadProps); - pexp_loc = loc; - pexp_attributes = []; - } + { + pexp_desc = Pexp_record (fields, Some spreadProps); + pexp_loc = loc; + pexp_attributes = []; + } (* make type params for make fn arguments *) (* let make = ({id, name, children}: props<'id, 'name, 'children>) *) @@ -285192,17 +285416,18 @@ let makePropsTypeParamsTvar namedTypeList = let stripOption coreType = match coreType with - | {ptyp_desc = Ptyp_constr ({txt = Lident "option"}, coreTypes)} -> - List.nth_opt coreTypes 0 [@doesNotRaise] + | { ptyp_desc = Ptyp_constr ({ txt = Lident "option" }, coreTypes) } -> + List.nth_opt coreTypes 0 [@doesNotRaise] | _ -> Some coreType let stripJsNullable coreType = match coreType with | { ptyp_desc = - Ptyp_constr ({txt = Ldot (Ldot (Lident "Js", "Nullable"), "t")}, coreTypes); + Ptyp_constr + ({ txt = Ldot (Ldot (Lident "Js", "Nullable"), "t") }, coreTypes); } -> - List.nth_opt coreTypes 0 [@doesNotRaise] + List.nth_opt coreTypes 0 [@doesNotRaise] | _ -> Some coreType (* Make type params of the props type *) @@ -285221,11 +285446,11 @@ let makePropsTypeParams ?(stripExplicitOption = false) For example, if JSX ppx is used for React Native, type would be different. *) match interiorType with - | {ptyp_desc = Ptyp_var "ref"} -> Some (refType Location.none) + | { ptyp_desc = Ptyp_var "ref" } -> Some (refType Location.none) | _ -> - (* Strip explicit Js.Nullable.t in case of forwardRef *) - if stripExplicitJsNullableOfRef then stripJsNullable interiorType - else Some interiorType + (* Strip explicit Js.Nullable.t in case of forwardRef *) + if stripExplicitJsNullableOfRef then stripJsNullable interiorType + else Some interiorType (* Strip the explicit option type in implementation *) (* let make = (~x: option=?) => ... *) else if isOptional && stripExplicitOption then stripOption interiorType @@ -285235,12 +285460,13 @@ let makeLabelDecls ~loc namedTypeList = namedTypeList |> List.map (fun (isOptional, label, _, interiorType) -> if label = "key" then - Type.field ~loc ~attrs:optionalAttrs {txt = label; loc} interiorType + Type.field ~loc ~attrs:optionalAttrs { txt = label; loc } + interiorType else if isOptional then - Type.field ~loc ~attrs:optionalAttrs {txt = label; loc} + Type.field ~loc ~attrs:optionalAttrs { txt = label; loc } (Typ.var @@ safeTypeFromValue @@ Labelled label) else - Type.field ~loc {txt = label; loc} + Type.field ~loc { txt = label; loc } (Typ.var @@ safeTypeFromValue @@ Labelled label)) let makeTypeDecls propsName loc namedTypeList = @@ -285251,13 +285477,13 @@ let makeTypeDecls propsName loc namedTypeList = |> List.map (fun coreType -> (coreType, Invariant)) in [ - Type.mk ~loc ~params {txt = propsName; loc} + Type.mk ~loc ~params { txt = propsName; loc } ~kind:(Ptype_record labelDeclList); ] let makeTypeDeclsWithCoreType propsName loc coreType typVars = [ - Type.mk ~loc {txt = propsName; loc} ~kind:Ptype_abstract + Type.mk ~loc { txt = propsName; loc } ~kind:Ptype_abstract ~params:(typVars |> List.map (fun v -> (v, Invariant))) ~manifest:coreType; ] @@ -285269,7 +285495,7 @@ let makePropsRecordType ~coreTypeOfAttr ~typVarsOfCoreType propsName loc (match coreTypeOfAttr with | None -> makeTypeDecls propsName loc namedTypeList | Some coreType -> - makeTypeDeclsWithCoreType propsName loc coreType typVarsOfCoreType) + makeTypeDeclsWithCoreType propsName loc coreType typVarsOfCoreType) (* type props<'x, 'y, ...> = { x: 'x, y?: 'y, ... } *) let makePropsRecordTypeSig ~coreTypeOfAttr ~typVarsOfCoreType propsName loc @@ -285278,7 +285504,7 @@ let makePropsRecordTypeSig ~coreTypeOfAttr ~typVarsOfCoreType propsName loc (match coreTypeOfAttr with | None -> makeTypeDecls propsName loc namedTypeList | Some coreType -> - makeTypeDeclsWithCoreType propsName loc coreType typVarsOfCoreType) + makeTypeDeclsWithCoreType propsName loc coreType typVarsOfCoreType) let transformUppercaseCall3 ~config modulePath mapper jsxExprLoc callExprLoc attrs callArguments = @@ -285297,26 +285523,30 @@ let transformUppercaseCall3 ~config modulePath mapper jsxExprLoc callExprLoc recursivelyTransformedArgsForMake @ match childrenExpr with - | Exact children -> [(labelled "children", children)] - | ListLiteral {pexp_desc = Pexp_array list} when list = [] -> [] + | Exact children -> [ (labelled "children", children) ] + | ListLiteral { pexp_desc = Pexp_array list } when list = [] -> [] | ListLiteral expression -> ( - (* this is a hack to support react components that introspect into their children *) - childrenArg := Some expression; - match config.React_jsx_common.mode with - | "automatic" -> - [ - ( labelled "children", - Exp.apply - (Exp.ident - {txt = Ldot (Lident "React", "array"); loc = Location.none}) - [(Nolabel, expression)] ); - ] - | _ -> - [ - ( labelled "children", - Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "null")} - ); - ]) + (* this is a hack to support react components that introspect into their children *) + childrenArg := Some expression; + match config.React_jsx_common.mode with + | "automatic" -> + [ + ( labelled "children", + Exp.apply + (Exp.ident + { + txt = Ldot (Lident "React", "array"); + loc = Location.none; + }) + [ (Nolabel, expression) ] ); + ] + | _ -> + [ + ( labelled "children", + Exp.ident + { loc = Location.none; txt = Ldot (Lident "React", "null") } + ); + ]) in let isCap str = String.capitalize_ascii str = str in @@ -285324,10 +285554,10 @@ let transformUppercaseCall3 ~config modulePath mapper jsxExprLoc callExprLoc match modulePath with | Lident _ -> Ldot (modulePath, suffix) | Ldot (_modulePath, value) as fullPath when isCap value -> - Ldot (fullPath, suffix) + Ldot (fullPath, suffix) | modulePath -> modulePath in - let isEmptyRecord {pexp_desc} = + let isEmptyRecord { pexp_desc } = match pexp_desc with | Pexp_record (labelDecls, _) when List.length labelDecls = 0 -> true | _ -> false @@ -285343,59 +285573,69 @@ let transformUppercaseCall3 ~config modulePath mapper jsxExprLoc callExprLoc args |> List.filter (fun (arg_label, _) -> "key" = getLabel arg_label) in let makeID = - Exp.ident ~loc:callExprLoc {txt = ident ~suffix:"make"; loc = callExprLoc} + Exp.ident ~loc:callExprLoc { txt = ident ~suffix:"make"; loc = callExprLoc } in match config.mode with (* The new jsx transform *) | "automatic" -> - let jsxExpr, keyAndUnit = + let jsxExpr, keyAndUnit = + match (!childrenArg, keyProp) with + | None, key :: _ -> + ( Exp.ident + { loc = Location.none; txt = Ldot (Lident "React", "jsxKeyed") }, + [ key; (nolabel, unitExpr ~loc:Location.none) ] ) + | None, [] -> + ( Exp.ident + { loc = Location.none; txt = Ldot (Lident "React", "jsx") }, + [] ) + | Some _, key :: _ -> + ( Exp.ident + { + loc = Location.none; + txt = Ldot (Lident "React", "jsxsKeyed"); + }, + [ key; (nolabel, unitExpr ~loc:Location.none) ] ) + | Some _, [] -> + ( Exp.ident + { loc = Location.none; txt = Ldot (Lident "React", "jsxs") }, + [] ) + in + Exp.apply ~attrs jsxExpr + ([ (nolabel, makeID); (nolabel, props) ] @ keyAndUnit) + | _ -> ( match (!childrenArg, keyProp) with | None, key :: _ -> - ( Exp.ident - {loc = Location.none; txt = Ldot (Lident "React", "jsxKeyed")}, - [key; (nolabel, unitExpr ~loc:Location.none)] ) + Exp.apply ~attrs + (Exp.ident + { + loc = Location.none; + txt = Ldot (Lident "React", "createElementWithKey"); + }) + [ key; (nolabel, makeID); (nolabel, props) ] | None, [] -> - (Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "jsx")}, []) - | Some _, key :: _ -> - ( Exp.ident - {loc = Location.none; txt = Ldot (Lident "React", "jsxsKeyed")}, - [key; (nolabel, unitExpr ~loc:Location.none)] ) - | Some _, [] -> - ( Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "jsxs")}, - [] ) - in - Exp.apply ~attrs jsxExpr ([(nolabel, makeID); (nolabel, props)] @ keyAndUnit) - | _ -> ( - match (!childrenArg, keyProp) with - | None, key :: _ -> - Exp.apply ~attrs - (Exp.ident - { - loc = Location.none; - txt = Ldot (Lident "React", "createElementWithKey"); - }) - [key; (nolabel, makeID); (nolabel, props)] - | None, [] -> - Exp.apply ~attrs - (Exp.ident - {loc = Location.none; txt = Ldot (Lident "React", "createElement")}) - [(nolabel, makeID); (nolabel, props)] - | Some children, key :: _ -> - Exp.apply ~attrs - (Exp.ident - { - loc = Location.none; - txt = Ldot (Lident "React", "createElementVariadicWithKey"); - }) - [key; (nolabel, makeID); (nolabel, props); (nolabel, children)] - | Some children, [] -> - Exp.apply ~attrs - (Exp.ident - { - loc = Location.none; - txt = Ldot (Lident "React", "createElementVariadic"); - }) - [(nolabel, makeID); (nolabel, props); (nolabel, children)]) + Exp.apply ~attrs + (Exp.ident + { + loc = Location.none; + txt = Ldot (Lident "React", "createElement"); + }) + [ (nolabel, makeID); (nolabel, props) ] + | Some children, key :: _ -> + Exp.apply ~attrs + (Exp.ident + { + loc = Location.none; + txt = Ldot (Lident "React", "createElementVariadicWithKey"); + }) + [ key; (nolabel, makeID); (nolabel, props); (nolabel, children) ] + | Some children, [] -> + Exp.apply ~attrs + (Exp.ident + { + loc = Location.none; + txt = Ldot (Lident "React", "createElementVariadic"); + }) + [ (nolabel, makeID); (nolabel, props); (nolabel, children) ]) let transformLowercaseCall3 ~config mapper jsxExprLoc callExprLoc attrs callArguments id = @@ -285403,125 +285643,138 @@ let transformLowercaseCall3 ~config mapper jsxExprLoc callExprLoc attrs match config.React_jsx_common.mode with (* the new jsx transform *) | "automatic" -> - let children, nonChildrenProps = - extractChildren ~removeLastPositionUnit:true ~loc:jsxExprLoc callArguments - in - let argsForMake = nonChildrenProps in - let childrenExpr = transformChildrenIfListUpper ~mapper children in - let recursivelyTransformedArgsForMake = - argsForMake - |> List.map (fun (label, expression) -> - (label, mapper.expr mapper expression)) - in - let childrenArg = ref None in - let args = - recursivelyTransformedArgsForMake - @ - match childrenExpr with - | Exact children -> - [ - ( labelled "children", - Exp.apply ~attrs:optionalAttrs - (Exp.ident - { - txt = Ldot (Lident "ReactDOM", "someElement"); - loc = Location.none; - }) - [(Nolabel, children)] ); - ] - | ListLiteral {pexp_desc = Pexp_array list} when list = [] -> [] - | ListLiteral expression -> - (* this is a hack to support react components that introspect into their children *) - childrenArg := Some expression; - [ - ( labelled "children", - Exp.apply - (Exp.ident - {txt = Ldot (Lident "React", "array"); loc = Location.none}) - [(Nolabel, expression)] ); - ] - in - let isEmptyRecord {pexp_desc} = - match pexp_desc with - | Pexp_record (labelDecls, _) when List.length labelDecls = 0 -> true - | _ -> false - in - let record = recordFromProps ~loc:jsxExprLoc ~removeKey:true args in - let props = - if isEmptyRecord record then emptyRecord ~loc:jsxExprLoc else record - in - let keyProp = - args |> List.filter (fun (arg_label, _) -> "key" = getLabel arg_label) - in - let jsxExpr, keyAndUnit = - match (!childrenArg, keyProp) with - | None, key :: _ -> - ( Exp.ident - {loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsxKeyed")}, - [key; (nolabel, unitExpr ~loc:Location.none)] ) - | None, [] -> - ( Exp.ident {loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsx")}, - [] ) - | Some _, key :: _ -> - ( Exp.ident - {loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsxsKeyed")}, - [key; (nolabel, unitExpr ~loc:Location.none)] ) - | Some _, [] -> - ( Exp.ident {loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsxs")}, - [] ) - in - Exp.apply ~attrs jsxExpr - ([(nolabel, componentNameExpr); (nolabel, props)] @ keyAndUnit) + let children, nonChildrenProps = + extractChildren ~removeLastPositionUnit:true ~loc:jsxExprLoc + callArguments + in + let argsForMake = nonChildrenProps in + let childrenExpr = transformChildrenIfListUpper ~mapper children in + let recursivelyTransformedArgsForMake = + argsForMake + |> List.map (fun (label, expression) -> + (label, mapper.expr mapper expression)) + in + let childrenArg = ref None in + let args = + recursivelyTransformedArgsForMake + @ + match childrenExpr with + | Exact children -> + [ + ( labelled "children", + Exp.apply ~attrs:optionalAttrs + (Exp.ident + { + txt = Ldot (Lident "ReactDOM", "someElement"); + loc = Location.none; + }) + [ (Nolabel, children) ] ); + ] + | ListLiteral { pexp_desc = Pexp_array list } when list = [] -> [] + | ListLiteral expression -> + (* this is a hack to support react components that introspect into their children *) + childrenArg := Some expression; + [ + ( labelled "children", + Exp.apply + (Exp.ident + { + txt = Ldot (Lident "React", "array"); + loc = Location.none; + }) + [ (Nolabel, expression) ] ); + ] + in + let isEmptyRecord { pexp_desc } = + match pexp_desc with + | Pexp_record (labelDecls, _) when List.length labelDecls = 0 -> true + | _ -> false + in + let record = recordFromProps ~loc:jsxExprLoc ~removeKey:true args in + let props = + if isEmptyRecord record then emptyRecord ~loc:jsxExprLoc else record + in + let keyProp = + args |> List.filter (fun (arg_label, _) -> "key" = getLabel arg_label) + in + let jsxExpr, keyAndUnit = + match (!childrenArg, keyProp) with + | None, key :: _ -> + ( Exp.ident + { + loc = Location.none; + txt = Ldot (Lident "ReactDOM", "jsxKeyed"); + }, + [ key; (nolabel, unitExpr ~loc:Location.none) ] ) + | None, [] -> + ( Exp.ident + { loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsx") }, + [] ) + | Some _, key :: _ -> + ( Exp.ident + { + loc = Location.none; + txt = Ldot (Lident "ReactDOM", "jsxsKeyed"); + }, + [ key; (nolabel, unitExpr ~loc:Location.none) ] ) + | Some _, [] -> + ( Exp.ident + { loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsxs") }, + [] ) + in + Exp.apply ~attrs jsxExpr + ([ (nolabel, componentNameExpr); (nolabel, props) ] @ keyAndUnit) | _ -> - let children, nonChildrenProps = - extractChildren ~loc:jsxExprLoc callArguments - in - let childrenExpr = transformChildrenIfList ~mapper children in - let createElementCall = - match children with - (* [@JSX] div(~children=[a]), coming from
a
*) - | { - pexp_desc = - ( Pexp_construct ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple _}) - | Pexp_construct ({txt = Lident "[]"}, None) ); - } -> - "createDOMElementVariadic" - (* [@JSX] div(~children= value), coming from
...(value)
*) - | {pexp_loc} -> - React_jsx_common.raiseError ~loc:pexp_loc - "A spread as a DOM element's children don't make sense written \ - together. You can simply remove the spread." - in - let args = - match nonChildrenProps with - | [_justTheUnitArgumentAtEnd] -> - [ - (* "div" *) - (nolabel, componentNameExpr); - (* [|moreCreateElementCallsHere|] *) - (nolabel, childrenExpr); - ] - | nonEmptyProps -> - let propsRecord = - recordFromProps ~loc:Location.none ~removeKey:false nonEmptyProps - in - [ - (* "div" *) - (nolabel, componentNameExpr); - (* ReactDOM.domProps(~className=blabla, ~foo=bar, ()) *) - (labelled "props", propsRecord); - (* [|moreCreateElementCallsHere|] *) - (nolabel, childrenExpr); - ] - in - Exp.apply ~loc:jsxExprLoc ~attrs - (* ReactDOM.createElement *) - (Exp.ident - { - loc = Location.none; - txt = Ldot (Lident "ReactDOM", createElementCall); - }) - args + let children, nonChildrenProps = + extractChildren ~loc:jsxExprLoc callArguments + in + let childrenExpr = transformChildrenIfList ~mapper children in + let createElementCall = + match children with + (* [@JSX] div(~children=[a]), coming from
a
*) + | { + pexp_desc = + ( Pexp_construct + ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple _ }) + | Pexp_construct ({ txt = Lident "[]" }, None) ); + } -> + "createDOMElementVariadic" + (* [@JSX] div(~children= value), coming from
...(value)
*) + | { pexp_loc } -> + React_jsx_common.raiseError ~loc:pexp_loc + "A spread as a DOM element's children don't make sense written \ + together. You can simply remove the spread." + in + let args = + match nonChildrenProps with + | [ _justTheUnitArgumentAtEnd ] -> + [ + (* "div" *) + (nolabel, componentNameExpr); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr); + ] + | nonEmptyProps -> + let propsRecord = + recordFromProps ~loc:Location.none ~removeKey:false nonEmptyProps + in + [ + (* "div" *) + (nolabel, componentNameExpr); + (* ReactDOM.domProps(~className=blabla, ~foo=bar, ()) *) + (labelled "props", propsRecord); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr); + ] + in + Exp.apply ~loc:jsxExprLoc ~attrs + (* ReactDOM.createElement *) + (Exp.ident + { + loc = Location.none; + txt = Ldot (Lident "ReactDOM", createElementCall); + }) + args let rec recursivelyTransformNamedArgsForMake mapper expr args newtypes coreType = @@ -285529,106 +285782,107 @@ let rec recursivelyTransformNamedArgsForMake mapper expr args newtypes coreType match expr.pexp_desc with (* TODO: make this show up with a loc. *) | Pexp_fun (Labelled "key", _, _, _) | Pexp_fun (Optional "key", _, _, _) -> - React_jsx_common.raiseError ~loc:expr.pexp_loc - "Key cannot be accessed inside of a component. Don't worry - you can \ - always key a component from its parent!" + React_jsx_common.raiseError ~loc:expr.pexp_loc + "Key cannot be accessed inside of a component. Don't worry - you can \ + always key a component from its parent!" | Pexp_fun (Labelled "ref", _, _, _) | Pexp_fun (Optional "ref", _, _, _) -> - React_jsx_common.raiseError ~loc:expr.pexp_loc - "Ref cannot be passed as a normal prop. Please use `forwardRef` API \ - instead." + React_jsx_common.raiseError ~loc:expr.pexp_loc + "Ref cannot be passed as a normal prop. Please use `forwardRef` API \ + instead." | Pexp_fun (arg, default, pattern, expression) when isOptional arg || isLabelled arg -> - let () = - match (isOptional arg, pattern, default) with - | true, {ppat_desc = Ppat_constraint (_, {ptyp_desc})}, None -> ( - match ptyp_desc with - | Ptyp_constr ({txt = Lident "option"}, [_]) -> () - | _ -> - let currentType = + let () = + match (isOptional arg, pattern, default) with + | true, { ppat_desc = Ppat_constraint (_, { ptyp_desc }) }, None -> ( match ptyp_desc with - | Ptyp_constr ({txt}, []) -> - String.concat "." (Longident.flatten txt) - | Ptyp_constr ({txt}, _innerTypeArgs) -> - String.concat "." (Longident.flatten txt) ^ "(...)" - | _ -> "..." - in - Location.prerr_warning pattern.ppat_loc - (Preprocessor - (Printf.sprintf - "React: optional argument annotations must have explicit \ - `option`. Did you mean `option(%s)=?`?" - currentType))) - | _ -> () - in - let alias = - match pattern with - | {ppat_desc = Ppat_alias (_, {txt}) | Ppat_var {txt}} -> txt - | {ppat_desc = Ppat_any} -> "_" - | _ -> getLabel arg - in - let type_ = - match pattern with - | {ppat_desc = Ppat_constraint (_, type_)} -> Some type_ - | _ -> None - in + | Ptyp_constr ({ txt = Lident "option" }, [ _ ]) -> () + | _ -> + let currentType = + match ptyp_desc with + | Ptyp_constr ({ txt }, []) -> + String.concat "." (Longident.flatten txt) + | Ptyp_constr ({ txt }, _innerTypeArgs) -> + String.concat "." (Longident.flatten txt) ^ "(...)" + | _ -> "..." + in + Location.prerr_warning pattern.ppat_loc + (Preprocessor + (Printf.sprintf + "React: optional argument annotations must have \ + explicit `option`. Did you mean `option(%s)=?`?" + currentType))) + | _ -> () + in + let alias = + match pattern with + | { ppat_desc = Ppat_alias (_, { txt }) | Ppat_var { txt } } -> txt + | { ppat_desc = Ppat_any } -> "_" + | _ -> getLabel arg + in + let type_ = + match pattern with + | { ppat_desc = Ppat_constraint (_, type_) } -> Some type_ + | _ -> None + in - recursivelyTransformNamedArgsForMake mapper expression - ((arg, default, pattern, alias, pattern.ppat_loc, type_) :: args) - newtypes coreType + recursivelyTransformNamedArgsForMake mapper expression + ((arg, default, pattern, alias, pattern.ppat_loc, type_) :: args) + newtypes coreType | Pexp_fun ( Nolabel, _, - {ppat_desc = Ppat_construct ({txt = Lident "()"}, _) | Ppat_any}, + { ppat_desc = Ppat_construct ({ txt = Lident "()" }, _) | Ppat_any }, _expression ) -> - (args, newtypes, coreType) + (args, newtypes, coreType) | Pexp_fun ( Nolabel, _, ({ ppat_desc = - Ppat_var {txt} | Ppat_constraint ({ppat_desc = Ppat_var {txt}}, _); + ( Ppat_var { txt } + | Ppat_constraint ({ ppat_desc = Ppat_var { txt } }, _) ); } as pattern), _expression ) -> - if txt = "ref" then - let type_ = - match pattern with - | {ppat_desc = Ppat_constraint (_, type_)} -> Some type_ - | _ -> None - in - (* The ref arguement of forwardRef should be optional *) - ( (Optional "ref", None, pattern, txt, pattern.ppat_loc, type_) :: args, - newtypes, - coreType ) - else (args, newtypes, coreType) + if txt = "ref" then + let type_ = + match pattern with + | { ppat_desc = Ppat_constraint (_, type_) } -> Some type_ + | _ -> None + in + (* The ref arguement of forwardRef should be optional *) + ( (Optional "ref", None, pattern, txt, pattern.ppat_loc, type_) :: args, + newtypes, + coreType ) + else (args, newtypes, coreType) | Pexp_fun (Nolabel, _, pattern, _expression) -> - Location.raise_errorf ~loc:pattern.ppat_loc - "React: react.component refs only support plain arguments and type \ - annotations." + Location.raise_errorf ~loc:pattern.ppat_loc + "React: react.component refs only support plain arguments and type \ + annotations." | Pexp_newtype (label, expression) -> - recursivelyTransformNamedArgsForMake mapper expression args - (label :: newtypes) coreType + recursivelyTransformNamedArgsForMake mapper expression args + (label :: newtypes) coreType | Pexp_constraint (expression, coreType) -> - recursivelyTransformNamedArgsForMake mapper expression args newtypes - (Some coreType) + recursivelyTransformNamedArgsForMake mapper expression args newtypes + (Some coreType) | _ -> (args, newtypes, coreType) let newtypeToVar newtype type_ = let var_desc = Ptyp_var ("type-" ^ newtype) in let typ (mapper : Ast_mapper.mapper) typ = match typ.ptyp_desc with - | Ptyp_constr ({txt = Lident name}, _) when name = newtype -> - {typ with ptyp_desc = var_desc} + | Ptyp_constr ({ txt = Lident name }, _) when name = newtype -> + { typ with ptyp_desc = var_desc } | _ -> Ast_mapper.default_mapper.typ mapper typ in - let mapper = {Ast_mapper.default_mapper with typ} in + let mapper = { Ast_mapper.default_mapper with typ } in mapper.typ mapper type_ let argToType ~newtypes ~(typeConstraints : core_type option) types (name, default, _noLabelName, _alias, loc, type_) = let rec getType name coreType = match coreType with - | {ptyp_desc = Ptyp_arrow (arg, c1, c2)} -> - if name = arg then Some c1 else getType name c2 + | { ptyp_desc = Ptyp_arrow (arg, c1, c2) } -> + if name = arg then Some c1 else getType name c2 | _ -> None in let typeConst = Option.bind typeConstraints (getType name) in @@ -285642,17 +285896,17 @@ let argToType ~newtypes ~(typeConstraints : core_type option) types in match (type_, name, default) with | Some type_, name, _ when isOptional name -> - (true, getLabel name, [], {type_ with ptyp_attributes = optionalAttrs}) - :: types + (true, getLabel name, [], { type_ with ptyp_attributes = optionalAttrs }) + :: types | Some type_, name, _ -> (false, getLabel name, [], type_) :: types | None, name, _ when isOptional name -> - ( true, - getLabel name, - [], - Typ.var ~loc ~attrs:optionalAttrs (safeTypeFromValue name) ) - :: types + ( true, + getLabel name, + [], + Typ.var ~loc ~attrs:optionalAttrs (safeTypeFromValue name) ) + :: types | None, name, _ when isLabelled name -> - (false, getLabel name, [], Typ.var ~loc (safeTypeFromValue name)) :: types + (false, getLabel name, [], Typ.var ~loc (safeTypeFromValue name)) :: types | _ -> types let argWithDefaultValue (name, default, _, _, _, _) = @@ -285667,14 +285921,14 @@ let argToConcreteType types (name, _loc, type_) = | _ -> types let check_string_int_attribute_iter = - let attribute _ ({txt; loc}, _) = + let attribute _ ({ txt; loc }, _) = if txt = "string" || txt = "int" then React_jsx_common.raiseError ~loc "@string and @int attributes not supported. See \ https://github.com/rescript-lang/rescript-compiler/issues/5724" in - {Ast_iterator.default_iterator with attribute} + { Ast_iterator.default_iterator with attribute } let transformStructureItem ~config mapper item = match item with @@ -285682,590 +285936,625 @@ let transformStructureItem ~config mapper item = | { pstr_loc; pstr_desc = - Pstr_primitive ({pval_attributes; pval_type} as value_description); + Pstr_primitive ({ pval_attributes; pval_type } as value_description); } as pstr -> ( - match List.filter React_jsx_common.hasAttr pval_attributes with - | [] -> [item] - | [_] -> - (* If there is another @react.component, throw error *) - if config.React_jsx_common.hasReactComponent then - React_jsx_common.raiseErrorMultipleReactComponent ~loc:pstr_loc - else ( - config.hasReactComponent <- true; - check_string_int_attribute_iter.structure_item - check_string_int_attribute_iter item; - let coreTypeOfAttr = React_jsx_common.coreTypeOfAttrs pval_attributes in - let typVarsOfCoreType = - coreTypeOfAttr - |> Option.map React_jsx_common.typVarsOfCoreType - |> Option.value ~default:[] - in - let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = - match ptyp_desc with - | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) - when isLabelled name || isOptional name -> - getPropTypes ((name, ptyp_loc, type_) :: types) rest - | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest - | Ptyp_arrow (name, type_, returnValue) - when isLabelled name || isOptional name -> - (returnValue, (name, returnValue.ptyp_loc, type_) :: types) - | _ -> (fullType, types) - in - let innerType, propTypes = getPropTypes [] pval_type in - let namedTypeList = List.fold_left argToConcreteType [] propTypes in - let retPropsType = - Typ.constr ~loc:pstr_loc - (Location.mkloc (Lident "props") pstr_loc) - (match coreTypeOfAttr with - | None -> makePropsTypeParams namedTypeList - | Some _ -> typVarsOfCoreType) - in - (* type props<'x, 'y> = { x: 'x, y?: 'y, ... } *) - let propsRecordType = - makePropsRecordType ~coreTypeOfAttr ~typVarsOfCoreType "props" - pstr_loc namedTypeList - in - (* can't be an arrow because it will defensively uncurry *) - let newExternalType = - Ptyp_constr - ( {loc = pstr_loc; txt = Ldot (Lident "React", "componentLike")}, - [retPropsType; innerType] ) - in - let newStructure = - { - pstr with - pstr_desc = - Pstr_primitive - { - value_description with - pval_type = {pval_type with ptyp_desc = newExternalType}; - pval_attributes = List.filter otherAttrsPure pval_attributes; - }; - } - in - [propsRecordType; newStructure]) - | _ -> - React_jsx_common.raiseError ~loc:pstr_loc - "Only one react.component call can exist on a component at one time") + match List.filter React_jsx_common.hasAttr pval_attributes with + | [] -> [ item ] + | [ _ ] -> + (* If there is another @react.component, throw error *) + if config.React_jsx_common.hasReactComponent then + React_jsx_common.raiseErrorMultipleReactComponent ~loc:pstr_loc + else ( + config.hasReactComponent <- true; + check_string_int_attribute_iter.structure_item + check_string_int_attribute_iter item; + let coreTypeOfAttr = + React_jsx_common.coreTypeOfAttrs pval_attributes + in + let typVarsOfCoreType = + coreTypeOfAttr + |> Option.map React_jsx_common.typVarsOfCoreType + |> Option.value ~default:[] + in + let rec getPropTypes types ({ ptyp_loc; ptyp_desc } as fullType) = + match ptyp_desc with + | Ptyp_arrow (name, type_, ({ ptyp_desc = Ptyp_arrow _ } as rest)) + when isLabelled name || isOptional name -> + getPropTypes ((name, ptyp_loc, type_) :: types) rest + | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest + | Ptyp_arrow (name, type_, returnValue) + when isLabelled name || isOptional name -> + (returnValue, (name, returnValue.ptyp_loc, type_) :: types) + | _ -> (fullType, types) + in + let innerType, propTypes = getPropTypes [] pval_type in + let namedTypeList = List.fold_left argToConcreteType [] propTypes in + let retPropsType = + Typ.constr ~loc:pstr_loc + (Location.mkloc (Lident "props") pstr_loc) + (match coreTypeOfAttr with + | None -> makePropsTypeParams namedTypeList + | Some _ -> typVarsOfCoreType) + in + (* type props<'x, 'y> = { x: 'x, y?: 'y, ... } *) + let propsRecordType = + makePropsRecordType ~coreTypeOfAttr ~typVarsOfCoreType "props" + pstr_loc namedTypeList + in + (* can't be an arrow because it will defensively uncurry *) + let newExternalType = + Ptyp_constr + ( { + loc = pstr_loc; + txt = Ldot (Lident "React", "componentLike"); + }, + [ retPropsType; innerType ] ) + in + let newStructure = + { + pstr with + pstr_desc = + Pstr_primitive + { + value_description with + pval_type = { pval_type with ptyp_desc = newExternalType }; + pval_attributes = + List.filter otherAttrsPure pval_attributes; + }; + } + in + [ propsRecordType; newStructure ]) + | _ -> + React_jsx_common.raiseError ~loc:pstr_loc + "Only one react.component call can exist on a component at one time" + ) (* let component = ... *) - | {pstr_loc; pstr_desc = Pstr_value (recFlag, valueBindings)} -> ( - let fileName = filenameFromLoc pstr_loc in - let emptyLoc = Location.in_file fileName in - let mapBinding binding = - if React_jsx_common.hasAttrOnBinding binding then - if config.hasReactComponent then - React_jsx_common.raiseErrorMultipleReactComponent ~loc:pstr_loc - else ( - config.hasReactComponent <- true; - let coreTypeOfAttr = - React_jsx_common.coreTypeOfAttrs binding.pvb_attributes - in - let typVarsOfCoreType = - coreTypeOfAttr - |> Option.map React_jsx_common.typVarsOfCoreType - |> Option.value ~default:[] - in - let bindingLoc = binding.pvb_loc in - let bindingPatLoc = binding.pvb_pat.ppat_loc in - let binding = - { - binding with - pvb_pat = {binding.pvb_pat with ppat_loc = emptyLoc}; - pvb_loc = emptyLoc; - } - in - let fnName = getFnName binding.pvb_pat in - let internalFnName = fnName ^ "$Internal" in - let fullModuleName = - makeModuleName fileName config.nestedModules fnName - in - let modifiedBindingOld binding = - let expression = binding.pvb_expr in - (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) - let rec spelunkForFunExpression expression = - match expression with - (* let make = (~prop) => ... *) - | {pexp_desc = Pexp_fun _} | {pexp_desc = Pexp_newtype _} -> - expression - (* let make = {let foo = bar in (~prop) => ...} *) - | {pexp_desc = Pexp_let (_recursive, _vbs, returnExpression)} -> - (* here's where we spelunk! *) - spelunkForFunExpression returnExpression - (* let make = React.forwardRef((~prop) => ...) *) - | { - pexp_desc = - Pexp_apply - (_wrapperExpression, [(Nolabel, innerFunctionExpression)]); - } -> - spelunkForFunExpression innerFunctionExpression - | { - pexp_desc = - Pexp_sequence (_wrapperExpression, innerFunctionExpression); - } -> - spelunkForFunExpression innerFunctionExpression - | {pexp_desc = Pexp_constraint (innerFunctionExpression, _typ)} -> - spelunkForFunExpression innerFunctionExpression - | {pexp_loc} -> - React_jsx_common.raiseError ~loc:pexp_loc - "react.component calls can only be on function definitions \ - or component wrappers (forwardRef, memo)." + | { pstr_loc; pstr_desc = Pstr_value (recFlag, valueBindings) } -> ( + let fileName = filenameFromLoc pstr_loc in + let emptyLoc = Location.in_file fileName in + let mapBinding binding = + if React_jsx_common.hasAttrOnBinding binding then + if config.hasReactComponent then + React_jsx_common.raiseErrorMultipleReactComponent ~loc:pstr_loc + else ( + config.hasReactComponent <- true; + let coreTypeOfAttr = + React_jsx_common.coreTypeOfAttrs binding.pvb_attributes in - spelunkForFunExpression expression - in - let modifiedBinding binding = - let hasApplication = ref false in - let wrapExpressionWithBinding expressionFn expression = - Vb.mk ~loc:bindingLoc - ~attrs:(List.filter otherAttrsPure binding.pvb_attributes) - (Pat.var ~loc:bindingPatLoc {loc = bindingPatLoc; txt = fnName}) - (expressionFn expression) + let typVarsOfCoreType = + coreTypeOfAttr + |> Option.map React_jsx_common.typVarsOfCoreType + |> Option.value ~default:[] in - let expression = binding.pvb_expr in - (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) - let rec spelunkForFunExpression expression = - match expression with - (* let make = (~prop) => ... with no final unit *) - | { - pexp_desc = - Pexp_fun - ( ((Labelled _ | Optional _) as label), - default, - pattern, - ({pexp_desc = Pexp_fun _} as internalExpression) ); - } -> - let wrap, hasForwardRef, exp = - spelunkForFunExpression internalExpression - in - ( wrap, - hasForwardRef, - { - expression with - pexp_desc = Pexp_fun (label, default, pattern, exp); - } ) - (* let make = (()) => ... *) - (* let make = (_) => ... *) - | { - pexp_desc = - Pexp_fun - ( Nolabel, - _default, - { - ppat_desc = - Ppat_construct ({txt = Lident "()"}, _) | Ppat_any; - }, - _internalExpression ); - } -> - ((fun a -> a), false, expression) - (* let make = (~prop) => ... *) - | { - pexp_desc = - Pexp_fun - ( (Labelled _ | Optional _), - _default, - _pattern, - _internalExpression ); - } -> - ((fun a -> a), false, expression) - (* let make = (prop) => ... *) - | { - pexp_desc = - Pexp_fun (_nolabel, _default, pattern, _internalExpression); - } -> - if !hasApplication then ((fun a -> a), false, expression) - else - Location.raise_errorf ~loc:pattern.ppat_loc - "React: props need to be labelled arguments.\n\ - \ If you are working with refs be sure to wrap with \ - React.forwardRef.\n\ - \ If your component doesn't have any props use () or _ \ - instead of a name." - (* let make = {let foo = bar in (~prop) => ...} *) - | {pexp_desc = Pexp_let (recursive, vbs, internalExpression)} -> - (* here's where we spelunk! *) - let wrap, hasForwardRef, exp = - spelunkForFunExpression internalExpression - in - ( wrap, - hasForwardRef, - {expression with pexp_desc = Pexp_let (recursive, vbs, exp)} - ) - (* let make = React.forwardRef((~prop) => ...) *) - | { - pexp_desc = - Pexp_apply (wrapperExpression, [(Nolabel, internalExpression)]); - } -> - let () = hasApplication := true in - let _, _, exp = spelunkForFunExpression internalExpression in - let hasForwardRef = isForwardRef wrapperExpression in - ( (fun exp -> Exp.apply wrapperExpression [(nolabel, exp)]), - hasForwardRef, - exp ) - | { - pexp_desc = Pexp_sequence (wrapperExpression, internalExpression); - } -> - let wrap, hasForwardRef, exp = - spelunkForFunExpression internalExpression - in - ( wrap, - hasForwardRef, - { - expression with - pexp_desc = Pexp_sequence (wrapperExpression, exp); - } ) - | e -> ((fun a -> a), false, e) + let bindingLoc = binding.pvb_loc in + let bindingPatLoc = binding.pvb_pat.ppat_loc in + let binding = + { + binding with + pvb_pat = { binding.pvb_pat with ppat_loc = emptyLoc }; + pvb_loc = emptyLoc; + } in - let wrapExpression, hasForwardRef, expression = + let fnName = getFnName binding.pvb_pat in + let internalFnName = fnName ^ "$Internal" in + let fullModuleName = + makeModuleName fileName config.nestedModules fnName + in + let modifiedBindingOld binding = + let expression = binding.pvb_expr in + (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) + let rec spelunkForFunExpression expression = + match expression with + (* let make = (~prop) => ... *) + | { pexp_desc = Pexp_fun _ } | { pexp_desc = Pexp_newtype _ } -> + expression + (* let make = {let foo = bar in (~prop) => ...} *) + | { pexp_desc = Pexp_let (_recursive, _vbs, returnExpression) } + -> + (* here's where we spelunk! *) + spelunkForFunExpression returnExpression + (* let make = React.forwardRef((~prop) => ...) *) + | { + pexp_desc = + Pexp_apply + (_wrapperExpression, [ (Nolabel, innerFunctionExpression) ]); + } -> + spelunkForFunExpression innerFunctionExpression + | { + pexp_desc = + Pexp_sequence (_wrapperExpression, innerFunctionExpression); + } -> + spelunkForFunExpression innerFunctionExpression + | { + pexp_desc = Pexp_constraint (innerFunctionExpression, _typ); + } -> + spelunkForFunExpression innerFunctionExpression + | { pexp_loc } -> + React_jsx_common.raiseError ~loc:pexp_loc + "react.component calls can only be on function \ + definitions or component wrappers (forwardRef, memo)." + in spelunkForFunExpression expression in - (wrapExpressionWithBinding wrapExpression, hasForwardRef, expression) - in - let bindingWrapper, hasForwardRef, expression = - modifiedBinding binding - in - (* do stuff here! *) - let namedArgList, newtypes, typeConstraints = - recursivelyTransformNamedArgsForMake mapper - (modifiedBindingOld binding) - [] [] None - in - let namedTypeList = - List.fold_left - (argToType ~newtypes ~typeConstraints) - [] namedArgList - in - let namedArgWithDefaultValueList = - List.filter_map argWithDefaultValue namedArgList - in - let vbMatch (label, default) = - Vb.mk - (Pat.var (Location.mknoloc label)) - (Exp.match_ - (Exp.ident {txt = Lident label; loc = Location.none}) - [ - Exp.case - (Pat.construct - (Location.mknoloc @@ Lident "Some") - (Some (Pat.var (Location.mknoloc label)))) - (Exp.ident (Location.mknoloc @@ Lident label)); - Exp.case - (Pat.construct (Location.mknoloc @@ Lident "None") None) - default; - ]) - in - let vbMatchList = List.map vbMatch namedArgWithDefaultValueList in - (* type props = { ... } *) - let propsRecordType = - makePropsRecordType ~coreTypeOfAttr ~typVarsOfCoreType "props" - pstr_loc namedTypeList - in - let innerExpression = - Exp.apply - (Exp.ident (Location.mknoloc @@ Lident fnName)) - ([(Nolabel, Exp.ident (Location.mknoloc @@ Lident "props"))] - @ - match hasForwardRef with - | true -> - [(Nolabel, Exp.ident (Location.mknoloc @@ Lident "ref"))] - | false -> []) - in - let makePropsPattern = function - | [] -> Pat.var @@ Location.mknoloc "props" - | _ -> - Pat.constraint_ - (Pat.var @@ Location.mknoloc "props") - (Typ.constr (Location.mknoloc @@ Lident "props") [Typ.any ()]) - in - let fullExpression = - (* React component name should start with uppercase letter *) - (* let make = { let \"App" = props => make(props); \"App" } *) - (* let make = React.forwardRef({ - let \"App" = (props, ref) => make({...props, ref: @optional (Js.Nullabel.toOption(ref))}) - })*) - Exp.fun_ nolabel None - (match coreTypeOfAttr with - | None -> makePropsPattern namedTypeList - | Some _ -> makePropsPattern typVarsOfCoreType) - (if hasForwardRef then - Exp.fun_ nolabel None - (Pat.var @@ Location.mknoloc "ref") - innerExpression - else innerExpression) - in - let fullExpression = - match fullModuleName with - | "" -> fullExpression - | txt -> - Exp.let_ Nonrecursive - [ - Vb.mk ~loc:emptyLoc - (Pat.var ~loc:emptyLoc {loc = emptyLoc; txt}) - fullExpression; - ] - (Exp.ident ~loc:pstr_loc {loc = emptyLoc; txt = Lident txt}) - in - let rec stripConstraintUnpack ~label pattern = - match pattern with - | {ppat_desc = Ppat_constraint (pattern, _)} -> - stripConstraintUnpack ~label pattern - | {ppat_desc = Ppat_unpack _; ppat_loc} -> - (* remove unpack e.g. model: module(T) *) - Pat.var ~loc:ppat_loc {txt = label; loc = ppat_loc} - | _ -> pattern - in - let rec returnedExpression patternsWithLabel patternsWithNolabel - ({pexp_desc} as expr) = - match pexp_desc with - | Pexp_newtype (_, expr) -> - returnedExpression patternsWithLabel patternsWithNolabel expr - | Pexp_constraint (expr, _) -> - returnedExpression patternsWithLabel patternsWithNolabel expr - | Pexp_fun - ( _arg_label, - _default, - { - ppat_desc = - Ppat_construct ({txt = Lident "()"}, _) | Ppat_any; - }, - expr ) -> - (patternsWithLabel, patternsWithNolabel, expr) - | Pexp_fun - (arg_label, _default, ({ppat_loc; ppat_desc} as pattern), expr) - -> ( - let patternWithoutConstraint = - stripConstraintUnpack ~label:(getLabel arg_label) pattern + let modifiedBinding binding = + let hasApplication = ref false in + let wrapExpressionWithBinding expressionFn expression = + Vb.mk ~loc:bindingLoc + ~attrs:(List.filter otherAttrsPure binding.pvb_attributes) + (Pat.var ~loc:bindingPatLoc + { loc = bindingPatLoc; txt = fnName }) + (expressionFn expression) in - if isLabelled arg_label || isOptional arg_label then - returnedExpression - (( {loc = ppat_loc; txt = Lident (getLabel arg_label)}, - { - patternWithoutConstraint with - ppat_attributes = - (if isOptional arg_label then optionalAttrs else []) - @ pattern.ppat_attributes; - } ) - :: patternsWithLabel) - patternsWithNolabel expr - else - (* Special case of nolabel arg "ref" in forwardRef fn *) - (* let make = React.forwardRef(ref => body) *) - match ppat_desc with - | Ppat_var {txt} - | Ppat_constraint ({ppat_desc = Ppat_var {txt}}, _) -> - returnedExpression patternsWithLabel - (( {loc = ppat_loc; txt = Lident txt}, + let expression = binding.pvb_expr in + (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) + let rec spelunkForFunExpression expression = + match expression with + (* let make = (~prop) => ... with no final unit *) + | { + pexp_desc = + Pexp_fun + ( ((Labelled _ | Optional _) as label), + default, + pattern, + ({ pexp_desc = Pexp_fun _ } as internalExpression) ); + } -> + let wrap, hasForwardRef, exp = + spelunkForFunExpression internalExpression + in + ( wrap, + hasForwardRef, + { + expression with + pexp_desc = Pexp_fun (label, default, pattern, exp); + } ) + (* let make = (()) => ... *) + (* let make = (_) => ... *) + | { + pexp_desc = + Pexp_fun + ( Nolabel, + _default, { - pattern with - ppat_attributes = - optionalAttrs @ pattern.ppat_attributes; - } ) - :: patternsWithNolabel) - expr - | _ -> - returnedExpression patternsWithLabel patternsWithNolabel expr) - | _ -> (patternsWithLabel, patternsWithNolabel, expr) + ppat_desc = + Ppat_construct ({ txt = Lident "()" }, _) | Ppat_any; + }, + _internalExpression ); + } -> + ((fun a -> a), false, expression) + (* let make = (~prop) => ... *) + | { + pexp_desc = + Pexp_fun + ( (Labelled _ | Optional _), + _default, + _pattern, + _internalExpression ); + } -> + ((fun a -> a), false, expression) + (* let make = (prop) => ... *) + | { + pexp_desc = + Pexp_fun (_nolabel, _default, pattern, _internalExpression); + } -> + if !hasApplication then ((fun a -> a), false, expression) + else + Location.raise_errorf ~loc:pattern.ppat_loc + "React: props need to be labelled arguments.\n\ + \ If you are working with refs be sure to wrap with \ + React.forwardRef.\n\ + \ If your component doesn't have any props use () or \ + _ instead of a name." + (* let make = {let foo = bar in (~prop) => ...} *) + | { pexp_desc = Pexp_let (recursive, vbs, internalExpression) } + -> + (* here's where we spelunk! *) + let wrap, hasForwardRef, exp = + spelunkForFunExpression internalExpression + in + ( wrap, + hasForwardRef, + { + expression with + pexp_desc = Pexp_let (recursive, vbs, exp); + } ) + (* let make = React.forwardRef((~prop) => ...) *) + | { + pexp_desc = + Pexp_apply + (wrapperExpression, [ (Nolabel, internalExpression) ]); + } -> + let () = hasApplication := true in + let _, _, exp = + spelunkForFunExpression internalExpression + in + let hasForwardRef = isForwardRef wrapperExpression in + ( (fun exp -> Exp.apply wrapperExpression [ (nolabel, exp) ]), + hasForwardRef, + exp ) + | { + pexp_desc = + Pexp_sequence (wrapperExpression, internalExpression); + } -> + let wrap, hasForwardRef, exp = + spelunkForFunExpression internalExpression + in + ( wrap, + hasForwardRef, + { + expression with + pexp_desc = Pexp_sequence (wrapperExpression, exp); + } ) + | e -> ((fun a -> a), false, e) + in + let wrapExpression, hasForwardRef, expression = + spelunkForFunExpression expression + in + ( wrapExpressionWithBinding wrapExpression, + hasForwardRef, + expression ) + in + let bindingWrapper, hasForwardRef, expression = + modifiedBinding binding + in + (* do stuff here! *) + let namedArgList, newtypes, typeConstraints = + recursivelyTransformNamedArgsForMake mapper + (modifiedBindingOld binding) + [] [] None + in + let namedTypeList = + List.fold_left + (argToType ~newtypes ~typeConstraints) + [] namedArgList + in + let namedArgWithDefaultValueList = + List.filter_map argWithDefaultValue namedArgList + in + let vbMatch (label, default) = + Vb.mk + (Pat.var (Location.mknoloc label)) + (Exp.match_ + (Exp.ident { txt = Lident label; loc = Location.none }) + [ + Exp.case + (Pat.construct + (Location.mknoloc @@ Lident "Some") + (Some (Pat.var (Location.mknoloc label)))) + (Exp.ident (Location.mknoloc @@ Lident label)); + Exp.case + (Pat.construct (Location.mknoloc @@ Lident "None") None) + default; + ]) + in + let vbMatchList = List.map vbMatch namedArgWithDefaultValueList in + (* type props = { ... } *) + let propsRecordType = + makePropsRecordType ~coreTypeOfAttr ~typVarsOfCoreType "props" + pstr_loc namedTypeList + in + let innerExpression = + Exp.apply + (Exp.ident (Location.mknoloc @@ Lident fnName)) + ([ (Nolabel, Exp.ident (Location.mknoloc @@ Lident "props")) ] + @ + match hasForwardRef with + | true -> + [ (Nolabel, Exp.ident (Location.mknoloc @@ Lident "ref")) ] + | false -> []) + in + let makePropsPattern = function + | [] -> Pat.var @@ Location.mknoloc "props" + | _ -> + Pat.constraint_ + (Pat.var @@ Location.mknoloc "props") + (Typ.constr + (Location.mknoloc @@ Lident "props") + [ Typ.any () ]) + in + let fullExpression = + (* React component name should start with uppercase letter *) + (* let make = { let \"App" = props => make(props); \"App" } *) + (* let make = React.forwardRef({ + let \"App" = (props, ref) => make({...props, ref: @optional (Js.Nullabel.toOption(ref))}) + })*) + Exp.fun_ nolabel None + (match coreTypeOfAttr with + | None -> makePropsPattern namedTypeList + | Some _ -> makePropsPattern typVarsOfCoreType) + (if hasForwardRef then + Exp.fun_ nolabel None + (Pat.var @@ Location.mknoloc "ref") + innerExpression + else innerExpression) + in + let fullExpression = + match fullModuleName with + | "" -> fullExpression + | txt -> + Exp.let_ Nonrecursive + [ + Vb.mk ~loc:emptyLoc + (Pat.var ~loc:emptyLoc { loc = emptyLoc; txt }) + fullExpression; + ] + (Exp.ident ~loc:pstr_loc + { loc = emptyLoc; txt = Lident txt }) + in + let rec stripConstraintUnpack ~label pattern = + match pattern with + | { ppat_desc = Ppat_constraint (pattern, _) } -> + stripConstraintUnpack ~label pattern + | { ppat_desc = Ppat_unpack _; ppat_loc } -> + (* remove unpack e.g. model: module(T) *) + Pat.var ~loc:ppat_loc { txt = label; loc = ppat_loc } + | _ -> pattern + in + let rec returnedExpression patternsWithLabel patternsWithNolabel + ({ pexp_desc } as expr) = + match pexp_desc with + | Pexp_newtype (_, expr) -> + returnedExpression patternsWithLabel patternsWithNolabel expr + | Pexp_constraint (expr, _) -> + returnedExpression patternsWithLabel patternsWithNolabel expr + | Pexp_fun + ( _arg_label, + _default, + { + ppat_desc = + Ppat_construct ({ txt = Lident "()" }, _) | Ppat_any; + }, + expr ) -> + (patternsWithLabel, patternsWithNolabel, expr) + | Pexp_fun + ( arg_label, + _default, + ({ ppat_loc; ppat_desc } as pattern), + expr ) -> ( + let patternWithoutConstraint = + stripConstraintUnpack ~label:(getLabel arg_label) pattern + in + if isLabelled arg_label || isOptional arg_label then + returnedExpression + (( { loc = ppat_loc; txt = Lident (getLabel arg_label) }, + { + patternWithoutConstraint with + ppat_attributes = + (if isOptional arg_label then optionalAttrs + else []) + @ pattern.ppat_attributes; + } ) + :: patternsWithLabel) + patternsWithNolabel expr + else + (* Special case of nolabel arg "ref" in forwardRef fn *) + (* let make = React.forwardRef(ref => body) *) + match ppat_desc with + | Ppat_var { txt } + | Ppat_constraint ({ ppat_desc = Ppat_var { txt } }, _) -> + returnedExpression patternsWithLabel + (( { loc = ppat_loc; txt = Lident txt }, + { + pattern with + ppat_attributes = + optionalAttrs @ pattern.ppat_attributes; + } ) + :: patternsWithNolabel) + expr + | _ -> + returnedExpression patternsWithLabel patternsWithNolabel + expr) + | _ -> (patternsWithLabel, patternsWithNolabel, expr) + in + let patternsWithLabel, patternsWithNolabel, expression = + returnedExpression [] [] expression + in + (* add pattern matching for optional prop value *) + let expression = + if List.length vbMatchList = 0 then expression + else Exp.let_ Nonrecursive vbMatchList expression + in + (* (ref) => expr *) + let expression = + List.fold_left + (fun expr (_, pattern) -> Exp.fun_ Nolabel None pattern expr) + expression patternsWithNolabel + in + let recordPattern = + match patternsWithLabel with + | [] -> Pat.any () + | _ -> Pat.record (List.rev patternsWithLabel) Open + in + let expression = + Exp.fun_ Nolabel None + (Pat.constraint_ recordPattern + (Typ.constr ~loc:emptyLoc + { txt = Lident "props"; loc = emptyLoc } + (match coreTypeOfAttr with + | None -> + makePropsTypeParams ~stripExplicitOption:true + ~stripExplicitJsNullableOfRef:hasForwardRef + namedTypeList + | Some _ -> typVarsOfCoreType))) + expression + in + (* let make = ({id, name, ...}: props<'id, 'name, ...>) => { ... } *) + let bindings, newBinding = + match recFlag with + | Recursive -> + ( [ + bindingWrapper + (Exp.let_ ~loc:emptyLoc Recursive + [ + makeNewBinding binding expression internalFnName; + Vb.mk + (Pat.var { loc = emptyLoc; txt = fnName }) + fullExpression; + ] + (Exp.ident { loc = emptyLoc; txt = Lident fnName })); + ], + None ) + | Nonrecursive -> + ( [ + { + binding with + pvb_expr = expression; + pvb_pat = Pat.var { txt = fnName; loc = Location.none }; + }; + ], + Some (bindingWrapper fullExpression) ) + in + (Some propsRecordType, bindings, newBinding)) + else (None, [ binding ], None) + in + (* END of mapBinding fn *) + let structuresAndBinding = List.map mapBinding valueBindings in + let otherStructures (type_, binding, newBinding) + (types, bindings, newBindings) = + let types = + match type_ with Some type_ -> type_ :: types | None -> types + in + let newBindings = + match newBinding with + | Some newBinding -> newBinding :: newBindings + | None -> newBindings + in + (types, binding @ bindings, newBindings) + in + let types, bindings, newBindings = + List.fold_right otherStructures structuresAndBinding ([], [], []) + in + types + @ [ { pstr_loc; pstr_desc = Pstr_value (recFlag, bindings) } ] + @ + match newBindings with + | [] -> [] + | newBindings -> + [ + { + pstr_loc = emptyLoc; + pstr_desc = Pstr_value (recFlag, newBindings); + }; + ]) + | _ -> [ item ] + +let transformSignatureItem ~config _mapper item = + match item with + | { + psig_loc; + psig_desc = Psig_value ({ pval_attributes; pval_type } as psig_desc); + } as psig -> ( + match List.filter React_jsx_common.hasAttr pval_attributes with + | [] -> [ item ] + | [ _ ] -> + (* If there is another @react.component, throw error *) + if config.React_jsx_common.hasReactComponent then + React_jsx_common.raiseErrorMultipleReactComponent ~loc:psig_loc + else config.hasReactComponent <- true; + check_string_int_attribute_iter.signature_item + check_string_int_attribute_iter item; + let hasForwardRef = ref false in + let coreTypeOfAttr = + React_jsx_common.coreTypeOfAttrs pval_attributes in - let patternsWithLabel, patternsWithNolabel, expression = - returnedExpression [] [] expression + let typVarsOfCoreType = + coreTypeOfAttr + |> Option.map React_jsx_common.typVarsOfCoreType + |> Option.value ~default:[] in - (* add pattern matching for optional prop value *) - let expression = - if List.length vbMatchList = 0 then expression - else Exp.let_ Nonrecursive vbMatchList expression + let rec getPropTypes types ({ ptyp_loc; ptyp_desc } as fullType) = + match ptyp_desc with + | Ptyp_arrow (name, type_, ({ ptyp_desc = Ptyp_arrow _ } as rest)) + when isOptional name || isLabelled name -> + getPropTypes ((name, ptyp_loc, type_) :: types) rest + | Ptyp_arrow + ( Nolabel, + { ptyp_desc = Ptyp_constr ({ txt = Lident "unit" }, _) }, + rest ) -> + getPropTypes types rest + | Ptyp_arrow (Nolabel, _type, rest) -> + hasForwardRef := true; + getPropTypes types rest + | Ptyp_arrow (name, type_, returnValue) + when isOptional name || isLabelled name -> + (returnValue, (name, returnValue.ptyp_loc, type_) :: types) + | _ -> (fullType, types) in - (* (ref) => expr *) - let expression = - List.fold_left - (fun expr (_, pattern) -> Exp.fun_ Nolabel None pattern expr) - expression patternsWithNolabel + let innerType, propTypes = getPropTypes [] pval_type in + let namedTypeList = List.fold_left argToConcreteType [] propTypes in + let retPropsType = + Typ.constr + (Location.mkloc (Lident "props") psig_loc) + (match coreTypeOfAttr with + | None -> makePropsTypeParams namedTypeList + | Some _ -> typVarsOfCoreType) in - let recordPattern = - match patternsWithLabel with - | [] -> Pat.any () - | _ -> Pat.record (List.rev patternsWithLabel) Open + let propsRecordType = + makePropsRecordTypeSig ~coreTypeOfAttr ~typVarsOfCoreType "props" + psig_loc + ((* If there is Nolabel arg, regard the type as ref in forwardRef *) + (if !hasForwardRef then + [ (true, "ref", [], refType Location.none) ] + else []) + @ namedTypeList) in - let expression = - Exp.fun_ Nolabel None - (Pat.constraint_ recordPattern - (Typ.constr ~loc:emptyLoc - {txt = Lident "props"; loc = emptyLoc} - (match coreTypeOfAttr with - | None -> - makePropsTypeParams ~stripExplicitOption:true - ~stripExplicitJsNullableOfRef:hasForwardRef - namedTypeList - | Some _ -> typVarsOfCoreType))) - expression + (* can't be an arrow because it will defensively uncurry *) + let newExternalType = + Ptyp_constr + ( { loc = psig_loc; txt = Ldot (Lident "React", "componentLike") }, + [ retPropsType; innerType ] ) in - (* let make = ({id, name, ...}: props<'id, 'name, ...>) => { ... } *) - let bindings, newBinding = - match recFlag with - | Recursive -> - ( [ - bindingWrapper - (Exp.let_ ~loc:emptyLoc Recursive - [ - makeNewBinding binding expression internalFnName; - Vb.mk - (Pat.var {loc = emptyLoc; txt = fnName}) - fullExpression; - ] - (Exp.ident {loc = emptyLoc; txt = Lident fnName})); - ], - None ) - | Nonrecursive -> - ( [ + let newStructure = + { + psig with + psig_desc = + Psig_value { - binding with - pvb_expr = expression; - pvb_pat = Pat.var {txt = fnName; loc = Location.none}; + psig_desc with + pval_type = { pval_type with ptyp_desc = newExternalType }; + pval_attributes = List.filter otherAttrsPure pval_attributes; }; - ], - Some (bindingWrapper fullExpression) ) + } in - (Some propsRecordType, bindings, newBinding)) - else (None, [binding], None) - in - (* END of mapBinding fn *) - let structuresAndBinding = List.map mapBinding valueBindings in - let otherStructures (type_, binding, newBinding) - (types, bindings, newBindings) = - let types = - match type_ with - | Some type_ -> type_ :: types - | None -> types - in - let newBindings = - match newBinding with - | Some newBinding -> newBinding :: newBindings - | None -> newBindings - in - (types, binding @ bindings, newBindings) - in - let types, bindings, newBindings = - List.fold_right otherStructures structuresAndBinding ([], [], []) - in - types - @ [{pstr_loc; pstr_desc = Pstr_value (recFlag, bindings)}] - @ - match newBindings with - | [] -> [] - | newBindings -> - [{pstr_loc = emptyLoc; pstr_desc = Pstr_value (recFlag, newBindings)}]) - | _ -> [item] - -let transformSignatureItem ~config _mapper item = - match item with - | { - psig_loc; - psig_desc = Psig_value ({pval_attributes; pval_type} as psig_desc); - } as psig -> ( - match List.filter React_jsx_common.hasAttr pval_attributes with - | [] -> [item] - | [_] -> - (* If there is another @react.component, throw error *) - if config.React_jsx_common.hasReactComponent then - React_jsx_common.raiseErrorMultipleReactComponent ~loc:psig_loc - else config.hasReactComponent <- true; - check_string_int_attribute_iter.signature_item - check_string_int_attribute_iter item; - let hasForwardRef = ref false in - let coreTypeOfAttr = React_jsx_common.coreTypeOfAttrs pval_attributes in - let typVarsOfCoreType = - coreTypeOfAttr - |> Option.map React_jsx_common.typVarsOfCoreType - |> Option.value ~default:[] - in - let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = - match ptyp_desc with - | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) - when isOptional name || isLabelled name -> - getPropTypes ((name, ptyp_loc, type_) :: types) rest - | Ptyp_arrow - (Nolabel, {ptyp_desc = Ptyp_constr ({txt = Lident "unit"}, _)}, rest) - -> - getPropTypes types rest - | Ptyp_arrow (Nolabel, _type, rest) -> - hasForwardRef := true; - getPropTypes types rest - | Ptyp_arrow (name, type_, returnValue) - when isOptional name || isLabelled name -> - (returnValue, (name, returnValue.ptyp_loc, type_) :: types) - | _ -> (fullType, types) - in - let innerType, propTypes = getPropTypes [] pval_type in - let namedTypeList = List.fold_left argToConcreteType [] propTypes in - let retPropsType = - Typ.constr - (Location.mkloc (Lident "props") psig_loc) - (match coreTypeOfAttr with - | None -> makePropsTypeParams namedTypeList - | Some _ -> typVarsOfCoreType) - in - let propsRecordType = - makePropsRecordTypeSig ~coreTypeOfAttr ~typVarsOfCoreType "props" - psig_loc - ((* If there is Nolabel arg, regard the type as ref in forwardRef *) - (if !hasForwardRef then [(true, "ref", [], refType Location.none)] - else []) - @ namedTypeList) - in - (* can't be an arrow because it will defensively uncurry *) - let newExternalType = - Ptyp_constr - ( {loc = psig_loc; txt = Ldot (Lident "React", "componentLike")}, - [retPropsType; innerType] ) - in - let newStructure = - { - psig with - psig_desc = - Psig_value - { - psig_desc with - pval_type = {pval_type with ptyp_desc = newExternalType}; - pval_attributes = List.filter otherAttrsPure pval_attributes; - }; - } - in - [propsRecordType; newStructure] - | _ -> - React_jsx_common.raiseError ~loc:psig_loc - "Only one react.component call can exist on a component at one time") - | _ -> [item] + [ propsRecordType; newStructure ] + | _ -> + React_jsx_common.raiseError ~loc:psig_loc + "Only one react.component call can exist on a component at one time" + ) + | _ -> [ item ] let transformJsxCall ~config mapper callExpression callArguments jsxExprLoc attrs = match callExpression.pexp_desc with | Pexp_ident caller -> ( - match caller with - | {txt = Lident "createElement"; loc} -> - React_jsx_common.raiseError ~loc - "JSX: `createElement` should be preceeded by a module name." - (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *) - | {loc; txt = Ldot (modulePath, ("createElement" | "make"))} -> - transformUppercaseCall3 ~config modulePath mapper jsxExprLoc loc attrs - callArguments - (* div(~prop1=foo, ~prop2=bar, ~children=[bla], ()) *) - (* turn that into - ReactDOM.createElement(~props=ReactDOM.props(~props1=foo, ~props2=bar, ()), [|bla|]) *) - | {loc; txt = Lident id} -> - transformLowercaseCall3 ~config mapper jsxExprLoc loc attrs callArguments - id - | {txt = Ldot (_, anythingNotCreateElementOrMake); loc} -> - React_jsx_common.raiseError ~loc - "JSX: the JSX attribute should be attached to a \ - `YourModuleName.createElement` or `YourModuleName.make` call. We saw \ - `%s` instead" - anythingNotCreateElementOrMake - | {txt = Lapply _; loc} -> - (* don't think there's ever a case where this is reached *) - React_jsx_common.raiseError ~loc - "JSX: encountered a weird case while processing the code. Please \ - report this!") + match caller with + | { txt = Lident "createElement"; loc } -> + React_jsx_common.raiseError ~loc + "JSX: `createElement` should be preceeded by a module name." + (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *) + | { loc; txt = Ldot (modulePath, ("createElement" | "make")) } -> + transformUppercaseCall3 ~config modulePath mapper jsxExprLoc loc attrs + callArguments + (* div(~prop1=foo, ~prop2=bar, ~children=[bla], ()) *) + (* turn that into + ReactDOM.createElement(~props=ReactDOM.props(~props1=foo, ~props2=bar, ()), [|bla|]) *) + | { loc; txt = Lident id } -> + transformLowercaseCall3 ~config mapper jsxExprLoc loc attrs + callArguments id + | { txt = Ldot (_, anythingNotCreateElementOrMake); loc } -> + React_jsx_common.raiseError ~loc + "JSX: the JSX attribute should be attached to a \ + `YourModuleName.createElement` or `YourModuleName.make` call. We \ + saw `%s` instead" + anythingNotCreateElementOrMake + | { txt = Lapply _; loc } -> + (* don't think there's ever a case where this is reached *) + React_jsx_common.raiseError ~loc + "JSX: encountered a weird case while processing the code. Please \ + report this!") | _ -> - React_jsx_common.raiseError ~loc:callExpression.pexp_loc - "JSX: `createElement` should be preceeded by a simple, direct module \ - name." + React_jsx_common.raiseError ~loc:callExpression.pexp_loc + "JSX: `createElement` should be preceeded by a simple, direct module \ + name." let expr ~config mapper expression = match expression with @@ -286275,78 +286564,81 @@ let expr ~config mapper expression = pexp_attributes; pexp_loc; } -> ( - let jsxAttribute, nonJSXAttributes = - List.partition - (fun (attribute, _) -> attribute.txt = "JSX") - pexp_attributes - in - match (jsxAttribute, nonJSXAttributes) with - (* no JSX attribute *) - | [], _ -> default_mapper.expr mapper expression - | _, nonJSXAttributes -> - transformJsxCall ~config mapper callExpression callArguments pexp_loc - nonJSXAttributes) + let jsxAttribute, nonJSXAttributes = + List.partition + (fun (attribute, _) -> attribute.txt = "JSX") + pexp_attributes + in + match (jsxAttribute, nonJSXAttributes) with + (* no JSX attribute *) + | [], _ -> default_mapper.expr mapper expression + | _, nonJSXAttributes -> + transformJsxCall ~config mapper callExpression callArguments pexp_loc + nonJSXAttributes) (* is it a list with jsx attribute? Reason <>foo desugars to [@JSX][foo]*) | { pexp_desc = ( Pexp_construct - ({txt = Lident "::"; loc}, Some {pexp_desc = Pexp_tuple _}) - | Pexp_construct ({txt = Lident "[]"; loc}, None) ); + ({ txt = Lident "::"; loc }, Some { pexp_desc = Pexp_tuple _ }) + | Pexp_construct ({ txt = Lident "[]"; loc }, None) ); pexp_attributes; } as listItems -> ( - let jsxAttribute, nonJSXAttributes = - List.partition - (fun (attribute, _) -> attribute.txt = "JSX") - pexp_attributes - in - match (jsxAttribute, nonJSXAttributes) with - (* no JSX attribute *) - | [], _ -> default_mapper.expr mapper expression - | _, nonJSXAttributes -> - let loc = {loc with loc_ghost = true} in - let fragment = - match config.mode with - | "automatic" -> - Exp.ident ~loc {loc; txt = Ldot (Lident "React", "jsxFragment")} - | "classic" | _ -> - Exp.ident ~loc {loc; txt = Ldot (Lident "React", "fragment")} - in - let childrenExpr = transformChildrenIfList ~mapper listItems in - let recordOfChildren children = - Exp.record [(Location.mknoloc (Lident "children"), children)] None - in - let args = - [ - (nolabel, fragment); - (match config.mode with - | "automatic" -> ( - ( nolabel, - match childrenExpr with - | {pexp_desc = Pexp_array children} -> ( - match children with - | [] -> emptyRecord ~loc:Location.none - | [child] -> recordOfChildren child - | _ -> recordOfChildren childrenExpr) - | _ -> recordOfChildren childrenExpr )) - | "classic" | _ -> (nolabel, childrenExpr)); - ] - in - let countOfChildren = function - | {pexp_desc = Pexp_array children} -> List.length children - | _ -> 0 + let jsxAttribute, nonJSXAttributes = + List.partition + (fun (attribute, _) -> attribute.txt = "JSX") + pexp_attributes in - Exp.apply - ~loc (* throw away the [@JSX] attribute and keep the others, if any *) - ~attrs:nonJSXAttributes - (* ReactDOM.createElement *) - (match config.mode with - | "automatic" -> - if countOfChildren childrenExpr > 1 then - Exp.ident ~loc {loc; txt = Ldot (Lident "React", "jsxs")} - else Exp.ident ~loc {loc; txt = Ldot (Lident "React", "jsx")} - | "classic" | _ -> - Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOM", "createElement")}) - args) + match (jsxAttribute, nonJSXAttributes) with + (* no JSX attribute *) + | [], _ -> default_mapper.expr mapper expression + | _, nonJSXAttributes -> + let loc = { loc with loc_ghost = true } in + let fragment = + match config.mode with + | "automatic" -> + Exp.ident ~loc + { loc; txt = Ldot (Lident "React", "jsxFragment") } + | "classic" | _ -> + Exp.ident ~loc { loc; txt = Ldot (Lident "React", "fragment") } + in + let childrenExpr = transformChildrenIfList ~mapper listItems in + let recordOfChildren children = + Exp.record [ (Location.mknoloc (Lident "children"), children) ] None + in + let args = + [ + (nolabel, fragment); + (match config.mode with + | "automatic" -> ( + ( nolabel, + match childrenExpr with + | { pexp_desc = Pexp_array children } -> ( + match children with + | [] -> emptyRecord ~loc:Location.none + | [ child ] -> recordOfChildren child + | _ -> recordOfChildren childrenExpr) + | _ -> recordOfChildren childrenExpr )) + | "classic" | _ -> (nolabel, childrenExpr)); + ] + in + let countOfChildren = function + | { pexp_desc = Pexp_array children } -> List.length children + | _ -> 0 + in + Exp.apply + ~loc + (* throw away the [@JSX] attribute and keep the others, if any *) + ~attrs:nonJSXAttributes + (* ReactDOM.createElement *) + (match config.mode with + | "automatic" -> + if countOfChildren childrenExpr > 1 then + Exp.ident ~loc { loc; txt = Ldot (Lident "React", "jsxs") } + else Exp.ident ~loc { loc; txt = Ldot (Lident "React", "jsx") } + | "classic" | _ -> + Exp.ident ~loc + { loc; txt = Ldot (Lident "ReactDOM", "createElement") }) + args) (* Delegate to the default mapper, a deep identity traversal *) | e -> default_mapper.expr mapper e @@ -286408,10 +286700,10 @@ let getPayloadFields payload = | PStr ({ pstr_desc = - Pstr_eval ({pexp_desc = Pexp_record (recordFields, None)}, _); + Pstr_eval ({ pexp_desc = Pexp_record (recordFields, None) }, _); } :: _rest) -> - recordFields + recordFields | _ -> [] type configKey = Int | String @@ -286422,21 +286714,19 @@ let getJsxConfigByKey ~key ~type_ recordFields = (fun ((lid, expr) : Longident.t Location.loc * expression) -> match (type_, lid, expr) with | ( Int, - {txt = Lident k}, - {pexp_desc = Pexp_constant (Pconst_integer (value, None))} ) + { txt = Lident k }, + { pexp_desc = Pexp_constant (Pconst_integer (value, None)) } ) when k = key -> - Some value + Some value | ( String, - {txt = Lident k}, - {pexp_desc = Pexp_constant (Pconst_string (value, None))} ) + { txt = Lident k }, + { pexp_desc = Pexp_constant (Pconst_string (value, None)) } ) when k = key -> - Some value + Some value | _ -> None) recordFields in - match values with - | [] -> None - | [v] | v :: _ -> Some v + match values with [] -> None | [ v ] | v :: _ -> Some v let getInt ~key fields = match fields |> getJsxConfigByKey ~key ~type_:Int with @@ -286509,7 +286799,7 @@ let getMapper ~config = let item = default_mapper.signature_item mapper item in if config.version = 3 then transformSignatureItem3 mapper item else if config.version = 4 then transformSignatureItem4 mapper item - else [item]) + else [ item ]) items |> List.flatten in @@ -286528,7 +286818,7 @@ let getMapper ~config = let item = default_mapper.structure_item mapper item in if config.version = 3 then transformStructureItem3 mapper item else if config.version = 4 then transformStructureItem4 mapper item - else [item]) + else [ item ]) items |> List.flatten in @@ -286536,7 +286826,7 @@ let getMapper ~config = result in - {default_mapper with expr; module_binding; signature; structure} + { default_mapper with expr; module_binding; signature; structure } let rewrite_implementation ~jsxVersion ~jsxModule ~jsxMode (code : Parsetree.structure) : Parsetree.structure = @@ -294483,7 +294773,7 @@ module Super_code_frame = struct else match src.[current_char] [@doesNotRaise] with | '\n' when current_line = original_line + 2 -> - (current_char, current_line) + (current_char, current_line) | '\n' -> loop (current_line + 1) (current_char + 1) | _ -> loop current_line (current_char + 1) in @@ -294512,12 +294802,10 @@ module Super_code_frame = struct match l with | [] -> accum | head :: rest -> - let accum = - match f i head with - | None -> accum - | Some result -> result :: accum - in - loop f rest (i + 1) accum + let accum = + match f i head with None -> accum | Some result -> result :: accum + in + loop f rest (i + 1) accum in loop f l 0 [] |> List.rev @@ -294566,8 +294854,8 @@ module Super_code_frame = struct let setup = Color.setup type gutter = Number of int | Elided - type highlighted_string = {s: string; start: int; end_: int} - type line = {gutter: gutter; content: highlighted_string list} + type highlighted_string = { s : string; start : int; end_ : int } + type line = { gutter : gutter; content : highlighted_string list } (* Features: @@ -294629,47 +294917,49 @@ module Super_code_frame = struct |> List.map (fun (gutter, line) -> let new_content = if String.length line <= leading_space_to_cut then - [{s = ""; start = 0; end_ = 0}] + [ { s = ""; start = 0; end_ = 0 } ] else (String.sub [@doesNotRaise]) line leading_space_to_cut (String.length line - leading_space_to_cut) |> break_long_line line_width |> List.mapi (fun i line -> match gutter with - | Elided -> {s = line; start = 0; end_ = 0} + | Elided -> { s = line; start = 0; end_ = 0 } | Number line_number -> - let highlight_line_start_offset = - startPos.pos_cnum - startPos.pos_bol - in - let highlight_line_end_offset = - endPos.pos_cnum - endPos.pos_bol - in - let start = - if i = 0 && line_number = highlight_line_start_line - then - highlight_line_start_offset - leading_space_to_cut - else 0 - in - let end_ = - if line_number < highlight_line_start_line then 0 - else if - line_number = highlight_line_start_line - && line_number = highlight_line_end_line - then - highlight_line_end_offset - leading_space_to_cut - else if line_number = highlight_line_start_line then - String.length line - else if - line_number > highlight_line_start_line - && line_number < highlight_line_end_line - then String.length line - else if line_number = highlight_line_end_line then - highlight_line_end_offset - leading_space_to_cut - else 0 - in - {s = line; start; end_}) + let highlight_line_start_offset = + startPos.pos_cnum - startPos.pos_bol + in + let highlight_line_end_offset = + endPos.pos_cnum - endPos.pos_bol + in + let start = + if + i = 0 && line_number = highlight_line_start_line + then + highlight_line_start_offset + - leading_space_to_cut + else 0 + in + let end_ = + if line_number < highlight_line_start_line then 0 + else if + line_number = highlight_line_start_line + && line_number = highlight_line_end_line + then + highlight_line_end_offset - leading_space_to_cut + else if line_number = highlight_line_start_line + then String.length line + else if + line_number > highlight_line_start_line + && line_number < highlight_line_end_line + then String.length line + else if line_number = highlight_line_end_line then + highlight_line_end_offset - leading_space_to_cut + else 0 + in + { s = line; start; end_ }) in - {gutter; content = new_content}) + { gutter; content = new_content }) in let buf = Buffer.create 100 in let open Color in @@ -294705,39 +294995,39 @@ module Super_code_frame = struct add_ch NoColor ' ' in stripped_lines - |> List.iter (fun {gutter; content} -> + |> List.iter (fun { gutter; content } -> match gutter with | Elided -> - draw_gutter Dim "."; - add_ch Dim '.'; - add_ch Dim '.'; - add_ch Dim '.'; - add_ch NoColor '\n' + draw_gutter Dim "."; + add_ch Dim '.'; + add_ch Dim '.'; + add_ch Dim '.'; + add_ch NoColor '\n' | Number line_number -> - content - |> List.iteri (fun i line -> - let gutter_content = - if i = 0 then string_of_int line_number else "" - in - let gutter_color = - if - i = 0 - && line_number >= highlight_line_start_line - && line_number <= highlight_line_end_line - then if is_warning then Warn else Err - else NoColor - in - draw_gutter gutter_color gutter_content; - - line.s - |> String.iteri (fun ii ch -> - let c = - if ii >= line.start && ii < line.end_ then - if is_warning then Warn else Err - else NoColor - in - add_ch c ch); - add_ch NoColor '\n')); + content + |> List.iteri (fun i line -> + let gutter_content = + if i = 0 then string_of_int line_number else "" + in + let gutter_color = + if + i = 0 + && line_number >= highlight_line_start_line + && line_number <= highlight_line_end_line + then if is_warning then Warn else Err + else NoColor + in + draw_gutter gutter_color gutter_content; + + line.s + |> String.iteri (fun ii ch -> + let c = + if ii >= line.start && ii < line.end_ then + if is_warning then Warn else Err + else NoColor + in + add_ch c ch); + add_ch NoColor '\n')); Buffer.contents buf end @@ -294757,15 +295047,15 @@ module Super_location = struct | None -> () | Some ((start_line, start_line_start_char), (end_line, end_line_end_char)) -> - if start_line = end_line then - if start_line_start_char = end_line_end_char then - fprintf ppf ":@{%i:%i@}" start_line start_line_start_char + if start_line = end_line then + if start_line_start_char = end_line_end_char then + fprintf ppf ":@{%i:%i@}" start_line start_line_start_char + else + fprintf ppf ":@{%i:%i-%i@}" start_line start_line_start_char + end_line_end_char else - fprintf ppf ":@{%i:%i-%i@}" start_line start_line_start_char - end_line_end_char - else - fprintf ppf ":@{%i:%i-%i:%i@}" start_line start_line_start_char - end_line end_line_end_char + fprintf ppf ":@{%i:%i-%i:%i@}" start_line start_line_start_char + end_line end_line_end_char in fprintf ppf "@{%a@}%a" print_filename loc.loc_start.pos_fname dim_loc normalizedRange @@ -294775,7 +295065,7 @@ module Super_location = struct (match message_kind with | `warning -> fprintf ppf "@[@{%s@}@]@," intro | `warning_as_error -> - fprintf ppf "@[@{%s@} (configured as error) @]@," intro + fprintf ppf "@[@{%s@} (configured as error) @]@," intro | `error -> fprintf ppf "@[@{%s@}@]@," intro); (* ocaml's reported line/col numbering is horrible and super error-prone when being handled programmatically (or humanly for that matter. If you're @@ -294808,24 +295098,24 @@ module Super_location = struct match normalizedRange with | None -> () | Some _ -> ( - try - (* let src = Ext_io.load_file file in *) - (* we're putting the line break `@,` here rather than above, because this - branch might not be reached (aka no inline file content display) so - we don't wanna end up with two line breaks in the the consequent *) - fprintf ppf "@,%s" - (Super_code_frame.print ~is_warning:(message_kind = `warning) ~src - ~startPos:loc.loc_start ~endPos:loc.loc_end) - with - (* this might happen if the file is e.g. "", "_none_" or any of the fake file name placeholders. - we've already printed the location above, so nothing more to do here. *) - | Sys_error _ -> - ()) + try + (* let src = Ext_io.load_file file in *) + (* we're putting the line break `@,` here rather than above, because this + branch might not be reached (aka no inline file content display) so + we don't wanna end up with two line breaks in the the consequent *) + fprintf ppf "@,%s" + (Super_code_frame.print ~is_warning:(message_kind = `warning) ~src + ~startPos:loc.loc_start ~endPos:loc.loc_end) + with + (* this might happen if the file is e.g. "", "_none_" or any of the fake file name placeholders. + we've already printed the location above, so nothing more to do here. *) + | Sys_error _ -> + ()) (* taken from https://github.com/rescript-lang/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/parsing/location.ml#L380 *) (* This is the error report entry point. We'll replace the default reporter with this one. *) (* let rec super_error_reporter ppf ({loc; msg; sub} : Location.error) = *) - let super_error_reporter ppf src ({loc; msg} : Location.error) = + let super_error_reporter ppf src ({ loc; msg } : Location.error) = setup_colors (); (* open a vertical box. Everything in our message is indented 2 spaces *) (* Format.fprintf ppf "@[@, %a@, %s@,@]" (print ~message_kind:`error "We've found a bug for you!") src loc msg; *) @@ -294912,7 +295202,7 @@ let toString = function | ExprOperand -> "a basic expression" | ExprUnary -> "a unary expression" | ExprBinaryAfterOp op -> - "an expression after the operator \"" ^ Token.toString op ^ "\"" + "an expression after the operator \"" ^ Token.toString op ^ "\"" | ExprIf -> "an if expression" | IfCondition -> "the condition of an if expression" | IfBranch -> "the true-branch of an if expression" @@ -294966,26 +295256,26 @@ let toString = function let isSignatureItemStart = function | Token.At | Let | Typ | External | Exception | Open | Include | Module | AtAt | PercentPercent -> - true + true | _ -> false let isAtomicPatternStart = function | Token.Int _ | String _ | Codepoint _ | Backtick | Lparen | Lbracket | Lbrace | Underscore | Lident _ | Uident _ | List | Exception | Lazy | Percent -> - true + true | _ -> false let isAtomicExprStart = function | Token.True | False | Int _ | String _ | Float _ | Codepoint _ | Backtick | Uident _ | Lident _ | Hash | Lparen | List | Lbracket | Lbrace | LessThan | Module | Percent -> - true + true | _ -> false let isAtomicTypExprStart = function | Token.SingleQuote | Underscore | Lparen | Lbrace | Uident _ | Lident _ | Percent -> - true + true | _ -> false let isExprStart = function @@ -294994,7 +295284,7 @@ let isExprStart = function | List | Lparen | Minus | MinusDot | Module | Percent | Plus | PlusDot | String _ | Switch | True | Try | Uident _ | Underscore (* _ => doThings() *) | While -> - true + true | _ -> false let isJsxAttributeStart = function @@ -295004,7 +295294,7 @@ let isJsxAttributeStart = function let isStructureItemStart = function | Token.Open | Let | Typ | External | Exception | Include | Module | AtAt | PercentPercent | At -> - true + true | t when isExprStart t -> true | _ -> false @@ -295012,7 +295302,7 @@ let isPatternStart = function | Token.Int _ | Float _ | String _ | Codepoint _ | Backtick | True | False | Minus | Plus | Lparen | Lbracket | Lbrace | List | Underscore | Lident _ | Uident _ | Hash | Exception | Lazy | Percent | Module | At -> - true + true | _ -> false let isParameterStart = function @@ -295040,7 +295330,7 @@ let isRecordDeclStart = function let isTypExprStart = function | Token.At | SingleQuote | Underscore | Lparen | Lbracket | Uident _ | Lident _ | Module | Percent | Lbrace -> - true + true | _ -> false let isTypeParameterStart = function @@ -295067,9 +295357,7 @@ let isRecordRowStart = function | t when Token.isKeyword t -> true | _ -> false -let isRecordRowStringKeyStart = function - | Token.String _ -> true - | _ -> false +let isRecordRowStringKeyStart = function Token.String _ -> true | _ -> false let isArgumentStart = function | Token.Tilde | Dot | Underscore -> true @@ -295090,10 +295378,7 @@ let isPatternRecordItemStart = function | Token.DotDotDot | Uident _ | Lident _ | Underscore -> true | _ -> false -let isAttributeStart = function - | Token.At -> true - | _ -> false - +let isAttributeStart = function Token.At -> true | _ -> false let isJsxChildStart = isAtomicExprStart let isBlockExprStart = function @@ -295102,7 +295387,7 @@ let isBlockExprStart = function | Lbracket | LessThan | Let | Lident _ | List | Lparen | Minus | MinusDot | Module | Open | Percent | Plus | PlusDot | String _ | Switch | True | Try | Uident _ | Underscore | While -> - true + true | _ -> false let isListElement grammar token = @@ -295154,7 +295439,7 @@ let isListTerminator grammar token = | ParameterList, (EqualGreater | Lbrace) | JsxAttribute, (Forwardslash | GreaterThan) | StringFieldDeclarations, Rbrace -> - true + true | Attribute, token when token <> At -> true | TypeConstraint, token when token <> Constraint -> true | PackageConstraint, token when token <> And -> true @@ -295178,9 +295463,7 @@ type report val getStartPos : t -> Lexing.position [@@live] (* for playground *) val getEndPos : t -> Lexing.position [@@live] (* for playground *) - val explain : t -> string [@@live] (* for playground *) - val unexpected : Token.t -> (Grammar.t * Lexing.position) list -> category val expected : ?grammar:Grammar.t -> Lexing.position -> Token.t -> category val uident : Token.t -> category @@ -295190,9 +295473,7 @@ val unclosedTemplate : category val unclosedComment : category val unknownUchar : Char.t -> category val message : string -> category - val make : startPos:Lexing.position -> endPos:Lexing.position -> category -> t - val printReport : t list -> string -> unit end = struct @@ -295201,11 +295482,14 @@ module Grammar = Res_grammar module Token = Res_token type category = - | Unexpected of {token: Token.t; context: (Grammar.t * Lexing.position) list} + | Unexpected of { + token : Token.t; + context : (Grammar.t * Lexing.position) list; + } | Expected of { - context: Grammar.t option; - pos: Lexing.position; (* prev token end*) - token: Token.t; + context : Grammar.t option; + pos : Lexing.position; (* prev token end*) + token : Token.t; } | Message of string | Uident of Token.t @@ -295216,9 +295500,9 @@ type category = | UnknownUchar of Char.t type t = { - startPos: Lexing.position; - endPos: Lexing.position; - category: category; + startPos : Lexing.position; + endPos : Lexing.position; + category : category; } type report = t list @@ -295238,131 +295522,140 @@ let reservedKeyword token = let explain t = match t.category with | Uident currentToken -> ( - match currentToken with - | Lident lident -> - let guess = String.capitalize_ascii lident in - "Did you mean `" ^ guess ^ "` instead of `" ^ lident ^ "`?" - | t when Token.isKeyword t -> - let token = Token.toString t in - "`" ^ token ^ "` is a reserved keyword." - | _ -> - "At this point, I'm looking for an uppercased name like `Belt` or `Array`" - ) + match currentToken with + | Lident lident -> + let guess = String.capitalize_ascii lident in + "Did you mean `" ^ guess ^ "` instead of `" ^ lident ^ "`?" + | t when Token.isKeyword t -> + let token = Token.toString t in + "`" ^ token ^ "` is a reserved keyword." + | _ -> + "At this point, I'm looking for an uppercased name like `Belt` or \ + `Array`") | Lident currentToken -> ( - match currentToken with - | Uident uident -> - let guess = String.uncapitalize_ascii uident in - "Did you mean `" ^ guess ^ "` instead of `" ^ uident ^ "`?" - | t when Token.isKeyword t -> - let token = Token.toString t in - "`" ^ token ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" - ^ token ^ "\"" - | Underscore -> "`_` isn't a valid name." - | _ -> "I'm expecting a lowercase name like `user or `age`") + match currentToken with + | Uident uident -> + let guess = String.uncapitalize_ascii uident in + "Did you mean `" ^ guess ^ "` instead of `" ^ uident ^ "`?" + | t when Token.isKeyword t -> + let token = Token.toString t in + "`" ^ token + ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" ^ token + ^ "\"" + | Underscore -> "`_` isn't a valid name." + | _ -> "I'm expecting a lowercase name like `user or `age`") | Message txt -> txt | UnclosedString -> "This string is missing a double quote at the end" | UnclosedTemplate -> - "Did you forget to close this template expression with a backtick?" + "Did you forget to close this template expression with a backtick?" | UnclosedComment -> "This comment seems to be missing a closing `*/`" | UnknownUchar uchar -> ( - match uchar with - | '^' -> - "Not sure what to do with this character.\n" - ^ " If you're trying to dereference a mutable value, use \ - `myValue.contents` instead.\n" - ^ " To concatenate strings, use `\"a\" ++ \"b\"` instead." - | _ -> "Not sure what to do with this character.") - | Expected {context; token = t} -> - let hint = - match context with - | Some grammar -> " It signals the start of " ^ Grammar.toString grammar - | None -> "" - in - "Did you forget a `" ^ Token.toString t ^ "` here?" ^ hint - | Unexpected {token = t; context = breadcrumbs} -> ( - let name = Token.toString t in - match breadcrumbs with - | (AtomicTypExpr, _) :: breadcrumbs -> ( - match (breadcrumbs, t) with - | ( ((StringFieldDeclarations | FieldDeclarations), _) :: _, - (String _ | At | Rbrace | Comma | Eof) ) -> - "I'm missing a type here" - | _, t when Grammar.isStructureItemStart t || t = Eof -> - "Missing a type here" - | _ -> defaultUnexpected t) - | (ExprOperand, _) :: breadcrumbs -> ( - match (breadcrumbs, t) with - | (ExprBlock, _) :: _, Rbrace -> - "It seems that this expression block is empty" - | (ExprBlock, _) :: _, Bar -> - (* Pattern matching *) - "Looks like there might be an expression missing here" - | (ExprSetField, _) :: _, _ -> - "It seems that this record field mutation misses an expression" - | (ExprArrayMutation, _) :: _, _ -> - "Seems that an expression is missing, with what do I mutate the array?" - | ((ExprBinaryAfterOp _ | ExprUnary), _) :: _, _ -> - "Did you forget to write an expression here?" - | (Grammar.LetBinding, _) :: _, _ -> - "This let-binding misses an expression" - | _ :: _, (Rbracket | Rbrace | Eof) -> "Missing expression" - | _ -> "I'm not sure what to parse here when looking at \"" ^ name ^ "\"." - ) - | (TypeParam, _) :: _ -> ( - match t with - | Lident ident -> - "Did you mean '" ^ ident ^ "? A Type parameter starts with a quote." - | _ -> "I'm not sure what to parse here when looking at \"" ^ name ^ "\"." - ) - | (Pattern, _) :: breadcrumbs -> ( - match (t, breadcrumbs) with - | Equal, (LetBinding, _) :: _ -> - "I was expecting a name for this let-binding. Example: `let message = \ - \"hello\"`" - | In, (ExprFor, _) :: _ -> - "A for-loop has the following form: `for i in 0 to 10`. Did you forget \ - to supply a name before `in`?" - | EqualGreater, (PatternMatchCase, _) :: _ -> - "I was expecting a pattern to match on before the `=>`" - | token, _ when Token.isKeyword t -> reservedKeyword token - | token, _ -> defaultUnexpected token) - | _ -> - (* TODO: match on circumstance to verify Lident needed ? *) - if Token.isKeyword t then - "`" ^ name - ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" - ^ Token.toString t ^ "\"" - else "I'm not sure what to parse here when looking at \"" ^ name ^ "\".") + match uchar with + | '^' -> + "Not sure what to do with this character.\n" + ^ " If you're trying to dereference a mutable value, use \ + `myValue.contents` instead.\n" + ^ " To concatenate strings, use `\"a\" ++ \"b\"` instead." + | _ -> "Not sure what to do with this character.") + | Expected { context; token = t } -> + let hint = + match context with + | Some grammar -> " It signals the start of " ^ Grammar.toString grammar + | None -> "" + in + "Did you forget a `" ^ Token.toString t ^ "` here?" ^ hint + | Unexpected { token = t; context = breadcrumbs } -> ( + let name = Token.toString t in + match breadcrumbs with + | (AtomicTypExpr, _) :: breadcrumbs -> ( + match (breadcrumbs, t) with + | ( ((StringFieldDeclarations | FieldDeclarations), _) :: _, + (String _ | At | Rbrace | Comma | Eof) ) -> + "I'm missing a type here" + | _, t when Grammar.isStructureItemStart t || t = Eof -> + "Missing a type here" + | _ -> defaultUnexpected t) + | (ExprOperand, _) :: breadcrumbs -> ( + match (breadcrumbs, t) with + | (ExprBlock, _) :: _, Rbrace -> + "It seems that this expression block is empty" + | (ExprBlock, _) :: _, Bar -> + (* Pattern matching *) + "Looks like there might be an expression missing here" + | (ExprSetField, _) :: _, _ -> + "It seems that this record field mutation misses an expression" + | (ExprArrayMutation, _) :: _, _ -> + "Seems that an expression is missing, with what do I mutate the \ + array?" + | ((ExprBinaryAfterOp _ | ExprUnary), _) :: _, _ -> + "Did you forget to write an expression here?" + | (Grammar.LetBinding, _) :: _, _ -> + "This let-binding misses an expression" + | _ :: _, (Rbracket | Rbrace | Eof) -> "Missing expression" + | _ -> + "I'm not sure what to parse here when looking at \"" ^ name + ^ "\".") + | (TypeParam, _) :: _ -> ( + match t with + | Lident ident -> + "Did you mean '" ^ ident + ^ "? A Type parameter starts with a quote." + | _ -> + "I'm not sure what to parse here when looking at \"" ^ name + ^ "\".") + | (Pattern, _) :: breadcrumbs -> ( + match (t, breadcrumbs) with + | Equal, (LetBinding, _) :: _ -> + "I was expecting a name for this let-binding. Example: `let \ + message = \"hello\"`" + | In, (ExprFor, _) :: _ -> + "A for-loop has the following form: `for i in 0 to 10`. Did you \ + forget to supply a name before `in`?" + | EqualGreater, (PatternMatchCase, _) :: _ -> + "I was expecting a pattern to match on before the `=>`" + | token, _ when Token.isKeyword t -> reservedKeyword token + | token, _ -> defaultUnexpected token) + | _ -> + (* TODO: match on circumstance to verify Lident needed ? *) + if Token.isKeyword t then + "`" ^ name + ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" + ^ Token.toString t ^ "\"" + else + "I'm not sure what to parse here when looking at \"" ^ name ^ "\".") -let make ~startPos ~endPos category = {startPos; endPos; category} +let make ~startPos ~endPos category = { startPos; endPos; category } let printReport diagnostics src = let rec print diagnostics src = match diagnostics with | [] -> () | d :: rest -> - Res_diagnostics_printing_utils.Super_location.super_error_reporter - Format.err_formatter src - Location. - { - loc = {loc_start = d.startPos; loc_end = d.endPos; loc_ghost = false}; - msg = explain d; - sub = []; - if_highlight = ""; - }; - (match rest with - | [] -> () - | _ -> Format.fprintf Format.err_formatter "@."); - print rest src + Res_diagnostics_printing_utils.Super_location.super_error_reporter + Format.err_formatter src + Location. + { + loc = + { + loc_start = d.startPos; + loc_end = d.endPos; + loc_ghost = false; + }; + msg = explain d; + sub = []; + if_highlight = ""; + }; + (match rest with + | [] -> () + | _ -> Format.fprintf Format.err_formatter "@."); + print rest src in Format.fprintf Format.err_formatter "@["; print (List.rev diagnostics) src; Format.fprintf Format.err_formatter "@]@." -let unexpected token context = Unexpected {token; context} - -let expected ?grammar pos token = Expected {context = grammar; pos; token} - +let unexpected token context = Unexpected { token; context } +let expected ?grammar pos token = Expected { context = grammar; pos; token } let uident currentToken = Uident currentToken let lident currentToken = Lident currentToken let unclosedString = UnclosedString @@ -295381,9 +295674,9 @@ module Grammar = Res_grammar type problem = | Unexpected of Token.t [@live] | Expected of { - token: Token.t; - pos: Lexing.position; - context: Grammar.t option; + token : Token.t; + pos : Lexing.position; + context : Grammar.t option; } [@live] | Message of string [@live] | Uident [@live] @@ -295405,42 +295698,38 @@ let convertDecimalToHex ~strDecimal = let intNum = int_of_string strDecimal in let c1 = Array.get hexTable (intNum lsr 4) in let c2 = Array.get hexTable (intNum land 15) in - "x" ^ String.concat "" [String.make 1 c1; String.make 1 c2] + "x" ^ String.concat "" [ String.make 1 c1; String.make 1 c2 ] with Invalid_argument _ | Failure _ -> strDecimal end module Res_scanner : sig #1 "res_scanner.mli" type mode = Jsx | Diamond - type charEncoding type t = { - filename: string; - src: string; - mutable err: + filename : string; + src : string; + mutable err : startPos:Lexing.position -> endPos:Lexing.position -> Res_diagnostics.category -> unit; - mutable ch: charEncoding; (* current character *) - mutable offset: int; (* character offset *) - mutable lineOffset: int; (* current line offset *) - mutable lnum: int; (* current line number *) - mutable mode: mode list; + mutable ch : charEncoding; (* current character *) + mutable offset : int; (* character offset *) + mutable lineOffset : int; (* current line offset *) + mutable lnum : int; (* current line number *) + mutable mode : mode list; } val make : filename:string -> string -> t (* TODO: make this a record *) val scan : t -> Lexing.position * Lexing.position * Res_token.t - val isBinaryOp : string -> int -> int -> bool - val setJsxMode : t -> unit val setDiamondMode : t -> unit val popMode : t -> mode -> unit - val reconsiderLessThan : t -> Res_token.t val scanTemplateLiteralToken : @@ -295460,25 +295749,25 @@ type mode = Jsx | Diamond will also contain the special -1 value to indicate end-of-file. This isn't ideal; we should clean this up *) let hackyEOFChar = Char.unsafe_chr (-1) + type charEncoding = Char.t type t = { - filename: string; - src: string; - mutable err: + filename : string; + src : string; + mutable err : startPos:Lexing.position -> endPos:Lexing.position -> Diagnostics.category -> unit; - mutable ch: charEncoding; (* current character *) - mutable offset: int; (* character offset *) - mutable lineOffset: int; (* current line offset *) - mutable lnum: int; (* current line number *) - mutable mode: mode list; + mutable ch : charEncoding; (* current character *) + mutable offset : int; (* character offset *) + mutable lineOffset : int; (* current line offset *) + mutable lnum : int; (* current line number *) + mutable mode : mode list; } let setDiamondMode scanner = scanner.mode <- Diamond :: scanner.mode - let setJsxMode scanner = scanner.mode <- Jsx :: scanner.mode let popMode scanner mode = @@ -295487,14 +295776,9 @@ let popMode scanner mode = | _ -> () let inDiamondMode scanner = - match scanner.mode with - | Diamond :: _ -> true - | _ -> false + match scanner.mode with Diamond :: _ -> true | _ -> false -let inJsxMode scanner = - match scanner.mode with - | Jsx :: _ -> true - | _ -> false +let inJsxMode scanner = match scanner.mode with Jsx :: _ -> true | _ -> false let position scanner = Lexing. @@ -295534,8 +295818,8 @@ let _printDebug ~startPos ~endPos scanner token = | 0 -> if token = Token.Eof then () else assert false | 1 -> () | n -> - print_string ((String.make [@doesNotRaise]) (n - 2) '-'); - print_char '^'); + print_string ((String.make [@doesNotRaise]) (n - 2) '-'); + print_char '^'); print_char ' '; print_string (Res_token.toString token); print_char ' '; @@ -295549,11 +295833,11 @@ let next scanner = let nextOffset = scanner.offset + 1 in (match scanner.ch with | '\n' -> - scanner.lineOffset <- nextOffset; - scanner.lnum <- scanner.lnum + 1 - (* What about CRLF (\r + \n) on windows? - * \r\n will always be terminated by a \n - * -> we can just bump the line count on \n *) + scanner.lineOffset <- nextOffset; + scanner.lnum <- scanner.lnum + 1 + (* What about CRLF (\r + \n) on windows? + * \r\n will always be terminated by a \n + * -> we can just bump the line count on \n *) | _ -> ()); if nextOffset < String.length scanner.src then ( scanner.offset <- nextOffset; @@ -295601,9 +295885,7 @@ let make ~filename src = (* generic helpers *) let isWhitespace ch = - match ch with - | ' ' | '\t' | '\n' | '\r' -> true - | _ -> false + match ch with ' ' | '\t' | '\n' | '\r' -> true | _ -> false let rec skipWhitespace scanner = if isWhitespace scanner.ch then ( @@ -295620,8 +295902,8 @@ let digitValue ch = let rec skipLowerCaseChars scanner = match scanner.ch with | 'a' .. 'z' -> - next scanner; - skipLowerCaseChars scanner + next scanner; + skipLowerCaseChars scanner | _ -> () (* scanning helpers *) @@ -295631,8 +295913,8 @@ let scanIdentifier scanner = let rec skipGoodChars scanner = match scanner.ch with | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' | '\'' -> - next scanner; - skipGoodChars scanner + next scanner; + skipGoodChars scanner | _ -> () in skipGoodChars scanner; @@ -295650,8 +295932,8 @@ let scanDigits scanner ~base = let rec loop scanner = match scanner.ch with | '0' .. '9' | '_' -> - next scanner; - loop scanner + next scanner; + loop scanner | _ -> () in loop scanner @@ -295660,8 +295942,8 @@ let scanDigits scanner ~base = match scanner.ch with (* hex *) | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_' -> - next scanner; - loop scanner + next scanner; + loop scanner | _ -> () in loop scanner @@ -295674,19 +295956,19 @@ let scanNumber scanner = let base = match scanner.ch with | '0' -> ( - match peek scanner with - | 'x' | 'X' -> - next2 scanner; - 16 - | 'o' | 'O' -> - next2 scanner; - 8 - | 'b' | 'B' -> - next2 scanner; - 2 - | _ -> - next scanner; - 8) + match peek scanner with + | 'x' | 'X' -> + next2 scanner; + 16 + | 'o' | 'O' -> + next2 scanner; + 8 + | 'b' | 'B' -> + next2 scanner; + 2 + | _ -> + next scanner; + 8) | _ -> 10 in scanDigits scanner ~base; @@ -295704,11 +295986,11 @@ let scanNumber scanner = let isFloat = match scanner.ch with | 'e' | 'E' | 'p' | 'P' -> - (match peek scanner with - | '+' | '-' -> next2 scanner - | _ -> next scanner); - scanDigits scanner ~base; - true + (match peek scanner with + | '+' | '-' -> next2 scanner + | _ -> next scanner); + scanDigits scanner ~base; + true | _ -> isFloat in let literal = @@ -295719,20 +296001,20 @@ let scanNumber scanner = let suffix = match scanner.ch with | 'n' -> - let msg = - "Unsupported number type (nativeint). Did you mean `" ^ literal ^ "`?" - in - let pos = position scanner in - scanner.err ~startPos:pos ~endPos:pos (Diagnostics.message msg); - next scanner; - Some 'n' + let msg = + "Unsupported number type (nativeint). Did you mean `" ^ literal ^ "`?" + in + let pos = position scanner in + scanner.err ~startPos:pos ~endPos:pos (Diagnostics.message msg); + next scanner; + Some 'n' | ('g' .. 'z' | 'G' .. 'Z') as ch -> - next scanner; - Some ch + next scanner; + Some ch | _ -> None in - if isFloat then Token.Float {f = literal; suffix} - else Token.Int {i = literal; suffix} + if isFloat then Token.Float { f = literal; suffix } + else Token.Int { i = literal; suffix } let scanExoticIdentifier scanner = (* TODO: are we disregarding the current char...? Should be a quote *) @@ -295744,19 +296026,19 @@ let scanExoticIdentifier scanner = match scanner.ch with | '"' -> next scanner | '\n' | '\r' -> - (* line break *) - let endPos = position scanner in - scanner.err ~startPos ~endPos - (Diagnostics.message "A quoted identifier can't contain line breaks."); - next scanner + (* line break *) + let endPos = position scanner in + scanner.err ~startPos ~endPos + (Diagnostics.message "A quoted identifier can't contain line breaks."); + next scanner | ch when ch == hackyEOFChar -> - let endPos = position scanner in - scanner.err ~startPos ~endPos - (Diagnostics.message "Did you forget a \" here?") + let endPos = position scanner in + scanner.err ~startPos ~endPos + (Diagnostics.message "Did you forget a \" here?") | ch -> - Buffer.add_char buffer ch; - next scanner; - scan () + Buffer.add_char buffer ch; + next scanner; + scan () in scan (); (* TODO: do we really need to create a new buffer instead of substring once? *) @@ -295792,37 +296074,35 @@ let scanStringEscapeSequence ~startPos scanner = | '0' when let c = peek scanner in c < '0' || c > '9' -> - (* Allow \0 *) - next scanner + (* Allow \0 *) + next scanner | '0' .. '9' -> scan ~n:3 ~base:10 ~max:255 | 'x' -> - (* hex *) - next scanner; - scan ~n:2 ~base:16 ~max:255 + (* hex *) + next scanner; + scan ~n:2 ~base:16 ~max:255 | 'u' -> ( - next scanner; - match scanner.ch with - | '{' -> ( - (* unicode code point escape sequence: '\u{7A}', one or more hex digits *) next scanner; - let x = ref 0 in - while - match scanner.ch with - | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true - | _ -> false - do - x := (!x * 16) + digitValue scanner.ch; - next scanner - done; - (* consume '}' in '\u{7A}' *) match scanner.ch with - | '}' -> next scanner - | _ -> ()) - | _ -> scan ~n:4 ~base:16 ~max:Res_utf8.max) + | '{' -> ( + (* unicode code point escape sequence: '\u{7A}', one or more hex digits *) + next scanner; + let x = ref 0 in + while + match scanner.ch with + | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true + | _ -> false + do + x := (!x * 16) + digitValue scanner.ch; + next scanner + done; + (* consume '}' in '\u{7A}' *) + match scanner.ch with '}' -> next scanner | _ -> ()) + | _ -> scan ~n:4 ~base:16 ~max:Res_utf8.max) | _ -> - (* unknown escape sequence - * TODO: we should warn the user here. Let's not make it a hard error for now, for reason compat *) - (* + (* unknown escape sequence + * TODO: we should warn the user here. Let's not make it a hard error for now, for reason compat *) + (* let pos = position scanner in let msg = if ch == -1 then "unclosed escape sequence" @@ -295830,7 +296110,7 @@ let scanStringEscapeSequence ~startPos scanner = in scanner.err ~startPos ~endPos:pos (Diagnostics.message msg) *) - () + () let scanString scanner = (* assumption: we've just matched a quote *) @@ -295863,30 +296143,28 @@ let scanString scanner = let rec scan () = match scanner.ch with | '"' -> - let lastCharOffset = scanner.offset in - next scanner; - result ~firstCharOffset ~lastCharOffset + let lastCharOffset = scanner.offset in + next scanner; + result ~firstCharOffset ~lastCharOffset | '\\' -> - let startPos = position scanner in - let startOffset = scanner.offset + 1 in - next scanner; - scanStringEscapeSequence ~startPos scanner; - let endOffset = scanner.offset in - convertOctalToHex ~startOffset ~endOffset + let startPos = position scanner in + let startOffset = scanner.offset + 1 in + next scanner; + scanStringEscapeSequence ~startPos scanner; + let endOffset = scanner.offset in + convertOctalToHex ~startOffset ~endOffset | ch when ch == hackyEOFChar -> - let endPos = position scanner in - scanner.err ~startPos:startPosWithQuote ~endPos Diagnostics.unclosedString; - let lastCharOffset = scanner.offset in - result ~firstCharOffset ~lastCharOffset + let endPos = position scanner in + scanner.err ~startPos:startPosWithQuote ~endPos + Diagnostics.unclosedString; + let lastCharOffset = scanner.offset in + result ~firstCharOffset ~lastCharOffset | _ -> - next scanner; - scan () + next scanner; + scan () and convertOctalToHex ~startOffset ~endOffset = let len = endOffset - startOffset in - let isDigit = function - | '0' .. '9' -> true - | _ -> false - in + let isDigit = function '0' .. '9' -> true | _ -> false in let txt = scanner.src in let isNumericEscape = len = 3 @@ -295922,50 +296200,48 @@ let scanEscape scanner = match scanner.ch with | '0' .. '9' -> convertNumber scanner ~n:3 ~base:10 | 'b' -> - next scanner; - 8 + next scanner; + 8 | 'n' -> - next scanner; - 10 + next scanner; + 10 | 'r' -> - next scanner; - 13 + next scanner; + 13 | 't' -> - next scanner; - 009 + next scanner; + 009 | 'x' -> - next scanner; - convertNumber scanner ~n:2 ~base:16 + next scanner; + convertNumber scanner ~n:2 ~base:16 | 'o' -> - next scanner; - convertNumber scanner ~n:3 ~base:8 + next scanner; + convertNumber scanner ~n:3 ~base:8 | 'u' -> ( - next scanner; - match scanner.ch with - | '{' -> - (* unicode code point escape sequence: '\u{7A}', one or more hex digits *) next scanner; - let x = ref 0 in - while - match scanner.ch with - | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true - | _ -> false - do - x := (!x * 16) + digitValue scanner.ch; - next scanner - done; - (* consume '}' in '\u{7A}' *) - (match scanner.ch with - | '}' -> next scanner - | _ -> ()); - let c = !x in - if Res_utf8.isValidCodePoint c then c else Res_utf8.repl - | _ -> - (* unicode escape sequence: '\u007A', exactly 4 hex digits *) - convertNumber scanner ~n:4 ~base:16) + match scanner.ch with + | '{' -> + (* unicode code point escape sequence: '\u{7A}', one or more hex digits *) + next scanner; + let x = ref 0 in + while + match scanner.ch with + | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true + | _ -> false + do + x := (!x * 16) + digitValue scanner.ch; + next scanner + done; + (* consume '}' in '\u{7A}' *) + (match scanner.ch with '}' -> next scanner | _ -> ()); + let c = !x in + if Res_utf8.isValidCodePoint c then c else Res_utf8.repl + | _ -> + (* unicode escape sequence: '\u007A', exactly 4 hex digits *) + convertNumber scanner ~n:4 ~base:16) | ch -> - next scanner; - Char.code ch + next scanner; + Char.code ch in let contents = (String.sub [@doesNotRaise]) scanner.src offset (scanner.offset - offset) @@ -295973,7 +296249,7 @@ let scanEscape scanner = next scanner; (* Consume \' *) (* TODO: do we know it's \' ? *) - Token.Codepoint {c = codepoint; original = contents} + Token.Codepoint { c = codepoint; original = contents } let scanSingleLineComment scanner = let startOff = scanner.offset in @@ -295983,14 +296259,15 @@ let scanSingleLineComment scanner = | '\n' | '\r' -> () | ch when ch == hackyEOFChar -> () | _ -> - next scanner; - skip scanner + next scanner; + skip scanner in skip scanner; let endPos = position scanner in Token.Comment (Comment.makeSingleLineComment - ~loc:Location.{loc_start = startPos; loc_end = endPos; loc_ghost = false} + ~loc: + Location.{ loc_start = startPos; loc_end = endPos; loc_ghost = false } ((String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - startOff))) @@ -296006,17 +296283,17 @@ let scanMultiLineComment scanner = (* invariant: depth > 0 right after this match. See assumption *) match (scanner.ch, peek scanner) with | '/', '*' -> - next2 scanner; - scan ~depth:(depth + 1) + next2 scanner; + scan ~depth:(depth + 1) | '*', '/' -> - next2 scanner; - if depth > 1 then scan ~depth:(depth - 1) + next2 scanner; + if depth > 1 then scan ~depth:(depth - 1) | ch, _ when ch == hackyEOFChar -> - let endPos = position scanner in - scanner.err ~startPos ~endPos Diagnostics.unclosedComment + let endPos = position scanner in + scanner.err ~startPos ~endPos Diagnostics.unclosedComment | _ -> - next scanner; - scan ~depth + next scanner; + scan ~depth in scan ~depth:0; let length = scanner.offset - 2 - contentStartOff in @@ -296025,7 +296302,11 @@ let scanMultiLineComment scanner = (Comment.makeMultiLineComment ~docComment ~standalone ~loc: Location. - {loc_start = startPos; loc_end = position scanner; loc_ghost = false} + { + loc_start = startPos; + loc_end = position scanner; + loc_ghost = false; + } ((String.sub [@doesNotRaise]) scanner.src contentStartOff length)) let scanTemplateLiteralToken scanner = @@ -296040,44 +296321,44 @@ let scanTemplateLiteralToken scanner = let lastPos = position scanner in match scanner.ch with | '`' -> - next scanner; - let contents = - (String.sub [@doesNotRaise]) scanner.src startOff - (scanner.offset - 1 - startOff) - in - Token.TemplateTail (contents, lastPos) - | '$' -> ( - match peek scanner with - | '{' -> - next2 scanner; + next scanner; let contents = (String.sub [@doesNotRaise]) scanner.src startOff - (scanner.offset - 2 - startOff) + (scanner.offset - 1 - startOff) in - Token.TemplatePart (contents, lastPos) - | _ -> - next scanner; - scan ()) + Token.TemplateTail (contents, lastPos) + | '$' -> ( + match peek scanner with + | '{' -> + next2 scanner; + let contents = + (String.sub [@doesNotRaise]) scanner.src startOff + (scanner.offset - 2 - startOff) + in + Token.TemplatePart (contents, lastPos) + | _ -> + next scanner; + scan ()) | '\\' -> ( - match peek scanner with - | '`' | '\\' | '$' | '\n' | '\r' -> - (* line break *) - next2 scanner; - scan () - | _ -> - next scanner; - scan ()) + match peek scanner with + | '`' | '\\' | '$' | '\n' | '\r' -> + (* line break *) + next2 scanner; + scan () + | _ -> + next scanner; + scan ()) | ch when ch = hackyEOFChar -> - let endPos = position scanner in - scanner.err ~startPos ~endPos Diagnostics.unclosedTemplate; - let contents = - (String.sub [@doesNotRaise]) scanner.src startOff - (max (scanner.offset - 1 - startOff) 0) - in - Token.TemplateTail (contents, lastPos) + let endPos = position scanner in + scanner.err ~startPos ~endPos Diagnostics.unclosedTemplate; + let contents = + (String.sub [@doesNotRaise]) scanner.src startOff + (max (scanner.offset - 1 - startOff) 0) + in + Token.TemplateTail (contents, lastPos) | _ -> - next scanner; - scan () + next scanner; + scan () in let token = scan () in let endPos = position scanner in @@ -296093,273 +296374,273 @@ let rec scan scanner = | 'A' .. 'Z' | 'a' .. 'z' -> scanIdentifier scanner | '0' .. '9' -> scanNumber scanner | '`' -> - next scanner; - Token.Backtick + next scanner; + Token.Backtick | '~' -> - next scanner; - Token.Tilde + next scanner; + Token.Tilde | '?' -> - next scanner; - Token.Question + next scanner; + Token.Question | ';' -> - next scanner; - Token.Semicolon + next scanner; + Token.Semicolon | '(' -> - next scanner; - Token.Lparen + next scanner; + Token.Lparen | ')' -> - next scanner; - Token.Rparen + next scanner; + Token.Rparen | '[' -> - next scanner; - Token.Lbracket + next scanner; + Token.Lbracket | ']' -> - next scanner; - Token.Rbracket + next scanner; + Token.Rbracket | '{' -> - next scanner; - Token.Lbrace + next scanner; + Token.Lbrace | '}' -> - next scanner; - Token.Rbrace + next scanner; + Token.Rbrace | ',' -> - next scanner; - Token.Comma + next scanner; + Token.Comma | '"' -> scanString scanner (* peeking 1 char *) | '_' -> ( - match peek scanner with - | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' -> scanIdentifier scanner - | _ -> - next scanner; - Token.Underscore) + match peek scanner with + | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' -> scanIdentifier scanner + | _ -> + next scanner; + Token.Underscore) | '#' -> ( - match peek scanner with - | '=' -> - next2 scanner; - Token.HashEqual - | _ -> - next scanner; - Token.Hash) + match peek scanner with + | '=' -> + next2 scanner; + Token.HashEqual + | _ -> + next scanner; + Token.Hash) | '*' -> ( - match peek scanner with - | '*' -> - next2 scanner; - Token.Exponentiation - | '.' -> - next2 scanner; - Token.AsteriskDot - | _ -> - next scanner; - Token.Asterisk) + match peek scanner with + | '*' -> + next2 scanner; + Token.Exponentiation + | '.' -> + next2 scanner; + Token.AsteriskDot + | _ -> + next scanner; + Token.Asterisk) | '@' -> ( - match peek scanner with - | '@' -> - next2 scanner; - Token.AtAt - | _ -> - next scanner; - Token.At) + match peek scanner with + | '@' -> + next2 scanner; + Token.AtAt + | _ -> + next scanner; + Token.At) | '%' -> ( - match peek scanner with - | '%' -> - next2 scanner; - Token.PercentPercent - | _ -> - next scanner; - Token.Percent) + match peek scanner with + | '%' -> + next2 scanner; + Token.PercentPercent + | _ -> + next scanner; + Token.Percent) | '|' -> ( - match peek scanner with - | '|' -> - next2 scanner; - Token.Lor - | '>' -> - next2 scanner; - Token.BarGreater - | _ -> - next scanner; - Token.Bar) + match peek scanner with + | '|' -> + next2 scanner; + Token.Lor + | '>' -> + next2 scanner; + Token.BarGreater + | _ -> + next scanner; + Token.Bar) | '&' -> ( - match peek scanner with - | '&' -> - next2 scanner; - Token.Land - | _ -> - next scanner; - Token.Band) + match peek scanner with + | '&' -> + next2 scanner; + Token.Land + | _ -> + next scanner; + Token.Band) | ':' -> ( - match peek scanner with - | '=' -> - next2 scanner; - Token.ColonEqual - | '>' -> - next2 scanner; - Token.ColonGreaterThan - | _ -> - next scanner; - Token.Colon) + match peek scanner with + | '=' -> + next2 scanner; + Token.ColonEqual + | '>' -> + next2 scanner; + Token.ColonGreaterThan + | _ -> + next scanner; + Token.Colon) | '\\' -> - next scanner; - scanExoticIdentifier scanner - | '/' -> ( - match peek scanner with - | '/' -> - next2 scanner; - scanSingleLineComment scanner - | '*' -> scanMultiLineComment scanner - | '.' -> - next2 scanner; - Token.ForwardslashDot - | _ -> next scanner; - Token.Forwardslash) + scanExoticIdentifier scanner + | '/' -> ( + match peek scanner with + | '/' -> + next2 scanner; + scanSingleLineComment scanner + | '*' -> scanMultiLineComment scanner + | '.' -> + next2 scanner; + Token.ForwardslashDot + | _ -> + next scanner; + Token.Forwardslash) | '-' -> ( - match peek scanner with - | '.' -> - next2 scanner; - Token.MinusDot - | '>' -> - next2 scanner; - Token.MinusGreater - | _ -> - next scanner; - Token.Minus) + match peek scanner with + | '.' -> + next2 scanner; + Token.MinusDot + | '>' -> + next2 scanner; + Token.MinusGreater + | _ -> + next scanner; + Token.Minus) | '+' -> ( - match peek scanner with - | '.' -> - next2 scanner; - Token.PlusDot - | '+' -> - next2 scanner; - Token.PlusPlus - | '=' -> - next2 scanner; - Token.PlusEqual - | _ -> - next scanner; - Token.Plus) + match peek scanner with + | '.' -> + next2 scanner; + Token.PlusDot + | '+' -> + next2 scanner; + Token.PlusPlus + | '=' -> + next2 scanner; + Token.PlusEqual + | _ -> + next scanner; + Token.Plus) | '>' -> ( - match peek scanner with - | '=' when not (inDiamondMode scanner) -> - next2 scanner; - Token.GreaterEqual - | _ -> - next scanner; - Token.GreaterThan) + match peek scanner with + | '=' when not (inDiamondMode scanner) -> + next2 scanner; + Token.GreaterEqual + | _ -> + next scanner; + Token.GreaterThan) | '<' when not (inJsxMode scanner) -> ( - match peek scanner with - | '=' -> - next2 scanner; - Token.LessEqual - | _ -> - next scanner; - Token.LessThan) + match peek scanner with + | '=' -> + next2 scanner; + Token.LessEqual + | _ -> + next scanner; + Token.LessThan) (* special handling for JSX < *) | '<' -> ( - (* Imagine the following:
< - * < indicates the start of a new jsx-element, the parser expects - * the name of a new element after the < - * Example:
- * This signals a closing element. To simulate the two-token lookahead, - * the - next scanner; - Token.LessThanSlash - | '=' -> + (* Imagine the following:
< + * < indicates the start of a new jsx-element, the parser expects + * the name of a new element after the < + * Example:
+ * This signals a closing element. To simulate the two-token lookahead, + * the Token.LessThan) + skipWhitespace scanner; + match scanner.ch with + | '/' -> + next scanner; + Token.LessThanSlash + | '=' -> + next scanner; + Token.LessEqual + | _ -> Token.LessThan) (* peeking 2 chars *) | '.' -> ( - match (peek scanner, peek2 scanner) with - | '.', '.' -> - next3 scanner; - Token.DotDotDot - | '.', _ -> - next2 scanner; - Token.DotDot - | _ -> - next scanner; - Token.Dot) + match (peek scanner, peek2 scanner) with + | '.', '.' -> + next3 scanner; + Token.DotDotDot + | '.', _ -> + next2 scanner; + Token.DotDot + | _ -> + next scanner; + Token.Dot) | '\'' -> ( - match (peek scanner, peek2 scanner) with - | '\\', '"' -> - (* careful with this one! We're next-ing _once_ (not twice), - then relying on matching on the quote *) - next scanner; - SingleQuote - | '\\', _ -> - next2 scanner; - scanEscape scanner - | ch, '\'' -> - let offset = scanner.offset + 1 in - next3 scanner; - Token.Codepoint - { - c = Char.code ch; - original = (String.sub [@doesNotRaise]) scanner.src offset 1; - } - | ch, _ -> - next scanner; - let offset = scanner.offset in - let codepoint, length = - Res_utf8.decodeCodePoint scanner.offset scanner.src - (String.length scanner.src) - in - for _ = 0 to length - 1 do - next scanner - done; - if scanner.ch = '\'' then ( - let contents = - (String.sub [@doesNotRaise]) scanner.src offset length - in - next scanner; - Token.Codepoint {c = codepoint; original = contents}) - else ( - scanner.ch <- ch; - scanner.offset <- offset; - SingleQuote)) + match (peek scanner, peek2 scanner) with + | '\\', '"' -> + (* careful with this one! We're next-ing _once_ (not twice), + then relying on matching on the quote *) + next scanner; + SingleQuote + | '\\', _ -> + next2 scanner; + scanEscape scanner + | ch, '\'' -> + let offset = scanner.offset + 1 in + next3 scanner; + Token.Codepoint + { + c = Char.code ch; + original = (String.sub [@doesNotRaise]) scanner.src offset 1; + } + | ch, _ -> + next scanner; + let offset = scanner.offset in + let codepoint, length = + Res_utf8.decodeCodePoint scanner.offset scanner.src + (String.length scanner.src) + in + for _ = 0 to length - 1 do + next scanner + done; + if scanner.ch = '\'' then ( + let contents = + (String.sub [@doesNotRaise]) scanner.src offset length + in + next scanner; + Token.Codepoint { c = codepoint; original = contents }) + else ( + scanner.ch <- ch; + scanner.offset <- offset; + SingleQuote)) | '!' -> ( - match (peek scanner, peek2 scanner) with - | '=', '=' -> - next3 scanner; - Token.BangEqualEqual - | '=', _ -> - next2 scanner; - Token.BangEqual - | _ -> - next scanner; - Token.Bang) + match (peek scanner, peek2 scanner) with + | '=', '=' -> + next3 scanner; + Token.BangEqualEqual + | '=', _ -> + next2 scanner; + Token.BangEqual + | _ -> + next scanner; + Token.Bang) | '=' -> ( - match (peek scanner, peek2 scanner) with - | '=', '=' -> - next3 scanner; - Token.EqualEqualEqual - | '=', _ -> - next2 scanner; - Token.EqualEqual - | '>', _ -> - next2 scanner; - Token.EqualGreater - | _ -> - next scanner; - Token.Equal) + match (peek scanner, peek2 scanner) with + | '=', '=' -> + next3 scanner; + Token.EqualEqualEqual + | '=', _ -> + next2 scanner; + Token.EqualEqual + | '>', _ -> + next2 scanner; + Token.EqualGreater + | _ -> + next scanner; + Token.Equal) (* special cases *) | ch when ch == hackyEOFChar -> - next scanner; - Token.Eof + next scanner; + Token.Eof | ch -> - (* if we arrive here, we're dealing with an unknown character, - * report the error and continue scanning… *) - next scanner; - let endPos = position scanner in - scanner.err ~startPos ~endPos (Diagnostics.unknownUchar ch); - let _, _, token = scan scanner in - token + (* if we arrive here, we're dealing with an unknown character, + * report the error and continue scanning… *) + next scanner; + let endPos = position scanner in + scanner.err ~startPos ~endPos (Diagnostics.unknownUchar ch); + let _, _, token = scan scanner in + token in let endPos = position scanner in (* _printDebug ~startPos ~endPos scanner token; *) @@ -296403,36 +296684,36 @@ let tryAdvanceQuotedString scanner = let rec scanContents tag = match scanner.ch with | '|' -> ( - next scanner; - match scanner.ch with - | 'a' .. 'z' -> - let startOff = scanner.offset in - skipLowerCaseChars scanner; - let suffix = - (String.sub [@doesNotRaise]) scanner.src startOff - (scanner.offset - startOff) - in - if tag = suffix then - if scanner.ch = '}' then next scanner else scanContents tag - else scanContents tag - | '}' -> next scanner - | _ -> scanContents tag) + next scanner; + match scanner.ch with + | 'a' .. 'z' -> + let startOff = scanner.offset in + skipLowerCaseChars scanner; + let suffix = + (String.sub [@doesNotRaise]) scanner.src startOff + (scanner.offset - startOff) + in + if tag = suffix then + if scanner.ch = '}' then next scanner else scanContents tag + else scanContents tag + | '}' -> next scanner + | _ -> scanContents tag) | ch when ch == hackyEOFChar -> - (* TODO: why is this place checking EOF and not others? *) - () + (* TODO: why is this place checking EOF and not others? *) + () | _ -> - next scanner; - scanContents tag + next scanner; + scanContents tag in match scanner.ch with | 'a' .. 'z' -> - let startOff = scanner.offset in - skipLowerCaseChars scanner; - let tag = - (String.sub [@doesNotRaise]) scanner.src startOff - (scanner.offset - startOff) - in - if scanner.ch = '|' then scanContents tag + let startOff = scanner.offset in + skipLowerCaseChars scanner; + let tag = + (String.sub [@doesNotRaise]) scanner.src startOff + (scanner.offset - startOff) + in + if scanner.ch = '|' then scanContents tag | '|' -> scanContents "" | _ -> () @@ -296447,31 +296728,30 @@ module Diagnostics = Res_diagnostics module Comment = Res_comment type mode = ParseForTypeChecker | Default - type regionStatus = Report | Silent type t = { - mode: mode; - mutable scanner: Scanner.t; - mutable token: Token.t; - mutable startPos: Lexing.position; - mutable endPos: Lexing.position; - mutable prevEndPos: Lexing.position; - mutable breadcrumbs: (Grammar.t * Lexing.position) list; - mutable errors: Reporting.parseError list; - mutable diagnostics: Diagnostics.t list; - mutable comments: Comment.t list; - mutable regions: regionStatus ref list; + mode : mode; + mutable scanner : Scanner.t; + mutable token : Token.t; + mutable startPos : Lexing.position; + mutable endPos : Lexing.position; + mutable prevEndPos : Lexing.position; + mutable breadcrumbs : (Grammar.t * Lexing.position) list; + mutable errors : Reporting.parseError list; + mutable diagnostics : Diagnostics.t list; + mutable comments : Comment.t list; + mutable regions : regionStatus ref list; } val make : ?mode:mode -> string -> string -> t - val expect : ?grammar:Grammar.t -> Token.t -> t -> unit val optional : t -> Token.t -> bool val next : ?prevEndPos:Lexing.position -> t -> unit val nextUnsafe : t -> unit (* Does not assert on Eof, makes no progress *) val nextTemplateLiteralToken : t -> unit val lookahead : t -> (t -> 'a) -> 'a + val err : ?startPos:Lexing.position -> ?endPos:Lexing.position -> @@ -296481,10 +296761,8 @@ val err : val leaveBreadcrumb : t -> Grammar.t -> unit val eatBreadcrumb : t -> unit - val beginRegion : t -> unit val endRegion : t -> unit - val checkProgress : prevEndPos:Lexing.position -> result:'a -> t -> 'a option end = struct @@ -296494,51 +296772,42 @@ module Diagnostics = Res_diagnostics module Token = Res_token module Grammar = Res_grammar module Reporting = Res_reporting - module Comment = Res_comment type mode = ParseForTypeChecker | Default - type regionStatus = Report | Silent type t = { - mode: mode; - mutable scanner: Scanner.t; - mutable token: Token.t; - mutable startPos: Lexing.position; - mutable endPos: Lexing.position; - mutable prevEndPos: Lexing.position; - mutable breadcrumbs: (Grammar.t * Lexing.position) list; - mutable errors: Reporting.parseError list; - mutable diagnostics: Diagnostics.t list; - mutable comments: Comment.t list; - mutable regions: regionStatus ref list; + mode : mode; + mutable scanner : Scanner.t; + mutable token : Token.t; + mutable startPos : Lexing.position; + mutable endPos : Lexing.position; + mutable prevEndPos : Lexing.position; + mutable breadcrumbs : (Grammar.t * Lexing.position) list; + mutable errors : Reporting.parseError list; + mutable diagnostics : Diagnostics.t list; + mutable comments : Comment.t list; + mutable regions : regionStatus ref list; } let err ?startPos ?endPos p error = match p.regions with - | ({contents = Report} as region) :: _ -> - let d = - Diagnostics.make - ~startPos: - (match startPos with - | Some pos -> pos - | None -> p.startPos) - ~endPos: - (match endPos with - | Some pos -> pos - | None -> p.endPos) - error - in - p.diagnostics <- d :: p.diagnostics; - region := Silent + | ({ contents = Report } as region) :: _ -> + let d = + Diagnostics.make + ~startPos:(match startPos with Some pos -> pos | None -> p.startPos) + ~endPos:(match endPos with Some pos -> pos | None -> p.endPos) + error + in + p.diagnostics <- d :: p.diagnostics; + region := Silent | _ -> () let beginRegion p = p.regions <- ref Report :: p.regions + let endRegion p = - match p.regions with - | [] -> () - | _ :: rest -> p.regions <- rest + match p.regions with [] -> () | _ :: rest -> p.regions <- rest let docCommentToAttributeToken comment = let txt = Comment.txt comment in @@ -296555,35 +296824,31 @@ let moduleCommentToAttributeToken comment = * previous token to facilite comment interleaving *) let rec next ?prevEndPos p = if p.token = Eof then assert false; - let prevEndPos = - match prevEndPos with - | Some pos -> pos - | None -> p.endPos - in + let prevEndPos = match prevEndPos with Some pos -> pos | None -> p.endPos in let startPos, endPos, token = Scanner.scan p.scanner in match token with | Comment c -> - if Comment.isDocComment c then ( - p.token <- docCommentToAttributeToken c; - p.prevEndPos <- prevEndPos; - p.startPos <- startPos; - p.endPos <- endPos) - else if Comment.isModuleComment c then ( - p.token <- moduleCommentToAttributeToken c; + if Comment.isDocComment c then ( + p.token <- docCommentToAttributeToken c; + p.prevEndPos <- prevEndPos; + p.startPos <- startPos; + p.endPos <- endPos) + else if Comment.isModuleComment c then ( + p.token <- moduleCommentToAttributeToken c; + p.prevEndPos <- prevEndPos; + p.startPos <- startPos; + p.endPos <- endPos) + else ( + Comment.setPrevTokEndPos c p.endPos; + p.comments <- c :: p.comments; + p.prevEndPos <- p.endPos; + p.endPos <- endPos; + next ~prevEndPos p) + | _ -> + p.token <- token; p.prevEndPos <- prevEndPos; p.startPos <- startPos; - p.endPos <- endPos) - else ( - Comment.setPrevTokEndPos c p.endPos; - p.comments <- c :: p.comments; - p.prevEndPos <- p.endPos; - p.endPos <- endPos; - next ~prevEndPos p) - | _ -> - p.token <- token; - p.prevEndPos <- prevEndPos; - p.startPos <- startPos; - p.endPos <- endPos + p.endPos <- endPos let nextUnsafe p = if p.token <> Eof then next p @@ -296611,7 +296876,7 @@ let make ?(mode = ParseForTypeChecker) src filename = errors = []; diagnostics = []; comments = []; - regions = [ref Report]; + regions = [ ref Report ]; } in parserState.scanner.err <- @@ -296626,9 +296891,7 @@ let leaveBreadcrumb p circumstance = p.breadcrumbs <- crumb :: p.breadcrumbs let eatBreadcrumb p = - match p.breadcrumbs with - | [] -> () - | _ :: crumbs -> p.breadcrumbs <- crumbs + match p.breadcrumbs with [] -> () | _ :: crumbs -> p.breadcrumbs <- crumbs let optional p token = if p.token = token then @@ -296697,7 +296960,7 @@ module Scanner = Res_scanner module Parser = Res_parser let mkLoc startLoc endLoc = - Location.{loc_start = startLoc; loc_end = endLoc; loc_ghost = false} + Location.{ loc_start = startLoc; loc_end = endLoc; loc_ghost = false } module Recover = struct let defaultExpr () = @@ -296721,16 +296984,15 @@ module Recover = struct let recoverEqualGreater p = Parser.expect EqualGreater p; - match p.Parser.token with - | MinusGreater -> Parser.next p - | _ -> () + match p.Parser.token with MinusGreater -> Parser.next p | _ -> () let shouldAbortListParse p = let rec check breadcrumbs = match breadcrumbs with | [] -> false | (grammar, _) :: rest -> - if Grammar.isPartOfList grammar p.Parser.token then true else check rest + if Grammar.isPartOfList grammar p.Parser.token then true + else check rest in check p.breadcrumbs end @@ -296775,7 +297037,7 @@ module ErrorMessages = struct or be a number (e.g. #742)" let experimentalIfLet expr = - let switchExpr = {expr with Parsetree.pexp_attributes = []} in + let switchExpr = { expr with Parsetree.pexp_attributes = [] } in Doc.concat [ Doc.text "If-let is currently highly experimental."; @@ -296793,12 +297055,13 @@ module ErrorMessages = struct let typeParam = "A type param consists of a singlequote followed by a name like `'a` or \ `'A`" + let typeVar = "A type variable consists of a singlequote followed by a name like `'a` or \ `'A`" let attributeWithoutNode (attr : Parsetree.attribute) = - let {Asttypes.txt = attrName}, _ = attr in + let { Asttypes.txt = attrName }, _ = attr in "Did you forget to attach `" ^ attrName ^ "` to an item?\n Standalone attributes start with `@@` like: `@@" ^ attrName ^ "`" @@ -296845,10 +297108,13 @@ let makeAwaitAttr loc = (Location.mkloc "res.await" loc, Parsetree.PStr []) let makeAsyncAttr loc = (Location.mkloc "res.async" loc, Parsetree.PStr []) let makeExpressionOptional ~optional (e : Parsetree.expression) = - if optional then {e with pexp_attributes = optionalAttr :: e.pexp_attributes} + if optional then + { e with pexp_attributes = optionalAttr :: e.pexp_attributes } else e + let makePatternOptional ~optional (p : Parsetree.pattern) = - if optional then {p with ppat_attributes = optionalAttr :: p.ppat_attributes} + if optional then + { p with ppat_attributes = optionalAttr :: p.ppat_attributes } else p let suppressFragileMatchWarningAttr = @@ -296858,32 +297124,32 @@ let suppressFragileMatchWarningAttr = Ast_helper.Str.eval (Ast_helper.Exp.constant (Pconst_string ("-4", None))); ] ) + let makeBracesAttr loc = (Location.mkloc "ns.braces" loc, Parsetree.PStr []) let templateLiteralAttr = (Location.mknoloc "res.template", Parsetree.PStr []) - let spreadAttr = (Location.mknoloc "res.spread", Parsetree.PStr []) type typDefOrExt = | TypeDef of { - recFlag: Asttypes.rec_flag; - types: Parsetree.type_declaration list; + recFlag : Asttypes.rec_flag; + types : Parsetree.type_declaration list; } | TypeExt of Parsetree.type_extension type labelledParameter = | TermParameter of { - uncurried: bool; - attrs: Parsetree.attributes; - label: Asttypes.arg_label; - expr: Parsetree.expression option; - pat: Parsetree.pattern; - pos: Lexing.position; + uncurried : bool; + attrs : Parsetree.attributes; + label : Asttypes.arg_label; + expr : Parsetree.expression option; + pat : Parsetree.pattern; + pos : Lexing.position; } | TypeParameter of { - uncurried: bool; - attrs: Parsetree.attributes; - locs: string Location.loc list; - pos: Lexing.position; + uncurried : bool; + attrs : Parsetree.attributes; + locs : string Location.loc list; + pos : Lexing.position; } type recordPatternItem = @@ -296906,17 +297172,17 @@ let rec goToClosing closingToken state = | Rbrace, Rbrace | Rbracket, Rbracket | GreaterThan, GreaterThan -> - Parser.next state; - () + Parser.next state; + () | ((Token.Lbracket | Lparen | Lbrace | List | LessThan) as t), _ -> - Parser.next state; - goToClosing (getClosingToken t) state; - goToClosing closingToken state + Parser.next state; + goToClosing (getClosingToken t) state; + goToClosing closingToken state | (Rparen | Token.Rbrace | Rbracket | Eof), _ -> - () (* TODO: how do report errors here? *) + () (* TODO: how do report errors here? *) | _ -> - Parser.next state; - goToClosing closingToken state + Parser.next state; + goToClosing closingToken state (* Madness *) let isEs6ArrowExpression ~inTernary p = @@ -296926,75 +297192,75 @@ let isEs6ArrowExpression ~inTernary p = | _ -> ()); match state.Parser.token with | Lident _ | Underscore -> ( - Parser.next state; - match state.Parser.token with - (* Don't think that this valid - * Imagine: let x = (a: int) - * This is a parenthesized expression with a type constraint, wait for - * the arrow *) - (* | Colon when not inTernary -> true *) - | EqualGreater -> true - | _ -> false) - | Lparen -> ( - let prevEndPos = state.prevEndPos in - Parser.next state; - match state.token with - (* arrived at `()` here *) - | Rparen -> ( Parser.next state; match state.Parser.token with - (* arrived at `() :` here *) - | Colon when not inTernary -> ( - Parser.next state; - match state.Parser.token with - (* arrived at `() :typ` here *) - | Lident _ -> ( + (* Don't think that this valid + * Imagine: let x = (a: int) + * This is a parenthesized expression with a type constraint, wait for + * the arrow *) + (* | Colon when not inTernary -> true *) + | EqualGreater -> true + | _ -> false) + | Lparen -> ( + let prevEndPos = state.prevEndPos in + Parser.next state; + match state.token with + (* arrived at `()` here *) + | Rparen -> ( Parser.next state; - (match state.Parser.token with - (* arrived at `() :typ<` here *) - | LessThan -> - Parser.next state; - goToClosing GreaterThan state - | _ -> ()); match state.Parser.token with - (* arrived at `() :typ =>` or `() :typ<'a,'b> =>` here *) + (* arrived at `() :` here *) + | Colon when not inTernary -> ( + Parser.next state; + match state.Parser.token with + (* arrived at `() :typ` here *) + | Lident _ -> ( + Parser.next state; + (match state.Parser.token with + (* arrived at `() :typ<` here *) + | LessThan -> + Parser.next state; + goToClosing GreaterThan state + | _ -> ()); + match state.Parser.token with + (* arrived at `() :typ =>` or `() :typ<'a,'b> =>` here *) + | EqualGreater -> true + | _ -> false) + | _ -> true) | EqualGreater -> true | _ -> false) - | _ -> true) - | EqualGreater -> true - | _ -> false) - | Dot (* uncurried *) -> true - | Tilde -> true - | Backtick -> - false - (* (` always indicates the start of an expr, can't be es6 parameter *) - | _ -> ( - goToClosing Rparen state; - match state.Parser.token with - | EqualGreater -> true - (* | Lbrace TODO: detect missing =>, is this possible? *) - | Colon when not inTernary -> true - | Rparen -> - (* imagine having something as : - * switch colour { - * | Red - * when l == l' - * || (&Clflags.classic && (l == Nolabel && !is_optional(l'))) => (t1, t2) - * We'll arrive at the outer rparen just before the =>. - * This is not an es6 arrow. - * *) - false + | Dot (* uncurried *) -> true + | Tilde -> true + | Backtick -> + false + (* (` always indicates the start of an expr, can't be es6 parameter *) | _ -> ( - Parser.nextUnsafe state; - (* error recovery, peek at the next token, - * (elements, providerId] => { - * in the example above, we have an unbalanced ] here - *) - match state.Parser.token with - | EqualGreater when state.startPos.pos_lnum == prevEndPos.pos_lnum - -> - true - | _ -> false))) + goToClosing Rparen state; + match state.Parser.token with + | EqualGreater -> true + (* | Lbrace TODO: detect missing =>, is this possible? *) + | Colon when not inTernary -> true + | Rparen -> + (* imagine having something as : + * switch colour { + * | Red + * when l == l' + * || (&Clflags.classic && (l == Nolabel && !is_optional(l'))) => (t1, t2) + * We'll arrive at the outer rparen just before the =>. + * This is not an es6 arrow. + * *) + false + | _ -> ( + Parser.nextUnsafe state; + (* error recovery, peek at the next token, + * (elements, providerId] => { + * in the example above, we have an unbalanced ] here + *) + match state.Parser.token with + | EqualGreater + when state.startPos.pos_lnum == prevEndPos.pos_lnum -> + true + | _ -> false))) | _ -> false) let isEs6ArrowFunctor p = @@ -297007,38 +297273,32 @@ let isEs6ArrowFunctor p = (* | _ -> false *) (* end *) | Lparen -> ( - Parser.next state; - match state.token with - | Rparen -> ( Parser.next state; match state.token with - | Colon | EqualGreater -> true - | _ -> false) - | _ -> ( - goToClosing Rparen state; - match state.Parser.token with - | EqualGreater | Lbrace -> true - | Colon -> true - | _ -> false)) + | Rparen -> ( + Parser.next state; + match state.token with Colon | EqualGreater -> true | _ -> false) + | _ -> ( + goToClosing Rparen state; + match state.Parser.token with + | EqualGreater | Lbrace -> true + | Colon -> true + | _ -> false)) | _ -> false) let isEs6ArrowType p = Parser.lookahead p (fun state -> match state.Parser.token with | Lparen -> ( - Parser.next state; - match state.Parser.token with - | Rparen -> ( Parser.next state; match state.Parser.token with - | EqualGreater -> true - | _ -> false) - | Tilde | Dot -> true - | _ -> ( - goToClosing Rparen state; - match state.Parser.token with - | EqualGreater -> true - | _ -> false)) + | Rparen -> ( + Parser.next state; + match state.Parser.token with EqualGreater -> true | _ -> false) + | Tilde | Dot -> true + | _ -> ( + goToClosing Rparen state; + match state.Parser.token with EqualGreater -> true | _ -> false)) | Tilde -> true | _ -> false) @@ -297074,71 +297334,76 @@ let negateString s = let makeUnaryExpr startPos tokenEnd token operand = match (token, operand.Parsetree.pexp_desc) with | (Token.Plus | PlusDot), Pexp_constant (Pconst_integer _ | Pconst_float _) -> - operand + operand | Minus, Pexp_constant (Pconst_integer (n, m)) -> - { - operand with - pexp_desc = Pexp_constant (Pconst_integer (negateString n, m)); - } + { + operand with + pexp_desc = Pexp_constant (Pconst_integer (negateString n, m)); + } | (Minus | MinusDot), Pexp_constant (Pconst_float (n, m)) -> - {operand with pexp_desc = Pexp_constant (Pconst_float (negateString n, m))} + { + operand with + pexp_desc = Pexp_constant (Pconst_float (negateString n, m)); + } | (Token.Plus | PlusDot | Minus | MinusDot), _ -> - let tokenLoc = mkLoc startPos tokenEnd in - let operator = "~" ^ Token.toString token in - Ast_helper.Exp.apply - ~loc:(mkLoc startPos operand.Parsetree.pexp_loc.loc_end) - (Ast_helper.Exp.ident ~loc:tokenLoc - (Location.mkloc (Longident.Lident operator) tokenLoc)) - [(Nolabel, operand)] + let tokenLoc = mkLoc startPos tokenEnd in + let operator = "~" ^ Token.toString token in + Ast_helper.Exp.apply + ~loc:(mkLoc startPos operand.Parsetree.pexp_loc.loc_end) + (Ast_helper.Exp.ident ~loc:tokenLoc + (Location.mkloc (Longident.Lident operator) tokenLoc)) + [ (Nolabel, operand) ] | Token.Bang, _ -> - let tokenLoc = mkLoc startPos tokenEnd in - Ast_helper.Exp.apply - ~loc:(mkLoc startPos operand.Parsetree.pexp_loc.loc_end) - (Ast_helper.Exp.ident ~loc:tokenLoc - (Location.mkloc (Longident.Lident "not") tokenLoc)) - [(Nolabel, operand)] + let tokenLoc = mkLoc startPos tokenEnd in + Ast_helper.Exp.apply + ~loc:(mkLoc startPos operand.Parsetree.pexp_loc.loc_end) + (Ast_helper.Exp.ident ~loc:tokenLoc + (Location.mkloc (Longident.Lident "not") tokenLoc)) + [ (Nolabel, operand) ] | _ -> operand let makeListExpression loc seq extOpt = let rec handleSeq = function | [] -> ( - match extOpt with - | Some ext -> ext - | None -> - let loc = {loc with Location.loc_ghost = true} in - let nil = Location.mkloc (Longident.Lident "[]") loc in - Ast_helper.Exp.construct ~loc nil None) + match extOpt with + | Some ext -> ext + | None -> + let loc = { loc with Location.loc_ghost = true } in + let nil = Location.mkloc (Longident.Lident "[]") loc in + Ast_helper.Exp.construct ~loc nil None) | e1 :: el -> - let exp_el = handleSeq el in - let loc = - mkLoc e1.Parsetree.pexp_loc.Location.loc_start exp_el.pexp_loc.loc_end - in - let arg = Ast_helper.Exp.tuple ~loc [e1; exp_el] in - Ast_helper.Exp.construct ~loc - (Location.mkloc (Longident.Lident "::") loc) - (Some arg) + let exp_el = handleSeq el in + let loc = + mkLoc e1.Parsetree.pexp_loc.Location.loc_start exp_el.pexp_loc.loc_end + in + let arg = Ast_helper.Exp.tuple ~loc [ e1; exp_el ] in + Ast_helper.Exp.construct ~loc + (Location.mkloc (Longident.Lident "::") loc) + (Some arg) in let expr = handleSeq seq in - {expr with pexp_loc = loc} + { expr with pexp_loc = loc } let makeListPattern loc seq ext_opt = let rec handle_seq = function | [] -> - let base_case = - match ext_opt with - | Some ext -> ext - | None -> - let loc = {loc with Location.loc_ghost = true} in - let nil = {Location.txt = Longident.Lident "[]"; loc} in - Ast_helper.Pat.construct ~loc nil None - in - base_case + let base_case = + match ext_opt with + | Some ext -> ext + | None -> + let loc = { loc with Location.loc_ghost = true } in + let nil = { Location.txt = Longident.Lident "[]"; loc } in + Ast_helper.Pat.construct ~loc nil None + in + base_case | p1 :: pl -> - let pat_pl = handle_seq pl in - let loc = mkLoc p1.Parsetree.ppat_loc.loc_start pat_pl.ppat_loc.loc_end in - let arg = Ast_helper.Pat.mk ~loc (Ppat_tuple [p1; pat_pl]) in - Ast_helper.Pat.mk ~loc - (Ppat_construct (Location.mkloc (Longident.Lident "::") loc, Some arg)) + let pat_pl = handle_seq pl in + let loc = + mkLoc p1.Parsetree.ppat_loc.loc_start pat_pl.ppat_loc.loc_end + in + let arg = Ast_helper.Pat.mk ~loc (Ppat_tuple [ p1; pat_pl ]) in + Ast_helper.Pat.mk ~loc + (Ppat_construct (Location.mkloc (Longident.Lident "::") loc, Some arg)) in handle_seq seq @@ -297154,7 +297419,7 @@ let makeNewtypes ~attrs ~loc newtypes exp = (fun newtype exp -> Ast_helper.Exp.mk ~loc (Pexp_newtype (newtype, exp))) newtypes exp in - {expr with pexp_attributes = attrs} + { expr with pexp_attributes = attrs } (* locally abstract types syntax sugar * Transforms @@ -297184,23 +297449,23 @@ let processUnderscoreApplication args = let hidden_var = "__x" in let check_arg ((lab, exp) as arg) = match exp.Parsetree.pexp_desc with - | Pexp_ident ({txt = Lident "_"} as id) -> - let new_id = Location.mkloc (Longident.Lident hidden_var) id.loc in - let new_exp = Ast_helper.Exp.mk (Pexp_ident new_id) ~loc:exp.pexp_loc in - exp_question := Some new_exp; - (lab, new_exp) + | Pexp_ident ({ txt = Lident "_" } as id) -> + let new_id = Location.mkloc (Longident.Lident hidden_var) id.loc in + let new_exp = Ast_helper.Exp.mk (Pexp_ident new_id) ~loc:exp.pexp_loc in + exp_question := Some new_exp; + (lab, new_exp) | _ -> arg in let args = List.map check_arg args in let wrap (exp_apply : Parsetree.expression) = match !exp_question with - | Some {pexp_loc = loc} -> - let pattern = - Ast_helper.Pat.mk - (Ppat_var (Location.mkloc hidden_var loc)) - ~loc:Location.none - in - Ast_helper.Exp.mk (Pexp_fun (Nolabel, None, pattern, exp_apply)) ~loc + | Some { pexp_loc = loc } -> + let pattern = + Ast_helper.Pat.mk + (Ppat_var (Location.mkloc hidden_var loc)) + ~loc:Location.none + in + Ast_helper.Exp.mk (Pexp_fun (Nolabel, None, pattern, exp_apply)) ~loc | None -> exp_apply in (args, wrap) @@ -297209,11 +297474,12 @@ let processUnderscoreApplication args = let removeModuleNameFromPunnedFieldValue exp = match exp.Parsetree.pexp_desc with | Pexp_ident pathIdent -> - { - exp with - pexp_desc = - Pexp_ident {pathIdent with txt = Lident (Longident.last pathIdent.txt)}; - } + { + exp with + pexp_desc = + Pexp_ident + { pathIdent with txt = Lident (Longident.last pathIdent.txt) }; + } | _ -> exp let rec parseLident p = @@ -297234,66 +297500,65 @@ let rec parseLident p = Parser.err p (Diagnostics.lident p.Parser.token); Parser.next p; loop p; - match p.Parser.token with - | Lident _ -> Some () - | _ -> None + match p.Parser.token with Lident _ -> Some () | _ -> None in let startPos = p.Parser.startPos in match p.Parser.token with | Lident ident -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - (ident, loc) + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + (ident, loc) | Eof -> - Parser.err ~startPos p (Diagnostics.unexpected p.Parser.token p.breadcrumbs); - ("_", mkLoc startPos p.prevEndPos) + Parser.err ~startPos p + (Diagnostics.unexpected p.Parser.token p.breadcrumbs); + ("_", mkLoc startPos p.prevEndPos) | _ -> ( - match recoverLident p with - | Some () -> parseLident p - | None -> ("_", mkLoc startPos p.prevEndPos)) + match recoverLident p with + | Some () -> parseLident p + | None -> ("_", mkLoc startPos p.prevEndPos)) let parseIdent ~msg ~startPos p = match p.Parser.token with | Lident ident | Uident ident -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - (ident, loc) + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + (ident, loc) | token when Token.isKeyword token && p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> - let tokenTxt = Token.toString token in - let msg = - "`" ^ tokenTxt - ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" ^ tokenTxt - ^ "\"" - in - Parser.err ~startPos p (Diagnostics.message msg); - Parser.next p; - (tokenTxt, mkLoc startPos p.prevEndPos) + let tokenTxt = Token.toString token in + let msg = + "`" ^ tokenTxt + ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" + ^ tokenTxt ^ "\"" + in + Parser.err ~startPos p (Diagnostics.message msg); + Parser.next p; + (tokenTxt, mkLoc startPos p.prevEndPos) | _token -> - Parser.err ~startPos p (Diagnostics.message msg); - Parser.next p; - ("", mkLoc startPos p.prevEndPos) + Parser.err ~startPos p (Diagnostics.message msg); + Parser.next p; + ("", mkLoc startPos p.prevEndPos) let parseHashIdent ~startPos p = Parser.expect Hash p; match p.token with | String text -> - Parser.next p; - (text, mkLoc startPos p.prevEndPos) - | Int {i; suffix} -> - let () = - match suffix with - | Some _ -> - Parser.err p - (Diagnostics.message (ErrorMessages.polyVarIntWithSuffix i)) - | None -> () - in - Parser.next p; - (i, mkLoc startPos p.prevEndPos) + Parser.next p; + (text, mkLoc startPos p.prevEndPos) + | Int { i; suffix } -> + let () = + match suffix with + | Some _ -> + Parser.err p + (Diagnostics.message (ErrorMessages.polyVarIntWithSuffix i)) + | None -> () + in + Parser.next p; + (i, mkLoc startPos p.prevEndPos) | Eof -> - Parser.err ~startPos p (Diagnostics.unexpected p.token p.breadcrumbs); - ("", mkLoc startPos p.prevEndPos) + Parser.err ~startPos p (Diagnostics.unexpected p.token p.breadcrumbs); + ("", mkLoc startPos p.prevEndPos) | _ -> parseIdent ~startPos ~msg:ErrorMessages.variantIdent p (* Ldot (Ldot (Lident "Foo", "Bar"), "baz") *) @@ -297311,8 +297576,8 @@ let parseValuePath p = | Lident ident -> Longident.Ldot (path, ident) | Uident uident -> aux p (Ldot (path, uident)) | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Longident.Ldot (path, "_")) + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Longident.Ldot (path, "_")) else ( Parser.err p ~startPos ~endPos:p.prevEndPos (Diagnostics.lident token); path) @@ -297320,16 +297585,16 @@ let parseValuePath p = let ident = match p.Parser.token with | Lident ident -> - Parser.next p; - Longident.Lident ident + Parser.next p; + Longident.Lident ident | Uident ident -> - let res = aux p (Lident ident) in - Parser.nextUnsafe p; - res + let res = aux p (Lident ident) in + Parser.nextUnsafe p; + res | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Parser.nextUnsafe p; - Longident.Lident "_" + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Parser.nextUnsafe p; + Longident.Lident "_" in Location.mkloc ident (mkLoc startPos p.prevEndPos) @@ -297338,24 +297603,26 @@ let parseValuePathAfterDot p = match p.Parser.token with | Lident _ | Uident _ -> parseValuePath p | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Location.mkloc (Longident.Lident "_") (mkLoc startPos p.prevEndPos) + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Location.mkloc (Longident.Lident "_") (mkLoc startPos p.prevEndPos) let parseValuePathTail p startPos ident = let rec loop p path = match p.Parser.token with | Lident ident -> - Parser.next p; - Location.mkloc - (Longident.Ldot (path, ident)) - (mkLoc startPos p.prevEndPos) + Parser.next p; + Location.mkloc + (Longident.Ldot (path, ident)) + (mkLoc startPos p.prevEndPos) | Uident ident -> - Parser.next p; - Parser.expect Dot p; - loop p (Longident.Ldot (path, ident)) + Parser.next p; + Parser.expect Dot p; + loop p (Longident.Ldot (path, ident)) | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Location.mkloc (Longident.Ldot (path, "_")) (mkLoc startPos p.prevEndPos) + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Location.mkloc + (Longident.Ldot (path, "_")) + (mkLoc startPos p.prevEndPos) in loop p ident @@ -297363,21 +297630,21 @@ let parseModuleLongIdentTail ~lowercase p startPos ident = let rec loop p acc = match p.Parser.token with | Lident ident when lowercase -> - Parser.next p; - let lident = Longident.Ldot (acc, ident) in - Location.mkloc lident (mkLoc startPos p.prevEndPos) + Parser.next p; + let lident = Longident.Ldot (acc, ident) in + Location.mkloc lident (mkLoc startPos p.prevEndPos) | Uident ident -> ( - Parser.next p; - let endPos = p.prevEndPos in - let lident = Longident.Ldot (acc, ident) in - match p.Parser.token with - | Dot -> Parser.next p; - loop p lident - | _ -> Location.mkloc lident (mkLoc startPos endPos)) + let endPos = p.prevEndPos in + let lident = Longident.Ldot (acc, ident) in + match p.Parser.token with + | Dot -> + Parser.next p; + loop p lident + | _ -> Location.mkloc lident (mkLoc startPos endPos)) | t -> - Parser.err p (Diagnostics.uident t); - Location.mkloc (Longident.Ldot (acc, "_")) (mkLoc startPos p.prevEndPos) + Parser.err p (Diagnostics.uident t); + Location.mkloc (Longident.Ldot (acc, "_")) (mkLoc startPos p.prevEndPos) in loop p ident @@ -297390,22 +297657,22 @@ let parseModuleLongIdent ~lowercase p = let moduleIdent = match p.Parser.token with | Lident ident when lowercase -> - let loc = mkLoc startPos p.endPos in - let lident = Longident.Lident ident in - Parser.next p; - Location.mkloc lident loc + let loc = mkLoc startPos p.endPos in + let lident = Longident.Lident ident in + Parser.next p; + Location.mkloc lident loc | Uident ident -> ( - let lident = Longident.Lident ident in - let endPos = p.endPos in - Parser.next p; - match p.Parser.token with - | Dot -> + let lident = Longident.Lident ident in + let endPos = p.endPos in Parser.next p; - parseModuleLongIdentTail ~lowercase p startPos lident - | _ -> Location.mkloc lident (mkLoc startPos endPos)) + match p.Parser.token with + | Dot -> + Parser.next p; + parseModuleLongIdentTail ~lowercase p startPos lident + | _ -> Location.mkloc lident (mkLoc startPos endPos)) | t -> - Parser.err p (Diagnostics.uident t); - Location.mkloc (Longident.Lident "_") (mkLoc startPos p.prevEndPos) + Parser.err p (Diagnostics.uident t); + Location.mkloc (Longident.Lident "_") (mkLoc startPos p.prevEndPos) in (* Parser.eatBreadcrumb p; *) moduleIdent @@ -297414,31 +297681,31 @@ let verifyJsxOpeningClosingName p nameExpr = let closing = match p.Parser.token with | Lident lident -> - Parser.next p; - Longident.Lident lident + Parser.next p; + Longident.Lident lident | Uident _ -> (parseModuleLongIdent ~lowercase:true p).txt | _ -> Longident.Lident "" in match nameExpr.Parsetree.pexp_desc with | Pexp_ident openingIdent -> - let opening = - let withoutCreateElement = - Longident.flatten openingIdent.txt - |> List.filter (fun s -> s <> "createElement") + let opening = + let withoutCreateElement = + Longident.flatten openingIdent.txt + |> List.filter (fun s -> s <> "createElement") + in + match Longident.unflatten withoutCreateElement with + | Some li -> li + | None -> Longident.Lident "" in - match Longident.unflatten withoutCreateElement with - | Some li -> li - | None -> Longident.Lident "" - in - opening = closing + opening = closing | _ -> assert false let string_of_pexp_ident nameExpr = match nameExpr.Parsetree.pexp_desc with | Pexp_ident openingIdent -> - Longident.flatten openingIdent.txt - |> List.filter (fun s -> s <> "createElement") - |> String.concat "." + Longident.flatten openingIdent.txt + |> List.filter (fun s -> s <> "createElement") + |> String.concat "." | _ -> "" (* open-def ::= @@ -297463,33 +297730,34 @@ let parseConstant p = let isNegative = match p.Parser.token with | Token.Minus -> - Parser.next p; - true + Parser.next p; + true | Plus -> - Parser.next p; - false + Parser.next p; + false | _ -> false in let constant = match p.Parser.token with - | Int {i; suffix} -> - let intTxt = if isNegative then "-" ^ i else i in - Parsetree.Pconst_integer (intTxt, suffix) - | Float {f; suffix} -> - let floatTxt = if isNegative then "-" ^ f else f in - Parsetree.Pconst_float (floatTxt, suffix) + | Int { i; suffix } -> + let intTxt = if isNegative then "-" ^ i else i in + Parsetree.Pconst_integer (intTxt, suffix) + | Float { f; suffix } -> + let floatTxt = if isNegative then "-" ^ f else f in + Parsetree.Pconst_float (floatTxt, suffix) | String s -> - Pconst_string (s, if p.mode = ParseForTypeChecker then Some "js" else None) - | Codepoint {c; original} -> - if p.mode = ParseForTypeChecker then Pconst_char c - else - (* Pconst_char char does not have enough information for formatting. - * When parsing for the printer, we encode the char contents as a string - * with a special prefix. *) - Pconst_string (original, Some "INTERNAL_RES_CHAR_CONTENTS") + Pconst_string + (s, if p.mode = ParseForTypeChecker then Some "js" else None) + | Codepoint { c; original } -> + if p.mode = ParseForTypeChecker then Pconst_char c + else + (* Pconst_char char does not have enough information for formatting. + * When parsing for the printer, we encode the char contents as a string + * with a special prefix. *) + Pconst_string (original, Some "INTERNAL_RES_CHAR_CONTENTS") | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Pconst_string ("", None) + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Pconst_string ("", None) in Parser.nextUnsafe p; constant @@ -297500,63 +297768,63 @@ let parseTemplateConstant ~prefix (p : Parser.t) = Parser.nextTemplateLiteralToken p; match p.token with | TemplateTail (txt, _) -> - Parser.next p; - Parsetree.Pconst_string (txt, prefix) + Parser.next p; + Parsetree.Pconst_string (txt, prefix) | _ -> - let rec skipTokens () = - if p.token <> Eof then ( - Parser.next p; - match p.token with - | Backtick -> + let rec skipTokens () = + if p.token <> Eof then ( Parser.next p; - () - | _ -> skipTokens ()) - in - skipTokens (); - Parser.err ~startPos ~endPos:p.prevEndPos p - (Diagnostics.message ErrorMessages.stringInterpolationInPattern); - Pconst_string ("", None) + match p.token with + | Backtick -> + Parser.next p; + () + | _ -> skipTokens ()) + in + skipTokens (); + Parser.err ~startPos ~endPos:p.prevEndPos p + (Diagnostics.message ErrorMessages.stringInterpolationInPattern); + Pconst_string ("", None) let parseCommaDelimitedRegion p ~grammar ~closing ~f = Parser.leaveBreadcrumb p grammar; let rec loop nodes = match f p with | Some node -> ( - match p.Parser.token with - | Comma -> - Parser.next p; - loop (node :: nodes) - | token when token = closing || token = Eof -> List.rev (node :: nodes) - | _ when Grammar.isListElement grammar p.token -> - (* missing comma between nodes in the region and the current token - * looks like the start of something valid in the current region. - * Example: - * type student<'extraInfo> = { - * name: string, - * age: int - * otherInfo: 'extraInfo - * } - * There is a missing comma between `int` and `otherInfo`. - * `otherInfo` looks like a valid start of the record declaration. - * We report the error here and then continue parsing the region. - *) - Parser.expect Comma p; - loop (node :: nodes) - | _ -> - if - not - (p.token = Eof || p.token = closing - || Recover.shouldAbortListParse p) - then Parser.expect Comma p; - if p.token = Semicolon then Parser.next p; - loop (node :: nodes)) + match p.Parser.token with + | Comma -> + Parser.next p; + loop (node :: nodes) + | token when token = closing || token = Eof -> List.rev (node :: nodes) + | _ when Grammar.isListElement grammar p.token -> + (* missing comma between nodes in the region and the current token + * looks like the start of something valid in the current region. + * Example: + * type student<'extraInfo> = { + * name: string, + * age: int + * otherInfo: 'extraInfo + * } + * There is a missing comma between `int` and `otherInfo`. + * `otherInfo` looks like a valid start of the record declaration. + * We report the error here and then continue parsing the region. + *) + Parser.expect Comma p; + loop (node :: nodes) + | _ -> + if + not + (p.token = Eof || p.token = closing + || Recover.shouldAbortListParse p) + then Parser.expect Comma p; + if p.token = Semicolon then Parser.next p; + loop (node :: nodes)) | None -> - if p.token = Eof || p.token = closing || Recover.shouldAbortListParse p - then List.rev nodes - else ( - Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); - Parser.next p; - loop nodes) + if p.token = Eof || p.token = closing || Recover.shouldAbortListParse p + then List.rev nodes + else ( + Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); + Parser.next p; + loop nodes) in let nodes = loop [] in Parser.eatBreadcrumb p; @@ -297567,41 +297835,41 @@ let parseCommaDelimitedReversedList p ~grammar ~closing ~f = let rec loop nodes = match f p with | Some node -> ( - match p.Parser.token with - | Comma -> - Parser.next p; - loop (node :: nodes) - | token when token = closing || token = Eof -> node :: nodes - | _ when Grammar.isListElement grammar p.token -> - (* missing comma between nodes in the region and the current token - * looks like the start of something valid in the current region. - * Example: - * type student<'extraInfo> = { - * name: string, - * age: int - * otherInfo: 'extraInfo - * } - * There is a missing comma between `int` and `otherInfo`. - * `otherInfo` looks like a valid start of the record declaration. - * We report the error here and then continue parsing the region. - *) - Parser.expect Comma p; - loop (node :: nodes) - | _ -> - if - not - (p.token = Eof || p.token = closing - || Recover.shouldAbortListParse p) - then Parser.expect Comma p; - if p.token = Semicolon then Parser.next p; - loop (node :: nodes)) + match p.Parser.token with + | Comma -> + Parser.next p; + loop (node :: nodes) + | token when token = closing || token = Eof -> node :: nodes + | _ when Grammar.isListElement grammar p.token -> + (* missing comma between nodes in the region and the current token + * looks like the start of something valid in the current region. + * Example: + * type student<'extraInfo> = { + * name: string, + * age: int + * otherInfo: 'extraInfo + * } + * There is a missing comma between `int` and `otherInfo`. + * `otherInfo` looks like a valid start of the record declaration. + * We report the error here and then continue parsing the region. + *) + Parser.expect Comma p; + loop (node :: nodes) + | _ -> + if + not + (p.token = Eof || p.token = closing + || Recover.shouldAbortListParse p) + then Parser.expect Comma p; + if p.token = Semicolon then Parser.next p; + loop (node :: nodes)) | None -> - if p.token = Eof || p.token = closing || Recover.shouldAbortListParse p - then nodes - else ( - Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); - Parser.next p; - loop nodes) + if p.token = Eof || p.token = closing || Recover.shouldAbortListParse p + then nodes + else ( + Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); + Parser.next p; + loop nodes) in let nodes = loop [] in Parser.eatBreadcrumb p; @@ -297613,14 +297881,14 @@ let parseDelimitedRegion p ~grammar ~closing ~f = match f p with | Some node -> loop (node :: nodes) | None -> - if - p.Parser.token = Token.Eof || p.token = closing - || Recover.shouldAbortListParse p - then List.rev nodes - else ( - Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); - Parser.next p; - loop nodes) + if + p.Parser.token = Token.Eof || p.token = closing + || Recover.shouldAbortListParse p + then List.rev nodes + else ( + Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); + Parser.next p; + loop nodes) in let nodes = loop [] in Parser.eatBreadcrumb p; @@ -297632,12 +297900,12 @@ let parseRegion p ~grammar ~f = match f p with | Some node -> loop (node :: nodes) | None -> - if p.Parser.token = Token.Eof || Recover.shouldAbortListParse p then - List.rev nodes - else ( - Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); - Parser.next p; - loop nodes) + if p.Parser.token = Token.Eof || Recover.shouldAbortListParse p then + List.rev nodes + else ( + Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); + Parser.next p; + loop nodes) in let nodes = loop [] in Parser.eatBreadcrumb p; @@ -297670,128 +297938,130 @@ let rec parsePattern ?(alias = true) ?(or_ = true) p = let pat = match p.Parser.token with | (True | False) as token -> - let endPos = p.endPos in - Parser.next p; - let loc = mkLoc startPos endPos in - Ast_helper.Pat.construct ~loc - (Location.mkloc (Longident.Lident (Token.toString token)) loc) - None - | Int _ | String _ | Float _ | Codepoint _ | Minus | Plus -> ( - let c = parseConstant p in - match p.token with - | DotDot -> + let endPos = p.endPos in Parser.next p; - let c2 = parseConstant p in - Ast_helper.Pat.interval ~loc:(mkLoc startPos p.prevEndPos) c c2 - | _ -> Ast_helper.Pat.constant ~loc:(mkLoc startPos p.prevEndPos) c) + let loc = mkLoc startPos endPos in + Ast_helper.Pat.construct ~loc + (Location.mkloc (Longident.Lident (Token.toString token)) loc) + None + | Int _ | String _ | Float _ | Codepoint _ | Minus | Plus -> ( + let c = parseConstant p in + match p.token with + | DotDot -> + Parser.next p; + let c2 = parseConstant p in + Ast_helper.Pat.interval ~loc:(mkLoc startPos p.prevEndPos) c c2 + | _ -> Ast_helper.Pat.constant ~loc:(mkLoc startPos p.prevEndPos) c) | Backtick -> - let constant = parseTemplateConstant ~prefix:(Some "js") p in - Ast_helper.Pat.constant ~attrs:[templateLiteralAttr] - ~loc:(mkLoc startPos p.prevEndPos) - constant + let constant = parseTemplateConstant ~prefix:(Some "js") p in + Ast_helper.Pat.constant ~attrs:[ templateLiteralAttr ] + ~loc:(mkLoc startPos p.prevEndPos) + constant | Lparen -> ( - Parser.next p; - match p.token with - | Rparen -> Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let lid = Location.mkloc (Longident.Lident "()") loc in - Ast_helper.Pat.construct ~loc lid None - | _ -> ( - let pat = parseConstrainedPattern p in match p.token with - | Comma -> - Parser.next p; - parseTuplePattern ~attrs ~first:pat ~startPos p - | _ -> - Parser.expect Rparen p; - let loc = mkLoc startPos p.prevEndPos in - { - pat with - ppat_loc = loc; - ppat_attributes = attrs @ pat.Parsetree.ppat_attributes; - })) + | Rparen -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let lid = Location.mkloc (Longident.Lident "()") loc in + Ast_helper.Pat.construct ~loc lid None + | _ -> ( + let pat = parseConstrainedPattern p in + match p.token with + | Comma -> + Parser.next p; + parseTuplePattern ~attrs ~first:pat ~startPos p + | _ -> + Parser.expect Rparen p; + let loc = mkLoc startPos p.prevEndPos in + { + pat with + ppat_loc = loc; + ppat_attributes = attrs @ pat.Parsetree.ppat_attributes; + })) | Lbracket -> parseArrayPattern ~attrs p | Lbrace -> parseRecordPattern ~attrs p | Underscore -> - let endPos = p.endPos in - let loc = mkLoc startPos endPos in - Parser.next p; - Ast_helper.Pat.any ~loc ~attrs () + let endPos = p.endPos in + let loc = mkLoc startPos endPos in + Parser.next p; + Ast_helper.Pat.any ~loc ~attrs () | Lident ident -> ( - let endPos = p.endPos in - let loc = mkLoc startPos endPos in - Parser.next p; - match p.token with - | Backtick -> - let constant = parseTemplateConstant ~prefix:(Some ident) p in - Ast_helper.Pat.constant ~loc:(mkLoc startPos p.prevEndPos) constant - | _ -> Ast_helper.Pat.var ~loc ~attrs (Location.mkloc ident loc)) + let endPos = p.endPos in + let loc = mkLoc startPos endPos in + Parser.next p; + match p.token with + | Backtick -> + let constant = parseTemplateConstant ~prefix:(Some ident) p in + Ast_helper.Pat.constant ~loc:(mkLoc startPos p.prevEndPos) constant + | _ -> Ast_helper.Pat.var ~loc ~attrs (Location.mkloc ident loc)) | Uident _ -> ( - let constr = parseModuleLongIdent ~lowercase:false p in - match p.Parser.token with - | Lparen -> parseConstructorPatternArgs p constr startPos attrs - | _ -> Ast_helper.Pat.construct ~loc:constr.loc ~attrs constr None) + let constr = parseModuleLongIdent ~lowercase:false p in + match p.Parser.token with + | Lparen -> parseConstructorPatternArgs p constr startPos attrs + | _ -> Ast_helper.Pat.construct ~loc:constr.loc ~attrs constr None) | Hash -> ( - Parser.next p; - if p.Parser.token == DotDotDot then ( Parser.next p; - let ident = parseValuePath p in - let loc = mkLoc startPos ident.loc.loc_end in - Ast_helper.Pat.type_ ~loc ~attrs ident) - else - let ident, loc = - match p.token with - | String text -> - Parser.next p; - (text, mkLoc startPos p.prevEndPos) - | Int {i; suffix} -> - let () = - match suffix with - | Some _ -> - Parser.err p - (Diagnostics.message (ErrorMessages.polyVarIntWithSuffix i)) - | None -> () - in - Parser.next p; - (i, mkLoc startPos p.prevEndPos) - | Eof -> - Parser.err ~startPos p - (Diagnostics.unexpected p.token p.breadcrumbs); - ("", mkLoc startPos p.prevEndPos) - | _ -> parseIdent ~msg:ErrorMessages.variantIdent ~startPos p - in - match p.Parser.token with - | Lparen -> parseVariantPatternArgs p ident startPos attrs - | _ -> Ast_helper.Pat.variant ~loc ~attrs ident None) + if p.Parser.token == DotDotDot then ( + Parser.next p; + let ident = parseValuePath p in + let loc = mkLoc startPos ident.loc.loc_end in + Ast_helper.Pat.type_ ~loc ~attrs ident) + else + let ident, loc = + match p.token with + | String text -> + Parser.next p; + (text, mkLoc startPos p.prevEndPos) + | Int { i; suffix } -> + let () = + match suffix with + | Some _ -> + Parser.err p + (Diagnostics.message + (ErrorMessages.polyVarIntWithSuffix i)) + | None -> () + in + Parser.next p; + (i, mkLoc startPos p.prevEndPos) + | Eof -> + Parser.err ~startPos p + (Diagnostics.unexpected p.token p.breadcrumbs); + ("", mkLoc startPos p.prevEndPos) + | _ -> parseIdent ~msg:ErrorMessages.variantIdent ~startPos p + in + match p.Parser.token with + | Lparen -> parseVariantPatternArgs p ident startPos attrs + | _ -> Ast_helper.Pat.variant ~loc ~attrs ident None) | Exception -> - Parser.next p; - let pat = parsePattern ~alias:false ~or_:false p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.exception_ ~loc ~attrs pat + Parser.next p; + let pat = parsePattern ~alias:false ~or_:false p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Pat.exception_ ~loc ~attrs pat | Lazy -> - Parser.next p; - let pat = parsePattern ~alias:false ~or_:false p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.lazy_ ~loc ~attrs pat + Parser.next p; + let pat = parsePattern ~alias:false ~or_:false p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Pat.lazy_ ~loc ~attrs pat | List -> - Parser.next p; - parseListPattern ~startPos ~attrs p + Parser.next p; + parseListPattern ~startPos ~attrs p | Module -> parseModulePattern ~attrs p | Percent -> - let extension = parseExtension p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.extension ~loc ~attrs extension + let extension = parseExtension p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Pat.extension ~loc ~attrs extension | Eof -> - Parser.err p (Diagnostics.unexpected p.Parser.token p.breadcrumbs); - Recover.defaultPattern () + Parser.err p (Diagnostics.unexpected p.Parser.token p.breadcrumbs); + Recover.defaultPattern () | token -> ( - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - match - skipTokensAndMaybeRetry p ~isStartOfGrammar:Grammar.isAtomicPatternStart - with - | None -> Recover.defaultPattern () - | Some () -> parsePattern p) + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + match + skipTokensAndMaybeRetry p + ~isStartOfGrammar:Grammar.isAtomicPatternStart + with + | None -> Recover.defaultPattern () + | Some () -> parsePattern p) in let pat = if alias then parseAliasPattern ~attrs pat p else pat in if or_ then parseOrPattern pat p else pat @@ -297822,12 +298092,12 @@ and skipTokensAndMaybeRetry p ~isStartOfGrammar = and parseAliasPattern ~attrs pattern p = match p.Parser.token with | As -> - Parser.next p; - let name, loc = parseLident p in - let name = Location.mkloc name loc in - Ast_helper.Pat.alias - ~loc:{pattern.ppat_loc with loc_end = p.prevEndPos} - ~attrs pattern name + Parser.next p; + let name, loc = parseLident p in + let name = Location.mkloc name loc in + Ast_helper.Pat.alias + ~loc:{ pattern.ppat_loc with loc_end = p.prevEndPos } + ~attrs pattern name | _ -> pattern (* or ::= pattern | pattern @@ -297836,12 +298106,15 @@ and parseOrPattern pattern1 p = let rec loop pattern1 = match p.Parser.token with | Bar -> - Parser.next p; - let pattern2 = parsePattern ~or_:false p in - let loc = - {pattern1.Parsetree.ppat_loc with loc_end = pattern2.ppat_loc.loc_end} - in - loop (Ast_helper.Pat.or_ ~loc pattern1 pattern2) + Parser.next p; + let pattern2 = parsePattern ~or_:false p in + let loc = + { + pattern1.Parsetree.ppat_loc with + loc_end = pattern2.ppat_loc.loc_end; + } + in + loop (Ast_helper.Pat.or_ ~loc pattern1 pattern2) | _ -> pattern1 in loop pattern1 @@ -297850,30 +298123,32 @@ and parseNonSpreadPattern ~msg p = let () = match p.Parser.token with | DotDotDot -> - Parser.err p (Diagnostics.message msg); - Parser.next p + Parser.err p (Diagnostics.message msg); + Parser.next p | _ -> () in match p.Parser.token with | token when Grammar.isPatternStart token -> ( - let pat = parsePattern p in - match p.Parser.token with - | Colon -> - Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc pat.ppat_loc.loc_start typ.Parsetree.ptyp_loc.loc_end in - Some (Ast_helper.Pat.constraint_ ~loc pat typ) - | _ -> Some pat) + let pat = parsePattern p in + match p.Parser.token with + | Colon -> + Parser.next p; + let typ = parseTypExpr p in + let loc = + mkLoc pat.ppat_loc.loc_start typ.Parsetree.ptyp_loc.loc_end + in + Some (Ast_helper.Pat.constraint_ ~loc pat typ) + | _ -> Some pat) | _ -> None and parseConstrainedPattern p = let pat = parsePattern p in match p.Parser.token with | Colon -> - Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc pat.ppat_loc.loc_start typ.Parsetree.ptyp_loc.loc_end in - Ast_helper.Pat.constraint_ ~loc pat typ + Parser.next p; + let typ = parseTypExpr p in + let loc = mkLoc pat.ppat_loc.loc_start typ.Parsetree.ptyp_loc.loc_end in + Ast_helper.Pat.constraint_ ~loc pat typ | _ -> pat and parseConstrainedPatternRegion p = @@ -297884,8 +298159,8 @@ and parseConstrainedPatternRegion p = and parseOptionalLabel p = match p.Parser.token with | Question -> - Parser.next p; - true + Parser.next p; + true | _ -> false (* field ::= @@ -297903,13 +298178,13 @@ and parseRecordPatternRowField ~attrs p = let pattern = match p.Parser.token with | Colon -> - Parser.next p; - let optional = parseOptionalLabel p in - let pat = parsePattern p in - makePatternOptional ~optional pat + Parser.next p; + let optional = parseOptionalLabel p in + let pat = parsePattern p in + makePatternOptional ~optional pat | _ -> - Ast_helper.Pat.var ~loc:label.loc ~attrs - (Location.mkloc (Longident.last label.txt) label.loc) + Ast_helper.Pat.var ~loc:label.loc ~attrs + (Location.mkloc (Longident.last label.txt) label.loc) in (label, pattern) @@ -297918,20 +298193,20 @@ and parseRecordPatternRow p = let attrs = parseAttributes p in match p.Parser.token with | DotDotDot -> - Parser.next p; - Some (true, PatField (parseRecordPatternRowField ~attrs p)) + Parser.next p; + Some (true, PatField (parseRecordPatternRowField ~attrs p)) | Uident _ | Lident _ -> - Some (false, PatField (parseRecordPatternRowField ~attrs p)) + Some (false, PatField (parseRecordPatternRowField ~attrs p)) | Question -> ( - Parser.next p; - match p.token with - | Uident _ | Lident _ -> - let lid, pat = parseRecordPatternRowField ~attrs p in - Some (false, PatField (lid, makePatternOptional ~optional:true pat)) - | _ -> None) + Parser.next p; + match p.token with + | Uident _ | Lident _ -> + let lid, pat = parseRecordPatternRowField ~attrs p in + Some (false, PatField (lid, makePatternOptional ~optional:true pat)) + | _ -> None) | Underscore -> - Parser.next p; - Some (false, PatUnderscore) + Parser.next p; + Some (false, PatUnderscore) | _ -> None and parseRecordPattern ~attrs p = @@ -297953,11 +298228,11 @@ and parseRecordPattern ~attrs p = let hasSpread, field = curr in match field with | PatField field -> - (if hasSpread then - let _, pattern = field in - Parser.err ~startPos:pattern.Parsetree.ppat_loc.loc_start p - (Diagnostics.message ErrorMessages.recordPatternSpread)); - (field :: fields, flag) + (if hasSpread then + let _, pattern = field in + Parser.err ~startPos:pattern.Parsetree.ppat_loc.loc_start p + (Diagnostics.message ErrorMessages.recordPatternSpread)); + (field :: fields, flag) | PatUnderscore -> (fields, flag)) ([], flag) rawFields in @@ -297973,9 +298248,9 @@ and parseTuplePattern ~attrs ~first ~startPos p = Parser.expect Rparen p; let () = match patterns with - | [_] -> - Parser.err ~startPos ~endPos:p.prevEndPos p - (Diagnostics.message ErrorMessages.tupleSingleElement) + | [ _ ] -> + Parser.err ~startPos ~endPos:p.prevEndPos p + (Diagnostics.message ErrorMessages.tupleSingleElement) | _ -> () in let loc = mkLoc startPos p.prevEndPos in @@ -297984,10 +298259,10 @@ and parseTuplePattern ~attrs ~first ~startPos p = and parsePatternRegion p = match p.Parser.token with | DotDotDot -> - Parser.next p; - Some (true, parseConstrainedPattern p) + Parser.next p; + Some (true, parseConstrainedPattern p) | token when Grammar.isPatternStart token -> - Some (false, parseConstrainedPattern p) + Some (false, parseConstrainedPattern p) | _ -> None and parseModulePattern ~attrs p = @@ -297997,29 +298272,29 @@ and parseModulePattern ~attrs p = let uident = match p.token with | Uident uident -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Location.mkloc uident loc + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc uident loc | _ -> - (* TODO: error recovery *) - Location.mknoloc "_" + (* TODO: error recovery *) + Location.mknoloc "_" in match p.token with | Colon -> - let colonStart = p.Parser.startPos in - Parser.next p; - let packageTypAttrs = parseAttributes p in - let packageType = - parsePackageType ~startPos:colonStart ~attrs:packageTypAttrs p - in - Parser.expect Rparen p; - let loc = mkLoc startPos p.prevEndPos in - let unpack = Ast_helper.Pat.unpack ~loc:uident.loc uident in - Ast_helper.Pat.constraint_ ~loc ~attrs unpack packageType + let colonStart = p.Parser.startPos in + Parser.next p; + let packageTypAttrs = parseAttributes p in + let packageType = + parsePackageType ~startPos:colonStart ~attrs:packageTypAttrs p + in + Parser.expect Rparen p; + let loc = mkLoc startPos p.prevEndPos in + let unpack = Ast_helper.Pat.unpack ~loc:uident.loc uident in + Ast_helper.Pat.constraint_ ~loc ~attrs unpack packageType | _ -> - Parser.expect Rparen p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.unpack ~loc ~attrs uident + Parser.expect Rparen p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Pat.unpack ~loc ~attrs uident and parseListPattern ~startPos ~attrs p = let listPatterns = @@ -298037,13 +298312,13 @@ and parseListPattern ~startPos ~attrs p = in match listPatterns with | (true, pattern) :: patterns -> - let patterns = patterns |> List.map filterSpread |> List.rev in - let pat = makeListPattern loc patterns (Some pattern) in - {pat with ppat_loc = loc; ppat_attributes = attrs} + let patterns = patterns |> List.map filterSpread |> List.rev in + let pat = makeListPattern loc patterns (Some pattern) in + { pat with ppat_loc = loc; ppat_attributes = attrs } | patterns -> - let patterns = patterns |> List.map filterSpread |> List.rev in - let pat = makeListPattern loc patterns None in - {pat with ppat_loc = loc; ppat_attributes = attrs} + let patterns = patterns |> List.map filterSpread |> List.rev in + let pat = makeListPattern loc patterns None in + { pat with ppat_loc = loc; ppat_attributes = attrs } and parseArrayPattern ~attrs p = let startPos = p.startPos in @@ -298067,21 +298342,21 @@ and parseConstructorPatternArgs p constr startPos attrs = let args = match args with | [] -> - let loc = mkLoc lparen p.prevEndPos in - Some - (Ast_helper.Pat.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - None) - | [({ppat_desc = Ppat_tuple _} as pat)] as patterns -> - if p.mode = ParseForTypeChecker then - (* Some(1, 2) for type-checker *) - Some pat - else - (* Some((1, 2)) for printer *) - Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) - | [pattern] -> Some pattern + let loc = mkLoc lparen p.prevEndPos in + Some + (Ast_helper.Pat.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None) + | [ ({ ppat_desc = Ppat_tuple _ } as pat) ] as patterns -> + if p.mode = ParseForTypeChecker then + (* Some(1, 2) for type-checker *) + Some pat + else + (* Some((1, 2)) for printer *) + Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) + | [ pattern ] -> Some pattern | patterns -> - Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) + Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) in Ast_helper.Pat.construct ~loc:(mkLoc startPos p.prevEndPos) ~attrs constr args @@ -298095,21 +298370,21 @@ and parseVariantPatternArgs p ident startPos attrs = let args = match patterns with | [] -> - let loc = mkLoc lparen p.prevEndPos in - Some - (Ast_helper.Pat.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - None) - | [({ppat_desc = Ppat_tuple _} as pat)] as patterns -> - if p.mode = ParseForTypeChecker then - (* #ident(1, 2) for type-checker *) - Some pat - else - (* #ident((1, 2)) for printer *) - Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) - | [pattern] -> Some pattern + let loc = mkLoc lparen p.prevEndPos in + Some + (Ast_helper.Pat.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None) + | [ ({ ppat_desc = Ppat_tuple _ } as pat) ] as patterns -> + if p.mode = ParseForTypeChecker then + (* #ident(1, 2) for type-checker *) + Some pat + else + (* #ident((1, 2)) for printer *) + Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) + | [ pattern ] -> Some pattern | patterns -> - Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) + Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) in Parser.expect Rparen p; Ast_helper.Pat.variant ~loc:(mkLoc startPos p.prevEndPos) ~attrs ident args @@ -298123,36 +298398,34 @@ and parseExpr ?(context = OrdinaryExpr) p = and parseTernaryExpr leftOperand p = match p.Parser.token with | Question -> - Parser.leaveBreadcrumb p Grammar.Ternary; - Parser.next p; - let trueBranch = parseExpr ~context:TernaryTrueBranchExpr p in - Parser.expect Colon p; - let falseBranch = parseExpr p in - Parser.eatBreadcrumb p; - let loc = - { - leftOperand.Parsetree.pexp_loc with - loc_start = leftOperand.pexp_loc.loc_start; - loc_end = falseBranch.Parsetree.pexp_loc.loc_end; - } - in - Ast_helper.Exp.ifthenelse ~attrs:[ternaryAttr] ~loc leftOperand trueBranch - (Some falseBranch) + Parser.leaveBreadcrumb p Grammar.Ternary; + Parser.next p; + let trueBranch = parseExpr ~context:TernaryTrueBranchExpr p in + Parser.expect Colon p; + let falseBranch = parseExpr p in + Parser.eatBreadcrumb p; + let loc = + { + leftOperand.Parsetree.pexp_loc with + loc_start = leftOperand.pexp_loc.loc_start; + loc_end = falseBranch.Parsetree.pexp_loc.loc_end; + } + in + Ast_helper.Exp.ifthenelse ~attrs:[ ternaryAttr ] ~loc leftOperand + trueBranch (Some falseBranch) | _ -> leftOperand and parseEs6ArrowExpression ?context ?parameters p = let startPos = p.Parser.startPos in Parser.leaveBreadcrumb p Grammar.Es6ArrowExpr; let parameters = - match parameters with - | Some params -> params - | None -> parseParameters p + match parameters with Some params -> params | None -> parseParameters p in let returnType = match p.Parser.token with | Colon -> - Parser.next p; - Some (parseTypExpr ~es6Arrow:false p) + Parser.next p; + Some (parseTypExpr ~es6Arrow:false p) | _ -> None in Parser.expect EqualGreater p; @@ -298160,9 +298433,9 @@ and parseEs6ArrowExpression ?context ?parameters p = let expr = parseExpr ?context p in match returnType with | Some typ -> - Ast_helper.Exp.constraint_ - ~loc:(mkLoc expr.pexp_loc.loc_start typ.Parsetree.ptyp_loc.loc_end) - expr typ + Ast_helper.Exp.constraint_ + ~loc:(mkLoc expr.pexp_loc.loc_start typ.Parsetree.ptyp_loc.loc_end) + expr typ | None -> expr in Parser.eatBreadcrumb p; @@ -298180,15 +298453,15 @@ and parseEs6ArrowExpression ?context ?parameters p = pat; pos = startPos; } -> - let attrs = if uncurried then uncurryAttr :: attrs else attrs in - Ast_helper.Exp.fun_ ~loc:(mkLoc startPos endPos) ~attrs lbl - defaultExpr pat expr - | TypeParameter {uncurried; attrs; locs = newtypes; pos = startPos} -> - let attrs = if uncurried then uncurryAttr :: attrs else attrs in - makeNewtypes ~attrs ~loc:(mkLoc startPos endPos) newtypes expr) + let attrs = if uncurried then uncurryAttr :: attrs else attrs in + Ast_helper.Exp.fun_ ~loc:(mkLoc startPos endPos) ~attrs lbl + defaultExpr pat expr + | TypeParameter { uncurried; attrs; locs = newtypes; pos = startPos } -> + let attrs = if uncurried then uncurryAttr :: attrs else attrs in + makeNewtypes ~attrs ~loc:(mkLoc startPos endPos) newtypes expr) parameters body in - {arrowExpr with pexp_loc = {arrowExpr.pexp_loc with loc_start = startPos}} + { arrowExpr with pexp_loc = { arrowExpr.pexp_loc with loc_start = startPos } } (* * uncurried_parameter ::= @@ -298226,92 +298499,109 @@ and parseParameter p = if p.Parser.token = Typ then ( Parser.next p; let lidents = parseLidentList p in - Some (TypeParameter {uncurried; attrs; locs = lidents; pos = startPos})) + Some (TypeParameter { uncurried; attrs; locs = lidents; pos = startPos })) else let attrs, lbl, pat = match p.Parser.token with | Tilde -> ( - Parser.next p; - let lblName, loc = parseLident p in - let propLocAttr = - (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) - in - match p.Parser.token with - | Comma | Equal | Rparen -> - let loc = mkLoc startPos p.prevEndPos in - ( attrs, - Asttypes.Labelled lblName, - Ast_helper.Pat.var ~attrs:[propLocAttr] ~loc - (Location.mkloc lblName loc) ) - | Colon -> - let lblEnd = p.prevEndPos in Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc startPos lblEnd in - let pat = - let pat = Ast_helper.Pat.var ~loc (Location.mkloc lblName loc) in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.constraint_ ~attrs:[propLocAttr] ~loc pat typ - in - (attrs, Asttypes.Labelled lblName, pat) - | As -> - Parser.next p; - let pat = - let pat = parseConstrainedPattern p in - {pat with ppat_attributes = propLocAttr :: pat.ppat_attributes} + let lblName, loc = parseLident p in + let propLocAttr = + (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) in - (attrs, Asttypes.Labelled lblName, pat) - | t -> - Parser.err p (Diagnostics.unexpected t p.breadcrumbs); - let loc = mkLoc startPos p.prevEndPos in - ( attrs, - Asttypes.Labelled lblName, - Ast_helper.Pat.var ~loc (Location.mkloc lblName loc) )) + match p.Parser.token with + | Comma | Equal | Rparen -> + let loc = mkLoc startPos p.prevEndPos in + ( attrs, + Asttypes.Labelled lblName, + Ast_helper.Pat.var ~attrs:[ propLocAttr ] ~loc + (Location.mkloc lblName loc) ) + | Colon -> + let lblEnd = p.prevEndPos in + Parser.next p; + let typ = parseTypExpr p in + let loc = mkLoc startPos lblEnd in + let pat = + let pat = + Ast_helper.Pat.var ~loc (Location.mkloc lblName loc) + in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Pat.constraint_ ~attrs:[ propLocAttr ] ~loc pat typ + in + (attrs, Asttypes.Labelled lblName, pat) + | As -> + Parser.next p; + let pat = + let pat = parseConstrainedPattern p in + { + pat with + ppat_attributes = propLocAttr :: pat.ppat_attributes; + } + in + (attrs, Asttypes.Labelled lblName, pat) + | t -> + Parser.err p (Diagnostics.unexpected t p.breadcrumbs); + let loc = mkLoc startPos p.prevEndPos in + ( attrs, + Asttypes.Labelled lblName, + Ast_helper.Pat.var ~loc (Location.mkloc lblName loc) )) | _ -> - let pattern = parseConstrainedPattern p in - let attrs = List.concat [attrs; pattern.ppat_attributes] in - ([], Asttypes.Nolabel, {pattern with ppat_attributes = attrs}) + let pattern = parseConstrainedPattern p in + let attrs = List.concat [ attrs; pattern.ppat_attributes ] in + ([], Asttypes.Nolabel, { pattern with ppat_attributes = attrs }) in match p.Parser.token with | Equal -> ( - Parser.next p; - let lbl = - match lbl with - | Asttypes.Labelled lblName -> Asttypes.Optional lblName - | Asttypes.Nolabel -> - let lblName = - match pat.ppat_desc with - | Ppat_var var -> var.txt - | _ -> "" - in - Parser.err ~startPos ~endPos:p.prevEndPos p - (Diagnostics.message - (ErrorMessages.missingTildeLabeledParameter lblName)); - Asttypes.Optional lblName - | lbl -> lbl - in - match p.Parser.token with - | Question -> Parser.next p; - Some - (TermParameter - {uncurried; attrs; label = lbl; expr = None; pat; pos = startPos}) - | _ -> - let expr = parseConstrainedOrCoercedExpr p in + let lbl = + match lbl with + | Asttypes.Labelled lblName -> Asttypes.Optional lblName + | Asttypes.Nolabel -> + let lblName = + match pat.ppat_desc with Ppat_var var -> var.txt | _ -> "" + in + Parser.err ~startPos ~endPos:p.prevEndPos p + (Diagnostics.message + (ErrorMessages.missingTildeLabeledParameter lblName)); + Asttypes.Optional lblName + | lbl -> lbl + in + match p.Parser.token with + | Question -> + Parser.next p; + Some + (TermParameter + { + uncurried; + attrs; + label = lbl; + expr = None; + pat; + pos = startPos; + }) + | _ -> + let expr = parseConstrainedOrCoercedExpr p in + Some + (TermParameter + { + uncurried; + attrs; + label = lbl; + expr = Some expr; + pat; + pos = startPos; + })) + | _ -> Some (TermParameter { uncurried; attrs; label = lbl; - expr = Some expr; + expr = None; pat; pos = startPos; - })) - | _ -> - Some - (TermParameter - {uncurried; attrs; label = lbl; expr = None; pat; pos = startPos}) + }) else None and parseParameterList p = @@ -298333,44 +298623,22 @@ and parseParameters p = let startPos = p.Parser.startPos in match p.Parser.token with | Lident ident -> - Parser.next p; - let loc = mkLoc startPos p.Parser.prevEndPos in - [ - TermParameter - { - uncurried = false; - attrs = []; - label = Asttypes.Nolabel; - expr = None; - pat = Ast_helper.Pat.var ~loc (Location.mkloc ident loc); - pos = startPos; - }; - ] + Parser.next p; + let loc = mkLoc startPos p.Parser.prevEndPos in + [ + TermParameter + { + uncurried = false; + attrs = []; + label = Asttypes.Nolabel; + expr = None; + pat = Ast_helper.Pat.var ~loc (Location.mkloc ident loc); + pos = startPos; + }; + ] | Underscore -> - Parser.next p; - let loc = mkLoc startPos p.Parser.prevEndPos in - [ - TermParameter - { - uncurried = false; - attrs = []; - label = Asttypes.Nolabel; - expr = None; - pat = Ast_helper.Pat.any ~loc (); - pos = startPos; - }; - ] - | Lparen -> ( - Parser.next p; - match p.Parser.token with - | Rparen -> Parser.next p; let loc = mkLoc startPos p.Parser.prevEndPos in - let unitPattern = - Ast_helper.Pat.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - None - in [ TermParameter { @@ -298378,58 +298646,80 @@ and parseParameters p = attrs = []; label = Asttypes.Nolabel; expr = None; - pat = unitPattern; + pat = Ast_helper.Pat.any ~loc (); pos = startPos; }; ] - | Dot -> ( + | Lparen -> ( Parser.next p; - match p.token with + match p.Parser.token with | Rparen -> - Parser.next p; - let loc = mkLoc startPos p.Parser.prevEndPos in - let unitPattern = - Ast_helper.Pat.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - None - in - [ - TermParameter - { - uncurried = true; - attrs = []; - label = Asttypes.Nolabel; - expr = None; - pat = unitPattern; - pos = startPos; - }; - ] - | _ -> ( - match parseParameterList p with - | TermParameter - { - attrs; - label = lbl; - expr = defaultExpr; - pat = pattern; - pos = startPos; - } - :: rest -> - TermParameter - { - uncurried = true; - attrs; - label = lbl; - expr = defaultExpr; - pat = pattern; - pos = startPos; - } - :: rest - | parameters -> parameters)) - | _ -> parseParameterList p) + Parser.next p; + let loc = mkLoc startPos p.Parser.prevEndPos in + let unitPattern = + Ast_helper.Pat.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None + in + [ + TermParameter + { + uncurried = false; + attrs = []; + label = Asttypes.Nolabel; + expr = None; + pat = unitPattern; + pos = startPos; + }; + ] + | Dot -> ( + Parser.next p; + match p.token with + | Rparen -> + Parser.next p; + let loc = mkLoc startPos p.Parser.prevEndPos in + let unitPattern = + Ast_helper.Pat.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None + in + [ + TermParameter + { + uncurried = true; + attrs = []; + label = Asttypes.Nolabel; + expr = None; + pat = unitPattern; + pos = startPos; + }; + ] + | _ -> ( + match parseParameterList p with + | TermParameter + { + attrs; + label = lbl; + expr = defaultExpr; + pat = pattern; + pos = startPos; + } + :: rest -> + TermParameter + { + uncurried = true; + attrs; + label = lbl; + expr = defaultExpr; + pat = pattern; + pos = startPos; + } + :: rest + | parameters -> parameters)) + | _ -> parseParameterList p) | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - [] + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + [] and parseCoercedExpr ~(expr : Parsetree.expression) p = Parser.expect ColonGreaterThan p; @@ -298442,28 +298732,28 @@ and parseConstrainedOrCoercedExpr p = match p.Parser.token with | ColonGreaterThan -> parseCoercedExpr ~expr p | Colon -> ( - Parser.next p; - match p.token with - | _ -> ( - let typ = parseTypExpr p in - let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in - let expr = Ast_helper.Exp.constraint_ ~loc expr typ in + Parser.next p; match p.token with - | ColonGreaterThan -> parseCoercedExpr ~expr p - | _ -> expr)) + | _ -> ( + let typ = parseTypExpr p in + let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in + let expr = Ast_helper.Exp.constraint_ ~loc expr typ in + match p.token with + | ColonGreaterThan -> parseCoercedExpr ~expr p + | _ -> expr)) | _ -> expr and parseConstrainedExprRegion p = match p.Parser.token with | token when Grammar.isExprStart token -> ( - let expr = parseExpr p in - match p.Parser.token with - | Colon -> - Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in - Some (Ast_helper.Exp.constraint_ ~loc expr typ) - | _ -> Some expr) + let expr = parseExpr p in + match p.Parser.token with + | Colon -> + Parser.next p; + let typ = parseTypExpr p in + let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in + Some (Ast_helper.Exp.constraint_ ~loc expr typ) + | _ -> Some expr) | _ -> None (* Atomic expressions represent unambiguous expressions. @@ -298475,74 +298765,75 @@ and parseAtomicExpr p = let expr = match p.Parser.token with | (True | False) as token -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.construct ~loc - (Location.mkloc (Longident.Lident (Token.toString token)) loc) - None + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.construct ~loc + (Location.mkloc (Longident.Lident (Token.toString token)) loc) + None | Int _ | String _ | Float _ | Codepoint _ -> - let c = parseConstant p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.constant ~loc c + let c = parseConstant p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.constant ~loc c | Backtick -> - let expr = parseTemplateExpr p in - {expr with pexp_loc = mkLoc startPos p.prevEndPos} + let expr = parseTemplateExpr p in + { expr with pexp_loc = mkLoc startPos p.prevEndPos } | Uident _ | Lident _ -> parseValueOrConstructor p | Hash -> parsePolyVariantExpr p | Lparen -> ( - Parser.next p; - match p.Parser.token with - | Rparen -> Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - None - | _t -> ( - let expr = parseConstrainedOrCoercedExpr p in - match p.token with - | Comma -> - Parser.next p; - parseTupleExpr ~startPos ~first:expr p - | _ -> - Parser.expect Rparen p; - expr - (* {expr with pexp_loc = mkLoc startPos p.prevEndPos} - * What does this location mean here? It means that when there's - * a parenthesized we keep the location here for whitespace interleaving. - * Without the closing paren in the location there will always be an extra - * line. For now we don't include it, because it does weird things - * with for comments. *))) + match p.Parser.token with + | Rparen -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None + | _t -> ( + let expr = parseConstrainedOrCoercedExpr p in + match p.token with + | Comma -> + Parser.next p; + parseTupleExpr ~startPos ~first:expr p + | _ -> + Parser.expect Rparen p; + expr + (* {expr with pexp_loc = mkLoc startPos p.prevEndPos} + * What does this location mean here? It means that when there's + * a parenthesized we keep the location here for whitespace interleaving. + * Without the closing paren in the location there will always be an extra + * line. For now we don't include it, because it does weird things + * with for comments. *))) | List -> - Parser.next p; - parseListExpr ~startPos p + Parser.next p; + parseListExpr ~startPos p | Module -> - Parser.next p; - parseFirstClassModuleExpr ~startPos p + Parser.next p; + parseFirstClassModuleExpr ~startPos p | Lbracket -> parseArrayExp p | Lbrace -> parseBracedOrRecordExpr p | LessThan -> parseJsx p | Percent -> - let extension = parseExtension p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.extension ~loc extension + let extension = parseExtension p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.extension ~loc extension | Underscore as token -> - (* This case is for error recovery. Not sure if it's the correct place *) - Parser.err p (Diagnostics.lident token); - Parser.next p; - Recover.defaultExpr () + (* This case is for error recovery. Not sure if it's the correct place *) + Parser.err p (Diagnostics.lident token); + Parser.next p; + Recover.defaultExpr () | Eof -> - Parser.err ~startPos:p.prevEndPos p - (Diagnostics.unexpected p.Parser.token p.breadcrumbs); - Recover.defaultExpr () + Parser.err ~startPos:p.prevEndPos p + (Diagnostics.unexpected p.Parser.token p.breadcrumbs); + Recover.defaultExpr () | token -> ( - let errPos = p.prevEndPos in - Parser.err ~startPos:errPos p (Diagnostics.unexpected token p.breadcrumbs); - match - skipTokensAndMaybeRetry p ~isStartOfGrammar:Grammar.isAtomicExprStart - with - | None -> Recover.defaultExpr () - | Some () -> parseAtomicExpr p) + let errPos = p.prevEndPos in + Parser.err ~startPos:errPos p + (Diagnostics.unexpected token p.breadcrumbs); + match + skipTokensAndMaybeRetry p ~isStartOfGrammar:Grammar.isAtomicExprStart + with + | None -> Recover.defaultExpr () + | Some () -> parseAtomicExpr p) in Parser.eatBreadcrumb p; expr @@ -298556,19 +298847,19 @@ and parseFirstClassModuleExpr ~startPos p = let modEndLoc = p.prevEndPos in match p.Parser.token with | Colon -> - let colonStart = p.Parser.startPos in - Parser.next p; - let attrs = parseAttributes p in - let packageType = parsePackageType ~startPos:colonStart ~attrs p in - Parser.expect Rparen p; - let loc = mkLoc startPos modEndLoc in - let firstClassModule = Ast_helper.Exp.pack ~loc modExpr in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.constraint_ ~loc firstClassModule packageType + let colonStart = p.Parser.startPos in + Parser.next p; + let attrs = parseAttributes p in + let packageType = parsePackageType ~startPos:colonStart ~attrs p in + Parser.expect Rparen p; + let loc = mkLoc startPos modEndLoc in + let firstClassModule = Ast_helper.Exp.pack ~loc modExpr in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.constraint_ ~loc firstClassModule packageType | _ -> - Parser.expect Rparen p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.pack ~loc modExpr + Parser.expect Rparen p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.pack ~loc modExpr and parseBracketAccess p expr startPos = Parser.leaveBreadcrumb p Grammar.ExprArrayAccess; @@ -298577,61 +298868,63 @@ and parseBracketAccess p expr startPos = let stringStart = p.startPos in match p.Parser.token with | String s -> ( - Parser.next p; - let stringEnd = p.prevEndPos in - Parser.expect Rbracket p; - Parser.eatBreadcrumb p; - let rbracket = p.prevEndPos in - let e = - let identLoc = mkLoc stringStart stringEnd in - let loc = mkLoc startPos rbracket in - Ast_helper.Exp.send ~loc expr (Location.mkloc s identLoc) - in - let e = parsePrimaryExpr ~operand:e p in - let equalStart = p.startPos in - match p.token with - | Equal -> - Parser.next p; - let equalEnd = p.prevEndPos in - let rhsExpr = parseExpr p in - let loc = mkLoc startPos rhsExpr.pexp_loc.loc_end in - let operatorLoc = mkLoc equalStart equalEnd in - Ast_helper.Exp.apply ~loc - (Ast_helper.Exp.ident ~loc:operatorLoc - (Location.mkloc (Longident.Lident "#=") operatorLoc)) - [(Nolabel, e); (Nolabel, rhsExpr)] - | _ -> e) - | _ -> ( - let accessExpr = parseConstrainedOrCoercedExpr p in - Parser.expect Rbracket p; - Parser.eatBreadcrumb p; - let rbracket = p.prevEndPos in - let arrayLoc = mkLoc lbracket rbracket in - match p.token with - | Equal -> - Parser.leaveBreadcrumb p ExprArrayMutation; Parser.next p; - let rhsExpr = parseExpr p in - let arraySet = - Location.mkloc (Longident.Ldot (Lident "Array", "set")) arrayLoc - in - let endPos = p.prevEndPos in - let arraySet = - Ast_helper.Exp.apply ~loc:(mkLoc startPos endPos) - (Ast_helper.Exp.ident ~loc:arrayLoc arraySet) - [(Nolabel, expr); (Nolabel, accessExpr); (Nolabel, rhsExpr)] - in + let stringEnd = p.prevEndPos in + Parser.expect Rbracket p; Parser.eatBreadcrumb p; - arraySet - | _ -> - let endPos = p.prevEndPos in + let rbracket = p.prevEndPos in let e = - Ast_helper.Exp.apply ~loc:(mkLoc startPos endPos) - (Ast_helper.Exp.ident ~loc:arrayLoc - (Location.mkloc (Longident.Ldot (Lident "Array", "get")) arrayLoc)) - [(Nolabel, expr); (Nolabel, accessExpr)] + let identLoc = mkLoc stringStart stringEnd in + let loc = mkLoc startPos rbracket in + Ast_helper.Exp.send ~loc expr (Location.mkloc s identLoc) in - parsePrimaryExpr ~operand:e p) + let e = parsePrimaryExpr ~operand:e p in + let equalStart = p.startPos in + match p.token with + | Equal -> + Parser.next p; + let equalEnd = p.prevEndPos in + let rhsExpr = parseExpr p in + let loc = mkLoc startPos rhsExpr.pexp_loc.loc_end in + let operatorLoc = mkLoc equalStart equalEnd in + Ast_helper.Exp.apply ~loc + (Ast_helper.Exp.ident ~loc:operatorLoc + (Location.mkloc (Longident.Lident "#=") operatorLoc)) + [ (Nolabel, e); (Nolabel, rhsExpr) ] + | _ -> e) + | _ -> ( + let accessExpr = parseConstrainedOrCoercedExpr p in + Parser.expect Rbracket p; + Parser.eatBreadcrumb p; + let rbracket = p.prevEndPos in + let arrayLoc = mkLoc lbracket rbracket in + match p.token with + | Equal -> + Parser.leaveBreadcrumb p ExprArrayMutation; + Parser.next p; + let rhsExpr = parseExpr p in + let arraySet = + Location.mkloc (Longident.Ldot (Lident "Array", "set")) arrayLoc + in + let endPos = p.prevEndPos in + let arraySet = + Ast_helper.Exp.apply ~loc:(mkLoc startPos endPos) + (Ast_helper.Exp.ident ~loc:arrayLoc arraySet) + [ (Nolabel, expr); (Nolabel, accessExpr); (Nolabel, rhsExpr) ] + in + Parser.eatBreadcrumb p; + arraySet + | _ -> + let endPos = p.prevEndPos in + let e = + Ast_helper.Exp.apply ~loc:(mkLoc startPos endPos) + (Ast_helper.Exp.ident ~loc:arrayLoc + (Location.mkloc + (Longident.Ldot (Lident "Array", "get")) + arrayLoc)) + [ (Nolabel, expr); (Nolabel, accessExpr) ] + in + parsePrimaryExpr ~operand:e p) (* * A primary expression represents * - atomic-expr @@ -298646,39 +298939,41 @@ and parsePrimaryExpr ~operand ?(noCall = false) p = let rec loop p expr = match p.Parser.token with | Dot -> ( - Parser.next p; - let lident = parseValuePathAfterDot p in - match p.Parser.token with - | Equal when noCall = false -> - Parser.leaveBreadcrumb p Grammar.ExprSetField; Parser.next p; - let targetExpr = parseExpr p in - let loc = mkLoc startPos p.prevEndPos in - let setfield = Ast_helper.Exp.setfield ~loc expr lident targetExpr in - Parser.eatBreadcrumb p; - setfield - | _ -> - let endPos = p.prevEndPos in - let loc = mkLoc startPos endPos in - loop p (Ast_helper.Exp.field ~loc expr lident)) + let lident = parseValuePathAfterDot p in + match p.Parser.token with + | Equal when noCall = false -> + Parser.leaveBreadcrumb p Grammar.ExprSetField; + Parser.next p; + let targetExpr = parseExpr p in + let loc = mkLoc startPos p.prevEndPos in + let setfield = + Ast_helper.Exp.setfield ~loc expr lident targetExpr + in + Parser.eatBreadcrumb p; + setfield + | _ -> + let endPos = p.prevEndPos in + let loc = mkLoc startPos endPos in + loop p (Ast_helper.Exp.field ~loc expr lident)) | Lbracket when noCall = false && p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> - parseBracketAccess p expr startPos + parseBracketAccess p expr startPos | Lparen when noCall = false && p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> - loop p (parseCallExpr p expr) + loop p (parseCallExpr p expr) | Backtick when noCall = false && p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> ( - match expr.pexp_desc with - | Pexp_ident {txt = Longident.Lident ident} -> - parseTemplateExpr ~prefix:ident p - | _ -> - Parser.err ~startPos:expr.pexp_loc.loc_start - ~endPos:expr.pexp_loc.loc_end p - (Diagnostics.message - "Tagged template literals are currently restricted to names like: \ - json`null`."); - parseTemplateExpr p) + match expr.pexp_desc with + | Pexp_ident { txt = Longident.Lident ident } -> + parseTemplateExpr ~prefix:ident p + | _ -> + Parser.err ~startPos:expr.pexp_loc.loc_start + ~endPos:expr.pexp_loc.loc_end p + (Diagnostics.message + "Tagged template literals are currently restricted to names \ + like: json`null`."); + parseTemplateExpr p) | _ -> expr in loop p operand @@ -298693,13 +298988,13 @@ and parseUnaryExpr p = let startPos = p.Parser.startPos in match p.Parser.token with | (Minus | MinusDot | Plus | PlusDot | Bang) as token -> - Parser.leaveBreadcrumb p Grammar.ExprUnary; - let tokenEnd = p.endPos in - Parser.next p; - let operand = parseUnaryExpr p in - let unaryExpr = makeUnaryExpr startPos tokenEnd token operand in - Parser.eatBreadcrumb p; - unaryExpr + Parser.leaveBreadcrumb p Grammar.ExprUnary; + let tokenEnd = p.endPos in + Parser.next p; + let operand = parseUnaryExpr p in + let unaryExpr = makeUnaryExpr startPos tokenEnd token operand in + Parser.eatBreadcrumb p; + unaryExpr | _ -> parsePrimaryExpr ~operand:(parseAtomicExpr p) p (* Represents an "operand" in a binary expression. @@ -298711,10 +299006,10 @@ and parseOperandExpr ~context p = let expr = match p.Parser.token with | Assert -> - Parser.next p; - let expr = parseUnaryExpr p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.assert_ ~loc expr + Parser.next p; + let expr = parseUnaryExpr p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.assert_ ~loc expr | Lident "async" (* we need to be careful when we're in a ternary true branch: `condition ? ternary-true-branch : false-branch` @@ -298723,29 +299018,29 @@ and parseOperandExpr ~context p = *) when isEs6ArrowExpression ~inTernary:(context = TernaryTrueBranchExpr) p -> - parseAsyncArrowExpression p + parseAsyncArrowExpression p | Await -> parseAwaitExpression p - | Lazy -> - Parser.next p; - let expr = parseUnaryExpr p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.lazy_ ~loc expr + | Lazy -> + Parser.next p; + let expr = parseUnaryExpr p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.lazy_ ~loc expr | Try -> parseTryExpression p | If -> parseIfOrIfLetExpression p | For -> parseForExpression p | While -> parseWhileExpression p | Switch -> parseSwitchExpression p | _ -> - if - context != WhenExpr - && isEs6ArrowExpression ~inTernary:(context = TernaryTrueBranchExpr) p - then parseEs6ArrowExpression ~context p - else parseUnaryExpr p + if + context != WhenExpr + && isEs6ArrowExpression ~inTernary:(context = TernaryTrueBranchExpr) p + then parseEs6ArrowExpression ~context p + else parseUnaryExpr p in (* let endPos = p.Parser.prevEndPos in *) { expr with - pexp_attributes = List.concat [expr.Parsetree.pexp_attributes; attrs]; + pexp_attributes = List.concat [ expr.Parsetree.pexp_attributes; attrs ]; (* pexp_loc = mkLoc startPos endPos *) } @@ -298755,11 +299050,7 @@ and parseOperandExpr ~context p = * f(x) |> g(y) *) and parseBinaryExpr ?(context = OrdinaryExpr) ?a p prec = - let a = - match a with - | Some e -> e - | None -> parseOperandExpr ~context p - in + let a = match a with Some e -> e | None -> parseOperandExpr ~context p in let rec loop a = let token = p.Parser.token in let tokenPrec = @@ -298782,7 +299073,7 @@ and parseBinaryExpr ?(context = OrdinaryExpr) ?a p prec = (Scanner.isBinaryOp p.scanner.src p.startPos.pos_cnum p.endPos.pos_cnum)) && p.startPos.pos_lnum > p.prevEndPos.pos_lnum -> - -1 + -1 | token -> Token.precedence token in if tokenPrec < prec then a @@ -298796,7 +299087,7 @@ and parseBinaryExpr ?(context = OrdinaryExpr) ?a p prec = let expr = Ast_helper.Exp.apply ~loc (makeInfixOperator p token startPos endPos) - [(Nolabel, a); (Nolabel, b)] + [ (Nolabel, a); (Nolabel, b) ] in Parser.eatBreadcrumb p; loop expr) @@ -298843,59 +299134,59 @@ and parseTemplateExpr ?(prefix = "js") p = in let concat (e1 : Parsetree.expression) (e2 : Parsetree.expression) = let loc = mkLoc e1.pexp_loc.loc_start e2.pexp_loc.loc_end in - Ast_helper.Exp.apply ~attrs:[templateLiteralAttr] ~loc hiddenOperator - [(Nolabel, e1); (Nolabel, e2)] + Ast_helper.Exp.apply ~attrs:[ templateLiteralAttr ] ~loc hiddenOperator + [ (Nolabel, e1); (Nolabel, e2) ] in let rec parseParts (acc : Parsetree.expression) = let startPos = p.Parser.startPos in Parser.nextTemplateLiteralToken p; match p.token with | TemplateTail (txt, lastPos) -> - Parser.next p; - let loc = mkLoc startPos lastPos in - let str = - Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] ~loc - (Pconst_string (txt, Some prefix)) - in - concat acc str + Parser.next p; + let loc = mkLoc startPos lastPos in + let str = + Ast_helper.Exp.constant ~attrs:[ templateLiteralAttr ] ~loc + (Pconst_string (txt, Some prefix)) + in + concat acc str | TemplatePart (txt, lastPos) -> - Parser.next p; - let loc = mkLoc startPos lastPos in - let expr = parseExprBlock p in - let str = - Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] ~loc - (Pconst_string (txt, Some prefix)) - in - let next = - let a = concat acc str in - concat a expr - in - parseParts next + Parser.next p; + let loc = mkLoc startPos lastPos in + let expr = parseExprBlock p in + let str = + Ast_helper.Exp.constant ~attrs:[ templateLiteralAttr ] ~loc + (Pconst_string (txt, Some prefix)) + in + let next = + let a = concat acc str in + concat a expr + in + parseParts next | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Ast_helper.Exp.constant (Pconst_string ("", None)) + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Ast_helper.Exp.constant (Pconst_string ("", None)) in let startPos = p.startPos in Parser.nextTemplateLiteralToken p; match p.token with | TemplateTail (txt, lastPos) -> - Parser.next p; - Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] - ~loc:(mkLoc startPos lastPos) - (Pconst_string (txt, Some prefix)) - | TemplatePart (txt, lastPos) -> - Parser.next p; - let constantLoc = mkLoc startPos lastPos in - let expr = parseExprBlock p in - let str = - Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] ~loc:constantLoc + Parser.next p; + Ast_helper.Exp.constant ~attrs:[ templateLiteralAttr ] + ~loc:(mkLoc startPos lastPos) (Pconst_string (txt, Some prefix)) - in - let next = concat str expr in - parseParts next + | TemplatePart (txt, lastPos) -> + Parser.next p; + let constantLoc = mkLoc startPos lastPos in + let expr = parseExprBlock p in + let str = + Ast_helper.Exp.constant ~attrs:[ templateLiteralAttr ] ~loc:constantLoc + (Pconst_string (txt, Some prefix)) + in + let next = concat str expr in + parseParts next | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Ast_helper.Exp.constant (Pconst_string ("", None)) + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Ast_helper.Exp.constant (Pconst_string ("", None)) (* Overparse: let f = a : int => a + 1, is it (a : int) => or (a): int => * Also overparse constraints: @@ -298910,85 +299201,85 @@ and overParseConstrainedOrCoercedOrArrowExpression p expr = match p.Parser.token with | ColonGreaterThan -> parseCoercedExpr ~expr p | Colon -> ( - Parser.next p; - let typ = parseTypExpr ~es6Arrow:false p in - match p.Parser.token with - | EqualGreater -> Parser.next p; - let body = parseExpr p in - let pat = - match expr.pexp_desc with - | Pexp_ident longident -> - Ast_helper.Pat.var ~loc:expr.pexp_loc - (Location.mkloc - (Longident.flatten longident.txt |> String.concat ".") - longident.loc) - (* TODO: can we convert more expressions to patterns?*) - | _ -> - Ast_helper.Pat.var ~loc:expr.pexp_loc - (Location.mkloc "pattern" expr.pexp_loc) - in - let arrow1 = - Ast_helper.Exp.fun_ - ~loc:(mkLoc expr.pexp_loc.loc_start body.pexp_loc.loc_end) - Asttypes.Nolabel None pat - (Ast_helper.Exp.constraint_ body typ) - in - let arrow2 = - Ast_helper.Exp.fun_ - ~loc:(mkLoc expr.pexp_loc.loc_start body.pexp_loc.loc_end) - Asttypes.Nolabel None - (Ast_helper.Pat.constraint_ pat typ) - body - in - let msg = - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.text - "Did you mean to annotate the parameter type or the return \ - type?"; - Doc.indent - (Doc.concat - [ - Doc.line; - Doc.text "1) "; - ResPrinter.printExpression arrow1 CommentTable.empty; - Doc.line; - Doc.text "2) "; - ResPrinter.printExpression arrow2 CommentTable.empty; - ]); - ]) - |> Doc.toString ~width:80 - in - Parser.err ~startPos:expr.pexp_loc.loc_start ~endPos:body.pexp_loc.loc_end - p (Diagnostics.message msg); - arrow1 - | _ -> - let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in - let expr = Ast_helper.Exp.constraint_ ~loc expr typ in - let () = - Parser.err ~startPos:expr.pexp_loc.loc_start - ~endPos:typ.ptyp_loc.loc_end p - (Diagnostics.message - (Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.text - "Expressions with type constraints need to be wrapped \ - in parens:"; - Doc.indent - (Doc.concat - [ - Doc.line; - ResPrinter.addParens - (ResPrinter.printExpression expr - CommentTable.empty); - ]); - ]) - |> Doc.toString ~width:80)) - in - expr) + let typ = parseTypExpr ~es6Arrow:false p in + match p.Parser.token with + | EqualGreater -> + Parser.next p; + let body = parseExpr p in + let pat = + match expr.pexp_desc with + | Pexp_ident longident -> + Ast_helper.Pat.var ~loc:expr.pexp_loc + (Location.mkloc + (Longident.flatten longident.txt |> String.concat ".") + longident.loc) + (* TODO: can we convert more expressions to patterns?*) + | _ -> + Ast_helper.Pat.var ~loc:expr.pexp_loc + (Location.mkloc "pattern" expr.pexp_loc) + in + let arrow1 = + Ast_helper.Exp.fun_ + ~loc:(mkLoc expr.pexp_loc.loc_start body.pexp_loc.loc_end) + Asttypes.Nolabel None pat + (Ast_helper.Exp.constraint_ body typ) + in + let arrow2 = + Ast_helper.Exp.fun_ + ~loc:(mkLoc expr.pexp_loc.loc_start body.pexp_loc.loc_end) + Asttypes.Nolabel None + (Ast_helper.Pat.constraint_ pat typ) + body + in + let msg = + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.text + "Did you mean to annotate the parameter type or the \ + return type?"; + Doc.indent + (Doc.concat + [ + Doc.line; + Doc.text "1) "; + ResPrinter.printExpression arrow1 CommentTable.empty; + Doc.line; + Doc.text "2) "; + ResPrinter.printExpression arrow2 CommentTable.empty; + ]); + ]) + |> Doc.toString ~width:80 + in + Parser.err ~startPos:expr.pexp_loc.loc_start + ~endPos:body.pexp_loc.loc_end p (Diagnostics.message msg); + arrow1 + | _ -> + let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in + let expr = Ast_helper.Exp.constraint_ ~loc expr typ in + let () = + Parser.err ~startPos:expr.pexp_loc.loc_start + ~endPos:typ.ptyp_loc.loc_end p + (Diagnostics.message + (Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.text + "Expressions with type constraints need to be \ + wrapped in parens:"; + Doc.indent + (Doc.concat + [ + Doc.line; + ResPrinter.addParens + (ResPrinter.printExpression expr + CommentTable.empty); + ]); + ]) + |> Doc.toString ~width:80)) + in + expr) | _ -> expr and parseLetBindingBody ~startPos ~attrs p = @@ -299000,36 +299291,39 @@ and parseLetBindingBody ~startPos ~attrs p = Parser.eatBreadcrumb p; match p.Parser.token with | Colon -> ( - Parser.next p; - match p.token with - | Typ -> - (* locally abstract types *) Parser.next p; - let newtypes = parseLidentList p in - Parser.expect Dot p; - let typ = parseTypExpr p in - Parser.expect Equal p; - let expr = parseExpr p in - let loc = mkLoc startPos p.prevEndPos in - let exp, poly = wrapTypeAnnotation ~loc newtypes typ expr in - let pat = Ast_helper.Pat.constraint_ ~loc pat poly in - (pat, exp) - | _ -> - let polyType = parsePolyTypeExpr p in - let loc = - {pat.ppat_loc with loc_end = polyType.Parsetree.ptyp_loc.loc_end} - in - let pat = Ast_helper.Pat.constraint_ ~loc pat polyType in - Parser.expect Token.Equal p; - let exp = parseExpr p in - let exp = overParseConstrainedOrCoercedOrArrowExpression p exp in - (pat, exp)) + match p.token with + | Typ -> + (* locally abstract types *) + Parser.next p; + let newtypes = parseLidentList p in + Parser.expect Dot p; + let typ = parseTypExpr p in + Parser.expect Equal p; + let expr = parseExpr p in + let loc = mkLoc startPos p.prevEndPos in + let exp, poly = wrapTypeAnnotation ~loc newtypes typ expr in + let pat = Ast_helper.Pat.constraint_ ~loc pat poly in + (pat, exp) + | _ -> + let polyType = parsePolyTypeExpr p in + let loc = + { + pat.ppat_loc with + loc_end = polyType.Parsetree.ptyp_loc.loc_end; + } + in + let pat = Ast_helper.Pat.constraint_ ~loc pat polyType in + Parser.expect Token.Equal p; + let exp = parseExpr p in + let exp = overParseConstrainedOrCoercedOrArrowExpression p exp in + (pat, exp)) | _ -> - Parser.expect Token.Equal p; - let exp = - overParseConstrainedOrCoercedOrArrowExpression p (parseExpr p) - in - (pat, exp) + Parser.expect Token.Equal p; + let exp = + overParseConstrainedOrCoercedOrArrowExpression p (parseExpr p) + in + (pat, exp) in let loc = mkLoc startPos p.prevEndPos in let vb = Ast_helper.Vb.mk ~loc ~attrs pat exp in @@ -299070,25 +299364,25 @@ and parseAttributesAndBinding (p : Parser.t) = match p.Parser.token with | At -> ( - let attrs = parseAttributes p in - match p.Parser.token with - | And -> attrs - | _ -> - p.scanner.err <- err; - p.scanner.ch <- ch; - p.scanner.offset <- offset; - p.scanner.lineOffset <- lineOffset; - p.scanner.lnum <- lnum; - p.scanner.mode <- mode; - p.token <- token; - p.startPos <- startPos; - p.endPos <- endPos; - p.prevEndPos <- prevEndPos; - p.breadcrumbs <- breadcrumbs; - p.errors <- errors; - p.diagnostics <- diagnostics; - p.comments <- comments; - []) + let attrs = parseAttributes p in + match p.Parser.token with + | And -> attrs + | _ -> + p.scanner.err <- err; + p.scanner.ch <- ch; + p.scanner.offset <- offset; + p.scanner.lineOffset <- lineOffset; + p.scanner.lnum <- lnum; + p.scanner.mode <- mode; + p.token <- token; + p.startPos <- startPos; + p.endPos <- endPos; + p.prevEndPos <- prevEndPos; + p.breadcrumbs <- breadcrumbs; + p.errors <- errors; + p.diagnostics <- diagnostics; + p.comments <- comments; + []) | _ -> [] (* definition ::= let [rec] let-binding { and let-binding } *) @@ -299106,14 +299400,14 @@ and parseLetBindings ~attrs p = let attrs = parseAttributesAndBinding p in match p.Parser.token with | And -> - Parser.next p; - ignore (Parser.optional p Let); - (* overparse for fault tolerance *) - let letBinding = parseLetBindingBody ~startPos ~attrs p in - loop p (letBinding :: bindings) + Parser.next p; + ignore (Parser.optional p Let); + (* overparse for fault tolerance *) + let letBinding = parseLetBindingBody ~startPos ~attrs p in + loop p (letBinding :: bindings) | _ -> List.rev bindings in - (recFlag, loop p [first]) + (recFlag, loop p [ first ]) (* * div -> div @@ -299124,23 +299418,23 @@ and parseJsxName p = let longident = match p.Parser.token with | Lident ident -> - let identStart = p.startPos in - let identEnd = p.endPos in - Parser.next p; - let loc = mkLoc identStart identEnd in - Location.mkloc (Longident.Lident ident) loc + let identStart = p.startPos in + let identEnd = p.endPos in + Parser.next p; + let loc = mkLoc identStart identEnd in + Location.mkloc (Longident.Lident ident) loc | Uident _ -> - let longident = parseModuleLongIdent ~lowercase:true p in - Location.mkloc - (Longident.Ldot (longident.txt, "createElement")) - longident.loc + let longident = parseModuleLongIdent ~lowercase:true p in + Location.mkloc + (Longident.Ldot (longident.txt, "createElement")) + longident.loc | _ -> - let msg = - "A jsx name must be a lowercase or uppercase name, like: div in
or Navbar in " - in - Parser.err p (Diagnostics.message msg); - Location.mknoloc (Longident.Lident "_") + let msg = + "A jsx name must be a lowercase or uppercase name, like: div in
or Navbar in " + in + Parser.err p (Diagnostics.message msg); + Location.mknoloc (Longident.Lident "_") in Ast_helper.Exp.ident ~loc:longident.loc longident @@ -299151,59 +299445,59 @@ and parseJsxOpeningOrSelfClosingElement ~startPos p = let children = match p.Parser.token with | Forwardslash -> - (* *) - let childrenStartPos = p.Parser.startPos in - Parser.next p; - let childrenEndPos = p.Parser.startPos in - Parser.expect GreaterThan p; - let loc = mkLoc childrenStartPos childrenEndPos in - makeListExpression loc [] None (* no children *) - | GreaterThan -> ( - (* bar *) - let childrenStartPos = p.Parser.startPos in - Scanner.setJsxMode p.scanner; - Parser.next p; - let spread, children = parseJsxChildren p in - let childrenEndPos = p.Parser.startPos in - let () = - match p.token with - | LessThanSlash -> Parser.next p - | LessThan -> - Parser.next p; - Parser.expect Forwardslash p - | token when Grammar.isStructureItemStart token -> () - | _ -> Parser.expect LessThanSlash p - in - match p.Parser.token with - | (Lident _ | Uident _) when verifyJsxOpeningClosingName p name -> ( + (* *) + let childrenStartPos = p.Parser.startPos in + Parser.next p; + let childrenEndPos = p.Parser.startPos in Parser.expect GreaterThan p; let loc = mkLoc childrenStartPos childrenEndPos in - match (spread, children) with - | true, child :: _ -> child - | _ -> makeListExpression loc children None) - | token -> ( + makeListExpression loc [] None (* no children *) + | GreaterThan -> ( + (* bar *) + let childrenStartPos = p.Parser.startPos in + Scanner.setJsxMode p.scanner; + Parser.next p; + let spread, children = parseJsxChildren p in + let childrenEndPos = p.Parser.startPos in let () = - if Grammar.isStructureItemStart token then - let closing = "" in - let msg = Diagnostics.message ("Missing " ^ closing) in - Parser.err ~startPos ~endPos:p.prevEndPos p msg - else - let opening = "" in - let msg = - "Closing jsx name should be the same as the opening name. Did \ - you mean " ^ opening ^ " ?" - in - Parser.err ~startPos ~endPos:p.prevEndPos p - (Diagnostics.message msg); - Parser.expect GreaterThan p + match p.token with + | LessThanSlash -> Parser.next p + | LessThan -> + Parser.next p; + Parser.expect Forwardslash p + | token when Grammar.isStructureItemStart token -> () + | _ -> Parser.expect LessThanSlash p in - let loc = mkLoc childrenStartPos childrenEndPos in - match (spread, children) with - | true, child :: _ -> child - | _ -> makeListExpression loc children None)) + match p.Parser.token with + | (Lident _ | Uident _) when verifyJsxOpeningClosingName p name -> ( + Parser.expect GreaterThan p; + let loc = mkLoc childrenStartPos childrenEndPos in + match (spread, children) with + | true, child :: _ -> child + | _ -> makeListExpression loc children None) + | token -> ( + let () = + if Grammar.isStructureItemStart token then + let closing = "" in + let msg = Diagnostics.message ("Missing " ^ closing) in + Parser.err ~startPos ~endPos:p.prevEndPos p msg + else + let opening = "" in + let msg = + "Closing jsx name should be the same as the opening name. \ + Did you mean " ^ opening ^ " ?" + in + Parser.err ~startPos ~endPos:p.prevEndPos p + (Diagnostics.message msg); + Parser.expect GreaterThan p + in + let loc = mkLoc childrenStartPos childrenEndPos in + match (spread, children) with + | true, child :: _ -> child + | _ -> makeListExpression loc children None)) | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - makeListExpression Location.none [] None + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + makeListExpression Location.none [] None in let jsxEndPos = p.prevEndPos in let loc = mkLoc jsxStartPos jsxEndPos in @@ -299236,12 +299530,12 @@ and parseJsx p = match p.Parser.token with | Lident _ | Uident _ -> parseJsxOpeningOrSelfClosingElement ~startPos p | GreaterThan -> - (* fragment: <> foo *) - parseJsxFragment p + (* fragment: <> foo *) + parseJsxFragment p | _ -> parseJsxName p in Parser.eatBreadcrumb p; - {jsxExpr with pexp_attributes = [jsxAttr]} + { jsxExpr with pexp_attributes = [ jsxAttr ] } (* * jsx-fragment ::= @@ -299270,62 +299564,64 @@ and parseJsxFragment p = and parseJsxProp p = match p.Parser.token with | Question | Lident _ -> ( - let optional = Parser.optional p Question in - let name, loc = parseLident p in - let propLocAttr = - (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) - in - (* optional punning: *) - if optional then - Some - ( Asttypes.Optional name, - Ast_helper.Exp.ident ~attrs:[propLocAttr] ~loc - (Location.mkloc (Longident.Lident name) loc) ) - else - match p.Parser.token with - | Equal -> - Parser.next p; - (* no punning *) - let optional = Parser.optional p Question in - let attrExpr = - let e = parsePrimaryExpr ~operand:(parseAtomicExpr p) p in - {e with pexp_attributes = propLocAttr :: e.pexp_attributes} - in - let label = - if optional then Asttypes.Optional name else Asttypes.Labelled name - in - Some (label, attrExpr) - | _ -> - let attrExpr = - Ast_helper.Exp.ident ~loc ~attrs:[propLocAttr] - (Location.mkloc (Longident.Lident name) loc) - in - let label = - if optional then Asttypes.Optional name else Asttypes.Labelled name - in - Some (label, attrExpr)) - (* {...props} *) - | Lbrace -> ( - Parser.next p; - match p.Parser.token with - | DotDotDot -> ( - Parser.next p; - let loc = mkLoc p.Parser.startPos p.prevEndPos in + let optional = Parser.optional p Question in + let name, loc = parseLident p in let propLocAttr = (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) in - let attrExpr = - let e = parsePrimaryExpr ~operand:(parseAtomicExpr p) p in - {e with pexp_attributes = propLocAttr :: e.pexp_attributes} - in - (* using label "spreadProps" to distinguish from others *) - let label = Asttypes.Labelled "_spreadProps" in + (* optional punning: *) + if optional then + Some + ( Asttypes.Optional name, + Ast_helper.Exp.ident ~attrs:[ propLocAttr ] ~loc + (Location.mkloc (Longident.Lident name) loc) ) + else + match p.Parser.token with + | Equal -> + Parser.next p; + (* no punning *) + let optional = Parser.optional p Question in + let attrExpr = + let e = parsePrimaryExpr ~operand:(parseAtomicExpr p) p in + { e with pexp_attributes = propLocAttr :: e.pexp_attributes } + in + let label = + if optional then Asttypes.Optional name + else Asttypes.Labelled name + in + Some (label, attrExpr) + | _ -> + let attrExpr = + Ast_helper.Exp.ident ~loc ~attrs:[ propLocAttr ] + (Location.mkloc (Longident.Lident name) loc) + in + let label = + if optional then Asttypes.Optional name + else Asttypes.Labelled name + in + Some (label, attrExpr)) + (* {...props} *) + | Lbrace -> ( + Parser.next p; match p.Parser.token with - | Rbrace -> - Parser.next p; - Some (label, attrExpr) + | DotDotDot -> ( + Parser.next p; + let loc = mkLoc p.Parser.startPos p.prevEndPos in + let propLocAttr = + (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) + in + let attrExpr = + let e = parsePrimaryExpr ~operand:(parseAtomicExpr p) p in + { e with pexp_attributes = propLocAttr :: e.pexp_attributes } + in + (* using label "spreadProps" to distinguish from others *) + let label = Asttypes.Labelled "_spreadProps" in + match p.Parser.token with + | Rbrace -> + Parser.next p; + Some (label, attrExpr) + | _ -> None) | _ -> None) - | _ -> None) | _ -> None and parseJsxProps p = @@ -299335,39 +299631,39 @@ and parseJsxChildren p = let rec loop p children = match p.Parser.token with | Token.Eof | LessThanSlash -> - Scanner.popMode p.scanner Jsx; - List.rev children + Scanner.popMode p.scanner Jsx; + List.rev children | LessThan -> - (* Imagine:
< - * is `<` the start of a jsx-child?
- * reconsiderLessThan peeks at the next token and - * determines the correct token to disambiguate *) - let token = Scanner.reconsiderLessThan p.scanner in - if token = LessThan then + (* Imagine:
< + * is `<` the start of a jsx-child?
+ * reconsiderLessThan peeks at the next token and + * determines the correct token to disambiguate *) + let token = Scanner.reconsiderLessThan p.scanner in + if token = LessThan then + let child = + parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p + in + loop p (child :: children) + else + (* LessThanSlash *) + let () = p.token <- token in + let () = Scanner.popMode p.scanner Jsx in + List.rev children + | token when Grammar.isJsxChildStart token -> + let () = Scanner.popMode p.scanner Jsx in let child = parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p in loop p (child :: children) - else - (* LessThanSlash *) - let () = p.token <- token in - let () = Scanner.popMode p.scanner Jsx in - List.rev children - | token when Grammar.isJsxChildStart token -> - let () = Scanner.popMode p.scanner Jsx in - let child = - parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p - in - loop p (child :: children) | _ -> - Scanner.popMode p.scanner Jsx; - List.rev children + Scanner.popMode p.scanner Jsx; + List.rev children in match p.Parser.token with | DotDotDot -> - Parser.next p; - (true, [parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p]) + Parser.next p; + (true, [ parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p ]) | _ -> (false, loop p []) and parseBracedOrRecordExpr p = @@ -299375,65 +299671,68 @@ and parseBracedOrRecordExpr p = Parser.expect Lbrace p; match p.Parser.token with | Rbrace -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.record ~loc [] None - | DotDotDot -> - (* beginning of record spread, parse record *) - Parser.next p; - let spreadExpr = parseConstrainedOrCoercedExpr p in - Parser.expect Comma p; - let expr = parseRecordExpr ~startPos ~spread:(Some spreadExpr) [] p in - Parser.expect Rbrace p; - expr - | String s -> ( - let field = - let loc = mkLoc p.startPos p.endPos in Parser.next p; - Location.mkloc (Longident.Lident s) loc - in - match p.Parser.token with - | Colon -> + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.record ~loc [] None + | DotDotDot -> + (* beginning of record spread, parse record *) Parser.next p; - let fieldExpr = parseExpr p in - Parser.optional p Comma |> ignore; - let expr = parseRecordExprWithStringKeys ~startPos (field, fieldExpr) p in + let spreadExpr = parseConstrainedOrCoercedExpr p in + Parser.expect Comma p; + let expr = parseRecordExpr ~startPos ~spread:(Some spreadExpr) [] p in Parser.expect Rbrace p; expr - | _ -> ( - let tag = if p.mode = ParseForTypeChecker then Some "js" else None in - let constant = - Ast_helper.Exp.constant ~loc:field.loc - (Parsetree.Pconst_string (s, tag)) + | String s -> ( + let field = + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc (Longident.Lident s) loc in - let a = parsePrimaryExpr ~operand:constant p in - let e = parseBinaryExpr ~a p 1 in - let e = parseTernaryExpr e p in match p.Parser.token with - | Semicolon -> - let expr = parseExprBlock ~first:e p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - { - expr with - Parsetree.pexp_attributes = braces :: expr.Parsetree.pexp_attributes; - } - | Rbrace -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {e with pexp_attributes = braces :: e.pexp_attributes} - | _ -> - let expr = parseExprBlock ~first:e p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes})) + | Colon -> + Parser.next p; + let fieldExpr = parseExpr p in + Parser.optional p Comma |> ignore; + let expr = + parseRecordExprWithStringKeys ~startPos (field, fieldExpr) p + in + Parser.expect Rbrace p; + expr + | _ -> ( + let tag = if p.mode = ParseForTypeChecker then Some "js" else None in + let constant = + Ast_helper.Exp.constant ~loc:field.loc + (Parsetree.Pconst_string (s, tag)) + in + let a = parsePrimaryExpr ~operand:constant p in + let e = parseBinaryExpr ~a p 1 in + let e = parseTernaryExpr e p in + match p.Parser.token with + | Semicolon -> + let expr = parseExprBlock ~first:e p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + { + expr with + Parsetree.pexp_attributes = + braces :: expr.Parsetree.pexp_attributes; + } + | Rbrace -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + { e with pexp_attributes = braces :: e.pexp_attributes } + | _ -> + let expr = parseExprBlock ~first:e p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + { expr with pexp_attributes = braces :: expr.pexp_attributes })) | Question -> - let expr = parseRecordExpr ~startPos [] p in - Parser.expect Rbrace p; - expr + let expr = parseRecordExpr ~startPos [] p in + Parser.expect Rbrace p; + expr (* The branch below takes care of the "braced" expression {async}. The big reason that we need all these branches is that {x} isn't a record with a punned field x, but a braced expression… There's lots of "ambiguity" between a record with a single punned field and a braced expression… @@ -299443,184 +299742,195 @@ and parseBracedOrRecordExpr p = Due to historical reasons, we always follow 2 *) | Lident "async" when isEs6ArrowExpression ~inTernary:false p -> - let expr = parseAsyncArrowExpression p in - let expr = parseExprBlock ~first:expr p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes} + let expr = parseAsyncArrowExpression p in + let expr = parseExprBlock ~first:expr p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + { expr with pexp_attributes = braces :: expr.pexp_attributes } | Uident _ | Lident _ -> ( - let startToken = p.token in - let valueOrConstructor = parseValueOrConstructor p in - match valueOrConstructor.pexp_desc with - | Pexp_ident pathIdent -> ( - let identEndPos = p.prevEndPos in - match p.Parser.token with - | Comma -> - Parser.next p; - let valueOrConstructor = - match startToken with - | Uident _ -> removeModuleNameFromPunnedFieldValue valueOrConstructor - | _ -> valueOrConstructor - in - let expr = - parseRecordExpr ~startPos [(pathIdent, valueOrConstructor)] p - in - Parser.expect Rbrace p; - expr - | Colon -> ( - Parser.next p; - let optional = parseOptionalLabel p in - let fieldExpr = parseExpr p in - let fieldExpr = makeExpressionOptional ~optional fieldExpr in - match p.token with - | Rbrace -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.record ~loc [(pathIdent, fieldExpr)] None - | _ -> - Parser.expect Comma p; - let expr = parseRecordExpr ~startPos [(pathIdent, fieldExpr)] p in - Parser.expect Rbrace p; - expr) - (* error case *) - | Lident _ -> - if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then ( - Parser.expect Comma p; - let expr = - parseRecordExpr ~startPos [(pathIdent, valueOrConstructor)] p - in - Parser.expect Rbrace p; - expr) - else ( - Parser.expect Colon p; - let expr = - parseRecordExpr ~startPos [(pathIdent, valueOrConstructor)] p - in - Parser.expect Rbrace p; - expr) - | Semicolon -> - let expr = parseExprBlock ~first:(Ast_helper.Exp.ident pathIdent) p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes} - | Rbrace -> - Parser.next p; - let expr = Ast_helper.Exp.ident ~loc:pathIdent.loc pathIdent in - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes} - | EqualGreater -> ( - let loc = mkLoc startPos identEndPos in - let ident = Location.mkloc (Longident.last pathIdent.txt) loc in - let a = - parseEs6ArrowExpression - ~parameters: - [ - TermParameter - { - uncurried = false; - attrs = []; - label = Asttypes.Nolabel; - expr = None; - pat = Ast_helper.Pat.var ident; - pos = startPos; - }; - ] - p - in - let e = parseBinaryExpr ~a p 1 in - let e = parseTernaryExpr e p in - match p.Parser.token with - | Semicolon -> - let expr = parseExprBlock ~first:e p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes} - | Rbrace -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {e with pexp_attributes = braces :: e.pexp_attributes} - | _ -> - let expr = parseExprBlock ~first:e p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes}) + let startToken = p.token in + let valueOrConstructor = parseValueOrConstructor p in + match valueOrConstructor.pexp_desc with + | Pexp_ident pathIdent -> ( + let identEndPos = p.prevEndPos in + match p.Parser.token with + | Comma -> + Parser.next p; + let valueOrConstructor = + match startToken with + | Uident _ -> + removeModuleNameFromPunnedFieldValue valueOrConstructor + | _ -> valueOrConstructor + in + let expr = + parseRecordExpr ~startPos [ (pathIdent, valueOrConstructor) ] p + in + Parser.expect Rbrace p; + expr + | Colon -> ( + Parser.next p; + let optional = parseOptionalLabel p in + let fieldExpr = parseExpr p in + let fieldExpr = makeExpressionOptional ~optional fieldExpr in + match p.token with + | Rbrace -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.record ~loc [ (pathIdent, fieldExpr) ] None + | _ -> + Parser.expect Comma p; + let expr = + parseRecordExpr ~startPos [ (pathIdent, fieldExpr) ] p + in + Parser.expect Rbrace p; + expr) + (* error case *) + | Lident _ -> + if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then ( + Parser.expect Comma p; + let expr = + parseRecordExpr ~startPos + [ (pathIdent, valueOrConstructor) ] + p + in + Parser.expect Rbrace p; + expr) + else ( + Parser.expect Colon p; + let expr = + parseRecordExpr ~startPos + [ (pathIdent, valueOrConstructor) ] + p + in + Parser.expect Rbrace p; + expr) + | Semicolon -> + let expr = + parseExprBlock ~first:(Ast_helper.Exp.ident pathIdent) p + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + { expr with pexp_attributes = braces :: expr.pexp_attributes } + | Rbrace -> + Parser.next p; + let expr = Ast_helper.Exp.ident ~loc:pathIdent.loc pathIdent in + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + { expr with pexp_attributes = braces :: expr.pexp_attributes } + | EqualGreater -> ( + let loc = mkLoc startPos identEndPos in + let ident = Location.mkloc (Longident.last pathIdent.txt) loc in + let a = + parseEs6ArrowExpression + ~parameters: + [ + TermParameter + { + uncurried = false; + attrs = []; + label = Asttypes.Nolabel; + expr = None; + pat = Ast_helper.Pat.var ident; + pos = startPos; + }; + ] + p + in + let e = parseBinaryExpr ~a p 1 in + let e = parseTernaryExpr e p in + match p.Parser.token with + | Semicolon -> + let expr = parseExprBlock ~first:e p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + { expr with pexp_attributes = braces :: expr.pexp_attributes } + | Rbrace -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + { e with pexp_attributes = braces :: e.pexp_attributes } + | _ -> + let expr = parseExprBlock ~first:e p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + { expr with pexp_attributes = braces :: expr.pexp_attributes } + ) + | _ -> ( + Parser.leaveBreadcrumb p Grammar.ExprBlock; + let a = + parsePrimaryExpr + ~operand:(Ast_helper.Exp.ident ~loc:pathIdent.loc pathIdent) + p + in + let e = parseBinaryExpr ~a p 1 in + let e = parseTernaryExpr e p in + Parser.eatBreadcrumb p; + match p.Parser.token with + | Semicolon -> + let expr = parseExprBlock ~first:e p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + { expr with pexp_attributes = braces :: expr.pexp_attributes } + | Rbrace -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + { e with pexp_attributes = braces :: e.pexp_attributes } + | _ -> + let expr = parseExprBlock ~first:e p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + { expr with pexp_attributes = braces :: expr.pexp_attributes } + )) | _ -> ( - Parser.leaveBreadcrumb p Grammar.ExprBlock; - let a = - parsePrimaryExpr - ~operand:(Ast_helper.Exp.ident ~loc:pathIdent.loc pathIdent) - p - in - let e = parseBinaryExpr ~a p 1 in - let e = parseTernaryExpr e p in - Parser.eatBreadcrumb p; - match p.Parser.token with - | Semicolon -> - let expr = parseExprBlock ~first:e p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes} - | Rbrace -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {e with pexp_attributes = braces :: e.pexp_attributes} - | _ -> - let expr = parseExprBlock ~first:e p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes})) - | _ -> ( - Parser.leaveBreadcrumb p Grammar.ExprBlock; - let a = parsePrimaryExpr ~operand:valueOrConstructor p in - let e = parseBinaryExpr ~a p 1 in - let e = parseTernaryExpr e p in - Parser.eatBreadcrumb p; - match p.Parser.token with - | Semicolon -> - let expr = parseExprBlock ~first:e p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes} - | Rbrace -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {e with pexp_attributes = braces :: e.pexp_attributes} - | _ -> - let expr = parseExprBlock ~first:e p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes})) + Parser.leaveBreadcrumb p Grammar.ExprBlock; + let a = parsePrimaryExpr ~operand:valueOrConstructor p in + let e = parseBinaryExpr ~a p 1 in + let e = parseTernaryExpr e p in + Parser.eatBreadcrumb p; + match p.Parser.token with + | Semicolon -> + let expr = parseExprBlock ~first:e p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + { expr with pexp_attributes = braces :: expr.pexp_attributes } + | Rbrace -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + { e with pexp_attributes = braces :: e.pexp_attributes } + | _ -> + let expr = parseExprBlock ~first:e p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + { expr with pexp_attributes = braces :: expr.pexp_attributes })) | _ -> - let expr = parseExprBlock p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes} + let expr = parseExprBlock p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + { expr with pexp_attributes = braces :: expr.pexp_attributes } and parseRecordExprRowWithStringKey p = match p.Parser.token with | String s -> ( - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - let field = Location.mkloc (Longident.Lident s) loc in - match p.Parser.token with - | Colon -> + let loc = mkLoc p.startPos p.endPos in Parser.next p; - let fieldExpr = parseExpr p in - Some (field, fieldExpr) - | _ -> Some (field, Ast_helper.Exp.ident ~loc:field.loc field)) + let field = Location.mkloc (Longident.Lident s) loc in + match p.Parser.token with + | Colon -> + Parser.next p; + let fieldExpr = parseExpr p in + Some (field, fieldExpr) + | _ -> Some (field, Ast_helper.Exp.ident ~loc:field.loc field)) | _ -> None and parseRecordExprRow p = @@ -299628,43 +299938,43 @@ and parseRecordExprRow p = let () = match p.Parser.token with | Token.DotDotDot -> - Parser.err p (Diagnostics.message ErrorMessages.recordExprSpread); - Parser.next p + Parser.err p (Diagnostics.message ErrorMessages.recordExprSpread); + Parser.next p | _ -> () in match p.Parser.token with | Lident _ | Uident _ -> ( - let startToken = p.token in - let field = parseValuePath p in - match p.Parser.token with - | Colon -> - Parser.next p; - let optional = parseOptionalLabel p in - let fieldExpr = parseExpr p in - let fieldExpr = makeExpressionOptional ~optional fieldExpr in - Some (field, fieldExpr) - | _ -> - let value = Ast_helper.Exp.ident ~loc:field.loc ~attrs field in - let value = - match startToken with - | Uident _ -> removeModuleNameFromPunnedFieldValue value - | _ -> value - in - Some (field, value)) - | Question -> ( - Parser.next p; - match p.Parser.token with - | Lident _ | Uident _ -> let startToken = p.token in let field = parseValuePath p in - let value = Ast_helper.Exp.ident ~loc:field.loc ~attrs field in - let value = - match startToken with - | Uident _ -> removeModuleNameFromPunnedFieldValue value - | _ -> value - in - Some (field, makeExpressionOptional ~optional:true value) - | _ -> None) + match p.Parser.token with + | Colon -> + Parser.next p; + let optional = parseOptionalLabel p in + let fieldExpr = parseExpr p in + let fieldExpr = makeExpressionOptional ~optional fieldExpr in + Some (field, fieldExpr) + | _ -> + let value = Ast_helper.Exp.ident ~loc:field.loc ~attrs field in + let value = + match startToken with + | Uident _ -> removeModuleNameFromPunnedFieldValue value + | _ -> value + in + Some (field, value)) + | Question -> ( + Parser.next p; + match p.Parser.token with + | Lident _ | Uident _ -> + let startToken = p.token in + let field = parseValuePath p in + let value = Ast_helper.Exp.ident ~loc:field.loc ~attrs field in + let value = + match startToken with + | Uident _ -> removeModuleNameFromPunnedFieldValue value + | _ -> value + in + Some (field, makeExpressionOptional ~optional:true value) + | _ -> None) | _ -> None and parseRecordExprWithStringKeys ~startPos firstRow p = @@ -299678,19 +299988,19 @@ and parseRecordExprWithStringKeys ~startPos firstRow p = Ast_helper.Str.eval ~loc (Ast_helper.Exp.record ~loc rows None) in Ast_helper.Exp.extension ~loc - (Location.mkloc "obj" loc, Parsetree.PStr [recordStrExpr]) + (Location.mkloc "obj" loc, Parsetree.PStr [ recordStrExpr ]) and parseRecordExpr ~startPos ?(spread = None) rows p = let exprs = parseCommaDelimitedRegion ~grammar:Grammar.RecordRows ~closing:Rbrace ~f:parseRecordExprRow p in - let rows = List.concat [rows; exprs] in + let rows = List.concat [ rows; exprs ] in let () = match rows with | [] -> - let msg = "Record spread needs at least one field that's updated" in - Parser.err p (Diagnostics.message msg) + let msg = "Record spread needs at least one field that's updated" in + Parser.err p (Diagnostics.message msg) | _rows -> () in let loc = mkLoc startPos p.endPos in @@ -299700,12 +300010,12 @@ and parseNewlineOrSemicolonExprBlock p = match p.Parser.token with | Semicolon -> Parser.next p | token when Grammar.isBlockExprStart token -> - if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then () - else - Parser.err ~startPos:p.prevEndPos ~endPos:p.endPos p - (Diagnostics.message - "consecutive expressions on a line must be separated by ';' or a \ - newline") + if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then () + else + Parser.err ~startPos:p.prevEndPos ~endPos:p.endPos p + (Diagnostics.message + "consecutive expressions on a line must be separated by ';' or a \ + newline") | _ -> () and parseExprBlockItem p = @@ -299713,65 +300023,68 @@ and parseExprBlockItem p = let attrs = parseAttributes p in match p.Parser.token with | Module -> ( - Parser.next p; - match p.token with - | Lparen -> - let expr = parseFirstClassModuleExpr ~startPos p in - let a = parsePrimaryExpr ~operand:expr p in - let expr = parseBinaryExpr ~a p 1 in - parseTernaryExpr expr p - | _ -> - let name = - match p.Parser.token with - | Uident ident -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Location.mkloc ident loc - | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" - in - let body = parseModuleBindingBody p in + Parser.next p; + match p.token with + | Lparen -> + let expr = parseFirstClassModuleExpr ~startPos p in + let a = parsePrimaryExpr ~operand:expr p in + let expr = parseBinaryExpr ~a p 1 in + parseTernaryExpr expr p + | _ -> + let name = + match p.Parser.token with + | Uident ident -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc ident loc + | t -> + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" + in + let body = parseModuleBindingBody p in + parseNewlineOrSemicolonExprBlock p; + let expr = parseExprBlock p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.letmodule ~loc name body expr) + | Exception -> + let extensionConstructor = parseExceptionDef ~attrs p in parseNewlineOrSemicolonExprBlock p; - let expr = parseExprBlock p in + let blockExpr = parseExprBlock p in let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.letmodule ~loc name body expr) - | Exception -> - let extensionConstructor = parseExceptionDef ~attrs p in - parseNewlineOrSemicolonExprBlock p; - let blockExpr = parseExprBlock p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.letexception ~loc extensionConstructor blockExpr + Ast_helper.Exp.letexception ~loc extensionConstructor blockExpr | Open -> - let od = parseOpenDescription ~attrs p in - parseNewlineOrSemicolonExprBlock p; - let blockExpr = parseExprBlock p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.open_ ~loc od.popen_override od.popen_lid blockExpr + let od = parseOpenDescription ~attrs p in + parseNewlineOrSemicolonExprBlock p; + let blockExpr = parseExprBlock p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.open_ ~loc od.popen_override od.popen_lid blockExpr | Let -> - let recFlag, letBindings = parseLetBindings ~attrs p in - parseNewlineOrSemicolonExprBlock p; - let next = - if Grammar.isBlockExprStart p.Parser.token then parseExprBlock p - else - let loc = mkLoc p.startPos p.endPos in - Ast_helper.Exp.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - None - in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.let_ ~loc recFlag letBindings next + let recFlag, letBindings = parseLetBindings ~attrs p in + parseNewlineOrSemicolonExprBlock p; + let next = + if Grammar.isBlockExprStart p.Parser.token then parseExprBlock p + else + let loc = mkLoc p.startPos p.endPos in + Ast_helper.Exp.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None + in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.let_ ~loc recFlag letBindings next | _ -> - let e1 = - let expr = parseExpr p in - {expr with pexp_attributes = List.concat [attrs; expr.pexp_attributes]} - in - parseNewlineOrSemicolonExprBlock p; - if Grammar.isBlockExprStart p.Parser.token then - let e2 = parseExprBlock p in - let loc = {e1.pexp_loc with loc_end = e2.pexp_loc.loc_end} in - Ast_helper.Exp.sequence ~loc e1 e2 - else e1 + let e1 = + let expr = parseExpr p in + { + expr with + pexp_attributes = List.concat [ attrs; expr.pexp_attributes ]; + } + in + parseNewlineOrSemicolonExprBlock p; + if Grammar.isBlockExprStart p.Parser.token then + let e2 = parseExprBlock p in + let loc = { e1.pexp_loc with loc_end = e2.pexp_loc.loc_end } in + Ast_helper.Exp.sequence ~loc e1 e2 + else e1 (* blockExpr ::= expr * | expr ; @@ -299788,16 +300101,12 @@ and parseExprBlockItem p = *) and parseExprBlock ?first p = Parser.leaveBreadcrumb p Grammar.ExprBlock; - let item = - match first with - | Some e -> e - | None -> parseExprBlockItem p - in + let item = match first with Some e -> e | None -> parseExprBlockItem p in parseNewlineOrSemicolonExprBlock p; let blockExpr = if Grammar.isBlockExprStart p.Parser.token then let next = parseExprBlockItem p in - let loc = {item.pexp_loc with loc_end = next.pexp_loc.loc_end} in + let loc = { item.pexp_loc with loc_end = next.pexp_loc.loc_end } in Ast_helper.Exp.sequence ~loc item next else item in @@ -299812,7 +300121,7 @@ and parseAsyncArrowExpression p = { expr with pexp_attributes = asyncAttr :: expr.pexp_attributes; - pexp_loc = {expr.pexp_loc with loc_start = startPos}; + pexp_loc = { expr.pexp_loc with loc_start = startPos }; } and parseAwaitExpression p = @@ -299823,7 +300132,7 @@ and parseAwaitExpression p = { expr with pexp_attributes = awaitAttr :: expr.pexp_attributes; - pexp_loc = {expr.pexp_loc with loc_start = awaitLoc.loc_start}; + pexp_loc = { expr.pexp_loc with loc_start = awaitLoc.loc_start }; } and parseTryExpression p = @@ -299864,21 +300173,21 @@ and parseIfExpr startPos p = let elseExpr = match p.Parser.token with | Else -> - Parser.endRegion p; - Parser.leaveBreadcrumb p Grammar.ElseBranch; - Parser.next p; - Parser.beginRegion p; - let elseExpr = - match p.token with - | If -> parseIfOrIfLetExpression p - | _ -> parseElseBranch p - in - Parser.eatBreadcrumb p; - Parser.endRegion p; - Some elseExpr + Parser.endRegion p; + Parser.leaveBreadcrumb p Grammar.ElseBranch; + Parser.next p; + Parser.beginRegion p; + let elseExpr = + match p.token with + | If -> parseIfOrIfLetExpression p + | _ -> parseElseBranch p + in + Parser.eatBreadcrumb p; + Parser.endRegion p; + Some elseExpr | _ -> - Parser.endRegion p; - None + Parser.endRegion p; + None in let loc = mkLoc startPos p.prevEndPos in Ast_helper.Exp.ifthenelse ~loc conditionExpr thenExpr elseExpr @@ -299891,29 +300200,29 @@ and parseIfLetExpr startPos p = let elseExpr = match p.Parser.token with | Else -> - Parser.endRegion p; - Parser.leaveBreadcrumb p Grammar.ElseBranch; - Parser.next p; - Parser.beginRegion p; - let elseExpr = - match p.token with - | If -> parseIfOrIfLetExpression p - | _ -> parseElseBranch p - in - Parser.eatBreadcrumb p; - Parser.endRegion p; - elseExpr + Parser.endRegion p; + Parser.leaveBreadcrumb p Grammar.ElseBranch; + Parser.next p; + Parser.beginRegion p; + let elseExpr = + match p.token with + | If -> parseIfOrIfLetExpression p + | _ -> parseElseBranch p + in + Parser.eatBreadcrumb p; + Parser.endRegion p; + elseExpr | _ -> - Parser.endRegion p; - let startPos = p.Parser.startPos in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - None + Parser.endRegion p; + let startPos = p.Parser.startPos in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None in let loc = mkLoc startPos p.prevEndPos in Ast_helper.Exp.match_ - ~attrs:[ifLetAttr; suppressFragileMatchWarningAttr] + ~attrs:[ ifLetAttr; suppressFragileMatchWarningAttr ] ~loc conditionExpr [ Ast_helper.Exp.case pattern thenExpr; @@ -299928,12 +300237,12 @@ and parseIfOrIfLetExpression p = let expr = match p.Parser.token with | Let -> - Parser.next p; - let ifLetExpr = parseIfLetExpr startPos p in - Parser.err ~startPos:ifLetExpr.pexp_loc.loc_start - ~endPos:ifLetExpr.pexp_loc.loc_end p - (Diagnostics.message (ErrorMessages.experimentalIfLet ifLetExpr)); - ifLetExpr + Parser.next p; + let ifLetExpr = parseIfLetExpr startPos p in + Parser.err ~startPos:ifLetExpr.pexp_loc.loc_start + ~endPos:ifLetExpr.pexp_loc.loc_end p + (Diagnostics.message (ErrorMessages.experimentalIfLet ifLetExpr)); + ifLetExpr | _ -> parseIfExpr startPos p in Parser.eatBreadcrumb p; @@ -299947,8 +300256,8 @@ and parseForRest hasOpeningParen pattern startPos p = | Lident "to" -> Asttypes.Upto | Lident "downto" -> Asttypes.Downto | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Asttypes.Upto + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Asttypes.Upto in if p.Parser.token = Eof then Parser.err ~startPos:p.startPos p @@ -299970,37 +300279,37 @@ and parseForExpression p = let forExpr = match p.token with | Lparen -> ( - let lparen = p.startPos in - Parser.next p; - match p.token with - | Rparen -> + let lparen = p.startPos in Parser.next p; - let unitPattern = - let loc = mkLoc lparen p.prevEndPos in - let lid = Location.mkloc (Longident.Lident "()") loc in - Ast_helper.Pat.construct lid None - in - parseForRest false - (parseAliasPattern ~attrs:[] unitPattern p) - startPos p - | _ -> ( + match p.token with + | Rparen -> + Parser.next p; + let unitPattern = + let loc = mkLoc lparen p.prevEndPos in + let lid = Location.mkloc (Longident.Lident "()") loc in + Ast_helper.Pat.construct lid None + in + parseForRest false + (parseAliasPattern ~attrs:[] unitPattern p) + startPos p + | _ -> ( + Parser.leaveBreadcrumb p Grammar.Pattern; + let pat = parsePattern p in + Parser.eatBreadcrumb p; + match p.token with + | Comma -> + Parser.next p; + let tuplePattern = + parseTuplePattern ~attrs:[] ~startPos:lparen ~first:pat p + in + let pattern = parseAliasPattern ~attrs:[] tuplePattern p in + parseForRest false pattern startPos p + | _ -> parseForRest true pat startPos p)) + | _ -> Parser.leaveBreadcrumb p Grammar.Pattern; let pat = parsePattern p in Parser.eatBreadcrumb p; - match p.token with - | Comma -> - Parser.next p; - let tuplePattern = - parseTuplePattern ~attrs:[] ~startPos:lparen ~first:pat p - in - let pattern = parseAliasPattern ~attrs:[] tuplePattern p in - parseForRest false pattern startPos p - | _ -> parseForRest true pat startPos p)) - | _ -> - Parser.leaveBreadcrumb p Grammar.Pattern; - let pat = parsePattern p in - Parser.eatBreadcrumb p; - parseForRest false pat startPos p + parseForRest false pat startPos p in Parser.eatBreadcrumb p; Parser.endRegion p; @@ -300019,8 +300328,8 @@ and parseWhileExpression p = and parsePatternGuard p = match p.Parser.token with | When | If -> - Parser.next p; - Some (parseExpr ~context:WhenExpr p) + Parser.next p; + Some (parseExpr ~context:WhenExpr p) | _ -> None and parsePatternMatchCase p = @@ -300028,24 +300337,24 @@ and parsePatternMatchCase p = Parser.leaveBreadcrumb p Grammar.PatternMatchCase; match p.Parser.token with | Token.Bar -> - Parser.next p; - Parser.leaveBreadcrumb p Grammar.Pattern; - let lhs = parsePattern p in - Parser.eatBreadcrumb p; - let guard = parsePatternGuard p in - let () = - match p.token with - | EqualGreater -> Parser.next p - | _ -> Recover.recoverEqualGreater p - in - let rhs = parseExprBlock p in - Parser.endRegion p; - Parser.eatBreadcrumb p; - Some (Ast_helper.Exp.case lhs ?guard rhs) + Parser.next p; + Parser.leaveBreadcrumb p Grammar.Pattern; + let lhs = parsePattern p in + Parser.eatBreadcrumb p; + let guard = parsePatternGuard p in + let () = + match p.token with + | EqualGreater -> Parser.next p + | _ -> Recover.recoverEqualGreater p + in + let rhs = parseExprBlock p in + Parser.endRegion p; + Parser.eatBreadcrumb p; + Some (Ast_helper.Exp.case lhs ?guard rhs) | _ -> - Parser.endRegion p; - Parser.eatBreadcrumb p; - None + Parser.endRegion p; + Parser.eatBreadcrumb p; + None and parsePatternMatching p = let cases = @@ -300055,8 +300364,8 @@ and parsePatternMatching p = let () = match cases with | [] -> - Parser.err ~startPos:p.prevEndPos p - (Diagnostics.message "Pattern matching needs at least one case") + Parser.err ~startPos:p.prevEndPos p + (Diagnostics.message "Pattern matching needs at least one case") | _ -> () in cases @@ -300097,18 +300406,18 @@ and parseArgument p = then match p.Parser.token with | Dot -> ( - let uncurried = true in - Parser.next p; - match p.token with - (* apply(.) *) - | Rparen -> - let unitExpr = - Ast_helper.Exp.construct - (Location.mknoloc (Longident.Lident "()")) - None - in - Some (uncurried, Asttypes.Nolabel, unitExpr) - | _ -> parseArgument2 p ~uncurried) + let uncurried = true in + Parser.next p; + match p.token with + (* apply(.) *) + | Rparen -> + let unitExpr = + Ast_helper.Exp.construct + (Location.mknoloc (Longident.Lident "()")) + None + in + Some (uncurried, Asttypes.Nolabel, unitExpr) + | _ -> parseArgument2 p ~uncurried) | _ -> parseArgument2 p ~uncurried:false else None @@ -300116,65 +300425,70 @@ and parseArgument2 p ~uncurried = match p.Parser.token with (* foo(_), do not confuse with foo(_ => x), TODO: performance *) | Underscore when not (isEs6ArrowExpression ~inTernary:false p) -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - let exp = - Ast_helper.Exp.ident ~loc (Location.mkloc (Longident.Lident "_") loc) - in - Some (uncurried, Asttypes.Nolabel, exp) - | Tilde -> ( - Parser.next p; - (* TODO: nesting of pattern matches not intuitive for error recovery *) - match p.Parser.token with - | Lident ident -> ( - let startPos = p.startPos in + let loc = mkLoc p.startPos p.endPos in Parser.next p; - let endPos = p.prevEndPos in - let loc = mkLoc startPos endPos in - let propLocAttr = - (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) - in - let identExpr = - Ast_helper.Exp.ident ~attrs:[propLocAttr] ~loc - (Location.mkloc (Longident.Lident ident) loc) + let exp = + Ast_helper.Exp.ident ~loc (Location.mkloc (Longident.Lident "_") loc) in + Some (uncurried, Asttypes.Nolabel, exp) + | Tilde -> ( + Parser.next p; + (* TODO: nesting of pattern matches not intuitive for error recovery *) match p.Parser.token with - | Question -> - Parser.next p; - Some (uncurried, Asttypes.Optional ident, identExpr) - | Equal -> - Parser.next p; - let label = + | Lident ident -> ( + let startPos = p.startPos in + Parser.next p; + let endPos = p.prevEndPos in + let loc = mkLoc startPos endPos in + let propLocAttr = + (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) + in + let identExpr = + Ast_helper.Exp.ident ~attrs:[ propLocAttr ] ~loc + (Location.mkloc (Longident.Lident ident) loc) + in match p.Parser.token with | Question -> - Parser.next p; - Asttypes.Optional ident - | _ -> Labelled ident - in - let expr = - match p.Parser.token with - | Underscore when not (isEs6ArrowExpression ~inTernary:false p) -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Ast_helper.Exp.ident ~loc - (Location.mkloc (Longident.Lident "_") loc) - | _ -> - let expr = parseConstrainedOrCoercedExpr p in - {expr with pexp_attributes = propLocAttr :: expr.pexp_attributes} - in - Some (uncurried, label, expr) - | Colon -> - Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc startPos p.prevEndPos in - let expr = - Ast_helper.Exp.constraint_ ~attrs:[propLocAttr] ~loc identExpr typ - in - Some (uncurried, Labelled ident, expr) - | _ -> Some (uncurried, Labelled ident, identExpr)) - | t -> - Parser.err p (Diagnostics.lident t); - Some (uncurried, Nolabel, Recover.defaultExpr ())) + Parser.next p; + Some (uncurried, Asttypes.Optional ident, identExpr) + | Equal -> + Parser.next p; + let label = + match p.Parser.token with + | Question -> + Parser.next p; + Asttypes.Optional ident + | _ -> Labelled ident + in + let expr = + match p.Parser.token with + | Underscore when not (isEs6ArrowExpression ~inTernary:false p) + -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Ast_helper.Exp.ident ~loc + (Location.mkloc (Longident.Lident "_") loc) + | _ -> + let expr = parseConstrainedOrCoercedExpr p in + { + expr with + pexp_attributes = propLocAttr :: expr.pexp_attributes; + } + in + Some (uncurried, label, expr) + | Colon -> + Parser.next p; + let typ = parseTypExpr p in + let loc = mkLoc startPos p.prevEndPos in + let expr = + Ast_helper.Exp.constraint_ ~attrs:[ propLocAttr ] ~loc identExpr + typ + in + Some (uncurried, Labelled ident, expr) + | _ -> Some (uncurried, Labelled ident, identExpr)) + | t -> + Parser.err p (Diagnostics.lident t); + Some (uncurried, Nolabel, Recover.defaultExpr ())) | _ -> Some (uncurried, Nolabel, parseConstrainedOrCoercedExpr p) and parseCallExpr p funExpr = @@ -300189,63 +300503,65 @@ and parseCallExpr p funExpr = let args = match args with | [] -> - let loc = mkLoc startPos p.prevEndPos in - (* No args -> unit sugar: `foo()` *) - [ - ( false, - Asttypes.Nolabel, - Ast_helper.Exp.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - None ); - ] + let loc = mkLoc startPos p.prevEndPos in + (* No args -> unit sugar: `foo()` *) + [ + ( false, + Asttypes.Nolabel, + Ast_helper.Exp.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None ); + ] | [ ( true, Asttypes.Nolabel, ({ - pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, None); + pexp_desc = Pexp_construct ({ txt = Longident.Lident "()" }, None); pexp_loc = loc; pexp_attributes = []; } as expr) ); ] when (not loc.loc_ghost) && p.mode = ParseForTypeChecker -> - (* Since there is no syntax space for arity zero vs arity one, - * we expand - * `fn(. ())` into - * `fn(. {let __res_unit = (); __res_unit})` - * when the parsetree is intended for type checking - * - * Note: - * `fn(.)` is treated as zero arity application. - * The invisible unit expression here has loc_ghost === true - * - * Related: https://github.com/rescript-lang/syntax/issues/138 - *) - [ - ( true, - Asttypes.Nolabel, - Ast_helper.Exp.let_ Asttypes.Nonrecursive - [ - Ast_helper.Vb.mk - (Ast_helper.Pat.var (Location.mknoloc "__res_unit")) - expr; - ] - (Ast_helper.Exp.ident - (Location.mknoloc (Longident.Lident "__res_unit"))) ); - ] + (* Since there is no syntax space for arity zero vs arity one, + * we expand + * `fn(. ())` into + * `fn(. {let __res_unit = (); __res_unit})` + * when the parsetree is intended for type checking + * + * Note: + * `fn(.)` is treated as zero arity application. + * The invisible unit expression here has loc_ghost === true + * + * Related: https://github.com/rescript-lang/syntax/issues/138 + *) + [ + ( true, + Asttypes.Nolabel, + Ast_helper.Exp.let_ Asttypes.Nonrecursive + [ + Ast_helper.Vb.mk + (Ast_helper.Pat.var (Location.mknoloc "__res_unit")) + expr; + ] + (Ast_helper.Exp.ident + (Location.mknoloc (Longident.Lident "__res_unit"))) ); + ] | args -> args in - let loc = {funExpr.pexp_loc with loc_end = p.prevEndPos} in + let loc = { funExpr.pexp_loc with loc_end = p.prevEndPos } in let args = match args with | (u, lbl, expr) :: args -> - let group (grp, acc) (uncurried, lbl, expr) = - let _u, grp = grp in - if uncurried == true then - ((true, [(lbl, expr)]), (_u, List.rev grp) :: acc) - else ((_u, (lbl, expr) :: grp), acc) - in - let (_u, grp), acc = List.fold_left group ((u, [(lbl, expr)]), []) args in - List.rev ((_u, List.rev grp) :: acc) + let group (grp, acc) (uncurried, lbl, expr) = + let _u, grp = grp in + if uncurried == true then + ((true, [ (lbl, expr) ]), (_u, List.rev grp) :: acc) + else ((_u, (lbl, expr) :: grp), acc) + in + let (_u, grp), acc = + List.fold_left group ((u, [ (lbl, expr) ]), []) args + in + List.rev ((_u, List.rev grp) :: acc) | [] -> [] in let apply = @@ -300255,7 +300571,7 @@ and parseCallExpr p funExpr = let args, wrap = processUnderscoreApplication args in let exp = if uncurried then - let attrs = [uncurryAttr] in + let attrs = [ uncurryAttr ] in Ast_helper.Exp.apply ~loc ~attrs callBody args else Ast_helper.Exp.apply ~loc callBody args in @@ -300270,55 +300586,55 @@ and parseValueOrConstructor p = let rec aux p acc = match p.Parser.token with | Uident ident -> ( - let endPosLident = p.endPos in - Parser.next p; - match p.Parser.token with - | Dot -> + let endPosLident = p.endPos in Parser.next p; - aux p (ident :: acc) - | Lparen when p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> - let lparen = p.startPos in - let args = parseConstructorArgs p in - let rparen = p.prevEndPos in - let lident = buildLongident (ident :: acc) in - let tail = - match args with - | [] -> None - | [({Parsetree.pexp_desc = Pexp_tuple _} as arg)] as args -> - let loc = mkLoc lparen rparen in - if p.mode = ParseForTypeChecker then - (* Some(1, 2) for type-checker *) - Some arg - else - (* Some((1, 2)) for printer *) - Some (Ast_helper.Exp.tuple ~loc args) - | [arg] -> Some arg - | args -> - let loc = mkLoc lparen rparen in - Some (Ast_helper.Exp.tuple ~loc args) - in - let loc = mkLoc startPos p.prevEndPos in - let identLoc = mkLoc startPos endPosLident in - Ast_helper.Exp.construct ~loc (Location.mkloc lident identLoc) tail - | _ -> - let loc = mkLoc startPos p.prevEndPos in - let lident = buildLongident (ident :: acc) in - Ast_helper.Exp.construct ~loc (Location.mkloc lident loc) None) + match p.Parser.token with + | Dot -> + Parser.next p; + aux p (ident :: acc) + | Lparen when p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> + let lparen = p.startPos in + let args = parseConstructorArgs p in + let rparen = p.prevEndPos in + let lident = buildLongident (ident :: acc) in + let tail = + match args with + | [] -> None + | [ ({ Parsetree.pexp_desc = Pexp_tuple _ } as arg) ] as args -> + let loc = mkLoc lparen rparen in + if p.mode = ParseForTypeChecker then + (* Some(1, 2) for type-checker *) + Some arg + else + (* Some((1, 2)) for printer *) + Some (Ast_helper.Exp.tuple ~loc args) + | [ arg ] -> Some arg + | args -> + let loc = mkLoc lparen rparen in + Some (Ast_helper.Exp.tuple ~loc args) + in + let loc = mkLoc startPos p.prevEndPos in + let identLoc = mkLoc startPos endPosLident in + Ast_helper.Exp.construct ~loc (Location.mkloc lident identLoc) tail + | _ -> + let loc = mkLoc startPos p.prevEndPos in + let lident = buildLongident (ident :: acc) in + Ast_helper.Exp.construct ~loc (Location.mkloc lident loc) None) | Lident ident -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let lident = buildLongident (ident :: acc) in - Ast_helper.Exp.ident ~loc (Location.mkloc lident loc) - | token -> - if acc = [] then ( - Parser.nextUnsafe p; - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Recover.defaultExpr ()) - else + Parser.next p; let loc = mkLoc startPos p.prevEndPos in - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - let lident = buildLongident ("_" :: acc) in + let lident = buildLongident (ident :: acc) in Ast_helper.Exp.ident ~loc (Location.mkloc lident loc) + | token -> + if acc = [] then ( + Parser.nextUnsafe p; + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Recover.defaultExpr ()) + else + let loc = mkLoc startPos p.prevEndPos in + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + let lident = buildLongident ("_" :: acc) in + Ast_helper.Exp.ident ~loc (Location.mkloc lident loc) in aux p [] @@ -300327,30 +300643,30 @@ and parsePolyVariantExpr p = let ident, _loc = parseHashIdent ~startPos p in match p.Parser.token with | Lparen when p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> - let lparen = p.startPos in - let args = parseConstructorArgs p in - let rparen = p.prevEndPos in - let loc_paren = mkLoc lparen rparen in - let tail = - match args with - | [] -> None - | [({Parsetree.pexp_desc = Pexp_tuple _} as expr)] as args -> - if p.mode = ParseForTypeChecker then - (* #a(1, 2) for type-checker *) - Some expr - else - (* #a((1, 2)) for type-checker *) - Some (Ast_helper.Exp.tuple ~loc:loc_paren args) - | [arg] -> Some arg - | args -> - (* #a((1, 2)) for printer *) - Some (Ast_helper.Exp.tuple ~loc:loc_paren args) - in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.variant ~loc ident tail + let lparen = p.startPos in + let args = parseConstructorArgs p in + let rparen = p.prevEndPos in + let loc_paren = mkLoc lparen rparen in + let tail = + match args with + | [] -> None + | [ ({ Parsetree.pexp_desc = Pexp_tuple _ } as expr) ] as args -> + if p.mode = ParseForTypeChecker then + (* #a(1, 2) for type-checker *) + Some expr + else + (* #a((1, 2)) for type-checker *) + Some (Ast_helper.Exp.tuple ~loc:loc_paren args) + | [ arg ] -> Some arg + | args -> + (* #a((1, 2)) for printer *) + Some (Ast_helper.Exp.tuple ~loc:loc_paren args) + in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.variant ~loc ident tail | _ -> - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.variant ~loc ident None + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.variant ~loc ident None and parseConstructorArgs p = let lparen = p.Parser.startPos in @@ -300362,12 +300678,12 @@ and parseConstructorArgs p = Parser.expect Rparen p; match args with | [] -> - let loc = mkLoc lparen p.prevEndPos in - [ - Ast_helper.Exp.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - None; - ] + let loc = mkLoc lparen p.prevEndPos in + [ + Ast_helper.Exp.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None; + ] | args -> args and parseTupleExpr ~first ~startPos p = @@ -300379,9 +300695,9 @@ and parseTupleExpr ~first ~startPos p = Parser.expect Rparen p; let () = match exprs with - | [_] -> - Parser.err ~startPos ~endPos:p.prevEndPos p - (Diagnostics.message ErrorMessages.tupleSingleElement) + | [ _ ] -> + Parser.err ~startPos ~endPos:p.prevEndPos p + (Diagnostics.message ErrorMessages.tupleSingleElement) | _ -> () in let loc = mkLoc startPos p.prevEndPos in @@ -300391,11 +300707,11 @@ and parseSpreadExprRegionWithLoc p = let startPos = p.Parser.prevEndPos in match p.Parser.token with | DotDotDot -> - Parser.next p; - let expr = parseConstrainedOrCoercedExpr p in - Some (true, expr, startPos, p.prevEndPos) + Parser.next p; + let expr = parseConstrainedOrCoercedExpr p in + Some (true, expr, startPos, p.prevEndPos) | token when Grammar.isExprStart token -> - Some (false, parseConstrainedOrCoercedExpr p, startPos, p.prevEndPos) + Some (false, parseConstrainedOrCoercedExpr p, startPos, p.prevEndPos) | _ -> None and parseListExpr ~startPos p = @@ -300404,23 +300720,23 @@ and parseListExpr ~startPos p = (fun acc curr -> match (curr, acc) with | (true, expr, startPos, endPos), _ -> - (* find a spread expression, prepend a new sublist *) - ([], Some expr, startPos, endPos) :: acc + (* find a spread expression, prepend a new sublist *) + ([], Some expr, startPos, endPos) :: acc | ( (false, expr, startPos, _endPos), (no_spreads, spread, _accStartPos, accEndPos) :: acc ) -> - (* find a non-spread expression, and the accumulated is not empty, - * prepend to the first sublist, and update the loc of the first sublist *) - (expr :: no_spreads, spread, startPos, accEndPos) :: acc + (* find a non-spread expression, and the accumulated is not empty, + * prepend to the first sublist, and update the loc of the first sublist *) + (expr :: no_spreads, spread, startPos, accEndPos) :: acc | (false, expr, startPos, endPos), [] -> - (* find a non-spread expression, and the accumulated is empty *) - [([expr], None, startPos, endPos)]) + (* find a non-spread expression, and the accumulated is empty *) + [ ([ expr ], None, startPos, endPos) ]) [] exprs in let make_sub_expr = function | exprs, Some spread, startPos, endPos -> - makeListExpression (mkLoc startPos endPos) exprs (Some spread) + makeListExpression (mkLoc startPos endPos) exprs (Some spread) | exprs, None, startPos, endPos -> - makeListExpression (mkLoc startPos endPos) exprs None + makeListExpression (mkLoc startPos endPos) exprs None in let listExprsRev = parseCommaDelimitedReversedList p ~grammar:Grammar.ListExpr ~closing:Rbrace @@ -300430,37 +300746,37 @@ and parseListExpr ~startPos p = let loc = mkLoc startPos p.prevEndPos in match split_by_spread listExprsRev with | [] -> makeListExpression loc [] None - | [(exprs, Some spread, _, _)] -> makeListExpression loc exprs (Some spread) - | [(exprs, None, _, _)] -> makeListExpression loc exprs None + | [ (exprs, Some spread, _, _) ] -> makeListExpression loc exprs (Some spread) + | [ (exprs, None, _, _) ] -> makeListExpression loc exprs None | exprs -> - let listExprs = List.map make_sub_expr exprs in - Ast_helper.Exp.apply ~loc - (Ast_helper.Exp.ident ~loc ~attrs:[spreadAttr] - (Location.mkloc - (Longident.Ldot - (Longident.Ldot (Longident.Lident "Belt", "List"), "concatMany")) - loc)) - [(Asttypes.Nolabel, Ast_helper.Exp.array ~loc listExprs)] + let listExprs = List.map make_sub_expr exprs in + Ast_helper.Exp.apply ~loc + (Ast_helper.Exp.ident ~loc ~attrs:[ spreadAttr ] + (Location.mkloc + (Longident.Ldot + (Longident.Ldot (Longident.Lident "Belt", "List"), "concatMany")) + loc)) + [ (Asttypes.Nolabel, Ast_helper.Exp.array ~loc listExprs) ] (* Overparse ... and give a nice error message *) and parseNonSpreadExp ~msg p = let () = match p.Parser.token with | DotDotDot -> - Parser.err p (Diagnostics.message msg); - Parser.next p + Parser.err p (Diagnostics.message msg); + Parser.next p | _ -> () in match p.Parser.token with | token when Grammar.isExprStart token -> ( - let expr = parseExpr p in - match p.Parser.token with - | Colon -> - Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in - Some (Ast_helper.Exp.constraint_ ~loc expr typ) - | _ -> Some expr) + let expr = parseExpr p in + match p.Parser.token with + | Colon -> + Parser.next p; + let typ = parseTypExpr p in + let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in + Some (Ast_helper.Exp.constraint_ ~loc expr typ) + | _ -> Some expr) | _ -> None and parseArrayExp p = @@ -300479,28 +300795,28 @@ and parsePolyTypeExpr p = let startPos = p.Parser.startPos in match p.Parser.token with | SingleQuote -> ( - let vars = parseTypeVarList p in - match vars with - | _v1 :: _v2 :: _ -> - Parser.expect Dot p; - let typ = parseTypExpr p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.poly ~loc vars typ - | [var] -> ( - match p.Parser.token with - | Dot -> - Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.poly ~loc vars typ - | EqualGreater -> - Parser.next p; - let typ = Ast_helper.Typ.var ~loc:var.loc var.txt in - let returnType = parseTypExpr ~alias:false p in - let loc = mkLoc typ.Parsetree.ptyp_loc.loc_start p.prevEndPos in - Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType - | _ -> Ast_helper.Typ.var ~loc:var.loc var.txt) - | _ -> assert false) + let vars = parseTypeVarList p in + match vars with + | _v1 :: _v2 :: _ -> + Parser.expect Dot p; + let typ = parseTypExpr p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.poly ~loc vars typ + | [ var ] -> ( + match p.Parser.token with + | Dot -> + Parser.next p; + let typ = parseTypExpr p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.poly ~loc vars typ + | EqualGreater -> + Parser.next p; + let typ = Ast_helper.Typ.var ~loc:var.loc var.txt in + let returnType = parseTypExpr ~alias:false p in + let loc = mkLoc typ.Parsetree.ptyp_loc.loc_start p.prevEndPos in + Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType + | _ -> Ast_helper.Typ.var ~loc:var.loc var.txt) + | _ -> assert false) | _ -> parseTypExpr p (* 'a 'b 'c *) @@ -300508,10 +300824,10 @@ and parseTypeVarList p = let rec loop p vars = match p.Parser.token with | SingleQuote -> - Parser.next p; - let lident, loc = parseLident p in - let var = Location.mkloc lident loc in - loop p (var :: vars) + Parser.next p; + let lident, loc = parseLident p in + let var = Location.mkloc lident loc in + loop p (var :: vars) | _ -> List.rev vars in loop p [] @@ -300520,9 +300836,9 @@ and parseLidentList p = let rec loop p ls = match p.Parser.token with | Lident lident -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - loop p (Location.mkloc lident loc :: ls) + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + loop p (Location.mkloc lident loc :: ls) | _ -> List.rev ls in loop p [] @@ -300533,71 +300849,72 @@ and parseAtomicTypExpr ~attrs p = let typ = match p.Parser.token with | SingleQuote -> - Parser.next p; - let ident, loc = - if p.Parser.token = Eof then ( - Parser.err ~startPos:p.startPos p - (Diagnostics.unexpected p.Parser.token p.breadcrumbs); - ("", mkLoc p.startPos p.prevEndPos)) - else parseIdent ~msg:ErrorMessages.typeVar ~startPos:p.startPos p - in - Ast_helper.Typ.var ~loc ~attrs ident + Parser.next p; + let ident, loc = + if p.Parser.token = Eof then ( + Parser.err ~startPos:p.startPos p + (Diagnostics.unexpected p.Parser.token p.breadcrumbs); + ("", mkLoc p.startPos p.prevEndPos)) + else parseIdent ~msg:ErrorMessages.typeVar ~startPos:p.startPos p + in + Ast_helper.Typ.var ~loc ~attrs ident | Underscore -> - let endPos = p.endPos in - Parser.next p; - Ast_helper.Typ.any ~loc:(mkLoc startPos endPos) ~attrs () + let endPos = p.endPos in + Parser.next p; + Ast_helper.Typ.any ~loc:(mkLoc startPos endPos) ~attrs () | Lparen -> ( - Parser.next p; - match p.Parser.token with - | Rparen -> Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let unitConstr = Location.mkloc (Longident.Lident "unit") loc in - Ast_helper.Typ.constr ~attrs unitConstr [] - | _ -> ( - let t = parseTypExpr p in - match p.token with - | Comma -> - Parser.next p; - parseTupleType ~attrs ~first:t ~startPos p - | _ -> - Parser.expect Rparen p; - { - t with - ptyp_loc = mkLoc startPos p.prevEndPos; - ptyp_attributes = List.concat [attrs; t.ptyp_attributes]; - })) + match p.Parser.token with + | Rparen -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let unitConstr = Location.mkloc (Longident.Lident "unit") loc in + Ast_helper.Typ.constr ~attrs unitConstr [] + | _ -> ( + let t = parseTypExpr p in + match p.token with + | Comma -> + Parser.next p; + parseTupleType ~attrs ~first:t ~startPos p + | _ -> + Parser.expect Rparen p; + { + t with + ptyp_loc = mkLoc startPos p.prevEndPos; + ptyp_attributes = List.concat [ attrs; t.ptyp_attributes ]; + })) | Lbracket -> parsePolymorphicVariantType ~attrs p | Uident _ | Lident _ -> - let constr = parseValuePath p in - let args = parseTypeConstructorArgs ~constrName:constr p in - Ast_helper.Typ.constr - ~loc:(mkLoc startPos p.prevEndPos) - ~attrs constr args + let constr = parseValuePath p in + let args = parseTypeConstructorArgs ~constrName:constr p in + Ast_helper.Typ.constr + ~loc:(mkLoc startPos p.prevEndPos) + ~attrs constr args | Module -> - Parser.next p; - Parser.expect Lparen p; - let packageType = parsePackageType ~startPos ~attrs p in - Parser.expect Rparen p; - {packageType with ptyp_loc = mkLoc startPos p.prevEndPos} + Parser.next p; + Parser.expect Lparen p; + let packageType = parsePackageType ~startPos ~attrs p in + Parser.expect Rparen p; + { packageType with ptyp_loc = mkLoc startPos p.prevEndPos } | Percent -> - let extension = parseExtension p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.extension ~attrs ~loc extension + let extension = parseExtension p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.extension ~attrs ~loc extension | Lbrace -> parseRecordOrObjectType ~attrs p | Eof -> - Parser.err p (Diagnostics.unexpected p.Parser.token p.breadcrumbs); - Recover.defaultType () + Parser.err p (Diagnostics.unexpected p.Parser.token p.breadcrumbs); + Recover.defaultType () | token -> ( - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - match - skipTokensAndMaybeRetry p ~isStartOfGrammar:Grammar.isAtomicTypExprStart - with - | Some () -> parseAtomicTypExpr ~attrs p - | None -> - Parser.err ~startPos:p.prevEndPos p - (Diagnostics.unexpected token p.breadcrumbs); - Recover.defaultType ()) + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + match + skipTokensAndMaybeRetry p + ~isStartOfGrammar:Grammar.isAtomicTypExprStart + with + | Some () -> parseAtomicTypExpr ~attrs p + | None -> + Parser.err ~startPos:p.prevEndPos p + (Diagnostics.unexpected token p.breadcrumbs); + Recover.defaultType ()) in Parser.eatBreadcrumb p; typ @@ -300610,13 +300927,13 @@ and parsePackageType ~startPos ~attrs p = let modTypePath = parseModuleLongIdent ~lowercase:true p in match p.Parser.token with | Lident "with" -> - Parser.next p; - let constraints = parsePackageConstraints p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.package ~loc ~attrs modTypePath constraints + Parser.next p; + let constraints = parsePackageConstraints p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.package ~loc ~attrs modTypePath constraints | _ -> - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.package ~loc ~attrs modTypePath [] + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.package ~loc ~attrs modTypePath [] (* package-constraint { and package-constraint } *) and parsePackageConstraints p = @@ -300636,12 +300953,12 @@ and parsePackageConstraints p = and parsePackageConstraint p = match p.Parser.token with | And -> - Parser.next p; - Parser.expect Typ p; - let typeConstr = parseValuePath p in - Parser.expect Equal p; - let typ = parseTypExpr p in - Some (typeConstr, typ) + Parser.next p; + Parser.expect Typ p; + let typeConstr = parseValuePath p in + Parser.expect Equal p; + let typ = parseTypExpr p in + Some (typeConstr, typ) | _ -> None and parseRecordOrObjectType ~attrs p = @@ -300651,18 +300968,18 @@ and parseRecordOrObjectType ~attrs p = let closedFlag = match p.token with | DotDot -> - Parser.next p; - Asttypes.Open + Parser.next p; + Asttypes.Open | Dot -> - Parser.next p; - Asttypes.Closed + Parser.next p; + Asttypes.Closed | _ -> Asttypes.Closed in let () = match p.token with | Lident _ -> - Parser.err p - (Diagnostics.message ErrorMessages.forbiddenInlineRecordDeclaration) + Parser.err p + (Diagnostics.message ErrorMessages.forbiddenInlineRecordDeclaration) | _ -> () in let startFirstField = p.startPos in @@ -300672,10 +300989,10 @@ and parseRecordOrObjectType ~attrs p = in let () = match fields with - | [Parsetree.Oinherit {ptyp_loc}] -> - (* {...x}, spread without extra fields *) - Parser.err p ~startPos:startFirstField ~endPos:ptyp_loc.loc_end - (Diagnostics.message ErrorMessages.sameTypeSpread) + | [ Parsetree.Oinherit { ptyp_loc } ] -> + (* {...x}, spread without extra fields *) + Parser.err p ~startPos:startFirstField ~endPos:ptyp_loc.loc_end + (Diagnostics.message ErrorMessages.sameTypeSpread) | _ -> () in Parser.expect Rbrace p; @@ -300686,13 +301003,13 @@ and parseRecordOrObjectType ~attrs p = and parseTypeAlias p typ = match p.Parser.token with | As -> - Parser.next p; - Parser.expect SingleQuote p; - let ident, _loc = parseLident p in - (* TODO: how do we parse attributes here? *) - Ast_helper.Typ.alias - ~loc:(mkLoc typ.Parsetree.ptyp_loc.loc_start p.prevEndPos) - typ ident + Parser.next p; + Parser.expect SingleQuote p; + let ident, _loc = parseLident p in + (* TODO: how do we parse attributes here? *) + Ast_helper.Typ.alias + ~loc:(mkLoc typ.Parsetree.ptyp_loc.loc_start p.prevEndPos) + typ ident | _ -> typ (* type_parameter ::= @@ -300718,59 +301035,63 @@ and parseTypeParameter p = let attrs = parseAttributes p in match p.Parser.token with | Tilde -> ( - Parser.next p; - let name, loc = parseLident p in - let lblLocAttr = - (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) - in - Parser.expect ~grammar:Grammar.TypeExpression Colon p; - let typ = - let typ = parseTypExpr p in - {typ with ptyp_attributes = lblLocAttr :: typ.ptyp_attributes} - in - match p.Parser.token with - | Equal -> Parser.next p; - Parser.expect Question p; - Some (uncurried, attrs, Asttypes.Optional name, typ, startPos) - | _ -> Some (uncurried, attrs, Asttypes.Labelled name, typ, startPos)) - | Lident _ -> ( - let name, loc = parseLident p in - match p.token with - | Colon -> ( - let () = - let error = - Diagnostics.message - (ErrorMessages.missingTildeLabeledParameter name) - in - Parser.err ~startPos:loc.loc_start ~endPos:loc.loc_end p error + let name, loc = parseLident p in + let lblLocAttr = + (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) + in + Parser.expect ~grammar:Grammar.TypeExpression Colon p; + let typ = + let typ = parseTypExpr p in + { typ with ptyp_attributes = lblLocAttr :: typ.ptyp_attributes } in - Parser.next p; - let typ = parseTypExpr p in match p.Parser.token with | Equal -> - Parser.next p; - Parser.expect Question p; - Some (uncurried, attrs, Asttypes.Optional name, typ, startPos) + Parser.next p; + Parser.expect Question p; + Some (uncurried, attrs, Asttypes.Optional name, typ, startPos) | _ -> Some (uncurried, attrs, Asttypes.Labelled name, typ, startPos)) - | _ -> - let constr = Location.mkloc (Longident.Lident name) loc in - let args = parseTypeConstructorArgs ~constrName:constr p in - let typ = - Ast_helper.Typ.constr - ~loc:(mkLoc startPos p.prevEndPos) - ~attrs constr args - in + | Lident _ -> ( + let name, loc = parseLident p in + match p.token with + | Colon -> ( + let () = + let error = + Diagnostics.message + (ErrorMessages.missingTildeLabeledParameter name) + in + Parser.err ~startPos:loc.loc_start ~endPos:loc.loc_end p error + in + Parser.next p; + let typ = parseTypExpr p in + match p.Parser.token with + | Equal -> + Parser.next p; + Parser.expect Question p; + Some (uncurried, attrs, Asttypes.Optional name, typ, startPos) + | _ -> Some (uncurried, attrs, Asttypes.Labelled name, typ, startPos) + ) + | _ -> + let constr = Location.mkloc (Longident.Lident name) loc in + let args = parseTypeConstructorArgs ~constrName:constr p in + let typ = + Ast_helper.Typ.constr + ~loc:(mkLoc startPos p.prevEndPos) + ~attrs constr args + in - let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in - let typ = parseTypeAlias p typ in - Some (uncurried, [], Asttypes.Nolabel, typ, startPos)) + let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in + let typ = parseTypeAlias p typ in + Some (uncurried, [], Asttypes.Nolabel, typ, startPos)) | _ -> - let typ = parseTypExpr p in - let typWithAttributes = - {typ with ptyp_attributes = List.concat [attrs; typ.ptyp_attributes]} - in - Some (uncurried, [], Asttypes.Nolabel, typWithAttributes, startPos) + let typ = parseTypExpr p in + let typWithAttributes = + { + typ with + ptyp_attributes = List.concat [ attrs; typ.ptyp_attributes ]; + } + in + Some (uncurried, [], Asttypes.Nolabel, typWithAttributes, startPos) else None (* (int, ~x:string, float) *) @@ -300779,60 +301100,63 @@ and parseTypeParameters p = Parser.expect Lparen p; match p.Parser.token with | Rparen -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let unitConstr = Location.mkloc (Longident.Lident "unit") loc in - let typ = Ast_helper.Typ.constr unitConstr [] in - [(false, [], Asttypes.Nolabel, typ, startPos)] + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let unitConstr = Location.mkloc (Longident.Lident "unit") loc in + let typ = Ast_helper.Typ.constr unitConstr [] in + [ (false, [], Asttypes.Nolabel, typ, startPos) ] | _ -> - let params = - parseCommaDelimitedRegion ~grammar:Grammar.TypeParameters ~closing:Rparen - ~f:parseTypeParameter p - in - Parser.expect Rparen p; - params + let params = + parseCommaDelimitedRegion ~grammar:Grammar.TypeParameters + ~closing:Rparen ~f:parseTypeParameter p + in + Parser.expect Rparen p; + params and parseEs6ArrowType ~attrs p = let startPos = p.Parser.startPos in match p.Parser.token with | Tilde -> - Parser.next p; - let name, loc = parseLident p in - let lblLocAttr = (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) in - Parser.expect ~grammar:Grammar.TypeExpression Colon p; - let typ = - let typ = parseTypExpr ~alias:false ~es6Arrow:false p in - {typ with ptyp_attributes = lblLocAttr :: typ.ptyp_attributes} - in - let arg = - match p.Parser.token with - | Equal -> - Parser.next p; - Parser.expect Question p; - Asttypes.Optional name - | _ -> Asttypes.Labelled name - in - Parser.expect EqualGreater p; - let returnType = parseTypExpr ~alias:false p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.arrow ~loc ~attrs arg typ returnType + Parser.next p; + let name, loc = parseLident p in + let lblLocAttr = + (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) + in + Parser.expect ~grammar:Grammar.TypeExpression Colon p; + let typ = + let typ = parseTypExpr ~alias:false ~es6Arrow:false p in + { typ with ptyp_attributes = lblLocAttr :: typ.ptyp_attributes } + in + let arg = + match p.Parser.token with + | Equal -> + Parser.next p; + Parser.expect Question p; + Asttypes.Optional name + | _ -> Asttypes.Labelled name + in + Parser.expect EqualGreater p; + let returnType = parseTypExpr ~alias:false p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.arrow ~loc ~attrs arg typ returnType | _ -> - let parameters = parseTypeParameters p in - Parser.expect EqualGreater p; - let returnType = parseTypExpr ~alias:false p in - let endPos = p.prevEndPos in - let typ = - List.fold_right - (fun (uncurried, attrs, argLbl, typ, startPos) t -> - let attrs = if uncurried then uncurryAttr :: attrs else attrs in - Ast_helper.Typ.arrow ~loc:(mkLoc startPos endPos) ~attrs argLbl typ t) - parameters returnType - in - { - typ with - ptyp_attributes = List.concat [typ.ptyp_attributes; attrs]; - ptyp_loc = mkLoc startPos p.prevEndPos; - } + let parameters = parseTypeParameters p in + Parser.expect EqualGreater p; + let returnType = parseTypExpr ~alias:false p in + let endPos = p.prevEndPos in + let typ = + List.fold_right + (fun (uncurried, attrs, argLbl, typ, startPos) t -> + let attrs = if uncurried then uncurryAttr :: attrs else attrs in + Ast_helper.Typ.arrow ~loc:(mkLoc startPos endPos) ~attrs argLbl typ + t) + parameters returnType + in + { + typ with + ptyp_attributes = List.concat [ typ.ptyp_attributes; attrs ]; + ptyp_loc = mkLoc startPos p.prevEndPos; + } (* * typexpr ::= @@ -300858,9 +301182,7 @@ and parseTypExpr ?attrs ?(es6Arrow = true) ?(alias = true) p = (* Parser.leaveBreadcrumb p Grammar.TypeExpression; *) let startPos = p.Parser.startPos in let attrs = - match attrs with - | Some attrs -> attrs - | None -> parseAttributes p + match attrs with Some attrs -> attrs | None -> parseAttributes p in let typ = if es6Arrow && isEs6ArrowType p then parseEs6ArrowType ~attrs p @@ -300875,12 +301197,12 @@ and parseTypExpr ?attrs ?(es6Arrow = true) ?(alias = true) p = and parseArrowTypeRest ~es6Arrow ~startPos typ p = match p.Parser.token with | (EqualGreater | MinusGreater) as token when es6Arrow == true -> - (* error recovery *) - if token = MinusGreater then Parser.expect EqualGreater p; - Parser.next p; - let returnType = parseTypExpr ~alias:false p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType + (* error recovery *) + if token = MinusGreater then Parser.expect EqualGreater p; + Parser.next p; + let returnType = parseTypExpr ~alias:false p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType | _ -> typ and parseTypExprRegion p = @@ -300895,9 +301217,9 @@ and parseTupleType ~attrs ~first ~startPos p = Parser.expect Rparen p; let () = match typexprs with - | [_] -> - Parser.err ~startPos ~endPos:p.prevEndPos p - (Diagnostics.message ErrorMessages.tupleSingleElement) + | [ _ ] -> + Parser.err ~startPos ~endPos:p.prevEndPos p + (Diagnostics.message ErrorMessages.tupleSingleElement) | _ -> () in let tupleLoc = mkLoc startPos p.prevEndPos in @@ -300916,34 +301238,37 @@ and parseTypeConstructorArgs ~constrName p = let openingStartPos = p.startPos in match opening with | LessThan | Lparen -> - Scanner.setDiamondMode p.scanner; - Parser.next p; - let typeArgs = - (* TODO: change Grammar.TypExprList to TypArgList!!! Why did I wrote this? *) - parseCommaDelimitedRegion ~grammar:Grammar.TypExprList - ~closing:GreaterThan ~f:parseTypeConstructorArgRegion p - in - let () = - match p.token with - | Rparen when opening = Token.Lparen -> - let typ = Ast_helper.Typ.constr constrName typeArgs in - let msg = - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.text "Type parameters require angle brackets:"; - Doc.indent - (Doc.concat - [Doc.line; ResPrinter.printTypExpr typ CommentTable.empty]); - ]) - |> Doc.toString ~width:80 - in - Parser.err ~startPos:openingStartPos p (Diagnostics.message msg); - Parser.next p - | _ -> Parser.expect GreaterThan p - in - Scanner.popMode p.scanner Diamond; - typeArgs + Scanner.setDiamondMode p.scanner; + Parser.next p; + let typeArgs = + (* TODO: change Grammar.TypExprList to TypArgList!!! Why did I wrote this? *) + parseCommaDelimitedRegion ~grammar:Grammar.TypExprList + ~closing:GreaterThan ~f:parseTypeConstructorArgRegion p + in + let () = + match p.token with + | Rparen when opening = Token.Lparen -> + let typ = Ast_helper.Typ.constr constrName typeArgs in + let msg = + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.text "Type parameters require angle brackets:"; + Doc.indent + (Doc.concat + [ + Doc.line; + ResPrinter.printTypExpr typ CommentTable.empty; + ]); + ]) + |> Doc.toString ~width:80 + in + Parser.err ~startPos:openingStartPos p (Diagnostics.message msg); + Parser.next p + | _ -> Parser.expect GreaterThan p + in + Scanner.popMode p.scanner Diamond; + typeArgs | _ -> [] (* string-field-decl ::= @@ -300953,26 +301278,26 @@ and parseStringFieldDeclaration p = let attrs = parseAttributes p in match p.Parser.token with | String name -> - let nameStartPos = p.startPos in - let nameEndPos = p.endPos in - Parser.next p; - let fieldName = Location.mkloc name (mkLoc nameStartPos nameEndPos) in - Parser.expect ~grammar:Grammar.TypeExpression Colon p; - let typ = parsePolyTypeExpr p in - Some (Parsetree.Otag (fieldName, attrs, typ)) + let nameStartPos = p.startPos in + let nameEndPos = p.endPos in + Parser.next p; + let fieldName = Location.mkloc name (mkLoc nameStartPos nameEndPos) in + Parser.expect ~grammar:Grammar.TypeExpression Colon p; + let typ = parsePolyTypeExpr p in + Some (Parsetree.Otag (fieldName, attrs, typ)) | DotDotDot -> - Parser.next p; - let typ = parseTypExpr p in - Some (Parsetree.Oinherit typ) + Parser.next p; + let typ = parseTypExpr p in + Some (Parsetree.Oinherit typ) | Lident name -> - let nameLoc = mkLoc p.startPos p.endPos in - Parser.err p - (Diagnostics.message (ErrorMessages.objectQuotedFieldName name)); - Parser.next p; - let fieldName = Location.mkloc name nameLoc in - Parser.expect ~grammar:Grammar.TypeExpression Colon p; - let typ = parsePolyTypeExpr p in - Some (Parsetree.Otag (fieldName, attrs, typ)) + let nameLoc = mkLoc p.startPos p.endPos in + Parser.err p + (Diagnostics.message (ErrorMessages.objectQuotedFieldName name)); + Parser.next p; + let fieldName = Location.mkloc name nameLoc in + Parser.expect ~grammar:Grammar.TypeExpression Colon p; + let typ = parsePolyTypeExpr p in + Some (Parsetree.Otag (fieldName, attrs, typ)) | _token -> None (* field-decl ::= @@ -300985,19 +301310,18 @@ and parseFieldDeclaration p = if Parser.optional p Token.Mutable then Asttypes.Mutable else Asttypes.Immutable in - let lident, loc = - match p.token with - | _ -> parseLident p - in + let lident, loc = match p.token with _ -> parseLident p in let optional = parseOptionalLabel p in let name = Location.mkloc lident loc in let typ = match p.Parser.token with | Colon -> - Parser.next p; - parsePolyTypeExpr p + Parser.next p; + parsePolyTypeExpr p | _ -> - Ast_helper.Typ.constr ~loc:name.loc {name with txt = Lident name.txt} [] + Ast_helper.Typ.constr ~loc:name.loc + { name with txt = Lident name.txt } + [] in let loc = mkLoc startPos typ.ptyp_loc.loc_end in (optional, Ast_helper.Type.field ~attrs ~loc ~mut name typ) @@ -301011,22 +301335,22 @@ and parseFieldDeclarationRegion p = in match p.token with | Lident _ -> - let lident, loc = parseLident p in - let name = Location.mkloc lident loc in - let optional = parseOptionalLabel p in - let typ = - match p.Parser.token with - | Colon -> - Parser.next p; - parsePolyTypeExpr p - | _ -> - Ast_helper.Typ.constr ~loc:name.loc ~attrs - {name with txt = Lident name.txt} - [] - in - let loc = mkLoc startPos typ.ptyp_loc.loc_end in - let attrs = if optional then optionalAttr :: attrs else attrs in - Some (Ast_helper.Type.field ~attrs ~loc ~mut name typ) + let lident, loc = parseLident p in + let name = Location.mkloc lident loc in + let optional = parseOptionalLabel p in + let typ = + match p.Parser.token with + | Colon -> + Parser.next p; + parsePolyTypeExpr p + | _ -> + Ast_helper.Typ.constr ~loc:name.loc ~attrs + { name with txt = Lident name.txt } + [] + in + let loc = mkLoc startPos typ.ptyp_loc.loc_end in + let attrs = if optional then optionalAttr :: attrs else attrs in + Some (Ast_helper.Type.field ~attrs ~loc ~mut name typ) | _ -> None (* record-decl ::= @@ -301048,187 +301372,197 @@ and parseRecordDeclaration p = (* constr-args ::= * | (typexpr) * | (typexpr, typexpr) - * | (typexpr, typexpr, typexpr,) - * | (record-decl) - * - * TODO: should we overparse inline-records in every position? - * Give a good error message afterwards? - *) -and parseConstrDeclArgs p = - let constrArgs = - match p.Parser.token with - | Lparen -> ( - Parser.next p; - (* TODO: this could use some cleanup/stratification *) - match p.Parser.token with - | Lbrace -> ( - let lbrace = p.startPos in - Parser.next p; - let startPos = p.Parser.startPos in - match p.Parser.token with - | DotDot | Dot -> - let closedFlag = - match p.token with - | DotDot -> - Parser.next p; - Asttypes.Open - | Dot -> - Parser.next p; - Asttypes.Closed - | _ -> Asttypes.Closed - in - let fields = - parseCommaDelimitedRegion ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace ~f:parseStringFieldDeclaration p - in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let typ = Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag in - Parser.optional p Comma |> ignore; - let moreArgs = - parseCommaDelimitedRegion ~grammar:Grammar.TypExprList - ~closing:Rparen ~f:parseTypExprRegion p - in - Parser.expect Rparen p; - Parsetree.Pcstr_tuple (typ :: moreArgs) - | DotDotDot -> - let dotdotdotStart = p.startPos in - let dotdotdotEnd = p.endPos in - (* start of object type spreading, e.g. `User({...a, "u": int})` *) - Parser.next p; - let typ = parseTypExpr p in - let () = - match p.token with - | Rbrace -> - (* {...x}, spread without extra fields *) - Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p - (Diagnostics.message ErrorMessages.sameTypeSpread); - Parser.next p - | _ -> Parser.expect Comma p - in - let () = - match p.token with - | Lident _ -> - Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p - (Diagnostics.message ErrorMessages.spreadInRecordDeclaration) - | _ -> () - in - let fields = - Parsetree.Oinherit typ - :: parseCommaDelimitedRegion - ~grammar:Grammar.StringFieldDeclarations ~closing:Rbrace - ~f:parseStringFieldDeclaration p - in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let typ = - Ast_helper.Typ.object_ ~loc fields Asttypes.Closed - |> parseTypeAlias p - in - let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in - Parser.optional p Comma |> ignore; - let moreArgs = - parseCommaDelimitedRegion ~grammar:Grammar.TypExprList - ~closing:Rparen ~f:parseTypExprRegion p - in - Parser.expect Rparen p; - Parsetree.Pcstr_tuple (typ :: moreArgs) - | _ -> ( - let attrs = parseAttributes p in - match p.Parser.token with - | String _ -> - let closedFlag = Asttypes.Closed in - let fields = - match attrs with - | [] -> - parseCommaDelimitedRegion - ~grammar:Grammar.StringFieldDeclarations ~closing:Rbrace - ~f:parseStringFieldDeclaration p - | attrs -> - let first = - Parser.leaveBreadcrumb p Grammar.StringFieldDeclarations; - let field = - match parseStringFieldDeclaration p with - | Some field -> field - | None -> assert false - in - (* parse comma after first *) - let () = - match p.Parser.token with - | Rbrace | Eof -> () - | Comma -> Parser.next p - | _ -> Parser.expect Comma p - in - Parser.eatBreadcrumb p; - match field with - | Parsetree.Otag (label, _, ct) -> - Parsetree.Otag (label, attrs, ct) - | Oinherit ct -> Oinherit ct + * | (typexpr, typexpr, typexpr,) + * | (record-decl) + * + * TODO: should we overparse inline-records in every position? + * Give a good error message afterwards? + *) +and parseConstrDeclArgs p = + let constrArgs = + match p.Parser.token with + | Lparen -> ( + Parser.next p; + (* TODO: this could use some cleanup/stratification *) + match p.Parser.token with + | Lbrace -> ( + let lbrace = p.startPos in + Parser.next p; + let startPos = p.Parser.startPos in + match p.Parser.token with + | DotDot | Dot -> + let closedFlag = + match p.token with + | DotDot -> + Parser.next p; + Asttypes.Open + | Dot -> + Parser.next p; + Asttypes.Closed + | _ -> Asttypes.Closed in - first - :: parseCommaDelimitedRegion - ~grammar:Grammar.StringFieldDeclarations ~closing:Rbrace - ~f:parseStringFieldDeclaration p - in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let typ = - Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag - |> parseTypeAlias p - in - let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in - Parser.optional p Comma |> ignore; - let moreArgs = + let fields = + parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations ~closing:Rbrace + ~f:parseStringFieldDeclaration p + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let typ = + Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag + in + Parser.optional p Comma |> ignore; + let moreArgs = + parseCommaDelimitedRegion ~grammar:Grammar.TypExprList + ~closing:Rparen ~f:parseTypExprRegion p + in + Parser.expect Rparen p; + Parsetree.Pcstr_tuple (typ :: moreArgs) + | DotDotDot -> + let dotdotdotStart = p.startPos in + let dotdotdotEnd = p.endPos in + (* start of object type spreading, e.g. `User({...a, "u": int})` *) + Parser.next p; + let typ = parseTypExpr p in + let () = + match p.token with + | Rbrace -> + (* {...x}, spread without extra fields *) + Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p + (Diagnostics.message ErrorMessages.sameTypeSpread); + Parser.next p + | _ -> Parser.expect Comma p + in + let () = + match p.token with + | Lident _ -> + Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p + (Diagnostics.message + ErrorMessages.spreadInRecordDeclaration) + | _ -> () + in + let fields = + Parsetree.Oinherit typ + :: parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations ~closing:Rbrace + ~f:parseStringFieldDeclaration p + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let typ = + Ast_helper.Typ.object_ ~loc fields Asttypes.Closed + |> parseTypeAlias p + in + let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in + Parser.optional p Comma |> ignore; + let moreArgs = + parseCommaDelimitedRegion ~grammar:Grammar.TypExprList + ~closing:Rparen ~f:parseTypExprRegion p + in + Parser.expect Rparen p; + Parsetree.Pcstr_tuple (typ :: moreArgs) + | _ -> ( + let attrs = parseAttributes p in + match p.Parser.token with + | String _ -> + let closedFlag = Asttypes.Closed in + let fields = + match attrs with + | [] -> + parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace ~f:parseStringFieldDeclaration p + | attrs -> + let first = + Parser.leaveBreadcrumb p + Grammar.StringFieldDeclarations; + let field = + match parseStringFieldDeclaration p with + | Some field -> field + | None -> assert false + in + (* parse comma after first *) + let () = + match p.Parser.token with + | Rbrace | Eof -> () + | Comma -> Parser.next p + | _ -> Parser.expect Comma p + in + Parser.eatBreadcrumb p; + match field with + | Parsetree.Otag (label, _, ct) -> + Parsetree.Otag (label, attrs, ct) + | Oinherit ct -> Oinherit ct + in + first + :: parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace ~f:parseStringFieldDeclaration p + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let typ = + Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag + |> parseTypeAlias p + in + let typ = + parseArrowTypeRest ~es6Arrow:true ~startPos typ p + in + Parser.optional p Comma |> ignore; + let moreArgs = + parseCommaDelimitedRegion ~grammar:Grammar.TypExprList + ~closing:Rparen ~f:parseTypExprRegion p + in + Parser.expect Rparen p; + Parsetree.Pcstr_tuple (typ :: moreArgs) + | _ -> + let fields = + match attrs with + | [] -> + parseCommaDelimitedRegion + ~grammar:Grammar.FieldDeclarations ~closing:Rbrace + ~f:parseFieldDeclarationRegion p + | attrs -> + let first = + let optional, field = parseFieldDeclaration p in + let attrs = + if optional then optionalAttr :: attrs else attrs + in + Parser.expect Comma p; + { field with Parsetree.pld_attributes = attrs } + in + first + :: parseCommaDelimitedRegion + ~grammar:Grammar.FieldDeclarations + ~closing:Rbrace ~f:parseFieldDeclarationRegion p + in + let () = + match fields with + | [] -> + Parser.err ~startPos:lbrace p + (Diagnostics.message + "An inline record declaration needs at least \ + one field") + | _ -> () + in + Parser.expect Rbrace p; + Parser.optional p Comma |> ignore; + Parser.expect Rparen p; + Parsetree.Pcstr_record fields)) + | _ -> + let args = parseCommaDelimitedRegion ~grammar:Grammar.TypExprList ~closing:Rparen ~f:parseTypExprRegion p in Parser.expect Rparen p; - Parsetree.Pcstr_tuple (typ :: moreArgs) - | _ -> - let fields = - match attrs with - | [] -> - parseCommaDelimitedRegion ~grammar:Grammar.FieldDeclarations - ~closing:Rbrace ~f:parseFieldDeclarationRegion p - | attrs -> - let first = - let optional, field = parseFieldDeclaration p in - let attrs = - if optional then optionalAttr :: attrs else attrs - in - Parser.expect Comma p; - {field with Parsetree.pld_attributes = attrs} - in - first - :: parseCommaDelimitedRegion ~grammar:Grammar.FieldDeclarations - ~closing:Rbrace ~f:parseFieldDeclarationRegion p - in - let () = - match fields with - | [] -> - Parser.err ~startPos:lbrace p - (Diagnostics.message - "An inline record declaration needs at least one field") - | _ -> () - in - Parser.expect Rbrace p; - Parser.optional p Comma |> ignore; - Parser.expect Rparen p; - Parsetree.Pcstr_record fields)) - | _ -> - let args = - parseCommaDelimitedRegion ~grammar:Grammar.TypExprList ~closing:Rparen - ~f:parseTypExprRegion p - in - Parser.expect Rparen p; - Parsetree.Pcstr_tuple args) + Parsetree.Pcstr_tuple args) | _ -> Pcstr_tuple [] in let res = match p.Parser.token with | Colon -> - Parser.next p; - Some (parseTypExpr p) + Parser.next p; + Some (parseTypExpr p) | _ -> None in (constrArgs, res) @@ -301241,9 +301575,9 @@ and parseConstrDeclArgs p = and parseTypeConstructorDeclarationWithBar p = match p.Parser.token with | Bar -> - let startPos = p.Parser.startPos in - Parser.next p; - Some (parseTypeConstructorDeclaration ~startPos p) + let startPos = p.Parser.startPos in + Parser.next p; + Some (parseTypeConstructorDeclaration ~startPos p) | _ -> None and parseTypeConstructorDeclaration ~startPos p = @@ -301251,25 +301585,25 @@ and parseTypeConstructorDeclaration ~startPos p = let attrs = parseAttributes p in match p.Parser.token with | Uident uident -> - let uidentLoc = mkLoc p.startPos p.endPos in - Parser.next p; - let args, res = parseConstrDeclArgs p in - Parser.eatBreadcrumb p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Type.constructor ~loc ~attrs ?res ~args - (Location.mkloc uident uidentLoc) + let uidentLoc = mkLoc p.startPos p.endPos in + Parser.next p; + let args, res = parseConstrDeclArgs p in + Parser.eatBreadcrumb p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Type.constructor ~loc ~attrs ?res ~args + (Location.mkloc uident uidentLoc) | t -> - Parser.err p (Diagnostics.uident t); - Ast_helper.Type.constructor (Location.mknoloc "_") + Parser.err p (Diagnostics.uident t); + Ast_helper.Type.constructor (Location.mknoloc "_") (* [|] constr-decl { | constr-decl } *) and parseTypeConstructorDeclarations ?first p = let firstConstrDecl = match first with | None -> - let startPos = p.Parser.startPos in - ignore (Parser.optional p Token.Bar); - parseTypeConstructorDeclaration ~startPos p + let startPos = p.Parser.startPos in + ignore (Parser.optional p Token.Bar); + parseTypeConstructorDeclaration ~startPos p | Some firstConstrDecl -> firstConstrDecl in firstConstrDecl @@ -301296,15 +301630,15 @@ and parseTypeRepresentation p = let kind = match p.Parser.token with | Bar | Uident _ -> - Parsetree.Ptype_variant (parseTypeConstructorDeclarations p) + Parsetree.Ptype_variant (parseTypeConstructorDeclarations p) | Lbrace -> Parsetree.Ptype_record (parseRecordDeclaration p) | DotDot -> - Parser.next p; - Ptype_open + Parser.next p; + Ptype_open | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - (* TODO: I have no idea if this is even remotely a good idea *) - Parsetree.Ptype_variant [] + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + (* TODO: I have no idea if this is even remotely a good idea *) + Parsetree.Ptype_variant [] in Parser.eatBreadcrumb p; (privateFlag, kind) @@ -301323,36 +301657,36 @@ and parseTypeParam p = let variance = match p.Parser.token with | Plus -> - Parser.next p; - Asttypes.Covariant + Parser.next p; + Asttypes.Covariant | Minus -> - Parser.next p; - Contravariant + Parser.next p; + Contravariant | _ -> Invariant in match p.Parser.token with | SingleQuote -> - Parser.next p; - let ident, loc = - if p.Parser.token = Eof then ( - Parser.err ~startPos:p.startPos p - (Diagnostics.unexpected p.Parser.token p.breadcrumbs); - ("", mkLoc p.startPos p.prevEndPos)) - else parseIdent ~msg:ErrorMessages.typeParam ~startPos:p.startPos p - in - Some (Ast_helper.Typ.var ~loc ident, variance) + Parser.next p; + let ident, loc = + if p.Parser.token = Eof then ( + Parser.err ~startPos:p.startPos p + (Diagnostics.unexpected p.Parser.token p.breadcrumbs); + ("", mkLoc p.startPos p.prevEndPos)) + else parseIdent ~msg:ErrorMessages.typeParam ~startPos:p.startPos p + in + Some (Ast_helper.Typ.var ~loc ident, variance) | Underscore -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Some (Ast_helper.Typ.any ~loc (), variance) + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Some (Ast_helper.Typ.any ~loc (), variance) | (Uident _ | Lident _) as token -> - Parser.err p - (Diagnostics.message - ("Type params start with a singlequote: '" ^ Token.toString token)); - let ident, loc = - parseIdent ~msg:ErrorMessages.typeParam ~startPos:p.startPos p - in - Some (Ast_helper.Typ.var ~loc ident, variance) + Parser.err p + (Diagnostics.message + ("Type params start with a singlequote: '" ^ Token.toString token)); + let ident, loc = + parseIdent ~msg:ErrorMessages.typeParam ~startPos:p.startPos p + in + Some (Ast_helper.Typ.var ~loc ident, variance) | _token -> None (* type-params ::= @@ -301367,42 +301701,43 @@ and parseTypeParams ~parent p = let opening = p.Parser.token in match opening with | (LessThan | Lparen) when p.startPos.pos_lnum == p.prevEndPos.pos_lnum -> - Scanner.setDiamondMode p.scanner; - let openingStartPos = p.startPos in - Parser.leaveBreadcrumb p Grammar.TypeParams; - Parser.next p; - let params = - parseCommaDelimitedRegion ~grammar:Grammar.TypeParams ~closing:GreaterThan - ~f:parseTypeParam p - in - let () = - match p.token with - | Rparen when opening = Token.Lparen -> - let msg = - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.text "Type parameters require angle brackets:"; - Doc.indent - (Doc.concat - [ - Doc.line; - Doc.concat + Scanner.setDiamondMode p.scanner; + let openingStartPos = p.startPos in + Parser.leaveBreadcrumb p Grammar.TypeParams; + Parser.next p; + let params = + parseCommaDelimitedRegion ~grammar:Grammar.TypeParams + ~closing:GreaterThan ~f:parseTypeParam p + in + let () = + match p.token with + | Rparen when opening = Token.Lparen -> + let msg = + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.text "Type parameters require angle brackets:"; + Doc.indent + (Doc.concat [ - ResPrinter.printLongident parent.Location.txt; - ResPrinter.printTypeParams params CommentTable.empty; - ]; - ]); - ]) - |> Doc.toString ~width:80 - in - Parser.err ~startPos:openingStartPos p (Diagnostics.message msg); - Parser.next p - | _ -> Parser.expect GreaterThan p - in - Scanner.popMode p.scanner Diamond; - Parser.eatBreadcrumb p; - params + Doc.line; + Doc.concat + [ + ResPrinter.printLongident parent.Location.txt; + ResPrinter.printTypeParams params + CommentTable.empty; + ]; + ]); + ]) + |> Doc.toString ~width:80 + in + Parser.err ~startPos:openingStartPos p (Diagnostics.message msg); + Parser.next p + | _ -> Parser.expect GreaterThan p + in + Scanner.popMode p.scanner Diamond; + Parser.eatBreadcrumb p; + params | _ -> [] (* type-constraint ::= constraint ' ident = typexpr *) @@ -301410,20 +301745,20 @@ and parseTypeConstraint p = let startPos = p.Parser.startPos in match p.Parser.token with | Token.Constraint -> ( - Parser.next p; - Parser.expect SingleQuote p; - match p.Parser.token with - | Lident ident -> - let identLoc = mkLoc startPos p.endPos in Parser.next p; - Parser.expect Equal p; - let typ = parseTypExpr p in - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Typ.var ~loc:identLoc ident, typ, loc) - | t -> - Parser.err p (Diagnostics.lident t); - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Typ.any (), parseTypExpr p, loc)) + Parser.expect SingleQuote p; + match p.Parser.token with + | Lident ident -> + let identLoc = mkLoc startPos p.endPos in + Parser.next p; + Parser.expect Equal p; + let typ = parseTypExpr p in + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Typ.var ~loc:identLoc ident, typ, loc) + | t -> + Parser.err p (Diagnostics.lident t); + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Typ.any (), parseTypExpr p, loc)) | _ -> None (* type-constraints ::= @@ -301439,147 +301774,72 @@ and parseTypeEquationOrConstrDecl p = let uidentStartPos = p.Parser.startPos in match p.Parser.token with | Uident uident -> ( - Parser.next p; - match p.Parser.token with - | Dot -> ( Parser.next p; - let typeConstr = - parseValuePathTail p uidentStartPos (Longident.Lident uident) - in - let loc = mkLoc uidentStartPos p.prevEndPos in - let typ = - parseTypeAlias p - (Ast_helper.Typ.constr ~loc typeConstr - (parseTypeConstructorArgs ~constrName:typeConstr p)) - in - match p.token with - | Equal -> - Parser.next p; - let priv, kind = parseTypeRepresentation p in - (Some typ, priv, kind) - | EqualGreater -> - Parser.next p; - let returnType = parseTypExpr ~alias:false p in - let loc = mkLoc uidentStartPos p.prevEndPos in - let arrowType = - Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType - in - let typ = parseTypeAlias p arrowType in - (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) - | _ -> (Some typ, Asttypes.Public, Parsetree.Ptype_abstract)) - | _ -> - let uidentEndPos = p.prevEndPos in - let args, res = parseConstrDeclArgs p in - let first = - Some - (let uidentLoc = mkLoc uidentStartPos uidentEndPos in - Ast_helper.Type.constructor - ~loc:(mkLoc uidentStartPos p.prevEndPos) - ?res ~args - (Location.mkloc uident uidentLoc)) - in - ( None, - Asttypes.Public, - Parsetree.Ptype_variant (parseTypeConstructorDeclarations p ?first) )) + match p.Parser.token with + | Dot -> ( + Parser.next p; + let typeConstr = + parseValuePathTail p uidentStartPos (Longident.Lident uident) + in + let loc = mkLoc uidentStartPos p.prevEndPos in + let typ = + parseTypeAlias p + (Ast_helper.Typ.constr ~loc typeConstr + (parseTypeConstructorArgs ~constrName:typeConstr p)) + in + match p.token with + | Equal -> + Parser.next p; + let priv, kind = parseTypeRepresentation p in + (Some typ, priv, kind) + | EqualGreater -> + Parser.next p; + let returnType = parseTypExpr ~alias:false p in + let loc = mkLoc uidentStartPos p.prevEndPos in + let arrowType = + Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType + in + let typ = parseTypeAlias p arrowType in + (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) + | _ -> (Some typ, Asttypes.Public, Parsetree.Ptype_abstract)) + | _ -> + let uidentEndPos = p.prevEndPos in + let args, res = parseConstrDeclArgs p in + let first = + Some + (let uidentLoc = mkLoc uidentStartPos uidentEndPos in + Ast_helper.Type.constructor + ~loc:(mkLoc uidentStartPos p.prevEndPos) + ?res ~args + (Location.mkloc uident uidentLoc)) + in + ( None, + Asttypes.Public, + Parsetree.Ptype_variant (parseTypeConstructorDeclarations p ?first) + )) | t -> - Parser.err p (Diagnostics.uident t); - (* TODO: is this a good idea? *) - (None, Asttypes.Public, Parsetree.Ptype_abstract) + Parser.err p (Diagnostics.uident t); + (* TODO: is this a good idea? *) + (None, Asttypes.Public, Parsetree.Ptype_abstract) and parseRecordOrObjectDecl p = let startPos = p.Parser.startPos in Parser.expect Lbrace p; match p.Parser.token with | DotDot | Dot -> - let closedFlag = - match p.token with - | DotDot -> - Parser.next p; - Asttypes.Open - | Dot -> - Parser.next p; - Asttypes.Closed - | _ -> Asttypes.Closed - in - let fields = - parseCommaDelimitedRegion ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace ~f:parseStringFieldDeclaration p - in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let typ = - Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag - |> parseTypeAlias p - in - let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in - (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) - | DotDotDot -> - let dotdotdotStart = p.startPos in - let dotdotdotEnd = p.endPos in - (* start of object type spreading, e.g. `type u = {...a, "u": int}` *) - Parser.next p; - let typ = parseTypExpr p in - let () = - match p.token with - | Rbrace -> - (* {...x}, spread without extra fields *) - Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p - (Diagnostics.message ErrorMessages.sameTypeSpread); - Parser.next p - | _ -> Parser.expect Comma p - in - let () = - match p.token with - | Lident _ -> - Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p - (Diagnostics.message ErrorMessages.spreadInRecordDeclaration) - | _ -> () - in - let fields = - Parsetree.Oinherit typ - :: parseCommaDelimitedRegion ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace ~f:parseStringFieldDeclaration p - in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let typ = - Ast_helper.Typ.object_ ~loc fields Asttypes.Closed |> parseTypeAlias p - in - let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in - (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) - | _ -> ( - let attrs = parseAttributes p in - match p.Parser.token with - | String _ -> - let closedFlag = Asttypes.Closed in + let closedFlag = + match p.token with + | DotDot -> + Parser.next p; + Asttypes.Open + | Dot -> + Parser.next p; + Asttypes.Closed + | _ -> Asttypes.Closed + in let fields = - match attrs with - | [] -> - parseCommaDelimitedRegion ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace ~f:parseStringFieldDeclaration p - | attrs -> - let first = - Parser.leaveBreadcrumb p Grammar.StringFieldDeclarations; - let field = - match parseStringFieldDeclaration p with - | Some field -> field - | None -> assert false - in - (* parse comma after first *) - let () = - match p.Parser.token with - | Rbrace | Eof -> () - | Comma -> Parser.next p - | _ -> Parser.expect Comma p - in - Parser.eatBreadcrumb p; - match field with - | Parsetree.Otag (label, _, ct) -> Parsetree.Otag (label, attrs, ct) - | Oinherit ct -> Oinherit ct - in - first - :: parseCommaDelimitedRegion ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace ~f:parseStringFieldDeclaration p + parseCommaDelimitedRegion ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace ~f:parseStringFieldDeclaration p in Parser.expect Rbrace p; let loc = mkLoc startPos p.prevEndPos in @@ -301589,54 +301849,135 @@ and parseRecordOrObjectDecl p = in let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) - | _ -> - Parser.leaveBreadcrumb p Grammar.RecordDecl; + | DotDotDot -> + let dotdotdotStart = p.startPos in + let dotdotdotEnd = p.endPos in + (* start of object type spreading, e.g. `type u = {...a, "u": int}` *) + Parser.next p; + let typ = parseTypExpr p in + let () = + match p.token with + | Rbrace -> + (* {...x}, spread without extra fields *) + Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p + (Diagnostics.message ErrorMessages.sameTypeSpread); + Parser.next p + | _ -> Parser.expect Comma p + in + let () = + match p.token with + | Lident _ -> + Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p + (Diagnostics.message ErrorMessages.spreadInRecordDeclaration) + | _ -> () + in let fields = - (* XXX *) - match attrs with - | [] -> - parseCommaDelimitedRegion ~grammar:Grammar.FieldDeclarations - ~closing:Rbrace ~f:parseFieldDeclarationRegion p - | attr :: _ as attrs -> - let first = - let optional, field = parseFieldDeclaration p in - let attrs = if optional then optionalAttr :: attrs else attrs in - Parser.optional p Comma |> ignore; - { - field with - Parsetree.pld_attributes = attrs; - pld_loc = - { - field.Parsetree.pld_loc with - loc_start = (attr |> fst).loc.loc_start; - }; - } - in - first - :: parseCommaDelimitedRegion ~grammar:Grammar.FieldDeclarations - ~closing:Rbrace ~f:parseFieldDeclarationRegion p + Parsetree.Oinherit typ + :: parseCommaDelimitedRegion ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace ~f:parseStringFieldDeclaration p in Parser.expect Rbrace p; - Parser.eatBreadcrumb p; - (None, Asttypes.Public, Parsetree.Ptype_record fields)) + let loc = mkLoc startPos p.prevEndPos in + let typ = + Ast_helper.Typ.object_ ~loc fields Asttypes.Closed |> parseTypeAlias p + in + let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in + (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) + | _ -> ( + let attrs = parseAttributes p in + match p.Parser.token with + | String _ -> + let closedFlag = Asttypes.Closed in + let fields = + match attrs with + | [] -> + parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations ~closing:Rbrace + ~f:parseStringFieldDeclaration p + | attrs -> + let first = + Parser.leaveBreadcrumb p Grammar.StringFieldDeclarations; + let field = + match parseStringFieldDeclaration p with + | Some field -> field + | None -> assert false + in + (* parse comma after first *) + let () = + match p.Parser.token with + | Rbrace | Eof -> () + | Comma -> Parser.next p + | _ -> Parser.expect Comma p + in + Parser.eatBreadcrumb p; + match field with + | Parsetree.Otag (label, _, ct) -> + Parsetree.Otag (label, attrs, ct) + | Oinherit ct -> Oinherit ct + in + first + :: parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations ~closing:Rbrace + ~f:parseStringFieldDeclaration p + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let typ = + Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag + |> parseTypeAlias p + in + let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in + (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) + | _ -> + Parser.leaveBreadcrumb p Grammar.RecordDecl; + let fields = + (* XXX *) + match attrs with + | [] -> + parseCommaDelimitedRegion ~grammar:Grammar.FieldDeclarations + ~closing:Rbrace ~f:parseFieldDeclarationRegion p + | attr :: _ as attrs -> + let first = + let optional, field = parseFieldDeclaration p in + let attrs = + if optional then optionalAttr :: attrs else attrs + in + Parser.optional p Comma |> ignore; + { + field with + Parsetree.pld_attributes = attrs; + pld_loc = + { + field.Parsetree.pld_loc with + loc_start = (attr |> fst).loc.loc_start; + }; + } + in + first + :: parseCommaDelimitedRegion ~grammar:Grammar.FieldDeclarations + ~closing:Rbrace ~f:parseFieldDeclarationRegion p + in + Parser.expect Rbrace p; + Parser.eatBreadcrumb p; + (None, Asttypes.Public, Parsetree.Ptype_record fields)) and parsePrivateEqOrRepr p = Parser.expect Private p; match p.Parser.token with | Lbrace -> - let manifest, _, kind = parseRecordOrObjectDecl p in - (manifest, Asttypes.Private, kind) + let manifest, _, kind = parseRecordOrObjectDecl p in + (manifest, Asttypes.Private, kind) | Uident _ -> - let manifest, _, kind = parseTypeEquationOrConstrDecl p in - (manifest, Asttypes.Private, kind) + let manifest, _, kind = parseTypeEquationOrConstrDecl p in + (manifest, Asttypes.Private, kind) | Bar | DotDot -> - let _, kind = parseTypeRepresentation p in - (None, Asttypes.Private, kind) + let _, kind = parseTypeRepresentation p in + (None, Asttypes.Private, kind) | t when Grammar.isTypExprStart t -> - (Some (parseTypExpr p), Asttypes.Private, Parsetree.Ptype_abstract) + (Some (parseTypExpr p), Asttypes.Private, Parsetree.Ptype_abstract) | _ -> - let _, kind = parseTypeRepresentation p in - (None, Asttypes.Private, kind) + let _, kind = parseTypeRepresentation p in + (None, Asttypes.Private, kind) (* polymorphic-variant-type ::= @@ -301658,49 +301999,49 @@ and parsePolymorphicVariantType ~attrs p = Parser.expect Lbracket p; match p.token with | GreaterThan -> - Parser.next p; - let rowFields = - match p.token with - | Rbracket -> [] - | Bar -> parseTagSpecs p - | _ -> - let rowField = parseTagSpec p in - rowField :: parseTagSpecs p - in - let variant = - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.variant ~attrs ~loc rowFields Open None - in - Parser.expect Rbracket p; - variant + Parser.next p; + let rowFields = + match p.token with + | Rbracket -> [] + | Bar -> parseTagSpecs p + | _ -> + let rowField = parseTagSpec p in + rowField :: parseTagSpecs p + in + let variant = + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.variant ~attrs ~loc rowFields Open None + in + Parser.expect Rbracket p; + variant | LessThan -> - Parser.next p; - Parser.optional p Bar |> ignore; - let rowField = parseTagSpecFull p in - let rowFields = parseTagSpecFulls p in - let tagNames = parseTagNames p in - let variant = - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.variant ~attrs ~loc (rowField :: rowFields) Closed - (Some tagNames) - in - Parser.expect Rbracket p; - variant + Parser.next p; + Parser.optional p Bar |> ignore; + let rowField = parseTagSpecFull p in + let rowFields = parseTagSpecFulls p in + let tagNames = parseTagNames p in + let variant = + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.variant ~attrs ~loc (rowField :: rowFields) Closed + (Some tagNames) + in + Parser.expect Rbracket p; + variant | _ -> - let rowFields1 = parseTagSpecFirst p in - let rowFields2 = parseTagSpecs p in - let variant = - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.variant ~attrs ~loc (rowFields1 @ rowFields2) Closed None - in - Parser.expect Rbracket p; - variant + let rowFields1 = parseTagSpecFirst p in + let rowFields2 = parseTagSpecs p in + let variant = + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.variant ~attrs ~loc (rowFields1 @ rowFields2) Closed None + in + Parser.expect Rbracket p; + variant and parseTagName p = match p.Parser.token with | Hash -> - let ident, _loc = parseHashIdent ~startPos:p.startPos p in - Some ident + let ident, _loc = parseHashIdent ~startPos:p.startPos p in + Some ident | _ -> None and parseTagNames p = @@ -301714,9 +302055,9 @@ and parseTagSpecFulls p = | Rbracket -> [] | GreaterThan -> [] | Bar -> - Parser.next p; - let rowField = parseTagSpecFull p in - rowField :: parseTagSpecFulls p + Parser.next p; + let rowField = parseTagSpecFull p in + rowField :: parseTagSpecFulls p | _ -> [] and parseTagSpecFull p = @@ -301724,15 +302065,15 @@ and parseTagSpecFull p = match p.Parser.token with | Hash -> parsePolymorphicVariantTypeSpecHash ~attrs ~full:true p | _ -> - let typ = parseTypExpr ~attrs p in - Parsetree.Rinherit typ + let typ = parseTypExpr ~attrs p in + Parsetree.Rinherit typ and parseTagSpecs p = match p.Parser.token with | Bar -> - Parser.next p; - let rowField = parseTagSpec p in - rowField :: parseTagSpecs p + Parser.next p; + let rowField = parseTagSpec p in + rowField :: parseTagSpecs p | _ -> [] and parseTagSpec p = @@ -301740,25 +302081,25 @@ and parseTagSpec p = match p.Parser.token with | Hash -> parsePolymorphicVariantTypeSpecHash ~attrs ~full:false p | _ -> - let typ = parseTypExpr ~attrs p in - Parsetree.Rinherit typ + let typ = parseTypExpr ~attrs p in + Parsetree.Rinherit typ and parseTagSpecFirst p = let attrs = parseAttributes p in match p.Parser.token with | Bar -> - Parser.next p; - [parseTagSpec p] - | Hash -> [parsePolymorphicVariantTypeSpecHash ~attrs ~full:false p] + Parser.next p; + [ parseTagSpec p ] + | Hash -> [ parsePolymorphicVariantTypeSpecHash ~attrs ~full:false p ] | _ -> ( - let typ = parseTypExpr ~attrs p in - match p.token with - | Rbracket -> - (* example: [ListStyleType.t] *) - [Parsetree.Rinherit typ] - | _ -> - Parser.expect Bar p; - [Parsetree.Rinherit typ; parseTagSpec p]) + let typ = parseTypExpr ~attrs p in + match p.token with + | Rbracket -> + (* example: [ListStyleType.t] *) + [ Parsetree.Rinherit typ ] + | _ -> + Parser.expect Bar p; + [ Parsetree.Rinherit typ; parseTagSpec p ]) and parsePolymorphicVariantTypeSpecHash ~attrs ~full p : Parsetree.row_field = let startPos = p.Parser.startPos in @@ -301766,17 +302107,17 @@ and parsePolymorphicVariantTypeSpecHash ~attrs ~full p : Parsetree.row_field = let rec loop p = match p.Parser.token with | Band when full -> - Parser.next p; - let rowField = parsePolymorphicVariantTypeArgs p in - rowField :: loop p + Parser.next p; + let rowField = parsePolymorphicVariantTypeArgs p in + rowField :: loop p | _ -> [] in let firstTuple, tagContainsAConstantEmptyConstructor = match p.Parser.token with | Band when full -> - Parser.next p; - ([parsePolymorphicVariantTypeArgs p], true) - | Lparen -> ([parsePolymorphicVariantTypeArgs p], false) + Parser.next p; + ([ parsePolymorphicVariantTypeArgs p ], true) + | Lparen -> ([ parsePolymorphicVariantTypeArgs p ], false) | _ -> ([], true) in let tuples = firstTuple @ loop p in @@ -301797,32 +302138,32 @@ and parsePolymorphicVariantTypeArgs p = let attrs = [] in let loc = mkLoc startPos p.prevEndPos in match args with - | [({ptyp_desc = Ptyp_tuple _} as typ)] as types -> - if p.mode = ParseForTypeChecker then typ - else Ast_helper.Typ.tuple ~loc ~attrs types - | [typ] -> typ + | [ ({ ptyp_desc = Ptyp_tuple _ } as typ) ] as types -> + if p.mode = ParseForTypeChecker then typ + else Ast_helper.Typ.tuple ~loc ~attrs types + | [ typ ] -> typ | types -> Ast_helper.Typ.tuple ~loc ~attrs types and parseTypeEquationAndRepresentation p = match p.Parser.token with | (Equal | Bar) as token -> ( - if token = Bar then Parser.expect Equal p; - Parser.next p; - match p.Parser.token with - | Uident _ -> parseTypeEquationOrConstrDecl p - | Lbrace -> parseRecordOrObjectDecl p - | Private -> parsePrivateEqOrRepr p - | Bar | DotDot -> - let priv, kind = parseTypeRepresentation p in - (None, priv, kind) - | _ -> ( - let manifest = Some (parseTypExpr p) in + if token = Bar then Parser.expect Equal p; + Parser.next p; match p.Parser.token with - | Equal -> - Parser.next p; - let priv, kind = parseTypeRepresentation p in - (manifest, priv, kind) - | _ -> (manifest, Public, Parsetree.Ptype_abstract))) + | Uident _ -> parseTypeEquationOrConstrDecl p + | Lbrace -> parseRecordOrObjectDecl p + | Private -> parsePrivateEqOrRepr p + | Bar | DotDot -> + let priv, kind = parseTypeRepresentation p in + (None, priv, kind) + | _ -> ( + let manifest = Some (parseTypExpr p) in + match p.Parser.token with + | Equal -> + Parser.next p; + let priv, kind = parseTypeRepresentation p in + (manifest, priv, kind) + | _ -> (manifest, Public, Parsetree.Ptype_abstract))) | _ -> (None, Public, Parsetree.Ptype_abstract) (* type-definition ::= type [rec] typedef { and typedef } @@ -301862,8 +302203,8 @@ and parseTypeExtension ~params ~attrs ~name p = let attrs, name, kind = match p.Parser.token with | Bar -> - Parser.next p; - parseConstrDef ~parseAttrs:true p + Parser.next p; + parseConstrDef ~parseAttrs:true p | _ -> parseConstrDef ~parseAttrs:true p in let loc = mkLoc constrStart p.prevEndPos in @@ -301872,18 +302213,18 @@ and parseTypeExtension ~params ~attrs ~name p = let rec loop p cs = match p.Parser.token with | Bar -> - let startPos = p.Parser.startPos in - Parser.next p; - let attrs, name, kind = parseConstrDef ~parseAttrs:true p in - let extConstr = - Ast_helper.Te.constructor ~attrs - ~loc:(mkLoc startPos p.prevEndPos) - name kind - in - loop p (extConstr :: cs) + let startPos = p.Parser.startPos in + Parser.next p; + let attrs, name, kind = parseConstrDef ~parseAttrs:true p in + let extConstr = + Ast_helper.Te.constructor ~attrs + ~loc:(mkLoc startPos p.prevEndPos) + name kind + in + loop p (extConstr :: cs) | _ -> List.rev cs in - let constructors = loop p [first] in + let constructors = loop p [ first ] in Ast_helper.Te.mk ~attrs ~params ~priv name constructors and parseTypeDefinitions ~attrs ~name ~params ~startPos p = @@ -301892,19 +302233,19 @@ and parseTypeDefinitions ~attrs ~name ~params ~startPos p = let cstrs = parseTypeConstraints p in let loc = mkLoc startPos p.prevEndPos in Ast_helper.Type.mk ~loc ~attrs ~priv ~kind ~params ~cstrs ?manifest - {name with txt = lidentOfPath name.Location.txt} + { name with txt = lidentOfPath name.Location.txt } in let rec loop p defs = let startPos = p.Parser.startPos in let attrs = parseAttributesAndBinding p in match p.Parser.token with | And -> - Parser.next p; - let typeDef = parseTypeDef ~attrs ~startPos p in - loop p (typeDef :: defs) + Parser.next p; + let typeDef = parseTypeDef ~attrs ~startPos p in + loop p (typeDef :: defs) | _ -> List.rev defs in - loop p [typeDef] + loop p [ typeDef ] (* TODO: decide if we really want type extensions (eg. type x += Blue) * It adds quite a bit of complexity that can be avoided, @@ -301916,11 +302257,11 @@ and parseTypeDefinitionOrExtension ~attrs p = let recFlag = match p.token with | Rec -> - Parser.next p; - Asttypes.Recursive + Parser.next p; + Asttypes.Recursive | Lident "nonrec" -> - Parser.next p; - Asttypes.Nonrecursive + Parser.next p; + Asttypes.Nonrecursive | _ -> Asttypes.Nonrecursive in let name = parseValuePath p in @@ -301928,17 +302269,17 @@ and parseTypeDefinitionOrExtension ~attrs p = match p.Parser.token with | PlusEqual -> TypeExt (parseTypeExtension ~params ~attrs ~name p) | _ -> - (* shape of type name should be Lident, i.e. `t` is accepted. `User.t` not *) - let () = - match name.Location.txt with - | Lident _ -> () - | longident -> - Parser.err ~startPos:name.loc.loc_start ~endPos:name.loc.loc_end p - (longident |> ErrorMessages.typeDeclarationNameLongident - |> Diagnostics.message) - in - let typeDefs = parseTypeDefinitions ~attrs ~name ~params ~startPos p in - TypeDef {recFlag; types = typeDefs} + (* shape of type name should be Lident, i.e. `t` is accepted. `User.t` not *) + let () = + match name.Location.txt with + | Lident _ -> () + | longident -> + Parser.err ~startPos:name.loc.loc_start ~endPos:name.loc.loc_end p + (longident |> ErrorMessages.typeDeclarationNameLongident + |> Diagnostics.message) + in + let typeDefs = parseTypeDefinitions ~attrs ~name ~params ~startPos p in + TypeDef { recFlag; types = typeDefs } (* external value-name : typexp = external-declaration *) and parseExternalDef ~attrs ~startPos p = @@ -301954,14 +302295,14 @@ and parseExternalDef ~attrs ~startPos p = let prim = match p.token with | String s -> - Parser.next p; - [s] + Parser.next p; + [ s ] | _ -> - Parser.err ~startPos:equalStart ~endPos:equalEnd p - (Diagnostics.message - ("An external requires the name of the JS value you're referring \ - to, like \"" ^ name.txt ^ "\".")); - [] + Parser.err ~startPos:equalStart ~endPos:equalEnd p + (Diagnostics.message + ("An external requires the name of the JS value you're referring \ + to, like \"" ^ name.txt ^ "\".")); + [] in let loc = mkLoc startPos p.prevEndPos in let vb = Ast_helper.Val.mk ~loc ~attrs ~prim name typExpr in @@ -301980,26 +302321,26 @@ and parseConstrDef ~parseAttrs p = let name = match p.Parser.token with | Uident name -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Location.mkloc name loc + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc name loc | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" in let kind = match p.Parser.token with | Lparen -> - let args, res = parseConstrDeclArgs p in - Parsetree.Pext_decl (args, res) + let args, res = parseConstrDeclArgs p in + Parsetree.Pext_decl (args, res) | Equal -> - Parser.next p; - let longident = parseModuleLongIdent ~lowercase:false p in - Parsetree.Pext_rebind longident + Parser.next p; + let longident = parseModuleLongIdent ~lowercase:false p in + Parsetree.Pext_rebind longident | Colon -> - Parser.next p; - let typ = parseTypExpr p in - Parsetree.Pext_decl (Pcstr_tuple [], Some typ) + Parser.next p; + let typ = parseTypExpr p in + Parsetree.Pext_decl (Pcstr_tuple [], Some typ) | _ -> Parsetree.Pext_decl (Pcstr_tuple [], None) in (attrs, name, kind) @@ -302022,12 +302363,12 @@ and parseNewlineOrSemicolonStructure p = match p.Parser.token with | Semicolon -> Parser.next p | token when Grammar.isStructureItemStart token -> - if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then () - else - Parser.err ~startPos:p.prevEndPos ~endPos:p.endPos p - (Diagnostics.message - "consecutive statements on a line must be separated by ';' or a \ - newline") + if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then () + else + Parser.err ~startPos:p.prevEndPos ~endPos:p.endPos p + (Diagnostics.message + "consecutive statements on a line must be separated by ';' or a \ + newline") | _ -> () and parseStructureItemRegion p = @@ -302035,87 +302376,89 @@ and parseStructureItemRegion p = let attrs = parseAttributes p in match p.Parser.token with | Open -> - let openDescription = parseOpenDescription ~attrs p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.open_ ~loc openDescription) - | Let -> - let recFlag, letBindings = parseLetBindings ~attrs p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.value ~loc recFlag letBindings) - | Typ -> ( - Parser.beginRegion p; - match parseTypeDefinitionOrExtension ~attrs p with - | TypeDef {recFlag; types} -> + let openDescription = parseOpenDescription ~attrs p in parseNewlineOrSemicolonStructure p; let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Str.type_ ~loc recFlag types) - | TypeExt ext -> + Some (Ast_helper.Str.open_ ~loc openDescription) + | Let -> + let recFlag, letBindings = parseLetBindings ~attrs p in parseNewlineOrSemicolonStructure p; let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Str.type_extension ~loc ext)) + Some (Ast_helper.Str.value ~loc recFlag letBindings) + | Typ -> ( + Parser.beginRegion p; + match parseTypeDefinitionOrExtension ~attrs p with + | TypeDef { recFlag; types } -> + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some (Ast_helper.Str.type_ ~loc recFlag types) + | TypeExt ext -> + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some (Ast_helper.Str.type_extension ~loc ext)) | External -> - let externalDef = parseExternalDef ~attrs ~startPos p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.primitive ~loc externalDef) + let externalDef = parseExternalDef ~attrs ~startPos p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Str.primitive ~loc externalDef) | Exception -> - let exceptionDef = parseExceptionDef ~attrs p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.exception_ ~loc exceptionDef) + let exceptionDef = parseExceptionDef ~attrs p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Str.exception_ ~loc exceptionDef) | Include -> - let includeStatement = parseIncludeStatement ~attrs p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.include_ ~loc includeStatement) + let includeStatement = parseIncludeStatement ~attrs p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Str.include_ ~loc includeStatement) | Module -> - Parser.beginRegion p; - let structureItem = parseModuleOrModuleTypeImplOrPackExpr ~attrs p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some {structureItem with pstr_loc = loc} + Parser.beginRegion p; + let structureItem = parseModuleOrModuleTypeImplOrPackExpr ~attrs p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some { structureItem with pstr_loc = loc } | ModuleComment (loc, s) -> - Parser.next p; - Some - (Ast_helper.Str.attribute ~loc - ( {txt = "ns.doc"; loc}, - PStr - [ - Ast_helper.Str.eval ~loc - (Ast_helper.Exp.constant ~loc (Pconst_string (s, None))); - ] )) + Parser.next p; + Some + (Ast_helper.Str.attribute ~loc + ( { txt = "ns.doc"; loc }, + PStr + [ + Ast_helper.Str.eval ~loc + (Ast_helper.Exp.constant ~loc (Pconst_string (s, None))); + ] )) | AtAt -> - let attr = parseStandaloneAttribute p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.attribute ~loc attr) + let attr = parseStandaloneAttribute p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Str.attribute ~loc attr) | PercentPercent -> - let extension = parseExtension ~moduleLanguage:true p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.extension ~attrs ~loc extension) + let extension = parseExtension ~moduleLanguage:true p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Str.extension ~attrs ~loc extension) | token when Grammar.isExprStart token -> - let prevEndPos = p.Parser.endPos in - let exp = parseExpr p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Parser.checkProgress ~prevEndPos - ~result:(Ast_helper.Str.eval ~loc ~attrs exp) - p + let prevEndPos = p.Parser.endPos in + let exp = parseExpr p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Parser.checkProgress ~prevEndPos + ~result:(Ast_helper.Str.eval ~loc ~attrs exp) + p | _ -> ( - match attrs with - | (({Asttypes.loc = attrLoc}, _) as attr) :: _ -> - Parser.err ~startPos:attrLoc.loc_start ~endPos:attrLoc.loc_end p - (Diagnostics.message (ErrorMessages.attributeWithoutNode attr)); - let expr = parseExpr p in - Some - (Ast_helper.Str.eval ~loc:(mkLoc p.startPos p.prevEndPos) ~attrs expr) - | _ -> None) + match attrs with + | (({ Asttypes.loc = attrLoc }, _) as attr) :: _ -> + Parser.err ~startPos:attrLoc.loc_start ~endPos:attrLoc.loc_end p + (Diagnostics.message (ErrorMessages.attributeWithoutNode attr)); + let expr = parseExpr p in + Some + (Ast_helper.Str.eval + ~loc:(mkLoc p.startPos p.prevEndPos) + ~attrs expr) + | _ -> None) [@@progress Parser.next, Parser.expect] (* include-statement ::= include module-expr *) @@ -302130,53 +302473,56 @@ and parseAtomicModuleExpr p = let startPos = p.Parser.startPos in match p.Parser.token with | Uident _ident -> - let longident = parseModuleLongIdent ~lowercase:false p in - Ast_helper.Mod.ident ~loc:longident.loc longident + let longident = parseModuleLongIdent ~lowercase:false p in + Ast_helper.Mod.ident ~loc:longident.loc longident | Lbrace -> - Parser.next p; - let structure = - Ast_helper.Mod.structure - (parseDelimitedRegion ~grammar:Grammar.Structure ~closing:Rbrace - ~f:parseStructureItemRegion p) - in - Parser.expect Rbrace p; - let endPos = p.prevEndPos in - {structure with pmod_loc = mkLoc startPos endPos} + Parser.next p; + let structure = + Ast_helper.Mod.structure + (parseDelimitedRegion ~grammar:Grammar.Structure ~closing:Rbrace + ~f:parseStructureItemRegion p) + in + Parser.expect Rbrace p; + let endPos = p.prevEndPos in + { structure with pmod_loc = mkLoc startPos endPos } | Lparen -> - Parser.next p; - let modExpr = - match p.token with - | Rparen -> Ast_helper.Mod.structure ~loc:(mkLoc startPos p.prevEndPos) [] - | _ -> parseConstrainedModExpr p - in - Parser.expect Rparen p; - modExpr - | Lident "unpack" -> ( - (* TODO: should this be made a keyword?? *) - Parser.next p; - Parser.expect Lparen p; - let expr = parseExpr p in - match p.Parser.token with - | Colon -> - let colonStart = p.Parser.startPos in Parser.next p; - let attrs = parseAttributes p in - let packageType = parsePackageType ~startPos:colonStart ~attrs p in - Parser.expect Rparen p; - let loc = mkLoc startPos p.prevEndPos in - let constraintExpr = Ast_helper.Exp.constraint_ ~loc expr packageType in - Ast_helper.Mod.unpack ~loc constraintExpr - | _ -> + let modExpr = + match p.token with + | Rparen -> + Ast_helper.Mod.structure ~loc:(mkLoc startPos p.prevEndPos) [] + | _ -> parseConstrainedModExpr p + in Parser.expect Rparen p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Mod.unpack ~loc expr) + modExpr + | Lident "unpack" -> ( + (* TODO: should this be made a keyword?? *) + Parser.next p; + Parser.expect Lparen p; + let expr = parseExpr p in + match p.Parser.token with + | Colon -> + let colonStart = p.Parser.startPos in + Parser.next p; + let attrs = parseAttributes p in + let packageType = parsePackageType ~startPos:colonStart ~attrs p in + Parser.expect Rparen p; + let loc = mkLoc startPos p.prevEndPos in + let constraintExpr = + Ast_helper.Exp.constraint_ ~loc expr packageType + in + Ast_helper.Mod.unpack ~loc constraintExpr + | _ -> + Parser.expect Rparen p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Mod.unpack ~loc expr) | Percent -> - let extension = parseExtension p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Mod.extension ~loc extension + let extension = parseExtension p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Mod.extension ~loc extension | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Recover.defaultModuleExpr () + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Recover.defaultModuleExpr () and parsePrimaryModExpr p = let startPos = p.Parser.startPos in @@ -302184,11 +302530,11 @@ and parsePrimaryModExpr p = let rec loop p modExpr = match p.Parser.token with | Lparen when p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> - loop p (parseModuleApplication p modExpr) + loop p (parseModuleApplication p modExpr) | _ -> modExpr in let modExpr = loop p modExpr in - {modExpr with pmod_loc = mkLoc startPos p.prevEndPos} + { modExpr with pmod_loc = mkLoc startPos p.prevEndPos } (* * functor-arg ::= @@ -302202,43 +302548,43 @@ and parseFunctorArg p = let attrs = parseAttributes p in match p.Parser.token with | Uident ident -> ( - Parser.next p; - let uidentEndPos = p.prevEndPos in - match p.Parser.token with - | Colon -> Parser.next p; - let moduleType = parseModuleType p in - let loc = mkLoc startPos uidentEndPos in - let argName = Location.mkloc ident loc in - Some (attrs, argName, Some moduleType, startPos) - | Dot -> + let uidentEndPos = p.prevEndPos in + match p.Parser.token with + | Colon -> + Parser.next p; + let moduleType = parseModuleType p in + let loc = mkLoc startPos uidentEndPos in + let argName = Location.mkloc ident loc in + Some (attrs, argName, Some moduleType, startPos) + | Dot -> + Parser.next p; + let moduleType = + let moduleLongIdent = + parseModuleLongIdentTail ~lowercase:false p startPos + (Longident.Lident ident) + in + Ast_helper.Mty.ident ~loc:moduleLongIdent.loc moduleLongIdent + in + let argName = Location.mknoloc "_" in + Some (attrs, argName, Some moduleType, startPos) + | _ -> + let loc = mkLoc startPos uidentEndPos in + let modIdent = Location.mkloc (Longident.Lident ident) loc in + let moduleType = Ast_helper.Mty.ident ~loc modIdent in + let argName = Location.mknoloc "_" in + Some (attrs, argName, Some moduleType, startPos)) + | Underscore -> Parser.next p; - let moduleType = - let moduleLongIdent = - parseModuleLongIdentTail ~lowercase:false p startPos - (Longident.Lident ident) - in - Ast_helper.Mty.ident ~loc:moduleLongIdent.loc moduleLongIdent - in - let argName = Location.mknoloc "_" in + let argName = Location.mkloc "_" (mkLoc startPos p.prevEndPos) in + Parser.expect Colon p; + let moduleType = parseModuleType p in Some (attrs, argName, Some moduleType, startPos) - | _ -> - let loc = mkLoc startPos uidentEndPos in - let modIdent = Location.mkloc (Longident.Lident ident) loc in - let moduleType = Ast_helper.Mty.ident ~loc modIdent in - let argName = Location.mknoloc "_" in - Some (attrs, argName, Some moduleType, startPos)) - | Underscore -> - Parser.next p; - let argName = Location.mkloc "_" (mkLoc startPos p.prevEndPos) in - Parser.expect Colon p; - let moduleType = parseModuleType p in - Some (attrs, argName, Some moduleType, startPos) | Lparen -> - Parser.next p; - Parser.expect Rparen p; - let argName = Location.mkloc "*" (mkLoc startPos p.prevEndPos) in - Some (attrs, argName, None, startPos) + Parser.next p; + Parser.expect Rparen p; + let argName = Location.mkloc "*" (mkLoc startPos p.prevEndPos) in + Some (attrs, argName, None, startPos) | _ -> None and parseFunctorArgs p = @@ -302251,7 +302597,7 @@ and parseFunctorArgs p = Parser.expect Rparen p; match args with | [] -> - [([], Location.mkloc "*" (mkLoc startPos p.prevEndPos), None, startPos)] + [ ([], Location.mkloc "*" (mkLoc startPos p.prevEndPos), None, startPos) ] | args -> args and parseFunctorModuleExpr p = @@ -302260,8 +302606,8 @@ and parseFunctorModuleExpr p = let returnType = match p.Parser.token with | Colon -> - Parser.next p; - Some (parseModuleType ~es6Arrow:false p) + Parser.next p; + Some (parseModuleType ~es6Arrow:false p) | _ -> None in Parser.expect EqualGreater p; @@ -302269,10 +302615,10 @@ and parseFunctorModuleExpr p = let modExpr = parseModuleExpr p in match returnType with | Some modType -> - Ast_helper.Mod.constraint_ - ~loc: - (mkLoc modExpr.pmod_loc.loc_start modType.Parsetree.pmty_loc.loc_end) - modExpr modType + Ast_helper.Mod.constraint_ + ~loc: + (mkLoc modExpr.pmod_loc.loc_start modType.Parsetree.pmty_loc.loc_end) + modExpr modType | None -> modExpr in let endPos = p.prevEndPos in @@ -302283,7 +302629,7 @@ and parseFunctorModuleExpr p = moduleType acc) args rhsModuleExpr in - {modExpr with pmod_loc = mkLoc startPos endPos} + { modExpr with pmod_loc = mkLoc startPos endPos } (* module-expr ::= * | module-path @@ -302300,16 +302646,19 @@ and parseModuleExpr p = if isEs6ArrowFunctor p then parseFunctorModuleExpr p else parsePrimaryModExpr p in - {modExpr with pmod_attributes = List.concat [modExpr.pmod_attributes; attrs]} + { + modExpr with + pmod_attributes = List.concat [ modExpr.pmod_attributes; attrs ]; + } and parseConstrainedModExpr p = let modExpr = parseModuleExpr p in match p.Parser.token with | Colon -> - Parser.next p; - let modType = parseModuleType p in - let loc = mkLoc modExpr.pmod_loc.loc_start modType.pmty_loc.loc_end in - Ast_helper.Mod.constraint_ ~loc modExpr modType + Parser.next p; + let modType = parseModuleType p in + let loc = mkLoc modExpr.pmod_loc.loc_start modType.pmty_loc.loc_end in + Ast_helper.Mod.constraint_ ~loc modExpr modType | _ -> modExpr and parseConstrainedModExprRegion p = @@ -302327,8 +302676,8 @@ and parseModuleApplication p modExpr = let args = match args with | [] -> - let loc = mkLoc startPos p.prevEndPos in - [Ast_helper.Mod.structure ~loc []] + let loc = mkLoc startPos p.prevEndPos in + [ Ast_helper.Mod.structure ~loc [] ] | args -> args in List.fold_left @@ -302346,11 +302695,11 @@ and parseModuleOrModuleTypeImplOrPackExpr ~attrs p = match p.Parser.token with | Typ -> parseModuleTypeImpl ~attrs startPos p | Lparen -> - let expr = parseFirstClassModuleExpr ~startPos p in - let a = parsePrimaryExpr ~operand:expr p in - let expr = parseBinaryExpr ~a p 1 in - let expr = parseTernaryExpr expr p in - Ast_helper.Str.eval ~attrs expr + let expr = parseFirstClassModuleExpr ~startPos p in + let a = parsePrimaryExpr ~operand:expr p in + let expr = parseBinaryExpr ~a p 1 in + let expr = parseTernaryExpr expr p in + Ast_helper.Str.eval ~attrs expr | _ -> parseMaybeRecModuleBinding ~attrs ~startPos p and parseModuleTypeImpl ~attrs startPos p = @@ -302359,16 +302708,16 @@ and parseModuleTypeImpl ~attrs startPos p = let name = match p.Parser.token with | Lident ident -> - Parser.next p; - let loc = mkLoc nameStart p.prevEndPos in - Location.mkloc ident loc + Parser.next p; + let loc = mkLoc nameStart p.prevEndPos in + Location.mkloc ident loc | Uident ident -> - Parser.next p; - let loc = mkLoc nameStart p.prevEndPos in - Location.mkloc ident loc + Parser.next p; + let loc = mkLoc nameStart p.prevEndPos in + Location.mkloc ident loc | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" in Parser.expect Equal p; let moduleType = parseModuleType p in @@ -302386,23 +302735,23 @@ and parseModuleTypeImpl ~attrs startPos p = and parseMaybeRecModuleBinding ~attrs ~startPos p = match p.Parser.token with | Token.Rec -> - Parser.next p; - Ast_helper.Str.rec_module (parseModuleBindings ~startPos ~attrs p) + Parser.next p; + Ast_helper.Str.rec_module (parseModuleBindings ~startPos ~attrs p) | _ -> - Ast_helper.Str.module_ - (parseModuleBinding ~attrs ~startPos:p.Parser.startPos p) + Ast_helper.Str.module_ + (parseModuleBinding ~attrs ~startPos:p.Parser.startPos p) and parseModuleBinding ~attrs ~startPos p = let name = match p.Parser.token with | Uident ident -> - let startPos = p.Parser.startPos in - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - Location.mkloc ident loc + let startPos = p.Parser.startPos in + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + Location.mkloc ident loc | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" in let body = parseModuleBindingBody p in let loc = mkLoc startPos p.prevEndPos in @@ -302413,17 +302762,17 @@ and parseModuleBindingBody p = let returnModType = match p.Parser.token with | Colon -> - Parser.next p; - Some (parseModuleType p) + Parser.next p; + Some (parseModuleType p) | _ -> None in Parser.expect Equal p; let modExpr = parseModuleExpr p in match returnModType with | Some modType -> - Ast_helper.Mod.constraint_ - ~loc:(mkLoc modType.pmty_loc.loc_start modExpr.pmod_loc.loc_end) - modExpr modType + Ast_helper.Mod.constraint_ + ~loc:(mkLoc modType.pmty_loc.loc_start modExpr.pmod_loc.loc_end) + modExpr modType | None -> modExpr (* module-name : module-type = module-expr @@ -302434,52 +302783,52 @@ and parseModuleBindings ~attrs ~startPos p = let attrs = parseAttributesAndBinding p in match p.Parser.token with | And -> - Parser.next p; - ignore (Parser.optional p Module); - (* over-parse for fault-tolerance *) - let modBinding = parseModuleBinding ~attrs ~startPos p in - loop p (modBinding :: acc) + Parser.next p; + ignore (Parser.optional p Module); + (* over-parse for fault-tolerance *) + let modBinding = parseModuleBinding ~attrs ~startPos p in + loop p (modBinding :: acc) | _ -> List.rev acc in let first = parseModuleBinding ~attrs ~startPos p in - loop p [first] + loop p [ first ] and parseAtomicModuleType p = let startPos = p.Parser.startPos in let moduleType = match p.Parser.token with | Uident _ | Lident _ -> - (* Ocaml allows module types to end with lowercase: module Foo : bar = { ... } - * lets go with uppercase terminal for now *) - let moduleLongIdent = parseModuleLongIdent ~lowercase:true p in - Ast_helper.Mty.ident ~loc:moduleLongIdent.loc moduleLongIdent + (* Ocaml allows module types to end with lowercase: module Foo : bar = { ... } + * lets go with uppercase terminal for now *) + let moduleLongIdent = parseModuleLongIdent ~lowercase:true p in + Ast_helper.Mty.ident ~loc:moduleLongIdent.loc moduleLongIdent | Lparen -> - Parser.next p; - let mty = parseModuleType p in - Parser.expect Rparen p; - {mty with pmty_loc = mkLoc startPos p.prevEndPos} + Parser.next p; + let mty = parseModuleType p in + Parser.expect Rparen p; + { mty with pmty_loc = mkLoc startPos p.prevEndPos } | Lbrace -> - Parser.next p; - let spec = - parseDelimitedRegion ~grammar:Grammar.Signature ~closing:Rbrace - ~f:parseSignatureItemRegion p - in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Mty.signature ~loc spec + Parser.next p; + let spec = + parseDelimitedRegion ~grammar:Grammar.Signature ~closing:Rbrace + ~f:parseSignatureItemRegion p + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Mty.signature ~loc spec | Module -> - (* TODO: check if this is still atomic when implementing first class modules*) - parseModuleTypeOf p + (* TODO: check if this is still atomic when implementing first class modules*) + parseModuleTypeOf p | Percent -> - let extension = parseExtension p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Mty.extension ~loc extension + let extension = parseExtension p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Mty.extension ~loc extension | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Recover.defaultModuleType () + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Recover.defaultModuleType () in let moduleTypeLoc = mkLoc startPos p.prevEndPos in - {moduleType with pmty_loc = moduleTypeLoc} + { moduleType with pmty_loc = moduleTypeLoc } and parseFunctorModuleType p = let startPos = p.Parser.startPos in @@ -302494,7 +302843,7 @@ and parseFunctorModuleType p = moduleType acc) args rhs in - {modType with pmty_loc = mkLoc startPos endPos} + { modType with pmty_loc = mkLoc startPos endPos } (* Module types are the module-level equivalent of type expressions: they * specify the general shape and type properties of modules. @@ -302518,33 +302867,36 @@ and parseModuleType ?(es6Arrow = true) ?(with_ = true) p = let modty = parseAtomicModuleType p in match p.Parser.token with | EqualGreater when es6Arrow == true -> - Parser.next p; - let rhs = parseModuleType ~with_:false p in - let str = Location.mknoloc "_" in - let loc = mkLoc modty.pmty_loc.loc_start p.prevEndPos in - Ast_helper.Mty.functor_ ~loc str (Some modty) rhs + Parser.next p; + let rhs = parseModuleType ~with_:false p in + let str = Location.mknoloc "_" in + let loc = mkLoc modty.pmty_loc.loc_start p.prevEndPos in + Ast_helper.Mty.functor_ ~loc str (Some modty) rhs | _ -> modty in let moduleType = - {modty with pmty_attributes = List.concat [modty.pmty_attributes; attrs]} + { + modty with + pmty_attributes = List.concat [ modty.pmty_attributes; attrs ]; + } in if with_ then parseWithConstraints moduleType p else moduleType and parseWithConstraints moduleType p = match p.Parser.token with | Lident "with" -> - Parser.next p; - let first = parseWithConstraint p in - let rec loop p acc = - match p.Parser.token with - | And -> - Parser.next p; - loop p (parseWithConstraint p :: acc) - | _ -> List.rev acc - in - let constraints = loop p [first] in - let loc = mkLoc moduleType.pmty_loc.loc_start p.prevEndPos in - Ast_helper.Mty.with_ ~loc moduleType constraints + Parser.next p; + let first = parseWithConstraint p in + let rec loop p acc = + match p.Parser.token with + | And -> + Parser.next p; + loop p (parseWithConstraint p :: acc) + | _ -> List.rev acc + in + let constraints = loop p [ first ] in + let loc = mkLoc moduleType.pmty_loc.loc_start p.prevEndPos in + Ast_helper.Mty.with_ ~loc moduleType constraints | _ -> moduleType (* mod-constraint ::= @@ -302557,60 +302909,63 @@ and parseWithConstraints moduleType p = and parseWithConstraint p = match p.Parser.token with | Module -> ( - Parser.next p; - let modulePath = parseModuleLongIdent ~lowercase:false p in - match p.Parser.token with - | ColonEqual -> - Parser.next p; - let lident = parseModuleLongIdent ~lowercase:false p in - Parsetree.Pwith_modsubst (modulePath, lident) - | Equal -> Parser.next p; - let lident = parseModuleLongIdent ~lowercase:false p in - Parsetree.Pwith_module (modulePath, lident) - | token -> - (* TODO: revisit *) - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - let lident = parseModuleLongIdent ~lowercase:false p in - Parsetree.Pwith_modsubst (modulePath, lident)) + let modulePath = parseModuleLongIdent ~lowercase:false p in + match p.Parser.token with + | ColonEqual -> + Parser.next p; + let lident = parseModuleLongIdent ~lowercase:false p in + Parsetree.Pwith_modsubst (modulePath, lident) + | Equal -> + Parser.next p; + let lident = parseModuleLongIdent ~lowercase:false p in + Parsetree.Pwith_module (modulePath, lident) + | token -> + (* TODO: revisit *) + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + let lident = parseModuleLongIdent ~lowercase:false p in + Parsetree.Pwith_modsubst (modulePath, lident)) | Typ -> ( - Parser.next p; - let typeConstr = parseValuePath p in - let params = parseTypeParams ~parent:typeConstr p in - match p.Parser.token with - | ColonEqual -> Parser.next p; - let typExpr = parseTypExpr p in - Parsetree.Pwith_typesubst - ( typeConstr, - Ast_helper.Type.mk ~loc:typeConstr.loc ~params ~manifest:typExpr - (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) ) - | Equal -> - Parser.next p; - let typExpr = parseTypExpr p in - let typeConstraints = parseTypeConstraints p in - Parsetree.Pwith_type - ( typeConstr, - Ast_helper.Type.mk ~loc:typeConstr.loc ~params ~manifest:typExpr - ~cstrs:typeConstraints - (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) ) - | token -> - (* TODO: revisit *) + let typeConstr = parseValuePath p in + let params = parseTypeParams ~parent:typeConstr p in + match p.Parser.token with + | ColonEqual -> + Parser.next p; + let typExpr = parseTypExpr p in + Parsetree.Pwith_typesubst + ( typeConstr, + Ast_helper.Type.mk ~loc:typeConstr.loc ~params ~manifest:typExpr + (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) + ) + | Equal -> + Parser.next p; + let typExpr = parseTypExpr p in + let typeConstraints = parseTypeConstraints p in + Parsetree.Pwith_type + ( typeConstr, + Ast_helper.Type.mk ~loc:typeConstr.loc ~params ~manifest:typExpr + ~cstrs:typeConstraints + (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) + ) + | token -> + (* TODO: revisit *) + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + let typExpr = parseTypExpr p in + let typeConstraints = parseTypeConstraints p in + Parsetree.Pwith_type + ( typeConstr, + Ast_helper.Type.mk ~loc:typeConstr.loc ~params ~manifest:typExpr + ~cstrs:typeConstraints + (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) + )) + | token -> + (* TODO: implement recovery strategy *) Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - let typExpr = parseTypExpr p in - let typeConstraints = parseTypeConstraints p in Parsetree.Pwith_type - ( typeConstr, - Ast_helper.Type.mk ~loc:typeConstr.loc ~params ~manifest:typExpr - ~cstrs:typeConstraints - (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) )) - | token -> - (* TODO: implement recovery strategy *) - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Parsetree.Pwith_type - ( Location.mknoloc (Longident.Lident ""), - Ast_helper.Type.mk ~params:[] ~manifest:(Recover.defaultType ()) - ~cstrs:[] (Location.mknoloc "") ) + ( Location.mknoloc (Longident.Lident ""), + Ast_helper.Type.mk ~params:[] ~manifest:(Recover.defaultType ()) + ~cstrs:[] (Location.mknoloc "") ) and parseModuleTypeOf p = let startPos = p.Parser.startPos in @@ -302624,12 +302979,12 @@ and parseNewlineOrSemicolonSignature p = match p.Parser.token with | Semicolon -> Parser.next p | token when Grammar.isSignatureItemStart token -> - if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then () - else - Parser.err ~startPos:p.prevEndPos ~endPos:p.endPos p - (Diagnostics.message - "consecutive specifications on a line must be separated by ';' or a \ - newline") + if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then () + else + Parser.err ~startPos:p.prevEndPos ~endPos:p.endPos p + (Diagnostics.message + "consecutive specifications on a line must be separated by ';' or \ + a newline") | _ -> () and parseSignatureItemRegion p = @@ -302637,102 +302992,102 @@ and parseSignatureItemRegion p = let attrs = parseAttributes p in match p.Parser.token with | Let -> - Parser.beginRegion p; - let valueDesc = parseSignLetDesc ~attrs p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Sig.value ~loc valueDesc) - | Typ -> ( - Parser.beginRegion p; - match parseTypeDefinitionOrExtension ~attrs p with - | TypeDef {recFlag; types} -> + Parser.beginRegion p; + let valueDesc = parseSignLetDesc ~attrs p in parseNewlineOrSemicolonSignature p; let loc = mkLoc startPos p.prevEndPos in Parser.endRegion p; - Some (Ast_helper.Sig.type_ ~loc recFlag types) - | TypeExt ext -> + Some (Ast_helper.Sig.value ~loc valueDesc) + | Typ -> ( + Parser.beginRegion p; + match parseTypeDefinitionOrExtension ~attrs p with + | TypeDef { recFlag; types } -> + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some (Ast_helper.Sig.type_ ~loc recFlag types) + | TypeExt ext -> + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some (Ast_helper.Sig.type_extension ~loc ext)) + | External -> + let externalDef = parseExternalDef ~attrs ~startPos p in parseNewlineOrSemicolonSignature p; let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Sig.type_extension ~loc ext)) - | External -> - let externalDef = parseExternalDef ~attrs ~startPos p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.value ~loc externalDef) + Some (Ast_helper.Sig.value ~loc externalDef) | Exception -> - let exceptionDef = parseExceptionDef ~attrs p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.exception_ ~loc exceptionDef) - | Open -> - let openDescription = parseOpenDescription ~attrs p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.open_ ~loc openDescription) - | Include -> - Parser.next p; - let moduleType = parseModuleType p in - let includeDescription = - Ast_helper.Incl.mk ~loc:(mkLoc startPos p.prevEndPos) ~attrs moduleType - in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.include_ ~loc includeDescription) - | Module -> ( - Parser.beginRegion p; - Parser.next p; - match p.Parser.token with - | Uident _ -> - let modDecl = parseModuleDeclarationOrAlias ~attrs p in + let exceptionDef = parseExceptionDef ~attrs p in parseNewlineOrSemicolonSignature p; let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Sig.module_ ~loc modDecl) - | Rec -> - let recModule = parseRecModuleSpec ~attrs ~startPos p in + Some (Ast_helper.Sig.exception_ ~loc exceptionDef) + | Open -> + let openDescription = parseOpenDescription ~attrs p in parseNewlineOrSemicolonSignature p; let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Sig.rec_module ~loc recModule) - | Typ -> - let modTypeDecl = parseModuleTypeDeclaration ~attrs ~startPos p in - Parser.endRegion p; - Some modTypeDecl - | _t -> - let modDecl = parseModuleDeclarationOrAlias ~attrs p in + Some (Ast_helper.Sig.open_ ~loc openDescription) + | Include -> + Parser.next p; + let moduleType = parseModuleType p in + let includeDescription = + Ast_helper.Incl.mk ~loc:(mkLoc startPos p.prevEndPos) ~attrs moduleType + in parseNewlineOrSemicolonSignature p; let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Sig.module_ ~loc modDecl)) + Some (Ast_helper.Sig.include_ ~loc includeDescription) + | Module -> ( + Parser.beginRegion p; + Parser.next p; + match p.Parser.token with + | Uident _ -> + let modDecl = parseModuleDeclarationOrAlias ~attrs p in + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some (Ast_helper.Sig.module_ ~loc modDecl) + | Rec -> + let recModule = parseRecModuleSpec ~attrs ~startPos p in + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some (Ast_helper.Sig.rec_module ~loc recModule) + | Typ -> + let modTypeDecl = parseModuleTypeDeclaration ~attrs ~startPos p in + Parser.endRegion p; + Some modTypeDecl + | _t -> + let modDecl = parseModuleDeclarationOrAlias ~attrs p in + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some (Ast_helper.Sig.module_ ~loc modDecl)) | AtAt -> - let attr = parseStandaloneAttribute p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.attribute ~loc attr) + let attr = parseStandaloneAttribute p in + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Sig.attribute ~loc attr) | ModuleComment (loc, s) -> - Parser.next p; - Some - (Ast_helper.Sig.attribute ~loc - ( {txt = "ns.doc"; loc}, - PStr - [ - Ast_helper.Str.eval ~loc - (Ast_helper.Exp.constant ~loc (Pconst_string (s, None))); - ] )) + Parser.next p; + Some + (Ast_helper.Sig.attribute ~loc + ( { txt = "ns.doc"; loc }, + PStr + [ + Ast_helper.Str.eval ~loc + (Ast_helper.Exp.constant ~loc (Pconst_string (s, None))); + ] )) | PercentPercent -> - let extension = parseExtension ~moduleLanguage:true p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.extension ~attrs ~loc extension) + let extension = parseExtension ~moduleLanguage:true p in + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Sig.extension ~attrs ~loc extension) | _ -> ( - match attrs with - | (({Asttypes.loc = attrLoc}, _) as attr) :: _ -> - Parser.err ~startPos:attrLoc.loc_start ~endPos:attrLoc.loc_end p - (Diagnostics.message (ErrorMessages.attributeWithoutNode attr)); - Some Recover.defaultSignatureItem - | _ -> None) + match attrs with + | (({ Asttypes.loc = attrLoc }, _) as attr) :: _ -> + Parser.err ~startPos:attrLoc.loc_start ~endPos:attrLoc.loc_end p + (Diagnostics.message (ErrorMessages.attributeWithoutNode attr)); + Some Recover.defaultSignatureItem + | _ -> None) [@@progress Parser.next, Parser.expect] (* module rec module-name : module-type { and module-name: module-type } *) @@ -302743,31 +303098,31 @@ and parseRecModuleSpec ~attrs ~startPos p = let attrs = parseAttributesAndBinding p in match p.Parser.token with | And -> - (* TODO: give a good error message when with constraint, no parens - * and ASet: (Set.S with type elt = A.t) - * and BTree: (Btree.S with type elt = A.t) - * Without parens, the `and` signals the start of another - * `with-constraint` - *) - Parser.expect And p; - let decl = parseRecModuleDeclaration ~attrs ~startPos p in - loop p (decl :: spec) + (* TODO: give a good error message when with constraint, no parens + * and ASet: (Set.S with type elt = A.t) + * and BTree: (Btree.S with type elt = A.t) + * Without parens, the `and` signals the start of another + * `with-constraint` + *) + Parser.expect And p; + let decl = parseRecModuleDeclaration ~attrs ~startPos p in + loop p (decl :: spec) | _ -> List.rev spec in let first = parseRecModuleDeclaration ~attrs ~startPos p in - loop p [first] + loop p [ first ] (* module-name : module-type *) and parseRecModuleDeclaration ~attrs ~startPos p = let name = match p.Parser.token with | Uident modName -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Location.mkloc modName loc + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc modName loc | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" in Parser.expect Colon p; let modType = parseModuleType p in @@ -302778,25 +303133,25 @@ and parseModuleDeclarationOrAlias ~attrs p = let moduleName = match p.Parser.token with | Uident ident -> - let loc = mkLoc p.Parser.startPos p.endPos in - Parser.next p; - Location.mkloc ident loc + let loc = mkLoc p.Parser.startPos p.endPos in + Parser.next p; + Location.mkloc ident loc | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" in let body = match p.Parser.token with | Colon -> - Parser.next p; - parseModuleType p + Parser.next p; + parseModuleType p | Equal -> - Parser.next p; - let lident = parseModuleLongIdent ~lowercase:false p in - Ast_helper.Mty.alias lident + Parser.next p; + let lident = parseModuleLongIdent ~lowercase:false p in + Ast_helper.Mty.alias lident | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Recover.defaultModuleType () + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Recover.defaultModuleType () in let loc = mkLoc startPos p.prevEndPos in Ast_helper.Md.mk ~loc ~attrs moduleName body @@ -302806,22 +303161,22 @@ and parseModuleTypeDeclaration ~attrs ~startPos p = let moduleName = match p.Parser.token with | Uident ident -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Location.mkloc ident loc + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc ident loc | Lident ident -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Location.mkloc ident loc + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc ident loc | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" in let typ = match p.Parser.token with | Equal -> - Parser.next p; - Some (parseModuleType p) + Parser.next p; + Some (parseModuleType p) | _ -> None in let moduleDecl = Ast_helper.Mtd.mk ~attrs ?typ moduleName in @@ -302844,24 +303199,24 @@ and parseAttributeId ~startPos p = let rec loop p acc = match p.Parser.token with | Lident ident | Uident ident -> ( - Parser.next p; - let id = acc ^ ident in - match p.Parser.token with - | Dot -> Parser.next p; - loop p (id ^ ".") - | _ -> id) + let id = acc ^ ident in + match p.Parser.token with + | Dot -> + Parser.next p; + loop p (id ^ ".") + | _ -> id) | token when Token.isKeyword token -> ( - Parser.next p; - let id = acc ^ Token.toString token in - match p.Parser.token with - | Dot -> Parser.next p; - loop p (id ^ ".") - | _ -> id) + let id = acc ^ Token.toString token in + match p.Parser.token with + | Dot -> + Parser.next p; + loop p (id ^ ".") + | _ -> id) | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - acc + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + acc in let id = loop p "" in let endPos = p.prevEndPos in @@ -302880,62 +303235,62 @@ and parseAttributeId ~startPos p = and parsePayload p = match p.Parser.token with | Lparen when p.startPos.pos_cnum = p.prevEndPos.pos_cnum -> ( - Parser.leaveBreadcrumb p Grammar.AttributePayload; - Parser.next p; - match p.token with - | Colon -> - Parser.next p; - let payload = - if Grammar.isSignatureItemStart p.token then - Parsetree.PSig - (parseDelimitedRegion ~grammar:Grammar.Signature ~closing:Rparen - ~f:parseSignatureItemRegion p) - else Parsetree.PTyp (parseTypExpr p) - in - Parser.expect Rparen p; - Parser.eatBreadcrumb p; - payload - | Question -> + Parser.leaveBreadcrumb p Grammar.AttributePayload; Parser.next p; - let pattern = parsePattern p in - let expr = - match p.token with - | When | If -> + match p.token with + | Colon -> Parser.next p; - Some (parseExpr p) - | _ -> None - in - Parser.expect Rparen p; - Parser.eatBreadcrumb p; - Parsetree.PPat (pattern, expr) - | _ -> - let items = - parseDelimitedRegion ~grammar:Grammar.Structure ~closing:Rparen - ~f:parseStructureItemRegion p - in - Parser.expect Rparen p; - Parser.eatBreadcrumb p; - Parsetree.PStr items) + let payload = + if Grammar.isSignatureItemStart p.token then + Parsetree.PSig + (parseDelimitedRegion ~grammar:Grammar.Signature ~closing:Rparen + ~f:parseSignatureItemRegion p) + else Parsetree.PTyp (parseTypExpr p) + in + Parser.expect Rparen p; + Parser.eatBreadcrumb p; + payload + | Question -> + Parser.next p; + let pattern = parsePattern p in + let expr = + match p.token with + | When | If -> + Parser.next p; + Some (parseExpr p) + | _ -> None + in + Parser.expect Rparen p; + Parser.eatBreadcrumb p; + Parsetree.PPat (pattern, expr) + | _ -> + let items = + parseDelimitedRegion ~grammar:Grammar.Structure ~closing:Rparen + ~f:parseStructureItemRegion p + in + Parser.expect Rparen p; + Parser.eatBreadcrumb p; + Parsetree.PStr items) | _ -> Parsetree.PStr [] (* type attribute = string loc * payload *) and parseAttribute p = match p.Parser.token with | At -> - let startPos = p.startPos in - Parser.next p; - let attrId = parseAttributeId ~startPos p in - let payload = parsePayload p in - Some (attrId, payload) + let startPos = p.startPos in + Parser.next p; + let attrId = parseAttributeId ~startPos p in + let payload = parsePayload p in + Some (attrId, payload) | DocComment (loc, s) -> - Parser.next p; - Some - ( {txt = "ns.doc"; loc}, - PStr - [ - Ast_helper.Str.eval ~loc - (Ast_helper.Exp.constant ~loc (Pconst_string (s, None))); - ] ) + Parser.next p; + Some + ( { txt = "ns.doc"; loc }, + PStr + [ + Ast_helper.Str.eval ~loc + (Ast_helper.Exp.constant ~loc (Pconst_string (s, None))); + ] ) | _ -> None and parseAttributes p = @@ -303035,24 +303390,24 @@ end module Res_driver : sig #1 "res_driver.mli" type ('ast, 'diagnostics) parseResult = { - filename: string; [@live] - source: string; - parsetree: 'ast; - diagnostics: 'diagnostics; - invalid: bool; - comments: Res_comment.t list; + filename : string; [@live] + source : string; + parsetree : 'ast; + diagnostics : 'diagnostics; + invalid : bool; + comments : Res_comment.t list; } type 'diagnostics parsingEngine = { - parseImplementation: + parseImplementation : forPrinter:bool -> filename:string -> (Parsetree.structure, 'diagnostics) parseResult; - parseInterface: + parseInterface : forPrinter:bool -> filename:string -> (Parsetree.signature, 'diagnostics) parseResult; - stringOfDiagnostics: source:string -> filename:string -> 'diagnostics -> unit; + stringOfDiagnostics : source:string -> filename:string -> 'diagnostics -> unit; } val parseImplementationFromSource : @@ -303070,13 +303425,13 @@ val parseInterfaceFromSource : [@@live] type printEngine = { - printImplementation: + printImplementation : width:int -> filename:string -> comments:Res_comment.t list -> Parsetree.structure -> unit; - printInterface: + printInterface : width:int -> filename:string -> comments:Res_comment.t list -> @@ -303085,7 +303440,6 @@ type printEngine = { } val parsingEngine : Res_diagnostics.t list parsingEngine - val printEngine : printEngine (* ReScript implementation parsing compatible with ocaml pparse driver. Used by the compiler. *) @@ -303101,34 +303455,34 @@ end = struct module IO = Res_io type ('ast, 'diagnostics) parseResult = { - filename: string; [@live] - source: string; - parsetree: 'ast; - diagnostics: 'diagnostics; - invalid: bool; - comments: Res_comment.t list; + filename : string; [@live] + source : string; + parsetree : 'ast; + diagnostics : 'diagnostics; + invalid : bool; + comments : Res_comment.t list; } type 'diagnostics parsingEngine = { - parseImplementation: + parseImplementation : forPrinter:bool -> filename:string -> (Parsetree.structure, 'diagnostics) parseResult; - parseInterface: + parseInterface : forPrinter:bool -> filename:string -> (Parsetree.signature, 'diagnostics) parseResult; - stringOfDiagnostics: source:string -> filename:string -> 'diagnostics -> unit; + stringOfDiagnostics : source:string -> filename:string -> 'diagnostics -> unit; } type printEngine = { - printImplementation: + printImplementation : width:int -> filename:string -> comments:Res_comment.t list -> Parsetree.structure -> unit; - printInterface: + printInterface : width:int -> filename:string -> comments:Res_comment.t list -> @@ -303267,12 +303621,14 @@ module Res_ast_conversion : sig * shouldn't be mangled when *) val replaceStringLiteralStructure : (string * Location.t) list -> Parsetree.structure -> Parsetree.structure + val replaceStringLiteralSignature : (string * Location.t) list -> Parsetree.signature -> Parsetree.signature (* Get rid of the explicit/implicit arity attributes *) val normalizeReasonArityStructure : forPrinter:bool -> Parsetree.structure -> Parsetree.structure + val normalizeReasonAritySignature : forPrinter:bool -> Parsetree.signature -> Parsetree.signature @@ -303286,7 +303642,7 @@ end = struct let concatLongidents l1 l2 = let parts1 = Longident.flatten l1 in let parts2 = Longident.flatten l2 in - match List.concat [parts1; parts2] |> Longident.unflatten with + match List.concat [ parts1; parts2 ] |> Longident.unflatten with | Some longident -> longident | None -> l2 @@ -303294,72 +303650,79 @@ let concatLongidents l1 l2 = let rec rewritePpatOpen longidentOpen pat = match pat.Parsetree.ppat_desc with | Ppat_array (first :: rest) -> - (* Color.[Red, Blue, Green] -> [Color.Red, Blue, Green] *) - { - pat with - ppat_desc = Ppat_array (rewritePpatOpen longidentOpen first :: rest); - } + (* Color.[Red, Blue, Green] -> [Color.Red, Blue, Green] *) + { + pat with + ppat_desc = Ppat_array (rewritePpatOpen longidentOpen first :: rest); + } | Ppat_tuple (first :: rest) -> - (* Color.(Red, Blue, Green) -> (Color.Red, Blue, Green) *) - { - pat with - ppat_desc = Ppat_tuple (rewritePpatOpen longidentOpen first :: rest); - } + (* Color.(Red, Blue, Green) -> (Color.Red, Blue, Green) *) + { + pat with + ppat_desc = Ppat_tuple (rewritePpatOpen longidentOpen first :: rest); + } | Ppat_construct - ( ({txt = Longident.Lident "::"} as listConstructor), - Some ({ppat_desc = Ppat_tuple (pat :: rest)} as element) ) -> - (* Color.(list[Red, Blue, Green]) -> list[Color.Red, Blue, Green] *) - { - pat with - ppat_desc = - Ppat_construct - ( listConstructor, - Some - { - element with - ppat_desc = - Ppat_tuple (rewritePpatOpen longidentOpen pat :: rest); - } ); - } - | Ppat_construct (({txt = constructor} as longidentLoc), optPattern) -> - (* Foo.(Bar(a)) -> Foo.Bar(a) *) - { - pat with - ppat_desc = - Ppat_construct - ( {longidentLoc with txt = concatLongidents longidentOpen constructor}, - optPattern ); - } - | Ppat_record ((({txt = lbl} as longidentLoc), firstPat) :: rest, flag) -> - (* Foo.{x} -> {Foo.x: x} *) - let firstRow = - ({longidentLoc with txt = concatLongidents longidentOpen lbl}, firstPat) - in - {pat with ppat_desc = Ppat_record (firstRow :: rest, flag)} + ( ({ txt = Longident.Lident "::" } as listConstructor), + Some ({ ppat_desc = Ppat_tuple (pat :: rest) } as element) ) -> + (* Color.(list[Red, Blue, Green]) -> list[Color.Red, Blue, Green] *) + { + pat with + ppat_desc = + Ppat_construct + ( listConstructor, + Some + { + element with + ppat_desc = + Ppat_tuple (rewritePpatOpen longidentOpen pat :: rest); + } ); + } + | Ppat_construct (({ txt = constructor } as longidentLoc), optPattern) -> + (* Foo.(Bar(a)) -> Foo.Bar(a) *) + { + pat with + ppat_desc = + Ppat_construct + ( { + longidentLoc with + txt = concatLongidents longidentOpen constructor; + }, + optPattern ); + } + | Ppat_record ((({ txt = lbl } as longidentLoc), firstPat) :: rest, flag) -> + (* Foo.{x} -> {Foo.x: x} *) + let firstRow = + ( { longidentLoc with txt = concatLongidents longidentOpen lbl }, + firstPat ) + in + { pat with ppat_desc = Ppat_record (firstRow :: rest, flag) } | Ppat_or (pat1, pat2) -> - { - pat with - ppat_desc = - Ppat_or - ( rewritePpatOpen longidentOpen pat1, - rewritePpatOpen longidentOpen pat2 ); - } + { + pat with + ppat_desc = + Ppat_or + ( rewritePpatOpen longidentOpen pat1, + rewritePpatOpen longidentOpen pat2 ); + } | Ppat_constraint (pattern, typ) -> - { - pat with - ppat_desc = Ppat_constraint (rewritePpatOpen longidentOpen pattern, typ); - } - | Ppat_type ({txt = constructor} as longidentLoc) -> - { - pat with - ppat_desc = - Ppat_type - {longidentLoc with txt = concatLongidents longidentOpen constructor}; - } + { + pat with + ppat_desc = Ppat_constraint (rewritePpatOpen longidentOpen pattern, typ); + } + | Ppat_type ({ txt = constructor } as longidentLoc) -> + { + pat with + ppat_desc = + Ppat_type + { + longidentLoc with + txt = concatLongidents longidentOpen constructor; + }; + } | Ppat_lazy p -> - {pat with ppat_desc = Ppat_lazy (rewritePpatOpen longidentOpen p)} + { pat with ppat_desc = Ppat_lazy (rewritePpatOpen longidentOpen p) } | Ppat_exception p -> - {pat with ppat_desc = Ppat_exception (rewritePpatOpen longidentOpen p)} + { pat with ppat_desc = Ppat_exception (rewritePpatOpen longidentOpen p) } | _ -> pat let rec rewriteReasonFastPipe expr = @@ -303369,25 +303732,31 @@ let rec rewriteReasonFastPipe expr = ( { pexp_desc = Pexp_apply - ( ({pexp_desc = Pexp_ident {txt = Longident.Lident "|."}} as op), - [(Asttypes.Nolabel, lhs); (Nolabel, rhs)] ); + ( ({ pexp_desc = Pexp_ident { txt = Longident.Lident "|." } } as + op), + [ (Asttypes.Nolabel, lhs); (Nolabel, rhs) ] ); pexp_attributes = subAttrs; }, args ) -> - let rhsLoc = {rhs.pexp_loc with loc_end = expr.pexp_loc.loc_end} in - let newLhs = - let expr = rewriteReasonFastPipe lhs in - {expr with pexp_attributes = List.concat [lhs.pexp_attributes; subAttrs]} - in - let newRhs = - { - pexp_loc = rhsLoc; - pexp_attributes = []; - pexp_desc = Pexp_apply (rhs, args); - } - in - let allArgs = (Asttypes.Nolabel, newLhs) :: [(Asttypes.Nolabel, newRhs)] in - {expr with pexp_desc = Pexp_apply (op, allArgs)} + let rhsLoc = { rhs.pexp_loc with loc_end = expr.pexp_loc.loc_end } in + let newLhs = + let expr = rewriteReasonFastPipe lhs in + { + expr with + pexp_attributes = List.concat [ lhs.pexp_attributes; subAttrs ]; + } + in + let newRhs = + { + pexp_loc = rhsLoc; + pexp_attributes = []; + pexp_desc = Pexp_apply (rhs, args); + } + in + let allArgs = + (Asttypes.Nolabel, newLhs) :: [ (Asttypes.Nolabel, newRhs) ] + in + { expr with pexp_desc = Pexp_apply (op, allArgs) } | _ -> expr let makeReasonArityMapper ~forPrinter = @@ -303406,21 +303775,25 @@ let makeReasonArityMapper ~forPrinter = (* | _ -> args *) (* in *) (* default_mapper.expr mapper {pexp_desc=Pexp_variant(lbl, newArgs); pexp_loc; pexp_attributes} *) - | {pexp_desc = Pexp_construct (lid, args); pexp_loc; pexp_attributes} -> - let newArgs = - match args with - | Some {pexp_desc = Pexp_tuple [({pexp_desc = Pexp_tuple _} as sp)]} - as args -> - if forPrinter then args else Some sp - | Some {pexp_desc = Pexp_tuple [sp]} -> Some sp - | _ -> args - in - default_mapper.expr mapper - { - pexp_desc = Pexp_construct (lid, newArgs); - pexp_loc; - pexp_attributes; - } + | { pexp_desc = Pexp_construct (lid, args); pexp_loc; pexp_attributes } + -> + let newArgs = + match args with + | Some + { + pexp_desc = + Pexp_tuple [ ({ pexp_desc = Pexp_tuple _ } as sp) ]; + } as args -> + if forPrinter then args else Some sp + | Some { pexp_desc = Pexp_tuple [ sp ] } -> Some sp + | _ -> args + in + default_mapper.expr mapper + { + pexp_desc = Pexp_construct (lid, newArgs); + pexp_loc; + pexp_attributes; + } | expr -> default_mapper.expr mapper (rewriteReasonFastPipe expr)); pat = (fun mapper pattern -> @@ -303434,21 +303807,25 @@ let makeReasonArityMapper ~forPrinter = (* | _ -> args *) (* in *) (* default_mapper.pat mapper {ppat_desc = Ppat_variant (lbl, newArgs); ppat_loc; ppat_attributes;} *) - | {ppat_desc = Ppat_construct (lid, args); ppat_loc; ppat_attributes} -> - let new_args = - match args with - | Some {ppat_desc = Ppat_tuple [({ppat_desc = Ppat_tuple _} as sp)]} - as args -> - if forPrinter then args else Some sp - | Some {ppat_desc = Ppat_tuple [sp]} -> Some sp - | _ -> args - in - default_mapper.pat mapper - { - ppat_desc = Ppat_construct (lid, new_args); - ppat_loc; - ppat_attributes; - } + | { ppat_desc = Ppat_construct (lid, args); ppat_loc; ppat_attributes } + -> + let new_args = + match args with + | Some + { + ppat_desc = + Ppat_tuple [ ({ ppat_desc = Ppat_tuple _ } as sp) ]; + } as args -> + if forPrinter then args else Some sp + | Some { ppat_desc = Ppat_tuple [ sp ] } -> Some sp + | _ -> args + in + default_mapper.pat mapper + { + ppat_desc = Ppat_construct (lid, new_args); + ppat_loc; + ppat_attributes; + } | x -> default_mapper.pat mapper x); } @@ -303519,9 +303896,9 @@ let looksLikeRecursiveTypeDeclaration typeDeclaration = match kind with | Ptype_abstract | Ptype_open -> false | Ptype_variant constructorDeclarations -> - List.exists checkConstructorDeclaration constructorDeclarations + List.exists checkConstructorDeclaration constructorDeclarations | Ptype_record labelDeclarations -> - List.exists checkLabelDeclaration labelDeclarations + List.exists checkLabelDeclaration labelDeclarations and checkConstructorDeclaration constrDecl = checkConstructorArguments constrDecl.pcd_args || @@ -303534,7 +303911,7 @@ let looksLikeRecursiveTypeDeclaration typeDeclaration = match constrArg with | Pcstr_tuple types -> List.exists checkTypExpr types | Pcstr_record labelDeclarations -> - List.exists checkLabelDeclaration labelDeclarations + List.exists checkLabelDeclaration labelDeclarations and checkTypExpr typ = match typ.ptyp_desc with | Ptyp_any -> false @@ -303545,11 +303922,9 @@ let looksLikeRecursiveTypeDeclaration typeDeclaration = | Ptyp_extension _ -> false | Ptyp_arrow (_lbl, typ1, typ2) -> checkTypExpr typ1 || checkTypExpr typ2 | Ptyp_tuple types -> List.exists checkTypExpr types - | Ptyp_constr ({txt = longident}, types) -> - (match longident with - | Lident ident -> ident = name - | _ -> false) - || List.exists checkTypExpr types + | Ptyp_constr ({ txt = longident }, types) -> + (match longident with Lident ident -> ident = name | _ -> false) + || List.exists checkTypExpr types | Ptyp_alias (typ, _) -> checkTypExpr typ | Ptyp_variant (rowFields, _, _) -> List.exists checkRowFields rowFields | Ptyp_poly (_, typ) -> checkTypExpr typ @@ -303562,9 +303937,7 @@ let looksLikeRecursiveTypeDeclaration typeDeclaration = | Rtag (_, _, _, types) -> List.exists checkTypExpr types | Rinherit typexpr -> checkTypExpr typexpr and checkManifest manifest = - match manifest with - | Some typ -> checkTypExpr typ - | None -> false + match manifest with Some typ -> checkTypExpr typ | None -> false in checkKind typeDeclaration.ptype_kind || checkManifest typeDeclaration.ptype_manifest @@ -303573,7 +303946,7 @@ let filterReasonRawLiteral attrs = List.filter (fun attr -> match attr with - | {Location.txt = "reason.raw_literal"}, _ -> false + | { Location.txt = "reason.raw_literal" }, _ -> false | _ -> true) attrs @@ -303590,48 +303963,48 @@ let stringLiteralMapper stringData = (fun mapper expr -> match expr.pexp_desc with | Pexp_constant (Pconst_string (_txt, None)) -> ( - match - List.find_opt - (fun (_stringData, stringLoc) -> - isSameLocation stringLoc expr.pexp_loc) - remainingStringData - with - | Some (stringData, _) -> - let stringData = - let attr = - List.find_opt - (fun attr -> - match attr with - | {Location.txt = "reason.raw_literal"}, _ -> true - | _ -> false) - expr.pexp_attributes - in - match attr with - | Some - ( _, - PStr - [ - { - pstr_desc = - Pstr_eval - ( { - pexp_desc = - Pexp_constant (Pconst_string (raw, _)); - }, - _ ); - }; - ] ) -> - raw - | _ -> - (String.sub [@doesNotRaise]) stringData 1 - (String.length stringData - 2) - in - { - expr with - pexp_attributes = filterReasonRawLiteral expr.pexp_attributes; - pexp_desc = Pexp_constant (Pconst_string (stringData, None)); - } - | None -> default_mapper.expr mapper expr) + match + List.find_opt + (fun (_stringData, stringLoc) -> + isSameLocation stringLoc expr.pexp_loc) + remainingStringData + with + | Some (stringData, _) -> + let stringData = + let attr = + List.find_opt + (fun attr -> + match attr with + | { Location.txt = "reason.raw_literal" }, _ -> true + | _ -> false) + expr.pexp_attributes + in + match attr with + | Some + ( _, + PStr + [ + { + pstr_desc = + Pstr_eval + ( { + pexp_desc = + Pexp_constant (Pconst_string (raw, _)); + }, + _ ); + }; + ] ) -> + raw + | _ -> + (String.sub [@doesNotRaise]) stringData 1 + (String.length stringData - 2) + in + { + expr with + pexp_attributes = filterReasonRawLiteral expr.pexp_attributes; + pexp_desc = Pexp_constant (Pconst_string (stringData, None)); + } + | None -> default_mapper.expr mapper expr) | _ -> default_mapper.expr mapper expr); } @@ -303639,7 +304012,7 @@ let hasUncurriedAttribute attrs = List.exists (fun attr -> match attr with - | {Asttypes.txt = "bs"}, Parsetree.PStr [] -> true + | { Asttypes.txt = "bs" }, Parsetree.PStr [] -> true | _ -> false) attrs @@ -303653,14 +304026,14 @@ let normalize = (fun mapper ext -> match ext with | id, payload -> - ( {id with txt = Res_printer.convertBsExtension id.txt}, - default_mapper.payload mapper payload )); + ( { id with txt = Res_printer.convertBsExtension id.txt }, + default_mapper.payload mapper payload )); attribute = (fun mapper attr -> match attr with | id, payload -> - ( {id with txt = Res_printer.convertBsExternalAttribute id.txt}, - default_mapper.payload mapper payload )); + ( { id with txt = Res_printer.convertBsExternalAttribute id.txt }, + default_mapper.payload mapper payload )); attributes = (fun mapper attrs -> attrs @@ -303672,156 +304045,161 @@ let normalize = | "implicity_arity" ); }, _ ) -> - false + false | _ -> true) |> default_mapper.attributes mapper); pat = (fun mapper p -> match p.ppat_desc with - | Ppat_open ({txt = longidentOpen}, pattern) -> - let p = rewritePpatOpen longidentOpen pattern in - default_mapper.pat mapper p + | Ppat_open ({ txt = longidentOpen }, pattern) -> + let p = rewritePpatOpen longidentOpen pattern in + default_mapper.pat mapper p | Ppat_constant (Pconst_string (txt, tag)) -> - let newTag = - match tag with - (* transform {|abc|} into {js|abc|js}, because `template string` is interpreted as {js||js} *) - | Some "" -> Some "js" - | tag -> tag - in - let s = Parsetree.Pconst_string (escapeTemplateLiteral txt, newTag) in - { - p with - ppat_attributes = - templateLiteralAttr :: mapper.attributes mapper p.ppat_attributes; - ppat_desc = Ppat_constant s; - } + let newTag = + match tag with + (* transform {|abc|} into {js|abc|js}, because `template string` is interpreted as {js||js} *) + | Some "" -> Some "js" + | tag -> tag + in + let s = + Parsetree.Pconst_string (escapeTemplateLiteral txt, newTag) + in + { + p with + ppat_attributes = + templateLiteralAttr + :: mapper.attributes mapper p.ppat_attributes; + ppat_desc = Ppat_constant s; + } | _ -> default_mapper.pat mapper p); typ = (fun mapper typ -> match typ.ptyp_desc with | Ptyp_constr - ({txt = Longident.Ldot (Longident.Lident "Js", "t")}, [arg]) -> - (* Js.t({"a": b}) -> {"a": b} - Since compiler >9.0.1 objects don't need Js.t wrapping anymore *) - mapper.typ mapper arg + ({ txt = Longident.Ldot (Longident.Lident "Js", "t") }, [ arg ]) -> + (* Js.t({"a": b}) -> {"a": b} + Since compiler >9.0.1 objects don't need Js.t wrapping anymore *) + mapper.typ mapper arg | _ -> default_mapper.typ mapper typ); expr = (fun mapper expr -> match expr.pexp_desc with | Pexp_constant (Pconst_string (txt, None)) -> - let raw = escapeStringContents txt in - let s = Parsetree.Pconst_string (raw, None) in - {expr with pexp_desc = Pexp_constant s} + let raw = escapeStringContents txt in + let s = Parsetree.Pconst_string (raw, None) in + { expr with pexp_desc = Pexp_constant s } | Pexp_constant (Pconst_string (txt, tag)) -> - let newTag = - match tag with - (* transform {|abc|} into {js|abc|js}, we want to preserve unicode by default *) - | Some "" -> Some "js" - | tag -> tag - in - let s = Parsetree.Pconst_string (escapeTemplateLiteral txt, newTag) in - { - expr with - pexp_attributes = - templateLiteralAttr - :: mapper.attributes mapper expr.pexp_attributes; - pexp_desc = Pexp_constant s; - } + let newTag = + match tag with + (* transform {|abc|} into {js|abc|js}, we want to preserve unicode by default *) + | Some "" -> Some "js" + | tag -> tag + in + let s = + Parsetree.Pconst_string (escapeTemplateLiteral txt, newTag) + in + { + expr with + pexp_attributes = + templateLiteralAttr + :: mapper.attributes mapper expr.pexp_attributes; + pexp_desc = Pexp_constant s; + } | Pexp_apply ( callExpr, [ ( Nolabel, ({ pexp_desc = - Pexp_construct ({txt = Longident.Lident "()"}, None); + Pexp_construct ({ txt = Longident.Lident "()" }, None); pexp_attributes = []; } as unitExpr) ); ] ) when hasUncurriedAttribute expr.pexp_attributes -> - { - expr with - pexp_attributes = mapper.attributes mapper expr.pexp_attributes; - pexp_desc = - Pexp_apply - ( callExpr, - [ - ( Nolabel, - { - unitExpr with - pexp_loc = {unitExpr.pexp_loc with loc_ghost = true}; - } ); - ] ); - } + { + expr with + pexp_attributes = mapper.attributes mapper expr.pexp_attributes; + pexp_desc = + Pexp_apply + ( callExpr, + [ + ( Nolabel, + { + unitExpr with + pexp_loc = { unitExpr.pexp_loc with loc_ghost = true }; + } ); + ] ); + } | Pexp_function cases -> - let loc = - match (cases, List.rev cases) with - | first :: _, last :: _ -> + let loc = + match (cases, List.rev cases) with + | first :: _, last :: _ -> + { + first.pc_lhs.ppat_loc with + loc_end = last.pc_rhs.pexp_loc.loc_end; + } + | _ -> Location.none + in + let var = { - first.pc_lhs.ppat_loc with - loc_end = last.pc_rhs.pexp_loc.loc_end; + Parsetree.ppat_loc = Location.none; + ppat_attributes = []; + ppat_desc = Ppat_var (Location.mknoloc "x"); } - | _ -> Location.none - in - let var = + in { - Parsetree.ppat_loc = Location.none; - ppat_attributes = []; - ppat_desc = Ppat_var (Location.mknoloc "x"); + pexp_loc = loc; + pexp_attributes = []; + pexp_desc = + Pexp_fun + ( Asttypes.Nolabel, + None, + var, + { + pexp_loc = loc; + pexp_attributes = []; + pexp_desc = + Pexp_match + ( { + pexp_loc = Location.none; + pexp_attributes = []; + pexp_desc = + Pexp_ident + (Location.mknoloc (Longident.Lident "x")); + }, + mapper.cases mapper cases ); + } ); } - in - { - pexp_loc = loc; - pexp_attributes = []; - pexp_desc = - Pexp_fun - ( Asttypes.Nolabel, - None, - var, - { - pexp_loc = loc; - pexp_attributes = []; - pexp_desc = - Pexp_match - ( { - pexp_loc = Location.none; - pexp_attributes = []; - pexp_desc = - Pexp_ident - (Location.mknoloc (Longident.Lident "x")); - }, - mapper.cases mapper cases ); - } ); - } | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident "!"}}, - [(Asttypes.Nolabel, operand)] ) -> - (* turn `!foo` into `foo.contents` *) - { - pexp_loc = expr.pexp_loc; - pexp_attributes = expr.pexp_attributes; - pexp_desc = - Pexp_field - ( mapper.expr mapper operand, - Location.mknoloc (Longident.Lident "contents") ); - } + ( { pexp_desc = Pexp_ident { txt = Longident.Lident "!" } }, + [ (Asttypes.Nolabel, operand) ] ) -> + (* turn `!foo` into `foo.contents` *) + { + pexp_loc = expr.pexp_loc; + pexp_attributes = expr.pexp_attributes; + pexp_desc = + Pexp_field + ( mapper.expr mapper operand, + Location.mknoloc (Longident.Lident "contents") ); + } | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident "##"}}, + ( { pexp_desc = Pexp_ident { txt = Longident.Lident "##" } }, [ (Asttypes.Nolabel, lhs); ( Nolabel, { pexp_desc = ( Pexp_constant (Pconst_string (txt, None)) - | Pexp_ident {txt = Longident.Lident txt} ); + | Pexp_ident { txt = Longident.Lident txt } ); pexp_loc = labelLoc; } ); ] ) -> - let label = Location.mkloc txt labelLoc in - { - pexp_loc = expr.pexp_loc; - pexp_attributes = expr.pexp_attributes; - pexp_desc = Pexp_send (mapper.expr mapper lhs, label); - } + let label = Location.mkloc txt labelLoc in + { + pexp_loc = expr.pexp_loc; + pexp_attributes = expr.pexp_attributes; + pexp_desc = Pexp_send (mapper.expr mapper lhs, label); + } | Pexp_match ( condition, [ @@ -303829,7 +304207,7 @@ let normalize = pc_lhs = { ppat_desc = - Ppat_construct ({txt = Longident.Lident "true"}, None); + Ppat_construct ({ txt = Longident.Lident "true" }, None); }; pc_rhs = thenExpr; }; @@ -303837,122 +304215,128 @@ let normalize = pc_lhs = { ppat_desc = - Ppat_construct ({txt = Longident.Lident "false"}, None); + Ppat_construct ({ txt = Longident.Lident "false" }, None); }; pc_rhs = elseExpr; }; ] ) -> - let ternaryMarker = - (Location.mknoloc "ns.ternary", Parsetree.PStr []) - in - { - Parsetree.pexp_loc = expr.pexp_loc; - pexp_desc = - Pexp_ifthenelse - ( mapper.expr mapper condition, - mapper.expr mapper thenExpr, - Some (mapper.expr mapper elseExpr) ); - pexp_attributes = ternaryMarker :: expr.pexp_attributes; - } + let ternaryMarker = + (Location.mknoloc "ns.ternary", Parsetree.PStr []) + in + { + Parsetree.pexp_loc = expr.pexp_loc; + pexp_desc = + Pexp_ifthenelse + ( mapper.expr mapper condition, + mapper.expr mapper thenExpr, + Some (mapper.expr mapper elseExpr) ); + pexp_attributes = ternaryMarker :: expr.pexp_attributes; + } | _ -> default_mapper.expr mapper expr); structure_item = (fun mapper structureItem -> match structureItem.pstr_desc with (* heuristic: if we have multiple type declarations, mark them recursive *) | Pstr_type ((Recursive as recFlag), typeDeclarations) -> - let flag = - match typeDeclarations with - | [td] -> - if looksLikeRecursiveTypeDeclaration td then Asttypes.Recursive - else Asttypes.Nonrecursive - | _ -> recFlag - in - { - structureItem with - pstr_desc = - Pstr_type - ( flag, - List.map - (fun typeDeclaration -> - default_mapper.type_declaration mapper typeDeclaration) - typeDeclarations ); - } + let flag = + match typeDeclarations with + | [ td ] -> + if looksLikeRecursiveTypeDeclaration td then + Asttypes.Recursive + else Asttypes.Nonrecursive + | _ -> recFlag + in + { + structureItem with + pstr_desc = + Pstr_type + ( flag, + List.map + (fun typeDeclaration -> + default_mapper.type_declaration mapper typeDeclaration) + typeDeclarations ); + } | _ -> default_mapper.structure_item mapper structureItem); signature_item = (fun mapper signatureItem -> match signatureItem.psig_desc with (* heuristic: if we have multiple type declarations, mark them recursive *) | Psig_type ((Recursive as recFlag), typeDeclarations) -> - let flag = - match typeDeclarations with - | [td] -> - if looksLikeRecursiveTypeDeclaration td then Asttypes.Recursive - else Asttypes.Nonrecursive - | _ -> recFlag - in - { - signatureItem with - psig_desc = - Psig_type - ( flag, - List.map - (fun typeDeclaration -> - default_mapper.type_declaration mapper typeDeclaration) - typeDeclarations ); - } + let flag = + match typeDeclarations with + | [ td ] -> + if looksLikeRecursiveTypeDeclaration td then + Asttypes.Recursive + else Asttypes.Nonrecursive + | _ -> recFlag + in + { + signatureItem with + psig_desc = + Psig_type + ( flag, + List.map + (fun typeDeclaration -> + default_mapper.type_declaration mapper typeDeclaration) + typeDeclarations ); + } | _ -> default_mapper.signature_item mapper signatureItem); value_binding = (fun mapper vb -> match vb with | { - pvb_pat = {ppat_desc = Ppat_var _} as pat; + pvb_pat = { ppat_desc = Ppat_var _ } as pat; pvb_expr = - {pexp_loc = expr_loc; pexp_desc = Pexp_constraint (expr, typ)}; + { pexp_loc = expr_loc; pexp_desc = Pexp_constraint (expr, typ) }; } when expr_loc.loc_ghost -> - (* let t: t = (expr : t) -> let t: t = expr *) - let typ = default_mapper.typ mapper typ in - let pat = default_mapper.pat mapper pat in - let expr = mapper.expr mapper expr in - let newPattern = + (* let t: t = (expr : t) -> let t: t = expr *) + let typ = default_mapper.typ mapper typ in + let pat = default_mapper.pat mapper pat in + let expr = mapper.expr mapper expr in + let newPattern = + { + Parsetree.ppat_loc = + { pat.ppat_loc with loc_end = typ.ptyp_loc.loc_end }; + ppat_attributes = []; + ppat_desc = Ppat_constraint (pat, typ); + } + in { - Parsetree.ppat_loc = - {pat.ppat_loc with loc_end = typ.ptyp_loc.loc_end}; - ppat_attributes = []; - ppat_desc = Ppat_constraint (pat, typ); + vb with + pvb_pat = newPattern; + pvb_expr = expr; + pvb_attributes = + default_mapper.attributes mapper vb.pvb_attributes; } - in - { - vb with - pvb_pat = newPattern; - pvb_expr = expr; - pvb_attributes = default_mapper.attributes mapper vb.pvb_attributes; - } | { pvb_pat = - {ppat_desc = Ppat_constraint (pat, {ptyp_desc = Ptyp_poly ([], _)})}; + { + ppat_desc = Ppat_constraint (pat, { ptyp_desc = Ptyp_poly ([], _) }); + }; pvb_expr = - {pexp_loc = expr_loc; pexp_desc = Pexp_constraint (expr, typ)}; + { pexp_loc = expr_loc; pexp_desc = Pexp_constraint (expr, typ) }; } when expr_loc.loc_ghost -> - (* let t: . t = (expr : t) -> let t: t = expr *) - let typ = default_mapper.typ mapper typ in - let pat = default_mapper.pat mapper pat in - let expr = mapper.expr mapper expr in - let newPattern = + (* let t: . t = (expr : t) -> let t: t = expr *) + let typ = default_mapper.typ mapper typ in + let pat = default_mapper.pat mapper pat in + let expr = mapper.expr mapper expr in + let newPattern = + { + Parsetree.ppat_loc = + { pat.ppat_loc with loc_end = typ.ptyp_loc.loc_end }; + ppat_attributes = []; + ppat_desc = Ppat_constraint (pat, typ); + } + in { - Parsetree.ppat_loc = - {pat.ppat_loc with loc_end = typ.ptyp_loc.loc_end}; - ppat_attributes = []; - ppat_desc = Ppat_constraint (pat, typ); + vb with + pvb_pat = newPattern; + pvb_expr = expr; + pvb_attributes = + default_mapper.attributes mapper vb.pvb_attributes; } - in - { - vb with - pvb_pat = newPattern; - pvb_expr = expr; - pvb_attributes = default_mapper.attributes mapper vb.pvb_attributes; - } | _ -> default_mapper.value_binding mapper vb); } @@ -303986,7 +304370,6 @@ val extractOcamlConcreteSyntax : [@@live] val parsingEngine : unit Res_driver.parsingEngine - val printEngine : Res_driver.printEngine end = struct @@ -304012,26 +304395,26 @@ let extractOcamlConcreteSyntax filename = let token = Lexer.token_with_comments lexbuf in match token with | OcamlParser.COMMENT (txt, loc) -> - let comment = Res_comment.fromOcamlComment ~loc ~prevTokEndPos ~txt in - commentData := comment :: !commentData; - next loc.Location.loc_end () + let comment = Res_comment.fromOcamlComment ~loc ~prevTokEndPos ~txt in + commentData := comment :: !commentData; + next loc.Location.loc_end () | OcamlParser.STRING (_txt, None) -> - let open Location in - let loc = - { - loc_start = lexbuf.lex_start_p; - loc_end = lexbuf.Lexing.lex_curr_p; - loc_ghost = false; - } - in - let len = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum in - let txt = - Bytes.to_string - ((Bytes.sub [@doesNotRaise]) lexbuf.Lexing.lex_buffer - loc.loc_start.pos_cnum len) - in - stringLocs := (txt, loc) :: !stringLocs; - next lexbuf.Lexing.lex_curr_p () + let open Location in + let loc = + { + loc_start = lexbuf.lex_start_p; + loc_end = lexbuf.Lexing.lex_curr_p; + loc_ghost = false; + } + in + let len = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum in + let txt = + Bytes.to_string + ((Bytes.sub [@doesNotRaise]) lexbuf.Lexing.lex_buffer + loc.loc_start.pos_cnum len) + in + stringLocs := (txt, loc) :: !stringLocs; + next lexbuf.Lexing.lex_curr_p () | OcamlParser.EOF -> () | _ -> next lexbuf.Lexing.lex_curr_p () in @@ -304097,7 +304480,7 @@ module Res_multi_printer : sig #1 "res_multi_printer.mli" (* Interface to print source code from different languages to res. * Takes a filename called "input" and returns the corresponding formatted res syntax *) -val print : [`ml | `res] -> input:string -> string +val print : [ `ml | `res ] -> input:string -> string end = struct #1 "res_multi_printer.ml" @@ -304168,11 +304551,11 @@ module Res_outcome_printer : sig * In general it represent messages to show results or errors to the user. *) val parenthesized_ident : string -> bool [@@live] - val setup : unit lazy_t [@@live] (* Needed for e.g. the playground to print typedtree data *) val printOutTypeDoc : Outcometree.out_type -> Res_doc.t [@@live] + val printOutSigItemDoc : ?printNameAsIs:bool -> Outcometree.out_sig_item -> Res_doc.t [@@live] @@ -304209,10 +304592,7 @@ let isValidNumericPolyvarNumber (x : string) = a <= 57 && if len > 1 then - a > 48 - && for_all_from x 1 (function - | '0' .. '9' -> true - | _ -> false) + a > 48 && for_all_from x 1 (function '0' .. '9' -> true | _ -> false) else a >= 48 (* checks if ident contains "arity", like in "arity1", "arity2", "arity3" etc. *) @@ -304249,7 +304629,7 @@ let classifyIdentContent ~allowUident txt = let printIdentLike ~allowUident txt = match classifyIdentContent ~allowUident txt with - | ExoticIdent -> Doc.concat [Doc.text "\\\""; Doc.text txt; Doc.text "\""] + | ExoticIdent -> Doc.concat [ Doc.text "\\\""; Doc.text txt; Doc.text "\"" ] | NormalIdent -> Doc.text txt let printPolyVarIdent txt = @@ -304257,7 +304637,7 @@ let printPolyVarIdent txt = if isValidNumericPolyvarNumber txt then Doc.text txt else match classifyIdentContent ~allowUident:true txt with - | ExoticIdent -> Doc.concat [Doc.text "\""; Doc.text txt; Doc.text "\""] + | ExoticIdent -> Doc.concat [ Doc.text "\""; Doc.text txt; Doc.text "\"" ] | NormalIdent -> Doc.text txt (* ReScript doesn't have parenthesized identifiers. @@ -304308,208 +304688,211 @@ let rec printOutIdentDoc ?(allowUident = true) (ident : Outcometree.out_ident) = match ident with | Oide_ident s -> printIdentLike ~allowUident s | Oide_dot (ident, s) -> - Doc.concat [printOutIdentDoc ident; Doc.dot; Doc.text s] + Doc.concat [ printOutIdentDoc ident; Doc.dot; Doc.text s ] | Oide_apply (call, arg) -> - Doc.concat - [printOutIdentDoc call; Doc.lparen; printOutIdentDoc arg; Doc.rparen] + Doc.concat + [ printOutIdentDoc call; Doc.lparen; printOutIdentDoc arg; Doc.rparen ] let printOutAttributeDoc (outAttribute : Outcometree.out_attribute) = - Doc.concat [Doc.text "@"; Doc.text outAttribute.oattr_name] + Doc.concat [ Doc.text "@"; Doc.text outAttribute.oattr_name ] let printOutAttributesDoc (attrs : Outcometree.out_attribute list) = match attrs with | [] -> Doc.nil | attrs -> - Doc.concat - [ - Doc.group (Doc.join ~sep:Doc.line (List.map printOutAttributeDoc attrs)); - Doc.line; - ] + Doc.concat + [ + Doc.group + (Doc.join ~sep:Doc.line (List.map printOutAttributeDoc attrs)); + Doc.line; + ] let rec collectArrowArgs (outType : Outcometree.out_type) args = match outType with | Otyp_arrow (label, argType, returnType) -> - let arg = (label, argType) in - collectArrowArgs returnType (arg :: args) + let arg = (label, argType) in + collectArrowArgs returnType (arg :: args) | _ as returnType -> (List.rev args, returnType) let rec collectFunctorArgs (outModuleType : Outcometree.out_module_type) args = match outModuleType with | Omty_functor (lbl, optModType, returnModType) -> - let arg = (lbl, optModType) in - collectFunctorArgs returnModType (arg :: args) + let arg = (lbl, optModType) in + collectFunctorArgs returnModType (arg :: args) | _ -> (List.rev args, outModuleType) let rec printOutTypeDoc (outType : Outcometree.out_type) = match outType with | Otyp_abstract | Otyp_open -> Doc.nil | Otyp_variant (nonGen, outVariant, closed, labels) -> - (* bool * out_variant * bool * (string list) option *) - let opening = - match (closed, labels) with - | true, None -> (* [#A | #B] *) Doc.softLine - | false, None -> - (* [> #A | #B] *) - Doc.concat [Doc.greaterThan; Doc.line] - | true, Some [] -> - (* [< #A | #B] *) - Doc.concat [Doc.lessThan; Doc.line] - | true, Some _ -> - (* [< #A | #B > #X #Y ] *) - Doc.concat [Doc.lessThan; Doc.line] - | false, Some _ -> - (* impossible!? ocaml seems to print ?, see oprint.ml in 4.06 *) - Doc.concat [Doc.text "?"; Doc.line] - in - Doc.group - (Doc.concat - [ - (if nonGen then Doc.text "_" else Doc.nil); - Doc.lbracket; - Doc.indent (Doc.concat [opening; printOutVariant outVariant]); - (match labels with - | None | Some [] -> Doc.nil - | Some tags -> - Doc.group - (Doc.concat - [ - Doc.space; - Doc.join ~sep:Doc.space - (List.map - (fun lbl -> printIdentLike ~allowUident:true lbl) - tags); - ])); - Doc.softLine; - Doc.rbracket; - ]) + (* bool * out_variant * bool * (string list) option *) + let opening = + match (closed, labels) with + | true, None -> (* [#A | #B] *) Doc.softLine + | false, None -> + (* [> #A | #B] *) + Doc.concat [ Doc.greaterThan; Doc.line ] + | true, Some [] -> + (* [< #A | #B] *) + Doc.concat [ Doc.lessThan; Doc.line ] + | true, Some _ -> + (* [< #A | #B > #X #Y ] *) + Doc.concat [ Doc.lessThan; Doc.line ] + | false, Some _ -> + (* impossible!? ocaml seems to print ?, see oprint.ml in 4.06 *) + Doc.concat [ Doc.text "?"; Doc.line ] + in + Doc.group + (Doc.concat + [ + (if nonGen then Doc.text "_" else Doc.nil); + Doc.lbracket; + Doc.indent (Doc.concat [ opening; printOutVariant outVariant ]); + (match labels with + | None | Some [] -> Doc.nil + | Some tags -> + Doc.group + (Doc.concat + [ + Doc.space; + Doc.join ~sep:Doc.space + (List.map + (fun lbl -> printIdentLike ~allowUident:true lbl) + tags); + ])); + Doc.softLine; + Doc.rbracket; + ]) | Otyp_alias (typ, aliasTxt) -> - Doc.concat - [ - Doc.lparen; - printOutTypeDoc typ; - Doc.text " as '"; - Doc.text aliasTxt; - Doc.rparen; - ] + Doc.concat + [ + Doc.lparen; + printOutTypeDoc typ; + Doc.text " as '"; + Doc.text aliasTxt; + Doc.rparen; + ] | Otyp_constr ( Oide_dot (Oide_dot (Oide_ident "Js", "Fn"), "arity0"), (* Js.Fn.arity0 *) - [typ] ) -> - (* Js.Fn.arity0 -> (.) => t *) - Doc.concat [Doc.text "(. ()) => "; printOutTypeDoc typ] + [ typ ] ) -> + (* Js.Fn.arity0 -> (.) => t *) + Doc.concat [ Doc.text "(. ()) => "; printOutTypeDoc typ ] | Otyp_constr ( Oide_dot (Oide_dot (Oide_ident "Js", "Fn"), ident), (* Js.Fn.arity2 *) - [(Otyp_arrow _ as arrowType)] (* (int, int) => int *) ) + [ (Otyp_arrow _ as arrowType) ] + (* (int, int) => int *) ) when isArityIdent ident -> - (* Js.Fn.arity2<(int, int) => int> -> (. int, int) => int*) - printOutArrowType ~uncurried:true arrowType + (* Js.Fn.arity2<(int, int) => int> -> (. int, int) => int*) + printOutArrowType ~uncurried:true arrowType | Otyp_constr (outIdent, []) -> printOutIdentDoc ~allowUident:false outIdent | Otyp_manifest (typ1, typ2) -> - Doc.concat [printOutTypeDoc typ1; Doc.text " = "; printOutTypeDoc typ2] + Doc.concat [ printOutTypeDoc typ1; Doc.text " = "; printOutTypeDoc typ2 ] | Otyp_record record -> printRecordDeclarationDoc ~inline:true record | Otyp_stuff txt -> Doc.text txt | Otyp_var (ng, s) -> - Doc.concat [Doc.text ("'" ^ if ng then "_" else ""); Doc.text s] + Doc.concat [ Doc.text ("'" ^ if ng then "_" else ""); Doc.text s ] | Otyp_object (fields, rest) -> printObjectFields fields rest | Otyp_class _ -> Doc.nil | Otyp_attribute (typ, attribute) -> - Doc.group - (Doc.concat - [printOutAttributeDoc attribute; Doc.line; printOutTypeDoc typ]) + Doc.group + (Doc.concat + [ printOutAttributeDoc attribute; Doc.line; printOutTypeDoc typ ]) (* example: Red | Blue | Green | CustomColour(float, float, float) *) | Otyp_sum constructors -> printOutConstructorsDoc constructors (* example: {"name": string, "age": int} *) - | Otyp_constr (Oide_dot (Oide_ident "Js", "t"), [Otyp_object (fields, rest)]) + | Otyp_constr (Oide_dot (Oide_ident "Js", "t"), [ Otyp_object (fields, rest) ]) -> - printObjectFields fields rest + printObjectFields fields rest (* example: node *) | Otyp_constr (outIdent, args) -> - let argsDoc = - match args with - | [] -> Doc.nil - | args -> - Doc.concat - [ - Doc.lessThan; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printOutTypeDoc args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.greaterThan; - ] - in - Doc.group (Doc.concat [printOutIdentDoc outIdent; argsDoc]) + let argsDoc = + match args with + | [] -> Doc.nil + | args -> + Doc.concat + [ + Doc.lessThan; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map printOutTypeDoc args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.greaterThan; + ] + in + Doc.group (Doc.concat [ printOutIdentDoc outIdent; argsDoc ]) | Otyp_tuple tupleArgs -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printOutTypeDoc tupleArgs); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map printOutTypeDoc tupleArgs); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) | Otyp_poly (vars, outType) -> - Doc.group - (Doc.concat - [ - Doc.join ~sep:Doc.space - (List.map (fun var -> Doc.text ("'" ^ var)) vars); - Doc.dot; - Doc.space; - printOutTypeDoc outType; - ]) + Doc.group + (Doc.concat + [ + Doc.join ~sep:Doc.space + (List.map (fun var -> Doc.text ("'" ^ var)) vars); + Doc.dot; + Doc.space; + printOutTypeDoc outType; + ]) | Otyp_arrow _ as typ -> printOutArrowType ~uncurried:false typ | Otyp_module (modName, stringList, outTypes) -> - let packageTypeDoc = - match (stringList, outTypes) with - | [], [] -> Doc.nil - | labels, types -> - let i = ref 0 in - let package = - Doc.join ~sep:Doc.line - ((List.map2 [@doesNotRaise]) - (fun lbl typ -> - Doc.concat - [ - Doc.text - (if i.contents > 0 then "and type " else "with type "); - Doc.text lbl; - Doc.text " = "; - printOutTypeDoc typ; - ]) - labels types) - in - Doc.indent (Doc.concat [Doc.line; package]) - in - Doc.concat - [ - Doc.text "module"; - Doc.lparen; - Doc.text modName; - packageTypeDoc; - Doc.rparen; - ] + let packageTypeDoc = + match (stringList, outTypes) with + | [], [] -> Doc.nil + | labels, types -> + let i = ref 0 in + let package = + Doc.join ~sep:Doc.line + ((List.map2 [@doesNotRaise]) + (fun lbl typ -> + Doc.concat + [ + Doc.text + (if i.contents > 0 then "and type " + else "with type "); + Doc.text lbl; + Doc.text " = "; + printOutTypeDoc typ; + ]) + labels types) + in + Doc.indent (Doc.concat [ Doc.line; package ]) + in + Doc.concat + [ + Doc.text "module"; + Doc.lparen; + Doc.text modName; + packageTypeDoc; + Doc.rparen; + ] and printOutArrowType ~uncurried typ = let typArgs, typ = collectArrowArgs typ [] in let args = Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) (List.map (fun (lbl, typ) -> let lblLen = String.length lbl in @@ -304519,7 +304902,8 @@ and printOutArrowType ~uncurried typ = (* the ocaml compiler hardcodes the optional label inside the string of the label in printtyp.ml *) match String.unsafe_get lbl 0 with | '?' -> - ((String.sub [@doesNotRaise]) lbl 1 (lblLen - 1), Doc.text "=?") + ( (String.sub [@doesNotRaise]) lbl 1 (lblLen - 1), + Doc.text "=?" ) | _ -> (lbl, Doc.nil) in Doc.group @@ -304535,9 +304919,9 @@ and printOutArrowType ~uncurried typ = let needsParens = match typArgs with | _ when uncurried -> true - | [(_, (Otyp_tuple _ | Otyp_arrow _))] -> true + | [ (_, (Otyp_tuple _ | Otyp_arrow _)) ] -> true (* single argument should not be wrapped *) - | [("", _)] -> false + | [ ("", _) ] -> false | _ -> true in if needsParens then @@ -304545,70 +304929,72 @@ and printOutArrowType ~uncurried typ = (Doc.concat [ (if uncurried then Doc.text "(. " else Doc.lparen); - Doc.indent (Doc.concat [Doc.softLine; args]); + Doc.indent (Doc.concat [ Doc.softLine; args ]); Doc.trailingComma; Doc.softLine; Doc.rparen; ]) else args in - Doc.concat [argsDoc; Doc.text " => "; printOutTypeDoc typ] + Doc.concat [ argsDoc; Doc.text " => "; printOutTypeDoc typ ] and printOutVariant variant = match variant with | Ovar_fields fields -> - (* (string * bool * out_type list) list *) - Doc.join ~sep:Doc.line - ((* - * [< | #T([< u2]) & ([< u2]) & ([< u1])] --> no ampersand - * [< | #S & ([< u2]) & ([< u2]) & ([< u1])] --> ampersand - *) - List.mapi - (fun i (name, ampersand, types) -> - let needsParens = - match types with - | [Outcometree.Otyp_tuple _] -> false - | _ -> true - in - Doc.concat - [ - (if i > 0 then Doc.text "| " - else Doc.ifBreaks (Doc.text "| ") Doc.nil); - Doc.group - (Doc.concat - [ - Doc.text "#"; - printPolyVarIdent name; - (match types with - | [] -> Doc.nil - | types -> - Doc.concat - [ - (if ampersand then Doc.text " & " else Doc.nil); - Doc.indent - (Doc.concat - [ - Doc.join - ~sep:(Doc.concat [Doc.text " &"; Doc.line]) - (List.map - (fun typ -> - let outTypeDoc = - printOutTypeDoc typ - in - if needsParens then - Doc.concat - [ - Doc.lparen; - outTypeDoc; - Doc.rparen; - ] - else outTypeDoc) - types); - ]); - ]); - ]); - ]) - fields) + (* (string * bool * out_type list) list *) + Doc.join ~sep:Doc.line + ((* + * [< | #T([< u2]) & ([< u2]) & ([< u1])] --> no ampersand + * [< | #S & ([< u2]) & ([< u2]) & ([< u1])] --> ampersand + *) + List.mapi + (fun i (name, ampersand, types) -> + let needsParens = + match types with + | [ Outcometree.Otyp_tuple _ ] -> false + | _ -> true + in + Doc.concat + [ + (if i > 0 then Doc.text "| " + else Doc.ifBreaks (Doc.text "| ") Doc.nil); + Doc.group + (Doc.concat + [ + Doc.text "#"; + printPolyVarIdent name; + (match types with + | [] -> Doc.nil + | types -> + Doc.concat + [ + (if ampersand then Doc.text " & " else Doc.nil); + Doc.indent + (Doc.concat + [ + Doc.join + ~sep: + (Doc.concat + [ Doc.text " &"; Doc.line ]) + (List.map + (fun typ -> + let outTypeDoc = + printOutTypeDoc typ + in + if needsParens then + Doc.concat + [ + Doc.lparen; + outTypeDoc; + Doc.rparen; + ] + else outTypeDoc) + types); + ]); + ]); + ]); + ]) + fields) | Ovar_typ typ -> printOutTypeDoc typ and printObjectFields fields rest = @@ -304627,7 +305013,7 @@ and printObjectFields fields rest = [ Doc.softLine; Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) (List.map (fun (lbl, outType) -> Doc.group @@ -304664,44 +305050,44 @@ and printOutConstructorsDoc constructors = and printOutConstructorDoc (name, args, gadt) = let gadtDoc = match gadt with - | Some outType -> Doc.concat [Doc.text ": "; printOutTypeDoc outType] + | Some outType -> Doc.concat [ Doc.text ": "; printOutTypeDoc outType ] | None -> Doc.nil in let argsDoc = match args with | [] -> Doc.nil - | [Otyp_record record] -> - (* inline records - * | Root({ - * mutable value: 'value, - * mutable updatedTime: float, - * }) - *) - Doc.concat - [ - Doc.lparen; - Doc.indent (printRecordDeclarationDoc ~inline:true record); - Doc.rparen; - ] + | [ Otyp_record record ] -> + (* inline records + * | Root({ + * mutable value: 'value, + * mutable updatedTime: float, + * }) + *) + Doc.concat + [ + Doc.lparen; + Doc.indent (printRecordDeclarationDoc ~inline:true record); + Doc.rparen; + ] | _types -> - Doc.indent - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printOutTypeDoc args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) + Doc.indent + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map printOutTypeDoc args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) in - Doc.group (Doc.concat [Doc.text name; argsDoc; gadtDoc]) + Doc.group (Doc.concat [ Doc.text name; argsDoc; gadtDoc ]) and printRecordDeclRowDoc (name, mut, opt, arg) = Doc.group @@ -304724,7 +305110,7 @@ and printRecordDeclarationDoc ~inline rows = [ Doc.softLine; Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) (List.map printRecordDeclRowDoc rows); ]); Doc.trailingComma; @@ -304740,7 +305126,9 @@ let printOutType fmt outType = let printTypeParameterDoc (typ, (co, cn)) = Doc.concat [ - (if not cn then Doc.text "+" else if not co then Doc.text "-" else Doc.nil); + (if not cn then Doc.text "+" + else if not co then Doc.text "-" + else Doc.nil); (if typ = "_" then Doc.text "_" else Doc.text ("'" ^ typ)); ] @@ -304750,173 +305138,175 @@ let rec printOutSigItemDoc ?(printNameAsIs = false) | Osig_class _ | Osig_class_type _ -> Doc.nil | Osig_ellipsis -> Doc.dotdotdot | Osig_value valueDecl -> - Doc.group - (Doc.concat - [ - printOutAttributesDoc valueDecl.oval_attributes; - Doc.text + Doc.group + (Doc.concat + [ + printOutAttributesDoc valueDecl.oval_attributes; + Doc.text + (match valueDecl.oval_prims with + | [] -> "let " + | _ -> "external "); + Doc.text valueDecl.oval_name; + Doc.text ":"; + Doc.space; + printOutTypeDoc valueDecl.oval_type; (match valueDecl.oval_prims with - | [] -> "let " - | _ -> "external "); - Doc.text valueDecl.oval_name; - Doc.text ":"; - Doc.space; - printOutTypeDoc valueDecl.oval_type; - (match valueDecl.oval_prims with - | [] -> Doc.nil - | primitives -> - Doc.indent - (Doc.concat - [ - Doc.text " ="; - Doc.line; - Doc.group - (Doc.join ~sep:Doc.line - (List.map - (fun prim -> - let prim = - if - prim <> "" - && (prim.[0] [@doesNotRaise]) = '\132' - then "#rescript-external" - else prim - in - (* not display those garbage '\132' is a magic number for marshal *) - Doc.text ("\"" ^ prim ^ "\"")) - primitives)); - ])); - ]) + | [] -> Doc.nil + | primitives -> + Doc.indent + (Doc.concat + [ + Doc.text " ="; + Doc.line; + Doc.group + (Doc.join ~sep:Doc.line + (List.map + (fun prim -> + let prim = + if + prim <> "" + && (prim.[0] [@doesNotRaise]) = '\132' + then "#rescript-external" + else prim + in + (* not display those garbage '\132' is a magic number for marshal *) + Doc.text ("\"" ^ prim ^ "\"")) + primitives)); + ])); + ]) | Osig_typext (outExtensionConstructor, _outExtStatus) -> - printOutExtensionConstructorDoc outExtensionConstructor + printOutExtensionConstructorDoc outExtensionConstructor | Osig_modtype (modName, Omty_signature []) -> - Doc.concat [Doc.text "module type "; Doc.text modName] + Doc.concat [ Doc.text "module type "; Doc.text modName ] | Osig_modtype (modName, outModuleType) -> - Doc.group - (Doc.concat - [ - Doc.text "module type "; - Doc.text modName; - Doc.text " = "; - printOutModuleTypeDoc outModuleType; - ]) + Doc.group + (Doc.concat + [ + Doc.text "module type "; + Doc.text modName; + Doc.text " = "; + printOutModuleTypeDoc outModuleType; + ]) | Osig_module (modName, Omty_alias ident, _) -> - Doc.group - (Doc.concat - [ - Doc.text "module "; - Doc.text modName; - Doc.text " ="; - Doc.line; - printOutIdentDoc ident; - ]) + Doc.group + (Doc.concat + [ + Doc.text "module "; + Doc.text modName; + Doc.text " ="; + Doc.line; + printOutIdentDoc ident; + ]) | Osig_module (modName, outModType, outRecStatus) -> - Doc.group - (Doc.concat - [ - Doc.text - (match outRecStatus with - | Orec_not -> "module " - | Orec_first -> "module rec " - | Orec_next -> "and "); - Doc.text modName; - Doc.text ": "; - printOutModuleTypeDoc outModType; - ]) + Doc.group + (Doc.concat + [ + Doc.text + (match outRecStatus with + | Orec_not -> "module " + | Orec_first -> "module rec " + | Orec_next -> "and "); + Doc.text modName; + Doc.text ": "; + printOutModuleTypeDoc outModType; + ]) | Osig_type (outTypeDecl, outRecStatus) -> - (* TODO: manifest ? *) - let attrs = - match (outTypeDecl.otype_immediate, outTypeDecl.otype_unboxed) with - | false, false -> Doc.nil - | true, false -> Doc.concat [Doc.text "@immediate"; Doc.line] - | false, true -> Doc.concat [Doc.text "@unboxed"; Doc.line] - | true, true -> Doc.concat [Doc.text "@immediate @unboxed"; Doc.line] - in - let kw = - Doc.text - (match outRecStatus with - | Orec_not -> "type " - | Orec_first -> "type rec " - | Orec_next -> "and ") - in - let typeParams = - match outTypeDecl.otype_params with - | [] -> Doc.nil - | _params -> - Doc.group - (Doc.concat - [ - Doc.lessThan; - Doc.indent + (* TODO: manifest ? *) + let attrs = + match (outTypeDecl.otype_immediate, outTypeDecl.otype_unboxed) with + | false, false -> Doc.nil + | true, false -> Doc.concat [ Doc.text "@immediate"; Doc.line ] + | false, true -> Doc.concat [ Doc.text "@unboxed"; Doc.line ] + | true, true -> Doc.concat [ Doc.text "@immediate @unboxed"; Doc.line ] + in + let kw = + Doc.text + (match outRecStatus with + | Orec_not -> "type " + | Orec_first -> "type rec " + | Orec_next -> "and ") + in + let typeParams = + match outTypeDecl.otype_params with + | [] -> Doc.nil + | _params -> + Doc.group + (Doc.concat + [ + Doc.lessThan; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map printTypeParameterDoc + outTypeDecl.otype_params); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.greaterThan; + ]) + in + let privateDoc = + match outTypeDecl.otype_private with + | Asttypes.Private -> Doc.text "private " + | Public -> Doc.nil + in + let kind = + match outTypeDecl.otype_type with + | Otyp_open -> Doc.concat [ Doc.text " = "; privateDoc; Doc.text ".." ] + | Otyp_abstract -> Doc.nil + | Otyp_record record -> + Doc.concat + [ + Doc.text " = "; + privateDoc; + printRecordDeclarationDoc ~inline:false record; + ] + | typ -> Doc.concat [ Doc.text " = "; printOutTypeDoc typ ] + in + let constraints = + match outTypeDecl.otype_cstrs with + | [] -> Doc.nil + | _ -> + Doc.group + (Doc.indent (Doc.concat [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printTypeParameterDoc outTypeDecl.otype_params); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.greaterThan; - ]) - in - let privateDoc = - match outTypeDecl.otype_private with - | Asttypes.Private -> Doc.text "private " - | Public -> Doc.nil - in - let kind = - match outTypeDecl.otype_type with - | Otyp_open -> Doc.concat [Doc.text " = "; privateDoc; Doc.text ".."] - | Otyp_abstract -> Doc.nil - | Otyp_record record -> - Doc.concat - [ - Doc.text " = "; - privateDoc; - printRecordDeclarationDoc ~inline:false record; - ] - | typ -> Doc.concat [Doc.text " = "; printOutTypeDoc typ] - in - let constraints = - match outTypeDecl.otype_cstrs with - | [] -> Doc.nil - | _ -> - Doc.group - (Doc.indent - (Doc.concat - [ - Doc.hardLine; - Doc.join ~sep:Doc.line - (List.map - (fun (typ1, typ2) -> - Doc.group - (Doc.concat - [ - Doc.text "constraint "; - printOutTypeDoc typ1; - Doc.text " ="; - Doc.space; - printOutTypeDoc typ2; - ])) - outTypeDecl.otype_cstrs); - ])) - in - Doc.group - (Doc.concat - [ - attrs; - Doc.group - (Doc.concat - [ - attrs; - kw; - (if printNameAsIs then Doc.text outTypeDecl.otype_name - else printIdentLike ~allowUident:false outTypeDecl.otype_name); - typeParams; - kind; - ]); - constraints; - ]) + Doc.hardLine; + Doc.join ~sep:Doc.line + (List.map + (fun (typ1, typ2) -> + Doc.group + (Doc.concat + [ + Doc.text "constraint "; + printOutTypeDoc typ1; + Doc.text " ="; + Doc.space; + printOutTypeDoc typ2; + ])) + outTypeDecl.otype_cstrs); + ])) + in + Doc.group + (Doc.concat + [ + attrs; + Doc.group + (Doc.concat + [ + attrs; + kw; + (if printNameAsIs then Doc.text outTypeDecl.otype_name + else + printIdentLike ~allowUident:false outTypeDecl.otype_name); + typeParams; + kind; + ]); + constraints; + ]) and printOutModuleTypeDoc (outModType : Outcometree.out_module_type) = match outModType with @@ -304924,56 +305314,57 @@ and printOutModuleTypeDoc (outModType : Outcometree.out_module_type) = | Omty_ident ident -> printOutIdentDoc ident (* example: module Increment = (M: X_int) => X_int *) | Omty_functor _ -> - let args, returnModType = collectFunctorArgs outModType [] in - let argsDoc = - match args with - | [(_, None)] -> Doc.text "()" - | args -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun (lbl, optModType) -> - Doc.group - (Doc.concat - [ - Doc.text lbl; - (match optModType with - | None -> Doc.nil - | Some modType -> - Doc.concat - [ - Doc.text ": "; - printOutModuleTypeDoc modType; - ]); - ])) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) - in - Doc.group - (Doc.concat - [argsDoc; Doc.text " => "; printOutModuleTypeDoc returnModType]) + let args, returnModType = collectFunctorArgs outModType [] in + let argsDoc = + match args with + | [ (_, None) ] -> Doc.text "()" + | args -> + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun (lbl, optModType) -> + Doc.group + (Doc.concat + [ + Doc.text lbl; + (match optModType with + | None -> Doc.nil + | Some modType -> + Doc.concat + [ + Doc.text ": "; + printOutModuleTypeDoc modType; + ]); + ])) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) + in + Doc.group + (Doc.concat + [ argsDoc; Doc.text " => "; printOutModuleTypeDoc returnModType ]) | Omty_signature [] -> Doc.nil | Omty_signature signature -> - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.lbrace; - Doc.indent (Doc.concat [Doc.line; printOutSignatureDoc signature]); - Doc.softLine; - Doc.rbrace; - ]) + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat [ Doc.line; printOutSignatureDoc signature ]); + Doc.softLine; + Doc.rbrace; + ]) | Omty_alias _ident -> Doc.nil and printOutSignatureDoc (signature : Outcometree.out_sig_item list) = @@ -304981,36 +305372,36 @@ and printOutSignatureDoc (signature : Outcometree.out_sig_item list) = match signature with | [] -> List.rev acc | Outcometree.Osig_typext (ext, Oext_first) :: items -> - (* Gather together the extension constructors *) - let rec gather_extensions acc items = - match items with - | Outcometree.Osig_typext (ext, Oext_next) :: items -> + (* Gather together the extension constructors *) + let rec gather_extensions acc items = + match items with + | Outcometree.Osig_typext (ext, Oext_next) :: items -> + gather_extensions + ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc) + items + | _ -> (List.rev acc, items) + in + let exts, items = gather_extensions - ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc) + [ (ext.oext_name, ext.oext_args, ext.oext_ret_type) ] items - | _ -> (List.rev acc, items) - in - let exts, items = - gather_extensions - [(ext.oext_name, ext.oext_args, ext.oext_ret_type)] - items - in - let te = - { - Outcometree.otyext_name = ext.oext_type_name; - otyext_params = ext.oext_type_params; - otyext_constructors = exts; - otyext_private = ext.oext_private; - } - in - let doc = printOutTypeExtensionDoc te in - loop items (doc :: acc) + in + let te = + { + Outcometree.otyext_name = ext.oext_type_name; + otyext_params = ext.oext_type_params; + otyext_constructors = exts; + otyext_private = ext.oext_private; + } + in + let doc = printOutTypeExtensionDoc te in + loop items (doc :: acc) | item :: items -> - let doc = printOutSigItemDoc ~printNameAsIs:false item in - loop items (doc :: acc) + let doc = printOutSigItemDoc ~printNameAsIs:false item in + loop items (doc :: acc) in match loop signature [] with - | [doc] -> doc + | [ doc ] -> doc | docs -> Doc.breakableGroup ~forceBreak:true (Doc.join ~sep:Doc.line docs) and printOutExtensionConstructorDoc @@ -305019,24 +305410,24 @@ and printOutExtensionConstructorDoc match outExt.oext_type_params with | [] -> Doc.nil | params -> - Doc.group - (Doc.concat - [ - Doc.lessThan; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun ty -> - Doc.text (if ty = "_" then ty else "'" ^ ty)) - params); - ]); - Doc.softLine; - Doc.greaterThan; - ]) + Doc.group + (Doc.concat + [ + Doc.lessThan; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun ty -> + Doc.text (if ty = "_" then ty else "'" ^ ty)) + params); + ]); + Doc.softLine; + Doc.greaterThan; + ]) in Doc.group @@ -305058,24 +305449,24 @@ and printOutTypeExtensionDoc (typeExtension : Outcometree.out_type_extension) = match typeExtension.otyext_params with | [] -> Doc.nil | params -> - Doc.group - (Doc.concat - [ - Doc.lessThan; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun ty -> - Doc.text (if ty = "_" then ty else "'" ^ ty)) - params); - ]); - Doc.softLine; - Doc.greaterThan; - ]) + Doc.group + (Doc.concat + [ + Doc.lessThan; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun ty -> + Doc.text (if ty = "_" then ty else "'" ^ ty)) + params); + ]); + Doc.softLine; + Doc.greaterThan; + ]) in Doc.group @@ -305115,54 +305506,54 @@ let floatRepres f = | FP_nan -> "nan" | FP_infinite -> if f < 0.0 then "neg_infinity" else "infinity" | _ -> - let float_val = - let s1 = Printf.sprintf "%.12g" f in - if f = (float_of_string [@doesNotRaise]) s1 then s1 - else - let s2 = Printf.sprintf "%.15g" f in - if f = (float_of_string [@doesNotRaise]) s2 then s2 - else Printf.sprintf "%.18g" f - in - validFloatLexeme float_val + let float_val = + let s1 = Printf.sprintf "%.12g" f in + if f = (float_of_string [@doesNotRaise]) s1 then s1 + else + let s2 = Printf.sprintf "%.15g" f in + if f = (float_of_string [@doesNotRaise]) s2 then s2 + else Printf.sprintf "%.18g" f + in + validFloatLexeme float_val let rec printOutValueDoc (outValue : Outcometree.out_value) = match outValue with | Oval_array outValues -> - Doc.group - (Doc.concat - [ - Doc.lbracket; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printOutValueDoc outValues); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbracket; - ]) + Doc.group + (Doc.concat + [ + Doc.lbracket; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map printOutValueDoc outValues); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbracket; + ]) | Oval_char c -> Doc.text ("'" ^ Char.escaped c ^ "'") | Oval_constr (outIdent, outValues) -> - Doc.group - (Doc.concat - [ - printOutIdentDoc outIdent; - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printOutValueDoc outValues); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + printOutIdentDoc outIdent; + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map printOutValueDoc outValues); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) | Oval_ellipsis -> Doc.text "..." | Oval_int i -> Doc.text (Format.sprintf "%i" i) | Oval_int32 i -> Doc.text (Format.sprintf "%lil" i) @@ -305170,73 +305561,73 @@ let rec printOutValueDoc (outValue : Outcometree.out_value) = | Oval_nativeint i -> Doc.text (Format.sprintf "%nin" i) | Oval_float f -> Doc.text (floatRepres f) | Oval_list outValues -> - Doc.group - (Doc.concat - [ - Doc.text "list["; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printOutValueDoc outValues); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbracket; - ]) + Doc.group + (Doc.concat + [ + Doc.text "list["; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map printOutValueDoc outValues); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbracket; + ]) | Oval_printer fn -> - let fmt = Format.str_formatter in - fn fmt; - let str = Format.flush_str_formatter () in - Doc.text str + let fmt = Format.str_formatter in + fn fmt; + let str = Format.flush_str_formatter () in + Doc.text str | Oval_record rows -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun (outIdent, outValue) -> - Doc.group - (Doc.concat - [ - printOutIdentDoc outIdent; - Doc.text ": "; - printOutValueDoc outValue; - ])) - rows); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map + (fun (outIdent, outValue) -> + Doc.group + (Doc.concat + [ + printOutIdentDoc outIdent; + Doc.text ": "; + printOutValueDoc outValue; + ])) + rows); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) | Oval_string (txt, _sizeToPrint, _kind) -> - Doc.text (escapeStringContents txt) + Doc.text (escapeStringContents txt) | Oval_stuff txt -> Doc.text txt | Oval_tuple outValues -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printOutValueDoc outValues); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + (List.map printOutValueDoc outValues); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) (* Not supported by ReScript *) | Oval_variant _ -> Doc.nil @@ -305245,56 +305636,56 @@ let printOutExceptionDoc exc outValue = | Sys.Break -> Doc.text "Interrupted." | Out_of_memory -> Doc.text "Out of memory during evaluation." | Stack_overflow -> - Doc.text "Stack overflow during evaluation (looping recursion?)." + Doc.text "Stack overflow during evaluation (looping recursion?)." | _ -> - Doc.group - (Doc.indent - (Doc.concat - [Doc.text "Exception:"; Doc.line; printOutValueDoc outValue])) + Doc.group + (Doc.indent + (Doc.concat + [ Doc.text "Exception:"; Doc.line; printOutValueDoc outValue ])) let printOutPhraseSignature signature = let rec loop signature acc = match signature with | [] -> List.rev acc | (Outcometree.Osig_typext (ext, Oext_first), None) :: signature -> - (* Gather together extension constructors *) - let rec gather_extensions acc items = - match items with - | (Outcometree.Osig_typext (ext, Oext_next), None) :: items -> + (* Gather together extension constructors *) + let rec gather_extensions acc items = + match items with + | (Outcometree.Osig_typext (ext, Oext_next), None) :: items -> + gather_extensions + ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc) + items + | _ -> (List.rev acc, items) + in + let exts, signature = gather_extensions - ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc) - items - | _ -> (List.rev acc, items) - in - let exts, signature = - gather_extensions - [(ext.oext_name, ext.oext_args, ext.oext_ret_type)] - signature - in - let te = - { - Outcometree.otyext_name = ext.oext_type_name; - otyext_params = ext.oext_type_params; - otyext_constructors = exts; - otyext_private = ext.oext_private; - } - in - let doc = printOutTypeExtensionDoc te in - loop signature (doc :: acc) + [ (ext.oext_name, ext.oext_args, ext.oext_ret_type) ] + signature + in + let te = + { + Outcometree.otyext_name = ext.oext_type_name; + otyext_params = ext.oext_type_params; + otyext_constructors = exts; + otyext_private = ext.oext_private; + } + in + let doc = printOutTypeExtensionDoc te in + loop signature (doc :: acc) | (sigItem, optOutValue) :: signature -> - let doc = - match optOutValue with - | None -> printOutSigItemDoc sigItem - | Some outValue -> - Doc.group - (Doc.concat - [ - printOutSigItemDoc sigItem; - Doc.text " = "; - printOutValueDoc outValue; - ]) - in - loop signature (doc :: acc) + let doc = + match optOutValue with + | None -> printOutSigItemDoc sigItem + | Some outValue -> + Doc.group + (Doc.concat + [ + printOutSigItemDoc sigItem; + Doc.text " = "; + printOutValueDoc outValue; + ]) + in + loop signature (doc :: acc) in Doc.breakableGroup ~forceBreak:true (Doc.join ~sep:Doc.line (loop signature [])) @@ -305302,14 +305693,14 @@ let printOutPhraseSignature signature = let printOutPhraseDoc (outPhrase : Outcometree.out_phrase) = match outPhrase with | Ophr_eval (outValue, outType) -> - Doc.group - (Doc.concat - [ - Doc.text "- : "; - printOutTypeDoc outType; - Doc.text " ="; - Doc.indent (Doc.concat [Doc.line; printOutValueDoc outValue]); - ]) + Doc.group + (Doc.concat + [ + Doc.text "- : "; + printOutTypeDoc outType; + Doc.text " ="; + Doc.indent (Doc.concat [ Doc.line; printOutValueDoc outValue ]); + ]) | Ophr_signature [] -> Doc.nil | Ophr_signature signature -> printOutPhraseSignature signature | Ophr_exception (exc, outValue) -> printOutExceptionDoc exc outValue From a0b7944269110c2f3a07d62942e9e3e64620b238 Mon Sep 17 00:00:00 2001 From: butterunderflow Date: Sun, 30 Oct 2022 04:05:26 +0800 Subject: [PATCH 12/15] (re)use encodeCodepoint to support string_of_int_as_char --- jscomp/ext/ext_utf8.ml | 36 ++ jscomp/ext/ext_utf8.mli | 2 + jscomp/ext/ext_util.ml | 2 +- jscomp/ml/pprintast.ml | 2 +- jscomp/test/build.ninja | 3 +- jscomp/test/gpr_5753.js | 6 + jscomp/test/gpr_5753.res | 5 + jscomp/test/res_debug.js | 2 +- jscomp/test/string_unicode_test.js | 4 +- lib/4.06.1/rescript.ml | 179 +++++++++- lib/4.06.1/rescript.ml.d | 2 + lib/4.06.1/unstable/all_ounit_tests.ml | 318 ++++++++++-------- lib/4.06.1/unstable/js_compiler.ml | 318 ++++++++++-------- lib/4.06.1/unstable/js_playground_compiler.ml | 318 ++++++++++-------- lib/4.06.1/whole_compiler.ml | 40 ++- 15 files changed, 809 insertions(+), 428 deletions(-) create mode 100644 jscomp/test/gpr_5753.js create mode 100644 jscomp/test/gpr_5753.res diff --git a/jscomp/ext/ext_utf8.ml b/jscomp/ext/ext_utf8.ml index 281bfb7a0c..1eb4298fe8 100644 --- a/jscomp/ext/ext_utf8.ml +++ b/jscomp/ext/ext_utf8.ml @@ -92,3 +92,39 @@ let decode_utf8_string s = (* let verify s loc = assert false *) + +let encode_codepoint c = + let h2 = 0b1100_0000 in + let h3 = 0b1110_0000 in + let h4 = 0b1111_0000 in + let cont_mask = 0b0011_1111 in + if c <= 127 then ( + let bytes = (Bytes.create [@doesNotRaise]) 1 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr c); + Bytes.unsafe_to_string bytes) + else if c <= 2047 then ( + let bytes = (Bytes.create [@doesNotRaise]) 2 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h2 lor (c lsr 6))); + Bytes.unsafe_set bytes 1 + (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); + Bytes.unsafe_to_string bytes) + else if c <= 65535 then ( + let bytes = (Bytes.create [@doesNotRaise]) 3 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h3 lor (c lsr 12))); + Bytes.unsafe_set bytes 1 + (Char.unsafe_chr (0b1000_0000 lor ((c lsr 6) land cont_mask))); + Bytes.unsafe_set bytes 2 + (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); + Bytes.unsafe_to_string bytes) + else + (* if c <= max then *) + let bytes = (Bytes.create [@doesNotRaise]) 4 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h4 lor (c lsr 18))); + Bytes.unsafe_set bytes 1 + (Char.unsafe_chr (0b1000_0000 lor ((c lsr 12) land cont_mask))); + Bytes.unsafe_set bytes 2 + (Char.unsafe_chr (0b1000_0000 lor ((c lsr 6) land cont_mask))); + Bytes.unsafe_set bytes 3 + (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); + Bytes.unsafe_to_string bytes + diff --git a/jscomp/ext/ext_utf8.mli b/jscomp/ext/ext_utf8.mli index 2f29717c12..e1beadec59 100644 --- a/jscomp/ext/ext_utf8.mli +++ b/jscomp/ext/ext_utf8.mli @@ -36,3 +36,5 @@ val next : string -> remaining:int -> int -> int exception Invalid_utf8 of string val decode_utf8_string : string -> int list + +val encode_codepoint : int -> string diff --git a/jscomp/ext/ext_util.ml b/jscomp/ext/ext_util.ml index 41b29437aa..5e27465aec 100644 --- a/jscomp/ext/ext_util.ml +++ b/jscomp/ext/ext_util.ml @@ -46,4 +46,4 @@ let string_of_int_as_char i = then Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) else - Printf.sprintf "\'\\%d\'" i + Printf.sprintf "\'%s\'" (Ext_utf8.encode_codepoint i) diff --git a/jscomp/ml/pprintast.ml b/jscomp/ml/pprintast.ml index 37d549bb77..ff817615bb 100644 --- a/jscomp/ml/pprintast.ml +++ b/jscomp/ml/pprintast.ml @@ -192,7 +192,7 @@ let rec longident f = function let longident_loc f x = pp f "%a" longident x.txt -let string_of_int_as_char i = Ext_util.string_of_int_as_char i +let string_of_int_as_char i = Ext_utf8.encode_codepoint i let constant f = function | Pconst_char i -> pp f "%s" (string_of_int_as_char i) diff --git a/jscomp/test/build.ninja b/jscomp/test/build.ninja index 6bc981131e..62bddc9122 100644 --- a/jscomp/test/build.ninja +++ b/jscomp/test/build.ninja @@ -333,6 +333,7 @@ o test/gpr_5218_test.cmi test/gpr_5218_test.cmj : cc test/gpr_5218_test.res | te o test/gpr_5280_optimize_test.cmi test/gpr_5280_optimize_test.cmj : cc test/gpr_5280_optimize_test.ml | $bsc $stdlib runtime o test/gpr_5312.cmi test/gpr_5312.cmj : cc test/gpr_5312.res | $bsc $stdlib runtime o test/gpr_5557.cmi test/gpr_5557.cmj : cc test/gpr_5557.res | $bsc $stdlib runtime +o test/gpr_5753.cmi test/gpr_5753.cmj : cc test/gpr_5753.res | $bsc $stdlib runtime o test/gpr_627_test.cmi test/gpr_627_test.cmj : cc test/gpr_627_test.ml | test/mt.cmj $bsc $stdlib runtime o test/gpr_658.cmi test/gpr_658.cmj : cc test/gpr_658.ml | $bsc $stdlib runtime o test/gpr_858_test.cmi test/gpr_858_test.cmj : cc test/gpr_858_test.ml | $bsc $stdlib runtime @@ -735,4 +736,4 @@ o test/utf8_decode_test.cmi test/utf8_decode_test.cmj : cc test/utf8_decode_test o test/variant.cmi test/variant.cmj : cc test/variant.ml | $bsc $stdlib runtime o test/watch_test.cmi test/watch_test.cmj : cc test/watch_test.ml | $bsc $stdlib runtime o test/webpack_config.cmi test/webpack_config.cmj : cc test/webpack_config.ml | $bsc $stdlib runtime -o test : phony test/406_primitive_test.cmi test/406_primitive_test.cmj test/EmptyRecord.cmi test/EmptyRecord.cmj test/SafePromises.cmi test/SafePromises.cmj test/a.cmi test/a.cmj test/a_filename_test.cmi test/a_filename_test.cmj test/a_list_test.cmi test/a_list_test.cmj test/a_recursive_type.cmi test/a_recursive_type.cmj test/a_scope_bug.cmi test/a_scope_bug.cmj test/a_string_test.cmi test/a_string_test.cmj test/abstract_type.cmi test/abstract_type.cmj test/adt_optimize_test.cmi test/adt_optimize_test.cmj test/alias_test.cmi test/alias_test.cmj test/and_or_tailcall_test.cmi test/and_or_tailcall_test.cmj test/app_root_finder.cmi test/app_root_finder.cmj test/argv_test.cmi test/argv_test.cmj test/ari_regress_test.cmi test/ari_regress_test.cmj test/arith_lexer.cmi test/arith_lexer.cmj test/arith_parser.cmi test/arith_parser.cmj test/arith_syntax.cmi test/arith_syntax.cmj test/arity.cmi test/arity.cmj test/arity_deopt.cmi test/arity_deopt.cmj test/arity_infer.cmi test/arity_infer.cmj test/arity_ml.cmi test/arity_ml.cmj test/array_data_util.cmi test/array_data_util.cmj test/array_safe_get.cmi test/array_safe_get.cmj test/array_subtle_test.cmi test/array_subtle_test.cmj test/array_test.cmi test/array_test.cmj test/ast_abstract_test.cmi test/ast_abstract_test.cmj test/ast_js_mapper_poly_test.cmi test/ast_js_mapper_poly_test.cmj test/ast_js_mapper_test.cmi test/ast_js_mapper_test.cmj test/ast_mapper_defensive_test.cmi test/ast_mapper_defensive_test.cmj test/ast_mapper_unused_warning_test.cmi test/ast_mapper_unused_warning_test.cmj test/async_ideas.cmi test/async_ideas.cmj test/attr_test.cmi test/attr_test.cmj test/b.cmi test/b.cmj test/bal_set_mini.cmi test/bal_set_mini.cmj test/bang_primitive.cmi test/bang_primitive.cmj test/basic_module_test.cmi test/basic_module_test.cmj test/bb.cmi test/bb.cmj test/bdd.cmi test/bdd.cmj test/belt_internal_test.cmi test/belt_internal_test.cmj test/belt_result_alias_test.cmi test/belt_result_alias_test.cmj test/bench.cmi test/bench.cmj test/big_enum.cmi test/big_enum.cmj test/big_polyvar_test.cmi test/big_polyvar_test.cmj test/block_alias_test.cmi test/block_alias_test.cmj test/boolean_test.cmi test/boolean_test.cmj test/bs_MapInt_test.cmi test/bs_MapInt_test.cmj test/bs_abstract_test.cmi test/bs_abstract_test.cmj test/bs_array_test.cmi test/bs_array_test.cmj test/bs_auto_uncurry.cmi test/bs_auto_uncurry.cmj test/bs_auto_uncurry_test.cmi test/bs_auto_uncurry_test.cmj test/bs_float_test.cmi test/bs_float_test.cmj test/bs_hashmap_test.cmi test/bs_hashmap_test.cmj test/bs_hashset_int_test.cmi test/bs_hashset_int_test.cmj test/bs_hashtbl_string_test.cmi test/bs_hashtbl_string_test.cmj test/bs_ignore_effect.cmi test/bs_ignore_effect.cmj test/bs_ignore_test.cmi test/bs_ignore_test.cmj test/bs_int_test.cmi test/bs_int_test.cmj test/bs_list_test.cmi test/bs_list_test.cmj test/bs_map_set_dict_test.cmi test/bs_map_set_dict_test.cmj test/bs_map_test.cmi test/bs_map_test.cmj test/bs_min_max_test.cmi test/bs_min_max_test.cmj test/bs_mutable_set_test.cmi test/bs_mutable_set_test.cmj test/bs_node_string_buffer_test.cmi test/bs_node_string_buffer_test.cmj test/bs_poly_map_test.cmi test/bs_poly_map_test.cmj test/bs_poly_mutable_map_test.cmi test/bs_poly_mutable_map_test.cmj test/bs_poly_mutable_set_test.cmi test/bs_poly_mutable_set_test.cmj test/bs_poly_set_test.cmi test/bs_poly_set_test.cmj test/bs_qualified.cmi test/bs_qualified.cmj test/bs_queue_test.cmi test/bs_queue_test.cmj test/bs_rbset_int_bench.cmi test/bs_rbset_int_bench.cmj test/bs_rest_test.cmi test/bs_rest_test.cmj test/bs_set_bench.cmi test/bs_set_bench.cmj test/bs_set_int_test.cmi test/bs_set_int_test.cmj test/bs_sort_test.cmi test/bs_sort_test.cmj test/bs_splice_partial.cmi test/bs_splice_partial.cmj test/bs_stack_test.cmi test/bs_stack_test.cmj test/bs_string_test.cmi test/bs_string_test.cmj test/bs_unwrap_test.cmi test/bs_unwrap_test.cmj test/buffer_test.cmi test/buffer_test.cmj test/bytes_split_gpr_743_test.cmi test/bytes_split_gpr_743_test.cmj test/caml_compare_test.cmi test/caml_compare_test.cmj test/caml_format_test.cmi test/caml_format_test.cmj test/caml_sys_poly_fill_test.cmi test/caml_sys_poly_fill_test.cmj test/chain_code_test.cmi test/chain_code_test.cmj test/chn_test.cmi test/chn_test.cmj test/class_setter_getter.cmi test/class_setter_getter.cmj test/class_type_ffi_test.cmi test/class_type_ffi_test.cmj test/coercion_module_alias_test.cmi test/coercion_module_alias_test.cmj test/compare_test.cmi test/compare_test.cmj test/complete_parmatch_test.cmi test/complete_parmatch_test.cmj test/complex_if_test.cmi test/complex_if_test.cmj test/complex_test.cmi test/complex_test.cmj test/complex_while_loop.cmi test/complex_while_loop.cmj test/condition_compilation_test.cmi test/condition_compilation_test.cmj test/config1_test.cmi test/config1_test.cmj test/config2_test.cmi test/config2_test.cmj test/console_log_test.cmi test/console_log_test.cmj test/const_block_test.cmi test/const_block_test.cmj test/const_defs.cmi test/const_defs.cmj test/const_defs_test.cmi test/const_defs_test.cmj test/const_test.cmi test/const_test.cmj test/cont_int_fold_test.cmi test/cont_int_fold_test.cmj test/cps_test.cmi test/cps_test.cmj test/cross_module_inline_test.cmi test/cross_module_inline_test.cmj test/custom_error_test.cmi test/custom_error_test.cmj test/debug_keep_test.cmi test/debug_keep_test.cmj test/debug_mode_value.cmi test/debug_mode_value.cmj test/debug_tmp.cmi test/debug_tmp.cmj test/debugger_test.cmi test/debugger_test.cmj test/default_export_test.cmi test/default_export_test.cmj test/defunctor_make_test.cmi test/defunctor_make_test.cmj test/demo.cmi test/demo.cmj test/demo_binding.cmi test/demo_binding.cmj test/demo_int_map.cmi test/demo_int_map.cmj test/demo_page.cmi test/demo_page.cmj test/demo_pipe.cmi test/demo_pipe.cmj test/derive_dyntype.cmi test/derive_dyntype.cmj test/derive_projector_test.cmi test/derive_projector_test.cmj test/derive_type_test.cmi test/derive_type_test.cmj test/digest_test.cmi test/digest_test.cmj test/div_by_zero_test.cmi test/div_by_zero_test.cmj test/dollar_escape_test.cmi test/dollar_escape_test.cmj test/earger_curry_test.cmi test/earger_curry_test.cmj test/effect.cmi test/effect.cmj test/epsilon_test.cmi test/epsilon_test.cmj test/equal_box_test.cmi test/equal_box_test.cmj test/equal_exception_test.cmi test/equal_exception_test.cmj test/equal_test.cmi test/equal_test.cmj test/es6_export.cmi test/es6_export.cmj test/es6_import.cmi test/es6_import.cmj test/es6_module_test.cmi test/es6_module_test.cmj test/escape_esmodule.cmi test/escape_esmodule.cmj test/esmodule_ref.cmi test/esmodule_ref.cmj test/event_ffi.cmi test/event_ffi.cmj test/exception_alias.cmi test/exception_alias.cmj test/exception_def.cmi test/exception_def.cmj test/exception_raise_test.cmi test/exception_raise_test.cmj test/exception_rebind_test.cmi test/exception_rebind_test.cmj test/exception_rebound_err_test.cmi test/exception_rebound_err_test.cmj test/exception_repr_test.cmi test/exception_repr_test.cmj test/exception_value_test.cmi test/exception_value_test.cmj test/exn_error_pattern.cmi test/exn_error_pattern.cmj test/export_keyword.cmi test/export_keyword.cmj test/ext_array_test.cmi test/ext_array_test.cmj test/ext_bytes_test.cmi test/ext_bytes_test.cmj test/ext_filename_test.cmi test/ext_filename_test.cmj test/ext_list_test.cmi test/ext_list_test.cmj test/ext_pervasives_test.cmi test/ext_pervasives_test.cmj test/ext_string_test.cmi test/ext_string_test.cmj test/ext_sys_test.cmi test/ext_sys_test.cmj test/extensible_variant_test.cmi test/extensible_variant_test.cmj test/external_polyfill_test.cmi test/external_polyfill_test.cmj test/external_ppx.cmi test/external_ppx.cmj test/external_ppx2.cmi test/external_ppx2.cmj test/fail_comp.cmi test/fail_comp.cmj test/ffi_arity_test.cmi test/ffi_arity_test.cmj test/ffi_array_test.cmi test/ffi_array_test.cmj test/ffi_js_test.cmi test/ffi_js_test.cmj test/ffi_splice_test.cmi test/ffi_splice_test.cmj test/ffi_test.cmi test/ffi_test.cmj test/fib.cmi test/fib.cmj test/flattern_order_test.cmi test/flattern_order_test.cmj test/flexible_array_test.cmi test/flexible_array_test.cmj test/float_array.cmi test/float_array.cmj test/float_of_bits_test.cmi test/float_of_bits_test.cmj test/float_record.cmi test/float_record.cmj test/float_test.cmi test/float_test.cmj test/floatarray_test.cmi test/floatarray_test.cmj test/flow_parser_reg_test.cmi test/flow_parser_reg_test.cmj test/for_loop_test.cmi test/for_loop_test.cmj test/for_side_effect_test.cmi test/for_side_effect_test.cmj test/format_regression.cmi test/format_regression.cmj test/format_test.cmi test/format_test.cmj test/fs_test.cmi test/fs_test.cmj test/fun_pattern_match.cmi test/fun_pattern_match.cmj test/functor_app_test.cmi test/functor_app_test.cmj test/functor_def.cmi test/functor_def.cmj test/functor_ffi.cmi test/functor_ffi.cmj test/functor_inst.cmi test/functor_inst.cmj test/functors.cmi test/functors.cmj test/gbk.cmi test/gbk.cmj test/genlex_test.cmi test/genlex_test.cmj test/gentTypeReTest.cmi test/gentTypeReTest.cmj test/global_exception_regression_test.cmi test/global_exception_regression_test.cmj test/global_mangles.cmi test/global_mangles.cmj test/global_module_alias_test.cmi test/global_module_alias_test.cmj test/google_closure_test.cmi test/google_closure_test.cmj test/gpr496_test.cmi test/gpr496_test.cmj test/gpr_1063_test.cmi test/gpr_1063_test.cmj test/gpr_1072.cmi test/gpr_1072.cmj test/gpr_1072_reg.cmi test/gpr_1072_reg.cmj test/gpr_1150.cmi test/gpr_1150.cmj test/gpr_1154_test.cmi test/gpr_1154_test.cmj test/gpr_1170.cmi test/gpr_1170.cmj test/gpr_1240_missing_unbox.cmi test/gpr_1240_missing_unbox.cmj test/gpr_1245_test.cmi test/gpr_1245_test.cmj test/gpr_1268.cmi test/gpr_1268.cmj test/gpr_1409_test.cmi test/gpr_1409_test.cmj test/gpr_1423_app_test.cmi test/gpr_1423_app_test.cmj test/gpr_1423_nav.cmi test/gpr_1423_nav.cmj test/gpr_1438.cmi test/gpr_1438.cmj test/gpr_1481.cmi test/gpr_1481.cmj test/gpr_1484.cmi test/gpr_1484.cmj test/gpr_1501_test.cmi test/gpr_1501_test.cmj test/gpr_1503_test.cmi test/gpr_1503_test.cmj test/gpr_1539_test.cmi test/gpr_1539_test.cmj test/gpr_1600_test.cmi test/gpr_1600_test.cmj test/gpr_1658_test.cmi test/gpr_1658_test.cmj test/gpr_1667_test.cmi test/gpr_1667_test.cmj test/gpr_1692_test.cmi test/gpr_1692_test.cmj test/gpr_1698_test.cmi test/gpr_1698_test.cmj test/gpr_1701_test.cmi test/gpr_1701_test.cmj test/gpr_1716_test.cmi test/gpr_1716_test.cmj test/gpr_1717_test.cmi test/gpr_1717_test.cmj test/gpr_1728_test.cmi test/gpr_1728_test.cmj test/gpr_1749_test.cmi test/gpr_1749_test.cmj test/gpr_1759_test.cmi test/gpr_1759_test.cmj test/gpr_1760_test.cmi test/gpr_1760_test.cmj test/gpr_1762_test.cmi test/gpr_1762_test.cmj test/gpr_1817_test.cmi test/gpr_1817_test.cmj test/gpr_1822_test.cmi test/gpr_1822_test.cmj test/gpr_1891_test.cmi test/gpr_1891_test.cmj test/gpr_1943_test.cmi test/gpr_1943_test.cmj test/gpr_1946_test.cmi test/gpr_1946_test.cmj test/gpr_2316_test.cmi test/gpr_2316_test.cmj test/gpr_2352_test.cmi test/gpr_2352_test.cmj test/gpr_2413_test.cmi test/gpr_2413_test.cmj test/gpr_2474.cmi test/gpr_2474.cmj test/gpr_2487.cmi test/gpr_2487.cmj test/gpr_2503_test.cmi test/gpr_2503_test.cmj test/gpr_2608_test.cmi test/gpr_2608_test.cmj test/gpr_2614_test.cmi test/gpr_2614_test.cmj test/gpr_2633_test.cmi test/gpr_2633_test.cmj test/gpr_2642_test.cmi test/gpr_2642_test.cmj test/gpr_2652_test.cmi test/gpr_2652_test.cmj test/gpr_2682_test.cmi test/gpr_2682_test.cmj test/gpr_2700_test.cmi test/gpr_2700_test.cmj test/gpr_2731_test.cmi test/gpr_2731_test.cmj test/gpr_2789_test.cmi test/gpr_2789_test.cmj test/gpr_2931_test.cmi test/gpr_2931_test.cmj test/gpr_3142_test.cmi test/gpr_3142_test.cmj test/gpr_3154_test.cmi test/gpr_3154_test.cmj test/gpr_3209_test.cmi test/gpr_3209_test.cmj test/gpr_3492_test.cmi test/gpr_3492_test.cmj test/gpr_3519_jsx_test.cmi test/gpr_3519_jsx_test.cmj test/gpr_3519_test.cmi test/gpr_3519_test.cmj test/gpr_3536_test.cmi test/gpr_3536_test.cmj test/gpr_3546_test.cmi test/gpr_3546_test.cmj test/gpr_3548_test.cmi test/gpr_3548_test.cmj test/gpr_3549_test.cmi test/gpr_3549_test.cmj test/gpr_3566_drive_test.cmi test/gpr_3566_drive_test.cmj test/gpr_3566_test.cmi test/gpr_3566_test.cmj test/gpr_3595_test.cmi test/gpr_3595_test.cmj test/gpr_3609_test.cmi test/gpr_3609_test.cmj test/gpr_3697_test.cmi test/gpr_3697_test.cmj test/gpr_373_test.cmi test/gpr_373_test.cmj test/gpr_3770_test.cmi test/gpr_3770_test.cmj test/gpr_3852_alias.cmi test/gpr_3852_alias.cmj test/gpr_3852_alias_reify.cmi test/gpr_3852_alias_reify.cmj test/gpr_3852_effect.cmi test/gpr_3852_effect.cmj test/gpr_3865.cmi test/gpr_3865.cmj test/gpr_3865_bar.cmi test/gpr_3865_bar.cmj test/gpr_3865_foo.cmi test/gpr_3865_foo.cmj test/gpr_3875_test.cmi test/gpr_3875_test.cmj test/gpr_3877_test.cmi test/gpr_3877_test.cmj test/gpr_3895_test.cmi test/gpr_3895_test.cmj test/gpr_3897_test.cmi test/gpr_3897_test.cmj test/gpr_3931_test.cmi test/gpr_3931_test.cmj test/gpr_3980_test.cmi test/gpr_3980_test.cmj test/gpr_4025_test.cmi test/gpr_4025_test.cmj test/gpr_405_test.cmi test/gpr_405_test.cmj test/gpr_4069_test.cmi test/gpr_4069_test.cmj test/gpr_4265_test.cmi test/gpr_4265_test.cmj test/gpr_4274_test.cmi test/gpr_4274_test.cmj test/gpr_4280_test.cmi test/gpr_4280_test.cmj test/gpr_4407_test.cmi test/gpr_4407_test.cmj test/gpr_441.cmi test/gpr_441.cmj test/gpr_4442_test.cmi test/gpr_4442_test.cmj test/gpr_4491_test.cmi test/gpr_4491_test.cmj test/gpr_4494_test.cmi test/gpr_4494_test.cmj test/gpr_4519_test.cmi test/gpr_4519_test.cmj test/gpr_459_test.cmi test/gpr_459_test.cmj test/gpr_4632.cmi test/gpr_4632.cmj test/gpr_4639_test.cmi test/gpr_4639_test.cmj test/gpr_4900_test.cmi test/gpr_4900_test.cmj test/gpr_4924_test.cmi test/gpr_4924_test.cmj test/gpr_4931.cmi test/gpr_4931.cmj test/gpr_4931_allow.cmi test/gpr_4931_allow.cmj test/gpr_5071_test.cmi test/gpr_5071_test.cmj test/gpr_5169_test.cmi test/gpr_5169_test.cmj test/gpr_5218_test.cmi test/gpr_5218_test.cmj test/gpr_5280_optimize_test.cmi test/gpr_5280_optimize_test.cmj test/gpr_5312.cmi test/gpr_5312.cmj test/gpr_5557.cmi test/gpr_5557.cmj test/gpr_627_test.cmi test/gpr_627_test.cmj test/gpr_658.cmi test/gpr_658.cmj test/gpr_858_test.cmi test/gpr_858_test.cmj test/gpr_858_unit2_test.cmi test/gpr_858_unit2_test.cmj test/gpr_904_test.cmi test/gpr_904_test.cmj test/gpr_974_test.cmi test/gpr_974_test.cmj test/gpr_977_test.cmi test/gpr_977_test.cmj test/gpr_return_type_unused_attribute.cmi test/gpr_return_type_unused_attribute.cmj test/gray_code_test.cmi test/gray_code_test.cmj test/guide_for_ext.cmi test/guide_for_ext.cmj test/hamming_test.cmi test/hamming_test.cmj test/hash_collision_test.cmi test/hash_collision_test.cmj test/hash_sugar_desugar.cmi test/hash_sugar_desugar.cmj test/hash_test.cmi test/hash_test.cmj test/hashtbl_test.cmi test/hashtbl_test.cmj test/hello.foo.cmi test/hello.foo.cmj test/hello_res.cmi test/hello_res.cmj test/http_types.cmi test/http_types.cmj test/ignore_test.cmi test/ignore_test.cmj test/imm_map_bench.cmi test/imm_map_bench.cmj test/include_side_effect.cmi test/include_side_effect.cmj test/include_side_effect_free.cmi test/include_side_effect_free.cmj test/incomplete_toplevel_test.cmi test/incomplete_toplevel_test.cmj test/infer_type_test.cmi test/infer_type_test.cmj test/inline_const.cmi test/inline_const.cmj test/inline_const_test.cmi test/inline_const_test.cmj test/inline_edge_cases.cmi test/inline_edge_cases.cmj test/inline_map2_test.cmi test/inline_map2_test.cmj test/inline_map_demo.cmi test/inline_map_demo.cmj test/inline_map_test.cmi test/inline_map_test.cmj test/inline_record_test.cmi test/inline_record_test.cmj test/inline_regression_test.cmi test/inline_regression_test.cmj test/inline_string_test.cmi test/inline_string_test.cmj test/inner_call.cmi test/inner_call.cmj test/inner_define.cmi test/inner_define.cmj test/inner_unused.cmi test/inner_unused.cmj test/installation_test.cmi test/installation_test.cmj test/int32_test.cmi test/int32_test.cmj test/int64_mul_div_test.cmi test/int64_mul_div_test.cmj test/int64_string_bench.cmi test/int64_string_bench.cmj test/int64_string_test.cmi test/int64_string_test.cmj test/int64_test.cmi test/int64_test.cmj test/int_hashtbl_test.cmi test/int_hashtbl_test.cmj test/int_map.cmi test/int_map.cmj test/int_overflow_test.cmi test/int_overflow_test.cmj test/int_poly_var.cmi test/int_poly_var.cmj test/int_switch_test.cmi test/int_switch_test.cmj test/internal_unused_test.cmi test/internal_unused_test.cmj test/io_test.cmi test/io_test.cmj test/js_array_test.cmi test/js_array_test.cmj test/js_bool_test.cmi test/js_bool_test.cmj test/js_cast_test.cmi test/js_cast_test.cmj test/js_date_test.cmi test/js_date_test.cmj test/js_dict_test.cmi test/js_dict_test.cmj test/js_exception_catch_test.cmi test/js_exception_catch_test.cmj test/js_float_test.cmi test/js_float_test.cmj test/js_global_test.cmi test/js_global_test.cmj test/js_int_test.cmi test/js_int_test.cmj test/js_json_test.cmi test/js_json_test.cmj test/js_list_test.cmi test/js_list_test.cmj test/js_math_test.cmi test/js_math_test.cmj test/js_null_test.cmi test/js_null_test.cmj test/js_null_undefined_test.cmi test/js_null_undefined_test.cmj test/js_nullable_test.cmi test/js_nullable_test.cmj test/js_obj_test.cmi test/js_obj_test.cmj test/js_option_test.cmi test/js_option_test.cmj test/js_promise_basic_test.cmi test/js_promise_basic_test.cmj test/js_re_test.cmi test/js_re_test.cmj test/js_string_test.cmi test/js_string_test.cmj test/js_typed_array_test.cmi test/js_typed_array_test.cmj test/js_undefined_test.cmi test/js_undefined_test.cmj test/js_val.cmi test/js_val.cmj test/jsoo_400_test.cmi test/jsoo_400_test.cmj test/jsoo_485_test.cmi test/jsoo_485_test.cmj test/key_word_property.cmi test/key_word_property.cmj test/key_word_property2.cmi test/key_word_property2.cmj test/key_word_property_plus_test.cmi test/key_word_property_plus_test.cmj test/label_uncurry.cmi test/label_uncurry.cmj test/large_integer_pat.cmi test/large_integer_pat.cmj test/large_record_duplication_test.cmi test/large_record_duplication_test.cmj test/largest_int_flow.cmi test/largest_int_flow.cmj test/lazy_demo.cmi test/lazy_demo.cmj test/lazy_test.cmi test/lazy_test.cmj test/lexer_test.cmi test/lexer_test.cmj test/lib_js_test.cmi test/lib_js_test.cmj test/libarg_test.cmi test/libarg_test.cmj test/libqueue_test.cmi test/libqueue_test.cmj test/limits_test.cmi test/limits_test.cmj test/list_stack.cmi test/list_stack.cmj test/list_test.cmi test/list_test.cmj test/local_class_type.cmi test/local_class_type.cmj test/local_exception_test.cmi test/local_exception_test.cmj test/loop_regression_test.cmi test/loop_regression_test.cmj test/loop_suites_test.cmi test/loop_suites_test.cmj test/map_find_test.cmi test/map_find_test.cmj test/map_test.cmi test/map_test.cmj test/mario_game.cmi test/mario_game.cmj test/marshal.cmi test/marshal.cmj test/method_chain.cmi test/method_chain.cmj test/method_name_test.cmi test/method_name_test.cmj test/method_string_name.cmi test/method_string_name.cmj test/minimal_test.cmi test/minimal_test.cmj test/miss_colon_test.cmi test/miss_colon_test.cmj test/mock_mt.cmi test/mock_mt.cmj test/module_alias_test.cmi test/module_alias_test.cmj test/module_as_class_ffi.cmi test/module_as_class_ffi.cmj test/module_as_function.cmi test/module_as_function.cmj test/module_missing_conversion.cmi test/module_missing_conversion.cmj test/module_parameter_test.cmi test/module_parameter_test.cmj test/module_splice_test.cmi test/module_splice_test.cmj test/more_poly_variant_test.cmi test/more_poly_variant_test.cmj test/more_uncurry.cmi test/more_uncurry.cmj test/mpr_6033_test.cmi test/mpr_6033_test.cmj test/mt.cmi test/mt.cmj test/mt_global.cmi test/mt_global.cmj test/mutable_obj_test.cmi test/mutable_obj_test.cmj test/mutable_uncurry_test.cmi test/mutable_uncurry_test.cmj test/mutual_non_recursive_type.cmi test/mutual_non_recursive_type.cmj test/name_mangle_test.cmi test/name_mangle_test.cmj test/nested_include.cmi test/nested_include.cmj test/nested_module_alias.cmi test/nested_module_alias.cmj test/nested_obj_literal.cmi test/nested_obj_literal.cmj test/nested_obj_test.cmi test/nested_obj_test.cmj test/nested_pattern_match_test.cmi test/nested_pattern_match_test.cmj test/noassert.cmi test/noassert.cmj test/node_fs_test.cmi test/node_fs_test.cmj test/node_path_test.cmi test/node_path_test.cmj test/null_list_test.cmi test/null_list_test.cmj test/number_lexer.cmi test/number_lexer.cmj test/obj_literal_ppx.cmi test/obj_literal_ppx.cmj test/obj_literal_ppx_test.cmi test/obj_literal_ppx_test.cmj test/obj_magic_test.cmi test/obj_magic_test.cmj test/obj_type_test.cmi test/obj_type_test.cmj test/ocaml_re_test.cmi test/ocaml_re_test.cmj test/of_string_test.cmi test/of_string_test.cmj test/offset.cmi test/offset.cmj test/oo_js_test_date.cmi test/oo_js_test_date.cmj test/option_encoding_test.cmi test/option_encoding_test.cmj test/option_record_none_test.cmi test/option_record_none_test.cmj test/option_repr_test.cmi test/option_repr_test.cmj test/optional_ffi_test.cmi test/optional_ffi_test.cmj test/optional_regression_test.cmi test/optional_regression_test.cmj test/pipe_send_readline.cmi test/pipe_send_readline.cmj test/pipe_syntax.cmi test/pipe_syntax.cmj test/poly_empty_array.cmi test/poly_empty_array.cmj test/poly_type.cmi test/poly_type.cmj test/poly_variant_test.cmi test/poly_variant_test.cmj test/polymorphic_raw_test.cmi test/polymorphic_raw_test.cmj test/polymorphism_test.cmi test/polymorphism_test.cmj test/polyvar_convert.cmi test/polyvar_convert.cmj test/polyvar_test.cmi test/polyvar_test.cmj test/ppx_apply_test.cmi test/ppx_apply_test.cmj test/ppx_this_obj_field.cmi test/ppx_this_obj_field.cmj test/ppx_this_obj_test.cmi test/ppx_this_obj_test.cmj test/pq_test.cmi test/pq_test.cmj test/pr6726.cmi test/pr6726.cmj test/pr_regression_test.cmi test/pr_regression_test.cmj test/prepend_data_ffi.cmi test/prepend_data_ffi.cmj test/primitive_reg_test.cmi test/primitive_reg_test.cmj test/print_alpha_test.cmi test/print_alpha_test.cmj test/promise.cmi test/promise.cmj test/promise_catch_test.cmi test/promise_catch_test.cmj test/queue_402.cmi test/queue_402.cmj test/queue_test.cmi test/queue_test.cmj test/random_test.cmi test/random_test.cmj test/raw_hash_tbl_bench.cmi test/raw_hash_tbl_bench.cmj test/raw_output_test.cmi test/raw_output_test.cmj test/raw_pure_test.cmi test/raw_pure_test.cmj test/rbset.cmi test/rbset.cmj test/react.cmi test/react.cmj test/reactDOMRe.cmi test/reactDOMRe.cmj test/reactDOMServerRe.cmi test/reactDOMServerRe.cmj test/reactEvent.cmi test/reactEvent.cmj test/reactTestUtils.cmi test/reactTestUtils.cmj test/reasonReact.cmi test/reasonReact.cmj test/reasonReactCompat.cmi test/reasonReactCompat.cmj test/reasonReactOptimizedCreateClass.cmi test/reasonReactOptimizedCreateClass.cmj test/reasonReactRouter.cmi test/reasonReactRouter.cmj test/rebind_module.cmi test/rebind_module.cmj test/rebind_module_test.cmi test/rebind_module_test.cmj test/rec_array_test.cmi test/rec_array_test.cmj test/rec_fun_test.cmi test/rec_fun_test.cmj test/rec_module_opt.cmi test/rec_module_opt.cmj test/rec_module_test.cmi test/rec_module_test.cmj test/rec_value_test.cmi test/rec_value_test.cmj test/record_debug_test.cmi test/record_debug_test.cmj test/record_extension_test.cmi test/record_extension_test.cmj test/record_name_test.cmi test/record_name_test.cmj test/record_regression.cmi test/record_regression.cmj test/record_with_test.cmi test/record_with_test.cmj test/recursive_module.cmi test/recursive_module.cmj test/recursive_module_test.cmi test/recursive_module_test.cmj test/recursive_react_component.cmi test/recursive_react_component.cmj test/recursive_records_test.cmi test/recursive_records_test.cmj test/recursive_unbound_module_test.cmi test/recursive_unbound_module_test.cmj test/regression_print.cmi test/regression_print.cmj test/relative_path.cmi test/relative_path.cmj test/res_debug.cmi test/res_debug.cmj test/return_check.cmi test/return_check.cmj test/runtime_encoding_test.cmi test/runtime_encoding_test.cmj test/set_gen.cmi test/set_gen.cmj test/sexp.cmi test/sexp.cmj test/sexpm.cmi test/sexpm.cmj test/sexpm_test.cmi test/sexpm_test.cmj test/side_effect.cmi test/side_effect.cmj test/side_effect_free.cmi test/side_effect_free.cmj test/simple_derive_test.cmi test/simple_derive_test.cmj test/simple_derive_use.cmi test/simple_derive_use.cmj test/simple_lexer_test.cmi test/simple_lexer_test.cmj test/simplify_lambda_632o.cmi test/simplify_lambda_632o.cmj test/single_module_alias.cmi test/single_module_alias.cmj test/singular_unit_test.cmi test/singular_unit_test.cmj test/small_inline_test.cmi test/small_inline_test.cmj test/splice_test.cmi test/splice_test.cmj test/stack_comp_test.cmi test/stack_comp_test.cmj test/stack_test.cmi test/stack_test.cmj test/stream_parser_test.cmi test/stream_parser_test.cmj test/string_bound_get_test.cmi test/string_bound_get_test.cmj test/string_get_set_test.cmi test/string_get_set_test.cmj test/string_interp_test.cmi test/string_interp_test.cmj test/string_literal_print_test.cmi test/string_literal_print_test.cmj test/string_runtime_test.cmi test/string_runtime_test.cmj test/string_set.cmi test/string_set.cmj test/string_set_test.cmi test/string_set_test.cmj test/string_test.cmi test/string_test.cmj test/string_unicode_test.cmi test/string_unicode_test.cmj test/stringmatch_test.cmi test/stringmatch_test.cmj test/submodule.cmi test/submodule.cmj test/submodule_call.cmi test/submodule_call.cmj test/switch_case_test.cmi test/switch_case_test.cmj test/tailcall_inline_test.cmi test/tailcall_inline_test.cmj test/template.cmi test/template.cmj test/test.cmi test/test.cmj test/test2.cmi test/test2.cmj test/test_alias.cmi test/test_alias.cmj test/test_ari.cmi test/test_ari.cmj test/test_array.cmi test/test_array.cmj test/test_array_append.cmi test/test_array_append.cmj test/test_array_primitive.cmi test/test_array_primitive.cmj test/test_bool_equal.cmi test/test_bool_equal.cmj test/test_bs_this.cmi test/test_bs_this.cmj test/test_bug.cmi test/test_bug.cmj test/test_bytes.cmi test/test_bytes.cmj test/test_case_opt_collision.cmi test/test_case_opt_collision.cmj test/test_case_set.cmi test/test_case_set.cmj test/test_char.cmi test/test_char.cmj test/test_closure.cmi test/test_closure.cmj test/test_common.cmi test/test_common.cmj test/test_const_elim.cmi test/test_const_elim.cmj test/test_const_propogate.cmi test/test_const_propogate.cmj test/test_cpp.cmi test/test_cpp.cmj test/test_cps.cmi test/test_cps.cmj test/test_demo.cmi test/test_demo.cmj test/test_dup_param.cmi test/test_dup_param.cmj test/test_eq.cmi test/test_eq.cmj test/test_exception.cmi test/test_exception.cmj test/test_exception_escape.cmi test/test_exception_escape.cmj test/test_export2.cmi test/test_export2.cmj test/test_external.cmi test/test_external.cmj test/test_external_unit.cmi test/test_external_unit.cmj test/test_ffi.cmi test/test_ffi.cmj test/test_fib.cmi test/test_fib.cmj test/test_filename.cmi test/test_filename.cmj test/test_for_loop.cmi test/test_for_loop.cmj test/test_for_map.cmi test/test_for_map.cmj test/test_for_map2.cmi test/test_for_map2.cmj test/test_format.cmi test/test_format.cmj test/test_formatter.cmi test/test_formatter.cmj test/test_functor_dead_code.cmi test/test_functor_dead_code.cmj test/test_generative_module.cmi test/test_generative_module.cmj test/test_global_print.cmi test/test_global_print.cmj test/test_google_closure.cmi test/test_google_closure.cmj test/test_http_server.cmi test/test_http_server.cmj test/test_include.cmi test/test_include.cmj test/test_incomplete.cmi test/test_incomplete.cmj test/test_incr_ref.cmi test/test_incr_ref.cmj test/test_index.cmi test/test_index.cmj test/test_int_map_find.cmi test/test_int_map_find.cmj test/test_internalOO.cmi test/test_internalOO.cmj test/test_is_js.cmi test/test_is_js.cmj test/test_js_ffi.cmi test/test_js_ffi.cmj test/test_let.cmi test/test_let.cmj test/test_list.cmi test/test_list.cmj test/test_literal.cmi test/test_literal.cmj test/test_literals.cmi test/test_literals.cmj test/test_match_exception.cmi test/test_match_exception.cmj test/test_mutliple.cmi test/test_mutliple.cmj test/test_nat64.cmi test/test_nat64.cmj test/test_nested_let.cmi test/test_nested_let.cmj test/test_nested_print.cmi test/test_nested_print.cmj test/test_non_export.cmi test/test_non_export.cmj test/test_nullary.cmi test/test_nullary.cmj test/test_obj.cmi test/test_obj.cmj test/test_obj_simple_ffi.cmi test/test_obj_simple_ffi.cmj test/test_order.cmi test/test_order.cmj test/test_order_tailcall.cmi test/test_order_tailcall.cmj test/test_other_exn.cmi test/test_other_exn.cmj test/test_pack.cmi test/test_pack.cmj test/test_per.cmi test/test_per.cmj test/test_pervasive.cmi test/test_pervasive.cmj test/test_pervasives2.cmi test/test_pervasives2.cmj test/test_pervasives3.cmi test/test_pervasives3.cmj test/test_primitive.cmi test/test_primitive.cmj test/test_promise_bind.cmi test/test_promise_bind.cmj test/test_ramification.cmi test/test_ramification.cmj test/test_react.cmi test/test_react.cmj test/test_react_case.cmi test/test_react_case.cmj test/test_regex.cmi test/test_regex.cmj test/test_require.cmi test/test_require.cmj test/test_runtime_encoding.cmi test/test_runtime_encoding.cmj test/test_scope.cmi test/test_scope.cmj test/test_seq.cmi test/test_seq.cmj test/test_set.cmi test/test_set.cmj test/test_side_effect_functor.cmi test/test_side_effect_functor.cmj test/test_simple_include.cmi test/test_simple_include.cmj test/test_simple_pattern_match.cmi test/test_simple_pattern_match.cmj test/test_simple_ref.cmi test/test_simple_ref.cmj test/test_simple_tailcall.cmi test/test_simple_tailcall.cmj test/test_small.cmi test/test_small.cmj test/test_sprintf.cmi test/test_sprintf.cmj test/test_stack.cmi test/test_stack.cmj test/test_static_catch_ident.cmi test/test_static_catch_ident.cmj test/test_string.cmi test/test_string.cmj test/test_string_case.cmi test/test_string_case.cmj test/test_string_const.cmi test/test_string_const.cmj test/test_string_map.cmi test/test_string_map.cmj test/test_string_switch.cmi test/test_string_switch.cmj test/test_switch.cmi test/test_switch.cmj test/test_trywith.cmi test/test_trywith.cmj test/test_tuple.cmi test/test_tuple.cmj test/test_tuple_destructring.cmi test/test_tuple_destructring.cmj test/test_type_based_arity.cmi test/test_type_based_arity.cmj test/test_u.cmi test/test_u.cmj test/test_unknown.cmi test/test_unknown.cmj test/test_unsafe_cmp.cmi test/test_unsafe_cmp.cmj test/test_unsafe_obj_ffi.cmi test/test_unsafe_obj_ffi.cmj test/test_unsafe_obj_ffi_ppx.cmi test/test_unsafe_obj_ffi_ppx.cmj test/test_unsupported_primitive.cmi test/test_unsupported_primitive.cmj test/test_while_closure.cmi test/test_while_closure.cmj test/test_while_side_effect.cmi test/test_while_side_effect.cmj test/test_zero_nullable.cmi test/test_zero_nullable.cmj test/then_mangle_test.cmi test/then_mangle_test.cmj test/ticker.cmi test/ticker.cmj test/to_string_test.cmi test/to_string_test.cmj test/topsort_test.cmi test/topsort_test.cmj test/tramp_fib.cmi test/tramp_fib.cmj test/tuple_alloc.cmi test/tuple_alloc.cmj test/type_disambiguate.cmi test/type_disambiguate.cmj test/typeof_test.cmi test/typeof_test.cmj test/ui_defs.cmi test/unboxed_attribute.cmi test/unboxed_attribute.cmj test/unboxed_attribute_test.cmi test/unboxed_attribute_test.cmj test/unboxed_crash.cmi test/unboxed_crash.cmj test/unboxed_use_case.cmi test/unboxed_use_case.cmj test/uncurry_external_test.cmi test/uncurry_external_test.cmj test/uncurry_glob_test.cmi test/uncurry_glob_test.cmj test/uncurry_method.cmi test/uncurry_method.cmj test/uncurry_test.cmi test/uncurry_test.cmj test/undef_regression2_test.cmi test/undef_regression2_test.cmj test/undef_regression_test.cmi test/undef_regression_test.cmj test/undefine_conditional.cmi test/undefine_conditional.cmj test/unicode_type_error.cmi test/unicode_type_error.cmj test/unit_undefined_test.cmi test/unit_undefined_test.cmj test/unitest_string.cmi test/unitest_string.cmj test/unsafe_full_apply_primitive.cmi test/unsafe_full_apply_primitive.cmj test/unsafe_obj_external.cmi test/unsafe_obj_external.cmj test/unsafe_ppx_test.cmi test/unsafe_ppx_test.cmj test/unsafe_this.cmi test/unsafe_this.cmj test/update_record_test.cmi test/update_record_test.cmj test/utf8_decode_test.cmi test/utf8_decode_test.cmj test/variant.cmi test/variant.cmj test/watch_test.cmi test/watch_test.cmj test/webpack_config.cmi test/webpack_config.cmj +o test : phony test/406_primitive_test.cmi test/406_primitive_test.cmj test/EmptyRecord.cmi test/EmptyRecord.cmj test/SafePromises.cmi test/SafePromises.cmj test/a.cmi test/a.cmj test/a_filename_test.cmi test/a_filename_test.cmj test/a_list_test.cmi test/a_list_test.cmj test/a_recursive_type.cmi test/a_recursive_type.cmj test/a_scope_bug.cmi test/a_scope_bug.cmj test/a_string_test.cmi test/a_string_test.cmj test/abstract_type.cmi test/abstract_type.cmj test/adt_optimize_test.cmi test/adt_optimize_test.cmj test/alias_test.cmi test/alias_test.cmj test/and_or_tailcall_test.cmi test/and_or_tailcall_test.cmj test/app_root_finder.cmi test/app_root_finder.cmj test/argv_test.cmi test/argv_test.cmj test/ari_regress_test.cmi test/ari_regress_test.cmj test/arith_lexer.cmi test/arith_lexer.cmj test/arith_parser.cmi test/arith_parser.cmj test/arith_syntax.cmi test/arith_syntax.cmj test/arity.cmi test/arity.cmj test/arity_deopt.cmi test/arity_deopt.cmj test/arity_infer.cmi test/arity_infer.cmj test/arity_ml.cmi test/arity_ml.cmj test/array_data_util.cmi test/array_data_util.cmj test/array_safe_get.cmi test/array_safe_get.cmj test/array_subtle_test.cmi test/array_subtle_test.cmj test/array_test.cmi test/array_test.cmj test/ast_abstract_test.cmi test/ast_abstract_test.cmj test/ast_js_mapper_poly_test.cmi test/ast_js_mapper_poly_test.cmj test/ast_js_mapper_test.cmi test/ast_js_mapper_test.cmj test/ast_mapper_defensive_test.cmi test/ast_mapper_defensive_test.cmj test/ast_mapper_unused_warning_test.cmi test/ast_mapper_unused_warning_test.cmj test/async_ideas.cmi test/async_ideas.cmj test/attr_test.cmi test/attr_test.cmj test/b.cmi test/b.cmj test/bal_set_mini.cmi test/bal_set_mini.cmj test/bang_primitive.cmi test/bang_primitive.cmj test/basic_module_test.cmi test/basic_module_test.cmj test/bb.cmi test/bb.cmj test/bdd.cmi test/bdd.cmj test/belt_internal_test.cmi test/belt_internal_test.cmj test/belt_result_alias_test.cmi test/belt_result_alias_test.cmj test/bench.cmi test/bench.cmj test/big_enum.cmi test/big_enum.cmj test/big_polyvar_test.cmi test/big_polyvar_test.cmj test/block_alias_test.cmi test/block_alias_test.cmj test/boolean_test.cmi test/boolean_test.cmj test/bs_MapInt_test.cmi test/bs_MapInt_test.cmj test/bs_abstract_test.cmi test/bs_abstract_test.cmj test/bs_array_test.cmi test/bs_array_test.cmj test/bs_auto_uncurry.cmi test/bs_auto_uncurry.cmj test/bs_auto_uncurry_test.cmi test/bs_auto_uncurry_test.cmj test/bs_float_test.cmi test/bs_float_test.cmj test/bs_hashmap_test.cmi test/bs_hashmap_test.cmj test/bs_hashset_int_test.cmi test/bs_hashset_int_test.cmj test/bs_hashtbl_string_test.cmi test/bs_hashtbl_string_test.cmj test/bs_ignore_effect.cmi test/bs_ignore_effect.cmj test/bs_ignore_test.cmi test/bs_ignore_test.cmj test/bs_int_test.cmi test/bs_int_test.cmj test/bs_list_test.cmi test/bs_list_test.cmj test/bs_map_set_dict_test.cmi test/bs_map_set_dict_test.cmj test/bs_map_test.cmi test/bs_map_test.cmj test/bs_min_max_test.cmi test/bs_min_max_test.cmj test/bs_mutable_set_test.cmi test/bs_mutable_set_test.cmj test/bs_node_string_buffer_test.cmi test/bs_node_string_buffer_test.cmj test/bs_poly_map_test.cmi test/bs_poly_map_test.cmj test/bs_poly_mutable_map_test.cmi test/bs_poly_mutable_map_test.cmj test/bs_poly_mutable_set_test.cmi test/bs_poly_mutable_set_test.cmj test/bs_poly_set_test.cmi test/bs_poly_set_test.cmj test/bs_qualified.cmi test/bs_qualified.cmj test/bs_queue_test.cmi test/bs_queue_test.cmj test/bs_rbset_int_bench.cmi test/bs_rbset_int_bench.cmj test/bs_rest_test.cmi test/bs_rest_test.cmj test/bs_set_bench.cmi test/bs_set_bench.cmj test/bs_set_int_test.cmi test/bs_set_int_test.cmj test/bs_sort_test.cmi test/bs_sort_test.cmj test/bs_splice_partial.cmi test/bs_splice_partial.cmj test/bs_stack_test.cmi test/bs_stack_test.cmj test/bs_string_test.cmi test/bs_string_test.cmj test/bs_unwrap_test.cmi test/bs_unwrap_test.cmj test/buffer_test.cmi test/buffer_test.cmj test/bytes_split_gpr_743_test.cmi test/bytes_split_gpr_743_test.cmj test/caml_compare_test.cmi test/caml_compare_test.cmj test/caml_format_test.cmi test/caml_format_test.cmj test/caml_sys_poly_fill_test.cmi test/caml_sys_poly_fill_test.cmj test/chain_code_test.cmi test/chain_code_test.cmj test/chn_test.cmi test/chn_test.cmj test/class_setter_getter.cmi test/class_setter_getter.cmj test/class_type_ffi_test.cmi test/class_type_ffi_test.cmj test/coercion_module_alias_test.cmi test/coercion_module_alias_test.cmj test/compare_test.cmi test/compare_test.cmj test/complete_parmatch_test.cmi test/complete_parmatch_test.cmj test/complex_if_test.cmi test/complex_if_test.cmj test/complex_test.cmi test/complex_test.cmj test/complex_while_loop.cmi test/complex_while_loop.cmj test/condition_compilation_test.cmi test/condition_compilation_test.cmj test/config1_test.cmi test/config1_test.cmj test/config2_test.cmi test/config2_test.cmj test/console_log_test.cmi test/console_log_test.cmj test/const_block_test.cmi test/const_block_test.cmj test/const_defs.cmi test/const_defs.cmj test/const_defs_test.cmi test/const_defs_test.cmj test/const_test.cmi test/const_test.cmj test/cont_int_fold_test.cmi test/cont_int_fold_test.cmj test/cps_test.cmi test/cps_test.cmj test/cross_module_inline_test.cmi test/cross_module_inline_test.cmj test/custom_error_test.cmi test/custom_error_test.cmj test/debug_keep_test.cmi test/debug_keep_test.cmj test/debug_mode_value.cmi test/debug_mode_value.cmj test/debug_tmp.cmi test/debug_tmp.cmj test/debugger_test.cmi test/debugger_test.cmj test/default_export_test.cmi test/default_export_test.cmj test/defunctor_make_test.cmi test/defunctor_make_test.cmj test/demo.cmi test/demo.cmj test/demo_binding.cmi test/demo_binding.cmj test/demo_int_map.cmi test/demo_int_map.cmj test/demo_page.cmi test/demo_page.cmj test/demo_pipe.cmi test/demo_pipe.cmj test/derive_dyntype.cmi test/derive_dyntype.cmj test/derive_projector_test.cmi test/derive_projector_test.cmj test/derive_type_test.cmi test/derive_type_test.cmj test/digest_test.cmi test/digest_test.cmj test/div_by_zero_test.cmi test/div_by_zero_test.cmj test/dollar_escape_test.cmi test/dollar_escape_test.cmj test/earger_curry_test.cmi test/earger_curry_test.cmj test/effect.cmi test/effect.cmj test/epsilon_test.cmi test/epsilon_test.cmj test/equal_box_test.cmi test/equal_box_test.cmj test/equal_exception_test.cmi test/equal_exception_test.cmj test/equal_test.cmi test/equal_test.cmj test/es6_export.cmi test/es6_export.cmj test/es6_import.cmi test/es6_import.cmj test/es6_module_test.cmi test/es6_module_test.cmj test/escape_esmodule.cmi test/escape_esmodule.cmj test/esmodule_ref.cmi test/esmodule_ref.cmj test/event_ffi.cmi test/event_ffi.cmj test/exception_alias.cmi test/exception_alias.cmj test/exception_def.cmi test/exception_def.cmj test/exception_raise_test.cmi test/exception_raise_test.cmj test/exception_rebind_test.cmi test/exception_rebind_test.cmj test/exception_rebound_err_test.cmi test/exception_rebound_err_test.cmj test/exception_repr_test.cmi test/exception_repr_test.cmj test/exception_value_test.cmi test/exception_value_test.cmj test/exn_error_pattern.cmi test/exn_error_pattern.cmj test/export_keyword.cmi test/export_keyword.cmj test/ext_array_test.cmi test/ext_array_test.cmj test/ext_bytes_test.cmi test/ext_bytes_test.cmj test/ext_filename_test.cmi test/ext_filename_test.cmj test/ext_list_test.cmi test/ext_list_test.cmj test/ext_pervasives_test.cmi test/ext_pervasives_test.cmj test/ext_string_test.cmi test/ext_string_test.cmj test/ext_sys_test.cmi test/ext_sys_test.cmj test/extensible_variant_test.cmi test/extensible_variant_test.cmj test/external_polyfill_test.cmi test/external_polyfill_test.cmj test/external_ppx.cmi test/external_ppx.cmj test/external_ppx2.cmi test/external_ppx2.cmj test/fail_comp.cmi test/fail_comp.cmj test/ffi_arity_test.cmi test/ffi_arity_test.cmj test/ffi_array_test.cmi test/ffi_array_test.cmj test/ffi_js_test.cmi test/ffi_js_test.cmj test/ffi_splice_test.cmi test/ffi_splice_test.cmj test/ffi_test.cmi test/ffi_test.cmj test/fib.cmi test/fib.cmj test/flattern_order_test.cmi test/flattern_order_test.cmj test/flexible_array_test.cmi test/flexible_array_test.cmj test/float_array.cmi test/float_array.cmj test/float_of_bits_test.cmi test/float_of_bits_test.cmj test/float_record.cmi test/float_record.cmj test/float_test.cmi test/float_test.cmj test/floatarray_test.cmi test/floatarray_test.cmj test/flow_parser_reg_test.cmi test/flow_parser_reg_test.cmj test/for_loop_test.cmi test/for_loop_test.cmj test/for_side_effect_test.cmi test/for_side_effect_test.cmj test/format_regression.cmi test/format_regression.cmj test/format_test.cmi test/format_test.cmj test/fs_test.cmi test/fs_test.cmj test/fun_pattern_match.cmi test/fun_pattern_match.cmj test/functor_app_test.cmi test/functor_app_test.cmj test/functor_def.cmi test/functor_def.cmj test/functor_ffi.cmi test/functor_ffi.cmj test/functor_inst.cmi test/functor_inst.cmj test/functors.cmi test/functors.cmj test/gbk.cmi test/gbk.cmj test/genlex_test.cmi test/genlex_test.cmj test/gentTypeReTest.cmi test/gentTypeReTest.cmj test/global_exception_regression_test.cmi test/global_exception_regression_test.cmj test/global_mangles.cmi test/global_mangles.cmj test/global_module_alias_test.cmi test/global_module_alias_test.cmj test/google_closure_test.cmi test/google_closure_test.cmj test/gpr496_test.cmi test/gpr496_test.cmj test/gpr_1063_test.cmi test/gpr_1063_test.cmj test/gpr_1072.cmi test/gpr_1072.cmj test/gpr_1072_reg.cmi test/gpr_1072_reg.cmj test/gpr_1150.cmi test/gpr_1150.cmj test/gpr_1154_test.cmi test/gpr_1154_test.cmj test/gpr_1170.cmi test/gpr_1170.cmj test/gpr_1240_missing_unbox.cmi test/gpr_1240_missing_unbox.cmj test/gpr_1245_test.cmi test/gpr_1245_test.cmj test/gpr_1268.cmi test/gpr_1268.cmj test/gpr_1409_test.cmi test/gpr_1409_test.cmj test/gpr_1423_app_test.cmi test/gpr_1423_app_test.cmj test/gpr_1423_nav.cmi test/gpr_1423_nav.cmj test/gpr_1438.cmi test/gpr_1438.cmj test/gpr_1481.cmi test/gpr_1481.cmj test/gpr_1484.cmi test/gpr_1484.cmj test/gpr_1501_test.cmi test/gpr_1501_test.cmj test/gpr_1503_test.cmi test/gpr_1503_test.cmj test/gpr_1539_test.cmi test/gpr_1539_test.cmj test/gpr_1600_test.cmi test/gpr_1600_test.cmj test/gpr_1658_test.cmi test/gpr_1658_test.cmj test/gpr_1667_test.cmi test/gpr_1667_test.cmj test/gpr_1692_test.cmi test/gpr_1692_test.cmj test/gpr_1698_test.cmi test/gpr_1698_test.cmj test/gpr_1701_test.cmi test/gpr_1701_test.cmj test/gpr_1716_test.cmi test/gpr_1716_test.cmj test/gpr_1717_test.cmi test/gpr_1717_test.cmj test/gpr_1728_test.cmi test/gpr_1728_test.cmj test/gpr_1749_test.cmi test/gpr_1749_test.cmj test/gpr_1759_test.cmi test/gpr_1759_test.cmj test/gpr_1760_test.cmi test/gpr_1760_test.cmj test/gpr_1762_test.cmi test/gpr_1762_test.cmj test/gpr_1817_test.cmi test/gpr_1817_test.cmj test/gpr_1822_test.cmi test/gpr_1822_test.cmj test/gpr_1891_test.cmi test/gpr_1891_test.cmj test/gpr_1943_test.cmi test/gpr_1943_test.cmj test/gpr_1946_test.cmi test/gpr_1946_test.cmj test/gpr_2316_test.cmi test/gpr_2316_test.cmj test/gpr_2352_test.cmi test/gpr_2352_test.cmj test/gpr_2413_test.cmi test/gpr_2413_test.cmj test/gpr_2474.cmi test/gpr_2474.cmj test/gpr_2487.cmi test/gpr_2487.cmj test/gpr_2503_test.cmi test/gpr_2503_test.cmj test/gpr_2608_test.cmi test/gpr_2608_test.cmj test/gpr_2614_test.cmi test/gpr_2614_test.cmj test/gpr_2633_test.cmi test/gpr_2633_test.cmj test/gpr_2642_test.cmi test/gpr_2642_test.cmj test/gpr_2652_test.cmi test/gpr_2652_test.cmj test/gpr_2682_test.cmi test/gpr_2682_test.cmj test/gpr_2700_test.cmi test/gpr_2700_test.cmj test/gpr_2731_test.cmi test/gpr_2731_test.cmj test/gpr_2789_test.cmi test/gpr_2789_test.cmj test/gpr_2931_test.cmi test/gpr_2931_test.cmj test/gpr_3142_test.cmi test/gpr_3142_test.cmj test/gpr_3154_test.cmi test/gpr_3154_test.cmj test/gpr_3209_test.cmi test/gpr_3209_test.cmj test/gpr_3492_test.cmi test/gpr_3492_test.cmj test/gpr_3519_jsx_test.cmi test/gpr_3519_jsx_test.cmj test/gpr_3519_test.cmi test/gpr_3519_test.cmj test/gpr_3536_test.cmi test/gpr_3536_test.cmj test/gpr_3546_test.cmi test/gpr_3546_test.cmj test/gpr_3548_test.cmi test/gpr_3548_test.cmj test/gpr_3549_test.cmi test/gpr_3549_test.cmj test/gpr_3566_drive_test.cmi test/gpr_3566_drive_test.cmj test/gpr_3566_test.cmi test/gpr_3566_test.cmj test/gpr_3595_test.cmi test/gpr_3595_test.cmj test/gpr_3609_test.cmi test/gpr_3609_test.cmj test/gpr_3697_test.cmi test/gpr_3697_test.cmj test/gpr_373_test.cmi test/gpr_373_test.cmj test/gpr_3770_test.cmi test/gpr_3770_test.cmj test/gpr_3852_alias.cmi test/gpr_3852_alias.cmj test/gpr_3852_alias_reify.cmi test/gpr_3852_alias_reify.cmj test/gpr_3852_effect.cmi test/gpr_3852_effect.cmj test/gpr_3865.cmi test/gpr_3865.cmj test/gpr_3865_bar.cmi test/gpr_3865_bar.cmj test/gpr_3865_foo.cmi test/gpr_3865_foo.cmj test/gpr_3875_test.cmi test/gpr_3875_test.cmj test/gpr_3877_test.cmi test/gpr_3877_test.cmj test/gpr_3895_test.cmi test/gpr_3895_test.cmj test/gpr_3897_test.cmi test/gpr_3897_test.cmj test/gpr_3931_test.cmi test/gpr_3931_test.cmj test/gpr_3980_test.cmi test/gpr_3980_test.cmj test/gpr_4025_test.cmi test/gpr_4025_test.cmj test/gpr_405_test.cmi test/gpr_405_test.cmj test/gpr_4069_test.cmi test/gpr_4069_test.cmj test/gpr_4265_test.cmi test/gpr_4265_test.cmj test/gpr_4274_test.cmi test/gpr_4274_test.cmj test/gpr_4280_test.cmi test/gpr_4280_test.cmj test/gpr_4407_test.cmi test/gpr_4407_test.cmj test/gpr_441.cmi test/gpr_441.cmj test/gpr_4442_test.cmi test/gpr_4442_test.cmj test/gpr_4491_test.cmi test/gpr_4491_test.cmj test/gpr_4494_test.cmi test/gpr_4494_test.cmj test/gpr_4519_test.cmi test/gpr_4519_test.cmj test/gpr_459_test.cmi test/gpr_459_test.cmj test/gpr_4632.cmi test/gpr_4632.cmj test/gpr_4639_test.cmi test/gpr_4639_test.cmj test/gpr_4900_test.cmi test/gpr_4900_test.cmj test/gpr_4924_test.cmi test/gpr_4924_test.cmj test/gpr_4931.cmi test/gpr_4931.cmj test/gpr_4931_allow.cmi test/gpr_4931_allow.cmj test/gpr_5071_test.cmi test/gpr_5071_test.cmj test/gpr_5169_test.cmi test/gpr_5169_test.cmj test/gpr_5218_test.cmi test/gpr_5218_test.cmj test/gpr_5280_optimize_test.cmi test/gpr_5280_optimize_test.cmj test/gpr_5312.cmi test/gpr_5312.cmj test/gpr_5557.cmi test/gpr_5557.cmj test/gpr_5753.cmi test/gpr_5753.cmj test/gpr_627_test.cmi test/gpr_627_test.cmj test/gpr_658.cmi test/gpr_658.cmj test/gpr_858_test.cmi test/gpr_858_test.cmj test/gpr_858_unit2_test.cmi test/gpr_858_unit2_test.cmj test/gpr_904_test.cmi test/gpr_904_test.cmj test/gpr_974_test.cmi test/gpr_974_test.cmj test/gpr_977_test.cmi test/gpr_977_test.cmj test/gpr_return_type_unused_attribute.cmi test/gpr_return_type_unused_attribute.cmj test/gray_code_test.cmi test/gray_code_test.cmj test/guide_for_ext.cmi test/guide_for_ext.cmj test/hamming_test.cmi test/hamming_test.cmj test/hash_collision_test.cmi test/hash_collision_test.cmj test/hash_sugar_desugar.cmi test/hash_sugar_desugar.cmj test/hash_test.cmi test/hash_test.cmj test/hashtbl_test.cmi test/hashtbl_test.cmj test/hello.foo.cmi test/hello.foo.cmj test/hello_res.cmi test/hello_res.cmj test/http_types.cmi test/http_types.cmj test/ignore_test.cmi test/ignore_test.cmj test/imm_map_bench.cmi test/imm_map_bench.cmj test/include_side_effect.cmi test/include_side_effect.cmj test/include_side_effect_free.cmi test/include_side_effect_free.cmj test/incomplete_toplevel_test.cmi test/incomplete_toplevel_test.cmj test/infer_type_test.cmi test/infer_type_test.cmj test/inline_const.cmi test/inline_const.cmj test/inline_const_test.cmi test/inline_const_test.cmj test/inline_edge_cases.cmi test/inline_edge_cases.cmj test/inline_map2_test.cmi test/inline_map2_test.cmj test/inline_map_demo.cmi test/inline_map_demo.cmj test/inline_map_test.cmi test/inline_map_test.cmj test/inline_record_test.cmi test/inline_record_test.cmj test/inline_regression_test.cmi test/inline_regression_test.cmj test/inline_string_test.cmi test/inline_string_test.cmj test/inner_call.cmi test/inner_call.cmj test/inner_define.cmi test/inner_define.cmj test/inner_unused.cmi test/inner_unused.cmj test/installation_test.cmi test/installation_test.cmj test/int32_test.cmi test/int32_test.cmj test/int64_mul_div_test.cmi test/int64_mul_div_test.cmj test/int64_string_bench.cmi test/int64_string_bench.cmj test/int64_string_test.cmi test/int64_string_test.cmj test/int64_test.cmi test/int64_test.cmj test/int_hashtbl_test.cmi test/int_hashtbl_test.cmj test/int_map.cmi test/int_map.cmj test/int_overflow_test.cmi test/int_overflow_test.cmj test/int_poly_var.cmi test/int_poly_var.cmj test/int_switch_test.cmi test/int_switch_test.cmj test/internal_unused_test.cmi test/internal_unused_test.cmj test/io_test.cmi test/io_test.cmj test/js_array_test.cmi test/js_array_test.cmj test/js_bool_test.cmi test/js_bool_test.cmj test/js_cast_test.cmi test/js_cast_test.cmj test/js_date_test.cmi test/js_date_test.cmj test/js_dict_test.cmi test/js_dict_test.cmj test/js_exception_catch_test.cmi test/js_exception_catch_test.cmj test/js_float_test.cmi test/js_float_test.cmj test/js_global_test.cmi test/js_global_test.cmj test/js_int_test.cmi test/js_int_test.cmj test/js_json_test.cmi test/js_json_test.cmj test/js_list_test.cmi test/js_list_test.cmj test/js_math_test.cmi test/js_math_test.cmj test/js_null_test.cmi test/js_null_test.cmj test/js_null_undefined_test.cmi test/js_null_undefined_test.cmj test/js_nullable_test.cmi test/js_nullable_test.cmj test/js_obj_test.cmi test/js_obj_test.cmj test/js_option_test.cmi test/js_option_test.cmj test/js_promise_basic_test.cmi test/js_promise_basic_test.cmj test/js_re_test.cmi test/js_re_test.cmj test/js_string_test.cmi test/js_string_test.cmj test/js_typed_array_test.cmi test/js_typed_array_test.cmj test/js_undefined_test.cmi test/js_undefined_test.cmj test/js_val.cmi test/js_val.cmj test/jsoo_400_test.cmi test/jsoo_400_test.cmj test/jsoo_485_test.cmi test/jsoo_485_test.cmj test/key_word_property.cmi test/key_word_property.cmj test/key_word_property2.cmi test/key_word_property2.cmj test/key_word_property_plus_test.cmi test/key_word_property_plus_test.cmj test/label_uncurry.cmi test/label_uncurry.cmj test/large_integer_pat.cmi test/large_integer_pat.cmj test/large_record_duplication_test.cmi test/large_record_duplication_test.cmj test/largest_int_flow.cmi test/largest_int_flow.cmj test/lazy_demo.cmi test/lazy_demo.cmj test/lazy_test.cmi test/lazy_test.cmj test/lexer_test.cmi test/lexer_test.cmj test/lib_js_test.cmi test/lib_js_test.cmj test/libarg_test.cmi test/libarg_test.cmj test/libqueue_test.cmi test/libqueue_test.cmj test/limits_test.cmi test/limits_test.cmj test/list_stack.cmi test/list_stack.cmj test/list_test.cmi test/list_test.cmj test/local_class_type.cmi test/local_class_type.cmj test/local_exception_test.cmi test/local_exception_test.cmj test/loop_regression_test.cmi test/loop_regression_test.cmj test/loop_suites_test.cmi test/loop_suites_test.cmj test/map_find_test.cmi test/map_find_test.cmj test/map_test.cmi test/map_test.cmj test/mario_game.cmi test/mario_game.cmj test/marshal.cmi test/marshal.cmj test/method_chain.cmi test/method_chain.cmj test/method_name_test.cmi test/method_name_test.cmj test/method_string_name.cmi test/method_string_name.cmj test/minimal_test.cmi test/minimal_test.cmj test/miss_colon_test.cmi test/miss_colon_test.cmj test/mock_mt.cmi test/mock_mt.cmj test/module_alias_test.cmi test/module_alias_test.cmj test/module_as_class_ffi.cmi test/module_as_class_ffi.cmj test/module_as_function.cmi test/module_as_function.cmj test/module_missing_conversion.cmi test/module_missing_conversion.cmj test/module_parameter_test.cmi test/module_parameter_test.cmj test/module_splice_test.cmi test/module_splice_test.cmj test/more_poly_variant_test.cmi test/more_poly_variant_test.cmj test/more_uncurry.cmi test/more_uncurry.cmj test/mpr_6033_test.cmi test/mpr_6033_test.cmj test/mt.cmi test/mt.cmj test/mt_global.cmi test/mt_global.cmj test/mutable_obj_test.cmi test/mutable_obj_test.cmj test/mutable_uncurry_test.cmi test/mutable_uncurry_test.cmj test/mutual_non_recursive_type.cmi test/mutual_non_recursive_type.cmj test/name_mangle_test.cmi test/name_mangle_test.cmj test/nested_include.cmi test/nested_include.cmj test/nested_module_alias.cmi test/nested_module_alias.cmj test/nested_obj_literal.cmi test/nested_obj_literal.cmj test/nested_obj_test.cmi test/nested_obj_test.cmj test/nested_pattern_match_test.cmi test/nested_pattern_match_test.cmj test/noassert.cmi test/noassert.cmj test/node_fs_test.cmi test/node_fs_test.cmj test/node_path_test.cmi test/node_path_test.cmj test/null_list_test.cmi test/null_list_test.cmj test/number_lexer.cmi test/number_lexer.cmj test/obj_literal_ppx.cmi test/obj_literal_ppx.cmj test/obj_literal_ppx_test.cmi test/obj_literal_ppx_test.cmj test/obj_magic_test.cmi test/obj_magic_test.cmj test/obj_type_test.cmi test/obj_type_test.cmj test/ocaml_re_test.cmi test/ocaml_re_test.cmj test/of_string_test.cmi test/of_string_test.cmj test/offset.cmi test/offset.cmj test/oo_js_test_date.cmi test/oo_js_test_date.cmj test/option_encoding_test.cmi test/option_encoding_test.cmj test/option_record_none_test.cmi test/option_record_none_test.cmj test/option_repr_test.cmi test/option_repr_test.cmj test/optional_ffi_test.cmi test/optional_ffi_test.cmj test/optional_regression_test.cmi test/optional_regression_test.cmj test/pipe_send_readline.cmi test/pipe_send_readline.cmj test/pipe_syntax.cmi test/pipe_syntax.cmj test/poly_empty_array.cmi test/poly_empty_array.cmj test/poly_type.cmi test/poly_type.cmj test/poly_variant_test.cmi test/poly_variant_test.cmj test/polymorphic_raw_test.cmi test/polymorphic_raw_test.cmj test/polymorphism_test.cmi test/polymorphism_test.cmj test/polyvar_convert.cmi test/polyvar_convert.cmj test/polyvar_test.cmi test/polyvar_test.cmj test/ppx_apply_test.cmi test/ppx_apply_test.cmj test/ppx_this_obj_field.cmi test/ppx_this_obj_field.cmj test/ppx_this_obj_test.cmi test/ppx_this_obj_test.cmj test/pq_test.cmi test/pq_test.cmj test/pr6726.cmi test/pr6726.cmj test/pr_regression_test.cmi test/pr_regression_test.cmj test/prepend_data_ffi.cmi test/prepend_data_ffi.cmj test/primitive_reg_test.cmi test/primitive_reg_test.cmj test/print_alpha_test.cmi test/print_alpha_test.cmj test/promise.cmi test/promise.cmj test/promise_catch_test.cmi test/promise_catch_test.cmj test/queue_402.cmi test/queue_402.cmj test/queue_test.cmi test/queue_test.cmj test/random_test.cmi test/random_test.cmj test/raw_hash_tbl_bench.cmi test/raw_hash_tbl_bench.cmj test/raw_output_test.cmi test/raw_output_test.cmj test/raw_pure_test.cmi test/raw_pure_test.cmj test/rbset.cmi test/rbset.cmj test/react.cmi test/react.cmj test/reactDOMRe.cmi test/reactDOMRe.cmj test/reactDOMServerRe.cmi test/reactDOMServerRe.cmj test/reactEvent.cmi test/reactEvent.cmj test/reactTestUtils.cmi test/reactTestUtils.cmj test/reasonReact.cmi test/reasonReact.cmj test/reasonReactCompat.cmi test/reasonReactCompat.cmj test/reasonReactOptimizedCreateClass.cmi test/reasonReactOptimizedCreateClass.cmj test/reasonReactRouter.cmi test/reasonReactRouter.cmj test/rebind_module.cmi test/rebind_module.cmj test/rebind_module_test.cmi test/rebind_module_test.cmj test/rec_array_test.cmi test/rec_array_test.cmj test/rec_fun_test.cmi test/rec_fun_test.cmj test/rec_module_opt.cmi test/rec_module_opt.cmj test/rec_module_test.cmi test/rec_module_test.cmj test/rec_value_test.cmi test/rec_value_test.cmj test/record_debug_test.cmi test/record_debug_test.cmj test/record_extension_test.cmi test/record_extension_test.cmj test/record_name_test.cmi test/record_name_test.cmj test/record_regression.cmi test/record_regression.cmj test/record_with_test.cmi test/record_with_test.cmj test/recursive_module.cmi test/recursive_module.cmj test/recursive_module_test.cmi test/recursive_module_test.cmj test/recursive_react_component.cmi test/recursive_react_component.cmj test/recursive_records_test.cmi test/recursive_records_test.cmj test/recursive_unbound_module_test.cmi test/recursive_unbound_module_test.cmj test/regression_print.cmi test/regression_print.cmj test/relative_path.cmi test/relative_path.cmj test/res_debug.cmi test/res_debug.cmj test/return_check.cmi test/return_check.cmj test/runtime_encoding_test.cmi test/runtime_encoding_test.cmj test/set_gen.cmi test/set_gen.cmj test/sexp.cmi test/sexp.cmj test/sexpm.cmi test/sexpm.cmj test/sexpm_test.cmi test/sexpm_test.cmj test/side_effect.cmi test/side_effect.cmj test/side_effect_free.cmi test/side_effect_free.cmj test/simple_derive_test.cmi test/simple_derive_test.cmj test/simple_derive_use.cmi test/simple_derive_use.cmj test/simple_lexer_test.cmi test/simple_lexer_test.cmj test/simplify_lambda_632o.cmi test/simplify_lambda_632o.cmj test/single_module_alias.cmi test/single_module_alias.cmj test/singular_unit_test.cmi test/singular_unit_test.cmj test/small_inline_test.cmi test/small_inline_test.cmj test/splice_test.cmi test/splice_test.cmj test/stack_comp_test.cmi test/stack_comp_test.cmj test/stack_test.cmi test/stack_test.cmj test/stream_parser_test.cmi test/stream_parser_test.cmj test/string_bound_get_test.cmi test/string_bound_get_test.cmj test/string_get_set_test.cmi test/string_get_set_test.cmj test/string_interp_test.cmi test/string_interp_test.cmj test/string_literal_print_test.cmi test/string_literal_print_test.cmj test/string_runtime_test.cmi test/string_runtime_test.cmj test/string_set.cmi test/string_set.cmj test/string_set_test.cmi test/string_set_test.cmj test/string_test.cmi test/string_test.cmj test/string_unicode_test.cmi test/string_unicode_test.cmj test/stringmatch_test.cmi test/stringmatch_test.cmj test/submodule.cmi test/submodule.cmj test/submodule_call.cmi test/submodule_call.cmj test/switch_case_test.cmi test/switch_case_test.cmj test/tailcall_inline_test.cmi test/tailcall_inline_test.cmj test/template.cmi test/template.cmj test/test.cmi test/test.cmj test/test2.cmi test/test2.cmj test/test_alias.cmi test/test_alias.cmj test/test_ari.cmi test/test_ari.cmj test/test_array.cmi test/test_array.cmj test/test_array_append.cmi test/test_array_append.cmj test/test_array_primitive.cmi test/test_array_primitive.cmj test/test_bool_equal.cmi test/test_bool_equal.cmj test/test_bs_this.cmi test/test_bs_this.cmj test/test_bug.cmi test/test_bug.cmj test/test_bytes.cmi test/test_bytes.cmj test/test_case_opt_collision.cmi test/test_case_opt_collision.cmj test/test_case_set.cmi test/test_case_set.cmj test/test_char.cmi test/test_char.cmj test/test_closure.cmi test/test_closure.cmj test/test_common.cmi test/test_common.cmj test/test_const_elim.cmi test/test_const_elim.cmj test/test_const_propogate.cmi test/test_const_propogate.cmj test/test_cpp.cmi test/test_cpp.cmj test/test_cps.cmi test/test_cps.cmj test/test_demo.cmi test/test_demo.cmj test/test_dup_param.cmi test/test_dup_param.cmj test/test_eq.cmi test/test_eq.cmj test/test_exception.cmi test/test_exception.cmj test/test_exception_escape.cmi test/test_exception_escape.cmj test/test_export2.cmi test/test_export2.cmj test/test_external.cmi test/test_external.cmj test/test_external_unit.cmi test/test_external_unit.cmj test/test_ffi.cmi test/test_ffi.cmj test/test_fib.cmi test/test_fib.cmj test/test_filename.cmi test/test_filename.cmj test/test_for_loop.cmi test/test_for_loop.cmj test/test_for_map.cmi test/test_for_map.cmj test/test_for_map2.cmi test/test_for_map2.cmj test/test_format.cmi test/test_format.cmj test/test_formatter.cmi test/test_formatter.cmj test/test_functor_dead_code.cmi test/test_functor_dead_code.cmj test/test_generative_module.cmi test/test_generative_module.cmj test/test_global_print.cmi test/test_global_print.cmj test/test_google_closure.cmi test/test_google_closure.cmj test/test_http_server.cmi test/test_http_server.cmj test/test_include.cmi test/test_include.cmj test/test_incomplete.cmi test/test_incomplete.cmj test/test_incr_ref.cmi test/test_incr_ref.cmj test/test_index.cmi test/test_index.cmj test/test_int_map_find.cmi test/test_int_map_find.cmj test/test_internalOO.cmi test/test_internalOO.cmj test/test_is_js.cmi test/test_is_js.cmj test/test_js_ffi.cmi test/test_js_ffi.cmj test/test_let.cmi test/test_let.cmj test/test_list.cmi test/test_list.cmj test/test_literal.cmi test/test_literal.cmj test/test_literals.cmi test/test_literals.cmj test/test_match_exception.cmi test/test_match_exception.cmj test/test_mutliple.cmi test/test_mutliple.cmj test/test_nat64.cmi test/test_nat64.cmj test/test_nested_let.cmi test/test_nested_let.cmj test/test_nested_print.cmi test/test_nested_print.cmj test/test_non_export.cmi test/test_non_export.cmj test/test_nullary.cmi test/test_nullary.cmj test/test_obj.cmi test/test_obj.cmj test/test_obj_simple_ffi.cmi test/test_obj_simple_ffi.cmj test/test_order.cmi test/test_order.cmj test/test_order_tailcall.cmi test/test_order_tailcall.cmj test/test_other_exn.cmi test/test_other_exn.cmj test/test_pack.cmi test/test_pack.cmj test/test_per.cmi test/test_per.cmj test/test_pervasive.cmi test/test_pervasive.cmj test/test_pervasives2.cmi test/test_pervasives2.cmj test/test_pervasives3.cmi test/test_pervasives3.cmj test/test_primitive.cmi test/test_primitive.cmj test/test_promise_bind.cmi test/test_promise_bind.cmj test/test_ramification.cmi test/test_ramification.cmj test/test_react.cmi test/test_react.cmj test/test_react_case.cmi test/test_react_case.cmj test/test_regex.cmi test/test_regex.cmj test/test_require.cmi test/test_require.cmj test/test_runtime_encoding.cmi test/test_runtime_encoding.cmj test/test_scope.cmi test/test_scope.cmj test/test_seq.cmi test/test_seq.cmj test/test_set.cmi test/test_set.cmj test/test_side_effect_functor.cmi test/test_side_effect_functor.cmj test/test_simple_include.cmi test/test_simple_include.cmj test/test_simple_pattern_match.cmi test/test_simple_pattern_match.cmj test/test_simple_ref.cmi test/test_simple_ref.cmj test/test_simple_tailcall.cmi test/test_simple_tailcall.cmj test/test_small.cmi test/test_small.cmj test/test_sprintf.cmi test/test_sprintf.cmj test/test_stack.cmi test/test_stack.cmj test/test_static_catch_ident.cmi test/test_static_catch_ident.cmj test/test_string.cmi test/test_string.cmj test/test_string_case.cmi test/test_string_case.cmj test/test_string_const.cmi test/test_string_const.cmj test/test_string_map.cmi test/test_string_map.cmj test/test_string_switch.cmi test/test_string_switch.cmj test/test_switch.cmi test/test_switch.cmj test/test_trywith.cmi test/test_trywith.cmj test/test_tuple.cmi test/test_tuple.cmj test/test_tuple_destructring.cmi test/test_tuple_destructring.cmj test/test_type_based_arity.cmi test/test_type_based_arity.cmj test/test_u.cmi test/test_u.cmj test/test_unknown.cmi test/test_unknown.cmj test/test_unsafe_cmp.cmi test/test_unsafe_cmp.cmj test/test_unsafe_obj_ffi.cmi test/test_unsafe_obj_ffi.cmj test/test_unsafe_obj_ffi_ppx.cmi test/test_unsafe_obj_ffi_ppx.cmj test/test_unsupported_primitive.cmi test/test_unsupported_primitive.cmj test/test_while_closure.cmi test/test_while_closure.cmj test/test_while_side_effect.cmi test/test_while_side_effect.cmj test/test_zero_nullable.cmi test/test_zero_nullable.cmj test/then_mangle_test.cmi test/then_mangle_test.cmj test/ticker.cmi test/ticker.cmj test/to_string_test.cmi test/to_string_test.cmj test/topsort_test.cmi test/topsort_test.cmj test/tramp_fib.cmi test/tramp_fib.cmj test/tuple_alloc.cmi test/tuple_alloc.cmj test/type_disambiguate.cmi test/type_disambiguate.cmj test/typeof_test.cmi test/typeof_test.cmj test/ui_defs.cmi test/unboxed_attribute.cmi test/unboxed_attribute.cmj test/unboxed_attribute_test.cmi test/unboxed_attribute_test.cmj test/unboxed_crash.cmi test/unboxed_crash.cmj test/unboxed_use_case.cmi test/unboxed_use_case.cmj test/uncurry_external_test.cmi test/uncurry_external_test.cmj test/uncurry_glob_test.cmi test/uncurry_glob_test.cmj test/uncurry_method.cmi test/uncurry_method.cmj test/uncurry_test.cmi test/uncurry_test.cmj test/undef_regression2_test.cmi test/undef_regression2_test.cmj test/undef_regression_test.cmi test/undef_regression_test.cmj test/undefine_conditional.cmi test/undefine_conditional.cmj test/unicode_type_error.cmi test/unicode_type_error.cmj test/unit_undefined_test.cmi test/unit_undefined_test.cmj test/unitest_string.cmi test/unitest_string.cmj test/unsafe_full_apply_primitive.cmi test/unsafe_full_apply_primitive.cmj test/unsafe_obj_external.cmi test/unsafe_obj_external.cmj test/unsafe_ppx_test.cmi test/unsafe_ppx_test.cmj test/unsafe_this.cmi test/unsafe_this.cmj test/update_record_test.cmi test/update_record_test.cmj test/utf8_decode_test.cmi test/utf8_decode_test.cmj test/variant.cmi test/variant.cmj test/watch_test.cmi test/watch_test.cmj test/webpack_config.cmi test/webpack_config.cmj diff --git a/jscomp/test/gpr_5753.js b/jscomp/test/gpr_5753.js new file mode 100644 index 0000000000..beabaa708e --- /dev/null +++ b/jscomp/test/gpr_5753.js @@ -0,0 +1,6 @@ +'use strict'; + + +console.log(/* '文' */25991); + +/* Not a pure module */ diff --git a/jscomp/test/gpr_5753.res b/jscomp/test/gpr_5753.res new file mode 100644 index 0000000000..27eb975ef7 --- /dev/null +++ b/jscomp/test/gpr_5753.res @@ -0,0 +1,5 @@ +@@config({ + flags : ["-w", "-8"] +}) + +'文'-> Js.log \ No newline at end of file diff --git a/jscomp/test/res_debug.js b/jscomp/test/res_debug.js index 5a9b1bfc4b..af0d0fa941 100644 --- a/jscomp/test/res_debug.js +++ b/jscomp/test/res_debug.js @@ -70,7 +70,7 @@ var v1 = { z: 3 }; -var h = /* '\128522' */128522; +var h = /* '😊' */128522; var hey = "hello, 世界"; diff --git a/jscomp/test/string_unicode_test.js b/jscomp/test/string_unicode_test.js index 46cda2dc3a..e423a44a7b 100644 --- a/jscomp/test/string_unicode_test.js +++ b/jscomp/test/string_unicode_test.js @@ -47,9 +47,9 @@ function f(x) { eq("File \"string_unicode_test.ml\", line 27, characters 7-14", f(/* '{' */123), 0); -eq("File \"string_unicode_test.ml\", line 28, characters 7-14", f(/* '\333' */333), 2); +eq("File \"string_unicode_test.ml\", line 28, characters 7-14", f(/* 'ō' */333), 2); -eq("File \"string_unicode_test.ml\", line 29, characters 7-14", f(/* '\444' */444), 3); +eq("File \"string_unicode_test.ml\", line 29, characters 7-14", f(/* 'Ƽ' */444), 3); Mt.from_pair_suites("string_unicode_test.ml", suites.contents); diff --git a/lib/4.06.1/rescript.ml b/lib/4.06.1/rescript.ml index a1fec32709..58f603810a 100644 --- a/lib/4.06.1/rescript.ml +++ b/lib/4.06.1/rescript.ml @@ -6472,6 +6472,183 @@ let real_path p = let is_same_paths_via_io a b = if a = b then true else real_path a = real_path b +end +module Ext_utf8 : sig +#1 "ext_utf8.mli" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +type byte = Single of int | Cont of int | Leading of int * int | Invalid + +val classify : char -> byte + +val follow : string -> int -> int -> int -> int * int + +val next : string -> remaining:int -> int -> int +(** + return [-1] if failed +*) + +exception Invalid_utf8 of string + +val decode_utf8_string : string -> int list + +val encode_codepoint : int -> string + +end = struct +#1 "ext_utf8.ml" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +type byte = Single of int | Cont of int | Leading of int * int | Invalid + +(** [classify chr] returns the {!byte} corresponding to [chr] *) +let classify chr = + let c = int_of_char chr in + (* Classify byte according to leftmost 0 bit *) + if c land 0b1000_0000 = 0 then Single c + else if (* c 0b0____*) + c land 0b0100_0000 = 0 then Cont (c land 0b0011_1111) + else if (* c 0b10___*) + c land 0b0010_0000 = 0 then Leading (1, c land 0b0001_1111) + else if (* c 0b110__*) + c land 0b0001_0000 = 0 then Leading (2, c land 0b0000_1111) + else if (* c 0b1110_ *) + c land 0b0000_1000 = 0 then Leading (3, c land 0b0000_0111) + else if (* c 0b1111_0___*) + c land 0b0000_0100 = 0 then Leading (4, c land 0b0000_0011) + else if (* c 0b1111_10__*) + c land 0b0000_0010 = 0 then Leading (5, c land 0b0000_0001) + (* c 0b1111_110__ *) + else Invalid + +exception Invalid_utf8 of string + +(* when the first char is [Leading], + TODO: need more error checking + when out of bond +*) +let rec follow s n (c : int) offset = + if n = 0 then (c, offset) + else + match classify s.[offset + 1] with + | Cont cc -> follow s (n - 1) ((c lsl 6) lor (cc land 0x3f)) (offset + 1) + | _ -> raise (Invalid_utf8 "Continuation byte expected") + +let rec next s ~remaining offset = + if remaining = 0 then offset + else + match classify s.[offset + 1] with + | Cont _cc -> next s ~remaining:(remaining - 1) (offset + 1) + | _ -> -1 + | exception _ -> -1 +(* it can happen when out of bound *) + +let decode_utf8_string s = + let lst = ref [] in + let add elem = lst := elem :: !lst in + let rec decode_utf8_cont s i s_len = + if i = s_len then () + else + match classify s.[i] with + | Single c -> + add c; + decode_utf8_cont s (i + 1) s_len + | Cont _ -> raise (Invalid_utf8 "Unexpected continuation byte") + | Leading (n, c) -> + let c', i' = follow s n c i in + add c'; + decode_utf8_cont s (i' + 1) s_len + | Invalid -> raise (Invalid_utf8 "Invalid byte") + in + decode_utf8_cont s 0 (String.length s); + List.rev !lst + +(** To decode {j||j} we need verify in the ast so that we have better error + location, then we do the decode later +*) + +(* let verify s loc = + assert false *) + +let encode_codepoint c = + let h2 = 0b1100_0000 in + let h3 = 0b1110_0000 in + let h4 = 0b1111_0000 in + let cont_mask = 0b0011_1111 in + if c <= 127 then ( + let bytes = (Bytes.create [@doesNotRaise]) 1 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr c); + Bytes.unsafe_to_string bytes) + else if c <= 2047 then ( + let bytes = (Bytes.create [@doesNotRaise]) 2 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h2 lor (c lsr 6))); + Bytes.unsafe_set bytes 1 + (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); + Bytes.unsafe_to_string bytes) + else if c <= 65535 then ( + let bytes = (Bytes.create [@doesNotRaise]) 3 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h3 lor (c lsr 12))); + Bytes.unsafe_set bytes 1 + (Char.unsafe_chr (0b1000_0000 lor ((c lsr 6) land cont_mask))); + Bytes.unsafe_set bytes 2 + (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); + Bytes.unsafe_to_string bytes) + else + (* if c <= max then *) + let bytes = (Bytes.create [@doesNotRaise]) 4 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h4 lor (c lsr 18))); + Bytes.unsafe_set bytes 1 + (Char.unsafe_chr (0b1000_0000 lor ((c lsr 12) land cont_mask))); + Bytes.unsafe_set bytes 2 + (Char.unsafe_chr (0b1000_0000 lor ((c lsr 6) land cont_mask))); + Bytes.unsafe_set bytes 3 + (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); + Bytes.unsafe_to_string bytes + + end module Ext_util : sig #1 "ext_util.mli" @@ -6556,7 +6733,7 @@ let string_of_int_as_char i = then Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) else - Printf.sprintf "\'\\%d\'" i + Printf.sprintf "\'%s\'" (Ext_utf8.encode_codepoint i) end module Hash_gen diff --git a/lib/4.06.1/rescript.ml.d b/lib/4.06.1/rescript.ml.d index ebfcb8e90e..f195047559 100644 --- a/lib/4.06.1/rescript.ml.d +++ b/lib/4.06.1/rescript.ml.d @@ -115,6 +115,8 @@ ../lib/4.06.1/rescript.ml: ./ext/ext_string.pp.mli ../lib/4.06.1/rescript.ml: ./ext/ext_sys.mli ../lib/4.06.1/rescript.ml: ./ext/ext_sys.pp.ml +../lib/4.06.1/rescript.ml: ./ext/ext_utf8.ml +../lib/4.06.1/rescript.ml: ./ext/ext_utf8.mli ../lib/4.06.1/rescript.ml: ./ext/ext_util.ml ../lib/4.06.1/rescript.ml: ./ext/ext_util.mli ../lib/4.06.1/rescript.ml: ./ext/hash.ml diff --git a/lib/4.06.1/unstable/all_ounit_tests.ml b/lib/4.06.1/unstable/all_ounit_tests.ml index 113d11f14d..aee6e430a4 100644 --- a/lib/4.06.1/unstable/all_ounit_tests.ml +++ b/lib/4.06.1/unstable/all_ounit_tests.ml @@ -6388,6 +6388,183 @@ external set_as_old_file : string -> unit = "caml_stale_file" +end +module Ext_utf8 : sig +#1 "ext_utf8.mli" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +type byte = Single of int | Cont of int | Leading of int * int | Invalid + +val classify : char -> byte + +val follow : string -> int -> int -> int -> int * int + +val next : string -> remaining:int -> int -> int +(** + return [-1] if failed +*) + +exception Invalid_utf8 of string + +val decode_utf8_string : string -> int list + +val encode_codepoint : int -> string + +end = struct +#1 "ext_utf8.ml" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +type byte = Single of int | Cont of int | Leading of int * int | Invalid + +(** [classify chr] returns the {!byte} corresponding to [chr] *) +let classify chr = + let c = int_of_char chr in + (* Classify byte according to leftmost 0 bit *) + if c land 0b1000_0000 = 0 then Single c + else if (* c 0b0____*) + c land 0b0100_0000 = 0 then Cont (c land 0b0011_1111) + else if (* c 0b10___*) + c land 0b0010_0000 = 0 then Leading (1, c land 0b0001_1111) + else if (* c 0b110__*) + c land 0b0001_0000 = 0 then Leading (2, c land 0b0000_1111) + else if (* c 0b1110_ *) + c land 0b0000_1000 = 0 then Leading (3, c land 0b0000_0111) + else if (* c 0b1111_0___*) + c land 0b0000_0100 = 0 then Leading (4, c land 0b0000_0011) + else if (* c 0b1111_10__*) + c land 0b0000_0010 = 0 then Leading (5, c land 0b0000_0001) + (* c 0b1111_110__ *) + else Invalid + +exception Invalid_utf8 of string + +(* when the first char is [Leading], + TODO: need more error checking + when out of bond +*) +let rec follow s n (c : int) offset = + if n = 0 then (c, offset) + else + match classify s.[offset + 1] with + | Cont cc -> follow s (n - 1) ((c lsl 6) lor (cc land 0x3f)) (offset + 1) + | _ -> raise (Invalid_utf8 "Continuation byte expected") + +let rec next s ~remaining offset = + if remaining = 0 then offset + else + match classify s.[offset + 1] with + | Cont _cc -> next s ~remaining:(remaining - 1) (offset + 1) + | _ -> -1 + | exception _ -> -1 +(* it can happen when out of bound *) + +let decode_utf8_string s = + let lst = ref [] in + let add elem = lst := elem :: !lst in + let rec decode_utf8_cont s i s_len = + if i = s_len then () + else + match classify s.[i] with + | Single c -> + add c; + decode_utf8_cont s (i + 1) s_len + | Cont _ -> raise (Invalid_utf8 "Unexpected continuation byte") + | Leading (n, c) -> + let c', i' = follow s n c i in + add c'; + decode_utf8_cont s (i' + 1) s_len + | Invalid -> raise (Invalid_utf8 "Invalid byte") + in + decode_utf8_cont s 0 (String.length s); + List.rev !lst + +(** To decode {j||j} we need verify in the ast so that we have better error + location, then we do the decode later +*) + +(* let verify s loc = + assert false *) + +let encode_codepoint c = + let h2 = 0b1100_0000 in + let h3 = 0b1110_0000 in + let h4 = 0b1111_0000 in + let cont_mask = 0b0011_1111 in + if c <= 127 then ( + let bytes = (Bytes.create [@doesNotRaise]) 1 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr c); + Bytes.unsafe_to_string bytes) + else if c <= 2047 then ( + let bytes = (Bytes.create [@doesNotRaise]) 2 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h2 lor (c lsr 6))); + Bytes.unsafe_set bytes 1 + (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); + Bytes.unsafe_to_string bytes) + else if c <= 65535 then ( + let bytes = (Bytes.create [@doesNotRaise]) 3 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h3 lor (c lsr 12))); + Bytes.unsafe_set bytes 1 + (Char.unsafe_chr (0b1000_0000 lor ((c lsr 6) land cont_mask))); + Bytes.unsafe_set bytes 2 + (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); + Bytes.unsafe_to_string bytes) + else + (* if c <= max then *) + let bytes = (Bytes.create [@doesNotRaise]) 4 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h4 lor (c lsr 18))); + Bytes.unsafe_set bytes 1 + (Char.unsafe_chr (0b1000_0000 lor ((c lsr 12) land cont_mask))); + Bytes.unsafe_set bytes 2 + (Char.unsafe_chr (0b1000_0000 lor ((c lsr 6) land cont_mask))); + Bytes.unsafe_set bytes 3 + (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); + Bytes.unsafe_to_string bytes + + end module Ext_util : sig #1 "ext_util.mli" @@ -6472,7 +6649,7 @@ let string_of_int_as_char i = then Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) else - Printf.sprintf "\'\\%d\'" i + Printf.sprintf "\'%s\'" (Ext_utf8.encode_codepoint i) end module Hash_gen @@ -34106,145 +34283,6 @@ let suites = end ] end -module Ext_utf8 : sig -#1 "ext_utf8.mli" -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type byte = Single of int | Cont of int | Leading of int * int | Invalid - -val classify : char -> byte - -val follow : string -> int -> int -> int -> int * int - -val next : string -> remaining:int -> int -> int -(** - return [-1] if failed -*) - -exception Invalid_utf8 of string - -val decode_utf8_string : string -> int list - -end = struct -#1 "ext_utf8.ml" -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type byte = Single of int | Cont of int | Leading of int * int | Invalid - -(** [classify chr] returns the {!byte} corresponding to [chr] *) -let classify chr = - let c = int_of_char chr in - (* Classify byte according to leftmost 0 bit *) - if c land 0b1000_0000 = 0 then Single c - else if (* c 0b0____*) - c land 0b0100_0000 = 0 then Cont (c land 0b0011_1111) - else if (* c 0b10___*) - c land 0b0010_0000 = 0 then Leading (1, c land 0b0001_1111) - else if (* c 0b110__*) - c land 0b0001_0000 = 0 then Leading (2, c land 0b0000_1111) - else if (* c 0b1110_ *) - c land 0b0000_1000 = 0 then Leading (3, c land 0b0000_0111) - else if (* c 0b1111_0___*) - c land 0b0000_0100 = 0 then Leading (4, c land 0b0000_0011) - else if (* c 0b1111_10__*) - c land 0b0000_0010 = 0 then Leading (5, c land 0b0000_0001) - (* c 0b1111_110__ *) - else Invalid - -exception Invalid_utf8 of string - -(* when the first char is [Leading], - TODO: need more error checking - when out of bond -*) -let rec follow s n (c : int) offset = - if n = 0 then (c, offset) - else - match classify s.[offset + 1] with - | Cont cc -> follow s (n - 1) ((c lsl 6) lor (cc land 0x3f)) (offset + 1) - | _ -> raise (Invalid_utf8 "Continuation byte expected") - -let rec next s ~remaining offset = - if remaining = 0 then offset - else - match classify s.[offset + 1] with - | Cont _cc -> next s ~remaining:(remaining - 1) (offset + 1) - | _ -> -1 - | exception _ -> -1 -(* it can happen when out of bound *) - -let decode_utf8_string s = - let lst = ref [] in - let add elem = lst := elem :: !lst in - let rec decode_utf8_cont s i s_len = - if i = s_len then () - else - match classify s.[i] with - | Single c -> - add c; - decode_utf8_cont s (i + 1) s_len - | Cont _ -> raise (Invalid_utf8 "Unexpected continuation byte") - | Leading (n, c) -> - let c', i' = follow s n c i in - add c'; - decode_utf8_cont s (i' + 1) s_len - | Invalid -> raise (Invalid_utf8 "Invalid byte") - in - decode_utf8_cont s 0 (String.length s); - List.rev !lst - -(** To decode {j||j} we need verify in the ast so that we have better error - location, then we do the decode later -*) - -(* let verify s loc = - assert false *) - -end module Ext_js_regex : sig #1 "ext_js_regex.mli" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. diff --git a/lib/4.06.1/unstable/js_compiler.ml b/lib/4.06.1/unstable/js_compiler.ml index 7648567382..3f7e870aa0 100644 --- a/lib/4.06.1/unstable/js_compiler.ml +++ b/lib/4.06.1/unstable/js_compiler.ml @@ -24863,6 +24863,183 @@ let lam_of_loc kind loc = let reset () = raise_count := 0 +end +module Ext_utf8 : sig +#1 "ext_utf8.mli" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +type byte = Single of int | Cont of int | Leading of int * int | Invalid + +val classify : char -> byte + +val follow : string -> int -> int -> int -> int * int + +val next : string -> remaining:int -> int -> int +(** + return [-1] if failed +*) + +exception Invalid_utf8 of string + +val decode_utf8_string : string -> int list + +val encode_codepoint : int -> string + +end = struct +#1 "ext_utf8.ml" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +type byte = Single of int | Cont of int | Leading of int * int | Invalid + +(** [classify chr] returns the {!byte} corresponding to [chr] *) +let classify chr = + let c = int_of_char chr in + (* Classify byte according to leftmost 0 bit *) + if c land 0b1000_0000 = 0 then Single c + else if (* c 0b0____*) + c land 0b0100_0000 = 0 then Cont (c land 0b0011_1111) + else if (* c 0b10___*) + c land 0b0010_0000 = 0 then Leading (1, c land 0b0001_1111) + else if (* c 0b110__*) + c land 0b0001_0000 = 0 then Leading (2, c land 0b0000_1111) + else if (* c 0b1110_ *) + c land 0b0000_1000 = 0 then Leading (3, c land 0b0000_0111) + else if (* c 0b1111_0___*) + c land 0b0000_0100 = 0 then Leading (4, c land 0b0000_0011) + else if (* c 0b1111_10__*) + c land 0b0000_0010 = 0 then Leading (5, c land 0b0000_0001) + (* c 0b1111_110__ *) + else Invalid + +exception Invalid_utf8 of string + +(* when the first char is [Leading], + TODO: need more error checking + when out of bond +*) +let rec follow s n (c : int) offset = + if n = 0 then (c, offset) + else + match classify s.[offset + 1] with + | Cont cc -> follow s (n - 1) ((c lsl 6) lor (cc land 0x3f)) (offset + 1) + | _ -> raise (Invalid_utf8 "Continuation byte expected") + +let rec next s ~remaining offset = + if remaining = 0 then offset + else + match classify s.[offset + 1] with + | Cont _cc -> next s ~remaining:(remaining - 1) (offset + 1) + | _ -> -1 + | exception _ -> -1 +(* it can happen when out of bound *) + +let decode_utf8_string s = + let lst = ref [] in + let add elem = lst := elem :: !lst in + let rec decode_utf8_cont s i s_len = + if i = s_len then () + else + match classify s.[i] with + | Single c -> + add c; + decode_utf8_cont s (i + 1) s_len + | Cont _ -> raise (Invalid_utf8 "Unexpected continuation byte") + | Leading (n, c) -> + let c', i' = follow s n c i in + add c'; + decode_utf8_cont s (i' + 1) s_len + | Invalid -> raise (Invalid_utf8 "Invalid byte") + in + decode_utf8_cont s 0 (String.length s); + List.rev !lst + +(** To decode {j||j} we need verify in the ast so that we have better error + location, then we do the decode later +*) + +(* let verify s loc = + assert false *) + +let encode_codepoint c = + let h2 = 0b1100_0000 in + let h3 = 0b1110_0000 in + let h4 = 0b1111_0000 in + let cont_mask = 0b0011_1111 in + if c <= 127 then ( + let bytes = (Bytes.create [@doesNotRaise]) 1 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr c); + Bytes.unsafe_to_string bytes) + else if c <= 2047 then ( + let bytes = (Bytes.create [@doesNotRaise]) 2 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h2 lor (c lsr 6))); + Bytes.unsafe_set bytes 1 + (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); + Bytes.unsafe_to_string bytes) + else if c <= 65535 then ( + let bytes = (Bytes.create [@doesNotRaise]) 3 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h3 lor (c lsr 12))); + Bytes.unsafe_set bytes 1 + (Char.unsafe_chr (0b1000_0000 lor ((c lsr 6) land cont_mask))); + Bytes.unsafe_set bytes 2 + (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); + Bytes.unsafe_to_string bytes) + else + (* if c <= max then *) + let bytes = (Bytes.create [@doesNotRaise]) 4 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h4 lor (c lsr 18))); + Bytes.unsafe_set bytes 1 + (Char.unsafe_chr (0b1000_0000 lor ((c lsr 12) land cont_mask))); + Bytes.unsafe_set bytes 2 + (Char.unsafe_chr (0b1000_0000 lor ((c lsr 6) land cont_mask))); + Bytes.unsafe_set bytes 3 + (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); + Bytes.unsafe_to_string bytes + + end module Ext_util : sig #1 "ext_util.mli" @@ -24947,7 +25124,7 @@ let string_of_int_as_char i = then Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) else - Printf.sprintf "\'\\%d\'" i + Printf.sprintf "\'%s\'" (Ext_utf8.encode_codepoint i) end module Pprintast : sig @@ -84085,145 +84262,6 @@ let is_lower_case c = || (c >= '\224' && c <= '\246') || (c >= '\248' && c <= '\254') -end -module Ext_utf8 : sig -#1 "ext_utf8.mli" -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type byte = Single of int | Cont of int | Leading of int * int | Invalid - -val classify : char -> byte - -val follow : string -> int -> int -> int -> int * int - -val next : string -> remaining:int -> int -> int -(** - return [-1] if failed -*) - -exception Invalid_utf8 of string - -val decode_utf8_string : string -> int list - -end = struct -#1 "ext_utf8.ml" -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type byte = Single of int | Cont of int | Leading of int * int | Invalid - -(** [classify chr] returns the {!byte} corresponding to [chr] *) -let classify chr = - let c = int_of_char chr in - (* Classify byte according to leftmost 0 bit *) - if c land 0b1000_0000 = 0 then Single c - else if (* c 0b0____*) - c land 0b0100_0000 = 0 then Cont (c land 0b0011_1111) - else if (* c 0b10___*) - c land 0b0010_0000 = 0 then Leading (1, c land 0b0001_1111) - else if (* c 0b110__*) - c land 0b0001_0000 = 0 then Leading (2, c land 0b0000_1111) - else if (* c 0b1110_ *) - c land 0b0000_1000 = 0 then Leading (3, c land 0b0000_0111) - else if (* c 0b1111_0___*) - c land 0b0000_0100 = 0 then Leading (4, c land 0b0000_0011) - else if (* c 0b1111_10__*) - c land 0b0000_0010 = 0 then Leading (5, c land 0b0000_0001) - (* c 0b1111_110__ *) - else Invalid - -exception Invalid_utf8 of string - -(* when the first char is [Leading], - TODO: need more error checking - when out of bond -*) -let rec follow s n (c : int) offset = - if n = 0 then (c, offset) - else - match classify s.[offset + 1] with - | Cont cc -> follow s (n - 1) ((c lsl 6) lor (cc land 0x3f)) (offset + 1) - | _ -> raise (Invalid_utf8 "Continuation byte expected") - -let rec next s ~remaining offset = - if remaining = 0 then offset - else - match classify s.[offset + 1] with - | Cont _cc -> next s ~remaining:(remaining - 1) (offset + 1) - | _ -> -1 - | exception _ -> -1 -(* it can happen when out of bound *) - -let decode_utf8_string s = - let lst = ref [] in - let add elem = lst := elem :: !lst in - let rec decode_utf8_cont s i s_len = - if i = s_len then () - else - match classify s.[i] with - | Single c -> - add c; - decode_utf8_cont s (i + 1) s_len - | Cont _ -> raise (Invalid_utf8 "Unexpected continuation byte") - | Leading (n, c) -> - let c', i' = follow s n c i in - add c'; - decode_utf8_cont s (i' + 1) s_len - | Invalid -> raise (Invalid_utf8 "Invalid byte") - in - decode_utf8_cont s 0 (String.length s); - List.rev !lst - -(** To decode {j||j} we need verify in the ast so that we have better error - location, then we do the decode later -*) - -(* let verify s loc = - assert false *) - end module Ast_utf8_string : sig #1 "ast_utf8_string.mli" diff --git a/lib/4.06.1/unstable/js_playground_compiler.ml b/lib/4.06.1/unstable/js_playground_compiler.ml index 6f7feeb88a..929a54aaa5 100644 --- a/lib/4.06.1/unstable/js_playground_compiler.ml +++ b/lib/4.06.1/unstable/js_playground_compiler.ml @@ -24863,6 +24863,183 @@ let lam_of_loc kind loc = let reset () = raise_count := 0 +end +module Ext_utf8 : sig +#1 "ext_utf8.mli" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +type byte = Single of int | Cont of int | Leading of int * int | Invalid + +val classify : char -> byte + +val follow : string -> int -> int -> int -> int * int + +val next : string -> remaining:int -> int -> int +(** + return [-1] if failed +*) + +exception Invalid_utf8 of string + +val decode_utf8_string : string -> int list + +val encode_codepoint : int -> string + +end = struct +#1 "ext_utf8.ml" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +type byte = Single of int | Cont of int | Leading of int * int | Invalid + +(** [classify chr] returns the {!byte} corresponding to [chr] *) +let classify chr = + let c = int_of_char chr in + (* Classify byte according to leftmost 0 bit *) + if c land 0b1000_0000 = 0 then Single c + else if (* c 0b0____*) + c land 0b0100_0000 = 0 then Cont (c land 0b0011_1111) + else if (* c 0b10___*) + c land 0b0010_0000 = 0 then Leading (1, c land 0b0001_1111) + else if (* c 0b110__*) + c land 0b0001_0000 = 0 then Leading (2, c land 0b0000_1111) + else if (* c 0b1110_ *) + c land 0b0000_1000 = 0 then Leading (3, c land 0b0000_0111) + else if (* c 0b1111_0___*) + c land 0b0000_0100 = 0 then Leading (4, c land 0b0000_0011) + else if (* c 0b1111_10__*) + c land 0b0000_0010 = 0 then Leading (5, c land 0b0000_0001) + (* c 0b1111_110__ *) + else Invalid + +exception Invalid_utf8 of string + +(* when the first char is [Leading], + TODO: need more error checking + when out of bond +*) +let rec follow s n (c : int) offset = + if n = 0 then (c, offset) + else + match classify s.[offset + 1] with + | Cont cc -> follow s (n - 1) ((c lsl 6) lor (cc land 0x3f)) (offset + 1) + | _ -> raise (Invalid_utf8 "Continuation byte expected") + +let rec next s ~remaining offset = + if remaining = 0 then offset + else + match classify s.[offset + 1] with + | Cont _cc -> next s ~remaining:(remaining - 1) (offset + 1) + | _ -> -1 + | exception _ -> -1 +(* it can happen when out of bound *) + +let decode_utf8_string s = + let lst = ref [] in + let add elem = lst := elem :: !lst in + let rec decode_utf8_cont s i s_len = + if i = s_len then () + else + match classify s.[i] with + | Single c -> + add c; + decode_utf8_cont s (i + 1) s_len + | Cont _ -> raise (Invalid_utf8 "Unexpected continuation byte") + | Leading (n, c) -> + let c', i' = follow s n c i in + add c'; + decode_utf8_cont s (i' + 1) s_len + | Invalid -> raise (Invalid_utf8 "Invalid byte") + in + decode_utf8_cont s 0 (String.length s); + List.rev !lst + +(** To decode {j||j} we need verify in the ast so that we have better error + location, then we do the decode later +*) + +(* let verify s loc = + assert false *) + +let encode_codepoint c = + let h2 = 0b1100_0000 in + let h3 = 0b1110_0000 in + let h4 = 0b1111_0000 in + let cont_mask = 0b0011_1111 in + if c <= 127 then ( + let bytes = (Bytes.create [@doesNotRaise]) 1 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr c); + Bytes.unsafe_to_string bytes) + else if c <= 2047 then ( + let bytes = (Bytes.create [@doesNotRaise]) 2 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h2 lor (c lsr 6))); + Bytes.unsafe_set bytes 1 + (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); + Bytes.unsafe_to_string bytes) + else if c <= 65535 then ( + let bytes = (Bytes.create [@doesNotRaise]) 3 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h3 lor (c lsr 12))); + Bytes.unsafe_set bytes 1 + (Char.unsafe_chr (0b1000_0000 lor ((c lsr 6) land cont_mask))); + Bytes.unsafe_set bytes 2 + (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); + Bytes.unsafe_to_string bytes) + else + (* if c <= max then *) + let bytes = (Bytes.create [@doesNotRaise]) 4 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h4 lor (c lsr 18))); + Bytes.unsafe_set bytes 1 + (Char.unsafe_chr (0b1000_0000 lor ((c lsr 12) land cont_mask))); + Bytes.unsafe_set bytes 2 + (Char.unsafe_chr (0b1000_0000 lor ((c lsr 6) land cont_mask))); + Bytes.unsafe_set bytes 3 + (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); + Bytes.unsafe_to_string bytes + + end module Ext_util : sig #1 "ext_util.mli" @@ -24947,7 +25124,7 @@ let string_of_int_as_char i = then Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) else - Printf.sprintf "\'\\%d\'" i + Printf.sprintf "\'%s\'" (Ext_utf8.encode_codepoint i) end module Pprintast : sig @@ -84085,145 +84262,6 @@ let is_lower_case c = || (c >= '\224' && c <= '\246') || (c >= '\248' && c <= '\254') -end -module Ext_utf8 : sig -#1 "ext_utf8.mli" -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type byte = Single of int | Cont of int | Leading of int * int | Invalid - -val classify : char -> byte - -val follow : string -> int -> int -> int -> int * int - -val next : string -> remaining:int -> int -> int -(** - return [-1] if failed -*) - -exception Invalid_utf8 of string - -val decode_utf8_string : string -> int list - -end = struct -#1 "ext_utf8.ml" -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type byte = Single of int | Cont of int | Leading of int * int | Invalid - -(** [classify chr] returns the {!byte} corresponding to [chr] *) -let classify chr = - let c = int_of_char chr in - (* Classify byte according to leftmost 0 bit *) - if c land 0b1000_0000 = 0 then Single c - else if (* c 0b0____*) - c land 0b0100_0000 = 0 then Cont (c land 0b0011_1111) - else if (* c 0b10___*) - c land 0b0010_0000 = 0 then Leading (1, c land 0b0001_1111) - else if (* c 0b110__*) - c land 0b0001_0000 = 0 then Leading (2, c land 0b0000_1111) - else if (* c 0b1110_ *) - c land 0b0000_1000 = 0 then Leading (3, c land 0b0000_0111) - else if (* c 0b1111_0___*) - c land 0b0000_0100 = 0 then Leading (4, c land 0b0000_0011) - else if (* c 0b1111_10__*) - c land 0b0000_0010 = 0 then Leading (5, c land 0b0000_0001) - (* c 0b1111_110__ *) - else Invalid - -exception Invalid_utf8 of string - -(* when the first char is [Leading], - TODO: need more error checking - when out of bond -*) -let rec follow s n (c : int) offset = - if n = 0 then (c, offset) - else - match classify s.[offset + 1] with - | Cont cc -> follow s (n - 1) ((c lsl 6) lor (cc land 0x3f)) (offset + 1) - | _ -> raise (Invalid_utf8 "Continuation byte expected") - -let rec next s ~remaining offset = - if remaining = 0 then offset - else - match classify s.[offset + 1] with - | Cont _cc -> next s ~remaining:(remaining - 1) (offset + 1) - | _ -> -1 - | exception _ -> -1 -(* it can happen when out of bound *) - -let decode_utf8_string s = - let lst = ref [] in - let add elem = lst := elem :: !lst in - let rec decode_utf8_cont s i s_len = - if i = s_len then () - else - match classify s.[i] with - | Single c -> - add c; - decode_utf8_cont s (i + 1) s_len - | Cont _ -> raise (Invalid_utf8 "Unexpected continuation byte") - | Leading (n, c) -> - let c', i' = follow s n c i in - add c'; - decode_utf8_cont s (i' + 1) s_len - | Invalid -> raise (Invalid_utf8 "Invalid byte") - in - decode_utf8_cont s 0 (String.length s); - List.rev !lst - -(** To decode {j||j} we need verify in the ast so that we have better error - location, then we do the decode later -*) - -(* let verify s loc = - assert false *) - end module Ast_utf8_string : sig #1 "ast_utf8_string.mli" diff --git a/lib/4.06.1/whole_compiler.ml b/lib/4.06.1/whole_compiler.ml index cdb5cd7f2d..289a4049af 100644 --- a/lib/4.06.1/whole_compiler.ml +++ b/lib/4.06.1/whole_compiler.ml @@ -176769,6 +176769,8 @@ exception Invalid_utf8 of string val decode_utf8_string : string -> int list +val encode_codepoint : int -> string + end = struct #1 "ext_utf8.ml" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. @@ -176866,6 +176868,42 @@ let decode_utf8_string s = (* let verify s loc = assert false *) +let encode_codepoint c = + let h2 = 0b1100_0000 in + let h3 = 0b1110_0000 in + let h4 = 0b1111_0000 in + let cont_mask = 0b0011_1111 in + if c <= 127 then ( + let bytes = (Bytes.create [@doesNotRaise]) 1 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr c); + Bytes.unsafe_to_string bytes) + else if c <= 2047 then ( + let bytes = (Bytes.create [@doesNotRaise]) 2 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h2 lor (c lsr 6))); + Bytes.unsafe_set bytes 1 + (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); + Bytes.unsafe_to_string bytes) + else if c <= 65535 then ( + let bytes = (Bytes.create [@doesNotRaise]) 3 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h3 lor (c lsr 12))); + Bytes.unsafe_set bytes 1 + (Char.unsafe_chr (0b1000_0000 lor ((c lsr 6) land cont_mask))); + Bytes.unsafe_set bytes 2 + (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); + Bytes.unsafe_to_string bytes) + else + (* if c <= max then *) + let bytes = (Bytes.create [@doesNotRaise]) 4 in + Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h4 lor (c lsr 18))); + Bytes.unsafe_set bytes 1 + (Char.unsafe_chr (0b1000_0000 lor ((c lsr 12) land cont_mask))); + Bytes.unsafe_set bytes 2 + (Char.unsafe_chr (0b1000_0000 lor ((c lsr 6) land cont_mask))); + Bytes.unsafe_set bytes 3 + (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); + Bytes.unsafe_to_string bytes + + end module Ast_utf8_string : sig #1 "ast_utf8_string.mli" @@ -179670,7 +179708,7 @@ let string_of_int_as_char i = then Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) else - Printf.sprintf "\'\\%d\'" i + Printf.sprintf "\'%s\'" (Ext_utf8.encode_codepoint i) end module Hash_set_gen From c291e07ca8c42014e3b36d1653580fe83dfa18ab Mon Sep 17 00:00:00 2001 From: butterunderflow Date: Mon, 31 Oct 2022 02:27:01 +0800 Subject: [PATCH 13/15] some refactor --- jscomp/ext/ext_utf8.ml | 1 + jscomp/ext/ext_util.ml | 20 +++++++++++++++----- 2 files changed, 16 insertions(+), 5 deletions(-) diff --git a/jscomp/ext/ext_utf8.ml b/jscomp/ext/ext_utf8.ml index 1eb4298fe8..0d02b2c573 100644 --- a/jscomp/ext/ext_utf8.ml +++ b/jscomp/ext/ext_utf8.ml @@ -94,6 +94,7 @@ let decode_utf8_string s = assert false *) let encode_codepoint c = + (* reused from syntax/src/res_utf8.ml *) let h2 = 0b1100_0000 in let h3 = 0b1110_0000 in let h4 = 0b1111_0000 in diff --git a/jscomp/ext/ext_util.ml b/jscomp/ext/ext_util.ml index 5e27465aec..e945e506f1 100644 --- a/jscomp/ext/ext_util.ml +++ b/jscomp/ext/ext_util.ml @@ -42,8 +42,18 @@ let stats_to_string (Array.to_list (Array.map string_of_int bucket_histogram))) let string_of_int_as_char i = - if i >= 0 && i <= 255 - then - Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) - else - Printf.sprintf "\'%s\'" (Ext_utf8.encode_codepoint i) + let str = match Char.unsafe_chr i with + | '\'' -> "\\'" + | '\\' -> "\\\\" + | '\n' -> "\\n" + | '\t' -> "\\t" + | '\r' -> "\\r" + | '\b' -> "\\b" + | ' ' .. '~' as c -> + let s = (Bytes.create [@doesNotRaise]) 1 in + Bytes.unsafe_set s 0 c; + Bytes.unsafe_to_string s + | _ -> Ext_utf8.encode_codepoint i + in + Printf.sprintf "\'%s\'" str + From 4b9cadb397bd37941a3af8872022fecd2595e74e Mon Sep 17 00:00:00 2001 From: butterunderflow Date: Mon, 31 Oct 2022 02:42:56 +0800 Subject: [PATCH 14/15] libs --- lib/4.06.1/rescript.ml | 21 +- lib/4.06.1/unstable/all_ounit_tests.ml | 21 +- lib/4.06.1/unstable/js_compiler.ml | 7012 ++++++++------- lib/4.06.1/unstable/js_playground_compiler.ml | 7836 ++++++++--------- lib/4.06.1/whole_compiler.ml | 7836 ++++++++--------- 5 files changed, 11172 insertions(+), 11554 deletions(-) diff --git a/lib/4.06.1/rescript.ml b/lib/4.06.1/rescript.ml index 58f603810a..e812aa3a81 100644 --- a/lib/4.06.1/rescript.ml +++ b/lib/4.06.1/rescript.ml @@ -6614,6 +6614,7 @@ let decode_utf8_string s = assert false *) let encode_codepoint c = + (* reused from syntax/src/res_utf8.ml *) let h2 = 0b1100_0000 in let h3 = 0b1110_0000 in let h4 = 0b1111_0000 in @@ -6729,11 +6730,21 @@ let stats_to_string (Array.to_list (Array.map string_of_int bucket_histogram))) let string_of_int_as_char i = - if i >= 0 && i <= 255 - then - Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) - else - Printf.sprintf "\'%s\'" (Ext_utf8.encode_codepoint i) + let str = match Char.unsafe_chr i with + | '\'' -> "\\'" + | '\\' -> "\\\\" + | '\n' -> "\\n" + | '\t' -> "\\t" + | '\r' -> "\\r" + | '\b' -> "\\b" + | ' ' .. '~' as c -> + let s = (Bytes.create [@doesNotRaise]) 1 in + Bytes.unsafe_set s 0 c; + Bytes.unsafe_to_string s + | _ -> Ext_utf8.encode_codepoint i + in + Printf.sprintf "\'%s\'" str + end module Hash_gen diff --git a/lib/4.06.1/unstable/all_ounit_tests.ml b/lib/4.06.1/unstable/all_ounit_tests.ml index aee6e430a4..8aee14b3f8 100644 --- a/lib/4.06.1/unstable/all_ounit_tests.ml +++ b/lib/4.06.1/unstable/all_ounit_tests.ml @@ -6530,6 +6530,7 @@ let decode_utf8_string s = assert false *) let encode_codepoint c = + (* reused from syntax/src/res_utf8.ml *) let h2 = 0b1100_0000 in let h3 = 0b1110_0000 in let h4 = 0b1111_0000 in @@ -6645,11 +6646,21 @@ let stats_to_string (Array.to_list (Array.map string_of_int bucket_histogram))) let string_of_int_as_char i = - if i >= 0 && i <= 255 - then - Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) - else - Printf.sprintf "\'%s\'" (Ext_utf8.encode_codepoint i) + let str = match Char.unsafe_chr i with + | '\'' -> "\\'" + | '\\' -> "\\\\" + | '\n' -> "\\n" + | '\t' -> "\\t" + | '\r' -> "\\r" + | '\b' -> "\\b" + | ' ' .. '~' as c -> + let s = (Bytes.create [@doesNotRaise]) 1 in + Bytes.unsafe_set s 0 c; + Bytes.unsafe_to_string s + | _ -> Ext_utf8.encode_codepoint i + in + Printf.sprintf "\'%s\'" str + end module Hash_gen diff --git a/lib/4.06.1/unstable/js_compiler.ml b/lib/4.06.1/unstable/js_compiler.ml index 3f7e870aa0..e2dddb990f 100644 --- a/lib/4.06.1/unstable/js_compiler.ml +++ b/lib/4.06.1/unstable/js_compiler.ml @@ -25005,6 +25005,7 @@ let decode_utf8_string s = assert false *) let encode_codepoint c = + (* reused from syntax/src/res_utf8.ml *) let h2 = 0b1100_0000 in let h3 = 0b1110_0000 in let h4 = 0b1111_0000 in @@ -25120,11 +25121,21 @@ let stats_to_string (Array.to_list (Array.map string_of_int bucket_histogram))) let string_of_int_as_char i = - if i >= 0 && i <= 255 - then - Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) - else - Printf.sprintf "\'%s\'" (Ext_utf8.encode_codepoint i) + let str = match Char.unsafe_chr i with + | '\'' -> "\\'" + | '\\' -> "\\\\" + | '\n' -> "\\n" + | '\t' -> "\\t" + | '\r' -> "\\r" + | '\b' -> "\\b" + | ' ' .. '~' as c -> + let s = (Bytes.create [@doesNotRaise]) 1 in + Bytes.unsafe_set s 0 c; + Bytes.unsafe_to_string s + | _ -> Ext_utf8.encode_codepoint i + in + Printf.sprintf "\'%s\'" str + end module Pprintast : sig @@ -52652,9 +52663,9 @@ type t = | Open | True | False - | Codepoint of { c : int; original : string } - | Int of { i : string; suffix : char option } - | Float of { f : string; suffix : char option } + | Codepoint of {c: int; original: string} + | Int of {i: string; suffix: char option} + | Float of {f: string; suffix: char option} | String of string | Lident of string | Uident of string @@ -52750,7 +52761,7 @@ let precedence = function | Land -> 3 | Equal | EqualEqual | EqualEqualEqual | LessThan | GreaterThan | BangEqual | BangEqualEqual | LessEqual | GreaterEqual | BarGreater -> - 4 + 4 | Plus | PlusDot | Minus | MinusDot | PlusPlus -> 5 | Asterisk | AsteriskDot | Forwardslash | ForwardslashDot -> 6 | Exponentiation -> 7 @@ -52763,15 +52774,15 @@ let toString = function | Open -> "open" | True -> "true" | False -> "false" - | Codepoint { original } -> "codepoint '" ^ original ^ "'" + | Codepoint {original} -> "codepoint '" ^ original ^ "'" | String s -> "string \"" ^ s ^ "\"" | Lident str -> str | Uident str -> str | Dot -> "." | DotDot -> ".." | DotDotDot -> "..." - | Int { i } -> "int " ^ i - | Float { f } -> "Float: " ^ f + | Int {i} -> "int " ^ i + | Float {f} -> "Float: " ^ f | Bang -> "!" | Semicolon -> ";" | Let -> "let" @@ -52891,7 +52902,7 @@ let isKeyword = function | Await | And | As | Assert | Constraint | Else | Exception | External | False | For | If | In | Include | Land | Lazy | Let | List | Lor | Module | Mutable | Of | Open | Private | Rec | Switch | True | Try | Typ | When | While -> - true + true | _ -> false let lookupKeyword str = @@ -53158,7 +53169,7 @@ let addParens doc = (Doc.concat [ Doc.lparen; - Doc.indent (Doc.concat [ Doc.softLine; doc ]); + Doc.indent (Doc.concat [Doc.softLine; doc]); Doc.softLine; Doc.rparen; ]) @@ -53168,12 +53179,12 @@ let addBraces doc = (Doc.concat [ Doc.lbrace; - Doc.indent (Doc.concat [ Doc.softLine; doc ]); + Doc.indent (Doc.concat [Doc.softLine; doc]); Doc.softLine; Doc.rbrace; ]) -let addAsync doc = Doc.concat [ Doc.text "async "; doc ] +let addAsync doc = Doc.concat [Doc.text "async "; doc] let getFirstLeadingComment tbl loc = match Hashtbl.find tbl.CommentTable.leading loc with @@ -53190,8 +53201,8 @@ let hasLeadingLineComment tbl loc = let hasCommentBelow tbl loc = match Hashtbl.find tbl.CommentTable.trailing loc with | comment :: _ -> - let commentLoc = Comment.loc comment in - commentLoc.Location.loc_start.pos_lnum > loc.Location.loc_end.pos_lnum + let commentLoc = Comment.loc comment in + commentLoc.Location.loc_start.pos_lnum > loc.Location.loc_end.pos_lnum | [] -> false | exception Not_found -> false @@ -53199,10 +53210,10 @@ let hasNestedJsxOrMoreThanOneChild expr = let rec loop inRecursion expr = match expr.Parsetree.pexp_desc with | Pexp_construct - ( { txt = Longident.Lident "::" }, - Some { pexp_desc = Pexp_tuple [ hd; tail ] } ) -> - if inRecursion || ParsetreeViewer.isJsxExpression hd then true - else loop true tail + ({txt = Longident.Lident "::"}, Some {pexp_desc = Pexp_tuple [hd; tail]}) + -> + if inRecursion || ParsetreeViewer.isJsxExpression hd then true + else loop true tail | _ -> false in loop false expr @@ -53233,40 +53244,42 @@ let printMultilineCommentContent txt = let rec indentStars lines acc = match lines with | [] -> Doc.nil - | [ lastLine ] -> - let line = String.trim lastLine in - let doc = Doc.text (" " ^ line) in - let trailingSpace = if line = "" then Doc.nil else Doc.space in - List.rev (trailingSpace :: doc :: acc) |> Doc.concat + | [lastLine] -> + let line = String.trim lastLine in + let doc = Doc.text (" " ^ line) in + let trailingSpace = if line = "" then Doc.nil else Doc.space in + List.rev (trailingSpace :: doc :: acc) |> Doc.concat | line :: lines -> - let line = String.trim line in - if line != "" && String.unsafe_get line 0 == '*' then - let doc = Doc.text (" " ^ line) in - indentStars lines (Doc.hardLine :: doc :: acc) - else - let trailingSpace = - let len = String.length txt in - if len > 0 && String.unsafe_get txt (len - 1) = ' ' then Doc.space - else Doc.nil - in - let content = Comment.trimSpaces txt in - Doc.concat [ Doc.text content; trailingSpace ] + let line = String.trim line in + if line != "" && String.unsafe_get line 0 == '*' then + let doc = Doc.text (" " ^ line) in + indentStars lines (Doc.hardLine :: doc :: acc) + else + let trailingSpace = + let len = String.length txt in + if len > 0 && String.unsafe_get txt (len - 1) = ' ' then Doc.space + else Doc.nil + in + let content = Comment.trimSpaces txt in + Doc.concat [Doc.text content; trailingSpace] in let lines = String.split_on_char '\n' txt in match lines with | [] -> Doc.text "/* */" - | [ line ] -> - Doc.concat - [ Doc.text "/* "; Doc.text (Comment.trimSpaces line); Doc.text " */" ] + | [line] -> + Doc.concat + [Doc.text "/* "; Doc.text (Comment.trimSpaces line); Doc.text " */"] | first :: rest -> - let firstLine = Comment.trimSpaces first in - Doc.concat - [ - Doc.text "/*"; - (match firstLine with "" | "*" -> Doc.nil | _ -> Doc.space); - indentStars rest [ Doc.hardLine; Doc.text firstLine ]; - Doc.text "*/"; - ] + let firstLine = Comment.trimSpaces first in + Doc.concat + [ + Doc.text "/*"; + (match firstLine with + | "" | "*" -> Doc.nil + | _ -> Doc.space); + indentStars rest [Doc.hardLine; Doc.text firstLine]; + Doc.text "*/"; + ] let printTrailingComment (prevLoc : Location.t) (nodeLoc : Location.t) comment = let singleLine = Comment.isSingleLineComment comment in @@ -53294,8 +53307,8 @@ let printTrailingComment (prevLoc : Location.t) (nodeLoc : Location.t) comment = content; ]); ] - else if not singleLine then Doc.concat [ Doc.space; content ] - else Doc.lineSuffix (Doc.concat [ Doc.space; content ]) + else if not singleLine then Doc.concat [Doc.space; content] + else Doc.lineSuffix (Doc.concat [Doc.space; content]) let printLeadingComment ?nextComment comment = let singleLine = Comment.isSingleLineComment comment in @@ -53307,28 +53320,28 @@ let printLeadingComment ?nextComment comment = let separator = Doc.concat [ - (if singleLine then Doc.concat [ Doc.hardLine; Doc.breakParent ] + (if singleLine then Doc.concat [Doc.hardLine; Doc.breakParent] else Doc.nil); (match nextComment with | Some next -> - let nextLoc = Comment.loc next in - let currLoc = Comment.loc comment in - let diff = - nextLoc.Location.loc_start.pos_lnum - - currLoc.Location.loc_end.pos_lnum - in - let nextSingleLine = Comment.isSingleLineComment next in - if singleLine && nextSingleLine then - if diff > 1 then Doc.hardLine else Doc.nil - else if singleLine && not nextSingleLine then - if diff > 1 then Doc.hardLine else Doc.nil - else if diff > 1 then Doc.concat [ Doc.hardLine; Doc.hardLine ] - else if diff == 1 then Doc.hardLine - else Doc.space + let nextLoc = Comment.loc next in + let currLoc = Comment.loc comment in + let diff = + nextLoc.Location.loc_start.pos_lnum + - currLoc.Location.loc_end.pos_lnum + in + let nextSingleLine = Comment.isSingleLineComment next in + if singleLine && nextSingleLine then + if diff > 1 then Doc.hardLine else Doc.nil + else if singleLine && not nextSingleLine then + if diff > 1 then Doc.hardLine else Doc.nil + else if diff > 1 then Doc.concat [Doc.hardLine; Doc.hardLine] + else if diff == 1 then Doc.hardLine + else Doc.space | None -> Doc.nil); ] in - Doc.concat [ content; separator ] + Doc.concat [content; separator] (* This function is used for printing comments inside an empty block *) let printCommentsInside cmtTbl loc = @@ -53344,98 +53357,96 @@ let printCommentsInside cmtTbl loc = let rec loop acc comments = match comments with | [] -> Doc.nil - | [ comment ] -> - let cmtDoc = printComment comment in - let cmtsDoc = Doc.concat (Doc.softLine :: List.rev (cmtDoc :: acc)) in - let doc = - Doc.breakableGroup ~forceBreak - (Doc.concat - [ Doc.ifBreaks (Doc.indent cmtsDoc) cmtsDoc; Doc.softLine ]) - in - doc + | [comment] -> + let cmtDoc = printComment comment in + let cmtsDoc = Doc.concat (Doc.softLine :: List.rev (cmtDoc :: acc)) in + let doc = + Doc.breakableGroup ~forceBreak + (Doc.concat [Doc.ifBreaks (Doc.indent cmtsDoc) cmtsDoc; Doc.softLine]) + in + doc | comment :: rest -> - let cmtDoc = Doc.concat [ printComment comment; Doc.line ] in - loop (cmtDoc :: acc) rest + let cmtDoc = Doc.concat [printComment comment; Doc.line] in + loop (cmtDoc :: acc) rest in match Hashtbl.find cmtTbl.CommentTable.inside loc with | exception Not_found -> Doc.nil | comments -> - Hashtbl.remove cmtTbl.inside loc; - loop [] comments + Hashtbl.remove cmtTbl.inside loc; + loop [] comments (* This function is used for printing comments inside an empty file *) let printCommentsInsideFile cmtTbl = let rec loop acc comments = match comments with | [] -> Doc.nil - | [ comment ] -> - let cmtDoc = printLeadingComment comment in - let doc = - Doc.group (Doc.concat [ Doc.concat (List.rev (cmtDoc :: acc)) ]) - in - doc + | [comment] -> + let cmtDoc = printLeadingComment comment in + let doc = + Doc.group (Doc.concat [Doc.concat (List.rev (cmtDoc :: acc))]) + in + doc | comment :: (nextComment :: _comments as rest) -> - let cmtDoc = printLeadingComment ~nextComment comment in - loop (cmtDoc :: acc) rest + let cmtDoc = printLeadingComment ~nextComment comment in + loop (cmtDoc :: acc) rest in match Hashtbl.find cmtTbl.CommentTable.inside Location.none with | exception Not_found -> Doc.nil | comments -> - Hashtbl.remove cmtTbl.inside Location.none; - Doc.group (loop [] comments) + Hashtbl.remove cmtTbl.inside Location.none; + Doc.group (loop [] comments) let printLeadingComments node tbl loc = let rec loop acc comments = match comments with | [] -> node - | [ comment ] -> - let cmtDoc = printLeadingComment comment in - let diff = - loc.Location.loc_start.pos_lnum - - (Comment.loc comment).Location.loc_end.pos_lnum - in - let separator = - if Comment.isSingleLineComment comment then - if diff > 1 then Doc.hardLine else Doc.nil - else if diff == 0 then Doc.space - else if diff > 1 then Doc.concat [ Doc.hardLine; Doc.hardLine ] - else Doc.hardLine - in - let doc = - Doc.group - (Doc.concat - [ Doc.concat (List.rev (cmtDoc :: acc)); separator; node ]) - in - doc + | [comment] -> + let cmtDoc = printLeadingComment comment in + let diff = + loc.Location.loc_start.pos_lnum + - (Comment.loc comment).Location.loc_end.pos_lnum + in + let separator = + if Comment.isSingleLineComment comment then + if diff > 1 then Doc.hardLine else Doc.nil + else if diff == 0 then Doc.space + else if diff > 1 then Doc.concat [Doc.hardLine; Doc.hardLine] + else Doc.hardLine + in + let doc = + Doc.group + (Doc.concat [Doc.concat (List.rev (cmtDoc :: acc)); separator; node]) + in + doc | comment :: (nextComment :: _comments as rest) -> - let cmtDoc = printLeadingComment ~nextComment comment in - loop (cmtDoc :: acc) rest + let cmtDoc = printLeadingComment ~nextComment comment in + loop (cmtDoc :: acc) rest in match Hashtbl.find tbl loc with | exception Not_found -> node | comments -> - (* Remove comments from tbl: Some ast nodes have the same location. - * We only want to print comments once *) - Hashtbl.remove tbl loc; - loop [] comments + (* Remove comments from tbl: Some ast nodes have the same location. + * We only want to print comments once *) + Hashtbl.remove tbl loc; + loop [] comments let printTrailingComments node tbl loc = let rec loop prev acc comments = match comments with | [] -> Doc.concat (List.rev acc) | comment :: comments -> - let cmtDoc = printTrailingComment prev loc comment in - loop (Comment.loc comment) (cmtDoc :: acc) comments + let cmtDoc = printTrailingComment prev loc comment in + loop (Comment.loc comment) (cmtDoc :: acc) comments in match Hashtbl.find tbl loc with | exception Not_found -> node | [] -> node | _first :: _ as comments -> - (* Remove comments from tbl: Some ast nodes have the same location. - * We only want to print comments once *) - Hashtbl.remove tbl loc; - let cmtsDoc = loop loc [] comments in - Doc.concat [ node; cmtsDoc ] + (* Remove comments from tbl: Some ast nodes have the same location. + * We only want to print comments once *) + Hashtbl.remove tbl loc; + let cmtsDoc = loop loc [] comments in + Doc.concat [node; cmtsDoc] let printComments doc (tbl : CommentTable.t) loc = let docWithLeadingComments = printLeadingComments doc tbl.leading loc in @@ -53446,68 +53457,68 @@ let printList ~getLoc ~nodes ~print ?(forceBreak = false) t = match nodes with | [] -> (prevLoc, Doc.concat (List.rev acc)) | node :: nodes -> - let loc = getLoc node in - let startPos = - match getFirstLeadingComment t loc with - | None -> loc.loc_start - | Some comment -> (Comment.loc comment).loc_start - in - let sep = - if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then - Doc.concat [ Doc.hardLine; Doc.hardLine ] - else Doc.hardLine - in - let doc = printComments (print node t) t loc in - loop loc (doc :: sep :: acc) nodes + let loc = getLoc node in + let startPos = + match getFirstLeadingComment t loc with + | None -> loc.loc_start + | Some comment -> (Comment.loc comment).loc_start + in + let sep = + if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then + Doc.concat [Doc.hardLine; Doc.hardLine] + else Doc.hardLine + in + let doc = printComments (print node t) t loc in + loop loc (doc :: sep :: acc) nodes in match nodes with | [] -> Doc.nil | node :: nodes -> - let firstLoc = getLoc node in - let doc = printComments (print node t) t firstLoc in - let lastLoc, docs = loop firstLoc [ doc ] nodes in - let forceBreak = - forceBreak || firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak docs + let firstLoc = getLoc node in + let doc = printComments (print node t) t firstLoc in + let lastLoc, docs = loop firstLoc [doc] nodes in + let forceBreak = + forceBreak || firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak docs let printListi ~getLoc ~nodes ~print ?(forceBreak = false) t = let rec loop i (prevLoc : Location.t) acc nodes = match nodes with | [] -> (prevLoc, Doc.concat (List.rev acc)) | node :: nodes -> - let loc = getLoc node in - let startPos = - match getFirstLeadingComment t loc with - | None -> loc.loc_start - | Some comment -> (Comment.loc comment).loc_start - in - let sep = - if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then - Doc.concat [ Doc.hardLine; Doc.hardLine ] - else Doc.line - in - let doc = printComments (print node t i) t loc in - loop (i + 1) loc (doc :: sep :: acc) nodes + let loc = getLoc node in + let startPos = + match getFirstLeadingComment t loc with + | None -> loc.loc_start + | Some comment -> (Comment.loc comment).loc_start + in + let sep = + if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then + Doc.concat [Doc.hardLine; Doc.hardLine] + else Doc.line + in + let doc = printComments (print node t i) t loc in + loop (i + 1) loc (doc :: sep :: acc) nodes in match nodes with | [] -> Doc.nil | node :: nodes -> - let firstLoc = getLoc node in - let doc = printComments (print node t 0) t firstLoc in - let lastLoc, docs = loop 1 firstLoc [ doc ] nodes in - let forceBreak = - forceBreak || firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak docs + let firstLoc = getLoc node in + let doc = printComments (print node t 0) t firstLoc in + let lastLoc, docs = loop 1 firstLoc [doc] nodes in + let forceBreak = + forceBreak || firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak docs let rec printLongidentAux accu = function | Longident.Lident s -> Doc.text s :: accu | Ldot (lid, s) -> printLongidentAux (Doc.text s :: accu) lid | Lapply (lid1, lid2) -> - let d1 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid1) in - let d2 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid2) in - Doc.concat [ d1; Doc.lparen; d2; Doc.rparen ] :: accu + let d1 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid1) in + let d2 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid2) in + Doc.concat [d1; Doc.lparen; d2; Doc.rparen] :: accu let printLongident = function | Longident.Lident txt -> Doc.text txt @@ -53535,7 +53546,7 @@ let classifyIdentContent ?(allowUident = false) txt = let printIdentLike ?allowUident txt = match classifyIdentContent ?allowUident txt with - | ExoticIdent -> Doc.concat [ Doc.text "\\\""; Doc.text txt; Doc.text "\"" ] + | ExoticIdent -> Doc.concat [Doc.text "\\\""; Doc.text txt; Doc.text "\""] | NormalIdent -> Doc.text txt let rec unsafe_for_all_range s ~start ~finish p = @@ -53556,7 +53567,10 @@ let isValidNumericPolyvarNumber (x : string) = a <= 57 && if len > 1 then - a > 48 && for_all_from x 1 (function '0' .. '9' -> true | _ -> false) + a > 48 + && for_all_from x 1 (function + | '0' .. '9' -> true + | _ -> false) else a >= 48 (* Exotic identifiers in poly-vars have a "lighter" syntax: #"ease-in" *) @@ -53565,11 +53579,11 @@ let printPolyVarIdent txt = if isValidNumericPolyvarNumber txt then Doc.text txt else match classifyIdentContent ~allowUident:true txt with - | ExoticIdent -> Doc.concat [ Doc.text "\""; Doc.text txt; Doc.text "\"" ] + | ExoticIdent -> Doc.concat [Doc.text "\""; Doc.text txt; Doc.text "\""] | NormalIdent -> ( - match txt with - | "" -> Doc.concat [ Doc.text "\""; Doc.text txt; Doc.text "\"" ] - | _ -> Doc.text txt) + match txt with + | "" -> Doc.concat [Doc.text "\""; Doc.text txt; Doc.text "\""] + | _ -> Doc.text txt) let printLident l = let flatLidOpt lid = @@ -53583,18 +53597,18 @@ let printLident l = match l with | Longident.Lident txt -> printIdentLike txt | Longident.Ldot (path, txt) -> - let doc = - match flatLidOpt path with - | Some txts -> - Doc.concat - [ - Doc.join ~sep:Doc.dot (List.map Doc.text txts); - Doc.dot; - printIdentLike txt; - ] - | None -> Doc.text "printLident: Longident.Lapply is not supported" - in - doc + let doc = + match flatLidOpt path with + | Some txts -> + Doc.concat + [ + Doc.join ~sep:Doc.dot (List.map Doc.text txts); + Doc.dot; + printIdentLike txt; + ] + | None -> Doc.text "printLident: Longident.Lapply is not supported" + in + doc | Lapply (_, _) -> Doc.text "printLident: Longident.Lapply is not supported" let printLongidentLocation l cmtTbl = @@ -53622,42 +53636,42 @@ let printStringContents txt = let printConstant ?(templateLiteral = false) c = match c with | Parsetree.Pconst_integer (s, suffix) -> ( - match suffix with - | Some c -> Doc.text (s ^ Char.escaped c) - | None -> Doc.text s) + match suffix with + | Some c -> Doc.text (s ^ Char.escaped c) + | None -> Doc.text s) | Pconst_string (txt, None) -> - Doc.concat [ Doc.text "\""; printStringContents txt; Doc.text "\"" ] + Doc.concat [Doc.text "\""; printStringContents txt; Doc.text "\""] | Pconst_string (txt, Some prefix) -> - if prefix = "INTERNAL_RES_CHAR_CONTENTS" then - Doc.concat [ Doc.text "'"; Doc.text txt; Doc.text "'" ] - else - let lquote, rquote = - if templateLiteral then ("`", "`") else ("\"", "\"") - in - Doc.concat - [ - (if prefix = "js" then Doc.nil else Doc.text prefix); - Doc.text lquote; - printStringContents txt; - Doc.text rquote; - ] + if prefix = "INTERNAL_RES_CHAR_CONTENTS" then + Doc.concat [Doc.text "'"; Doc.text txt; Doc.text "'"] + else + let lquote, rquote = + if templateLiteral then ("`", "`") else ("\"", "\"") + in + Doc.concat + [ + (if prefix = "js" then Doc.nil else Doc.text prefix); + Doc.text lquote; + printStringContents txt; + Doc.text rquote; + ] | Pconst_float (s, _) -> Doc.text s | Pconst_char c -> - let str = - match Char.unsafe_chr c with - | '\'' -> "\\'" - | '\\' -> "\\\\" - | '\n' -> "\\n" - | '\t' -> "\\t" - | '\r' -> "\\r" - | '\b' -> "\\b" - | ' ' .. '~' as c -> - let s = (Bytes.create [@doesNotRaise]) 1 in - Bytes.unsafe_set s 0 c; - Bytes.unsafe_to_string s - | _ -> Res_utf8.encodeCodePoint c - in - Doc.text ("'" ^ str ^ "'") + let str = + match Char.unsafe_chr c with + | '\'' -> "\\'" + | '\\' -> "\\\\" + | '\n' -> "\\n" + | '\t' -> "\\t" + | '\r' -> "\\r" + | '\b' -> "\\b" + | ' ' .. '~' as c -> + let s = (Bytes.create [@doesNotRaise]) 1 in + Bytes.unsafe_set s 0 c; + Bytes.unsafe_to_string s + | _ -> Res_utf8.encodeCodePoint c + in + Doc.text ("'" ^ str ^ "'") let printOptionalLabel attrs = if Res_parsetree_viewer.hasOptionalAttribute attrs then Doc.text "?" @@ -53669,66 +53683,66 @@ let rec printStructure ~customLayout (s : Parsetree.structure) t = match s with | [] -> printCommentsInsideFile t | structure -> - printList - ~getLoc:(fun s -> s.Parsetree.pstr_loc) - ~nodes:structure - ~print:(printStructureItem ~customLayout) - t + printList + ~getLoc:(fun s -> s.Parsetree.pstr_loc) + ~nodes:structure + ~print:(printStructureItem ~customLayout) + t and printStructureItem ~customLayout (si : Parsetree.structure_item) cmtTbl = match si.pstr_desc with | Pstr_value (rec_flag, valueBindings) -> - let recFlag = - match rec_flag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - printValueBindings ~customLayout ~recFlag valueBindings cmtTbl + let recFlag = + match rec_flag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + printValueBindings ~customLayout ~recFlag valueBindings cmtTbl | Pstr_type (recFlag, typeDeclarations) -> - let recFlag = - match recFlag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - printTypeDeclarations ~customLayout ~recFlag typeDeclarations cmtTbl + let recFlag = + match recFlag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + printTypeDeclarations ~customLayout ~recFlag typeDeclarations cmtTbl | Pstr_primitive valueDescription -> - printValueDescription ~customLayout valueDescription cmtTbl + printValueDescription ~customLayout valueDescription cmtTbl | Pstr_eval (expr, attrs) -> - let exprDoc = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.structureExpr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat [ printAttributes ~customLayout attrs cmtTbl; exprDoc ] + let exprDoc = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.structureExpr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [printAttributes ~customLayout attrs cmtTbl; exprDoc] | Pstr_attribute attr -> - fst (printAttribute ~customLayout ~standalone:true attr cmtTbl) + fst (printAttribute ~customLayout ~standalone:true attr cmtTbl) | Pstr_extension (extension, attrs) -> - Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - Doc.concat - [ printExtension ~customLayout ~atModuleLvl:true extension cmtTbl ]; - ] + Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + Doc.concat + [printExtension ~customLayout ~atModuleLvl:true extension cmtTbl]; + ] | Pstr_include includeDeclaration -> - printIncludeDeclaration ~customLayout includeDeclaration cmtTbl + printIncludeDeclaration ~customLayout includeDeclaration cmtTbl | Pstr_open openDescription -> - printOpenDescription ~customLayout openDescription cmtTbl + printOpenDescription ~customLayout openDescription cmtTbl | Pstr_modtype modTypeDecl -> - printModuleTypeDeclaration ~customLayout modTypeDecl cmtTbl + printModuleTypeDeclaration ~customLayout modTypeDecl cmtTbl | Pstr_module moduleBinding -> - printModuleBinding ~customLayout ~isRec:false moduleBinding cmtTbl 0 + printModuleBinding ~customLayout ~isRec:false moduleBinding cmtTbl 0 | Pstr_recmodule moduleBindings -> - printListi - ~getLoc:(fun mb -> mb.Parsetree.pmb_loc) - ~nodes:moduleBindings - ~print:(printModuleBinding ~customLayout ~isRec:true) - cmtTbl + printListi + ~getLoc:(fun mb -> mb.Parsetree.pmb_loc) + ~nodes:moduleBindings + ~print:(printModuleBinding ~customLayout ~isRec:true) + cmtTbl | Pstr_exception extensionConstructor -> - printExceptionDef ~customLayout extensionConstructor cmtTbl + printExceptionDef ~customLayout extensionConstructor cmtTbl | Pstr_typext typeExtension -> - printTypeExtension ~customLayout typeExtension cmtTbl + printTypeExtension ~customLayout typeExtension cmtTbl | Pstr_class _ | Pstr_class_type _ -> Doc.nil and printTypeExtension ~customLayout (te : Parsetree.type_extension) cmtTbl = @@ -53740,14 +53754,13 @@ and printTypeExtension ~customLayout (te : Parsetree.type_extension) cmtTbl = let forceBreak = match (ecs, List.rev ecs) with | first :: _, last :: _ -> - first.pext_loc.loc_start.pos_lnum - > te.ptyext_path.loc.loc_end.pos_lnum - || first.pext_loc.loc_start.pos_lnum < last.pext_loc.loc_end.pos_lnum + first.pext_loc.loc_start.pos_lnum > te.ptyext_path.loc.loc_end.pos_lnum + || first.pext_loc.loc_start.pos_lnum < last.pext_loc.loc_end.pos_lnum | _ -> false in let privateFlag = match te.ptyext_private with - | Asttypes.Private -> Doc.concat [ Doc.text "private"; Doc.line ] + | Asttypes.Private -> Doc.concat [Doc.text "private"; Doc.line] | Public -> Doc.nil in let rows = @@ -53784,15 +53797,14 @@ and printModuleBinding ~customLayout ~isRec moduleBinding cmtTbl i = let prefix = if i = 0 then Doc.concat - [ Doc.text "module "; (if isRec then Doc.text "rec " else Doc.nil) ] + [Doc.text "module "; (if isRec then Doc.text "rec " else Doc.nil)] else Doc.text "and " in let modExprDoc, modConstraintDoc = match moduleBinding.pmb_expr with - | { pmod_desc = Pmod_constraint (modExpr, modType) } -> - ( printModExpr ~customLayout modExpr cmtTbl, - Doc.concat - [ Doc.text ": "; printModType ~customLayout modType cmtTbl ] ) + | {pmod_desc = Pmod_constraint (modExpr, modType)} -> + ( printModExpr ~customLayout modExpr cmtTbl, + Doc.concat [Doc.text ": "; printModType ~customLayout modType cmtTbl] ) | modExpr -> (printModExpr ~customLayout modExpr cmtTbl, Doc.nil) in let modName = @@ -53827,160 +53839,153 @@ and printModuleTypeDeclaration ~customLayout (match modTypeDecl.pmtd_type with | None -> Doc.nil | Some modType -> - Doc.concat - [ Doc.text " = "; printModType ~customLayout modType cmtTbl ]); + Doc.concat [Doc.text " = "; printModType ~customLayout modType cmtTbl]); ] and printModType ~customLayout modType cmtTbl = let modTypeDoc = match modType.pmty_desc with | Parsetree.Pmty_ident longident -> - Doc.concat - [ - printAttributes ~customLayout ~loc:longident.loc - modType.pmty_attributes cmtTbl; - printLongidentLocation longident cmtTbl; - ] + Doc.concat + [ + printAttributes ~customLayout ~loc:longident.loc + modType.pmty_attributes cmtTbl; + printLongidentLocation longident cmtTbl; + ] | Pmty_signature [] -> - if hasCommentsInside cmtTbl modType.pmty_loc then - let doc = printCommentsInside cmtTbl modType.pmty_loc in - Doc.concat [ Doc.lbrace; doc; Doc.rbrace ] - else - let shouldBreak = - modType.pmty_loc.loc_start.pos_lnum - < modType.pmty_loc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak:shouldBreak - (Doc.concat [ Doc.lbrace; Doc.softLine; Doc.softLine; Doc.rbrace ]) + if hasCommentsInside cmtTbl modType.pmty_loc then + let doc = printCommentsInside cmtTbl modType.pmty_loc in + Doc.concat [Doc.lbrace; doc; Doc.rbrace] + else + let shouldBreak = + modType.pmty_loc.loc_start.pos_lnum + < modType.pmty_loc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak:shouldBreak + (Doc.concat [Doc.lbrace; Doc.softLine; Doc.softLine; Doc.rbrace]) | Pmty_signature signature -> - let signatureDoc = - Doc.breakableGroup ~forceBreak:true + let signatureDoc = + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [Doc.line; printSignature ~customLayout signature cmtTbl]); + Doc.line; + Doc.rbrace; + ]) + in + Doc.concat + [ + printAttributes ~customLayout modType.pmty_attributes cmtTbl; + signatureDoc; + ] + | Pmty_functor _ -> + let parameters, returnType = ParsetreeViewer.functorType modType in + let parametersDoc = + match parameters with + | [] -> Doc.nil + | [(attrs, {Location.txt = "_"; loc}, Some modType)] -> + let cmtLoc = + {loc with loc_end = modType.Parsetree.pmty_loc.loc_end} + in + let attrs = printAttributes ~customLayout attrs cmtTbl in + let doc = + Doc.concat [attrs; printModType ~customLayout modType cmtTbl] + in + printComments doc cmtTbl cmtLoc + | params -> + Doc.group (Doc.concat [ - Doc.lbrace; + Doc.lparen; Doc.indent (Doc.concat [ - Doc.line; printSignature ~customLayout signature cmtTbl; + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun (attrs, lbl, modType) -> + let cmtLoc = + match modType with + | None -> lbl.Asttypes.loc + | Some modType -> + { + lbl.Asttypes.loc with + loc_end = + modType.Parsetree.pmty_loc.loc_end; + } + in + let attrs = + printAttributes ~customLayout attrs cmtTbl + in + let lblDoc = + if lbl.Location.txt = "_" || lbl.txt = "*" then + Doc.nil + else + let doc = Doc.text lbl.txt in + printComments doc cmtTbl lbl.loc + in + let doc = + Doc.concat + [ + attrs; + lblDoc; + (match modType with + | None -> Doc.nil + | Some modType -> + Doc.concat + [ + (if lbl.txt = "_" then Doc.nil + else Doc.text ": "); + printModType ~customLayout modType + cmtTbl; + ]); + ] + in + printComments doc cmtTbl cmtLoc) + params); ]); - Doc.line; - Doc.rbrace; + Doc.trailingComma; + Doc.softLine; + Doc.rparen; ]) - in - Doc.concat - [ - printAttributes ~customLayout modType.pmty_attributes cmtTbl; - signatureDoc; - ] - | Pmty_functor _ -> - let parameters, returnType = ParsetreeViewer.functorType modType in - let parametersDoc = - match parameters with - | [] -> Doc.nil - | [ (attrs, { Location.txt = "_"; loc }, Some modType) ] -> - let cmtLoc = - { loc with loc_end = modType.Parsetree.pmty_loc.loc_end } - in - let attrs = printAttributes ~customLayout attrs cmtTbl in - let doc = - Doc.concat [ attrs; printModType ~customLayout modType cmtTbl ] - in - printComments doc cmtTbl cmtLoc - | params -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun (attrs, lbl, modType) -> - let cmtLoc = - match modType with - | None -> lbl.Asttypes.loc - | Some modType -> - { - lbl.Asttypes.loc with - loc_end = - modType.Parsetree.pmty_loc.loc_end; - } - in - let attrs = - printAttributes ~customLayout attrs cmtTbl - in - let lblDoc = - if lbl.Location.txt = "_" || lbl.txt = "*" - then Doc.nil - else - let doc = Doc.text lbl.txt in - printComments doc cmtTbl lbl.loc - in - let doc = - Doc.concat - [ - attrs; - lblDoc; - (match modType with - | None -> Doc.nil - | Some modType -> - Doc.concat - [ - (if lbl.txt = "_" then Doc.nil - else Doc.text ": "); - printModType ~customLayout - modType cmtTbl; - ]); - ] - in - printComments doc cmtTbl cmtLoc) - params); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) - in - let returnDoc = - let doc = printModType ~customLayout returnType cmtTbl in - if Parens.modTypeFunctorReturn returnType then addParens doc else doc - in - Doc.group - (Doc.concat - [ - parametersDoc; - Doc.group (Doc.concat [ Doc.text " =>"; Doc.line; returnDoc ]); - ]) + in + let returnDoc = + let doc = printModType ~customLayout returnType cmtTbl in + if Parens.modTypeFunctorReturn returnType then addParens doc else doc + in + Doc.group + (Doc.concat + [ + parametersDoc; + Doc.group (Doc.concat [Doc.text " =>"; Doc.line; returnDoc]); + ]) | Pmty_typeof modExpr -> - Doc.concat - [ - Doc.text "module type of "; - printModExpr ~customLayout modExpr cmtTbl; - ] + Doc.concat + [Doc.text "module type of "; printModExpr ~customLayout modExpr cmtTbl] | Pmty_extension extension -> - printExtension ~customLayout ~atModuleLvl:false extension cmtTbl + printExtension ~customLayout ~atModuleLvl:false extension cmtTbl | Pmty_alias longident -> - Doc.concat - [ Doc.text "module "; printLongidentLocation longident cmtTbl ] + Doc.concat [Doc.text "module "; printLongidentLocation longident cmtTbl] | Pmty_with (modType, withConstraints) -> - let operand = - let doc = printModType ~customLayout modType cmtTbl in - if Parens.modTypeWithOperand modType then addParens doc else doc - in - Doc.group - (Doc.concat - [ - operand; - Doc.indent - (Doc.concat - [ - Doc.line; - printWithConstraints ~customLayout withConstraints cmtTbl; - ]); - ]) + let operand = + let doc = printModType ~customLayout modType cmtTbl in + if Parens.modTypeWithOperand modType then addParens doc else doc + in + Doc.group + (Doc.concat + [ + operand; + Doc.indent + (Doc.concat + [ + Doc.line; + printWithConstraints ~customLayout withConstraints cmtTbl; + ]); + ]) in let attrsAlreadyPrinted = match modType.pmty_desc with @@ -54016,78 +54021,78 @@ and printWithConstraint ~customLayout match withConstraint with (* with type X.t = ... *) | Pwith_type (longident, typeDeclaration) -> - Doc.group - (printTypeDeclaration ~customLayout - ~name:(printLidentPath longident cmtTbl) - ~equalSign:"=" ~recFlag:Doc.nil 0 typeDeclaration CommentTable.empty) + Doc.group + (printTypeDeclaration ~customLayout + ~name:(printLidentPath longident cmtTbl) + ~equalSign:"=" ~recFlag:Doc.nil 0 typeDeclaration CommentTable.empty) (* with module X.Y = Z *) - | Pwith_module ({ txt = longident1 }, { txt = longident2 }) -> - Doc.concat - [ - Doc.text "module "; - printLongident longident1; - Doc.text " ="; - Doc.indent (Doc.concat [ Doc.line; printLongident longident2 ]); - ] + | Pwith_module ({txt = longident1}, {txt = longident2}) -> + Doc.concat + [ + Doc.text "module "; + printLongident longident1; + Doc.text " ="; + Doc.indent (Doc.concat [Doc.line; printLongident longident2]); + ] (* with type X.t := ..., same format as [Pwith_type] *) | Pwith_typesubst (longident, typeDeclaration) -> - Doc.group - (printTypeDeclaration ~customLayout - ~name:(printLidentPath longident cmtTbl) - ~equalSign:":=" ~recFlag:Doc.nil 0 typeDeclaration CommentTable.empty) - | Pwith_modsubst ({ txt = longident1 }, { txt = longident2 }) -> - Doc.concat - [ - Doc.text "module "; - printLongident longident1; - Doc.text " :="; - Doc.indent (Doc.concat [ Doc.line; printLongident longident2 ]); - ] - -and printSignature ~customLayout signature cmtTbl = - match signature with + Doc.group + (printTypeDeclaration ~customLayout + ~name:(printLidentPath longident cmtTbl) + ~equalSign:":=" ~recFlag:Doc.nil 0 typeDeclaration CommentTable.empty) + | Pwith_modsubst ({txt = longident1}, {txt = longident2}) -> + Doc.concat + [ + Doc.text "module "; + printLongident longident1; + Doc.text " :="; + Doc.indent (Doc.concat [Doc.line; printLongident longident2]); + ] + +and printSignature ~customLayout signature cmtTbl = + match signature with | [] -> printCommentsInsideFile cmtTbl | signature -> - printList - ~getLoc:(fun s -> s.Parsetree.psig_loc) - ~nodes:signature - ~print:(printSignatureItem ~customLayout) - cmtTbl + printList + ~getLoc:(fun s -> s.Parsetree.psig_loc) + ~nodes:signature + ~print:(printSignatureItem ~customLayout) + cmtTbl and printSignatureItem ~customLayout (si : Parsetree.signature_item) cmtTbl = match si.psig_desc with | Parsetree.Psig_value valueDescription -> - printValueDescription ~customLayout valueDescription cmtTbl + printValueDescription ~customLayout valueDescription cmtTbl | Psig_type (recFlag, typeDeclarations) -> - let recFlag = - match recFlag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - printTypeDeclarations ~customLayout ~recFlag typeDeclarations cmtTbl + let recFlag = + match recFlag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + printTypeDeclarations ~customLayout ~recFlag typeDeclarations cmtTbl | Psig_typext typeExtension -> - printTypeExtension ~customLayout typeExtension cmtTbl + printTypeExtension ~customLayout typeExtension cmtTbl | Psig_exception extensionConstructor -> - printExceptionDef ~customLayout extensionConstructor cmtTbl + printExceptionDef ~customLayout extensionConstructor cmtTbl | Psig_module moduleDeclaration -> - printModuleDeclaration ~customLayout moduleDeclaration cmtTbl + printModuleDeclaration ~customLayout moduleDeclaration cmtTbl | Psig_recmodule moduleDeclarations -> - printRecModuleDeclarations ~customLayout moduleDeclarations cmtTbl + printRecModuleDeclarations ~customLayout moduleDeclarations cmtTbl | Psig_modtype modTypeDecl -> - printModuleTypeDeclaration ~customLayout modTypeDecl cmtTbl + printModuleTypeDeclaration ~customLayout modTypeDecl cmtTbl | Psig_open openDescription -> - printOpenDescription ~customLayout openDescription cmtTbl + printOpenDescription ~customLayout openDescription cmtTbl | Psig_include includeDescription -> - printIncludeDescription ~customLayout includeDescription cmtTbl + printIncludeDescription ~customLayout includeDescription cmtTbl | Psig_attribute attr -> - fst (printAttribute ~customLayout ~standalone:true attr cmtTbl) + fst (printAttribute ~customLayout ~standalone:true attr cmtTbl) | Psig_extension (extension, attrs) -> - Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - Doc.concat - [ printExtension ~customLayout ~atModuleLvl:true extension cmtTbl ]; - ] + Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + Doc.concat + [printExtension ~customLayout ~atModuleLvl:true extension cmtTbl]; + ] | Psig_class _ | Psig_class_type _ -> Doc.nil and printRecModuleDeclarations ~customLayout moduleDeclarations cmtTbl = @@ -54101,22 +54106,23 @@ and printRecModuleDeclaration ~customLayout md cmtTbl i = let body = match md.pmd_type.pmty_desc with | Parsetree.Pmty_alias longident -> - Doc.concat [ Doc.text " = "; printLongidentLocation longident cmtTbl ] + Doc.concat [Doc.text " = "; printLongidentLocation longident cmtTbl] | _ -> - let needsParens = - match md.pmd_type.pmty_desc with Pmty_with _ -> true | _ -> false - in - let modTypeDoc = - let doc = printModType ~customLayout md.pmd_type cmtTbl in - if needsParens then addParens doc else doc - in - Doc.concat [ Doc.text ": "; modTypeDoc ] + let needsParens = + match md.pmd_type.pmty_desc with + | Pmty_with _ -> true + | _ -> false + in + let modTypeDoc = + let doc = printModType ~customLayout md.pmd_type cmtTbl in + if needsParens then addParens doc else doc + in + Doc.concat [Doc.text ": "; modTypeDoc] in let prefix = if i < 1 then "module rec " else "and " in Doc.concat [ - printAttributes ~customLayout ~loc:md.pmd_name.loc md.pmd_attributes - cmtTbl; + printAttributes ~customLayout ~loc:md.pmd_name.loc md.pmd_attributes cmtTbl; Doc.text prefix; printComments (Doc.text md.pmd_name.txt) cmtTbl md.pmd_name.loc; body; @@ -54127,15 +54133,13 @@ and printModuleDeclaration ~customLayout (md : Parsetree.module_declaration) let body = match md.pmd_type.pmty_desc with | Parsetree.Pmty_alias longident -> - Doc.concat [ Doc.text " = "; printLongidentLocation longident cmtTbl ] + Doc.concat [Doc.text " = "; printLongidentLocation longident cmtTbl] | _ -> - Doc.concat - [ Doc.text ": "; printModType ~customLayout md.pmd_type cmtTbl ] + Doc.concat [Doc.text ": "; printModType ~customLayout md.pmd_type cmtTbl] in Doc.concat [ - printAttributes ~customLayout ~loc:md.pmd_name.loc md.pmd_attributes - cmtTbl; + printAttributes ~customLayout ~loc:md.pmd_name.loc md.pmd_attributes cmtTbl; Doc.text "module "; printComments (Doc.text md.pmd_name.txt) cmtTbl md.pmd_name.loc; body; @@ -54186,7 +54190,9 @@ and printValueBindings ~customLayout ~recFlag and printValueDescription ~customLayout valueDescription cmtTbl = let isExternal = - match valueDescription.pval_prim with [] -> false | _ -> true + match valueDescription.pval_prim with + | [] -> false + | _ -> true in let attrs = printAttributes ~customLayout ~loc:valueDescription.pval_name.loc @@ -54216,7 +54222,7 @@ and printValueDescription ~customLayout valueDescription cmtTbl = (List.map (fun s -> Doc.concat - [ Doc.text "\""; Doc.text s; Doc.text "\"" ]) + [Doc.text "\""; Doc.text s; Doc.text "\""]) valueDescription.pval_prim); ]); ]) @@ -54268,72 +54274,72 @@ and printTypeDeclaration ~customLayout ~name ~equalSign ~recFlag i printAttributes ~customLayout ~loc:td.ptype_loc td.ptype_attributes cmtTbl in let prefix = - if i > 0 then Doc.text "and " else Doc.concat [ Doc.text "type "; recFlag ] + if i > 0 then Doc.text "and " else Doc.concat [Doc.text "type "; recFlag] in let typeName = name in let typeParams = printTypeParams ~customLayout td.ptype_params cmtTbl in let manifestAndKind = match td.ptype_kind with | Ptype_abstract -> ( - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; - printPrivateFlag td.ptype_private; - printTypExpr ~customLayout typ cmtTbl; - ]) - | Ptype_open -> + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> Doc.concat [ - Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; printPrivateFlag td.ptype_private; - Doc.text ".."; - ] + printTypExpr ~customLayout typ cmtTbl; + ]) + | Ptype_open -> + Doc.concat + [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printPrivateFlag td.ptype_private; + Doc.text ".."; + ] | Ptype_record lds -> - let manifest = - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; - printTypExpr ~customLayout typ cmtTbl; - ] - in - Doc.concat - [ - manifest; - Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; - printPrivateFlag td.ptype_private; - printRecordDeclaration ~customLayout lds cmtTbl; - ] + let manifest = + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> + Doc.concat + [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printTypExpr ~customLayout typ cmtTbl; + ] + in + Doc.concat + [ + manifest; + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printPrivateFlag td.ptype_private; + printRecordDeclaration ~customLayout lds cmtTbl; + ] | Ptype_variant cds -> - let manifest = - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; - printTypExpr ~customLayout typ cmtTbl; - ] - in - Doc.concat - [ - manifest; - Doc.concat [ Doc.space; Doc.text equalSign ]; - printConstructorDeclarations ~customLayout - ~privateFlag:td.ptype_private cds cmtTbl; - ] + let manifest = + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> + Doc.concat + [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printTypExpr ~customLayout typ cmtTbl; + ] + in + Doc.concat + [ + manifest; + Doc.concat [Doc.space; Doc.text equalSign]; + printConstructorDeclarations ~customLayout + ~privateFlag:td.ptype_private cds cmtTbl; + ] in let constraints = printTypeDefinitionConstraints ~customLayout td.ptype_cstrs in Doc.group (Doc.concat - [ attrs; prefix; typeName; typeParams; manifestAndKind; constraints ]) + [attrs; prefix; typeName; typeParams; manifestAndKind; constraints]) and printTypeDeclaration2 ~customLayout ~recFlag (td : Parsetree.type_declaration) cmtTbl i = @@ -54346,99 +54352,99 @@ and printTypeDeclaration2 ~customLayout ~recFlag printAttributes ~customLayout ~loc:td.ptype_loc td.ptype_attributes cmtTbl in let prefix = - if i > 0 then Doc.text "and " else Doc.concat [ Doc.text "type "; recFlag ] + if i > 0 then Doc.text "and " else Doc.concat [Doc.text "type "; recFlag] in let typeName = name in let typeParams = printTypeParams ~customLayout td.ptype_params cmtTbl in let manifestAndKind = match td.ptype_kind with | Ptype_abstract -> ( - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; - printPrivateFlag td.ptype_private; - printTypExpr ~customLayout typ cmtTbl; - ]) - | Ptype_open -> + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> Doc.concat [ - Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; printPrivateFlag td.ptype_private; - Doc.text ".."; - ] + printTypExpr ~customLayout typ cmtTbl; + ]) + | Ptype_open -> + Doc.concat + [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printPrivateFlag td.ptype_private; + Doc.text ".."; + ] | Ptype_record lds -> - if lds = [] then - Doc.concat - [ - Doc.space; - Doc.text equalSign; - Doc.space; - Doc.lbrace; - printCommentsInside cmtTbl td.ptype_loc; - Doc.rbrace; - ] - else - let manifest = - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; - printTypExpr ~customLayout typ cmtTbl; - ] - in - Doc.concat - [ - manifest; - Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; - printPrivateFlag td.ptype_private; - printRecordDeclaration ~customLayout lds cmtTbl; - ] - | Ptype_variant cds -> + if lds = [] then + Doc.concat + [ + Doc.space; + Doc.text equalSign; + Doc.space; + Doc.lbrace; + printCommentsInside cmtTbl td.ptype_loc; + Doc.rbrace; + ] + else let manifest = match td.ptype_manifest with | None -> Doc.nil | Some typ -> - Doc.concat - [ - Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; - printTypExpr ~customLayout typ cmtTbl; - ] + Doc.concat + [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printTypExpr ~customLayout typ cmtTbl; + ] in Doc.concat [ manifest; - Doc.concat [ Doc.space; Doc.text equalSign ]; - printConstructorDeclarations ~customLayout - ~privateFlag:td.ptype_private cds cmtTbl; + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printPrivateFlag td.ptype_private; + printRecordDeclaration ~customLayout lds cmtTbl; ] + | Ptype_variant cds -> + let manifest = + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> + Doc.concat + [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printTypExpr ~customLayout typ cmtTbl; + ] + in + Doc.concat + [ + manifest; + Doc.concat [Doc.space; Doc.text equalSign]; + printConstructorDeclarations ~customLayout + ~privateFlag:td.ptype_private cds cmtTbl; + ] in let constraints = printTypeDefinitionConstraints ~customLayout td.ptype_cstrs in Doc.group (Doc.concat - [ attrs; prefix; typeName; typeParams; manifestAndKind; constraints ]) + [attrs; prefix; typeName; typeParams; manifestAndKind; constraints]) and printTypeDefinitionConstraints ~customLayout cstrs = match cstrs with | [] -> Doc.nil | cstrs -> - Doc.indent - (Doc.group - (Doc.concat - [ - Doc.line; - Doc.group - (Doc.join ~sep:Doc.line - (List.map - (printTypeDefinitionConstraint ~customLayout) - cstrs)); - ])) + Doc.indent + (Doc.group + (Doc.concat + [ + Doc.line; + Doc.group + (Doc.join ~sep:Doc.line + (List.map + (printTypeDefinitionConstraint ~customLayout) + cstrs)); + ])) and printTypeDefinitionConstraint ~customLayout ((typ1, typ2, _loc) : @@ -54452,35 +54458,37 @@ and printTypeDefinitionConstraint ~customLayout ] and printPrivateFlag (flag : Asttypes.private_flag) = - match flag with Private -> Doc.text "private " | Public -> Doc.nil + match flag with + | Private -> Doc.text "private " + | Public -> Doc.nil and printTypeParams ~customLayout typeParams cmtTbl = match typeParams with | [] -> Doc.nil | typeParams -> - Doc.group - (Doc.concat - [ - Doc.lessThan; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun typeParam -> - let doc = - printTypeParam ~customLayout typeParam cmtTbl - in - printComments doc cmtTbl - (fst typeParam).Parsetree.ptyp_loc) - typeParams); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.greaterThan; - ]) + Doc.group + (Doc.concat + [ + Doc.lessThan; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun typeParam -> + let doc = + printTypeParam ~customLayout typeParam cmtTbl + in + printComments doc cmtTbl + (fst typeParam).Parsetree.ptyp_loc) + typeParams); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.greaterThan; + ]) and printTypeParam ~customLayout (param : Parsetree.core_type * Asttypes.variance) cmtTbl = @@ -54491,14 +54499,14 @@ and printTypeParam ~customLayout | Contravariant -> Doc.text "-" | Invariant -> Doc.nil in - Doc.concat [ printedVariance; printTypExpr ~customLayout typ cmtTbl ] + Doc.concat [printedVariance; printTypExpr ~customLayout typ cmtTbl] and printRecordDeclaration ~customLayout (lds : Parsetree.label_declaration list) cmtTbl = let forceBreak = match (lds, List.rev lds) with | first :: _, last :: _ -> - first.pld_loc.loc_start.pos_lnum < last.pld_loc.loc_end.pos_lnum + first.pld_loc.loc_start.pos_lnum < last.pld_loc.loc_end.pos_lnum | _ -> false in Doc.breakableGroup ~forceBreak @@ -54510,7 +54518,7 @@ and printRecordDeclaration ~customLayout [ Doc.softLine; Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map (fun ld -> let doc = @@ -54529,12 +54537,12 @@ and printConstructorDeclarations ~customLayout ~privateFlag let forceBreak = match (cds, List.rev cds) with | first :: _, last :: _ -> - first.pcd_loc.loc_start.pos_lnum < last.pcd_loc.loc_end.pos_lnum + first.pcd_loc.loc_start.pos_lnum < last.pcd_loc.loc_end.pos_lnum | _ -> false in let privateFlag = match privateFlag with - | Asttypes.Private -> Doc.concat [ Doc.text "private"; Doc.line ] + | Asttypes.Private -> Doc.concat [Doc.text "private"; Doc.line] | Public -> Doc.nil in let rows = @@ -54547,7 +54555,7 @@ and printConstructorDeclarations ~customLayout ~privateFlag ~forceBreak cmtTbl in Doc.breakableGroup ~forceBreak - (Doc.indent (Doc.concat [ Doc.line; privateFlag; rows ])) + (Doc.indent (Doc.concat [Doc.line; privateFlag; rows])) and printConstructorDeclaration2 ~customLayout i (cd : Parsetree.constructor_declaration) cmtTbl = @@ -54567,8 +54575,8 @@ and printConstructorDeclaration2 ~customLayout i match cd.pcd_res with | None -> Doc.nil | Some typ -> - Doc.indent - (Doc.concat [ Doc.text ": "; printTypExpr ~customLayout typ cmtTbl ]) + Doc.indent + (Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ cmtTbl]) in Doc.concat [ @@ -54589,55 +54597,54 @@ and printConstructorArguments ~customLayout ~indent match cdArgs with | Pcstr_tuple [] -> Doc.nil | Pcstr_tuple types -> - let args = - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun typexpr -> - printTypExpr ~customLayout typexpr cmtTbl) - types); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - in - Doc.group (if indent then Doc.indent args else args) + let args = + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun typexpr -> printTypExpr ~customLayout typexpr cmtTbl) + types); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + in + Doc.group (if indent then Doc.indent args else args) | Pcstr_record lds -> - let args = - Doc.concat - [ - Doc.lparen; - (* manually inline the printRecordDeclaration, gives better layout *) - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun ld -> - let doc = - printLabelDeclaration ~customLayout ld cmtTbl - in - printComments doc cmtTbl ld.Parsetree.pld_loc) - lds); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - Doc.rparen; - ] - in - if indent then Doc.indent args else args + let args = + Doc.concat + [ + Doc.lparen; + (* manually inline the printRecordDeclaration, gives better layout *) + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun ld -> + let doc = + printLabelDeclaration ~customLayout ld cmtTbl + in + printComments doc cmtTbl ld.Parsetree.pld_loc) + lds); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + Doc.rparen; + ] + in + if indent then Doc.indent args else args and printLabelDeclaration ~customLayout (ld : Parsetree.label_declaration) cmtTbl = @@ -54670,261 +54677,242 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = match typExpr.ptyp_desc with | Ptyp_any -> Doc.text "_" | Ptyp_var var -> - Doc.concat [ Doc.text "'"; printIdentLike ~allowUident:true var ] + Doc.concat [Doc.text "'"; printIdentLike ~allowUident:true var] | Ptyp_extension extension -> - printExtension ~customLayout ~atModuleLvl:false extension cmtTbl + printExtension ~customLayout ~atModuleLvl:false extension cmtTbl | Ptyp_alias (typ, alias) -> - let typ = - (* Technically type t = (string, float) => unit as 'x, doesn't require - * parens around the arrow expression. This is very confusing though. - * Is the "as" part of "unit" or "(string, float) => unit". By printing - * parens we guide the user towards its meaning.*) - let needsParens = - match typ.ptyp_desc with Ptyp_arrow _ -> true | _ -> false - in - let doc = printTypExpr ~customLayout typ cmtTbl in - if needsParens then Doc.concat [ Doc.lparen; doc; Doc.rparen ] - else doc + let typ = + (* Technically type t = (string, float) => unit as 'x, doesn't require + * parens around the arrow expression. This is very confusing though. + * Is the "as" part of "unit" or "(string, float) => unit". By printing + * parens we guide the user towards its meaning.*) + let needsParens = + match typ.ptyp_desc with + | Ptyp_arrow _ -> true + | _ -> false in - Doc.concat - [ - typ; - Doc.text " as "; - Doc.concat [ Doc.text "'"; printIdentLike alias ]; - ] + let doc = printTypExpr ~customLayout typ cmtTbl in + if needsParens then Doc.concat [Doc.lparen; doc; Doc.rparen] else doc + in + Doc.concat + [typ; Doc.text " as "; Doc.concat [Doc.text "'"; printIdentLike alias]] (* object printings *) | Ptyp_object (fields, openFlag) -> - printObject ~customLayout ~inline:false fields openFlag cmtTbl - | Ptyp_constr - (longidentLoc, [ { ptyp_desc = Ptyp_object (fields, openFlag) } ]) -> - (* for foo<{"a": b}>, when the object is long and needs a line break, we - want the <{ and }> to stay hugged together *) - let constrName = printLidentPath longidentLoc cmtTbl in - Doc.concat - [ - constrName; - Doc.lessThan; - printObject ~customLayout ~inline:true fields openFlag cmtTbl; - Doc.greaterThan; - ] - | Ptyp_constr (longidentLoc, [ { ptyp_desc = Parsetree.Ptyp_tuple tuple } ]) + printObject ~customLayout ~inline:false fields openFlag cmtTbl + | Ptyp_constr (longidentLoc, [{ptyp_desc = Ptyp_object (fields, openFlag)}]) -> - let constrName = printLidentPath longidentLoc cmtTbl in - Doc.group - (Doc.concat - [ - constrName; - Doc.lessThan; - printTupleType ~customLayout ~inline:true tuple cmtTbl; - Doc.greaterThan; - ]) + (* for foo<{"a": b}>, when the object is long and needs a line break, we + want the <{ and }> to stay hugged together *) + let constrName = printLidentPath longidentLoc cmtTbl in + Doc.concat + [ + constrName; + Doc.lessThan; + printObject ~customLayout ~inline:true fields openFlag cmtTbl; + Doc.greaterThan; + ] + | Ptyp_constr (longidentLoc, [{ptyp_desc = Parsetree.Ptyp_tuple tuple}]) -> + let constrName = printLidentPath longidentLoc cmtTbl in + Doc.group + (Doc.concat + [ + constrName; + Doc.lessThan; + printTupleType ~customLayout ~inline:true tuple cmtTbl; + Doc.greaterThan; + ]) | Ptyp_constr (longidentLoc, constrArgs) -> ( - let constrName = printLidentPath longidentLoc cmtTbl in - match constrArgs with - | [] -> constrName - | _args -> - Doc.group - (Doc.concat - [ - constrName; - Doc.lessThan; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun typexpr -> - printTypExpr ~customLayout typexpr cmtTbl) - constrArgs); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.greaterThan; - ])) + let constrName = printLidentPath longidentLoc cmtTbl in + match constrArgs with + | [] -> constrName + | _args -> + Doc.group + (Doc.concat + [ + constrName; + Doc.lessThan; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun typexpr -> + printTypExpr ~customLayout typexpr cmtTbl) + constrArgs); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.greaterThan; + ])) | Ptyp_arrow _ -> ( - let attrsBefore, args, returnType = ParsetreeViewer.arrowType typExpr in - let returnTypeNeedsParens = - match returnType.ptyp_desc with Ptyp_alias _ -> true | _ -> false + let attrsBefore, args, returnType = ParsetreeViewer.arrowType typExpr in + let returnTypeNeedsParens = + match returnType.ptyp_desc with + | Ptyp_alias _ -> true + | _ -> false + in + let returnDoc = + let doc = printTypExpr ~customLayout returnType cmtTbl in + if returnTypeNeedsParens then Doc.concat [Doc.lparen; doc; Doc.rparen] + else doc + in + let isUncurried, attrs = + ParsetreeViewer.processUncurriedAttribute attrsBefore + in + match args with + | [] -> Doc.nil + | [([], Nolabel, n)] when not isUncurried -> + let hasAttrsBefore = not (attrs = []) in + let attrs = + if hasAttrsBefore then + printAttributes ~customLayout ~inline:true attrsBefore cmtTbl + else Doc.nil in - let returnDoc = - let doc = printTypExpr ~customLayout returnType cmtTbl in - if returnTypeNeedsParens then - Doc.concat [ Doc.lparen; doc; Doc.rparen ] - else doc + let typDoc = + let doc = printTypExpr ~customLayout n cmtTbl in + match n.ptyp_desc with + | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> addParens doc + | _ -> doc in - let isUncurried, attrs = - ParsetreeViewer.processUncurriedAttribute attrsBefore + Doc.group + (Doc.concat + [ + Doc.group attrs; + Doc.group + (if hasAttrsBefore then + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [Doc.softLine; typDoc; Doc.text " => "; returnDoc]); + Doc.softLine; + Doc.rparen; + ] + else Doc.concat [typDoc; Doc.text " => "; returnDoc]); + ]) + | args -> + let attrs = printAttributes ~customLayout ~inline:true attrs cmtTbl in + let renderedArgs = + Doc.concat + [ + attrs; + Doc.text "("; + Doc.indent + (Doc.concat + [ + Doc.softLine; + (if isUncurried then Doc.concat [Doc.dot; Doc.space] + else Doc.nil); + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun tp -> printTypeParameter ~customLayout tp cmtTbl) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.text ")"; + ] in - match args with - | [] -> Doc.nil - | [ ([], Nolabel, n) ] when not isUncurried -> - let hasAttrsBefore = not (attrs = []) in - let attrs = - if hasAttrsBefore then - printAttributes ~customLayout ~inline:true attrsBefore cmtTbl - else Doc.nil - in - let typDoc = - let doc = printTypExpr ~customLayout n cmtTbl in - match n.ptyp_desc with - | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> addParens doc - | _ -> doc - in - Doc.group - (Doc.concat - [ - Doc.group attrs; - Doc.group - (if hasAttrsBefore then - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - typDoc; - Doc.text " => "; - returnDoc; - ]); - Doc.softLine; - Doc.rparen; - ] - else Doc.concat [ typDoc; Doc.text " => "; returnDoc ]); - ]) - | args -> - let attrs = - printAttributes ~customLayout ~inline:true attrs cmtTbl - in - let renderedArgs = - Doc.concat - [ - attrs; - Doc.text "("; - Doc.indent - (Doc.concat - [ - Doc.softLine; - (if isUncurried then Doc.concat [ Doc.dot; Doc.space ] - else Doc.nil); - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun tp -> - printTypeParameter ~customLayout tp cmtTbl) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.text ")"; - ] - in - Doc.group (Doc.concat [ renderedArgs; Doc.text " => "; returnDoc ])) + Doc.group (Doc.concat [renderedArgs; Doc.text " => "; returnDoc])) | Ptyp_tuple types -> - printTupleType ~customLayout ~inline:false types cmtTbl + printTupleType ~customLayout ~inline:false types cmtTbl | Ptyp_poly ([], typ) -> printTypExpr ~customLayout typ cmtTbl | Ptyp_poly (stringLocs, typ) -> - Doc.concat - [ - Doc.join ~sep:Doc.space - (List.map - (fun { Location.txt; loc } -> - let doc = Doc.concat [ Doc.text "'"; Doc.text txt ] in - printComments doc cmtTbl loc) - stringLocs); - Doc.dot; - Doc.space; - printTypExpr ~customLayout typ cmtTbl; - ] + Doc.concat + [ + Doc.join ~sep:Doc.space + (List.map + (fun {Location.txt; loc} -> + let doc = Doc.concat [Doc.text "'"; Doc.text txt] in + printComments doc cmtTbl loc) + stringLocs); + Doc.dot; + Doc.space; + printTypExpr ~customLayout typ cmtTbl; + ] | Ptyp_package packageType -> - printPackageType ~customLayout ~printModuleKeywordAndParens:true - packageType cmtTbl + printPackageType ~customLayout ~printModuleKeywordAndParens:true + packageType cmtTbl | Ptyp_class _ -> Doc.text "classes are not supported in types" | Ptyp_variant (rowFields, closedFlag, labelsOpt) -> - let forceBreak = - typExpr.ptyp_loc.Location.loc_start.pos_lnum - < typExpr.ptyp_loc.loc_end.pos_lnum - in - let printRowField = function - | Parsetree.Rtag ({ txt; loc }, attrs, true, []) -> - let doc = - Doc.group - (Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - Doc.concat [ Doc.text "#"; printPolyVarIdent txt ]; - ]) - in - printComments doc cmtTbl loc - | Rtag ({ txt }, attrs, truth, types) -> - let doType t = - match t.Parsetree.ptyp_desc with - | Ptyp_tuple _ -> printTypExpr ~customLayout t cmtTbl - | _ -> - Doc.concat - [ - Doc.lparen; - printTypExpr ~customLayout t cmtTbl; - Doc.rparen; - ] - in - let printedTypes = List.map doType types in - let cases = - Doc.join - ~sep:(Doc.concat [ Doc.line; Doc.text "& " ]) - printedTypes - in - let cases = - if truth then Doc.concat [ Doc.line; Doc.text "& "; cases ] - else cases - in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - Doc.concat [ Doc.text "#"; printPolyVarIdent txt ]; - cases; - ]) - | Rinherit coreType -> printTypExpr ~customLayout coreType cmtTbl - in - let docs = List.map printRowField rowFields in - let cases = - Doc.join ~sep:(Doc.concat [ Doc.line; Doc.text "| " ]) docs - in - let cases = - if docs = [] then cases - else Doc.concat [ Doc.ifBreaks (Doc.text "| ") Doc.nil; cases ] - in - let openingSymbol = - if closedFlag = Open then Doc.concat [ Doc.greaterThan; Doc.line ] - else if labelsOpt = None then Doc.softLine - else Doc.concat [ Doc.lessThan; Doc.line ] - in - let labels = - match labelsOpt with - | None | Some [] -> Doc.nil - | Some labels -> + let forceBreak = + typExpr.ptyp_loc.Location.loc_start.pos_lnum + < typExpr.ptyp_loc.loc_end.pos_lnum + in + let printRowField = function + | Parsetree.Rtag ({txt; loc}, attrs, true, []) -> + let doc = + Doc.group + (Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + Doc.concat [Doc.text "#"; printPolyVarIdent txt]; + ]) + in + printComments doc cmtTbl loc + | Rtag ({txt}, attrs, truth, types) -> + let doType t = + match t.Parsetree.ptyp_desc with + | Ptyp_tuple _ -> printTypExpr ~customLayout t cmtTbl + | _ -> Doc.concat - (List.map - (fun label -> - Doc.concat - [ Doc.line; Doc.text "#"; printPolyVarIdent label ]) - labels) - in - let closingSymbol = - match labelsOpt with None | Some [] -> Doc.nil | _ -> Doc.text " >" - in - Doc.breakableGroup ~forceBreak - (Doc.concat - [ - Doc.lbracket; - Doc.indent - (Doc.concat [ openingSymbol; cases; closingSymbol; labels ]); - Doc.softLine; - Doc.rbracket; - ]) + [Doc.lparen; printTypExpr ~customLayout t cmtTbl; Doc.rparen] + in + let printedTypes = List.map doType types in + let cases = + Doc.join ~sep:(Doc.concat [Doc.line; Doc.text "& "]) printedTypes + in + let cases = + if truth then Doc.concat [Doc.line; Doc.text "& "; cases] else cases + in + Doc.group + (Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + Doc.concat [Doc.text "#"; printPolyVarIdent txt]; + cases; + ]) + | Rinherit coreType -> printTypExpr ~customLayout coreType cmtTbl + in + let docs = List.map printRowField rowFields in + let cases = Doc.join ~sep:(Doc.concat [Doc.line; Doc.text "| "]) docs in + let cases = + if docs = [] then cases + else Doc.concat [Doc.ifBreaks (Doc.text "| ") Doc.nil; cases] + in + let openingSymbol = + if closedFlag = Open then Doc.concat [Doc.greaterThan; Doc.line] + else if labelsOpt = None then Doc.softLine + else Doc.concat [Doc.lessThan; Doc.line] + in + let labels = + match labelsOpt with + | None | Some [] -> Doc.nil + | Some labels -> + Doc.concat + (List.map + (fun label -> + Doc.concat [Doc.line; Doc.text "#"; printPolyVarIdent label]) + labels) + in + let closingSymbol = + match labelsOpt with + | None | Some [] -> Doc.nil + | _ -> Doc.text " >" + in + Doc.breakableGroup ~forceBreak + (Doc.concat + [ + Doc.lbracket; + Doc.indent + (Doc.concat [openingSymbol; cases; closingSymbol; labels]); + Doc.softLine; + Doc.rbracket; + ]) in let shouldPrintItsOwnAttributes = match typExpr.ptyp_desc with @@ -54934,9 +54922,8 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = let doc = match typExpr.ptyp_attributes with | _ :: _ as attrs when not shouldPrintItsOwnAttributes -> - Doc.group - (Doc.concat - [ printAttributes ~customLayout attrs cmtTbl; renderedType ]) + Doc.group + (Doc.concat [printAttributes ~customLayout attrs cmtTbl; renderedType]) | _ -> renderedType in printComments doc cmtTbl typExpr.ptyp_loc @@ -54945,41 +54932,40 @@ and printObject ~customLayout ~inline fields openFlag cmtTbl = let doc = match fields with | [] -> - Doc.concat - [ - Doc.lbrace; - (match openFlag with - | Asttypes.Closed -> Doc.dot - | Open -> Doc.dotdot); - Doc.rbrace; - ] + Doc.concat + [ + Doc.lbrace; + (match openFlag with + | Asttypes.Closed -> Doc.dot + | Open -> Doc.dotdot); + Doc.rbrace; + ] | fields -> - Doc.concat - [ - Doc.lbrace; - (match openFlag with - | Asttypes.Closed -> Doc.nil - | Open -> ( - match fields with - (* handle `type t = {.. ...objType, "x": int}` - * .. and ... should have a space in between *) - | Oinherit _ :: _ -> Doc.text ".. " - | _ -> Doc.dotdot)); - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun field -> - printObjectField ~customLayout field cmtTbl) - fields); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ] + Doc.concat + [ + Doc.lbrace; + (match openFlag with + | Asttypes.Closed -> Doc.nil + | Open -> ( + match fields with + (* handle `type t = {.. ...objType, "x": int}` + * .. and ... should have a space in between *) + | Oinherit _ :: _ -> Doc.text ".. " + | _ -> Doc.dotdot)); + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun field -> printObjectField ~customLayout field cmtTbl) + fields); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ] in if inline then doc else Doc.group doc @@ -54994,7 +54980,7 @@ and printTupleType ~customLayout ~inline (types : Parsetree.core_type list) [ Doc.softLine; Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map (fun typexpr -> printTypExpr ~customLayout typexpr cmtTbl) types); @@ -55009,23 +54995,23 @@ and printTupleType ~customLayout ~inline (types : Parsetree.core_type list) and printObjectField ~customLayout (field : Parsetree.object_field) cmtTbl = match field with | Otag (labelLoc, attrs, typ) -> - let lbl = - let doc = Doc.text ("\"" ^ labelLoc.txt ^ "\"") in - printComments doc cmtTbl labelLoc.loc - in - let doc = - Doc.concat - [ - printAttributes ~customLayout ~loc:labelLoc.loc attrs cmtTbl; - lbl; - Doc.text ": "; - printTypExpr ~customLayout typ cmtTbl; - ] - in - let cmtLoc = { labelLoc.loc with loc_end = typ.ptyp_loc.loc_end } in - printComments doc cmtTbl cmtLoc + let lbl = + let doc = Doc.text ("\"" ^ labelLoc.txt ^ "\"") in + printComments doc cmtTbl labelLoc.loc + in + let doc = + Doc.concat + [ + printAttributes ~customLayout ~loc:labelLoc.loc attrs cmtTbl; + lbl; + Doc.text ": "; + printTypExpr ~customLayout typ cmtTbl; + ] + in + let cmtLoc = {labelLoc.loc with loc_end = typ.ptyp_loc.loc_end} in + printComments doc cmtTbl cmtLoc | Oinherit typexpr -> - Doc.concat [ Doc.dotdotdot; printTypExpr ~customLayout typexpr cmtTbl ] + Doc.concat [Doc.dotdotdot; printTypExpr ~customLayout typexpr cmtTbl] (* es6 arrow type arg * type t = (~foo: string, ~bar: float=?, unit) => unit @@ -55033,16 +55019,16 @@ and printObjectField ~customLayout (field : Parsetree.object_field) cmtTbl = and printTypeParameter ~customLayout (attrs, lbl, typ) cmtTbl = let isUncurried, attrs = ParsetreeViewer.processUncurriedAttribute attrs in let uncurried = - if isUncurried then Doc.concat [ Doc.dot; Doc.space ] else Doc.nil + if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil in let attrs = printAttributes ~customLayout attrs cmtTbl in let label = match lbl with | Asttypes.Nolabel -> Doc.nil | Labelled lbl -> - Doc.concat [ Doc.text "~"; printIdentLike lbl; Doc.text ": " ] + Doc.concat [Doc.text "~"; printIdentLike lbl; Doc.text ": "] | Optional lbl -> - Doc.concat [ Doc.text "~"; printIdentLike lbl; Doc.text ": " ] + Doc.concat [Doc.text "~"; printIdentLike lbl; Doc.text ": "] in let optionalIndicator = match lbl with @@ -55051,9 +55037,9 @@ and printTypeParameter ~customLayout (attrs, lbl, typ) cmtTbl = in let loc, typ = match typ.ptyp_attributes with - | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: attrs -> - ( { loc with loc_end = typ.ptyp_loc.loc_end }, - { typ with ptyp_attributes = attrs } ) + | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: attrs -> + ( {loc with loc_end = typ.ptyp_loc.loc_end}, + {typ with ptyp_attributes = attrs} ) | _ -> (typ.ptyp_loc, typ) in let doc = @@ -55076,178 +55062,169 @@ and printValueBinding ~customLayout ~recFlag (vb : Parsetree.value_binding) cmtTbl in let header = - if i == 0 then Doc.concat [ Doc.text "let "; recFlag ] else Doc.text "and " + if i == 0 then Doc.concat [Doc.text "let "; recFlag] else Doc.text "and " in match vb with | { pvb_pat = { ppat_desc = - Ppat_constraint (pattern, ({ ptyp_desc = Ptyp_poly _ } as patTyp)); + Ppat_constraint (pattern, ({ptyp_desc = Ptyp_poly _} as patTyp)); }; - pvb_expr = { pexp_desc = Pexp_newtype _ } as expr; + pvb_expr = {pexp_desc = Pexp_newtype _} as expr; } -> ( - let _attrs, parameters, returnExpr = ParsetreeViewer.funExpr expr in - let abstractType = - match parameters with - | [ NewTypes { locs = vars } ] -> - Doc.concat - [ - Doc.text "type "; - Doc.join ~sep:Doc.space - (List.map (fun var -> Doc.text var.Asttypes.txt) vars); - Doc.dot; - ] - | _ -> Doc.nil - in - match returnExpr.pexp_desc with - | Pexp_constraint (expr, typ) -> + let _attrs, parameters, returnExpr = ParsetreeViewer.funExpr expr in + let abstractType = + match parameters with + | [NewTypes {locs = vars}] -> + Doc.concat + [ + Doc.text "type "; + Doc.join ~sep:Doc.space + (List.map (fun var -> Doc.text var.Asttypes.txt) vars); + Doc.dot; + ] + | _ -> Doc.nil + in + match returnExpr.pexp_desc with + | Pexp_constraint (expr, typ) -> + Doc.group + (Doc.concat + [ + attrs; + header; + printPattern ~customLayout pattern cmtTbl; + Doc.text ":"; + Doc.indent + (Doc.concat + [ + Doc.line; + abstractType; + Doc.space; + printTypExpr ~customLayout typ cmtTbl; + Doc.text " ="; + Doc.concat + [ + Doc.line; + printExpressionWithComments ~customLayout expr cmtTbl; + ]; + ]); + ]) + | _ -> + (* Example: + * let cancel_and_collect_callbacks: + * 'a 'u 'c. (list, promise<'a, 'u, 'c>) => list = * (type x, callbacks_accumulator, p: promise<_, _, c>) + *) + Doc.group + (Doc.concat + [ + attrs; + header; + printPattern ~customLayout pattern cmtTbl; + Doc.text ":"; + Doc.indent + (Doc.concat + [ + Doc.line; + abstractType; + Doc.space; + printTypExpr ~customLayout patTyp cmtTbl; + Doc.text " ="; + Doc.concat + [ + Doc.line; + printExpressionWithComments ~customLayout expr cmtTbl; + ]; + ]); + ])) + | _ -> + let optBraces, expr = ParsetreeViewer.processBracesAttr vb.pvb_expr in + let printedExpr = + let doc = printExpressionWithComments ~customLayout vb.pvb_expr cmtTbl in + match Parens.expr vb.pvb_expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + let patternDoc = printPattern ~customLayout vb.pvb_pat cmtTbl in + (* + * we want to optimize the layout of one pipe: + * let tbl = data->Js.Array2.reduce((map, curr) => { + * ... + * }) + * important is that we don't do this for multiple pipes: + * let decoratorTags = + * items + * ->Js.Array2.filter(items => {items.category === Decorators}) + * ->Belt.Array.map(...) + * Multiple pipes chained together lend themselves more towards the last layout. + *) + if ParsetreeViewer.isSinglePipeExpr vb.pvb_expr then + Doc.customLayout + [ + Doc.group + (Doc.concat + [ + attrs; header; patternDoc; Doc.text " ="; Doc.space; printedExpr; + ]); Doc.group (Doc.concat [ attrs; header; - printPattern ~customLayout pattern cmtTbl; - Doc.text ":"; - Doc.indent - (Doc.concat - [ - Doc.line; - abstractType; - Doc.space; - printTypExpr ~customLayout typ cmtTbl; - Doc.text " ="; - Doc.concat - [ - Doc.line; - printExpressionWithComments ~customLayout expr - cmtTbl; - ]; - ]); - ]) - | _ -> - (* Example: - * let cancel_and_collect_callbacks: - * 'a 'u 'c. (list, promise<'a, 'u, 'c>) => list = * (type x, callbacks_accumulator, p: promise<_, _, c>) - *) - Doc.group - (Doc.concat - [ - attrs; - header; - printPattern ~customLayout pattern cmtTbl; - Doc.text ":"; - Doc.indent - (Doc.concat - [ - Doc.line; - abstractType; - Doc.space; - printTypExpr ~customLayout patTyp cmtTbl; - Doc.text " ="; - Doc.concat - [ - Doc.line; - printExpressionWithComments ~customLayout expr - cmtTbl; - ]; - ]); - ])) - | _ -> - let optBraces, expr = ParsetreeViewer.processBracesAttr vb.pvb_expr in - let printedExpr = - let doc = - printExpressionWithComments ~customLayout vb.pvb_expr cmtTbl - in - match Parens.expr vb.pvb_expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc + patternDoc; + Doc.text " ="; + Doc.indent (Doc.concat [Doc.line; printedExpr]); + ]); + ] + else + let shouldIndent = + match optBraces with + | Some _ -> false + | _ -> ( + ParsetreeViewer.isBinaryExpression expr + || + match vb.pvb_expr with + | { + pexp_attributes = [({Location.txt = "ns.ternary"}, _)]; + pexp_desc = Pexp_ifthenelse (ifExpr, _, _); + } -> + ParsetreeViewer.isBinaryExpression ifExpr + || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes + | {pexp_desc = Pexp_newtype _} -> false + | e -> + ParsetreeViewer.hasAttributes e.pexp_attributes + || ParsetreeViewer.isArrayAccess e) in - let patternDoc = printPattern ~customLayout vb.pvb_pat cmtTbl in - (* - * we want to optimize the layout of one pipe: - * let tbl = data->Js.Array2.reduce((map, curr) => { - * ... - * }) - * important is that we don't do this for multiple pipes: - * let decoratorTags = - * items - * ->Js.Array2.filter(items => {items.category === Decorators}) - * ->Belt.Array.map(...) - * Multiple pipes chained together lend themselves more towards the last layout. - *) - if ParsetreeViewer.isSinglePipeExpr vb.pvb_expr then - Doc.customLayout - [ - Doc.group - (Doc.concat - [ - attrs; - header; - patternDoc; - Doc.text " ="; - Doc.space; - printedExpr; - ]); - Doc.group - (Doc.concat - [ - attrs; - header; - patternDoc; - Doc.text " ="; - Doc.indent (Doc.concat [ Doc.line; printedExpr ]); - ]); - ] - else - let shouldIndent = - match optBraces with - | Some _ -> false - | _ -> ( - ParsetreeViewer.isBinaryExpression expr - || - match vb.pvb_expr with - | { - pexp_attributes = [ ({ Location.txt = "ns.ternary" }, _) ]; - pexp_desc = Pexp_ifthenelse (ifExpr, _, _); - } -> - ParsetreeViewer.isBinaryExpression ifExpr - || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes - | { pexp_desc = Pexp_newtype _ } -> false - | e -> - ParsetreeViewer.hasAttributes e.pexp_attributes - || ParsetreeViewer.isArrayAccess e) - in - Doc.group - (Doc.concat - [ - attrs; - header; - patternDoc; - Doc.text " ="; - (if shouldIndent then - Doc.indent (Doc.concat [ Doc.line; printedExpr ]) - else Doc.concat [ Doc.space; printedExpr ]); - ]) + Doc.group + (Doc.concat + [ + attrs; + header; + patternDoc; + Doc.text " ="; + (if shouldIndent then + Doc.indent (Doc.concat [Doc.line; printedExpr]) + else Doc.concat [Doc.space; printedExpr]); + ]) and printPackageType ~customLayout ~printModuleKeywordAndParens (packageType : Parsetree.package_type) cmtTbl = let doc = match packageType with | longidentLoc, [] -> - Doc.group (Doc.concat [ printLongidentLocation longidentLoc cmtTbl ]) + Doc.group (Doc.concat [printLongidentLocation longidentLoc cmtTbl]) | longidentLoc, packageConstraints -> - Doc.group - (Doc.concat - [ - printLongidentLocation longidentLoc cmtTbl; - printPackageConstraints ~customLayout packageConstraints cmtTbl; - Doc.softLine; - ]) + Doc.group + (Doc.concat + [ + printLongidentLocation longidentLoc cmtTbl; + printPackageConstraints ~customLayout packageConstraints cmtTbl; + Doc.softLine; + ]) in if printModuleKeywordAndParens then - Doc.concat [ Doc.text "module("; doc; Doc.rparen ] + Doc.concat [Doc.text "module("; doc; Doc.rparen] else doc and printPackageConstraints ~customLayout packageConstraints cmtTbl = @@ -55299,7 +55276,7 @@ and printExtension ~customLayout ~atModuleLvl (stringLoc, payload) cmtTbl = in printComments doc cmtTbl stringLoc.Location.loc in - Doc.group (Doc.concat [ extName; printPayload ~customLayout payload cmtTbl ]) + Doc.group (Doc.concat [extName; printPayload ~customLayout payload cmtTbl]) and printPattern ~customLayout (p : Parsetree.pattern) cmtTbl = let patternWithoutAttributes = @@ -55307,404 +55284,376 @@ and printPattern ~customLayout (p : Parsetree.pattern) cmtTbl = | Ppat_any -> Doc.text "_" | Ppat_var var -> printIdentLike var.txt | Ppat_constant c -> - let templateLiteral = - ParsetreeViewer.hasTemplateLiteralAttr p.ppat_attributes - in - printConstant ~templateLiteral c + let templateLiteral = + ParsetreeViewer.hasTemplateLiteralAttr p.ppat_attributes + in + printConstant ~templateLiteral c | Ppat_tuple patterns -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) - (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) - patterns); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) | Ppat_array [] -> - Doc.concat - [ Doc.lbracket; printCommentsInside cmtTbl p.ppat_loc; Doc.rbracket ] + Doc.concat + [Doc.lbracket; printCommentsInside cmtTbl p.ppat_loc; Doc.rbracket] | Ppat_array patterns -> - Doc.group - (Doc.concat - [ - Doc.text "["; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) - (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) - patterns); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.text "]"; - ]) - | Ppat_construct ({ txt = Longident.Lident "()" }, _) -> - Doc.concat - [ Doc.lparen; printCommentsInside cmtTbl p.ppat_loc; Doc.rparen ] - | Ppat_construct ({ txt = Longident.Lident "[]" }, _) -> + Doc.group + (Doc.concat + [ + Doc.text "["; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.text "]"; + ]) + | Ppat_construct ({txt = Longident.Lident "()"}, _) -> + Doc.concat [Doc.lparen; printCommentsInside cmtTbl p.ppat_loc; Doc.rparen] + | Ppat_construct ({txt = Longident.Lident "[]"}, _) -> + Doc.concat + [Doc.text "list{"; printCommentsInside cmtTbl p.ppat_loc; Doc.rbrace] + | Ppat_construct ({txt = Longident.Lident "::"}, _) -> + let patterns, tail = + ParsetreeViewer.collectPatternsFromListConstruct [] p + in + let shouldHug = + match (patterns, tail) with + | [pat], {ppat_desc = Ppat_construct ({txt = Longident.Lident "[]"}, _)} + when ParsetreeViewer.isHuggablePattern pat -> + true + | _ -> false + in + let children = Doc.concat [ - Doc.text "list{"; printCommentsInside cmtTbl p.ppat_loc; Doc.rbrace; + (if shouldHug then Doc.nil else Doc.softLine); + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); + (match tail.Parsetree.ppat_desc with + | Ppat_construct ({txt = Longident.Lident "[]"}, _) -> Doc.nil + | _ -> + let doc = + Doc.concat + [Doc.text "..."; printPattern ~customLayout tail cmtTbl] + in + let tail = printComments doc cmtTbl tail.ppat_loc in + Doc.concat [Doc.text ","; Doc.line; tail]); ] - | Ppat_construct ({ txt = Longident.Lident "::" }, _) -> - let patterns, tail = - ParsetreeViewer.collectPatternsFromListConstruct [] p - in - let shouldHug = - match (patterns, tail) with - | ( [ pat ], - { - ppat_desc = Ppat_construct ({ txt = Longident.Lident "[]" }, _); - } ) - when ParsetreeViewer.isHuggablePattern pat -> - true - | _ -> false - in - let children = + in + Doc.group + (Doc.concat + [ + Doc.text "list{"; + (if shouldHug then children + else + Doc.concat + [ + Doc.indent children; + Doc.ifBreaks (Doc.text ",") Doc.nil; + Doc.softLine; + ]); + Doc.rbrace; + ]) + | Ppat_construct (constrName, constructorArgs) -> + let constrName = printLongidentLocation constrName cmtTbl in + let argsDoc = + match constructorArgs with + | None -> Doc.nil + | Some + { + ppat_loc; + ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _); + } -> + Doc.concat + [Doc.lparen; printCommentsInside cmtTbl ppat_loc; Doc.rparen] + | Some {ppat_desc = Ppat_tuple []; ppat_loc = loc} -> + Doc.concat [Doc.lparen; printCommentsInside cmtTbl loc; Doc.rparen] + (* Some((1, 2) *) + | Some {ppat_desc = Ppat_tuple [({ppat_desc = Ppat_tuple _} as arg)]} -> + Doc.concat + [Doc.lparen; printPattern ~customLayout arg cmtTbl; Doc.rparen] + | Some {ppat_desc = Ppat_tuple patterns} -> Doc.concat [ - (if shouldHug then Doc.nil else Doc.softLine); - Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) - (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) - patterns); - (match tail.Parsetree.ppat_desc with - | Ppat_construct ({ txt = Longident.Lident "[]" }, _) -> Doc.nil - | _ -> - let doc = - Doc.concat - [ Doc.text "..."; printPattern ~customLayout tail cmtTbl ] - in - let tail = printComments doc cmtTbl tail.ppat_loc in - Doc.concat [ Doc.text ","; Doc.line; tail ]); - ] - in - Doc.group - (Doc.concat - [ - Doc.text "list{"; - (if shouldHug then children - else - Doc.concat + Doc.lparen; + Doc.indent + (Doc.concat [ - Doc.indent children; - Doc.ifBreaks (Doc.text ",") Doc.nil; Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); ]); - Doc.rbrace; - ]) - | Ppat_construct (constrName, constructorArgs) -> - let constrName = printLongidentLocation constrName cmtTbl in - let argsDoc = - match constructorArgs with - | None -> Doc.nil - | Some - { - ppat_loc; - ppat_desc = Ppat_construct ({ txt = Longident.Lident "()" }, _); - } -> - Doc.concat - [ Doc.lparen; printCommentsInside cmtTbl ppat_loc; Doc.rparen ] - | Some { ppat_desc = Ppat_tuple []; ppat_loc = loc } -> - Doc.concat - [ Doc.lparen; printCommentsInside cmtTbl loc; Doc.rparen ] - (* Some((1, 2) *) - | Some - { - ppat_desc = Ppat_tuple [ ({ ppat_desc = Ppat_tuple _ } as arg) ]; - } -> - Doc.concat - [ - Doc.lparen; printPattern ~customLayout arg cmtTbl; Doc.rparen; - ] - | Some { ppat_desc = Ppat_tuple patterns } -> - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) - patterns); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some arg -> - let argDoc = printPattern ~customLayout arg cmtTbl in - let shouldHug = ParsetreeViewer.isHuggablePattern arg in - Doc.concat - [ - Doc.lparen; - (if shouldHug then argDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [ Doc.softLine; argDoc ]); - Doc.trailingComma; - Doc.softLine; - ]); - Doc.rparen; - ] - in - Doc.group (Doc.concat [ constrName; argsDoc ]) + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + | Some arg -> + let argDoc = printPattern ~customLayout arg cmtTbl in + let shouldHug = ParsetreeViewer.isHuggablePattern arg in + Doc.concat + [ + Doc.lparen; + (if shouldHug then argDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [Doc.softLine; argDoc]); + Doc.trailingComma; + Doc.softLine; + ]); + Doc.rparen; + ] + in + Doc.group (Doc.concat [constrName; argsDoc]) | Ppat_variant (label, None) -> - Doc.concat [ Doc.text "#"; printPolyVarIdent label ] + Doc.concat [Doc.text "#"; printPolyVarIdent label] | Ppat_variant (label, variantArgs) -> - let variantName = - Doc.concat [ Doc.text "#"; printPolyVarIdent label ] - in - let argsDoc = - match variantArgs with - | None -> Doc.nil - | Some - { - ppat_desc = Ppat_construct ({ txt = Longident.Lident "()" }, _); - } -> - Doc.text "()" - | Some { ppat_desc = Ppat_tuple []; ppat_loc = loc } -> - Doc.concat - [ Doc.lparen; printCommentsInside cmtTbl loc; Doc.rparen ] - (* Some((1, 2) *) - | Some - { - ppat_desc = Ppat_tuple [ ({ ppat_desc = Ppat_tuple _ } as arg) ]; - } -> - Doc.concat - [ - Doc.lparen; printPattern ~customLayout arg cmtTbl; Doc.rparen; - ] - | Some { ppat_desc = Ppat_tuple patterns } -> - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) - patterns); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some arg -> - let argDoc = printPattern ~customLayout arg cmtTbl in - let shouldHug = ParsetreeViewer.isHuggablePattern arg in - Doc.concat - [ - Doc.lparen; - (if shouldHug then argDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [ Doc.softLine; argDoc ]); - Doc.trailingComma; - Doc.softLine; - ]); - Doc.rparen; - ] - in - Doc.group (Doc.concat [ variantName; argsDoc ]) - | Ppat_type ident -> - Doc.concat [ Doc.text "#..."; printIdentPath ident cmtTbl ] - | Ppat_record (rows, openFlag) -> - Doc.group - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) - (List.map - (fun row -> - printPatternRecordRow ~customLayout row cmtTbl) - rows); - (match openFlag with - | Open -> - Doc.concat [ Doc.text ","; Doc.line; Doc.text "_" ] - | Closed -> Doc.nil); - ]); - Doc.ifBreaks (Doc.text ",") Doc.nil; - Doc.softLine; - Doc.rbrace; - ]) + let variantName = Doc.concat [Doc.text "#"; printPolyVarIdent label] in + let argsDoc = + match variantArgs with + | None -> Doc.nil + | Some {ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _)} + -> + Doc.text "()" + | Some {ppat_desc = Ppat_tuple []; ppat_loc = loc} -> + Doc.concat [Doc.lparen; printCommentsInside cmtTbl loc; Doc.rparen] + (* Some((1, 2) *) + | Some {ppat_desc = Ppat_tuple [({ppat_desc = Ppat_tuple _} as arg)]} -> + Doc.concat + [Doc.lparen; printPattern ~customLayout arg cmtTbl; Doc.rparen] + | Some {ppat_desc = Ppat_tuple patterns} -> + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + | Some arg -> + let argDoc = printPattern ~customLayout arg cmtTbl in + let shouldHug = ParsetreeViewer.isHuggablePattern arg in + Doc.concat + [ + Doc.lparen; + (if shouldHug then argDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [Doc.softLine; argDoc]); + Doc.trailingComma; + Doc.softLine; + ]); + Doc.rparen; + ] + in + Doc.group (Doc.concat [variantName; argsDoc]) + | Ppat_type ident -> + Doc.concat [Doc.text "#..."; printIdentPath ident cmtTbl] + | Ppat_record (rows, openFlag) -> + Doc.group + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun row -> + printPatternRecordRow ~customLayout row cmtTbl) + rows); + (match openFlag with + | Open -> Doc.concat [Doc.text ","; Doc.line; Doc.text "_"] + | Closed -> Doc.nil); + ]); + Doc.ifBreaks (Doc.text ",") Doc.nil; + Doc.softLine; + Doc.rbrace; + ]) | Ppat_exception p -> - let needsParens = - match p.ppat_desc with - | Ppat_or (_, _) | Ppat_alias (_, _) -> true - | _ -> false - in - let pat = - let p = printPattern ~customLayout p cmtTbl in - if needsParens then Doc.concat [ Doc.text "("; p; Doc.text ")" ] - else p - in - Doc.group (Doc.concat [ Doc.text "exception"; Doc.line; pat ]) + let needsParens = + match p.ppat_desc with + | Ppat_or (_, _) | Ppat_alias (_, _) -> true + | _ -> false + in + let pat = + let p = printPattern ~customLayout p cmtTbl in + if needsParens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p + in + Doc.group (Doc.concat [Doc.text "exception"; Doc.line; pat]) | Ppat_or _ -> - (* Blue | Red | Green -> [Blue; Red; Green] *) - let orChain = ParsetreeViewer.collectOrPatternChain p in - let docs = - List.mapi - (fun i pat -> - let patternDoc = printPattern ~customLayout pat cmtTbl in - Doc.concat - [ - (if i == 0 then Doc.nil - else Doc.concat [ Doc.line; Doc.text "| " ]); - (match pat.ppat_desc with - (* (Blue | Red) | (Green | Black) | White *) - | Ppat_or _ -> addParens patternDoc - | _ -> patternDoc); - ]) - orChain - in - let isSpreadOverMultipleLines = - match (orChain, List.rev orChain) with - | first :: _, last :: _ -> - first.ppat_loc.loc_start.pos_lnum < last.ppat_loc.loc_end.pos_lnum - | _ -> false - in - Doc.breakableGroup ~forceBreak:isSpreadOverMultipleLines - (Doc.concat docs) + (* Blue | Red | Green -> [Blue; Red; Green] *) + let orChain = ParsetreeViewer.collectOrPatternChain p in + let docs = + List.mapi + (fun i pat -> + let patternDoc = printPattern ~customLayout pat cmtTbl in + Doc.concat + [ + (if i == 0 then Doc.nil + else Doc.concat [Doc.line; Doc.text "| "]); + (match pat.ppat_desc with + (* (Blue | Red) | (Green | Black) | White *) + | Ppat_or _ -> addParens patternDoc + | _ -> patternDoc); + ]) + orChain + in + let isSpreadOverMultipleLines = + match (orChain, List.rev orChain) with + | first :: _, last :: _ -> + first.ppat_loc.loc_start.pos_lnum < last.ppat_loc.loc_end.pos_lnum + | _ -> false + in + Doc.breakableGroup ~forceBreak:isSpreadOverMultipleLines (Doc.concat docs) | Ppat_extension ext -> - printExtension ~customLayout ~atModuleLvl:false ext cmtTbl + printExtension ~customLayout ~atModuleLvl:false ext cmtTbl | Ppat_lazy p -> - let needsParens = - match p.ppat_desc with - | Ppat_or (_, _) | Ppat_alias (_, _) -> true - | _ -> false - in - let pat = - let p = printPattern ~customLayout p cmtTbl in - if needsParens then Doc.concat [ Doc.text "("; p; Doc.text ")" ] - else p - in - Doc.concat [ Doc.text "lazy "; pat ] + let needsParens = + match p.ppat_desc with + | Ppat_or (_, _) | Ppat_alias (_, _) -> true + | _ -> false + in + let pat = + let p = printPattern ~customLayout p cmtTbl in + if needsParens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p + in + Doc.concat [Doc.text "lazy "; pat] | Ppat_alias (p, aliasLoc) -> - let needsParens = - match p.ppat_desc with - | Ppat_or (_, _) | Ppat_alias (_, _) -> true - | _ -> false - in - let renderedPattern = - let p = printPattern ~customLayout p cmtTbl in - if needsParens then Doc.concat [ Doc.text "("; p; Doc.text ")" ] - else p - in - Doc.concat - [ renderedPattern; Doc.text " as "; printStringLoc aliasLoc cmtTbl ] + let needsParens = + match p.ppat_desc with + | Ppat_or (_, _) | Ppat_alias (_, _) -> true + | _ -> false + in + let renderedPattern = + let p = printPattern ~customLayout p cmtTbl in + if needsParens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p + in + Doc.concat + [renderedPattern; Doc.text " as "; printStringLoc aliasLoc cmtTbl] (* Note: module(P : S) is represented as *) (* Ppat_constraint(Ppat_unpack, Ptyp_package) *) | Ppat_constraint - ( { ppat_desc = Ppat_unpack stringLoc }, - { ptyp_desc = Ptyp_package packageType; ptyp_loc } ) -> - Doc.concat - [ - Doc.text "module("; - printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; - Doc.text ": "; - printComments - (printPackageType ~customLayout ~printModuleKeywordAndParens:false - packageType cmtTbl) - cmtTbl ptyp_loc; - Doc.rparen; - ] + ( {ppat_desc = Ppat_unpack stringLoc}, + {ptyp_desc = Ptyp_package packageType; ptyp_loc} ) -> + Doc.concat + [ + Doc.text "module("; + printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; + Doc.text ": "; + printComments + (printPackageType ~customLayout ~printModuleKeywordAndParens:false + packageType cmtTbl) + cmtTbl ptyp_loc; + Doc.rparen; + ] | Ppat_constraint (pattern, typ) -> - Doc.concat - [ - printPattern ~customLayout pattern cmtTbl; - Doc.text ": "; - printTypExpr ~customLayout typ cmtTbl; - ] + Doc.concat + [ + printPattern ~customLayout pattern cmtTbl; + Doc.text ": "; + printTypExpr ~customLayout typ cmtTbl; + ] (* Note: module(P : S) is represented as *) (* Ppat_constraint(Ppat_unpack, Ptyp_package) *) | Ppat_unpack stringLoc -> - Doc.concat - [ - Doc.text "module("; - printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; - Doc.rparen; - ] + Doc.concat + [ + Doc.text "module("; + printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; + Doc.rparen; + ] | Ppat_interval (a, b) -> - Doc.concat [ printConstant a; Doc.text " .. "; printConstant b ] + Doc.concat [printConstant a; Doc.text " .. "; printConstant b] | Ppat_open _ -> Doc.nil in let doc = match p.ppat_attributes with | [] -> patternWithoutAttributes | attrs -> - Doc.group - (Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - patternWithoutAttributes; - ]) + Doc.group + (Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; patternWithoutAttributes; + ]) in printComments doc cmtTbl p.ppat_loc and printPatternRecordRow ~customLayout row cmtTbl = match row with (* punned {x}*) - | ( ({ Location.txt = Longident.Lident ident } as longident), - { Parsetree.ppat_desc = Ppat_var { txt; _ }; ppat_attributes } ) + | ( ({Location.txt = Longident.Lident ident} as longident), + {Parsetree.ppat_desc = Ppat_var {txt; _}; ppat_attributes} ) when ident = txt -> - Doc.concat - [ - printOptionalLabel ppat_attributes; - printAttributes ~customLayout ppat_attributes cmtTbl; - printLidentPath longident cmtTbl; - ] + Doc.concat + [ + printOptionalLabel ppat_attributes; + printAttributes ~customLayout ppat_attributes cmtTbl; + printLidentPath longident cmtTbl; + ] | longident, pattern -> - let locForComments = - { longident.loc with loc_end = pattern.Parsetree.ppat_loc.loc_end } - in - let rhsDoc = - let doc = printPattern ~customLayout pattern cmtTbl in - let doc = - if Parens.patternRecordRowRhs pattern then addParens doc else doc - in - Doc.concat [ printOptionalLabel pattern.ppat_attributes; doc ] - in + let locForComments = + {longident.loc with loc_end = pattern.Parsetree.ppat_loc.loc_end} + in + let rhsDoc = + let doc = printPattern ~customLayout pattern cmtTbl in let doc = - Doc.group - (Doc.concat - [ - printLidentPath longident cmtTbl; - Doc.text ":"; - (if ParsetreeViewer.isHuggablePattern pattern then - Doc.concat [ Doc.space; rhsDoc ] - else Doc.indent (Doc.concat [ Doc.line; rhsDoc ])); - ]) + if Parens.patternRecordRowRhs pattern then addParens doc else doc in - printComments doc cmtTbl locForComments + Doc.concat [printOptionalLabel pattern.ppat_attributes; doc] + in + let doc = + Doc.group + (Doc.concat + [ + printLidentPath longident cmtTbl; + Doc.text ":"; + (if ParsetreeViewer.isHuggablePattern pattern then + Doc.concat [Doc.space; rhsDoc] + else Doc.indent (Doc.concat [Doc.line; rhsDoc])); + ]) + in + printComments doc cmtTbl locForComments and printExpressionWithComments ~customLayout expr cmtTbl : Doc.t = let doc = printExpression ~customLayout expr cmtTbl in @@ -55719,55 +55668,54 @@ and printIfChain ~customLayout pexp_attributes ifs elseExpr cmtTbl = let doc = match ifExpr with | ParsetreeViewer.If ifExpr -> - let condition = - if ParsetreeViewer.isBlockExpr ifExpr then - printExpressionBlock ~customLayout ~braces:true ifExpr - cmtTbl - else - let doc = - printExpressionWithComments ~customLayout ifExpr cmtTbl - in - match Parens.expr ifExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc ifExpr braces - | Nothing -> Doc.ifBreaks (addParens doc) doc - in - Doc.concat - [ - ifTxt; - Doc.group condition; - Doc.space; - (let thenExpr = - match ParsetreeViewer.processBracesAttr thenExpr with - (* This case only happens when coming from Reason, we strip braces *) - | Some _, expr -> expr - | _ -> thenExpr - in - printExpressionBlock ~customLayout ~braces:true thenExpr - cmtTbl); - ] - | IfLet (pattern, conditionExpr) -> - let conditionDoc = + let condition = + if ParsetreeViewer.isBlockExpr ifExpr then + printExpressionBlock ~customLayout ~braces:true ifExpr cmtTbl + else let doc = - printExpressionWithComments ~customLayout conditionExpr - cmtTbl + printExpressionWithComments ~customLayout ifExpr cmtTbl in - match Parens.expr conditionExpr with + match Parens.expr ifExpr with | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc conditionExpr braces - | Nothing -> doc + | Braced braces -> printBraces doc ifExpr braces + | Nothing -> Doc.ifBreaks (addParens doc) doc + in + Doc.concat + [ + ifTxt; + Doc.group condition; + Doc.space; + (let thenExpr = + match ParsetreeViewer.processBracesAttr thenExpr with + (* This case only happens when coming from Reason, we strip braces *) + | Some _, expr -> expr + | _ -> thenExpr + in + printExpressionBlock ~customLayout ~braces:true thenExpr + cmtTbl); + ] + | IfLet (pattern, conditionExpr) -> + let conditionDoc = + let doc = + printExpressionWithComments ~customLayout conditionExpr + cmtTbl in - Doc.concat - [ - ifTxt; - Doc.text "let "; - printPattern ~customLayout pattern cmtTbl; - Doc.text " = "; - conditionDoc; - Doc.space; - printExpressionBlock ~customLayout ~braces:true thenExpr - cmtTbl; - ] + match Parens.expr conditionExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc conditionExpr braces + | Nothing -> doc + in + Doc.concat + [ + ifTxt; + Doc.text "let "; + printPattern ~customLayout pattern cmtTbl; + Doc.text " = "; + conditionDoc; + Doc.space; + printExpressionBlock ~customLayout ~braces:true thenExpr + cmtTbl; + ] in printLeadingComments doc cmtTbl.leading outerLoc) ifs) @@ -55776,736 +55724,707 @@ and printIfChain ~customLayout pexp_attributes ifs elseExpr cmtTbl = match elseExpr with | None -> Doc.nil | Some expr -> - Doc.concat - [ - Doc.text " else "; - printExpressionBlock ~customLayout ~braces:true expr cmtTbl; - ] + Doc.concat + [ + Doc.text " else "; + printExpressionBlock ~customLayout ~braces:true expr cmtTbl; + ] in let attrs = ParsetreeViewer.filterFragileMatchAttributes pexp_attributes in - Doc.concat [ printAttributes ~customLayout attrs cmtTbl; ifDocs; elseDoc ] + Doc.concat [printAttributes ~customLayout attrs cmtTbl; ifDocs; elseDoc] and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = let printedExpression = match e.pexp_desc with | Parsetree.Pexp_constant c -> - printConstant ~templateLiteral:(ParsetreeViewer.isTemplateLiteral e) c + printConstant ~templateLiteral:(ParsetreeViewer.isTemplateLiteral e) c | Pexp_construct _ when ParsetreeViewer.hasJsxAttribute e.pexp_attributes -> - printJsxFragment ~customLayout e cmtTbl - | Pexp_construct ({ txt = Longident.Lident "()" }, _) -> Doc.text "()" - | Pexp_construct ({ txt = Longident.Lident "[]" }, _) -> - Doc.concat - [ - Doc.text "list{"; printCommentsInside cmtTbl e.pexp_loc; Doc.rbrace; - ] - | Pexp_construct ({ txt = Longident.Lident "::" }, _) -> - let expressions, spread = ParsetreeViewer.collectListExpressions e in - let spreadDoc = - match spread with - | Some expr -> - Doc.concat - [ - Doc.text ","; - Doc.line; - Doc.dotdotdot; - (let doc = - printExpressionWithComments ~customLayout expr cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); - ] - | None -> Doc.nil - in - Doc.group - (Doc.concat - [ - Doc.text "list{"; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) - (List.map - (fun expr -> - let doc = - printExpressionWithComments ~customLayout expr - cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - expressions); - spreadDoc; - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ]) + printJsxFragment ~customLayout e cmtTbl + | Pexp_construct ({txt = Longident.Lident "()"}, _) -> Doc.text "()" + | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> + Doc.concat + [Doc.text "list{"; printCommentsInside cmtTbl e.pexp_loc; Doc.rbrace] + | Pexp_construct ({txt = Longident.Lident "::"}, _) -> + let expressions, spread = ParsetreeViewer.collectListExpressions e in + let spreadDoc = + match spread with + | Some expr -> + Doc.concat + [ + Doc.text ","; + Doc.line; + Doc.dotdotdot; + (let doc = + printExpressionWithComments ~customLayout expr cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + ] + | None -> Doc.nil + in + Doc.group + (Doc.concat + [ + Doc.text "list{"; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + expressions); + spreadDoc; + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ]) | Pexp_construct (longidentLoc, args) -> - let constr = printLongidentLocation longidentLoc cmtTbl in - let args = - match args with - | None -> Doc.nil - | Some - { - pexp_desc = Pexp_construct ({ txt = Longident.Lident "()" }, _); - } -> - Doc.text "()" - (* Some((1, 2)) *) - | Some - { - pexp_desc = Pexp_tuple [ ({ pexp_desc = Pexp_tuple _ } as arg) ]; - } -> - Doc.concat - [ - Doc.lparen; - (let doc = - printExpressionWithComments ~customLayout arg cmtTbl - in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc); - Doc.rparen; - ] - | Some { pexp_desc = Pexp_tuple args } -> - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun expr -> - let doc = - printExpressionWithComments ~customLayout expr - cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some arg -> - let argDoc = - let doc = - printExpressionWithComments ~customLayout arg cmtTbl - in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc - in - let shouldHug = ParsetreeViewer.isHuggableExpression arg in - Doc.concat - [ - Doc.lparen; - (if shouldHug then argDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [ Doc.softLine; argDoc ]); - Doc.trailingComma; - Doc.softLine; - ]); - Doc.rparen; - ] - in - Doc.group (Doc.concat [ constr; args ]) - | Pexp_ident path -> printLidentPath path cmtTbl - | Pexp_tuple exprs -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) - (List.map - (fun expr -> - let doc = - printExpressionWithComments ~customLayout expr - cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - exprs); - ]); - Doc.ifBreaks (Doc.text ",") Doc.nil; - Doc.softLine; - Doc.rparen; - ]) - | Pexp_array [] -> - Doc.concat - [ Doc.lbracket; printCommentsInside cmtTbl e.pexp_loc; Doc.rbracket ] + let constr = printLongidentLocation longidentLoc cmtTbl in + let args = + match args with + | None -> Doc.nil + | Some {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)} + -> + Doc.text "()" + (* Some((1, 2)) *) + | Some {pexp_desc = Pexp_tuple [({pexp_desc = Pexp_tuple _} as arg)]} -> + Doc.concat + [ + Doc.lparen; + (let doc = printExpressionWithComments ~customLayout arg cmtTbl in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc); + Doc.rparen; + ] + | Some {pexp_desc = Pexp_tuple args} -> + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + | Some arg -> + let argDoc = + let doc = printExpressionWithComments ~customLayout arg cmtTbl in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc + in + let shouldHug = ParsetreeViewer.isHuggableExpression arg in + Doc.concat + [ + Doc.lparen; + (if shouldHug then argDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [Doc.softLine; argDoc]); + Doc.trailingComma; + Doc.softLine; + ]); + Doc.rparen; + ] + in + Doc.group (Doc.concat [constr; args]) + | Pexp_ident path -> printLidentPath path cmtTbl + | Pexp_tuple exprs -> + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + exprs); + ]); + Doc.ifBreaks (Doc.text ",") Doc.nil; + Doc.softLine; + Doc.rparen; + ]) + | Pexp_array [] -> + Doc.concat + [Doc.lbracket; printCommentsInside cmtTbl e.pexp_loc; Doc.rbracket] | Pexp_array exprs -> - Doc.group + Doc.group + (Doc.concat + [ + Doc.lbracket; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + exprs); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbracket; + ]) + | Pexp_variant (label, args) -> + let variantName = Doc.concat [Doc.text "#"; printPolyVarIdent label] in + let args = + match args with + | None -> Doc.nil + | Some {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)} + -> + Doc.text "()" + (* #poly((1, 2) *) + | Some {pexp_desc = Pexp_tuple [({pexp_desc = Pexp_tuple _} as arg)]} -> + Doc.concat + [ + Doc.lparen; + (let doc = printExpressionWithComments ~customLayout arg cmtTbl in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc); + Doc.rparen; + ] + | Some {pexp_desc = Pexp_tuple args} -> + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + | Some arg -> + let argDoc = + let doc = printExpressionWithComments ~customLayout arg cmtTbl in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc + in + let shouldHug = ParsetreeViewer.isHuggableExpression arg in + Doc.concat + [ + Doc.lparen; + (if shouldHug then argDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [Doc.softLine; argDoc]); + Doc.trailingComma; + Doc.softLine; + ]); + Doc.rparen; + ] + in + Doc.group (Doc.concat [variantName; args]) + | Pexp_record (rows, spreadExpr) -> + if rows = [] then + Doc.concat + [Doc.lbrace; printCommentsInside cmtTbl e.pexp_loc; Doc.rbrace] + else + let spread = + match spreadExpr with + | None -> Doc.nil + | Some expr -> + Doc.concat + [ + Doc.dotdotdot; + (let doc = + printExpressionWithComments ~customLayout expr cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + Doc.comma; + Doc.line; + ] + in + (* If the record is written over multiple lines, break automatically + * `let x = {a: 1, b: 3}` -> same line, break when line-width exceeded + * `let x = { + * a: 1, + * b: 2, + * }` -> record is written on multiple lines, break the group *) + let forceBreak = + e.pexp_loc.loc_start.pos_lnum < e.pexp_loc.loc_end.pos_lnum + in + let punningAllowed = + match (spreadExpr, rows) with + | None, [_] -> false (* disallow punning for single-element records *) + | _ -> true + in + Doc.breakableGroup ~forceBreak (Doc.concat [ - Doc.lbracket; + Doc.lbrace; Doc.indent (Doc.concat [ Doc.softLine; + spread; Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) + ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map - (fun expr -> - let doc = - printExpressionWithComments ~customLayout expr - cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - exprs); + (fun row -> + printExpressionRecordRow ~customLayout row cmtTbl + punningAllowed) + rows); ]); Doc.trailingComma; Doc.softLine; - Doc.rbracket; + Doc.rbrace; ]) - | Pexp_variant (label, args) -> - let variantName = - Doc.concat [ Doc.text "#"; printPolyVarIdent label ] - in - let args = - match args with - | None -> Doc.nil - | Some - { - pexp_desc = Pexp_construct ({ txt = Longident.Lident "()" }, _); - } -> - Doc.text "()" - (* #poly((1, 2) *) - | Some - { - pexp_desc = Pexp_tuple [ ({ pexp_desc = Pexp_tuple _ } as arg) ]; - } -> - Doc.concat - [ - Doc.lparen; - (let doc = - printExpressionWithComments ~customLayout arg cmtTbl - in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc); - Doc.rparen; - ] - | Some { pexp_desc = Pexp_tuple args } -> - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun expr -> - let doc = - printExpressionWithComments ~customLayout expr - cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some arg -> - let argDoc = - let doc = - printExpressionWithComments ~customLayout arg cmtTbl - in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc - in - let shouldHug = ParsetreeViewer.isHuggableExpression arg in - Doc.concat - [ - Doc.lparen; - (if shouldHug then argDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [ Doc.softLine; argDoc ]); - Doc.trailingComma; - Doc.softLine; - ]); - Doc.rparen; - ] - in - Doc.group (Doc.concat [ variantName; args ]) - | Pexp_record (rows, spreadExpr) -> - if rows = [] then - Doc.concat - [ Doc.lbrace; printCommentsInside cmtTbl e.pexp_loc; Doc.rbrace ] - else - let spread = - match spreadExpr with - | None -> Doc.nil - | Some expr -> - Doc.concat - [ - Doc.dotdotdot; - (let doc = - printExpressionWithComments ~customLayout expr cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); - Doc.comma; - Doc.line; - ] - in - (* If the record is written over multiple lines, break automatically - * `let x = {a: 1, b: 3}` -> same line, break when line-width exceeded - * `let x = { - * a: 1, - * b: 2, - * }` -> record is written on multiple lines, break the group *) - let forceBreak = - e.pexp_loc.loc_start.pos_lnum < e.pexp_loc.loc_end.pos_lnum - in - let punningAllowed = - match (spreadExpr, rows) with - | None, [ _ ] -> - false (* disallow punning for single-element records *) - | _ -> true - in - Doc.breakableGroup ~forceBreak - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - spread; - Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) - (List.map - (fun row -> - printExpressionRecordRow ~customLayout row cmtTbl - punningAllowed) - rows); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ]) | Pexp_extension extension -> ( - match extension with - | ( { txt = "bs.obj" | "obj" }, - PStr - [ - { - pstr_loc = loc; - pstr_desc = - Pstr_eval ({ pexp_desc = Pexp_record (rows, _) }, []); - }; - ] ) -> - (* If the object is written over multiple lines, break automatically - * `let x = {"a": 1, "b": 3}` -> same line, break when line-width exceeded - * `let x = { - * "a": 1, - * "b": 2, - * }` -> object is written on multiple lines, break the group *) - let forceBreak = loc.loc_start.pos_lnum < loc.loc_end.pos_lnum in - Doc.breakableGroup ~forceBreak - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) - (List.map - (fun row -> - printBsObjectRow ~customLayout row cmtTbl) - rows); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ]) - | extension -> - printExtension ~customLayout ~atModuleLvl:false extension cmtTbl) - | Pexp_apply (e, [ (Nolabel, { pexp_desc = Pexp_array subLists }) ]) + match extension with + | ( {txt = "bs.obj" | "obj"}, + PStr + [ + { + pstr_loc = loc; + pstr_desc = Pstr_eval ({pexp_desc = Pexp_record (rows, _)}, []); + }; + ] ) -> + (* If the object is written over multiple lines, break automatically + * `let x = {"a": 1, "b": 3}` -> same line, break when line-width exceeded + * `let x = { + * "a": 1, + * "b": 2, + * }` -> object is written on multiple lines, break the group *) + let forceBreak = loc.loc_start.pos_lnum < loc.loc_end.pos_lnum in + Doc.breakableGroup ~forceBreak + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun row -> + printBsObjectRow ~customLayout row cmtTbl) + rows); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ]) + | extension -> + printExtension ~customLayout ~atModuleLvl:false extension cmtTbl) + | Pexp_apply (e, [(Nolabel, {pexp_desc = Pexp_array subLists})]) when ParsetreeViewer.isSpreadBeltListConcat e -> - printBeltListConcatApply ~customLayout subLists cmtTbl + printBeltListConcatApply ~customLayout subLists cmtTbl | Pexp_apply _ -> - if ParsetreeViewer.isUnaryExpression e then - printUnaryExpression ~customLayout e cmtTbl - else if ParsetreeViewer.isTemplateLiteral e then - printTemplateLiteral ~customLayout e cmtTbl - else if ParsetreeViewer.isBinaryExpression e then - printBinaryExpression ~customLayout e cmtTbl - else printPexpApply ~customLayout e cmtTbl + if ParsetreeViewer.isUnaryExpression e then + printUnaryExpression ~customLayout e cmtTbl + else if ParsetreeViewer.isTemplateLiteral e then + printTemplateLiteral ~customLayout e cmtTbl + else if ParsetreeViewer.isBinaryExpression e then + printBinaryExpression ~customLayout e cmtTbl + else printPexpApply ~customLayout e cmtTbl | Pexp_unreachable -> Doc.dot | Pexp_field (expr, longidentLoc) -> - let lhs = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.fieldExpr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat [ lhs; Doc.dot; printLidentPath longidentLoc cmtTbl ] + let lhs = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.fieldExpr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [lhs; Doc.dot; printLidentPath longidentLoc cmtTbl] | Pexp_setfield (expr1, longidentLoc, expr2) -> - printSetFieldExpr ~customLayout e.pexp_attributes expr1 longidentLoc - expr2 e.pexp_loc cmtTbl + printSetFieldExpr ~customLayout e.pexp_attributes expr1 longidentLoc expr2 + e.pexp_loc cmtTbl | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) when ParsetreeViewer.isTernaryExpr e -> - let parts, alternate = ParsetreeViewer.collectTernaryParts e in - let ternaryDoc = - match parts with - | (condition1, consequent1) :: rest -> - Doc.group - (Doc.concat - [ - printTernaryOperand ~customLayout condition1 cmtTbl; - Doc.indent - (Doc.concat - [ - Doc.line; - Doc.indent - (Doc.concat + let parts, alternate = ParsetreeViewer.collectTernaryParts e in + let ternaryDoc = + match parts with + | (condition1, consequent1) :: rest -> + Doc.group + (Doc.concat + [ + printTernaryOperand ~customLayout condition1 cmtTbl; + Doc.indent + (Doc.concat + [ + Doc.line; + Doc.indent + (Doc.concat + [ + Doc.text "? "; + printTernaryOperand ~customLayout consequent1 + cmtTbl; + ]); + Doc.concat + (List.map + (fun (condition, consequent) -> + Doc.concat [ + Doc.line; + Doc.text ": "; + printTernaryOperand ~customLayout condition + cmtTbl; + Doc.line; Doc.text "? "; - printTernaryOperand ~customLayout consequent1 + printTernaryOperand ~customLayout consequent cmtTbl; - ]); - Doc.concat - (List.map - (fun (condition, consequent) -> - Doc.concat - [ - Doc.line; - Doc.text ": "; - printTernaryOperand ~customLayout - condition cmtTbl; - Doc.line; - Doc.text "? "; - printTernaryOperand ~customLayout - consequent cmtTbl; - ]) - rest); - Doc.line; - Doc.text ": "; - Doc.indent - (printTernaryOperand ~customLayout alternate - cmtTbl); - ]); - ]) - | _ -> Doc.nil - in - let attrs = ParsetreeViewer.filterTernaryAttributes e.pexp_attributes in - let needsParens = - match ParsetreeViewer.filterParsingAttrs attrs with - | [] -> false - | _ -> true - in - Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - (if needsParens then addParens ternaryDoc else ternaryDoc); - ] + ]) + rest); + Doc.line; + Doc.text ": "; + Doc.indent + (printTernaryOperand ~customLayout alternate cmtTbl); + ]); + ]) + | _ -> Doc.nil + in + let attrs = ParsetreeViewer.filterTernaryAttributes e.pexp_attributes in + let needsParens = + match ParsetreeViewer.filterParsingAttrs attrs with + | [] -> false + | _ -> true + in + Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + (if needsParens then addParens ternaryDoc else ternaryDoc); + ] | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) -> - let ifs, elseExpr = ParsetreeViewer.collectIfExpressions e in - printIfChain ~customLayout e.pexp_attributes ifs elseExpr cmtTbl + let ifs, elseExpr = ParsetreeViewer.collectIfExpressions e in + printIfChain ~customLayout e.pexp_attributes ifs elseExpr cmtTbl | Pexp_while (expr1, expr2) -> - let condition = - let doc = printExpressionWithComments ~customLayout expr1 cmtTbl in - match Parens.expr expr1 with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr1 braces - | Nothing -> doc - in - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.text "while "; - (if ParsetreeViewer.isBlockExpr expr1 then condition - else Doc.group (Doc.ifBreaks (addParens condition) condition)); - Doc.space; - printExpressionBlock ~customLayout ~braces:true expr2 cmtTbl; - ]) + let condition = + let doc = printExpressionWithComments ~customLayout expr1 cmtTbl in + match Parens.expr expr1 with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr1 braces + | Nothing -> doc + in + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.text "while "; + (if ParsetreeViewer.isBlockExpr expr1 then condition + else Doc.group (Doc.ifBreaks (addParens condition) condition)); + Doc.space; + printExpressionBlock ~customLayout ~braces:true expr2 cmtTbl; + ]) | Pexp_for (pattern, fromExpr, toExpr, directionFlag, body) -> - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.text "for "; - printPattern ~customLayout pattern cmtTbl; - Doc.text " in "; - (let doc = - printExpressionWithComments ~customLayout fromExpr cmtTbl - in - match Parens.expr fromExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc fromExpr braces - | Nothing -> doc); - printDirectionFlag directionFlag; - (let doc = - printExpressionWithComments ~customLayout toExpr cmtTbl - in - match Parens.expr toExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc toExpr braces - | Nothing -> doc); - Doc.space; - printExpressionBlock ~customLayout ~braces:true body cmtTbl; - ]) - | Pexp_constraint - ( { pexp_desc = Pexp_pack modExpr }, - { ptyp_desc = Ptyp_package packageType; ptyp_loc } ) -> - Doc.group - (Doc.concat - [ - Doc.text "module("; - Doc.indent - (Doc.concat - [ - Doc.softLine; - printModExpr ~customLayout modExpr cmtTbl; - Doc.text ": "; - printComments - (printPackageType ~customLayout - ~printModuleKeywordAndParens:false packageType cmtTbl) - cmtTbl ptyp_loc; - ]); - Doc.softLine; - Doc.rparen; - ]) + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.text "for "; + printPattern ~customLayout pattern cmtTbl; + Doc.text " in "; + (let doc = + printExpressionWithComments ~customLayout fromExpr cmtTbl + in + match Parens.expr fromExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc fromExpr braces + | Nothing -> doc); + printDirectionFlag directionFlag; + (let doc = + printExpressionWithComments ~customLayout toExpr cmtTbl + in + match Parens.expr toExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc toExpr braces + | Nothing -> doc); + Doc.space; + printExpressionBlock ~customLayout ~braces:true body cmtTbl; + ]) + | Pexp_constraint + ( {pexp_desc = Pexp_pack modExpr}, + {ptyp_desc = Ptyp_package packageType; ptyp_loc} ) -> + Doc.group + (Doc.concat + [ + Doc.text "module("; + Doc.indent + (Doc.concat + [ + Doc.softLine; + printModExpr ~customLayout modExpr cmtTbl; + Doc.text ": "; + printComments + (printPackageType ~customLayout + ~printModuleKeywordAndParens:false packageType cmtTbl) + cmtTbl ptyp_loc; + ]); + Doc.softLine; + Doc.rparen; + ]) | Pexp_constraint (expr, typ) -> - let exprDoc = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat - [ exprDoc; Doc.text ": "; printTypExpr ~customLayout typ cmtTbl ] - | Pexp_letmodule ({ txt = _modName }, _modExpr, _expr) -> - printExpressionBlock ~customLayout ~braces:true e cmtTbl + let exprDoc = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [exprDoc; Doc.text ": "; printTypExpr ~customLayout typ cmtTbl] + | Pexp_letmodule ({txt = _modName}, _modExpr, _expr) -> + printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_letexception (_extensionConstructor, _expr) -> - printExpressionBlock ~customLayout ~braces:true e cmtTbl + printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_assert expr -> - let rhs = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.lazyOrAssertOrAwaitExprRhs expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat [ Doc.text "assert "; rhs ] + let rhs = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.lazyOrAssertOrAwaitExprRhs expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [Doc.text "assert "; rhs] | Pexp_lazy expr -> - let rhs = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.lazyOrAssertOrAwaitExprRhs expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.group (Doc.concat [ Doc.text "lazy "; rhs ]) + let rhs = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.lazyOrAssertOrAwaitExprRhs expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.group (Doc.concat [Doc.text "lazy "; rhs]) | Pexp_open (_overrideFlag, _longidentLoc, _expr) -> - printExpressionBlock ~customLayout ~braces:true e cmtTbl + printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_pack modExpr -> - Doc.group - (Doc.concat - [ - Doc.text "module("; - Doc.indent - (Doc.concat - [ Doc.softLine; printModExpr ~customLayout modExpr cmtTbl ]); - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + Doc.text "module("; + Doc.indent + (Doc.concat + [Doc.softLine; printModExpr ~customLayout modExpr cmtTbl]); + Doc.softLine; + Doc.rparen; + ]) | Pexp_sequence _ -> - printExpressionBlock ~customLayout ~braces:true e cmtTbl + printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_let _ -> printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_fun ( Nolabel, None, - { ppat_desc = Ppat_var { txt = "__x" } }, - { pexp_desc = Pexp_apply _ } ) -> - (* (__x) => f(a, __x, c) -----> f(a, _, c) *) - printExpressionWithComments ~customLayout - (ParsetreeViewer.rewriteUnderscoreApply e) - cmtTbl + {ppat_desc = Ppat_var {txt = "__x"}}, + {pexp_desc = Pexp_apply _} ) -> + (* (__x) => f(a, __x, c) -----> f(a, _, c) *) + printExpressionWithComments ~customLayout + (ParsetreeViewer.rewriteUnderscoreApply e) + cmtTbl | Pexp_fun _ | Pexp_newtype _ -> - let attrsOnArrow, parameters, returnExpr = ParsetreeViewer.funExpr e in - let ParsetreeViewer.{ async; uncurried; attributes = attrs } = - ParsetreeViewer.processFunctionAttributes attrsOnArrow + let attrsOnArrow, parameters, returnExpr = ParsetreeViewer.funExpr e in + let ParsetreeViewer.{async; uncurried; attributes = attrs} = + ParsetreeViewer.processFunctionAttributes attrsOnArrow + in + let returnExpr, typConstraint = + match returnExpr.pexp_desc with + | Pexp_constraint (expr, typ) -> + ( { + expr with + pexp_attributes = + List.concat [expr.pexp_attributes; returnExpr.pexp_attributes]; + }, + Some typ ) + | _ -> (returnExpr, None) + in + let hasConstraint = + match typConstraint with + | Some _ -> true + | None -> false + in + let parametersDoc = + printExprFunParameters ~customLayout ~inCallback:NoCallback ~uncurried + ~async ~hasConstraint parameters cmtTbl + in + let returnExprDoc = + let optBraces, _ = ParsetreeViewer.processBracesAttr returnExpr in + let shouldInline = + match (returnExpr.pexp_desc, optBraces) with + | _, Some _ -> true + | ( ( Pexp_array _ | Pexp_tuple _ + | Pexp_construct (_, Some _) + | Pexp_record _ ), + _ ) -> + true + | _ -> false in - let returnExpr, typConstraint = + let shouldIndent = match returnExpr.pexp_desc with - | Pexp_constraint (expr, typ) -> - ( { - expr with - pexp_attributes = - List.concat - [ expr.pexp_attributes; returnExpr.pexp_attributes ]; - }, - Some typ ) - | _ -> (returnExpr, None) - in - let hasConstraint = - match typConstraint with Some _ -> true | None -> false - in - let parametersDoc = - printExprFunParameters ~customLayout ~inCallback:NoCallback ~uncurried - ~async ~hasConstraint parameters cmtTbl + | Pexp_sequence _ | Pexp_let _ | Pexp_letmodule _ + | Pexp_letexception _ | Pexp_open _ -> + false + | _ -> true in - let returnExprDoc = - let optBraces, _ = ParsetreeViewer.processBracesAttr returnExpr in - let shouldInline = - match (returnExpr.pexp_desc, optBraces) with - | _, Some _ -> true - | ( ( Pexp_array _ | Pexp_tuple _ - | Pexp_construct (_, Some _) - | Pexp_record _ ), - _ ) -> - true - | _ -> false - in - let shouldIndent = - match returnExpr.pexp_desc with - | Pexp_sequence _ | Pexp_let _ | Pexp_letmodule _ - | Pexp_letexception _ | Pexp_open _ -> - false - | _ -> true - in - let returnDoc = - let doc = - printExpressionWithComments ~customLayout returnExpr cmtTbl - in - match Parens.expr returnExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc returnExpr braces - | Nothing -> doc + let returnDoc = + let doc = + printExpressionWithComments ~customLayout returnExpr cmtTbl in - if shouldInline then Doc.concat [ Doc.space; returnDoc ] - else - Doc.group - (if shouldIndent then - Doc.indent (Doc.concat [ Doc.line; returnDoc ]) - else Doc.concat [ Doc.space; returnDoc ]) - in - let typConstraintDoc = - match typConstraint with - | Some typ -> - let typDoc = - let doc = printTypExpr ~customLayout typ cmtTbl in - if Parens.arrowReturnTypExpr typ then addParens doc else doc - in - Doc.concat [ Doc.text ": "; typDoc ] - | _ -> Doc.nil - in - let attrs = printAttributes ~customLayout attrs cmtTbl in - Doc.group - (Doc.concat - [ - attrs; - parametersDoc; - typConstraintDoc; - Doc.text " =>"; - returnExprDoc; - ]) - | Pexp_try (expr, cases) -> - let exprDoc = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with + match Parens.expr returnExpr with | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces + | Braced braces -> printBraces doc returnExpr braces | Nothing -> doc in - Doc.concat - [ - Doc.text "try "; - exprDoc; - Doc.text " catch "; - printCases ~customLayout cases cmtTbl; - ] - | Pexp_match (_, [ _; _ ]) when ParsetreeViewer.isIfLetExpr e -> - let ifs, elseExpr = ParsetreeViewer.collectIfExpressions e in - printIfChain ~customLayout e.pexp_attributes ifs elseExpr cmtTbl + if shouldInline then Doc.concat [Doc.space; returnDoc] + else + Doc.group + (if shouldIndent then Doc.indent (Doc.concat [Doc.line; returnDoc]) + else Doc.concat [Doc.space; returnDoc]) + in + let typConstraintDoc = + match typConstraint with + | Some typ -> + let typDoc = + let doc = printTypExpr ~customLayout typ cmtTbl in + if Parens.arrowReturnTypExpr typ then addParens doc else doc + in + Doc.concat [Doc.text ": "; typDoc] + | _ -> Doc.nil + in + let attrs = printAttributes ~customLayout attrs cmtTbl in + Doc.group + (Doc.concat + [ + attrs; + parametersDoc; + typConstraintDoc; + Doc.text " =>"; + returnExprDoc; + ]) + | Pexp_try (expr, cases) -> + let exprDoc = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat + [ + Doc.text "try "; + exprDoc; + Doc.text " catch "; + printCases ~customLayout cases cmtTbl; + ] + | Pexp_match (_, [_; _]) when ParsetreeViewer.isIfLetExpr e -> + let ifs, elseExpr = ParsetreeViewer.collectIfExpressions e in + printIfChain ~customLayout e.pexp_attributes ifs elseExpr cmtTbl | Pexp_match (expr, cases) -> - let exprDoc = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat - [ - Doc.text "switch "; - exprDoc; - Doc.space; - printCases ~customLayout cases cmtTbl; - ] + let exprDoc = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat + [ + Doc.text "switch "; + exprDoc; + Doc.space; + printCases ~customLayout cases cmtTbl; + ] | Pexp_function cases -> - Doc.concat - [ Doc.text "x => switch x "; printCases ~customLayout cases cmtTbl ] + Doc.concat + [Doc.text "x => switch x "; printCases ~customLayout cases cmtTbl] | Pexp_coerce (expr, typOpt, typ) -> - let docExpr = printExpressionWithComments ~customLayout expr cmtTbl in - let docTyp = printTypExpr ~customLayout typ cmtTbl in - let ofType = - match typOpt with - | None -> Doc.nil - | Some typ1 -> - Doc.concat - [ Doc.text ": "; printTypExpr ~customLayout typ1 cmtTbl ] - in - Doc.concat - [ Doc.lparen; docExpr; ofType; Doc.text " :> "; docTyp; Doc.rparen ] + let docExpr = printExpressionWithComments ~customLayout expr cmtTbl in + let docTyp = printTypExpr ~customLayout typ cmtTbl in + let ofType = + match typOpt with + | None -> Doc.nil + | Some typ1 -> + Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ1 cmtTbl] + in + Doc.concat + [Doc.lparen; docExpr; ofType; Doc.text " :> "; docTyp; Doc.rparen] | Pexp_send (parentExpr, label) -> - let parentDoc = - let doc = - printExpressionWithComments ~customLayout parentExpr cmtTbl - in - match Parens.unaryExprOperand parentExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces - | Nothing -> doc - in - let member = - let memberDoc = printComments (Doc.text label.txt) cmtTbl label.loc in - Doc.concat [ Doc.text "\""; memberDoc; Doc.text "\"" ] - in - Doc.group (Doc.concat [ parentDoc; Doc.lbracket; member; Doc.rbracket ]) + let parentDoc = + let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in + match Parens.unaryExprOperand parentExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc parentExpr braces + | Nothing -> doc + in + let member = + let memberDoc = printComments (Doc.text label.txt) cmtTbl label.loc in + Doc.concat [Doc.text "\""; memberDoc; Doc.text "\""] + in + Doc.group (Doc.concat [parentDoc; Doc.lbracket; member; Doc.rbracket]) | Pexp_new _ -> Doc.text "Pexp_new not impemented in printer" | Pexp_setinstvar _ -> Doc.text "Pexp_setinstvar not impemented in printer" | Pexp_override _ -> Doc.text "Pexp_override not impemented in printer" @@ -56522,7 +56441,7 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = pexp_attributes = List.filter (function - | { Location.txt = "res.await" | "ns.braces" }, _ -> false + | {Location.txt = "res.await" | "ns.braces"}, _ -> false | _ -> true) e.pexp_attributes; } @@ -56531,53 +56450,55 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = | Braced braces -> printBraces printedExpression e braces | Nothing -> printedExpression in - Doc.concat [ Doc.text "await "; rhs ] + Doc.concat [Doc.text "await "; rhs] else printedExpression in let shouldPrintItsOwnAttributes = match e.pexp_desc with | Pexp_apply _ | Pexp_fun _ | Pexp_newtype _ | Pexp_setfield _ | Pexp_ifthenelse _ -> - true + true | Pexp_match _ when ParsetreeViewer.isIfLetExpr e -> true | Pexp_construct _ when ParsetreeViewer.hasJsxAttribute e.pexp_attributes -> - true + true | _ -> false in match e.pexp_attributes with | [] -> exprWithAwait | attrs when not shouldPrintItsOwnAttributes -> - Doc.group - (Doc.concat - [ printAttributes ~customLayout attrs cmtTbl; exprWithAwait ]) + Doc.group + (Doc.concat [printAttributes ~customLayout attrs cmtTbl; exprWithAwait]) | _ -> exprWithAwait and printPexpFun ~customLayout ~inCallback e cmtTbl = let attrsOnArrow, parameters, returnExpr = ParsetreeViewer.funExpr e in - let ParsetreeViewer.{ async; uncurried; attributes = attrs } = + let ParsetreeViewer.{async; uncurried; attributes = attrs} = ParsetreeViewer.processFunctionAttributes attrsOnArrow in let returnExpr, typConstraint = match returnExpr.pexp_desc with | Pexp_constraint (expr, typ) -> - ( { - expr with - pexp_attributes = - List.concat [ expr.pexp_attributes; returnExpr.pexp_attributes ]; - }, - Some typ ) + ( { + expr with + pexp_attributes = + List.concat [expr.pexp_attributes; returnExpr.pexp_attributes]; + }, + Some typ ) | _ -> (returnExpr, None) in let parametersDoc = printExprFunParameters ~customLayout ~inCallback ~async ~uncurried - ~hasConstraint:(match typConstraint with Some _ -> true | None -> false) + ~hasConstraint: + (match typConstraint with + | Some _ -> true + | None -> false) parameters cmtTbl in let returnShouldIndent = match returnExpr.pexp_desc with | Pexp_sequence _ | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ -> - false + false | _ -> true in let returnExprDoc = @@ -56589,7 +56510,7 @@ and printPexpFun ~customLayout ~inCallback e cmtTbl = | Pexp_construct (_, Some _) | Pexp_record _ ), _ ) -> - true + true | _ -> false in let returnDoc = @@ -56599,23 +56520,23 @@ and printPexpFun ~customLayout ~inCallback e cmtTbl = | Braced braces -> printBraces doc returnExpr braces | Nothing -> doc in - if shouldInline then Doc.concat [ Doc.space; returnDoc ] + if shouldInline then Doc.concat [Doc.space; returnDoc] else Doc.group (if returnShouldIndent then Doc.concat [ - Doc.indent (Doc.concat [ Doc.line; returnDoc ]); + Doc.indent (Doc.concat [Doc.line; returnDoc]); (match inCallback with | FitsOnOneLine | ArgumentsFitOnOneLine -> Doc.softLine | _ -> Doc.nil); ] - else Doc.concat [ Doc.space; returnDoc ]) + else Doc.concat [Doc.space; returnDoc]) in let typConstraintDoc = match typConstraint with | Some typ -> - Doc.concat [ Doc.text ": "; printTypExpr ~customLayout typ cmtTbl ] + Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ cmtTbl] | _ -> Doc.nil in Doc.concat @@ -56659,16 +56580,15 @@ and printSetFieldExpr ~customLayout attrs lhs longidentLoc rhs loc cmtTbl = printLidentPath longidentLoc cmtTbl; Doc.text " ="; (if shouldIndent then - Doc.group (Doc.indent (Doc.concat [ Doc.line; rhsDoc ])) - else Doc.concat [ Doc.space; rhsDoc ]); + Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) + else Doc.concat [Doc.space; rhsDoc]); ]) in let doc = match attrs with | [] -> doc | attrs -> - Doc.group - (Doc.concat [ printAttributes ~customLayout attrs cmtTbl; doc ]) + Doc.group (Doc.concat [printAttributes ~customLayout attrs cmtTbl; doc]) in printComments doc cmtTbl loc @@ -56678,17 +56598,17 @@ and printTemplateLiteral ~customLayout expr cmtTbl = let open Parsetree in match expr.pexp_desc with | Pexp_apply - ( { pexp_desc = Pexp_ident { txt = Longident.Lident "^" } }, - [ (Nolabel, arg1); (Nolabel, arg2) ] ) -> - let lhs = walkExpr arg1 in - let rhs = walkExpr arg2 in - Doc.concat [ lhs; rhs ] + ( {pexp_desc = Pexp_ident {txt = Longident.Lident "^"}}, + [(Nolabel, arg1); (Nolabel, arg2)] ) -> + let lhs = walkExpr arg1 in + let rhs = walkExpr arg2 in + Doc.concat [lhs; rhs] | Pexp_constant (Pconst_string (txt, Some prefix)) -> - tag := prefix; - printStringContents txt + tag := prefix; + printStringContents txt | _ -> - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - Doc.group (Doc.concat [ Doc.text "${"; Doc.indent doc; Doc.rbrace ]) + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + Doc.group (Doc.concat [Doc.text "${"; Doc.indent doc; Doc.rbrace]) in let content = walkExpr expr in Doc.concat @@ -56712,17 +56632,17 @@ and printUnaryExpression ~customLayout expr cmtTbl = in match expr.pexp_desc with | Pexp_apply - ( { pexp_desc = Pexp_ident { txt = Longident.Lident operator } }, - [ (Nolabel, operand) ] ) -> - let printedOperand = - let doc = printExpressionWithComments ~customLayout operand cmtTbl in - match Parens.unaryExprOperand operand with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc operand braces - | Nothing -> doc - in - let doc = Doc.concat [ printUnaryOperator operator; printedOperand ] in - printComments doc cmtTbl expr.pexp_loc + ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, + [(Nolabel, operand)] ) -> + let printedOperand = + let doc = printExpressionWithComments ~customLayout operand cmtTbl in + match Parens.unaryExprOperand operand with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc operand braces + | Nothing -> doc + in + let doc = Doc.concat [printUnaryOperator operator; printedOperand] in + printComments doc cmtTbl expr.pexp_loc | _ -> assert false and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = @@ -56736,254 +56656,252 @@ and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = | "<>" -> "!=" | "!=" -> "!==" | txt -> txt - in - let spacingBeforeOperator = - if operator = "|." then Doc.softLine - else if operator = "|>" then Doc.line - else Doc.space - in - let spacingAfterOperator = - if operator = "|." then Doc.nil - else if operator = "|>" then Doc.space - else if inlineRhs then Doc.space - else Doc.line - in - Doc.concat - [ spacingBeforeOperator; Doc.text operatorTxt; spacingAfterOperator ] - in - let printOperand ~isLhs expr parentOperator = - let rec flatten ~isLhs expr parentOperator = - if ParsetreeViewer.isBinaryExpression expr then - match expr with - | { - pexp_desc = - Pexp_apply - ( { pexp_desc = Pexp_ident { txt = Longident.Lident operator } }, - [ (_, left); (_, right) ] ); - } -> - if - ParsetreeViewer.flattenableOperators parentOperator operator - && not (ParsetreeViewer.hasAttributes expr.pexp_attributes) - then - let leftPrinted = flatten ~isLhs:true left operator in - let rightPrinted = - let rightPrinteableAttrs, rightInternalAttrs = - ParsetreeViewer.partitionPrintableAttributes - right.pexp_attributes - in - let doc = - printExpressionWithComments ~customLayout - { right with pexp_attributes = rightInternalAttrs } - cmtTbl - in - let doc = - if Parens.flattenOperandRhs parentOperator right then - Doc.concat [ Doc.lparen; doc; Doc.rparen ] - else doc - in - let doc = - Doc.concat - [ - printAttributes ~customLayout rightPrinteableAttrs cmtTbl; - doc; - ] - in - match rightPrinteableAttrs with [] -> doc | _ -> addParens doc - in - let isAwait = - ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes - in - let doc = - if isAwait then - Doc.concat - [ - Doc.text "await "; - Doc.lparen; - leftPrinted; - printBinaryOperator ~inlineRhs:false operator; - rightPrinted; - Doc.rparen; - ] - else - Doc.concat - [ - leftPrinted; - printBinaryOperator ~inlineRhs:false operator; - rightPrinted; - ] - in - - let doc = - if (not isLhs) && Parens.rhsBinaryExprOperand operator expr then - Doc.concat [ Doc.lparen; doc; Doc.rparen ] - else doc - in - printComments doc cmtTbl expr.pexp_loc - else - let printeableAttrs, internalAttrs = + in + let spacingBeforeOperator = + if operator = "|." then Doc.softLine + else if operator = "|>" then Doc.line + else Doc.space + in + let spacingAfterOperator = + if operator = "|." then Doc.nil + else if operator = "|>" then Doc.space + else if inlineRhs then Doc.space + else Doc.line + in + Doc.concat + [spacingBeforeOperator; Doc.text operatorTxt; spacingAfterOperator] + in + let printOperand ~isLhs expr parentOperator = + let rec flatten ~isLhs expr parentOperator = + if ParsetreeViewer.isBinaryExpression expr then + match expr with + | { + pexp_desc = + Pexp_apply + ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, + [(_, left); (_, right)] ); + } -> + if + ParsetreeViewer.flattenableOperators parentOperator operator + && not (ParsetreeViewer.hasAttributes expr.pexp_attributes) + then + let leftPrinted = flatten ~isLhs:true left operator in + let rightPrinted = + let rightPrinteableAttrs, rightInternalAttrs = ParsetreeViewer.partitionPrintableAttributes - expr.pexp_attributes + right.pexp_attributes in let doc = printExpressionWithComments ~customLayout - { expr with pexp_attributes = internalAttrs } + {right with pexp_attributes = rightInternalAttrs} cmtTbl in let doc = - if - Parens.subBinaryExprOperand parentOperator operator - || printeableAttrs <> [] - && (ParsetreeViewer.isBinaryExpression expr - || ParsetreeViewer.isTernaryExpr expr) - then Doc.concat [ Doc.lparen; doc; Doc.rparen ] + if Parens.flattenOperandRhs parentOperator right then + Doc.concat [Doc.lparen; doc; Doc.rparen] else doc in - Doc.concat - [ printAttributes ~customLayout printeableAttrs cmtTbl; doc ] + let doc = + Doc.concat + [ + printAttributes ~customLayout rightPrinteableAttrs cmtTbl; + doc; + ] + in + match rightPrinteableAttrs with + | [] -> doc + | _ -> addParens doc + in + let isAwait = + ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes + in + let doc = + if isAwait then + Doc.concat + [ + Doc.text "await "; + Doc.lparen; + leftPrinted; + printBinaryOperator ~inlineRhs:false operator; + rightPrinted; + Doc.rparen; + ] + else + Doc.concat + [ + leftPrinted; + printBinaryOperator ~inlineRhs:false operator; + rightPrinted; + ] + in + + let doc = + if (not isLhs) && Parens.rhsBinaryExprOperand operator expr then + Doc.concat [Doc.lparen; doc; Doc.rparen] + else doc + in + printComments doc cmtTbl expr.pexp_loc + else + let printeableAttrs, internalAttrs = + ParsetreeViewer.partitionPrintableAttributes expr.pexp_attributes + in + let doc = + printExpressionWithComments ~customLayout + {expr with pexp_attributes = internalAttrs} + cmtTbl + in + let doc = + if + Parens.subBinaryExprOperand parentOperator operator + || printeableAttrs <> [] + && (ParsetreeViewer.isBinaryExpression expr + || ParsetreeViewer.isTernaryExpr expr) + then Doc.concat [Doc.lparen; doc; Doc.rparen] + else doc + in + Doc.concat + [printAttributes ~customLayout printeableAttrs cmtTbl; doc] | _ -> assert false else match expr.pexp_desc with | Pexp_apply - ( { pexp_desc = Pexp_ident { txt = Longident.Lident "^"; loc } }, - [ (Nolabel, _); (Nolabel, _) ] ) + ( {pexp_desc = Pexp_ident {txt = Longident.Lident "^"; loc}}, + [(Nolabel, _); (Nolabel, _)] ) when loc.loc_ghost -> - let doc = printTemplateLiteral ~customLayout expr cmtTbl in - printComments doc cmtTbl expr.Parsetree.pexp_loc + let doc = printTemplateLiteral ~customLayout expr cmtTbl in + printComments doc cmtTbl expr.Parsetree.pexp_loc | Pexp_setfield (lhs, field, rhs) -> - let doc = - printSetFieldExpr ~customLayout expr.pexp_attributes lhs field rhs - expr.pexp_loc cmtTbl - in - if isLhs then addParens doc else doc + let doc = + printSetFieldExpr ~customLayout expr.pexp_attributes lhs field rhs + expr.pexp_loc cmtTbl + in + if isLhs then addParens doc else doc | Pexp_apply - ( { pexp_desc = Pexp_ident { txt = Longident.Lident "#=" } }, - [ (Nolabel, lhs); (Nolabel, rhs) ] ) -> - let rhsDoc = printExpressionWithComments ~customLayout rhs cmtTbl in - let lhsDoc = printExpressionWithComments ~customLayout lhs cmtTbl in - (* TODO: unify indentation of "=" *) - let shouldIndent = ParsetreeViewer.isBinaryExpression rhs in - let doc = + ( {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}}, + [(Nolabel, lhs); (Nolabel, rhs)] ) -> + let rhsDoc = printExpressionWithComments ~customLayout rhs cmtTbl in + let lhsDoc = printExpressionWithComments ~customLayout lhs cmtTbl in + (* TODO: unify indentation of "=" *) + let shouldIndent = ParsetreeViewer.isBinaryExpression rhs in + let doc = + Doc.group + (Doc.concat + [ + lhsDoc; + Doc.text " ="; + (if shouldIndent then + Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) + else Doc.concat [Doc.space; rhsDoc]); + ]) + in + let doc = + match expr.pexp_attributes with + | [] -> doc + | attrs -> Doc.group - (Doc.concat - [ - lhsDoc; - Doc.text " ="; - (if shouldIndent then - Doc.group (Doc.indent (Doc.concat [ Doc.line; rhsDoc ])) - else Doc.concat [ Doc.space; rhsDoc ]); - ]) - in - let doc = - match expr.pexp_attributes with - | [] -> doc - | attrs -> - Doc.group - (Doc.concat - [ printAttributes ~customLayout attrs cmtTbl; doc ]) - in - if isLhs then addParens doc else doc + (Doc.concat [printAttributes ~customLayout attrs cmtTbl; doc]) + in + if isLhs then addParens doc else doc | _ -> ( - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.binaryExprOperand ~isLhs expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.binaryExprOperand ~isLhs expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) in flatten ~isLhs expr parentOperator in match expr.pexp_desc with | Pexp_apply - ( { - pexp_desc = Pexp_ident { txt = Longident.Lident (("|." | "|>") as op) }; - }, - [ (Nolabel, lhs); (Nolabel, rhs) ] ) + ( {pexp_desc = Pexp_ident {txt = Longident.Lident (("|." | "|>") as op)}}, + [(Nolabel, lhs); (Nolabel, rhs)] ) when not (ParsetreeViewer.isBinaryExpression lhs || ParsetreeViewer.isBinaryExpression rhs || printAttributes ~customLayout expr.pexp_attributes cmtTbl <> Doc.nil) -> - let lhsHasCommentBelow = hasCommentBelow cmtTbl lhs.pexp_loc in - let lhsDoc = printOperand ~isLhs:true lhs op in - let rhsDoc = printOperand ~isLhs:false rhs op in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - lhsDoc; - (match (lhsHasCommentBelow, op) with - | true, "|." -> Doc.concat [ Doc.softLine; Doc.text "->" ] - | false, "|." -> Doc.text "->" - | true, "|>" -> Doc.concat [ Doc.line; Doc.text "|> " ] - | false, "|>" -> Doc.text " |> " - | _ -> Doc.nil); - rhsDoc; - ]) + let lhsHasCommentBelow = hasCommentBelow cmtTbl lhs.pexp_loc in + let lhsDoc = printOperand ~isLhs:true lhs op in + let rhsDoc = printOperand ~isLhs:false rhs op in + Doc.group + (Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + lhsDoc; + (match (lhsHasCommentBelow, op) with + | true, "|." -> Doc.concat [Doc.softLine; Doc.text "->"] + | false, "|." -> Doc.text "->" + | true, "|>" -> Doc.concat [Doc.line; Doc.text "|> "] + | false, "|>" -> Doc.text " |> " + | _ -> Doc.nil); + rhsDoc; + ]) | Pexp_apply - ( { pexp_desc = Pexp_ident { txt = Longident.Lident operator } }, - [ (Nolabel, lhs); (Nolabel, rhs) ] ) -> - let right = - let operatorWithRhs = - let rhsDoc = printOperand ~isLhs:false rhs operator in - Doc.concat - [ - printBinaryOperator - ~inlineRhs:(ParsetreeViewer.shouldInlineRhsBinaryExpr rhs) - operator; - rhsDoc; - ] - in - if ParsetreeViewer.shouldIndentBinaryExpr expr then - Doc.group (Doc.indent operatorWithRhs) - else operatorWithRhs - in - let doc = - Doc.group (Doc.concat [ printOperand ~isLhs:true lhs operator; right ]) + ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, + [(Nolabel, lhs); (Nolabel, rhs)] ) -> + let right = + let operatorWithRhs = + let rhsDoc = printOperand ~isLhs:false rhs operator in + Doc.concat + [ + printBinaryOperator + ~inlineRhs:(ParsetreeViewer.shouldInlineRhsBinaryExpr rhs) + operator; + rhsDoc; + ] in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - (match - Parens.binaryExpr - { - expr with - pexp_attributes = - ParsetreeViewer.filterPrintableAttributes - expr.pexp_attributes; - } - with - | Braced bracesLoc -> printBraces doc expr bracesLoc - | Parenthesized -> addParens doc - | Nothing -> doc); - ]) + if ParsetreeViewer.shouldIndentBinaryExpr expr then + Doc.group (Doc.indent operatorWithRhs) + else operatorWithRhs + in + let doc = + Doc.group (Doc.concat [printOperand ~isLhs:true lhs operator; right]) + in + Doc.group + (Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + (match + Parens.binaryExpr + { + expr with + pexp_attributes = + ParsetreeViewer.filterPrintableAttributes + expr.pexp_attributes; + } + with + | Braced bracesLoc -> printBraces doc expr bracesLoc + | Parenthesized -> addParens doc + | Nothing -> doc); + ]) | _ -> Doc.nil and printBeltListConcatApply ~customLayout subLists cmtTbl = let makeSpreadDoc commaBeforeSpread = function | Some expr -> - Doc.concat - [ - commaBeforeSpread; - Doc.dotdotdot; - (let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); - ] + Doc.concat + [ + commaBeforeSpread; + Doc.dotdotdot; + (let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + ] | None -> Doc.nil in let makeSubListDoc (expressions, spread) = let commaBeforeSpread = match expressions with | [] -> Doc.nil - | _ -> Doc.concat [ Doc.text ","; Doc.line ] + | _ -> Doc.concat [Doc.text ","; Doc.line] in let spreadDoc = makeSpreadDoc commaBeforeSpread spread in Doc.concat [ Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) + ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map (fun expr -> let doc = @@ -57006,7 +56924,7 @@ and printBeltListConcatApply ~customLayout subLists cmtTbl = [ Doc.softLine; Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) + ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map makeSubListDoc (List.map ParsetreeViewer.collectListExpressions subLists)); ]); @@ -57019,243 +56937,228 @@ and printBeltListConcatApply ~customLayout subLists cmtTbl = and printPexpApply ~customLayout expr cmtTbl = match expr.pexp_desc with | Pexp_apply - ( { pexp_desc = Pexp_ident { txt = Longident.Lident "##" } }, - [ (Nolabel, parentExpr); (Nolabel, memberExpr) ] ) -> - let parentDoc = - let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces - | Nothing -> doc - in - let member = - let memberDoc = - match memberExpr.pexp_desc with - | Pexp_ident lident -> - printComments - (printLongident lident.txt) - cmtTbl memberExpr.pexp_loc - | _ -> printExpressionWithComments ~customLayout memberExpr cmtTbl - in - Doc.concat [ Doc.text "\""; memberDoc; Doc.text "\"" ] + ( {pexp_desc = Pexp_ident {txt = Longident.Lident "##"}}, + [(Nolabel, parentExpr); (Nolabel, memberExpr)] ) -> + let parentDoc = + let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in + match Parens.unaryExprOperand parentExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc parentExpr braces + | Nothing -> doc + in + let member = + let memberDoc = + match memberExpr.pexp_desc with + | Pexp_ident lident -> + printComments (printLongident lident.txt) cmtTbl memberExpr.pexp_loc + | _ -> printExpressionWithComments ~customLayout memberExpr cmtTbl in + Doc.concat [Doc.text "\""; memberDoc; Doc.text "\""] + in + Doc.group + (Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + parentDoc; + Doc.lbracket; + member; + Doc.rbracket; + ]) + | Pexp_apply + ( {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}}, + [(Nolabel, lhs); (Nolabel, rhs)] ) -> ( + let rhsDoc = + let doc = printExpressionWithComments ~customLayout rhs cmtTbl in + match Parens.expr rhs with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc rhs braces + | Nothing -> doc + in + (* TODO: unify indentation of "=" *) + let shouldIndent = + (not (ParsetreeViewer.isBracedExpr rhs)) + && ParsetreeViewer.isBinaryExpression rhs + in + let doc = Doc.group (Doc.concat [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - parentDoc; - Doc.lbracket; - member; - Doc.rbracket; + printExpressionWithComments ~customLayout lhs cmtTbl; + Doc.text " ="; + (if shouldIndent then + Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) + else Doc.concat [Doc.space; rhsDoc]); ]) + in + match expr.pexp_attributes with + | [] -> doc + | attrs -> + Doc.group (Doc.concat [printAttributes ~customLayout attrs cmtTbl; doc])) | Pexp_apply - ( { pexp_desc = Pexp_ident { txt = Longident.Lident "#=" } }, - [ (Nolabel, lhs); (Nolabel, rhs) ] ) -> ( - let rhsDoc = - let doc = printExpressionWithComments ~customLayout rhs cmtTbl in - match Parens.expr rhs with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc rhs braces - | Nothing -> doc - in - (* TODO: unify indentation of "=" *) - let shouldIndent = - (not (ParsetreeViewer.isBracedExpr rhs)) - && ParsetreeViewer.isBinaryExpression rhs - in - let doc = - Doc.group - (Doc.concat - [ - printExpressionWithComments ~customLayout lhs cmtTbl; - Doc.text " ="; - (if shouldIndent then - Doc.group (Doc.indent (Doc.concat [ Doc.line; rhsDoc ])) - else Doc.concat [ Doc.space; rhsDoc ]); - ]) - in - match expr.pexp_attributes with - | [] -> doc - | attrs -> - Doc.group - (Doc.concat [ printAttributes ~customLayout attrs cmtTbl; doc ])) - | Pexp_apply - ( { - pexp_desc = Pexp_ident { txt = Longident.Ldot (Lident "Array", "get") }; - }, - [ (Nolabel, parentExpr); (Nolabel, memberExpr) ] ) + ( {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "get")}}, + [(Nolabel, parentExpr); (Nolabel, memberExpr)] ) when not (ParsetreeViewer.isRewrittenUnderscoreApplySugar parentExpr) -> - (* Don't print the Array.get(_, 0) sugar a.k.a. (__x) => Array.get(__x, 0) as _[0] *) - let member = - let memberDoc = - let doc = - printExpressionWithComments ~customLayout memberExpr cmtTbl - in - match Parens.expr memberExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc memberExpr braces - | Nothing -> doc - in - let shouldInline = - match memberExpr.pexp_desc with - | Pexp_constant _ | Pexp_ident _ -> true - | _ -> false - in - if shouldInline then memberDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [ Doc.softLine; memberDoc ]); Doc.softLine; - ] - in - let parentDoc = - let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with + (* Don't print the Array.get(_, 0) sugar a.k.a. (__x) => Array.get(__x, 0) as _[0] *) + let member = + let memberDoc = + let doc = printExpressionWithComments ~customLayout memberExpr cmtTbl in + match Parens.expr memberExpr with | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces + | Braced braces -> printBraces doc memberExpr braces | Nothing -> doc in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - parentDoc; - Doc.lbracket; - member; - Doc.rbracket; - ]) - | Pexp_apply - ( { - pexp_desc = Pexp_ident { txt = Longident.Ldot (Lident "Array", "set") }; - }, - [ (Nolabel, parentExpr); (Nolabel, memberExpr); (Nolabel, targetExpr) ] - ) -> - let member = - let memberDoc = - let doc = - printExpressionWithComments ~customLayout memberExpr cmtTbl - in - match Parens.expr memberExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc memberExpr braces - | Nothing -> doc - in - let shouldInline = - match memberExpr.pexp_desc with - | Pexp_constant _ | Pexp_ident _ -> true - | _ -> false - in - if shouldInline then memberDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [ Doc.softLine; memberDoc ]); Doc.softLine; - ] - in - let shouldIndentTargetExpr = - if ParsetreeViewer.isBracedExpr targetExpr then false - else - ParsetreeViewer.isBinaryExpression targetExpr - || - match targetExpr with - | { - pexp_attributes = [ ({ Location.txt = "ns.ternary" }, _) ]; - pexp_desc = Pexp_ifthenelse (ifExpr, _, _); - } -> - ParsetreeViewer.isBinaryExpression ifExpr - || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes - | { pexp_desc = Pexp_newtype _ } -> false - | e -> - ParsetreeViewer.hasAttributes e.pexp_attributes - || ParsetreeViewer.isArrayAccess e - in - let targetExpr = - let doc = printExpressionWithComments ~customLayout targetExpr cmtTbl in - match Parens.expr targetExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc targetExpr braces - | Nothing -> doc + let shouldInline = + match memberExpr.pexp_desc with + | Pexp_constant _ | Pexp_ident _ -> true + | _ -> false in - let parentDoc = - let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with + if shouldInline then memberDoc + else + Doc.concat + [Doc.indent (Doc.concat [Doc.softLine; memberDoc]); Doc.softLine] + in + let parentDoc = + let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in + match Parens.unaryExprOperand parentExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc parentExpr braces + | Nothing -> doc + in + Doc.group + (Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + parentDoc; + Doc.lbracket; + member; + Doc.rbracket; + ]) + | Pexp_apply + ( {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "set")}}, + [(Nolabel, parentExpr); (Nolabel, memberExpr); (Nolabel, targetExpr)] ) + -> + let member = + let memberDoc = + let doc = printExpressionWithComments ~customLayout memberExpr cmtTbl in + match Parens.expr memberExpr with | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces - | Nothing -> doc - in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - parentDoc; - Doc.lbracket; - member; - Doc.rbracket; - Doc.text " ="; - (if shouldIndentTargetExpr then - Doc.indent (Doc.concat [ Doc.line; targetExpr ]) - else Doc.concat [ Doc.space; targetExpr ]); - ]) + | Braced braces -> printBraces doc memberExpr braces + | Nothing -> doc + in + let shouldInline = + match memberExpr.pexp_desc with + | Pexp_constant _ | Pexp_ident _ -> true + | _ -> false + in + if shouldInline then memberDoc + else + Doc.concat + [Doc.indent (Doc.concat [Doc.softLine; memberDoc]); Doc.softLine] + in + let shouldIndentTargetExpr = + if ParsetreeViewer.isBracedExpr targetExpr then false + else + ParsetreeViewer.isBinaryExpression targetExpr + || + match targetExpr with + | { + pexp_attributes = [({Location.txt = "ns.ternary"}, _)]; + pexp_desc = Pexp_ifthenelse (ifExpr, _, _); + } -> + ParsetreeViewer.isBinaryExpression ifExpr + || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes + | {pexp_desc = Pexp_newtype _} -> false + | e -> + ParsetreeViewer.hasAttributes e.pexp_attributes + || ParsetreeViewer.isArrayAccess e + in + let targetExpr = + let doc = printExpressionWithComments ~customLayout targetExpr cmtTbl in + match Parens.expr targetExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc targetExpr braces + | Nothing -> doc + in + let parentDoc = + let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in + match Parens.unaryExprOperand parentExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc parentExpr braces + | Nothing -> doc + in + Doc.group + (Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + parentDoc; + Doc.lbracket; + member; + Doc.rbracket; + Doc.text " ="; + (if shouldIndentTargetExpr then + Doc.indent (Doc.concat [Doc.line; targetExpr]) + else Doc.concat [Doc.space; targetExpr]); + ]) (* TODO: cleanup, are those branches even remotely performant? *) - | Pexp_apply ({ pexp_desc = Pexp_ident lident }, args) + | Pexp_apply ({pexp_desc = Pexp_ident lident}, args) when ParsetreeViewer.isJsxExpression expr -> - printJsxExpression ~customLayout lident args cmtTbl + printJsxExpression ~customLayout lident args cmtTbl | Pexp_apply (callExpr, args) -> - let args = - List.map - (fun (lbl, arg) -> (lbl, ParsetreeViewer.rewriteUnderscoreApply arg)) - args + let args = + List.map + (fun (lbl, arg) -> (lbl, ParsetreeViewer.rewriteUnderscoreApply arg)) + args + in + let uncurried, attrs = + ParsetreeViewer.processUncurriedAttribute expr.pexp_attributes + in + let callExprDoc = + let doc = printExpressionWithComments ~customLayout callExpr cmtTbl in + match Parens.callExpr callExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc callExpr braces + | Nothing -> doc + in + if ParsetreeViewer.requiresSpecialCallbackPrintingFirstArg args then + let argsDoc = + printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args + cmtTbl in - let uncurried, attrs = - ParsetreeViewer.processUncurriedAttribute expr.pexp_attributes + Doc.concat + [printAttributes ~customLayout attrs cmtTbl; callExprDoc; argsDoc] + else if ParsetreeViewer.requiresSpecialCallbackPrintingLastArg args then + let argsDoc = + printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args + cmtTbl in - let callExprDoc = - let doc = printExpressionWithComments ~customLayout callExpr cmtTbl in - match Parens.callExpr callExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc callExpr braces - | Nothing -> doc + (* + * Fixes the following layout (the `[` and `]` should break): + * [fn(x => { + * let _ = x + * }), fn(y => { + * let _ = y + * }), fn(z => { + * let _ = z + * })] + * See `Doc.willBreak documentation in interface file for more context. + * Context: + * https://github.com/rescript-lang/syntax/issues/111 + * https://github.com/rescript-lang/syntax/issues/166 + *) + let maybeBreakParent = + if Doc.willBreak argsDoc then Doc.breakParent else Doc.nil in - if ParsetreeViewer.requiresSpecialCallbackPrintingFirstArg args then - let argsDoc = - printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout - args cmtTbl - in - Doc.concat - [ printAttributes ~customLayout attrs cmtTbl; callExprDoc; argsDoc ] - else if ParsetreeViewer.requiresSpecialCallbackPrintingLastArg args then - let argsDoc = - printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args - cmtTbl - in - (* - * Fixes the following layout (the `[` and `]` should break): - * [fn(x => { - * let _ = x - * }), fn(y => { - * let _ = y - * }), fn(z => { - * let _ = z - * })] - * See `Doc.willBreak documentation in interface file for more context. - * Context: - * https://github.com/rescript-lang/syntax/issues/111 - * https://github.com/rescript-lang/syntax/issues/166 - *) - let maybeBreakParent = - if Doc.willBreak argsDoc then Doc.breakParent else Doc.nil - in - Doc.concat - [ - maybeBreakParent; - printAttributes ~customLayout attrs cmtTbl; - callExprDoc; - argsDoc; - ] - else - let argsDoc = printArguments ~customLayout ~uncurried args cmtTbl in - Doc.concat - [ printAttributes ~customLayout attrs cmtTbl; callExprDoc; argsDoc ] + Doc.concat + [ + maybeBreakParent; + printAttributes ~customLayout attrs cmtTbl; + callExprDoc; + argsDoc; + ] + else + let argsDoc = printArguments ~customLayout ~uncurried args cmtTbl in + Doc.concat + [printAttributes ~customLayout attrs cmtTbl; callExprDoc; argsDoc] | _ -> assert false and printJsxExpression ~customLayout lident args cmtTbl = @@ -57267,9 +57170,9 @@ and printJsxExpression ~customLayout lident args cmtTbl = | Some { Parsetree.pexp_desc = - Pexp_construct ({ txt = Longident.Lident "[]" }, None); + Pexp_construct ({txt = Longident.Lident "[]"}, None); } -> - false + false | None -> false | _ -> true in @@ -57278,17 +57181,17 @@ and printJsxExpression ~customLayout lident args cmtTbl = | Some { Parsetree.pexp_desc = - Pexp_construct ({ txt = Longident.Lident "[]" }, None); + Pexp_construct ({txt = Longident.Lident "[]"}, None); pexp_loc = loc; } -> - not (hasCommentsInside cmtTbl loc) + not (hasCommentsInside cmtTbl loc) | _ -> false in let printChildren children = let lineSep = match children with | Some expr -> - if hasNestedJsxOrMoreThanOneChild expr then Doc.hardLine else Doc.line + if hasNestedJsxOrMoreThanOneChild expr then Doc.hardLine else Doc.line | None -> Doc.line in Doc.concat @@ -57299,8 +57202,8 @@ and printJsxExpression ~customLayout lident args cmtTbl = Doc.line; (match children with | Some childrenExpression -> - printJsxChildren ~customLayout childrenExpression - ~sep:lineSep cmtTbl + printJsxChildren ~customLayout childrenExpression ~sep:lineSep + cmtTbl | None -> Doc.nil); ]); lineSep; @@ -57313,27 +57216,27 @@ and printJsxExpression ~customLayout lident args cmtTbl = (Doc.concat [ printComments - (Doc.concat [ Doc.lessThan; name ]) + (Doc.concat [Doc.lessThan; name]) cmtTbl lident.Asttypes.loc; formattedProps; (match children with | Some { Parsetree.pexp_desc = - Pexp_construct ({ txt = Longident.Lident "[]" }, None); + Pexp_construct ({txt = Longident.Lident "[]"}, None); } when isSelfClosing -> - Doc.text "/>" + Doc.text "/>" | _ -> - (* if tag A has trailing comments then put > on the next line - - - *) - if hasTrailingComments cmtTbl lident.Asttypes.loc then - Doc.concat [ Doc.softLine; Doc.greaterThan ] - else Doc.greaterThan); + (* if tag A has trailing comments then put > on the next line + + + *) + if hasTrailingComments cmtTbl lident.Asttypes.loc then + Doc.concat [Doc.softLine; Doc.greaterThan] + else Doc.greaterThan); ]); (if isSelfClosing then Doc.nil else @@ -57345,10 +57248,10 @@ and printJsxExpression ~customLayout lident args cmtTbl = | Some { Parsetree.pexp_desc = - Pexp_construct ({ txt = Longident.Lident "[]" }, None); + Pexp_construct ({txt = Longident.Lident "[]"}, None); pexp_loc = loc; } -> - printCommentsInside cmtTbl loc + printCommentsInside cmtTbl loc | _ -> Doc.nil); Doc.text " Doc.nil + | Pexp_construct ({txt = Longident.Lident "[]"}, None) -> Doc.nil | _ -> - Doc.indent - (Doc.concat - [ - Doc.line; - printJsxChildren ~customLayout expr ~sep:lineSep cmtTbl; - ])); + Doc.indent + (Doc.concat + [ + Doc.line; + printJsxChildren ~customLayout expr ~sep:lineSep cmtTbl; + ])); lineSep; closing; ]) @@ -57382,53 +57285,52 @@ and printJsxFragment ~customLayout expr cmtTbl = and printJsxChildren ~customLayout (childrenExpr : Parsetree.expression) ~sep cmtTbl = match childrenExpr.pexp_desc with - | Pexp_construct ({ txt = Longident.Lident "::" }, _) -> - let children, _ = ParsetreeViewer.collectListExpressions childrenExpr in - Doc.group - (Doc.join ~sep - (List.map - (fun (expr : Parsetree.expression) -> - let leadingLineCommentPresent = - hasLeadingLineComment cmtTbl expr.pexp_loc - in - let exprDoc = - printExpressionWithComments ~customLayout expr cmtTbl - in - let addParensOrBraces exprDoc = - (* {(20: int)} make sure that we also protect the expression inside *) - let innerDoc = - if Parens.bracedExpr expr then addParens exprDoc - else exprDoc - in - if leadingLineCommentPresent then addBraces innerDoc - else Doc.concat [ Doc.lbrace; innerDoc; Doc.rbrace ] + | Pexp_construct ({txt = Longident.Lident "::"}, _) -> + let children, _ = ParsetreeViewer.collectListExpressions childrenExpr in + Doc.group + (Doc.join ~sep + (List.map + (fun (expr : Parsetree.expression) -> + let leadingLineCommentPresent = + hasLeadingLineComment cmtTbl expr.pexp_loc + in + let exprDoc = + printExpressionWithComments ~customLayout expr cmtTbl + in + let addParensOrBraces exprDoc = + (* {(20: int)} make sure that we also protect the expression inside *) + let innerDoc = + if Parens.bracedExpr expr then addParens exprDoc else exprDoc in - match Parens.jsxChildExpr expr with - | Nothing -> exprDoc - | Parenthesized -> addParensOrBraces exprDoc - | Braced bracesLoc -> - printComments (addParensOrBraces exprDoc) cmtTbl bracesLoc) - children)) - | _ -> - let leadingLineCommentPresent = - hasLeadingLineComment cmtTbl childrenExpr.pexp_loc - in - let exprDoc = - printExpressionWithComments ~customLayout childrenExpr cmtTbl - in - Doc.concat - [ - Doc.dotdotdot; - (match Parens.jsxChildExpr childrenExpr with - | Parenthesized | Braced _ -> - let innerDoc = - if Parens.bracedExpr childrenExpr then addParens exprDoc - else exprDoc + if leadingLineCommentPresent then addBraces innerDoc + else Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace] in - if leadingLineCommentPresent then addBraces innerDoc - else Doc.concat [ Doc.lbrace; innerDoc; Doc.rbrace ] - | Nothing -> exprDoc); - ] + match Parens.jsxChildExpr expr with + | Nothing -> exprDoc + | Parenthesized -> addParensOrBraces exprDoc + | Braced bracesLoc -> + printComments (addParensOrBraces exprDoc) cmtTbl bracesLoc) + children)) + | _ -> + let leadingLineCommentPresent = + hasLeadingLineComment cmtTbl childrenExpr.pexp_loc + in + let exprDoc = + printExpressionWithComments ~customLayout childrenExpr cmtTbl + in + Doc.concat + [ + Doc.dotdotdot; + (match Parens.jsxChildExpr childrenExpr with + | Parenthesized | Braced _ -> + let innerDoc = + if Parens.bracedExpr childrenExpr then addParens exprDoc + else exprDoc + in + if leadingLineCommentPresent then addBraces innerDoc + else Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace] + | Nothing -> exprDoc); + ] and printJsxProps ~customLayout args cmtTbl : Doc.t * Parsetree.expression option = @@ -57447,10 +57349,10 @@ and printJsxProps ~customLayout args cmtTbl : let isSelfClosing children = match children with | { - Parsetree.pexp_desc = Pexp_construct ({ txt = Longident.Lident "[]" }, None); + Parsetree.pexp_desc = Pexp_construct ({txt = Longident.Lident "[]"}, None); pexp_loc = loc; } -> - not (hasCommentsInside cmtTbl loc) + not (hasCommentsInside cmtTbl loc) | _ -> false in let rec loop props args = @@ -57461,50 +57363,50 @@ and printJsxProps ~customLayout args cmtTbl : ( Asttypes.Nolabel, { Parsetree.pexp_desc = - Pexp_construct ({ txt = Longident.Lident "()" }, None); + Pexp_construct ({txt = Longident.Lident "()"}, None); } ); ] -> - let doc = if isSelfClosing children then Doc.line else Doc.nil in - (doc, Some children) + let doc = if isSelfClosing children then Doc.line else Doc.nil in + (doc, Some children) | ((_, expr) as lastProp) :: [ (Asttypes.Labelled "children", children); ( Asttypes.Nolabel, { Parsetree.pexp_desc = - Pexp_construct ({ txt = Longident.Lident "()" }, None); + Pexp_construct ({txt = Longident.Lident "()"}, None); } ); ] -> - let loc = - match expr.Parsetree.pexp_attributes with - | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _attrs -> - { loc with loc_end = expr.pexp_loc.loc_end } - | _ -> expr.pexp_loc - in - let trailingCommentsPresent = hasTrailingComments cmtTbl loc in - let propDoc = printJsxProp ~customLayout lastProp cmtTbl in - let formattedProps = - Doc.concat - [ - Doc.indent - (Doc.concat - [ - Doc.line; - Doc.group - (Doc.join ~sep:Doc.line (propDoc :: props |> List.rev)); - ]); - (* print > on new line if the last prop has trailing comments *) - (match (isSelfClosing children, trailingCommentsPresent) with - (* we always put /> on a new line when a self-closing tag breaks *) - | true, _ -> Doc.line - | false, true -> Doc.softLine - | false, false -> Doc.nil); - ] - in - (formattedProps, Some children) + let loc = + match expr.Parsetree.pexp_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _attrs -> + {loc with loc_end = expr.pexp_loc.loc_end} + | _ -> expr.pexp_loc + in + let trailingCommentsPresent = hasTrailingComments cmtTbl loc in + let propDoc = printJsxProp ~customLayout lastProp cmtTbl in + let formattedProps = + Doc.concat + [ + Doc.indent + (Doc.concat + [ + Doc.line; + Doc.group + (Doc.join ~sep:Doc.line (propDoc :: props |> List.rev)); + ]); + (* print > on new line if the last prop has trailing comments *) + (match (isSelfClosing children, trailingCommentsPresent) with + (* we always put /> on a new line when a self-closing tag breaks *) + | true, _ -> Doc.line + | false, true -> Doc.softLine + | false, false -> Doc.nil); + ] + in + (formattedProps, Some children) | arg :: args -> - let propDoc = printJsxProp ~customLayout arg cmtTbl in - loop (propDoc :: props) args + let propDoc = printJsxProp ~customLayout arg cmtTbl in + loop (propDoc :: props) args in loop [] args @@ -57513,81 +57415,79 @@ and printJsxProp ~customLayout arg cmtTbl = | ( ((Asttypes.Labelled lblTxt | Optional lblTxt) as lbl), { Parsetree.pexp_attributes = - [ ({ Location.txt = "ns.namedArgLoc"; loc = argLoc }, _) ]; - pexp_desc = Pexp_ident { txt = Longident.Lident ident }; + [({Location.txt = "ns.namedArgLoc"; loc = argLoc}, _)]; + pexp_desc = Pexp_ident {txt = Longident.Lident ident}; } ) when lblTxt = ident (* jsx punning *) -> ( - match lbl with - | Nolabel -> Doc.nil - | Labelled _lbl -> printComments (printIdentLike ident) cmtTbl argLoc - | Optional _lbl -> - let doc = Doc.concat [ Doc.question; printIdentLike ident ] in - printComments doc cmtTbl argLoc) + match lbl with + | Nolabel -> Doc.nil + | Labelled _lbl -> printComments (printIdentLike ident) cmtTbl argLoc + | Optional _lbl -> + let doc = Doc.concat [Doc.question; printIdentLike ident] in + printComments doc cmtTbl argLoc) | ( ((Asttypes.Labelled lblTxt | Optional lblTxt) as lbl), { Parsetree.pexp_attributes = []; - pexp_desc = Pexp_ident { txt = Longident.Lident ident }; + pexp_desc = Pexp_ident {txt = Longident.Lident ident}; } ) when lblTxt = ident (* jsx punning when printing from Reason *) -> ( - match lbl with - | Nolabel -> Doc.nil - | Labelled _lbl -> printIdentLike ident - | Optional _lbl -> Doc.concat [ Doc.question; printIdentLike ident ]) + match lbl with + | Nolabel -> Doc.nil + | Labelled _lbl -> printIdentLike ident + | Optional _lbl -> Doc.concat [Doc.question; printIdentLike ident]) | Asttypes.Labelled "_spreadProps", expr -> - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - Doc.concat [ Doc.lbrace; Doc.dotdotdot; Doc.softLine; doc; Doc.rbrace ] + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + Doc.concat [Doc.lbrace; Doc.dotdotdot; Doc.softLine; doc; Doc.rbrace] | lbl, expr -> - let argLoc, expr = - match expr.pexp_attributes with - | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: attrs -> - (loc, { expr with pexp_attributes = attrs }) - | _ -> (Location.none, expr) - in - let lblDoc = - match lbl with - | Asttypes.Labelled lbl -> - let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in - Doc.concat [ lbl; Doc.equal ] - | Asttypes.Optional lbl -> - let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in - Doc.concat [ lbl; Doc.equal; Doc.question ] - | Nolabel -> Doc.nil - in - let exprDoc = - let leadingLineCommentPresent = - hasLeadingLineComment cmtTbl expr.pexp_loc - in - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.jsxPropExpr expr with - | Parenthesized | Braced _ -> - (* {(20: int)} make sure that we also protect the expression inside *) - let innerDoc = - if Parens.bracedExpr expr then addParens doc else doc - in - if leadingLineCommentPresent then addBraces innerDoc - else Doc.concat [ Doc.lbrace; innerDoc; Doc.rbrace ] - | _ -> doc + let argLoc, expr = + match expr.pexp_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: attrs -> + (loc, {expr with pexp_attributes = attrs}) + | _ -> (Location.none, expr) + in + let lblDoc = + match lbl with + | Asttypes.Labelled lbl -> + let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in + Doc.concat [lbl; Doc.equal] + | Asttypes.Optional lbl -> + let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in + Doc.concat [lbl; Doc.equal; Doc.question] + | Nolabel -> Doc.nil + in + let exprDoc = + let leadingLineCommentPresent = + hasLeadingLineComment cmtTbl expr.pexp_loc in - let fullLoc = { argLoc with loc_end = expr.pexp_loc.loc_end } in - printComments (Doc.concat [ lblDoc; exprDoc ]) cmtTbl fullLoc + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.jsxPropExpr expr with + | Parenthesized | Braced _ -> + (* {(20: int)} make sure that we also protect the expression inside *) + let innerDoc = if Parens.bracedExpr expr then addParens doc else doc in + if leadingLineCommentPresent then addBraces innerDoc + else Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace] + | _ -> doc + in + let fullLoc = {argLoc with loc_end = expr.pexp_loc.loc_end} in + printComments (Doc.concat [lblDoc; exprDoc]) cmtTbl fullLoc (* div -> div. * Navabar.createElement -> Navbar * Staff.Users.createElement -> Staff.Users *) -and printJsxName { txt = lident } = +and printJsxName {txt = lident} = let rec flatten acc lident = match lident with | Longident.Lident txt -> txt :: acc | Ldot (lident, txt) -> - let acc = if txt = "createElement" then acc else txt :: acc in - flatten acc lident + let acc = if txt = "createElement" then acc else txt :: acc in + flatten acc lident | _ -> acc in match lident with | Longident.Lident txt -> Doc.text txt | _ as lident -> - let segments = flatten [] lident in - Doc.join ~sep:Doc.dot (List.map Doc.text segments) + let segments = flatten [] lident in + Doc.join ~sep:Doc.dot (List.map Doc.text segments) and printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args cmtTbl = @@ -57599,32 +57499,29 @@ and printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args let callback, printedArgs = match args with | (lbl, expr) :: args -> - let lblDoc = - match lbl with - | Asttypes.Nolabel -> Doc.nil - | Asttypes.Labelled txt -> - Doc.concat [ Doc.tilde; printIdentLike txt; Doc.equal ] - | Asttypes.Optional txt -> - Doc.concat - [ Doc.tilde; printIdentLike txt; Doc.equal; Doc.question ] - in - let callback = - Doc.concat - [ - lblDoc; - printPexpFun ~customLayout ~inCallback:FitsOnOneLine expr cmtTbl; - ] - in - let callback = lazy (printComments callback cmtTbl expr.pexp_loc) in - let printedArgs = - lazy - (Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun arg -> printArgument ~customLayout arg cmtTbl) - args)) - in - (callback, printedArgs) + let lblDoc = + match lbl with + | Asttypes.Nolabel -> Doc.nil + | Asttypes.Labelled txt -> + Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal] + | Asttypes.Optional txt -> + Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal; Doc.question] + in + let callback = + Doc.concat + [ + lblDoc; + printPexpFun ~customLayout ~inCallback:FitsOnOneLine expr cmtTbl; + ] + in + let callback = lazy (printComments callback cmtTbl expr.pexp_loc) in + let printedArgs = + lazy + (Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map (fun arg -> printArgument ~customLayout arg cmtTbl) args)) + in + (callback, printedArgs) | _ -> assert false in @@ -57674,7 +57571,7 @@ and printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args *) if customLayout > customLayoutThreshold then Lazy.force breakAllArgs else if Doc.willBreak (Lazy.force printedArgs) then Lazy.force breakAllArgs - else Doc.customLayout [ Lazy.force fitsOnOneLine; Lazy.force breakAllArgs ] + else Doc.customLayout [Lazy.force fitsOnOneLine; Lazy.force breakAllArgs] and printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args cmtTbl = @@ -57687,39 +57584,38 @@ and printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args let rec loop acc args = match args with | [] -> (lazy Doc.nil, lazy Doc.nil, lazy Doc.nil) - | [ (lbl, expr) ] -> - let lblDoc = - match lbl with - | Asttypes.Nolabel -> Doc.nil - | Asttypes.Labelled txt -> - Doc.concat [ Doc.tilde; printIdentLike txt; Doc.equal ] - | Asttypes.Optional txt -> - Doc.concat - [ Doc.tilde; printIdentLike txt; Doc.equal; Doc.question ] - in - let callbackFitsOnOneLine = - lazy - (let pexpFunDoc = - printPexpFun ~customLayout ~inCallback:FitsOnOneLine expr cmtTbl - in - let doc = Doc.concat [ lblDoc; pexpFunDoc ] in - printComments doc cmtTbl expr.pexp_loc) - in - let callbackArgumentsFitsOnOneLine = - lazy - (let pexpFunDoc = - printPexpFun ~customLayout ~inCallback:ArgumentsFitOnOneLine expr - cmtTblCopy - in - let doc = Doc.concat [ lblDoc; pexpFunDoc ] in - printComments doc cmtTblCopy expr.pexp_loc) - in - ( lazy (Doc.concat (List.rev acc)), - callbackFitsOnOneLine, - callbackArgumentsFitsOnOneLine ) + | [(lbl, expr)] -> + let lblDoc = + match lbl with + | Asttypes.Nolabel -> Doc.nil + | Asttypes.Labelled txt -> + Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal] + | Asttypes.Optional txt -> + Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal; Doc.question] + in + let callbackFitsOnOneLine = + lazy + (let pexpFunDoc = + printPexpFun ~customLayout ~inCallback:FitsOnOneLine expr cmtTbl + in + let doc = Doc.concat [lblDoc; pexpFunDoc] in + printComments doc cmtTbl expr.pexp_loc) + in + let callbackArgumentsFitsOnOneLine = + lazy + (let pexpFunDoc = + printPexpFun ~customLayout ~inCallback:ArgumentsFitOnOneLine expr + cmtTblCopy + in + let doc = Doc.concat [lblDoc; pexpFunDoc] in + printComments doc cmtTblCopy expr.pexp_loc) + in + ( lazy (Doc.concat (List.rev acc)), + callbackFitsOnOneLine, + callbackArgumentsFitsOnOneLine ) | arg :: args -> - let argDoc = printArgument ~customLayout arg cmtTbl in - loop (Doc.line :: Doc.comma :: argDoc :: acc) args + let argDoc = printArgument ~customLayout arg cmtTbl in + loop (Doc.line :: Doc.comma :: argDoc :: acc) args in let printedArgs, callback, callback2 = loop [] args in @@ -57792,48 +57688,46 @@ and printArguments ~customLayout ~uncurried | [ ( Nolabel, { - pexp_desc = Pexp_construct ({ txt = Longident.Lident "()" }, _); + pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _); pexp_loc = loc; } ); ] -> ( - (* See "parseCallExpr", ghost unit expression is used the implement - * arity zero vs arity one syntax. - * Related: https://github.com/rescript-lang/syntax/issues/138 *) - match (uncurried, loc.loc_ghost) with - | true, true -> Doc.text "(.)" (* arity zero *) - | true, false -> Doc.text "(. ())" (* arity one *) - | _ -> Doc.text "()") - | [ (Nolabel, arg) ] when ParsetreeViewer.isHuggableExpression arg -> - let argDoc = - let doc = printExpressionWithComments ~customLayout arg cmtTbl in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc - in - Doc.concat - [ - (if uncurried then Doc.text "(. " else Doc.lparen); argDoc; Doc.rparen; - ] + (* See "parseCallExpr", ghost unit expression is used the implement + * arity zero vs arity one syntax. + * Related: https://github.com/rescript-lang/syntax/issues/138 *) + match (uncurried, loc.loc_ghost) with + | true, true -> Doc.text "(.)" (* arity zero *) + | true, false -> Doc.text "(. ())" (* arity one *) + | _ -> Doc.text "()") + | [(Nolabel, arg)] when ParsetreeViewer.isHuggableExpression arg -> + let argDoc = + let doc = printExpressionWithComments ~customLayout arg cmtTbl in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc + in + Doc.concat + [(if uncurried then Doc.text "(. " else Doc.lparen); argDoc; Doc.rparen] | args -> - Doc.group - (Doc.concat - [ - (if uncurried then Doc.text "(." else Doc.lparen); - Doc.indent - (Doc.concat - [ - (if uncurried then Doc.line else Doc.softLine); - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun arg -> printArgument ~customLayout arg cmtTbl) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + (if uncurried then Doc.text "(." else Doc.lparen); + Doc.indent + (Doc.concat + [ + (if uncurried then Doc.line else Doc.softLine); + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun arg -> printArgument ~customLayout arg cmtTbl) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) (* * argument ::= @@ -57854,90 +57748,88 @@ and printArgument ~customLayout (argLbl, arg) cmtTbl = (* ~a (punned)*) | ( Asttypes.Labelled lbl, ({ - pexp_desc = Pexp_ident { txt = Longident.Lident name }; - pexp_attributes = [] | [ ({ Location.txt = "ns.namedArgLoc" }, _) ]; + pexp_desc = Pexp_ident {txt = Longident.Lident name}; + pexp_attributes = [] | [({Location.txt = "ns.namedArgLoc"}, _)]; } as argExpr) ) when lbl = name && not (ParsetreeViewer.isBracedExpr argExpr) -> - let loc = - match arg.pexp_attributes with - | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _ -> loc - | _ -> arg.pexp_loc - in - let doc = Doc.concat [ Doc.tilde; printIdentLike lbl ] in - printComments doc cmtTbl loc + let loc = + match arg.pexp_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> loc + | _ -> arg.pexp_loc + in + let doc = Doc.concat [Doc.tilde; printIdentLike lbl] in + printComments doc cmtTbl loc (* ~a: int (punned)*) | ( Asttypes.Labelled lbl, { pexp_desc = Pexp_constraint - ( ({ pexp_desc = Pexp_ident { txt = Longident.Lident name } } as - argExpr), + ( ({pexp_desc = Pexp_ident {txt = Longident.Lident name}} as argExpr), typ ); pexp_loc; pexp_attributes = - ([] | [ ({ Location.txt = "ns.namedArgLoc" }, _) ]) as attrs; + ([] | [({Location.txt = "ns.namedArgLoc"}, _)]) as attrs; } ) when lbl = name && not (ParsetreeViewer.isBracedExpr argExpr) -> - let loc = - match attrs with - | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _ -> - { loc with loc_end = pexp_loc.loc_end } - | _ -> arg.pexp_loc - in - let doc = - Doc.concat - [ - Doc.tilde; - printIdentLike lbl; - Doc.text ": "; - printTypExpr ~customLayout typ cmtTbl; - ] - in - printComments doc cmtTbl loc + let loc = + match attrs with + | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> + {loc with loc_end = pexp_loc.loc_end} + | _ -> arg.pexp_loc + in + let doc = + Doc.concat + [ + Doc.tilde; + printIdentLike lbl; + Doc.text ": "; + printTypExpr ~customLayout typ cmtTbl; + ] + in + printComments doc cmtTbl loc (* ~a? (optional lbl punned)*) | ( Asttypes.Optional lbl, { - pexp_desc = Pexp_ident { txt = Longident.Lident name }; - pexp_attributes = [] | [ ({ Location.txt = "ns.namedArgLoc" }, _) ]; + pexp_desc = Pexp_ident {txt = Longident.Lident name}; + pexp_attributes = [] | [({Location.txt = "ns.namedArgLoc"}, _)]; } ) when lbl = name -> - let loc = - match arg.pexp_attributes with - | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _ -> loc - | _ -> arg.pexp_loc - in - let doc = Doc.concat [ Doc.tilde; printIdentLike lbl; Doc.question ] in - printComments doc cmtTbl loc + let loc = + match arg.pexp_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> loc + | _ -> arg.pexp_loc + in + let doc = Doc.concat [Doc.tilde; printIdentLike lbl; Doc.question] in + printComments doc cmtTbl loc | _lbl, expr -> - let argLoc, expr = - match expr.pexp_attributes with - | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: attrs -> - (loc, { expr with pexp_attributes = attrs }) - | _ -> (expr.pexp_loc, expr) - in - let printedLbl = - match argLbl with - | Asttypes.Nolabel -> Doc.nil - | Asttypes.Labelled lbl -> - let doc = Doc.concat [ Doc.tilde; printIdentLike lbl; Doc.equal ] in - printComments doc cmtTbl argLoc - | Asttypes.Optional lbl -> - let doc = - Doc.concat - [ Doc.tilde; printIdentLike lbl; Doc.equal; Doc.question ] - in - printComments doc cmtTbl argLoc - in - let printedExpr = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - let loc = { argLoc with loc_end = expr.pexp_loc.loc_end } in - let doc = Doc.concat [ printedLbl; printedExpr ] in - printComments doc cmtTbl loc + let argLoc, expr = + match expr.pexp_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: attrs -> + (loc, {expr with pexp_attributes = attrs}) + | _ -> (expr.pexp_loc, expr) + in + let printedLbl = + match argLbl with + | Asttypes.Nolabel -> Doc.nil + | Asttypes.Labelled lbl -> + let doc = Doc.concat [Doc.tilde; printIdentLike lbl; Doc.equal] in + printComments doc cmtTbl argLoc + | Asttypes.Optional lbl -> + let doc = + Doc.concat [Doc.tilde; printIdentLike lbl; Doc.equal; Doc.question] + in + printComments doc cmtTbl argLoc + in + let printedExpr = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + let loc = {argLoc with loc_end = expr.pexp_loc.loc_end} in + let doc = Doc.concat [printedLbl; printedExpr] in + printComments doc cmtTbl loc and printCases ~customLayout (cases : Parsetree.case list) cmtTbl = Doc.breakableGroup ~forceBreak:true @@ -57964,40 +57856,40 @@ and printCase ~customLayout (case : Parsetree.case) cmtTbl = match case.pc_rhs.pexp_desc with | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ | Pexp_sequence _ -> - printExpressionBlock ~customLayout - ~braces:(ParsetreeViewer.isBracedExpr case.pc_rhs) - case.pc_rhs cmtTbl + printExpressionBlock ~customLayout + ~braces:(ParsetreeViewer.isBracedExpr case.pc_rhs) + case.pc_rhs cmtTbl | _ -> ( - let doc = - printExpressionWithComments ~customLayout case.pc_rhs cmtTbl - in - match Parens.expr case.pc_rhs with - | Parenthesized -> addParens doc - | _ -> doc) + let doc = printExpressionWithComments ~customLayout case.pc_rhs cmtTbl in + match Parens.expr case.pc_rhs with + | Parenthesized -> addParens doc + | _ -> doc) in let guard = match case.pc_guard with | None -> Doc.nil | Some expr -> - Doc.group - (Doc.concat - [ - Doc.line; - Doc.text "if "; - printExpressionWithComments ~customLayout expr cmtTbl; - ]) + Doc.group + (Doc.concat + [ + Doc.line; + Doc.text "if "; + printExpressionWithComments ~customLayout expr cmtTbl; + ]) in let shouldInlineRhs = match case.pc_rhs.pexp_desc with - | Pexp_construct ({ txt = Longident.Lident ("()" | "true" | "false") }, _) + | Pexp_construct ({txt = Longident.Lident ("()" | "true" | "false")}, _) | Pexp_constant _ | Pexp_ident _ -> - true + true | _ when ParsetreeViewer.isHuggableRhs case.pc_rhs -> true | _ -> false in let shouldIndentPattern = - match case.pc_lhs.ppat_desc with Ppat_or _ -> false | _ -> true + match case.pc_lhs.ppat_desc with + | Ppat_or _ -> false + | _ -> true in let patternDoc = let doc = printPattern ~customLayout case.pc_lhs cmtTbl in @@ -58012,11 +57904,10 @@ and printCase ~customLayout (case : Parsetree.case) cmtTbl = Doc.indent guard; Doc.text " =>"; Doc.indent - (Doc.concat - [ (if shouldInlineRhs then Doc.space else Doc.line); rhs ]); + (Doc.concat [(if shouldInlineRhs then Doc.space else Doc.line); rhs]); ] in - Doc.group (Doc.concat [ Doc.text "| "; content ]) + Doc.group (Doc.concat [Doc.text "| "; content]) and printExprFunParameters ~customLayout ~inCallback ~async ~uncurried ~hasConstraint parameters cmtTbl = @@ -58028,15 +57919,15 @@ and printExprFunParameters ~customLayout ~inCallback ~async ~uncurried attrs = []; lbl = Asttypes.Nolabel; defaultExpr = None; - pat = { Parsetree.ppat_desc = Ppat_any; ppat_loc }; + pat = {Parsetree.ppat_desc = Ppat_any; ppat_loc}; }; ] when not uncurried -> - let any = - let doc = if hasConstraint then Doc.text "(_)" else Doc.text "_" in - printComments doc cmtTbl ppat_loc - in - if async then addAsync any else any + let any = + let doc = if hasConstraint then Doc.text "(_)" else Doc.text "_" in + printComments doc cmtTbl ppat_loc + in + if async then addAsync any else any (* let f = a => () *) | [ ParsetreeViewer.Parameter @@ -58044,16 +57935,16 @@ and printExprFunParameters ~customLayout ~inCallback ~async ~uncurried attrs = []; lbl = Asttypes.Nolabel; defaultExpr = None; - pat = { Parsetree.ppat_desc = Ppat_var stringLoc }; + pat = {Parsetree.ppat_desc = Ppat_var stringLoc}; }; ] when not uncurried -> - let txtDoc = - let var = printIdentLike stringLoc.txt in - let var = if hasConstraint then addParens var else var in - if async then addAsync var else var - in - printComments txtDoc cmtTbl stringLoc.loc + let txtDoc = + let var = printIdentLike stringLoc.txt in + let var = if hasConstraint then addParens var else var in + if async then addAsync var else var + in + printComments txtDoc cmtTbl stringLoc.loc (* let f = () => () *) | [ ParsetreeViewer.Parameter @@ -58062,264 +57953,250 @@ and printExprFunParameters ~customLayout ~inCallback ~async ~uncurried lbl = Asttypes.Nolabel; defaultExpr = None; pat = - { - ppat_desc = - Ppat_construct ({ txt = Longident.Lident "()"; loc }, None); - }; + {ppat_desc = Ppat_construct ({txt = Longident.Lident "()"; loc}, None)}; }; ] when not uncurried -> - let doc = - let lparenRparen = Doc.text "()" in - if async then addAsync lparenRparen else lparenRparen - in - printComments doc cmtTbl loc + let doc = + let lparenRparen = Doc.text "()" in + if async then addAsync lparenRparen else lparenRparen + in + printComments doc cmtTbl loc (* let f = (~greeting, ~from as hometown, ~x=?) => () *) | parameters -> - let inCallback = - match inCallback with FitsOnOneLine -> true | _ -> false - in - let maybeAsyncLparen = - let lparen = if uncurried then Doc.text "(. " else Doc.lparen in - if async then addAsync lparen else lparen - in - let shouldHug = ParsetreeViewer.parametersShouldHug parameters in - let printedParamaters = - Doc.concat - [ - (if shouldHug || inCallback then Doc.nil else Doc.softLine); - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun p -> printExpFunParameter ~customLayout p cmtTbl) - parameters); - ] - in - Doc.group - (Doc.concat - [ - maybeAsyncLparen; - (if shouldHug || inCallback then printedParamaters - else - Doc.concat - [ - Doc.indent printedParamaters; Doc.trailingComma; Doc.softLine; - ]); - Doc.rparen; - ]) + let inCallback = + match inCallback with + | FitsOnOneLine -> true + | _ -> false + in + let maybeAsyncLparen = + let lparen = if uncurried then Doc.text "(. " else Doc.lparen in + if async then addAsync lparen else lparen + in + let shouldHug = ParsetreeViewer.parametersShouldHug parameters in + let printedParamaters = + Doc.concat + [ + (if shouldHug || inCallback then Doc.nil else Doc.softLine); + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun p -> printExpFunParameter ~customLayout p cmtTbl) + parameters); + ] + in + Doc.group + (Doc.concat + [ + maybeAsyncLparen; + (if shouldHug || inCallback then printedParamaters + else + Doc.concat + [Doc.indent printedParamaters; Doc.trailingComma; Doc.softLine]); + Doc.rparen; + ]) and printExpFunParameter ~customLayout parameter cmtTbl = match parameter with - | ParsetreeViewer.NewTypes { attrs; locs = lbls } -> + | ParsetreeViewer.NewTypes {attrs; locs = lbls} -> + Doc.group + (Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + Doc.text "type "; + Doc.join ~sep:Doc.space + (List.map + (fun lbl -> + printComments + (printIdentLike lbl.Asttypes.txt) + cmtTbl lbl.Asttypes.loc) + lbls); + ]) + | Parameter {attrs; lbl; defaultExpr; pat = pattern} -> + let isUncurried, attrs = ParsetreeViewer.processUncurriedAttribute attrs in + let uncurried = + if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil + in + let attrs = printAttributes ~customLayout attrs cmtTbl in + (* =defaultValue *) + let defaultExprDoc = + match defaultExpr with + | Some expr -> + Doc.concat + [Doc.text "="; printExpressionWithComments ~customLayout expr cmtTbl] + | None -> Doc.nil + in + (* ~from as hometown + * ~from -> punning *) + let labelWithPattern = + match (lbl, pattern) with + | Asttypes.Nolabel, pattern -> printPattern ~customLayout pattern cmtTbl + | ( (Asttypes.Labelled lbl | Optional lbl), + { + ppat_desc = Ppat_var stringLoc; + ppat_attributes = [] | [({Location.txt = "ns.namedArgLoc"}, _)]; + } ) + when lbl = stringLoc.txt -> + (* ~d *) + Doc.concat [Doc.text "~"; printIdentLike lbl] + | ( (Asttypes.Labelled lbl | Optional lbl), + { + ppat_desc = Ppat_constraint ({ppat_desc = Ppat_var {txt}}, typ); + ppat_attributes = [] | [({Location.txt = "ns.namedArgLoc"}, _)]; + } ) + when lbl = txt -> + (* ~d: e *) + Doc.concat + [ + Doc.text "~"; + printIdentLike lbl; + Doc.text ": "; + printTypExpr ~customLayout typ cmtTbl; + ] + | (Asttypes.Labelled lbl | Optional lbl), pattern -> + (* ~b as c *) + Doc.concat + [ + Doc.text "~"; + printIdentLike lbl; + Doc.text " as "; + printPattern ~customLayout pattern cmtTbl; + ] + in + let optionalLabelSuffix = + match (lbl, defaultExpr) with + | Asttypes.Optional _, None -> Doc.text "=?" + | _ -> Doc.nil + in + let doc = Doc.group (Doc.concat [ - printAttributes ~customLayout attrs cmtTbl; - Doc.text "type "; - Doc.join ~sep:Doc.space - (List.map - (fun lbl -> - printComments - (printIdentLike lbl.Asttypes.txt) - cmtTbl lbl.Asttypes.loc) - lbls); + uncurried; + attrs; + labelWithPattern; + defaultExprDoc; + optionalLabelSuffix; ]) - | Parameter { attrs; lbl; defaultExpr; pat = pattern } -> - let isUncurried, attrs = - ParsetreeViewer.processUncurriedAttribute attrs - in - let uncurried = - if isUncurried then Doc.concat [ Doc.dot; Doc.space ] else Doc.nil - in - let attrs = printAttributes ~customLayout attrs cmtTbl in - (* =defaultValue *) - let defaultExprDoc = - match defaultExpr with - | Some expr -> - Doc.concat - [ - Doc.text "="; - printExpressionWithComments ~customLayout expr cmtTbl; - ] - | None -> Doc.nil - in - (* ~from as hometown - * ~from -> punning *) - let labelWithPattern = - match (lbl, pattern) with - | Asttypes.Nolabel, pattern -> printPattern ~customLayout pattern cmtTbl - | ( (Asttypes.Labelled lbl | Optional lbl), - { - ppat_desc = Ppat_var stringLoc; - ppat_attributes = - [] | [ ({ Location.txt = "ns.namedArgLoc" }, _) ]; - } ) - when lbl = stringLoc.txt -> - (* ~d *) - Doc.concat [ Doc.text "~"; printIdentLike lbl ] - | ( (Asttypes.Labelled lbl | Optional lbl), - { - ppat_desc = Ppat_constraint ({ ppat_desc = Ppat_var { txt } }, typ); - ppat_attributes = - [] | [ ({ Location.txt = "ns.namedArgLoc" }, _) ]; - } ) - when lbl = txt -> - (* ~d: e *) - Doc.concat - [ - Doc.text "~"; - printIdentLike lbl; - Doc.text ": "; - printTypExpr ~customLayout typ cmtTbl; - ] - | (Asttypes.Labelled lbl | Optional lbl), pattern -> - (* ~b as c *) - Doc.concat - [ - Doc.text "~"; - printIdentLike lbl; - Doc.text " as "; - printPattern ~customLayout pattern cmtTbl; - ] - in - let optionalLabelSuffix = - match (lbl, defaultExpr) with - | Asttypes.Optional _, None -> Doc.text "=?" - | _ -> Doc.nil - in - let doc = - Doc.group - (Doc.concat - [ - uncurried; - attrs; - labelWithPattern; - defaultExprDoc; - optionalLabelSuffix; - ]) - in - let cmtLoc = - match defaultExpr with - | None -> ( - match pattern.ppat_attributes with - | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _ -> - { loc with loc_end = pattern.ppat_loc.loc_end } - | _ -> pattern.ppat_loc) - | Some expr -> - let startPos = - match pattern.ppat_attributes with - | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _ -> - loc.loc_start - | _ -> pattern.ppat_loc.loc_start - in - { - pattern.ppat_loc with - loc_start = startPos; - loc_end = expr.pexp_loc.loc_end; - } - in - printComments doc cmtTbl cmtLoc + in + let cmtLoc = + match defaultExpr with + | None -> ( + match pattern.ppat_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> + {loc with loc_end = pattern.ppat_loc.loc_end} + | _ -> pattern.ppat_loc) + | Some expr -> + let startPos = + match pattern.ppat_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> loc.loc_start + | _ -> pattern.ppat_loc.loc_start + in + { + pattern.ppat_loc with + loc_start = startPos; + loc_end = expr.pexp_loc.loc_end; + } + in + printComments doc cmtTbl cmtLoc and printExpressionBlock ~customLayout ~braces expr cmtTbl = let rec collectRows acc expr = match expr.Parsetree.pexp_desc with | Parsetree.Pexp_letmodule (modName, modExpr, expr2) -> - let name = - let doc = Doc.text modName.txt in - printComments doc cmtTbl modName.loc - in - let letModuleDoc = - Doc.concat - [ - Doc.text "module "; - name; - Doc.text " = "; - printModExpr ~customLayout modExpr cmtTbl; - ] - in - let loc = { expr.pexp_loc with loc_end = modExpr.pmod_loc.loc_end } in - collectRows ((loc, letModuleDoc) :: acc) expr2 + let name = + let doc = Doc.text modName.txt in + printComments doc cmtTbl modName.loc + in + let letModuleDoc = + Doc.concat + [ + Doc.text "module "; + name; + Doc.text " = "; + printModExpr ~customLayout modExpr cmtTbl; + ] + in + let loc = {expr.pexp_loc with loc_end = modExpr.pmod_loc.loc_end} in + collectRows ((loc, letModuleDoc) :: acc) expr2 | Pexp_letexception (extensionConstructor, expr2) -> + let loc = let loc = - let loc = - { - expr.pexp_loc with - loc_end = extensionConstructor.pext_loc.loc_end; - } - in - match getFirstLeadingComment cmtTbl loc with - | None -> loc - | Some comment -> - let cmtLoc = Comment.loc comment in - { cmtLoc with loc_end = loc.loc_end } - in - let letExceptionDoc = - printExceptionDef ~customLayout extensionConstructor cmtTbl + {expr.pexp_loc with loc_end = extensionConstructor.pext_loc.loc_end} in - collectRows ((loc, letExceptionDoc) :: acc) expr2 + match getFirstLeadingComment cmtTbl loc with + | None -> loc + | Some comment -> + let cmtLoc = Comment.loc comment in + {cmtLoc with loc_end = loc.loc_end} + in + let letExceptionDoc = + printExceptionDef ~customLayout extensionConstructor cmtTbl + in + collectRows ((loc, letExceptionDoc) :: acc) expr2 | Pexp_open (overrideFlag, longidentLoc, expr2) -> - let openDoc = - Doc.concat - [ - Doc.text "open"; - printOverrideFlag overrideFlag; - Doc.space; - printLongidentLocation longidentLoc cmtTbl; - ] - in - let loc = { expr.pexp_loc with loc_end = longidentLoc.loc.loc_end } in - collectRows ((loc, openDoc) :: acc) expr2 + let openDoc = + Doc.concat + [ + Doc.text "open"; + printOverrideFlag overrideFlag; + Doc.space; + printLongidentLocation longidentLoc cmtTbl; + ] + in + let loc = {expr.pexp_loc with loc_end = longidentLoc.loc.loc_end} in + collectRows ((loc, openDoc) :: acc) expr2 | Pexp_sequence (expr1, expr2) -> - let exprDoc = - let doc = printExpression ~customLayout expr1 cmtTbl in - match Parens.expr expr1 with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr1 braces - | Nothing -> doc - in - let loc = expr1.pexp_loc in - collectRows ((loc, exprDoc) :: acc) expr2 + let exprDoc = + let doc = printExpression ~customLayout expr1 cmtTbl in + match Parens.expr expr1 with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr1 braces + | Nothing -> doc + in + let loc = expr1.pexp_loc in + collectRows ((loc, exprDoc) :: acc) expr2 | Pexp_let (recFlag, valueBindings, expr2) -> ( + let loc = let loc = - let loc = - match (valueBindings, List.rev valueBindings) with - | vb :: _, lastVb :: _ -> - { vb.pvb_loc with loc_end = lastVb.pvb_loc.loc_end } - | _ -> Location.none - in - match getFirstLeadingComment cmtTbl loc with - | None -> loc - | Some comment -> - let cmtLoc = Comment.loc comment in - { cmtLoc with loc_end = loc.loc_end } - in - let recFlag = - match recFlag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - let letDoc = - printValueBindings ~customLayout ~recFlag valueBindings cmtTbl + match (valueBindings, List.rev valueBindings) with + | vb :: _, lastVb :: _ -> + {vb.pvb_loc with loc_end = lastVb.pvb_loc.loc_end} + | _ -> Location.none in - (* let () = { - * let () = foo() - * () - * } - * We don't need to print the () on the last line of the block - *) - match expr2.pexp_desc with - | Pexp_construct ({ txt = Longident.Lident "()" }, _) -> - List.rev ((loc, letDoc) :: acc) - | _ -> collectRows ((loc, letDoc) :: acc) expr2) + match getFirstLeadingComment cmtTbl loc with + | None -> loc + | Some comment -> + let cmtLoc = Comment.loc comment in + {cmtLoc with loc_end = loc.loc_end} + in + let recFlag = + match recFlag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + let letDoc = + printValueBindings ~customLayout ~recFlag valueBindings cmtTbl + in + (* let () = { + * let () = foo() + * () + * } + * We don't need to print the () on the last line of the block + *) + match expr2.pexp_desc with + | Pexp_construct ({txt = Longident.Lident "()"}, _) -> + List.rev ((loc, letDoc) :: acc) + | _ -> collectRows ((loc, letDoc) :: acc) expr2) | _ -> - let exprDoc = - let doc = printExpression ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - List.rev ((expr.pexp_loc, exprDoc) :: acc) + let exprDoc = + let doc = printExpression ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + List.rev ((expr.pexp_loc, exprDoc) :: acc) in let rows = collectRows [] expr in let block = @@ -58332,7 +58209,7 @@ and printExpressionBlock ~customLayout ~braces expr cmtTbl = Doc.concat [ Doc.lbrace; - Doc.indent (Doc.concat [ Doc.line; block ]); + Doc.indent (Doc.concat [Doc.line; block]); Doc.line; Doc.rbrace; ] @@ -58363,25 +58240,27 @@ and printBraces doc expr bracesLoc = match expr.Parsetree.pexp_desc with | Pexp_letmodule _ | Pexp_letexception _ | Pexp_let _ | Pexp_open _ | Pexp_sequence _ -> - (* already has braces *) - doc + (* already has braces *) + doc | _ -> - Doc.breakableGroup ~forceBreak:overMultipleLines - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - (if Parens.bracedExpr expr then addParens doc else doc); - ]); - Doc.softLine; - Doc.rbrace; - ]) + Doc.breakableGroup ~forceBreak:overMultipleLines + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.softLine; + (if Parens.bracedExpr expr then addParens doc else doc); + ]); + Doc.softLine; + Doc.rbrace; + ]) and printOverrideFlag overrideFlag = - match overrideFlag with Asttypes.Override -> Doc.text "!" | Fresh -> Doc.nil + match overrideFlag with + | Asttypes.Override -> Doc.text "!" + | Fresh -> Doc.nil and printDirectionFlag flag = match flag with @@ -58389,41 +58268,39 @@ and printDirectionFlag flag = | Asttypes.Upto -> Doc.text " to " and printExpressionRecordRow ~customLayout (lbl, expr) cmtTbl punningAllowed = - let cmtLoc = { lbl.loc with loc_end = expr.pexp_loc.loc_end } in + let cmtLoc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in let doc = Doc.group (match expr.pexp_desc with - | Pexp_ident { txt = Lident key; loc = _keyLoc } + | Pexp_ident {txt = Lident key; loc = _keyLoc} when punningAllowed && Longident.last lbl.txt = key -> - (* print punned field *) - Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - printOptionalLabel expr.pexp_attributes; - printLidentPath lbl cmtTbl; - ] + (* print punned field *) + Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + printOptionalLabel expr.pexp_attributes; + printLidentPath lbl cmtTbl; + ] | _ -> - Doc.concat - [ - printLidentPath lbl cmtTbl; - Doc.text ": "; - printOptionalLabel expr.pexp_attributes; - (let doc = - printExpressionWithComments ~customLayout expr cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); - ]) + Doc.concat + [ + printLidentPath lbl cmtTbl; + Doc.text ": "; + printOptionalLabel expr.pexp_attributes; + (let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + ]) in printComments doc cmtTbl cmtLoc and printBsObjectRow ~customLayout (lbl, expr) cmtTbl = - let cmtLoc = { lbl.loc with loc_end = expr.pexp_loc.loc_end } in + let cmtLoc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in let lblDoc = let doc = - Doc.concat [ Doc.text "\""; printLongident lbl.txt; Doc.text "\"" ] + Doc.concat [Doc.text "\""; printLongident lbl.txt; Doc.text "\""] in printComments doc cmtTbl lbl.loc in @@ -58452,80 +58329,46 @@ and printAttributes ?loc ?(inline = false) ~customLayout match ParsetreeViewer.filterParsingAttrs attrs with | [] -> Doc.nil | attrs -> - let lineBreak = - match loc with - | None -> Doc.line - | Some loc -> ( - match List.rev attrs with - | ({ loc = firstLoc }, _) :: _ - when loc.loc_start.pos_lnum > firstLoc.loc_end.pos_lnum -> - Doc.hardLine - | _ -> Doc.line) - in - Doc.concat - [ - Doc.group - (Doc.joinWithSep - (List.map - (fun attr -> printAttribute ~customLayout attr cmtTbl) - attrs)); - (if inline then Doc.space else lineBreak); - ] + let lineBreak = + match loc with + | None -> Doc.line + | Some loc -> ( + match List.rev attrs with + | ({loc = firstLoc}, _) :: _ + when loc.loc_start.pos_lnum > firstLoc.loc_end.pos_lnum -> + Doc.hardLine + | _ -> Doc.line) + in + Doc.concat + [ + Doc.group + (Doc.joinWithSep + (List.map + (fun attr -> printAttribute ~customLayout attr cmtTbl) + attrs)); + (if inline then Doc.space else lineBreak); + ] and printPayload ~customLayout (payload : Parsetree.payload) cmtTbl = - match payload with - | PStr [] -> Doc.nil - | PStr [ { pstr_desc = Pstr_eval (expr, attrs) } ] -> - let exprDoc = printExpressionWithComments ~customLayout expr cmtTbl in - let needsParens = match attrs with [] -> false | _ -> true in - let shouldHug = ParsetreeViewer.isHuggableExpression expr in - if shouldHug then - Doc.concat - [ - Doc.lparen; - printAttributes ~customLayout attrs cmtTbl; - (if needsParens then addParens exprDoc else exprDoc); - Doc.rparen; - ] - else - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - printAttributes ~customLayout attrs cmtTbl; - (if needsParens then addParens exprDoc else exprDoc); - ]); - Doc.softLine; - Doc.rparen; - ] - | PStr [ ({ pstr_desc = Pstr_value (_recFlag, _bindings) } as si) ] -> - addParens (printStructureItem ~customLayout si cmtTbl) - | PStr structure -> addParens (printStructure ~customLayout structure cmtTbl) - | PTyp typ -> + match payload with + | PStr [] -> Doc.nil + | PStr [{pstr_desc = Pstr_eval (expr, attrs)}] -> + let exprDoc = printExpressionWithComments ~customLayout expr cmtTbl in + let needsParens = + match attrs with + | [] -> false + | _ -> true + in + let shouldHug = ParsetreeViewer.isHuggableExpression expr in + if shouldHug then Doc.concat [ Doc.lparen; - Doc.text ":"; - Doc.indent - (Doc.concat [ Doc.line; printTypExpr ~customLayout typ cmtTbl ]); - Doc.softLine; + printAttributes ~customLayout attrs cmtTbl; + (if needsParens then addParens exprDoc else exprDoc); Doc.rparen; ] - | PPat (pat, optExpr) -> - let whenDoc = - match optExpr with - | Some expr -> - Doc.concat - [ - Doc.line; - Doc.text "if "; - printExpressionWithComments ~customLayout expr cmtTbl; - ] - | None -> Doc.nil - in + else Doc.concat [ Doc.lparen; @@ -58533,193 +58376,217 @@ and printPayload ~customLayout (payload : Parsetree.payload) cmtTbl = (Doc.concat [ Doc.softLine; - Doc.text "? "; - printPattern ~customLayout pat cmtTbl; - whenDoc; + printAttributes ~customLayout attrs cmtTbl; + (if needsParens then addParens exprDoc else exprDoc); ]); Doc.softLine; Doc.rparen; ] + | PStr [({pstr_desc = Pstr_value (_recFlag, _bindings)} as si)] -> + addParens (printStructureItem ~customLayout si cmtTbl) + | PStr structure -> addParens (printStructure ~customLayout structure cmtTbl) + | PTyp typ -> + Doc.concat + [ + Doc.lparen; + Doc.text ":"; + Doc.indent + (Doc.concat [Doc.line; printTypExpr ~customLayout typ cmtTbl]); + Doc.softLine; + Doc.rparen; + ] + | PPat (pat, optExpr) -> + let whenDoc = + match optExpr with + | Some expr -> + Doc.concat + [ + Doc.line; + Doc.text "if "; + printExpressionWithComments ~customLayout expr cmtTbl; + ] + | None -> Doc.nil + in + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.text "? "; + printPattern ~customLayout pat cmtTbl; + whenDoc; + ]); + Doc.softLine; + Doc.rparen; + ] | PSig signature -> - Doc.concat - [ - Doc.lparen; - Doc.text ":"; - Doc.indent - (Doc.concat - [ Doc.line; printSignature ~customLayout signature cmtTbl ]); - Doc.softLine; - Doc.rparen; - ] + Doc.concat + [ + Doc.lparen; + Doc.text ":"; + Doc.indent + (Doc.concat [Doc.line; printSignature ~customLayout signature cmtTbl]); + Doc.softLine; + Doc.rparen; + ] and printAttribute ?(standalone = false) ~customLayout ((id, payload) : Parsetree.attribute) cmtTbl = match (id, payload) with - | ( { txt = "ns.doc" }, + | ( {txt = "ns.doc"}, PStr [ { pstr_desc = - Pstr_eval - ({ pexp_desc = Pexp_constant (Pconst_string (txt, _)) }, _); + Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (txt, _))}, _); }; ] ) -> - ( Doc.concat - [ - Doc.text (if standalone then "/***" else "/**"); - Doc.text txt; - Doc.text "*/"; - ], - Doc.hardLine ) + ( Doc.concat + [ + Doc.text (if standalone then "/***" else "/**"); + Doc.text txt; + Doc.text "*/"; + ], + Doc.hardLine ) | _ -> - ( Doc.group - (Doc.concat - [ - Doc.text (if standalone then "@@" else "@"); - Doc.text (convertBsExternalAttribute id.txt); - printPayload ~customLayout payload cmtTbl; - ]), - Doc.line ) + ( Doc.group + (Doc.concat + [ + Doc.text (if standalone then "@@" else "@"); + Doc.text (convertBsExternalAttribute id.txt); + printPayload ~customLayout payload cmtTbl; + ]), + Doc.line ) and printModExpr ~customLayout modExpr cmtTbl = let doc = match modExpr.pmod_desc with | Pmod_ident longidentLoc -> printLongidentLocation longidentLoc cmtTbl | Pmod_structure [] -> - let shouldBreak = - modExpr.pmod_loc.loc_start.pos_lnum - < modExpr.pmod_loc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak:shouldBreak - (Doc.concat - [ - Doc.lbrace; - printCommentsInside cmtTbl modExpr.pmod_loc; - Doc.rbrace; - ]) + let shouldBreak = + modExpr.pmod_loc.loc_start.pos_lnum < modExpr.pmod_loc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak:shouldBreak + (Doc.concat + [Doc.lbrace; printCommentsInside cmtTbl modExpr.pmod_loc; Doc.rbrace]) | Pmod_structure structure -> - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - printStructure ~customLayout structure cmtTbl; - ]); - Doc.softLine; - Doc.rbrace; - ]) + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [Doc.softLine; printStructure ~customLayout structure cmtTbl]); + Doc.softLine; + Doc.rbrace; + ]) | Pmod_unpack expr -> - let shouldHug = - match expr.pexp_desc with - | Pexp_let _ -> true - | Pexp_constraint - ( { pexp_desc = Pexp_let _ }, - { ptyp_desc = Ptyp_package _packageType } ) -> - true - | _ -> false - in - let expr, moduleConstraint = - match expr.pexp_desc with - | Pexp_constraint - (expr, { ptyp_desc = Ptyp_package packageType; ptyp_loc }) -> - let packageDoc = - let doc = - printPackageType ~customLayout - ~printModuleKeywordAndParens:false packageType cmtTbl - in - printComments doc cmtTbl ptyp_loc - in - let typeDoc = - Doc.group - (Doc.concat - [ - Doc.text ":"; - Doc.indent (Doc.concat [ Doc.line; packageDoc ]); - ]) - in - (expr, typeDoc) - | _ -> (expr, Doc.nil) - in - let unpackDoc = - Doc.group - (Doc.concat - [ - printExpressionWithComments ~customLayout expr cmtTbl; - moduleConstraint; - ]) - in + let shouldHug = + match expr.pexp_desc with + | Pexp_let _ -> true + | Pexp_constraint + ({pexp_desc = Pexp_let _}, {ptyp_desc = Ptyp_package _packageType}) + -> + true + | _ -> false + in + let expr, moduleConstraint = + match expr.pexp_desc with + | Pexp_constraint + (expr, {ptyp_desc = Ptyp_package packageType; ptyp_loc}) -> + let packageDoc = + let doc = + printPackageType ~customLayout ~printModuleKeywordAndParens:false + packageType cmtTbl + in + printComments doc cmtTbl ptyp_loc + in + let typeDoc = + Doc.group + (Doc.concat + [Doc.text ":"; Doc.indent (Doc.concat [Doc.line; packageDoc])]) + in + (expr, typeDoc) + | _ -> (expr, Doc.nil) + in + let unpackDoc = Doc.group (Doc.concat [ - Doc.text "unpack("; - (if shouldHug then unpackDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [ Doc.softLine; unpackDoc ]); - Doc.softLine; - ]); - Doc.rparen; + printExpressionWithComments ~customLayout expr cmtTbl; + moduleConstraint; ]) + in + Doc.group + (Doc.concat + [ + Doc.text "unpack("; + (if shouldHug then unpackDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [Doc.softLine; unpackDoc]); + Doc.softLine; + ]); + Doc.rparen; + ]) | Pmod_extension extension -> - printExtension ~customLayout ~atModuleLvl:false extension cmtTbl + printExtension ~customLayout ~atModuleLvl:false extension cmtTbl | Pmod_apply _ -> - let args, callExpr = ParsetreeViewer.modExprApply modExpr in - let isUnitSugar = - match args with - | [ { pmod_desc = Pmod_structure [] } ] -> true - | _ -> false - in - let shouldHug = - match args with - | [ { pmod_desc = Pmod_structure _ } ] -> true - | _ -> false - in - Doc.group - (Doc.concat - [ - printModExpr ~customLayout callExpr cmtTbl; - (if isUnitSugar then - printModApplyArg ~customLayout - (List.hd args [@doesNotRaise]) - cmtTbl - else - Doc.concat - [ - Doc.lparen; - (if shouldHug then - printModApplyArg ~customLayout - (List.hd args [@doesNotRaise]) - cmtTbl - else - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun modArg -> - printModApplyArg ~customLayout modArg - cmtTbl) - args); - ])); - (if not shouldHug then - Doc.concat [ Doc.trailingComma; Doc.softLine ] - else Doc.nil); - Doc.rparen; - ]); - ]) + let args, callExpr = ParsetreeViewer.modExprApply modExpr in + let isUnitSugar = + match args with + | [{pmod_desc = Pmod_structure []}] -> true + | _ -> false + in + let shouldHug = + match args with + | [{pmod_desc = Pmod_structure _}] -> true + | _ -> false + in + Doc.group + (Doc.concat + [ + printModExpr ~customLayout callExpr cmtTbl; + (if isUnitSugar then + printModApplyArg ~customLayout + (List.hd args [@doesNotRaise]) + cmtTbl + else + Doc.concat + [ + Doc.lparen; + (if shouldHug then + printModApplyArg ~customLayout + (List.hd args [@doesNotRaise]) + cmtTbl + else + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun modArg -> + printModApplyArg ~customLayout modArg cmtTbl) + args); + ])); + (if not shouldHug then + Doc.concat [Doc.trailingComma; Doc.softLine] + else Doc.nil); + Doc.rparen; + ]); + ]) | Pmod_constraint (modExpr, modType) -> - Doc.concat - [ - printModExpr ~customLayout modExpr cmtTbl; - Doc.text ": "; - printModType ~customLayout modType cmtTbl; - ] + Doc.concat + [ + printModExpr ~customLayout modExpr cmtTbl; + Doc.text ": "; + printModType ~customLayout modType cmtTbl; + ] | Pmod_functor _ -> printModFunctor ~customLayout modExpr cmtTbl in printComments doc cmtTbl modExpr.pmod_loc @@ -58734,52 +58601,51 @@ and printModFunctor ~customLayout modExpr cmtTbl = let returnConstraint, returnModExpr = match returnModExpr.pmod_desc with | Pmod_constraint (modExpr, modType) -> - let constraintDoc = - let doc = printModType ~customLayout modType cmtTbl in - if Parens.modExprFunctorConstraint modType then addParens doc else doc - in - let modConstraint = Doc.concat [ Doc.text ": "; constraintDoc ] in - (modConstraint, printModExpr ~customLayout modExpr cmtTbl) + let constraintDoc = + let doc = printModType ~customLayout modType cmtTbl in + if Parens.modExprFunctorConstraint modType then addParens doc else doc + in + let modConstraint = Doc.concat [Doc.text ": "; constraintDoc] in + (modConstraint, printModExpr ~customLayout modExpr cmtTbl) | _ -> (Doc.nil, printModExpr ~customLayout returnModExpr cmtTbl) in let parametersDoc = match parameters with - | [ (attrs, { txt = "*" }, None) ] -> - Doc.group - (Doc.concat - [ printAttributes ~customLayout attrs cmtTbl; Doc.text "()" ]) - | [ ([], { txt = lbl }, None) ] -> Doc.text lbl + | [(attrs, {txt = "*"}, None)] -> + Doc.group + (Doc.concat [printAttributes ~customLayout attrs cmtTbl; Doc.text "()"]) + | [([], {txt = lbl}, None)] -> Doc.text lbl | parameters -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun param -> - printModFunctorParam ~customLayout param cmtTbl) - parameters); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun param -> + printModFunctorParam ~customLayout param cmtTbl) + parameters); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) in Doc.group (Doc.concat - [ parametersDoc; returnConstraint; Doc.text " => "; returnModExpr ]) + [parametersDoc; returnConstraint; Doc.text " => "; returnModExpr]) and printModFunctorParam ~customLayout (attrs, lbl, optModType) cmtTbl = let cmtLoc = match optModType with | None -> lbl.Asttypes.loc | Some modType -> - { lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end } + {lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end} in let attrs = printAttributes ~customLayout attrs cmtTbl in let lblDoc = @@ -58795,8 +58661,8 @@ and printModFunctorParam ~customLayout (attrs, lbl, optModType) cmtTbl = (match optModType with | None -> Doc.nil | Some modType -> - Doc.concat - [ Doc.text ": "; printModType ~customLayout modType cmtTbl ]); + Doc.concat + [Doc.text ": "; printModType ~customLayout modType cmtTbl]); ]) in printComments doc cmtTbl cmtLoc @@ -58811,25 +58677,22 @@ and printExceptionDef ~customLayout (constr : Parsetree.extension_constructor) let kind = match constr.pext_kind with | Pext_rebind longident -> - Doc.indent - (Doc.concat - [ - Doc.text " ="; Doc.line; printLongidentLocation longident cmtTbl; - ]) + Doc.indent + (Doc.concat + [Doc.text " ="; Doc.line; printLongidentLocation longident cmtTbl]) | Pext_decl (Pcstr_tuple [], None) -> Doc.nil | Pext_decl (args, gadt) -> - let gadtDoc = - match gadt with - | Some typ -> - Doc.concat - [ Doc.text ": "; printTypExpr ~customLayout typ cmtTbl ] - | None -> Doc.nil - in - Doc.concat - [ - printConstructorArguments ~customLayout ~indent:false args cmtTbl; - gadtDoc; - ] + let gadtDoc = + match gadt with + | Some typ -> + Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ cmtTbl] + | None -> Doc.nil + in + Doc.concat + [ + printConstructorArguments ~customLayout ~indent:false args cmtTbl; + gadtDoc; + ] in let name = printComments (Doc.text constr.pext_name.txt) cmtTbl constr.pext_name.loc @@ -58855,30 +58718,27 @@ and printExtensionConstructor ~customLayout let kind = match constr.pext_kind with | Pext_rebind longident -> - Doc.indent - (Doc.concat - [ - Doc.text " ="; Doc.line; printLongidentLocation longident cmtTbl; - ]) + Doc.indent + (Doc.concat + [Doc.text " ="; Doc.line; printLongidentLocation longident cmtTbl]) | Pext_decl (Pcstr_tuple [], None) -> Doc.nil | Pext_decl (args, gadt) -> - let gadtDoc = - match gadt with - | Some typ -> - Doc.concat - [ Doc.text ": "; printTypExpr ~customLayout typ cmtTbl ] - | None -> Doc.nil - in - Doc.concat - [ - printConstructorArguments ~customLayout ~indent:false args cmtTbl; - gadtDoc; - ] + let gadtDoc = + match gadt with + | Some typ -> + Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ cmtTbl] + | None -> Doc.nil + in + Doc.concat + [ + printConstructorArguments ~customLayout ~indent:false args cmtTbl; + gadtDoc; + ] in let name = printComments (Doc.text constr.pext_name.txt) cmtTbl constr.pext_name.loc in - Doc.concat [ bar; Doc.group (Doc.concat [ attrs; name; kind ]) ] + Doc.concat [bar; Doc.group (Doc.concat [attrs; name; kind])] let printTypeParams = printTypeParams ~customLayout:0 let printTypExpr = printTypExpr ~customLayout:0 diff --git a/lib/4.06.1/unstable/js_playground_compiler.ml b/lib/4.06.1/unstable/js_playground_compiler.ml index 929a54aaa5..7a87841aff 100644 --- a/lib/4.06.1/unstable/js_playground_compiler.ml +++ b/lib/4.06.1/unstable/js_playground_compiler.ml @@ -25005,6 +25005,7 @@ let decode_utf8_string s = assert false *) let encode_codepoint c = + (* reused from syntax/src/res_utf8.ml *) let h2 = 0b1100_0000 in let h3 = 0b1110_0000 in let h4 = 0b1111_0000 in @@ -25120,11 +25121,21 @@ let stats_to_string (Array.to_list (Array.map string_of_int bucket_histogram))) let string_of_int_as_char i = - if i >= 0 && i <= 255 - then - Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) - else - Printf.sprintf "\'%s\'" (Ext_utf8.encode_codepoint i) + let str = match Char.unsafe_chr i with + | '\'' -> "\\'" + | '\\' -> "\\\\" + | '\n' -> "\\n" + | '\t' -> "\\t" + | '\r' -> "\\r" + | '\b' -> "\\b" + | ' ' .. '~' as c -> + let s = (Bytes.create [@doesNotRaise]) 1 in + Bytes.unsafe_set s 0 c; + Bytes.unsafe_to_string s + | _ -> Ext_utf8.encode_codepoint i + in + Printf.sprintf "\'%s\'" str + end module Pprintast : sig @@ -52652,9 +52663,9 @@ type t = | Open | True | False - | Codepoint of { c : int; original : string } - | Int of { i : string; suffix : char option } - | Float of { f : string; suffix : char option } + | Codepoint of {c: int; original: string} + | Int of {i: string; suffix: char option} + | Float of {f: string; suffix: char option} | String of string | Lident of string | Uident of string @@ -52750,7 +52761,7 @@ let precedence = function | Land -> 3 | Equal | EqualEqual | EqualEqualEqual | LessThan | GreaterThan | BangEqual | BangEqualEqual | LessEqual | GreaterEqual | BarGreater -> - 4 + 4 | Plus | PlusDot | Minus | MinusDot | PlusPlus -> 5 | Asterisk | AsteriskDot | Forwardslash | ForwardslashDot -> 6 | Exponentiation -> 7 @@ -52763,15 +52774,15 @@ let toString = function | Open -> "open" | True -> "true" | False -> "false" - | Codepoint { original } -> "codepoint '" ^ original ^ "'" + | Codepoint {original} -> "codepoint '" ^ original ^ "'" | String s -> "string \"" ^ s ^ "\"" | Lident str -> str | Uident str -> str | Dot -> "." | DotDot -> ".." | DotDotDot -> "..." - | Int { i } -> "int " ^ i - | Float { f } -> "Float: " ^ f + | Int {i} -> "int " ^ i + | Float {f} -> "Float: " ^ f | Bang -> "!" | Semicolon -> ";" | Let -> "let" @@ -52891,7 +52902,7 @@ let isKeyword = function | Await | And | As | Assert | Constraint | Else | Exception | External | False | For | If | In | Include | Land | Lazy | Let | List | Lor | Module | Mutable | Of | Open | Private | Rec | Switch | True | Try | Typ | When | While -> - true + true | _ -> false let lookupKeyword str = @@ -53158,7 +53169,7 @@ let addParens doc = (Doc.concat [ Doc.lparen; - Doc.indent (Doc.concat [ Doc.softLine; doc ]); + Doc.indent (Doc.concat [Doc.softLine; doc]); Doc.softLine; Doc.rparen; ]) @@ -53168,12 +53179,12 @@ let addBraces doc = (Doc.concat [ Doc.lbrace; - Doc.indent (Doc.concat [ Doc.softLine; doc ]); + Doc.indent (Doc.concat [Doc.softLine; doc]); Doc.softLine; Doc.rbrace; ]) -let addAsync doc = Doc.concat [ Doc.text "async "; doc ] +let addAsync doc = Doc.concat [Doc.text "async "; doc] let getFirstLeadingComment tbl loc = match Hashtbl.find tbl.CommentTable.leading loc with @@ -53190,8 +53201,8 @@ let hasLeadingLineComment tbl loc = let hasCommentBelow tbl loc = match Hashtbl.find tbl.CommentTable.trailing loc with | comment :: _ -> - let commentLoc = Comment.loc comment in - commentLoc.Location.loc_start.pos_lnum > loc.Location.loc_end.pos_lnum + let commentLoc = Comment.loc comment in + commentLoc.Location.loc_start.pos_lnum > loc.Location.loc_end.pos_lnum | [] -> false | exception Not_found -> false @@ -53199,10 +53210,10 @@ let hasNestedJsxOrMoreThanOneChild expr = let rec loop inRecursion expr = match expr.Parsetree.pexp_desc with | Pexp_construct - ( { txt = Longident.Lident "::" }, - Some { pexp_desc = Pexp_tuple [ hd; tail ] } ) -> - if inRecursion || ParsetreeViewer.isJsxExpression hd then true - else loop true tail + ({txt = Longident.Lident "::"}, Some {pexp_desc = Pexp_tuple [hd; tail]}) + -> + if inRecursion || ParsetreeViewer.isJsxExpression hd then true + else loop true tail | _ -> false in loop false expr @@ -53233,40 +53244,42 @@ let printMultilineCommentContent txt = let rec indentStars lines acc = match lines with | [] -> Doc.nil - | [ lastLine ] -> - let line = String.trim lastLine in - let doc = Doc.text (" " ^ line) in - let trailingSpace = if line = "" then Doc.nil else Doc.space in - List.rev (trailingSpace :: doc :: acc) |> Doc.concat + | [lastLine] -> + let line = String.trim lastLine in + let doc = Doc.text (" " ^ line) in + let trailingSpace = if line = "" then Doc.nil else Doc.space in + List.rev (trailingSpace :: doc :: acc) |> Doc.concat | line :: lines -> - let line = String.trim line in - if line != "" && String.unsafe_get line 0 == '*' then - let doc = Doc.text (" " ^ line) in - indentStars lines (Doc.hardLine :: doc :: acc) - else - let trailingSpace = - let len = String.length txt in - if len > 0 && String.unsafe_get txt (len - 1) = ' ' then Doc.space - else Doc.nil - in - let content = Comment.trimSpaces txt in - Doc.concat [ Doc.text content; trailingSpace ] + let line = String.trim line in + if line != "" && String.unsafe_get line 0 == '*' then + let doc = Doc.text (" " ^ line) in + indentStars lines (Doc.hardLine :: doc :: acc) + else + let trailingSpace = + let len = String.length txt in + if len > 0 && String.unsafe_get txt (len - 1) = ' ' then Doc.space + else Doc.nil + in + let content = Comment.trimSpaces txt in + Doc.concat [Doc.text content; trailingSpace] in let lines = String.split_on_char '\n' txt in match lines with | [] -> Doc.text "/* */" - | [ line ] -> - Doc.concat - [ Doc.text "/* "; Doc.text (Comment.trimSpaces line); Doc.text " */" ] + | [line] -> + Doc.concat + [Doc.text "/* "; Doc.text (Comment.trimSpaces line); Doc.text " */"] | first :: rest -> - let firstLine = Comment.trimSpaces first in - Doc.concat - [ - Doc.text "/*"; - (match firstLine with "" | "*" -> Doc.nil | _ -> Doc.space); - indentStars rest [ Doc.hardLine; Doc.text firstLine ]; - Doc.text "*/"; - ] + let firstLine = Comment.trimSpaces first in + Doc.concat + [ + Doc.text "/*"; + (match firstLine with + | "" | "*" -> Doc.nil + | _ -> Doc.space); + indentStars rest [Doc.hardLine; Doc.text firstLine]; + Doc.text "*/"; + ] let printTrailingComment (prevLoc : Location.t) (nodeLoc : Location.t) comment = let singleLine = Comment.isSingleLineComment comment in @@ -53294,8 +53307,8 @@ let printTrailingComment (prevLoc : Location.t) (nodeLoc : Location.t) comment = content; ]); ] - else if not singleLine then Doc.concat [ Doc.space; content ] - else Doc.lineSuffix (Doc.concat [ Doc.space; content ]) + else if not singleLine then Doc.concat [Doc.space; content] + else Doc.lineSuffix (Doc.concat [Doc.space; content]) let printLeadingComment ?nextComment comment = let singleLine = Comment.isSingleLineComment comment in @@ -53307,28 +53320,28 @@ let printLeadingComment ?nextComment comment = let separator = Doc.concat [ - (if singleLine then Doc.concat [ Doc.hardLine; Doc.breakParent ] + (if singleLine then Doc.concat [Doc.hardLine; Doc.breakParent] else Doc.nil); (match nextComment with | Some next -> - let nextLoc = Comment.loc next in - let currLoc = Comment.loc comment in - let diff = - nextLoc.Location.loc_start.pos_lnum - - currLoc.Location.loc_end.pos_lnum - in - let nextSingleLine = Comment.isSingleLineComment next in - if singleLine && nextSingleLine then - if diff > 1 then Doc.hardLine else Doc.nil - else if singleLine && not nextSingleLine then - if diff > 1 then Doc.hardLine else Doc.nil - else if diff > 1 then Doc.concat [ Doc.hardLine; Doc.hardLine ] - else if diff == 1 then Doc.hardLine - else Doc.space + let nextLoc = Comment.loc next in + let currLoc = Comment.loc comment in + let diff = + nextLoc.Location.loc_start.pos_lnum + - currLoc.Location.loc_end.pos_lnum + in + let nextSingleLine = Comment.isSingleLineComment next in + if singleLine && nextSingleLine then + if diff > 1 then Doc.hardLine else Doc.nil + else if singleLine && not nextSingleLine then + if diff > 1 then Doc.hardLine else Doc.nil + else if diff > 1 then Doc.concat [Doc.hardLine; Doc.hardLine] + else if diff == 1 then Doc.hardLine + else Doc.space | None -> Doc.nil); ] in - Doc.concat [ content; separator ] + Doc.concat [content; separator] (* This function is used for printing comments inside an empty block *) let printCommentsInside cmtTbl loc = @@ -53344,98 +53357,96 @@ let printCommentsInside cmtTbl loc = let rec loop acc comments = match comments with | [] -> Doc.nil - | [ comment ] -> - let cmtDoc = printComment comment in - let cmtsDoc = Doc.concat (Doc.softLine :: List.rev (cmtDoc :: acc)) in - let doc = - Doc.breakableGroup ~forceBreak - (Doc.concat - [ Doc.ifBreaks (Doc.indent cmtsDoc) cmtsDoc; Doc.softLine ]) - in - doc + | [comment] -> + let cmtDoc = printComment comment in + let cmtsDoc = Doc.concat (Doc.softLine :: List.rev (cmtDoc :: acc)) in + let doc = + Doc.breakableGroup ~forceBreak + (Doc.concat [Doc.ifBreaks (Doc.indent cmtsDoc) cmtsDoc; Doc.softLine]) + in + doc | comment :: rest -> - let cmtDoc = Doc.concat [ printComment comment; Doc.line ] in - loop (cmtDoc :: acc) rest + let cmtDoc = Doc.concat [printComment comment; Doc.line] in + loop (cmtDoc :: acc) rest in match Hashtbl.find cmtTbl.CommentTable.inside loc with | exception Not_found -> Doc.nil | comments -> - Hashtbl.remove cmtTbl.inside loc; - loop [] comments + Hashtbl.remove cmtTbl.inside loc; + loop [] comments (* This function is used for printing comments inside an empty file *) let printCommentsInsideFile cmtTbl = let rec loop acc comments = match comments with | [] -> Doc.nil - | [ comment ] -> - let cmtDoc = printLeadingComment comment in - let doc = - Doc.group (Doc.concat [ Doc.concat (List.rev (cmtDoc :: acc)) ]) - in - doc + | [comment] -> + let cmtDoc = printLeadingComment comment in + let doc = + Doc.group (Doc.concat [Doc.concat (List.rev (cmtDoc :: acc))]) + in + doc | comment :: (nextComment :: _comments as rest) -> - let cmtDoc = printLeadingComment ~nextComment comment in - loop (cmtDoc :: acc) rest + let cmtDoc = printLeadingComment ~nextComment comment in + loop (cmtDoc :: acc) rest in match Hashtbl.find cmtTbl.CommentTable.inside Location.none with | exception Not_found -> Doc.nil | comments -> - Hashtbl.remove cmtTbl.inside Location.none; - Doc.group (loop [] comments) + Hashtbl.remove cmtTbl.inside Location.none; + Doc.group (loop [] comments) let printLeadingComments node tbl loc = let rec loop acc comments = match comments with | [] -> node - | [ comment ] -> - let cmtDoc = printLeadingComment comment in - let diff = - loc.Location.loc_start.pos_lnum - - (Comment.loc comment).Location.loc_end.pos_lnum - in - let separator = - if Comment.isSingleLineComment comment then - if diff > 1 then Doc.hardLine else Doc.nil - else if diff == 0 then Doc.space - else if diff > 1 then Doc.concat [ Doc.hardLine; Doc.hardLine ] - else Doc.hardLine - in - let doc = - Doc.group - (Doc.concat - [ Doc.concat (List.rev (cmtDoc :: acc)); separator; node ]) - in - doc + | [comment] -> + let cmtDoc = printLeadingComment comment in + let diff = + loc.Location.loc_start.pos_lnum + - (Comment.loc comment).Location.loc_end.pos_lnum + in + let separator = + if Comment.isSingleLineComment comment then + if diff > 1 then Doc.hardLine else Doc.nil + else if diff == 0 then Doc.space + else if diff > 1 then Doc.concat [Doc.hardLine; Doc.hardLine] + else Doc.hardLine + in + let doc = + Doc.group + (Doc.concat [Doc.concat (List.rev (cmtDoc :: acc)); separator; node]) + in + doc | comment :: (nextComment :: _comments as rest) -> - let cmtDoc = printLeadingComment ~nextComment comment in - loop (cmtDoc :: acc) rest + let cmtDoc = printLeadingComment ~nextComment comment in + loop (cmtDoc :: acc) rest in match Hashtbl.find tbl loc with | exception Not_found -> node | comments -> - (* Remove comments from tbl: Some ast nodes have the same location. - * We only want to print comments once *) - Hashtbl.remove tbl loc; - loop [] comments + (* Remove comments from tbl: Some ast nodes have the same location. + * We only want to print comments once *) + Hashtbl.remove tbl loc; + loop [] comments let printTrailingComments node tbl loc = let rec loop prev acc comments = match comments with | [] -> Doc.concat (List.rev acc) | comment :: comments -> - let cmtDoc = printTrailingComment prev loc comment in - loop (Comment.loc comment) (cmtDoc :: acc) comments + let cmtDoc = printTrailingComment prev loc comment in + loop (Comment.loc comment) (cmtDoc :: acc) comments in match Hashtbl.find tbl loc with | exception Not_found -> node | [] -> node | _first :: _ as comments -> - (* Remove comments from tbl: Some ast nodes have the same location. - * We only want to print comments once *) - Hashtbl.remove tbl loc; - let cmtsDoc = loop loc [] comments in - Doc.concat [ node; cmtsDoc ] + (* Remove comments from tbl: Some ast nodes have the same location. + * We only want to print comments once *) + Hashtbl.remove tbl loc; + let cmtsDoc = loop loc [] comments in + Doc.concat [node; cmtsDoc] let printComments doc (tbl : CommentTable.t) loc = let docWithLeadingComments = printLeadingComments doc tbl.leading loc in @@ -53446,68 +53457,68 @@ let printList ~getLoc ~nodes ~print ?(forceBreak = false) t = match nodes with | [] -> (prevLoc, Doc.concat (List.rev acc)) | node :: nodes -> - let loc = getLoc node in - let startPos = - match getFirstLeadingComment t loc with - | None -> loc.loc_start - | Some comment -> (Comment.loc comment).loc_start - in - let sep = - if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then - Doc.concat [ Doc.hardLine; Doc.hardLine ] - else Doc.hardLine - in - let doc = printComments (print node t) t loc in - loop loc (doc :: sep :: acc) nodes + let loc = getLoc node in + let startPos = + match getFirstLeadingComment t loc with + | None -> loc.loc_start + | Some comment -> (Comment.loc comment).loc_start + in + let sep = + if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then + Doc.concat [Doc.hardLine; Doc.hardLine] + else Doc.hardLine + in + let doc = printComments (print node t) t loc in + loop loc (doc :: sep :: acc) nodes in match nodes with | [] -> Doc.nil | node :: nodes -> - let firstLoc = getLoc node in - let doc = printComments (print node t) t firstLoc in - let lastLoc, docs = loop firstLoc [ doc ] nodes in - let forceBreak = - forceBreak || firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak docs + let firstLoc = getLoc node in + let doc = printComments (print node t) t firstLoc in + let lastLoc, docs = loop firstLoc [doc] nodes in + let forceBreak = + forceBreak || firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak docs let printListi ~getLoc ~nodes ~print ?(forceBreak = false) t = let rec loop i (prevLoc : Location.t) acc nodes = match nodes with | [] -> (prevLoc, Doc.concat (List.rev acc)) | node :: nodes -> - let loc = getLoc node in - let startPos = - match getFirstLeadingComment t loc with - | None -> loc.loc_start - | Some comment -> (Comment.loc comment).loc_start - in - let sep = - if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then - Doc.concat [ Doc.hardLine; Doc.hardLine ] - else Doc.line - in - let doc = printComments (print node t i) t loc in - loop (i + 1) loc (doc :: sep :: acc) nodes + let loc = getLoc node in + let startPos = + match getFirstLeadingComment t loc with + | None -> loc.loc_start + | Some comment -> (Comment.loc comment).loc_start + in + let sep = + if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then + Doc.concat [Doc.hardLine; Doc.hardLine] + else Doc.line + in + let doc = printComments (print node t i) t loc in + loop (i + 1) loc (doc :: sep :: acc) nodes in match nodes with | [] -> Doc.nil | node :: nodes -> - let firstLoc = getLoc node in - let doc = printComments (print node t 0) t firstLoc in - let lastLoc, docs = loop 1 firstLoc [ doc ] nodes in - let forceBreak = - forceBreak || firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak docs + let firstLoc = getLoc node in + let doc = printComments (print node t 0) t firstLoc in + let lastLoc, docs = loop 1 firstLoc [doc] nodes in + let forceBreak = + forceBreak || firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak docs let rec printLongidentAux accu = function | Longident.Lident s -> Doc.text s :: accu | Ldot (lid, s) -> printLongidentAux (Doc.text s :: accu) lid | Lapply (lid1, lid2) -> - let d1 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid1) in - let d2 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid2) in - Doc.concat [ d1; Doc.lparen; d2; Doc.rparen ] :: accu + let d1 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid1) in + let d2 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid2) in + Doc.concat [d1; Doc.lparen; d2; Doc.rparen] :: accu let printLongident = function | Longident.Lident txt -> Doc.text txt @@ -53535,7 +53546,7 @@ let classifyIdentContent ?(allowUident = false) txt = let printIdentLike ?allowUident txt = match classifyIdentContent ?allowUident txt with - | ExoticIdent -> Doc.concat [ Doc.text "\\\""; Doc.text txt; Doc.text "\"" ] + | ExoticIdent -> Doc.concat [Doc.text "\\\""; Doc.text txt; Doc.text "\""] | NormalIdent -> Doc.text txt let rec unsafe_for_all_range s ~start ~finish p = @@ -53556,7 +53567,10 @@ let isValidNumericPolyvarNumber (x : string) = a <= 57 && if len > 1 then - a > 48 && for_all_from x 1 (function '0' .. '9' -> true | _ -> false) + a > 48 + && for_all_from x 1 (function + | '0' .. '9' -> true + | _ -> false) else a >= 48 (* Exotic identifiers in poly-vars have a "lighter" syntax: #"ease-in" *) @@ -53565,11 +53579,11 @@ let printPolyVarIdent txt = if isValidNumericPolyvarNumber txt then Doc.text txt else match classifyIdentContent ~allowUident:true txt with - | ExoticIdent -> Doc.concat [ Doc.text "\""; Doc.text txt; Doc.text "\"" ] + | ExoticIdent -> Doc.concat [Doc.text "\""; Doc.text txt; Doc.text "\""] | NormalIdent -> ( - match txt with - | "" -> Doc.concat [ Doc.text "\""; Doc.text txt; Doc.text "\"" ] - | _ -> Doc.text txt) + match txt with + | "" -> Doc.concat [Doc.text "\""; Doc.text txt; Doc.text "\""] + | _ -> Doc.text txt) let printLident l = let flatLidOpt lid = @@ -53583,18 +53597,18 @@ let printLident l = match l with | Longident.Lident txt -> printIdentLike txt | Longident.Ldot (path, txt) -> - let doc = - match flatLidOpt path with - | Some txts -> - Doc.concat - [ - Doc.join ~sep:Doc.dot (List.map Doc.text txts); - Doc.dot; - printIdentLike txt; - ] - | None -> Doc.text "printLident: Longident.Lapply is not supported" - in - doc + let doc = + match flatLidOpt path with + | Some txts -> + Doc.concat + [ + Doc.join ~sep:Doc.dot (List.map Doc.text txts); + Doc.dot; + printIdentLike txt; + ] + | None -> Doc.text "printLident: Longident.Lapply is not supported" + in + doc | Lapply (_, _) -> Doc.text "printLident: Longident.Lapply is not supported" let printLongidentLocation l cmtTbl = @@ -53622,42 +53636,42 @@ let printStringContents txt = let printConstant ?(templateLiteral = false) c = match c with | Parsetree.Pconst_integer (s, suffix) -> ( - match suffix with - | Some c -> Doc.text (s ^ Char.escaped c) - | None -> Doc.text s) + match suffix with + | Some c -> Doc.text (s ^ Char.escaped c) + | None -> Doc.text s) | Pconst_string (txt, None) -> - Doc.concat [ Doc.text "\""; printStringContents txt; Doc.text "\"" ] + Doc.concat [Doc.text "\""; printStringContents txt; Doc.text "\""] | Pconst_string (txt, Some prefix) -> - if prefix = "INTERNAL_RES_CHAR_CONTENTS" then - Doc.concat [ Doc.text "'"; Doc.text txt; Doc.text "'" ] - else - let lquote, rquote = - if templateLiteral then ("`", "`") else ("\"", "\"") - in - Doc.concat - [ - (if prefix = "js" then Doc.nil else Doc.text prefix); - Doc.text lquote; - printStringContents txt; - Doc.text rquote; - ] + if prefix = "INTERNAL_RES_CHAR_CONTENTS" then + Doc.concat [Doc.text "'"; Doc.text txt; Doc.text "'"] + else + let lquote, rquote = + if templateLiteral then ("`", "`") else ("\"", "\"") + in + Doc.concat + [ + (if prefix = "js" then Doc.nil else Doc.text prefix); + Doc.text lquote; + printStringContents txt; + Doc.text rquote; + ] | Pconst_float (s, _) -> Doc.text s | Pconst_char c -> - let str = - match Char.unsafe_chr c with - | '\'' -> "\\'" - | '\\' -> "\\\\" - | '\n' -> "\\n" - | '\t' -> "\\t" - | '\r' -> "\\r" - | '\b' -> "\\b" - | ' ' .. '~' as c -> - let s = (Bytes.create [@doesNotRaise]) 1 in - Bytes.unsafe_set s 0 c; - Bytes.unsafe_to_string s - | _ -> Res_utf8.encodeCodePoint c - in - Doc.text ("'" ^ str ^ "'") + let str = + match Char.unsafe_chr c with + | '\'' -> "\\'" + | '\\' -> "\\\\" + | '\n' -> "\\n" + | '\t' -> "\\t" + | '\r' -> "\\r" + | '\b' -> "\\b" + | ' ' .. '~' as c -> + let s = (Bytes.create [@doesNotRaise]) 1 in + Bytes.unsafe_set s 0 c; + Bytes.unsafe_to_string s + | _ -> Res_utf8.encodeCodePoint c + in + Doc.text ("'" ^ str ^ "'") let printOptionalLabel attrs = if Res_parsetree_viewer.hasOptionalAttribute attrs then Doc.text "?" @@ -53669,66 +53683,66 @@ let rec printStructure ~customLayout (s : Parsetree.structure) t = match s with | [] -> printCommentsInsideFile t | structure -> - printList - ~getLoc:(fun s -> s.Parsetree.pstr_loc) - ~nodes:structure - ~print:(printStructureItem ~customLayout) - t + printList + ~getLoc:(fun s -> s.Parsetree.pstr_loc) + ~nodes:structure + ~print:(printStructureItem ~customLayout) + t and printStructureItem ~customLayout (si : Parsetree.structure_item) cmtTbl = match si.pstr_desc with | Pstr_value (rec_flag, valueBindings) -> - let recFlag = - match rec_flag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - printValueBindings ~customLayout ~recFlag valueBindings cmtTbl + let recFlag = + match rec_flag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + printValueBindings ~customLayout ~recFlag valueBindings cmtTbl | Pstr_type (recFlag, typeDeclarations) -> - let recFlag = - match recFlag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - printTypeDeclarations ~customLayout ~recFlag typeDeclarations cmtTbl + let recFlag = + match recFlag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + printTypeDeclarations ~customLayout ~recFlag typeDeclarations cmtTbl | Pstr_primitive valueDescription -> - printValueDescription ~customLayout valueDescription cmtTbl + printValueDescription ~customLayout valueDescription cmtTbl | Pstr_eval (expr, attrs) -> - let exprDoc = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.structureExpr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat [ printAttributes ~customLayout attrs cmtTbl; exprDoc ] + let exprDoc = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.structureExpr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [printAttributes ~customLayout attrs cmtTbl; exprDoc] | Pstr_attribute attr -> - fst (printAttribute ~customLayout ~standalone:true attr cmtTbl) + fst (printAttribute ~customLayout ~standalone:true attr cmtTbl) | Pstr_extension (extension, attrs) -> - Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - Doc.concat - [ printExtension ~customLayout ~atModuleLvl:true extension cmtTbl ]; - ] + Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + Doc.concat + [printExtension ~customLayout ~atModuleLvl:true extension cmtTbl]; + ] | Pstr_include includeDeclaration -> - printIncludeDeclaration ~customLayout includeDeclaration cmtTbl + printIncludeDeclaration ~customLayout includeDeclaration cmtTbl | Pstr_open openDescription -> - printOpenDescription ~customLayout openDescription cmtTbl + printOpenDescription ~customLayout openDescription cmtTbl | Pstr_modtype modTypeDecl -> - printModuleTypeDeclaration ~customLayout modTypeDecl cmtTbl + printModuleTypeDeclaration ~customLayout modTypeDecl cmtTbl | Pstr_module moduleBinding -> - printModuleBinding ~customLayout ~isRec:false moduleBinding cmtTbl 0 + printModuleBinding ~customLayout ~isRec:false moduleBinding cmtTbl 0 | Pstr_recmodule moduleBindings -> - printListi - ~getLoc:(fun mb -> mb.Parsetree.pmb_loc) - ~nodes:moduleBindings - ~print:(printModuleBinding ~customLayout ~isRec:true) - cmtTbl + printListi + ~getLoc:(fun mb -> mb.Parsetree.pmb_loc) + ~nodes:moduleBindings + ~print:(printModuleBinding ~customLayout ~isRec:true) + cmtTbl | Pstr_exception extensionConstructor -> - printExceptionDef ~customLayout extensionConstructor cmtTbl + printExceptionDef ~customLayout extensionConstructor cmtTbl | Pstr_typext typeExtension -> - printTypeExtension ~customLayout typeExtension cmtTbl + printTypeExtension ~customLayout typeExtension cmtTbl | Pstr_class _ | Pstr_class_type _ -> Doc.nil and printTypeExtension ~customLayout (te : Parsetree.type_extension) cmtTbl = @@ -53740,14 +53754,13 @@ and printTypeExtension ~customLayout (te : Parsetree.type_extension) cmtTbl = let forceBreak = match (ecs, List.rev ecs) with | first :: _, last :: _ -> - first.pext_loc.loc_start.pos_lnum - > te.ptyext_path.loc.loc_end.pos_lnum - || first.pext_loc.loc_start.pos_lnum < last.pext_loc.loc_end.pos_lnum + first.pext_loc.loc_start.pos_lnum > te.ptyext_path.loc.loc_end.pos_lnum + || first.pext_loc.loc_start.pos_lnum < last.pext_loc.loc_end.pos_lnum | _ -> false in let privateFlag = match te.ptyext_private with - | Asttypes.Private -> Doc.concat [ Doc.text "private"; Doc.line ] + | Asttypes.Private -> Doc.concat [Doc.text "private"; Doc.line] | Public -> Doc.nil in let rows = @@ -53784,15 +53797,14 @@ and printModuleBinding ~customLayout ~isRec moduleBinding cmtTbl i = let prefix = if i = 0 then Doc.concat - [ Doc.text "module "; (if isRec then Doc.text "rec " else Doc.nil) ] + [Doc.text "module "; (if isRec then Doc.text "rec " else Doc.nil)] else Doc.text "and " in let modExprDoc, modConstraintDoc = match moduleBinding.pmb_expr with - | { pmod_desc = Pmod_constraint (modExpr, modType) } -> - ( printModExpr ~customLayout modExpr cmtTbl, - Doc.concat - [ Doc.text ": "; printModType ~customLayout modType cmtTbl ] ) + | {pmod_desc = Pmod_constraint (modExpr, modType)} -> + ( printModExpr ~customLayout modExpr cmtTbl, + Doc.concat [Doc.text ": "; printModType ~customLayout modType cmtTbl] ) | modExpr -> (printModExpr ~customLayout modExpr cmtTbl, Doc.nil) in let modName = @@ -53827,160 +53839,153 @@ and printModuleTypeDeclaration ~customLayout (match modTypeDecl.pmtd_type with | None -> Doc.nil | Some modType -> - Doc.concat - [ Doc.text " = "; printModType ~customLayout modType cmtTbl ]); + Doc.concat [Doc.text " = "; printModType ~customLayout modType cmtTbl]); ] and printModType ~customLayout modType cmtTbl = let modTypeDoc = match modType.pmty_desc with | Parsetree.Pmty_ident longident -> - Doc.concat - [ - printAttributes ~customLayout ~loc:longident.loc - modType.pmty_attributes cmtTbl; - printLongidentLocation longident cmtTbl; - ] + Doc.concat + [ + printAttributes ~customLayout ~loc:longident.loc + modType.pmty_attributes cmtTbl; + printLongidentLocation longident cmtTbl; + ] | Pmty_signature [] -> - if hasCommentsInside cmtTbl modType.pmty_loc then - let doc = printCommentsInside cmtTbl modType.pmty_loc in - Doc.concat [ Doc.lbrace; doc; Doc.rbrace ] - else - let shouldBreak = - modType.pmty_loc.loc_start.pos_lnum - < modType.pmty_loc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak:shouldBreak - (Doc.concat [ Doc.lbrace; Doc.softLine; Doc.softLine; Doc.rbrace ]) + if hasCommentsInside cmtTbl modType.pmty_loc then + let doc = printCommentsInside cmtTbl modType.pmty_loc in + Doc.concat [Doc.lbrace; doc; Doc.rbrace] + else + let shouldBreak = + modType.pmty_loc.loc_start.pos_lnum + < modType.pmty_loc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak:shouldBreak + (Doc.concat [Doc.lbrace; Doc.softLine; Doc.softLine; Doc.rbrace]) | Pmty_signature signature -> - let signatureDoc = - Doc.breakableGroup ~forceBreak:true + let signatureDoc = + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [Doc.line; printSignature ~customLayout signature cmtTbl]); + Doc.line; + Doc.rbrace; + ]) + in + Doc.concat + [ + printAttributes ~customLayout modType.pmty_attributes cmtTbl; + signatureDoc; + ] + | Pmty_functor _ -> + let parameters, returnType = ParsetreeViewer.functorType modType in + let parametersDoc = + match parameters with + | [] -> Doc.nil + | [(attrs, {Location.txt = "_"; loc}, Some modType)] -> + let cmtLoc = + {loc with loc_end = modType.Parsetree.pmty_loc.loc_end} + in + let attrs = printAttributes ~customLayout attrs cmtTbl in + let doc = + Doc.concat [attrs; printModType ~customLayout modType cmtTbl] + in + printComments doc cmtTbl cmtLoc + | params -> + Doc.group (Doc.concat [ - Doc.lbrace; + Doc.lparen; Doc.indent (Doc.concat [ - Doc.line; printSignature ~customLayout signature cmtTbl; + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun (attrs, lbl, modType) -> + let cmtLoc = + match modType with + | None -> lbl.Asttypes.loc + | Some modType -> + { + lbl.Asttypes.loc with + loc_end = + modType.Parsetree.pmty_loc.loc_end; + } + in + let attrs = + printAttributes ~customLayout attrs cmtTbl + in + let lblDoc = + if lbl.Location.txt = "_" || lbl.txt = "*" then + Doc.nil + else + let doc = Doc.text lbl.txt in + printComments doc cmtTbl lbl.loc + in + let doc = + Doc.concat + [ + attrs; + lblDoc; + (match modType with + | None -> Doc.nil + | Some modType -> + Doc.concat + [ + (if lbl.txt = "_" then Doc.nil + else Doc.text ": "); + printModType ~customLayout modType + cmtTbl; + ]); + ] + in + printComments doc cmtTbl cmtLoc) + params); ]); - Doc.line; - Doc.rbrace; + Doc.trailingComma; + Doc.softLine; + Doc.rparen; ]) - in - Doc.concat - [ - printAttributes ~customLayout modType.pmty_attributes cmtTbl; - signatureDoc; - ] - | Pmty_functor _ -> - let parameters, returnType = ParsetreeViewer.functorType modType in - let parametersDoc = - match parameters with - | [] -> Doc.nil - | [ (attrs, { Location.txt = "_"; loc }, Some modType) ] -> - let cmtLoc = - { loc with loc_end = modType.Parsetree.pmty_loc.loc_end } - in - let attrs = printAttributes ~customLayout attrs cmtTbl in - let doc = - Doc.concat [ attrs; printModType ~customLayout modType cmtTbl ] - in - printComments doc cmtTbl cmtLoc - | params -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun (attrs, lbl, modType) -> - let cmtLoc = - match modType with - | None -> lbl.Asttypes.loc - | Some modType -> - { - lbl.Asttypes.loc with - loc_end = - modType.Parsetree.pmty_loc.loc_end; - } - in - let attrs = - printAttributes ~customLayout attrs cmtTbl - in - let lblDoc = - if lbl.Location.txt = "_" || lbl.txt = "*" - then Doc.nil - else - let doc = Doc.text lbl.txt in - printComments doc cmtTbl lbl.loc - in - let doc = - Doc.concat - [ - attrs; - lblDoc; - (match modType with - | None -> Doc.nil - | Some modType -> - Doc.concat - [ - (if lbl.txt = "_" then Doc.nil - else Doc.text ": "); - printModType ~customLayout - modType cmtTbl; - ]); - ] - in - printComments doc cmtTbl cmtLoc) - params); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) - in - let returnDoc = - let doc = printModType ~customLayout returnType cmtTbl in - if Parens.modTypeFunctorReturn returnType then addParens doc else doc - in - Doc.group - (Doc.concat - [ - parametersDoc; - Doc.group (Doc.concat [ Doc.text " =>"; Doc.line; returnDoc ]); - ]) + in + let returnDoc = + let doc = printModType ~customLayout returnType cmtTbl in + if Parens.modTypeFunctorReturn returnType then addParens doc else doc + in + Doc.group + (Doc.concat + [ + parametersDoc; + Doc.group (Doc.concat [Doc.text " =>"; Doc.line; returnDoc]); + ]) | Pmty_typeof modExpr -> - Doc.concat - [ - Doc.text "module type of "; - printModExpr ~customLayout modExpr cmtTbl; - ] + Doc.concat + [Doc.text "module type of "; printModExpr ~customLayout modExpr cmtTbl] | Pmty_extension extension -> - printExtension ~customLayout ~atModuleLvl:false extension cmtTbl + printExtension ~customLayout ~atModuleLvl:false extension cmtTbl | Pmty_alias longident -> - Doc.concat - [ Doc.text "module "; printLongidentLocation longident cmtTbl ] + Doc.concat [Doc.text "module "; printLongidentLocation longident cmtTbl] | Pmty_with (modType, withConstraints) -> - let operand = - let doc = printModType ~customLayout modType cmtTbl in - if Parens.modTypeWithOperand modType then addParens doc else doc - in - Doc.group - (Doc.concat - [ - operand; - Doc.indent - (Doc.concat - [ - Doc.line; - printWithConstraints ~customLayout withConstraints cmtTbl; - ]); - ]) + let operand = + let doc = printModType ~customLayout modType cmtTbl in + if Parens.modTypeWithOperand modType then addParens doc else doc + in + Doc.group + (Doc.concat + [ + operand; + Doc.indent + (Doc.concat + [ + Doc.line; + printWithConstraints ~customLayout withConstraints cmtTbl; + ]); + ]) in let attrsAlreadyPrinted = match modType.pmty_desc with @@ -54016,78 +54021,78 @@ and printWithConstraint ~customLayout match withConstraint with (* with type X.t = ... *) | Pwith_type (longident, typeDeclaration) -> - Doc.group - (printTypeDeclaration ~customLayout - ~name:(printLidentPath longident cmtTbl) - ~equalSign:"=" ~recFlag:Doc.nil 0 typeDeclaration CommentTable.empty) + Doc.group + (printTypeDeclaration ~customLayout + ~name:(printLidentPath longident cmtTbl) + ~equalSign:"=" ~recFlag:Doc.nil 0 typeDeclaration CommentTable.empty) (* with module X.Y = Z *) - | Pwith_module ({ txt = longident1 }, { txt = longident2 }) -> - Doc.concat - [ - Doc.text "module "; - printLongident longident1; - Doc.text " ="; - Doc.indent (Doc.concat [ Doc.line; printLongident longident2 ]); - ] + | Pwith_module ({txt = longident1}, {txt = longident2}) -> + Doc.concat + [ + Doc.text "module "; + printLongident longident1; + Doc.text " ="; + Doc.indent (Doc.concat [Doc.line; printLongident longident2]); + ] (* with type X.t := ..., same format as [Pwith_type] *) | Pwith_typesubst (longident, typeDeclaration) -> - Doc.group - (printTypeDeclaration ~customLayout - ~name:(printLidentPath longident cmtTbl) - ~equalSign:":=" ~recFlag:Doc.nil 0 typeDeclaration CommentTable.empty) - | Pwith_modsubst ({ txt = longident1 }, { txt = longident2 }) -> - Doc.concat - [ - Doc.text "module "; - printLongident longident1; - Doc.text " :="; - Doc.indent (Doc.concat [ Doc.line; printLongident longident2 ]); - ] + Doc.group + (printTypeDeclaration ~customLayout + ~name:(printLidentPath longident cmtTbl) + ~equalSign:":=" ~recFlag:Doc.nil 0 typeDeclaration CommentTable.empty) + | Pwith_modsubst ({txt = longident1}, {txt = longident2}) -> + Doc.concat + [ + Doc.text "module "; + printLongident longident1; + Doc.text " :="; + Doc.indent (Doc.concat [Doc.line; printLongident longident2]); + ] and printSignature ~customLayout signature cmtTbl = match signature with | [] -> printCommentsInsideFile cmtTbl | signature -> - printList - ~getLoc:(fun s -> s.Parsetree.psig_loc) - ~nodes:signature - ~print:(printSignatureItem ~customLayout) - cmtTbl + printList + ~getLoc:(fun s -> s.Parsetree.psig_loc) + ~nodes:signature + ~print:(printSignatureItem ~customLayout) + cmtTbl and printSignatureItem ~customLayout (si : Parsetree.signature_item) cmtTbl = match si.psig_desc with | Parsetree.Psig_value valueDescription -> - printValueDescription ~customLayout valueDescription cmtTbl + printValueDescription ~customLayout valueDescription cmtTbl | Psig_type (recFlag, typeDeclarations) -> - let recFlag = - match recFlag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - printTypeDeclarations ~customLayout ~recFlag typeDeclarations cmtTbl + let recFlag = + match recFlag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + printTypeDeclarations ~customLayout ~recFlag typeDeclarations cmtTbl | Psig_typext typeExtension -> - printTypeExtension ~customLayout typeExtension cmtTbl + printTypeExtension ~customLayout typeExtension cmtTbl | Psig_exception extensionConstructor -> - printExceptionDef ~customLayout extensionConstructor cmtTbl + printExceptionDef ~customLayout extensionConstructor cmtTbl | Psig_module moduleDeclaration -> - printModuleDeclaration ~customLayout moduleDeclaration cmtTbl + printModuleDeclaration ~customLayout moduleDeclaration cmtTbl | Psig_recmodule moduleDeclarations -> - printRecModuleDeclarations ~customLayout moduleDeclarations cmtTbl + printRecModuleDeclarations ~customLayout moduleDeclarations cmtTbl | Psig_modtype modTypeDecl -> - printModuleTypeDeclaration ~customLayout modTypeDecl cmtTbl + printModuleTypeDeclaration ~customLayout modTypeDecl cmtTbl | Psig_open openDescription -> - printOpenDescription ~customLayout openDescription cmtTbl + printOpenDescription ~customLayout openDescription cmtTbl | Psig_include includeDescription -> - printIncludeDescription ~customLayout includeDescription cmtTbl + printIncludeDescription ~customLayout includeDescription cmtTbl | Psig_attribute attr -> - fst (printAttribute ~customLayout ~standalone:true attr cmtTbl) + fst (printAttribute ~customLayout ~standalone:true attr cmtTbl) | Psig_extension (extension, attrs) -> - Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - Doc.concat - [ printExtension ~customLayout ~atModuleLvl:true extension cmtTbl ]; - ] + Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + Doc.concat + [printExtension ~customLayout ~atModuleLvl:true extension cmtTbl]; + ] | Psig_class _ | Psig_class_type _ -> Doc.nil and printRecModuleDeclarations ~customLayout moduleDeclarations cmtTbl = @@ -54101,22 +54106,23 @@ and printRecModuleDeclaration ~customLayout md cmtTbl i = let body = match md.pmd_type.pmty_desc with | Parsetree.Pmty_alias longident -> - Doc.concat [ Doc.text " = "; printLongidentLocation longident cmtTbl ] + Doc.concat [Doc.text " = "; printLongidentLocation longident cmtTbl] | _ -> - let needsParens = - match md.pmd_type.pmty_desc with Pmty_with _ -> true | _ -> false - in - let modTypeDoc = - let doc = printModType ~customLayout md.pmd_type cmtTbl in - if needsParens then addParens doc else doc - in - Doc.concat [ Doc.text ": "; modTypeDoc ] + let needsParens = + match md.pmd_type.pmty_desc with + | Pmty_with _ -> true + | _ -> false + in + let modTypeDoc = + let doc = printModType ~customLayout md.pmd_type cmtTbl in + if needsParens then addParens doc else doc + in + Doc.concat [Doc.text ": "; modTypeDoc] in let prefix = if i < 1 then "module rec " else "and " in Doc.concat [ - printAttributes ~customLayout ~loc:md.pmd_name.loc md.pmd_attributes - cmtTbl; + printAttributes ~customLayout ~loc:md.pmd_name.loc md.pmd_attributes cmtTbl; Doc.text prefix; printComments (Doc.text md.pmd_name.txt) cmtTbl md.pmd_name.loc; body; @@ -54127,15 +54133,13 @@ and printModuleDeclaration ~customLayout (md : Parsetree.module_declaration) let body = match md.pmd_type.pmty_desc with | Parsetree.Pmty_alias longident -> - Doc.concat [ Doc.text " = "; printLongidentLocation longident cmtTbl ] + Doc.concat [Doc.text " = "; printLongidentLocation longident cmtTbl] | _ -> - Doc.concat - [ Doc.text ": "; printModType ~customLayout md.pmd_type cmtTbl ] + Doc.concat [Doc.text ": "; printModType ~customLayout md.pmd_type cmtTbl] in Doc.concat [ - printAttributes ~customLayout ~loc:md.pmd_name.loc md.pmd_attributes - cmtTbl; + printAttributes ~customLayout ~loc:md.pmd_name.loc md.pmd_attributes cmtTbl; Doc.text "module "; printComments (Doc.text md.pmd_name.txt) cmtTbl md.pmd_name.loc; body; @@ -54186,7 +54190,9 @@ and printValueBindings ~customLayout ~recFlag and printValueDescription ~customLayout valueDescription cmtTbl = let isExternal = - match valueDescription.pval_prim with [] -> false | _ -> true + match valueDescription.pval_prim with + | [] -> false + | _ -> true in let attrs = printAttributes ~customLayout ~loc:valueDescription.pval_name.loc @@ -54216,7 +54222,7 @@ and printValueDescription ~customLayout valueDescription cmtTbl = (List.map (fun s -> Doc.concat - [ Doc.text "\""; Doc.text s; Doc.text "\"" ]) + [Doc.text "\""; Doc.text s; Doc.text "\""]) valueDescription.pval_prim); ]); ]) @@ -54268,72 +54274,72 @@ and printTypeDeclaration ~customLayout ~name ~equalSign ~recFlag i printAttributes ~customLayout ~loc:td.ptype_loc td.ptype_attributes cmtTbl in let prefix = - if i > 0 then Doc.text "and " else Doc.concat [ Doc.text "type "; recFlag ] + if i > 0 then Doc.text "and " else Doc.concat [Doc.text "type "; recFlag] in let typeName = name in let typeParams = printTypeParams ~customLayout td.ptype_params cmtTbl in let manifestAndKind = match td.ptype_kind with | Ptype_abstract -> ( - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; - printPrivateFlag td.ptype_private; - printTypExpr ~customLayout typ cmtTbl; - ]) - | Ptype_open -> + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> Doc.concat [ - Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; printPrivateFlag td.ptype_private; - Doc.text ".."; - ] + printTypExpr ~customLayout typ cmtTbl; + ]) + | Ptype_open -> + Doc.concat + [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printPrivateFlag td.ptype_private; + Doc.text ".."; + ] | Ptype_record lds -> - let manifest = - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; - printTypExpr ~customLayout typ cmtTbl; - ] - in - Doc.concat - [ - manifest; - Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; - printPrivateFlag td.ptype_private; - printRecordDeclaration ~customLayout lds cmtTbl; - ] + let manifest = + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> + Doc.concat + [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printTypExpr ~customLayout typ cmtTbl; + ] + in + Doc.concat + [ + manifest; + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printPrivateFlag td.ptype_private; + printRecordDeclaration ~customLayout lds cmtTbl; + ] | Ptype_variant cds -> - let manifest = - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; - printTypExpr ~customLayout typ cmtTbl; - ] - in - Doc.concat - [ - manifest; - Doc.concat [ Doc.space; Doc.text equalSign ]; - printConstructorDeclarations ~customLayout - ~privateFlag:td.ptype_private cds cmtTbl; - ] + let manifest = + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> + Doc.concat + [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printTypExpr ~customLayout typ cmtTbl; + ] + in + Doc.concat + [ + manifest; + Doc.concat [Doc.space; Doc.text equalSign]; + printConstructorDeclarations ~customLayout + ~privateFlag:td.ptype_private cds cmtTbl; + ] in let constraints = printTypeDefinitionConstraints ~customLayout td.ptype_cstrs in Doc.group (Doc.concat - [ attrs; prefix; typeName; typeParams; manifestAndKind; constraints ]) + [attrs; prefix; typeName; typeParams; manifestAndKind; constraints]) and printTypeDeclaration2 ~customLayout ~recFlag (td : Parsetree.type_declaration) cmtTbl i = @@ -54346,99 +54352,99 @@ and printTypeDeclaration2 ~customLayout ~recFlag printAttributes ~customLayout ~loc:td.ptype_loc td.ptype_attributes cmtTbl in let prefix = - if i > 0 then Doc.text "and " else Doc.concat [ Doc.text "type "; recFlag ] + if i > 0 then Doc.text "and " else Doc.concat [Doc.text "type "; recFlag] in let typeName = name in let typeParams = printTypeParams ~customLayout td.ptype_params cmtTbl in let manifestAndKind = match td.ptype_kind with | Ptype_abstract -> ( - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; - printPrivateFlag td.ptype_private; - printTypExpr ~customLayout typ cmtTbl; - ]) - | Ptype_open -> + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> Doc.concat [ - Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; printPrivateFlag td.ptype_private; - Doc.text ".."; - ] + printTypExpr ~customLayout typ cmtTbl; + ]) + | Ptype_open -> + Doc.concat + [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printPrivateFlag td.ptype_private; + Doc.text ".."; + ] | Ptype_record lds -> - if lds = [] then - Doc.concat - [ - Doc.space; - Doc.text equalSign; - Doc.space; - Doc.lbrace; - printCommentsInside cmtTbl td.ptype_loc; - Doc.rbrace; - ] - else - let manifest = - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; - printTypExpr ~customLayout typ cmtTbl; - ] - in - Doc.concat - [ - manifest; - Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; - printPrivateFlag td.ptype_private; - printRecordDeclaration ~customLayout lds cmtTbl; - ] - | Ptype_variant cds -> + if lds = [] then + Doc.concat + [ + Doc.space; + Doc.text equalSign; + Doc.space; + Doc.lbrace; + printCommentsInside cmtTbl td.ptype_loc; + Doc.rbrace; + ] + else let manifest = match td.ptype_manifest with | None -> Doc.nil | Some typ -> - Doc.concat - [ - Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; - printTypExpr ~customLayout typ cmtTbl; - ] + Doc.concat + [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printTypExpr ~customLayout typ cmtTbl; + ] in Doc.concat [ manifest; - Doc.concat [ Doc.space; Doc.text equalSign ]; - printConstructorDeclarations ~customLayout - ~privateFlag:td.ptype_private cds cmtTbl; + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printPrivateFlag td.ptype_private; + printRecordDeclaration ~customLayout lds cmtTbl; ] + | Ptype_variant cds -> + let manifest = + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> + Doc.concat + [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printTypExpr ~customLayout typ cmtTbl; + ] + in + Doc.concat + [ + manifest; + Doc.concat [Doc.space; Doc.text equalSign]; + printConstructorDeclarations ~customLayout + ~privateFlag:td.ptype_private cds cmtTbl; + ] in let constraints = printTypeDefinitionConstraints ~customLayout td.ptype_cstrs in Doc.group (Doc.concat - [ attrs; prefix; typeName; typeParams; manifestAndKind; constraints ]) + [attrs; prefix; typeName; typeParams; manifestAndKind; constraints]) and printTypeDefinitionConstraints ~customLayout cstrs = match cstrs with | [] -> Doc.nil | cstrs -> - Doc.indent - (Doc.group - (Doc.concat - [ - Doc.line; - Doc.group - (Doc.join ~sep:Doc.line - (List.map - (printTypeDefinitionConstraint ~customLayout) - cstrs)); - ])) + Doc.indent + (Doc.group + (Doc.concat + [ + Doc.line; + Doc.group + (Doc.join ~sep:Doc.line + (List.map + (printTypeDefinitionConstraint ~customLayout) + cstrs)); + ])) and printTypeDefinitionConstraint ~customLayout ((typ1, typ2, _loc) : @@ -54452,35 +54458,37 @@ and printTypeDefinitionConstraint ~customLayout ] and printPrivateFlag (flag : Asttypes.private_flag) = - match flag with Private -> Doc.text "private " | Public -> Doc.nil + match flag with + | Private -> Doc.text "private " + | Public -> Doc.nil and printTypeParams ~customLayout typeParams cmtTbl = match typeParams with | [] -> Doc.nil | typeParams -> - Doc.group - (Doc.concat - [ - Doc.lessThan; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun typeParam -> - let doc = - printTypeParam ~customLayout typeParam cmtTbl - in - printComments doc cmtTbl - (fst typeParam).Parsetree.ptyp_loc) - typeParams); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.greaterThan; - ]) + Doc.group + (Doc.concat + [ + Doc.lessThan; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun typeParam -> + let doc = + printTypeParam ~customLayout typeParam cmtTbl + in + printComments doc cmtTbl + (fst typeParam).Parsetree.ptyp_loc) + typeParams); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.greaterThan; + ]) and printTypeParam ~customLayout (param : Parsetree.core_type * Asttypes.variance) cmtTbl = @@ -54491,14 +54499,14 @@ and printTypeParam ~customLayout | Contravariant -> Doc.text "-" | Invariant -> Doc.nil in - Doc.concat [ printedVariance; printTypExpr ~customLayout typ cmtTbl ] + Doc.concat [printedVariance; printTypExpr ~customLayout typ cmtTbl] and printRecordDeclaration ~customLayout (lds : Parsetree.label_declaration list) cmtTbl = let forceBreak = match (lds, List.rev lds) with | first :: _, last :: _ -> - first.pld_loc.loc_start.pos_lnum < last.pld_loc.loc_end.pos_lnum + first.pld_loc.loc_start.pos_lnum < last.pld_loc.loc_end.pos_lnum | _ -> false in Doc.breakableGroup ~forceBreak @@ -54510,7 +54518,7 @@ and printRecordDeclaration ~customLayout [ Doc.softLine; Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map (fun ld -> let doc = @@ -54529,12 +54537,12 @@ and printConstructorDeclarations ~customLayout ~privateFlag let forceBreak = match (cds, List.rev cds) with | first :: _, last :: _ -> - first.pcd_loc.loc_start.pos_lnum < last.pcd_loc.loc_end.pos_lnum + first.pcd_loc.loc_start.pos_lnum < last.pcd_loc.loc_end.pos_lnum | _ -> false in let privateFlag = match privateFlag with - | Asttypes.Private -> Doc.concat [ Doc.text "private"; Doc.line ] + | Asttypes.Private -> Doc.concat [Doc.text "private"; Doc.line] | Public -> Doc.nil in let rows = @@ -54547,7 +54555,7 @@ and printConstructorDeclarations ~customLayout ~privateFlag ~forceBreak cmtTbl in Doc.breakableGroup ~forceBreak - (Doc.indent (Doc.concat [ Doc.line; privateFlag; rows ])) + (Doc.indent (Doc.concat [Doc.line; privateFlag; rows])) and printConstructorDeclaration2 ~customLayout i (cd : Parsetree.constructor_declaration) cmtTbl = @@ -54567,8 +54575,8 @@ and printConstructorDeclaration2 ~customLayout i match cd.pcd_res with | None -> Doc.nil | Some typ -> - Doc.indent - (Doc.concat [ Doc.text ": "; printTypExpr ~customLayout typ cmtTbl ]) + Doc.indent + (Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ cmtTbl]) in Doc.concat [ @@ -54589,55 +54597,54 @@ and printConstructorArguments ~customLayout ~indent match cdArgs with | Pcstr_tuple [] -> Doc.nil | Pcstr_tuple types -> - let args = - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun typexpr -> - printTypExpr ~customLayout typexpr cmtTbl) - types); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - in - Doc.group (if indent then Doc.indent args else args) + let args = + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun typexpr -> printTypExpr ~customLayout typexpr cmtTbl) + types); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + in + Doc.group (if indent then Doc.indent args else args) | Pcstr_record lds -> - let args = - Doc.concat - [ - Doc.lparen; - (* manually inline the printRecordDeclaration, gives better layout *) - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun ld -> - let doc = - printLabelDeclaration ~customLayout ld cmtTbl - in - printComments doc cmtTbl ld.Parsetree.pld_loc) - lds); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - Doc.rparen; - ] - in - if indent then Doc.indent args else args + let args = + Doc.concat + [ + Doc.lparen; + (* manually inline the printRecordDeclaration, gives better layout *) + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun ld -> + let doc = + printLabelDeclaration ~customLayout ld cmtTbl + in + printComments doc cmtTbl ld.Parsetree.pld_loc) + lds); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + Doc.rparen; + ] + in + if indent then Doc.indent args else args and printLabelDeclaration ~customLayout (ld : Parsetree.label_declaration) cmtTbl = @@ -54670,261 +54677,242 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = match typExpr.ptyp_desc with | Ptyp_any -> Doc.text "_" | Ptyp_var var -> - Doc.concat [ Doc.text "'"; printIdentLike ~allowUident:true var ] + Doc.concat [Doc.text "'"; printIdentLike ~allowUident:true var] | Ptyp_extension extension -> - printExtension ~customLayout ~atModuleLvl:false extension cmtTbl + printExtension ~customLayout ~atModuleLvl:false extension cmtTbl | Ptyp_alias (typ, alias) -> - let typ = - (* Technically type t = (string, float) => unit as 'x, doesn't require - * parens around the arrow expression. This is very confusing though. - * Is the "as" part of "unit" or "(string, float) => unit". By printing - * parens we guide the user towards its meaning.*) - let needsParens = - match typ.ptyp_desc with Ptyp_arrow _ -> true | _ -> false - in - let doc = printTypExpr ~customLayout typ cmtTbl in - if needsParens then Doc.concat [ Doc.lparen; doc; Doc.rparen ] - else doc + let typ = + (* Technically type t = (string, float) => unit as 'x, doesn't require + * parens around the arrow expression. This is very confusing though. + * Is the "as" part of "unit" or "(string, float) => unit". By printing + * parens we guide the user towards its meaning.*) + let needsParens = + match typ.ptyp_desc with + | Ptyp_arrow _ -> true + | _ -> false in - Doc.concat - [ - typ; - Doc.text " as "; - Doc.concat [ Doc.text "'"; printIdentLike alias ]; - ] + let doc = printTypExpr ~customLayout typ cmtTbl in + if needsParens then Doc.concat [Doc.lparen; doc; Doc.rparen] else doc + in + Doc.concat + [typ; Doc.text " as "; Doc.concat [Doc.text "'"; printIdentLike alias]] (* object printings *) | Ptyp_object (fields, openFlag) -> - printObject ~customLayout ~inline:false fields openFlag cmtTbl - | Ptyp_constr - (longidentLoc, [ { ptyp_desc = Ptyp_object (fields, openFlag) } ]) -> - (* for foo<{"a": b}>, when the object is long and needs a line break, we - want the <{ and }> to stay hugged together *) - let constrName = printLidentPath longidentLoc cmtTbl in - Doc.concat - [ - constrName; - Doc.lessThan; - printObject ~customLayout ~inline:true fields openFlag cmtTbl; - Doc.greaterThan; - ] - | Ptyp_constr (longidentLoc, [ { ptyp_desc = Parsetree.Ptyp_tuple tuple } ]) + printObject ~customLayout ~inline:false fields openFlag cmtTbl + | Ptyp_constr (longidentLoc, [{ptyp_desc = Ptyp_object (fields, openFlag)}]) -> - let constrName = printLidentPath longidentLoc cmtTbl in + (* for foo<{"a": b}>, when the object is long and needs a line break, we + want the <{ and }> to stay hugged together *) + let constrName = printLidentPath longidentLoc cmtTbl in + Doc.concat + [ + constrName; + Doc.lessThan; + printObject ~customLayout ~inline:true fields openFlag cmtTbl; + Doc.greaterThan; + ] + | Ptyp_constr (longidentLoc, [{ptyp_desc = Parsetree.Ptyp_tuple tuple}]) -> + let constrName = printLidentPath longidentLoc cmtTbl in + Doc.group + (Doc.concat + [ + constrName; + Doc.lessThan; + printTupleType ~customLayout ~inline:true tuple cmtTbl; + Doc.greaterThan; + ]) + | Ptyp_constr (longidentLoc, constrArgs) -> ( + let constrName = printLidentPath longidentLoc cmtTbl in + match constrArgs with + | [] -> constrName + | _args -> Doc.group (Doc.concat [ constrName; Doc.lessThan; - printTupleType ~customLayout ~inline:true tuple cmtTbl; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun typexpr -> + printTypExpr ~customLayout typexpr cmtTbl) + constrArgs); + ]); + Doc.trailingComma; + Doc.softLine; Doc.greaterThan; - ]) - | Ptyp_constr (longidentLoc, constrArgs) -> ( - let constrName = printLidentPath longidentLoc cmtTbl in - match constrArgs with - | [] -> constrName - | _args -> - Doc.group - (Doc.concat - [ - constrName; - Doc.lessThan; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun typexpr -> - printTypExpr ~customLayout typexpr cmtTbl) - constrArgs); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.greaterThan; - ])) + ])) | Ptyp_arrow _ -> ( - let attrsBefore, args, returnType = ParsetreeViewer.arrowType typExpr in - let returnTypeNeedsParens = - match returnType.ptyp_desc with Ptyp_alias _ -> true | _ -> false + let attrsBefore, args, returnType = ParsetreeViewer.arrowType typExpr in + let returnTypeNeedsParens = + match returnType.ptyp_desc with + | Ptyp_alias _ -> true + | _ -> false + in + let returnDoc = + let doc = printTypExpr ~customLayout returnType cmtTbl in + if returnTypeNeedsParens then Doc.concat [Doc.lparen; doc; Doc.rparen] + else doc + in + let isUncurried, attrs = + ParsetreeViewer.processUncurriedAttribute attrsBefore + in + match args with + | [] -> Doc.nil + | [([], Nolabel, n)] when not isUncurried -> + let hasAttrsBefore = not (attrs = []) in + let attrs = + if hasAttrsBefore then + printAttributes ~customLayout ~inline:true attrsBefore cmtTbl + else Doc.nil in - let returnDoc = - let doc = printTypExpr ~customLayout returnType cmtTbl in - if returnTypeNeedsParens then - Doc.concat [ Doc.lparen; doc; Doc.rparen ] - else doc + let typDoc = + let doc = printTypExpr ~customLayout n cmtTbl in + match n.ptyp_desc with + | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> addParens doc + | _ -> doc in - let isUncurried, attrs = - ParsetreeViewer.processUncurriedAttribute attrsBefore + Doc.group + (Doc.concat + [ + Doc.group attrs; + Doc.group + (if hasAttrsBefore then + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [Doc.softLine; typDoc; Doc.text " => "; returnDoc]); + Doc.softLine; + Doc.rparen; + ] + else Doc.concat [typDoc; Doc.text " => "; returnDoc]); + ]) + | args -> + let attrs = printAttributes ~customLayout ~inline:true attrs cmtTbl in + let renderedArgs = + Doc.concat + [ + attrs; + Doc.text "("; + Doc.indent + (Doc.concat + [ + Doc.softLine; + (if isUncurried then Doc.concat [Doc.dot; Doc.space] + else Doc.nil); + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun tp -> printTypeParameter ~customLayout tp cmtTbl) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.text ")"; + ] in - match args with - | [] -> Doc.nil - | [ ([], Nolabel, n) ] when not isUncurried -> - let hasAttrsBefore = not (attrs = []) in - let attrs = - if hasAttrsBefore then - printAttributes ~customLayout ~inline:true attrsBefore cmtTbl - else Doc.nil - in - let typDoc = - let doc = printTypExpr ~customLayout n cmtTbl in - match n.ptyp_desc with - | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> addParens doc - | _ -> doc - in - Doc.group - (Doc.concat - [ - Doc.group attrs; - Doc.group - (if hasAttrsBefore then - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - typDoc; - Doc.text " => "; - returnDoc; - ]); - Doc.softLine; - Doc.rparen; - ] - else Doc.concat [ typDoc; Doc.text " => "; returnDoc ]); - ]) - | args -> - let attrs = - printAttributes ~customLayout ~inline:true attrs cmtTbl - in - let renderedArgs = - Doc.concat - [ - attrs; - Doc.text "("; - Doc.indent - (Doc.concat - [ - Doc.softLine; - (if isUncurried then Doc.concat [ Doc.dot; Doc.space ] - else Doc.nil); - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun tp -> - printTypeParameter ~customLayout tp cmtTbl) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.text ")"; - ] - in - Doc.group (Doc.concat [ renderedArgs; Doc.text " => "; returnDoc ])) + Doc.group (Doc.concat [renderedArgs; Doc.text " => "; returnDoc])) | Ptyp_tuple types -> - printTupleType ~customLayout ~inline:false types cmtTbl + printTupleType ~customLayout ~inline:false types cmtTbl | Ptyp_poly ([], typ) -> printTypExpr ~customLayout typ cmtTbl | Ptyp_poly (stringLocs, typ) -> - Doc.concat - [ - Doc.join ~sep:Doc.space - (List.map - (fun { Location.txt; loc } -> - let doc = Doc.concat [ Doc.text "'"; Doc.text txt ] in - printComments doc cmtTbl loc) - stringLocs); - Doc.dot; - Doc.space; - printTypExpr ~customLayout typ cmtTbl; - ] + Doc.concat + [ + Doc.join ~sep:Doc.space + (List.map + (fun {Location.txt; loc} -> + let doc = Doc.concat [Doc.text "'"; Doc.text txt] in + printComments doc cmtTbl loc) + stringLocs); + Doc.dot; + Doc.space; + printTypExpr ~customLayout typ cmtTbl; + ] | Ptyp_package packageType -> - printPackageType ~customLayout ~printModuleKeywordAndParens:true - packageType cmtTbl + printPackageType ~customLayout ~printModuleKeywordAndParens:true + packageType cmtTbl | Ptyp_class _ -> Doc.text "classes are not supported in types" | Ptyp_variant (rowFields, closedFlag, labelsOpt) -> - let forceBreak = - typExpr.ptyp_loc.Location.loc_start.pos_lnum - < typExpr.ptyp_loc.loc_end.pos_lnum - in - let printRowField = function - | Parsetree.Rtag ({ txt; loc }, attrs, true, []) -> - let doc = - Doc.group - (Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - Doc.concat [ Doc.text "#"; printPolyVarIdent txt ]; - ]) - in - printComments doc cmtTbl loc - | Rtag ({ txt }, attrs, truth, types) -> - let doType t = - match t.Parsetree.ptyp_desc with - | Ptyp_tuple _ -> printTypExpr ~customLayout t cmtTbl - | _ -> - Doc.concat - [ - Doc.lparen; - printTypExpr ~customLayout t cmtTbl; - Doc.rparen; - ] - in - let printedTypes = List.map doType types in - let cases = - Doc.join - ~sep:(Doc.concat [ Doc.line; Doc.text "& " ]) - printedTypes - in - let cases = - if truth then Doc.concat [ Doc.line; Doc.text "& "; cases ] - else cases - in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - Doc.concat [ Doc.text "#"; printPolyVarIdent txt ]; - cases; - ]) - | Rinherit coreType -> printTypExpr ~customLayout coreType cmtTbl - in - let docs = List.map printRowField rowFields in - let cases = - Doc.join ~sep:(Doc.concat [ Doc.line; Doc.text "| " ]) docs - in - let cases = - if docs = [] then cases - else Doc.concat [ Doc.ifBreaks (Doc.text "| ") Doc.nil; cases ] - in - let openingSymbol = - if closedFlag = Open then Doc.concat [ Doc.greaterThan; Doc.line ] - else if labelsOpt = None then Doc.softLine - else Doc.concat [ Doc.lessThan; Doc.line ] - in - let labels = - match labelsOpt with - | None | Some [] -> Doc.nil - | Some labels -> + let forceBreak = + typExpr.ptyp_loc.Location.loc_start.pos_lnum + < typExpr.ptyp_loc.loc_end.pos_lnum + in + let printRowField = function + | Parsetree.Rtag ({txt; loc}, attrs, true, []) -> + let doc = + Doc.group + (Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + Doc.concat [Doc.text "#"; printPolyVarIdent txt]; + ]) + in + printComments doc cmtTbl loc + | Rtag ({txt}, attrs, truth, types) -> + let doType t = + match t.Parsetree.ptyp_desc with + | Ptyp_tuple _ -> printTypExpr ~customLayout t cmtTbl + | _ -> Doc.concat - (List.map - (fun label -> - Doc.concat - [ Doc.line; Doc.text "#"; printPolyVarIdent label ]) - labels) - in - let closingSymbol = - match labelsOpt with None | Some [] -> Doc.nil | _ -> Doc.text " >" - in - Doc.breakableGroup ~forceBreak - (Doc.concat - [ - Doc.lbracket; - Doc.indent - (Doc.concat [ openingSymbol; cases; closingSymbol; labels ]); - Doc.softLine; - Doc.rbracket; - ]) + [Doc.lparen; printTypExpr ~customLayout t cmtTbl; Doc.rparen] + in + let printedTypes = List.map doType types in + let cases = + Doc.join ~sep:(Doc.concat [Doc.line; Doc.text "& "]) printedTypes + in + let cases = + if truth then Doc.concat [Doc.line; Doc.text "& "; cases] else cases + in + Doc.group + (Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + Doc.concat [Doc.text "#"; printPolyVarIdent txt]; + cases; + ]) + | Rinherit coreType -> printTypExpr ~customLayout coreType cmtTbl + in + let docs = List.map printRowField rowFields in + let cases = Doc.join ~sep:(Doc.concat [Doc.line; Doc.text "| "]) docs in + let cases = + if docs = [] then cases + else Doc.concat [Doc.ifBreaks (Doc.text "| ") Doc.nil; cases] + in + let openingSymbol = + if closedFlag = Open then Doc.concat [Doc.greaterThan; Doc.line] + else if labelsOpt = None then Doc.softLine + else Doc.concat [Doc.lessThan; Doc.line] + in + let labels = + match labelsOpt with + | None | Some [] -> Doc.nil + | Some labels -> + Doc.concat + (List.map + (fun label -> + Doc.concat [Doc.line; Doc.text "#"; printPolyVarIdent label]) + labels) + in + let closingSymbol = + match labelsOpt with + | None | Some [] -> Doc.nil + | _ -> Doc.text " >" + in + Doc.breakableGroup ~forceBreak + (Doc.concat + [ + Doc.lbracket; + Doc.indent + (Doc.concat [openingSymbol; cases; closingSymbol; labels]); + Doc.softLine; + Doc.rbracket; + ]) in let shouldPrintItsOwnAttributes = match typExpr.ptyp_desc with @@ -54934,9 +54922,8 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = let doc = match typExpr.ptyp_attributes with | _ :: _ as attrs when not shouldPrintItsOwnAttributes -> - Doc.group - (Doc.concat - [ printAttributes ~customLayout attrs cmtTbl; renderedType ]) + Doc.group + (Doc.concat [printAttributes ~customLayout attrs cmtTbl; renderedType]) | _ -> renderedType in printComments doc cmtTbl typExpr.ptyp_loc @@ -54945,41 +54932,40 @@ and printObject ~customLayout ~inline fields openFlag cmtTbl = let doc = match fields with | [] -> - Doc.concat - [ - Doc.lbrace; - (match openFlag with - | Asttypes.Closed -> Doc.dot - | Open -> Doc.dotdot); - Doc.rbrace; - ] + Doc.concat + [ + Doc.lbrace; + (match openFlag with + | Asttypes.Closed -> Doc.dot + | Open -> Doc.dotdot); + Doc.rbrace; + ] | fields -> - Doc.concat - [ - Doc.lbrace; - (match openFlag with - | Asttypes.Closed -> Doc.nil - | Open -> ( - match fields with - (* handle `type t = {.. ...objType, "x": int}` - * .. and ... should have a space in between *) - | Oinherit _ :: _ -> Doc.text ".. " - | _ -> Doc.dotdot)); - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun field -> - printObjectField ~customLayout field cmtTbl) - fields); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ] + Doc.concat + [ + Doc.lbrace; + (match openFlag with + | Asttypes.Closed -> Doc.nil + | Open -> ( + match fields with + (* handle `type t = {.. ...objType, "x": int}` + * .. and ... should have a space in between *) + | Oinherit _ :: _ -> Doc.text ".. " + | _ -> Doc.dotdot)); + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun field -> printObjectField ~customLayout field cmtTbl) + fields); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ] in if inline then doc else Doc.group doc @@ -54994,7 +54980,7 @@ and printTupleType ~customLayout ~inline (types : Parsetree.core_type list) [ Doc.softLine; Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map (fun typexpr -> printTypExpr ~customLayout typexpr cmtTbl) types); @@ -55009,23 +54995,23 @@ and printTupleType ~customLayout ~inline (types : Parsetree.core_type list) and printObjectField ~customLayout (field : Parsetree.object_field) cmtTbl = match field with | Otag (labelLoc, attrs, typ) -> - let lbl = - let doc = Doc.text ("\"" ^ labelLoc.txt ^ "\"") in - printComments doc cmtTbl labelLoc.loc - in - let doc = - Doc.concat - [ - printAttributes ~customLayout ~loc:labelLoc.loc attrs cmtTbl; - lbl; - Doc.text ": "; - printTypExpr ~customLayout typ cmtTbl; - ] - in - let cmtLoc = { labelLoc.loc with loc_end = typ.ptyp_loc.loc_end } in - printComments doc cmtTbl cmtLoc + let lbl = + let doc = Doc.text ("\"" ^ labelLoc.txt ^ "\"") in + printComments doc cmtTbl labelLoc.loc + in + let doc = + Doc.concat + [ + printAttributes ~customLayout ~loc:labelLoc.loc attrs cmtTbl; + lbl; + Doc.text ": "; + printTypExpr ~customLayout typ cmtTbl; + ] + in + let cmtLoc = {labelLoc.loc with loc_end = typ.ptyp_loc.loc_end} in + printComments doc cmtTbl cmtLoc | Oinherit typexpr -> - Doc.concat [ Doc.dotdotdot; printTypExpr ~customLayout typexpr cmtTbl ] + Doc.concat [Doc.dotdotdot; printTypExpr ~customLayout typexpr cmtTbl] (* es6 arrow type arg * type t = (~foo: string, ~bar: float=?, unit) => unit @@ -55033,16 +55019,16 @@ and printObjectField ~customLayout (field : Parsetree.object_field) cmtTbl = and printTypeParameter ~customLayout (attrs, lbl, typ) cmtTbl = let isUncurried, attrs = ParsetreeViewer.processUncurriedAttribute attrs in let uncurried = - if isUncurried then Doc.concat [ Doc.dot; Doc.space ] else Doc.nil + if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil in let attrs = printAttributes ~customLayout attrs cmtTbl in let label = match lbl with | Asttypes.Nolabel -> Doc.nil | Labelled lbl -> - Doc.concat [ Doc.text "~"; printIdentLike lbl; Doc.text ": " ] + Doc.concat [Doc.text "~"; printIdentLike lbl; Doc.text ": "] | Optional lbl -> - Doc.concat [ Doc.text "~"; printIdentLike lbl; Doc.text ": " ] + Doc.concat [Doc.text "~"; printIdentLike lbl; Doc.text ": "] in let optionalIndicator = match lbl with @@ -55051,9 +55037,9 @@ and printTypeParameter ~customLayout (attrs, lbl, typ) cmtTbl = in let loc, typ = match typ.ptyp_attributes with - | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: attrs -> - ( { loc with loc_end = typ.ptyp_loc.loc_end }, - { typ with ptyp_attributes = attrs } ) + | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: attrs -> + ( {loc with loc_end = typ.ptyp_loc.loc_end}, + {typ with ptyp_attributes = attrs} ) | _ -> (typ.ptyp_loc, typ) in let doc = @@ -55076,178 +55062,169 @@ and printValueBinding ~customLayout ~recFlag (vb : Parsetree.value_binding) cmtTbl in let header = - if i == 0 then Doc.concat [ Doc.text "let "; recFlag ] else Doc.text "and " + if i == 0 then Doc.concat [Doc.text "let "; recFlag] else Doc.text "and " in match vb with | { pvb_pat = { ppat_desc = - Ppat_constraint (pattern, ({ ptyp_desc = Ptyp_poly _ } as patTyp)); + Ppat_constraint (pattern, ({ptyp_desc = Ptyp_poly _} as patTyp)); }; - pvb_expr = { pexp_desc = Pexp_newtype _ } as expr; + pvb_expr = {pexp_desc = Pexp_newtype _} as expr; } -> ( - let _attrs, parameters, returnExpr = ParsetreeViewer.funExpr expr in - let abstractType = - match parameters with - | [ NewTypes { locs = vars } ] -> - Doc.concat - [ - Doc.text "type "; - Doc.join ~sep:Doc.space - (List.map (fun var -> Doc.text var.Asttypes.txt) vars); - Doc.dot; - ] - | _ -> Doc.nil - in - match returnExpr.pexp_desc with - | Pexp_constraint (expr, typ) -> + let _attrs, parameters, returnExpr = ParsetreeViewer.funExpr expr in + let abstractType = + match parameters with + | [NewTypes {locs = vars}] -> + Doc.concat + [ + Doc.text "type "; + Doc.join ~sep:Doc.space + (List.map (fun var -> Doc.text var.Asttypes.txt) vars); + Doc.dot; + ] + | _ -> Doc.nil + in + match returnExpr.pexp_desc with + | Pexp_constraint (expr, typ) -> + Doc.group + (Doc.concat + [ + attrs; + header; + printPattern ~customLayout pattern cmtTbl; + Doc.text ":"; + Doc.indent + (Doc.concat + [ + Doc.line; + abstractType; + Doc.space; + printTypExpr ~customLayout typ cmtTbl; + Doc.text " ="; + Doc.concat + [ + Doc.line; + printExpressionWithComments ~customLayout expr cmtTbl; + ]; + ]); + ]) + | _ -> + (* Example: + * let cancel_and_collect_callbacks: + * 'a 'u 'c. (list, promise<'a, 'u, 'c>) => list = * (type x, callbacks_accumulator, p: promise<_, _, c>) + *) + Doc.group + (Doc.concat + [ + attrs; + header; + printPattern ~customLayout pattern cmtTbl; + Doc.text ":"; + Doc.indent + (Doc.concat + [ + Doc.line; + abstractType; + Doc.space; + printTypExpr ~customLayout patTyp cmtTbl; + Doc.text " ="; + Doc.concat + [ + Doc.line; + printExpressionWithComments ~customLayout expr cmtTbl; + ]; + ]); + ])) + | _ -> + let optBraces, expr = ParsetreeViewer.processBracesAttr vb.pvb_expr in + let printedExpr = + let doc = printExpressionWithComments ~customLayout vb.pvb_expr cmtTbl in + match Parens.expr vb.pvb_expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + let patternDoc = printPattern ~customLayout vb.pvb_pat cmtTbl in + (* + * we want to optimize the layout of one pipe: + * let tbl = data->Js.Array2.reduce((map, curr) => { + * ... + * }) + * important is that we don't do this for multiple pipes: + * let decoratorTags = + * items + * ->Js.Array2.filter(items => {items.category === Decorators}) + * ->Belt.Array.map(...) + * Multiple pipes chained together lend themselves more towards the last layout. + *) + if ParsetreeViewer.isSinglePipeExpr vb.pvb_expr then + Doc.customLayout + [ Doc.group (Doc.concat [ - attrs; - header; - printPattern ~customLayout pattern cmtTbl; - Doc.text ":"; - Doc.indent - (Doc.concat - [ - Doc.line; - abstractType; - Doc.space; - printTypExpr ~customLayout typ cmtTbl; - Doc.text " ="; - Doc.concat - [ - Doc.line; - printExpressionWithComments ~customLayout expr - cmtTbl; - ]; - ]); - ]) - | _ -> - (* Example: - * let cancel_and_collect_callbacks: - * 'a 'u 'c. (list, promise<'a, 'u, 'c>) => list = * (type x, callbacks_accumulator, p: promise<_, _, c>) - *) + attrs; header; patternDoc; Doc.text " ="; Doc.space; printedExpr; + ]); Doc.group (Doc.concat [ attrs; header; - printPattern ~customLayout pattern cmtTbl; - Doc.text ":"; - Doc.indent - (Doc.concat - [ - Doc.line; - abstractType; - Doc.space; - printTypExpr ~customLayout patTyp cmtTbl; - Doc.text " ="; - Doc.concat - [ - Doc.line; - printExpressionWithComments ~customLayout expr - cmtTbl; - ]; - ]); - ])) - | _ -> - let optBraces, expr = ParsetreeViewer.processBracesAttr vb.pvb_expr in - let printedExpr = - let doc = - printExpressionWithComments ~customLayout vb.pvb_expr cmtTbl - in - match Parens.expr vb.pvb_expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc + patternDoc; + Doc.text " ="; + Doc.indent (Doc.concat [Doc.line; printedExpr]); + ]); + ] + else + let shouldIndent = + match optBraces with + | Some _ -> false + | _ -> ( + ParsetreeViewer.isBinaryExpression expr + || + match vb.pvb_expr with + | { + pexp_attributes = [({Location.txt = "ns.ternary"}, _)]; + pexp_desc = Pexp_ifthenelse (ifExpr, _, _); + } -> + ParsetreeViewer.isBinaryExpression ifExpr + || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes + | {pexp_desc = Pexp_newtype _} -> false + | e -> + ParsetreeViewer.hasAttributes e.pexp_attributes + || ParsetreeViewer.isArrayAccess e) in - let patternDoc = printPattern ~customLayout vb.pvb_pat cmtTbl in - (* - * we want to optimize the layout of one pipe: - * let tbl = data->Js.Array2.reduce((map, curr) => { - * ... - * }) - * important is that we don't do this for multiple pipes: - * let decoratorTags = - * items - * ->Js.Array2.filter(items => {items.category === Decorators}) - * ->Belt.Array.map(...) - * Multiple pipes chained together lend themselves more towards the last layout. - *) - if ParsetreeViewer.isSinglePipeExpr vb.pvb_expr then - Doc.customLayout - [ - Doc.group - (Doc.concat - [ - attrs; - header; - patternDoc; - Doc.text " ="; - Doc.space; - printedExpr; - ]); - Doc.group - (Doc.concat - [ - attrs; - header; - patternDoc; - Doc.text " ="; - Doc.indent (Doc.concat [ Doc.line; printedExpr ]); - ]); - ] - else - let shouldIndent = - match optBraces with - | Some _ -> false - | _ -> ( - ParsetreeViewer.isBinaryExpression expr - || - match vb.pvb_expr with - | { - pexp_attributes = [ ({ Location.txt = "ns.ternary" }, _) ]; - pexp_desc = Pexp_ifthenelse (ifExpr, _, _); - } -> - ParsetreeViewer.isBinaryExpression ifExpr - || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes - | { pexp_desc = Pexp_newtype _ } -> false - | e -> - ParsetreeViewer.hasAttributes e.pexp_attributes - || ParsetreeViewer.isArrayAccess e) - in - Doc.group - (Doc.concat - [ - attrs; - header; - patternDoc; - Doc.text " ="; - (if shouldIndent then - Doc.indent (Doc.concat [ Doc.line; printedExpr ]) - else Doc.concat [ Doc.space; printedExpr ]); - ]) + Doc.group + (Doc.concat + [ + attrs; + header; + patternDoc; + Doc.text " ="; + (if shouldIndent then + Doc.indent (Doc.concat [Doc.line; printedExpr]) + else Doc.concat [Doc.space; printedExpr]); + ]) and printPackageType ~customLayout ~printModuleKeywordAndParens (packageType : Parsetree.package_type) cmtTbl = let doc = match packageType with | longidentLoc, [] -> - Doc.group (Doc.concat [ printLongidentLocation longidentLoc cmtTbl ]) + Doc.group (Doc.concat [printLongidentLocation longidentLoc cmtTbl]) | longidentLoc, packageConstraints -> - Doc.group - (Doc.concat - [ - printLongidentLocation longidentLoc cmtTbl; - printPackageConstraints ~customLayout packageConstraints cmtTbl; - Doc.softLine; - ]) + Doc.group + (Doc.concat + [ + printLongidentLocation longidentLoc cmtTbl; + printPackageConstraints ~customLayout packageConstraints cmtTbl; + Doc.softLine; + ]) in if printModuleKeywordAndParens then - Doc.concat [ Doc.text "module("; doc; Doc.rparen ] + Doc.concat [Doc.text "module("; doc; Doc.rparen] else doc and printPackageConstraints ~customLayout packageConstraints cmtTbl = @@ -55299,7 +55276,7 @@ and printExtension ~customLayout ~atModuleLvl (stringLoc, payload) cmtTbl = in printComments doc cmtTbl stringLoc.Location.loc in - Doc.group (Doc.concat [ extName; printPayload ~customLayout payload cmtTbl ]) + Doc.group (Doc.concat [extName; printPayload ~customLayout payload cmtTbl]) and printPattern ~customLayout (p : Parsetree.pattern) cmtTbl = let patternWithoutAttributes = @@ -55307,404 +55284,376 @@ and printPattern ~customLayout (p : Parsetree.pattern) cmtTbl = | Ppat_any -> Doc.text "_" | Ppat_var var -> printIdentLike var.txt | Ppat_constant c -> - let templateLiteral = - ParsetreeViewer.hasTemplateLiteralAttr p.ppat_attributes - in - printConstant ~templateLiteral c + let templateLiteral = + ParsetreeViewer.hasTemplateLiteralAttr p.ppat_attributes + in + printConstant ~templateLiteral c | Ppat_tuple patterns -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) - (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) - patterns); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) | Ppat_array [] -> - Doc.concat - [ Doc.lbracket; printCommentsInside cmtTbl p.ppat_loc; Doc.rbracket ] + Doc.concat + [Doc.lbracket; printCommentsInside cmtTbl p.ppat_loc; Doc.rbracket] | Ppat_array patterns -> - Doc.group - (Doc.concat - [ - Doc.text "["; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) - (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) - patterns); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.text "]"; - ]) - | Ppat_construct ({ txt = Longident.Lident "()" }, _) -> - Doc.concat - [ Doc.lparen; printCommentsInside cmtTbl p.ppat_loc; Doc.rparen ] - | Ppat_construct ({ txt = Longident.Lident "[]" }, _) -> + Doc.group + (Doc.concat + [ + Doc.text "["; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.text "]"; + ]) + | Ppat_construct ({txt = Longident.Lident "()"}, _) -> + Doc.concat [Doc.lparen; printCommentsInside cmtTbl p.ppat_loc; Doc.rparen] + | Ppat_construct ({txt = Longident.Lident "[]"}, _) -> + Doc.concat + [Doc.text "list{"; printCommentsInside cmtTbl p.ppat_loc; Doc.rbrace] + | Ppat_construct ({txt = Longident.Lident "::"}, _) -> + let patterns, tail = + ParsetreeViewer.collectPatternsFromListConstruct [] p + in + let shouldHug = + match (patterns, tail) with + | [pat], {ppat_desc = Ppat_construct ({txt = Longident.Lident "[]"}, _)} + when ParsetreeViewer.isHuggablePattern pat -> + true + | _ -> false + in + let children = Doc.concat [ - Doc.text "list{"; printCommentsInside cmtTbl p.ppat_loc; Doc.rbrace; + (if shouldHug then Doc.nil else Doc.softLine); + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); + (match tail.Parsetree.ppat_desc with + | Ppat_construct ({txt = Longident.Lident "[]"}, _) -> Doc.nil + | _ -> + let doc = + Doc.concat + [Doc.text "..."; printPattern ~customLayout tail cmtTbl] + in + let tail = printComments doc cmtTbl tail.ppat_loc in + Doc.concat [Doc.text ","; Doc.line; tail]); ] - | Ppat_construct ({ txt = Longident.Lident "::" }, _) -> - let patterns, tail = - ParsetreeViewer.collectPatternsFromListConstruct [] p - in - let shouldHug = - match (patterns, tail) with - | ( [ pat ], - { - ppat_desc = Ppat_construct ({ txt = Longident.Lident "[]" }, _); - } ) - when ParsetreeViewer.isHuggablePattern pat -> - true - | _ -> false - in - let children = + in + Doc.group + (Doc.concat + [ + Doc.text "list{"; + (if shouldHug then children + else + Doc.concat + [ + Doc.indent children; + Doc.ifBreaks (Doc.text ",") Doc.nil; + Doc.softLine; + ]); + Doc.rbrace; + ]) + | Ppat_construct (constrName, constructorArgs) -> + let constrName = printLongidentLocation constrName cmtTbl in + let argsDoc = + match constructorArgs with + | None -> Doc.nil + | Some + { + ppat_loc; + ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _); + } -> + Doc.concat + [Doc.lparen; printCommentsInside cmtTbl ppat_loc; Doc.rparen] + | Some {ppat_desc = Ppat_tuple []; ppat_loc = loc} -> + Doc.concat [Doc.lparen; printCommentsInside cmtTbl loc; Doc.rparen] + (* Some((1, 2) *) + | Some {ppat_desc = Ppat_tuple [({ppat_desc = Ppat_tuple _} as arg)]} -> + Doc.concat + [Doc.lparen; printPattern ~customLayout arg cmtTbl; Doc.rparen] + | Some {ppat_desc = Ppat_tuple patterns} -> Doc.concat [ - (if shouldHug then Doc.nil else Doc.softLine); - Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) - (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) - patterns); - (match tail.Parsetree.ppat_desc with - | Ppat_construct ({ txt = Longident.Lident "[]" }, _) -> Doc.nil - | _ -> - let doc = - Doc.concat - [ Doc.text "..."; printPattern ~customLayout tail cmtTbl ] - in - let tail = printComments doc cmtTbl tail.ppat_loc in - Doc.concat [ Doc.text ","; Doc.line; tail ]); - ] - in - Doc.group - (Doc.concat - [ - Doc.text "list{"; - (if shouldHug then children - else - Doc.concat + Doc.lparen; + Doc.indent + (Doc.concat [ - Doc.indent children; - Doc.ifBreaks (Doc.text ",") Doc.nil; Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); ]); - Doc.rbrace; - ]) - | Ppat_construct (constrName, constructorArgs) -> - let constrName = printLongidentLocation constrName cmtTbl in - let argsDoc = - match constructorArgs with - | None -> Doc.nil - | Some - { - ppat_loc; - ppat_desc = Ppat_construct ({ txt = Longident.Lident "()" }, _); - } -> - Doc.concat - [ Doc.lparen; printCommentsInside cmtTbl ppat_loc; Doc.rparen ] - | Some { ppat_desc = Ppat_tuple []; ppat_loc = loc } -> - Doc.concat - [ Doc.lparen; printCommentsInside cmtTbl loc; Doc.rparen ] - (* Some((1, 2) *) - | Some - { - ppat_desc = Ppat_tuple [ ({ ppat_desc = Ppat_tuple _ } as arg) ]; - } -> - Doc.concat - [ - Doc.lparen; printPattern ~customLayout arg cmtTbl; Doc.rparen; - ] - | Some { ppat_desc = Ppat_tuple patterns } -> - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) - patterns); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some arg -> - let argDoc = printPattern ~customLayout arg cmtTbl in - let shouldHug = ParsetreeViewer.isHuggablePattern arg in - Doc.concat - [ - Doc.lparen; - (if shouldHug then argDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [ Doc.softLine; argDoc ]); - Doc.trailingComma; - Doc.softLine; - ]); - Doc.rparen; - ] - in - Doc.group (Doc.concat [ constrName; argsDoc ]) + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + | Some arg -> + let argDoc = printPattern ~customLayout arg cmtTbl in + let shouldHug = ParsetreeViewer.isHuggablePattern arg in + Doc.concat + [ + Doc.lparen; + (if shouldHug then argDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [Doc.softLine; argDoc]); + Doc.trailingComma; + Doc.softLine; + ]); + Doc.rparen; + ] + in + Doc.group (Doc.concat [constrName; argsDoc]) | Ppat_variant (label, None) -> - Doc.concat [ Doc.text "#"; printPolyVarIdent label ] + Doc.concat [Doc.text "#"; printPolyVarIdent label] | Ppat_variant (label, variantArgs) -> - let variantName = - Doc.concat [ Doc.text "#"; printPolyVarIdent label ] - in - let argsDoc = - match variantArgs with - | None -> Doc.nil - | Some - { - ppat_desc = Ppat_construct ({ txt = Longident.Lident "()" }, _); - } -> - Doc.text "()" - | Some { ppat_desc = Ppat_tuple []; ppat_loc = loc } -> - Doc.concat - [ Doc.lparen; printCommentsInside cmtTbl loc; Doc.rparen ] - (* Some((1, 2) *) - | Some - { - ppat_desc = Ppat_tuple [ ({ ppat_desc = Ppat_tuple _ } as arg) ]; - } -> - Doc.concat - [ - Doc.lparen; printPattern ~customLayout arg cmtTbl; Doc.rparen; - ] - | Some { ppat_desc = Ppat_tuple patterns } -> - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) - patterns); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some arg -> - let argDoc = printPattern ~customLayout arg cmtTbl in - let shouldHug = ParsetreeViewer.isHuggablePattern arg in - Doc.concat - [ - Doc.lparen; - (if shouldHug then argDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [ Doc.softLine; argDoc ]); - Doc.trailingComma; - Doc.softLine; - ]); - Doc.rparen; - ] - in - Doc.group (Doc.concat [ variantName; argsDoc ]) + let variantName = Doc.concat [Doc.text "#"; printPolyVarIdent label] in + let argsDoc = + match variantArgs with + | None -> Doc.nil + | Some {ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _)} + -> + Doc.text "()" + | Some {ppat_desc = Ppat_tuple []; ppat_loc = loc} -> + Doc.concat [Doc.lparen; printCommentsInside cmtTbl loc; Doc.rparen] + (* Some((1, 2) *) + | Some {ppat_desc = Ppat_tuple [({ppat_desc = Ppat_tuple _} as arg)]} -> + Doc.concat + [Doc.lparen; printPattern ~customLayout arg cmtTbl; Doc.rparen] + | Some {ppat_desc = Ppat_tuple patterns} -> + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + | Some arg -> + let argDoc = printPattern ~customLayout arg cmtTbl in + let shouldHug = ParsetreeViewer.isHuggablePattern arg in + Doc.concat + [ + Doc.lparen; + (if shouldHug then argDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [Doc.softLine; argDoc]); + Doc.trailingComma; + Doc.softLine; + ]); + Doc.rparen; + ] + in + Doc.group (Doc.concat [variantName; argsDoc]) | Ppat_type ident -> - Doc.concat [ Doc.text "#..."; printIdentPath ident cmtTbl ] + Doc.concat [Doc.text "#..."; printIdentPath ident cmtTbl] | Ppat_record (rows, openFlag) -> - Doc.group - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) - (List.map - (fun row -> - printPatternRecordRow ~customLayout row cmtTbl) - rows); - (match openFlag with - | Open -> - Doc.concat [ Doc.text ","; Doc.line; Doc.text "_" ] - | Closed -> Doc.nil); - ]); - Doc.ifBreaks (Doc.text ",") Doc.nil; - Doc.softLine; - Doc.rbrace; - ]) + Doc.group + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun row -> + printPatternRecordRow ~customLayout row cmtTbl) + rows); + (match openFlag with + | Open -> Doc.concat [Doc.text ","; Doc.line; Doc.text "_"] + | Closed -> Doc.nil); + ]); + Doc.ifBreaks (Doc.text ",") Doc.nil; + Doc.softLine; + Doc.rbrace; + ]) | Ppat_exception p -> - let needsParens = - match p.ppat_desc with - | Ppat_or (_, _) | Ppat_alias (_, _) -> true - | _ -> false - in - let pat = - let p = printPattern ~customLayout p cmtTbl in - if needsParens then Doc.concat [ Doc.text "("; p; Doc.text ")" ] - else p - in - Doc.group (Doc.concat [ Doc.text "exception"; Doc.line; pat ]) + let needsParens = + match p.ppat_desc with + | Ppat_or (_, _) | Ppat_alias (_, _) -> true + | _ -> false + in + let pat = + let p = printPattern ~customLayout p cmtTbl in + if needsParens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p + in + Doc.group (Doc.concat [Doc.text "exception"; Doc.line; pat]) | Ppat_or _ -> - (* Blue | Red | Green -> [Blue; Red; Green] *) - let orChain = ParsetreeViewer.collectOrPatternChain p in - let docs = - List.mapi - (fun i pat -> - let patternDoc = printPattern ~customLayout pat cmtTbl in - Doc.concat - [ - (if i == 0 then Doc.nil - else Doc.concat [ Doc.line; Doc.text "| " ]); - (match pat.ppat_desc with - (* (Blue | Red) | (Green | Black) | White *) - | Ppat_or _ -> addParens patternDoc - | _ -> patternDoc); - ]) - orChain - in - let isSpreadOverMultipleLines = - match (orChain, List.rev orChain) with - | first :: _, last :: _ -> - first.ppat_loc.loc_start.pos_lnum < last.ppat_loc.loc_end.pos_lnum - | _ -> false - in - Doc.breakableGroup ~forceBreak:isSpreadOverMultipleLines - (Doc.concat docs) + (* Blue | Red | Green -> [Blue; Red; Green] *) + let orChain = ParsetreeViewer.collectOrPatternChain p in + let docs = + List.mapi + (fun i pat -> + let patternDoc = printPattern ~customLayout pat cmtTbl in + Doc.concat + [ + (if i == 0 then Doc.nil + else Doc.concat [Doc.line; Doc.text "| "]); + (match pat.ppat_desc with + (* (Blue | Red) | (Green | Black) | White *) + | Ppat_or _ -> addParens patternDoc + | _ -> patternDoc); + ]) + orChain + in + let isSpreadOverMultipleLines = + match (orChain, List.rev orChain) with + | first :: _, last :: _ -> + first.ppat_loc.loc_start.pos_lnum < last.ppat_loc.loc_end.pos_lnum + | _ -> false + in + Doc.breakableGroup ~forceBreak:isSpreadOverMultipleLines (Doc.concat docs) | Ppat_extension ext -> - printExtension ~customLayout ~atModuleLvl:false ext cmtTbl + printExtension ~customLayout ~atModuleLvl:false ext cmtTbl | Ppat_lazy p -> - let needsParens = - match p.ppat_desc with - | Ppat_or (_, _) | Ppat_alias (_, _) -> true - | _ -> false - in - let pat = - let p = printPattern ~customLayout p cmtTbl in - if needsParens then Doc.concat [ Doc.text "("; p; Doc.text ")" ] - else p - in - Doc.concat [ Doc.text "lazy "; pat ] + let needsParens = + match p.ppat_desc with + | Ppat_or (_, _) | Ppat_alias (_, _) -> true + | _ -> false + in + let pat = + let p = printPattern ~customLayout p cmtTbl in + if needsParens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p + in + Doc.concat [Doc.text "lazy "; pat] | Ppat_alias (p, aliasLoc) -> - let needsParens = - match p.ppat_desc with - | Ppat_or (_, _) | Ppat_alias (_, _) -> true - | _ -> false - in - let renderedPattern = - let p = printPattern ~customLayout p cmtTbl in - if needsParens then Doc.concat [ Doc.text "("; p; Doc.text ")" ] - else p - in - Doc.concat - [ renderedPattern; Doc.text " as "; printStringLoc aliasLoc cmtTbl ] + let needsParens = + match p.ppat_desc with + | Ppat_or (_, _) | Ppat_alias (_, _) -> true + | _ -> false + in + let renderedPattern = + let p = printPattern ~customLayout p cmtTbl in + if needsParens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p + in + Doc.concat + [renderedPattern; Doc.text " as "; printStringLoc aliasLoc cmtTbl] (* Note: module(P : S) is represented as *) (* Ppat_constraint(Ppat_unpack, Ptyp_package) *) | Ppat_constraint - ( { ppat_desc = Ppat_unpack stringLoc }, - { ptyp_desc = Ptyp_package packageType; ptyp_loc } ) -> - Doc.concat - [ - Doc.text "module("; - printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; - Doc.text ": "; - printComments - (printPackageType ~customLayout ~printModuleKeywordAndParens:false - packageType cmtTbl) - cmtTbl ptyp_loc; - Doc.rparen; - ] + ( {ppat_desc = Ppat_unpack stringLoc}, + {ptyp_desc = Ptyp_package packageType; ptyp_loc} ) -> + Doc.concat + [ + Doc.text "module("; + printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; + Doc.text ": "; + printComments + (printPackageType ~customLayout ~printModuleKeywordAndParens:false + packageType cmtTbl) + cmtTbl ptyp_loc; + Doc.rparen; + ] | Ppat_constraint (pattern, typ) -> - Doc.concat - [ - printPattern ~customLayout pattern cmtTbl; - Doc.text ": "; - printTypExpr ~customLayout typ cmtTbl; - ] + Doc.concat + [ + printPattern ~customLayout pattern cmtTbl; + Doc.text ": "; + printTypExpr ~customLayout typ cmtTbl; + ] (* Note: module(P : S) is represented as *) (* Ppat_constraint(Ppat_unpack, Ptyp_package) *) | Ppat_unpack stringLoc -> - Doc.concat - [ - Doc.text "module("; - printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; - Doc.rparen; - ] + Doc.concat + [ + Doc.text "module("; + printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; + Doc.rparen; + ] | Ppat_interval (a, b) -> - Doc.concat [ printConstant a; Doc.text " .. "; printConstant b ] + Doc.concat [printConstant a; Doc.text " .. "; printConstant b] | Ppat_open _ -> Doc.nil in let doc = match p.ppat_attributes with | [] -> patternWithoutAttributes | attrs -> - Doc.group - (Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - patternWithoutAttributes; - ]) + Doc.group + (Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; patternWithoutAttributes; + ]) in printComments doc cmtTbl p.ppat_loc and printPatternRecordRow ~customLayout row cmtTbl = match row with (* punned {x}*) - | ( ({ Location.txt = Longident.Lident ident } as longident), - { Parsetree.ppat_desc = Ppat_var { txt; _ }; ppat_attributes } ) + | ( ({Location.txt = Longident.Lident ident} as longident), + {Parsetree.ppat_desc = Ppat_var {txt; _}; ppat_attributes} ) when ident = txt -> - Doc.concat - [ - printOptionalLabel ppat_attributes; - printAttributes ~customLayout ppat_attributes cmtTbl; - printLidentPath longident cmtTbl; - ] + Doc.concat + [ + printOptionalLabel ppat_attributes; + printAttributes ~customLayout ppat_attributes cmtTbl; + printLidentPath longident cmtTbl; + ] | longident, pattern -> - let locForComments = - { longident.loc with loc_end = pattern.Parsetree.ppat_loc.loc_end } - in - let rhsDoc = - let doc = printPattern ~customLayout pattern cmtTbl in - let doc = - if Parens.patternRecordRowRhs pattern then addParens doc else doc - in - Doc.concat [ printOptionalLabel pattern.ppat_attributes; doc ] - in + let locForComments = + {longident.loc with loc_end = pattern.Parsetree.ppat_loc.loc_end} + in + let rhsDoc = + let doc = printPattern ~customLayout pattern cmtTbl in let doc = - Doc.group - (Doc.concat - [ - printLidentPath longident cmtTbl; - Doc.text ":"; - (if ParsetreeViewer.isHuggablePattern pattern then - Doc.concat [ Doc.space; rhsDoc ] - else Doc.indent (Doc.concat [ Doc.line; rhsDoc ])); - ]) + if Parens.patternRecordRowRhs pattern then addParens doc else doc in - printComments doc cmtTbl locForComments + Doc.concat [printOptionalLabel pattern.ppat_attributes; doc] + in + let doc = + Doc.group + (Doc.concat + [ + printLidentPath longident cmtTbl; + Doc.text ":"; + (if ParsetreeViewer.isHuggablePattern pattern then + Doc.concat [Doc.space; rhsDoc] + else Doc.indent (Doc.concat [Doc.line; rhsDoc])); + ]) + in + printComments doc cmtTbl locForComments and printExpressionWithComments ~customLayout expr cmtTbl : Doc.t = let doc = printExpression ~customLayout expr cmtTbl in @@ -55719,55 +55668,54 @@ and printIfChain ~customLayout pexp_attributes ifs elseExpr cmtTbl = let doc = match ifExpr with | ParsetreeViewer.If ifExpr -> - let condition = - if ParsetreeViewer.isBlockExpr ifExpr then - printExpressionBlock ~customLayout ~braces:true ifExpr - cmtTbl - else - let doc = - printExpressionWithComments ~customLayout ifExpr cmtTbl - in - match Parens.expr ifExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc ifExpr braces - | Nothing -> Doc.ifBreaks (addParens doc) doc - in - Doc.concat - [ - ifTxt; - Doc.group condition; - Doc.space; - (let thenExpr = - match ParsetreeViewer.processBracesAttr thenExpr with - (* This case only happens when coming from Reason, we strip braces *) - | Some _, expr -> expr - | _ -> thenExpr - in - printExpressionBlock ~customLayout ~braces:true thenExpr - cmtTbl); - ] - | IfLet (pattern, conditionExpr) -> - let conditionDoc = + let condition = + if ParsetreeViewer.isBlockExpr ifExpr then + printExpressionBlock ~customLayout ~braces:true ifExpr cmtTbl + else let doc = - printExpressionWithComments ~customLayout conditionExpr - cmtTbl + printExpressionWithComments ~customLayout ifExpr cmtTbl in - match Parens.expr conditionExpr with + match Parens.expr ifExpr with | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc conditionExpr braces - | Nothing -> doc + | Braced braces -> printBraces doc ifExpr braces + | Nothing -> Doc.ifBreaks (addParens doc) doc + in + Doc.concat + [ + ifTxt; + Doc.group condition; + Doc.space; + (let thenExpr = + match ParsetreeViewer.processBracesAttr thenExpr with + (* This case only happens when coming from Reason, we strip braces *) + | Some _, expr -> expr + | _ -> thenExpr + in + printExpressionBlock ~customLayout ~braces:true thenExpr + cmtTbl); + ] + | IfLet (pattern, conditionExpr) -> + let conditionDoc = + let doc = + printExpressionWithComments ~customLayout conditionExpr + cmtTbl in - Doc.concat - [ - ifTxt; - Doc.text "let "; - printPattern ~customLayout pattern cmtTbl; - Doc.text " = "; - conditionDoc; - Doc.space; - printExpressionBlock ~customLayout ~braces:true thenExpr - cmtTbl; - ] + match Parens.expr conditionExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc conditionExpr braces + | Nothing -> doc + in + Doc.concat + [ + ifTxt; + Doc.text "let "; + printPattern ~customLayout pattern cmtTbl; + Doc.text " = "; + conditionDoc; + Doc.space; + printExpressionBlock ~customLayout ~braces:true thenExpr + cmtTbl; + ] in printLeadingComments doc cmtTbl.leading outerLoc) ifs) @@ -55776,736 +55724,707 @@ and printIfChain ~customLayout pexp_attributes ifs elseExpr cmtTbl = match elseExpr with | None -> Doc.nil | Some expr -> - Doc.concat - [ - Doc.text " else "; - printExpressionBlock ~customLayout ~braces:true expr cmtTbl; - ] + Doc.concat + [ + Doc.text " else "; + printExpressionBlock ~customLayout ~braces:true expr cmtTbl; + ] in let attrs = ParsetreeViewer.filterFragileMatchAttributes pexp_attributes in - Doc.concat [ printAttributes ~customLayout attrs cmtTbl; ifDocs; elseDoc ] + Doc.concat [printAttributes ~customLayout attrs cmtTbl; ifDocs; elseDoc] and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = let printedExpression = match e.pexp_desc with | Parsetree.Pexp_constant c -> - printConstant ~templateLiteral:(ParsetreeViewer.isTemplateLiteral e) c + printConstant ~templateLiteral:(ParsetreeViewer.isTemplateLiteral e) c | Pexp_construct _ when ParsetreeViewer.hasJsxAttribute e.pexp_attributes -> - printJsxFragment ~customLayout e cmtTbl - | Pexp_construct ({ txt = Longident.Lident "()" }, _) -> Doc.text "()" - | Pexp_construct ({ txt = Longident.Lident "[]" }, _) -> - Doc.concat - [ - Doc.text "list{"; printCommentsInside cmtTbl e.pexp_loc; Doc.rbrace; - ] - | Pexp_construct ({ txt = Longident.Lident "::" }, _) -> - let expressions, spread = ParsetreeViewer.collectListExpressions e in - let spreadDoc = - match spread with - | Some expr -> - Doc.concat - [ - Doc.text ","; - Doc.line; - Doc.dotdotdot; - (let doc = - printExpressionWithComments ~customLayout expr cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); - ] - | None -> Doc.nil - in - Doc.group - (Doc.concat - [ - Doc.text "list{"; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) - (List.map - (fun expr -> - let doc = - printExpressionWithComments ~customLayout expr - cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - expressions); - spreadDoc; - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ]) + printJsxFragment ~customLayout e cmtTbl + | Pexp_construct ({txt = Longident.Lident "()"}, _) -> Doc.text "()" + | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> + Doc.concat + [Doc.text "list{"; printCommentsInside cmtTbl e.pexp_loc; Doc.rbrace] + | Pexp_construct ({txt = Longident.Lident "::"}, _) -> + let expressions, spread = ParsetreeViewer.collectListExpressions e in + let spreadDoc = + match spread with + | Some expr -> + Doc.concat + [ + Doc.text ","; + Doc.line; + Doc.dotdotdot; + (let doc = + printExpressionWithComments ~customLayout expr cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + ] + | None -> Doc.nil + in + Doc.group + (Doc.concat + [ + Doc.text "list{"; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + expressions); + spreadDoc; + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ]) | Pexp_construct (longidentLoc, args) -> - let constr = printLongidentLocation longidentLoc cmtTbl in - let args = - match args with - | None -> Doc.nil - | Some - { - pexp_desc = Pexp_construct ({ txt = Longident.Lident "()" }, _); - } -> - Doc.text "()" - (* Some((1, 2)) *) - | Some - { - pexp_desc = Pexp_tuple [ ({ pexp_desc = Pexp_tuple _ } as arg) ]; - } -> - Doc.concat - [ - Doc.lparen; - (let doc = - printExpressionWithComments ~customLayout arg cmtTbl - in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc); - Doc.rparen; - ] - | Some { pexp_desc = Pexp_tuple args } -> - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun expr -> - let doc = - printExpressionWithComments ~customLayout expr - cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some arg -> - let argDoc = - let doc = - printExpressionWithComments ~customLayout arg cmtTbl - in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc - in - let shouldHug = ParsetreeViewer.isHuggableExpression arg in - Doc.concat - [ - Doc.lparen; - (if shouldHug then argDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [ Doc.softLine; argDoc ]); - Doc.trailingComma; - Doc.softLine; - ]); - Doc.rparen; - ] - in - Doc.group (Doc.concat [ constr; args ]) + let constr = printLongidentLocation longidentLoc cmtTbl in + let args = + match args with + | None -> Doc.nil + | Some {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)} + -> + Doc.text "()" + (* Some((1, 2)) *) + | Some {pexp_desc = Pexp_tuple [({pexp_desc = Pexp_tuple _} as arg)]} -> + Doc.concat + [ + Doc.lparen; + (let doc = printExpressionWithComments ~customLayout arg cmtTbl in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc); + Doc.rparen; + ] + | Some {pexp_desc = Pexp_tuple args} -> + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + | Some arg -> + let argDoc = + let doc = printExpressionWithComments ~customLayout arg cmtTbl in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc + in + let shouldHug = ParsetreeViewer.isHuggableExpression arg in + Doc.concat + [ + Doc.lparen; + (if shouldHug then argDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [Doc.softLine; argDoc]); + Doc.trailingComma; + Doc.softLine; + ]); + Doc.rparen; + ] + in + Doc.group (Doc.concat [constr; args]) | Pexp_ident path -> printLidentPath path cmtTbl | Pexp_tuple exprs -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) - (List.map - (fun expr -> - let doc = - printExpressionWithComments ~customLayout expr - cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - exprs); - ]); - Doc.ifBreaks (Doc.text ",") Doc.nil; - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + exprs); + ]); + Doc.ifBreaks (Doc.text ",") Doc.nil; + Doc.softLine; + Doc.rparen; + ]) | Pexp_array [] -> - Doc.concat - [ Doc.lbracket; printCommentsInside cmtTbl e.pexp_loc; Doc.rbracket ] + Doc.concat + [Doc.lbracket; printCommentsInside cmtTbl e.pexp_loc; Doc.rbracket] | Pexp_array exprs -> - Doc.group + Doc.group + (Doc.concat + [ + Doc.lbracket; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + exprs); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbracket; + ]) + | Pexp_variant (label, args) -> + let variantName = Doc.concat [Doc.text "#"; printPolyVarIdent label] in + let args = + match args with + | None -> Doc.nil + | Some {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)} + -> + Doc.text "()" + (* #poly((1, 2) *) + | Some {pexp_desc = Pexp_tuple [({pexp_desc = Pexp_tuple _} as arg)]} -> + Doc.concat + [ + Doc.lparen; + (let doc = printExpressionWithComments ~customLayout arg cmtTbl in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc); + Doc.rparen; + ] + | Some {pexp_desc = Pexp_tuple args} -> + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + | Some arg -> + let argDoc = + let doc = printExpressionWithComments ~customLayout arg cmtTbl in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc + in + let shouldHug = ParsetreeViewer.isHuggableExpression arg in + Doc.concat + [ + Doc.lparen; + (if shouldHug then argDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [Doc.softLine; argDoc]); + Doc.trailingComma; + Doc.softLine; + ]); + Doc.rparen; + ] + in + Doc.group (Doc.concat [variantName; args]) + | Pexp_record (rows, spreadExpr) -> + if rows = [] then + Doc.concat + [Doc.lbrace; printCommentsInside cmtTbl e.pexp_loc; Doc.rbrace] + else + let spread = + match spreadExpr with + | None -> Doc.nil + | Some expr -> + Doc.concat + [ + Doc.dotdotdot; + (let doc = + printExpressionWithComments ~customLayout expr cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + Doc.comma; + Doc.line; + ] + in + (* If the record is written over multiple lines, break automatically + * `let x = {a: 1, b: 3}` -> same line, break when line-width exceeded + * `let x = { + * a: 1, + * b: 2, + * }` -> record is written on multiple lines, break the group *) + let forceBreak = + e.pexp_loc.loc_start.pos_lnum < e.pexp_loc.loc_end.pos_lnum + in + let punningAllowed = + match (spreadExpr, rows) with + | None, [_] -> false (* disallow punning for single-element records *) + | _ -> true + in + Doc.breakableGroup ~forceBreak (Doc.concat [ - Doc.lbracket; + Doc.lbrace; Doc.indent (Doc.concat [ Doc.softLine; + spread; Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) + ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map - (fun expr -> - let doc = - printExpressionWithComments ~customLayout expr - cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - exprs); + (fun row -> + printExpressionRecordRow ~customLayout row cmtTbl + punningAllowed) + rows); ]); Doc.trailingComma; Doc.softLine; - Doc.rbracket; + Doc.rbrace; ]) - | Pexp_variant (label, args) -> - let variantName = - Doc.concat [ Doc.text "#"; printPolyVarIdent label ] - in - let args = - match args with - | None -> Doc.nil - | Some - { - pexp_desc = Pexp_construct ({ txt = Longident.Lident "()" }, _); - } -> - Doc.text "()" - (* #poly((1, 2) *) - | Some - { - pexp_desc = Pexp_tuple [ ({ pexp_desc = Pexp_tuple _ } as arg) ]; - } -> - Doc.concat - [ - Doc.lparen; - (let doc = - printExpressionWithComments ~customLayout arg cmtTbl - in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc); - Doc.rparen; - ] - | Some { pexp_desc = Pexp_tuple args } -> - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun expr -> - let doc = - printExpressionWithComments ~customLayout expr - cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some arg -> - let argDoc = - let doc = - printExpressionWithComments ~customLayout arg cmtTbl - in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc - in - let shouldHug = ParsetreeViewer.isHuggableExpression arg in - Doc.concat - [ - Doc.lparen; - (if shouldHug then argDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [ Doc.softLine; argDoc ]); - Doc.trailingComma; - Doc.softLine; - ]); - Doc.rparen; - ] - in - Doc.group (Doc.concat [ variantName; args ]) - | Pexp_record (rows, spreadExpr) -> - if rows = [] then - Doc.concat - [ Doc.lbrace; printCommentsInside cmtTbl e.pexp_loc; Doc.rbrace ] - else - let spread = - match spreadExpr with - | None -> Doc.nil - | Some expr -> - Doc.concat - [ - Doc.dotdotdot; - (let doc = - printExpressionWithComments ~customLayout expr cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); - Doc.comma; - Doc.line; - ] - in - (* If the record is written over multiple lines, break automatically - * `let x = {a: 1, b: 3}` -> same line, break when line-width exceeded - * `let x = { - * a: 1, - * b: 2, - * }` -> record is written on multiple lines, break the group *) - let forceBreak = - e.pexp_loc.loc_start.pos_lnum < e.pexp_loc.loc_end.pos_lnum - in - let punningAllowed = - match (spreadExpr, rows) with - | None, [ _ ] -> - false (* disallow punning for single-element records *) - | _ -> true - in - Doc.breakableGroup ~forceBreak - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - spread; - Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) - (List.map - (fun row -> - printExpressionRecordRow ~customLayout row cmtTbl - punningAllowed) - rows); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ]) | Pexp_extension extension -> ( - match extension with - | ( { txt = "bs.obj" | "obj" }, - PStr - [ - { - pstr_loc = loc; - pstr_desc = - Pstr_eval ({ pexp_desc = Pexp_record (rows, _) }, []); - }; - ] ) -> - (* If the object is written over multiple lines, break automatically - * `let x = {"a": 1, "b": 3}` -> same line, break when line-width exceeded - * `let x = { - * "a": 1, - * "b": 2, - * }` -> object is written on multiple lines, break the group *) - let forceBreak = loc.loc_start.pos_lnum < loc.loc_end.pos_lnum in - Doc.breakableGroup ~forceBreak - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) - (List.map - (fun row -> - printBsObjectRow ~customLayout row cmtTbl) - rows); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ]) - | extension -> - printExtension ~customLayout ~atModuleLvl:false extension cmtTbl) - | Pexp_apply (e, [ (Nolabel, { pexp_desc = Pexp_array subLists }) ]) - when ParsetreeViewer.isSpreadBeltListConcat e -> - printBeltListConcatApply ~customLayout subLists cmtTbl - | Pexp_apply _ -> - if ParsetreeViewer.isUnaryExpression e then - printUnaryExpression ~customLayout e cmtTbl - else if ParsetreeViewer.isTemplateLiteral e then - printTemplateLiteral ~customLayout e cmtTbl - else if ParsetreeViewer.isBinaryExpression e then - printBinaryExpression ~customLayout e cmtTbl - else printPexpApply ~customLayout e cmtTbl - | Pexp_unreachable -> Doc.dot - | Pexp_field (expr, longidentLoc) -> - let lhs = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.fieldExpr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat [ lhs; Doc.dot; printLidentPath longidentLoc cmtTbl ] - | Pexp_setfield (expr1, longidentLoc, expr2) -> - printSetFieldExpr ~customLayout e.pexp_attributes expr1 longidentLoc - expr2 e.pexp_loc cmtTbl - | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) - when ParsetreeViewer.isTernaryExpr e -> - let parts, alternate = ParsetreeViewer.collectTernaryParts e in - let ternaryDoc = - match parts with - | (condition1, consequent1) :: rest -> - Doc.group - (Doc.concat - [ - printTernaryOperand ~customLayout condition1 cmtTbl; - Doc.indent - (Doc.concat - [ - Doc.line; - Doc.indent - (Doc.concat - [ - Doc.text "? "; - printTernaryOperand ~customLayout consequent1 - cmtTbl; - ]); - Doc.concat - (List.map - (fun (condition, consequent) -> - Doc.concat - [ - Doc.line; - Doc.text ": "; - printTernaryOperand ~customLayout - condition cmtTbl; - Doc.line; - Doc.text "? "; - printTernaryOperand ~customLayout - consequent cmtTbl; - ]) - rest); - Doc.line; - Doc.text ": "; - Doc.indent - (printTernaryOperand ~customLayout alternate - cmtTbl); - ]); - ]) - | _ -> Doc.nil - in - let attrs = ParsetreeViewer.filterTernaryAttributes e.pexp_attributes in - let needsParens = - match ParsetreeViewer.filterParsingAttrs attrs with - | [] -> false - | _ -> true - in - Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - (if needsParens then addParens ternaryDoc else ternaryDoc); - ] - | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) -> - let ifs, elseExpr = ParsetreeViewer.collectIfExpressions e in - printIfChain ~customLayout e.pexp_attributes ifs elseExpr cmtTbl - | Pexp_while (expr1, expr2) -> - let condition = - let doc = printExpressionWithComments ~customLayout expr1 cmtTbl in - match Parens.expr expr1 with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr1 braces - | Nothing -> doc - in - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.text "while "; - (if ParsetreeViewer.isBlockExpr expr1 then condition - else Doc.group (Doc.ifBreaks (addParens condition) condition)); - Doc.space; - printExpressionBlock ~customLayout ~braces:true expr2 cmtTbl; - ]) - | Pexp_for (pattern, fromExpr, toExpr, directionFlag, body) -> - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.text "for "; - printPattern ~customLayout pattern cmtTbl; - Doc.text " in "; - (let doc = - printExpressionWithComments ~customLayout fromExpr cmtTbl - in - match Parens.expr fromExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc fromExpr braces - | Nothing -> doc); - printDirectionFlag directionFlag; - (let doc = - printExpressionWithComments ~customLayout toExpr cmtTbl - in - match Parens.expr toExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc toExpr braces - | Nothing -> doc); - Doc.space; - printExpressionBlock ~customLayout ~braces:true body cmtTbl; - ]) - | Pexp_constraint - ( { pexp_desc = Pexp_pack modExpr }, - { ptyp_desc = Ptyp_package packageType; ptyp_loc } ) -> - Doc.group + match extension with + | ( {txt = "bs.obj" | "obj"}, + PStr + [ + { + pstr_loc = loc; + pstr_desc = Pstr_eval ({pexp_desc = Pexp_record (rows, _)}, []); + }; + ] ) -> + (* If the object is written over multiple lines, break automatically + * `let x = {"a": 1, "b": 3}` -> same line, break when line-width exceeded + * `let x = { + * "a": 1, + * "b": 2, + * }` -> object is written on multiple lines, break the group *) + let forceBreak = loc.loc_start.pos_lnum < loc.loc_end.pos_lnum in + Doc.breakableGroup ~forceBreak (Doc.concat [ - Doc.text "module("; + Doc.lbrace; Doc.indent (Doc.concat [ Doc.softLine; - printModExpr ~customLayout modExpr cmtTbl; - Doc.text ": "; - printComments - (printPackageType ~customLayout - ~printModuleKeywordAndParens:false packageType cmtTbl) - cmtTbl ptyp_loc; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun row -> + printBsObjectRow ~customLayout row cmtTbl) + rows); ]); + Doc.trailingComma; Doc.softLine; - Doc.rparen; + Doc.rbrace; ]) + | extension -> + printExtension ~customLayout ~atModuleLvl:false extension cmtTbl) + | Pexp_apply (e, [(Nolabel, {pexp_desc = Pexp_array subLists})]) + when ParsetreeViewer.isSpreadBeltListConcat e -> + printBeltListConcatApply ~customLayout subLists cmtTbl + | Pexp_apply _ -> + if ParsetreeViewer.isUnaryExpression e then + printUnaryExpression ~customLayout e cmtTbl + else if ParsetreeViewer.isTemplateLiteral e then + printTemplateLiteral ~customLayout e cmtTbl + else if ParsetreeViewer.isBinaryExpression e then + printBinaryExpression ~customLayout e cmtTbl + else printPexpApply ~customLayout e cmtTbl + | Pexp_unreachable -> Doc.dot + | Pexp_field (expr, longidentLoc) -> + let lhs = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.fieldExpr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [lhs; Doc.dot; printLidentPath longidentLoc cmtTbl] + | Pexp_setfield (expr1, longidentLoc, expr2) -> + printSetFieldExpr ~customLayout e.pexp_attributes expr1 longidentLoc expr2 + e.pexp_loc cmtTbl + | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) + when ParsetreeViewer.isTernaryExpr e -> + let parts, alternate = ParsetreeViewer.collectTernaryParts e in + let ternaryDoc = + match parts with + | (condition1, consequent1) :: rest -> + Doc.group + (Doc.concat + [ + printTernaryOperand ~customLayout condition1 cmtTbl; + Doc.indent + (Doc.concat + [ + Doc.line; + Doc.indent + (Doc.concat + [ + Doc.text "? "; + printTernaryOperand ~customLayout consequent1 + cmtTbl; + ]); + Doc.concat + (List.map + (fun (condition, consequent) -> + Doc.concat + [ + Doc.line; + Doc.text ": "; + printTernaryOperand ~customLayout condition + cmtTbl; + Doc.line; + Doc.text "? "; + printTernaryOperand ~customLayout consequent + cmtTbl; + ]) + rest); + Doc.line; + Doc.text ": "; + Doc.indent + (printTernaryOperand ~customLayout alternate cmtTbl); + ]); + ]) + | _ -> Doc.nil + in + let attrs = ParsetreeViewer.filterTernaryAttributes e.pexp_attributes in + let needsParens = + match ParsetreeViewer.filterParsingAttrs attrs with + | [] -> false + | _ -> true + in + Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + (if needsParens then addParens ternaryDoc else ternaryDoc); + ] + | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) -> + let ifs, elseExpr = ParsetreeViewer.collectIfExpressions e in + printIfChain ~customLayout e.pexp_attributes ifs elseExpr cmtTbl + | Pexp_while (expr1, expr2) -> + let condition = + let doc = printExpressionWithComments ~customLayout expr1 cmtTbl in + match Parens.expr expr1 with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr1 braces + | Nothing -> doc + in + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.text "while "; + (if ParsetreeViewer.isBlockExpr expr1 then condition + else Doc.group (Doc.ifBreaks (addParens condition) condition)); + Doc.space; + printExpressionBlock ~customLayout ~braces:true expr2 cmtTbl; + ]) + | Pexp_for (pattern, fromExpr, toExpr, directionFlag, body) -> + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.text "for "; + printPattern ~customLayout pattern cmtTbl; + Doc.text " in "; + (let doc = + printExpressionWithComments ~customLayout fromExpr cmtTbl + in + match Parens.expr fromExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc fromExpr braces + | Nothing -> doc); + printDirectionFlag directionFlag; + (let doc = + printExpressionWithComments ~customLayout toExpr cmtTbl + in + match Parens.expr toExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc toExpr braces + | Nothing -> doc); + Doc.space; + printExpressionBlock ~customLayout ~braces:true body cmtTbl; + ]) + | Pexp_constraint + ( {pexp_desc = Pexp_pack modExpr}, + {ptyp_desc = Ptyp_package packageType; ptyp_loc} ) -> + Doc.group + (Doc.concat + [ + Doc.text "module("; + Doc.indent + (Doc.concat + [ + Doc.softLine; + printModExpr ~customLayout modExpr cmtTbl; + Doc.text ": "; + printComments + (printPackageType ~customLayout + ~printModuleKeywordAndParens:false packageType cmtTbl) + cmtTbl ptyp_loc; + ]); + Doc.softLine; + Doc.rparen; + ]) | Pexp_constraint (expr, typ) -> - let exprDoc = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat - [ exprDoc; Doc.text ": "; printTypExpr ~customLayout typ cmtTbl ] - | Pexp_letmodule ({ txt = _modName }, _modExpr, _expr) -> - printExpressionBlock ~customLayout ~braces:true e cmtTbl + let exprDoc = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [exprDoc; Doc.text ": "; printTypExpr ~customLayout typ cmtTbl] + | Pexp_letmodule ({txt = _modName}, _modExpr, _expr) -> + printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_letexception (_extensionConstructor, _expr) -> - printExpressionBlock ~customLayout ~braces:true e cmtTbl + printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_assert expr -> - let rhs = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.lazyOrAssertOrAwaitExprRhs expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat [ Doc.text "assert "; rhs ] + let rhs = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.lazyOrAssertOrAwaitExprRhs expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [Doc.text "assert "; rhs] | Pexp_lazy expr -> - let rhs = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.lazyOrAssertOrAwaitExprRhs expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.group (Doc.concat [ Doc.text "lazy "; rhs ]) + let rhs = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.lazyOrAssertOrAwaitExprRhs expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.group (Doc.concat [Doc.text "lazy "; rhs]) | Pexp_open (_overrideFlag, _longidentLoc, _expr) -> - printExpressionBlock ~customLayout ~braces:true e cmtTbl + printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_pack modExpr -> - Doc.group - (Doc.concat - [ - Doc.text "module("; - Doc.indent - (Doc.concat - [ Doc.softLine; printModExpr ~customLayout modExpr cmtTbl ]); - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + Doc.text "module("; + Doc.indent + (Doc.concat + [Doc.softLine; printModExpr ~customLayout modExpr cmtTbl]); + Doc.softLine; + Doc.rparen; + ]) | Pexp_sequence _ -> - printExpressionBlock ~customLayout ~braces:true e cmtTbl + printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_let _ -> printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_fun ( Nolabel, None, - { ppat_desc = Ppat_var { txt = "__x" } }, - { pexp_desc = Pexp_apply _ } ) -> - (* (__x) => f(a, __x, c) -----> f(a, _, c) *) - printExpressionWithComments ~customLayout - (ParsetreeViewer.rewriteUnderscoreApply e) - cmtTbl + {ppat_desc = Ppat_var {txt = "__x"}}, + {pexp_desc = Pexp_apply _} ) -> + (* (__x) => f(a, __x, c) -----> f(a, _, c) *) + printExpressionWithComments ~customLayout + (ParsetreeViewer.rewriteUnderscoreApply e) + cmtTbl | Pexp_fun _ | Pexp_newtype _ -> - let attrsOnArrow, parameters, returnExpr = ParsetreeViewer.funExpr e in - let ParsetreeViewer.{ async; uncurried; attributes = attrs } = - ParsetreeViewer.processFunctionAttributes attrsOnArrow + let attrsOnArrow, parameters, returnExpr = ParsetreeViewer.funExpr e in + let ParsetreeViewer.{async; uncurried; attributes = attrs} = + ParsetreeViewer.processFunctionAttributes attrsOnArrow + in + let returnExpr, typConstraint = + match returnExpr.pexp_desc with + | Pexp_constraint (expr, typ) -> + ( { + expr with + pexp_attributes = + List.concat [expr.pexp_attributes; returnExpr.pexp_attributes]; + }, + Some typ ) + | _ -> (returnExpr, None) + in + let hasConstraint = + match typConstraint with + | Some _ -> true + | None -> false + in + let parametersDoc = + printExprFunParameters ~customLayout ~inCallback:NoCallback ~uncurried + ~async ~hasConstraint parameters cmtTbl + in + let returnExprDoc = + let optBraces, _ = ParsetreeViewer.processBracesAttr returnExpr in + let shouldInline = + match (returnExpr.pexp_desc, optBraces) with + | _, Some _ -> true + | ( ( Pexp_array _ | Pexp_tuple _ + | Pexp_construct (_, Some _) + | Pexp_record _ ), + _ ) -> + true + | _ -> false in - let returnExpr, typConstraint = + let shouldIndent = match returnExpr.pexp_desc with - | Pexp_constraint (expr, typ) -> - ( { - expr with - pexp_attributes = - List.concat - [ expr.pexp_attributes; returnExpr.pexp_attributes ]; - }, - Some typ ) - | _ -> (returnExpr, None) - in - let hasConstraint = - match typConstraint with Some _ -> true | None -> false - in - let parametersDoc = - printExprFunParameters ~customLayout ~inCallback:NoCallback ~uncurried - ~async ~hasConstraint parameters cmtTbl + | Pexp_sequence _ | Pexp_let _ | Pexp_letmodule _ + | Pexp_letexception _ | Pexp_open _ -> + false + | _ -> true in - let returnExprDoc = - let optBraces, _ = ParsetreeViewer.processBracesAttr returnExpr in - let shouldInline = - match (returnExpr.pexp_desc, optBraces) with - | _, Some _ -> true - | ( ( Pexp_array _ | Pexp_tuple _ - | Pexp_construct (_, Some _) - | Pexp_record _ ), - _ ) -> - true - | _ -> false - in - let shouldIndent = - match returnExpr.pexp_desc with - | Pexp_sequence _ | Pexp_let _ | Pexp_letmodule _ - | Pexp_letexception _ | Pexp_open _ -> - false - | _ -> true - in - let returnDoc = - let doc = - printExpressionWithComments ~customLayout returnExpr cmtTbl - in - match Parens.expr returnExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc returnExpr braces - | Nothing -> doc + let returnDoc = + let doc = + printExpressionWithComments ~customLayout returnExpr cmtTbl in - if shouldInline then Doc.concat [ Doc.space; returnDoc ] - else - Doc.group - (if shouldIndent then - Doc.indent (Doc.concat [ Doc.line; returnDoc ]) - else Doc.concat [ Doc.space; returnDoc ]) - in - let typConstraintDoc = - match typConstraint with - | Some typ -> - let typDoc = - let doc = printTypExpr ~customLayout typ cmtTbl in - if Parens.arrowReturnTypExpr typ then addParens doc else doc - in - Doc.concat [ Doc.text ": "; typDoc ] - | _ -> Doc.nil - in - let attrs = printAttributes ~customLayout attrs cmtTbl in - Doc.group - (Doc.concat - [ - attrs; - parametersDoc; - typConstraintDoc; - Doc.text " =>"; - returnExprDoc; - ]) - | Pexp_try (expr, cases) -> - let exprDoc = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with + match Parens.expr returnExpr with | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces + | Braced braces -> printBraces doc returnExpr braces | Nothing -> doc in - Doc.concat - [ - Doc.text "try "; - exprDoc; - Doc.text " catch "; - printCases ~customLayout cases cmtTbl; - ] - | Pexp_match (_, [ _; _ ]) when ParsetreeViewer.isIfLetExpr e -> - let ifs, elseExpr = ParsetreeViewer.collectIfExpressions e in - printIfChain ~customLayout e.pexp_attributes ifs elseExpr cmtTbl + if shouldInline then Doc.concat [Doc.space; returnDoc] + else + Doc.group + (if shouldIndent then Doc.indent (Doc.concat [Doc.line; returnDoc]) + else Doc.concat [Doc.space; returnDoc]) + in + let typConstraintDoc = + match typConstraint with + | Some typ -> + let typDoc = + let doc = printTypExpr ~customLayout typ cmtTbl in + if Parens.arrowReturnTypExpr typ then addParens doc else doc + in + Doc.concat [Doc.text ": "; typDoc] + | _ -> Doc.nil + in + let attrs = printAttributes ~customLayout attrs cmtTbl in + Doc.group + (Doc.concat + [ + attrs; + parametersDoc; + typConstraintDoc; + Doc.text " =>"; + returnExprDoc; + ]) + | Pexp_try (expr, cases) -> + let exprDoc = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat + [ + Doc.text "try "; + exprDoc; + Doc.text " catch "; + printCases ~customLayout cases cmtTbl; + ] + | Pexp_match (_, [_; _]) when ParsetreeViewer.isIfLetExpr e -> + let ifs, elseExpr = ParsetreeViewer.collectIfExpressions e in + printIfChain ~customLayout e.pexp_attributes ifs elseExpr cmtTbl | Pexp_match (expr, cases) -> - let exprDoc = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat - [ - Doc.text "switch "; - exprDoc; - Doc.space; - printCases ~customLayout cases cmtTbl; - ] + let exprDoc = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat + [ + Doc.text "switch "; + exprDoc; + Doc.space; + printCases ~customLayout cases cmtTbl; + ] | Pexp_function cases -> - Doc.concat - [ Doc.text "x => switch x "; printCases ~customLayout cases cmtTbl ] + Doc.concat + [Doc.text "x => switch x "; printCases ~customLayout cases cmtTbl] | Pexp_coerce (expr, typOpt, typ) -> - let docExpr = printExpressionWithComments ~customLayout expr cmtTbl in - let docTyp = printTypExpr ~customLayout typ cmtTbl in - let ofType = - match typOpt with - | None -> Doc.nil - | Some typ1 -> - Doc.concat - [ Doc.text ": "; printTypExpr ~customLayout typ1 cmtTbl ] - in - Doc.concat - [ Doc.lparen; docExpr; ofType; Doc.text " :> "; docTyp; Doc.rparen ] + let docExpr = printExpressionWithComments ~customLayout expr cmtTbl in + let docTyp = printTypExpr ~customLayout typ cmtTbl in + let ofType = + match typOpt with + | None -> Doc.nil + | Some typ1 -> + Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ1 cmtTbl] + in + Doc.concat + [Doc.lparen; docExpr; ofType; Doc.text " :> "; docTyp; Doc.rparen] | Pexp_send (parentExpr, label) -> - let parentDoc = - let doc = - printExpressionWithComments ~customLayout parentExpr cmtTbl - in - match Parens.unaryExprOperand parentExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces - | Nothing -> doc - in - let member = - let memberDoc = printComments (Doc.text label.txt) cmtTbl label.loc in - Doc.concat [ Doc.text "\""; memberDoc; Doc.text "\"" ] - in - Doc.group (Doc.concat [ parentDoc; Doc.lbracket; member; Doc.rbracket ]) + let parentDoc = + let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in + match Parens.unaryExprOperand parentExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc parentExpr braces + | Nothing -> doc + in + let member = + let memberDoc = printComments (Doc.text label.txt) cmtTbl label.loc in + Doc.concat [Doc.text "\""; memberDoc; Doc.text "\""] + in + Doc.group (Doc.concat [parentDoc; Doc.lbracket; member; Doc.rbracket]) | Pexp_new _ -> Doc.text "Pexp_new not impemented in printer" | Pexp_setinstvar _ -> Doc.text "Pexp_setinstvar not impemented in printer" | Pexp_override _ -> Doc.text "Pexp_override not impemented in printer" @@ -56522,7 +56441,7 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = pexp_attributes = List.filter (function - | { Location.txt = "res.await" | "ns.braces" }, _ -> false + | {Location.txt = "res.await" | "ns.braces"}, _ -> false | _ -> true) e.pexp_attributes; } @@ -56531,53 +56450,55 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = | Braced braces -> printBraces printedExpression e braces | Nothing -> printedExpression in - Doc.concat [ Doc.text "await "; rhs ] + Doc.concat [Doc.text "await "; rhs] else printedExpression in let shouldPrintItsOwnAttributes = match e.pexp_desc with | Pexp_apply _ | Pexp_fun _ | Pexp_newtype _ | Pexp_setfield _ | Pexp_ifthenelse _ -> - true + true | Pexp_match _ when ParsetreeViewer.isIfLetExpr e -> true | Pexp_construct _ when ParsetreeViewer.hasJsxAttribute e.pexp_attributes -> - true + true | _ -> false in match e.pexp_attributes with | [] -> exprWithAwait | attrs when not shouldPrintItsOwnAttributes -> - Doc.group - (Doc.concat - [ printAttributes ~customLayout attrs cmtTbl; exprWithAwait ]) + Doc.group + (Doc.concat [printAttributes ~customLayout attrs cmtTbl; exprWithAwait]) | _ -> exprWithAwait and printPexpFun ~customLayout ~inCallback e cmtTbl = let attrsOnArrow, parameters, returnExpr = ParsetreeViewer.funExpr e in - let ParsetreeViewer.{ async; uncurried; attributes = attrs } = + let ParsetreeViewer.{async; uncurried; attributes = attrs} = ParsetreeViewer.processFunctionAttributes attrsOnArrow in let returnExpr, typConstraint = match returnExpr.pexp_desc with | Pexp_constraint (expr, typ) -> - ( { - expr with - pexp_attributes = - List.concat [ expr.pexp_attributes; returnExpr.pexp_attributes ]; - }, - Some typ ) + ( { + expr with + pexp_attributes = + List.concat [expr.pexp_attributes; returnExpr.pexp_attributes]; + }, + Some typ ) | _ -> (returnExpr, None) in let parametersDoc = printExprFunParameters ~customLayout ~inCallback ~async ~uncurried - ~hasConstraint:(match typConstraint with Some _ -> true | None -> false) + ~hasConstraint: + (match typConstraint with + | Some _ -> true + | None -> false) parameters cmtTbl in let returnShouldIndent = match returnExpr.pexp_desc with | Pexp_sequence _ | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ -> - false + false | _ -> true in let returnExprDoc = @@ -56589,7 +56510,7 @@ and printPexpFun ~customLayout ~inCallback e cmtTbl = | Pexp_construct (_, Some _) | Pexp_record _ ), _ ) -> - true + true | _ -> false in let returnDoc = @@ -56599,23 +56520,23 @@ and printPexpFun ~customLayout ~inCallback e cmtTbl = | Braced braces -> printBraces doc returnExpr braces | Nothing -> doc in - if shouldInline then Doc.concat [ Doc.space; returnDoc ] + if shouldInline then Doc.concat [Doc.space; returnDoc] else Doc.group (if returnShouldIndent then Doc.concat [ - Doc.indent (Doc.concat [ Doc.line; returnDoc ]); + Doc.indent (Doc.concat [Doc.line; returnDoc]); (match inCallback with | FitsOnOneLine | ArgumentsFitOnOneLine -> Doc.softLine | _ -> Doc.nil); ] - else Doc.concat [ Doc.space; returnDoc ]) + else Doc.concat [Doc.space; returnDoc]) in let typConstraintDoc = match typConstraint with | Some typ -> - Doc.concat [ Doc.text ": "; printTypExpr ~customLayout typ cmtTbl ] + Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ cmtTbl] | _ -> Doc.nil in Doc.concat @@ -56659,16 +56580,15 @@ and printSetFieldExpr ~customLayout attrs lhs longidentLoc rhs loc cmtTbl = printLidentPath longidentLoc cmtTbl; Doc.text " ="; (if shouldIndent then - Doc.group (Doc.indent (Doc.concat [ Doc.line; rhsDoc ])) - else Doc.concat [ Doc.space; rhsDoc ]); + Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) + else Doc.concat [Doc.space; rhsDoc]); ]) in let doc = match attrs with | [] -> doc | attrs -> - Doc.group - (Doc.concat [ printAttributes ~customLayout attrs cmtTbl; doc ]) + Doc.group (Doc.concat [printAttributes ~customLayout attrs cmtTbl; doc]) in printComments doc cmtTbl loc @@ -56678,17 +56598,17 @@ and printTemplateLiteral ~customLayout expr cmtTbl = let open Parsetree in match expr.pexp_desc with | Pexp_apply - ( { pexp_desc = Pexp_ident { txt = Longident.Lident "^" } }, - [ (Nolabel, arg1); (Nolabel, arg2) ] ) -> - let lhs = walkExpr arg1 in - let rhs = walkExpr arg2 in - Doc.concat [ lhs; rhs ] + ( {pexp_desc = Pexp_ident {txt = Longident.Lident "^"}}, + [(Nolabel, arg1); (Nolabel, arg2)] ) -> + let lhs = walkExpr arg1 in + let rhs = walkExpr arg2 in + Doc.concat [lhs; rhs] | Pexp_constant (Pconst_string (txt, Some prefix)) -> - tag := prefix; - printStringContents txt + tag := prefix; + printStringContents txt | _ -> - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - Doc.group (Doc.concat [ Doc.text "${"; Doc.indent doc; Doc.rbrace ]) + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + Doc.group (Doc.concat [Doc.text "${"; Doc.indent doc; Doc.rbrace]) in let content = walkExpr expr in Doc.concat @@ -56712,17 +56632,17 @@ and printUnaryExpression ~customLayout expr cmtTbl = in match expr.pexp_desc with | Pexp_apply - ( { pexp_desc = Pexp_ident { txt = Longident.Lident operator } }, - [ (Nolabel, operand) ] ) -> - let printedOperand = - let doc = printExpressionWithComments ~customLayout operand cmtTbl in - match Parens.unaryExprOperand operand with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc operand braces - | Nothing -> doc - in - let doc = Doc.concat [ printUnaryOperator operator; printedOperand ] in - printComments doc cmtTbl expr.pexp_loc + ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, + [(Nolabel, operand)] ) -> + let printedOperand = + let doc = printExpressionWithComments ~customLayout operand cmtTbl in + match Parens.unaryExprOperand operand with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc operand braces + | Nothing -> doc + in + let doc = Doc.concat [printUnaryOperator operator; printedOperand] in + printComments doc cmtTbl expr.pexp_loc | _ -> assert false and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = @@ -56749,7 +56669,7 @@ and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = else Doc.line in Doc.concat - [ spacingBeforeOperator; Doc.text operatorTxt; spacingAfterOperator ] + [spacingBeforeOperator; Doc.text operatorTxt; spacingAfterOperator] in let printOperand ~isLhs expr parentOperator = let rec flatten ~isLhs expr parentOperator = @@ -56758,232 +56678,230 @@ and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = | { pexp_desc = Pexp_apply - ( { pexp_desc = Pexp_ident { txt = Longident.Lident operator } }, - [ (_, left); (_, right) ] ); + ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, + [(_, left); (_, right)] ); } -> - if - ParsetreeViewer.flattenableOperators parentOperator operator - && not (ParsetreeViewer.hasAttributes expr.pexp_attributes) - then - let leftPrinted = flatten ~isLhs:true left operator in - let rightPrinted = - let rightPrinteableAttrs, rightInternalAttrs = - ParsetreeViewer.partitionPrintableAttributes - right.pexp_attributes - in - let doc = - printExpressionWithComments ~customLayout - { right with pexp_attributes = rightInternalAttrs } - cmtTbl - in - let doc = - if Parens.flattenOperandRhs parentOperator right then - Doc.concat [ Doc.lparen; doc; Doc.rparen ] - else doc - in - let doc = - Doc.concat - [ - printAttributes ~customLayout rightPrinteableAttrs cmtTbl; - doc; - ] - in - match rightPrinteableAttrs with [] -> doc | _ -> addParens doc - in - let isAwait = - ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes - in - let doc = - if isAwait then - Doc.concat - [ - Doc.text "await "; - Doc.lparen; - leftPrinted; - printBinaryOperator ~inlineRhs:false operator; - rightPrinted; - Doc.rparen; - ] - else - Doc.concat - [ - leftPrinted; - printBinaryOperator ~inlineRhs:false operator; - rightPrinted; - ] - in - - let doc = - if (not isLhs) && Parens.rhsBinaryExprOperand operator expr then - Doc.concat [ Doc.lparen; doc; Doc.rparen ] - else doc - in - printComments doc cmtTbl expr.pexp_loc - else - let printeableAttrs, internalAttrs = + if + ParsetreeViewer.flattenableOperators parentOperator operator + && not (ParsetreeViewer.hasAttributes expr.pexp_attributes) + then + let leftPrinted = flatten ~isLhs:true left operator in + let rightPrinted = + let rightPrinteableAttrs, rightInternalAttrs = ParsetreeViewer.partitionPrintableAttributes - expr.pexp_attributes + right.pexp_attributes in let doc = printExpressionWithComments ~customLayout - { expr with pexp_attributes = internalAttrs } + {right with pexp_attributes = rightInternalAttrs} cmtTbl in let doc = - if - Parens.subBinaryExprOperand parentOperator operator - || printeableAttrs <> [] - && (ParsetreeViewer.isBinaryExpression expr - || ParsetreeViewer.isTernaryExpr expr) - then Doc.concat [ Doc.lparen; doc; Doc.rparen ] + if Parens.flattenOperandRhs parentOperator right then + Doc.concat [Doc.lparen; doc; Doc.rparen] else doc in - Doc.concat - [ printAttributes ~customLayout printeableAttrs cmtTbl; doc ] + let doc = + Doc.concat + [ + printAttributes ~customLayout rightPrinteableAttrs cmtTbl; + doc; + ] + in + match rightPrinteableAttrs with + | [] -> doc + | _ -> addParens doc + in + let isAwait = + ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes + in + let doc = + if isAwait then + Doc.concat + [ + Doc.text "await "; + Doc.lparen; + leftPrinted; + printBinaryOperator ~inlineRhs:false operator; + rightPrinted; + Doc.rparen; + ] + else + Doc.concat + [ + leftPrinted; + printBinaryOperator ~inlineRhs:false operator; + rightPrinted; + ] + in + + let doc = + if (not isLhs) && Parens.rhsBinaryExprOperand operator expr then + Doc.concat [Doc.lparen; doc; Doc.rparen] + else doc + in + printComments doc cmtTbl expr.pexp_loc + else + let printeableAttrs, internalAttrs = + ParsetreeViewer.partitionPrintableAttributes expr.pexp_attributes + in + let doc = + printExpressionWithComments ~customLayout + {expr with pexp_attributes = internalAttrs} + cmtTbl + in + let doc = + if + Parens.subBinaryExprOperand parentOperator operator + || printeableAttrs <> [] + && (ParsetreeViewer.isBinaryExpression expr + || ParsetreeViewer.isTernaryExpr expr) + then Doc.concat [Doc.lparen; doc; Doc.rparen] + else doc + in + Doc.concat + [printAttributes ~customLayout printeableAttrs cmtTbl; doc] | _ -> assert false else match expr.pexp_desc with | Pexp_apply - ( { pexp_desc = Pexp_ident { txt = Longident.Lident "^"; loc } }, - [ (Nolabel, _); (Nolabel, _) ] ) + ( {pexp_desc = Pexp_ident {txt = Longident.Lident "^"; loc}}, + [(Nolabel, _); (Nolabel, _)] ) when loc.loc_ghost -> - let doc = printTemplateLiteral ~customLayout expr cmtTbl in - printComments doc cmtTbl expr.Parsetree.pexp_loc + let doc = printTemplateLiteral ~customLayout expr cmtTbl in + printComments doc cmtTbl expr.Parsetree.pexp_loc | Pexp_setfield (lhs, field, rhs) -> - let doc = - printSetFieldExpr ~customLayout expr.pexp_attributes lhs field rhs - expr.pexp_loc cmtTbl - in - if isLhs then addParens doc else doc + let doc = + printSetFieldExpr ~customLayout expr.pexp_attributes lhs field rhs + expr.pexp_loc cmtTbl + in + if isLhs then addParens doc else doc | Pexp_apply - ( { pexp_desc = Pexp_ident { txt = Longident.Lident "#=" } }, - [ (Nolabel, lhs); (Nolabel, rhs) ] ) -> - let rhsDoc = printExpressionWithComments ~customLayout rhs cmtTbl in - let lhsDoc = printExpressionWithComments ~customLayout lhs cmtTbl in - (* TODO: unify indentation of "=" *) - let shouldIndent = ParsetreeViewer.isBinaryExpression rhs in - let doc = + ( {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}}, + [(Nolabel, lhs); (Nolabel, rhs)] ) -> + let rhsDoc = printExpressionWithComments ~customLayout rhs cmtTbl in + let lhsDoc = printExpressionWithComments ~customLayout lhs cmtTbl in + (* TODO: unify indentation of "=" *) + let shouldIndent = ParsetreeViewer.isBinaryExpression rhs in + let doc = + Doc.group + (Doc.concat + [ + lhsDoc; + Doc.text " ="; + (if shouldIndent then + Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) + else Doc.concat [Doc.space; rhsDoc]); + ]) + in + let doc = + match expr.pexp_attributes with + | [] -> doc + | attrs -> Doc.group - (Doc.concat - [ - lhsDoc; - Doc.text " ="; - (if shouldIndent then - Doc.group (Doc.indent (Doc.concat [ Doc.line; rhsDoc ])) - else Doc.concat [ Doc.space; rhsDoc ]); - ]) - in - let doc = - match expr.pexp_attributes with - | [] -> doc - | attrs -> - Doc.group - (Doc.concat - [ printAttributes ~customLayout attrs cmtTbl; doc ]) - in - if isLhs then addParens doc else doc + (Doc.concat [printAttributes ~customLayout attrs cmtTbl; doc]) + in + if isLhs then addParens doc else doc | _ -> ( - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.binaryExprOperand ~isLhs expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.binaryExprOperand ~isLhs expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) in flatten ~isLhs expr parentOperator in match expr.pexp_desc with | Pexp_apply - ( { - pexp_desc = Pexp_ident { txt = Longident.Lident (("|." | "|>") as op) }; - }, - [ (Nolabel, lhs); (Nolabel, rhs) ] ) + ( {pexp_desc = Pexp_ident {txt = Longident.Lident (("|." | "|>") as op)}}, + [(Nolabel, lhs); (Nolabel, rhs)] ) when not (ParsetreeViewer.isBinaryExpression lhs || ParsetreeViewer.isBinaryExpression rhs || printAttributes ~customLayout expr.pexp_attributes cmtTbl <> Doc.nil) -> - let lhsHasCommentBelow = hasCommentBelow cmtTbl lhs.pexp_loc in - let lhsDoc = printOperand ~isLhs:true lhs op in - let rhsDoc = printOperand ~isLhs:false rhs op in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - lhsDoc; - (match (lhsHasCommentBelow, op) with - | true, "|." -> Doc.concat [ Doc.softLine; Doc.text "->" ] - | false, "|." -> Doc.text "->" - | true, "|>" -> Doc.concat [ Doc.line; Doc.text "|> " ] - | false, "|>" -> Doc.text " |> " - | _ -> Doc.nil); - rhsDoc; - ]) + let lhsHasCommentBelow = hasCommentBelow cmtTbl lhs.pexp_loc in + let lhsDoc = printOperand ~isLhs:true lhs op in + let rhsDoc = printOperand ~isLhs:false rhs op in + Doc.group + (Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + lhsDoc; + (match (lhsHasCommentBelow, op) with + | true, "|." -> Doc.concat [Doc.softLine; Doc.text "->"] + | false, "|." -> Doc.text "->" + | true, "|>" -> Doc.concat [Doc.line; Doc.text "|> "] + | false, "|>" -> Doc.text " |> " + | _ -> Doc.nil); + rhsDoc; + ]) | Pexp_apply - ( { pexp_desc = Pexp_ident { txt = Longident.Lident operator } }, - [ (Nolabel, lhs); (Nolabel, rhs) ] ) -> - let right = - let operatorWithRhs = - let rhsDoc = printOperand ~isLhs:false rhs operator in - Doc.concat - [ - printBinaryOperator - ~inlineRhs:(ParsetreeViewer.shouldInlineRhsBinaryExpr rhs) - operator; - rhsDoc; - ] - in - if ParsetreeViewer.shouldIndentBinaryExpr expr then - Doc.group (Doc.indent operatorWithRhs) - else operatorWithRhs - in - let doc = - Doc.group (Doc.concat [ printOperand ~isLhs:true lhs operator; right ]) + ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, + [(Nolabel, lhs); (Nolabel, rhs)] ) -> + let right = + let operatorWithRhs = + let rhsDoc = printOperand ~isLhs:false rhs operator in + Doc.concat + [ + printBinaryOperator + ~inlineRhs:(ParsetreeViewer.shouldInlineRhsBinaryExpr rhs) + operator; + rhsDoc; + ] in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - (match - Parens.binaryExpr - { - expr with - pexp_attributes = - ParsetreeViewer.filterPrintableAttributes - expr.pexp_attributes; - } - with - | Braced bracesLoc -> printBraces doc expr bracesLoc - | Parenthesized -> addParens doc - | Nothing -> doc); - ]) + if ParsetreeViewer.shouldIndentBinaryExpr expr then + Doc.group (Doc.indent operatorWithRhs) + else operatorWithRhs + in + let doc = + Doc.group (Doc.concat [printOperand ~isLhs:true lhs operator; right]) + in + Doc.group + (Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + (match + Parens.binaryExpr + { + expr with + pexp_attributes = + ParsetreeViewer.filterPrintableAttributes + expr.pexp_attributes; + } + with + | Braced bracesLoc -> printBraces doc expr bracesLoc + | Parenthesized -> addParens doc + | Nothing -> doc); + ]) | _ -> Doc.nil and printBeltListConcatApply ~customLayout subLists cmtTbl = let makeSpreadDoc commaBeforeSpread = function | Some expr -> - Doc.concat - [ - commaBeforeSpread; - Doc.dotdotdot; - (let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); - ] + Doc.concat + [ + commaBeforeSpread; + Doc.dotdotdot; + (let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + ] | None -> Doc.nil in let makeSubListDoc (expressions, spread) = let commaBeforeSpread = match expressions with | [] -> Doc.nil - | _ -> Doc.concat [ Doc.text ","; Doc.line ] + | _ -> Doc.concat [Doc.text ","; Doc.line] in let spreadDoc = makeSpreadDoc commaBeforeSpread spread in Doc.concat [ Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) + ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map (fun expr -> let doc = @@ -57006,7 +56924,7 @@ and printBeltListConcatApply ~customLayout subLists cmtTbl = [ Doc.softLine; Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) + ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map makeSubListDoc (List.map ParsetreeViewer.collectListExpressions subLists)); ]); @@ -57019,243 +56937,228 @@ and printBeltListConcatApply ~customLayout subLists cmtTbl = and printPexpApply ~customLayout expr cmtTbl = match expr.pexp_desc with | Pexp_apply - ( { pexp_desc = Pexp_ident { txt = Longident.Lident "##" } }, - [ (Nolabel, parentExpr); (Nolabel, memberExpr) ] ) -> - let parentDoc = - let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces - | Nothing -> doc - in - let member = - let memberDoc = - match memberExpr.pexp_desc with - | Pexp_ident lident -> - printComments - (printLongident lident.txt) - cmtTbl memberExpr.pexp_loc - | _ -> printExpressionWithComments ~customLayout memberExpr cmtTbl - in - Doc.concat [ Doc.text "\""; memberDoc; Doc.text "\"" ] + ( {pexp_desc = Pexp_ident {txt = Longident.Lident "##"}}, + [(Nolabel, parentExpr); (Nolabel, memberExpr)] ) -> + let parentDoc = + let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in + match Parens.unaryExprOperand parentExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc parentExpr braces + | Nothing -> doc + in + let member = + let memberDoc = + match memberExpr.pexp_desc with + | Pexp_ident lident -> + printComments (printLongident lident.txt) cmtTbl memberExpr.pexp_loc + | _ -> printExpressionWithComments ~customLayout memberExpr cmtTbl in + Doc.concat [Doc.text "\""; memberDoc; Doc.text "\""] + in + Doc.group + (Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + parentDoc; + Doc.lbracket; + member; + Doc.rbracket; + ]) + | Pexp_apply + ( {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}}, + [(Nolabel, lhs); (Nolabel, rhs)] ) -> ( + let rhsDoc = + let doc = printExpressionWithComments ~customLayout rhs cmtTbl in + match Parens.expr rhs with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc rhs braces + | Nothing -> doc + in + (* TODO: unify indentation of "=" *) + let shouldIndent = + (not (ParsetreeViewer.isBracedExpr rhs)) + && ParsetreeViewer.isBinaryExpression rhs + in + let doc = Doc.group (Doc.concat [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - parentDoc; - Doc.lbracket; - member; - Doc.rbracket; + printExpressionWithComments ~customLayout lhs cmtTbl; + Doc.text " ="; + (if shouldIndent then + Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) + else Doc.concat [Doc.space; rhsDoc]); ]) + in + match expr.pexp_attributes with + | [] -> doc + | attrs -> + Doc.group (Doc.concat [printAttributes ~customLayout attrs cmtTbl; doc])) | Pexp_apply - ( { pexp_desc = Pexp_ident { txt = Longident.Lident "#=" } }, - [ (Nolabel, lhs); (Nolabel, rhs) ] ) -> ( - let rhsDoc = - let doc = printExpressionWithComments ~customLayout rhs cmtTbl in - match Parens.expr rhs with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc rhs braces - | Nothing -> doc - in - (* TODO: unify indentation of "=" *) - let shouldIndent = - (not (ParsetreeViewer.isBracedExpr rhs)) - && ParsetreeViewer.isBinaryExpression rhs - in - let doc = - Doc.group - (Doc.concat - [ - printExpressionWithComments ~customLayout lhs cmtTbl; - Doc.text " ="; - (if shouldIndent then - Doc.group (Doc.indent (Doc.concat [ Doc.line; rhsDoc ])) - else Doc.concat [ Doc.space; rhsDoc ]); - ]) - in - match expr.pexp_attributes with - | [] -> doc - | attrs -> - Doc.group - (Doc.concat [ printAttributes ~customLayout attrs cmtTbl; doc ])) - | Pexp_apply - ( { - pexp_desc = Pexp_ident { txt = Longident.Ldot (Lident "Array", "get") }; - }, - [ (Nolabel, parentExpr); (Nolabel, memberExpr) ] ) + ( {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "get")}}, + [(Nolabel, parentExpr); (Nolabel, memberExpr)] ) when not (ParsetreeViewer.isRewrittenUnderscoreApplySugar parentExpr) -> - (* Don't print the Array.get(_, 0) sugar a.k.a. (__x) => Array.get(__x, 0) as _[0] *) - let member = - let memberDoc = - let doc = - printExpressionWithComments ~customLayout memberExpr cmtTbl - in - match Parens.expr memberExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc memberExpr braces - | Nothing -> doc - in - let shouldInline = - match memberExpr.pexp_desc with - | Pexp_constant _ | Pexp_ident _ -> true - | _ -> false - in - if shouldInline then memberDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [ Doc.softLine; memberDoc ]); Doc.softLine; - ] - in - let parentDoc = - let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with + (* Don't print the Array.get(_, 0) sugar a.k.a. (__x) => Array.get(__x, 0) as _[0] *) + let member = + let memberDoc = + let doc = printExpressionWithComments ~customLayout memberExpr cmtTbl in + match Parens.expr memberExpr with | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces + | Braced braces -> printBraces doc memberExpr braces | Nothing -> doc in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - parentDoc; - Doc.lbracket; - member; - Doc.rbracket; - ]) - | Pexp_apply - ( { - pexp_desc = Pexp_ident { txt = Longident.Ldot (Lident "Array", "set") }; - }, - [ (Nolabel, parentExpr); (Nolabel, memberExpr); (Nolabel, targetExpr) ] - ) -> - let member = - let memberDoc = - let doc = - printExpressionWithComments ~customLayout memberExpr cmtTbl - in - match Parens.expr memberExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc memberExpr braces - | Nothing -> doc - in - let shouldInline = - match memberExpr.pexp_desc with - | Pexp_constant _ | Pexp_ident _ -> true - | _ -> false - in - if shouldInline then memberDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [ Doc.softLine; memberDoc ]); Doc.softLine; - ] - in - let shouldIndentTargetExpr = - if ParsetreeViewer.isBracedExpr targetExpr then false - else - ParsetreeViewer.isBinaryExpression targetExpr - || - match targetExpr with - | { - pexp_attributes = [ ({ Location.txt = "ns.ternary" }, _) ]; - pexp_desc = Pexp_ifthenelse (ifExpr, _, _); - } -> - ParsetreeViewer.isBinaryExpression ifExpr - || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes - | { pexp_desc = Pexp_newtype _ } -> false - | e -> - ParsetreeViewer.hasAttributes e.pexp_attributes - || ParsetreeViewer.isArrayAccess e + let shouldInline = + match memberExpr.pexp_desc with + | Pexp_constant _ | Pexp_ident _ -> true + | _ -> false in - let targetExpr = - let doc = printExpressionWithComments ~customLayout targetExpr cmtTbl in - match Parens.expr targetExpr with + if shouldInline then memberDoc + else + Doc.concat + [Doc.indent (Doc.concat [Doc.softLine; memberDoc]); Doc.softLine] + in + let parentDoc = + let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in + match Parens.unaryExprOperand parentExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc parentExpr braces + | Nothing -> doc + in + Doc.group + (Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + parentDoc; + Doc.lbracket; + member; + Doc.rbracket; + ]) + | Pexp_apply + ( {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "set")}}, + [(Nolabel, parentExpr); (Nolabel, memberExpr); (Nolabel, targetExpr)] ) + -> + let member = + let memberDoc = + let doc = printExpressionWithComments ~customLayout memberExpr cmtTbl in + match Parens.expr memberExpr with | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc targetExpr braces + | Braced braces -> printBraces doc memberExpr braces | Nothing -> doc in - let parentDoc = - let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces - | Nothing -> doc + let shouldInline = + match memberExpr.pexp_desc with + | Pexp_constant _ | Pexp_ident _ -> true + | _ -> false in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - parentDoc; - Doc.lbracket; - member; - Doc.rbracket; - Doc.text " ="; - (if shouldIndentTargetExpr then - Doc.indent (Doc.concat [ Doc.line; targetExpr ]) - else Doc.concat [ Doc.space; targetExpr ]); - ]) + if shouldInline then memberDoc + else + Doc.concat + [Doc.indent (Doc.concat [Doc.softLine; memberDoc]); Doc.softLine] + in + let shouldIndentTargetExpr = + if ParsetreeViewer.isBracedExpr targetExpr then false + else + ParsetreeViewer.isBinaryExpression targetExpr + || + match targetExpr with + | { + pexp_attributes = [({Location.txt = "ns.ternary"}, _)]; + pexp_desc = Pexp_ifthenelse (ifExpr, _, _); + } -> + ParsetreeViewer.isBinaryExpression ifExpr + || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes + | {pexp_desc = Pexp_newtype _} -> false + | e -> + ParsetreeViewer.hasAttributes e.pexp_attributes + || ParsetreeViewer.isArrayAccess e + in + let targetExpr = + let doc = printExpressionWithComments ~customLayout targetExpr cmtTbl in + match Parens.expr targetExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc targetExpr braces + | Nothing -> doc + in + let parentDoc = + let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in + match Parens.unaryExprOperand parentExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc parentExpr braces + | Nothing -> doc + in + Doc.group + (Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + parentDoc; + Doc.lbracket; + member; + Doc.rbracket; + Doc.text " ="; + (if shouldIndentTargetExpr then + Doc.indent (Doc.concat [Doc.line; targetExpr]) + else Doc.concat [Doc.space; targetExpr]); + ]) (* TODO: cleanup, are those branches even remotely performant? *) - | Pexp_apply ({ pexp_desc = Pexp_ident lident }, args) + | Pexp_apply ({pexp_desc = Pexp_ident lident}, args) when ParsetreeViewer.isJsxExpression expr -> - printJsxExpression ~customLayout lident args cmtTbl + printJsxExpression ~customLayout lident args cmtTbl | Pexp_apply (callExpr, args) -> - let args = - List.map - (fun (lbl, arg) -> (lbl, ParsetreeViewer.rewriteUnderscoreApply arg)) - args + let args = + List.map + (fun (lbl, arg) -> (lbl, ParsetreeViewer.rewriteUnderscoreApply arg)) + args + in + let uncurried, attrs = + ParsetreeViewer.processUncurriedAttribute expr.pexp_attributes + in + let callExprDoc = + let doc = printExpressionWithComments ~customLayout callExpr cmtTbl in + match Parens.callExpr callExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc callExpr braces + | Nothing -> doc + in + if ParsetreeViewer.requiresSpecialCallbackPrintingFirstArg args then + let argsDoc = + printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args + cmtTbl in - let uncurried, attrs = - ParsetreeViewer.processUncurriedAttribute expr.pexp_attributes + Doc.concat + [printAttributes ~customLayout attrs cmtTbl; callExprDoc; argsDoc] + else if ParsetreeViewer.requiresSpecialCallbackPrintingLastArg args then + let argsDoc = + printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args + cmtTbl in - let callExprDoc = - let doc = printExpressionWithComments ~customLayout callExpr cmtTbl in - match Parens.callExpr callExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc callExpr braces - | Nothing -> doc + (* + * Fixes the following layout (the `[` and `]` should break): + * [fn(x => { + * let _ = x + * }), fn(y => { + * let _ = y + * }), fn(z => { + * let _ = z + * })] + * See `Doc.willBreak documentation in interface file for more context. + * Context: + * https://github.com/rescript-lang/syntax/issues/111 + * https://github.com/rescript-lang/syntax/issues/166 + *) + let maybeBreakParent = + if Doc.willBreak argsDoc then Doc.breakParent else Doc.nil in - if ParsetreeViewer.requiresSpecialCallbackPrintingFirstArg args then - let argsDoc = - printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout - args cmtTbl - in - Doc.concat - [ printAttributes ~customLayout attrs cmtTbl; callExprDoc; argsDoc ] - else if ParsetreeViewer.requiresSpecialCallbackPrintingLastArg args then - let argsDoc = - printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args - cmtTbl - in - (* - * Fixes the following layout (the `[` and `]` should break): - * [fn(x => { - * let _ = x - * }), fn(y => { - * let _ = y - * }), fn(z => { - * let _ = z - * })] - * See `Doc.willBreak documentation in interface file for more context. - * Context: - * https://github.com/rescript-lang/syntax/issues/111 - * https://github.com/rescript-lang/syntax/issues/166 - *) - let maybeBreakParent = - if Doc.willBreak argsDoc then Doc.breakParent else Doc.nil - in - Doc.concat - [ - maybeBreakParent; - printAttributes ~customLayout attrs cmtTbl; - callExprDoc; - argsDoc; - ] - else - let argsDoc = printArguments ~customLayout ~uncurried args cmtTbl in - Doc.concat - [ printAttributes ~customLayout attrs cmtTbl; callExprDoc; argsDoc ] + Doc.concat + [ + maybeBreakParent; + printAttributes ~customLayout attrs cmtTbl; + callExprDoc; + argsDoc; + ] + else + let argsDoc = printArguments ~customLayout ~uncurried args cmtTbl in + Doc.concat + [printAttributes ~customLayout attrs cmtTbl; callExprDoc; argsDoc] | _ -> assert false and printJsxExpression ~customLayout lident args cmtTbl = @@ -57267,9 +57170,9 @@ and printJsxExpression ~customLayout lident args cmtTbl = | Some { Parsetree.pexp_desc = - Pexp_construct ({ txt = Longident.Lident "[]" }, None); + Pexp_construct ({txt = Longident.Lident "[]"}, None); } -> - false + false | None -> false | _ -> true in @@ -57278,17 +57181,17 @@ and printJsxExpression ~customLayout lident args cmtTbl = | Some { Parsetree.pexp_desc = - Pexp_construct ({ txt = Longident.Lident "[]" }, None); + Pexp_construct ({txt = Longident.Lident "[]"}, None); pexp_loc = loc; } -> - not (hasCommentsInside cmtTbl loc) + not (hasCommentsInside cmtTbl loc) | _ -> false in let printChildren children = let lineSep = match children with | Some expr -> - if hasNestedJsxOrMoreThanOneChild expr then Doc.hardLine else Doc.line + if hasNestedJsxOrMoreThanOneChild expr then Doc.hardLine else Doc.line | None -> Doc.line in Doc.concat @@ -57299,8 +57202,8 @@ and printJsxExpression ~customLayout lident args cmtTbl = Doc.line; (match children with | Some childrenExpression -> - printJsxChildren ~customLayout childrenExpression - ~sep:lineSep cmtTbl + printJsxChildren ~customLayout childrenExpression ~sep:lineSep + cmtTbl | None -> Doc.nil); ]); lineSep; @@ -57313,27 +57216,27 @@ and printJsxExpression ~customLayout lident args cmtTbl = (Doc.concat [ printComments - (Doc.concat [ Doc.lessThan; name ]) + (Doc.concat [Doc.lessThan; name]) cmtTbl lident.Asttypes.loc; formattedProps; (match children with | Some { Parsetree.pexp_desc = - Pexp_construct ({ txt = Longident.Lident "[]" }, None); + Pexp_construct ({txt = Longident.Lident "[]"}, None); } when isSelfClosing -> - Doc.text "/>" + Doc.text "/>" | _ -> - (* if tag A has trailing comments then put > on the next line - - - *) - if hasTrailingComments cmtTbl lident.Asttypes.loc then - Doc.concat [ Doc.softLine; Doc.greaterThan ] - else Doc.greaterThan); + (* if tag A has trailing comments then put > on the next line + + + *) + if hasTrailingComments cmtTbl lident.Asttypes.loc then + Doc.concat [Doc.softLine; Doc.greaterThan] + else Doc.greaterThan); ]); (if isSelfClosing then Doc.nil else @@ -57345,10 +57248,10 @@ and printJsxExpression ~customLayout lident args cmtTbl = | Some { Parsetree.pexp_desc = - Pexp_construct ({ txt = Longident.Lident "[]" }, None); + Pexp_construct ({txt = Longident.Lident "[]"}, None); pexp_loc = loc; } -> - printCommentsInside cmtTbl loc + printCommentsInside cmtTbl loc | _ -> Doc.nil); Doc.text " Doc.nil + | Pexp_construct ({txt = Longident.Lident "[]"}, None) -> Doc.nil | _ -> - Doc.indent - (Doc.concat - [ - Doc.line; - printJsxChildren ~customLayout expr ~sep:lineSep cmtTbl; - ])); + Doc.indent + (Doc.concat + [ + Doc.line; + printJsxChildren ~customLayout expr ~sep:lineSep cmtTbl; + ])); lineSep; closing; ]) @@ -57382,53 +57285,52 @@ and printJsxFragment ~customLayout expr cmtTbl = and printJsxChildren ~customLayout (childrenExpr : Parsetree.expression) ~sep cmtTbl = match childrenExpr.pexp_desc with - | Pexp_construct ({ txt = Longident.Lident "::" }, _) -> - let children, _ = ParsetreeViewer.collectListExpressions childrenExpr in - Doc.group - (Doc.join ~sep - (List.map - (fun (expr : Parsetree.expression) -> - let leadingLineCommentPresent = - hasLeadingLineComment cmtTbl expr.pexp_loc - in - let exprDoc = - printExpressionWithComments ~customLayout expr cmtTbl - in - let addParensOrBraces exprDoc = - (* {(20: int)} make sure that we also protect the expression inside *) - let innerDoc = - if Parens.bracedExpr expr then addParens exprDoc - else exprDoc - in - if leadingLineCommentPresent then addBraces innerDoc - else Doc.concat [ Doc.lbrace; innerDoc; Doc.rbrace ] + | Pexp_construct ({txt = Longident.Lident "::"}, _) -> + let children, _ = ParsetreeViewer.collectListExpressions childrenExpr in + Doc.group + (Doc.join ~sep + (List.map + (fun (expr : Parsetree.expression) -> + let leadingLineCommentPresent = + hasLeadingLineComment cmtTbl expr.pexp_loc + in + let exprDoc = + printExpressionWithComments ~customLayout expr cmtTbl + in + let addParensOrBraces exprDoc = + (* {(20: int)} make sure that we also protect the expression inside *) + let innerDoc = + if Parens.bracedExpr expr then addParens exprDoc else exprDoc in - match Parens.jsxChildExpr expr with - | Nothing -> exprDoc - | Parenthesized -> addParensOrBraces exprDoc - | Braced bracesLoc -> - printComments (addParensOrBraces exprDoc) cmtTbl bracesLoc) - children)) - | _ -> - let leadingLineCommentPresent = - hasLeadingLineComment cmtTbl childrenExpr.pexp_loc - in - let exprDoc = - printExpressionWithComments ~customLayout childrenExpr cmtTbl - in - Doc.concat - [ - Doc.dotdotdot; - (match Parens.jsxChildExpr childrenExpr with - | Parenthesized | Braced _ -> - let innerDoc = - if Parens.bracedExpr childrenExpr then addParens exprDoc - else exprDoc + if leadingLineCommentPresent then addBraces innerDoc + else Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace] in - if leadingLineCommentPresent then addBraces innerDoc - else Doc.concat [ Doc.lbrace; innerDoc; Doc.rbrace ] - | Nothing -> exprDoc); - ] + match Parens.jsxChildExpr expr with + | Nothing -> exprDoc + | Parenthesized -> addParensOrBraces exprDoc + | Braced bracesLoc -> + printComments (addParensOrBraces exprDoc) cmtTbl bracesLoc) + children)) + | _ -> + let leadingLineCommentPresent = + hasLeadingLineComment cmtTbl childrenExpr.pexp_loc + in + let exprDoc = + printExpressionWithComments ~customLayout childrenExpr cmtTbl + in + Doc.concat + [ + Doc.dotdotdot; + (match Parens.jsxChildExpr childrenExpr with + | Parenthesized | Braced _ -> + let innerDoc = + if Parens.bracedExpr childrenExpr then addParens exprDoc + else exprDoc + in + if leadingLineCommentPresent then addBraces innerDoc + else Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace] + | Nothing -> exprDoc); + ] and printJsxProps ~customLayout args cmtTbl : Doc.t * Parsetree.expression option = @@ -57447,10 +57349,10 @@ and printJsxProps ~customLayout args cmtTbl : let isSelfClosing children = match children with | { - Parsetree.pexp_desc = Pexp_construct ({ txt = Longident.Lident "[]" }, None); + Parsetree.pexp_desc = Pexp_construct ({txt = Longident.Lident "[]"}, None); pexp_loc = loc; } -> - not (hasCommentsInside cmtTbl loc) + not (hasCommentsInside cmtTbl loc) | _ -> false in let rec loop props args = @@ -57461,50 +57363,50 @@ and printJsxProps ~customLayout args cmtTbl : ( Asttypes.Nolabel, { Parsetree.pexp_desc = - Pexp_construct ({ txt = Longident.Lident "()" }, None); + Pexp_construct ({txt = Longident.Lident "()"}, None); } ); ] -> - let doc = if isSelfClosing children then Doc.line else Doc.nil in - (doc, Some children) + let doc = if isSelfClosing children then Doc.line else Doc.nil in + (doc, Some children) | ((_, expr) as lastProp) :: [ (Asttypes.Labelled "children", children); ( Asttypes.Nolabel, { Parsetree.pexp_desc = - Pexp_construct ({ txt = Longident.Lident "()" }, None); + Pexp_construct ({txt = Longident.Lident "()"}, None); } ); ] -> - let loc = - match expr.Parsetree.pexp_attributes with - | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _attrs -> - { loc with loc_end = expr.pexp_loc.loc_end } - | _ -> expr.pexp_loc - in - let trailingCommentsPresent = hasTrailingComments cmtTbl loc in - let propDoc = printJsxProp ~customLayout lastProp cmtTbl in - let formattedProps = - Doc.concat - [ - Doc.indent - (Doc.concat - [ - Doc.line; - Doc.group - (Doc.join ~sep:Doc.line (propDoc :: props |> List.rev)); - ]); - (* print > on new line if the last prop has trailing comments *) - (match (isSelfClosing children, trailingCommentsPresent) with - (* we always put /> on a new line when a self-closing tag breaks *) - | true, _ -> Doc.line - | false, true -> Doc.softLine - | false, false -> Doc.nil); - ] - in - (formattedProps, Some children) + let loc = + match expr.Parsetree.pexp_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _attrs -> + {loc with loc_end = expr.pexp_loc.loc_end} + | _ -> expr.pexp_loc + in + let trailingCommentsPresent = hasTrailingComments cmtTbl loc in + let propDoc = printJsxProp ~customLayout lastProp cmtTbl in + let formattedProps = + Doc.concat + [ + Doc.indent + (Doc.concat + [ + Doc.line; + Doc.group + (Doc.join ~sep:Doc.line (propDoc :: props |> List.rev)); + ]); + (* print > on new line if the last prop has trailing comments *) + (match (isSelfClosing children, trailingCommentsPresent) with + (* we always put /> on a new line when a self-closing tag breaks *) + | true, _ -> Doc.line + | false, true -> Doc.softLine + | false, false -> Doc.nil); + ] + in + (formattedProps, Some children) | arg :: args -> - let propDoc = printJsxProp ~customLayout arg cmtTbl in - loop (propDoc :: props) args + let propDoc = printJsxProp ~customLayout arg cmtTbl in + loop (propDoc :: props) args in loop [] args @@ -57513,81 +57415,79 @@ and printJsxProp ~customLayout arg cmtTbl = | ( ((Asttypes.Labelled lblTxt | Optional lblTxt) as lbl), { Parsetree.pexp_attributes = - [ ({ Location.txt = "ns.namedArgLoc"; loc = argLoc }, _) ]; - pexp_desc = Pexp_ident { txt = Longident.Lident ident }; + [({Location.txt = "ns.namedArgLoc"; loc = argLoc}, _)]; + pexp_desc = Pexp_ident {txt = Longident.Lident ident}; } ) when lblTxt = ident (* jsx punning *) -> ( - match lbl with - | Nolabel -> Doc.nil - | Labelled _lbl -> printComments (printIdentLike ident) cmtTbl argLoc - | Optional _lbl -> - let doc = Doc.concat [ Doc.question; printIdentLike ident ] in - printComments doc cmtTbl argLoc) + match lbl with + | Nolabel -> Doc.nil + | Labelled _lbl -> printComments (printIdentLike ident) cmtTbl argLoc + | Optional _lbl -> + let doc = Doc.concat [Doc.question; printIdentLike ident] in + printComments doc cmtTbl argLoc) | ( ((Asttypes.Labelled lblTxt | Optional lblTxt) as lbl), { Parsetree.pexp_attributes = []; - pexp_desc = Pexp_ident { txt = Longident.Lident ident }; + pexp_desc = Pexp_ident {txt = Longident.Lident ident}; } ) when lblTxt = ident (* jsx punning when printing from Reason *) -> ( - match lbl with - | Nolabel -> Doc.nil - | Labelled _lbl -> printIdentLike ident - | Optional _lbl -> Doc.concat [ Doc.question; printIdentLike ident ]) + match lbl with + | Nolabel -> Doc.nil + | Labelled _lbl -> printIdentLike ident + | Optional _lbl -> Doc.concat [Doc.question; printIdentLike ident]) | Asttypes.Labelled "_spreadProps", expr -> - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - Doc.concat [ Doc.lbrace; Doc.dotdotdot; Doc.softLine; doc; Doc.rbrace ] + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + Doc.concat [Doc.lbrace; Doc.dotdotdot; Doc.softLine; doc; Doc.rbrace] | lbl, expr -> - let argLoc, expr = - match expr.pexp_attributes with - | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: attrs -> - (loc, { expr with pexp_attributes = attrs }) - | _ -> (Location.none, expr) - in - let lblDoc = - match lbl with - | Asttypes.Labelled lbl -> - let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in - Doc.concat [ lbl; Doc.equal ] - | Asttypes.Optional lbl -> - let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in - Doc.concat [ lbl; Doc.equal; Doc.question ] - | Nolabel -> Doc.nil - in - let exprDoc = - let leadingLineCommentPresent = - hasLeadingLineComment cmtTbl expr.pexp_loc - in - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.jsxPropExpr expr with - | Parenthesized | Braced _ -> - (* {(20: int)} make sure that we also protect the expression inside *) - let innerDoc = - if Parens.bracedExpr expr then addParens doc else doc - in - if leadingLineCommentPresent then addBraces innerDoc - else Doc.concat [ Doc.lbrace; innerDoc; Doc.rbrace ] - | _ -> doc + let argLoc, expr = + match expr.pexp_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: attrs -> + (loc, {expr with pexp_attributes = attrs}) + | _ -> (Location.none, expr) + in + let lblDoc = + match lbl with + | Asttypes.Labelled lbl -> + let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in + Doc.concat [lbl; Doc.equal] + | Asttypes.Optional lbl -> + let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in + Doc.concat [lbl; Doc.equal; Doc.question] + | Nolabel -> Doc.nil + in + let exprDoc = + let leadingLineCommentPresent = + hasLeadingLineComment cmtTbl expr.pexp_loc in - let fullLoc = { argLoc with loc_end = expr.pexp_loc.loc_end } in - printComments (Doc.concat [ lblDoc; exprDoc ]) cmtTbl fullLoc + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.jsxPropExpr expr with + | Parenthesized | Braced _ -> + (* {(20: int)} make sure that we also protect the expression inside *) + let innerDoc = if Parens.bracedExpr expr then addParens doc else doc in + if leadingLineCommentPresent then addBraces innerDoc + else Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace] + | _ -> doc + in + let fullLoc = {argLoc with loc_end = expr.pexp_loc.loc_end} in + printComments (Doc.concat [lblDoc; exprDoc]) cmtTbl fullLoc (* div -> div. * Navabar.createElement -> Navbar * Staff.Users.createElement -> Staff.Users *) -and printJsxName { txt = lident } = +and printJsxName {txt = lident} = let rec flatten acc lident = match lident with | Longident.Lident txt -> txt :: acc | Ldot (lident, txt) -> - let acc = if txt = "createElement" then acc else txt :: acc in - flatten acc lident + let acc = if txt = "createElement" then acc else txt :: acc in + flatten acc lident | _ -> acc in match lident with | Longident.Lident txt -> Doc.text txt | _ as lident -> - let segments = flatten [] lident in - Doc.join ~sep:Doc.dot (List.map Doc.text segments) + let segments = flatten [] lident in + Doc.join ~sep:Doc.dot (List.map Doc.text segments) and printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args cmtTbl = @@ -57599,32 +57499,29 @@ and printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args let callback, printedArgs = match args with | (lbl, expr) :: args -> - let lblDoc = - match lbl with - | Asttypes.Nolabel -> Doc.nil - | Asttypes.Labelled txt -> - Doc.concat [ Doc.tilde; printIdentLike txt; Doc.equal ] - | Asttypes.Optional txt -> - Doc.concat - [ Doc.tilde; printIdentLike txt; Doc.equal; Doc.question ] - in - let callback = - Doc.concat - [ - lblDoc; - printPexpFun ~customLayout ~inCallback:FitsOnOneLine expr cmtTbl; - ] - in - let callback = lazy (printComments callback cmtTbl expr.pexp_loc) in - let printedArgs = - lazy - (Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun arg -> printArgument ~customLayout arg cmtTbl) - args)) - in - (callback, printedArgs) + let lblDoc = + match lbl with + | Asttypes.Nolabel -> Doc.nil + | Asttypes.Labelled txt -> + Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal] + | Asttypes.Optional txt -> + Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal; Doc.question] + in + let callback = + Doc.concat + [ + lblDoc; + printPexpFun ~customLayout ~inCallback:FitsOnOneLine expr cmtTbl; + ] + in + let callback = lazy (printComments callback cmtTbl expr.pexp_loc) in + let printedArgs = + lazy + (Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map (fun arg -> printArgument ~customLayout arg cmtTbl) args)) + in + (callback, printedArgs) | _ -> assert false in @@ -57674,7 +57571,7 @@ and printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args *) if customLayout > customLayoutThreshold then Lazy.force breakAllArgs else if Doc.willBreak (Lazy.force printedArgs) then Lazy.force breakAllArgs - else Doc.customLayout [ Lazy.force fitsOnOneLine; Lazy.force breakAllArgs ] + else Doc.customLayout [Lazy.force fitsOnOneLine; Lazy.force breakAllArgs] and printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args cmtTbl = @@ -57687,39 +57584,38 @@ and printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args let rec loop acc args = match args with | [] -> (lazy Doc.nil, lazy Doc.nil, lazy Doc.nil) - | [ (lbl, expr) ] -> - let lblDoc = - match lbl with - | Asttypes.Nolabel -> Doc.nil - | Asttypes.Labelled txt -> - Doc.concat [ Doc.tilde; printIdentLike txt; Doc.equal ] - | Asttypes.Optional txt -> - Doc.concat - [ Doc.tilde; printIdentLike txt; Doc.equal; Doc.question ] - in - let callbackFitsOnOneLine = - lazy - (let pexpFunDoc = - printPexpFun ~customLayout ~inCallback:FitsOnOneLine expr cmtTbl - in - let doc = Doc.concat [ lblDoc; pexpFunDoc ] in - printComments doc cmtTbl expr.pexp_loc) - in - let callbackArgumentsFitsOnOneLine = - lazy - (let pexpFunDoc = - printPexpFun ~customLayout ~inCallback:ArgumentsFitOnOneLine expr - cmtTblCopy - in - let doc = Doc.concat [ lblDoc; pexpFunDoc ] in - printComments doc cmtTblCopy expr.pexp_loc) - in - ( lazy (Doc.concat (List.rev acc)), - callbackFitsOnOneLine, - callbackArgumentsFitsOnOneLine ) + | [(lbl, expr)] -> + let lblDoc = + match lbl with + | Asttypes.Nolabel -> Doc.nil + | Asttypes.Labelled txt -> + Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal] + | Asttypes.Optional txt -> + Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal; Doc.question] + in + let callbackFitsOnOneLine = + lazy + (let pexpFunDoc = + printPexpFun ~customLayout ~inCallback:FitsOnOneLine expr cmtTbl + in + let doc = Doc.concat [lblDoc; pexpFunDoc] in + printComments doc cmtTbl expr.pexp_loc) + in + let callbackArgumentsFitsOnOneLine = + lazy + (let pexpFunDoc = + printPexpFun ~customLayout ~inCallback:ArgumentsFitOnOneLine expr + cmtTblCopy + in + let doc = Doc.concat [lblDoc; pexpFunDoc] in + printComments doc cmtTblCopy expr.pexp_loc) + in + ( lazy (Doc.concat (List.rev acc)), + callbackFitsOnOneLine, + callbackArgumentsFitsOnOneLine ) | arg :: args -> - let argDoc = printArgument ~customLayout arg cmtTbl in - loop (Doc.line :: Doc.comma :: argDoc :: acc) args + let argDoc = printArgument ~customLayout arg cmtTbl in + loop (Doc.line :: Doc.comma :: argDoc :: acc) args in let printedArgs, callback, callback2 = loop [] args in @@ -57792,48 +57688,46 @@ and printArguments ~customLayout ~uncurried | [ ( Nolabel, { - pexp_desc = Pexp_construct ({ txt = Longident.Lident "()" }, _); + pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _); pexp_loc = loc; } ); ] -> ( - (* See "parseCallExpr", ghost unit expression is used the implement - * arity zero vs arity one syntax. - * Related: https://github.com/rescript-lang/syntax/issues/138 *) - match (uncurried, loc.loc_ghost) with - | true, true -> Doc.text "(.)" (* arity zero *) - | true, false -> Doc.text "(. ())" (* arity one *) - | _ -> Doc.text "()") - | [ (Nolabel, arg) ] when ParsetreeViewer.isHuggableExpression arg -> - let argDoc = - let doc = printExpressionWithComments ~customLayout arg cmtTbl in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc - in - Doc.concat - [ - (if uncurried then Doc.text "(. " else Doc.lparen); argDoc; Doc.rparen; - ] + (* See "parseCallExpr", ghost unit expression is used the implement + * arity zero vs arity one syntax. + * Related: https://github.com/rescript-lang/syntax/issues/138 *) + match (uncurried, loc.loc_ghost) with + | true, true -> Doc.text "(.)" (* arity zero *) + | true, false -> Doc.text "(. ())" (* arity one *) + | _ -> Doc.text "()") + | [(Nolabel, arg)] when ParsetreeViewer.isHuggableExpression arg -> + let argDoc = + let doc = printExpressionWithComments ~customLayout arg cmtTbl in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc + in + Doc.concat + [(if uncurried then Doc.text "(. " else Doc.lparen); argDoc; Doc.rparen] | args -> - Doc.group - (Doc.concat - [ - (if uncurried then Doc.text "(." else Doc.lparen); - Doc.indent - (Doc.concat - [ - (if uncurried then Doc.line else Doc.softLine); - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun arg -> printArgument ~customLayout arg cmtTbl) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + (if uncurried then Doc.text "(." else Doc.lparen); + Doc.indent + (Doc.concat + [ + (if uncurried then Doc.line else Doc.softLine); + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun arg -> printArgument ~customLayout arg cmtTbl) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) (* * argument ::= @@ -57854,90 +57748,88 @@ and printArgument ~customLayout (argLbl, arg) cmtTbl = (* ~a (punned)*) | ( Asttypes.Labelled lbl, ({ - pexp_desc = Pexp_ident { txt = Longident.Lident name }; - pexp_attributes = [] | [ ({ Location.txt = "ns.namedArgLoc" }, _) ]; + pexp_desc = Pexp_ident {txt = Longident.Lident name}; + pexp_attributes = [] | [({Location.txt = "ns.namedArgLoc"}, _)]; } as argExpr) ) when lbl = name && not (ParsetreeViewer.isBracedExpr argExpr) -> - let loc = - match arg.pexp_attributes with - | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _ -> loc - | _ -> arg.pexp_loc - in - let doc = Doc.concat [ Doc.tilde; printIdentLike lbl ] in - printComments doc cmtTbl loc + let loc = + match arg.pexp_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> loc + | _ -> arg.pexp_loc + in + let doc = Doc.concat [Doc.tilde; printIdentLike lbl] in + printComments doc cmtTbl loc (* ~a: int (punned)*) | ( Asttypes.Labelled lbl, { pexp_desc = Pexp_constraint - ( ({ pexp_desc = Pexp_ident { txt = Longident.Lident name } } as - argExpr), + ( ({pexp_desc = Pexp_ident {txt = Longident.Lident name}} as argExpr), typ ); pexp_loc; pexp_attributes = - ([] | [ ({ Location.txt = "ns.namedArgLoc" }, _) ]) as attrs; + ([] | [({Location.txt = "ns.namedArgLoc"}, _)]) as attrs; } ) when lbl = name && not (ParsetreeViewer.isBracedExpr argExpr) -> - let loc = - match attrs with - | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _ -> - { loc with loc_end = pexp_loc.loc_end } - | _ -> arg.pexp_loc - in - let doc = - Doc.concat - [ - Doc.tilde; - printIdentLike lbl; - Doc.text ": "; - printTypExpr ~customLayout typ cmtTbl; - ] - in - printComments doc cmtTbl loc + let loc = + match attrs with + | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> + {loc with loc_end = pexp_loc.loc_end} + | _ -> arg.pexp_loc + in + let doc = + Doc.concat + [ + Doc.tilde; + printIdentLike lbl; + Doc.text ": "; + printTypExpr ~customLayout typ cmtTbl; + ] + in + printComments doc cmtTbl loc (* ~a? (optional lbl punned)*) | ( Asttypes.Optional lbl, { - pexp_desc = Pexp_ident { txt = Longident.Lident name }; - pexp_attributes = [] | [ ({ Location.txt = "ns.namedArgLoc" }, _) ]; + pexp_desc = Pexp_ident {txt = Longident.Lident name}; + pexp_attributes = [] | [({Location.txt = "ns.namedArgLoc"}, _)]; } ) when lbl = name -> - let loc = - match arg.pexp_attributes with - | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _ -> loc - | _ -> arg.pexp_loc - in - let doc = Doc.concat [ Doc.tilde; printIdentLike lbl; Doc.question ] in - printComments doc cmtTbl loc + let loc = + match arg.pexp_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> loc + | _ -> arg.pexp_loc + in + let doc = Doc.concat [Doc.tilde; printIdentLike lbl; Doc.question] in + printComments doc cmtTbl loc | _lbl, expr -> - let argLoc, expr = - match expr.pexp_attributes with - | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: attrs -> - (loc, { expr with pexp_attributes = attrs }) - | _ -> (expr.pexp_loc, expr) - in - let printedLbl = - match argLbl with - | Asttypes.Nolabel -> Doc.nil - | Asttypes.Labelled lbl -> - let doc = Doc.concat [ Doc.tilde; printIdentLike lbl; Doc.equal ] in - printComments doc cmtTbl argLoc - | Asttypes.Optional lbl -> - let doc = - Doc.concat - [ Doc.tilde; printIdentLike lbl; Doc.equal; Doc.question ] - in - printComments doc cmtTbl argLoc - in - let printedExpr = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - let loc = { argLoc with loc_end = expr.pexp_loc.loc_end } in - let doc = Doc.concat [ printedLbl; printedExpr ] in - printComments doc cmtTbl loc + let argLoc, expr = + match expr.pexp_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: attrs -> + (loc, {expr with pexp_attributes = attrs}) + | _ -> (expr.pexp_loc, expr) + in + let printedLbl = + match argLbl with + | Asttypes.Nolabel -> Doc.nil + | Asttypes.Labelled lbl -> + let doc = Doc.concat [Doc.tilde; printIdentLike lbl; Doc.equal] in + printComments doc cmtTbl argLoc + | Asttypes.Optional lbl -> + let doc = + Doc.concat [Doc.tilde; printIdentLike lbl; Doc.equal; Doc.question] + in + printComments doc cmtTbl argLoc + in + let printedExpr = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + let loc = {argLoc with loc_end = expr.pexp_loc.loc_end} in + let doc = Doc.concat [printedLbl; printedExpr] in + printComments doc cmtTbl loc and printCases ~customLayout (cases : Parsetree.case list) cmtTbl = Doc.breakableGroup ~forceBreak:true @@ -57964,40 +57856,40 @@ and printCase ~customLayout (case : Parsetree.case) cmtTbl = match case.pc_rhs.pexp_desc with | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ | Pexp_sequence _ -> - printExpressionBlock ~customLayout - ~braces:(ParsetreeViewer.isBracedExpr case.pc_rhs) - case.pc_rhs cmtTbl + printExpressionBlock ~customLayout + ~braces:(ParsetreeViewer.isBracedExpr case.pc_rhs) + case.pc_rhs cmtTbl | _ -> ( - let doc = - printExpressionWithComments ~customLayout case.pc_rhs cmtTbl - in - match Parens.expr case.pc_rhs with - | Parenthesized -> addParens doc - | _ -> doc) + let doc = printExpressionWithComments ~customLayout case.pc_rhs cmtTbl in + match Parens.expr case.pc_rhs with + | Parenthesized -> addParens doc + | _ -> doc) in let guard = match case.pc_guard with | None -> Doc.nil | Some expr -> - Doc.group - (Doc.concat - [ - Doc.line; - Doc.text "if "; - printExpressionWithComments ~customLayout expr cmtTbl; - ]) + Doc.group + (Doc.concat + [ + Doc.line; + Doc.text "if "; + printExpressionWithComments ~customLayout expr cmtTbl; + ]) in let shouldInlineRhs = match case.pc_rhs.pexp_desc with - | Pexp_construct ({ txt = Longident.Lident ("()" | "true" | "false") }, _) + | Pexp_construct ({txt = Longident.Lident ("()" | "true" | "false")}, _) | Pexp_constant _ | Pexp_ident _ -> - true + true | _ when ParsetreeViewer.isHuggableRhs case.pc_rhs -> true | _ -> false in let shouldIndentPattern = - match case.pc_lhs.ppat_desc with Ppat_or _ -> false | _ -> true + match case.pc_lhs.ppat_desc with + | Ppat_or _ -> false + | _ -> true in let patternDoc = let doc = printPattern ~customLayout case.pc_lhs cmtTbl in @@ -58012,11 +57904,10 @@ and printCase ~customLayout (case : Parsetree.case) cmtTbl = Doc.indent guard; Doc.text " =>"; Doc.indent - (Doc.concat - [ (if shouldInlineRhs then Doc.space else Doc.line); rhs ]); + (Doc.concat [(if shouldInlineRhs then Doc.space else Doc.line); rhs]); ] in - Doc.group (Doc.concat [ Doc.text "| "; content ]) + Doc.group (Doc.concat [Doc.text "| "; content]) and printExprFunParameters ~customLayout ~inCallback ~async ~uncurried ~hasConstraint parameters cmtTbl = @@ -58028,15 +57919,15 @@ and printExprFunParameters ~customLayout ~inCallback ~async ~uncurried attrs = []; lbl = Asttypes.Nolabel; defaultExpr = None; - pat = { Parsetree.ppat_desc = Ppat_any; ppat_loc }; + pat = {Parsetree.ppat_desc = Ppat_any; ppat_loc}; }; ] when not uncurried -> - let any = - let doc = if hasConstraint then Doc.text "(_)" else Doc.text "_" in - printComments doc cmtTbl ppat_loc - in - if async then addAsync any else any + let any = + let doc = if hasConstraint then Doc.text "(_)" else Doc.text "_" in + printComments doc cmtTbl ppat_loc + in + if async then addAsync any else any (* let f = a => () *) | [ ParsetreeViewer.Parameter @@ -58044,16 +57935,16 @@ and printExprFunParameters ~customLayout ~inCallback ~async ~uncurried attrs = []; lbl = Asttypes.Nolabel; defaultExpr = None; - pat = { Parsetree.ppat_desc = Ppat_var stringLoc }; + pat = {Parsetree.ppat_desc = Ppat_var stringLoc}; }; ] when not uncurried -> - let txtDoc = - let var = printIdentLike stringLoc.txt in - let var = if hasConstraint then addParens var else var in - if async then addAsync var else var - in - printComments txtDoc cmtTbl stringLoc.loc + let txtDoc = + let var = printIdentLike stringLoc.txt in + let var = if hasConstraint then addParens var else var in + if async then addAsync var else var + in + printComments txtDoc cmtTbl stringLoc.loc (* let f = () => () *) | [ ParsetreeViewer.Parameter @@ -58062,264 +57953,250 @@ and printExprFunParameters ~customLayout ~inCallback ~async ~uncurried lbl = Asttypes.Nolabel; defaultExpr = None; pat = - { - ppat_desc = - Ppat_construct ({ txt = Longident.Lident "()"; loc }, None); - }; + {ppat_desc = Ppat_construct ({txt = Longident.Lident "()"; loc}, None)}; }; ] when not uncurried -> - let doc = - let lparenRparen = Doc.text "()" in - if async then addAsync lparenRparen else lparenRparen - in - printComments doc cmtTbl loc + let doc = + let lparenRparen = Doc.text "()" in + if async then addAsync lparenRparen else lparenRparen + in + printComments doc cmtTbl loc (* let f = (~greeting, ~from as hometown, ~x=?) => () *) | parameters -> - let inCallback = - match inCallback with FitsOnOneLine -> true | _ -> false - in - let maybeAsyncLparen = - let lparen = if uncurried then Doc.text "(. " else Doc.lparen in - if async then addAsync lparen else lparen - in - let shouldHug = ParsetreeViewer.parametersShouldHug parameters in - let printedParamaters = - Doc.concat - [ - (if shouldHug || inCallback then Doc.nil else Doc.softLine); - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun p -> printExpFunParameter ~customLayout p cmtTbl) - parameters); - ] - in - Doc.group - (Doc.concat - [ - maybeAsyncLparen; - (if shouldHug || inCallback then printedParamaters - else - Doc.concat - [ - Doc.indent printedParamaters; Doc.trailingComma; Doc.softLine; - ]); - Doc.rparen; - ]) + let inCallback = + match inCallback with + | FitsOnOneLine -> true + | _ -> false + in + let maybeAsyncLparen = + let lparen = if uncurried then Doc.text "(. " else Doc.lparen in + if async then addAsync lparen else lparen + in + let shouldHug = ParsetreeViewer.parametersShouldHug parameters in + let printedParamaters = + Doc.concat + [ + (if shouldHug || inCallback then Doc.nil else Doc.softLine); + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun p -> printExpFunParameter ~customLayout p cmtTbl) + parameters); + ] + in + Doc.group + (Doc.concat + [ + maybeAsyncLparen; + (if shouldHug || inCallback then printedParamaters + else + Doc.concat + [Doc.indent printedParamaters; Doc.trailingComma; Doc.softLine]); + Doc.rparen; + ]) and printExpFunParameter ~customLayout parameter cmtTbl = match parameter with - | ParsetreeViewer.NewTypes { attrs; locs = lbls } -> + | ParsetreeViewer.NewTypes {attrs; locs = lbls} -> + Doc.group + (Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + Doc.text "type "; + Doc.join ~sep:Doc.space + (List.map + (fun lbl -> + printComments + (printIdentLike lbl.Asttypes.txt) + cmtTbl lbl.Asttypes.loc) + lbls); + ]) + | Parameter {attrs; lbl; defaultExpr; pat = pattern} -> + let isUncurried, attrs = ParsetreeViewer.processUncurriedAttribute attrs in + let uncurried = + if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil + in + let attrs = printAttributes ~customLayout attrs cmtTbl in + (* =defaultValue *) + let defaultExprDoc = + match defaultExpr with + | Some expr -> + Doc.concat + [Doc.text "="; printExpressionWithComments ~customLayout expr cmtTbl] + | None -> Doc.nil + in + (* ~from as hometown + * ~from -> punning *) + let labelWithPattern = + match (lbl, pattern) with + | Asttypes.Nolabel, pattern -> printPattern ~customLayout pattern cmtTbl + | ( (Asttypes.Labelled lbl | Optional lbl), + { + ppat_desc = Ppat_var stringLoc; + ppat_attributes = [] | [({Location.txt = "ns.namedArgLoc"}, _)]; + } ) + when lbl = stringLoc.txt -> + (* ~d *) + Doc.concat [Doc.text "~"; printIdentLike lbl] + | ( (Asttypes.Labelled lbl | Optional lbl), + { + ppat_desc = Ppat_constraint ({ppat_desc = Ppat_var {txt}}, typ); + ppat_attributes = [] | [({Location.txt = "ns.namedArgLoc"}, _)]; + } ) + when lbl = txt -> + (* ~d: e *) + Doc.concat + [ + Doc.text "~"; + printIdentLike lbl; + Doc.text ": "; + printTypExpr ~customLayout typ cmtTbl; + ] + | (Asttypes.Labelled lbl | Optional lbl), pattern -> + (* ~b as c *) + Doc.concat + [ + Doc.text "~"; + printIdentLike lbl; + Doc.text " as "; + printPattern ~customLayout pattern cmtTbl; + ] + in + let optionalLabelSuffix = + match (lbl, defaultExpr) with + | Asttypes.Optional _, None -> Doc.text "=?" + | _ -> Doc.nil + in + let doc = Doc.group (Doc.concat [ - printAttributes ~customLayout attrs cmtTbl; - Doc.text "type "; - Doc.join ~sep:Doc.space - (List.map - (fun lbl -> - printComments - (printIdentLike lbl.Asttypes.txt) - cmtTbl lbl.Asttypes.loc) - lbls); + uncurried; + attrs; + labelWithPattern; + defaultExprDoc; + optionalLabelSuffix; ]) - | Parameter { attrs; lbl; defaultExpr; pat = pattern } -> - let isUncurried, attrs = - ParsetreeViewer.processUncurriedAttribute attrs - in - let uncurried = - if isUncurried then Doc.concat [ Doc.dot; Doc.space ] else Doc.nil - in - let attrs = printAttributes ~customLayout attrs cmtTbl in - (* =defaultValue *) - let defaultExprDoc = - match defaultExpr with - | Some expr -> - Doc.concat - [ - Doc.text "="; - printExpressionWithComments ~customLayout expr cmtTbl; - ] - | None -> Doc.nil - in - (* ~from as hometown - * ~from -> punning *) - let labelWithPattern = - match (lbl, pattern) with - | Asttypes.Nolabel, pattern -> printPattern ~customLayout pattern cmtTbl - | ( (Asttypes.Labelled lbl | Optional lbl), - { - ppat_desc = Ppat_var stringLoc; - ppat_attributes = - [] | [ ({ Location.txt = "ns.namedArgLoc" }, _) ]; - } ) - when lbl = stringLoc.txt -> - (* ~d *) - Doc.concat [ Doc.text "~"; printIdentLike lbl ] - | ( (Asttypes.Labelled lbl | Optional lbl), - { - ppat_desc = Ppat_constraint ({ ppat_desc = Ppat_var { txt } }, typ); - ppat_attributes = - [] | [ ({ Location.txt = "ns.namedArgLoc" }, _) ]; - } ) - when lbl = txt -> - (* ~d: e *) - Doc.concat - [ - Doc.text "~"; - printIdentLike lbl; - Doc.text ": "; - printTypExpr ~customLayout typ cmtTbl; - ] - | (Asttypes.Labelled lbl | Optional lbl), pattern -> - (* ~b as c *) - Doc.concat - [ - Doc.text "~"; - printIdentLike lbl; - Doc.text " as "; - printPattern ~customLayout pattern cmtTbl; - ] - in - let optionalLabelSuffix = - match (lbl, defaultExpr) with - | Asttypes.Optional _, None -> Doc.text "=?" - | _ -> Doc.nil - in - let doc = - Doc.group - (Doc.concat - [ - uncurried; - attrs; - labelWithPattern; - defaultExprDoc; - optionalLabelSuffix; - ]) - in - let cmtLoc = - match defaultExpr with - | None -> ( - match pattern.ppat_attributes with - | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _ -> - { loc with loc_end = pattern.ppat_loc.loc_end } - | _ -> pattern.ppat_loc) - | Some expr -> - let startPos = - match pattern.ppat_attributes with - | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _ -> - loc.loc_start - | _ -> pattern.ppat_loc.loc_start - in - { - pattern.ppat_loc with - loc_start = startPos; - loc_end = expr.pexp_loc.loc_end; - } - in - printComments doc cmtTbl cmtLoc + in + let cmtLoc = + match defaultExpr with + | None -> ( + match pattern.ppat_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> + {loc with loc_end = pattern.ppat_loc.loc_end} + | _ -> pattern.ppat_loc) + | Some expr -> + let startPos = + match pattern.ppat_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> loc.loc_start + | _ -> pattern.ppat_loc.loc_start + in + { + pattern.ppat_loc with + loc_start = startPos; + loc_end = expr.pexp_loc.loc_end; + } + in + printComments doc cmtTbl cmtLoc and printExpressionBlock ~customLayout ~braces expr cmtTbl = let rec collectRows acc expr = match expr.Parsetree.pexp_desc with | Parsetree.Pexp_letmodule (modName, modExpr, expr2) -> - let name = - let doc = Doc.text modName.txt in - printComments doc cmtTbl modName.loc - in - let letModuleDoc = - Doc.concat - [ - Doc.text "module "; - name; - Doc.text " = "; - printModExpr ~customLayout modExpr cmtTbl; - ] - in - let loc = { expr.pexp_loc with loc_end = modExpr.pmod_loc.loc_end } in - collectRows ((loc, letModuleDoc) :: acc) expr2 + let name = + let doc = Doc.text modName.txt in + printComments doc cmtTbl modName.loc + in + let letModuleDoc = + Doc.concat + [ + Doc.text "module "; + name; + Doc.text " = "; + printModExpr ~customLayout modExpr cmtTbl; + ] + in + let loc = {expr.pexp_loc with loc_end = modExpr.pmod_loc.loc_end} in + collectRows ((loc, letModuleDoc) :: acc) expr2 | Pexp_letexception (extensionConstructor, expr2) -> + let loc = let loc = - let loc = - { - expr.pexp_loc with - loc_end = extensionConstructor.pext_loc.loc_end; - } - in - match getFirstLeadingComment cmtTbl loc with - | None -> loc - | Some comment -> - let cmtLoc = Comment.loc comment in - { cmtLoc with loc_end = loc.loc_end } - in - let letExceptionDoc = - printExceptionDef ~customLayout extensionConstructor cmtTbl + {expr.pexp_loc with loc_end = extensionConstructor.pext_loc.loc_end} in - collectRows ((loc, letExceptionDoc) :: acc) expr2 + match getFirstLeadingComment cmtTbl loc with + | None -> loc + | Some comment -> + let cmtLoc = Comment.loc comment in + {cmtLoc with loc_end = loc.loc_end} + in + let letExceptionDoc = + printExceptionDef ~customLayout extensionConstructor cmtTbl + in + collectRows ((loc, letExceptionDoc) :: acc) expr2 | Pexp_open (overrideFlag, longidentLoc, expr2) -> - let openDoc = - Doc.concat - [ - Doc.text "open"; - printOverrideFlag overrideFlag; - Doc.space; - printLongidentLocation longidentLoc cmtTbl; - ] - in - let loc = { expr.pexp_loc with loc_end = longidentLoc.loc.loc_end } in - collectRows ((loc, openDoc) :: acc) expr2 + let openDoc = + Doc.concat + [ + Doc.text "open"; + printOverrideFlag overrideFlag; + Doc.space; + printLongidentLocation longidentLoc cmtTbl; + ] + in + let loc = {expr.pexp_loc with loc_end = longidentLoc.loc.loc_end} in + collectRows ((loc, openDoc) :: acc) expr2 | Pexp_sequence (expr1, expr2) -> - let exprDoc = - let doc = printExpression ~customLayout expr1 cmtTbl in - match Parens.expr expr1 with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr1 braces - | Nothing -> doc - in - let loc = expr1.pexp_loc in - collectRows ((loc, exprDoc) :: acc) expr2 + let exprDoc = + let doc = printExpression ~customLayout expr1 cmtTbl in + match Parens.expr expr1 with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr1 braces + | Nothing -> doc + in + let loc = expr1.pexp_loc in + collectRows ((loc, exprDoc) :: acc) expr2 | Pexp_let (recFlag, valueBindings, expr2) -> ( + let loc = let loc = - let loc = - match (valueBindings, List.rev valueBindings) with - | vb :: _, lastVb :: _ -> - { vb.pvb_loc with loc_end = lastVb.pvb_loc.loc_end } - | _ -> Location.none - in - match getFirstLeadingComment cmtTbl loc with - | None -> loc - | Some comment -> - let cmtLoc = Comment.loc comment in - { cmtLoc with loc_end = loc.loc_end } - in - let recFlag = - match recFlag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - let letDoc = - printValueBindings ~customLayout ~recFlag valueBindings cmtTbl + match (valueBindings, List.rev valueBindings) with + | vb :: _, lastVb :: _ -> + {vb.pvb_loc with loc_end = lastVb.pvb_loc.loc_end} + | _ -> Location.none in - (* let () = { - * let () = foo() - * () - * } - * We don't need to print the () on the last line of the block - *) - match expr2.pexp_desc with - | Pexp_construct ({ txt = Longident.Lident "()" }, _) -> - List.rev ((loc, letDoc) :: acc) - | _ -> collectRows ((loc, letDoc) :: acc) expr2) + match getFirstLeadingComment cmtTbl loc with + | None -> loc + | Some comment -> + let cmtLoc = Comment.loc comment in + {cmtLoc with loc_end = loc.loc_end} + in + let recFlag = + match recFlag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + let letDoc = + printValueBindings ~customLayout ~recFlag valueBindings cmtTbl + in + (* let () = { + * let () = foo() + * () + * } + * We don't need to print the () on the last line of the block + *) + match expr2.pexp_desc with + | Pexp_construct ({txt = Longident.Lident "()"}, _) -> + List.rev ((loc, letDoc) :: acc) + | _ -> collectRows ((loc, letDoc) :: acc) expr2) | _ -> - let exprDoc = - let doc = printExpression ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - List.rev ((expr.pexp_loc, exprDoc) :: acc) + let exprDoc = + let doc = printExpression ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + List.rev ((expr.pexp_loc, exprDoc) :: acc) in let rows = collectRows [] expr in let block = @@ -58332,7 +58209,7 @@ and printExpressionBlock ~customLayout ~braces expr cmtTbl = Doc.concat [ Doc.lbrace; - Doc.indent (Doc.concat [ Doc.line; block ]); + Doc.indent (Doc.concat [Doc.line; block]); Doc.line; Doc.rbrace; ] @@ -58363,25 +58240,27 @@ and printBraces doc expr bracesLoc = match expr.Parsetree.pexp_desc with | Pexp_letmodule _ | Pexp_letexception _ | Pexp_let _ | Pexp_open _ | Pexp_sequence _ -> - (* already has braces *) - doc + (* already has braces *) + doc | _ -> - Doc.breakableGroup ~forceBreak:overMultipleLines - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - (if Parens.bracedExpr expr then addParens doc else doc); - ]); - Doc.softLine; - Doc.rbrace; - ]) + Doc.breakableGroup ~forceBreak:overMultipleLines + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.softLine; + (if Parens.bracedExpr expr then addParens doc else doc); + ]); + Doc.softLine; + Doc.rbrace; + ]) and printOverrideFlag overrideFlag = - match overrideFlag with Asttypes.Override -> Doc.text "!" | Fresh -> Doc.nil + match overrideFlag with + | Asttypes.Override -> Doc.text "!" + | Fresh -> Doc.nil and printDirectionFlag flag = match flag with @@ -58389,41 +58268,39 @@ and printDirectionFlag flag = | Asttypes.Upto -> Doc.text " to " and printExpressionRecordRow ~customLayout (lbl, expr) cmtTbl punningAllowed = - let cmtLoc = { lbl.loc with loc_end = expr.pexp_loc.loc_end } in + let cmtLoc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in let doc = Doc.group (match expr.pexp_desc with - | Pexp_ident { txt = Lident key; loc = _keyLoc } + | Pexp_ident {txt = Lident key; loc = _keyLoc} when punningAllowed && Longident.last lbl.txt = key -> - (* print punned field *) - Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - printOptionalLabel expr.pexp_attributes; - printLidentPath lbl cmtTbl; - ] + (* print punned field *) + Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + printOptionalLabel expr.pexp_attributes; + printLidentPath lbl cmtTbl; + ] | _ -> - Doc.concat - [ - printLidentPath lbl cmtTbl; - Doc.text ": "; - printOptionalLabel expr.pexp_attributes; - (let doc = - printExpressionWithComments ~customLayout expr cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); - ]) + Doc.concat + [ + printLidentPath lbl cmtTbl; + Doc.text ": "; + printOptionalLabel expr.pexp_attributes; + (let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + ]) in printComments doc cmtTbl cmtLoc and printBsObjectRow ~customLayout (lbl, expr) cmtTbl = - let cmtLoc = { lbl.loc with loc_end = expr.pexp_loc.loc_end } in + let cmtLoc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in let lblDoc = let doc = - Doc.concat [ Doc.text "\""; printLongident lbl.txt; Doc.text "\"" ] + Doc.concat [Doc.text "\""; printLongident lbl.txt; Doc.text "\""] in printComments doc cmtTbl lbl.loc in @@ -58452,80 +58329,46 @@ and printAttributes ?loc ?(inline = false) ~customLayout match ParsetreeViewer.filterParsingAttrs attrs with | [] -> Doc.nil | attrs -> - let lineBreak = - match loc with - | None -> Doc.line - | Some loc -> ( - match List.rev attrs with - | ({ loc = firstLoc }, _) :: _ - when loc.loc_start.pos_lnum > firstLoc.loc_end.pos_lnum -> - Doc.hardLine - | _ -> Doc.line) - in - Doc.concat - [ - Doc.group - (Doc.joinWithSep - (List.map - (fun attr -> printAttribute ~customLayout attr cmtTbl) - attrs)); - (if inline then Doc.space else lineBreak); - ] + let lineBreak = + match loc with + | None -> Doc.line + | Some loc -> ( + match List.rev attrs with + | ({loc = firstLoc}, _) :: _ + when loc.loc_start.pos_lnum > firstLoc.loc_end.pos_lnum -> + Doc.hardLine + | _ -> Doc.line) + in + Doc.concat + [ + Doc.group + (Doc.joinWithSep + (List.map + (fun attr -> printAttribute ~customLayout attr cmtTbl) + attrs)); + (if inline then Doc.space else lineBreak); + ] and printPayload ~customLayout (payload : Parsetree.payload) cmtTbl = match payload with | PStr [] -> Doc.nil - | PStr [ { pstr_desc = Pstr_eval (expr, attrs) } ] -> - let exprDoc = printExpressionWithComments ~customLayout expr cmtTbl in - let needsParens = match attrs with [] -> false | _ -> true in - let shouldHug = ParsetreeViewer.isHuggableExpression expr in - if shouldHug then - Doc.concat - [ - Doc.lparen; - printAttributes ~customLayout attrs cmtTbl; - (if needsParens then addParens exprDoc else exprDoc); - Doc.rparen; - ] - else - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - printAttributes ~customLayout attrs cmtTbl; - (if needsParens then addParens exprDoc else exprDoc); - ]); - Doc.softLine; - Doc.rparen; - ] - | PStr [ ({ pstr_desc = Pstr_value (_recFlag, _bindings) } as si) ] -> - addParens (printStructureItem ~customLayout si cmtTbl) - | PStr structure -> addParens (printStructure ~customLayout structure cmtTbl) - | PTyp typ -> + | PStr [{pstr_desc = Pstr_eval (expr, attrs)}] -> + let exprDoc = printExpressionWithComments ~customLayout expr cmtTbl in + let needsParens = + match attrs with + | [] -> false + | _ -> true + in + let shouldHug = ParsetreeViewer.isHuggableExpression expr in + if shouldHug then Doc.concat [ Doc.lparen; - Doc.text ":"; - Doc.indent - (Doc.concat [ Doc.line; printTypExpr ~customLayout typ cmtTbl ]); - Doc.softLine; + printAttributes ~customLayout attrs cmtTbl; + (if needsParens then addParens exprDoc else exprDoc); Doc.rparen; ] - | PPat (pat, optExpr) -> - let whenDoc = - match optExpr with - | Some expr -> - Doc.concat - [ - Doc.line; - Doc.text "if "; - printExpressionWithComments ~customLayout expr cmtTbl; - ] - | None -> Doc.nil - in + else Doc.concat [ Doc.lparen; @@ -58533,193 +58376,217 @@ and printPayload ~customLayout (payload : Parsetree.payload) cmtTbl = (Doc.concat [ Doc.softLine; - Doc.text "? "; - printPattern ~customLayout pat cmtTbl; - whenDoc; + printAttributes ~customLayout attrs cmtTbl; + (if needsParens then addParens exprDoc else exprDoc); ]); Doc.softLine; Doc.rparen; ] + | PStr [({pstr_desc = Pstr_value (_recFlag, _bindings)} as si)] -> + addParens (printStructureItem ~customLayout si cmtTbl) + | PStr structure -> addParens (printStructure ~customLayout structure cmtTbl) + | PTyp typ -> + Doc.concat + [ + Doc.lparen; + Doc.text ":"; + Doc.indent + (Doc.concat [Doc.line; printTypExpr ~customLayout typ cmtTbl]); + Doc.softLine; + Doc.rparen; + ] + | PPat (pat, optExpr) -> + let whenDoc = + match optExpr with + | Some expr -> + Doc.concat + [ + Doc.line; + Doc.text "if "; + printExpressionWithComments ~customLayout expr cmtTbl; + ] + | None -> Doc.nil + in + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.text "? "; + printPattern ~customLayout pat cmtTbl; + whenDoc; + ]); + Doc.softLine; + Doc.rparen; + ] | PSig signature -> - Doc.concat - [ - Doc.lparen; - Doc.text ":"; - Doc.indent - (Doc.concat - [ Doc.line; printSignature ~customLayout signature cmtTbl ]); - Doc.softLine; - Doc.rparen; - ] + Doc.concat + [ + Doc.lparen; + Doc.text ":"; + Doc.indent + (Doc.concat [Doc.line; printSignature ~customLayout signature cmtTbl]); + Doc.softLine; + Doc.rparen; + ] and printAttribute ?(standalone = false) ~customLayout ((id, payload) : Parsetree.attribute) cmtTbl = match (id, payload) with - | ( { txt = "ns.doc" }, + | ( {txt = "ns.doc"}, PStr [ { pstr_desc = - Pstr_eval - ({ pexp_desc = Pexp_constant (Pconst_string (txt, _)) }, _); + Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (txt, _))}, _); }; ] ) -> - ( Doc.concat - [ - Doc.text (if standalone then "/***" else "/**"); - Doc.text txt; - Doc.text "*/"; - ], - Doc.hardLine ) + ( Doc.concat + [ + Doc.text (if standalone then "/***" else "/**"); + Doc.text txt; + Doc.text "*/"; + ], + Doc.hardLine ) | _ -> - ( Doc.group - (Doc.concat - [ - Doc.text (if standalone then "@@" else "@"); - Doc.text (convertBsExternalAttribute id.txt); - printPayload ~customLayout payload cmtTbl; - ]), - Doc.line ) + ( Doc.group + (Doc.concat + [ + Doc.text (if standalone then "@@" else "@"); + Doc.text (convertBsExternalAttribute id.txt); + printPayload ~customLayout payload cmtTbl; + ]), + Doc.line ) and printModExpr ~customLayout modExpr cmtTbl = let doc = match modExpr.pmod_desc with | Pmod_ident longidentLoc -> printLongidentLocation longidentLoc cmtTbl | Pmod_structure [] -> - let shouldBreak = - modExpr.pmod_loc.loc_start.pos_lnum - < modExpr.pmod_loc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak:shouldBreak - (Doc.concat - [ - Doc.lbrace; - printCommentsInside cmtTbl modExpr.pmod_loc; - Doc.rbrace; - ]) + let shouldBreak = + modExpr.pmod_loc.loc_start.pos_lnum < modExpr.pmod_loc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak:shouldBreak + (Doc.concat + [Doc.lbrace; printCommentsInside cmtTbl modExpr.pmod_loc; Doc.rbrace]) | Pmod_structure structure -> - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - printStructure ~customLayout structure cmtTbl; - ]); - Doc.softLine; - Doc.rbrace; - ]) + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [Doc.softLine; printStructure ~customLayout structure cmtTbl]); + Doc.softLine; + Doc.rbrace; + ]) | Pmod_unpack expr -> - let shouldHug = - match expr.pexp_desc with - | Pexp_let _ -> true - | Pexp_constraint - ( { pexp_desc = Pexp_let _ }, - { ptyp_desc = Ptyp_package _packageType } ) -> - true - | _ -> false - in - let expr, moduleConstraint = - match expr.pexp_desc with - | Pexp_constraint - (expr, { ptyp_desc = Ptyp_package packageType; ptyp_loc }) -> - let packageDoc = - let doc = - printPackageType ~customLayout - ~printModuleKeywordAndParens:false packageType cmtTbl - in - printComments doc cmtTbl ptyp_loc - in - let typeDoc = - Doc.group - (Doc.concat - [ - Doc.text ":"; - Doc.indent (Doc.concat [ Doc.line; packageDoc ]); - ]) - in - (expr, typeDoc) - | _ -> (expr, Doc.nil) - in - let unpackDoc = - Doc.group - (Doc.concat - [ - printExpressionWithComments ~customLayout expr cmtTbl; - moduleConstraint; - ]) - in + let shouldHug = + match expr.pexp_desc with + | Pexp_let _ -> true + | Pexp_constraint + ({pexp_desc = Pexp_let _}, {ptyp_desc = Ptyp_package _packageType}) + -> + true + | _ -> false + in + let expr, moduleConstraint = + match expr.pexp_desc with + | Pexp_constraint + (expr, {ptyp_desc = Ptyp_package packageType; ptyp_loc}) -> + let packageDoc = + let doc = + printPackageType ~customLayout ~printModuleKeywordAndParens:false + packageType cmtTbl + in + printComments doc cmtTbl ptyp_loc + in + let typeDoc = + Doc.group + (Doc.concat + [Doc.text ":"; Doc.indent (Doc.concat [Doc.line; packageDoc])]) + in + (expr, typeDoc) + | _ -> (expr, Doc.nil) + in + let unpackDoc = Doc.group (Doc.concat [ - Doc.text "unpack("; - (if shouldHug then unpackDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [ Doc.softLine; unpackDoc ]); - Doc.softLine; - ]); - Doc.rparen; + printExpressionWithComments ~customLayout expr cmtTbl; + moduleConstraint; ]) + in + Doc.group + (Doc.concat + [ + Doc.text "unpack("; + (if shouldHug then unpackDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [Doc.softLine; unpackDoc]); + Doc.softLine; + ]); + Doc.rparen; + ]) | Pmod_extension extension -> - printExtension ~customLayout ~atModuleLvl:false extension cmtTbl + printExtension ~customLayout ~atModuleLvl:false extension cmtTbl | Pmod_apply _ -> - let args, callExpr = ParsetreeViewer.modExprApply modExpr in - let isUnitSugar = - match args with - | [ { pmod_desc = Pmod_structure [] } ] -> true - | _ -> false - in - let shouldHug = - match args with - | [ { pmod_desc = Pmod_structure _ } ] -> true - | _ -> false - in - Doc.group - (Doc.concat - [ - printModExpr ~customLayout callExpr cmtTbl; - (if isUnitSugar then - printModApplyArg ~customLayout - (List.hd args [@doesNotRaise]) - cmtTbl - else - Doc.concat - [ - Doc.lparen; - (if shouldHug then - printModApplyArg ~customLayout - (List.hd args [@doesNotRaise]) - cmtTbl - else - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun modArg -> - printModApplyArg ~customLayout modArg - cmtTbl) - args); - ])); - (if not shouldHug then - Doc.concat [ Doc.trailingComma; Doc.softLine ] - else Doc.nil); - Doc.rparen; - ]); - ]) + let args, callExpr = ParsetreeViewer.modExprApply modExpr in + let isUnitSugar = + match args with + | [{pmod_desc = Pmod_structure []}] -> true + | _ -> false + in + let shouldHug = + match args with + | [{pmod_desc = Pmod_structure _}] -> true + | _ -> false + in + Doc.group + (Doc.concat + [ + printModExpr ~customLayout callExpr cmtTbl; + (if isUnitSugar then + printModApplyArg ~customLayout + (List.hd args [@doesNotRaise]) + cmtTbl + else + Doc.concat + [ + Doc.lparen; + (if shouldHug then + printModApplyArg ~customLayout + (List.hd args [@doesNotRaise]) + cmtTbl + else + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun modArg -> + printModApplyArg ~customLayout modArg cmtTbl) + args); + ])); + (if not shouldHug then + Doc.concat [Doc.trailingComma; Doc.softLine] + else Doc.nil); + Doc.rparen; + ]); + ]) | Pmod_constraint (modExpr, modType) -> - Doc.concat - [ - printModExpr ~customLayout modExpr cmtTbl; - Doc.text ": "; - printModType ~customLayout modType cmtTbl; - ] + Doc.concat + [ + printModExpr ~customLayout modExpr cmtTbl; + Doc.text ": "; + printModType ~customLayout modType cmtTbl; + ] | Pmod_functor _ -> printModFunctor ~customLayout modExpr cmtTbl in printComments doc cmtTbl modExpr.pmod_loc @@ -58734,52 +58601,51 @@ and printModFunctor ~customLayout modExpr cmtTbl = let returnConstraint, returnModExpr = match returnModExpr.pmod_desc with | Pmod_constraint (modExpr, modType) -> - let constraintDoc = - let doc = printModType ~customLayout modType cmtTbl in - if Parens.modExprFunctorConstraint modType then addParens doc else doc - in - let modConstraint = Doc.concat [ Doc.text ": "; constraintDoc ] in - (modConstraint, printModExpr ~customLayout modExpr cmtTbl) + let constraintDoc = + let doc = printModType ~customLayout modType cmtTbl in + if Parens.modExprFunctorConstraint modType then addParens doc else doc + in + let modConstraint = Doc.concat [Doc.text ": "; constraintDoc] in + (modConstraint, printModExpr ~customLayout modExpr cmtTbl) | _ -> (Doc.nil, printModExpr ~customLayout returnModExpr cmtTbl) in let parametersDoc = match parameters with - | [ (attrs, { txt = "*" }, None) ] -> - Doc.group - (Doc.concat - [ printAttributes ~customLayout attrs cmtTbl; Doc.text "()" ]) - | [ ([], { txt = lbl }, None) ] -> Doc.text lbl + | [(attrs, {txt = "*"}, None)] -> + Doc.group + (Doc.concat [printAttributes ~customLayout attrs cmtTbl; Doc.text "()"]) + | [([], {txt = lbl}, None)] -> Doc.text lbl | parameters -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun param -> - printModFunctorParam ~customLayout param cmtTbl) - parameters); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun param -> + printModFunctorParam ~customLayout param cmtTbl) + parameters); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) in Doc.group (Doc.concat - [ parametersDoc; returnConstraint; Doc.text " => "; returnModExpr ]) + [parametersDoc; returnConstraint; Doc.text " => "; returnModExpr]) and printModFunctorParam ~customLayout (attrs, lbl, optModType) cmtTbl = let cmtLoc = match optModType with | None -> lbl.Asttypes.loc | Some modType -> - { lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end } + {lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end} in let attrs = printAttributes ~customLayout attrs cmtTbl in let lblDoc = @@ -58795,8 +58661,8 @@ and printModFunctorParam ~customLayout (attrs, lbl, optModType) cmtTbl = (match optModType with | None -> Doc.nil | Some modType -> - Doc.concat - [ Doc.text ": "; printModType ~customLayout modType cmtTbl ]); + Doc.concat + [Doc.text ": "; printModType ~customLayout modType cmtTbl]); ]) in printComments doc cmtTbl cmtLoc @@ -58811,25 +58677,22 @@ and printExceptionDef ~customLayout (constr : Parsetree.extension_constructor) let kind = match constr.pext_kind with | Pext_rebind longident -> - Doc.indent - (Doc.concat - [ - Doc.text " ="; Doc.line; printLongidentLocation longident cmtTbl; - ]) + Doc.indent + (Doc.concat + [Doc.text " ="; Doc.line; printLongidentLocation longident cmtTbl]) | Pext_decl (Pcstr_tuple [], None) -> Doc.nil | Pext_decl (args, gadt) -> - let gadtDoc = - match gadt with - | Some typ -> - Doc.concat - [ Doc.text ": "; printTypExpr ~customLayout typ cmtTbl ] - | None -> Doc.nil - in - Doc.concat - [ - printConstructorArguments ~customLayout ~indent:false args cmtTbl; - gadtDoc; - ] + let gadtDoc = + match gadt with + | Some typ -> + Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ cmtTbl] + | None -> Doc.nil + in + Doc.concat + [ + printConstructorArguments ~customLayout ~indent:false args cmtTbl; + gadtDoc; + ] in let name = printComments (Doc.text constr.pext_name.txt) cmtTbl constr.pext_name.loc @@ -58855,30 +58718,27 @@ and printExtensionConstructor ~customLayout let kind = match constr.pext_kind with | Pext_rebind longident -> - Doc.indent - (Doc.concat - [ - Doc.text " ="; Doc.line; printLongidentLocation longident cmtTbl; - ]) + Doc.indent + (Doc.concat + [Doc.text " ="; Doc.line; printLongidentLocation longident cmtTbl]) | Pext_decl (Pcstr_tuple [], None) -> Doc.nil | Pext_decl (args, gadt) -> - let gadtDoc = - match gadt with - | Some typ -> - Doc.concat - [ Doc.text ": "; printTypExpr ~customLayout typ cmtTbl ] - | None -> Doc.nil - in - Doc.concat - [ - printConstructorArguments ~customLayout ~indent:false args cmtTbl; - gadtDoc; - ] + let gadtDoc = + match gadt with + | Some typ -> + Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ cmtTbl] + | None -> Doc.nil + in + Doc.concat + [ + printConstructorArguments ~customLayout ~indent:false args cmtTbl; + gadtDoc; + ] in let name = printComments (Doc.text constr.pext_name.txt) cmtTbl constr.pext_name.loc in - Doc.concat [ bar; Doc.group (Doc.concat [ attrs; name; kind ]) ] + Doc.concat [bar; Doc.group (Doc.concat [attrs; name; kind])] let printTypeParams = printTypeParams ~customLayout:0 let printTypExpr = printTypExpr ~customLayout:0 @@ -282255,25 +282115,25 @@ type mode = Jsx | Diamond will also contain the special -1 value to indicate end-of-file. This isn't ideal; we should clean this up *) let hackyEOFChar = Char.unsafe_chr (-1) - type charEncoding = Char.t type t = { - filename : string; - src : string; - mutable err : + filename: string; + src: string; + mutable err: startPos:Lexing.position -> endPos:Lexing.position -> Diagnostics.category -> unit; - mutable ch : charEncoding; (* current character *) - mutable offset : int; (* character offset *) - mutable lineOffset : int; (* current line offset *) - mutable lnum : int; (* current line number *) - mutable mode : mode list; + mutable ch: charEncoding; (* current character *) + mutable offset: int; (* character offset *) + mutable lineOffset: int; (* current line offset *) + mutable lnum: int; (* current line number *) + mutable mode: mode list; } let setDiamondMode scanner = scanner.mode <- Diamond :: scanner.mode + let setJsxMode scanner = scanner.mode <- Jsx :: scanner.mode let popMode scanner mode = @@ -282282,9 +282142,14 @@ let popMode scanner mode = | _ -> () let inDiamondMode scanner = - match scanner.mode with Diamond :: _ -> true | _ -> false + match scanner.mode with + | Diamond :: _ -> true + | _ -> false -let inJsxMode scanner = match scanner.mode with Jsx :: _ -> true | _ -> false +let inJsxMode scanner = + match scanner.mode with + | Jsx :: _ -> true + | _ -> false let position scanner = Lexing. @@ -282324,8 +282189,8 @@ let _printDebug ~startPos ~endPos scanner token = | 0 -> if token = Token.Eof then () else assert false | 1 -> () | n -> - print_string ((String.make [@doesNotRaise]) (n - 2) '-'); - print_char '^'); + print_string ((String.make [@doesNotRaise]) (n - 2) '-'); + print_char '^'); print_char ' '; print_string (Res_token.toString token); print_char ' '; @@ -282339,11 +282204,11 @@ let next scanner = let nextOffset = scanner.offset + 1 in (match scanner.ch with | '\n' -> - scanner.lineOffset <- nextOffset; - scanner.lnum <- scanner.lnum + 1 - (* What about CRLF (\r + \n) on windows? - * \r\n will always be terminated by a \n - * -> we can just bump the line count on \n *) + scanner.lineOffset <- nextOffset; + scanner.lnum <- scanner.lnum + 1 + (* What about CRLF (\r + \n) on windows? + * \r\n will always be terminated by a \n + * -> we can just bump the line count on \n *) | _ -> ()); if nextOffset < String.length scanner.src then ( scanner.offset <- nextOffset; @@ -282391,7 +282256,9 @@ let make ~filename src = (* generic helpers *) let isWhitespace ch = - match ch with ' ' | '\t' | '\n' | '\r' -> true | _ -> false + match ch with + | ' ' | '\t' | '\n' | '\r' -> true + | _ -> false let rec skipWhitespace scanner = if isWhitespace scanner.ch then ( @@ -282408,8 +282275,8 @@ let digitValue ch = let rec skipLowerCaseChars scanner = match scanner.ch with | 'a' .. 'z' -> - next scanner; - skipLowerCaseChars scanner + next scanner; + skipLowerCaseChars scanner | _ -> () (* scanning helpers *) @@ -282419,8 +282286,8 @@ let scanIdentifier scanner = let rec skipGoodChars scanner = match scanner.ch with | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' | '\'' -> - next scanner; - skipGoodChars scanner + next scanner; + skipGoodChars scanner | _ -> () in skipGoodChars scanner; @@ -282438,8 +282305,8 @@ let scanDigits scanner ~base = let rec loop scanner = match scanner.ch with | '0' .. '9' | '_' -> - next scanner; - loop scanner + next scanner; + loop scanner | _ -> () in loop scanner @@ -282448,8 +282315,8 @@ let scanDigits scanner ~base = match scanner.ch with (* hex *) | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_' -> - next scanner; - loop scanner + next scanner; + loop scanner | _ -> () in loop scanner @@ -282462,19 +282329,19 @@ let scanNumber scanner = let base = match scanner.ch with | '0' -> ( - match peek scanner with - | 'x' | 'X' -> - next2 scanner; - 16 - | 'o' | 'O' -> - next2 scanner; - 8 - | 'b' | 'B' -> - next2 scanner; - 2 - | _ -> - next scanner; - 8) + match peek scanner with + | 'x' | 'X' -> + next2 scanner; + 16 + | 'o' | 'O' -> + next2 scanner; + 8 + | 'b' | 'B' -> + next2 scanner; + 2 + | _ -> + next scanner; + 8) | _ -> 10 in scanDigits scanner ~base; @@ -282492,11 +282359,11 @@ let scanNumber scanner = let isFloat = match scanner.ch with | 'e' | 'E' | 'p' | 'P' -> - (match peek scanner with - | '+' | '-' -> next2 scanner - | _ -> next scanner); - scanDigits scanner ~base; - true + (match peek scanner with + | '+' | '-' -> next2 scanner + | _ -> next scanner); + scanDigits scanner ~base; + true | _ -> isFloat in let literal = @@ -282507,20 +282374,20 @@ let scanNumber scanner = let suffix = match scanner.ch with | 'n' -> - let msg = - "Unsupported number type (nativeint). Did you mean `" ^ literal ^ "`?" - in - let pos = position scanner in - scanner.err ~startPos:pos ~endPos:pos (Diagnostics.message msg); - next scanner; - Some 'n' + let msg = + "Unsupported number type (nativeint). Did you mean `" ^ literal ^ "`?" + in + let pos = position scanner in + scanner.err ~startPos:pos ~endPos:pos (Diagnostics.message msg); + next scanner; + Some 'n' | ('g' .. 'z' | 'G' .. 'Z') as ch -> - next scanner; - Some ch + next scanner; + Some ch | _ -> None in - if isFloat then Token.Float { f = literal; suffix } - else Token.Int { i = literal; suffix } + if isFloat then Token.Float {f = literal; suffix} + else Token.Int {i = literal; suffix} let scanExoticIdentifier scanner = (* TODO: are we disregarding the current char...? Should be a quote *) @@ -282532,19 +282399,19 @@ let scanExoticIdentifier scanner = match scanner.ch with | '"' -> next scanner | '\n' | '\r' -> - (* line break *) - let endPos = position scanner in - scanner.err ~startPos ~endPos - (Diagnostics.message "A quoted identifier can't contain line breaks."); - next scanner + (* line break *) + let endPos = position scanner in + scanner.err ~startPos ~endPos + (Diagnostics.message "A quoted identifier can't contain line breaks."); + next scanner | ch when ch == hackyEOFChar -> - let endPos = position scanner in - scanner.err ~startPos ~endPos - (Diagnostics.message "Did you forget a \" here?") + let endPos = position scanner in + scanner.err ~startPos ~endPos + (Diagnostics.message "Did you forget a \" here?") | ch -> - Buffer.add_char buffer ch; - next scanner; - scan () + Buffer.add_char buffer ch; + next scanner; + scan () in scan (); (* TODO: do we really need to create a new buffer instead of substring once? *) @@ -282580,35 +282447,37 @@ let scanStringEscapeSequence ~startPos scanner = | '0' when let c = peek scanner in c < '0' || c > '9' -> - (* Allow \0 *) - next scanner + (* Allow \0 *) + next scanner | '0' .. '9' -> scan ~n:3 ~base:10 ~max:255 | 'x' -> - (* hex *) - next scanner; - scan ~n:2 ~base:16 ~max:255 + (* hex *) + next scanner; + scan ~n:2 ~base:16 ~max:255 | 'u' -> ( + next scanner; + match scanner.ch with + | '{' -> ( + (* unicode code point escape sequence: '\u{7A}', one or more hex digits *) next scanner; + let x = ref 0 in + while + match scanner.ch with + | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true + | _ -> false + do + x := (!x * 16) + digitValue scanner.ch; + next scanner + done; + (* consume '}' in '\u{7A}' *) match scanner.ch with - | '{' -> ( - (* unicode code point escape sequence: '\u{7A}', one or more hex digits *) - next scanner; - let x = ref 0 in - while - match scanner.ch with - | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true - | _ -> false - do - x := (!x * 16) + digitValue scanner.ch; - next scanner - done; - (* consume '}' in '\u{7A}' *) - match scanner.ch with '}' -> next scanner | _ -> ()) - | _ -> scan ~n:4 ~base:16 ~max:Res_utf8.max) + | '}' -> next scanner + | _ -> ()) + | _ -> scan ~n:4 ~base:16 ~max:Res_utf8.max) | _ -> - (* unknown escape sequence - * TODO: we should warn the user here. Let's not make it a hard error for now, for reason compat *) - (* + (* unknown escape sequence + * TODO: we should warn the user here. Let's not make it a hard error for now, for reason compat *) + (* let pos = position scanner in let msg = if ch == -1 then "unclosed escape sequence" @@ -282616,7 +282485,7 @@ let scanStringEscapeSequence ~startPos scanner = in scanner.err ~startPos ~endPos:pos (Diagnostics.message msg) *) - () + () let scanString scanner = (* assumption: we've just matched a quote *) @@ -282649,28 +282518,30 @@ let scanString scanner = let rec scan () = match scanner.ch with | '"' -> - let lastCharOffset = scanner.offset in - next scanner; - result ~firstCharOffset ~lastCharOffset + let lastCharOffset = scanner.offset in + next scanner; + result ~firstCharOffset ~lastCharOffset | '\\' -> - let startPos = position scanner in - let startOffset = scanner.offset + 1 in - next scanner; - scanStringEscapeSequence ~startPos scanner; - let endOffset = scanner.offset in - convertOctalToHex ~startOffset ~endOffset + let startPos = position scanner in + let startOffset = scanner.offset + 1 in + next scanner; + scanStringEscapeSequence ~startPos scanner; + let endOffset = scanner.offset in + convertOctalToHex ~startOffset ~endOffset | ch when ch == hackyEOFChar -> - let endPos = position scanner in - scanner.err ~startPos:startPosWithQuote ~endPos - Diagnostics.unclosedString; - let lastCharOffset = scanner.offset in - result ~firstCharOffset ~lastCharOffset + let endPos = position scanner in + scanner.err ~startPos:startPosWithQuote ~endPos Diagnostics.unclosedString; + let lastCharOffset = scanner.offset in + result ~firstCharOffset ~lastCharOffset | _ -> - next scanner; - scan () + next scanner; + scan () and convertOctalToHex ~startOffset ~endOffset = let len = endOffset - startOffset in - let isDigit = function '0' .. '9' -> true | _ -> false in + let isDigit = function + | '0' .. '9' -> true + | _ -> false + in let txt = scanner.src in let isNumericEscape = len = 3 @@ -282706,48 +282577,50 @@ let scanEscape scanner = match scanner.ch with | '0' .. '9' -> convertNumber scanner ~n:3 ~base:10 | 'b' -> - next scanner; - 8 + next scanner; + 8 | 'n' -> - next scanner; - 10 + next scanner; + 10 | 'r' -> - next scanner; - 13 + next scanner; + 13 | 't' -> - next scanner; - 009 + next scanner; + 009 | 'x' -> - next scanner; - convertNumber scanner ~n:2 ~base:16 + next scanner; + convertNumber scanner ~n:2 ~base:16 | 'o' -> - next scanner; - convertNumber scanner ~n:3 ~base:8 + next scanner; + convertNumber scanner ~n:3 ~base:8 | 'u' -> ( + next scanner; + match scanner.ch with + | '{' -> + (* unicode code point escape sequence: '\u{7A}', one or more hex digits *) next scanner; - match scanner.ch with - | '{' -> - (* unicode code point escape sequence: '\u{7A}', one or more hex digits *) - next scanner; - let x = ref 0 in - while - match scanner.ch with - | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true - | _ -> false - do - x := (!x * 16) + digitValue scanner.ch; - next scanner - done; - (* consume '}' in '\u{7A}' *) - (match scanner.ch with '}' -> next scanner | _ -> ()); - let c = !x in - if Res_utf8.isValidCodePoint c then c else Res_utf8.repl - | _ -> - (* unicode escape sequence: '\u007A', exactly 4 hex digits *) - convertNumber scanner ~n:4 ~base:16) + let x = ref 0 in + while + match scanner.ch with + | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true + | _ -> false + do + x := (!x * 16) + digitValue scanner.ch; + next scanner + done; + (* consume '}' in '\u{7A}' *) + (match scanner.ch with + | '}' -> next scanner + | _ -> ()); + let c = !x in + if Res_utf8.isValidCodePoint c then c else Res_utf8.repl + | _ -> + (* unicode escape sequence: '\u007A', exactly 4 hex digits *) + convertNumber scanner ~n:4 ~base:16) | ch -> - next scanner; - Char.code ch + next scanner; + Char.code ch in let contents = (String.sub [@doesNotRaise]) scanner.src offset (scanner.offset - offset) @@ -282755,7 +282628,7 @@ let scanEscape scanner = next scanner; (* Consume \' *) (* TODO: do we know it's \' ? *) - Token.Codepoint { c = codepoint; original = contents } + Token.Codepoint {c = codepoint; original = contents} let scanSingleLineComment scanner = let startOff = scanner.offset in @@ -282765,15 +282638,14 @@ let scanSingleLineComment scanner = | '\n' | '\r' -> () | ch when ch == hackyEOFChar -> () | _ -> - next scanner; - skip scanner + next scanner; + skip scanner in skip scanner; let endPos = position scanner in Token.Comment (Comment.makeSingleLineComment - ~loc: - Location.{ loc_start = startPos; loc_end = endPos; loc_ghost = false } + ~loc:Location.{loc_start = startPos; loc_end = endPos; loc_ghost = false} ((String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - startOff))) @@ -282789,17 +282661,17 @@ let scanMultiLineComment scanner = (* invariant: depth > 0 right after this match. See assumption *) match (scanner.ch, peek scanner) with | '/', '*' -> - next2 scanner; - scan ~depth:(depth + 1) + next2 scanner; + scan ~depth:(depth + 1) | '*', '/' -> - next2 scanner; - if depth > 1 then scan ~depth:(depth - 1) + next2 scanner; + if depth > 1 then scan ~depth:(depth - 1) | ch, _ when ch == hackyEOFChar -> - let endPos = position scanner in - scanner.err ~startPos ~endPos Diagnostics.unclosedComment + let endPos = position scanner in + scanner.err ~startPos ~endPos Diagnostics.unclosedComment | _ -> - next scanner; - scan ~depth + next scanner; + scan ~depth in scan ~depth:0; let length = scanner.offset - 2 - contentStartOff in @@ -282808,11 +282680,7 @@ let scanMultiLineComment scanner = (Comment.makeMultiLineComment ~docComment ~standalone ~loc: Location. - { - loc_start = startPos; - loc_end = position scanner; - loc_ghost = false; - } + {loc_start = startPos; loc_end = position scanner; loc_ghost = false} ((String.sub [@doesNotRaise]) scanner.src contentStartOff length)) let scanTemplateLiteralToken scanner = @@ -282827,44 +282695,44 @@ let scanTemplateLiteralToken scanner = let lastPos = position scanner in match scanner.ch with | '`' -> - next scanner; - let contents = - (String.sub [@doesNotRaise]) scanner.src startOff - (scanner.offset - 1 - startOff) - in - Token.TemplateTail (contents, lastPos) + next scanner; + let contents = + (String.sub [@doesNotRaise]) scanner.src startOff + (scanner.offset - 1 - startOff) + in + Token.TemplateTail (contents, lastPos) | '$' -> ( - match peek scanner with - | '{' -> - next2 scanner; - let contents = - (String.sub [@doesNotRaise]) scanner.src startOff - (scanner.offset - 2 - startOff) - in - Token.TemplatePart (contents, lastPos) - | _ -> - next scanner; - scan ()) - | '\\' -> ( - match peek scanner with - | '`' | '\\' | '$' | '\n' | '\r' -> - (* line break *) - next2 scanner; - scan () - | _ -> - next scanner; - scan ()) - | ch when ch = hackyEOFChar -> - let endPos = position scanner in - scanner.err ~startPos ~endPos Diagnostics.unclosedTemplate; + match peek scanner with + | '{' -> + next2 scanner; let contents = (String.sub [@doesNotRaise]) scanner.src startOff - (max (scanner.offset - 1 - startOff) 0) + (scanner.offset - 2 - startOff) in - Token.TemplateTail (contents, lastPos) - | _ -> + Token.TemplatePart (contents, lastPos) + | _ -> next scanner; + scan ()) + | '\\' -> ( + match peek scanner with + | '`' | '\\' | '$' | '\n' | '\r' -> + (* line break *) + next2 scanner; scan () + | _ -> + next scanner; + scan ()) + | ch when ch = hackyEOFChar -> + let endPos = position scanner in + scanner.err ~startPos ~endPos Diagnostics.unclosedTemplate; + let contents = + (String.sub [@doesNotRaise]) scanner.src startOff + (max (scanner.offset - 1 - startOff) 0) + in + Token.TemplateTail (contents, lastPos) + | _ -> + next scanner; + scan () in let token = scan () in let endPos = position scanner in @@ -282880,273 +282748,273 @@ let rec scan scanner = | 'A' .. 'Z' | 'a' .. 'z' -> scanIdentifier scanner | '0' .. '9' -> scanNumber scanner | '`' -> - next scanner; - Token.Backtick + next scanner; + Token.Backtick | '~' -> - next scanner; - Token.Tilde + next scanner; + Token.Tilde | '?' -> - next scanner; - Token.Question + next scanner; + Token.Question | ';' -> - next scanner; - Token.Semicolon + next scanner; + Token.Semicolon | '(' -> - next scanner; - Token.Lparen + next scanner; + Token.Lparen | ')' -> - next scanner; - Token.Rparen + next scanner; + Token.Rparen | '[' -> - next scanner; - Token.Lbracket + next scanner; + Token.Lbracket | ']' -> - next scanner; - Token.Rbracket + next scanner; + Token.Rbracket | '{' -> - next scanner; - Token.Lbrace + next scanner; + Token.Lbrace | '}' -> - next scanner; - Token.Rbrace + next scanner; + Token.Rbrace | ',' -> - next scanner; - Token.Comma + next scanner; + Token.Comma | '"' -> scanString scanner (* peeking 1 char *) | '_' -> ( - match peek scanner with - | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' -> scanIdentifier scanner - | _ -> - next scanner; - Token.Underscore) + match peek scanner with + | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' -> scanIdentifier scanner + | _ -> + next scanner; + Token.Underscore) | '#' -> ( - match peek scanner with - | '=' -> - next2 scanner; - Token.HashEqual - | _ -> - next scanner; - Token.Hash) + match peek scanner with + | '=' -> + next2 scanner; + Token.HashEqual + | _ -> + next scanner; + Token.Hash) | '*' -> ( - match peek scanner with - | '*' -> - next2 scanner; - Token.Exponentiation - | '.' -> - next2 scanner; - Token.AsteriskDot - | _ -> - next scanner; - Token.Asterisk) + match peek scanner with + | '*' -> + next2 scanner; + Token.Exponentiation + | '.' -> + next2 scanner; + Token.AsteriskDot + | _ -> + next scanner; + Token.Asterisk) | '@' -> ( - match peek scanner with - | '@' -> - next2 scanner; - Token.AtAt - | _ -> - next scanner; - Token.At) + match peek scanner with + | '@' -> + next2 scanner; + Token.AtAt + | _ -> + next scanner; + Token.At) | '%' -> ( - match peek scanner with - | '%' -> - next2 scanner; - Token.PercentPercent - | _ -> - next scanner; - Token.Percent) + match peek scanner with + | '%' -> + next2 scanner; + Token.PercentPercent + | _ -> + next scanner; + Token.Percent) | '|' -> ( - match peek scanner with - | '|' -> - next2 scanner; - Token.Lor - | '>' -> - next2 scanner; - Token.BarGreater - | _ -> - next scanner; - Token.Bar) + match peek scanner with + | '|' -> + next2 scanner; + Token.Lor + | '>' -> + next2 scanner; + Token.BarGreater + | _ -> + next scanner; + Token.Bar) | '&' -> ( - match peek scanner with - | '&' -> - next2 scanner; - Token.Land - | _ -> - next scanner; - Token.Band) + match peek scanner with + | '&' -> + next2 scanner; + Token.Land + | _ -> + next scanner; + Token.Band) | ':' -> ( - match peek scanner with - | '=' -> - next2 scanner; - Token.ColonEqual - | '>' -> - next2 scanner; - Token.ColonGreaterThan - | _ -> - next scanner; - Token.Colon) - | '\\' -> + match peek scanner with + | '=' -> + next2 scanner; + Token.ColonEqual + | '>' -> + next2 scanner; + Token.ColonGreaterThan + | _ -> next scanner; - scanExoticIdentifier scanner + Token.Colon) + | '\\' -> + next scanner; + scanExoticIdentifier scanner | '/' -> ( - match peek scanner with - | '/' -> - next2 scanner; - scanSingleLineComment scanner - | '*' -> scanMultiLineComment scanner - | '.' -> - next2 scanner; - Token.ForwardslashDot - | _ -> - next scanner; - Token.Forwardslash) + match peek scanner with + | '/' -> + next2 scanner; + scanSingleLineComment scanner + | '*' -> scanMultiLineComment scanner + | '.' -> + next2 scanner; + Token.ForwardslashDot + | _ -> + next scanner; + Token.Forwardslash) | '-' -> ( - match peek scanner with - | '.' -> - next2 scanner; - Token.MinusDot - | '>' -> - next2 scanner; - Token.MinusGreater - | _ -> - next scanner; - Token.Minus) + match peek scanner with + | '.' -> + next2 scanner; + Token.MinusDot + | '>' -> + next2 scanner; + Token.MinusGreater + | _ -> + next scanner; + Token.Minus) | '+' -> ( - match peek scanner with - | '.' -> - next2 scanner; - Token.PlusDot - | '+' -> - next2 scanner; - Token.PlusPlus - | '=' -> - next2 scanner; - Token.PlusEqual - | _ -> - next scanner; - Token.Plus) + match peek scanner with + | '.' -> + next2 scanner; + Token.PlusDot + | '+' -> + next2 scanner; + Token.PlusPlus + | '=' -> + next2 scanner; + Token.PlusEqual + | _ -> + next scanner; + Token.Plus) | '>' -> ( - match peek scanner with - | '=' when not (inDiamondMode scanner) -> - next2 scanner; - Token.GreaterEqual - | _ -> - next scanner; - Token.GreaterThan) + match peek scanner with + | '=' when not (inDiamondMode scanner) -> + next2 scanner; + Token.GreaterEqual + | _ -> + next scanner; + Token.GreaterThan) | '<' when not (inJsxMode scanner) -> ( - match peek scanner with - | '=' -> - next2 scanner; - Token.LessEqual - | _ -> - next scanner; - Token.LessThan) + match peek scanner with + | '=' -> + next2 scanner; + Token.LessEqual + | _ -> + next scanner; + Token.LessThan) (* special handling for JSX < *) | '<' -> ( - (* Imagine the following:
< - * < indicates the start of a new jsx-element, the parser expects - * the name of a new element after the < - * Example:
- * This signals a closing element. To simulate the two-token lookahead, - * the < + * < indicates the start of a new jsx-element, the parser expects + * the name of a new element after the < + * Example:
+ * This signals a closing element. To simulate the two-token lookahead, + * the next scanner; - skipWhitespace scanner; - match scanner.ch with - | '/' -> - next scanner; - Token.LessThanSlash - | '=' -> - next scanner; - Token.LessEqual - | _ -> Token.LessThan) + Token.LessThanSlash + | '=' -> + next scanner; + Token.LessEqual + | _ -> Token.LessThan) (* peeking 2 chars *) | '.' -> ( - match (peek scanner, peek2 scanner) with - | '.', '.' -> - next3 scanner; - Token.DotDotDot - | '.', _ -> - next2 scanner; - Token.DotDot - | _ -> - next scanner; - Token.Dot) + match (peek scanner, peek2 scanner) with + | '.', '.' -> + next3 scanner; + Token.DotDotDot + | '.', _ -> + next2 scanner; + Token.DotDot + | _ -> + next scanner; + Token.Dot) | '\'' -> ( - match (peek scanner, peek2 scanner) with - | '\\', '"' -> - (* careful with this one! We're next-ing _once_ (not twice), - then relying on matching on the quote *) - next scanner; - SingleQuote - | '\\', _ -> - next2 scanner; - scanEscape scanner - | ch, '\'' -> - let offset = scanner.offset + 1 in - next3 scanner; - Token.Codepoint - { - c = Char.code ch; - original = (String.sub [@doesNotRaise]) scanner.src offset 1; - } - | ch, _ -> - next scanner; - let offset = scanner.offset in - let codepoint, length = - Res_utf8.decodeCodePoint scanner.offset scanner.src - (String.length scanner.src) - in - for _ = 0 to length - 1 do - next scanner - done; - if scanner.ch = '\'' then ( - let contents = - (String.sub [@doesNotRaise]) scanner.src offset length - in - next scanner; - Token.Codepoint { c = codepoint; original = contents }) - else ( - scanner.ch <- ch; - scanner.offset <- offset; - SingleQuote)) + match (peek scanner, peek2 scanner) with + | '\\', '"' -> + (* careful with this one! We're next-ing _once_ (not twice), + then relying on matching on the quote *) + next scanner; + SingleQuote + | '\\', _ -> + next2 scanner; + scanEscape scanner + | ch, '\'' -> + let offset = scanner.offset + 1 in + next3 scanner; + Token.Codepoint + { + c = Char.code ch; + original = (String.sub [@doesNotRaise]) scanner.src offset 1; + } + | ch, _ -> + next scanner; + let offset = scanner.offset in + let codepoint, length = + Res_utf8.decodeCodePoint scanner.offset scanner.src + (String.length scanner.src) + in + for _ = 0 to length - 1 do + next scanner + done; + if scanner.ch = '\'' then ( + let contents = + (String.sub [@doesNotRaise]) scanner.src offset length + in + next scanner; + Token.Codepoint {c = codepoint; original = contents}) + else ( + scanner.ch <- ch; + scanner.offset <- offset; + SingleQuote)) | '!' -> ( - match (peek scanner, peek2 scanner) with - | '=', '=' -> - next3 scanner; - Token.BangEqualEqual - | '=', _ -> - next2 scanner; - Token.BangEqual - | _ -> - next scanner; - Token.Bang) + match (peek scanner, peek2 scanner) with + | '=', '=' -> + next3 scanner; + Token.BangEqualEqual + | '=', _ -> + next2 scanner; + Token.BangEqual + | _ -> + next scanner; + Token.Bang) | '=' -> ( - match (peek scanner, peek2 scanner) with - | '=', '=' -> - next3 scanner; - Token.EqualEqualEqual - | '=', _ -> - next2 scanner; - Token.EqualEqual - | '>', _ -> - next2 scanner; - Token.EqualGreater - | _ -> - next scanner; - Token.Equal) + match (peek scanner, peek2 scanner) with + | '=', '=' -> + next3 scanner; + Token.EqualEqualEqual + | '=', _ -> + next2 scanner; + Token.EqualEqual + | '>', _ -> + next2 scanner; + Token.EqualGreater + | _ -> + next scanner; + Token.Equal) (* special cases *) | ch when ch == hackyEOFChar -> - next scanner; - Token.Eof + next scanner; + Token.Eof | ch -> - (* if we arrive here, we're dealing with an unknown character, - * report the error and continue scanning… *) - next scanner; - let endPos = position scanner in - scanner.err ~startPos ~endPos (Diagnostics.unknownUchar ch); - let _, _, token = scan scanner in - token + (* if we arrive here, we're dealing with an unknown character, + * report the error and continue scanning… *) + next scanner; + let endPos = position scanner in + scanner.err ~startPos ~endPos (Diagnostics.unknownUchar ch); + let _, _, token = scan scanner in + token in let endPos = position scanner in (* _printDebug ~startPos ~endPos scanner token; *) @@ -283190,36 +283058,36 @@ let tryAdvanceQuotedString scanner = let rec scanContents tag = match scanner.ch with | '|' -> ( - next scanner; - match scanner.ch with - | 'a' .. 'z' -> - let startOff = scanner.offset in - skipLowerCaseChars scanner; - let suffix = - (String.sub [@doesNotRaise]) scanner.src startOff - (scanner.offset - startOff) - in - if tag = suffix then - if scanner.ch = '}' then next scanner else scanContents tag - else scanContents tag - | '}' -> next scanner - | _ -> scanContents tag) + next scanner; + match scanner.ch with + | 'a' .. 'z' -> + let startOff = scanner.offset in + skipLowerCaseChars scanner; + let suffix = + (String.sub [@doesNotRaise]) scanner.src startOff + (scanner.offset - startOff) + in + if tag = suffix then + if scanner.ch = '}' then next scanner else scanContents tag + else scanContents tag + | '}' -> next scanner + | _ -> scanContents tag) | ch when ch == hackyEOFChar -> - (* TODO: why is this place checking EOF and not others? *) - () + (* TODO: why is this place checking EOF and not others? *) + () | _ -> - next scanner; - scanContents tag + next scanner; + scanContents tag in match scanner.ch with | 'a' .. 'z' -> - let startOff = scanner.offset in - skipLowerCaseChars scanner; - let tag = - (String.sub [@doesNotRaise]) scanner.src startOff - (scanner.offset - startOff) - in - if scanner.ch = '|' then scanContents tag + let startOff = scanner.offset in + skipLowerCaseChars scanner; + let tag = + (String.sub [@doesNotRaise]) scanner.src startOff + (scanner.offset - startOff) + in + if scanner.ch = '|' then scanContents tag | '|' -> scanContents "" | _ -> () diff --git a/lib/4.06.1/whole_compiler.ml b/lib/4.06.1/whole_compiler.ml index 289a4049af..b46d12963b 100644 --- a/lib/4.06.1/whole_compiler.ml +++ b/lib/4.06.1/whole_compiler.ml @@ -176869,6 +176869,7 @@ let decode_utf8_string s = assert false *) let encode_codepoint c = + (* reused from syntax/src/res_utf8.ml *) let h2 = 0b1100_0000 in let h3 = 0b1110_0000 in let h4 = 0b1111_0000 in @@ -179704,11 +179705,21 @@ let stats_to_string (Array.to_list (Array.map string_of_int bucket_histogram))) let string_of_int_as_char i = - if i >= 0 && i <= 255 - then - Printf.sprintf "\'%s\'" (Char.escaped (Char.unsafe_chr i)) - else - Printf.sprintf "\'%s\'" (Ext_utf8.encode_codepoint i) + let str = match Char.unsafe_chr i with + | '\'' -> "\\'" + | '\\' -> "\\\\" + | '\n' -> "\\n" + | '\t' -> "\\t" + | '\r' -> "\\r" + | '\b' -> "\\b" + | ' ' .. '~' as c -> + let s = (Bytes.create [@doesNotRaise]) 1 in + Bytes.unsafe_set s 0 c; + Bytes.unsafe_to_string s + | _ -> Ext_utf8.encode_codepoint i + in + Printf.sprintf "\'%s\'" str + end module Hash_set_gen @@ -228624,9 +228635,9 @@ type t = | Open | True | False - | Codepoint of { c : int; original : string } - | Int of { i : string; suffix : char option } - | Float of { f : string; suffix : char option } + | Codepoint of {c: int; original: string} + | Int of {i: string; suffix: char option} + | Float of {f: string; suffix: char option} | String of string | Lident of string | Uident of string @@ -228722,7 +228733,7 @@ let precedence = function | Land -> 3 | Equal | EqualEqual | EqualEqualEqual | LessThan | GreaterThan | BangEqual | BangEqualEqual | LessEqual | GreaterEqual | BarGreater -> - 4 + 4 | Plus | PlusDot | Minus | MinusDot | PlusPlus -> 5 | Asterisk | AsteriskDot | Forwardslash | ForwardslashDot -> 6 | Exponentiation -> 7 @@ -228735,15 +228746,15 @@ let toString = function | Open -> "open" | True -> "true" | False -> "false" - | Codepoint { original } -> "codepoint '" ^ original ^ "'" + | Codepoint {original} -> "codepoint '" ^ original ^ "'" | String s -> "string \"" ^ s ^ "\"" | Lident str -> str | Uident str -> str | Dot -> "." | DotDot -> ".." | DotDotDot -> "..." - | Int { i } -> "int " ^ i - | Float { f } -> "Float: " ^ f + | Int {i} -> "int " ^ i + | Float {f} -> "Float: " ^ f | Bang -> "!" | Semicolon -> ";" | Let -> "let" @@ -228863,7 +228874,7 @@ let isKeyword = function | Await | And | As | Assert | Constraint | Else | Exception | External | False | For | If | In | Include | Land | Lazy | Let | List | Lor | Module | Mutable | Of | Open | Private | Rec | Switch | True | Try | Typ | When | While -> - true + true | _ -> false let lookupKeyword str = @@ -229130,7 +229141,7 @@ let addParens doc = (Doc.concat [ Doc.lparen; - Doc.indent (Doc.concat [ Doc.softLine; doc ]); + Doc.indent (Doc.concat [Doc.softLine; doc]); Doc.softLine; Doc.rparen; ]) @@ -229140,12 +229151,12 @@ let addBraces doc = (Doc.concat [ Doc.lbrace; - Doc.indent (Doc.concat [ Doc.softLine; doc ]); + Doc.indent (Doc.concat [Doc.softLine; doc]); Doc.softLine; Doc.rbrace; ]) -let addAsync doc = Doc.concat [ Doc.text "async "; doc ] +let addAsync doc = Doc.concat [Doc.text "async "; doc] let getFirstLeadingComment tbl loc = match Hashtbl.find tbl.CommentTable.leading loc with @@ -229162,8 +229173,8 @@ let hasLeadingLineComment tbl loc = let hasCommentBelow tbl loc = match Hashtbl.find tbl.CommentTable.trailing loc with | comment :: _ -> - let commentLoc = Comment.loc comment in - commentLoc.Location.loc_start.pos_lnum > loc.Location.loc_end.pos_lnum + let commentLoc = Comment.loc comment in + commentLoc.Location.loc_start.pos_lnum > loc.Location.loc_end.pos_lnum | [] -> false | exception Not_found -> false @@ -229171,10 +229182,10 @@ let hasNestedJsxOrMoreThanOneChild expr = let rec loop inRecursion expr = match expr.Parsetree.pexp_desc with | Pexp_construct - ( { txt = Longident.Lident "::" }, - Some { pexp_desc = Pexp_tuple [ hd; tail ] } ) -> - if inRecursion || ParsetreeViewer.isJsxExpression hd then true - else loop true tail + ({txt = Longident.Lident "::"}, Some {pexp_desc = Pexp_tuple [hd; tail]}) + -> + if inRecursion || ParsetreeViewer.isJsxExpression hd then true + else loop true tail | _ -> false in loop false expr @@ -229205,40 +229216,42 @@ let printMultilineCommentContent txt = let rec indentStars lines acc = match lines with | [] -> Doc.nil - | [ lastLine ] -> - let line = String.trim lastLine in - let doc = Doc.text (" " ^ line) in - let trailingSpace = if line = "" then Doc.nil else Doc.space in - List.rev (trailingSpace :: doc :: acc) |> Doc.concat + | [lastLine] -> + let line = String.trim lastLine in + let doc = Doc.text (" " ^ line) in + let trailingSpace = if line = "" then Doc.nil else Doc.space in + List.rev (trailingSpace :: doc :: acc) |> Doc.concat | line :: lines -> - let line = String.trim line in - if line != "" && String.unsafe_get line 0 == '*' then - let doc = Doc.text (" " ^ line) in - indentStars lines (Doc.hardLine :: doc :: acc) - else - let trailingSpace = - let len = String.length txt in - if len > 0 && String.unsafe_get txt (len - 1) = ' ' then Doc.space - else Doc.nil - in - let content = Comment.trimSpaces txt in - Doc.concat [ Doc.text content; trailingSpace ] + let line = String.trim line in + if line != "" && String.unsafe_get line 0 == '*' then + let doc = Doc.text (" " ^ line) in + indentStars lines (Doc.hardLine :: doc :: acc) + else + let trailingSpace = + let len = String.length txt in + if len > 0 && String.unsafe_get txt (len - 1) = ' ' then Doc.space + else Doc.nil + in + let content = Comment.trimSpaces txt in + Doc.concat [Doc.text content; trailingSpace] in let lines = String.split_on_char '\n' txt in match lines with | [] -> Doc.text "/* */" - | [ line ] -> - Doc.concat - [ Doc.text "/* "; Doc.text (Comment.trimSpaces line); Doc.text " */" ] + | [line] -> + Doc.concat + [Doc.text "/* "; Doc.text (Comment.trimSpaces line); Doc.text " */"] | first :: rest -> - let firstLine = Comment.trimSpaces first in - Doc.concat - [ - Doc.text "/*"; - (match firstLine with "" | "*" -> Doc.nil | _ -> Doc.space); - indentStars rest [ Doc.hardLine; Doc.text firstLine ]; - Doc.text "*/"; - ] + let firstLine = Comment.trimSpaces first in + Doc.concat + [ + Doc.text "/*"; + (match firstLine with + | "" | "*" -> Doc.nil + | _ -> Doc.space); + indentStars rest [Doc.hardLine; Doc.text firstLine]; + Doc.text "*/"; + ] let printTrailingComment (prevLoc : Location.t) (nodeLoc : Location.t) comment = let singleLine = Comment.isSingleLineComment comment in @@ -229266,8 +229279,8 @@ let printTrailingComment (prevLoc : Location.t) (nodeLoc : Location.t) comment = content; ]); ] - else if not singleLine then Doc.concat [ Doc.space; content ] - else Doc.lineSuffix (Doc.concat [ Doc.space; content ]) + else if not singleLine then Doc.concat [Doc.space; content] + else Doc.lineSuffix (Doc.concat [Doc.space; content]) let printLeadingComment ?nextComment comment = let singleLine = Comment.isSingleLineComment comment in @@ -229279,28 +229292,28 @@ let printLeadingComment ?nextComment comment = let separator = Doc.concat [ - (if singleLine then Doc.concat [ Doc.hardLine; Doc.breakParent ] + (if singleLine then Doc.concat [Doc.hardLine; Doc.breakParent] else Doc.nil); (match nextComment with | Some next -> - let nextLoc = Comment.loc next in - let currLoc = Comment.loc comment in - let diff = - nextLoc.Location.loc_start.pos_lnum - - currLoc.Location.loc_end.pos_lnum - in - let nextSingleLine = Comment.isSingleLineComment next in - if singleLine && nextSingleLine then - if diff > 1 then Doc.hardLine else Doc.nil - else if singleLine && not nextSingleLine then - if diff > 1 then Doc.hardLine else Doc.nil - else if diff > 1 then Doc.concat [ Doc.hardLine; Doc.hardLine ] - else if diff == 1 then Doc.hardLine - else Doc.space + let nextLoc = Comment.loc next in + let currLoc = Comment.loc comment in + let diff = + nextLoc.Location.loc_start.pos_lnum + - currLoc.Location.loc_end.pos_lnum + in + let nextSingleLine = Comment.isSingleLineComment next in + if singleLine && nextSingleLine then + if diff > 1 then Doc.hardLine else Doc.nil + else if singleLine && not nextSingleLine then + if diff > 1 then Doc.hardLine else Doc.nil + else if diff > 1 then Doc.concat [Doc.hardLine; Doc.hardLine] + else if diff == 1 then Doc.hardLine + else Doc.space | None -> Doc.nil); ] in - Doc.concat [ content; separator ] + Doc.concat [content; separator] (* This function is used for printing comments inside an empty block *) let printCommentsInside cmtTbl loc = @@ -229316,98 +229329,96 @@ let printCommentsInside cmtTbl loc = let rec loop acc comments = match comments with | [] -> Doc.nil - | [ comment ] -> - let cmtDoc = printComment comment in - let cmtsDoc = Doc.concat (Doc.softLine :: List.rev (cmtDoc :: acc)) in - let doc = - Doc.breakableGroup ~forceBreak - (Doc.concat - [ Doc.ifBreaks (Doc.indent cmtsDoc) cmtsDoc; Doc.softLine ]) - in - doc + | [comment] -> + let cmtDoc = printComment comment in + let cmtsDoc = Doc.concat (Doc.softLine :: List.rev (cmtDoc :: acc)) in + let doc = + Doc.breakableGroup ~forceBreak + (Doc.concat [Doc.ifBreaks (Doc.indent cmtsDoc) cmtsDoc; Doc.softLine]) + in + doc | comment :: rest -> - let cmtDoc = Doc.concat [ printComment comment; Doc.line ] in - loop (cmtDoc :: acc) rest + let cmtDoc = Doc.concat [printComment comment; Doc.line] in + loop (cmtDoc :: acc) rest in match Hashtbl.find cmtTbl.CommentTable.inside loc with | exception Not_found -> Doc.nil | comments -> - Hashtbl.remove cmtTbl.inside loc; - loop [] comments + Hashtbl.remove cmtTbl.inside loc; + loop [] comments (* This function is used for printing comments inside an empty file *) let printCommentsInsideFile cmtTbl = let rec loop acc comments = match comments with | [] -> Doc.nil - | [ comment ] -> - let cmtDoc = printLeadingComment comment in - let doc = - Doc.group (Doc.concat [ Doc.concat (List.rev (cmtDoc :: acc)) ]) - in - doc + | [comment] -> + let cmtDoc = printLeadingComment comment in + let doc = + Doc.group (Doc.concat [Doc.concat (List.rev (cmtDoc :: acc))]) + in + doc | comment :: (nextComment :: _comments as rest) -> - let cmtDoc = printLeadingComment ~nextComment comment in - loop (cmtDoc :: acc) rest + let cmtDoc = printLeadingComment ~nextComment comment in + loop (cmtDoc :: acc) rest in match Hashtbl.find cmtTbl.CommentTable.inside Location.none with | exception Not_found -> Doc.nil | comments -> - Hashtbl.remove cmtTbl.inside Location.none; - Doc.group (loop [] comments) + Hashtbl.remove cmtTbl.inside Location.none; + Doc.group (loop [] comments) let printLeadingComments node tbl loc = let rec loop acc comments = match comments with | [] -> node - | [ comment ] -> - let cmtDoc = printLeadingComment comment in - let diff = - loc.Location.loc_start.pos_lnum - - (Comment.loc comment).Location.loc_end.pos_lnum - in - let separator = - if Comment.isSingleLineComment comment then - if diff > 1 then Doc.hardLine else Doc.nil - else if diff == 0 then Doc.space - else if diff > 1 then Doc.concat [ Doc.hardLine; Doc.hardLine ] - else Doc.hardLine - in - let doc = - Doc.group - (Doc.concat - [ Doc.concat (List.rev (cmtDoc :: acc)); separator; node ]) - in - doc + | [comment] -> + let cmtDoc = printLeadingComment comment in + let diff = + loc.Location.loc_start.pos_lnum + - (Comment.loc comment).Location.loc_end.pos_lnum + in + let separator = + if Comment.isSingleLineComment comment then + if diff > 1 then Doc.hardLine else Doc.nil + else if diff == 0 then Doc.space + else if diff > 1 then Doc.concat [Doc.hardLine; Doc.hardLine] + else Doc.hardLine + in + let doc = + Doc.group + (Doc.concat [Doc.concat (List.rev (cmtDoc :: acc)); separator; node]) + in + doc | comment :: (nextComment :: _comments as rest) -> - let cmtDoc = printLeadingComment ~nextComment comment in - loop (cmtDoc :: acc) rest + let cmtDoc = printLeadingComment ~nextComment comment in + loop (cmtDoc :: acc) rest in match Hashtbl.find tbl loc with | exception Not_found -> node | comments -> - (* Remove comments from tbl: Some ast nodes have the same location. - * We only want to print comments once *) - Hashtbl.remove tbl loc; - loop [] comments + (* Remove comments from tbl: Some ast nodes have the same location. + * We only want to print comments once *) + Hashtbl.remove tbl loc; + loop [] comments let printTrailingComments node tbl loc = let rec loop prev acc comments = match comments with | [] -> Doc.concat (List.rev acc) | comment :: comments -> - let cmtDoc = printTrailingComment prev loc comment in - loop (Comment.loc comment) (cmtDoc :: acc) comments + let cmtDoc = printTrailingComment prev loc comment in + loop (Comment.loc comment) (cmtDoc :: acc) comments in match Hashtbl.find tbl loc with | exception Not_found -> node | [] -> node | _first :: _ as comments -> - (* Remove comments from tbl: Some ast nodes have the same location. - * We only want to print comments once *) - Hashtbl.remove tbl loc; - let cmtsDoc = loop loc [] comments in - Doc.concat [ node; cmtsDoc ] + (* Remove comments from tbl: Some ast nodes have the same location. + * We only want to print comments once *) + Hashtbl.remove tbl loc; + let cmtsDoc = loop loc [] comments in + Doc.concat [node; cmtsDoc] let printComments doc (tbl : CommentTable.t) loc = let docWithLeadingComments = printLeadingComments doc tbl.leading loc in @@ -229418,68 +229429,68 @@ let printList ~getLoc ~nodes ~print ?(forceBreak = false) t = match nodes with | [] -> (prevLoc, Doc.concat (List.rev acc)) | node :: nodes -> - let loc = getLoc node in - let startPos = - match getFirstLeadingComment t loc with - | None -> loc.loc_start - | Some comment -> (Comment.loc comment).loc_start - in - let sep = - if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then - Doc.concat [ Doc.hardLine; Doc.hardLine ] - else Doc.hardLine - in - let doc = printComments (print node t) t loc in - loop loc (doc :: sep :: acc) nodes + let loc = getLoc node in + let startPos = + match getFirstLeadingComment t loc with + | None -> loc.loc_start + | Some comment -> (Comment.loc comment).loc_start + in + let sep = + if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then + Doc.concat [Doc.hardLine; Doc.hardLine] + else Doc.hardLine + in + let doc = printComments (print node t) t loc in + loop loc (doc :: sep :: acc) nodes in match nodes with | [] -> Doc.nil | node :: nodes -> - let firstLoc = getLoc node in - let doc = printComments (print node t) t firstLoc in - let lastLoc, docs = loop firstLoc [ doc ] nodes in - let forceBreak = - forceBreak || firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak docs + let firstLoc = getLoc node in + let doc = printComments (print node t) t firstLoc in + let lastLoc, docs = loop firstLoc [doc] nodes in + let forceBreak = + forceBreak || firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak docs let printListi ~getLoc ~nodes ~print ?(forceBreak = false) t = let rec loop i (prevLoc : Location.t) acc nodes = match nodes with | [] -> (prevLoc, Doc.concat (List.rev acc)) | node :: nodes -> - let loc = getLoc node in - let startPos = - match getFirstLeadingComment t loc with - | None -> loc.loc_start - | Some comment -> (Comment.loc comment).loc_start - in - let sep = - if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then - Doc.concat [ Doc.hardLine; Doc.hardLine ] - else Doc.line - in - let doc = printComments (print node t i) t loc in - loop (i + 1) loc (doc :: sep :: acc) nodes + let loc = getLoc node in + let startPos = + match getFirstLeadingComment t loc with + | None -> loc.loc_start + | Some comment -> (Comment.loc comment).loc_start + in + let sep = + if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then + Doc.concat [Doc.hardLine; Doc.hardLine] + else Doc.line + in + let doc = printComments (print node t i) t loc in + loop (i + 1) loc (doc :: sep :: acc) nodes in match nodes with | [] -> Doc.nil | node :: nodes -> - let firstLoc = getLoc node in - let doc = printComments (print node t 0) t firstLoc in - let lastLoc, docs = loop 1 firstLoc [ doc ] nodes in - let forceBreak = - forceBreak || firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak docs + let firstLoc = getLoc node in + let doc = printComments (print node t 0) t firstLoc in + let lastLoc, docs = loop 1 firstLoc [doc] nodes in + let forceBreak = + forceBreak || firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak docs let rec printLongidentAux accu = function | Longident.Lident s -> Doc.text s :: accu | Ldot (lid, s) -> printLongidentAux (Doc.text s :: accu) lid | Lapply (lid1, lid2) -> - let d1 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid1) in - let d2 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid2) in - Doc.concat [ d1; Doc.lparen; d2; Doc.rparen ] :: accu + let d1 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid1) in + let d2 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid2) in + Doc.concat [d1; Doc.lparen; d2; Doc.rparen] :: accu let printLongident = function | Longident.Lident txt -> Doc.text txt @@ -229507,7 +229518,7 @@ let classifyIdentContent ?(allowUident = false) txt = let printIdentLike ?allowUident txt = match classifyIdentContent ?allowUident txt with - | ExoticIdent -> Doc.concat [ Doc.text "\\\""; Doc.text txt; Doc.text "\"" ] + | ExoticIdent -> Doc.concat [Doc.text "\\\""; Doc.text txt; Doc.text "\""] | NormalIdent -> Doc.text txt let rec unsafe_for_all_range s ~start ~finish p = @@ -229528,7 +229539,10 @@ let isValidNumericPolyvarNumber (x : string) = a <= 57 && if len > 1 then - a > 48 && for_all_from x 1 (function '0' .. '9' -> true | _ -> false) + a > 48 + && for_all_from x 1 (function + | '0' .. '9' -> true + | _ -> false) else a >= 48 (* Exotic identifiers in poly-vars have a "lighter" syntax: #"ease-in" *) @@ -229537,11 +229551,11 @@ let printPolyVarIdent txt = if isValidNumericPolyvarNumber txt then Doc.text txt else match classifyIdentContent ~allowUident:true txt with - | ExoticIdent -> Doc.concat [ Doc.text "\""; Doc.text txt; Doc.text "\"" ] + | ExoticIdent -> Doc.concat [Doc.text "\""; Doc.text txt; Doc.text "\""] | NormalIdent -> ( - match txt with - | "" -> Doc.concat [ Doc.text "\""; Doc.text txt; Doc.text "\"" ] - | _ -> Doc.text txt) + match txt with + | "" -> Doc.concat [Doc.text "\""; Doc.text txt; Doc.text "\""] + | _ -> Doc.text txt) let printLident l = let flatLidOpt lid = @@ -229555,18 +229569,18 @@ let printLident l = match l with | Longident.Lident txt -> printIdentLike txt | Longident.Ldot (path, txt) -> - let doc = - match flatLidOpt path with - | Some txts -> - Doc.concat - [ - Doc.join ~sep:Doc.dot (List.map Doc.text txts); - Doc.dot; - printIdentLike txt; - ] - | None -> Doc.text "printLident: Longident.Lapply is not supported" - in - doc + let doc = + match flatLidOpt path with + | Some txts -> + Doc.concat + [ + Doc.join ~sep:Doc.dot (List.map Doc.text txts); + Doc.dot; + printIdentLike txt; + ] + | None -> Doc.text "printLident: Longident.Lapply is not supported" + in + doc | Lapply (_, _) -> Doc.text "printLident: Longident.Lapply is not supported" let printLongidentLocation l cmtTbl = @@ -229594,42 +229608,42 @@ let printStringContents txt = let printConstant ?(templateLiteral = false) c = match c with | Parsetree.Pconst_integer (s, suffix) -> ( - match suffix with - | Some c -> Doc.text (s ^ Char.escaped c) - | None -> Doc.text s) + match suffix with + | Some c -> Doc.text (s ^ Char.escaped c) + | None -> Doc.text s) | Pconst_string (txt, None) -> - Doc.concat [ Doc.text "\""; printStringContents txt; Doc.text "\"" ] + Doc.concat [Doc.text "\""; printStringContents txt; Doc.text "\""] | Pconst_string (txt, Some prefix) -> - if prefix = "INTERNAL_RES_CHAR_CONTENTS" then - Doc.concat [ Doc.text "'"; Doc.text txt; Doc.text "'" ] - else - let lquote, rquote = - if templateLiteral then ("`", "`") else ("\"", "\"") - in - Doc.concat - [ - (if prefix = "js" then Doc.nil else Doc.text prefix); - Doc.text lquote; - printStringContents txt; - Doc.text rquote; - ] + if prefix = "INTERNAL_RES_CHAR_CONTENTS" then + Doc.concat [Doc.text "'"; Doc.text txt; Doc.text "'"] + else + let lquote, rquote = + if templateLiteral then ("`", "`") else ("\"", "\"") + in + Doc.concat + [ + (if prefix = "js" then Doc.nil else Doc.text prefix); + Doc.text lquote; + printStringContents txt; + Doc.text rquote; + ] | Pconst_float (s, _) -> Doc.text s | Pconst_char c -> - let str = - match Char.unsafe_chr c with - | '\'' -> "\\'" - | '\\' -> "\\\\" - | '\n' -> "\\n" - | '\t' -> "\\t" - | '\r' -> "\\r" - | '\b' -> "\\b" - | ' ' .. '~' as c -> - let s = (Bytes.create [@doesNotRaise]) 1 in - Bytes.unsafe_set s 0 c; - Bytes.unsafe_to_string s - | _ -> Res_utf8.encodeCodePoint c - in - Doc.text ("'" ^ str ^ "'") + let str = + match Char.unsafe_chr c with + | '\'' -> "\\'" + | '\\' -> "\\\\" + | '\n' -> "\\n" + | '\t' -> "\\t" + | '\r' -> "\\r" + | '\b' -> "\\b" + | ' ' .. '~' as c -> + let s = (Bytes.create [@doesNotRaise]) 1 in + Bytes.unsafe_set s 0 c; + Bytes.unsafe_to_string s + | _ -> Res_utf8.encodeCodePoint c + in + Doc.text ("'" ^ str ^ "'") let printOptionalLabel attrs = if Res_parsetree_viewer.hasOptionalAttribute attrs then Doc.text "?" @@ -229641,66 +229655,66 @@ let rec printStructure ~customLayout (s : Parsetree.structure) t = match s with | [] -> printCommentsInsideFile t | structure -> - printList - ~getLoc:(fun s -> s.Parsetree.pstr_loc) - ~nodes:structure - ~print:(printStructureItem ~customLayout) - t + printList + ~getLoc:(fun s -> s.Parsetree.pstr_loc) + ~nodes:structure + ~print:(printStructureItem ~customLayout) + t and printStructureItem ~customLayout (si : Parsetree.structure_item) cmtTbl = match si.pstr_desc with | Pstr_value (rec_flag, valueBindings) -> - let recFlag = - match rec_flag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - printValueBindings ~customLayout ~recFlag valueBindings cmtTbl + let recFlag = + match rec_flag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + printValueBindings ~customLayout ~recFlag valueBindings cmtTbl | Pstr_type (recFlag, typeDeclarations) -> - let recFlag = - match recFlag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - printTypeDeclarations ~customLayout ~recFlag typeDeclarations cmtTbl + let recFlag = + match recFlag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + printTypeDeclarations ~customLayout ~recFlag typeDeclarations cmtTbl | Pstr_primitive valueDescription -> - printValueDescription ~customLayout valueDescription cmtTbl + printValueDescription ~customLayout valueDescription cmtTbl | Pstr_eval (expr, attrs) -> - let exprDoc = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.structureExpr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat [ printAttributes ~customLayout attrs cmtTbl; exprDoc ] + let exprDoc = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.structureExpr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [printAttributes ~customLayout attrs cmtTbl; exprDoc] | Pstr_attribute attr -> - fst (printAttribute ~customLayout ~standalone:true attr cmtTbl) + fst (printAttribute ~customLayout ~standalone:true attr cmtTbl) | Pstr_extension (extension, attrs) -> - Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - Doc.concat - [ printExtension ~customLayout ~atModuleLvl:true extension cmtTbl ]; - ] + Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + Doc.concat + [printExtension ~customLayout ~atModuleLvl:true extension cmtTbl]; + ] | Pstr_include includeDeclaration -> - printIncludeDeclaration ~customLayout includeDeclaration cmtTbl + printIncludeDeclaration ~customLayout includeDeclaration cmtTbl | Pstr_open openDescription -> - printOpenDescription ~customLayout openDescription cmtTbl + printOpenDescription ~customLayout openDescription cmtTbl | Pstr_modtype modTypeDecl -> - printModuleTypeDeclaration ~customLayout modTypeDecl cmtTbl + printModuleTypeDeclaration ~customLayout modTypeDecl cmtTbl | Pstr_module moduleBinding -> - printModuleBinding ~customLayout ~isRec:false moduleBinding cmtTbl 0 + printModuleBinding ~customLayout ~isRec:false moduleBinding cmtTbl 0 | Pstr_recmodule moduleBindings -> - printListi - ~getLoc:(fun mb -> mb.Parsetree.pmb_loc) - ~nodes:moduleBindings - ~print:(printModuleBinding ~customLayout ~isRec:true) - cmtTbl + printListi + ~getLoc:(fun mb -> mb.Parsetree.pmb_loc) + ~nodes:moduleBindings + ~print:(printModuleBinding ~customLayout ~isRec:true) + cmtTbl | Pstr_exception extensionConstructor -> - printExceptionDef ~customLayout extensionConstructor cmtTbl + printExceptionDef ~customLayout extensionConstructor cmtTbl | Pstr_typext typeExtension -> - printTypeExtension ~customLayout typeExtension cmtTbl + printTypeExtension ~customLayout typeExtension cmtTbl | Pstr_class _ | Pstr_class_type _ -> Doc.nil and printTypeExtension ~customLayout (te : Parsetree.type_extension) cmtTbl = @@ -229712,14 +229726,13 @@ and printTypeExtension ~customLayout (te : Parsetree.type_extension) cmtTbl = let forceBreak = match (ecs, List.rev ecs) with | first :: _, last :: _ -> - first.pext_loc.loc_start.pos_lnum - > te.ptyext_path.loc.loc_end.pos_lnum - || first.pext_loc.loc_start.pos_lnum < last.pext_loc.loc_end.pos_lnum + first.pext_loc.loc_start.pos_lnum > te.ptyext_path.loc.loc_end.pos_lnum + || first.pext_loc.loc_start.pos_lnum < last.pext_loc.loc_end.pos_lnum | _ -> false in let privateFlag = match te.ptyext_private with - | Asttypes.Private -> Doc.concat [ Doc.text "private"; Doc.line ] + | Asttypes.Private -> Doc.concat [Doc.text "private"; Doc.line] | Public -> Doc.nil in let rows = @@ -229756,15 +229769,14 @@ and printModuleBinding ~customLayout ~isRec moduleBinding cmtTbl i = let prefix = if i = 0 then Doc.concat - [ Doc.text "module "; (if isRec then Doc.text "rec " else Doc.nil) ] + [Doc.text "module "; (if isRec then Doc.text "rec " else Doc.nil)] else Doc.text "and " in let modExprDoc, modConstraintDoc = match moduleBinding.pmb_expr with - | { pmod_desc = Pmod_constraint (modExpr, modType) } -> - ( printModExpr ~customLayout modExpr cmtTbl, - Doc.concat - [ Doc.text ": "; printModType ~customLayout modType cmtTbl ] ) + | {pmod_desc = Pmod_constraint (modExpr, modType)} -> + ( printModExpr ~customLayout modExpr cmtTbl, + Doc.concat [Doc.text ": "; printModType ~customLayout modType cmtTbl] ) | modExpr -> (printModExpr ~customLayout modExpr cmtTbl, Doc.nil) in let modName = @@ -229799,160 +229811,153 @@ and printModuleTypeDeclaration ~customLayout (match modTypeDecl.pmtd_type with | None -> Doc.nil | Some modType -> - Doc.concat - [ Doc.text " = "; printModType ~customLayout modType cmtTbl ]); + Doc.concat [Doc.text " = "; printModType ~customLayout modType cmtTbl]); ] and printModType ~customLayout modType cmtTbl = let modTypeDoc = match modType.pmty_desc with | Parsetree.Pmty_ident longident -> - Doc.concat - [ - printAttributes ~customLayout ~loc:longident.loc - modType.pmty_attributes cmtTbl; - printLongidentLocation longident cmtTbl; - ] + Doc.concat + [ + printAttributes ~customLayout ~loc:longident.loc + modType.pmty_attributes cmtTbl; + printLongidentLocation longident cmtTbl; + ] | Pmty_signature [] -> - if hasCommentsInside cmtTbl modType.pmty_loc then - let doc = printCommentsInside cmtTbl modType.pmty_loc in - Doc.concat [ Doc.lbrace; doc; Doc.rbrace ] - else - let shouldBreak = - modType.pmty_loc.loc_start.pos_lnum - < modType.pmty_loc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak:shouldBreak - (Doc.concat [ Doc.lbrace; Doc.softLine; Doc.softLine; Doc.rbrace ]) + if hasCommentsInside cmtTbl modType.pmty_loc then + let doc = printCommentsInside cmtTbl modType.pmty_loc in + Doc.concat [Doc.lbrace; doc; Doc.rbrace] + else + let shouldBreak = + modType.pmty_loc.loc_start.pos_lnum + < modType.pmty_loc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak:shouldBreak + (Doc.concat [Doc.lbrace; Doc.softLine; Doc.softLine; Doc.rbrace]) | Pmty_signature signature -> - let signatureDoc = - Doc.breakableGroup ~forceBreak:true + let signatureDoc = + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [Doc.line; printSignature ~customLayout signature cmtTbl]); + Doc.line; + Doc.rbrace; + ]) + in + Doc.concat + [ + printAttributes ~customLayout modType.pmty_attributes cmtTbl; + signatureDoc; + ] + | Pmty_functor _ -> + let parameters, returnType = ParsetreeViewer.functorType modType in + let parametersDoc = + match parameters with + | [] -> Doc.nil + | [(attrs, {Location.txt = "_"; loc}, Some modType)] -> + let cmtLoc = + {loc with loc_end = modType.Parsetree.pmty_loc.loc_end} + in + let attrs = printAttributes ~customLayout attrs cmtTbl in + let doc = + Doc.concat [attrs; printModType ~customLayout modType cmtTbl] + in + printComments doc cmtTbl cmtLoc + | params -> + Doc.group (Doc.concat [ - Doc.lbrace; + Doc.lparen; Doc.indent (Doc.concat [ - Doc.line; printSignature ~customLayout signature cmtTbl; + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun (attrs, lbl, modType) -> + let cmtLoc = + match modType with + | None -> lbl.Asttypes.loc + | Some modType -> + { + lbl.Asttypes.loc with + loc_end = + modType.Parsetree.pmty_loc.loc_end; + } + in + let attrs = + printAttributes ~customLayout attrs cmtTbl + in + let lblDoc = + if lbl.Location.txt = "_" || lbl.txt = "*" then + Doc.nil + else + let doc = Doc.text lbl.txt in + printComments doc cmtTbl lbl.loc + in + let doc = + Doc.concat + [ + attrs; + lblDoc; + (match modType with + | None -> Doc.nil + | Some modType -> + Doc.concat + [ + (if lbl.txt = "_" then Doc.nil + else Doc.text ": "); + printModType ~customLayout modType + cmtTbl; + ]); + ] + in + printComments doc cmtTbl cmtLoc) + params); ]); - Doc.line; - Doc.rbrace; + Doc.trailingComma; + Doc.softLine; + Doc.rparen; ]) - in - Doc.concat - [ - printAttributes ~customLayout modType.pmty_attributes cmtTbl; - signatureDoc; - ] - | Pmty_functor _ -> - let parameters, returnType = ParsetreeViewer.functorType modType in - let parametersDoc = - match parameters with - | [] -> Doc.nil - | [ (attrs, { Location.txt = "_"; loc }, Some modType) ] -> - let cmtLoc = - { loc with loc_end = modType.Parsetree.pmty_loc.loc_end } - in - let attrs = printAttributes ~customLayout attrs cmtTbl in - let doc = - Doc.concat [ attrs; printModType ~customLayout modType cmtTbl ] - in - printComments doc cmtTbl cmtLoc - | params -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun (attrs, lbl, modType) -> - let cmtLoc = - match modType with - | None -> lbl.Asttypes.loc - | Some modType -> - { - lbl.Asttypes.loc with - loc_end = - modType.Parsetree.pmty_loc.loc_end; - } - in - let attrs = - printAttributes ~customLayout attrs cmtTbl - in - let lblDoc = - if lbl.Location.txt = "_" || lbl.txt = "*" - then Doc.nil - else - let doc = Doc.text lbl.txt in - printComments doc cmtTbl lbl.loc - in - let doc = - Doc.concat - [ - attrs; - lblDoc; - (match modType with - | None -> Doc.nil - | Some modType -> - Doc.concat - [ - (if lbl.txt = "_" then Doc.nil - else Doc.text ": "); - printModType ~customLayout - modType cmtTbl; - ]); - ] - in - printComments doc cmtTbl cmtLoc) - params); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) - in - let returnDoc = - let doc = printModType ~customLayout returnType cmtTbl in - if Parens.modTypeFunctorReturn returnType then addParens doc else doc - in - Doc.group - (Doc.concat - [ - parametersDoc; - Doc.group (Doc.concat [ Doc.text " =>"; Doc.line; returnDoc ]); - ]) + in + let returnDoc = + let doc = printModType ~customLayout returnType cmtTbl in + if Parens.modTypeFunctorReturn returnType then addParens doc else doc + in + Doc.group + (Doc.concat + [ + parametersDoc; + Doc.group (Doc.concat [Doc.text " =>"; Doc.line; returnDoc]); + ]) | Pmty_typeof modExpr -> - Doc.concat - [ - Doc.text "module type of "; - printModExpr ~customLayout modExpr cmtTbl; - ] + Doc.concat + [Doc.text "module type of "; printModExpr ~customLayout modExpr cmtTbl] | Pmty_extension extension -> - printExtension ~customLayout ~atModuleLvl:false extension cmtTbl + printExtension ~customLayout ~atModuleLvl:false extension cmtTbl | Pmty_alias longident -> - Doc.concat - [ Doc.text "module "; printLongidentLocation longident cmtTbl ] + Doc.concat [Doc.text "module "; printLongidentLocation longident cmtTbl] | Pmty_with (modType, withConstraints) -> - let operand = - let doc = printModType ~customLayout modType cmtTbl in - if Parens.modTypeWithOperand modType then addParens doc else doc - in - Doc.group - (Doc.concat - [ - operand; - Doc.indent - (Doc.concat - [ - Doc.line; - printWithConstraints ~customLayout withConstraints cmtTbl; - ]); - ]) + let operand = + let doc = printModType ~customLayout modType cmtTbl in + if Parens.modTypeWithOperand modType then addParens doc else doc + in + Doc.group + (Doc.concat + [ + operand; + Doc.indent + (Doc.concat + [ + Doc.line; + printWithConstraints ~customLayout withConstraints cmtTbl; + ]); + ]) in let attrsAlreadyPrinted = match modType.pmty_desc with @@ -229988,78 +229993,78 @@ and printWithConstraint ~customLayout match withConstraint with (* with type X.t = ... *) | Pwith_type (longident, typeDeclaration) -> - Doc.group - (printTypeDeclaration ~customLayout - ~name:(printLidentPath longident cmtTbl) - ~equalSign:"=" ~recFlag:Doc.nil 0 typeDeclaration CommentTable.empty) + Doc.group + (printTypeDeclaration ~customLayout + ~name:(printLidentPath longident cmtTbl) + ~equalSign:"=" ~recFlag:Doc.nil 0 typeDeclaration CommentTable.empty) (* with module X.Y = Z *) - | Pwith_module ({ txt = longident1 }, { txt = longident2 }) -> - Doc.concat - [ - Doc.text "module "; - printLongident longident1; - Doc.text " ="; - Doc.indent (Doc.concat [ Doc.line; printLongident longident2 ]); - ] + | Pwith_module ({txt = longident1}, {txt = longident2}) -> + Doc.concat + [ + Doc.text "module "; + printLongident longident1; + Doc.text " ="; + Doc.indent (Doc.concat [Doc.line; printLongident longident2]); + ] (* with type X.t := ..., same format as [Pwith_type] *) | Pwith_typesubst (longident, typeDeclaration) -> - Doc.group - (printTypeDeclaration ~customLayout - ~name:(printLidentPath longident cmtTbl) - ~equalSign:":=" ~recFlag:Doc.nil 0 typeDeclaration CommentTable.empty) - | Pwith_modsubst ({ txt = longident1 }, { txt = longident2 }) -> - Doc.concat - [ - Doc.text "module "; - printLongident longident1; - Doc.text " :="; - Doc.indent (Doc.concat [ Doc.line; printLongident longident2 ]); - ] + Doc.group + (printTypeDeclaration ~customLayout + ~name:(printLidentPath longident cmtTbl) + ~equalSign:":=" ~recFlag:Doc.nil 0 typeDeclaration CommentTable.empty) + | Pwith_modsubst ({txt = longident1}, {txt = longident2}) -> + Doc.concat + [ + Doc.text "module "; + printLongident longident1; + Doc.text " :="; + Doc.indent (Doc.concat [Doc.line; printLongident longident2]); + ] and printSignature ~customLayout signature cmtTbl = match signature with | [] -> printCommentsInsideFile cmtTbl | signature -> - printList - ~getLoc:(fun s -> s.Parsetree.psig_loc) - ~nodes:signature - ~print:(printSignatureItem ~customLayout) - cmtTbl + printList + ~getLoc:(fun s -> s.Parsetree.psig_loc) + ~nodes:signature + ~print:(printSignatureItem ~customLayout) + cmtTbl and printSignatureItem ~customLayout (si : Parsetree.signature_item) cmtTbl = match si.psig_desc with | Parsetree.Psig_value valueDescription -> - printValueDescription ~customLayout valueDescription cmtTbl + printValueDescription ~customLayout valueDescription cmtTbl | Psig_type (recFlag, typeDeclarations) -> - let recFlag = - match recFlag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - printTypeDeclarations ~customLayout ~recFlag typeDeclarations cmtTbl + let recFlag = + match recFlag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + printTypeDeclarations ~customLayout ~recFlag typeDeclarations cmtTbl | Psig_typext typeExtension -> - printTypeExtension ~customLayout typeExtension cmtTbl + printTypeExtension ~customLayout typeExtension cmtTbl | Psig_exception extensionConstructor -> - printExceptionDef ~customLayout extensionConstructor cmtTbl + printExceptionDef ~customLayout extensionConstructor cmtTbl | Psig_module moduleDeclaration -> - printModuleDeclaration ~customLayout moduleDeclaration cmtTbl + printModuleDeclaration ~customLayout moduleDeclaration cmtTbl | Psig_recmodule moduleDeclarations -> - printRecModuleDeclarations ~customLayout moduleDeclarations cmtTbl + printRecModuleDeclarations ~customLayout moduleDeclarations cmtTbl | Psig_modtype modTypeDecl -> - printModuleTypeDeclaration ~customLayout modTypeDecl cmtTbl + printModuleTypeDeclaration ~customLayout modTypeDecl cmtTbl | Psig_open openDescription -> - printOpenDescription ~customLayout openDescription cmtTbl + printOpenDescription ~customLayout openDescription cmtTbl | Psig_include includeDescription -> - printIncludeDescription ~customLayout includeDescription cmtTbl + printIncludeDescription ~customLayout includeDescription cmtTbl | Psig_attribute attr -> - fst (printAttribute ~customLayout ~standalone:true attr cmtTbl) + fst (printAttribute ~customLayout ~standalone:true attr cmtTbl) | Psig_extension (extension, attrs) -> - Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - Doc.concat - [ printExtension ~customLayout ~atModuleLvl:true extension cmtTbl ]; - ] + Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + Doc.concat + [printExtension ~customLayout ~atModuleLvl:true extension cmtTbl]; + ] | Psig_class _ | Psig_class_type _ -> Doc.nil and printRecModuleDeclarations ~customLayout moduleDeclarations cmtTbl = @@ -230073,22 +230078,23 @@ and printRecModuleDeclaration ~customLayout md cmtTbl i = let body = match md.pmd_type.pmty_desc with | Parsetree.Pmty_alias longident -> - Doc.concat [ Doc.text " = "; printLongidentLocation longident cmtTbl ] + Doc.concat [Doc.text " = "; printLongidentLocation longident cmtTbl] | _ -> - let needsParens = - match md.pmd_type.pmty_desc with Pmty_with _ -> true | _ -> false - in - let modTypeDoc = - let doc = printModType ~customLayout md.pmd_type cmtTbl in - if needsParens then addParens doc else doc - in - Doc.concat [ Doc.text ": "; modTypeDoc ] + let needsParens = + match md.pmd_type.pmty_desc with + | Pmty_with _ -> true + | _ -> false + in + let modTypeDoc = + let doc = printModType ~customLayout md.pmd_type cmtTbl in + if needsParens then addParens doc else doc + in + Doc.concat [Doc.text ": "; modTypeDoc] in let prefix = if i < 1 then "module rec " else "and " in Doc.concat [ - printAttributes ~customLayout ~loc:md.pmd_name.loc md.pmd_attributes - cmtTbl; + printAttributes ~customLayout ~loc:md.pmd_name.loc md.pmd_attributes cmtTbl; Doc.text prefix; printComments (Doc.text md.pmd_name.txt) cmtTbl md.pmd_name.loc; body; @@ -230099,15 +230105,13 @@ and printModuleDeclaration ~customLayout (md : Parsetree.module_declaration) let body = match md.pmd_type.pmty_desc with | Parsetree.Pmty_alias longident -> - Doc.concat [ Doc.text " = "; printLongidentLocation longident cmtTbl ] + Doc.concat [Doc.text " = "; printLongidentLocation longident cmtTbl] | _ -> - Doc.concat - [ Doc.text ": "; printModType ~customLayout md.pmd_type cmtTbl ] + Doc.concat [Doc.text ": "; printModType ~customLayout md.pmd_type cmtTbl] in Doc.concat [ - printAttributes ~customLayout ~loc:md.pmd_name.loc md.pmd_attributes - cmtTbl; + printAttributes ~customLayout ~loc:md.pmd_name.loc md.pmd_attributes cmtTbl; Doc.text "module "; printComments (Doc.text md.pmd_name.txt) cmtTbl md.pmd_name.loc; body; @@ -230158,7 +230162,9 @@ and printValueBindings ~customLayout ~recFlag and printValueDescription ~customLayout valueDescription cmtTbl = let isExternal = - match valueDescription.pval_prim with [] -> false | _ -> true + match valueDescription.pval_prim with + | [] -> false + | _ -> true in let attrs = printAttributes ~customLayout ~loc:valueDescription.pval_name.loc @@ -230188,7 +230194,7 @@ and printValueDescription ~customLayout valueDescription cmtTbl = (List.map (fun s -> Doc.concat - [ Doc.text "\""; Doc.text s; Doc.text "\"" ]) + [Doc.text "\""; Doc.text s; Doc.text "\""]) valueDescription.pval_prim); ]); ]) @@ -230240,72 +230246,72 @@ and printTypeDeclaration ~customLayout ~name ~equalSign ~recFlag i printAttributes ~customLayout ~loc:td.ptype_loc td.ptype_attributes cmtTbl in let prefix = - if i > 0 then Doc.text "and " else Doc.concat [ Doc.text "type "; recFlag ] + if i > 0 then Doc.text "and " else Doc.concat [Doc.text "type "; recFlag] in let typeName = name in let typeParams = printTypeParams ~customLayout td.ptype_params cmtTbl in let manifestAndKind = match td.ptype_kind with | Ptype_abstract -> ( - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; - printPrivateFlag td.ptype_private; - printTypExpr ~customLayout typ cmtTbl; - ]) - | Ptype_open -> + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> Doc.concat [ - Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; printPrivateFlag td.ptype_private; - Doc.text ".."; - ] + printTypExpr ~customLayout typ cmtTbl; + ]) + | Ptype_open -> + Doc.concat + [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printPrivateFlag td.ptype_private; + Doc.text ".."; + ] | Ptype_record lds -> - let manifest = - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; - printTypExpr ~customLayout typ cmtTbl; - ] - in - Doc.concat - [ - manifest; - Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; - printPrivateFlag td.ptype_private; - printRecordDeclaration ~customLayout lds cmtTbl; - ] + let manifest = + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> + Doc.concat + [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printTypExpr ~customLayout typ cmtTbl; + ] + in + Doc.concat + [ + manifest; + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printPrivateFlag td.ptype_private; + printRecordDeclaration ~customLayout lds cmtTbl; + ] | Ptype_variant cds -> - let manifest = - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; - printTypExpr ~customLayout typ cmtTbl; - ] - in - Doc.concat - [ - manifest; - Doc.concat [ Doc.space; Doc.text equalSign ]; - printConstructorDeclarations ~customLayout - ~privateFlag:td.ptype_private cds cmtTbl; - ] + let manifest = + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> + Doc.concat + [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printTypExpr ~customLayout typ cmtTbl; + ] + in + Doc.concat + [ + manifest; + Doc.concat [Doc.space; Doc.text equalSign]; + printConstructorDeclarations ~customLayout + ~privateFlag:td.ptype_private cds cmtTbl; + ] in let constraints = printTypeDefinitionConstraints ~customLayout td.ptype_cstrs in Doc.group (Doc.concat - [ attrs; prefix; typeName; typeParams; manifestAndKind; constraints ]) + [attrs; prefix; typeName; typeParams; manifestAndKind; constraints]) and printTypeDeclaration2 ~customLayout ~recFlag (td : Parsetree.type_declaration) cmtTbl i = @@ -230318,99 +230324,99 @@ and printTypeDeclaration2 ~customLayout ~recFlag printAttributes ~customLayout ~loc:td.ptype_loc td.ptype_attributes cmtTbl in let prefix = - if i > 0 then Doc.text "and " else Doc.concat [ Doc.text "type "; recFlag ] + if i > 0 then Doc.text "and " else Doc.concat [Doc.text "type "; recFlag] in let typeName = name in let typeParams = printTypeParams ~customLayout td.ptype_params cmtTbl in let manifestAndKind = match td.ptype_kind with | Ptype_abstract -> ( - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; - printPrivateFlag td.ptype_private; - printTypExpr ~customLayout typ cmtTbl; - ]) - | Ptype_open -> + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> Doc.concat [ - Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; printPrivateFlag td.ptype_private; - Doc.text ".."; - ] + printTypExpr ~customLayout typ cmtTbl; + ]) + | Ptype_open -> + Doc.concat + [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printPrivateFlag td.ptype_private; + Doc.text ".."; + ] | Ptype_record lds -> - if lds = [] then - Doc.concat - [ - Doc.space; - Doc.text equalSign; - Doc.space; - Doc.lbrace; - printCommentsInside cmtTbl td.ptype_loc; - Doc.rbrace; - ] - else - let manifest = - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; - printTypExpr ~customLayout typ cmtTbl; - ] - in - Doc.concat - [ - manifest; - Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; - printPrivateFlag td.ptype_private; - printRecordDeclaration ~customLayout lds cmtTbl; - ] - | Ptype_variant cds -> + if lds = [] then + Doc.concat + [ + Doc.space; + Doc.text equalSign; + Doc.space; + Doc.lbrace; + printCommentsInside cmtTbl td.ptype_loc; + Doc.rbrace; + ] + else let manifest = match td.ptype_manifest with | None -> Doc.nil | Some typ -> - Doc.concat - [ - Doc.concat [ Doc.space; Doc.text equalSign; Doc.space ]; - printTypExpr ~customLayout typ cmtTbl; - ] + Doc.concat + [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printTypExpr ~customLayout typ cmtTbl; + ] in Doc.concat [ manifest; - Doc.concat [ Doc.space; Doc.text equalSign ]; - printConstructorDeclarations ~customLayout - ~privateFlag:td.ptype_private cds cmtTbl; + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printPrivateFlag td.ptype_private; + printRecordDeclaration ~customLayout lds cmtTbl; ] + | Ptype_variant cds -> + let manifest = + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> + Doc.concat + [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printTypExpr ~customLayout typ cmtTbl; + ] + in + Doc.concat + [ + manifest; + Doc.concat [Doc.space; Doc.text equalSign]; + printConstructorDeclarations ~customLayout + ~privateFlag:td.ptype_private cds cmtTbl; + ] in let constraints = printTypeDefinitionConstraints ~customLayout td.ptype_cstrs in Doc.group (Doc.concat - [ attrs; prefix; typeName; typeParams; manifestAndKind; constraints ]) + [attrs; prefix; typeName; typeParams; manifestAndKind; constraints]) and printTypeDefinitionConstraints ~customLayout cstrs = match cstrs with | [] -> Doc.nil | cstrs -> - Doc.indent - (Doc.group - (Doc.concat - [ - Doc.line; - Doc.group - (Doc.join ~sep:Doc.line - (List.map - (printTypeDefinitionConstraint ~customLayout) - cstrs)); - ])) + Doc.indent + (Doc.group + (Doc.concat + [ + Doc.line; + Doc.group + (Doc.join ~sep:Doc.line + (List.map + (printTypeDefinitionConstraint ~customLayout) + cstrs)); + ])) and printTypeDefinitionConstraint ~customLayout ((typ1, typ2, _loc) : @@ -230424,35 +230430,37 @@ and printTypeDefinitionConstraint ~customLayout ] and printPrivateFlag (flag : Asttypes.private_flag) = - match flag with Private -> Doc.text "private " | Public -> Doc.nil + match flag with + | Private -> Doc.text "private " + | Public -> Doc.nil and printTypeParams ~customLayout typeParams cmtTbl = match typeParams with | [] -> Doc.nil | typeParams -> - Doc.group - (Doc.concat - [ - Doc.lessThan; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun typeParam -> - let doc = - printTypeParam ~customLayout typeParam cmtTbl - in - printComments doc cmtTbl - (fst typeParam).Parsetree.ptyp_loc) - typeParams); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.greaterThan; - ]) + Doc.group + (Doc.concat + [ + Doc.lessThan; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun typeParam -> + let doc = + printTypeParam ~customLayout typeParam cmtTbl + in + printComments doc cmtTbl + (fst typeParam).Parsetree.ptyp_loc) + typeParams); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.greaterThan; + ]) and printTypeParam ~customLayout (param : Parsetree.core_type * Asttypes.variance) cmtTbl = @@ -230463,14 +230471,14 @@ and printTypeParam ~customLayout | Contravariant -> Doc.text "-" | Invariant -> Doc.nil in - Doc.concat [ printedVariance; printTypExpr ~customLayout typ cmtTbl ] + Doc.concat [printedVariance; printTypExpr ~customLayout typ cmtTbl] and printRecordDeclaration ~customLayout (lds : Parsetree.label_declaration list) cmtTbl = let forceBreak = match (lds, List.rev lds) with | first :: _, last :: _ -> - first.pld_loc.loc_start.pos_lnum < last.pld_loc.loc_end.pos_lnum + first.pld_loc.loc_start.pos_lnum < last.pld_loc.loc_end.pos_lnum | _ -> false in Doc.breakableGroup ~forceBreak @@ -230482,7 +230490,7 @@ and printRecordDeclaration ~customLayout [ Doc.softLine; Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map (fun ld -> let doc = @@ -230501,12 +230509,12 @@ and printConstructorDeclarations ~customLayout ~privateFlag let forceBreak = match (cds, List.rev cds) with | first :: _, last :: _ -> - first.pcd_loc.loc_start.pos_lnum < last.pcd_loc.loc_end.pos_lnum + first.pcd_loc.loc_start.pos_lnum < last.pcd_loc.loc_end.pos_lnum | _ -> false in let privateFlag = match privateFlag with - | Asttypes.Private -> Doc.concat [ Doc.text "private"; Doc.line ] + | Asttypes.Private -> Doc.concat [Doc.text "private"; Doc.line] | Public -> Doc.nil in let rows = @@ -230519,7 +230527,7 @@ and printConstructorDeclarations ~customLayout ~privateFlag ~forceBreak cmtTbl in Doc.breakableGroup ~forceBreak - (Doc.indent (Doc.concat [ Doc.line; privateFlag; rows ])) + (Doc.indent (Doc.concat [Doc.line; privateFlag; rows])) and printConstructorDeclaration2 ~customLayout i (cd : Parsetree.constructor_declaration) cmtTbl = @@ -230539,8 +230547,8 @@ and printConstructorDeclaration2 ~customLayout i match cd.pcd_res with | None -> Doc.nil | Some typ -> - Doc.indent - (Doc.concat [ Doc.text ": "; printTypExpr ~customLayout typ cmtTbl ]) + Doc.indent + (Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ cmtTbl]) in Doc.concat [ @@ -230561,55 +230569,54 @@ and printConstructorArguments ~customLayout ~indent match cdArgs with | Pcstr_tuple [] -> Doc.nil | Pcstr_tuple types -> - let args = - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun typexpr -> - printTypExpr ~customLayout typexpr cmtTbl) - types); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - in - Doc.group (if indent then Doc.indent args else args) + let args = + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun typexpr -> printTypExpr ~customLayout typexpr cmtTbl) + types); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + in + Doc.group (if indent then Doc.indent args else args) | Pcstr_record lds -> - let args = - Doc.concat - [ - Doc.lparen; - (* manually inline the printRecordDeclaration, gives better layout *) - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun ld -> - let doc = - printLabelDeclaration ~customLayout ld cmtTbl - in - printComments doc cmtTbl ld.Parsetree.pld_loc) - lds); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - Doc.rparen; - ] - in - if indent then Doc.indent args else args + let args = + Doc.concat + [ + Doc.lparen; + (* manually inline the printRecordDeclaration, gives better layout *) + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun ld -> + let doc = + printLabelDeclaration ~customLayout ld cmtTbl + in + printComments doc cmtTbl ld.Parsetree.pld_loc) + lds); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + Doc.rparen; + ] + in + if indent then Doc.indent args else args and printLabelDeclaration ~customLayout (ld : Parsetree.label_declaration) cmtTbl = @@ -230642,261 +230649,242 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = match typExpr.ptyp_desc with | Ptyp_any -> Doc.text "_" | Ptyp_var var -> - Doc.concat [ Doc.text "'"; printIdentLike ~allowUident:true var ] + Doc.concat [Doc.text "'"; printIdentLike ~allowUident:true var] | Ptyp_extension extension -> - printExtension ~customLayout ~atModuleLvl:false extension cmtTbl + printExtension ~customLayout ~atModuleLvl:false extension cmtTbl | Ptyp_alias (typ, alias) -> - let typ = - (* Technically type t = (string, float) => unit as 'x, doesn't require - * parens around the arrow expression. This is very confusing though. - * Is the "as" part of "unit" or "(string, float) => unit". By printing - * parens we guide the user towards its meaning.*) - let needsParens = - match typ.ptyp_desc with Ptyp_arrow _ -> true | _ -> false - in - let doc = printTypExpr ~customLayout typ cmtTbl in - if needsParens then Doc.concat [ Doc.lparen; doc; Doc.rparen ] - else doc + let typ = + (* Technically type t = (string, float) => unit as 'x, doesn't require + * parens around the arrow expression. This is very confusing though. + * Is the "as" part of "unit" or "(string, float) => unit". By printing + * parens we guide the user towards its meaning.*) + let needsParens = + match typ.ptyp_desc with + | Ptyp_arrow _ -> true + | _ -> false in - Doc.concat - [ - typ; - Doc.text " as "; - Doc.concat [ Doc.text "'"; printIdentLike alias ]; - ] + let doc = printTypExpr ~customLayout typ cmtTbl in + if needsParens then Doc.concat [Doc.lparen; doc; Doc.rparen] else doc + in + Doc.concat + [typ; Doc.text " as "; Doc.concat [Doc.text "'"; printIdentLike alias]] (* object printings *) | Ptyp_object (fields, openFlag) -> - printObject ~customLayout ~inline:false fields openFlag cmtTbl - | Ptyp_constr - (longidentLoc, [ { ptyp_desc = Ptyp_object (fields, openFlag) } ]) -> - (* for foo<{"a": b}>, when the object is long and needs a line break, we - want the <{ and }> to stay hugged together *) - let constrName = printLidentPath longidentLoc cmtTbl in - Doc.concat - [ - constrName; - Doc.lessThan; - printObject ~customLayout ~inline:true fields openFlag cmtTbl; - Doc.greaterThan; - ] - | Ptyp_constr (longidentLoc, [ { ptyp_desc = Parsetree.Ptyp_tuple tuple } ]) + printObject ~customLayout ~inline:false fields openFlag cmtTbl + | Ptyp_constr (longidentLoc, [{ptyp_desc = Ptyp_object (fields, openFlag)}]) -> - let constrName = printLidentPath longidentLoc cmtTbl in + (* for foo<{"a": b}>, when the object is long and needs a line break, we + want the <{ and }> to stay hugged together *) + let constrName = printLidentPath longidentLoc cmtTbl in + Doc.concat + [ + constrName; + Doc.lessThan; + printObject ~customLayout ~inline:true fields openFlag cmtTbl; + Doc.greaterThan; + ] + | Ptyp_constr (longidentLoc, [{ptyp_desc = Parsetree.Ptyp_tuple tuple}]) -> + let constrName = printLidentPath longidentLoc cmtTbl in + Doc.group + (Doc.concat + [ + constrName; + Doc.lessThan; + printTupleType ~customLayout ~inline:true tuple cmtTbl; + Doc.greaterThan; + ]) + | Ptyp_constr (longidentLoc, constrArgs) -> ( + let constrName = printLidentPath longidentLoc cmtTbl in + match constrArgs with + | [] -> constrName + | _args -> Doc.group (Doc.concat [ constrName; Doc.lessThan; - printTupleType ~customLayout ~inline:true tuple cmtTbl; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun typexpr -> + printTypExpr ~customLayout typexpr cmtTbl) + constrArgs); + ]); + Doc.trailingComma; + Doc.softLine; Doc.greaterThan; - ]) - | Ptyp_constr (longidentLoc, constrArgs) -> ( - let constrName = printLidentPath longidentLoc cmtTbl in - match constrArgs with - | [] -> constrName - | _args -> - Doc.group - (Doc.concat - [ - constrName; - Doc.lessThan; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun typexpr -> - printTypExpr ~customLayout typexpr cmtTbl) - constrArgs); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.greaterThan; - ])) + ])) | Ptyp_arrow _ -> ( - let attrsBefore, args, returnType = ParsetreeViewer.arrowType typExpr in - let returnTypeNeedsParens = - match returnType.ptyp_desc with Ptyp_alias _ -> true | _ -> false + let attrsBefore, args, returnType = ParsetreeViewer.arrowType typExpr in + let returnTypeNeedsParens = + match returnType.ptyp_desc with + | Ptyp_alias _ -> true + | _ -> false + in + let returnDoc = + let doc = printTypExpr ~customLayout returnType cmtTbl in + if returnTypeNeedsParens then Doc.concat [Doc.lparen; doc; Doc.rparen] + else doc + in + let isUncurried, attrs = + ParsetreeViewer.processUncurriedAttribute attrsBefore + in + match args with + | [] -> Doc.nil + | [([], Nolabel, n)] when not isUncurried -> + let hasAttrsBefore = not (attrs = []) in + let attrs = + if hasAttrsBefore then + printAttributes ~customLayout ~inline:true attrsBefore cmtTbl + else Doc.nil in - let returnDoc = - let doc = printTypExpr ~customLayout returnType cmtTbl in - if returnTypeNeedsParens then - Doc.concat [ Doc.lparen; doc; Doc.rparen ] - else doc + let typDoc = + let doc = printTypExpr ~customLayout n cmtTbl in + match n.ptyp_desc with + | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> addParens doc + | _ -> doc in - let isUncurried, attrs = - ParsetreeViewer.processUncurriedAttribute attrsBefore + Doc.group + (Doc.concat + [ + Doc.group attrs; + Doc.group + (if hasAttrsBefore then + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [Doc.softLine; typDoc; Doc.text " => "; returnDoc]); + Doc.softLine; + Doc.rparen; + ] + else Doc.concat [typDoc; Doc.text " => "; returnDoc]); + ]) + | args -> + let attrs = printAttributes ~customLayout ~inline:true attrs cmtTbl in + let renderedArgs = + Doc.concat + [ + attrs; + Doc.text "("; + Doc.indent + (Doc.concat + [ + Doc.softLine; + (if isUncurried then Doc.concat [Doc.dot; Doc.space] + else Doc.nil); + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun tp -> printTypeParameter ~customLayout tp cmtTbl) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.text ")"; + ] in - match args with - | [] -> Doc.nil - | [ ([], Nolabel, n) ] when not isUncurried -> - let hasAttrsBefore = not (attrs = []) in - let attrs = - if hasAttrsBefore then - printAttributes ~customLayout ~inline:true attrsBefore cmtTbl - else Doc.nil - in - let typDoc = - let doc = printTypExpr ~customLayout n cmtTbl in - match n.ptyp_desc with - | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> addParens doc - | _ -> doc - in - Doc.group - (Doc.concat - [ - Doc.group attrs; - Doc.group - (if hasAttrsBefore then - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - typDoc; - Doc.text " => "; - returnDoc; - ]); - Doc.softLine; - Doc.rparen; - ] - else Doc.concat [ typDoc; Doc.text " => "; returnDoc ]); - ]) - | args -> - let attrs = - printAttributes ~customLayout ~inline:true attrs cmtTbl - in - let renderedArgs = - Doc.concat - [ - attrs; - Doc.text "("; - Doc.indent - (Doc.concat - [ - Doc.softLine; - (if isUncurried then Doc.concat [ Doc.dot; Doc.space ] - else Doc.nil); - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun tp -> - printTypeParameter ~customLayout tp cmtTbl) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.text ")"; - ] - in - Doc.group (Doc.concat [ renderedArgs; Doc.text " => "; returnDoc ])) + Doc.group (Doc.concat [renderedArgs; Doc.text " => "; returnDoc])) | Ptyp_tuple types -> - printTupleType ~customLayout ~inline:false types cmtTbl + printTupleType ~customLayout ~inline:false types cmtTbl | Ptyp_poly ([], typ) -> printTypExpr ~customLayout typ cmtTbl | Ptyp_poly (stringLocs, typ) -> - Doc.concat - [ - Doc.join ~sep:Doc.space - (List.map - (fun { Location.txt; loc } -> - let doc = Doc.concat [ Doc.text "'"; Doc.text txt ] in - printComments doc cmtTbl loc) - stringLocs); - Doc.dot; - Doc.space; - printTypExpr ~customLayout typ cmtTbl; - ] + Doc.concat + [ + Doc.join ~sep:Doc.space + (List.map + (fun {Location.txt; loc} -> + let doc = Doc.concat [Doc.text "'"; Doc.text txt] in + printComments doc cmtTbl loc) + stringLocs); + Doc.dot; + Doc.space; + printTypExpr ~customLayout typ cmtTbl; + ] | Ptyp_package packageType -> - printPackageType ~customLayout ~printModuleKeywordAndParens:true - packageType cmtTbl + printPackageType ~customLayout ~printModuleKeywordAndParens:true + packageType cmtTbl | Ptyp_class _ -> Doc.text "classes are not supported in types" | Ptyp_variant (rowFields, closedFlag, labelsOpt) -> - let forceBreak = - typExpr.ptyp_loc.Location.loc_start.pos_lnum - < typExpr.ptyp_loc.loc_end.pos_lnum - in - let printRowField = function - | Parsetree.Rtag ({ txt; loc }, attrs, true, []) -> - let doc = - Doc.group - (Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - Doc.concat [ Doc.text "#"; printPolyVarIdent txt ]; - ]) - in - printComments doc cmtTbl loc - | Rtag ({ txt }, attrs, truth, types) -> - let doType t = - match t.Parsetree.ptyp_desc with - | Ptyp_tuple _ -> printTypExpr ~customLayout t cmtTbl - | _ -> - Doc.concat - [ - Doc.lparen; - printTypExpr ~customLayout t cmtTbl; - Doc.rparen; - ] - in - let printedTypes = List.map doType types in - let cases = - Doc.join - ~sep:(Doc.concat [ Doc.line; Doc.text "& " ]) - printedTypes - in - let cases = - if truth then Doc.concat [ Doc.line; Doc.text "& "; cases ] - else cases - in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - Doc.concat [ Doc.text "#"; printPolyVarIdent txt ]; - cases; - ]) - | Rinherit coreType -> printTypExpr ~customLayout coreType cmtTbl - in - let docs = List.map printRowField rowFields in - let cases = - Doc.join ~sep:(Doc.concat [ Doc.line; Doc.text "| " ]) docs - in - let cases = - if docs = [] then cases - else Doc.concat [ Doc.ifBreaks (Doc.text "| ") Doc.nil; cases ] - in - let openingSymbol = - if closedFlag = Open then Doc.concat [ Doc.greaterThan; Doc.line ] - else if labelsOpt = None then Doc.softLine - else Doc.concat [ Doc.lessThan; Doc.line ] - in - let labels = - match labelsOpt with - | None | Some [] -> Doc.nil - | Some labels -> + let forceBreak = + typExpr.ptyp_loc.Location.loc_start.pos_lnum + < typExpr.ptyp_loc.loc_end.pos_lnum + in + let printRowField = function + | Parsetree.Rtag ({txt; loc}, attrs, true, []) -> + let doc = + Doc.group + (Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + Doc.concat [Doc.text "#"; printPolyVarIdent txt]; + ]) + in + printComments doc cmtTbl loc + | Rtag ({txt}, attrs, truth, types) -> + let doType t = + match t.Parsetree.ptyp_desc with + | Ptyp_tuple _ -> printTypExpr ~customLayout t cmtTbl + | _ -> Doc.concat - (List.map - (fun label -> - Doc.concat - [ Doc.line; Doc.text "#"; printPolyVarIdent label ]) - labels) - in - let closingSymbol = - match labelsOpt with None | Some [] -> Doc.nil | _ -> Doc.text " >" - in - Doc.breakableGroup ~forceBreak - (Doc.concat - [ - Doc.lbracket; - Doc.indent - (Doc.concat [ openingSymbol; cases; closingSymbol; labels ]); - Doc.softLine; - Doc.rbracket; - ]) + [Doc.lparen; printTypExpr ~customLayout t cmtTbl; Doc.rparen] + in + let printedTypes = List.map doType types in + let cases = + Doc.join ~sep:(Doc.concat [Doc.line; Doc.text "& "]) printedTypes + in + let cases = + if truth then Doc.concat [Doc.line; Doc.text "& "; cases] else cases + in + Doc.group + (Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + Doc.concat [Doc.text "#"; printPolyVarIdent txt]; + cases; + ]) + | Rinherit coreType -> printTypExpr ~customLayout coreType cmtTbl + in + let docs = List.map printRowField rowFields in + let cases = Doc.join ~sep:(Doc.concat [Doc.line; Doc.text "| "]) docs in + let cases = + if docs = [] then cases + else Doc.concat [Doc.ifBreaks (Doc.text "| ") Doc.nil; cases] + in + let openingSymbol = + if closedFlag = Open then Doc.concat [Doc.greaterThan; Doc.line] + else if labelsOpt = None then Doc.softLine + else Doc.concat [Doc.lessThan; Doc.line] + in + let labels = + match labelsOpt with + | None | Some [] -> Doc.nil + | Some labels -> + Doc.concat + (List.map + (fun label -> + Doc.concat [Doc.line; Doc.text "#"; printPolyVarIdent label]) + labels) + in + let closingSymbol = + match labelsOpt with + | None | Some [] -> Doc.nil + | _ -> Doc.text " >" + in + Doc.breakableGroup ~forceBreak + (Doc.concat + [ + Doc.lbracket; + Doc.indent + (Doc.concat [openingSymbol; cases; closingSymbol; labels]); + Doc.softLine; + Doc.rbracket; + ]) in let shouldPrintItsOwnAttributes = match typExpr.ptyp_desc with @@ -230906,9 +230894,8 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = let doc = match typExpr.ptyp_attributes with | _ :: _ as attrs when not shouldPrintItsOwnAttributes -> - Doc.group - (Doc.concat - [ printAttributes ~customLayout attrs cmtTbl; renderedType ]) + Doc.group + (Doc.concat [printAttributes ~customLayout attrs cmtTbl; renderedType]) | _ -> renderedType in printComments doc cmtTbl typExpr.ptyp_loc @@ -230917,41 +230904,40 @@ and printObject ~customLayout ~inline fields openFlag cmtTbl = let doc = match fields with | [] -> - Doc.concat - [ - Doc.lbrace; - (match openFlag with - | Asttypes.Closed -> Doc.dot - | Open -> Doc.dotdot); - Doc.rbrace; - ] + Doc.concat + [ + Doc.lbrace; + (match openFlag with + | Asttypes.Closed -> Doc.dot + | Open -> Doc.dotdot); + Doc.rbrace; + ] | fields -> - Doc.concat - [ - Doc.lbrace; - (match openFlag with - | Asttypes.Closed -> Doc.nil - | Open -> ( - match fields with - (* handle `type t = {.. ...objType, "x": int}` - * .. and ... should have a space in between *) - | Oinherit _ :: _ -> Doc.text ".. " - | _ -> Doc.dotdot)); - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun field -> - printObjectField ~customLayout field cmtTbl) - fields); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ] + Doc.concat + [ + Doc.lbrace; + (match openFlag with + | Asttypes.Closed -> Doc.nil + | Open -> ( + match fields with + (* handle `type t = {.. ...objType, "x": int}` + * .. and ... should have a space in between *) + | Oinherit _ :: _ -> Doc.text ".. " + | _ -> Doc.dotdot)); + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun field -> printObjectField ~customLayout field cmtTbl) + fields); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ] in if inline then doc else Doc.group doc @@ -230966,7 +230952,7 @@ and printTupleType ~customLayout ~inline (types : Parsetree.core_type list) [ Doc.softLine; Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) + ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map (fun typexpr -> printTypExpr ~customLayout typexpr cmtTbl) types); @@ -230981,23 +230967,23 @@ and printTupleType ~customLayout ~inline (types : Parsetree.core_type list) and printObjectField ~customLayout (field : Parsetree.object_field) cmtTbl = match field with | Otag (labelLoc, attrs, typ) -> - let lbl = - let doc = Doc.text ("\"" ^ labelLoc.txt ^ "\"") in - printComments doc cmtTbl labelLoc.loc - in - let doc = - Doc.concat - [ - printAttributes ~customLayout ~loc:labelLoc.loc attrs cmtTbl; - lbl; - Doc.text ": "; - printTypExpr ~customLayout typ cmtTbl; - ] - in - let cmtLoc = { labelLoc.loc with loc_end = typ.ptyp_loc.loc_end } in - printComments doc cmtTbl cmtLoc + let lbl = + let doc = Doc.text ("\"" ^ labelLoc.txt ^ "\"") in + printComments doc cmtTbl labelLoc.loc + in + let doc = + Doc.concat + [ + printAttributes ~customLayout ~loc:labelLoc.loc attrs cmtTbl; + lbl; + Doc.text ": "; + printTypExpr ~customLayout typ cmtTbl; + ] + in + let cmtLoc = {labelLoc.loc with loc_end = typ.ptyp_loc.loc_end} in + printComments doc cmtTbl cmtLoc | Oinherit typexpr -> - Doc.concat [ Doc.dotdotdot; printTypExpr ~customLayout typexpr cmtTbl ] + Doc.concat [Doc.dotdotdot; printTypExpr ~customLayout typexpr cmtTbl] (* es6 arrow type arg * type t = (~foo: string, ~bar: float=?, unit) => unit @@ -231005,16 +230991,16 @@ and printObjectField ~customLayout (field : Parsetree.object_field) cmtTbl = and printTypeParameter ~customLayout (attrs, lbl, typ) cmtTbl = let isUncurried, attrs = ParsetreeViewer.processUncurriedAttribute attrs in let uncurried = - if isUncurried then Doc.concat [ Doc.dot; Doc.space ] else Doc.nil + if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil in let attrs = printAttributes ~customLayout attrs cmtTbl in let label = match lbl with | Asttypes.Nolabel -> Doc.nil | Labelled lbl -> - Doc.concat [ Doc.text "~"; printIdentLike lbl; Doc.text ": " ] + Doc.concat [Doc.text "~"; printIdentLike lbl; Doc.text ": "] | Optional lbl -> - Doc.concat [ Doc.text "~"; printIdentLike lbl; Doc.text ": " ] + Doc.concat [Doc.text "~"; printIdentLike lbl; Doc.text ": "] in let optionalIndicator = match lbl with @@ -231023,9 +231009,9 @@ and printTypeParameter ~customLayout (attrs, lbl, typ) cmtTbl = in let loc, typ = match typ.ptyp_attributes with - | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: attrs -> - ( { loc with loc_end = typ.ptyp_loc.loc_end }, - { typ with ptyp_attributes = attrs } ) + | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: attrs -> + ( {loc with loc_end = typ.ptyp_loc.loc_end}, + {typ with ptyp_attributes = attrs} ) | _ -> (typ.ptyp_loc, typ) in let doc = @@ -231048,178 +231034,169 @@ and printValueBinding ~customLayout ~recFlag (vb : Parsetree.value_binding) cmtTbl in let header = - if i == 0 then Doc.concat [ Doc.text "let "; recFlag ] else Doc.text "and " + if i == 0 then Doc.concat [Doc.text "let "; recFlag] else Doc.text "and " in match vb with | { pvb_pat = { ppat_desc = - Ppat_constraint (pattern, ({ ptyp_desc = Ptyp_poly _ } as patTyp)); + Ppat_constraint (pattern, ({ptyp_desc = Ptyp_poly _} as patTyp)); }; - pvb_expr = { pexp_desc = Pexp_newtype _ } as expr; + pvb_expr = {pexp_desc = Pexp_newtype _} as expr; } -> ( - let _attrs, parameters, returnExpr = ParsetreeViewer.funExpr expr in - let abstractType = - match parameters with - | [ NewTypes { locs = vars } ] -> - Doc.concat - [ - Doc.text "type "; - Doc.join ~sep:Doc.space - (List.map (fun var -> Doc.text var.Asttypes.txt) vars); - Doc.dot; - ] - | _ -> Doc.nil - in - match returnExpr.pexp_desc with - | Pexp_constraint (expr, typ) -> + let _attrs, parameters, returnExpr = ParsetreeViewer.funExpr expr in + let abstractType = + match parameters with + | [NewTypes {locs = vars}] -> + Doc.concat + [ + Doc.text "type "; + Doc.join ~sep:Doc.space + (List.map (fun var -> Doc.text var.Asttypes.txt) vars); + Doc.dot; + ] + | _ -> Doc.nil + in + match returnExpr.pexp_desc with + | Pexp_constraint (expr, typ) -> + Doc.group + (Doc.concat + [ + attrs; + header; + printPattern ~customLayout pattern cmtTbl; + Doc.text ":"; + Doc.indent + (Doc.concat + [ + Doc.line; + abstractType; + Doc.space; + printTypExpr ~customLayout typ cmtTbl; + Doc.text " ="; + Doc.concat + [ + Doc.line; + printExpressionWithComments ~customLayout expr cmtTbl; + ]; + ]); + ]) + | _ -> + (* Example: + * let cancel_and_collect_callbacks: + * 'a 'u 'c. (list, promise<'a, 'u, 'c>) => list = * (type x, callbacks_accumulator, p: promise<_, _, c>) + *) + Doc.group + (Doc.concat + [ + attrs; + header; + printPattern ~customLayout pattern cmtTbl; + Doc.text ":"; + Doc.indent + (Doc.concat + [ + Doc.line; + abstractType; + Doc.space; + printTypExpr ~customLayout patTyp cmtTbl; + Doc.text " ="; + Doc.concat + [ + Doc.line; + printExpressionWithComments ~customLayout expr cmtTbl; + ]; + ]); + ])) + | _ -> + let optBraces, expr = ParsetreeViewer.processBracesAttr vb.pvb_expr in + let printedExpr = + let doc = printExpressionWithComments ~customLayout vb.pvb_expr cmtTbl in + match Parens.expr vb.pvb_expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + let patternDoc = printPattern ~customLayout vb.pvb_pat cmtTbl in + (* + * we want to optimize the layout of one pipe: + * let tbl = data->Js.Array2.reduce((map, curr) => { + * ... + * }) + * important is that we don't do this for multiple pipes: + * let decoratorTags = + * items + * ->Js.Array2.filter(items => {items.category === Decorators}) + * ->Belt.Array.map(...) + * Multiple pipes chained together lend themselves more towards the last layout. + *) + if ParsetreeViewer.isSinglePipeExpr vb.pvb_expr then + Doc.customLayout + [ Doc.group (Doc.concat [ - attrs; - header; - printPattern ~customLayout pattern cmtTbl; - Doc.text ":"; - Doc.indent - (Doc.concat - [ - Doc.line; - abstractType; - Doc.space; - printTypExpr ~customLayout typ cmtTbl; - Doc.text " ="; - Doc.concat - [ - Doc.line; - printExpressionWithComments ~customLayout expr - cmtTbl; - ]; - ]); - ]) - | _ -> - (* Example: - * let cancel_and_collect_callbacks: - * 'a 'u 'c. (list, promise<'a, 'u, 'c>) => list = * (type x, callbacks_accumulator, p: promise<_, _, c>) - *) + attrs; header; patternDoc; Doc.text " ="; Doc.space; printedExpr; + ]); Doc.group (Doc.concat [ attrs; header; - printPattern ~customLayout pattern cmtTbl; - Doc.text ":"; - Doc.indent - (Doc.concat - [ - Doc.line; - abstractType; - Doc.space; - printTypExpr ~customLayout patTyp cmtTbl; - Doc.text " ="; - Doc.concat - [ - Doc.line; - printExpressionWithComments ~customLayout expr - cmtTbl; - ]; - ]); - ])) - | _ -> - let optBraces, expr = ParsetreeViewer.processBracesAttr vb.pvb_expr in - let printedExpr = - let doc = - printExpressionWithComments ~customLayout vb.pvb_expr cmtTbl - in - match Parens.expr vb.pvb_expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc + patternDoc; + Doc.text " ="; + Doc.indent (Doc.concat [Doc.line; printedExpr]); + ]); + ] + else + let shouldIndent = + match optBraces with + | Some _ -> false + | _ -> ( + ParsetreeViewer.isBinaryExpression expr + || + match vb.pvb_expr with + | { + pexp_attributes = [({Location.txt = "ns.ternary"}, _)]; + pexp_desc = Pexp_ifthenelse (ifExpr, _, _); + } -> + ParsetreeViewer.isBinaryExpression ifExpr + || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes + | {pexp_desc = Pexp_newtype _} -> false + | e -> + ParsetreeViewer.hasAttributes e.pexp_attributes + || ParsetreeViewer.isArrayAccess e) in - let patternDoc = printPattern ~customLayout vb.pvb_pat cmtTbl in - (* - * we want to optimize the layout of one pipe: - * let tbl = data->Js.Array2.reduce((map, curr) => { - * ... - * }) - * important is that we don't do this for multiple pipes: - * let decoratorTags = - * items - * ->Js.Array2.filter(items => {items.category === Decorators}) - * ->Belt.Array.map(...) - * Multiple pipes chained together lend themselves more towards the last layout. - *) - if ParsetreeViewer.isSinglePipeExpr vb.pvb_expr then - Doc.customLayout - [ - Doc.group - (Doc.concat - [ - attrs; - header; - patternDoc; - Doc.text " ="; - Doc.space; - printedExpr; - ]); - Doc.group - (Doc.concat - [ - attrs; - header; - patternDoc; - Doc.text " ="; - Doc.indent (Doc.concat [ Doc.line; printedExpr ]); - ]); - ] - else - let shouldIndent = - match optBraces with - | Some _ -> false - | _ -> ( - ParsetreeViewer.isBinaryExpression expr - || - match vb.pvb_expr with - | { - pexp_attributes = [ ({ Location.txt = "ns.ternary" }, _) ]; - pexp_desc = Pexp_ifthenelse (ifExpr, _, _); - } -> - ParsetreeViewer.isBinaryExpression ifExpr - || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes - | { pexp_desc = Pexp_newtype _ } -> false - | e -> - ParsetreeViewer.hasAttributes e.pexp_attributes - || ParsetreeViewer.isArrayAccess e) - in - Doc.group - (Doc.concat - [ - attrs; - header; - patternDoc; - Doc.text " ="; - (if shouldIndent then - Doc.indent (Doc.concat [ Doc.line; printedExpr ]) - else Doc.concat [ Doc.space; printedExpr ]); - ]) + Doc.group + (Doc.concat + [ + attrs; + header; + patternDoc; + Doc.text " ="; + (if shouldIndent then + Doc.indent (Doc.concat [Doc.line; printedExpr]) + else Doc.concat [Doc.space; printedExpr]); + ]) and printPackageType ~customLayout ~printModuleKeywordAndParens (packageType : Parsetree.package_type) cmtTbl = let doc = match packageType with | longidentLoc, [] -> - Doc.group (Doc.concat [ printLongidentLocation longidentLoc cmtTbl ]) + Doc.group (Doc.concat [printLongidentLocation longidentLoc cmtTbl]) | longidentLoc, packageConstraints -> - Doc.group - (Doc.concat - [ - printLongidentLocation longidentLoc cmtTbl; - printPackageConstraints ~customLayout packageConstraints cmtTbl; - Doc.softLine; - ]) + Doc.group + (Doc.concat + [ + printLongidentLocation longidentLoc cmtTbl; + printPackageConstraints ~customLayout packageConstraints cmtTbl; + Doc.softLine; + ]) in if printModuleKeywordAndParens then - Doc.concat [ Doc.text "module("; doc; Doc.rparen ] + Doc.concat [Doc.text "module("; doc; Doc.rparen] else doc and printPackageConstraints ~customLayout packageConstraints cmtTbl = @@ -231271,7 +231248,7 @@ and printExtension ~customLayout ~atModuleLvl (stringLoc, payload) cmtTbl = in printComments doc cmtTbl stringLoc.Location.loc in - Doc.group (Doc.concat [ extName; printPayload ~customLayout payload cmtTbl ]) + Doc.group (Doc.concat [extName; printPayload ~customLayout payload cmtTbl]) and printPattern ~customLayout (p : Parsetree.pattern) cmtTbl = let patternWithoutAttributes = @@ -231279,404 +231256,376 @@ and printPattern ~customLayout (p : Parsetree.pattern) cmtTbl = | Ppat_any -> Doc.text "_" | Ppat_var var -> printIdentLike var.txt | Ppat_constant c -> - let templateLiteral = - ParsetreeViewer.hasTemplateLiteralAttr p.ppat_attributes - in - printConstant ~templateLiteral c + let templateLiteral = + ParsetreeViewer.hasTemplateLiteralAttr p.ppat_attributes + in + printConstant ~templateLiteral c | Ppat_tuple patterns -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) - (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) - patterns); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) | Ppat_array [] -> - Doc.concat - [ Doc.lbracket; printCommentsInside cmtTbl p.ppat_loc; Doc.rbracket ] + Doc.concat + [Doc.lbracket; printCommentsInside cmtTbl p.ppat_loc; Doc.rbracket] | Ppat_array patterns -> - Doc.group - (Doc.concat - [ - Doc.text "["; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) - (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) - patterns); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.text "]"; - ]) - | Ppat_construct ({ txt = Longident.Lident "()" }, _) -> - Doc.concat - [ Doc.lparen; printCommentsInside cmtTbl p.ppat_loc; Doc.rparen ] - | Ppat_construct ({ txt = Longident.Lident "[]" }, _) -> + Doc.group + (Doc.concat + [ + Doc.text "["; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.text "]"; + ]) + | Ppat_construct ({txt = Longident.Lident "()"}, _) -> + Doc.concat [Doc.lparen; printCommentsInside cmtTbl p.ppat_loc; Doc.rparen] + | Ppat_construct ({txt = Longident.Lident "[]"}, _) -> + Doc.concat + [Doc.text "list{"; printCommentsInside cmtTbl p.ppat_loc; Doc.rbrace] + | Ppat_construct ({txt = Longident.Lident "::"}, _) -> + let patterns, tail = + ParsetreeViewer.collectPatternsFromListConstruct [] p + in + let shouldHug = + match (patterns, tail) with + | [pat], {ppat_desc = Ppat_construct ({txt = Longident.Lident "[]"}, _)} + when ParsetreeViewer.isHuggablePattern pat -> + true + | _ -> false + in + let children = Doc.concat [ - Doc.text "list{"; printCommentsInside cmtTbl p.ppat_loc; Doc.rbrace; + (if shouldHug then Doc.nil else Doc.softLine); + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); + (match tail.Parsetree.ppat_desc with + | Ppat_construct ({txt = Longident.Lident "[]"}, _) -> Doc.nil + | _ -> + let doc = + Doc.concat + [Doc.text "..."; printPattern ~customLayout tail cmtTbl] + in + let tail = printComments doc cmtTbl tail.ppat_loc in + Doc.concat [Doc.text ","; Doc.line; tail]); ] - | Ppat_construct ({ txt = Longident.Lident "::" }, _) -> - let patterns, tail = - ParsetreeViewer.collectPatternsFromListConstruct [] p - in - let shouldHug = - match (patterns, tail) with - | ( [ pat ], - { - ppat_desc = Ppat_construct ({ txt = Longident.Lident "[]" }, _); - } ) - when ParsetreeViewer.isHuggablePattern pat -> - true - | _ -> false - in - let children = + in + Doc.group + (Doc.concat + [ + Doc.text "list{"; + (if shouldHug then children + else + Doc.concat + [ + Doc.indent children; + Doc.ifBreaks (Doc.text ",") Doc.nil; + Doc.softLine; + ]); + Doc.rbrace; + ]) + | Ppat_construct (constrName, constructorArgs) -> + let constrName = printLongidentLocation constrName cmtTbl in + let argsDoc = + match constructorArgs with + | None -> Doc.nil + | Some + { + ppat_loc; + ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _); + } -> + Doc.concat + [Doc.lparen; printCommentsInside cmtTbl ppat_loc; Doc.rparen] + | Some {ppat_desc = Ppat_tuple []; ppat_loc = loc} -> + Doc.concat [Doc.lparen; printCommentsInside cmtTbl loc; Doc.rparen] + (* Some((1, 2) *) + | Some {ppat_desc = Ppat_tuple [({ppat_desc = Ppat_tuple _} as arg)]} -> + Doc.concat + [Doc.lparen; printPattern ~customLayout arg cmtTbl; Doc.rparen] + | Some {ppat_desc = Ppat_tuple patterns} -> Doc.concat [ - (if shouldHug then Doc.nil else Doc.softLine); - Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) - (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) - patterns); - (match tail.Parsetree.ppat_desc with - | Ppat_construct ({ txt = Longident.Lident "[]" }, _) -> Doc.nil - | _ -> - let doc = - Doc.concat - [ Doc.text "..."; printPattern ~customLayout tail cmtTbl ] - in - let tail = printComments doc cmtTbl tail.ppat_loc in - Doc.concat [ Doc.text ","; Doc.line; tail ]); - ] - in - Doc.group - (Doc.concat - [ - Doc.text "list{"; - (if shouldHug then children - else - Doc.concat + Doc.lparen; + Doc.indent + (Doc.concat [ - Doc.indent children; - Doc.ifBreaks (Doc.text ",") Doc.nil; Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); ]); - Doc.rbrace; - ]) - | Ppat_construct (constrName, constructorArgs) -> - let constrName = printLongidentLocation constrName cmtTbl in - let argsDoc = - match constructorArgs with - | None -> Doc.nil - | Some - { - ppat_loc; - ppat_desc = Ppat_construct ({ txt = Longident.Lident "()" }, _); - } -> - Doc.concat - [ Doc.lparen; printCommentsInside cmtTbl ppat_loc; Doc.rparen ] - | Some { ppat_desc = Ppat_tuple []; ppat_loc = loc } -> - Doc.concat - [ Doc.lparen; printCommentsInside cmtTbl loc; Doc.rparen ] - (* Some((1, 2) *) - | Some - { - ppat_desc = Ppat_tuple [ ({ ppat_desc = Ppat_tuple _ } as arg) ]; - } -> - Doc.concat - [ - Doc.lparen; printPattern ~customLayout arg cmtTbl; Doc.rparen; - ] - | Some { ppat_desc = Ppat_tuple patterns } -> - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) - patterns); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some arg -> - let argDoc = printPattern ~customLayout arg cmtTbl in - let shouldHug = ParsetreeViewer.isHuggablePattern arg in - Doc.concat - [ - Doc.lparen; - (if shouldHug then argDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [ Doc.softLine; argDoc ]); - Doc.trailingComma; - Doc.softLine; - ]); - Doc.rparen; - ] - in - Doc.group (Doc.concat [ constrName; argsDoc ]) + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + | Some arg -> + let argDoc = printPattern ~customLayout arg cmtTbl in + let shouldHug = ParsetreeViewer.isHuggablePattern arg in + Doc.concat + [ + Doc.lparen; + (if shouldHug then argDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [Doc.softLine; argDoc]); + Doc.trailingComma; + Doc.softLine; + ]); + Doc.rparen; + ] + in + Doc.group (Doc.concat [constrName; argsDoc]) | Ppat_variant (label, None) -> - Doc.concat [ Doc.text "#"; printPolyVarIdent label ] + Doc.concat [Doc.text "#"; printPolyVarIdent label] | Ppat_variant (label, variantArgs) -> - let variantName = - Doc.concat [ Doc.text "#"; printPolyVarIdent label ] - in - let argsDoc = - match variantArgs with - | None -> Doc.nil - | Some - { - ppat_desc = Ppat_construct ({ txt = Longident.Lident "()" }, _); - } -> - Doc.text "()" - | Some { ppat_desc = Ppat_tuple []; ppat_loc = loc } -> - Doc.concat - [ Doc.lparen; printCommentsInside cmtTbl loc; Doc.rparen ] - (* Some((1, 2) *) - | Some - { - ppat_desc = Ppat_tuple [ ({ ppat_desc = Ppat_tuple _ } as arg) ]; - } -> - Doc.concat - [ - Doc.lparen; printPattern ~customLayout arg cmtTbl; Doc.rparen; - ] - | Some { ppat_desc = Ppat_tuple patterns } -> - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) - patterns); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some arg -> - let argDoc = printPattern ~customLayout arg cmtTbl in - let shouldHug = ParsetreeViewer.isHuggablePattern arg in - Doc.concat - [ - Doc.lparen; - (if shouldHug then argDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [ Doc.softLine; argDoc ]); - Doc.trailingComma; - Doc.softLine; - ]); - Doc.rparen; - ] - in - Doc.group (Doc.concat [ variantName; argsDoc ]) + let variantName = Doc.concat [Doc.text "#"; printPolyVarIdent label] in + let argsDoc = + match variantArgs with + | None -> Doc.nil + | Some {ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _)} + -> + Doc.text "()" + | Some {ppat_desc = Ppat_tuple []; ppat_loc = loc} -> + Doc.concat [Doc.lparen; printCommentsInside cmtTbl loc; Doc.rparen] + (* Some((1, 2) *) + | Some {ppat_desc = Ppat_tuple [({ppat_desc = Ppat_tuple _} as arg)]} -> + Doc.concat + [Doc.lparen; printPattern ~customLayout arg cmtTbl; Doc.rparen] + | Some {ppat_desc = Ppat_tuple patterns} -> + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + | Some arg -> + let argDoc = printPattern ~customLayout arg cmtTbl in + let shouldHug = ParsetreeViewer.isHuggablePattern arg in + Doc.concat + [ + Doc.lparen; + (if shouldHug then argDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [Doc.softLine; argDoc]); + Doc.trailingComma; + Doc.softLine; + ]); + Doc.rparen; + ] + in + Doc.group (Doc.concat [variantName; argsDoc]) | Ppat_type ident -> - Doc.concat [ Doc.text "#..."; printIdentPath ident cmtTbl ] + Doc.concat [Doc.text "#..."; printIdentPath ident cmtTbl] | Ppat_record (rows, openFlag) -> - Doc.group - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) - (List.map - (fun row -> - printPatternRecordRow ~customLayout row cmtTbl) - rows); - (match openFlag with - | Open -> - Doc.concat [ Doc.text ","; Doc.line; Doc.text "_" ] - | Closed -> Doc.nil); - ]); - Doc.ifBreaks (Doc.text ",") Doc.nil; - Doc.softLine; - Doc.rbrace; - ]) + Doc.group + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun row -> + printPatternRecordRow ~customLayout row cmtTbl) + rows); + (match openFlag with + | Open -> Doc.concat [Doc.text ","; Doc.line; Doc.text "_"] + | Closed -> Doc.nil); + ]); + Doc.ifBreaks (Doc.text ",") Doc.nil; + Doc.softLine; + Doc.rbrace; + ]) | Ppat_exception p -> - let needsParens = - match p.ppat_desc with - | Ppat_or (_, _) | Ppat_alias (_, _) -> true - | _ -> false - in - let pat = - let p = printPattern ~customLayout p cmtTbl in - if needsParens then Doc.concat [ Doc.text "("; p; Doc.text ")" ] - else p - in - Doc.group (Doc.concat [ Doc.text "exception"; Doc.line; pat ]) + let needsParens = + match p.ppat_desc with + | Ppat_or (_, _) | Ppat_alias (_, _) -> true + | _ -> false + in + let pat = + let p = printPattern ~customLayout p cmtTbl in + if needsParens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p + in + Doc.group (Doc.concat [Doc.text "exception"; Doc.line; pat]) | Ppat_or _ -> - (* Blue | Red | Green -> [Blue; Red; Green] *) - let orChain = ParsetreeViewer.collectOrPatternChain p in - let docs = - List.mapi - (fun i pat -> - let patternDoc = printPattern ~customLayout pat cmtTbl in - Doc.concat - [ - (if i == 0 then Doc.nil - else Doc.concat [ Doc.line; Doc.text "| " ]); - (match pat.ppat_desc with - (* (Blue | Red) | (Green | Black) | White *) - | Ppat_or _ -> addParens patternDoc - | _ -> patternDoc); - ]) - orChain - in - let isSpreadOverMultipleLines = - match (orChain, List.rev orChain) with - | first :: _, last :: _ -> - first.ppat_loc.loc_start.pos_lnum < last.ppat_loc.loc_end.pos_lnum - | _ -> false - in - Doc.breakableGroup ~forceBreak:isSpreadOverMultipleLines - (Doc.concat docs) + (* Blue | Red | Green -> [Blue; Red; Green] *) + let orChain = ParsetreeViewer.collectOrPatternChain p in + let docs = + List.mapi + (fun i pat -> + let patternDoc = printPattern ~customLayout pat cmtTbl in + Doc.concat + [ + (if i == 0 then Doc.nil + else Doc.concat [Doc.line; Doc.text "| "]); + (match pat.ppat_desc with + (* (Blue | Red) | (Green | Black) | White *) + | Ppat_or _ -> addParens patternDoc + | _ -> patternDoc); + ]) + orChain + in + let isSpreadOverMultipleLines = + match (orChain, List.rev orChain) with + | first :: _, last :: _ -> + first.ppat_loc.loc_start.pos_lnum < last.ppat_loc.loc_end.pos_lnum + | _ -> false + in + Doc.breakableGroup ~forceBreak:isSpreadOverMultipleLines (Doc.concat docs) | Ppat_extension ext -> - printExtension ~customLayout ~atModuleLvl:false ext cmtTbl + printExtension ~customLayout ~atModuleLvl:false ext cmtTbl | Ppat_lazy p -> - let needsParens = - match p.ppat_desc with - | Ppat_or (_, _) | Ppat_alias (_, _) -> true - | _ -> false - in - let pat = - let p = printPattern ~customLayout p cmtTbl in - if needsParens then Doc.concat [ Doc.text "("; p; Doc.text ")" ] - else p - in - Doc.concat [ Doc.text "lazy "; pat ] + let needsParens = + match p.ppat_desc with + | Ppat_or (_, _) | Ppat_alias (_, _) -> true + | _ -> false + in + let pat = + let p = printPattern ~customLayout p cmtTbl in + if needsParens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p + in + Doc.concat [Doc.text "lazy "; pat] | Ppat_alias (p, aliasLoc) -> - let needsParens = - match p.ppat_desc with - | Ppat_or (_, _) | Ppat_alias (_, _) -> true - | _ -> false - in - let renderedPattern = - let p = printPattern ~customLayout p cmtTbl in - if needsParens then Doc.concat [ Doc.text "("; p; Doc.text ")" ] - else p - in - Doc.concat - [ renderedPattern; Doc.text " as "; printStringLoc aliasLoc cmtTbl ] + let needsParens = + match p.ppat_desc with + | Ppat_or (_, _) | Ppat_alias (_, _) -> true + | _ -> false + in + let renderedPattern = + let p = printPattern ~customLayout p cmtTbl in + if needsParens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p + in + Doc.concat + [renderedPattern; Doc.text " as "; printStringLoc aliasLoc cmtTbl] (* Note: module(P : S) is represented as *) (* Ppat_constraint(Ppat_unpack, Ptyp_package) *) | Ppat_constraint - ( { ppat_desc = Ppat_unpack stringLoc }, - { ptyp_desc = Ptyp_package packageType; ptyp_loc } ) -> - Doc.concat - [ - Doc.text "module("; - printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; - Doc.text ": "; - printComments - (printPackageType ~customLayout ~printModuleKeywordAndParens:false - packageType cmtTbl) - cmtTbl ptyp_loc; - Doc.rparen; - ] + ( {ppat_desc = Ppat_unpack stringLoc}, + {ptyp_desc = Ptyp_package packageType; ptyp_loc} ) -> + Doc.concat + [ + Doc.text "module("; + printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; + Doc.text ": "; + printComments + (printPackageType ~customLayout ~printModuleKeywordAndParens:false + packageType cmtTbl) + cmtTbl ptyp_loc; + Doc.rparen; + ] | Ppat_constraint (pattern, typ) -> - Doc.concat - [ - printPattern ~customLayout pattern cmtTbl; - Doc.text ": "; - printTypExpr ~customLayout typ cmtTbl; - ] + Doc.concat + [ + printPattern ~customLayout pattern cmtTbl; + Doc.text ": "; + printTypExpr ~customLayout typ cmtTbl; + ] (* Note: module(P : S) is represented as *) (* Ppat_constraint(Ppat_unpack, Ptyp_package) *) | Ppat_unpack stringLoc -> - Doc.concat - [ - Doc.text "module("; - printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; - Doc.rparen; - ] + Doc.concat + [ + Doc.text "module("; + printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; + Doc.rparen; + ] | Ppat_interval (a, b) -> - Doc.concat [ printConstant a; Doc.text " .. "; printConstant b ] + Doc.concat [printConstant a; Doc.text " .. "; printConstant b] | Ppat_open _ -> Doc.nil in let doc = match p.ppat_attributes with | [] -> patternWithoutAttributes | attrs -> - Doc.group - (Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - patternWithoutAttributes; - ]) + Doc.group + (Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; patternWithoutAttributes; + ]) in printComments doc cmtTbl p.ppat_loc and printPatternRecordRow ~customLayout row cmtTbl = match row with (* punned {x}*) - | ( ({ Location.txt = Longident.Lident ident } as longident), - { Parsetree.ppat_desc = Ppat_var { txt; _ }; ppat_attributes } ) + | ( ({Location.txt = Longident.Lident ident} as longident), + {Parsetree.ppat_desc = Ppat_var {txt; _}; ppat_attributes} ) when ident = txt -> - Doc.concat - [ - printOptionalLabel ppat_attributes; - printAttributes ~customLayout ppat_attributes cmtTbl; - printLidentPath longident cmtTbl; - ] + Doc.concat + [ + printOptionalLabel ppat_attributes; + printAttributes ~customLayout ppat_attributes cmtTbl; + printLidentPath longident cmtTbl; + ] | longident, pattern -> - let locForComments = - { longident.loc with loc_end = pattern.Parsetree.ppat_loc.loc_end } - in - let rhsDoc = - let doc = printPattern ~customLayout pattern cmtTbl in - let doc = - if Parens.patternRecordRowRhs pattern then addParens doc else doc - in - Doc.concat [ printOptionalLabel pattern.ppat_attributes; doc ] - in + let locForComments = + {longident.loc with loc_end = pattern.Parsetree.ppat_loc.loc_end} + in + let rhsDoc = + let doc = printPattern ~customLayout pattern cmtTbl in let doc = - Doc.group - (Doc.concat - [ - printLidentPath longident cmtTbl; - Doc.text ":"; - (if ParsetreeViewer.isHuggablePattern pattern then - Doc.concat [ Doc.space; rhsDoc ] - else Doc.indent (Doc.concat [ Doc.line; rhsDoc ])); - ]) + if Parens.patternRecordRowRhs pattern then addParens doc else doc in - printComments doc cmtTbl locForComments + Doc.concat [printOptionalLabel pattern.ppat_attributes; doc] + in + let doc = + Doc.group + (Doc.concat + [ + printLidentPath longident cmtTbl; + Doc.text ":"; + (if ParsetreeViewer.isHuggablePattern pattern then + Doc.concat [Doc.space; rhsDoc] + else Doc.indent (Doc.concat [Doc.line; rhsDoc])); + ]) + in + printComments doc cmtTbl locForComments and printExpressionWithComments ~customLayout expr cmtTbl : Doc.t = let doc = printExpression ~customLayout expr cmtTbl in @@ -231691,55 +231640,54 @@ and printIfChain ~customLayout pexp_attributes ifs elseExpr cmtTbl = let doc = match ifExpr with | ParsetreeViewer.If ifExpr -> - let condition = - if ParsetreeViewer.isBlockExpr ifExpr then - printExpressionBlock ~customLayout ~braces:true ifExpr - cmtTbl - else - let doc = - printExpressionWithComments ~customLayout ifExpr cmtTbl - in - match Parens.expr ifExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc ifExpr braces - | Nothing -> Doc.ifBreaks (addParens doc) doc - in - Doc.concat - [ - ifTxt; - Doc.group condition; - Doc.space; - (let thenExpr = - match ParsetreeViewer.processBracesAttr thenExpr with - (* This case only happens when coming from Reason, we strip braces *) - | Some _, expr -> expr - | _ -> thenExpr - in - printExpressionBlock ~customLayout ~braces:true thenExpr - cmtTbl); - ] - | IfLet (pattern, conditionExpr) -> - let conditionDoc = + let condition = + if ParsetreeViewer.isBlockExpr ifExpr then + printExpressionBlock ~customLayout ~braces:true ifExpr cmtTbl + else let doc = - printExpressionWithComments ~customLayout conditionExpr - cmtTbl + printExpressionWithComments ~customLayout ifExpr cmtTbl in - match Parens.expr conditionExpr with + match Parens.expr ifExpr with | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc conditionExpr braces - | Nothing -> doc + | Braced braces -> printBraces doc ifExpr braces + | Nothing -> Doc.ifBreaks (addParens doc) doc + in + Doc.concat + [ + ifTxt; + Doc.group condition; + Doc.space; + (let thenExpr = + match ParsetreeViewer.processBracesAttr thenExpr with + (* This case only happens when coming from Reason, we strip braces *) + | Some _, expr -> expr + | _ -> thenExpr + in + printExpressionBlock ~customLayout ~braces:true thenExpr + cmtTbl); + ] + | IfLet (pattern, conditionExpr) -> + let conditionDoc = + let doc = + printExpressionWithComments ~customLayout conditionExpr + cmtTbl in - Doc.concat - [ - ifTxt; - Doc.text "let "; - printPattern ~customLayout pattern cmtTbl; - Doc.text " = "; - conditionDoc; - Doc.space; - printExpressionBlock ~customLayout ~braces:true thenExpr - cmtTbl; - ] + match Parens.expr conditionExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc conditionExpr braces + | Nothing -> doc + in + Doc.concat + [ + ifTxt; + Doc.text "let "; + printPattern ~customLayout pattern cmtTbl; + Doc.text " = "; + conditionDoc; + Doc.space; + printExpressionBlock ~customLayout ~braces:true thenExpr + cmtTbl; + ] in printLeadingComments doc cmtTbl.leading outerLoc) ifs) @@ -231748,736 +231696,707 @@ and printIfChain ~customLayout pexp_attributes ifs elseExpr cmtTbl = match elseExpr with | None -> Doc.nil | Some expr -> - Doc.concat - [ - Doc.text " else "; - printExpressionBlock ~customLayout ~braces:true expr cmtTbl; - ] + Doc.concat + [ + Doc.text " else "; + printExpressionBlock ~customLayout ~braces:true expr cmtTbl; + ] in let attrs = ParsetreeViewer.filterFragileMatchAttributes pexp_attributes in - Doc.concat [ printAttributes ~customLayout attrs cmtTbl; ifDocs; elseDoc ] + Doc.concat [printAttributes ~customLayout attrs cmtTbl; ifDocs; elseDoc] and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = let printedExpression = match e.pexp_desc with | Parsetree.Pexp_constant c -> - printConstant ~templateLiteral:(ParsetreeViewer.isTemplateLiteral e) c + printConstant ~templateLiteral:(ParsetreeViewer.isTemplateLiteral e) c | Pexp_construct _ when ParsetreeViewer.hasJsxAttribute e.pexp_attributes -> - printJsxFragment ~customLayout e cmtTbl - | Pexp_construct ({ txt = Longident.Lident "()" }, _) -> Doc.text "()" - | Pexp_construct ({ txt = Longident.Lident "[]" }, _) -> - Doc.concat - [ - Doc.text "list{"; printCommentsInside cmtTbl e.pexp_loc; Doc.rbrace; - ] - | Pexp_construct ({ txt = Longident.Lident "::" }, _) -> - let expressions, spread = ParsetreeViewer.collectListExpressions e in - let spreadDoc = - match spread with - | Some expr -> - Doc.concat - [ - Doc.text ","; - Doc.line; - Doc.dotdotdot; - (let doc = - printExpressionWithComments ~customLayout expr cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); - ] - | None -> Doc.nil - in - Doc.group - (Doc.concat - [ - Doc.text "list{"; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) - (List.map - (fun expr -> - let doc = - printExpressionWithComments ~customLayout expr - cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - expressions); - spreadDoc; - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ]) + printJsxFragment ~customLayout e cmtTbl + | Pexp_construct ({txt = Longident.Lident "()"}, _) -> Doc.text "()" + | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> + Doc.concat + [Doc.text "list{"; printCommentsInside cmtTbl e.pexp_loc; Doc.rbrace] + | Pexp_construct ({txt = Longident.Lident "::"}, _) -> + let expressions, spread = ParsetreeViewer.collectListExpressions e in + let spreadDoc = + match spread with + | Some expr -> + Doc.concat + [ + Doc.text ","; + Doc.line; + Doc.dotdotdot; + (let doc = + printExpressionWithComments ~customLayout expr cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + ] + | None -> Doc.nil + in + Doc.group + (Doc.concat + [ + Doc.text "list{"; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + expressions); + spreadDoc; + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ]) | Pexp_construct (longidentLoc, args) -> - let constr = printLongidentLocation longidentLoc cmtTbl in - let args = - match args with - | None -> Doc.nil - | Some - { - pexp_desc = Pexp_construct ({ txt = Longident.Lident "()" }, _); - } -> - Doc.text "()" - (* Some((1, 2)) *) - | Some - { - pexp_desc = Pexp_tuple [ ({ pexp_desc = Pexp_tuple _ } as arg) ]; - } -> - Doc.concat - [ - Doc.lparen; - (let doc = - printExpressionWithComments ~customLayout arg cmtTbl - in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc); - Doc.rparen; - ] - | Some { pexp_desc = Pexp_tuple args } -> - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun expr -> - let doc = - printExpressionWithComments ~customLayout expr - cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some arg -> - let argDoc = - let doc = - printExpressionWithComments ~customLayout arg cmtTbl - in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc - in - let shouldHug = ParsetreeViewer.isHuggableExpression arg in - Doc.concat - [ - Doc.lparen; - (if shouldHug then argDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [ Doc.softLine; argDoc ]); - Doc.trailingComma; - Doc.softLine; - ]); - Doc.rparen; - ] - in - Doc.group (Doc.concat [ constr; args ]) + let constr = printLongidentLocation longidentLoc cmtTbl in + let args = + match args with + | None -> Doc.nil + | Some {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)} + -> + Doc.text "()" + (* Some((1, 2)) *) + | Some {pexp_desc = Pexp_tuple [({pexp_desc = Pexp_tuple _} as arg)]} -> + Doc.concat + [ + Doc.lparen; + (let doc = printExpressionWithComments ~customLayout arg cmtTbl in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc); + Doc.rparen; + ] + | Some {pexp_desc = Pexp_tuple args} -> + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + | Some arg -> + let argDoc = + let doc = printExpressionWithComments ~customLayout arg cmtTbl in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc + in + let shouldHug = ParsetreeViewer.isHuggableExpression arg in + Doc.concat + [ + Doc.lparen; + (if shouldHug then argDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [Doc.softLine; argDoc]); + Doc.trailingComma; + Doc.softLine; + ]); + Doc.rparen; + ] + in + Doc.group (Doc.concat [constr; args]) | Pexp_ident path -> printLidentPath path cmtTbl | Pexp_tuple exprs -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) - (List.map - (fun expr -> - let doc = - printExpressionWithComments ~customLayout expr - cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - exprs); - ]); - Doc.ifBreaks (Doc.text ",") Doc.nil; - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + exprs); + ]); + Doc.ifBreaks (Doc.text ",") Doc.nil; + Doc.softLine; + Doc.rparen; + ]) | Pexp_array [] -> - Doc.concat - [ Doc.lbracket; printCommentsInside cmtTbl e.pexp_loc; Doc.rbracket ] + Doc.concat + [Doc.lbracket; printCommentsInside cmtTbl e.pexp_loc; Doc.rbracket] | Pexp_array exprs -> - Doc.group + Doc.group + (Doc.concat + [ + Doc.lbracket; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + exprs); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbracket; + ]) + | Pexp_variant (label, args) -> + let variantName = Doc.concat [Doc.text "#"; printPolyVarIdent label] in + let args = + match args with + | None -> Doc.nil + | Some {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)} + -> + Doc.text "()" + (* #poly((1, 2) *) + | Some {pexp_desc = Pexp_tuple [({pexp_desc = Pexp_tuple _} as arg)]} -> + Doc.concat + [ + Doc.lparen; + (let doc = printExpressionWithComments ~customLayout arg cmtTbl in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc); + Doc.rparen; + ] + | Some {pexp_desc = Pexp_tuple args} -> + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun expr -> + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + | Some arg -> + let argDoc = + let doc = printExpressionWithComments ~customLayout arg cmtTbl in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc + in + let shouldHug = ParsetreeViewer.isHuggableExpression arg in + Doc.concat + [ + Doc.lparen; + (if shouldHug then argDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [Doc.softLine; argDoc]); + Doc.trailingComma; + Doc.softLine; + ]); + Doc.rparen; + ] + in + Doc.group (Doc.concat [variantName; args]) + | Pexp_record (rows, spreadExpr) -> + if rows = [] then + Doc.concat + [Doc.lbrace; printCommentsInside cmtTbl e.pexp_loc; Doc.rbrace] + else + let spread = + match spreadExpr with + | None -> Doc.nil + | Some expr -> + Doc.concat + [ + Doc.dotdotdot; + (let doc = + printExpressionWithComments ~customLayout expr cmtTbl + in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + Doc.comma; + Doc.line; + ] + in + (* If the record is written over multiple lines, break automatically + * `let x = {a: 1, b: 3}` -> same line, break when line-width exceeded + * `let x = { + * a: 1, + * b: 2, + * }` -> record is written on multiple lines, break the group *) + let forceBreak = + e.pexp_loc.loc_start.pos_lnum < e.pexp_loc.loc_end.pos_lnum + in + let punningAllowed = + match (spreadExpr, rows) with + | None, [_] -> false (* disallow punning for single-element records *) + | _ -> true + in + Doc.breakableGroup ~forceBreak (Doc.concat [ - Doc.lbracket; + Doc.lbrace; Doc.indent (Doc.concat [ Doc.softLine; + spread; Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) + ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map - (fun expr -> - let doc = - printExpressionWithComments ~customLayout expr - cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - exprs); + (fun row -> + printExpressionRecordRow ~customLayout row cmtTbl + punningAllowed) + rows); ]); Doc.trailingComma; Doc.softLine; - Doc.rbracket; + Doc.rbrace; ]) - | Pexp_variant (label, args) -> - let variantName = - Doc.concat [ Doc.text "#"; printPolyVarIdent label ] - in - let args = - match args with - | None -> Doc.nil - | Some - { - pexp_desc = Pexp_construct ({ txt = Longident.Lident "()" }, _); - } -> - Doc.text "()" - (* #poly((1, 2) *) - | Some - { - pexp_desc = Pexp_tuple [ ({ pexp_desc = Pexp_tuple _ } as arg) ]; - } -> - Doc.concat - [ - Doc.lparen; - (let doc = - printExpressionWithComments ~customLayout arg cmtTbl - in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc); - Doc.rparen; - ] - | Some { pexp_desc = Pexp_tuple args } -> - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun expr -> - let doc = - printExpressionWithComments ~customLayout expr - cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some arg -> - let argDoc = - let doc = - printExpressionWithComments ~customLayout arg cmtTbl - in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc - in - let shouldHug = ParsetreeViewer.isHuggableExpression arg in - Doc.concat - [ - Doc.lparen; - (if shouldHug then argDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [ Doc.softLine; argDoc ]); - Doc.trailingComma; - Doc.softLine; - ]); - Doc.rparen; - ] - in - Doc.group (Doc.concat [ variantName; args ]) - | Pexp_record (rows, spreadExpr) -> - if rows = [] then - Doc.concat - [ Doc.lbrace; printCommentsInside cmtTbl e.pexp_loc; Doc.rbrace ] - else - let spread = - match spreadExpr with - | None -> Doc.nil - | Some expr -> - Doc.concat - [ - Doc.dotdotdot; - (let doc = - printExpressionWithComments ~customLayout expr cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); - Doc.comma; - Doc.line; - ] - in - (* If the record is written over multiple lines, break automatically - * `let x = {a: 1, b: 3}` -> same line, break when line-width exceeded - * `let x = { - * a: 1, - * b: 2, - * }` -> record is written on multiple lines, break the group *) - let forceBreak = - e.pexp_loc.loc_start.pos_lnum < e.pexp_loc.loc_end.pos_lnum - in - let punningAllowed = - match (spreadExpr, rows) with - | None, [ _ ] -> - false (* disallow punning for single-element records *) - | _ -> true - in - Doc.breakableGroup ~forceBreak - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - spread; - Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) - (List.map - (fun row -> - printExpressionRecordRow ~customLayout row cmtTbl - punningAllowed) - rows); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ]) | Pexp_extension extension -> ( - match extension with - | ( { txt = "bs.obj" | "obj" }, - PStr - [ - { - pstr_loc = loc; - pstr_desc = - Pstr_eval ({ pexp_desc = Pexp_record (rows, _) }, []); - }; - ] ) -> - (* If the object is written over multiple lines, break automatically - * `let x = {"a": 1, "b": 3}` -> same line, break when line-width exceeded - * `let x = { - * "a": 1, - * "b": 2, - * }` -> object is written on multiple lines, break the group *) - let forceBreak = loc.loc_start.pos_lnum < loc.loc_end.pos_lnum in - Doc.breakableGroup ~forceBreak - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) - (List.map - (fun row -> - printBsObjectRow ~customLayout row cmtTbl) - rows); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ]) - | extension -> - printExtension ~customLayout ~atModuleLvl:false extension cmtTbl) - | Pexp_apply (e, [ (Nolabel, { pexp_desc = Pexp_array subLists }) ]) - when ParsetreeViewer.isSpreadBeltListConcat e -> - printBeltListConcatApply ~customLayout subLists cmtTbl - | Pexp_apply _ -> - if ParsetreeViewer.isUnaryExpression e then - printUnaryExpression ~customLayout e cmtTbl - else if ParsetreeViewer.isTemplateLiteral e then - printTemplateLiteral ~customLayout e cmtTbl - else if ParsetreeViewer.isBinaryExpression e then - printBinaryExpression ~customLayout e cmtTbl - else printPexpApply ~customLayout e cmtTbl - | Pexp_unreachable -> Doc.dot - | Pexp_field (expr, longidentLoc) -> - let lhs = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.fieldExpr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat [ lhs; Doc.dot; printLidentPath longidentLoc cmtTbl ] - | Pexp_setfield (expr1, longidentLoc, expr2) -> - printSetFieldExpr ~customLayout e.pexp_attributes expr1 longidentLoc - expr2 e.pexp_loc cmtTbl - | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) - when ParsetreeViewer.isTernaryExpr e -> - let parts, alternate = ParsetreeViewer.collectTernaryParts e in - let ternaryDoc = - match parts with - | (condition1, consequent1) :: rest -> - Doc.group - (Doc.concat - [ - printTernaryOperand ~customLayout condition1 cmtTbl; - Doc.indent - (Doc.concat - [ - Doc.line; - Doc.indent - (Doc.concat - [ - Doc.text "? "; - printTernaryOperand ~customLayout consequent1 - cmtTbl; - ]); - Doc.concat - (List.map - (fun (condition, consequent) -> - Doc.concat - [ - Doc.line; - Doc.text ": "; - printTernaryOperand ~customLayout - condition cmtTbl; - Doc.line; - Doc.text "? "; - printTernaryOperand ~customLayout - consequent cmtTbl; - ]) - rest); - Doc.line; - Doc.text ": "; - Doc.indent - (printTernaryOperand ~customLayout alternate - cmtTbl); - ]); - ]) - | _ -> Doc.nil - in - let attrs = ParsetreeViewer.filterTernaryAttributes e.pexp_attributes in - let needsParens = - match ParsetreeViewer.filterParsingAttrs attrs with - | [] -> false - | _ -> true - in - Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; - (if needsParens then addParens ternaryDoc else ternaryDoc); - ] - | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) -> - let ifs, elseExpr = ParsetreeViewer.collectIfExpressions e in - printIfChain ~customLayout e.pexp_attributes ifs elseExpr cmtTbl - | Pexp_while (expr1, expr2) -> - let condition = - let doc = printExpressionWithComments ~customLayout expr1 cmtTbl in - match Parens.expr expr1 with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr1 braces - | Nothing -> doc - in - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.text "while "; - (if ParsetreeViewer.isBlockExpr expr1 then condition - else Doc.group (Doc.ifBreaks (addParens condition) condition)); - Doc.space; - printExpressionBlock ~customLayout ~braces:true expr2 cmtTbl; - ]) - | Pexp_for (pattern, fromExpr, toExpr, directionFlag, body) -> - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.text "for "; - printPattern ~customLayout pattern cmtTbl; - Doc.text " in "; - (let doc = - printExpressionWithComments ~customLayout fromExpr cmtTbl - in - match Parens.expr fromExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc fromExpr braces - | Nothing -> doc); - printDirectionFlag directionFlag; - (let doc = - printExpressionWithComments ~customLayout toExpr cmtTbl - in - match Parens.expr toExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc toExpr braces - | Nothing -> doc); - Doc.space; - printExpressionBlock ~customLayout ~braces:true body cmtTbl; - ]) - | Pexp_constraint - ( { pexp_desc = Pexp_pack modExpr }, - { ptyp_desc = Ptyp_package packageType; ptyp_loc } ) -> - Doc.group + match extension with + | ( {txt = "bs.obj" | "obj"}, + PStr + [ + { + pstr_loc = loc; + pstr_desc = Pstr_eval ({pexp_desc = Pexp_record (rows, _)}, []); + }; + ] ) -> + (* If the object is written over multiple lines, break automatically + * `let x = {"a": 1, "b": 3}` -> same line, break when line-width exceeded + * `let x = { + * "a": 1, + * "b": 2, + * }` -> object is written on multiple lines, break the group *) + let forceBreak = loc.loc_start.pos_lnum < loc.loc_end.pos_lnum in + Doc.breakableGroup ~forceBreak (Doc.concat [ - Doc.text "module("; + Doc.lbrace; Doc.indent (Doc.concat [ Doc.softLine; - printModExpr ~customLayout modExpr cmtTbl; - Doc.text ": "; - printComments - (printPackageType ~customLayout - ~printModuleKeywordAndParens:false packageType cmtTbl) - cmtTbl ptyp_loc; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun row -> + printBsObjectRow ~customLayout row cmtTbl) + rows); ]); + Doc.trailingComma; Doc.softLine; - Doc.rparen; + Doc.rbrace; ]) + | extension -> + printExtension ~customLayout ~atModuleLvl:false extension cmtTbl) + | Pexp_apply (e, [(Nolabel, {pexp_desc = Pexp_array subLists})]) + when ParsetreeViewer.isSpreadBeltListConcat e -> + printBeltListConcatApply ~customLayout subLists cmtTbl + | Pexp_apply _ -> + if ParsetreeViewer.isUnaryExpression e then + printUnaryExpression ~customLayout e cmtTbl + else if ParsetreeViewer.isTemplateLiteral e then + printTemplateLiteral ~customLayout e cmtTbl + else if ParsetreeViewer.isBinaryExpression e then + printBinaryExpression ~customLayout e cmtTbl + else printPexpApply ~customLayout e cmtTbl + | Pexp_unreachable -> Doc.dot + | Pexp_field (expr, longidentLoc) -> + let lhs = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.fieldExpr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [lhs; Doc.dot; printLidentPath longidentLoc cmtTbl] + | Pexp_setfield (expr1, longidentLoc, expr2) -> + printSetFieldExpr ~customLayout e.pexp_attributes expr1 longidentLoc expr2 + e.pexp_loc cmtTbl + | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) + when ParsetreeViewer.isTernaryExpr e -> + let parts, alternate = ParsetreeViewer.collectTernaryParts e in + let ternaryDoc = + match parts with + | (condition1, consequent1) :: rest -> + Doc.group + (Doc.concat + [ + printTernaryOperand ~customLayout condition1 cmtTbl; + Doc.indent + (Doc.concat + [ + Doc.line; + Doc.indent + (Doc.concat + [ + Doc.text "? "; + printTernaryOperand ~customLayout consequent1 + cmtTbl; + ]); + Doc.concat + (List.map + (fun (condition, consequent) -> + Doc.concat + [ + Doc.line; + Doc.text ": "; + printTernaryOperand ~customLayout condition + cmtTbl; + Doc.line; + Doc.text "? "; + printTernaryOperand ~customLayout consequent + cmtTbl; + ]) + rest); + Doc.line; + Doc.text ": "; + Doc.indent + (printTernaryOperand ~customLayout alternate cmtTbl); + ]); + ]) + | _ -> Doc.nil + in + let attrs = ParsetreeViewer.filterTernaryAttributes e.pexp_attributes in + let needsParens = + match ParsetreeViewer.filterParsingAttrs attrs with + | [] -> false + | _ -> true + in + Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + (if needsParens then addParens ternaryDoc else ternaryDoc); + ] + | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) -> + let ifs, elseExpr = ParsetreeViewer.collectIfExpressions e in + printIfChain ~customLayout e.pexp_attributes ifs elseExpr cmtTbl + | Pexp_while (expr1, expr2) -> + let condition = + let doc = printExpressionWithComments ~customLayout expr1 cmtTbl in + match Parens.expr expr1 with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr1 braces + | Nothing -> doc + in + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.text "while "; + (if ParsetreeViewer.isBlockExpr expr1 then condition + else Doc.group (Doc.ifBreaks (addParens condition) condition)); + Doc.space; + printExpressionBlock ~customLayout ~braces:true expr2 cmtTbl; + ]) + | Pexp_for (pattern, fromExpr, toExpr, directionFlag, body) -> + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.text "for "; + printPattern ~customLayout pattern cmtTbl; + Doc.text " in "; + (let doc = + printExpressionWithComments ~customLayout fromExpr cmtTbl + in + match Parens.expr fromExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc fromExpr braces + | Nothing -> doc); + printDirectionFlag directionFlag; + (let doc = + printExpressionWithComments ~customLayout toExpr cmtTbl + in + match Parens.expr toExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc toExpr braces + | Nothing -> doc); + Doc.space; + printExpressionBlock ~customLayout ~braces:true body cmtTbl; + ]) + | Pexp_constraint + ( {pexp_desc = Pexp_pack modExpr}, + {ptyp_desc = Ptyp_package packageType; ptyp_loc} ) -> + Doc.group + (Doc.concat + [ + Doc.text "module("; + Doc.indent + (Doc.concat + [ + Doc.softLine; + printModExpr ~customLayout modExpr cmtTbl; + Doc.text ": "; + printComments + (printPackageType ~customLayout + ~printModuleKeywordAndParens:false packageType cmtTbl) + cmtTbl ptyp_loc; + ]); + Doc.softLine; + Doc.rparen; + ]) | Pexp_constraint (expr, typ) -> - let exprDoc = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat - [ exprDoc; Doc.text ": "; printTypExpr ~customLayout typ cmtTbl ] - | Pexp_letmodule ({ txt = _modName }, _modExpr, _expr) -> - printExpressionBlock ~customLayout ~braces:true e cmtTbl + let exprDoc = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [exprDoc; Doc.text ": "; printTypExpr ~customLayout typ cmtTbl] + | Pexp_letmodule ({txt = _modName}, _modExpr, _expr) -> + printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_letexception (_extensionConstructor, _expr) -> - printExpressionBlock ~customLayout ~braces:true e cmtTbl + printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_assert expr -> - let rhs = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.lazyOrAssertOrAwaitExprRhs expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat [ Doc.text "assert "; rhs ] + let rhs = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.lazyOrAssertOrAwaitExprRhs expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [Doc.text "assert "; rhs] | Pexp_lazy expr -> - let rhs = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.lazyOrAssertOrAwaitExprRhs expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.group (Doc.concat [ Doc.text "lazy "; rhs ]) + let rhs = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.lazyOrAssertOrAwaitExprRhs expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.group (Doc.concat [Doc.text "lazy "; rhs]) | Pexp_open (_overrideFlag, _longidentLoc, _expr) -> - printExpressionBlock ~customLayout ~braces:true e cmtTbl + printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_pack modExpr -> - Doc.group - (Doc.concat - [ - Doc.text "module("; - Doc.indent - (Doc.concat - [ Doc.softLine; printModExpr ~customLayout modExpr cmtTbl ]); - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + Doc.text "module("; + Doc.indent + (Doc.concat + [Doc.softLine; printModExpr ~customLayout modExpr cmtTbl]); + Doc.softLine; + Doc.rparen; + ]) | Pexp_sequence _ -> - printExpressionBlock ~customLayout ~braces:true e cmtTbl + printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_let _ -> printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_fun ( Nolabel, None, - { ppat_desc = Ppat_var { txt = "__x" } }, - { pexp_desc = Pexp_apply _ } ) -> - (* (__x) => f(a, __x, c) -----> f(a, _, c) *) - printExpressionWithComments ~customLayout - (ParsetreeViewer.rewriteUnderscoreApply e) - cmtTbl + {ppat_desc = Ppat_var {txt = "__x"}}, + {pexp_desc = Pexp_apply _} ) -> + (* (__x) => f(a, __x, c) -----> f(a, _, c) *) + printExpressionWithComments ~customLayout + (ParsetreeViewer.rewriteUnderscoreApply e) + cmtTbl | Pexp_fun _ | Pexp_newtype _ -> - let attrsOnArrow, parameters, returnExpr = ParsetreeViewer.funExpr e in - let ParsetreeViewer.{ async; uncurried; attributes = attrs } = - ParsetreeViewer.processFunctionAttributes attrsOnArrow + let attrsOnArrow, parameters, returnExpr = ParsetreeViewer.funExpr e in + let ParsetreeViewer.{async; uncurried; attributes = attrs} = + ParsetreeViewer.processFunctionAttributes attrsOnArrow + in + let returnExpr, typConstraint = + match returnExpr.pexp_desc with + | Pexp_constraint (expr, typ) -> + ( { + expr with + pexp_attributes = + List.concat [expr.pexp_attributes; returnExpr.pexp_attributes]; + }, + Some typ ) + | _ -> (returnExpr, None) + in + let hasConstraint = + match typConstraint with + | Some _ -> true + | None -> false + in + let parametersDoc = + printExprFunParameters ~customLayout ~inCallback:NoCallback ~uncurried + ~async ~hasConstraint parameters cmtTbl + in + let returnExprDoc = + let optBraces, _ = ParsetreeViewer.processBracesAttr returnExpr in + let shouldInline = + match (returnExpr.pexp_desc, optBraces) with + | _, Some _ -> true + | ( ( Pexp_array _ | Pexp_tuple _ + | Pexp_construct (_, Some _) + | Pexp_record _ ), + _ ) -> + true + | _ -> false in - let returnExpr, typConstraint = + let shouldIndent = match returnExpr.pexp_desc with - | Pexp_constraint (expr, typ) -> - ( { - expr with - pexp_attributes = - List.concat - [ expr.pexp_attributes; returnExpr.pexp_attributes ]; - }, - Some typ ) - | _ -> (returnExpr, None) - in - let hasConstraint = - match typConstraint with Some _ -> true | None -> false - in - let parametersDoc = - printExprFunParameters ~customLayout ~inCallback:NoCallback ~uncurried - ~async ~hasConstraint parameters cmtTbl + | Pexp_sequence _ | Pexp_let _ | Pexp_letmodule _ + | Pexp_letexception _ | Pexp_open _ -> + false + | _ -> true in - let returnExprDoc = - let optBraces, _ = ParsetreeViewer.processBracesAttr returnExpr in - let shouldInline = - match (returnExpr.pexp_desc, optBraces) with - | _, Some _ -> true - | ( ( Pexp_array _ | Pexp_tuple _ - | Pexp_construct (_, Some _) - | Pexp_record _ ), - _ ) -> - true - | _ -> false - in - let shouldIndent = - match returnExpr.pexp_desc with - | Pexp_sequence _ | Pexp_let _ | Pexp_letmodule _ - | Pexp_letexception _ | Pexp_open _ -> - false - | _ -> true - in - let returnDoc = - let doc = - printExpressionWithComments ~customLayout returnExpr cmtTbl - in - match Parens.expr returnExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc returnExpr braces - | Nothing -> doc + let returnDoc = + let doc = + printExpressionWithComments ~customLayout returnExpr cmtTbl in - if shouldInline then Doc.concat [ Doc.space; returnDoc ] - else - Doc.group - (if shouldIndent then - Doc.indent (Doc.concat [ Doc.line; returnDoc ]) - else Doc.concat [ Doc.space; returnDoc ]) - in - let typConstraintDoc = - match typConstraint with - | Some typ -> - let typDoc = - let doc = printTypExpr ~customLayout typ cmtTbl in - if Parens.arrowReturnTypExpr typ then addParens doc else doc - in - Doc.concat [ Doc.text ": "; typDoc ] - | _ -> Doc.nil - in - let attrs = printAttributes ~customLayout attrs cmtTbl in - Doc.group - (Doc.concat - [ - attrs; - parametersDoc; - typConstraintDoc; - Doc.text " =>"; - returnExprDoc; - ]) - | Pexp_try (expr, cases) -> - let exprDoc = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with + match Parens.expr returnExpr with | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces + | Braced braces -> printBraces doc returnExpr braces | Nothing -> doc in - Doc.concat - [ - Doc.text "try "; - exprDoc; - Doc.text " catch "; - printCases ~customLayout cases cmtTbl; - ] - | Pexp_match (_, [ _; _ ]) when ParsetreeViewer.isIfLetExpr e -> - let ifs, elseExpr = ParsetreeViewer.collectIfExpressions e in - printIfChain ~customLayout e.pexp_attributes ifs elseExpr cmtTbl + if shouldInline then Doc.concat [Doc.space; returnDoc] + else + Doc.group + (if shouldIndent then Doc.indent (Doc.concat [Doc.line; returnDoc]) + else Doc.concat [Doc.space; returnDoc]) + in + let typConstraintDoc = + match typConstraint with + | Some typ -> + let typDoc = + let doc = printTypExpr ~customLayout typ cmtTbl in + if Parens.arrowReturnTypExpr typ then addParens doc else doc + in + Doc.concat [Doc.text ": "; typDoc] + | _ -> Doc.nil + in + let attrs = printAttributes ~customLayout attrs cmtTbl in + Doc.group + (Doc.concat + [ + attrs; + parametersDoc; + typConstraintDoc; + Doc.text " =>"; + returnExprDoc; + ]) + | Pexp_try (expr, cases) -> + let exprDoc = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat + [ + Doc.text "try "; + exprDoc; + Doc.text " catch "; + printCases ~customLayout cases cmtTbl; + ] + | Pexp_match (_, [_; _]) when ParsetreeViewer.isIfLetExpr e -> + let ifs, elseExpr = ParsetreeViewer.collectIfExpressions e in + printIfChain ~customLayout e.pexp_attributes ifs elseExpr cmtTbl | Pexp_match (expr, cases) -> - let exprDoc = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat - [ - Doc.text "switch "; - exprDoc; - Doc.space; - printCases ~customLayout cases cmtTbl; - ] + let exprDoc = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat + [ + Doc.text "switch "; + exprDoc; + Doc.space; + printCases ~customLayout cases cmtTbl; + ] | Pexp_function cases -> - Doc.concat - [ Doc.text "x => switch x "; printCases ~customLayout cases cmtTbl ] + Doc.concat + [Doc.text "x => switch x "; printCases ~customLayout cases cmtTbl] | Pexp_coerce (expr, typOpt, typ) -> - let docExpr = printExpressionWithComments ~customLayout expr cmtTbl in - let docTyp = printTypExpr ~customLayout typ cmtTbl in - let ofType = - match typOpt with - | None -> Doc.nil - | Some typ1 -> - Doc.concat - [ Doc.text ": "; printTypExpr ~customLayout typ1 cmtTbl ] - in - Doc.concat - [ Doc.lparen; docExpr; ofType; Doc.text " :> "; docTyp; Doc.rparen ] + let docExpr = printExpressionWithComments ~customLayout expr cmtTbl in + let docTyp = printTypExpr ~customLayout typ cmtTbl in + let ofType = + match typOpt with + | None -> Doc.nil + | Some typ1 -> + Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ1 cmtTbl] + in + Doc.concat + [Doc.lparen; docExpr; ofType; Doc.text " :> "; docTyp; Doc.rparen] | Pexp_send (parentExpr, label) -> - let parentDoc = - let doc = - printExpressionWithComments ~customLayout parentExpr cmtTbl - in - match Parens.unaryExprOperand parentExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces - | Nothing -> doc - in - let member = - let memberDoc = printComments (Doc.text label.txt) cmtTbl label.loc in - Doc.concat [ Doc.text "\""; memberDoc; Doc.text "\"" ] - in - Doc.group (Doc.concat [ parentDoc; Doc.lbracket; member; Doc.rbracket ]) + let parentDoc = + let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in + match Parens.unaryExprOperand parentExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc parentExpr braces + | Nothing -> doc + in + let member = + let memberDoc = printComments (Doc.text label.txt) cmtTbl label.loc in + Doc.concat [Doc.text "\""; memberDoc; Doc.text "\""] + in + Doc.group (Doc.concat [parentDoc; Doc.lbracket; member; Doc.rbracket]) | Pexp_new _ -> Doc.text "Pexp_new not impemented in printer" | Pexp_setinstvar _ -> Doc.text "Pexp_setinstvar not impemented in printer" | Pexp_override _ -> Doc.text "Pexp_override not impemented in printer" @@ -232494,7 +232413,7 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = pexp_attributes = List.filter (function - | { Location.txt = "res.await" | "ns.braces" }, _ -> false + | {Location.txt = "res.await" | "ns.braces"}, _ -> false | _ -> true) e.pexp_attributes; } @@ -232503,53 +232422,55 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = | Braced braces -> printBraces printedExpression e braces | Nothing -> printedExpression in - Doc.concat [ Doc.text "await "; rhs ] + Doc.concat [Doc.text "await "; rhs] else printedExpression in let shouldPrintItsOwnAttributes = match e.pexp_desc with | Pexp_apply _ | Pexp_fun _ | Pexp_newtype _ | Pexp_setfield _ | Pexp_ifthenelse _ -> - true + true | Pexp_match _ when ParsetreeViewer.isIfLetExpr e -> true | Pexp_construct _ when ParsetreeViewer.hasJsxAttribute e.pexp_attributes -> - true + true | _ -> false in match e.pexp_attributes with | [] -> exprWithAwait | attrs when not shouldPrintItsOwnAttributes -> - Doc.group - (Doc.concat - [ printAttributes ~customLayout attrs cmtTbl; exprWithAwait ]) + Doc.group + (Doc.concat [printAttributes ~customLayout attrs cmtTbl; exprWithAwait]) | _ -> exprWithAwait and printPexpFun ~customLayout ~inCallback e cmtTbl = let attrsOnArrow, parameters, returnExpr = ParsetreeViewer.funExpr e in - let ParsetreeViewer.{ async; uncurried; attributes = attrs } = + let ParsetreeViewer.{async; uncurried; attributes = attrs} = ParsetreeViewer.processFunctionAttributes attrsOnArrow in let returnExpr, typConstraint = match returnExpr.pexp_desc with | Pexp_constraint (expr, typ) -> - ( { - expr with - pexp_attributes = - List.concat [ expr.pexp_attributes; returnExpr.pexp_attributes ]; - }, - Some typ ) + ( { + expr with + pexp_attributes = + List.concat [expr.pexp_attributes; returnExpr.pexp_attributes]; + }, + Some typ ) | _ -> (returnExpr, None) in let parametersDoc = printExprFunParameters ~customLayout ~inCallback ~async ~uncurried - ~hasConstraint:(match typConstraint with Some _ -> true | None -> false) + ~hasConstraint: + (match typConstraint with + | Some _ -> true + | None -> false) parameters cmtTbl in let returnShouldIndent = match returnExpr.pexp_desc with | Pexp_sequence _ | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ -> - false + false | _ -> true in let returnExprDoc = @@ -232561,7 +232482,7 @@ and printPexpFun ~customLayout ~inCallback e cmtTbl = | Pexp_construct (_, Some _) | Pexp_record _ ), _ ) -> - true + true | _ -> false in let returnDoc = @@ -232571,23 +232492,23 @@ and printPexpFun ~customLayout ~inCallback e cmtTbl = | Braced braces -> printBraces doc returnExpr braces | Nothing -> doc in - if shouldInline then Doc.concat [ Doc.space; returnDoc ] + if shouldInline then Doc.concat [Doc.space; returnDoc] else Doc.group (if returnShouldIndent then Doc.concat [ - Doc.indent (Doc.concat [ Doc.line; returnDoc ]); + Doc.indent (Doc.concat [Doc.line; returnDoc]); (match inCallback with | FitsOnOneLine | ArgumentsFitOnOneLine -> Doc.softLine | _ -> Doc.nil); ] - else Doc.concat [ Doc.space; returnDoc ]) + else Doc.concat [Doc.space; returnDoc]) in let typConstraintDoc = match typConstraint with | Some typ -> - Doc.concat [ Doc.text ": "; printTypExpr ~customLayout typ cmtTbl ] + Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ cmtTbl] | _ -> Doc.nil in Doc.concat @@ -232631,16 +232552,15 @@ and printSetFieldExpr ~customLayout attrs lhs longidentLoc rhs loc cmtTbl = printLidentPath longidentLoc cmtTbl; Doc.text " ="; (if shouldIndent then - Doc.group (Doc.indent (Doc.concat [ Doc.line; rhsDoc ])) - else Doc.concat [ Doc.space; rhsDoc ]); + Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) + else Doc.concat [Doc.space; rhsDoc]); ]) in let doc = match attrs with | [] -> doc | attrs -> - Doc.group - (Doc.concat [ printAttributes ~customLayout attrs cmtTbl; doc ]) + Doc.group (Doc.concat [printAttributes ~customLayout attrs cmtTbl; doc]) in printComments doc cmtTbl loc @@ -232650,17 +232570,17 @@ and printTemplateLiteral ~customLayout expr cmtTbl = let open Parsetree in match expr.pexp_desc with | Pexp_apply - ( { pexp_desc = Pexp_ident { txt = Longident.Lident "^" } }, - [ (Nolabel, arg1); (Nolabel, arg2) ] ) -> - let lhs = walkExpr arg1 in - let rhs = walkExpr arg2 in - Doc.concat [ lhs; rhs ] + ( {pexp_desc = Pexp_ident {txt = Longident.Lident "^"}}, + [(Nolabel, arg1); (Nolabel, arg2)] ) -> + let lhs = walkExpr arg1 in + let rhs = walkExpr arg2 in + Doc.concat [lhs; rhs] | Pexp_constant (Pconst_string (txt, Some prefix)) -> - tag := prefix; - printStringContents txt + tag := prefix; + printStringContents txt | _ -> - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - Doc.group (Doc.concat [ Doc.text "${"; Doc.indent doc; Doc.rbrace ]) + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + Doc.group (Doc.concat [Doc.text "${"; Doc.indent doc; Doc.rbrace]) in let content = walkExpr expr in Doc.concat @@ -232684,17 +232604,17 @@ and printUnaryExpression ~customLayout expr cmtTbl = in match expr.pexp_desc with | Pexp_apply - ( { pexp_desc = Pexp_ident { txt = Longident.Lident operator } }, - [ (Nolabel, operand) ] ) -> - let printedOperand = - let doc = printExpressionWithComments ~customLayout operand cmtTbl in - match Parens.unaryExprOperand operand with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc operand braces - | Nothing -> doc - in - let doc = Doc.concat [ printUnaryOperator operator; printedOperand ] in - printComments doc cmtTbl expr.pexp_loc + ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, + [(Nolabel, operand)] ) -> + let printedOperand = + let doc = printExpressionWithComments ~customLayout operand cmtTbl in + match Parens.unaryExprOperand operand with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc operand braces + | Nothing -> doc + in + let doc = Doc.concat [printUnaryOperator operator; printedOperand] in + printComments doc cmtTbl expr.pexp_loc | _ -> assert false and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = @@ -232721,7 +232641,7 @@ and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = else Doc.line in Doc.concat - [ spacingBeforeOperator; Doc.text operatorTxt; spacingAfterOperator ] + [spacingBeforeOperator; Doc.text operatorTxt; spacingAfterOperator] in let printOperand ~isLhs expr parentOperator = let rec flatten ~isLhs expr parentOperator = @@ -232730,232 +232650,230 @@ and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = | { pexp_desc = Pexp_apply - ( { pexp_desc = Pexp_ident { txt = Longident.Lident operator } }, - [ (_, left); (_, right) ] ); + ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, + [(_, left); (_, right)] ); } -> - if - ParsetreeViewer.flattenableOperators parentOperator operator - && not (ParsetreeViewer.hasAttributes expr.pexp_attributes) - then - let leftPrinted = flatten ~isLhs:true left operator in - let rightPrinted = - let rightPrinteableAttrs, rightInternalAttrs = - ParsetreeViewer.partitionPrintableAttributes - right.pexp_attributes - in - let doc = - printExpressionWithComments ~customLayout - { right with pexp_attributes = rightInternalAttrs } - cmtTbl - in - let doc = - if Parens.flattenOperandRhs parentOperator right then - Doc.concat [ Doc.lparen; doc; Doc.rparen ] - else doc - in - let doc = - Doc.concat - [ - printAttributes ~customLayout rightPrinteableAttrs cmtTbl; - doc; - ] - in - match rightPrinteableAttrs with [] -> doc | _ -> addParens doc - in - let isAwait = - ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes - in - let doc = - if isAwait then - Doc.concat - [ - Doc.text "await "; - Doc.lparen; - leftPrinted; - printBinaryOperator ~inlineRhs:false operator; - rightPrinted; - Doc.rparen; - ] - else - Doc.concat - [ - leftPrinted; - printBinaryOperator ~inlineRhs:false operator; - rightPrinted; - ] - in - - let doc = - if (not isLhs) && Parens.rhsBinaryExprOperand operator expr then - Doc.concat [ Doc.lparen; doc; Doc.rparen ] - else doc - in - printComments doc cmtTbl expr.pexp_loc - else - let printeableAttrs, internalAttrs = + if + ParsetreeViewer.flattenableOperators parentOperator operator + && not (ParsetreeViewer.hasAttributes expr.pexp_attributes) + then + let leftPrinted = flatten ~isLhs:true left operator in + let rightPrinted = + let rightPrinteableAttrs, rightInternalAttrs = ParsetreeViewer.partitionPrintableAttributes - expr.pexp_attributes + right.pexp_attributes in let doc = printExpressionWithComments ~customLayout - { expr with pexp_attributes = internalAttrs } + {right with pexp_attributes = rightInternalAttrs} cmtTbl in let doc = - if - Parens.subBinaryExprOperand parentOperator operator - || printeableAttrs <> [] - && (ParsetreeViewer.isBinaryExpression expr - || ParsetreeViewer.isTernaryExpr expr) - then Doc.concat [ Doc.lparen; doc; Doc.rparen ] + if Parens.flattenOperandRhs parentOperator right then + Doc.concat [Doc.lparen; doc; Doc.rparen] else doc in - Doc.concat - [ printAttributes ~customLayout printeableAttrs cmtTbl; doc ] + let doc = + Doc.concat + [ + printAttributes ~customLayout rightPrinteableAttrs cmtTbl; + doc; + ] + in + match rightPrinteableAttrs with + | [] -> doc + | _ -> addParens doc + in + let isAwait = + ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes + in + let doc = + if isAwait then + Doc.concat + [ + Doc.text "await "; + Doc.lparen; + leftPrinted; + printBinaryOperator ~inlineRhs:false operator; + rightPrinted; + Doc.rparen; + ] + else + Doc.concat + [ + leftPrinted; + printBinaryOperator ~inlineRhs:false operator; + rightPrinted; + ] + in + + let doc = + if (not isLhs) && Parens.rhsBinaryExprOperand operator expr then + Doc.concat [Doc.lparen; doc; Doc.rparen] + else doc + in + printComments doc cmtTbl expr.pexp_loc + else + let printeableAttrs, internalAttrs = + ParsetreeViewer.partitionPrintableAttributes expr.pexp_attributes + in + let doc = + printExpressionWithComments ~customLayout + {expr with pexp_attributes = internalAttrs} + cmtTbl + in + let doc = + if + Parens.subBinaryExprOperand parentOperator operator + || printeableAttrs <> [] + && (ParsetreeViewer.isBinaryExpression expr + || ParsetreeViewer.isTernaryExpr expr) + then Doc.concat [Doc.lparen; doc; Doc.rparen] + else doc + in + Doc.concat + [printAttributes ~customLayout printeableAttrs cmtTbl; doc] | _ -> assert false else match expr.pexp_desc with | Pexp_apply - ( { pexp_desc = Pexp_ident { txt = Longident.Lident "^"; loc } }, - [ (Nolabel, _); (Nolabel, _) ] ) + ( {pexp_desc = Pexp_ident {txt = Longident.Lident "^"; loc}}, + [(Nolabel, _); (Nolabel, _)] ) when loc.loc_ghost -> - let doc = printTemplateLiteral ~customLayout expr cmtTbl in - printComments doc cmtTbl expr.Parsetree.pexp_loc + let doc = printTemplateLiteral ~customLayout expr cmtTbl in + printComments doc cmtTbl expr.Parsetree.pexp_loc | Pexp_setfield (lhs, field, rhs) -> - let doc = - printSetFieldExpr ~customLayout expr.pexp_attributes lhs field rhs - expr.pexp_loc cmtTbl - in - if isLhs then addParens doc else doc + let doc = + printSetFieldExpr ~customLayout expr.pexp_attributes lhs field rhs + expr.pexp_loc cmtTbl + in + if isLhs then addParens doc else doc | Pexp_apply - ( { pexp_desc = Pexp_ident { txt = Longident.Lident "#=" } }, - [ (Nolabel, lhs); (Nolabel, rhs) ] ) -> - let rhsDoc = printExpressionWithComments ~customLayout rhs cmtTbl in - let lhsDoc = printExpressionWithComments ~customLayout lhs cmtTbl in - (* TODO: unify indentation of "=" *) - let shouldIndent = ParsetreeViewer.isBinaryExpression rhs in - let doc = + ( {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}}, + [(Nolabel, lhs); (Nolabel, rhs)] ) -> + let rhsDoc = printExpressionWithComments ~customLayout rhs cmtTbl in + let lhsDoc = printExpressionWithComments ~customLayout lhs cmtTbl in + (* TODO: unify indentation of "=" *) + let shouldIndent = ParsetreeViewer.isBinaryExpression rhs in + let doc = + Doc.group + (Doc.concat + [ + lhsDoc; + Doc.text " ="; + (if shouldIndent then + Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) + else Doc.concat [Doc.space; rhsDoc]); + ]) + in + let doc = + match expr.pexp_attributes with + | [] -> doc + | attrs -> Doc.group - (Doc.concat - [ - lhsDoc; - Doc.text " ="; - (if shouldIndent then - Doc.group (Doc.indent (Doc.concat [ Doc.line; rhsDoc ])) - else Doc.concat [ Doc.space; rhsDoc ]); - ]) - in - let doc = - match expr.pexp_attributes with - | [] -> doc - | attrs -> - Doc.group - (Doc.concat - [ printAttributes ~customLayout attrs cmtTbl; doc ]) - in - if isLhs then addParens doc else doc + (Doc.concat [printAttributes ~customLayout attrs cmtTbl; doc]) + in + if isLhs then addParens doc else doc | _ -> ( - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.binaryExprOperand ~isLhs expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.binaryExprOperand ~isLhs expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) in flatten ~isLhs expr parentOperator in match expr.pexp_desc with | Pexp_apply - ( { - pexp_desc = Pexp_ident { txt = Longident.Lident (("|." | "|>") as op) }; - }, - [ (Nolabel, lhs); (Nolabel, rhs) ] ) + ( {pexp_desc = Pexp_ident {txt = Longident.Lident (("|." | "|>") as op)}}, + [(Nolabel, lhs); (Nolabel, rhs)] ) when not (ParsetreeViewer.isBinaryExpression lhs || ParsetreeViewer.isBinaryExpression rhs || printAttributes ~customLayout expr.pexp_attributes cmtTbl <> Doc.nil) -> - let lhsHasCommentBelow = hasCommentBelow cmtTbl lhs.pexp_loc in - let lhsDoc = printOperand ~isLhs:true lhs op in - let rhsDoc = printOperand ~isLhs:false rhs op in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - lhsDoc; - (match (lhsHasCommentBelow, op) with - | true, "|." -> Doc.concat [ Doc.softLine; Doc.text "->" ] - | false, "|." -> Doc.text "->" - | true, "|>" -> Doc.concat [ Doc.line; Doc.text "|> " ] - | false, "|>" -> Doc.text " |> " - | _ -> Doc.nil); - rhsDoc; - ]) + let lhsHasCommentBelow = hasCommentBelow cmtTbl lhs.pexp_loc in + let lhsDoc = printOperand ~isLhs:true lhs op in + let rhsDoc = printOperand ~isLhs:false rhs op in + Doc.group + (Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + lhsDoc; + (match (lhsHasCommentBelow, op) with + | true, "|." -> Doc.concat [Doc.softLine; Doc.text "->"] + | false, "|." -> Doc.text "->" + | true, "|>" -> Doc.concat [Doc.line; Doc.text "|> "] + | false, "|>" -> Doc.text " |> " + | _ -> Doc.nil); + rhsDoc; + ]) | Pexp_apply - ( { pexp_desc = Pexp_ident { txt = Longident.Lident operator } }, - [ (Nolabel, lhs); (Nolabel, rhs) ] ) -> - let right = - let operatorWithRhs = - let rhsDoc = printOperand ~isLhs:false rhs operator in - Doc.concat - [ - printBinaryOperator - ~inlineRhs:(ParsetreeViewer.shouldInlineRhsBinaryExpr rhs) - operator; - rhsDoc; - ] - in - if ParsetreeViewer.shouldIndentBinaryExpr expr then - Doc.group (Doc.indent operatorWithRhs) - else operatorWithRhs - in - let doc = - Doc.group (Doc.concat [ printOperand ~isLhs:true lhs operator; right ]) + ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, + [(Nolabel, lhs); (Nolabel, rhs)] ) -> + let right = + let operatorWithRhs = + let rhsDoc = printOperand ~isLhs:false rhs operator in + Doc.concat + [ + printBinaryOperator + ~inlineRhs:(ParsetreeViewer.shouldInlineRhsBinaryExpr rhs) + operator; + rhsDoc; + ] in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - (match - Parens.binaryExpr - { - expr with - pexp_attributes = - ParsetreeViewer.filterPrintableAttributes - expr.pexp_attributes; - } - with - | Braced bracesLoc -> printBraces doc expr bracesLoc - | Parenthesized -> addParens doc - | Nothing -> doc); - ]) + if ParsetreeViewer.shouldIndentBinaryExpr expr then + Doc.group (Doc.indent operatorWithRhs) + else operatorWithRhs + in + let doc = + Doc.group (Doc.concat [printOperand ~isLhs:true lhs operator; right]) + in + Doc.group + (Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + (match + Parens.binaryExpr + { + expr with + pexp_attributes = + ParsetreeViewer.filterPrintableAttributes + expr.pexp_attributes; + } + with + | Braced bracesLoc -> printBraces doc expr bracesLoc + | Parenthesized -> addParens doc + | Nothing -> doc); + ]) | _ -> Doc.nil and printBeltListConcatApply ~customLayout subLists cmtTbl = let makeSpreadDoc commaBeforeSpread = function | Some expr -> - Doc.concat - [ - commaBeforeSpread; - Doc.dotdotdot; - (let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); - ] + Doc.concat + [ + commaBeforeSpread; + Doc.dotdotdot; + (let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + ] | None -> Doc.nil in let makeSubListDoc (expressions, spread) = let commaBeforeSpread = match expressions with | [] -> Doc.nil - | _ -> Doc.concat [ Doc.text ","; Doc.line ] + | _ -> Doc.concat [Doc.text ","; Doc.line] in let spreadDoc = makeSpreadDoc commaBeforeSpread spread in Doc.concat [ Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) + ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map (fun expr -> let doc = @@ -232978,7 +232896,7 @@ and printBeltListConcatApply ~customLayout subLists cmtTbl = [ Doc.softLine; Doc.join - ~sep:(Doc.concat [ Doc.text ","; Doc.line ]) + ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map makeSubListDoc (List.map ParsetreeViewer.collectListExpressions subLists)); ]); @@ -232991,243 +232909,228 @@ and printBeltListConcatApply ~customLayout subLists cmtTbl = and printPexpApply ~customLayout expr cmtTbl = match expr.pexp_desc with | Pexp_apply - ( { pexp_desc = Pexp_ident { txt = Longident.Lident "##" } }, - [ (Nolabel, parentExpr); (Nolabel, memberExpr) ] ) -> - let parentDoc = - let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces - | Nothing -> doc - in - let member = - let memberDoc = - match memberExpr.pexp_desc with - | Pexp_ident lident -> - printComments - (printLongident lident.txt) - cmtTbl memberExpr.pexp_loc - | _ -> printExpressionWithComments ~customLayout memberExpr cmtTbl - in - Doc.concat [ Doc.text "\""; memberDoc; Doc.text "\"" ] + ( {pexp_desc = Pexp_ident {txt = Longident.Lident "##"}}, + [(Nolabel, parentExpr); (Nolabel, memberExpr)] ) -> + let parentDoc = + let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in + match Parens.unaryExprOperand parentExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc parentExpr braces + | Nothing -> doc + in + let member = + let memberDoc = + match memberExpr.pexp_desc with + | Pexp_ident lident -> + printComments (printLongident lident.txt) cmtTbl memberExpr.pexp_loc + | _ -> printExpressionWithComments ~customLayout memberExpr cmtTbl in + Doc.concat [Doc.text "\""; memberDoc; Doc.text "\""] + in + Doc.group + (Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + parentDoc; + Doc.lbracket; + member; + Doc.rbracket; + ]) + | Pexp_apply + ( {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}}, + [(Nolabel, lhs); (Nolabel, rhs)] ) -> ( + let rhsDoc = + let doc = printExpressionWithComments ~customLayout rhs cmtTbl in + match Parens.expr rhs with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc rhs braces + | Nothing -> doc + in + (* TODO: unify indentation of "=" *) + let shouldIndent = + (not (ParsetreeViewer.isBracedExpr rhs)) + && ParsetreeViewer.isBinaryExpression rhs + in + let doc = Doc.group (Doc.concat [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - parentDoc; - Doc.lbracket; - member; - Doc.rbracket; + printExpressionWithComments ~customLayout lhs cmtTbl; + Doc.text " ="; + (if shouldIndent then + Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) + else Doc.concat [Doc.space; rhsDoc]); ]) + in + match expr.pexp_attributes with + | [] -> doc + | attrs -> + Doc.group (Doc.concat [printAttributes ~customLayout attrs cmtTbl; doc])) | Pexp_apply - ( { pexp_desc = Pexp_ident { txt = Longident.Lident "#=" } }, - [ (Nolabel, lhs); (Nolabel, rhs) ] ) -> ( - let rhsDoc = - let doc = printExpressionWithComments ~customLayout rhs cmtTbl in - match Parens.expr rhs with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc rhs braces - | Nothing -> doc - in - (* TODO: unify indentation of "=" *) - let shouldIndent = - (not (ParsetreeViewer.isBracedExpr rhs)) - && ParsetreeViewer.isBinaryExpression rhs - in - let doc = - Doc.group - (Doc.concat - [ - printExpressionWithComments ~customLayout lhs cmtTbl; - Doc.text " ="; - (if shouldIndent then - Doc.group (Doc.indent (Doc.concat [ Doc.line; rhsDoc ])) - else Doc.concat [ Doc.space; rhsDoc ]); - ]) - in - match expr.pexp_attributes with - | [] -> doc - | attrs -> - Doc.group - (Doc.concat [ printAttributes ~customLayout attrs cmtTbl; doc ])) - | Pexp_apply - ( { - pexp_desc = Pexp_ident { txt = Longident.Ldot (Lident "Array", "get") }; - }, - [ (Nolabel, parentExpr); (Nolabel, memberExpr) ] ) + ( {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "get")}}, + [(Nolabel, parentExpr); (Nolabel, memberExpr)] ) when not (ParsetreeViewer.isRewrittenUnderscoreApplySugar parentExpr) -> - (* Don't print the Array.get(_, 0) sugar a.k.a. (__x) => Array.get(__x, 0) as _[0] *) - let member = - let memberDoc = - let doc = - printExpressionWithComments ~customLayout memberExpr cmtTbl - in - match Parens.expr memberExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc memberExpr braces - | Nothing -> doc - in - let shouldInline = - match memberExpr.pexp_desc with - | Pexp_constant _ | Pexp_ident _ -> true - | _ -> false - in - if shouldInline then memberDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [ Doc.softLine; memberDoc ]); Doc.softLine; - ] - in - let parentDoc = - let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with + (* Don't print the Array.get(_, 0) sugar a.k.a. (__x) => Array.get(__x, 0) as _[0] *) + let member = + let memberDoc = + let doc = printExpressionWithComments ~customLayout memberExpr cmtTbl in + match Parens.expr memberExpr with | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces + | Braced braces -> printBraces doc memberExpr braces | Nothing -> doc in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - parentDoc; - Doc.lbracket; - member; - Doc.rbracket; - ]) - | Pexp_apply - ( { - pexp_desc = Pexp_ident { txt = Longident.Ldot (Lident "Array", "set") }; - }, - [ (Nolabel, parentExpr); (Nolabel, memberExpr); (Nolabel, targetExpr) ] - ) -> - let member = - let memberDoc = - let doc = - printExpressionWithComments ~customLayout memberExpr cmtTbl - in - match Parens.expr memberExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc memberExpr braces - | Nothing -> doc - in - let shouldInline = - match memberExpr.pexp_desc with - | Pexp_constant _ | Pexp_ident _ -> true - | _ -> false - in - if shouldInline then memberDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [ Doc.softLine; memberDoc ]); Doc.softLine; - ] - in - let shouldIndentTargetExpr = - if ParsetreeViewer.isBracedExpr targetExpr then false - else - ParsetreeViewer.isBinaryExpression targetExpr - || - match targetExpr with - | { - pexp_attributes = [ ({ Location.txt = "ns.ternary" }, _) ]; - pexp_desc = Pexp_ifthenelse (ifExpr, _, _); - } -> - ParsetreeViewer.isBinaryExpression ifExpr - || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes - | { pexp_desc = Pexp_newtype _ } -> false - | e -> - ParsetreeViewer.hasAttributes e.pexp_attributes - || ParsetreeViewer.isArrayAccess e + let shouldInline = + match memberExpr.pexp_desc with + | Pexp_constant _ | Pexp_ident _ -> true + | _ -> false in - let targetExpr = - let doc = printExpressionWithComments ~customLayout targetExpr cmtTbl in - match Parens.expr targetExpr with + if shouldInline then memberDoc + else + Doc.concat + [Doc.indent (Doc.concat [Doc.softLine; memberDoc]); Doc.softLine] + in + let parentDoc = + let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in + match Parens.unaryExprOperand parentExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc parentExpr braces + | Nothing -> doc + in + Doc.group + (Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + parentDoc; + Doc.lbracket; + member; + Doc.rbracket; + ]) + | Pexp_apply + ( {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "set")}}, + [(Nolabel, parentExpr); (Nolabel, memberExpr); (Nolabel, targetExpr)] ) + -> + let member = + let memberDoc = + let doc = printExpressionWithComments ~customLayout memberExpr cmtTbl in + match Parens.expr memberExpr with | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc targetExpr braces + | Braced braces -> printBraces doc memberExpr braces | Nothing -> doc in - let parentDoc = - let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces - | Nothing -> doc + let shouldInline = + match memberExpr.pexp_desc with + | Pexp_constant _ | Pexp_ident _ -> true + | _ -> false in - Doc.group - (Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - parentDoc; - Doc.lbracket; - member; - Doc.rbracket; - Doc.text " ="; - (if shouldIndentTargetExpr then - Doc.indent (Doc.concat [ Doc.line; targetExpr ]) - else Doc.concat [ Doc.space; targetExpr ]); - ]) + if shouldInline then memberDoc + else + Doc.concat + [Doc.indent (Doc.concat [Doc.softLine; memberDoc]); Doc.softLine] + in + let shouldIndentTargetExpr = + if ParsetreeViewer.isBracedExpr targetExpr then false + else + ParsetreeViewer.isBinaryExpression targetExpr + || + match targetExpr with + | { + pexp_attributes = [({Location.txt = "ns.ternary"}, _)]; + pexp_desc = Pexp_ifthenelse (ifExpr, _, _); + } -> + ParsetreeViewer.isBinaryExpression ifExpr + || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes + | {pexp_desc = Pexp_newtype _} -> false + | e -> + ParsetreeViewer.hasAttributes e.pexp_attributes + || ParsetreeViewer.isArrayAccess e + in + let targetExpr = + let doc = printExpressionWithComments ~customLayout targetExpr cmtTbl in + match Parens.expr targetExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc targetExpr braces + | Nothing -> doc + in + let parentDoc = + let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in + match Parens.unaryExprOperand parentExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc parentExpr braces + | Nothing -> doc + in + Doc.group + (Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + parentDoc; + Doc.lbracket; + member; + Doc.rbracket; + Doc.text " ="; + (if shouldIndentTargetExpr then + Doc.indent (Doc.concat [Doc.line; targetExpr]) + else Doc.concat [Doc.space; targetExpr]); + ]) (* TODO: cleanup, are those branches even remotely performant? *) - | Pexp_apply ({ pexp_desc = Pexp_ident lident }, args) + | Pexp_apply ({pexp_desc = Pexp_ident lident}, args) when ParsetreeViewer.isJsxExpression expr -> - printJsxExpression ~customLayout lident args cmtTbl + printJsxExpression ~customLayout lident args cmtTbl | Pexp_apply (callExpr, args) -> - let args = - List.map - (fun (lbl, arg) -> (lbl, ParsetreeViewer.rewriteUnderscoreApply arg)) - args + let args = + List.map + (fun (lbl, arg) -> (lbl, ParsetreeViewer.rewriteUnderscoreApply arg)) + args + in + let uncurried, attrs = + ParsetreeViewer.processUncurriedAttribute expr.pexp_attributes + in + let callExprDoc = + let doc = printExpressionWithComments ~customLayout callExpr cmtTbl in + match Parens.callExpr callExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc callExpr braces + | Nothing -> doc + in + if ParsetreeViewer.requiresSpecialCallbackPrintingFirstArg args then + let argsDoc = + printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args + cmtTbl in - let uncurried, attrs = - ParsetreeViewer.processUncurriedAttribute expr.pexp_attributes + Doc.concat + [printAttributes ~customLayout attrs cmtTbl; callExprDoc; argsDoc] + else if ParsetreeViewer.requiresSpecialCallbackPrintingLastArg args then + let argsDoc = + printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args + cmtTbl in - let callExprDoc = - let doc = printExpressionWithComments ~customLayout callExpr cmtTbl in - match Parens.callExpr callExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc callExpr braces - | Nothing -> doc + (* + * Fixes the following layout (the `[` and `]` should break): + * [fn(x => { + * let _ = x + * }), fn(y => { + * let _ = y + * }), fn(z => { + * let _ = z + * })] + * See `Doc.willBreak documentation in interface file for more context. + * Context: + * https://github.com/rescript-lang/syntax/issues/111 + * https://github.com/rescript-lang/syntax/issues/166 + *) + let maybeBreakParent = + if Doc.willBreak argsDoc then Doc.breakParent else Doc.nil in - if ParsetreeViewer.requiresSpecialCallbackPrintingFirstArg args then - let argsDoc = - printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout - args cmtTbl - in - Doc.concat - [ printAttributes ~customLayout attrs cmtTbl; callExprDoc; argsDoc ] - else if ParsetreeViewer.requiresSpecialCallbackPrintingLastArg args then - let argsDoc = - printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args - cmtTbl - in - (* - * Fixes the following layout (the `[` and `]` should break): - * [fn(x => { - * let _ = x - * }), fn(y => { - * let _ = y - * }), fn(z => { - * let _ = z - * })] - * See `Doc.willBreak documentation in interface file for more context. - * Context: - * https://github.com/rescript-lang/syntax/issues/111 - * https://github.com/rescript-lang/syntax/issues/166 - *) - let maybeBreakParent = - if Doc.willBreak argsDoc then Doc.breakParent else Doc.nil - in - Doc.concat - [ - maybeBreakParent; - printAttributes ~customLayout attrs cmtTbl; - callExprDoc; - argsDoc; - ] - else - let argsDoc = printArguments ~customLayout ~uncurried args cmtTbl in - Doc.concat - [ printAttributes ~customLayout attrs cmtTbl; callExprDoc; argsDoc ] + Doc.concat + [ + maybeBreakParent; + printAttributes ~customLayout attrs cmtTbl; + callExprDoc; + argsDoc; + ] + else + let argsDoc = printArguments ~customLayout ~uncurried args cmtTbl in + Doc.concat + [printAttributes ~customLayout attrs cmtTbl; callExprDoc; argsDoc] | _ -> assert false and printJsxExpression ~customLayout lident args cmtTbl = @@ -233239,9 +233142,9 @@ and printJsxExpression ~customLayout lident args cmtTbl = | Some { Parsetree.pexp_desc = - Pexp_construct ({ txt = Longident.Lident "[]" }, None); + Pexp_construct ({txt = Longident.Lident "[]"}, None); } -> - false + false | None -> false | _ -> true in @@ -233250,17 +233153,17 @@ and printJsxExpression ~customLayout lident args cmtTbl = | Some { Parsetree.pexp_desc = - Pexp_construct ({ txt = Longident.Lident "[]" }, None); + Pexp_construct ({txt = Longident.Lident "[]"}, None); pexp_loc = loc; } -> - not (hasCommentsInside cmtTbl loc) + not (hasCommentsInside cmtTbl loc) | _ -> false in let printChildren children = let lineSep = match children with | Some expr -> - if hasNestedJsxOrMoreThanOneChild expr then Doc.hardLine else Doc.line + if hasNestedJsxOrMoreThanOneChild expr then Doc.hardLine else Doc.line | None -> Doc.line in Doc.concat @@ -233271,8 +233174,8 @@ and printJsxExpression ~customLayout lident args cmtTbl = Doc.line; (match children with | Some childrenExpression -> - printJsxChildren ~customLayout childrenExpression - ~sep:lineSep cmtTbl + printJsxChildren ~customLayout childrenExpression ~sep:lineSep + cmtTbl | None -> Doc.nil); ]); lineSep; @@ -233285,27 +233188,27 @@ and printJsxExpression ~customLayout lident args cmtTbl = (Doc.concat [ printComments - (Doc.concat [ Doc.lessThan; name ]) + (Doc.concat [Doc.lessThan; name]) cmtTbl lident.Asttypes.loc; formattedProps; (match children with | Some { Parsetree.pexp_desc = - Pexp_construct ({ txt = Longident.Lident "[]" }, None); + Pexp_construct ({txt = Longident.Lident "[]"}, None); } when isSelfClosing -> - Doc.text "/>" + Doc.text "/>" | _ -> - (* if tag A has trailing comments then put > on the next line - - - *) - if hasTrailingComments cmtTbl lident.Asttypes.loc then - Doc.concat [ Doc.softLine; Doc.greaterThan ] - else Doc.greaterThan); + (* if tag A has trailing comments then put > on the next line + + + *) + if hasTrailingComments cmtTbl lident.Asttypes.loc then + Doc.concat [Doc.softLine; Doc.greaterThan] + else Doc.greaterThan); ]); (if isSelfClosing then Doc.nil else @@ -233317,10 +233220,10 @@ and printJsxExpression ~customLayout lident args cmtTbl = | Some { Parsetree.pexp_desc = - Pexp_construct ({ txt = Longident.Lident "[]" }, None); + Pexp_construct ({txt = Longident.Lident "[]"}, None); pexp_loc = loc; } -> - printCommentsInside cmtTbl loc + printCommentsInside cmtTbl loc | _ -> Doc.nil); Doc.text " Doc.nil + | Pexp_construct ({txt = Longident.Lident "[]"}, None) -> Doc.nil | _ -> - Doc.indent - (Doc.concat - [ - Doc.line; - printJsxChildren ~customLayout expr ~sep:lineSep cmtTbl; - ])); + Doc.indent + (Doc.concat + [ + Doc.line; + printJsxChildren ~customLayout expr ~sep:lineSep cmtTbl; + ])); lineSep; closing; ]) @@ -233354,53 +233257,52 @@ and printJsxFragment ~customLayout expr cmtTbl = and printJsxChildren ~customLayout (childrenExpr : Parsetree.expression) ~sep cmtTbl = match childrenExpr.pexp_desc with - | Pexp_construct ({ txt = Longident.Lident "::" }, _) -> - let children, _ = ParsetreeViewer.collectListExpressions childrenExpr in - Doc.group - (Doc.join ~sep - (List.map - (fun (expr : Parsetree.expression) -> - let leadingLineCommentPresent = - hasLeadingLineComment cmtTbl expr.pexp_loc - in - let exprDoc = - printExpressionWithComments ~customLayout expr cmtTbl - in - let addParensOrBraces exprDoc = - (* {(20: int)} make sure that we also protect the expression inside *) - let innerDoc = - if Parens.bracedExpr expr then addParens exprDoc - else exprDoc - in - if leadingLineCommentPresent then addBraces innerDoc - else Doc.concat [ Doc.lbrace; innerDoc; Doc.rbrace ] + | Pexp_construct ({txt = Longident.Lident "::"}, _) -> + let children, _ = ParsetreeViewer.collectListExpressions childrenExpr in + Doc.group + (Doc.join ~sep + (List.map + (fun (expr : Parsetree.expression) -> + let leadingLineCommentPresent = + hasLeadingLineComment cmtTbl expr.pexp_loc + in + let exprDoc = + printExpressionWithComments ~customLayout expr cmtTbl + in + let addParensOrBraces exprDoc = + (* {(20: int)} make sure that we also protect the expression inside *) + let innerDoc = + if Parens.bracedExpr expr then addParens exprDoc else exprDoc in - match Parens.jsxChildExpr expr with - | Nothing -> exprDoc - | Parenthesized -> addParensOrBraces exprDoc - | Braced bracesLoc -> - printComments (addParensOrBraces exprDoc) cmtTbl bracesLoc) - children)) - | _ -> - let leadingLineCommentPresent = - hasLeadingLineComment cmtTbl childrenExpr.pexp_loc - in - let exprDoc = - printExpressionWithComments ~customLayout childrenExpr cmtTbl - in - Doc.concat - [ - Doc.dotdotdot; - (match Parens.jsxChildExpr childrenExpr with - | Parenthesized | Braced _ -> - let innerDoc = - if Parens.bracedExpr childrenExpr then addParens exprDoc - else exprDoc + if leadingLineCommentPresent then addBraces innerDoc + else Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace] in - if leadingLineCommentPresent then addBraces innerDoc - else Doc.concat [ Doc.lbrace; innerDoc; Doc.rbrace ] - | Nothing -> exprDoc); - ] + match Parens.jsxChildExpr expr with + | Nothing -> exprDoc + | Parenthesized -> addParensOrBraces exprDoc + | Braced bracesLoc -> + printComments (addParensOrBraces exprDoc) cmtTbl bracesLoc) + children)) + | _ -> + let leadingLineCommentPresent = + hasLeadingLineComment cmtTbl childrenExpr.pexp_loc + in + let exprDoc = + printExpressionWithComments ~customLayout childrenExpr cmtTbl + in + Doc.concat + [ + Doc.dotdotdot; + (match Parens.jsxChildExpr childrenExpr with + | Parenthesized | Braced _ -> + let innerDoc = + if Parens.bracedExpr childrenExpr then addParens exprDoc + else exprDoc + in + if leadingLineCommentPresent then addBraces innerDoc + else Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace] + | Nothing -> exprDoc); + ] and printJsxProps ~customLayout args cmtTbl : Doc.t * Parsetree.expression option = @@ -233419,10 +233321,10 @@ and printJsxProps ~customLayout args cmtTbl : let isSelfClosing children = match children with | { - Parsetree.pexp_desc = Pexp_construct ({ txt = Longident.Lident "[]" }, None); + Parsetree.pexp_desc = Pexp_construct ({txt = Longident.Lident "[]"}, None); pexp_loc = loc; } -> - not (hasCommentsInside cmtTbl loc) + not (hasCommentsInside cmtTbl loc) | _ -> false in let rec loop props args = @@ -233433,50 +233335,50 @@ and printJsxProps ~customLayout args cmtTbl : ( Asttypes.Nolabel, { Parsetree.pexp_desc = - Pexp_construct ({ txt = Longident.Lident "()" }, None); + Pexp_construct ({txt = Longident.Lident "()"}, None); } ); ] -> - let doc = if isSelfClosing children then Doc.line else Doc.nil in - (doc, Some children) + let doc = if isSelfClosing children then Doc.line else Doc.nil in + (doc, Some children) | ((_, expr) as lastProp) :: [ (Asttypes.Labelled "children", children); ( Asttypes.Nolabel, { Parsetree.pexp_desc = - Pexp_construct ({ txt = Longident.Lident "()" }, None); + Pexp_construct ({txt = Longident.Lident "()"}, None); } ); ] -> - let loc = - match expr.Parsetree.pexp_attributes with - | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _attrs -> - { loc with loc_end = expr.pexp_loc.loc_end } - | _ -> expr.pexp_loc - in - let trailingCommentsPresent = hasTrailingComments cmtTbl loc in - let propDoc = printJsxProp ~customLayout lastProp cmtTbl in - let formattedProps = - Doc.concat - [ - Doc.indent - (Doc.concat - [ - Doc.line; - Doc.group - (Doc.join ~sep:Doc.line (propDoc :: props |> List.rev)); - ]); - (* print > on new line if the last prop has trailing comments *) - (match (isSelfClosing children, trailingCommentsPresent) with - (* we always put /> on a new line when a self-closing tag breaks *) - | true, _ -> Doc.line - | false, true -> Doc.softLine - | false, false -> Doc.nil); - ] - in - (formattedProps, Some children) + let loc = + match expr.Parsetree.pexp_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _attrs -> + {loc with loc_end = expr.pexp_loc.loc_end} + | _ -> expr.pexp_loc + in + let trailingCommentsPresent = hasTrailingComments cmtTbl loc in + let propDoc = printJsxProp ~customLayout lastProp cmtTbl in + let formattedProps = + Doc.concat + [ + Doc.indent + (Doc.concat + [ + Doc.line; + Doc.group + (Doc.join ~sep:Doc.line (propDoc :: props |> List.rev)); + ]); + (* print > on new line if the last prop has trailing comments *) + (match (isSelfClosing children, trailingCommentsPresent) with + (* we always put /> on a new line when a self-closing tag breaks *) + | true, _ -> Doc.line + | false, true -> Doc.softLine + | false, false -> Doc.nil); + ] + in + (formattedProps, Some children) | arg :: args -> - let propDoc = printJsxProp ~customLayout arg cmtTbl in - loop (propDoc :: props) args + let propDoc = printJsxProp ~customLayout arg cmtTbl in + loop (propDoc :: props) args in loop [] args @@ -233485,81 +233387,79 @@ and printJsxProp ~customLayout arg cmtTbl = | ( ((Asttypes.Labelled lblTxt | Optional lblTxt) as lbl), { Parsetree.pexp_attributes = - [ ({ Location.txt = "ns.namedArgLoc"; loc = argLoc }, _) ]; - pexp_desc = Pexp_ident { txt = Longident.Lident ident }; + [({Location.txt = "ns.namedArgLoc"; loc = argLoc}, _)]; + pexp_desc = Pexp_ident {txt = Longident.Lident ident}; } ) when lblTxt = ident (* jsx punning *) -> ( - match lbl with - | Nolabel -> Doc.nil - | Labelled _lbl -> printComments (printIdentLike ident) cmtTbl argLoc - | Optional _lbl -> - let doc = Doc.concat [ Doc.question; printIdentLike ident ] in - printComments doc cmtTbl argLoc) + match lbl with + | Nolabel -> Doc.nil + | Labelled _lbl -> printComments (printIdentLike ident) cmtTbl argLoc + | Optional _lbl -> + let doc = Doc.concat [Doc.question; printIdentLike ident] in + printComments doc cmtTbl argLoc) | ( ((Asttypes.Labelled lblTxt | Optional lblTxt) as lbl), { Parsetree.pexp_attributes = []; - pexp_desc = Pexp_ident { txt = Longident.Lident ident }; + pexp_desc = Pexp_ident {txt = Longident.Lident ident}; } ) when lblTxt = ident (* jsx punning when printing from Reason *) -> ( - match lbl with - | Nolabel -> Doc.nil - | Labelled _lbl -> printIdentLike ident - | Optional _lbl -> Doc.concat [ Doc.question; printIdentLike ident ]) + match lbl with + | Nolabel -> Doc.nil + | Labelled _lbl -> printIdentLike ident + | Optional _lbl -> Doc.concat [Doc.question; printIdentLike ident]) | Asttypes.Labelled "_spreadProps", expr -> - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - Doc.concat [ Doc.lbrace; Doc.dotdotdot; Doc.softLine; doc; Doc.rbrace ] + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + Doc.concat [Doc.lbrace; Doc.dotdotdot; Doc.softLine; doc; Doc.rbrace] | lbl, expr -> - let argLoc, expr = - match expr.pexp_attributes with - | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: attrs -> - (loc, { expr with pexp_attributes = attrs }) - | _ -> (Location.none, expr) - in - let lblDoc = - match lbl with - | Asttypes.Labelled lbl -> - let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in - Doc.concat [ lbl; Doc.equal ] - | Asttypes.Optional lbl -> - let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in - Doc.concat [ lbl; Doc.equal; Doc.question ] - | Nolabel -> Doc.nil - in - let exprDoc = - let leadingLineCommentPresent = - hasLeadingLineComment cmtTbl expr.pexp_loc - in - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.jsxPropExpr expr with - | Parenthesized | Braced _ -> - (* {(20: int)} make sure that we also protect the expression inside *) - let innerDoc = - if Parens.bracedExpr expr then addParens doc else doc - in - if leadingLineCommentPresent then addBraces innerDoc - else Doc.concat [ Doc.lbrace; innerDoc; Doc.rbrace ] - | _ -> doc + let argLoc, expr = + match expr.pexp_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: attrs -> + (loc, {expr with pexp_attributes = attrs}) + | _ -> (Location.none, expr) + in + let lblDoc = + match lbl with + | Asttypes.Labelled lbl -> + let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in + Doc.concat [lbl; Doc.equal] + | Asttypes.Optional lbl -> + let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in + Doc.concat [lbl; Doc.equal; Doc.question] + | Nolabel -> Doc.nil + in + let exprDoc = + let leadingLineCommentPresent = + hasLeadingLineComment cmtTbl expr.pexp_loc in - let fullLoc = { argLoc with loc_end = expr.pexp_loc.loc_end } in - printComments (Doc.concat [ lblDoc; exprDoc ]) cmtTbl fullLoc + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.jsxPropExpr expr with + | Parenthesized | Braced _ -> + (* {(20: int)} make sure that we also protect the expression inside *) + let innerDoc = if Parens.bracedExpr expr then addParens doc else doc in + if leadingLineCommentPresent then addBraces innerDoc + else Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace] + | _ -> doc + in + let fullLoc = {argLoc with loc_end = expr.pexp_loc.loc_end} in + printComments (Doc.concat [lblDoc; exprDoc]) cmtTbl fullLoc (* div -> div. * Navabar.createElement -> Navbar * Staff.Users.createElement -> Staff.Users *) -and printJsxName { txt = lident } = +and printJsxName {txt = lident} = let rec flatten acc lident = match lident with | Longident.Lident txt -> txt :: acc | Ldot (lident, txt) -> - let acc = if txt = "createElement" then acc else txt :: acc in - flatten acc lident + let acc = if txt = "createElement" then acc else txt :: acc in + flatten acc lident | _ -> acc in match lident with | Longident.Lident txt -> Doc.text txt | _ as lident -> - let segments = flatten [] lident in - Doc.join ~sep:Doc.dot (List.map Doc.text segments) + let segments = flatten [] lident in + Doc.join ~sep:Doc.dot (List.map Doc.text segments) and printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args cmtTbl = @@ -233571,32 +233471,29 @@ and printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args let callback, printedArgs = match args with | (lbl, expr) :: args -> - let lblDoc = - match lbl with - | Asttypes.Nolabel -> Doc.nil - | Asttypes.Labelled txt -> - Doc.concat [ Doc.tilde; printIdentLike txt; Doc.equal ] - | Asttypes.Optional txt -> - Doc.concat - [ Doc.tilde; printIdentLike txt; Doc.equal; Doc.question ] - in - let callback = - Doc.concat - [ - lblDoc; - printPexpFun ~customLayout ~inCallback:FitsOnOneLine expr cmtTbl; - ] - in - let callback = lazy (printComments callback cmtTbl expr.pexp_loc) in - let printedArgs = - lazy - (Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun arg -> printArgument ~customLayout arg cmtTbl) - args)) - in - (callback, printedArgs) + let lblDoc = + match lbl with + | Asttypes.Nolabel -> Doc.nil + | Asttypes.Labelled txt -> + Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal] + | Asttypes.Optional txt -> + Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal; Doc.question] + in + let callback = + Doc.concat + [ + lblDoc; + printPexpFun ~customLayout ~inCallback:FitsOnOneLine expr cmtTbl; + ] + in + let callback = lazy (printComments callback cmtTbl expr.pexp_loc) in + let printedArgs = + lazy + (Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map (fun arg -> printArgument ~customLayout arg cmtTbl) args)) + in + (callback, printedArgs) | _ -> assert false in @@ -233646,7 +233543,7 @@ and printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args *) if customLayout > customLayoutThreshold then Lazy.force breakAllArgs else if Doc.willBreak (Lazy.force printedArgs) then Lazy.force breakAllArgs - else Doc.customLayout [ Lazy.force fitsOnOneLine; Lazy.force breakAllArgs ] + else Doc.customLayout [Lazy.force fitsOnOneLine; Lazy.force breakAllArgs] and printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args cmtTbl = @@ -233659,39 +233556,38 @@ and printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args let rec loop acc args = match args with | [] -> (lazy Doc.nil, lazy Doc.nil, lazy Doc.nil) - | [ (lbl, expr) ] -> - let lblDoc = - match lbl with - | Asttypes.Nolabel -> Doc.nil - | Asttypes.Labelled txt -> - Doc.concat [ Doc.tilde; printIdentLike txt; Doc.equal ] - | Asttypes.Optional txt -> - Doc.concat - [ Doc.tilde; printIdentLike txt; Doc.equal; Doc.question ] - in - let callbackFitsOnOneLine = - lazy - (let pexpFunDoc = - printPexpFun ~customLayout ~inCallback:FitsOnOneLine expr cmtTbl - in - let doc = Doc.concat [ lblDoc; pexpFunDoc ] in - printComments doc cmtTbl expr.pexp_loc) - in - let callbackArgumentsFitsOnOneLine = - lazy - (let pexpFunDoc = - printPexpFun ~customLayout ~inCallback:ArgumentsFitOnOneLine expr - cmtTblCopy - in - let doc = Doc.concat [ lblDoc; pexpFunDoc ] in - printComments doc cmtTblCopy expr.pexp_loc) - in - ( lazy (Doc.concat (List.rev acc)), - callbackFitsOnOneLine, - callbackArgumentsFitsOnOneLine ) + | [(lbl, expr)] -> + let lblDoc = + match lbl with + | Asttypes.Nolabel -> Doc.nil + | Asttypes.Labelled txt -> + Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal] + | Asttypes.Optional txt -> + Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal; Doc.question] + in + let callbackFitsOnOneLine = + lazy + (let pexpFunDoc = + printPexpFun ~customLayout ~inCallback:FitsOnOneLine expr cmtTbl + in + let doc = Doc.concat [lblDoc; pexpFunDoc] in + printComments doc cmtTbl expr.pexp_loc) + in + let callbackArgumentsFitsOnOneLine = + lazy + (let pexpFunDoc = + printPexpFun ~customLayout ~inCallback:ArgumentsFitOnOneLine expr + cmtTblCopy + in + let doc = Doc.concat [lblDoc; pexpFunDoc] in + printComments doc cmtTblCopy expr.pexp_loc) + in + ( lazy (Doc.concat (List.rev acc)), + callbackFitsOnOneLine, + callbackArgumentsFitsOnOneLine ) | arg :: args -> - let argDoc = printArgument ~customLayout arg cmtTbl in - loop (Doc.line :: Doc.comma :: argDoc :: acc) args + let argDoc = printArgument ~customLayout arg cmtTbl in + loop (Doc.line :: Doc.comma :: argDoc :: acc) args in let printedArgs, callback, callback2 = loop [] args in @@ -233764,48 +233660,46 @@ and printArguments ~customLayout ~uncurried | [ ( Nolabel, { - pexp_desc = Pexp_construct ({ txt = Longident.Lident "()" }, _); + pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _); pexp_loc = loc; } ); ] -> ( - (* See "parseCallExpr", ghost unit expression is used the implement - * arity zero vs arity one syntax. - * Related: https://github.com/rescript-lang/syntax/issues/138 *) - match (uncurried, loc.loc_ghost) with - | true, true -> Doc.text "(.)" (* arity zero *) - | true, false -> Doc.text "(. ())" (* arity one *) - | _ -> Doc.text "()") - | [ (Nolabel, arg) ] when ParsetreeViewer.isHuggableExpression arg -> - let argDoc = - let doc = printExpressionWithComments ~customLayout arg cmtTbl in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc - in - Doc.concat - [ - (if uncurried then Doc.text "(. " else Doc.lparen); argDoc; Doc.rparen; - ] + (* See "parseCallExpr", ghost unit expression is used the implement + * arity zero vs arity one syntax. + * Related: https://github.com/rescript-lang/syntax/issues/138 *) + match (uncurried, loc.loc_ghost) with + | true, true -> Doc.text "(.)" (* arity zero *) + | true, false -> Doc.text "(. ())" (* arity one *) + | _ -> Doc.text "()") + | [(Nolabel, arg)] when ParsetreeViewer.isHuggableExpression arg -> + let argDoc = + let doc = printExpressionWithComments ~customLayout arg cmtTbl in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc + in + Doc.concat + [(if uncurried then Doc.text "(. " else Doc.lparen); argDoc; Doc.rparen] | args -> - Doc.group - (Doc.concat - [ - (if uncurried then Doc.text "(." else Doc.lparen); - Doc.indent - (Doc.concat - [ - (if uncurried then Doc.line else Doc.softLine); - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun arg -> printArgument ~customLayout arg cmtTbl) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + (if uncurried then Doc.text "(." else Doc.lparen); + Doc.indent + (Doc.concat + [ + (if uncurried then Doc.line else Doc.softLine); + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun arg -> printArgument ~customLayout arg cmtTbl) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) (* * argument ::= @@ -233826,90 +233720,88 @@ and printArgument ~customLayout (argLbl, arg) cmtTbl = (* ~a (punned)*) | ( Asttypes.Labelled lbl, ({ - pexp_desc = Pexp_ident { txt = Longident.Lident name }; - pexp_attributes = [] | [ ({ Location.txt = "ns.namedArgLoc" }, _) ]; + pexp_desc = Pexp_ident {txt = Longident.Lident name}; + pexp_attributes = [] | [({Location.txt = "ns.namedArgLoc"}, _)]; } as argExpr) ) when lbl = name && not (ParsetreeViewer.isBracedExpr argExpr) -> - let loc = - match arg.pexp_attributes with - | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _ -> loc - | _ -> arg.pexp_loc - in - let doc = Doc.concat [ Doc.tilde; printIdentLike lbl ] in - printComments doc cmtTbl loc + let loc = + match arg.pexp_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> loc + | _ -> arg.pexp_loc + in + let doc = Doc.concat [Doc.tilde; printIdentLike lbl] in + printComments doc cmtTbl loc (* ~a: int (punned)*) | ( Asttypes.Labelled lbl, { pexp_desc = Pexp_constraint - ( ({ pexp_desc = Pexp_ident { txt = Longident.Lident name } } as - argExpr), + ( ({pexp_desc = Pexp_ident {txt = Longident.Lident name}} as argExpr), typ ); pexp_loc; pexp_attributes = - ([] | [ ({ Location.txt = "ns.namedArgLoc" }, _) ]) as attrs; + ([] | [({Location.txt = "ns.namedArgLoc"}, _)]) as attrs; } ) when lbl = name && not (ParsetreeViewer.isBracedExpr argExpr) -> - let loc = - match attrs with - | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _ -> - { loc with loc_end = pexp_loc.loc_end } - | _ -> arg.pexp_loc - in - let doc = - Doc.concat - [ - Doc.tilde; - printIdentLike lbl; - Doc.text ": "; - printTypExpr ~customLayout typ cmtTbl; - ] - in - printComments doc cmtTbl loc + let loc = + match attrs with + | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> + {loc with loc_end = pexp_loc.loc_end} + | _ -> arg.pexp_loc + in + let doc = + Doc.concat + [ + Doc.tilde; + printIdentLike lbl; + Doc.text ": "; + printTypExpr ~customLayout typ cmtTbl; + ] + in + printComments doc cmtTbl loc (* ~a? (optional lbl punned)*) | ( Asttypes.Optional lbl, { - pexp_desc = Pexp_ident { txt = Longident.Lident name }; - pexp_attributes = [] | [ ({ Location.txt = "ns.namedArgLoc" }, _) ]; + pexp_desc = Pexp_ident {txt = Longident.Lident name}; + pexp_attributes = [] | [({Location.txt = "ns.namedArgLoc"}, _)]; } ) when lbl = name -> - let loc = - match arg.pexp_attributes with - | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _ -> loc - | _ -> arg.pexp_loc - in - let doc = Doc.concat [ Doc.tilde; printIdentLike lbl; Doc.question ] in - printComments doc cmtTbl loc + let loc = + match arg.pexp_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> loc + | _ -> arg.pexp_loc + in + let doc = Doc.concat [Doc.tilde; printIdentLike lbl; Doc.question] in + printComments doc cmtTbl loc | _lbl, expr -> - let argLoc, expr = - match expr.pexp_attributes with - | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: attrs -> - (loc, { expr with pexp_attributes = attrs }) - | _ -> (expr.pexp_loc, expr) - in - let printedLbl = - match argLbl with - | Asttypes.Nolabel -> Doc.nil - | Asttypes.Labelled lbl -> - let doc = Doc.concat [ Doc.tilde; printIdentLike lbl; Doc.equal ] in - printComments doc cmtTbl argLoc - | Asttypes.Optional lbl -> - let doc = - Doc.concat - [ Doc.tilde; printIdentLike lbl; Doc.equal; Doc.question ] - in - printComments doc cmtTbl argLoc - in - let printedExpr = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - let loc = { argLoc with loc_end = expr.pexp_loc.loc_end } in - let doc = Doc.concat [ printedLbl; printedExpr ] in - printComments doc cmtTbl loc + let argLoc, expr = + match expr.pexp_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: attrs -> + (loc, {expr with pexp_attributes = attrs}) + | _ -> (expr.pexp_loc, expr) + in + let printedLbl = + match argLbl with + | Asttypes.Nolabel -> Doc.nil + | Asttypes.Labelled lbl -> + let doc = Doc.concat [Doc.tilde; printIdentLike lbl; Doc.equal] in + printComments doc cmtTbl argLoc + | Asttypes.Optional lbl -> + let doc = + Doc.concat [Doc.tilde; printIdentLike lbl; Doc.equal; Doc.question] + in + printComments doc cmtTbl argLoc + in + let printedExpr = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + let loc = {argLoc with loc_end = expr.pexp_loc.loc_end} in + let doc = Doc.concat [printedLbl; printedExpr] in + printComments doc cmtTbl loc and printCases ~customLayout (cases : Parsetree.case list) cmtTbl = Doc.breakableGroup ~forceBreak:true @@ -233936,40 +233828,40 @@ and printCase ~customLayout (case : Parsetree.case) cmtTbl = match case.pc_rhs.pexp_desc with | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ | Pexp_sequence _ -> - printExpressionBlock ~customLayout - ~braces:(ParsetreeViewer.isBracedExpr case.pc_rhs) - case.pc_rhs cmtTbl + printExpressionBlock ~customLayout + ~braces:(ParsetreeViewer.isBracedExpr case.pc_rhs) + case.pc_rhs cmtTbl | _ -> ( - let doc = - printExpressionWithComments ~customLayout case.pc_rhs cmtTbl - in - match Parens.expr case.pc_rhs with - | Parenthesized -> addParens doc - | _ -> doc) + let doc = printExpressionWithComments ~customLayout case.pc_rhs cmtTbl in + match Parens.expr case.pc_rhs with + | Parenthesized -> addParens doc + | _ -> doc) in let guard = match case.pc_guard with | None -> Doc.nil | Some expr -> - Doc.group - (Doc.concat - [ - Doc.line; - Doc.text "if "; - printExpressionWithComments ~customLayout expr cmtTbl; - ]) + Doc.group + (Doc.concat + [ + Doc.line; + Doc.text "if "; + printExpressionWithComments ~customLayout expr cmtTbl; + ]) in let shouldInlineRhs = match case.pc_rhs.pexp_desc with - | Pexp_construct ({ txt = Longident.Lident ("()" | "true" | "false") }, _) + | Pexp_construct ({txt = Longident.Lident ("()" | "true" | "false")}, _) | Pexp_constant _ | Pexp_ident _ -> - true + true | _ when ParsetreeViewer.isHuggableRhs case.pc_rhs -> true | _ -> false in let shouldIndentPattern = - match case.pc_lhs.ppat_desc with Ppat_or _ -> false | _ -> true + match case.pc_lhs.ppat_desc with + | Ppat_or _ -> false + | _ -> true in let patternDoc = let doc = printPattern ~customLayout case.pc_lhs cmtTbl in @@ -233984,11 +233876,10 @@ and printCase ~customLayout (case : Parsetree.case) cmtTbl = Doc.indent guard; Doc.text " =>"; Doc.indent - (Doc.concat - [ (if shouldInlineRhs then Doc.space else Doc.line); rhs ]); + (Doc.concat [(if shouldInlineRhs then Doc.space else Doc.line); rhs]); ] in - Doc.group (Doc.concat [ Doc.text "| "; content ]) + Doc.group (Doc.concat [Doc.text "| "; content]) and printExprFunParameters ~customLayout ~inCallback ~async ~uncurried ~hasConstraint parameters cmtTbl = @@ -234000,15 +233891,15 @@ and printExprFunParameters ~customLayout ~inCallback ~async ~uncurried attrs = []; lbl = Asttypes.Nolabel; defaultExpr = None; - pat = { Parsetree.ppat_desc = Ppat_any; ppat_loc }; + pat = {Parsetree.ppat_desc = Ppat_any; ppat_loc}; }; ] when not uncurried -> - let any = - let doc = if hasConstraint then Doc.text "(_)" else Doc.text "_" in - printComments doc cmtTbl ppat_loc - in - if async then addAsync any else any + let any = + let doc = if hasConstraint then Doc.text "(_)" else Doc.text "_" in + printComments doc cmtTbl ppat_loc + in + if async then addAsync any else any (* let f = a => () *) | [ ParsetreeViewer.Parameter @@ -234016,16 +233907,16 @@ and printExprFunParameters ~customLayout ~inCallback ~async ~uncurried attrs = []; lbl = Asttypes.Nolabel; defaultExpr = None; - pat = { Parsetree.ppat_desc = Ppat_var stringLoc }; + pat = {Parsetree.ppat_desc = Ppat_var stringLoc}; }; ] when not uncurried -> - let txtDoc = - let var = printIdentLike stringLoc.txt in - let var = if hasConstraint then addParens var else var in - if async then addAsync var else var - in - printComments txtDoc cmtTbl stringLoc.loc + let txtDoc = + let var = printIdentLike stringLoc.txt in + let var = if hasConstraint then addParens var else var in + if async then addAsync var else var + in + printComments txtDoc cmtTbl stringLoc.loc (* let f = () => () *) | [ ParsetreeViewer.Parameter @@ -234034,264 +233925,250 @@ and printExprFunParameters ~customLayout ~inCallback ~async ~uncurried lbl = Asttypes.Nolabel; defaultExpr = None; pat = - { - ppat_desc = - Ppat_construct ({ txt = Longident.Lident "()"; loc }, None); - }; + {ppat_desc = Ppat_construct ({txt = Longident.Lident "()"; loc}, None)}; }; ] when not uncurried -> - let doc = - let lparenRparen = Doc.text "()" in - if async then addAsync lparenRparen else lparenRparen - in - printComments doc cmtTbl loc + let doc = + let lparenRparen = Doc.text "()" in + if async then addAsync lparenRparen else lparenRparen + in + printComments doc cmtTbl loc (* let f = (~greeting, ~from as hometown, ~x=?) => () *) | parameters -> - let inCallback = - match inCallback with FitsOnOneLine -> true | _ -> false - in - let maybeAsyncLparen = - let lparen = if uncurried then Doc.text "(. " else Doc.lparen in - if async then addAsync lparen else lparen - in - let shouldHug = ParsetreeViewer.parametersShouldHug parameters in - let printedParamaters = - Doc.concat - [ - (if shouldHug || inCallback then Doc.nil else Doc.softLine); - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun p -> printExpFunParameter ~customLayout p cmtTbl) - parameters); - ] - in - Doc.group - (Doc.concat - [ - maybeAsyncLparen; - (if shouldHug || inCallback then printedParamaters - else - Doc.concat - [ - Doc.indent printedParamaters; Doc.trailingComma; Doc.softLine; - ]); - Doc.rparen; - ]) + let inCallback = + match inCallback with + | FitsOnOneLine -> true + | _ -> false + in + let maybeAsyncLparen = + let lparen = if uncurried then Doc.text "(. " else Doc.lparen in + if async then addAsync lparen else lparen + in + let shouldHug = ParsetreeViewer.parametersShouldHug parameters in + let printedParamaters = + Doc.concat + [ + (if shouldHug || inCallback then Doc.nil else Doc.softLine); + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun p -> printExpFunParameter ~customLayout p cmtTbl) + parameters); + ] + in + Doc.group + (Doc.concat + [ + maybeAsyncLparen; + (if shouldHug || inCallback then printedParamaters + else + Doc.concat + [Doc.indent printedParamaters; Doc.trailingComma; Doc.softLine]); + Doc.rparen; + ]) and printExpFunParameter ~customLayout parameter cmtTbl = match parameter with - | ParsetreeViewer.NewTypes { attrs; locs = lbls } -> + | ParsetreeViewer.NewTypes {attrs; locs = lbls} -> + Doc.group + (Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; + Doc.text "type "; + Doc.join ~sep:Doc.space + (List.map + (fun lbl -> + printComments + (printIdentLike lbl.Asttypes.txt) + cmtTbl lbl.Asttypes.loc) + lbls); + ]) + | Parameter {attrs; lbl; defaultExpr; pat = pattern} -> + let isUncurried, attrs = ParsetreeViewer.processUncurriedAttribute attrs in + let uncurried = + if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil + in + let attrs = printAttributes ~customLayout attrs cmtTbl in + (* =defaultValue *) + let defaultExprDoc = + match defaultExpr with + | Some expr -> + Doc.concat + [Doc.text "="; printExpressionWithComments ~customLayout expr cmtTbl] + | None -> Doc.nil + in + (* ~from as hometown + * ~from -> punning *) + let labelWithPattern = + match (lbl, pattern) with + | Asttypes.Nolabel, pattern -> printPattern ~customLayout pattern cmtTbl + | ( (Asttypes.Labelled lbl | Optional lbl), + { + ppat_desc = Ppat_var stringLoc; + ppat_attributes = [] | [({Location.txt = "ns.namedArgLoc"}, _)]; + } ) + when lbl = stringLoc.txt -> + (* ~d *) + Doc.concat [Doc.text "~"; printIdentLike lbl] + | ( (Asttypes.Labelled lbl | Optional lbl), + { + ppat_desc = Ppat_constraint ({ppat_desc = Ppat_var {txt}}, typ); + ppat_attributes = [] | [({Location.txt = "ns.namedArgLoc"}, _)]; + } ) + when lbl = txt -> + (* ~d: e *) + Doc.concat + [ + Doc.text "~"; + printIdentLike lbl; + Doc.text ": "; + printTypExpr ~customLayout typ cmtTbl; + ] + | (Asttypes.Labelled lbl | Optional lbl), pattern -> + (* ~b as c *) + Doc.concat + [ + Doc.text "~"; + printIdentLike lbl; + Doc.text " as "; + printPattern ~customLayout pattern cmtTbl; + ] + in + let optionalLabelSuffix = + match (lbl, defaultExpr) with + | Asttypes.Optional _, None -> Doc.text "=?" + | _ -> Doc.nil + in + let doc = Doc.group (Doc.concat [ - printAttributes ~customLayout attrs cmtTbl; - Doc.text "type "; - Doc.join ~sep:Doc.space - (List.map - (fun lbl -> - printComments - (printIdentLike lbl.Asttypes.txt) - cmtTbl lbl.Asttypes.loc) - lbls); + uncurried; + attrs; + labelWithPattern; + defaultExprDoc; + optionalLabelSuffix; ]) - | Parameter { attrs; lbl; defaultExpr; pat = pattern } -> - let isUncurried, attrs = - ParsetreeViewer.processUncurriedAttribute attrs - in - let uncurried = - if isUncurried then Doc.concat [ Doc.dot; Doc.space ] else Doc.nil - in - let attrs = printAttributes ~customLayout attrs cmtTbl in - (* =defaultValue *) - let defaultExprDoc = - match defaultExpr with - | Some expr -> - Doc.concat - [ - Doc.text "="; - printExpressionWithComments ~customLayout expr cmtTbl; - ] - | None -> Doc.nil - in - (* ~from as hometown - * ~from -> punning *) - let labelWithPattern = - match (lbl, pattern) with - | Asttypes.Nolabel, pattern -> printPattern ~customLayout pattern cmtTbl - | ( (Asttypes.Labelled lbl | Optional lbl), - { - ppat_desc = Ppat_var stringLoc; - ppat_attributes = - [] | [ ({ Location.txt = "ns.namedArgLoc" }, _) ]; - } ) - when lbl = stringLoc.txt -> - (* ~d *) - Doc.concat [ Doc.text "~"; printIdentLike lbl ] - | ( (Asttypes.Labelled lbl | Optional lbl), - { - ppat_desc = Ppat_constraint ({ ppat_desc = Ppat_var { txt } }, typ); - ppat_attributes = - [] | [ ({ Location.txt = "ns.namedArgLoc" }, _) ]; - } ) - when lbl = txt -> - (* ~d: e *) - Doc.concat - [ - Doc.text "~"; - printIdentLike lbl; - Doc.text ": "; - printTypExpr ~customLayout typ cmtTbl; - ] - | (Asttypes.Labelled lbl | Optional lbl), pattern -> - (* ~b as c *) - Doc.concat - [ - Doc.text "~"; - printIdentLike lbl; - Doc.text " as "; - printPattern ~customLayout pattern cmtTbl; - ] - in - let optionalLabelSuffix = - match (lbl, defaultExpr) with - | Asttypes.Optional _, None -> Doc.text "=?" - | _ -> Doc.nil - in - let doc = - Doc.group - (Doc.concat - [ - uncurried; - attrs; - labelWithPattern; - defaultExprDoc; - optionalLabelSuffix; - ]) - in - let cmtLoc = - match defaultExpr with - | None -> ( - match pattern.ppat_attributes with - | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _ -> - { loc with loc_end = pattern.ppat_loc.loc_end } - | _ -> pattern.ppat_loc) - | Some expr -> - let startPos = - match pattern.ppat_attributes with - | ({ Location.txt = "ns.namedArgLoc"; loc }, _) :: _ -> - loc.loc_start - | _ -> pattern.ppat_loc.loc_start - in - { - pattern.ppat_loc with - loc_start = startPos; - loc_end = expr.pexp_loc.loc_end; - } - in - printComments doc cmtTbl cmtLoc + in + let cmtLoc = + match defaultExpr with + | None -> ( + match pattern.ppat_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> + {loc with loc_end = pattern.ppat_loc.loc_end} + | _ -> pattern.ppat_loc) + | Some expr -> + let startPos = + match pattern.ppat_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> loc.loc_start + | _ -> pattern.ppat_loc.loc_start + in + { + pattern.ppat_loc with + loc_start = startPos; + loc_end = expr.pexp_loc.loc_end; + } + in + printComments doc cmtTbl cmtLoc and printExpressionBlock ~customLayout ~braces expr cmtTbl = let rec collectRows acc expr = match expr.Parsetree.pexp_desc with | Parsetree.Pexp_letmodule (modName, modExpr, expr2) -> - let name = - let doc = Doc.text modName.txt in - printComments doc cmtTbl modName.loc - in - let letModuleDoc = - Doc.concat - [ - Doc.text "module "; - name; - Doc.text " = "; - printModExpr ~customLayout modExpr cmtTbl; - ] - in - let loc = { expr.pexp_loc with loc_end = modExpr.pmod_loc.loc_end } in - collectRows ((loc, letModuleDoc) :: acc) expr2 + let name = + let doc = Doc.text modName.txt in + printComments doc cmtTbl modName.loc + in + let letModuleDoc = + Doc.concat + [ + Doc.text "module "; + name; + Doc.text " = "; + printModExpr ~customLayout modExpr cmtTbl; + ] + in + let loc = {expr.pexp_loc with loc_end = modExpr.pmod_loc.loc_end} in + collectRows ((loc, letModuleDoc) :: acc) expr2 | Pexp_letexception (extensionConstructor, expr2) -> + let loc = let loc = - let loc = - { - expr.pexp_loc with - loc_end = extensionConstructor.pext_loc.loc_end; - } - in - match getFirstLeadingComment cmtTbl loc with - | None -> loc - | Some comment -> - let cmtLoc = Comment.loc comment in - { cmtLoc with loc_end = loc.loc_end } - in - let letExceptionDoc = - printExceptionDef ~customLayout extensionConstructor cmtTbl + {expr.pexp_loc with loc_end = extensionConstructor.pext_loc.loc_end} in - collectRows ((loc, letExceptionDoc) :: acc) expr2 + match getFirstLeadingComment cmtTbl loc with + | None -> loc + | Some comment -> + let cmtLoc = Comment.loc comment in + {cmtLoc with loc_end = loc.loc_end} + in + let letExceptionDoc = + printExceptionDef ~customLayout extensionConstructor cmtTbl + in + collectRows ((loc, letExceptionDoc) :: acc) expr2 | Pexp_open (overrideFlag, longidentLoc, expr2) -> - let openDoc = - Doc.concat - [ - Doc.text "open"; - printOverrideFlag overrideFlag; - Doc.space; - printLongidentLocation longidentLoc cmtTbl; - ] - in - let loc = { expr.pexp_loc with loc_end = longidentLoc.loc.loc_end } in - collectRows ((loc, openDoc) :: acc) expr2 + let openDoc = + Doc.concat + [ + Doc.text "open"; + printOverrideFlag overrideFlag; + Doc.space; + printLongidentLocation longidentLoc cmtTbl; + ] + in + let loc = {expr.pexp_loc with loc_end = longidentLoc.loc.loc_end} in + collectRows ((loc, openDoc) :: acc) expr2 | Pexp_sequence (expr1, expr2) -> - let exprDoc = - let doc = printExpression ~customLayout expr1 cmtTbl in - match Parens.expr expr1 with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr1 braces - | Nothing -> doc - in - let loc = expr1.pexp_loc in - collectRows ((loc, exprDoc) :: acc) expr2 + let exprDoc = + let doc = printExpression ~customLayout expr1 cmtTbl in + match Parens.expr expr1 with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr1 braces + | Nothing -> doc + in + let loc = expr1.pexp_loc in + collectRows ((loc, exprDoc) :: acc) expr2 | Pexp_let (recFlag, valueBindings, expr2) -> ( + let loc = let loc = - let loc = - match (valueBindings, List.rev valueBindings) with - | vb :: _, lastVb :: _ -> - { vb.pvb_loc with loc_end = lastVb.pvb_loc.loc_end } - | _ -> Location.none - in - match getFirstLeadingComment cmtTbl loc with - | None -> loc - | Some comment -> - let cmtLoc = Comment.loc comment in - { cmtLoc with loc_end = loc.loc_end } - in - let recFlag = - match recFlag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - let letDoc = - printValueBindings ~customLayout ~recFlag valueBindings cmtTbl + match (valueBindings, List.rev valueBindings) with + | vb :: _, lastVb :: _ -> + {vb.pvb_loc with loc_end = lastVb.pvb_loc.loc_end} + | _ -> Location.none in - (* let () = { - * let () = foo() - * () - * } - * We don't need to print the () on the last line of the block - *) - match expr2.pexp_desc with - | Pexp_construct ({ txt = Longident.Lident "()" }, _) -> - List.rev ((loc, letDoc) :: acc) - | _ -> collectRows ((loc, letDoc) :: acc) expr2) + match getFirstLeadingComment cmtTbl loc with + | None -> loc + | Some comment -> + let cmtLoc = Comment.loc comment in + {cmtLoc with loc_end = loc.loc_end} + in + let recFlag = + match recFlag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + let letDoc = + printValueBindings ~customLayout ~recFlag valueBindings cmtTbl + in + (* let () = { + * let () = foo() + * () + * } + * We don't need to print the () on the last line of the block + *) + match expr2.pexp_desc with + | Pexp_construct ({txt = Longident.Lident "()"}, _) -> + List.rev ((loc, letDoc) :: acc) + | _ -> collectRows ((loc, letDoc) :: acc) expr2) | _ -> - let exprDoc = - let doc = printExpression ~customLayout expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - List.rev ((expr.pexp_loc, exprDoc) :: acc) + let exprDoc = + let doc = printExpression ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + List.rev ((expr.pexp_loc, exprDoc) :: acc) in let rows = collectRows [] expr in let block = @@ -234304,7 +234181,7 @@ and printExpressionBlock ~customLayout ~braces expr cmtTbl = Doc.concat [ Doc.lbrace; - Doc.indent (Doc.concat [ Doc.line; block ]); + Doc.indent (Doc.concat [Doc.line; block]); Doc.line; Doc.rbrace; ] @@ -234335,25 +234212,27 @@ and printBraces doc expr bracesLoc = match expr.Parsetree.pexp_desc with | Pexp_letmodule _ | Pexp_letexception _ | Pexp_let _ | Pexp_open _ | Pexp_sequence _ -> - (* already has braces *) - doc + (* already has braces *) + doc | _ -> - Doc.breakableGroup ~forceBreak:overMultipleLines - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - (if Parens.bracedExpr expr then addParens doc else doc); - ]); - Doc.softLine; - Doc.rbrace; - ]) + Doc.breakableGroup ~forceBreak:overMultipleLines + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.softLine; + (if Parens.bracedExpr expr then addParens doc else doc); + ]); + Doc.softLine; + Doc.rbrace; + ]) and printOverrideFlag overrideFlag = - match overrideFlag with Asttypes.Override -> Doc.text "!" | Fresh -> Doc.nil + match overrideFlag with + | Asttypes.Override -> Doc.text "!" + | Fresh -> Doc.nil and printDirectionFlag flag = match flag with @@ -234361,41 +234240,39 @@ and printDirectionFlag flag = | Asttypes.Upto -> Doc.text " to " and printExpressionRecordRow ~customLayout (lbl, expr) cmtTbl punningAllowed = - let cmtLoc = { lbl.loc with loc_end = expr.pexp_loc.loc_end } in + let cmtLoc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in let doc = Doc.group (match expr.pexp_desc with - | Pexp_ident { txt = Lident key; loc = _keyLoc } + | Pexp_ident {txt = Lident key; loc = _keyLoc} when punningAllowed && Longident.last lbl.txt = key -> - (* print punned field *) - Doc.concat - [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; - printOptionalLabel expr.pexp_attributes; - printLidentPath lbl cmtTbl; - ] + (* print punned field *) + Doc.concat + [ + printAttributes ~customLayout expr.pexp_attributes cmtTbl; + printOptionalLabel expr.pexp_attributes; + printLidentPath lbl cmtTbl; + ] | _ -> - Doc.concat - [ - printLidentPath lbl cmtTbl; - Doc.text ": "; - printOptionalLabel expr.pexp_attributes; - (let doc = - printExpressionWithComments ~customLayout expr cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); - ]) + Doc.concat + [ + printLidentPath lbl cmtTbl; + Doc.text ": "; + printOptionalLabel expr.pexp_attributes; + (let doc = printExpressionWithComments ~customLayout expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + ]) in printComments doc cmtTbl cmtLoc and printBsObjectRow ~customLayout (lbl, expr) cmtTbl = - let cmtLoc = { lbl.loc with loc_end = expr.pexp_loc.loc_end } in + let cmtLoc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in let lblDoc = let doc = - Doc.concat [ Doc.text "\""; printLongident lbl.txt; Doc.text "\"" ] + Doc.concat [Doc.text "\""; printLongident lbl.txt; Doc.text "\""] in printComments doc cmtTbl lbl.loc in @@ -234424,80 +234301,46 @@ and printAttributes ?loc ?(inline = false) ~customLayout match ParsetreeViewer.filterParsingAttrs attrs with | [] -> Doc.nil | attrs -> - let lineBreak = - match loc with - | None -> Doc.line - | Some loc -> ( - match List.rev attrs with - | ({ loc = firstLoc }, _) :: _ - when loc.loc_start.pos_lnum > firstLoc.loc_end.pos_lnum -> - Doc.hardLine - | _ -> Doc.line) - in - Doc.concat - [ - Doc.group - (Doc.joinWithSep - (List.map - (fun attr -> printAttribute ~customLayout attr cmtTbl) - attrs)); - (if inline then Doc.space else lineBreak); - ] + let lineBreak = + match loc with + | None -> Doc.line + | Some loc -> ( + match List.rev attrs with + | ({loc = firstLoc}, _) :: _ + when loc.loc_start.pos_lnum > firstLoc.loc_end.pos_lnum -> + Doc.hardLine + | _ -> Doc.line) + in + Doc.concat + [ + Doc.group + (Doc.joinWithSep + (List.map + (fun attr -> printAttribute ~customLayout attr cmtTbl) + attrs)); + (if inline then Doc.space else lineBreak); + ] and printPayload ~customLayout (payload : Parsetree.payload) cmtTbl = match payload with | PStr [] -> Doc.nil - | PStr [ { pstr_desc = Pstr_eval (expr, attrs) } ] -> - let exprDoc = printExpressionWithComments ~customLayout expr cmtTbl in - let needsParens = match attrs with [] -> false | _ -> true in - let shouldHug = ParsetreeViewer.isHuggableExpression expr in - if shouldHug then - Doc.concat - [ - Doc.lparen; - printAttributes ~customLayout attrs cmtTbl; - (if needsParens then addParens exprDoc else exprDoc); - Doc.rparen; - ] - else - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - printAttributes ~customLayout attrs cmtTbl; - (if needsParens then addParens exprDoc else exprDoc); - ]); - Doc.softLine; - Doc.rparen; - ] - | PStr [ ({ pstr_desc = Pstr_value (_recFlag, _bindings) } as si) ] -> - addParens (printStructureItem ~customLayout si cmtTbl) - | PStr structure -> addParens (printStructure ~customLayout structure cmtTbl) - | PTyp typ -> + | PStr [{pstr_desc = Pstr_eval (expr, attrs)}] -> + let exprDoc = printExpressionWithComments ~customLayout expr cmtTbl in + let needsParens = + match attrs with + | [] -> false + | _ -> true + in + let shouldHug = ParsetreeViewer.isHuggableExpression expr in + if shouldHug then Doc.concat [ Doc.lparen; - Doc.text ":"; - Doc.indent - (Doc.concat [ Doc.line; printTypExpr ~customLayout typ cmtTbl ]); - Doc.softLine; + printAttributes ~customLayout attrs cmtTbl; + (if needsParens then addParens exprDoc else exprDoc); Doc.rparen; ] - | PPat (pat, optExpr) -> - let whenDoc = - match optExpr with - | Some expr -> - Doc.concat - [ - Doc.line; - Doc.text "if "; - printExpressionWithComments ~customLayout expr cmtTbl; - ] - | None -> Doc.nil - in + else Doc.concat [ Doc.lparen; @@ -234505,193 +234348,217 @@ and printPayload ~customLayout (payload : Parsetree.payload) cmtTbl = (Doc.concat [ Doc.softLine; - Doc.text "? "; - printPattern ~customLayout pat cmtTbl; - whenDoc; + printAttributes ~customLayout attrs cmtTbl; + (if needsParens then addParens exprDoc else exprDoc); ]); Doc.softLine; Doc.rparen; ] + | PStr [({pstr_desc = Pstr_value (_recFlag, _bindings)} as si)] -> + addParens (printStructureItem ~customLayout si cmtTbl) + | PStr structure -> addParens (printStructure ~customLayout structure cmtTbl) + | PTyp typ -> + Doc.concat + [ + Doc.lparen; + Doc.text ":"; + Doc.indent + (Doc.concat [Doc.line; printTypExpr ~customLayout typ cmtTbl]); + Doc.softLine; + Doc.rparen; + ] + | PPat (pat, optExpr) -> + let whenDoc = + match optExpr with + | Some expr -> + Doc.concat + [ + Doc.line; + Doc.text "if "; + printExpressionWithComments ~customLayout expr cmtTbl; + ] + | None -> Doc.nil + in + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.text "? "; + printPattern ~customLayout pat cmtTbl; + whenDoc; + ]); + Doc.softLine; + Doc.rparen; + ] | PSig signature -> - Doc.concat - [ - Doc.lparen; - Doc.text ":"; - Doc.indent - (Doc.concat - [ Doc.line; printSignature ~customLayout signature cmtTbl ]); - Doc.softLine; - Doc.rparen; - ] + Doc.concat + [ + Doc.lparen; + Doc.text ":"; + Doc.indent + (Doc.concat [Doc.line; printSignature ~customLayout signature cmtTbl]); + Doc.softLine; + Doc.rparen; + ] and printAttribute ?(standalone = false) ~customLayout ((id, payload) : Parsetree.attribute) cmtTbl = match (id, payload) with - | ( { txt = "ns.doc" }, + | ( {txt = "ns.doc"}, PStr [ { pstr_desc = - Pstr_eval - ({ pexp_desc = Pexp_constant (Pconst_string (txt, _)) }, _); + Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (txt, _))}, _); }; ] ) -> - ( Doc.concat - [ - Doc.text (if standalone then "/***" else "/**"); - Doc.text txt; - Doc.text "*/"; - ], - Doc.hardLine ) + ( Doc.concat + [ + Doc.text (if standalone then "/***" else "/**"); + Doc.text txt; + Doc.text "*/"; + ], + Doc.hardLine ) | _ -> - ( Doc.group - (Doc.concat - [ - Doc.text (if standalone then "@@" else "@"); - Doc.text (convertBsExternalAttribute id.txt); - printPayload ~customLayout payload cmtTbl; - ]), - Doc.line ) + ( Doc.group + (Doc.concat + [ + Doc.text (if standalone then "@@" else "@"); + Doc.text (convertBsExternalAttribute id.txt); + printPayload ~customLayout payload cmtTbl; + ]), + Doc.line ) and printModExpr ~customLayout modExpr cmtTbl = let doc = match modExpr.pmod_desc with | Pmod_ident longidentLoc -> printLongidentLocation longidentLoc cmtTbl | Pmod_structure [] -> - let shouldBreak = - modExpr.pmod_loc.loc_start.pos_lnum - < modExpr.pmod_loc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak:shouldBreak - (Doc.concat - [ - Doc.lbrace; - printCommentsInside cmtTbl modExpr.pmod_loc; - Doc.rbrace; - ]) + let shouldBreak = + modExpr.pmod_loc.loc_start.pos_lnum < modExpr.pmod_loc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak:shouldBreak + (Doc.concat + [Doc.lbrace; printCommentsInside cmtTbl modExpr.pmod_loc; Doc.rbrace]) | Pmod_structure structure -> - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - printStructure ~customLayout structure cmtTbl; - ]); - Doc.softLine; - Doc.rbrace; - ]) + Doc.breakableGroup ~forceBreak:true + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [Doc.softLine; printStructure ~customLayout structure cmtTbl]); + Doc.softLine; + Doc.rbrace; + ]) | Pmod_unpack expr -> - let shouldHug = - match expr.pexp_desc with - | Pexp_let _ -> true - | Pexp_constraint - ( { pexp_desc = Pexp_let _ }, - { ptyp_desc = Ptyp_package _packageType } ) -> - true - | _ -> false - in - let expr, moduleConstraint = - match expr.pexp_desc with - | Pexp_constraint - (expr, { ptyp_desc = Ptyp_package packageType; ptyp_loc }) -> - let packageDoc = - let doc = - printPackageType ~customLayout - ~printModuleKeywordAndParens:false packageType cmtTbl - in - printComments doc cmtTbl ptyp_loc - in - let typeDoc = - Doc.group - (Doc.concat - [ - Doc.text ":"; - Doc.indent (Doc.concat [ Doc.line; packageDoc ]); - ]) - in - (expr, typeDoc) - | _ -> (expr, Doc.nil) - in - let unpackDoc = - Doc.group - (Doc.concat - [ - printExpressionWithComments ~customLayout expr cmtTbl; - moduleConstraint; - ]) - in + let shouldHug = + match expr.pexp_desc with + | Pexp_let _ -> true + | Pexp_constraint + ({pexp_desc = Pexp_let _}, {ptyp_desc = Ptyp_package _packageType}) + -> + true + | _ -> false + in + let expr, moduleConstraint = + match expr.pexp_desc with + | Pexp_constraint + (expr, {ptyp_desc = Ptyp_package packageType; ptyp_loc}) -> + let packageDoc = + let doc = + printPackageType ~customLayout ~printModuleKeywordAndParens:false + packageType cmtTbl + in + printComments doc cmtTbl ptyp_loc + in + let typeDoc = + Doc.group + (Doc.concat + [Doc.text ":"; Doc.indent (Doc.concat [Doc.line; packageDoc])]) + in + (expr, typeDoc) + | _ -> (expr, Doc.nil) + in + let unpackDoc = Doc.group (Doc.concat [ - Doc.text "unpack("; - (if shouldHug then unpackDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [ Doc.softLine; unpackDoc ]); - Doc.softLine; - ]); - Doc.rparen; + printExpressionWithComments ~customLayout expr cmtTbl; + moduleConstraint; ]) + in + Doc.group + (Doc.concat + [ + Doc.text "unpack("; + (if shouldHug then unpackDoc + else + Doc.concat + [ + Doc.indent (Doc.concat [Doc.softLine; unpackDoc]); + Doc.softLine; + ]); + Doc.rparen; + ]) | Pmod_extension extension -> - printExtension ~customLayout ~atModuleLvl:false extension cmtTbl + printExtension ~customLayout ~atModuleLvl:false extension cmtTbl | Pmod_apply _ -> - let args, callExpr = ParsetreeViewer.modExprApply modExpr in - let isUnitSugar = - match args with - | [ { pmod_desc = Pmod_structure [] } ] -> true - | _ -> false - in - let shouldHug = - match args with - | [ { pmod_desc = Pmod_structure _ } ] -> true - | _ -> false - in - Doc.group - (Doc.concat - [ - printModExpr ~customLayout callExpr cmtTbl; - (if isUnitSugar then - printModApplyArg ~customLayout - (List.hd args [@doesNotRaise]) - cmtTbl - else - Doc.concat - [ - Doc.lparen; - (if shouldHug then - printModApplyArg ~customLayout - (List.hd args [@doesNotRaise]) - cmtTbl - else - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun modArg -> - printModApplyArg ~customLayout modArg - cmtTbl) - args); - ])); - (if not shouldHug then - Doc.concat [ Doc.trailingComma; Doc.softLine ] - else Doc.nil); - Doc.rparen; - ]); - ]) + let args, callExpr = ParsetreeViewer.modExprApply modExpr in + let isUnitSugar = + match args with + | [{pmod_desc = Pmod_structure []}] -> true + | _ -> false + in + let shouldHug = + match args with + | [{pmod_desc = Pmod_structure _}] -> true + | _ -> false + in + Doc.group + (Doc.concat + [ + printModExpr ~customLayout callExpr cmtTbl; + (if isUnitSugar then + printModApplyArg ~customLayout + (List.hd args [@doesNotRaise]) + cmtTbl + else + Doc.concat + [ + Doc.lparen; + (if shouldHug then + printModApplyArg ~customLayout + (List.hd args [@doesNotRaise]) + cmtTbl + else + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun modArg -> + printModApplyArg ~customLayout modArg cmtTbl) + args); + ])); + (if not shouldHug then + Doc.concat [Doc.trailingComma; Doc.softLine] + else Doc.nil); + Doc.rparen; + ]); + ]) | Pmod_constraint (modExpr, modType) -> - Doc.concat - [ - printModExpr ~customLayout modExpr cmtTbl; - Doc.text ": "; - printModType ~customLayout modType cmtTbl; - ] + Doc.concat + [ + printModExpr ~customLayout modExpr cmtTbl; + Doc.text ": "; + printModType ~customLayout modType cmtTbl; + ] | Pmod_functor _ -> printModFunctor ~customLayout modExpr cmtTbl in printComments doc cmtTbl modExpr.pmod_loc @@ -234706,52 +234573,51 @@ and printModFunctor ~customLayout modExpr cmtTbl = let returnConstraint, returnModExpr = match returnModExpr.pmod_desc with | Pmod_constraint (modExpr, modType) -> - let constraintDoc = - let doc = printModType ~customLayout modType cmtTbl in - if Parens.modExprFunctorConstraint modType then addParens doc else doc - in - let modConstraint = Doc.concat [ Doc.text ": "; constraintDoc ] in - (modConstraint, printModExpr ~customLayout modExpr cmtTbl) + let constraintDoc = + let doc = printModType ~customLayout modType cmtTbl in + if Parens.modExprFunctorConstraint modType then addParens doc else doc + in + let modConstraint = Doc.concat [Doc.text ": "; constraintDoc] in + (modConstraint, printModExpr ~customLayout modExpr cmtTbl) | _ -> (Doc.nil, printModExpr ~customLayout returnModExpr cmtTbl) in let parametersDoc = match parameters with - | [ (attrs, { txt = "*" }, None) ] -> - Doc.group - (Doc.concat - [ printAttributes ~customLayout attrs cmtTbl; Doc.text "()" ]) - | [ ([], { txt = lbl }, None) ] -> Doc.text lbl + | [(attrs, {txt = "*"}, None)] -> + Doc.group + (Doc.concat [printAttributes ~customLayout attrs cmtTbl; Doc.text "()"]) + | [([], {txt = lbl}, None)] -> Doc.text lbl | parameters -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [ Doc.comma; Doc.line ]) - (List.map - (fun param -> - printModFunctorParam ~customLayout param cmtTbl) - parameters); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun param -> + printModFunctorParam ~customLayout param cmtTbl) + parameters); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) in Doc.group (Doc.concat - [ parametersDoc; returnConstraint; Doc.text " => "; returnModExpr ]) + [parametersDoc; returnConstraint; Doc.text " => "; returnModExpr]) and printModFunctorParam ~customLayout (attrs, lbl, optModType) cmtTbl = let cmtLoc = match optModType with | None -> lbl.Asttypes.loc | Some modType -> - { lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end } + {lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end} in let attrs = printAttributes ~customLayout attrs cmtTbl in let lblDoc = @@ -234767,8 +234633,8 @@ and printModFunctorParam ~customLayout (attrs, lbl, optModType) cmtTbl = (match optModType with | None -> Doc.nil | Some modType -> - Doc.concat - [ Doc.text ": "; printModType ~customLayout modType cmtTbl ]); + Doc.concat + [Doc.text ": "; printModType ~customLayout modType cmtTbl]); ]) in printComments doc cmtTbl cmtLoc @@ -234783,25 +234649,22 @@ and printExceptionDef ~customLayout (constr : Parsetree.extension_constructor) let kind = match constr.pext_kind with | Pext_rebind longident -> - Doc.indent - (Doc.concat - [ - Doc.text " ="; Doc.line; printLongidentLocation longident cmtTbl; - ]) + Doc.indent + (Doc.concat + [Doc.text " ="; Doc.line; printLongidentLocation longident cmtTbl]) | Pext_decl (Pcstr_tuple [], None) -> Doc.nil | Pext_decl (args, gadt) -> - let gadtDoc = - match gadt with - | Some typ -> - Doc.concat - [ Doc.text ": "; printTypExpr ~customLayout typ cmtTbl ] - | None -> Doc.nil - in - Doc.concat - [ - printConstructorArguments ~customLayout ~indent:false args cmtTbl; - gadtDoc; - ] + let gadtDoc = + match gadt with + | Some typ -> + Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ cmtTbl] + | None -> Doc.nil + in + Doc.concat + [ + printConstructorArguments ~customLayout ~indent:false args cmtTbl; + gadtDoc; + ] in let name = printComments (Doc.text constr.pext_name.txt) cmtTbl constr.pext_name.loc @@ -234827,30 +234690,27 @@ and printExtensionConstructor ~customLayout let kind = match constr.pext_kind with | Pext_rebind longident -> - Doc.indent - (Doc.concat - [ - Doc.text " ="; Doc.line; printLongidentLocation longident cmtTbl; - ]) + Doc.indent + (Doc.concat + [Doc.text " ="; Doc.line; printLongidentLocation longident cmtTbl]) | Pext_decl (Pcstr_tuple [], None) -> Doc.nil | Pext_decl (args, gadt) -> - let gadtDoc = - match gadt with - | Some typ -> - Doc.concat - [ Doc.text ": "; printTypExpr ~customLayout typ cmtTbl ] - | None -> Doc.nil - in - Doc.concat - [ - printConstructorArguments ~customLayout ~indent:false args cmtTbl; - gadtDoc; - ] + let gadtDoc = + match gadt with + | Some typ -> + Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ cmtTbl] + | None -> Doc.nil + in + Doc.concat + [ + printConstructorArguments ~customLayout ~indent:false args cmtTbl; + gadtDoc; + ] in let name = printComments (Doc.text constr.pext_name.txt) cmtTbl constr.pext_name.loc in - Doc.concat [ bar; Doc.group (Doc.concat [ attrs; name; kind ]) ] + Doc.concat [bar; Doc.group (Doc.concat [attrs; name; kind])] let printTypeParams = printTypeParams ~customLayout:0 let printTypExpr = printTypExpr ~customLayout:0 @@ -295787,25 +295647,25 @@ type mode = Jsx | Diamond will also contain the special -1 value to indicate end-of-file. This isn't ideal; we should clean this up *) let hackyEOFChar = Char.unsafe_chr (-1) - type charEncoding = Char.t type t = { - filename : string; - src : string; - mutable err : + filename: string; + src: string; + mutable err: startPos:Lexing.position -> endPos:Lexing.position -> Diagnostics.category -> unit; - mutable ch : charEncoding; (* current character *) - mutable offset : int; (* character offset *) - mutable lineOffset : int; (* current line offset *) - mutable lnum : int; (* current line number *) - mutable mode : mode list; + mutable ch: charEncoding; (* current character *) + mutable offset: int; (* character offset *) + mutable lineOffset: int; (* current line offset *) + mutable lnum: int; (* current line number *) + mutable mode: mode list; } let setDiamondMode scanner = scanner.mode <- Diamond :: scanner.mode + let setJsxMode scanner = scanner.mode <- Jsx :: scanner.mode let popMode scanner mode = @@ -295814,9 +295674,14 @@ let popMode scanner mode = | _ -> () let inDiamondMode scanner = - match scanner.mode with Diamond :: _ -> true | _ -> false + match scanner.mode with + | Diamond :: _ -> true + | _ -> false -let inJsxMode scanner = match scanner.mode with Jsx :: _ -> true | _ -> false +let inJsxMode scanner = + match scanner.mode with + | Jsx :: _ -> true + | _ -> false let position scanner = Lexing. @@ -295856,8 +295721,8 @@ let _printDebug ~startPos ~endPos scanner token = | 0 -> if token = Token.Eof then () else assert false | 1 -> () | n -> - print_string ((String.make [@doesNotRaise]) (n - 2) '-'); - print_char '^'); + print_string ((String.make [@doesNotRaise]) (n - 2) '-'); + print_char '^'); print_char ' '; print_string (Res_token.toString token); print_char ' '; @@ -295871,11 +295736,11 @@ let next scanner = let nextOffset = scanner.offset + 1 in (match scanner.ch with | '\n' -> - scanner.lineOffset <- nextOffset; - scanner.lnum <- scanner.lnum + 1 - (* What about CRLF (\r + \n) on windows? - * \r\n will always be terminated by a \n - * -> we can just bump the line count on \n *) + scanner.lineOffset <- nextOffset; + scanner.lnum <- scanner.lnum + 1 + (* What about CRLF (\r + \n) on windows? + * \r\n will always be terminated by a \n + * -> we can just bump the line count on \n *) | _ -> ()); if nextOffset < String.length scanner.src then ( scanner.offset <- nextOffset; @@ -295923,7 +295788,9 @@ let make ~filename src = (* generic helpers *) let isWhitespace ch = - match ch with ' ' | '\t' | '\n' | '\r' -> true | _ -> false + match ch with + | ' ' | '\t' | '\n' | '\r' -> true + | _ -> false let rec skipWhitespace scanner = if isWhitespace scanner.ch then ( @@ -295940,8 +295807,8 @@ let digitValue ch = let rec skipLowerCaseChars scanner = match scanner.ch with | 'a' .. 'z' -> - next scanner; - skipLowerCaseChars scanner + next scanner; + skipLowerCaseChars scanner | _ -> () (* scanning helpers *) @@ -295951,8 +295818,8 @@ let scanIdentifier scanner = let rec skipGoodChars scanner = match scanner.ch with | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' | '\'' -> - next scanner; - skipGoodChars scanner + next scanner; + skipGoodChars scanner | _ -> () in skipGoodChars scanner; @@ -295970,8 +295837,8 @@ let scanDigits scanner ~base = let rec loop scanner = match scanner.ch with | '0' .. '9' | '_' -> - next scanner; - loop scanner + next scanner; + loop scanner | _ -> () in loop scanner @@ -295980,8 +295847,8 @@ let scanDigits scanner ~base = match scanner.ch with (* hex *) | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_' -> - next scanner; - loop scanner + next scanner; + loop scanner | _ -> () in loop scanner @@ -295994,19 +295861,19 @@ let scanNumber scanner = let base = match scanner.ch with | '0' -> ( - match peek scanner with - | 'x' | 'X' -> - next2 scanner; - 16 - | 'o' | 'O' -> - next2 scanner; - 8 - | 'b' | 'B' -> - next2 scanner; - 2 - | _ -> - next scanner; - 8) + match peek scanner with + | 'x' | 'X' -> + next2 scanner; + 16 + | 'o' | 'O' -> + next2 scanner; + 8 + | 'b' | 'B' -> + next2 scanner; + 2 + | _ -> + next scanner; + 8) | _ -> 10 in scanDigits scanner ~base; @@ -296024,11 +295891,11 @@ let scanNumber scanner = let isFloat = match scanner.ch with | 'e' | 'E' | 'p' | 'P' -> - (match peek scanner with - | '+' | '-' -> next2 scanner - | _ -> next scanner); - scanDigits scanner ~base; - true + (match peek scanner with + | '+' | '-' -> next2 scanner + | _ -> next scanner); + scanDigits scanner ~base; + true | _ -> isFloat in let literal = @@ -296039,20 +295906,20 @@ let scanNumber scanner = let suffix = match scanner.ch with | 'n' -> - let msg = - "Unsupported number type (nativeint). Did you mean `" ^ literal ^ "`?" - in - let pos = position scanner in - scanner.err ~startPos:pos ~endPos:pos (Diagnostics.message msg); - next scanner; - Some 'n' + let msg = + "Unsupported number type (nativeint). Did you mean `" ^ literal ^ "`?" + in + let pos = position scanner in + scanner.err ~startPos:pos ~endPos:pos (Diagnostics.message msg); + next scanner; + Some 'n' | ('g' .. 'z' | 'G' .. 'Z') as ch -> - next scanner; - Some ch + next scanner; + Some ch | _ -> None in - if isFloat then Token.Float { f = literal; suffix } - else Token.Int { i = literal; suffix } + if isFloat then Token.Float {f = literal; suffix} + else Token.Int {i = literal; suffix} let scanExoticIdentifier scanner = (* TODO: are we disregarding the current char...? Should be a quote *) @@ -296064,19 +295931,19 @@ let scanExoticIdentifier scanner = match scanner.ch with | '"' -> next scanner | '\n' | '\r' -> - (* line break *) - let endPos = position scanner in - scanner.err ~startPos ~endPos - (Diagnostics.message "A quoted identifier can't contain line breaks."); - next scanner + (* line break *) + let endPos = position scanner in + scanner.err ~startPos ~endPos + (Diagnostics.message "A quoted identifier can't contain line breaks."); + next scanner | ch when ch == hackyEOFChar -> - let endPos = position scanner in - scanner.err ~startPos ~endPos - (Diagnostics.message "Did you forget a \" here?") + let endPos = position scanner in + scanner.err ~startPos ~endPos + (Diagnostics.message "Did you forget a \" here?") | ch -> - Buffer.add_char buffer ch; - next scanner; - scan () + Buffer.add_char buffer ch; + next scanner; + scan () in scan (); (* TODO: do we really need to create a new buffer instead of substring once? *) @@ -296112,35 +295979,37 @@ let scanStringEscapeSequence ~startPos scanner = | '0' when let c = peek scanner in c < '0' || c > '9' -> - (* Allow \0 *) - next scanner + (* Allow \0 *) + next scanner | '0' .. '9' -> scan ~n:3 ~base:10 ~max:255 | 'x' -> - (* hex *) - next scanner; - scan ~n:2 ~base:16 ~max:255 + (* hex *) + next scanner; + scan ~n:2 ~base:16 ~max:255 | 'u' -> ( + next scanner; + match scanner.ch with + | '{' -> ( + (* unicode code point escape sequence: '\u{7A}', one or more hex digits *) next scanner; + let x = ref 0 in + while + match scanner.ch with + | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true + | _ -> false + do + x := (!x * 16) + digitValue scanner.ch; + next scanner + done; + (* consume '}' in '\u{7A}' *) match scanner.ch with - | '{' -> ( - (* unicode code point escape sequence: '\u{7A}', one or more hex digits *) - next scanner; - let x = ref 0 in - while - match scanner.ch with - | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true - | _ -> false - do - x := (!x * 16) + digitValue scanner.ch; - next scanner - done; - (* consume '}' in '\u{7A}' *) - match scanner.ch with '}' -> next scanner | _ -> ()) - | _ -> scan ~n:4 ~base:16 ~max:Res_utf8.max) + | '}' -> next scanner + | _ -> ()) + | _ -> scan ~n:4 ~base:16 ~max:Res_utf8.max) | _ -> - (* unknown escape sequence - * TODO: we should warn the user here. Let's not make it a hard error for now, for reason compat *) - (* + (* unknown escape sequence + * TODO: we should warn the user here. Let's not make it a hard error for now, for reason compat *) + (* let pos = position scanner in let msg = if ch == -1 then "unclosed escape sequence" @@ -296148,7 +296017,7 @@ let scanStringEscapeSequence ~startPos scanner = in scanner.err ~startPos ~endPos:pos (Diagnostics.message msg) *) - () + () let scanString scanner = (* assumption: we've just matched a quote *) @@ -296181,28 +296050,30 @@ let scanString scanner = let rec scan () = match scanner.ch with | '"' -> - let lastCharOffset = scanner.offset in - next scanner; - result ~firstCharOffset ~lastCharOffset + let lastCharOffset = scanner.offset in + next scanner; + result ~firstCharOffset ~lastCharOffset | '\\' -> - let startPos = position scanner in - let startOffset = scanner.offset + 1 in - next scanner; - scanStringEscapeSequence ~startPos scanner; - let endOffset = scanner.offset in - convertOctalToHex ~startOffset ~endOffset + let startPos = position scanner in + let startOffset = scanner.offset + 1 in + next scanner; + scanStringEscapeSequence ~startPos scanner; + let endOffset = scanner.offset in + convertOctalToHex ~startOffset ~endOffset | ch when ch == hackyEOFChar -> - let endPos = position scanner in - scanner.err ~startPos:startPosWithQuote ~endPos - Diagnostics.unclosedString; - let lastCharOffset = scanner.offset in - result ~firstCharOffset ~lastCharOffset + let endPos = position scanner in + scanner.err ~startPos:startPosWithQuote ~endPos Diagnostics.unclosedString; + let lastCharOffset = scanner.offset in + result ~firstCharOffset ~lastCharOffset | _ -> - next scanner; - scan () + next scanner; + scan () and convertOctalToHex ~startOffset ~endOffset = let len = endOffset - startOffset in - let isDigit = function '0' .. '9' -> true | _ -> false in + let isDigit = function + | '0' .. '9' -> true + | _ -> false + in let txt = scanner.src in let isNumericEscape = len = 3 @@ -296238,48 +296109,50 @@ let scanEscape scanner = match scanner.ch with | '0' .. '9' -> convertNumber scanner ~n:3 ~base:10 | 'b' -> - next scanner; - 8 + next scanner; + 8 | 'n' -> - next scanner; - 10 + next scanner; + 10 | 'r' -> - next scanner; - 13 + next scanner; + 13 | 't' -> - next scanner; - 009 + next scanner; + 009 | 'x' -> - next scanner; - convertNumber scanner ~n:2 ~base:16 + next scanner; + convertNumber scanner ~n:2 ~base:16 | 'o' -> - next scanner; - convertNumber scanner ~n:3 ~base:8 + next scanner; + convertNumber scanner ~n:3 ~base:8 | 'u' -> ( + next scanner; + match scanner.ch with + | '{' -> + (* unicode code point escape sequence: '\u{7A}', one or more hex digits *) next scanner; - match scanner.ch with - | '{' -> - (* unicode code point escape sequence: '\u{7A}', one or more hex digits *) - next scanner; - let x = ref 0 in - while - match scanner.ch with - | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true - | _ -> false - do - x := (!x * 16) + digitValue scanner.ch; - next scanner - done; - (* consume '}' in '\u{7A}' *) - (match scanner.ch with '}' -> next scanner | _ -> ()); - let c = !x in - if Res_utf8.isValidCodePoint c then c else Res_utf8.repl - | _ -> - (* unicode escape sequence: '\u007A', exactly 4 hex digits *) - convertNumber scanner ~n:4 ~base:16) + let x = ref 0 in + while + match scanner.ch with + | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true + | _ -> false + do + x := (!x * 16) + digitValue scanner.ch; + next scanner + done; + (* consume '}' in '\u{7A}' *) + (match scanner.ch with + | '}' -> next scanner + | _ -> ()); + let c = !x in + if Res_utf8.isValidCodePoint c then c else Res_utf8.repl + | _ -> + (* unicode escape sequence: '\u007A', exactly 4 hex digits *) + convertNumber scanner ~n:4 ~base:16) | ch -> - next scanner; - Char.code ch + next scanner; + Char.code ch in let contents = (String.sub [@doesNotRaise]) scanner.src offset (scanner.offset - offset) @@ -296287,7 +296160,7 @@ let scanEscape scanner = next scanner; (* Consume \' *) (* TODO: do we know it's \' ? *) - Token.Codepoint { c = codepoint; original = contents } + Token.Codepoint {c = codepoint; original = contents} let scanSingleLineComment scanner = let startOff = scanner.offset in @@ -296297,15 +296170,14 @@ let scanSingleLineComment scanner = | '\n' | '\r' -> () | ch when ch == hackyEOFChar -> () | _ -> - next scanner; - skip scanner + next scanner; + skip scanner in skip scanner; let endPos = position scanner in Token.Comment (Comment.makeSingleLineComment - ~loc: - Location.{ loc_start = startPos; loc_end = endPos; loc_ghost = false } + ~loc:Location.{loc_start = startPos; loc_end = endPos; loc_ghost = false} ((String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - startOff))) @@ -296321,17 +296193,17 @@ let scanMultiLineComment scanner = (* invariant: depth > 0 right after this match. See assumption *) match (scanner.ch, peek scanner) with | '/', '*' -> - next2 scanner; - scan ~depth:(depth + 1) + next2 scanner; + scan ~depth:(depth + 1) | '*', '/' -> - next2 scanner; - if depth > 1 then scan ~depth:(depth - 1) + next2 scanner; + if depth > 1 then scan ~depth:(depth - 1) | ch, _ when ch == hackyEOFChar -> - let endPos = position scanner in - scanner.err ~startPos ~endPos Diagnostics.unclosedComment + let endPos = position scanner in + scanner.err ~startPos ~endPos Diagnostics.unclosedComment | _ -> - next scanner; - scan ~depth + next scanner; + scan ~depth in scan ~depth:0; let length = scanner.offset - 2 - contentStartOff in @@ -296340,11 +296212,7 @@ let scanMultiLineComment scanner = (Comment.makeMultiLineComment ~docComment ~standalone ~loc: Location. - { - loc_start = startPos; - loc_end = position scanner; - loc_ghost = false; - } + {loc_start = startPos; loc_end = position scanner; loc_ghost = false} ((String.sub [@doesNotRaise]) scanner.src contentStartOff length)) let scanTemplateLiteralToken scanner = @@ -296359,44 +296227,44 @@ let scanTemplateLiteralToken scanner = let lastPos = position scanner in match scanner.ch with | '`' -> - next scanner; - let contents = - (String.sub [@doesNotRaise]) scanner.src startOff - (scanner.offset - 1 - startOff) - in - Token.TemplateTail (contents, lastPos) + next scanner; + let contents = + (String.sub [@doesNotRaise]) scanner.src startOff + (scanner.offset - 1 - startOff) + in + Token.TemplateTail (contents, lastPos) | '$' -> ( - match peek scanner with - | '{' -> - next2 scanner; - let contents = - (String.sub [@doesNotRaise]) scanner.src startOff - (scanner.offset - 2 - startOff) - in - Token.TemplatePart (contents, lastPos) - | _ -> - next scanner; - scan ()) - | '\\' -> ( - match peek scanner with - | '`' | '\\' | '$' | '\n' | '\r' -> - (* line break *) - next2 scanner; - scan () - | _ -> - next scanner; - scan ()) - | ch when ch = hackyEOFChar -> - let endPos = position scanner in - scanner.err ~startPos ~endPos Diagnostics.unclosedTemplate; + match peek scanner with + | '{' -> + next2 scanner; let contents = (String.sub [@doesNotRaise]) scanner.src startOff - (max (scanner.offset - 1 - startOff) 0) + (scanner.offset - 2 - startOff) in - Token.TemplateTail (contents, lastPos) - | _ -> + Token.TemplatePart (contents, lastPos) + | _ -> next scanner; + scan ()) + | '\\' -> ( + match peek scanner with + | '`' | '\\' | '$' | '\n' | '\r' -> + (* line break *) + next2 scanner; scan () + | _ -> + next scanner; + scan ()) + | ch when ch = hackyEOFChar -> + let endPos = position scanner in + scanner.err ~startPos ~endPos Diagnostics.unclosedTemplate; + let contents = + (String.sub [@doesNotRaise]) scanner.src startOff + (max (scanner.offset - 1 - startOff) 0) + in + Token.TemplateTail (contents, lastPos) + | _ -> + next scanner; + scan () in let token = scan () in let endPos = position scanner in @@ -296412,273 +296280,273 @@ let rec scan scanner = | 'A' .. 'Z' | 'a' .. 'z' -> scanIdentifier scanner | '0' .. '9' -> scanNumber scanner | '`' -> - next scanner; - Token.Backtick + next scanner; + Token.Backtick | '~' -> - next scanner; - Token.Tilde + next scanner; + Token.Tilde | '?' -> - next scanner; - Token.Question + next scanner; + Token.Question | ';' -> - next scanner; - Token.Semicolon + next scanner; + Token.Semicolon | '(' -> - next scanner; - Token.Lparen + next scanner; + Token.Lparen | ')' -> - next scanner; - Token.Rparen + next scanner; + Token.Rparen | '[' -> - next scanner; - Token.Lbracket + next scanner; + Token.Lbracket | ']' -> - next scanner; - Token.Rbracket + next scanner; + Token.Rbracket | '{' -> - next scanner; - Token.Lbrace + next scanner; + Token.Lbrace | '}' -> - next scanner; - Token.Rbrace + next scanner; + Token.Rbrace | ',' -> - next scanner; - Token.Comma + next scanner; + Token.Comma | '"' -> scanString scanner (* peeking 1 char *) | '_' -> ( - match peek scanner with - | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' -> scanIdentifier scanner - | _ -> - next scanner; - Token.Underscore) + match peek scanner with + | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' -> scanIdentifier scanner + | _ -> + next scanner; + Token.Underscore) | '#' -> ( - match peek scanner with - | '=' -> - next2 scanner; - Token.HashEqual - | _ -> - next scanner; - Token.Hash) + match peek scanner with + | '=' -> + next2 scanner; + Token.HashEqual + | _ -> + next scanner; + Token.Hash) | '*' -> ( - match peek scanner with - | '*' -> - next2 scanner; - Token.Exponentiation - | '.' -> - next2 scanner; - Token.AsteriskDot - | _ -> - next scanner; - Token.Asterisk) + match peek scanner with + | '*' -> + next2 scanner; + Token.Exponentiation + | '.' -> + next2 scanner; + Token.AsteriskDot + | _ -> + next scanner; + Token.Asterisk) | '@' -> ( - match peek scanner with - | '@' -> - next2 scanner; - Token.AtAt - | _ -> - next scanner; - Token.At) + match peek scanner with + | '@' -> + next2 scanner; + Token.AtAt + | _ -> + next scanner; + Token.At) | '%' -> ( - match peek scanner with - | '%' -> - next2 scanner; - Token.PercentPercent - | _ -> - next scanner; - Token.Percent) + match peek scanner with + | '%' -> + next2 scanner; + Token.PercentPercent + | _ -> + next scanner; + Token.Percent) | '|' -> ( - match peek scanner with - | '|' -> - next2 scanner; - Token.Lor - | '>' -> - next2 scanner; - Token.BarGreater - | _ -> - next scanner; - Token.Bar) + match peek scanner with + | '|' -> + next2 scanner; + Token.Lor + | '>' -> + next2 scanner; + Token.BarGreater + | _ -> + next scanner; + Token.Bar) | '&' -> ( - match peek scanner with - | '&' -> - next2 scanner; - Token.Land - | _ -> - next scanner; - Token.Band) + match peek scanner with + | '&' -> + next2 scanner; + Token.Land + | _ -> + next scanner; + Token.Band) | ':' -> ( - match peek scanner with - | '=' -> - next2 scanner; - Token.ColonEqual - | '>' -> - next2 scanner; - Token.ColonGreaterThan - | _ -> - next scanner; - Token.Colon) - | '\\' -> + match peek scanner with + | '=' -> + next2 scanner; + Token.ColonEqual + | '>' -> + next2 scanner; + Token.ColonGreaterThan + | _ -> next scanner; - scanExoticIdentifier scanner + Token.Colon) + | '\\' -> + next scanner; + scanExoticIdentifier scanner | '/' -> ( - match peek scanner with - | '/' -> - next2 scanner; - scanSingleLineComment scanner - | '*' -> scanMultiLineComment scanner - | '.' -> - next2 scanner; - Token.ForwardslashDot - | _ -> - next scanner; - Token.Forwardslash) + match peek scanner with + | '/' -> + next2 scanner; + scanSingleLineComment scanner + | '*' -> scanMultiLineComment scanner + | '.' -> + next2 scanner; + Token.ForwardslashDot + | _ -> + next scanner; + Token.Forwardslash) | '-' -> ( - match peek scanner with - | '.' -> - next2 scanner; - Token.MinusDot - | '>' -> - next2 scanner; - Token.MinusGreater - | _ -> - next scanner; - Token.Minus) + match peek scanner with + | '.' -> + next2 scanner; + Token.MinusDot + | '>' -> + next2 scanner; + Token.MinusGreater + | _ -> + next scanner; + Token.Minus) | '+' -> ( - match peek scanner with - | '.' -> - next2 scanner; - Token.PlusDot - | '+' -> - next2 scanner; - Token.PlusPlus - | '=' -> - next2 scanner; - Token.PlusEqual - | _ -> - next scanner; - Token.Plus) + match peek scanner with + | '.' -> + next2 scanner; + Token.PlusDot + | '+' -> + next2 scanner; + Token.PlusPlus + | '=' -> + next2 scanner; + Token.PlusEqual + | _ -> + next scanner; + Token.Plus) | '>' -> ( - match peek scanner with - | '=' when not (inDiamondMode scanner) -> - next2 scanner; - Token.GreaterEqual - | _ -> - next scanner; - Token.GreaterThan) + match peek scanner with + | '=' when not (inDiamondMode scanner) -> + next2 scanner; + Token.GreaterEqual + | _ -> + next scanner; + Token.GreaterThan) | '<' when not (inJsxMode scanner) -> ( - match peek scanner with - | '=' -> - next2 scanner; - Token.LessEqual - | _ -> - next scanner; - Token.LessThan) + match peek scanner with + | '=' -> + next2 scanner; + Token.LessEqual + | _ -> + next scanner; + Token.LessThan) (* special handling for JSX < *) | '<' -> ( - (* Imagine the following:
< - * < indicates the start of a new jsx-element, the parser expects - * the name of a new element after the < - * Example:
- * This signals a closing element. To simulate the two-token lookahead, - * the < + * < indicates the start of a new jsx-element, the parser expects + * the name of a new element after the < + * Example:
+ * This signals a closing element. To simulate the two-token lookahead, + * the next scanner; - skipWhitespace scanner; - match scanner.ch with - | '/' -> - next scanner; - Token.LessThanSlash - | '=' -> - next scanner; - Token.LessEqual - | _ -> Token.LessThan) + Token.LessThanSlash + | '=' -> + next scanner; + Token.LessEqual + | _ -> Token.LessThan) (* peeking 2 chars *) | '.' -> ( - match (peek scanner, peek2 scanner) with - | '.', '.' -> - next3 scanner; - Token.DotDotDot - | '.', _ -> - next2 scanner; - Token.DotDot - | _ -> - next scanner; - Token.Dot) + match (peek scanner, peek2 scanner) with + | '.', '.' -> + next3 scanner; + Token.DotDotDot + | '.', _ -> + next2 scanner; + Token.DotDot + | _ -> + next scanner; + Token.Dot) | '\'' -> ( - match (peek scanner, peek2 scanner) with - | '\\', '"' -> - (* careful with this one! We're next-ing _once_ (not twice), - then relying on matching on the quote *) - next scanner; - SingleQuote - | '\\', _ -> - next2 scanner; - scanEscape scanner - | ch, '\'' -> - let offset = scanner.offset + 1 in - next3 scanner; - Token.Codepoint - { - c = Char.code ch; - original = (String.sub [@doesNotRaise]) scanner.src offset 1; - } - | ch, _ -> - next scanner; - let offset = scanner.offset in - let codepoint, length = - Res_utf8.decodeCodePoint scanner.offset scanner.src - (String.length scanner.src) - in - for _ = 0 to length - 1 do - next scanner - done; - if scanner.ch = '\'' then ( - let contents = - (String.sub [@doesNotRaise]) scanner.src offset length - in - next scanner; - Token.Codepoint { c = codepoint; original = contents }) - else ( - scanner.ch <- ch; - scanner.offset <- offset; - SingleQuote)) + match (peek scanner, peek2 scanner) with + | '\\', '"' -> + (* careful with this one! We're next-ing _once_ (not twice), + then relying on matching on the quote *) + next scanner; + SingleQuote + | '\\', _ -> + next2 scanner; + scanEscape scanner + | ch, '\'' -> + let offset = scanner.offset + 1 in + next3 scanner; + Token.Codepoint + { + c = Char.code ch; + original = (String.sub [@doesNotRaise]) scanner.src offset 1; + } + | ch, _ -> + next scanner; + let offset = scanner.offset in + let codepoint, length = + Res_utf8.decodeCodePoint scanner.offset scanner.src + (String.length scanner.src) + in + for _ = 0 to length - 1 do + next scanner + done; + if scanner.ch = '\'' then ( + let contents = + (String.sub [@doesNotRaise]) scanner.src offset length + in + next scanner; + Token.Codepoint {c = codepoint; original = contents}) + else ( + scanner.ch <- ch; + scanner.offset <- offset; + SingleQuote)) | '!' -> ( - match (peek scanner, peek2 scanner) with - | '=', '=' -> - next3 scanner; - Token.BangEqualEqual - | '=', _ -> - next2 scanner; - Token.BangEqual - | _ -> - next scanner; - Token.Bang) + match (peek scanner, peek2 scanner) with + | '=', '=' -> + next3 scanner; + Token.BangEqualEqual + | '=', _ -> + next2 scanner; + Token.BangEqual + | _ -> + next scanner; + Token.Bang) | '=' -> ( - match (peek scanner, peek2 scanner) with - | '=', '=' -> - next3 scanner; - Token.EqualEqualEqual - | '=', _ -> - next2 scanner; - Token.EqualEqual - | '>', _ -> - next2 scanner; - Token.EqualGreater - | _ -> - next scanner; - Token.Equal) + match (peek scanner, peek2 scanner) with + | '=', '=' -> + next3 scanner; + Token.EqualEqualEqual + | '=', _ -> + next2 scanner; + Token.EqualEqual + | '>', _ -> + next2 scanner; + Token.EqualGreater + | _ -> + next scanner; + Token.Equal) (* special cases *) | ch when ch == hackyEOFChar -> - next scanner; - Token.Eof + next scanner; + Token.Eof | ch -> - (* if we arrive here, we're dealing with an unknown character, - * report the error and continue scanning… *) - next scanner; - let endPos = position scanner in - scanner.err ~startPos ~endPos (Diagnostics.unknownUchar ch); - let _, _, token = scan scanner in - token + (* if we arrive here, we're dealing with an unknown character, + * report the error and continue scanning… *) + next scanner; + let endPos = position scanner in + scanner.err ~startPos ~endPos (Diagnostics.unknownUchar ch); + let _, _, token = scan scanner in + token in let endPos = position scanner in (* _printDebug ~startPos ~endPos scanner token; *) @@ -296722,36 +296590,36 @@ let tryAdvanceQuotedString scanner = let rec scanContents tag = match scanner.ch with | '|' -> ( - next scanner; - match scanner.ch with - | 'a' .. 'z' -> - let startOff = scanner.offset in - skipLowerCaseChars scanner; - let suffix = - (String.sub [@doesNotRaise]) scanner.src startOff - (scanner.offset - startOff) - in - if tag = suffix then - if scanner.ch = '}' then next scanner else scanContents tag - else scanContents tag - | '}' -> next scanner - | _ -> scanContents tag) + next scanner; + match scanner.ch with + | 'a' .. 'z' -> + let startOff = scanner.offset in + skipLowerCaseChars scanner; + let suffix = + (String.sub [@doesNotRaise]) scanner.src startOff + (scanner.offset - startOff) + in + if tag = suffix then + if scanner.ch = '}' then next scanner else scanContents tag + else scanContents tag + | '}' -> next scanner + | _ -> scanContents tag) | ch when ch == hackyEOFChar -> - (* TODO: why is this place checking EOF and not others? *) - () + (* TODO: why is this place checking EOF and not others? *) + () | _ -> - next scanner; - scanContents tag + next scanner; + scanContents tag in match scanner.ch with | 'a' .. 'z' -> - let startOff = scanner.offset in - skipLowerCaseChars scanner; - let tag = - (String.sub [@doesNotRaise]) scanner.src startOff - (scanner.offset - startOff) - in - if scanner.ch = '|' then scanContents tag + let startOff = scanner.offset in + skipLowerCaseChars scanner; + let tag = + (String.sub [@doesNotRaise]) scanner.src startOff + (scanner.offset - startOff) + in + if scanner.ch = '|' then scanContents tag | '|' -> scanContents "" | _ -> () From c0cd6649c3278690c726db533a5ac090580766b2 Mon Sep 17 00:00:00 2001 From: butterunderflow Date: Mon, 31 Oct 2022 10:42:47 +0800 Subject: [PATCH 15/15] changelog --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index f238068159..2c98672d38 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -56,6 +56,7 @@ - Add `loading`, `aria-*` DOM element attributes in `JsxDOM.domProps`: `ariaCurrent`, `ariaInvalid`, `ariaAutocomplete`, etc. - Change the internal representation of props for the lowercase components to record. https://github.com/rescript-lang/syntax/pull/665 +- Change the payload of Pconst_char for type safety. https://github.com/rescript-lang/syntax/pull/709 # 10.1.0-alpha.2