From 8278bf0fe7d2af6fd7ae2dd4cc2de3b46f012c84 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 24 Oct 2022 09:03:09 +0200 Subject: [PATCH 01/10] sync latest syntax (#5751) --- CHANGELOG.md | 2 + jscomp/napkin/CHANGELOG.md | 1 + lib/4.06.1/unstable/js_compiler.ml | 39 +++++++++---------- lib/4.06.1/unstable/js_playground_compiler.ml | 39 +++++++++---------- lib/4.06.1/whole_compiler.ml | 39 +++++++++---------- syntax | 2 +- 6 files changed, 58 insertions(+), 64 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index f238068159a..eb4e0cd223e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -12,6 +12,8 @@ # 10.1.0-rc.3 +- Fix issue where the JSX key type is not an optional string https://github.com/rescript-lang/syntax/pull/693 + # 10.1.0-rc.2 #### :bug: Bug Fix diff --git a/jscomp/napkin/CHANGELOG.md b/jscomp/napkin/CHANGELOG.md index 87a36ca1e40..5848015ded6 100644 --- a/jscomp/napkin/CHANGELOG.md +++ b/jscomp/napkin/CHANGELOG.md @@ -43,6 +43,7 @@ - Fix several printing issues with `async` including an infinite loop https://github.com/rescript-lang/syntax/pull/680 - Fix issue where certain JSX expressions would be formatted differenctly in compiler 10.1.0-rc.1 https://github.com/rescript-lang/syntax/issues/675 - Fix issue where printing nested pipe discards await https://github.com/rescript-lang/syntax/issues/687 +- Fix issue where the JSX key type is not an optional string https://github.com/rescript-lang/syntax/pull/693 #### :eyeglasses: Spec Compliance diff --git a/lib/4.06.1/unstable/js_compiler.ml b/lib/4.06.1/unstable/js_compiler.ml index 0e6879f6174..eab64f524cc 100644 --- a/lib/4.06.1/unstable/js_compiler.ml +++ b/lib/4.06.1/unstable/js_compiler.ml @@ -273011,6 +273011,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 @@ -273360,51 +273362,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 @@ -273470,25 +273467,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 diff --git a/lib/4.06.1/unstable/js_playground_compiler.ml b/lib/4.06.1/unstable/js_playground_compiler.ml index 314e28560a1..559685bd4b9 100644 --- a/lib/4.06.1/unstable/js_playground_compiler.ml +++ b/lib/4.06.1/unstable/js_playground_compiler.ml @@ -274474,6 +274474,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 @@ -274823,51 +274825,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 @@ -274933,25 +274930,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 diff --git a/lib/4.06.1/whole_compiler.ml b/lib/4.06.1/whole_compiler.ml index 396eb85143c..3bf85a12a69 100644 --- a/lib/4.06.1/whole_compiler.ml +++ b/lib/4.06.1/whole_compiler.ml @@ -284858,6 +284858,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 @@ -285207,51 +285209,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 @@ -285317,25 +285314,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 diff --git a/syntax b/syntax index d64839e3dea..e3aaffd5fcf 160000 --- a/syntax +++ b/syntax @@ -1 +1 @@ -Subproject commit d64839e3deae9ecb9a5507b18981292dc6e3ec9f +Subproject commit e3aaffd5fcf30abf0a7e9b5a856881950b845b70 From 2a543a9725fd20fbffdb2aeedd05dd66b8816e1a Mon Sep 17 00:00:00 2001 From: HongboZhang Date: Mon, 24 Oct 2022 10:31:42 +0800 Subject: [PATCH 02/10] attempt to fix #5557 #5743 --- jscomp/ml/parmatch.ml | 12 +++++++++--- jscomp/test/build.ninja | 3 ++- jscomp/test/gpr_5557.js | 12 ++++++++++++ jscomp/test/gpr_5557.res | 6 ++++++ 4 files changed, 29 insertions(+), 4 deletions(-) create mode 100644 jscomp/test/gpr_5557.js create mode 100644 jscomp/test/gpr_5557.res diff --git a/jscomp/ml/parmatch.ml b/jscomp/ml/parmatch.ml index ef5440c7ee8..47ca04ad0dc 100644 --- a/jscomp/ml/parmatch.ml +++ b/jscomp/ml/parmatch.ml @@ -1037,7 +1037,7 @@ let build_other_constant proj make first next p env = let some_other_tag = "" -let build_other ext env = match env with +let build_other ext env : Typedtree.pattern = match env with | ({pat_desc = Tpat_construct (lid, {cstr_tag=Cstr_extension _},_)},_) :: _ -> (* let c = {c with cstr_name = "*extension*"} in *) (* PR#7330 *) make_pat (Tpat_var (Ident.create "*extension*", @@ -1079,13 +1079,19 @@ let build_other ext env = match env with make_pat (Tpat_or (pat, p_res, None)) p.pat_type p.pat_env) pat other_pats end -| ({pat_desc=(Tpat_constant (Const_int _ | Const_char _))} as p,_) :: _ -> +| ({pat_desc=(Tpat_constant (Const_int _ ))} as p,_) :: _ -> build_other_constant (function Tpat_constant(Const_int i) -> i - | Tpat_constant (Const_char i) -> Char.code i | _ -> assert false) (function i -> Tpat_constant(Const_int i)) 0 succ p env +| ({pat_desc=(Tpat_constant (Const_char _ ))} as p,_) :: _ -> + build_other_constant + (function + | Tpat_constant (Const_char i) -> Char.code i + | _ -> assert false) + (function i -> Tpat_constant(Const_char (Obj.magic (i:int) : char))) + 0 succ p env | ({pat_desc=(Tpat_constant (Const_int32 _))} as p,_) :: _ -> build_other_constant (function Tpat_constant(Const_int32 i) -> i | _ -> assert false) diff --git a/jscomp/test/build.ninja b/jscomp/test/build.ninja index 4d540ff1cf7..6bc981131e2 100644 --- a/jscomp/test/build.ninja +++ b/jscomp/test/build.ninja @@ -332,6 +332,7 @@ o test/gpr_5169_test.cmi test/gpr_5169_test.cmj : cc test/gpr_5169_test.ml | $bs o test/gpr_5218_test.cmi test/gpr_5218_test.cmj : cc test/gpr_5218_test.res | test/mt.cmj $bsc $stdlib runtime 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_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 @@ -734,4 +735,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_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_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_5557.js b/jscomp/test/gpr_5557.js new file mode 100644 index 00000000000..e247dd0dc52 --- /dev/null +++ b/jscomp/test/gpr_5557.js @@ -0,0 +1,12 @@ +'use strict'; + + +function isA(c) { + return true; +} + +var h = /* 'a' */97; + +exports.isA = isA; +exports.h = h; +/* No side effect */ diff --git a/jscomp/test/gpr_5557.res b/jscomp/test/gpr_5557.res new file mode 100644 index 00000000000..bef9908e193 --- /dev/null +++ b/jscomp/test/gpr_5557.res @@ -0,0 +1,6 @@ +let isA = c => + switch c { + | 'a' => true + } + +let h : int = ('a' :> int) From bdb0aae83bf91e6a1c5f11eb038e5cc8f24ee696 Mon Sep 17 00:00:00 2001 From: HongboZhang Date: Mon, 24 Oct 2022 10:57:06 +0800 Subject: [PATCH 03/10] add a test case --- jscomp/test/gpr_5557.js | 13 ++++++++++++- jscomp/test/gpr_5557.res | 3 +++ 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/jscomp/test/gpr_5557.js b/jscomp/test/gpr_5557.js index e247dd0dc52..14fcdbe75f8 100644 --- a/jscomp/test/gpr_5557.js +++ b/jscomp/test/gpr_5557.js @@ -2,7 +2,18 @@ function isA(c) { - return true; + if (c === 97) { + return true; + } + throw { + RE_EXN_ID: "Match_failure", + _1: [ + "gpr_5557.res", + 5, + 2 + ], + Error: new Error() + }; } var h = /* 'a' */97; diff --git a/jscomp/test/gpr_5557.res b/jscomp/test/gpr_5557.res index bef9908e193..a9342cfcf0b 100644 --- a/jscomp/test/gpr_5557.res +++ b/jscomp/test/gpr_5557.res @@ -1,3 +1,6 @@ +@@config({ + flags : ["-w", "-8"] +}) let isA = c => switch c { | 'a' => true From 8dc5ad00a25efe57f4327c756c656ba112ba1e64 Mon Sep 17 00:00:00 2001 From: HongboZhang Date: Mon, 24 Oct 2022 10:57:34 +0800 Subject: [PATCH 04/10] snapshot --- lib/4.06.1/unstable/js_compiler.ml | 173 +-------- lib/4.06.1/unstable/js_compiler.ml.d | 2 - lib/4.06.1/unstable/js_playground_compiler.ml | 332 +++++++++--------- lib/4.06.1/whole_compiler.ml | 332 +++++++++--------- 4 files changed, 348 insertions(+), 491 deletions(-) diff --git a/lib/4.06.1/unstable/js_compiler.ml b/lib/4.06.1/unstable/js_compiler.ml index eab64f524cc..5bf81b59e91 100644 --- a/lib/4.06.1/unstable/js_compiler.ml +++ b/lib/4.06.1/unstable/js_compiler.ml @@ -27495,7 +27495,7 @@ let build_other_constant proj make first next p env = let some_other_tag = "" -let build_other ext env = match env with +let build_other ext env : Typedtree.pattern = match env with | ({pat_desc = Tpat_construct (lid, {cstr_tag=Cstr_extension _},_)},_) :: _ -> (* let c = {c with cstr_name = "*extension*"} in *) (* PR#7330 *) make_pat (Tpat_var (Ident.create "*extension*", @@ -27537,13 +27537,19 @@ let build_other ext env = match env with make_pat (Tpat_or (pat, p_res, None)) p.pat_type p.pat_env) pat other_pats end -| ({pat_desc=(Tpat_constant (Const_int _ | Const_char _))} as p,_) :: _ -> +| ({pat_desc=(Tpat_constant (Const_int _ ))} as p,_) :: _ -> build_other_constant (function Tpat_constant(Const_int i) -> i - | Tpat_constant (Const_char i) -> Char.code i | _ -> assert false) (function i -> Tpat_constant(Const_int i)) 0 succ p env +| ({pat_desc=(Tpat_constant (Const_char _ ))} as p,_) :: _ -> + build_other_constant + (function + | Tpat_constant (Const_char i) -> Char.code i + | _ -> assert false) + (function i -> Tpat_constant(Const_char (Obj.magic (i:int) : char))) + 0 succ p env | ({pat_desc=(Tpat_constant (Const_int32 _))} as p,_) :: _ -> build_other_constant (function Tpat_constant(Const_int32 i) -> i | _ -> assert false) @@ -51098,165 +51104,6 @@ let isKeywordTxt str = 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 - -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" @@ -51855,7 +51702,7 @@ let printConstant ?(templateLiteral = false) c = let s = (Bytes.create [@doesNotRaise]) 1 in Bytes.unsafe_set s 0 c; Bytes.unsafe_to_string s - | c -> Res_utf8.encodeCodePoint (Obj.magic c) + | c -> string_of_int (Obj.magic c) in Doc.text ("'" ^ str ^ "'") diff --git a/lib/4.06.1/unstable/js_compiler.ml.d b/lib/4.06.1/unstable/js_compiler.ml.d index d9c1e6e21bb..1a6e5bdc134 100644 --- a/lib/4.06.1/unstable/js_compiler.ml.d +++ b/lib/4.06.1/unstable/js_compiler.ml.d @@ -584,8 +584,6 @@ ../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 559685bd4b9..be459897f86 100644 --- a/lib/4.06.1/unstable/js_playground_compiler.ml +++ b/lib/4.06.1/unstable/js_playground_compiler.ml @@ -27495,7 +27495,7 @@ let build_other_constant proj make first next p env = let some_other_tag = "" -let build_other ext env = match env with +let build_other ext env : Typedtree.pattern = match env with | ({pat_desc = Tpat_construct (lid, {cstr_tag=Cstr_extension _},_)},_) :: _ -> (* let c = {c with cstr_name = "*extension*"} in *) (* PR#7330 *) make_pat (Tpat_var (Ident.create "*extension*", @@ -27537,13 +27537,19 @@ let build_other ext env = match env with make_pat (Tpat_or (pat, p_res, None)) p.pat_type p.pat_env) pat other_pats end -| ({pat_desc=(Tpat_constant (Const_int _ | Const_char _))} as p,_) :: _ -> +| ({pat_desc=(Tpat_constant (Const_int _ ))} as p,_) :: _ -> build_other_constant (function Tpat_constant(Const_int i) -> i - | Tpat_constant (Const_char i) -> Char.code i | _ -> assert false) (function i -> Tpat_constant(Const_int i)) 0 succ p env +| ({pat_desc=(Tpat_constant (Const_char _ ))} as p,_) :: _ -> + build_other_constant + (function + | Tpat_constant (Const_char i) -> Char.code i + | _ -> assert false) + (function i -> Tpat_constant(Const_char (Obj.magic (i:int) : char))) + 0 succ p env | ({pat_desc=(Tpat_constant (Const_int32 _))} as p,_) :: _ -> build_other_constant (function Tpat_constant(Const_int32 i) -> i | _ -> assert false) @@ -51098,165 +51104,6 @@ let isKeywordTxt str = 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 - -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" @@ -51855,7 +51702,7 @@ let printConstant ?(templateLiteral = false) c = let s = (Bytes.create [@doesNotRaise]) 1 in Bytes.unsafe_set s 0 c; Bytes.unsafe_to_string s - | c -> Res_utf8.encodeCodePoint (Obj.magic c) + | c -> string_of_int (Obj.magic c) in Doc.text ("'" ^ str ^ "'") @@ -281704,6 +281551,165 @@ 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" diff --git a/lib/4.06.1/whole_compiler.ml b/lib/4.06.1/whole_compiler.ml index 3bf85a12a69..b60dea70328 100644 --- a/lib/4.06.1/whole_compiler.ml +++ b/lib/4.06.1/whole_compiler.ml @@ -189292,7 +189292,7 @@ let build_other_constant proj make first next p env = let some_other_tag = "" -let build_other ext env = match env with +let build_other ext env : Typedtree.pattern = match env with | ({pat_desc = Tpat_construct (lid, {cstr_tag=Cstr_extension _},_)},_) :: _ -> (* let c = {c with cstr_name = "*extension*"} in *) (* PR#7330 *) make_pat (Tpat_var (Ident.create "*extension*", @@ -189334,13 +189334,19 @@ let build_other ext env = match env with make_pat (Tpat_or (pat, p_res, None)) p.pat_type p.pat_env) pat other_pats end -| ({pat_desc=(Tpat_constant (Const_int _ | Const_char _))} as p,_) :: _ -> +| ({pat_desc=(Tpat_constant (Const_int _ ))} as p,_) :: _ -> build_other_constant (function Tpat_constant(Const_int i) -> i - | Tpat_constant (Const_char i) -> Char.code i | _ -> assert false) (function i -> Tpat_constant(Const_int i)) 0 succ p env +| ({pat_desc=(Tpat_constant (Const_char _ ))} as p,_) :: _ -> + build_other_constant + (function + | Tpat_constant (Const_char i) -> Char.code i + | _ -> assert false) + (function i -> Tpat_constant(Const_char (Obj.magic (i:int) : char))) + 0 succ p env | ({pat_desc=(Tpat_constant (Const_int32 _))} as p,_) :: _ -> build_other_constant (function Tpat_constant(Const_int32 i) -> i | _ -> assert false) @@ -227285,165 +227291,6 @@ let isKeywordTxt str = 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 - -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" @@ -228042,7 +227889,7 @@ let printConstant ?(templateLiteral = false) c = let s = (Bytes.create [@doesNotRaise]) 1 in Bytes.unsafe_set s 0 c; Bytes.unsafe_to_string s - | c -> Res_utf8.encodeCodePoint (Obj.magic c) + | c -> string_of_int (Obj.magic c) in Doc.text ("'" ^ str ^ "'") @@ -295236,6 +295083,165 @@ 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" From 4d03aef8cb40f869397069aece50ba2ee3b56795 Mon Sep 17 00:00:00 2001 From: butterunderflow Date: Thu, 27 Oct 2022 23:52:09 +0800 Subject: [PATCH 05/10] change Pconst_char payload (WIP) tweak tweak --- 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/parser.mly | 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 +- 15 files changed, 18 insertions(+), 18 deletions(-) diff --git a/jscomp/core/js_of_lam_string.ml b/jscomp/core/js_of_lam_string.ml index 6ba28e7037c..50c343f2381 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 50b76e2ee2d..143b44b3bb4 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 (Char.unsafe_chr 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 2d1f9b565b3..80fb40a1c72 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 9c6f4aea368..8fefc452830 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 e65cb7a21ed..4802a3dbf8f 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 47ca04ad0dc..4836af68f30 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 5ddf83e25f5..31527ccc9c8 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/parser.mly b/jscomp/ml/parser.mly index dc1fca42291..fe4ace9a4e2 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/parsetree.ml b/jscomp/ml/parsetree.ml index d2b997ab416..ebf18377557 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 8c0ec6d74dc..0efef3b106d 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.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 diff --git a/jscomp/ml/pprintast.pp.ml b/jscomp/ml/pprintast.pp.ml index 2bdeb8b9239..442594bb95a 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 3ab833359c0..eee7a905170 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 636834bed90..a355c867688 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 09e348c9fe7..f6243f6c6e8 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 012cdd765c5..59e0cda9d86 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 81075387cea3c09bf12ad96c920a367a867fd94c Mon Sep 17 00:00:00 2001 From: butterunderflow Date: Fri, 28 Oct 2022 04:14:43 +0800 Subject: [PATCH 06/10] representation of char for lambda lib bugfix: replace wrong pp libs bugfix: replace wrong print use unsafe_chr to handle possible overflow char safe print int as char --- 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 | 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/all_ounit_tests.ml | 11 +- lib/4.06.1/unstable/js_compiler.ml | 1896 +++++- lib/4.06.1/unstable/js_compiler.ml.d | 4 + lib/4.06.1/unstable/js_playground_compiler.ml | 5586 +++++++++-------- lib/4.06.1/whole_compiler.ml | 5480 ++++++++-------- 23 files changed, 7609 insertions(+), 5430 deletions(-) diff --git a/jscomp/core/js_dump.ml b/jscomp/core/js_dump.ml index 4063b60bde3..05237aed31c 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 "/* %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/js_exp_make.mli b/jscomp/core/js_exp_make.mli index 0c9ef3bd281..351663cceb3 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 50c343f2381..1ec3f77e985 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 cb3f2aeb10d..eb6ca708ddf 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 b7e25e2f4ab..4e40d3eb5bd 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 2915b1f5f74..989c047ac30 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 547c5be174d..5775e9b461f 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 eeb61134ddc..4fdb33b1c90 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 143b44b3bb4..50b76e2ee2d 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 11c35d10da4..75dc0c555a0 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 b8bd3e4d31a..cb9d2771ad4 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 80188805e82..5907149e839 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" 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 4836af68f30..21e169a0ad3 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 "%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 0efef3b106d..b161db201a4 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) (*consider safety*) + | 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 18ffa38b0ce..7da9ee0d120 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 442594bb95a..5ac5790a444 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 a355c867688..85422385946 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 "%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 bd4779d9957..5a9b1bfc4bb 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/all_ounit_tests.ml b/lib/4.06.1/unstable/all_ounit_tests.ml index ec50f41a699..f03e1543ee1 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 5bf81b59e91..894257411f7 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 @@ -24862,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" @@ -26837,7 +28309,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" (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 @@ -27546,9 +29018,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 +30600,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" (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 @@ -39966,7 +41438,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 +46531,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 +49245,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 +49890,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 +52340,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 +52597,165 @@ let isKeywordTxt str = 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 + +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" @@ -51691,7 +53343,7 @@ let printConstant ?(templateLiteral = false) c = | Pconst_float (s, _) -> Doc.text s | Pconst_char c -> let str = - match c with + match Char.unsafe_chr c with | '\'' -> "\\'" | '\\' -> "\\\\" | '\n' -> "\\n" @@ -51702,7 +53354,7 @@ let printConstant ?(templateLiteral = false) 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) + | _ -> Res_utf8.encodeCodePoint c in Doc.text ("'" ^ str ^ "'") @@ -54118,6 +55770,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 +56561,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 +71053,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 +76613,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 +78553,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 +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" 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 *) @@ -83388,7 +85100,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 +85163,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 +86955,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 +87026,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 @@ -92072,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" @@ -92080,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" 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 @@ -94882,7 +96601,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 +96638,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 +259934,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 +273333,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 = @@ -273133,13 +274871,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 = @@ -273555,6 +275310,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)) @@ -273571,11 +275332,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 = @@ -273609,6 +275373,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 = @@ -273799,7 +275571,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 @@ -273811,6 +275584,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" } *) @@ -273818,12 +275598,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") @@ -273927,8 +275704,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, ...>) => { ... } *) @@ -274004,6 +275785,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)) @@ -274026,10 +275813,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 []) @@ -274138,24 +275928,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 1a6e5bdc134..a16f0b5d823 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 @@ -584,6 +586,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 be459897f86..eb9d0122d87 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 @@ -24863,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 *) @@ -24880,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. *) @@ -24971,425 +24913,1955 @@ 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; + | 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" +(**************************************************************************) +(* *) +(* 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 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 [@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 = @@ -26837,7 +28309,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" (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 @@ -27546,9 +29018,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 +30600,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" (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 @@ -39966,7 +41438,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 +46531,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 +49245,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 +49890,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 +52340,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 +52597,165 @@ let isKeywordTxt str = 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 + +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" @@ -51691,7 +53343,7 @@ let printConstant ?(templateLiteral = false) c = | Pconst_float (s, _) -> Doc.text s | Pconst_char c -> let str = - match c with + match Char.unsafe_chr c with | '\'' -> "\\'" | '\\' -> "\\\\" | '\n' -> "\\n" @@ -51702,7 +53354,7 @@ let printConstant ?(templateLiteral = false) 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) + | _ -> Res_utf8.encodeCodePoint c in Doc.text ("'" ^ str ^ "'") @@ -54118,6 +55770,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 +56561,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 +71053,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 +76613,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 +78553,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 +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" 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 *) @@ -83388,7 +85100,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 +85163,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 +86955,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 +87026,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 @@ -92072,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" @@ -92080,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" 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 @@ -94882,7 +96601,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 +96638,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 +259934,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 | _ -> @@ -261236,2093 +262955,630 @@ let ( LBRACE ) # 1983 "ml/lexer.ml" - | 59 -> -# 472 "ml/lexer.mll" - ( LBRACELESS ) -# 1988 "ml/lexer.ml" - - | 60 -> -# 473 "ml/lexer.mll" - ( BAR ) -# 1993 "ml/lexer.ml" - - | 61 -> -# 474 "ml/lexer.mll" - ( BARBAR ) -# 1998 "ml/lexer.ml" - - | 62 -> -# 475 "ml/lexer.mll" - ( BARRBRACKET ) -# 2003 "ml/lexer.ml" - - | 63 -> -# 476 "ml/lexer.mll" - ( GREATER ) -# 2008 "ml/lexer.ml" - - | 64 -> -# 477 "ml/lexer.mll" - ( GREATERRBRACKET ) -# 2013 "ml/lexer.ml" - - | 65 -> -# 478 "ml/lexer.mll" - ( RBRACE ) -# 2018 "ml/lexer.ml" - - | 66 -> -# 479 "ml/lexer.mll" - ( GREATERRBRACE ) -# 2023 "ml/lexer.ml" - - | 67 -> -# 480 "ml/lexer.mll" - ( LBRACKETAT ) -# 2028 "ml/lexer.ml" - - | 68 -> -# 481 "ml/lexer.mll" - ( LBRACKETATAT ) -# 2033 "ml/lexer.ml" - - | 69 -> -# 482 "ml/lexer.mll" - ( LBRACKETATATAT ) -# 2038 "ml/lexer.ml" - - | 70 -> -# 483 "ml/lexer.mll" - ( LBRACKETPERCENT ) -# 2043 "ml/lexer.ml" - - | 71 -> -# 484 "ml/lexer.mll" - ( LBRACKETPERCENTPERCENT ) -# 2048 "ml/lexer.ml" - - | 72 -> -# 485 "ml/lexer.mll" - ( BANG ) -# 2053 "ml/lexer.ml" - - | 73 -> -# 486 "ml/lexer.mll" - ( INFIXOP0 "!=" ) -# 2058 "ml/lexer.ml" - - | 74 -> -# 487 "ml/lexer.mll" - ( PLUS ) -# 2063 "ml/lexer.ml" - - | 75 -> -# 488 "ml/lexer.mll" - ( PLUSDOT ) -# 2068 "ml/lexer.ml" - - | 76 -> -# 489 "ml/lexer.mll" - ( PLUSEQ ) -# 2073 "ml/lexer.ml" - - | 77 -> -# 490 "ml/lexer.mll" - ( MINUS ) -# 2078 "ml/lexer.ml" - - | 78 -> -# 491 "ml/lexer.mll" - ( MINUSDOT ) -# 2083 "ml/lexer.ml" - - | 79 -> -# 494 "ml/lexer.mll" - ( PREFIXOP(Lexing.lexeme lexbuf) ) -# 2088 "ml/lexer.ml" - - | 80 -> -# 496 "ml/lexer.mll" - ( PREFIXOP(Lexing.lexeme lexbuf) ) -# 2093 "ml/lexer.ml" - - | 81 -> -# 498 "ml/lexer.mll" - ( INFIXOP0(Lexing.lexeme lexbuf) ) -# 2098 "ml/lexer.ml" - - | 82 -> -# 500 "ml/lexer.mll" - ( INFIXOP1(Lexing.lexeme lexbuf) ) -# 2103 "ml/lexer.ml" - - | 83 -> -# 502 "ml/lexer.mll" - ( INFIXOP2(Lexing.lexeme lexbuf) ) -# 2108 "ml/lexer.ml" - - | 84 -> -# 504 "ml/lexer.mll" - ( INFIXOP4(Lexing.lexeme lexbuf) ) -# 2113 "ml/lexer.ml" - - | 85 -> -# 505 "ml/lexer.mll" - ( PERCENT ) -# 2118 "ml/lexer.ml" - - | 86 -> -# 507 "ml/lexer.mll" - ( INFIXOP3(Lexing.lexeme lexbuf) ) -# 2123 "ml/lexer.ml" - - | 87 -> -# 509 "ml/lexer.mll" - ( HASHOP(Lexing.lexeme lexbuf) ) -# 2128 "ml/lexer.ml" - - | 88 -> -# 510 "ml/lexer.mll" - ( Rescript_cpp.eof_check lexbuf; EOF) -# 2133 "ml/lexer.ml" - - | 89 -> -# 512 "ml/lexer.mll" - ( raise (Error(Illegal_character (Lexing.lexeme_char lexbuf 0), - Location.curr lexbuf)) - ) -# 2140 "ml/lexer.ml" - - | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; - __ocaml_lex_token_rec lexbuf __ocaml_lex_state - -and comment lexbuf = - __ocaml_lex_comment_rec lexbuf 137 -and __ocaml_lex_comment_rec lexbuf __ocaml_lex_state = - match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with - | 0 -> -# 518 "ml/lexer.mll" - ( comment_start_loc := (Location.curr lexbuf) :: !comment_start_loc; - store_lexeme lexbuf; - comment lexbuf - ) -# 2155 "ml/lexer.ml" - - | 1 -> -# 523 "ml/lexer.mll" - ( match !comment_start_loc with - | [] -> assert false - | [_] -> comment_start_loc := []; Location.curr lexbuf - | _ :: l -> comment_start_loc := l; - store_lexeme lexbuf; - comment lexbuf - ) -# 2166 "ml/lexer.ml" - - | 2 -> -# 531 "ml/lexer.mll" - ( - string_start_loc := Location.curr lexbuf; - store_string_char '\"'; - is_in_string := true; - begin try string lexbuf - with Error (Unterminated_string, str_start) -> - match !comment_start_loc with - | [] -> assert false - | loc :: _ -> - let start = List.hd (List.rev !comment_start_loc) in - comment_start_loc := []; - raise (Error (Unterminated_string_in_comment (start, str_start), - loc)) - end; - is_in_string := false; - store_string_char '\"'; - comment lexbuf ) -# 2187 "ml/lexer.ml" - - | 3 -> -# 549 "ml/lexer.mll" - ( - let delim = Lexing.lexeme lexbuf in - let delim = String.sub delim 1 (String.length delim - 2) in - string_start_loc := Location.curr lexbuf; - store_lexeme lexbuf; - is_in_string := true; - begin try quoted_string delim lexbuf - with Error (Unterminated_string, str_start) -> - match !comment_start_loc with - | [] -> assert false - | loc :: _ -> - let start = List.hd (List.rev !comment_start_loc) in - comment_start_loc := []; - raise (Error (Unterminated_string_in_comment (start, str_start), - loc)) - end; - is_in_string := false; - store_string_char '|'; - store_string delim; - store_string_char '}'; - comment lexbuf ) -# 2212 "ml/lexer.ml" - - | 4 -> -# 572 "ml/lexer.mll" - ( store_lexeme lexbuf; comment lexbuf ) -# 2217 "ml/lexer.ml" - - | 5 -> -# 574 "ml/lexer.mll" - ( update_loc lexbuf None 1 false 1; - store_lexeme lexbuf; - comment lexbuf - ) -# 2225 "ml/lexer.ml" - - | 6 -> -# 579 "ml/lexer.mll" - ( store_lexeme lexbuf; comment lexbuf ) -# 2230 "ml/lexer.ml" - - | 7 -> -# 581 "ml/lexer.mll" - ( store_lexeme lexbuf; comment lexbuf ) -# 2235 "ml/lexer.ml" - - | 8 -> -# 583 "ml/lexer.mll" - ( store_lexeme lexbuf; comment lexbuf ) -# 2240 "ml/lexer.ml" - - | 9 -> -# 585 "ml/lexer.mll" - ( store_lexeme lexbuf; comment lexbuf ) -# 2245 "ml/lexer.ml" - - | 10 -> -# 587 "ml/lexer.mll" - ( match !comment_start_loc with - | [] -> assert false - | loc :: _ -> - let start = List.hd (List.rev !comment_start_loc) in - comment_start_loc := []; - raise (Error (Unterminated_comment start, loc)) - ) -# 2256 "ml/lexer.ml" - - | 11 -> -# 595 "ml/lexer.mll" - ( update_loc lexbuf None 1 false 0; - store_lexeme lexbuf; - comment lexbuf - ) -# 2264 "ml/lexer.ml" - - | 12 -> -# 600 "ml/lexer.mll" - ( store_lexeme lexbuf; comment lexbuf ) -# 2269 "ml/lexer.ml" - - | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; - __ocaml_lex_comment_rec lexbuf __ocaml_lex_state - -and string lexbuf = - lexbuf.Lexing.lex_mem <- Array.make 2 (-1); __ocaml_lex_string_rec lexbuf 169 -and __ocaml_lex_string_rec lexbuf __ocaml_lex_state = - match Lexing.new_engine __ocaml_lex_tables __ocaml_lex_state lexbuf with - | 0 -> -# 604 "ml/lexer.mll" - ( () ) -# 2281 "ml/lexer.ml" - - | 1 -> -let -# 605 "ml/lexer.mll" - space -# 2287 "ml/lexer.ml" -= Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_mem.(0) lexbuf.Lexing.lex_curr_pos in -# 606 "ml/lexer.mll" - ( update_loc lexbuf None 1 false (String.length space); - if in_comment () then store_lexeme lexbuf; - string lexbuf - ) -# 2294 "ml/lexer.ml" - - | 2 -> -# 611 "ml/lexer.mll" - ( store_escaped_char lexbuf - (char_for_backslash(Lexing.lexeme_char lexbuf 1)); - string lexbuf ) -# 2301 "ml/lexer.ml" - - | 3 -> -# 615 "ml/lexer.mll" - ( store_escaped_char lexbuf (char_for_decimal_code lexbuf 1); - string lexbuf ) -# 2307 "ml/lexer.ml" - - | 4 -> -# 618 "ml/lexer.mll" - ( store_escaped_char lexbuf (char_for_octal_code lexbuf 2); - string lexbuf ) -# 2313 "ml/lexer.ml" - - | 5 -> -# 621 "ml/lexer.mll" - ( store_escaped_char lexbuf (char_for_hexadecimal_code lexbuf 2); - string lexbuf ) -# 2319 "ml/lexer.ml" - - | 6 -> -# 624 "ml/lexer.mll" - ( store_escaped_uchar lexbuf (uchar_for_uchar_escape lexbuf); - string lexbuf ) -# 2325 "ml/lexer.ml" - - | 7 -> -# 627 "ml/lexer.mll" - ( if not (in_comment ()) then begin -(* Should be an error, but we are very lax. - raise (Error (Illegal_escape (Lexing.lexeme lexbuf), - Location.curr lexbuf)) -*) - let loc = Location.curr lexbuf in - Location.prerr_warning loc Warnings.Illegal_backslash; - end; - store_lexeme lexbuf; - string lexbuf - ) -# 2340 "ml/lexer.ml" - - | 8 -> -# 639 "ml/lexer.mll" - ( if not (in_comment ()) then - Location.prerr_warning (Location.curr lexbuf) Warnings.Eol_in_string; - update_loc lexbuf None 1 false 0; - store_lexeme lexbuf; - string lexbuf - ) -# 2350 "ml/lexer.ml" - - | 9 -> -# 646 "ml/lexer.mll" - ( is_in_string := false; - raise (Error (Unterminated_string, !string_start_loc)) ) -# 2356 "ml/lexer.ml" - - | 10 -> -# 649 "ml/lexer.mll" - ( store_string_char(Lexing.lexeme_char lexbuf 0); - string lexbuf ) -# 2362 "ml/lexer.ml" - - | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; - __ocaml_lex_string_rec lexbuf __ocaml_lex_state - -and quoted_string delim lexbuf = - __ocaml_lex_quoted_string_rec delim lexbuf 196 -and __ocaml_lex_quoted_string_rec delim lexbuf __ocaml_lex_state = - match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with - | 0 -> -# 654 "ml/lexer.mll" - ( update_loc lexbuf None 1 false 0; - store_lexeme lexbuf; - quoted_string delim lexbuf - ) -# 2377 "ml/lexer.ml" - - | 1 -> -# 659 "ml/lexer.mll" - ( is_in_string := false; - raise (Error (Unterminated_string, !string_start_loc)) ) -# 2383 "ml/lexer.ml" - - | 2 -> -# 662 "ml/lexer.mll" - ( - let edelim = Lexing.lexeme lexbuf in - let edelim = String.sub edelim 1 (String.length edelim - 2) in - if delim = edelim then () - else (store_lexeme lexbuf; quoted_string delim lexbuf) - ) -# 2393 "ml/lexer.ml" - - | 3 -> -# 669 "ml/lexer.mll" - ( store_string_char(Lexing.lexeme_char lexbuf 0); - quoted_string delim lexbuf ) -# 2399 "ml/lexer.ml" - - | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; - __ocaml_lex_quoted_string_rec delim lexbuf __ocaml_lex_state - -and skip_hash_bang lexbuf = - __ocaml_lex_skip_hash_bang_rec lexbuf 205 -and __ocaml_lex_skip_hash_bang_rec lexbuf __ocaml_lex_state = - match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with - | 0 -> -# 674 "ml/lexer.mll" - ( update_loc lexbuf None 3 false 0 ) -# 2411 "ml/lexer.ml" - - | 1 -> -# 676 "ml/lexer.mll" - ( update_loc lexbuf None 1 false 0 ) -# 2416 "ml/lexer.ml" - - | 2 -> -# 677 "ml/lexer.mll" - ( () ) -# 2421 "ml/lexer.ml" - - | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; - __ocaml_lex_skip_hash_bang_rec lexbuf __ocaml_lex_state - -;; - -# 679 "ml/lexer.mll" - - let token_with_comments lexbuf = - match !preprocessor with - | None -> token lexbuf - | Some (_init, preprocess) -> preprocess token lexbuf - - type newline_state = - | NoLine (* There have been no blank lines yet. *) - | NewLine - (* There have been no blank lines, and the previous - token was a newline. *) - | BlankLine (* There have been blank lines. *) - - type doc_state = - | Initial (* There have been no docstrings yet *) - | After of docstring list - (* There have been docstrings, none of which were - preceded by a blank line *) - | Before of docstring list * docstring list * docstring list - (* There have been docstrings, some of which were - preceded by a blank line *) - - and docstring = Docstrings.docstring - - let token lexbuf = - let post_pos = lexeme_end_p lexbuf in - let attach lines docs pre_pos = - let open Docstrings in - match docs, lines with - | Initial, _ -> () - | After a, (NoLine | NewLine) -> - set_post_docstrings post_pos (List.rev a); - set_pre_docstrings pre_pos a; - | After a, BlankLine -> - set_post_docstrings post_pos (List.rev a); - set_pre_extra_docstrings pre_pos (List.rev a) - | Before(a, f, b), (NoLine | NewLine) -> - set_post_docstrings post_pos (List.rev a); - set_post_extra_docstrings post_pos - (List.rev_append f (List.rev b)); - set_floating_docstrings pre_pos (List.rev f); - set_pre_extra_docstrings pre_pos (List.rev a); - set_pre_docstrings pre_pos b - | Before(a, f, b), BlankLine -> - set_post_docstrings post_pos (List.rev a); - set_post_extra_docstrings post_pos - (List.rev_append f (List.rev b)); - set_floating_docstrings pre_pos - (List.rev_append f (List.rev b)); - set_pre_extra_docstrings pre_pos (List.rev a) - in - let rec loop lines docs lexbuf = - match token_with_comments lexbuf with - | COMMENT (s, loc) -> - add_comment (s, loc); - let lines' = - match lines with - | NoLine -> NoLine - | NewLine -> NoLine - | BlankLine -> BlankLine - in - loop lines' docs lexbuf - | EOL -> - let lines' = - match lines with - | NoLine -> NewLine - | NewLine -> BlankLine - | BlankLine -> BlankLine - in - loop lines' docs lexbuf - | HASH when Rescript_cpp.at_bol lexbuf -> - Rescript_cpp.interpret_directive lexbuf - ~cont:(fun lexbuf -> loop lines docs lexbuf) - ~token_with_comments - | DOCSTRING doc -> - Docstrings.register doc; - add_docstring_comment doc; - let docs' = - if Docstrings.docstring_body doc = "/*" then - match docs with - | Initial -> Before([], [doc], []) - | After a -> Before (a, [doc], []) - | Before(a, f, b) -> Before(a, doc :: b @ f, []) - else - match docs, lines with - | Initial, (NoLine | NewLine) -> After [doc] - | Initial, BlankLine -> Before([], [], [doc]) - | After a, (NoLine | NewLine) -> After (doc :: a) - | After a, BlankLine -> Before (a, [], [doc]) - | Before(a, f, b), (NoLine | NewLine) -> Before(a, f, doc :: b) - | Before(a, f, b), BlankLine -> Before(a, b @ f, [doc]) - in - loop NoLine docs' lexbuf - | tok -> - attach lines docs (lexeme_start_p lexbuf); - tok - in - Rescript_cpp.check_sharp_look_ahead (fun _ -> loop NoLine Initial lexbuf) - - let init () = - Rescript_cpp.init (); - is_in_string := false; - comment_start_loc := []; - comment_list := []; - match !preprocessor with - | None -> () - | Some (init, _preprocess) -> init () - - - let set_preprocessor init preprocess = - escaped_newlines := true; - preprocessor := Some (init, preprocess) - - -# 2543 "ml/lexer.ml" - -end -module Parse : sig -#1 "parse.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. *) -(* *) -(**************************************************************************) - -(** Entry points in the parser *) - -val implementation : Lexing.lexbuf -> Parsetree.structure -val interface : Lexing.lexbuf -> Parsetree.signature -val core_type : Lexing.lexbuf -> Parsetree.core_type -val expression : Lexing.lexbuf -> Parsetree.expression -val pattern : Lexing.lexbuf -> Parsetree.pattern - -end = struct -#1 "parse.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. *) -(* *) -(**************************************************************************) - -(* Entry points in the parser *) - - -let wrap parsing_fun lexbuf = - try - Docstrings.init (); - Lexer.init (); - let ast = parsing_fun Lexer.token lexbuf in - Parsing.clear_parser(); - Docstrings.warn_bad_docstrings (); - ast - with - | Parsing.Parse_error | Syntaxerr.Escape_error -> - let loc = Location.curr lexbuf in - raise(Syntaxerr.Error(Syntaxerr.Other loc)) - -let implementation = wrap Parser.implementation -and interface = wrap Parser.interface -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 *) + | 59 -> +# 472 "ml/lexer.mll" + ( LBRACELESS ) +# 1988 "ml/lexer.ml" -open Asttypes -open Format -open Location -open Longident -open Parsetree -open Ast_helper + | 60 -> +# 473 "ml/lexer.mll" + ( BAR ) +# 1993 "ml/lexer.ml" -let prefix_symbols = [ '!'; '?'; '~' ] ;; -let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/'; - '$'; '%'; '#' ] + | 61 -> +# 474 "ml/lexer.mll" + ( BARBAR ) +# 1998 "ml/lexer.ml" -(* type fixity = Infix| Prefix *) -let special_infix_strings = - ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!="; "::" ] + | 62 -> +# 475 "ml/lexer.mll" + ( BARRBRACKET ) +# 2003 "ml/lexer.ml" -(* 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 + | 63 -> +# 476 "ml/lexer.mll" + ( GREATER ) +# 2008 "ml/lexer.ml" -let view_fixity_of_exp = function - | {pexp_desc = Pexp_ident {txt=Lident l;_}; pexp_attributes = []} -> - fixity_of_string l - | _ -> `Normal + | 64 -> +# 477 "ml/lexer.mll" + ( GREATERRBRACKET ) +# 2013 "ml/lexer.ml" -let is_infix = function | `Infix _ -> true | _ -> false -let is_mixfix = function `Mixfix _ -> true | _ -> false + | 65 -> +# 478 "ml/lexer.mll" + ( RBRACE ) +# 2018 "ml/lexer.ml" -(* 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 + | 66 -> +# 479 "ml/lexer.mll" + ( GREATERRBRACE ) +# 2023 "ml/lexer.ml" -(* some infixes need spaces around parens to avoid clashes with comment - syntax *) -let needs_spaces txt = - txt.[0]='*' || txt.[String.length txt - 1] = '*' + | 67 -> +# 480 "ml/lexer.mll" + ( LBRACKETAT ) +# 2028 "ml/lexer.ml" -(* 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 + | 68 -> +# 481 "ml/lexer.mll" + ( LBRACKETATAT ) +# 2033 "ml/lexer.ml" -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 + | 69 -> +# 482 "ml/lexer.mll" + ( LBRACKETATATAT ) +# 2038 "ml/lexer.ml" -type space_formatter = (unit, Format.formatter, unit) format + | 70 -> +# 483 "ml/lexer.mll" + ( LBRACKETPERCENT ) +# 2043 "ml/lexer.ml" -let override = function - | Override -> "!" - | Fresh -> "" + | 71 -> +# 484 "ml/lexer.mll" + ( LBRACKETPERCENTPERCENT ) +# 2048 "ml/lexer.ml" -(* variance encoding: need to sync up with the [parser.mly] *) -let type_variance = function - | Invariant -> "" - | Covariant -> "+" - | Contravariant -> "-" + | 72 -> +# 485 "ml/lexer.mll" + ( BANG ) +# 2053 "ml/lexer.ml" -type construct = - [ `cons of expression list - | `list of expression list - | `nil - | `normal - | `simple of Longident.t - | `tuple ] + | 73 -> +# 486 "ml/lexer.mll" + ( INFIXOP0 "!=" ) +# 2058 "ml/lexer.ml" -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 + | 74 -> +# 487 "ml/lexer.mll" + ( PLUS ) +# 2063 "ml/lexer.ml" -let is_simple_construct :construct -> bool = function - | `nil | `tuple | `list _ | `simple _ -> true - | `cons _ | `normal -> false + | 75 -> +# 488 "ml/lexer.mll" + ( PLUSDOT ) +# 2068 "ml/lexer.ml" -let pp = fprintf + | 76 -> +# 489 "ml/lexer.mll" + ( PLUSEQ ) +# 2073 "ml/lexer.ml" -type ctxt = { - pipe : bool; - semi : bool; - ifthenelse : bool; -} + | 77 -> +# 490 "ml/lexer.mll" + ( MINUS ) +# 2078 "ml/lexer.ml" -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 } -*) + | 78 -> +# 491 "ml/lexer.mll" + ( MINUSDOT ) +# 2083 "ml/lexer.ml" -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 + | 79 -> +# 494 "ml/lexer.mll" + ( PREFIXOP(Lexing.lexeme lexbuf) ) +# 2088 "ml/lexer.ml" -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 + | 80 -> +# 496 "ml/lexer.mll" + ( PREFIXOP(Lexing.lexeme lexbuf) ) +# 2093 "ml/lexer.ml" -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 + | 81 -> +# 498 "ml/lexer.mll" + ( INFIXOP0(Lexing.lexeme lexbuf) ) +# 2098 "ml/lexer.ml" -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 + | 82 -> +# 500 "ml/lexer.mll" + ( INFIXOP1(Lexing.lexeme lexbuf) ) +# 2103 "ml/lexer.ml" -let longident_loc f x = pp f "%a" longident x.txt + | 83 -> +# 502 "ml/lexer.mll" + ( INFIXOP2(Lexing.lexeme lexbuf) ) +# 2108 "ml/lexer.ml" -let constant f = function - | Pconst_char i -> pp f "%C" 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) + | 84 -> +# 504 "ml/lexer.mll" + ( INFIXOP4(Lexing.lexeme lexbuf) ) +# 2113 "ml/lexer.ml" -(* trailing space*) -let mutable_flag f = function - | Immutable -> () - | Mutable -> pp f "mutable@;" -let virtual_flag f = function - | Concrete -> () - | Virtual -> pp f "virtual@;" + | 85 -> +# 505 "ml/lexer.mll" + ( PERCENT ) +# 2118 "ml/lexer.ml" -(* 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@ " + | 86 -> +# 507 "ml/lexer.mll" + ( INFIXOP3(Lexing.lexeme lexbuf) ) +# 2123 "ml/lexer.ml" -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 + | 87 -> +# 509 "ml/lexer.mll" + ( HASHOP(Lexing.lexeme lexbuf) ) +# 2128 "ml/lexer.ml" -(* c ['a,'b] *) -let rec class_params_def ctxt f = function - | [] -> () - | l -> - pp f "[%a] " (* space *) - (list (type_param ctxt) ~sep:",") l + | 88 -> +# 510 "ml/lexer.mll" + ( Rescript_cpp.eof_check lexbuf; EOF) +# 2133 "ml/lexer.ml" -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 + | 89 -> +# 512 "ml/lexer.mll" + ( raise (Error(Illegal_character (Lexing.lexeme_char lexbuf 0), + Location.curr lexbuf)) + ) +# 2140 "ml/lexer.ml" -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 + | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; + __ocaml_lex_token_rec lexbuf __ocaml_lex_state -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 comment lexbuf = + __ocaml_lex_comment_rec lexbuf 137 +and __ocaml_lex_comment_rec lexbuf __ocaml_lex_state = + match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with + | 0 -> +# 518 "ml/lexer.mll" + ( comment_start_loc := (Location.curr lexbuf) :: !comment_start_loc; + store_lexeme lexbuf; + comment lexbuf + ) +# 2155 "ml/lexer.ml" -(********************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 + | 1 -> +# 523 "ml/lexer.mll" + ( match !comment_start_loc with + | [] -> assert false + | [_] -> comment_start_loc := []; Location.curr lexbuf + | _ :: l -> comment_start_loc := l; + store_lexeme lexbuf; + comment lexbuf + ) +# 2166 "ml/lexer.ml" -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 = []} + | 2 -> +# 531 "ml/lexer.mll" + ( + string_start_loc := Location.curr lexbuf; + store_string_char '\"'; + is_in_string := true; + begin try string lexbuf + with Error (Unterminated_string, str_start) -> + match !comment_start_loc with + | [] -> assert false + | loc :: _ -> + let start = List.hd (List.rev !comment_start_loc) in + comment_start_loc := []; + raise (Error (Unterminated_string_in_comment (start, str_start), + loc)) + end; + is_in_string := false; + store_string_char '\"'; + comment lexbuf ) +# 2187 "ml/lexer.ml" - -> - 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 + | 3 -> +# 549 "ml/lexer.mll" + ( + let delim = Lexing.lexeme lexbuf in + let delim = String.sub delim 1 (String.length delim - 2) in + string_start_loc := Location.curr lexbuf; + store_lexeme lexbuf; + is_in_string := true; + begin try quoted_string delim lexbuf + with Error (Unterminated_string, str_start) -> + match !comment_start_loc with + | [] -> assert false + | loc :: _ -> + let start = List.hd (List.rev !comment_start_loc) in + comment_start_loc := []; + raise (Error (Unterminated_string_in_comment (start, str_start), + loc)) + end; + is_in_string := false; + store_string_char '|'; + store_string delim; + store_string_char '}'; + comment lexbuf ) +# 2212 "ml/lexer.ml" -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 + | 4 -> +# 572 "ml/lexer.mll" + ( store_lexeme lexbuf; comment lexbuf ) +# 2217 "ml/lexer.ml" -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 + | 5 -> +# 574 "ml/lexer.mll" + ( update_loc lexbuf None 1 false 1; + store_lexeme lexbuf; + comment lexbuf + ) +# 2225 "ml/lexer.ml" -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 + | 6 -> +# 579 "ml/lexer.mll" + ( store_lexeme lexbuf; comment lexbuf ) +# 2230 "ml/lexer.ml" -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 + | 7 -> +# 581 "ml/lexer.mll" + ( store_lexeme lexbuf; comment lexbuf ) +# 2235 "ml/lexer.ml" - | 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 + | 8 -> +# 583 "ml/lexer.mll" + ( store_lexeme lexbuf; comment lexbuf ) +# 2240 "ml/lexer.ml" - | 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 + | 9 -> +# 585 "ml/lexer.mll" + ( store_lexeme lexbuf; comment lexbuf ) +# 2245 "ml/lexer.ml" -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] *) + | 10 -> +# 587 "ml/lexer.mll" + ( match !comment_start_loc with + | [] -> assert false + | loc :: _ -> + let start = List.hd (List.rev !comment_start_loc) in + comment_start_loc := []; + raise (Error (Unterminated_comment start, loc)) + ) +# 2256 "ml/lexer.ml" -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 + | 11 -> +# 595 "ml/lexer.mll" + ( update_loc lexbuf None 1 false 0; + store_lexeme lexbuf; + comment lexbuf + ) +# 2264 "ml/lexer.ml" - | _ -> simple_expr ctxt f x + | 12 -> +# 600 "ml/lexer.mll" + ( store_lexeme lexbuf; comment lexbuf ) +# 2269 "ml/lexer.ml" -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 + | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; + __ocaml_lex_comment_rec lexbuf __ocaml_lex_state -and attributes ctxt f l = - List.iter (attribute ctxt f) l +and string lexbuf = + lexbuf.Lexing.lex_mem <- Array.make 2 (-1); __ocaml_lex_string_rec lexbuf 169 +and __ocaml_lex_string_rec lexbuf __ocaml_lex_state = + match Lexing.new_engine __ocaml_lex_tables __ocaml_lex_state lexbuf with + | 0 -> +# 604 "ml/lexer.mll" + ( () ) +# 2281 "ml/lexer.ml" -and item_attributes ctxt f l = - List.iter (item_attribute ctxt f) l + | 1 -> +let +# 605 "ml/lexer.mll" + space +# 2287 "ml/lexer.ml" += Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_mem.(0) lexbuf.Lexing.lex_curr_pos in +# 606 "ml/lexer.mll" + ( update_loc lexbuf None 1 false (String.length space); + if in_comment () then store_lexeme lexbuf; + string lexbuf + ) +# 2294 "ml/lexer.ml" -and attribute ctxt f (s, e) = - pp f "@[<2>[@@%s@ %a]@]" s.txt (payload ctxt) e + | 2 -> +# 611 "ml/lexer.mll" + ( store_escaped_char lexbuf + (char_for_backslash(Lexing.lexeme_char lexbuf 1)); + string lexbuf ) +# 2301 "ml/lexer.ml" -and item_attribute ctxt f (s, e) = - pp f "@[<2>[@@@@%s@ %a]@]" s.txt (payload ctxt) e + | 3 -> +# 615 "ml/lexer.mll" + ( store_escaped_char lexbuf (char_for_decimal_code lexbuf 1); + string lexbuf ) +# 2307 "ml/lexer.ml" -and floating_attribute ctxt f (s, e) = - pp f "@[<2>[@@@@@@%s@ %a]@]" s.txt (payload ctxt) e + | 4 -> +# 618 "ml/lexer.mll" + ( store_escaped_char lexbuf (char_for_octal_code lexbuf 2); + string lexbuf ) +# 2313 "ml/lexer.ml" -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 + | 5 -> +# 621 "ml/lexer.mll" + ( store_escaped_char lexbuf (char_for_hexadecimal_code lexbuf 2); + string lexbuf ) +# 2319 "ml/lexer.ml" - ) x + | 6 -> +# 624 "ml/lexer.mll" + ( store_escaped_uchar lexbuf (uchar_for_uchar_escape lexbuf); + string lexbuf ) +# 2325 "ml/lexer.ml" -and extension ctxt f (s, e) = - pp f "@[<2>[%%%s@ %a]@]" s.txt (payload ctxt) e + | 7 -> +# 627 "ml/lexer.mll" + ( if not (in_comment ()) then begin +(* Should be an error, but we are very lax. + raise (Error (Illegal_escape (Lexing.lexeme lexbuf), + Location.curr lexbuf)) +*) + let loc = Location.curr lexbuf in + Location.prerr_warning loc Warnings.Illegal_backslash; + end; + store_lexeme lexbuf; + string lexbuf + ) +# 2340 "ml/lexer.ml" -and item_extension ctxt f (s, e) = - pp f "@[<2>[%%%%%s@ %a]@]" s.txt (payload ctxt) e + | 8 -> +# 639 "ml/lexer.mll" + ( if not (in_comment ()) then + Location.prerr_warning (Location.curr lexbuf) Warnings.Eol_in_string; + update_loc lexbuf None 1 false 0; + store_lexeme lexbuf; + string lexbuf + ) +# 2350 "ml/lexer.ml" -and exception_declaration ctxt f ext = - pp f "@[exception@ %a@]" (extension_constructor ctxt) ext + | 9 -> +# 646 "ml/lexer.mll" + ( is_in_string := false; + raise (Error (Unterminated_string, !string_start_loc)) ) +# 2356 "ml/lexer.ml" -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 + | 10 -> +# 649 "ml/lexer.mll" + ( store_string_char(Lexing.lexeme_char lexbuf 0); + string lexbuf ) +# 2362 "ml/lexer.ml" -(* 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 + | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; + __ocaml_lex_string_rec lexbuf __ocaml_lex_state -(* [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 quoted_string delim lexbuf = + __ocaml_lex_quoted_string_rec delim lexbuf 196 +and __ocaml_lex_quoted_string_rec delim lexbuf __ocaml_lex_state = + match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with + | 0 -> +# 654 "ml/lexer.mll" + ( update_loc lexbuf None 1 false 0; + store_lexeme lexbuf; + quoted_string delim lexbuf + ) +# 2377 "ml/lexer.ml" -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 + | 1 -> +# 659 "ml/lexer.mll" + ( is_in_string := false; + raise (Error (Unterminated_string, !string_start_loc)) ) +# 2383 "ml/lexer.ml" -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 + | 2 -> +# 662 "ml/lexer.mll" + ( + let edelim = Lexing.lexeme lexbuf in + let edelim = String.sub edelim 1 (String.length edelim - 2) in + if delim = edelim then () + else (store_lexeme lexbuf; quoted_string delim lexbuf) + ) +# 2393 "ml/lexer.ml" -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 + | 3 -> +# 669 "ml/lexer.mll" + ( store_string_char(Lexing.lexeme_char lexbuf 0); + quoted_string delim lexbuf ) +# 2399 "ml/lexer.ml" -and signature ctxt f x = list ~sep:"@\n" (signature_item ctxt) f x + | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; + __ocaml_lex_quoted_string_rec delim lexbuf __ocaml_lex_state -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 skip_hash_bang lexbuf = + __ocaml_lex_skip_hash_bang_rec lexbuf 205 +and __ocaml_lex_skip_hash_bang_rec lexbuf __ocaml_lex_state = + match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with + | 0 -> +# 674 "ml/lexer.mll" + ( update_loc lexbuf None 3 false 0 ) +# 2411 "ml/lexer.ml" -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 + | 1 -> +# 676 "ml/lexer.mll" + ( update_loc lexbuf None 1 false 0 ) +# 2416 "ml/lexer.ml" -and structure ctxt f x = list ~sep:"@\n" (structure_item ctxt) f x + | 2 -> +# 677 "ml/lexer.mll" + ( () ) +# 2421 "ml/lexer.ml" -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 + | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; + __ocaml_lex_skip_hash_bang_rec lexbuf __ocaml_lex_state -(* 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 +# 679 "ml/lexer.mll" + + let token_with_comments lexbuf = + match !preprocessor with + | None -> token lexbuf + | Some (_init, preprocess) -> preprocess token lexbuf -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 + type newline_state = + | NoLine (* There have been no blank lines yet. *) + | NewLine + (* There have been no blank lines, and the previous + token was a newline. *) + | BlankLine (* There have been blank lines. *) -and type_param ctxt f (ct, a) = - pp f "%s%a" (type_variance a) (core_type ctxt) ct + type doc_state = + | Initial (* There have been no docstrings yet *) + | After of docstring list + (* There have been docstrings, none of which were + preceded by a blank line *) + | Before of docstring list * docstring list * docstring list + (* There have been docstrings, some of which were + preceded by a blank line *) -and type_params ctxt f = function - | [] -> () - | l -> pp f "%a " (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",@;") l + and docstring = Docstrings.docstring -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 " =" + let token lexbuf = + let post_pos = lexeme_end_p lexbuf in + let attach lines docs pre_pos = + let open Docstrings in + match docs, lines with + | Initial, _ -> () + | After a, (NoLine | NewLine) -> + set_post_docstrings post_pos (List.rev a); + set_pre_docstrings pre_pos a; + | After a, BlankLine -> + set_post_docstrings post_pos (List.rev a); + set_pre_extra_docstrings pre_pos (List.rev a) + | Before(a, f, b), (NoLine | NewLine) -> + set_post_docstrings post_pos (List.rev a); + set_post_extra_docstrings post_pos + (List.rev_append f (List.rev b)); + set_floating_docstrings pre_pos (List.rev f); + set_pre_extra_docstrings pre_pos (List.rev a); + set_pre_docstrings pre_pos b + | Before(a, f, b), BlankLine -> + set_post_docstrings post_pos (List.rev a); + set_post_extra_docstrings post_pos + (List.rev_append f (List.rev b)); + set_floating_docstrings pre_pos + (List.rev_append f (List.rev b)); + set_pre_extra_docstrings pre_pos (List.rev a) 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 + let rec loop lines docs lexbuf = + match token_with_comments lexbuf with + | COMMENT (s, loc) -> + add_comment (s, loc); + let lines' = + match lines with + | NoLine -> NoLine + | NewLine -> NoLine + | BlankLine -> BlankLine + in + loop lines' docs lexbuf + | EOL -> + let lines' = + match lines with + | NoLine -> NewLine + | NewLine -> BlankLine + | BlankLine -> BlankLine + in + loop lines' docs lexbuf + | HASH when Rescript_cpp.at_bol lexbuf -> + Rescript_cpp.interpret_directive lexbuf + ~cont:(fun lexbuf -> loop lines docs lexbuf) + ~token_with_comments + | DOCSTRING doc -> + Docstrings.register doc; + add_docstring_comment doc; + let docs' = + if Docstrings.docstring_body doc = "/*" then + match docs with + | Initial -> Before([], [doc], []) + | After a -> Before (a, [doc], []) + | Before(a, f, b) -> Before(a, doc :: b @ f, []) + else + match docs, lines with + | Initial, (NoLine | NewLine) -> After [doc] + | Initial, BlankLine -> Before([], [], [doc]) + | After a, (NoLine | NewLine) -> After (doc :: a) + | After a, BlankLine -> Before (a, [], [doc]) + | Before(a, f, b), (NoLine | NewLine) -> Before(a, f, doc :: b) + | Before(a, f, b), BlankLine -> Before(a, b @ f, [doc]) + in + loop NoLine docs' lexbuf + | tok -> + attach lines docs (lexeme_start_p lexbuf); + tok + in + Rescript_cpp.check_sharp_look_ahead (fun _ -> loop NoLine Initial lexbuf) -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 + let init () = + Rescript_cpp.init (); + is_in_string := false; + comment_start_loc := []; + comment_list := []; + match !preprocessor 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 + | Some (init, _preprocess) -> init () -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 + let set_preprocessor init preprocess = + escaped_newlines := true; + preprocessor := Some (init, preprocess) -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:"" +# 2543 "ml/lexer.ml" -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 +end +module Parse : sig +#1 "parse.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. *) +(* *) +(**************************************************************************) +(** Entry points in the parser *) +val implementation : Lexing.lexbuf -> Parsetree.structure +val interface : Lexing.lexbuf -> Parsetree.signature +val core_type : Lexing.lexbuf -> Parsetree.core_type +val expression : Lexing.lexbuf -> Parsetree.expression +val pattern : Lexing.lexbuf -> Parsetree.pattern -let expression f x = - pp f "@[%a@]" (expression reset_ctxt) x +end = struct +#1 "parse.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. *) +(* *) +(**************************************************************************) -let string_of_expression x = - ignore (flush_str_formatter ()) ; - let f = str_formatter in - expression f x; - flush_str_formatter () +(* Entry points in the parser *) -let string_of_structure x = - ignore (flush_str_formatter ()); - let f = str_formatter in - structure reset_ctxt f x; - flush_str_formatter () +let wrap parsing_fun lexbuf = + try + Docstrings.init (); + Lexer.init (); + let ast = parsing_fun Lexer.token lexbuf in + Parsing.clear_parser(); + Docstrings.warn_bad_docstrings (); + ast + with + | Parsing.Parse_error | Syntaxerr.Escape_error -> + let loc = Location.curr lexbuf in + raise(Syntaxerr.Error(Syntaxerr.Other loc)) -let core_type = core_type reset_ctxt -let pattern = pattern reset_ctxt -let signature = signature reset_ctxt -let structure = structure reset_ctxt +let implementation = wrap Parser.implementation +and interface = wrap Parser.interface +and core_type = wrap Parser.parse_core_type +and expression = wrap Parser.parse_expression +and pattern = wrap Parser.parse_pattern end module Ast_payload : sig @@ -273077,6 +273333,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 = @@ -274596,13 +274871,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 = @@ -275018,6 +275310,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)) @@ -275034,11 +275332,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 = @@ -275072,6 +275373,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 = @@ -275262,7 +275571,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 @@ -275274,6 +275584,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" } *) @@ -275281,12 +275598,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") @@ -275390,8 +275704,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, ...>) => { ... } *) @@ -275467,6 +275785,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)) @@ -275489,10 +275813,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 []) @@ -275601,24 +275928,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 @@ -281551,165 +281876,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" @@ -282218,24 +282384,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 + if Res_utf8.isValidCodePoint c then c else Res_utf8.repl 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 @@ -282262,14 +282427,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 + 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; - ch + Char.code ch in let contents = (String.sub [@doesNotRaise]) scanner.src offset (scanner.offset - offset) @@ -282603,7 +282767,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 @@ -282619,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; @@ -283071,15 +283238,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)" @@ -283171,6 +283329,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; @@ -286695,38 +286855,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 b60dea70328..d70b7c0f588 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 +/-, @@ -186660,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 *) @@ -186677,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. *) @@ -186768,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; + | 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 *) @@ -187443,26 +188149,792 @@ 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; +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; @@ -188634,7 +190106,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" (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 @@ -189343,9 +190815,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 +192397,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" (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 @@ -202551,7 +204023,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 +217825,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 +222918,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 +225432,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 +226077,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 +228527,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 +228784,165 @@ let isKeywordTxt str = 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 + +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" @@ -227878,7 +229530,7 @@ let printConstant ?(templateLiteral = false) c = | Pconst_float (s, _) -> Doc.text s | Pconst_char c -> let str = - match c with + match Char.unsafe_chr c with | '\'' -> "\\'" | '\\' -> "\\\\" | '\n' -> "\\n" @@ -227889,7 +229541,7 @@ let printConstant ?(templateLiteral = false) 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) + | _ -> Res_utf8.encodeCodePoint c in Doc.text ("'" ^ str ^ "'") @@ -230305,6 +231957,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 +232748,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 +247226,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 +247289,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 +249334,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 +249405,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 +254522,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 +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" 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 *) @@ -261433,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" @@ -261441,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" 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 @@ -264243,7 +265962,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 +265999,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 +275204,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 | _ -> @@ -274183,1746 +275902,283 @@ end = struct -(* 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 *) - -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" 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 +(* module E = Js_exp_make *) +(* module S = Js_stmt_make *) -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 +let compile_group (meta : Lam_stats.t) + (x : Lam_group.t) : Js_output.t = + match x with + (* + We need -and structure ctxt f x = list ~sep:"@\n" (structure_item ctxt) f x + 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 + *) -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 + (* QUICK hack to make hello world example nicer, + Note the arity of [print_endline] is already analyzed before, + so it should be safe + *) -(* 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 + | 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 -(* [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 + | 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 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 +(** 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 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 +let _d = fun s lam -> -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 + lam -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 _j = Js_pass_debug.dump -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 +(** 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 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 + 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*) -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_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 @@ -283461,6 +283717,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 = @@ -284980,13 +285255,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 = @@ -285402,6 +285694,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)) @@ -285418,11 +285716,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 = @@ -285456,6 +285757,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 = @@ -285646,7 +285955,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 @@ -285658,6 +285968,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" } *) @@ -285665,12 +285982,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") @@ -285774,8 +286088,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, ...>) => { ... } *) @@ -285851,6 +286169,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)) @@ -285873,10 +286197,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 []) @@ -285985,24 +286312,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 @@ -286405,7 +286730,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; @@ -287273,7 +287598,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; @@ -295083,165 +295408,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" @@ -295750,24 +295916,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 + if Res_utf8.isValidCodePoint c then c else Res_utf8.repl 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 @@ -295794,14 +295959,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 + 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; - ch + Char.code ch in let contents = (String.sub [@doesNotRaise]) scanner.src offset (scanner.offset - offset) @@ -296135,7 +296299,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 @@ -296151,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; @@ -296603,15 +296770,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)" @@ -296703,6 +296861,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; @@ -300227,38 +300387,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 b3dcdd49bde23ec0f49c6607003b97e260604b69 Mon Sep 17 00:00:00 2001 From: butterunderflow Date: Sun, 30 Oct 2022 02:53:42 +0800 Subject: [PATCH 07/10] 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 05237aed31c..7bc42e11644 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 5907149e839..b6cb43989a0 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 0664f4aac51..41b29437aa3 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 6b738376879..d31d11a90be 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 b161db201a4..37d549bb77d 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 5ac5790a444..b531404ef6e 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 7bfb38d172d..a1fec327091 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 f03e1543ee1..113d11f14df 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 894257411f7..7648567382f 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 eb9d0122d87..6f7feeb88a5 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 d70b7c0f588..cdb5cd7f2d3 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 1165667b81b3d13af21b756c7988fd96c9cec15a Mon Sep 17 00:00:00 2001 From: butterunderflow Date: Sun, 30 Oct 2022 04:05:26 +0800 Subject: [PATCH 08/10] (re)use encodeCodepoint to support string_of_int_as_char some refactor libs --- jscomp/ext/ext_utf8.ml | 37 + jscomp/ext/ext_utf8.mli | 2 + jscomp/ext/ext_util.ml | 20 +- 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 | 198 +- lib/4.06.1/rescript.ml.d | 2 + lib/4.06.1/unstable/all_ounit_tests.ml | 337 +- lib/4.06.1/unstable/js_compiler.ml | 7270 +++++++------- lib/4.06.1/unstable/js_playground_compiler.ml | 8406 ++++++++--------- lib/4.06.1/whole_compiler.ml | 7876 ++++++++------- 15 files changed, 12090 insertions(+), 12080 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 281bfb7a0cb..0d02b2c5735 100644 --- a/jscomp/ext/ext_utf8.ml +++ b/jscomp/ext/ext_utf8.ml @@ -92,3 +92,40 @@ let decode_utf8_string s = (* let verify s loc = 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 + 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 2f29717c12a..e1beadec594 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 41b29437aa3..e945e506f1d 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 "\'\\%d\'" 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 + diff --git a/jscomp/ml/pprintast.ml b/jscomp/ml/pprintast.ml index 37d549bb77d..ff817615bbd 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 6bc981131e2..62bddc9122c 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 00000000000..beabaa708ed --- /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 00000000000..27eb975ef75 --- /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 5a9b1bfc4bb..af0d0fa941e 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 46cda2dc3ac..e423a44a7b9 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 a1fec327091..e812aa3a815 100644 --- a/lib/4.06.1/rescript.ml +++ b/lib/4.06.1/rescript.ml @@ -6472,6 +6472,184 @@ 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 = + (* reused from syntax/src/res_utf8.ml *) + 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" @@ -6552,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 "\'\\%d\'" 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/rescript.ml.d b/lib/4.06.1/rescript.ml.d index ebfcb8e90e2..f1950475594 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 113d11f14df..8aee14b3f86 100644 --- a/lib/4.06.1/unstable/all_ounit_tests.ml +++ b/lib/4.06.1/unstable/all_ounit_tests.ml @@ -6388,6 +6388,184 @@ 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 = + (* reused from syntax/src/res_utf8.ml *) + 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" @@ -6468,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 "\'\\%d\'" 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 @@ -34106,145 +34294,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 7648567382f..e2dddb990fd 100644 --- a/lib/4.06.1/unstable/js_compiler.ml +++ b/lib/4.06.1/unstable/js_compiler.ml @@ -24863,6 +24863,184 @@ 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 = + (* reused from syntax/src/res_utf8.ml *) + 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" @@ -24943,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 "\'\\%d\'" 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 @@ -52475,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 @@ -52573,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 @@ -52586,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" @@ -52714,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 = @@ -52981,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; ]) @@ -52991,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 @@ -53013,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 @@ -53022,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 @@ -53056,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 @@ -53117,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 @@ -53130,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 = @@ -53167,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 @@ -53269,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 @@ -53358,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 = @@ -53379,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" *) @@ -53388,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 = @@ -53406,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 = @@ -53445,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 "?" @@ -53492,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 = @@ -53563,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 = @@ -53607,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 = @@ -53650,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 @@ -53839,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 = @@ -53924,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; @@ -53950,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; @@ -54009,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 @@ -54039,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); ]); ]) @@ -54091,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 = @@ -54169,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) : @@ -54275,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 = @@ -54314,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 @@ -54333,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 = @@ -54352,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 = @@ -54370,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 = @@ -54390,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 [ @@ -54412,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 = @@ -54493,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 @@ -54757,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 @@ -54768,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 @@ -54817,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); @@ -54832,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 @@ -54856,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 @@ -54874,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 = @@ -54899,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 = @@ -55122,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 = @@ -55130,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 @@ -55542,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) @@ -55599,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.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; - ]) + 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 + 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.lbrace; printCommentsInside cmtTbl e.pexp_loc; Doc.rbrace ] - else - let spread = - match spreadExpr with - | None -> Doc.nil - | Some expr -> + [ + 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.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 + 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 [ - { - 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 + 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 - 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 + (* 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 attrs = ParsetreeViewer.filterTernaryAttributes e.pexp_attributes in - let needsParens = - match ParsetreeViewer.filterParsingAttrs attrs with - | [] -> false + let punningAllowed = + match (spreadExpr, rows) with + | None, [_] -> false (* disallow punning for single-element records *) | _ -> 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.breakableGroup ~forceBreak (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.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.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" @@ -56345,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; } @@ -56354,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 = @@ -56412,7 +56510,7 @@ and printPexpFun ~customLayout ~inCallback e cmtTbl = | Pexp_construct (_, Some _) | Pexp_record _ ), _ ) -> - true + true | _ -> false in let returnDoc = @@ -56422,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 @@ -56482,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 @@ -56501,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 @@ -56535,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 = @@ -56572,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 = @@ -56581,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 = @@ -56829,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)); ]); @@ -56842,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 "\"" ] - 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 ]); - ]) - 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 - | 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 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 + ( {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 shouldIndentTargetExpr then - Doc.indent (Doc.concat [ Doc.line; targetExpr ]) - else Doc.concat [ Doc.space; targetExpr ]); + (if shouldIndent then + Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) + else Doc.concat [Doc.space; rhsDoc]); ]) - (* TODO: cleanup, are those branches even remotely performant? *) - | Pexp_apply ({ pexp_desc = Pexp_ident lident }, args) - when ParsetreeViewer.isJsxExpression expr -> - printJsxExpression ~customLayout lident args cmtTbl - | Pexp_apply (callExpr, args) -> - let args = - List.map - (fun (lbl, arg) -> (lbl, ParsetreeViewer.rewriteUnderscoreApply arg)) - args + 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 + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc memberExpr braces + | Nothing -> doc in - let uncurried, attrs = - ParsetreeViewer.processUncurriedAttribute expr.pexp_attributes + let shouldInline = + match memberExpr.pexp_desc with + | Pexp_constant _ | Pexp_ident _ -> true + | _ -> false in - let callExprDoc = - let doc = printExpressionWithComments ~customLayout callExpr cmtTbl in - match Parens.callExpr callExpr 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 callExpr braces + | Braced braces -> printBraces doc memberExpr braces | Nothing -> doc 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; - ] + let shouldInline = + match memberExpr.pexp_desc with + | Pexp_constant _ | Pexp_ident _ -> true + | _ -> false + in + if shouldInline then memberDoc else - let argsDoc = printArguments ~customLayout ~uncurried args cmtTbl in Doc.concat - [ printAttributes ~customLayout attrs cmtTbl; callExprDoc; argsDoc ] + [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) + when ParsetreeViewer.isJsxExpression expr -> + 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 + 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 = @@ -57090,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 @@ -57101,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 @@ -57122,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; @@ -57136,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 @@ -57168,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; ]) @@ -57205,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 = @@ -57270,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 = @@ -57284,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 @@ -57336,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 = @@ -57422,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 @@ -57497,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 = @@ -57510,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 @@ -57615,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 ::= @@ -57677,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 @@ -57787,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 @@ -57835,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 = @@ -57851,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 @@ -57867,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 @@ -57885,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 } + {expr.pexp_loc with loc_end = extensionConstructor.pext_loc.loc_end} in - let letExceptionDoc = - printExceptionDef ~customLayout extensionConstructor cmtTbl - 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 = @@ -58155,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; ] @@ -58186,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 @@ -58212,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 @@ -58275,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; @@ -58356,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 @@ -58557,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 = @@ -58618,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 @@ -58634,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 @@ -58678,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 @@ -84085,145 +84122,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 6f7feeb88a5..7a87841aff4 100644 --- a/lib/4.06.1/unstable/js_playground_compiler.ml +++ b/lib/4.06.1/unstable/js_playground_compiler.ml @@ -24863,6 +24863,184 @@ 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 = + (* reused from syntax/src/res_utf8.ml *) + 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" @@ -24943,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 "\'\\%d\'" 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 @@ -52475,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 @@ -52573,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 @@ -52586,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" @@ -52714,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 = @@ -52981,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; ]) @@ -52991,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 @@ -53013,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 @@ -53022,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 @@ -53056,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 @@ -53117,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 @@ -53130,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 = @@ -53167,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 @@ -53269,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 @@ -53358,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 = @@ -53379,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" *) @@ -53388,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 = @@ -53406,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 = @@ -53445,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 "?" @@ -53492,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 = @@ -53563,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 = @@ -53607,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 = @@ -53650,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 @@ -53839,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 = @@ -53924,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; @@ -53950,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; @@ -54009,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 @@ -54039,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); ]); ]) @@ -54091,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 = @@ -54169,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) : @@ -54275,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 = @@ -54314,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 @@ -54333,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 = @@ -54352,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 = @@ -54370,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 = @@ -54390,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 [ @@ -54412,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 = @@ -54493,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 @@ -54757,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 @@ -54768,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 @@ -54817,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); @@ -54832,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 @@ -54856,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 @@ -54874,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 = @@ -54899,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 = @@ -55122,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 = @@ -55130,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 @@ -55542,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) @@ -55599,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" @@ -56345,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; } @@ -56354,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 = @@ -56412,7 +56510,7 @@ and printPexpFun ~customLayout ~inCallback e cmtTbl = | Pexp_construct (_, Some _) | Pexp_record _ ), _ ) -> - true + true | _ -> false in let returnDoc = @@ -56422,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 @@ -56482,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 @@ -56501,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 @@ -56535,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 = @@ -56572,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 = @@ -56581,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 = @@ -56829,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)); ]); @@ -56842,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 = @@ -57090,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 @@ -57101,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 @@ -57122,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; @@ -57136,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 @@ -57168,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; ]) @@ -57205,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 = @@ -57270,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 = @@ -57284,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 @@ -57336,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 = @@ -57422,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 @@ -57497,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 = @@ -57510,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 @@ -57615,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 ::= @@ -57677,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 @@ -57787,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 @@ -57835,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 = @@ -57851,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 @@ -57867,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 @@ -57885,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 = @@ -58155,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; ] @@ -58186,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 @@ -58212,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 @@ -58275,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; @@ -58356,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 @@ -58557,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 = @@ -58618,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 @@ -58634,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 @@ -58678,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 @@ -83898,198 +83935,127 @@ 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 loc = Location.t - -type attrs = Parsetree.attribute list - -open Parsetree - -let default_loc = Location.none - -let arrow ?loc ?attrs a b = Ast_helper.Typ.arrow ?loc ?attrs Nolabel a b - -let apply_simple ?(loc = default_loc) ?(attrs = []) (fn : expression) - (args : expression list) : expression = - { - pexp_loc = loc; - pexp_attributes = attrs; - pexp_desc = - Pexp_apply (fn, Ext_list.map args (fun x -> (Asttypes.Nolabel, x))); - } - -let app1 ?(loc = default_loc) ?(attrs = []) fn arg1 : expression = - { - pexp_loc = loc; - pexp_attributes = attrs; - pexp_desc = Pexp_apply (fn, [ (Nolabel, arg1) ]); - } - -let app2 ?(loc = default_loc) ?(attrs = []) fn arg1 arg2 : expression = - { - pexp_loc = loc; - pexp_attributes = attrs; - pexp_desc = Pexp_apply (fn, [ (Nolabel, arg1); (Nolabel, arg2) ]); - } - -let app3 ?(loc = default_loc) ?(attrs = []) fn arg1 arg2 arg3 : expression = - { - pexp_loc = loc; - pexp_attributes = attrs; - pexp_desc = - Pexp_apply (fn, [ (Nolabel, arg1); (Nolabel, arg2); (Nolabel, arg3) ]); - } - -let fun_ ?(loc = default_loc) ?(attrs = []) pat exp = - { - pexp_loc = loc; - pexp_attributes = attrs; - pexp_desc = Pexp_fun (Nolabel, None, pat, exp); - } - -let const_exp_string ?(loc = default_loc) ?(attrs = []) ?delimiter (s : string) - : expression = - { - pexp_loc = loc; - pexp_attributes = attrs; - pexp_desc = Pexp_constant (Pconst_string (s, delimiter)); - } - -let const_exp_int ?(loc = default_loc) ?(attrs = []) (s : int) : expression = - { - pexp_loc = loc; - pexp_attributes = attrs; - pexp_desc = Pexp_constant (Pconst_integer (string_of_int s, None)); - } - -let apply_labels ?(loc = default_loc) ?(attrs = []) fn - (args : (string * expression) list) : expression = - { - pexp_loc = loc; - pexp_attributes = attrs; - pexp_desc = - Pexp_apply (fn, Ext_list.map args (fun (l, a) -> (Asttypes.Labelled l, a))); - } - -let label_arrow ?(loc = default_loc) ?(attrs = []) s a b : core_type = - { - ptyp_desc = Ptyp_arrow (Asttypes.Labelled s, a, b); - ptyp_loc = loc; - ptyp_attributes = attrs; - } - -let opt_arrow ?(loc = default_loc) ?(attrs = []) s a b : core_type = - { - ptyp_desc = Ptyp_arrow (Asttypes.Optional s, a, b); - ptyp_loc = loc; - ptyp_attributes = attrs; - } - -let rec_type_str ?(loc = default_loc) rf tds : structure_item = - { pstr_loc = loc; pstr_desc = Pstr_type (rf, tds) } - -let rec_type_sig ?(loc = default_loc) rf tds : signature_item = - { psig_loc = loc; psig_desc = Psig_type (rf, tds) } - -(* FIXME: need address migration of `[@nonrec]` attributes in older ocaml *) -(* let nonrec_type_sig ?(loc=default_loc) tds : signature_item = - { - psig_loc = loc; - psig_desc = Psig_type ( - Nonrecursive, - tds) - } *) - -let const_exp_int_list_as_array xs = - Ast_helper.Exp.array (Ext_list.map xs (fun x -> const_exp_int x)) - -(* let const_exp_string_list_as_array xs = - Ast_helper.Exp.array - (Ext_list.map xs (fun x -> const_exp_string x ) ) *) - - - -type object_field = Parsetree.object_field - -let object_field l attrs ty = Parsetree.Otag (l, attrs, ty) - -type args = (Asttypes.arg_label * Parsetree.expression) list - -end -module Ext_char : sig -#1 "ext_char.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. *) - -(** Extension to Standard char module, avoid locale sensitivity *) +type loc = Location.t -val valid_hex : char -> bool +type attrs = Parsetree.attribute list -val is_lower_case : char -> bool +open Parsetree -end = struct -#1 "ext_char.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. *) +let default_loc = Location.none -(** {!Char.escaped} is locale sensitive in 4.02.3, fixed in the trunk, - backport it here -*) +let arrow ?loc ?attrs a b = Ast_helper.Typ.arrow ?loc ?attrs Nolabel a b -let valid_hex x = - match x with '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true | _ -> false +let apply_simple ?(loc = default_loc) ?(attrs = []) (fn : expression) + (args : expression list) : expression = + { + pexp_loc = loc; + pexp_attributes = attrs; + pexp_desc = + Pexp_apply (fn, Ext_list.map args (fun x -> (Asttypes.Nolabel, x))); + } -let is_lower_case c = - (c >= 'a' && c <= 'z') - || (c >= '\224' && c <= '\246') - || (c >= '\248' && c <= '\254') +let app1 ?(loc = default_loc) ?(attrs = []) fn arg1 : expression = + { + pexp_loc = loc; + pexp_attributes = attrs; + pexp_desc = Pexp_apply (fn, [ (Nolabel, arg1) ]); + } + +let app2 ?(loc = default_loc) ?(attrs = []) fn arg1 arg2 : expression = + { + pexp_loc = loc; + pexp_attributes = attrs; + pexp_desc = Pexp_apply (fn, [ (Nolabel, arg1); (Nolabel, arg2) ]); + } + +let app3 ?(loc = default_loc) ?(attrs = []) fn arg1 arg2 arg3 : expression = + { + pexp_loc = loc; + pexp_attributes = attrs; + pexp_desc = + Pexp_apply (fn, [ (Nolabel, arg1); (Nolabel, arg2); (Nolabel, arg3) ]); + } + +let fun_ ?(loc = default_loc) ?(attrs = []) pat exp = + { + pexp_loc = loc; + pexp_attributes = attrs; + pexp_desc = Pexp_fun (Nolabel, None, pat, exp); + } + +let const_exp_string ?(loc = default_loc) ?(attrs = []) ?delimiter (s : string) + : expression = + { + pexp_loc = loc; + pexp_attributes = attrs; + pexp_desc = Pexp_constant (Pconst_string (s, delimiter)); + } + +let const_exp_int ?(loc = default_loc) ?(attrs = []) (s : int) : expression = + { + pexp_loc = loc; + pexp_attributes = attrs; + pexp_desc = Pexp_constant (Pconst_integer (string_of_int s, None)); + } + +let apply_labels ?(loc = default_loc) ?(attrs = []) fn + (args : (string * expression) list) : expression = + { + pexp_loc = loc; + pexp_attributes = attrs; + pexp_desc = + Pexp_apply (fn, Ext_list.map args (fun (l, a) -> (Asttypes.Labelled l, a))); + } + +let label_arrow ?(loc = default_loc) ?(attrs = []) s a b : core_type = + { + ptyp_desc = Ptyp_arrow (Asttypes.Labelled s, a, b); + ptyp_loc = loc; + ptyp_attributes = attrs; + } + +let opt_arrow ?(loc = default_loc) ?(attrs = []) s a b : core_type = + { + ptyp_desc = Ptyp_arrow (Asttypes.Optional s, a, b); + ptyp_loc = loc; + ptyp_attributes = attrs; + } + +let rec_type_str ?(loc = default_loc) rf tds : structure_item = + { pstr_loc = loc; pstr_desc = Pstr_type (rf, tds) } + +let rec_type_sig ?(loc = default_loc) rf tds : signature_item = + { psig_loc = loc; psig_desc = Psig_type (rf, tds) } + +(* FIXME: need address migration of `[@nonrec]` attributes in older ocaml *) +(* let nonrec_type_sig ?(loc=default_loc) tds : signature_item = + { + psig_loc = loc; + psig_desc = Psig_type ( + Nonrecursive, + tds) + } *) + +let const_exp_int_list_as_array xs = + Ast_helper.Exp.array (Ext_list.map xs (fun x -> const_exp_int x)) + +(* let const_exp_string_list_as_array xs = + Ast_helper.Exp.array + (Ext_list.map xs (fun x -> const_exp_string x ) ) *) + + + +type object_field = Parsetree.object_field + +let object_field l attrs ty = Parsetree.Otag (l, attrs, ty) + +type args = (Asttypes.arg_label * Parsetree.expression) list end -module Ext_utf8 : sig -#1 "ext_utf8.mli" +module Ext_char : sig +#1 "ext_char.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 @@ -84107,30 +84073,21 @@ module Ext_utf8 : 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. *) -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 -*) +(** Extension to Standard char module, avoid locale sensitivity *) -exception Invalid_utf8 of string +val valid_hex : char -> bool -val decode_utf8_string : string -> int list +val is_lower_case : char -> bool end = struct -#1 "ext_utf8.ml" +#1 "ext_char.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 @@ -84148,81 +84105,22 @@ 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 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 +(** {!Char.escaped} is locale sensitive in 4.02.3, fixed in the trunk, + backport it here *) -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 valid_hex x = + match x with '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true | _ -> false -(* let verify s loc = - assert false *) +let is_lower_case c = + (c >= 'a' && c <= 'z') + || (c >= '\224' && c <= '\246') + || (c >= '\248' && c <= '\254') end module Ast_utf8_string : sig @@ -282217,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 = @@ -282244,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. @@ -282286,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 ' '; @@ -282301,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; @@ -282353,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 ( @@ -282370,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 *) @@ -282381,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; @@ -282400,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 @@ -282410,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 @@ -282424,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; @@ -282454,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 = @@ -282469,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 *) @@ -282494,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? *) @@ -282542,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" @@ -282578,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 *) @@ -282611,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 @@ -282668,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) @@ -282717,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 @@ -282727,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))) @@ -282751,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 @@ -282770,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 = @@ -282789,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 @@ -282842,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; *) @@ -283152,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 cdb5cd7f2d3..b46d12963b5 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,43 @@ let decode_utf8_string s = (* let verify s loc = 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 + 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" @@ -179666,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 "\'\\%d\'" 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 @@ -228586,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 @@ -228684,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 @@ -228697,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" @@ -228825,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 = @@ -229092,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; ]) @@ -229102,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 @@ -229124,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 @@ -229133,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 @@ -229167,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 @@ -229228,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 @@ -229241,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 = @@ -229278,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 @@ -229380,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 @@ -229469,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 = @@ -229490,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" *) @@ -229499,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 = @@ -229517,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 = @@ -229556,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 "?" @@ -229603,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 = @@ -229674,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 = @@ -229718,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 = @@ -229761,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 @@ -229950,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 = @@ -230035,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; @@ -230061,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; @@ -230120,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 @@ -230150,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); ]); ]) @@ -230202,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 = @@ -230280,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) : @@ -230386,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 = @@ -230425,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 @@ -230444,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 = @@ -230463,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 = @@ -230481,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 = @@ -230501,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 [ @@ -230523,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 = @@ -230604,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 @@ -230868,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 @@ -230879,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 @@ -230928,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); @@ -230943,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 @@ -230967,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 @@ -230985,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 = @@ -231010,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) -> - Doc.group - (Doc.concat - [ - attrs; - header; - printPattern ~customLayout pattern cmtTbl; - Doc.text ":"; - Doc.indent - (Doc.concat + 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; - 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>) - *) + 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 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 = @@ -231233,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 = @@ -231241,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 @@ -231653,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) @@ -231710,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" @@ -232456,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; } @@ -232465,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 = @@ -232523,7 +232482,7 @@ and printPexpFun ~customLayout ~inCallback e cmtTbl = | Pexp_construct (_, Some _) | Pexp_record _ ), _ ) -> - true + true | _ -> false in let returnDoc = @@ -232533,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 @@ -232593,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 @@ -232612,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 @@ -232646,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 = @@ -232683,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 = @@ -232692,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 = @@ -232940,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)); ]); @@ -232953,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 = @@ -233201,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 @@ -233212,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 @@ -233233,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; @@ -233247,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 @@ -233279,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; ]) @@ -233316,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 = @@ -233381,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 = @@ -233395,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 @@ -233447,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 = @@ -233533,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 @@ -233608,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 = @@ -233621,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 @@ -233726,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 ::= @@ -233788,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 @@ -233898,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 @@ -233946,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 = @@ -233962,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 @@ -233978,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 @@ -233996,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 = @@ -234266,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; ] @@ -234297,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 @@ -234323,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 @@ -234386,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; @@ -234467,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 @@ -234668,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 = @@ -234729,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 @@ -234745,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 @@ -234789,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 @@ -295749,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 = @@ -295776,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. @@ -295818,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 ' '; @@ -295833,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; @@ -295885,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 ( @@ -295902,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 *) @@ -295913,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; @@ -295932,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 @@ -295942,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 @@ -295956,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; @@ -295986,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 = @@ -296001,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 *) @@ -296026,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? *) @@ -296074,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" @@ -296110,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 *) @@ -296143,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 @@ -296200,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) @@ -296249,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 @@ -296259,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))) @@ -296283,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 @@ -296302,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 = @@ -296321,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 @@ -296374,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; *) @@ -296684,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 8899b1a86baf8493edf584a376d5549fbb4e88a4 Mon Sep 17 00:00:00 2001 From: butterunderflow Date: Mon, 31 Oct 2022 10:42:47 +0800 Subject: [PATCH 09/10] changelog --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index eb4e0cd223e..39db25f8467 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -58,6 +58,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 From d5de029d7f3ed755f40b062127859618023032cb Mon Sep 17 00:00:00 2001 From: butterunderflow <935021934@qq.com> Date: Mon, 31 Oct 2022 15:26:12 +0800 Subject: [PATCH 10/10] CHANGELOG.md --- CHANGELOG.md | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 39db25f8467..dce3b4da04c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -13,6 +13,8 @@ # 10.1.0-rc.3 - Fix issue where the JSX key type is not an optional string https://github.com/rescript-lang/syntax/pull/693 +- Change the payload of Pconst_char for type safety. https://github.com/rescript-lang/syntax/pull/709 https://github.com/rescript-lang/rescript-compiler/pull/5749 + # 10.1.0-rc.2 @@ -58,7 +60,6 @@ - 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