From 8a2f20262e21e3139d33331f584a453578a89920 Mon Sep 17 00:00:00 2001 From: Guillaume Petiot Date: Fri, 12 Jan 2024 20:12:00 +0100 Subject: [PATCH 001/146] Update vendored compilerlibs for OCaml 5.2 --- vendor/parser-shims/ocamlformat_parser_shims.mli | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/parser-shims/ocamlformat_parser_shims.mli b/vendor/parser-shims/ocamlformat_parser_shims.mli index f83ad1e621..1d87299938 100644 --- a/vendor/parser-shims/ocamlformat_parser_shims.mli +++ b/vendor/parser-shims/ocamlformat_parser_shims.mli @@ -33,7 +33,7 @@ module Misc : sig end module Style : sig - val as_inline_code: (Format.formatter -> 'a -> unit as 'printer) -> 'printer + val as_inline_code: (Format.formatter -> 'a -> unit as 'printer) -> 'printer (** @since ocaml-5.2 *) val inline_code: Format.formatter -> string -> unit From b86e1a90e9126435c5929a462f1d548a3dacf1d3 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Thu, 18 Jan 2024 18:18:34 +0100 Subject: [PATCH 002/146] WIP: Backport 5.2 changes to parser-standard TODO: Compiler libs shims are needed in Load_path and Builtin_attributes. --- vendor/parser-standard/ast_helper.ml | 18 +- vendor/parser-standard/ast_mapper.ml | 57 +++- vendor/parser-standard/lexer.mll | 68 +++-- vendor/parser-standard/parser.mly | 385 ++++++++++++++++++++------- vendor/parser-standard/parsetree.mli | 100 +++++-- vendor/parser-standard/printast.ml | 47 +++- 6 files changed, 519 insertions(+), 156 deletions(-) diff --git a/vendor/parser-standard/ast_helper.ml b/vendor/parser-standard/ast_helper.ml index ae65b50931..184049f0cb 100644 --- a/vendor/parser-standard/ast_helper.ml +++ b/vendor/parser-standard/ast_helper.ml @@ -72,6 +72,7 @@ module Typ = struct let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b)) let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b)) let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a) + let open_ ?loc ?attrs mod_ident t = mk ?loc ?attrs (Ptyp_open (mod_ident, t)) let force_poly t = match t.ptyp_desc with @@ -102,9 +103,9 @@ module Typ = struct Ptyp_object (List.map loop_object_field lst, o) | Ptyp_class (longident, lst) -> Ptyp_class (longident, List.map loop lst) - | Ptyp_alias(core_type, string) -> - check_variable var_names t.ptyp_loc string; - Ptyp_alias(loop core_type, string) + | Ptyp_alias(core_type, alias) -> + check_variable var_names alias.loc alias.txt; + Ptyp_alias(loop core_type, alias) | Ptyp_variant(row_field_list, flag, lbl_lst_option) -> Ptyp_variant(List.map loop_row_field row_field_list, flag, lbl_lst_option) @@ -114,6 +115,8 @@ module Typ = struct Ptyp_poly(string_lst, loop core_type) | Ptyp_package(longident,lst) -> Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst) + | Ptyp_open (mod_ident, core_type) -> + Ptyp_open (mod_ident, loop core_type) | Ptyp_extension (s, arg) -> Ptyp_extension (s, arg) in @@ -178,8 +181,7 @@ module Exp = struct let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c)) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d)) - let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a) + let function_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_function (a, b, c)) let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b)) let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) @@ -213,7 +215,9 @@ module Exp = struct mk ?loc ?attrs (Pexp_letop {let_; ands; body}) let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a) let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable - let hole ?loc ?attrs () = mk ?loc ?attrs Pexp_hole + (* Added *) + let hole ?loc ?attrs () = mk ?loc ?attrs Pexp_hole + (* *) let case lhs ?guard rhs = { @@ -259,7 +263,9 @@ module Mod = struct let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty)) let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e) let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a) + (* Added *) let hole ?loc ?attrs () = mk ?loc ?attrs Pmod_hole + (* *) end module Sig = struct diff --git a/vendor/parser-standard/ast_mapper.ml b/vendor/parser-standard/ast_mapper.ml index 0bb017ddfc..3a40592616 100644 --- a/vendor/parser-standard/ast_mapper.ml +++ b/vendor/parser-standard/ast_mapper.ml @@ -20,6 +20,9 @@ (* Ensure that record patterns don't miss any field. *) *) +[@@@ocaml.warning "-60"] module Str = Ast_helper.Str (* For ocamldep *) +[@@@ocaml.warning "+60"] + open Parsetree open Ast_helper open Location @@ -45,6 +48,7 @@ type mapper = { constant: mapper -> constant -> constant; constructor_declaration: mapper -> constructor_declaration -> constructor_declaration; + directive_argument: mapper -> directive_argument -> directive_argument; expr: mapper -> expression -> expression; extension: mapper -> extension -> extension; extension_constructor: mapper -> extension_constructor @@ -68,6 +72,8 @@ type mapper = { signature_item: mapper -> signature_item -> signature_item; structure: mapper -> structure -> structure; structure_item: mapper -> structure_item -> structure_item; + toplevel_directive: mapper -> toplevel_directive -> toplevel_directive; + toplevel_phrase: mapper -> toplevel_phrase -> toplevel_phrase; typ: mapper -> core_type -> core_type; type_declaration: mapper -> type_declaration -> type_declaration; type_extension: mapper -> type_extension -> type_extension; @@ -76,9 +82,6 @@ type mapper = { value_binding: mapper -> value_binding -> value_binding; value_description: mapper -> value_description -> value_description; with_constraint: mapper -> with_constraint -> with_constraint; - directive_argument: mapper -> directive_argument -> directive_argument; - toplevel_directive: mapper -> toplevel_directive -> toplevel_directive; - toplevel_phrase: mapper -> toplevel_phrase -> toplevel_phrase; } let map_fst f (x, y) = (f x, y) @@ -147,7 +150,9 @@ module T = struct object_ ~loc ~attrs (List.map (object_field sub) l) o | Ptyp_class (lid, tl) -> class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s + | Ptyp_alias (t, s) -> + let s = map_loc sub s in + alias ~loc ~attrs (sub.typ sub t) s | Ptyp_variant (rl, b, ll) -> variant ~loc ~attrs (List.map (row_field sub) rl) b ll | Ptyp_poly (sl, t) -> poly ~loc ~attrs @@ -155,6 +160,8 @@ module T = struct | Ptyp_package (lid, l) -> package ~loc ~attrs (map_loc sub lid) (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) + | Ptyp_open (mod_ident, t) -> + open_ ~loc ~attrs (map_loc sub mod_ident) (sub.typ sub t) | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x) let map_type_declaration sub @@ -360,7 +367,9 @@ module M = struct (sub.module_type sub mty) | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e) | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x) + (* Added *) | Pmod_hole -> hole ~loc ~attrs () + (* *) let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = let open Str in @@ -391,6 +400,35 @@ end module E = struct (* Value expressions for the core language *) + let map_function_param sub { pparam_loc = loc; pparam_desc = desc } = + let loc = sub.location sub loc in + let desc = + match desc with + | Pparam_val (lab, def, p) -> + Pparam_val + (lab, + map_opt (sub.expr sub) def, + sub.pat sub p) + | Pparam_newtype ty -> + Pparam_newtype (map_loc sub ty) + in + { pparam_loc = loc; pparam_desc = desc } + + let map_function_body sub body = + match body with + | Pfunction_body e -> + Pfunction_body (sub.expr sub e) + | Pfunction_cases (cases, loc, attributes) -> + let cases = sub.cases sub cases in + let loc = sub.location sub loc in + let attributes = sub.attributes sub attributes in + Pfunction_cases (cases, loc, attributes) + + let map_constraint sub c = + match c with + | Pconstraint ty -> Pconstraint (sub.typ sub ty) + | Pcoerce (ty1, ty2) -> Pcoerce (map_opt (sub.typ sub) ty1, sub.typ sub ty2) + let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = let open Exp in let loc = sub.location sub loc in @@ -401,10 +439,11 @@ module E = struct | Pexp_let (r, vbs, e) -> let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) (sub.expr sub e) - | Pexp_fun (lab, def, p, e) -> - fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p) - (sub.expr sub e) - | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel) + | Pexp_function (ps, c, b) -> + function_ ~loc ~attrs + (List.map (map_function_param sub) ps) + (map_opt (map_constraint sub) c) + (map_function_body sub b) | Pexp_apply (e, l) -> apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) | Pexp_match (e, pel) -> @@ -469,7 +508,9 @@ module E = struct (List.map (sub.binding_op sub) ands) (sub.expr sub body) | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x) | Pexp_unreachable -> unreachable ~loc ~attrs () + (* Added *) | Pexp_hole -> hole ~loc ~attrs () + (* *) let map_binding_op sub {pbop_op; pbop_pat; pbop_exp; pbop_loc} = let open Exp in diff --git a/vendor/parser-standard/lexer.mll b/vendor/parser-standard/lexer.mll index dcaa9d89d1..d74edb17e7 100644 --- a/vendor/parser-standard/lexer.mll +++ b/vendor/parser-standard/lexer.mll @@ -107,7 +107,34 @@ let get_stored_string () = Buffer.contents string_buffer let store_string_char c = Buffer.add_char string_buffer c let store_string_utf_8_uchar u = Buffer.add_utf_8_uchar string_buffer u let store_string s = Buffer.add_string string_buffer s +let store_substring s ~pos ~len = Buffer.add_substring string_buffer s pos len + let store_lexeme lexbuf = store_string (Lexing.lexeme lexbuf) +let store_normalized_newline newline = + (* #12502: we normalize "\r\n" to "\n" at lexing time, + to avoid behavior difference due to OS-specific + newline characters in string literals. + + (For example, Git for Windows will translate \n in versioned + files into \r\n sequences when checking out files on Windows. If + your code contains multiline quoted string literals, the raw + content of the string literal would be different between Git for + Windows users and all other users. Thanks to newline + normalization, the value of the literal as a string constant will + be the same no matter which programming tools are used.) + + Many programming languages use the same approach, for example + Java, Javascript, Kotlin, Python, Swift and C++. + *) + (* Our 'newline' regexp accepts \r*\n, but we only wish + to normalize \r?\n into \n -- see the discussion in #12502. + All carriage returns except for the (optional) last one + are reproduced in the output. We implement this by skipping + the first carriage return, if any. *) + let len = String.length newline in + if len = 1 + then store_string_char '\n' + else store_substring newline ~pos:1 ~len:(len - 1) (* To store the position of the beginning of a string and comment *) let string_start_loc = ref Location.none @@ -338,7 +365,7 @@ let prepare_error loc = function Location.error ~loc ~sub msg | Keyword_as_label kwd -> Location.errorf ~loc - "`%s' is a keyword, it cannot be used as label name" kwd + "%a is a keyword, it cannot be used as label name" Style.inline_code kwd | Invalid_literal s -> Location.errorf ~loc "Invalid literal %s" s | Invalid_directive (dir, explanation) -> @@ -403,6 +430,7 @@ let hex_float_literal = ('.' ['0'-'9' 'A'-'F' 'a'-'f' '_']* )? (['p' 'P'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']* )? let literal_modifier = ['G'-'Z' 'g'-'z'] +let raw_ident_escape = "\\#" rule token = parse | ('\\' as bs) newline { @@ -421,6 +449,8 @@ rule token = parse | ".~" { error lexbuf (Reserved_sequence (".~", Some "is reserved for use in MetaOCaml")) } + | "~" raw_ident_escape (lowercase identchar * as name) ':' + { LABEL name } | "~" (lowercase identchar * as name) ':' { check_label_name lexbuf name; LABEL name } @@ -429,12 +459,16 @@ rule token = parse LABEL name } | "?" { QUESTION } + | "?" raw_ident_escape (lowercase identchar * as name) ':' + { OPTLABEL name } | "?" (lowercase identchar * as name) ':' { check_label_name lexbuf name; OPTLABEL name } | "?" (lowercase_latin1 identchar_latin1 * as name) ':' { warn_latin1 lexbuf; OPTLABEL name } + | raw_ident_escape (lowercase identchar * as name) + { LIDENT name } | lowercase identchar * as name { try Hashtbl.find keyword_table name with Not_found -> LIDENT name } @@ -493,7 +527,7 @@ rule token = parse { CHAR(char_for_octal_code lexbuf 3) } | "\'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "\'" { CHAR(char_for_hexadecimal_code lexbuf 3) } - | "\'" ("\\" _ as esc) + | "\'" ("\\" [^ '#'] as esc) { error lexbuf (Illegal_escape (esc, None)) } | "\'\'" { error lexbuf Empty_character_literal } @@ -676,9 +710,11 @@ and comment = parse comment lexbuf } | "\'\'" { store_lexeme lexbuf; comment lexbuf } - | "\'" newline "\'" + | "\'" (newline as nl) "\'" { update_loc lexbuf None 1 false 1; - store_lexeme lexbuf; + store_string_char '\''; + store_normalized_newline nl; + store_string_char '\''; comment lexbuf } | "\'" [^ '\\' '\'' '\010' '\013' ] "\'" @@ -699,9 +735,9 @@ and comment = parse comment_start_loc := []; error_loc loc (Unterminated_comment start) } - | newline + | newline as nl { update_loc lexbuf None 1 false 0; - store_lexeme lexbuf; + store_normalized_newline nl; comment lexbuf } | ident @@ -712,9 +748,13 @@ and comment = parse and string = parse '\"' { lexbuf.lex_start_p } - | '\\' newline ([' ' '\t'] * as space) + | '\\' (newline as nl) ([' ' '\t'] * as space) { update_loc lexbuf None 1 false (String.length space); - if in_comment () then store_lexeme lexbuf; + if in_comment () then begin + store_string_char '\\'; + store_normalized_newline nl; + store_string space; + end; string lexbuf } | '\\' (['\\' '\'' '\"' 'n' 't' 'b' 'r' ' '] as c) @@ -743,11 +783,9 @@ and string = parse store_lexeme lexbuf; string lexbuf } - | newline - { 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; + | newline as nl + { update_loc lexbuf None 1 false 0; + store_normalized_newline nl; string lexbuf } | eof @@ -758,9 +796,9 @@ and string = parse string lexbuf } and quoted_string delim = parse - | newline + | newline as nl { update_loc lexbuf None 1 false 0; - store_lexeme lexbuf; + store_normalized_newline nl; quoted_string delim lexbuf } | eof diff --git a/vendor/parser-standard/parser.mly b/vendor/parser-standard/parser.mly index 3785f49787..ba160f09c6 100644 --- a/vendor/parser-standard/parser.mly +++ b/vendor/parser-standard/parser.mly @@ -24,6 +24,9 @@ %{ +[@@@ocaml.warning "-60"] module Str = Ast_helper.Str (* For ocamldep *) +[@@@ocaml.warning "+60"] + open Asttypes open Longident open Parsetree @@ -164,6 +167,10 @@ let mkuplus ~oploc name arg = | _ -> Pexp_apply(mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg]) +let mk_attr ~loc name payload = + Builtin_attributes.(register_attr Parser name); + Attr.mk ~loc name payload + (* TODO define an abstraction boundary between locations-as-pairs and locations-as-Location.t; it should be clear when we move from one world to the other *) @@ -206,11 +213,13 @@ let rec mktailpat nilloc = let open Location in function let mkstrexp e attrs = { pstr_desc = Pstr_eval (e, attrs); pstr_loc = e.pexp_loc } -let mkexp_constraint ~loc e (t1, t2) = - match t1, t2 with - | Some t, None -> mkexp ~loc (Pexp_constraint(e, t)) - | _, Some t -> mkexp ~loc (Pexp_coerce(e, t1, t)) - | None, None -> assert false +let mkexp_desc_constraint e t = + match t with + | Pconstraint t -> Pexp_constraint(e, t) + | Pcoerce(t1, t2) -> Pexp_coerce(e, t1, t2) + +let mkexp_constraint ~loc e t = + mkexp ~loc (mkexp_desc_constraint e t) let mkexp_opt_constraint ~loc e = function | None -> e @@ -584,6 +593,64 @@ let class_of_let_bindings ~loc lbs body = assert (lbs.lbs_extension = None); mkclass ~loc (Pcl_let (lbs.lbs_rec, List.rev bindings, body)) +(* If all the parameters are [Pparam_newtype x], then return [Some xs] where + [xs] is the corresponding list of values [x]. This function is optimized for + the common case, where a list of parameters contains at least one value + parameter. +*) +let all_params_as_newtypes = + let is_newtype { pparam_desc; _ } = + match pparam_desc with + | Pparam_newtype _ -> true + | Pparam_val _ -> false + in + let as_newtype { pparam_desc; pparam_loc } = + match pparam_desc with + | Pparam_newtype x -> Some (x, pparam_loc) + | Pparam_val _ -> None + in + fun params -> + if List.for_all is_newtype params + then Some (List.filter_map as_newtype params) + else None + +(* Given a construct [fun (type a b c) : t -> e], we construct + [Pexp_newtype(a, Pexp_newtype(b, Pexp_newtype(c, Pexp_constraint(e, t))))] + rather than a [Pexp_function]. +*) +let mkghost_newtype_function_body newtypes body_constraint body = + let wrapped_body = + match body_constraint with + | None -> body + | Some body_constraint -> + let loc = { body.pexp_loc with loc_ghost = true } in + Exp.mk (mkexp_desc_constraint body body_constraint) ~loc + in + let expr = + List.fold_right + (fun (newtype, newtype_loc) e -> + (* Mints a ghost location that approximates the newtype's "extent" as + being from the start of the newtype param until the end of the + function body. + *) + let loc = (newtype_loc.Location.loc_start, body.pexp_loc.loc_end) in + ghexp (Pexp_newtype (newtype, e)) ~loc) + newtypes + wrapped_body + in + expr.pexp_desc + +let mkfunction params body_constraint body = + match body with + | Pfunction_cases _ -> Pexp_function (params, body_constraint, body) + | Pfunction_body body_exp -> + (* If all the params are newtypes, then we don't create a function node; + we create nested newtype nodes. *) + match all_params_as_newtypes params with + | None -> Pexp_function (params, body_constraint, body) + | Some newtypes -> + mkghost_newtype_function_body newtypes body_constraint body_exp + (* Alternatively, we could keep the generic module type in the Parsetree and extract the package type during type-checking. In that case, the assertions below should be turned into explicit checks. *) @@ -1000,6 +1067,27 @@ reversed_nonempty_llist(X): xs = rev(reversed_nonempty_llist(X)) { xs } +(* [reversed_nonempty_concat(X)] recognizes a nonempty sequence of [X]s (each of + which is a list), and produces an OCaml list of their concatenation in + reverse order -- that is, the last element of the last list in the input text + appears first in the list. +*) +reversed_nonempty_concat(X): + x = X + { List.rev x } +| xs = reversed_nonempty_concat(X) x = X + { List.rev_append x xs } + +(* [nonempty_concat(X)] recognizes a nonempty sequence of [X]s + (each of which is a list), and produces an OCaml list of their concatenation + in direct order -- that is, the first element of the first list in the input + text appears first in the list. +*) + +%inline nonempty_concat(X): + xs = rev(reversed_nonempty_concat(X)) + { xs } + (* [reversed_separated_nonempty_llist(separator, X)] recognizes a nonempty list of [X]s, separated with [separator]s, and produces an OCaml list in reverse order -- that is, the last element in the input text appears first in this @@ -2203,17 +2291,48 @@ class_type_declarations: /* Core expressions */ -seq_expr: - | expr %prec below_SEMI { $1 } - | expr SEMI { $1 } - | mkexp(expr SEMI seq_expr +%inline or_function(EXPR): + | EXPR + { $1 } + | FUNCTION ext_attributes match_cases + { let loc = make_loc $sloc in + let cases = $3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:$sloc desc $2 + } +; + +(* [fun_seq_expr] (and [fun_expr]) are legal expression bodies of a function. + [seq_expr] (and [expr]) are expressions that appear in other contexts + (e.g. subexpressions of the expression body of a function). + + [fun_seq_expr] can't be a bare [function _ -> ...]. [seq_expr] can. + + This distinction exists because [function _ -> ...] is parsed as a *function + cases* body of a function, not an expression body. This so functions can be + parsed with the intended arity. +*) +fun_seq_expr: + | fun_expr %prec below_SEMI { $1 } + | fun_expr SEMI { $1 } + | mkexp(fun_expr SEMI seq_expr { Pexp_sequence($1, $3) }) { $1 } - | expr SEMI PERCENT attr_id seq_expr + | fun_expr SEMI PERCENT attr_id seq_expr { let seq = mkexp ~loc:$sloc (Pexp_sequence ($1, $5)) in let payload = PStr [mkstrexp seq []] in mkexp ~loc:$sloc (Pexp_extension ($4, payload)) } ; +seq_expr: + | or_function(fun_seq_expr) { $1 } +; labeled_simple_pattern: QUESTION LPAREN label_let_pattern opt_default RPAREN { (Optional (fst $3), $4, snd $3) } @@ -2284,10 +2403,10 @@ let_pattern: %inline qualified_dotop: ioption(DOT mod_longident {$2}) DOTOP { $1, $2 }; -expr: +fun_expr: simple_expr %prec below_HASH { $1 } - | expr_attrs + | fun_expr_attrs { let desc, attrs = $1 in mkexp_attrs ~loc:$sloc desc attrs } | mkexp(expr_) @@ -2300,7 +2419,7 @@ expr: let pbop_loc = make_loc $sloc in let let_ = {pbop_op; pbop_pat; pbop_exp; pbop_loc} in mkexp ~loc:$sloc (Pexp_letop{ let_; ands; body}) } - | expr COLONCOLON expr + | fun_expr COLONCOLON expr { mkexp_cons ~loc:$sloc $loc($2) (ghexp ~loc:$sloc (Pexp_tuple[$1;$3])) } | mkrhs(label) LESSMINUS expr { mkexp ~loc:$sloc (Pexp_setinstvar($1, $3)) } @@ -2310,7 +2429,7 @@ expr: { mk_indexop_expr builtin_indexing_operators ~loc:$sloc $1 } | indexop_expr(qualified_dotop, expr_semi_list, LESSMINUS v=expr {Some v}) { mk_indexop_expr user_indexing_operators ~loc:$sloc $1 } - | expr attribute + | fun_expr attribute { Exp.attr $1 $2 } /* BEGIN AVOID */ (* Allowed in exprs. Commented-out to reduce diffs with upstream. @@ -2319,7 +2438,10 @@ expr: *) /* END AVOID */ ; -%inline expr_attrs: +%inline expr: + | or_function(fun_expr) { $1 } +; +%inline fun_expr_attrs: | LET MODULE ext_attributes mkrhs(module_name) module_binding_body IN seq_expr { Pexp_letmodule($4, $5, $7), $3 } | LET EXCEPTION ext_attributes let_exception_declaration IN seq_expr @@ -2328,13 +2450,12 @@ expr: { let open_loc = make_loc ($startpos($2), $endpos($5)) in let od = Opn.mk $5 ~override:$3 ~loc:open_loc in Pexp_open(od, $7), $4 } - | FUNCTION ext_attributes match_cases - { Pexp_function $3, $2 } - | FUN ext_attributes labeled_simple_pattern fun_def - { let (l,o,p) = $3 in - Pexp_fun(l, o, p, $4), $2 } - | FUN ext_attributes LPAREN TYPE lident_list RPAREN fun_def - { (mk_newtypes ~loc:$sloc $5 $7).pexp_desc, $2 } + /* Cf #5939: we used to accept (fun p when e0 -> e) */ + | FUN ext_attributes fun_params preceded(COLON, atomic_type)? + MINUSGREATER fun_body + { let body_constraint = Option.map (fun x -> Pconstraint x) $4 in + mkfunction $3 body_constraint $6, $2 + } | MATCH ext_attributes seq_expr WITH match_cases { Pexp_match($3, $5), $2 } | TRY ext_attributes seq_expr WITH match_cases @@ -2370,7 +2491,7 @@ expr: { Pexp_construct($1, Some $2) } | name_tag simple_expr %prec below_HASH { Pexp_variant($1, Some $2) } - | e1 = expr op = op(infix_operator) e2 = expr + | e1 = fun_expr op = op(infix_operator) e2 = expr { mkinfix e1 op e2 } | subtractive expr %prec prec_unary_minus { mkuminus ~oploc:$loc($1) $1 $2 } @@ -2538,10 +2659,9 @@ let_binding_body_no_punning: { let v = $1 in (* PR#7344 *) let t = match $2 with - Some t, None -> + Pconstraint t -> Pvc_constraint { locally_abstract_univars = []; typ=t } - | ground, Some coercion -> Pvc_coercion { ground; coercion} - | _ -> assert false + | Pcoerce (ground, coercion) -> Pvc_coercion { ground; coercion} in (v, $4, Some t) } @@ -2623,19 +2743,26 @@ letop_bindings: let and_ = {pbop_op; pbop_pat; pbop_exp; pbop_loc} in let_pat, let_exp, and_ :: rev_ands } ; -fun_binding: - strict_binding - { $1 } - | type_constraint EQUAL seq_expr - { mkexp_constraint ~loc:$sloc $3 $1 } -; strict_binding: EQUAL seq_expr { $2 } - | labeled_simple_pattern fun_binding - { let (l, o, p) = $1 in ghexp ~loc:$sloc (Pexp_fun(l, o, p, $2)) } - | LPAREN TYPE lident_list RPAREN fun_binding - { mk_newtypes ~loc:$sloc $3 $5 } + | fun_params type_constraint? EQUAL fun_body + { ghexp ~loc:$sloc (mkfunction $1 $2 $4) + } +; +fun_body: + | FUNCTION ext_attributes match_cases + { let ext, attrs = $2 in + match ext with + | None -> Pfunction_cases ($3, make_loc $sloc, attrs) + | Some _ -> + (* function%foo extension nodes interrupt the arity *) + let cases = Pfunction_cases ($3, make_loc $sloc, []) in + Pfunction_body + (mkexp_attrs ~loc:$sloc (mkfunction [] None cases) $2) + } + | fun_seq_expr + { Pfunction_body $1 } ; %inline match_cases: xs = preceded_or_separated_nonempty_llist(BAR, match_case) @@ -2649,20 +2776,28 @@ match_case: | pattern MINUSGREATER DOT { Exp.case $1 (Exp.unreachable ~loc:(make_loc $loc($3)) ()) } ; -fun_def: - MINUSGREATER seq_expr - { $2 } - | mkexp(COLON atomic_type MINUSGREATER seq_expr - { Pexp_constraint ($4, $2) }) - { $1 } -/* Cf #5939: we used to accept (fun p when e0 -> e) */ - | labeled_simple_pattern fun_def - { - let (l,o,p) = $1 in - ghexp ~loc:$sloc (Pexp_fun(l, o, p, $2)) +fun_param_as_list: + | LPAREN TYPE ty_params = lident_list RPAREN + { (* We desugar (type a b c) to (type a) (type b) (type c). + If we do this desugaring, the loc for each parameter is a ghost. + *) + let loc = + match ty_params with + | [] -> assert false (* lident_list is non-empty *) + | [_] -> make_loc $sloc + | _ :: _ :: _ -> ghost_loc $sloc + in + List.map + (fun x -> { pparam_loc = loc; pparam_desc = Pparam_newtype x }) + ty_params + } + | labeled_simple_pattern + { let a, b, c = $1 in + [ { pparam_loc = make_loc $sloc; pparam_desc = Pparam_val (a, b, c) } ] } - | LPAREN TYPE lident_list RPAREN fun_def - { mk_newtypes ~loc:$sloc $3 $5 } +; +fun_params: + | nonempty_concat(fun_param_as_list) { $1 } ; %inline expr_comma_list: es = separated_nontrivial_llist(COMMA, expr) @@ -2709,9 +2844,9 @@ record_expr_content: { es } ; type_constraint: - COLON core_type { (Some $2, None) } - | COLON core_type COLONGREATER core_type { (Some $2, Some $4) } - | COLONGREATER core_type { (None, Some $2) } + COLON core_type { Pconstraint $2 } + | COLON core_type COLONGREATER core_type { Pcoerce (Some $2, $4) } + | COLONGREATER core_type { Pcoerce (None, $2) } | COLON error { syntax_error() } | COLONGREATER error { syntax_error() } ; @@ -3291,8 +3426,8 @@ with_type_binder: /* Polymorphic types */ %inline typevar: - QUOTE mkrhs(ident) - { $2 } + QUOTE ident + { mkrhs $2 $sloc } ; %inline typevar_list: nonempty_llist(typevar) @@ -3346,7 +3481,7 @@ alias_type: function_type { $1 } | mktyp( - ty = alias_type AS QUOTE tyvar = ident + ty = alias_type AS tyvar = typevar { Ptyp_alias(ty, tyvar) } ) { $1 } @@ -3403,44 +3538,100 @@ tuple_type: - applications of type constructors: int, int list, int option list - variant types: [`A] *) + + +(* + Delimited types: + - parenthesised type (type) + - first-class module types (module S) + - object types < x: t; ... > + - variant types [ `A ] + - extension [%foo ...] + + We support local opens on the following classes of types: + - parenthesised + - first-class module types + - variant types + + Object types are not support for local opens due to a potential + conflict with MetaOCaml syntax: + M.< x: t, y: t > + and quoted expressions: + .< e >. + + Extension types are not support for local opens merely as a precaution. +*) +delimited_type_supporting_local_open: + | LPAREN type_ = core_type RPAREN + { type_ } + | LPAREN MODULE attrs = ext_attributes package_type = package_type RPAREN + { wrap_typ_attrs ~loc:$sloc (reloc_typ ~loc:$sloc package_type) attrs } + | mktyp( + LBRACKET field = tag_field RBRACKET + { Ptyp_variant([ field ], Closed, None) } + | LBRACKET BAR fields = row_field_list RBRACKET + { Ptyp_variant(fields, Closed, None) } + | LBRACKET field = row_field BAR fields = row_field_list RBRACKET + { Ptyp_variant(field :: fields, Closed, None) } + | LBRACKETGREATER BAR? fields = row_field_list RBRACKET + { Ptyp_variant(fields, Open, None) } + | LBRACKETGREATER RBRACKET + { Ptyp_variant([], Open, None) } + | LBRACKETLESS BAR? fields = row_field_list RBRACKET + { Ptyp_variant(fields, Closed, Some []) } + | LBRACKETLESS BAR? fields = row_field_list + GREATER + tags = name_tag_list + RBRACKET + { Ptyp_variant(fields, Closed, Some tags) } + ) + { $1 } +; + +object_type: + | mktyp( + LESS meth_list = meth_list GREATER + { let (f, c) = meth_list in Ptyp_object (f, c) } + | LESS GREATER + { Ptyp_object ([], Closed) } + ) + { $1 } +; + +extension_type: + | mktyp ( + ext = extension + { Ptyp_extension ext } + ) + { $1 } +; + +delimited_type: + | object_type + | extension_type + | delimited_type_supporting_local_open + { $1 } +; + atomic_type: - | LPAREN core_type RPAREN - { $2 } - | LPAREN MODULE ext_attributes package_type RPAREN - { wrap_typ_attrs ~loc:$sloc (reloc_typ ~loc:$sloc $4) $3 } + | type_ = delimited_type + { type_ } | mktyp( /* begin mktyp group */ - QUOTE ident - { Ptyp_var $2 } - | UNDERSCORE - { Ptyp_any } - | tys = actual_type_parameters + tys = actual_type_parameters tid = mkrhs(type_longident) - { Ptyp_constr(tid, tys) } - | LESS meth_list GREATER - { let (f, c) = $2 in Ptyp_object (f, c) } - | LESS GREATER - { Ptyp_object ([], Closed) } + { Ptyp_constr (tid, tys) } | tys = actual_type_parameters HASH cid = mkrhs(clty_longident) - { Ptyp_class(cid, tys) } - | LBRACKET tag_field RBRACKET - (* not row_field; see CONFLICTS *) - { Ptyp_variant([$2], Closed, None) } - | LBRACKET BAR row_field_list RBRACKET - { Ptyp_variant($3, Closed, None) } - | LBRACKET row_field BAR row_field_list RBRACKET - { Ptyp_variant($2 :: $4, Closed, None) } - | LBRACKETGREATER BAR? row_field_list RBRACKET - { Ptyp_variant($3, Open, None) } - | LBRACKETGREATER RBRACKET - { Ptyp_variant([], Open, None) } - | LBRACKETLESS BAR? row_field_list RBRACKET - { Ptyp_variant($3, Closed, Some []) } - | LBRACKETLESS BAR? row_field_list GREATER name_tag_list RBRACKET - { Ptyp_variant($3, Closed, Some $5) } - | extension - { Ptyp_extension $1 } + { Ptyp_class (cid, tys) } + | mod_ident = mkrhs(mod_ext_longident) + DOT + type_ = delimited_type_supporting_local_open + { Ptyp_open (mod_ident, type_) } + | QUOTE ident = ident + { Ptyp_var ident } + | UNDERSCORE + { Ptyp_any } ) { $1 } /* end mktyp group */ ; @@ -3459,7 +3650,7 @@ atomic_type: | /* empty */ { [] } | ty = atomic_type - { [ty] } + { [ ty ] } | LPAREN tys = separated_nontrivial_llist(COMMA, core_type) RPAREN { tys } ; @@ -3871,17 +4062,17 @@ attr_id: ) { $1 } ; attribute: - LBRACKETAT attr_id payload RBRACKET - { Attr.mk ~loc:(make_loc $sloc) $2 $3 } + LBRACKETAT attr_id attr_payload RBRACKET + { mk_attr ~loc:(make_loc $sloc) $2 $3 } ; post_item_attribute: - LBRACKETATAT attr_id payload RBRACKET - { Attr.mk ~loc:(make_loc $sloc) $2 $3 } + LBRACKETATAT attr_id attr_payload RBRACKET + { mk_attr ~loc:(make_loc $sloc) $2 $3 } ; floating_attribute: - LBRACKETATATAT attr_id payload RBRACKET + LBRACKETATATAT attr_id attr_payload RBRACKET { mark_symbol_docs $sloc; - Attr.mk ~loc:(make_loc $sloc) $2 $3 } + mk_attr ~loc:(make_loc $sloc) $2 $3 } ; %inline post_item_attributes: post_item_attribute* @@ -3921,4 +4112,10 @@ payload: | QUESTION pattern { PPat ($2, None) } | QUESTION pattern WHEN seq_expr { PPat ($2, Some $4) } ; +attr_payload: + payload + { Builtin_attributes.mark_payload_attrs_used $1; + $1 + } +; %% diff --git a/vendor/parser-standard/parsetree.mli b/vendor/parser-standard/parsetree.mli index fba4d0fc56..b50162c330 100644 --- a/vendor/parser-standard/parsetree.mli +++ b/vendor/parser-standard/parsetree.mli @@ -121,7 +121,7 @@ and core_type_desc = - [T #tconstr] when [l=[T]], - [(T1, ..., Tn) #tconstr] when [l=[T1 ; ... ; Tn]]. *) - | Ptyp_alias of core_type * string (** [T as 'a]. *) + | Ptyp_alias of core_type * string loc (** [T as 'a]. *) | Ptyp_variant of row_field list * closed_flag * label list option (** [Ptyp_variant([`A;`B], flag, labels)] represents: - [[ `A|`B ]] @@ -166,6 +166,7 @@ and core_type_desc = {!value_description}. *) | Ptyp_package of package_type (** [(module S)]. *) + | Ptyp_open of Longident.t loc * core_type (** [M.(T)] *) | Ptyp_extension of extension (** [[%id]]. *) and package_type = Longident.t loc * (Longident.t loc * core_type) list @@ -296,29 +297,20 @@ and expression_desc = - [let rec P1 = E1 and ... and Pn = EN in E] when [flag] is {{!Asttypes.rec_flag.Recursive}[Recursive]}. *) - | Pexp_function of case list (** [function P1 -> E1 | ... | Pn -> En] *) - | Pexp_fun of arg_label * expression option * pattern * expression - (** [Pexp_fun(lbl, exp0, P, E1)] represents: - - [fun P -> E1] - when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]} - and [exp0] is [None] - - [fun ~l:P -> E1] - when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]} - and [exp0] is [None] - - [fun ?l:P -> E1] - when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} - and [exp0] is [None] - - [fun ?l:(P = E0) -> E1] - when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} - and [exp0] is [Some E0] - - Notes: - - If [E0] is provided, only - {{!Asttypes.arg_label.Optional}[Optional]} is allowed. - - [fun P1 P2 .. Pn -> E1] is represented as nested - {{!expression_desc.Pexp_fun}[Pexp_fun]}. - - [let f P = E] is represented using - {{!expression_desc.Pexp_fun}[Pexp_fun]}. + | Pexp_function of + function_param list * type_constraint option * function_body + (** [Pexp_function ([P1; ...; Pn], C, body)] represents any construct + involving [fun] or [function], including: + - [fun P1 ... Pn -> E] + when [body = Pfunction_body E] + - [fun P1 ... Pn -> function p1 -> e1 | ... | pm -> em] + when [body = Pfunction_cases [ p1 -> e1; ...; pm -> em ]] + + [C] represents a type constraint or coercion placed immediately before the + arrow, e.g. [fun P1 ... Pn : ty -> ...] when [C = Some (Pconstraint ty)]. + + A function must have parameters. [Pexp_function (params, _, body)] must + have non-empty [params] or a [Pfunction_cases _] body. *) | Pexp_apply of expression * (arg_label * expression) list (** [Pexp_apply(E0, [(l1, E1) ; ... ; (ln, En)])] @@ -441,6 +433,66 @@ and binding_op = pbop_loc : Location.t; } +and function_param_desc = + | Pparam_val of arg_label * expression option * pattern + (** [Pparam_val (lbl, exp0, P)] represents the parameter: + - [P] + when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]} + and [exp0] is [None] + - [~l:P] + when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]} + and [exp0] is [None] + - [?l:P] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [None] + - [?l:(P = E0)] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [Some E0] + + Note: If [E0] is provided, only + {{!Asttypes.arg_label.Optional}[Optional]} is allowed. + *) + | Pparam_newtype of string loc + (** [Pparam_newtype x] represents the parameter [(type x)]. + [x] carries the location of the identifier, whereas the [pparam_loc] + on the enclosing [function_param] node is the location of the [(type x)] + as a whole. + + Multiple parameters [(type a b c)] are represented as multiple + [Pparam_newtype] nodes, let's say: + + {[ [ { pparam_kind = Pparam_newtype a; pparam_loc = loc1 }; + { pparam_kind = Pparam_newtype b; pparam_loc = loc2 }; + { pparam_kind = Pparam_newtype c; pparam_loc = loc3 }; + ] + ]} + + Here, the first loc [loc1] is the location of [(type a b c)], and the + subsequent locs [loc2] and [loc3] are the same as [loc1], except marked as + ghost locations. The locations on [a], [b], [c], correspond to the + variables [a], [b], and [c] in the source code. + *) + +and function_param = + { pparam_loc : Location.t; + pparam_desc : function_param_desc; + } + +and function_body = + | Pfunction_body of expression + | Pfunction_cases of case list * Location.t * attributes + (** In [Pfunction_cases (_, loc, attrs)], the location extends from the + start of the [function] keyword to the end of the last case. The compiler + will only use typechecking-related attributes from [attrs], e.g. enabling + or disabling a warning. + *) +(** See the comment on {{!expression_desc.Pexp_function}[Pexp_function]}. *) + +and type_constraint = + | Pconstraint of core_type + | Pcoerce of core_type option * core_type +(** See the comment on {{!expression_desc.Pexp_function}[Pexp_function]}. *) + (** {2 Value descriptions} *) and value_description = diff --git a/vendor/parser-standard/printast.ml b/vendor/parser-standard/printast.ml index bd59bfc4ae..7718d7d77b 100644 --- a/vendor/parser-standard/printast.ml +++ b/vendor/parser-standard/printast.ml @@ -172,7 +172,7 @@ let rec core_type i ppf x = line i ppf "Ptyp_class %a\n" fmt_longident_loc li; list i core_type ppf l | Ptyp_alias (ct, s) -> - line i ppf "Ptyp_alias \"%s\"\n" s; + line i ppf "Ptyp_alias \"%s\"\n" s.txt; core_type i ppf ct; | Ptyp_poly (sl, ct) -> line i ppf "Ptyp_poly%a\n" typevars sl; @@ -180,6 +180,9 @@ let rec core_type i ppf x = | Ptyp_package (s, l) -> line i ppf "Ptyp_package %a\n" fmt_longident_loc s; list i package_with ppf l; + | Ptyp_open (mod_ident, t) -> + line i ppf "Ptyp_open \"%a\"\n" fmt_longident_loc mod_ident; + core_type i ppf t | Ptyp_extension (s, arg) -> line i ppf "Ptyp_extension \"%s\"\n" s.txt; payload i ppf arg @@ -257,15 +260,11 @@ and expression i ppf x = line i ppf "Pexp_let %a\n" fmt_rec_flag rf; list i value_binding ppf l; expression i ppf e; - | Pexp_function l -> + | Pexp_function (params, c, body) -> line i ppf "Pexp_function\n"; - list i case ppf l; - | Pexp_fun (l, eo, p, e) -> - line i ppf "Pexp_fun\n"; - arg_label i ppf l; - option i expression ppf eo; - pattern i ppf p; - expression i ppf e; + list i function_param ppf params; + option i type_constraint ppf c; + function_body i ppf body | Pexp_apply (e, l) -> line i ppf "Pexp_apply\n"; expression i ppf e; @@ -385,6 +384,36 @@ and expression i ppf x = | Pexp_hole -> line i ppf "Pexp_hole" +and function_param i ppf { pparam_desc = desc; pparam_loc = loc } = + match desc with + | Pparam_val (l, eo, p) -> + line i ppf "Pparam_val %a\n" fmt_location loc; + arg_label (i+1) ppf l; + option (i+1) expression ppf eo; + pattern (i+1) ppf p + | Pparam_newtype ty -> + line i ppf "Pparam_newtype \"%s\" %a\n" ty.txt fmt_location loc + +and function_body i ppf body = + match body with + | Pfunction_body e -> + line i ppf "Pfunction_body\n"; + expression (i+1) ppf e + | Pfunction_cases (cases, loc, attrs) -> + line i ppf "Pfunction_cases %a\n" fmt_location loc; + attributes (i+1) ppf attrs; + list (i+1) case ppf cases + +and type_constraint i ppf constraint_ = + match constraint_ with + | Pconstraint ty -> + line i ppf "Pconstraint\n"; + core_type (i+1) ppf ty + | Pcoerce (ty1, ty2) -> + line i ppf "Pcoerce\n"; + option (i+1) core_type ppf ty1; + core_type (i+1) ppf ty2 + and value_description i ppf x = line i ppf "value_description %a %a\n" fmt_string_loc x.pval_name fmt_location x.pval_loc; From d534e74efba567b7b33deb61f2889c0f7174b11e Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Wed, 6 Mar 2024 20:02:34 +0100 Subject: [PATCH 003/146] parser-extended: Backport Pexp_function It already have some differences with upstream: - The special cases of a `fun` with only newtype arguments is no longer rewritten by `mkfunction`. - `(type a b)` is not desugared into `(type a) (type b)` --- vendor/parser-extended/ast_helper.ml | 3 +- vendor/parser-extended/ast_mapper.ml | 42 ++++-- vendor/parser-extended/parser.mly | 205 +++++++++++++++++++++++---- vendor/parser-extended/parsetree.mli | 99 +++++++++---- vendor/parser-extended/printast.ml | 39 ++--- 5 files changed, 305 insertions(+), 83 deletions(-) diff --git a/vendor/parser-extended/ast_helper.ml b/vendor/parser-extended/ast_helper.ml index a245df0856..bc32c86241 100644 --- a/vendor/parser-extended/ast_helper.ml +++ b/vendor/parser-extended/ast_helper.ml @@ -126,8 +126,7 @@ module Exp = struct let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) let let_ ?loc ?attrs ~loc_in a b = mk ?loc ?attrs (Pexp_let (a, b, loc_in)) - let fun_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_fun (a, b)) - let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a) + let function_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_function (a, b, c)) let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b)) let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) diff --git a/vendor/parser-extended/ast_mapper.ml b/vendor/parser-extended/ast_mapper.ml index 66f72c1ab8..98c7f7abfe 100644 --- a/vendor/parser-extended/ast_mapper.ml +++ b/vendor/parser-extended/ast_mapper.ml @@ -115,15 +115,15 @@ let map_value_constraint sub = function Pvc_coercion { ground; coercion } module FP = struct - let map_param_val sub ((lab, def, p) : param_val) : param_val = + let map_param_val sub ((lab, def, p) : pparam_val) : pparam_val = (sub.arg_label sub lab, map_opt (sub.expr sub) def, sub.pat sub p) - let map_param_newtype sub (ty : param_newtype) : param_newtype = + let map_param_newtype sub (ty : string loc list) : string loc list = List.map (map_loc sub) ty let map_expr sub = function - | Param_val x -> Param_val (map_param_val sub x) - | Param_newtype x -> Param_newtype (map_param_newtype sub x) + | Pparam_val x -> Pparam_val (map_param_val sub x) + | Pparam_newtype x -> Pparam_newtype (map_param_newtype sub x) let map_class sub x = map_param_val sub x @@ -498,6 +498,30 @@ end module E = struct (* Value expressions for the core language *) + let map_function_param sub { pparam_loc = loc; pparam_desc = desc } = + let loc = sub.location sub loc in + let desc = + match desc with + | Pparam_val (lab, def, p) -> + Pparam_val + (lab, + map_opt (sub.expr sub) def, + sub.pat sub p) + | Pparam_newtype ty -> + Pparam_newtype (List.map (map_loc sub) ty) + in + { pparam_loc = loc; pparam_desc = desc } + + let map_function_body sub body = + match body with + | Pfunction_body e -> + Pfunction_body (sub.expr sub e) + | Pfunction_cases (cases, loc, attributes) -> + let cases = sub.cases sub cases in + let loc = sub.location sub loc in + let attributes = sub.attributes sub attributes in + Pfunction_cases (cases, loc, attributes) + let map_constraint sub c = match c with | Pconstraint ty -> Pconstraint (sub.typ sub ty) @@ -520,11 +544,11 @@ module E = struct let loc_in = sub.location sub loc_in in let_ ~loc ~loc_in ~attrs (sub.value_bindings sub lbs) (sub.expr sub e) - | Pexp_fun (p, e) -> - fun_ ~loc ~attrs - (FP.map sub FP.map_expr p) - (sub.expr sub e) - | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel) + | Pexp_function (ps, c, b) -> + function_ ~loc ~attrs + (List.map (map_function_param sub) ps) + (map_opt (map_constraint sub) c) + (map_function_body sub b) | Pexp_apply (e, l) -> apply ~loc ~attrs (sub.expr sub e) diff --git a/vendor/parser-extended/parser.mly b/vendor/parser-extended/parser.mly index 5fb12a2710..ed27ff2bc7 100644 --- a/vendor/parser-extended/parser.mly +++ b/vendor/parser-extended/parser.mly @@ -486,6 +486,68 @@ let class_of_let_bindings ~loc ~loc_in lbs body = assert (not lbs.lbs_has_ext); mkclass ~loc (Pcl_let (mk_let_bindings lbs, body, loc_in)) +(* This rewrite is not wanted in OCamlformat +(* If all the parameters are [Pparam_newtype x], then return [Some xs] where + [xs] is the corresponding list of values [x]. This function is optimized for + the common case, where a list of parameters contains at least one value + parameter. +*) +let all_params_as_newtypes = + let is_newtype { pparam_desc; _ } = + match pparam_desc with + | Pparam_newtype _ -> true + | Pparam_val _ -> false + in + let as_newtype { pparam_desc; pparam_loc } = + match pparam_desc with + | Pparam_newtype x -> Some (x, pparam_loc) + | Pparam_val _ -> None + in + fun params -> + if List.for_all is_newtype params + then Some (List.filter_map as_newtype params) + else None + +(* Given a construct [fun (type a b c) : t -> e], we construct + [Pexp_newtype(a, Pexp_newtype(b, Pexp_newtype(c, Pexp_constraint(e, t))))] + rather than a [Pexp_function]. +*) +let mkghost_newtype_function_body newtypes body_constraint body = + let wrapped_body = + match body_constraint with + | None -> body + | Some body_constraint -> + let loc = { body.pexp_loc with loc_ghost = true } in + Exp.mk (mkexp_desc_constraint body body_constraint) ~loc + in + let expr = + List.fold_right + (fun (newtype, newtype_loc) e -> + (* Mints a ghost location that approximates the newtype's "extent" as + being from the start of the newtype param until the end of the + function body. + *) + let loc = (newtype_loc.Location.loc_start, body.pexp_loc.loc_end) in + ghexp (Pexp_newtype (newtype, e)) ~loc) + newtypes + wrapped_body + in + expr.pexp_desc + +let mkfunction params body_constraint body = + match body with + | Pfunction_cases _ -> Pexp_function (params, body_constraint, body) + | Pfunction_body body_exp -> + (* If all the params are newtypes, then we don't create a function node; + we create nested newtype nodes. *) + match all_params_as_newtypes params with + | None -> Pexp_function (params, body_constraint, body) + | Some newtypes -> + mkghost_newtype_function_body newtypes body_constraint body_exp +*) +let mkfunction params body_constraint body = + Pexp_function (params, body_constraint, body) + (* Alternatively, we could keep the generic module type in the Parsetree and extract the package type during type-checking. In that case, the assertions below should be turned into explicit checks. *) @@ -904,6 +966,28 @@ reversed_nonempty_llist(X): xs = rev(reversed_nonempty_llist(X)) { xs } +(* [reversed_nonempty_concat(X)] recognizes a nonempty sequence of [X]s (each of + which is a list), and produces an OCaml list of their concatenation in + reverse order -- that is, the last element of the last list in the input text + appears first in the list. +*) +reversed_nonempty_concat(X): + x = X + { List.rev x } +| xs = reversed_nonempty_concat(X) x = X + { List.rev_append x xs } + +(* Not needed. Upstream uses it only for desugaring (type a b c) +(* [nonempty_concat(X)] recognizes a nonempty sequence of [X]s + (each of which is a list), and produces an OCaml list of their concatenation + in direct order -- that is, the first element of the first list in the input + text appears first in the list. +*) + +%inline nonempty_concat(X): + xs = rev(reversed_nonempty_concat(X)) + { xs } + (* [reversed_separated_nonempty_llist(separator, X)] recognizes a nonempty list of [X]s, separated with [separator]s, and produces an OCaml list in reverse order -- that is, the last element in the input text appears first in this @@ -915,6 +999,7 @@ reversed_nonempty_llist(X): the case of a list of length more than one will be distinguished at the use site, and will give rise there to two productions. This can be used to avoid certain conflicts. *) +*) %inline inline_reversed_separated_nonempty_llist(separator, X): x = X @@ -1676,7 +1761,7 @@ module_declaration_body: ; (* A module substitution (in a signature). *) module_subst: -MODULE + MODULE ext = ext attrs1 = attributes uid = mkrhs(UIDENT) COLONEQUAL @@ -2108,17 +2193,48 @@ class_type_declarations: /* Core expressions */ -seq_expr: - | expr %prec below_SEMI { $1 } - | expr SEMI { $1 } - | mkexp(expr SEMI seq_expr +%inline or_function(EXPR): + | EXPR + { $1 } + | FUNCTION ext_attributes match_cases + { let loc = make_loc $sloc in + let cases = $3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:$sloc desc $2 + } +; + +(* [fun_seq_expr] (and [fun_expr]) are legal expression bodies of a function. + [seq_expr] (and [expr]) are expressions that appear in other contexts + (e.g. subexpressions of the expression body of a function). + + [fun_seq_expr] can't be a bare [function _ -> ...]. [seq_expr] can. + + This distinction exists because [function _ -> ...] is parsed as a *function + cases* body of a function, not an expression body. This so functions can be + parsed with the intended arity. +*) +fun_seq_expr: + | fun_expr %prec below_SEMI { $1 } + | fun_expr SEMI { $1 } + | mkexp(fun_expr SEMI seq_expr { Pexp_sequence($1, $3) }) { $1 } - | expr SEMI PERCENT attr_id seq_expr + | fun_expr SEMI PERCENT attr_id seq_expr { let seq = mkexp ~loc:$sloc (Pexp_sequence ($1, $5)) in let payload = PStr [mkstrexp seq []] in mkexp ~loc:$sloc (Pexp_extension ($4, payload)) } ; +seq_expr: + | or_function(fun_seq_expr) { $1 } +; labeled_simple_pattern: QUESTION LPAREN label_let_pattern opt_default RPAREN { mk_optional (fst $3) $sloc, $4, snd $3 } @@ -2135,7 +2251,7 @@ labeled_simple_pattern: | LABEL simple_pattern { mk_labelled $1 $sloc, None, $2 } | simple_pattern - { Nolabel, None, $1 } + { (Nolabel, None, $1) } ; pattern_var: @@ -2189,10 +2305,10 @@ let_pattern: %inline qualified_dotop: ioption(DOT mkrhs(mod_longident) {$2}) DOTOP { $1, $2 }; -expr: +fun_expr: simple_expr %prec below_HASH { $1 } - | expr_attrs + | fun_expr_attrs { let desc, attrs = $1 in mkexp_attrs ~loc:$sloc desc attrs } | mkexp(expr_) @@ -2229,7 +2345,10 @@ expr: *) /* END AVOID */ ; -%inline expr_attrs: +%inline expr: + | or_function(fun_expr) { $1 } +; +%inline fun_expr_attrs: | LET MODULE ext_attributes mkrhs(module_name) functor_args module_binding_body IN seq_expr { Pexp_letmodule($4, $5, $6, $8), $3 } | LET EXCEPTION ext_attributes let_exception_declaration IN seq_expr @@ -2238,10 +2357,12 @@ expr: { let open_loc = make_loc ($startpos($2), $endpos($5)) in let od = Opn.mk $5 ~override:$3 ~loc:open_loc in Pexp_letopen(od, $7), $4 } - | FUNCTION ext_attributes match_cases - { Pexp_function $3, $2 } - | FUN ext_attributes expr_fun_param fun_def - { Pexp_fun($3, $4), $2 } + /* Cf #5939: we used to accept (fun p when e0 -> e) */ + | FUN ext_attributes expr_fun_params preceded(COLON, atomic_type)? + MINUSGREATER fun_body + { let body_constraint = Option.map (fun x -> Pconstraint x) $4 in + mkfunction $3 body_constraint $6, $2 + } | MATCH ext_attributes seq_expr WITH match_cases { Pexp_match($3, $5), $2 } | TRY ext_attributes seq_expr WITH match_cases @@ -2286,7 +2407,7 @@ expr: { Pexp_construct($1, Some $2) } | name_tag simple_expr %prec below_HASH { Pexp_variant($1, Some $2) } - | e1 = expr op = op(infix_operator) e2 = expr + | e1 = fun_expr op = op(infix_operator) e2 = expr { mkinfix e1 op e2 } | subtractive expr %prec prec_unary_minus { mkuminus ~oploc:$loc($1) $1 $2 } @@ -2557,6 +2678,20 @@ strict_binding: in $1, tc, $4 } ; +fun_body: + | FUNCTION ext_attributes match_cases + { let ext, attrs = $2 in + match ext with + | None -> Pfunction_cases ($3, make_loc $sloc, attrs) + | Some _ -> + (* function%foo extension nodes interrupt the arity *) + let cases = Pfunction_cases ($3, make_loc $sloc, []) in + Pfunction_body + (mkexp_attrs ~loc:$sloc (mkfunction [] None cases) $2) + } + | fun_seq_expr + { Pfunction_body $1 } +; %inline match_cases: xs = preceded_or_separated_nonempty_llist(BAR, match_case) { xs } @@ -2569,6 +2704,30 @@ match_case: | pattern MINUSGREATER DOT { Exp.case $1 (Exp.unreachable ~loc:(make_loc $loc($3)) ()) } ; +(* Removed in favor of expr_fun_param +fun_param_as_list: + | LPAREN TYPE ty_params = lident_list RPAREN + { (* We desugar (type a b c) to (type a) (type b) (type c). + If we do this desugaring, the loc for each parameter is a ghost. + *) + let loc = + match ty_params with + | [] -> assert false (* lident_list is non-empty *) + | [_] -> make_loc $sloc + | _ :: _ :: _ -> ghost_loc $sloc + in + List.map + (fun x -> { pparam_loc = loc; pparam_desc = Pparam_newtype x }) + ty_params + } + | labeled_simple_pattern + { let a, b, c = $1 in + [ { pparam_loc = make_loc $sloc; pparam_desc = Pparam_val (a, b, c) } ] + } +; +fun_params: + | nonempty_concat(fun_param_as_list) { $1 } +*) param_val: | labeled_simple_pattern { $1 } @@ -2579,8 +2738,8 @@ param_newtype: ; expr_fun_param: mkfunparam( - param_val { Param_val $1 } - | param_newtype { Param_newtype $1 } + param_val { Pparam_val $1 } + | param_newtype { Pparam_newtype $1 } ) { $1 } ; class_fun_param: @@ -2588,16 +2747,8 @@ class_fun_param: param_val { $1 } ) { $1 } ; -fun_def: - MINUSGREATER seq_expr - { $2 } - | mkexp(COLON atomic_type MINUSGREATER seq_expr - { Pexp_constraint ($4, $2) }) - { $1 } -/* Cf #5939: we used to accept (fun p when e0 -> e) */ - | expr_fun_param fun_def - { ghexp ~loc:$sloc (Pexp_fun($1, $2)) } -; +expr_fun_params: + | nonempty_llist(expr_fun_param) { $1 } %inline expr_comma_list: es = separated_nontrivial_llist(COMMA, expr) { es } diff --git a/vendor/parser-extended/parsetree.mli b/vendor/parser-extended/parsetree.mli index 82f3ce85bc..eb9006460f 100644 --- a/vendor/parser-extended/parsetree.mli +++ b/vendor/parser-extended/parsetree.mli @@ -313,15 +313,21 @@ and expression_desc = when [flag] is {{!Asttypes.rec_flag.Recursive}[Recursive]}. - [loc_in] is the location of the [in] keyword. *) - | Pexp_function of case list (** [function P1 -> E1 | ... | Pn -> En] *) - | Pexp_fun of expr_function_param * expression - (** [Pexp_fun(P, E)] represents: - - [fun P -> E] - - [fun ~l:P -> E] - - [fun ?l:P -> E] - - [fun ?l:(P = E0) -> E] - - [fun (type t) -> E] - *) + | Pexp_function of + expr_function_param list * type_constraint option * function_body + (** [Pexp_function ([P1; ...; Pn], C, body)] represents any construct + involving [fun] or [function], including: + - [fun P1 ... Pn -> E] + when [body = Pfunction_body E] + - [fun P1 ... Pn -> function p1 -> e1 | ... | pm -> em] + when [body = Pfunction_cases [ p1 -> e1; ...; pm -> em ]] + + [C] represents a type constraint or coercion placed immediately before the + arrow, e.g. [fun P1 ... Pn : ty -> ...] when [C = Some (Pconstraint ty)]. + + A function must have parameters. [Pexp_function (params, _, body)] must + have non-empty [params] or a [Pfunction_cases _] body. + *) | Pexp_apply of expression * (arg_label * expression) list (** [Pexp_apply(E0, [(l1, E1) ; ... ; (ln, En)])] represents [E0 ~l1:E1 ... ~ln:En] @@ -476,35 +482,71 @@ and binding_op = pbop_loc : Location.t; } -and param_val = arg_label * expression option * pattern - (** - [P] when [lbl] is [Nolabel] and [exp0] is [None] - - [~l:P] when [lbl] is [Labelled l] and [exp0] is [None] - - [?l:P] when [lbl] is [Optional l] and [exp0] is [None] - - [?l:(P = E0)] when [lbl] is [Optional l] and [exp0] is [Some E0] - - Note: If [E0] is provided, only [Optional] is allowed. +and pparam_val = arg_label * expression option * pattern + +and function_param_desc = + | Pparam_val of pparam_val + (** [Pparam_val (lbl, exp0, P)] represents the parameter: + - [P] + when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]} + and [exp0] is [None] + - [~l:P] + when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]} + and [exp0] is [None] + - [?l:P] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [None] + - [?l:(P = E0)] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [Some E0] + + Note: If [E0] is provided, only + {{!Asttypes.arg_label.Optional}[Optional]} is allowed. + *) + | Pparam_newtype of string loc list + (** [Pparam_newtype x] represents the parameter [(type x)]. + [x] carries the location of the identifier, whereas the [pparam_loc] + on the enclosing [function_param] node is the location of the [(type x)] + as a whole. + + Multiple parameters [(type a b c)] are represented as multiple + [Pparam_newtype] nodes, let's say: + + {[ [ { pparam_kind = Pparam_newtype a; pparam_loc = loc1 }; + { pparam_kind = Pparam_newtype b; pparam_loc = loc2 }; + { pparam_kind = Pparam_newtype c; pparam_loc = loc3 }; + ] + ]} + + Here, the first loc [loc1] is the location of [(type a b c)], and the + subsequent locs [loc2] and [loc3] are the same as [loc1], except marked as + ghost locations. The locations on [a], [b], [c], correspond to the + variables [a], [b], and [c] in the source code. *) - -and param_newtype = string loc list - (** [(type x y z)]. *) and 'a function_param = - { - pparam_loc : Location.t; + { pparam_loc : Location.t; pparam_desc : 'a; } -and param_val_or_newtype = - | Param_val of param_val - | Param_newtype of param_newtype +and expr_function_param = function_param_desc function_param -and expr_function_param = param_val_or_newtype function_param +and class_function_param = pparam_val function_param -and class_function_param = param_val function_param +and function_body = + | Pfunction_body of expression + | Pfunction_cases of case list * Location.t * attributes + (** In [Pfunction_cases (_, loc, attrs)], the location extends from the + start of the [function] keyword to the end of the last case. The compiler + will only use typechecking-related attributes from [attrs], e.g. enabling + or disabling a warning. + *) +(** See the comment on {{!expression_desc.Pexp_function}[Pexp_function]}. *) and type_constraint = | Pconstraint of core_type | Pcoerce of core_type option * core_type +(** See the comment on {{!expression_desc.Pexp_function}[Pexp_function]}. *) (** {2 Value descriptions} *) @@ -886,7 +928,8 @@ and signature_item = and signature_item_desc = | Psig_value of value_description (** - [val x: T] - - [external x: T = "s1" ... "sn"] *) + - [external x: T = "s1" ... "sn"] + *) | Psig_type of rec_flag * type_declaration list (** [type t1 = ... and ... and tn = ...] *) | Psig_typesubst of type_declaration list @@ -1040,7 +1083,7 @@ and structure_item_desc = *) | Pstr_primitive of value_description (** - [val x: T] - - [external x: T = "s1" ... "sn"] *) + - [external x: T = "s1" ... "sn" ]*) | Pstr_type of rec_flag * type_declaration list (** [type t1 = ... and ... and tn = ...] *) | Pstr_typext of type_extension (** [type t1 += ...] *) diff --git a/vendor/parser-extended/printast.ml b/vendor/parser-extended/printast.ml index e8306a21e8..158c917a6c 100644 --- a/vendor/parser-extended/printast.ml +++ b/vendor/parser-extended/printast.ml @@ -346,13 +346,11 @@ and expression i ppf x = line (i + 1) ppf "loc_in: %a\n" fmt_location loc_in; value_bindings i ppf l; expression i ppf e; - | Pexp_function l -> + | Pexp_function (params, c, body) -> line i ppf "Pexp_function\n"; - list i case ppf l; - | Pexp_fun (p, e) -> - line i ppf "Pexp_fun\n"; - expr_function_param i ppf p; - expression i ppf e; + list i expr_function_param ppf params; + option i type_constraint ppf c; + function_body i ppf body | Pexp_apply (e, l) -> line i ppf "Pexp_apply\n"; expression i ppf e; @@ -509,25 +507,32 @@ and if_branch i ppf { if_cond; if_body } = expression i ppf if_cond; expression i ppf if_body -and param_val i ppf (l, eo, p) = - line i ppf "param_val\n"; +and pparam_val i ppf ~loc (l, eo, p) = + line i ppf "Pparam_val %a\n" fmt_location loc; arg_label (i+1) ppf l; option (i+1) expression ppf eo; pattern (i+1) ppf p -and param_newtype i ppf ty = - line i ppf "param_newtype\n"; - list i (fun i ppf x -> line (i+1) ppf "type %a" fmt_string_loc x) ppf ty - and expr_function_param i ppf { pparam_desc = desc; pparam_loc = loc } = - line i ppf "function_param %a\n" fmt_location loc; match desc with - | Param_val x -> param_val i ppf x - | Param_newtype x -> param_newtype i ppf x + | Pparam_val p -> pparam_val i ppf ~loc p + | Pparam_newtype tys -> + List.iter (fun ty -> + line i ppf "Pparam_newtype \"%s\" %a\n" ty.txt fmt_location loc) + tys and class_function_param i ppf { pparam_desc = desc; pparam_loc = loc } = - line i ppf "function_param %a\n" fmt_location loc; - param_val i ppf desc + pparam_val i ppf ~loc desc + +and function_body i ppf body = + match body with + | Pfunction_body e -> + line i ppf "Pfunction_body\n"; + expression (i+1) ppf e + | Pfunction_cases (cases, loc, attrs) -> + line i ppf "Pfunction_cases %a\n" fmt_location loc; + attributes (i+1) ppf attrs; + list (i+1) case ppf cases and type_constraint i ppf constraint_ = match constraint_ with From c662e0cb63cb553ee8b0bf26bbd7773049225d12 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Fri, 8 Mar 2024 12:11:04 +0100 Subject: [PATCH 004/146] WIP: Ast --- lib/Ast.ml | 86 +++++++++++++++++++++++++++++++++--------------------- 1 file changed, 53 insertions(+), 33 deletions(-) diff --git a/lib/Ast.ml b/lib/Ast.ml index 47b7af461d..c728f23cfd 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -145,7 +145,7 @@ module Exp = struct let has_trailing_attributes {pexp_desc; pexp_attributes; _} = match pexp_desc with - | Pexp_fun _ | Pexp_function _ | Pexp_ifthenelse _ | Pexp_match _ + | Pexp_function _ | Pexp_ifthenelse _ | Pexp_match _ |Pexp_try _ -> false | _ -> List.exists pexp_attributes ~f:(Fn.non Attr.is_doc) @@ -180,12 +180,12 @@ module Exp = struct |( {pexp_desc= Pexp_sequence _; _} , (Non_apply | Sequence | Then | ThenElse) ) |( { pexp_desc= - ( Pexp_function _ | Pexp_match _ | Pexp_try _ - | Pexp_fun (_, {pexp_desc= Pexp_constraint _; _}) ) + ( Pexp_function (_, _, Pfunction_cases _) | Pexp_match _ | Pexp_try _ + ) ; _ } , (Match | Let_match | Non_apply) ) |( { pexp_desc= - ( Pexp_fun _ | Pexp_let _ | Pexp_letop _ | Pexp_letexception _ + ( Pexp_function _ | Pexp_let _ | Pexp_letop _ | Pexp_letexception _ | Pexp_letmodule _ | Pexp_open _ | Pexp_letopen _ ) ; _ } , (Let_match | Non_apply) ) -> @@ -1206,8 +1206,8 @@ end = struct let check_param_val (_, _, p) = p == pat in let check_expr_function_param param = match param.pparam_desc with - | Param_val x -> check_param_val x - | Param_newtype _ -> false + | Pparam_val x -> check_param_val x + | Pparam_newtype _ -> false in let check_class_function_param param = check_param_val param.pparam_desc @@ -1215,6 +1215,8 @@ end = struct let check_class_function_params = List.exists ~f:check_class_function_param in + let check_cases = + List.exists ~f:(fun c -> c.pc_lhs == pat) in match ctx with | Pld (PPat (p1, _)) -> assert (p1 == pat) | Pld _ -> assert false @@ -1266,13 +1268,20 @@ end = struct | Pexp_letop {let_; ands; _} -> let f {pbop_pat; _} = check_subpat pbop_pat in assert (f let_ || List.exists ~f ands) - | Pexp_function cases | Pexp_match (_, cases) | Pexp_try (_, cases) -> - assert ( - List.exists cases ~f:(function - | {pc_lhs; _} when pc_lhs == pat -> true - | _ -> false ) ) + | Pexp_match (_, cases) | Pexp_try (_, cases) -> + assert (check_cases cases) | Pexp_for (p, _, _, _, _) -> assert (p == pat) - | Pexp_fun (p, _) -> assert (check_expr_function_param p) ) + | Pexp_function (params, _, body) -> + let check_body = + match body with + Pfunction_body _ -> false + | Pfunction_cases (cases, _, _) -> + check_cases cases + in + assert ( + List.exists ~f:check_expr_function_param params + || check_body + )) | Fpe ctx -> assert (check_expr_function_param ctx) | Fpc ctx -> assert (check_class_function_param ctx) | Vc _ -> assert false @@ -1329,8 +1338,8 @@ end = struct let check_param_val (_, e, _) = Option.exists e ~f:(fun x -> x == exp) in let check_expr_function_param param = match param.pparam_desc with - | Param_val x -> check_param_val x - | Param_newtype _ -> false + | Pparam_val x -> check_param_val x + | Pparam_newtype _ -> false in let check_class_function_param param = check_param_val param.pparam_desc @@ -1338,6 +1347,12 @@ end = struct let check_class_function_params = List.exists ~f:check_class_function_param in + let check_cases = + List.exists ~f:(function + | {pc_guard= Some g; _} when g == exp -> true + | {pc_rhs; _} when pc_rhs == exp -> true + | _ -> false ) + in match ctx with | Pld (PPat (_, Some e1)) -> assert (e1 == exp) | Pld _ -> assert false @@ -1359,15 +1374,15 @@ end = struct let f {pbop_exp; _} = pbop_exp == exp in assert (f let_ || List.exists ~f ands || body == exp) | (Pexp_match (e, _) | Pexp_try (e, _)) when e == exp -> () - | Pexp_function cases | Pexp_match (_, cases) | Pexp_try (_, cases) + | Pexp_match (_, cases) | Pexp_try (_, cases) -> - assert ( - List.exists cases ~f:(function - | {pc_guard= Some g; _} when g == exp -> true - | {pc_rhs; _} when pc_rhs == exp -> true - | _ -> false ) ) - | Pexp_fun (param, body) -> - assert (check_expr_function_param param || body == exp) + assert (check_cases cases) + | Pexp_function (params, _, body) -> + let check_body = match body with + | Pfunction_body body -> body == exp + | Pfunction_cases (cases, _, _) -> check_cases cases + in + assert (List.exists ~f:check_expr_function_param params || check_body) | Pexp_indexop_access {pia_lhs; pia_kind= Builtin idx; pia_rhs; _} -> assert ( pia_lhs == exp || idx == exp @@ -1867,7 +1882,7 @@ end = struct | Ppat_cons _ -> true | Ppat_construct _ | Ppat_record _ | Ppat_variant _ -> false | _ -> true ) - | Fpe {pparam_desc= Param_val (_, _, _); _}, Ppat_cons _ -> true + | Fpe {pparam_desc= Pparam_val (_, _, _); _}, Ppat_cons _ -> true | Fpc {pparam_desc= _; _}, Ppat_cons _ -> true | Pat {ppat_desc= Ppat_construct _; _}, Ppat_cons _ -> true | _, Ppat_constraint (_, {ptyp_desc= Ptyp_poly _; _}) -> false @@ -1901,7 +1916,7 @@ end = struct ( Ppat_construct _ | Ppat_exception _ | Ppat_or _ | Ppat_lazy _ | Ppat_tuple _ | Ppat_variant _ | Ppat_list _ ) ; _ } - | Exp {pexp_desc= Pexp_fun _; _} ) + | Exp {pexp_desc= Pexp_function _; _} ) , Ppat_alias _ ) |( Pat {ppat_desc= Ppat_lazy _; _} , ( Ppat_construct _ | Ppat_cons _ @@ -1917,14 +1932,14 @@ end = struct |Pat {ppat_desc= Ppat_tuple _; _}, Ppat_tuple _ |Pat _, Ppat_lazy _ |Pat _, Ppat_exception _ - |Exp {pexp_desc= Pexp_fun _; _}, Ppat_or _ + |Exp {pexp_desc= Pexp_function _; _}, Ppat_or _ |Cl {pcl_desc= Pcl_fun _; _}, Ppat_variant (_, Some _) |Cl {pcl_desc= Pcl_fun _; _}, Ppat_tuple _ |Cl {pcl_desc= Pcl_fun _; _}, Ppat_construct _ |Cl {pcl_desc= Pcl_fun _; _}, Ppat_alias _ |Cl {pcl_desc= Pcl_fun _; _}, Ppat_lazy _ |(Exp {pexp_desc= Pexp_letop _; _} | Bo _), Ppat_exception _ - |( Exp {pexp_desc= Pexp_fun _; _} + |( Exp {pexp_desc= Pexp_function _; _} , ( Ppat_construct _ | Ppat_cons _ | Ppat_lazy _ | Ppat_tuple _ | Ppat_variant _ ) ) -> true @@ -1976,7 +1991,7 @@ end = struct match exp.pexp_desc with | Pexp_assert e |Pexp_construct (_, Some e) - |Pexp_fun (_, e) + |Pexp_function (_, _, Pfunction_body e) |Pexp_ifthenelse (_, Some e) |Pexp_prefix (_, e) |Pexp_infix (_, _, e) @@ -2004,7 +2019,8 @@ end = struct match cls with Match | Then | ThenElse -> continue e | _ -> false ) | Pexp_match _ when match cls with Then -> true | _ -> false -> false - | Pexp_function cases | Pexp_match (_, cases) | Pexp_try (_, cases) + | Pexp_function (_, _, Pfunction_cases (cases, _, _)) + | Pexp_match (_, cases) | Pexp_try (_, cases) -> continue (List.last_exn cases).pc_rhs | Pexp_apply (_, args) -> continue (snd (List.last_exn args)) @@ -2057,7 +2073,7 @@ end = struct |Pexp_lazy e |Pexp_open (_, e) |Pexp_letopen (_, e) - |Pexp_fun (_, e) + |Pexp_function (_, _, Pfunction_body e) |Pexp_sequence (_, e) |Pexp_setfield (_, _, e) |Pexp_setinstvar (_, e) @@ -2073,13 +2089,15 @@ end = struct | Pexp_extension (ext, PStr [{pstr_desc= Pstr_eval (e, _); _}]) when Source.extension_using_sugar ~name:ext ~payload:e.pexp_loc -> ( match e.pexp_desc with - | Pexp_function cases | Pexp_match (_, cases) | Pexp_try (_, cases) + | Pexp_function (_, _, Pfunction_cases (cases, _, _)) + | Pexp_match (_, cases) | Pexp_try (_, cases) -> List.iter cases ~f:(fun case -> mark_parenzed_inner_nested_match case.pc_rhs ) ; true | _ -> continue e ) - | Pexp_function cases | Pexp_match (_, cases) | Pexp_try (_, cases) -> + | Pexp_function (_, _, Pfunction_cases (cases, _, _)) + | Pexp_match (_, cases) | Pexp_try (_, cases) -> List.iter cases ~f:(fun case -> mark_parenzed_inner_nested_match case.pc_rhs ) ; true @@ -2249,13 +2267,15 @@ end = struct [ { pstr_desc= Pstr_eval ( { pexp_desc= - ( Pexp_function cases + ( + Pexp_function (_, _, Pfunction_cases (cases, _, _)) + | Pexp_match (_, cases) | Pexp_try (_, cases) ) ; _ } , _ ) ; _ } ] ) - |Pexp_function cases + | Pexp_function (_, _, Pfunction_cases (cases, _, _)) |Pexp_match (_, cases) |Pexp_try (_, cases) -> if !leading_nested_match_parens then From dae3c6c337ce6b62087d4c011c79846c353d73a7 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Fri, 8 Mar 2024 12:11:15 +0100 Subject: [PATCH 005/146] WIP: Extended_ast --- lib/Extended_ast.ml | 21 +-------------------- 1 file changed, 1 insertion(+), 20 deletions(-) diff --git a/lib/Extended_ast.ml b/lib/Extended_ast.ml index 307543a223..af0ff02d9b 100644 --- a/lib/Extended_ast.ml +++ b/lib/Extended_ast.ml @@ -183,7 +183,7 @@ module Parse = struct {p with ppat_desc= Ppat_unpack (name, Some pt)} | p -> Ast_mapper.default_mapper.pat m p in - let rec expr (m : Ast_mapper.mapper) = function + let expr (m : Ast_mapper.mapper) = function | {pexp_desc= Pexp_cons (_ :: _ :: _ :: _ as l); _} as e when match List.last_exn l with (* Empty lists are always represented as Lident [] *) @@ -233,25 +233,6 @@ module Parse = struct (module S) = (module M)] - [let _ = ((module M) : (module S))] *) {p with pexp_desc= Pexp_pack (name, Some pt)} - | { pexp_desc= - Pexp_fun - ({pparam_desc= Param_newtype types1; pparam_loc= loc1}, e1) - ; pexp_attributes= [] - ; _ } as e -> - let e = - match (expr m e1).pexp_desc with - | Pexp_fun - ({pparam_desc= Param_newtype types2; pparam_loc= loc2}, e2) - -> - { e with - pexp_desc= - Pexp_fun - ( { pparam_desc= Param_newtype (types1 @ types2) - ; pparam_loc= {loc1 with loc_end= loc2.loc_end} } - , e2 ) } - | _ -> e - in - Ast_mapper.default_mapper.expr m e | e -> Ast_mapper.default_mapper.expr m e in Ast_mapper.{default_mapper with expr; pat; binding_op} From 9d92bb75a76dea7d705716c7a83facaba19d4006 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Fri, 8 Mar 2024 12:11:26 +0100 Subject: [PATCH 006/146] Remove Sugar.fun_ --- lib/Sugar.ml | 17 ----------------- lib/Sugar.mli | 9 --------- 2 files changed, 26 deletions(-) diff --git a/lib/Sugar.ml b/lib/Sugar.ml index 52c520978e..b3f454ff73 100644 --- a/lib/Sugar.ml +++ b/lib/Sugar.ml @@ -14,23 +14,6 @@ open Asttypes open Ast open Extended_ast -let fun_ cmts ?(will_keep_first_ast_node = true) xexp = - let rec fun_ ?(will_keep_first_ast_node = false) ({ast= exp; _} as xexp) = - let ctx = Exp exp in - let {pexp_desc; pexp_loc; pexp_attributes; _} = exp in - if will_keep_first_ast_node || List.is_empty pexp_attributes then - match pexp_desc with - | Pexp_fun (p, body) -> - if not will_keep_first_ast_node then - Cmts.relocate cmts ~src:pexp_loc ~before:p.pparam_loc - ~after:body.pexp_loc ; - let xargs, xbody = fun_ (sub_exp ~ctx body) in - (p :: xargs, xbody) - | _ -> ([], xexp) - else ([], xexp) - in - fun_ ~will_keep_first_ast_node xexp - module Exp = struct let infix cmts prec xexp = let assoc = Option.value_map prec ~default:Assoc.Non ~f:Assoc.of_prec in diff --git a/lib/Sugar.mli b/lib/Sugar.mli index c97c5d4bde..cc0c015315 100644 --- a/lib/Sugar.mli +++ b/lib/Sugar.mli @@ -13,15 +13,6 @@ open Migrate_ast open Asttypes open Extended_ast -val fun_ : - Cmts.t - -> ?will_keep_first_ast_node:bool - -> expression Ast.xt - -> expr_function_param list * expression Ast.xt -(** [fun_ cmts will_keep_first_ast_node exp] returns the list of arguments - and the body of the function [exp]. [will_keep_first_ast_node] is set by - default, otherwise the [exp] is returned without modification. *) - module Exp : sig val infix : Cmts.t From d7c439204e74381233de1445f2f9dbb114da5578 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Fri, 8 Mar 2024 12:11:38 +0100 Subject: [PATCH 007/146] WIP: Params --- lib/Params.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Params.ml b/lib/Params.ml index 0f8a74a4df..64bc3f6f69 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -70,7 +70,7 @@ module Exp = struct | Pexp_apply (_, args) -> ( (* Rhs is an apply and it ends with a [fun]. *) match List.last_exn args with - | _, {pexp_desc= Pexp_fun _ | Pexp_function _; _} -> true + | _, {pexp_desc= Pexp_function _; _} -> true | _ -> false ) | Pexp_match _ | Pexp_try _ -> true | _ -> false From bd08b270ba901ad7005bba242070d52b1c3dc0e2 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Fri, 8 Mar 2024 12:11:57 +0100 Subject: [PATCH 008/146] WIP: Fmt_ast --- lib/Fmt_ast.ml | 32 +++++++++----------------------- 1 file changed, 9 insertions(+), 23 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index e38f1e1c23..d314d60e55 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -746,25 +746,6 @@ and fmt_type_cstr c ?constraint_ctx xtyp = (fmt_core_type c ~pro:":" ?constraint_ctx ~pro_space:(not colon_before) ~box:(not colon_before) xtyp ) -and type_constr_and_body c xbody = - let body = xbody.ast in - match xbody.ast.pexp_desc with - | Pexp_constraint (exp, typ) -> - Cmts.relocate c.cmts ~src:body.pexp_loc ~before:exp.pexp_loc - ~after:exp.pexp_loc ; - let typ_ctx = Exp body in - let exp_ctx = - let pat = Ast_helper.Pat.any () in - let param = - { pparam_desc= Param_val (Nolabel, None, pat) - ; pparam_loc= pat.ppat_loc } - in - Exp Ast_helper.(Exp.fun_ param exp) - in - ( Some (fmt_type_cstr c ~constraint_ctx:`Fun (sub_typ ~ctx:typ_ctx typ)) - , sub_exp ~ctx:exp_ctx exp ) - | _ -> (None, xbody) - and fmt_arrow_param c ctx {pap_label= lI; pap_loc= locI; pap_type= tI} = let arg_label lbl = match lbl with @@ -1305,7 +1286,7 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false) $ wrap (str opn) (str cls) (break 0 2 $ fmt_pattern c (sub_pat ~ctx pat)) ) -and fmt_param_val c ctx : param_val -> _ = function +and fmt_param_val c ctx : pparam_val -> _ = function | ( ((Labelled l | Optional l) as lbl) , None , ( { ppat_desc= @@ -1379,7 +1360,7 @@ and fmt_param_val c ctx : param_val -> _ = function $ str " =" $ break 1 2 $ fmt_expression c xexp ) ) | (Labelled _ | Nolabel), Some _, _ -> impossible "not accepted by parser" -and fmt_param_newtype c : param_newtype -> _ = function +and fmt_param_newtype c = function | [] -> impossible "not accepted by parser" | names -> cbox 0 @@ -1391,8 +1372,8 @@ and fmt_expr_fun_arg c fp = Cmts.fmt c fp.pparam_loc @@ match fp.pparam_desc with - | Param_val x -> fmt_param_val c ctx x - | Param_newtype x -> fmt_param_newtype c x + | Pparam_val x -> fmt_param_val c ctx x + | Pparam_newtype x -> fmt_param_newtype c x and fmt_class_fun_arg c fp = let ctx = Fpc fp in @@ -1473,6 +1454,7 @@ and fmt_fun ?force_closing_paren in let xargs, xbody = Sugar.fun_ c.cmts xast in let fmt_cstr, xbody = type_constr_and_body c xbody in + (* fmt_type_cstr c ~constraint_ctx:`Fun (sub_typ ~ctx:typ_ctx typ) *) let body = let box = match xbody.ast.pexp_desc with @@ -1808,6 +1790,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens , e2 ) -> let xargs, xbody = Sugar.fun_ c.cmts (sub_exp ~ctx:(Str pld) call) in let fmt_cstr, xbody = type_constr_and_body c xbody in + (* fmt_type_cstr c ~constraint_ctx:`Fun (sub_typ ~ctx:typ_ctx typ) *) let is_simple x = is_simple c.conf (expression_width c) x in let break xexp1 xexp2 = not (is_simple xexp1 && is_simple xexp2) in let grps = @@ -1845,6 +1828,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens ; _ } ) -> let xargs, xbody = Sugar.fun_ c.cmts (sub_exp ~ctx:(Str pld) retn) in let fmt_cstr, xbody = type_constr_and_body c xbody in + (* fmt_type_cstr c ~constraint_ctx:`Fun (sub_typ ~ctx:typ_ctx typ) *) pro $ hvbox 0 (Params.Exp.wrap c.conf ~parens @@ -1917,6 +1901,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens let parens_r = parenze_exp xr in let xargs, xbody = Sugar.fun_ c.cmts xr in let fmt_cstr, xbody = type_constr_and_body c xbody in + (* fmt_type_cstr c ~constraint_ctx:`Fun (sub_typ ~ctx:typ_ctx typ) *) let indent_wrap = if parens then -2 else 0 in let pre_body, body = fmt_body c ?ext xbody in let followed_by_infix_op = @@ -2281,6 +2266,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens | Pexp_fun _ -> let xargs, xbody = Sugar.fun_ c.cmts xexp in let fmt_cstr, xbody = type_constr_and_body c xbody in + (* fmt_type_cstr c ~constraint_ctx:`Fun (sub_typ ~ctx:typ_ctx typ) *) let body_is_function = match xbody.ast.pexp_desc with Pexp_function _ -> true | _ -> false in From 4931f069b8e75ee42ac11b16c3bfb63708cff2b8 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Tue, 12 Mar 2024 11:55:36 +0100 Subject: [PATCH 009/146] WIP: Fmt_ast Rewrote the patterns 'Pexp_function cs' and 'Pexp_fun _ | Pexp_function _'. Remaining are 'Pexp_fun' and tweaking the formatting code. --- lib/Fmt_ast.ml | 58 ++++++++++++++++++++++++++++++-------------------- 1 file changed, 35 insertions(+), 23 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index d314d60e55..790023011d 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1162,7 +1162,11 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false) let nested = match ctx0 with | Pat {ppat_desc= Ppat_or _; _} - |Exp {pexp_desc= Pexp_match _ | Pexp_try _ | Pexp_function _; _} -> + |Exp + { pexp_desc= + ( Pexp_match _ | Pexp_try _ + | Pexp_function (_, _, Pfunction_cases _) ) + ; _ } -> List.is_empty xpat.ast.ppat_attributes | _ -> false in @@ -1389,7 +1393,10 @@ and fmt_body c ?ext ({ast= body; _} as xbody) = let ctx = Exp body in let parens = parenze_exp xbody in match body with - | {pexp_desc= Pexp_function cs; pexp_attributes; pexp_loc; _} -> + | { pexp_desc= Pexp_function (_, _, Pfunction_cases (_, _, cs)) + ; pexp_attributes + ; pexp_loc + ; _ } -> ( ( update_config_maybe_disabled c pexp_loc pexp_attributes @@ fun c -> space_break @@ -1458,7 +1465,7 @@ and fmt_fun ?force_closing_paren let body = let box = match xbody.ast.pexp_desc with - | Pexp_fun _ | Pexp_function _ -> Some false + | Pexp_function _ -> Some false | _ -> None in fmt_expression c ?box xbody @@ -1536,9 +1543,7 @@ and fmt_args_grouped ?epi:(global_epi = noop) c ctx args = let fmt_arg c ~first:_ ~last (lbl, arg) = let ({ast; _} as xarg) = sub_exp ~ctx arg in let box = - match ast.pexp_desc with - | Pexp_fun _ | Pexp_function _ -> Some false - | _ -> None + match ast.pexp_desc with Pexp_function _ -> Some false | _ -> None in let break_after = match (ast.pexp_desc, c.conf.fmt_opts.break_string_literals.v) with @@ -1682,7 +1687,7 @@ and fmt_infix_op_args c ~parens xexp op_args = else let expr_box = match xarg.ast.pexp_desc with - | Pexp_fun _ | Pexp_function _ -> Some false + | Pexp_function _ -> Some false | _ -> None in hvbox 0 @@ -1790,7 +1795,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens , e2 ) -> let xargs, xbody = Sugar.fun_ c.cmts (sub_exp ~ctx:(Str pld) call) in let fmt_cstr, xbody = type_constr_and_body c xbody in - (* fmt_type_cstr c ~constraint_ctx:`Fun (sub_typ ~ctx:typ_ctx typ) *) + (* fmt_type_cstr c ~constraint_ctx:`Fun (sub_typ ~ctx:typ_ctx typ) *) let is_simple x = is_simple c.conf (expression_width c) x in let break xexp1 xexp2 = not (is_simple xexp1 && is_simple xexp2) in let grps = @@ -1828,7 +1833,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens ; _ } ) -> let xargs, xbody = Sugar.fun_ c.cmts (sub_exp ~ctx:(Str pld) retn) in let fmt_cstr, xbody = type_constr_and_body c xbody in - (* fmt_type_cstr c ~constraint_ctx:`Fun (sub_typ ~ctx:typ_ctx typ) *) + (* fmt_type_cstr c ~constraint_ctx:`Fun (sub_typ ~ctx:typ_ctx typ) *) pro $ hvbox 0 (Params.Exp.wrap c.conf ~parens @@ -1901,13 +1906,12 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens let parens_r = parenze_exp xr in let xargs, xbody = Sugar.fun_ c.cmts xr in let fmt_cstr, xbody = type_constr_and_body c xbody in - (* fmt_type_cstr c ~constraint_ctx:`Fun (sub_typ ~ctx:typ_ctx typ) *) + (* fmt_type_cstr c ~constraint_ctx:`Fun (sub_typ ~ctx:typ_ctx typ) *) let indent_wrap = if parens then -2 else 0 in let pre_body, body = fmt_body c ?ext xbody in let followed_by_infix_op = match xbody.ast.pexp_desc with - | Pexp_infix (_, _, {pexp_desc= Pexp_fun _ | Pexp_function _; _}) -> - true + | Pexp_infix (_, _, {pexp_desc= Pexp_function _; _}) -> true | _ -> false in pro @@ -1940,7 +1944,10 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens | Pexp_infix ( op , l - , ({pexp_desc= Pexp_function cs; pexp_loc; pexp_attributes; _} as r) ) + , ( { pexp_desc= Pexp_function (_, _, Pfunction_cases (_, _, cs)) + ; pexp_loc + ; pexp_attributes + ; _ } as r ) ) when not c.conf.fmt_opts.break_infix_before_func.v -> let cmts_before = Cmts.fmt_before c pexp_loc in let cmts_after = Cmts.fmt_after c pexp_loc in @@ -2055,7 +2062,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens let args = let break_body = match eN1_body.pexp_desc with - | Pexp_function _ -> + | Pexp_function (_, _, Pfunction_cases _) -> break 1 (Params.Indent.docked_function_after_fun c.conf ~parens:true ~lbl ) @@ -2081,7 +2088,8 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens in hvbox_if has_attr 0 (expr_epi $ Params.parens_if parens c.conf (args $ fmt_atrs)) - | Pexp_function [{pc_lhs; pc_guard= None; pc_rhs}] + | Pexp_function + (_, _, Pfunction_cases (_, _, [{pc_lhs; pc_guard= None; pc_rhs}])) when List.for_all args_before ~f:(fun (_, eI) -> is_simple c.conf (fun _ -> 0) (sub_exp ~ctx eI) ) -> let force = @@ -2118,7 +2126,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens $ closing_paren c ~force $ Cmts.fmt_after c last_arg.pexp_loc ) $ fmt_atrs ) ) - | Pexp_function cs + | Pexp_function (_, _, Pfunction_cases (_, _, cs)) when List.for_all args_before ~f:(fun (_, eI) -> is_simple c.conf (fun _ -> 0) (sub_exp ~ctx eI) ) -> let wrap = @@ -2266,9 +2274,11 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens | Pexp_fun _ -> let xargs, xbody = Sugar.fun_ c.cmts xexp in let fmt_cstr, xbody = type_constr_and_body c xbody in - (* fmt_type_cstr c ~constraint_ctx:`Fun (sub_typ ~ctx:typ_ctx typ) *) + (* fmt_type_cstr c ~constraint_ctx:`Fun (sub_typ ~ctx:typ_ctx typ) *) let body_is_function = - match xbody.ast.pexp_desc with Pexp_function _ -> true | _ -> false + match xbody.ast.pexp_desc with + | Pexp_function (_, _, Pfunction_cases _) -> true + | _ -> false in let pre_body, body = fmt_body c ?ext xbody in let indent = @@ -2295,7 +2305,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens (Params.Exp.wrap c.conf ~parens ~disambiguate:true ~fits_breaks:false ~offset_closing_paren:(-2) (hovbox 2 (intro $ str " ->" $ pre_body) $ space_break $ body) ) - | Pexp_function cs -> + | Pexp_function (_, _, Pfunction_cases (_, _, cs)) -> let indent = Params.Indent.function_ c.conf ~parens xexp in pro $ Params.Exp.wrap c.conf ~parens ~disambiguate:true ~fits_breaks:false @@ -2682,8 +2692,8 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens | Pexp_new _ | Pexp_letmodule _ | Pexp_object _ | Pexp_function _ | Pexp_letexception _ | Pexp_open _ | Pexp_assert _ | Pexp_lazy _ - | Pexp_pack _ | Pexp_fun _ | Pexp_beginend _ - | Pexp_letopen _ ) + | Pexp_pack _ | Pexp_beginend _ | Pexp_letopen _ + ) ; pexp_attributes= [] ; _ } as e1 ) , _ ) @@ -4538,8 +4548,10 @@ and fmt_value_binding c ~rec_flag ?in_ ?epi let fmt_newtypes, fmt_cstr = fmt_value_constraint c lb_typ in let indent = match lb_exp.ast.pexp_desc with - | Pexp_function _ -> c.conf.fmt_opts.function_indent.v - | Pexp_fun _ when c.conf.fmt_opts.let_binding_deindent_fun.v -> + | Pexp_function (_, _, Pfunction_cases _) -> + c.conf.fmt_opts.function_indent.v + | Pexp_function (_, _, Pfunction_body _) + when c.conf.fmt_opts.let_binding_deindent_fun.v -> max (c.conf.fmt_opts.let_binding_indent.v - 1) 0 | _ -> c.conf.fmt_opts.let_binding_indent.v in From 21a43751c7067048c7e50b60d620071af343157d Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 18 Mar 2024 12:05:36 +0100 Subject: [PATCH 010/146] WIP: More precise matching --- lib/Fmt_ast.ml | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 790023011d..8d176ddacf 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1165,7 +1165,7 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false) |Exp { pexp_desc= ( Pexp_match _ | Pexp_try _ - | Pexp_function (_, _, Pfunction_cases _) ) + | Pexp_function ([], None, Pfunction_cases _) ) ; _ } -> List.is_empty xpat.ast.ppat_attributes | _ -> false @@ -1393,7 +1393,7 @@ and fmt_body c ?ext ({ast= body; _} as xbody) = let ctx = Exp body in let parens = parenze_exp xbody in match body with - | { pexp_desc= Pexp_function (_, _, Pfunction_cases (_, _, cs)) + | { pexp_desc= Pexp_function ([], None, Pfunction_cases (cs, _, _)) ; pexp_attributes ; pexp_loc ; _ } -> @@ -1944,13 +1944,10 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens | Pexp_infix ( op , l - , ( { pexp_desc= Pexp_function (_, _, Pfunction_cases (_, _, cs)) - ; pexp_loc - ; pexp_attributes - ; _ } as r ) ) + , ({pexp_desc= Pexp_function ([], None, Pfunction_cases (cs, loc, attrs)); pexp_loc; pexp_attributes; _} as r) ) when not c.conf.fmt_opts.break_infix_before_func.v -> - let cmts_before = Cmts.fmt_before c pexp_loc in - let cmts_after = Cmts.fmt_after c pexp_loc in + let cmts_before = Cmts.fmt_before c pexp_loc $ Cmts.fmt_before c loc in + let cmts_after = Cmts.fmt_after c loc $ Cmts.fmt_after c pexp_loc in let xr = sub_exp ~ctx r in let parens_r = parenze_exp xr in let indent = Params.Indent.function_ c.conf ~parens xr in @@ -1966,7 +1963,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens $ fmt_if parens_r (str "( ") $ str "function" $ fmt_extension_suffix c ext ) - $ fmt_attributes c pexp_attributes ) ) + $ fmt_attributes c (pexp_attributes @ attrs) ) ) $ space_break $ fmt_cases c (Exp r) cs $ fmt_if parens_r (str " )") $ cmts_after ) ) @@ -2062,7 +2059,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens let args = let break_body = match eN1_body.pexp_desc with - | Pexp_function (_, _, Pfunction_cases _) -> + | Pexp_function ([], None, Pfunction_cases _) -> break 1 (Params.Indent.docked_function_after_fun c.conf ~parens:true ~lbl ) @@ -2089,7 +2086,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens hvbox_if has_attr 0 (expr_epi $ Params.parens_if parens c.conf (args $ fmt_atrs)) | Pexp_function - (_, _, Pfunction_cases (_, _, [{pc_lhs; pc_guard= None; pc_rhs}])) + ([], None, Pfunction_cases ([{pc_lhs; pc_guard= None; pc_rhs}], loc, attrs)) when List.for_all args_before ~f:(fun (_, eI) -> is_simple c.conf (fun _ -> 0) (sub_exp ~ctx eI) ) -> let force = @@ -2112,10 +2109,12 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens $ fmt_args_grouped e0 args_before $ space_break $ Cmts.fmt_before c last_arg.pexp_loc + $ Cmts.fmt_before c loc + $ fmt_label lbl ":" $ str "(function" $ fmt_label lbl (str ":") $ str "(function" $ fmt_attributes c ~pre:Blank - last_arg.pexp_attributes ) + (last_arg.pexp_attributes @ attrs) ) $ space_break $ leading_cmt $ hvbox 0 ( fmt_pattern c ~pro:(if_newline "| ") @@ -2124,9 +2123,10 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens $ space_break $ cbox 0 (fmt_expression c (sub_exp ~ctx pc_rhs)) $ closing_paren c ~force + $ Cmts.fmt_after c loc $ Cmts.fmt_after c last_arg.pexp_loc ) $ fmt_atrs ) ) - | Pexp_function (_, _, Pfunction_cases (_, _, cs)) + | Pexp_function ([], None, Pfunction_cases (cs, loc, attrs)) when List.for_all args_before ~f:(fun (_, eI) -> is_simple c.conf (fun _ -> 0) (sub_exp ~ctx eI) ) -> let wrap = @@ -2277,7 +2277,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens (* fmt_type_cstr c ~constraint_ctx:`Fun (sub_typ ~ctx:typ_ctx typ) *) let body_is_function = match xbody.ast.pexp_desc with - | Pexp_function (_, _, Pfunction_cases _) -> true + | Pexp_function ([], None, Pfunction_cases _) -> true | _ -> false in let pre_body, body = fmt_body c ?ext xbody in @@ -2305,7 +2305,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens (Params.Exp.wrap c.conf ~parens ~disambiguate:true ~fits_breaks:false ~offset_closing_paren:(-2) (hovbox 2 (intro $ str " ->" $ pre_body) $ space_break $ body) ) - | Pexp_function (_, _, Pfunction_cases (_, _, cs)) -> + | Pexp_function ([], None, Pfunction_cases (cs, _, _)) -> let indent = Params.Indent.function_ c.conf ~parens xexp in pro $ Params.Exp.wrap c.conf ~parens ~disambiguate:true ~fits_breaks:false From 465360117d777d3242b8b0d11ec75c8fed132e16 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 18 Mar 2024 12:05:46 +0100 Subject: [PATCH 011/146] WIP: Preliminary fmt_function --- lib/Fmt_ast.ml | 92 ++++++++++++++++++++++++++++++-------------------- 1 file changed, 55 insertions(+), 37 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 8d176ddacf..ae3771c484 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -739,12 +739,17 @@ and fmt_record_field c ?typ1 ?typ2 ?rhs lid1 = $ cbox 0 (fmt_longident_loc c lid1 $ Cmts.fmt_after c lid1.loc $ fmt_type_rhs) -and fmt_type_cstr c ?constraint_ctx xtyp = +and fmt_type_cstr c ~ctx ?constraint_ctx typ = let colon_before = Poly.(c.conf.fmt_opts.break_colon.v = `Before) in + let fmt_typ ~pro t = + fmt_core_type c ~pro ?constraint_ctx ~pro_space:(not colon_before) + ~box:(not colon_before) (sub_typ ~ctx t) + in fmt_or colon_before (fits_breaks " " ~hint:(1000, 0) "") (break 0 (-1)) - $ cbox_if colon_before 0 - (fmt_core_type c ~pro:":" ?constraint_ctx ~pro_space:(not colon_before) - ~box:(not colon_before) xtyp ) + $ cbox_if colon_before 0 @@ + (match typ with + | Pconstraint t -> fmt_typ ~pro:":" t + | Pcoerce (t1, t2) -> opt t1 (fmt_typ ~pro:":") $ fmt_typ ~pro:":>" t2) and fmt_arrow_param c ctx {pap_label= lI; pap_loc= locI; pap_type= tI} = let arg_label lbl = @@ -1444,35 +1449,20 @@ and fmt_indexop_access c ctx ~fmt_atrs ~has_attr ~parens x = fmt_assign_arrow c $ fmt_expression c (sub_exp ~ctx e) ) ) $ fmt_atrs ) ) -(** Format [Pexp_fun] or [Pexp_newtype]. [wrap_intro] wraps up to after the - [->] and is responsible for breaking. *) -and fmt_fun ?force_closing_paren - ?(wrap_intro = fun x -> hvbox 2 x $ space_break) ?(box = true) ~label - ?(parens = false) c ({ast; _} as xast) = +(** Format a [Pexp_function]. [wrap_intro] wraps up to after the [->] and is + responsible for breaking. *) +and fmt_function ?force_closing_paren ~ctx ?(wrap_intro = fun x -> hvbox 2 x $ space_break) ?(box = true) + ~label ?(parens = false) ~attrs ~loc c (args, typ, body) = let has_label = match label with Nolabel -> false | _ -> true in (* Make sure the comment is placed after the eventual label but not into the inner box if no label is present. Side effects of Cmts.fmt c.cmts before Sugar.fun_ is important. *) let has_cmts_outer, cmts_outer, cmts_inner = let eol = if has_label then Some cut_break else None in - let has_cmts = Cmts.has_before c.cmts ast.pexp_loc in - let cmts = Cmts.fmt_before ?eol c ast.pexp_loc in + let has_cmts = Cmts.has_before c.cmts loc in + let cmts = Cmts.fmt_before ?eol c loc in if has_label then (false, noop, cmts) else (has_cmts, cmts, noop) in - let xargs, xbody = Sugar.fun_ c.cmts xast in - let fmt_cstr, xbody = type_constr_and_body c xbody in - (* fmt_type_cstr c ~constraint_ctx:`Fun (sub_typ ~ctx:typ_ctx typ) *) - let body = - let box = - match xbody.ast.pexp_desc with - | Pexp_function _ -> Some false - | _ -> None - in - fmt_expression c ?box xbody - and closing = - if parens then closing_paren c ?force:force_closing_paren ~offset:(-2) - else noop - in let (label_sep : t), break_fun = (* Break between the label and the fun to avoid ocp-indent's alignment. If a label is present, arguments should be indented more than the @@ -1481,22 +1471,50 @@ and fmt_fun ?force_closing_paren (str ":" $ cut_break, break 1 2) else (str ":", if has_label then break 1 2 else space_break) in + let fmt_typ typ = + fmt_type_cstr c ~ctx ~constraint_ctx:`Fun typ + in + let fmt_fun_args_typ args typ = + str "fun" $ fmt_attributes c attrs $ break_fun + $ fmt_expr_fun_args c args $ fmt_opt (Option.map ~f:fmt_typ typ) + $ break 1 (-2) $ str "->" + in + (* [head] is [fun args ->] or [function]. [body] is an expression or the + cases. *) + let head, body = + match args, typ, body with + | (_ :: _), _, Pfunction_body body -> + (* Only [fun]. *) + fmt_fun_args_typ args typ, fmt_expression c (sub_exp ~ctx body) + | [], _, Pfunction_body _ -> assert false + | args, typ, Pfunction_cases (cs, loc, cs_attrs) -> + (* Only [function]. *) + let fun_ = + match args, typ with + | [], None -> noop + | [], Some _ -> assert false + | args, typ -> fmt_fun_args_typ args typ + and function_ = + str "function" $ fmt_attributes c cs_attrs + in + fun_ $ function_, fmt_cases c ctx cs + in + let opn_paren, cls_paren = + if parens then str "(", closing_paren c ?force:force_closing_paren ~offset:(-2) + else noop, noop + in hovbox_if box 2 ( wrap_intro (hvbox_if has_cmts_outer 0 ( cmts_outer $ hvbox 2 ( fmt_label label label_sep $ cmts_inner - $ fmt_if parens (str "(") - $ str "fun" $ break_fun - $ hvbox 0 - ( fmt_attributes c ast.pexp_attributes ~suf:" " - $ fmt_expr_fun_args c xargs $ fmt_opt fmt_cstr - $ break 1 (-2) $ str "->" ) ) ) ) - $ body $ closing - $ Cmts.fmt_after c ast.pexp_loc ) - -and fmt_label_arg ?(box = true) ?eol c (lbl, ({ast= arg; _} as xarg)) = + $ opn_paren + $ head ) ) ) + $ body $ cls_paren + $ Cmts.fmt_after c loc ) + +and fmt_label_arg ?(box = true) ?eol c (lbl, ({ast= arg; ctx} as xarg)) = match (lbl, arg.pexp_desc) with | (Labelled l | Optional l), Pexp_ident {txt= Lident i; loc} when String.equal l.txt i && List.is_empty arg.pexp_attributes -> @@ -1524,8 +1542,8 @@ and fmt_label_arg ?(box = true) ?eol c (lbl, ({ast= arg; _} as xarg)) = ~pro:(fmt_label lbl (str ":" $ break 0 2)) ~box xarg ) $ cmts_after ) - | (Labelled _ | Optional _), Pexp_fun _ -> - fmt_fun ~box ~label:lbl ~parens:true c xarg + | (Labelled _ | Optional _), Pexp_function (args, typ, body) -> + fmt_function ~ctx ~label:lbl ~parens:true ~attrs:arg.pexp_attributes ~loc:arg.pexp_loc c (args, typ, body) | _ -> let label_sep : t = if box || c.conf.fmt_opts.wrap_fun_args.v then str ":" $ cut_break From 4af9c7341050bee18f8331db98568af0debbd071 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 18 Mar 2024 16:31:56 +0100 Subject: [PATCH 012/146] WIP: Matching --- lib/Fmt_ast.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index ae3771c484..9e3dc2b6f3 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1807,7 +1807,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens ( name , PStr [ ( { pstr_desc= - Pstr_eval (({pexp_desc= Pexp_fun _; _} as call), []) + Pstr_eval (({pexp_desc= Pexp_function (_, _, Pfunction_body _); _} as call), []) ; pstr_loc= _ } as pld ) ] ) ; _ } , e2 ) -> @@ -1846,7 +1846,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens ( name , PStr [ ( { pstr_desc= - Pstr_eval (({pexp_desc= Pexp_fun _; _} as retn), []) + Pstr_eval (({pexp_desc= Pexp_function (_, _, Pfunction_body _); _} as retn), []) ; pstr_loc= _ } as pld ) ] ) ; _ } ) -> let xargs, xbody = Sugar.fun_ c.cmts (sub_exp ~ctx:(Str pld) retn) in @@ -1915,7 +1915,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens $ hvbox 0 (fmt_str_loc c op) $ fmt_expression c (sub_exp ~ctx r) ) | Pexp_infix - (op, l, ({pexp_desc= Pexp_fun _; pexp_loc; pexp_attributes; _} as r)) + (op, l, ({pexp_desc= Pexp_function (_, _, Pfunction_body _); pexp_loc; pexp_attributes; _} as r)) when not c.conf.fmt_opts.break_infix_before_func.v -> (* side effects of Cmts.fmt c.cmts before Sugar.fun_ is important *) let cmts_before = Cmts.fmt_before c pexp_loc in @@ -2069,7 +2069,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens if parens || not dock_fun_arg then (noop, pro) else (pro, noop) in match last_arg.pexp_desc with - | Pexp_fun (_, eN1_body) + | Pexp_function (_, _, Pfunction_body eN1_body) when List.for_all args_before ~f:(fun (_, eI) -> is_simple c.conf (fun _ -> 0) (sub_exp ~ctx eI) ) -> (* Last argument is a [fun _ ->]. *) @@ -2289,7 +2289,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens (Params.parens_if parens c.conf ( fmt_expression c (sub_exp ~ctx exp) $ cut_break $ str "." $ fmt_longident_loc c lid $ fmt_atrs ) ) - | Pexp_fun _ -> + | Pexp_function (_, _, Pfunction_body _) -> let xargs, xbody = Sugar.fun_ c.cmts xexp in let fmt_cstr, xbody = type_constr_and_body c xbody in (* fmt_type_cstr c ~constraint_ctx:`Fun (sub_typ ~ctx:typ_ctx typ) *) From 19eb8ae7943e370238029c263706c195d0f3d5ce Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 18 Mar 2024 16:32:13 +0100 Subject: [PATCH 013/146] WIP: fmt_function call sites --- lib/Fmt_ast.ml | 81 +++++++++++++++++++------------------------------- 1 file changed, 30 insertions(+), 51 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 9e3dc2b6f3..53dcaaf20d 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1807,13 +1807,10 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens ( name , PStr [ ( { pstr_desc= - Pstr_eval (({pexp_desc= Pexp_function (_, _, Pfunction_body _); _} as call), []) + Pstr_eval (({pexp_desc= Pexp_function (args, typ, (Pfunction_body _ as body)); _} as call), []) ; pstr_loc= _ } as pld ) ] ) ; _ } , e2 ) -> - let xargs, xbody = Sugar.fun_ c.cmts (sub_exp ~ctx:(Str pld) call) in - let fmt_cstr, xbody = type_constr_and_body c xbody in - (* fmt_type_cstr c ~constraint_ctx:`Fun (sub_typ ~ctx:typ_ctx typ) *) let is_simple x = is_simple c.conf (expression_width c) x in let break xexp1 xexp2 = not (is_simple xexp1 && is_simple xexp2) in let grps = @@ -1829,13 +1826,13 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens (Params.parens_if parens c.conf ( hvbox c.conf.fmt_opts.extension_indent.v (wrap (str "[") (str "]") - ( str "%" - $ hovbox 2 - ( fmt_str_loc c name $ str " fun " - $ fmt_attributes c ~suf:" " call.pexp_attributes - $ fmt_expr_fun_args c xargs $ fmt_opt fmt_cstr - $ space_break $ str "->" ) - $ space_break $ fmt_expression c xbody ) ) + (fmt_function ~ctx ~wrap_intro:(fun x -> + ( str "%" + $ hovbox 2 + ( fmt_str_loc c name $ x))) + ~label:Nolabel ~parens:false ~attrs:call.pexp_attributes ~loc:call.pexp_loc c (args, typ, body) + ) + ) $ space_break $ str ";" $ space_break $ list grps (str " ;" $ force_break) fmt_grp ) ) | Pexp_infix @@ -1846,12 +1843,9 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens ( name , PStr [ ( { pstr_desc= - Pstr_eval (({pexp_desc= Pexp_function (_, _, Pfunction_body _); _} as retn), []) + Pstr_eval (({pexp_desc= Pexp_function (args, typ, (Pfunction_body _ as body)); _} as retn), []) ; pstr_loc= _ } as pld ) ] ) ; _ } ) -> - let xargs, xbody = Sugar.fun_ c.cmts (sub_exp ~ctx:(Str pld) retn) in - let fmt_cstr, xbody = type_constr_and_body c xbody in - (* fmt_type_cstr c ~constraint_ctx:`Fun (sub_typ ~ctx:typ_ctx typ) *) pro $ hvbox 0 (Params.Exp.wrap c.conf ~parens @@ -1860,13 +1854,13 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens $ Cmts.fmt c loc (str "|>" $ force_newline) $ hvbox c.conf.fmt_opts.extension_indent.v (wrap (str "[") (str "]") - ( str "%" - $ hovbox 2 - ( fmt_str_loc c name $ str " fun " - $ fmt_attributes c ~suf:" " retn.pexp_attributes - $ fmt_expr_fun_args c xargs $ fmt_opt fmt_cstr - $ space_break $ str "->" ) - $ space_break $ fmt_expression c xbody ) ) ) ) + (fmt_function ~ctx ~wrap_intro:(fun x -> + ( str "%" + $ hovbox 2 + ( fmt_str_loc c name $ x))) + ~label:Nolabel ~parens:false ~attrs:retn.pexp_attributes ~loc:retn.pexp_loc c (args, typ, body) + ) + ) ) ) | Pexp_infix ({txt= ":="; loc}, r, v) when is_simple c.conf (expression_width c) (sub_exp ~ctx r) -> let bol_indent = Params.Indent.assignment_operator_bol c.conf in @@ -1915,49 +1909,34 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens $ hvbox 0 (fmt_str_loc c op) $ fmt_expression c (sub_exp ~ctx r) ) | Pexp_infix - (op, l, ({pexp_desc= Pexp_function (_, _, Pfunction_body _); pexp_loc; pexp_attributes; _} as r)) + (op, l, ({pexp_desc= Pexp_function (args, typ, (Pfunction_body _ as body)); _} as r)) when not c.conf.fmt_opts.break_infix_before_func.v -> - (* side effects of Cmts.fmt c.cmts before Sugar.fun_ is important *) - let cmts_before = Cmts.fmt_before c pexp_loc in - let cmts_after = Cmts.fmt_after c pexp_loc in let xr = sub_exp ~ctx r in let parens_r = parenze_exp xr in - let xargs, xbody = Sugar.fun_ c.cmts xr in - let fmt_cstr, xbody = type_constr_and_body c xbody in - (* fmt_type_cstr c ~constraint_ctx:`Fun (sub_typ ~ctx:typ_ctx typ) *) let indent_wrap = if parens then -2 else 0 in - let pre_body, body = fmt_body c ?ext xbody in - let followed_by_infix_op = - match xbody.ast.pexp_desc with - | Pexp_infix (_, _, {pexp_desc= Pexp_function _; _}) -> true - | _ -> false - in + (* let followed_by_infix_op = *) + (* match xbody.ast.pexp_desc with *) + (* | Pexp_infix (_, _, {pexp_desc= Pexp_function _; _}) -> true *) + (* | _ -> false *) + (* in *) pro $ wrap_fits_breaks_if c.conf parens "(" ")" ( hovbox 0 (wrap_if has_attr (str "(") (str ")") + (fmt_function + ~ctx ~wrap_intro:(fun intro -> + ( hvbox 2 ( hvbox indent_wrap ( fmt_expression ~indent_wrap c (sub_exp ~ctx l) $ space_break $ hovbox 2 ( hvbox 0 - ( fmt_str_loc c op $ space_break - $ cmts_before - $ fmt_if parens_r (str "(") - $ str "fun " ) - $ fmt_attributes c pexp_attributes ~suf:" " - $ hvbox_if - (not c.conf.fmt_opts.wrap_fun_args.v) - 4 - ( fmt_expr_fun_args c xargs - $ fmt_opt fmt_cstr ) - $ space_break $ str "->" ) ) - $ pre_body ) - $ fmt_or followed_by_infix_op force_break space_break - $ body - $ fmt_if parens_r (str ")") - $ cmts_after ) ) + ( fmt_str_loc c op $ space_break $ intro))) + ) + )) + ~label:Nolabel ~parens:true ~attrs:r.pexp_attributes ~loc:r.pexp_loc c (args, typ, body) + )) $ fmt_atrs ) | Pexp_infix ( op From 754da22b746aee9da8c91f427d8856a956f82168 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Fri, 29 Mar 2024 14:07:02 +0100 Subject: [PATCH 014/146] WIP --- lib/Fmt_ast.ml | 245 +++++++++++++------------------------------------ 1 file changed, 65 insertions(+), 180 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 53dcaaf20d..a6b2cb765d 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -404,6 +404,12 @@ let virtual_or_override = function | Cfk_concrete (Override, _, _) -> str "!" | Cfk_concrete (Fresh, _, _) -> noop +(** Format the [:] before a type constraint. *) +let fmt_constraint_sep c sep = + match c.conf.fmt_opts.break_colon.v with + | `Before -> space_break $ str sep $ char ' ' + | `After -> char ' ' $ str sep $ space_break + let fmt_parsed_docstring c ~loc ?pro ~epi input parsed = assert (not (String.is_empty input)) ; let offset = @@ -741,12 +747,10 @@ and fmt_record_field c ?typ1 ?typ2 ?rhs lid1 = and fmt_type_cstr c ~ctx ?constraint_ctx typ = let colon_before = Poly.(c.conf.fmt_opts.break_colon.v = `Before) in - let fmt_typ ~pro t = - fmt_core_type c ~pro ?constraint_ctx ~pro_space:(not colon_before) - ~box:(not colon_before) (sub_typ ~ctx t) + let fmt_typ ?pro t = + fmt_core_type c ?pro ?constraint_ctx ~box:(not colon_before) (sub_typ ~ctx t) in - fmt_or colon_before (fits_breaks " " ~hint:(1000, 0) "") (break 0 (-1)) - $ cbox_if colon_before 0 @@ + cbox_if colon_before 0 @@ (match typ with | Pconstraint t -> fmt_typ ~pro:":" t | Pcoerce (t1, t2) -> opt t1 (fmt_typ ~pro:":") $ fmt_typ ~pro:":>" t2) @@ -796,7 +800,7 @@ and fmt_arrow_type c ~ctx ?indent ~parens ~parent_has_parens args fmt_ret_typ [xtyp] should be parenthesized. [constraint_ctx] gives the higher context of the expression, i.e. if the expression is part of a `fun` expression. *) -and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx +and fmt_core_type c ?(box = true) ?pro ?constraint_ctx ({ast= typ; ctx} as xtyp) = protect c (Typ typ) @@ @@ -804,10 +808,7 @@ and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx update_config_maybe_disabled c ptyp_loc ptyp_attributes @@ fun c -> ( match pro with - | Some pro -> ( - match c.conf.fmt_opts.break_colon.v with - | `Before -> fmt_if pro_space space_break $ str pro $ str " " - | `After -> fmt_if pro_space (str " ") $ str pro $ space_break ) + | Some pro -> (fmt_constraint_sep c pro) | None -> noop ) $ let doc, atrs = doc_atrs ptyp_attributes in @@ -1392,31 +1393,6 @@ and fmt_expr_fun_args c args = list args space_break (fmt_expr_fun_arg c) and fmt_class_fun_args c args = list args space_break (fmt_class_fun_arg c) -(** The second returned value of [fmt_body] belongs to a box of level N-1 if - the first returned value belongs to a box of level N. *) -and fmt_body c ?ext ({ast= body; _} as xbody) = - let ctx = Exp body in - let parens = parenze_exp xbody in - match body with - | { pexp_desc= Pexp_function ([], None, Pfunction_cases (cs, _, _)) - ; pexp_attributes - ; pexp_loc - ; _ } -> - ( ( update_config_maybe_disabled c pexp_loc pexp_attributes - @@ fun c -> - space_break - $ Cmts.fmt_before c pexp_loc - $ fmt_if parens (str "(") - $ str "function" - $ fmt_extension_suffix c ext - $ fmt_attributes c pexp_attributes ) - , update_config_maybe_disabled c pexp_loc pexp_attributes - @@ fun c -> - fmt_cases c ctx cs - $ fmt_if parens (str ")") - $ Cmts.fmt_after c pexp_loc ) - | _ -> (noop, fmt_expression c ~eol:force_break xbody) - and fmt_indexop_access c ctx ~fmt_atrs ~has_attr ~parens x = let {pia_lhs; pia_kind; pia_paren; pia_rhs} = x in let wrap_paren = @@ -1463,7 +1439,7 @@ and fmt_function ?force_closing_paren ~ctx ?(wrap_intro = fun x -> hvbox 2 x $ s let cmts = Cmts.fmt_before ?eol c loc in if has_label then (false, noop, cmts) else (has_cmts, cmts, noop) in - let (label_sep : t), break_fun = + let (label_sep : t), _break_fun = (* Break between the label and the fun to avoid ocp-indent's alignment. If a label is present, arguments should be indented more than the arrow and the eventually breaking [fun] keyword. *) @@ -1475,8 +1451,12 @@ and fmt_function ?force_closing_paren ~ctx ?(wrap_intro = fun x -> hvbox 2 x $ s fmt_type_cstr c ~ctx ~constraint_ctx:`Fun typ in let fmt_fun_args_typ args typ = - str "fun" $ fmt_attributes c attrs $ break_fun - $ fmt_expr_fun_args c args $ fmt_opt (Option.map ~f:fmt_typ typ) + let kw = + str "fun" $ fmt_attributes c attrs + and args = fmt_expr_fun_args c args + and annot = Option.map ~f:fmt_typ typ + in + Params.Exp.box_fun_decl_args c.conf ~parens ~kw ~args ~annot $ break 1 (-2) $ str "->" in (* [head] is [fun args ->] or [function]. [body] is an expression or the @@ -1487,7 +1467,7 @@ and fmt_function ?force_closing_paren ~ctx ?(wrap_intro = fun x -> hvbox 2 x $ s (* Only [fun]. *) fmt_fun_args_typ args typ, fmt_expression c (sub_exp ~ctx body) | [], _, Pfunction_body _ -> assert false - | args, typ, Pfunction_cases (cs, loc, cs_attrs) -> + | args, typ, Pfunction_cases (cs, _loc, cs_attrs) -> (* Only [function]. *) let fun_ = match args, typ with @@ -1808,7 +1788,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens , PStr [ ( { pstr_desc= Pstr_eval (({pexp_desc= Pexp_function (args, typ, (Pfunction_body _ as body)); _} as call), []) - ; pstr_loc= _ } as pld ) ] ) + ; pstr_loc= _ } as _pld ) ] ) ; _ } , e2 ) -> let is_simple x = is_simple c.conf (expression_width c) x in @@ -1844,7 +1824,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens , PStr [ ( { pstr_desc= Pstr_eval (({pexp_desc= Pexp_function (args, typ, (Pfunction_body _ as body)); _} as retn), []) - ; pstr_loc= _ } as pld ) ] ) + ; pstr_loc= _ } as _pld ) ] ) ; _ } ) -> pro $ hvbox 0 @@ -1909,7 +1889,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens $ hvbox 0 (fmt_str_loc c op) $ fmt_expression c (sub_exp ~ctx r) ) | Pexp_infix - (op, l, ({pexp_desc= Pexp_function (args, typ, (Pfunction_body _ as body)); _} as r)) + (op, l, ({pexp_desc= Pexp_function (args, typ, body); _} as r)) when not c.conf.fmt_opts.break_infix_before_func.v -> let xr = sub_exp ~ctx r in let parens_r = parenze_exp xr in @@ -1922,10 +1902,9 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens pro $ wrap_fits_breaks_if c.conf parens "(" ")" ( hovbox 0 - (wrap_if has_attr (str "(") (str ")") + ( (fmt_function - ~ctx ~wrap_intro:(fun intro -> - + ~ctx ~parens:(parens_r || has_attr) ~wrap_intro:(fun intro -> ( hvbox 2 ( hvbox indent_wrap ( fmt_expression ~indent_wrap c (sub_exp ~ctx l) @@ -1935,35 +1914,9 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens ( fmt_str_loc c op $ space_break $ intro))) ) )) - ~label:Nolabel ~parens:true ~attrs:r.pexp_attributes ~loc:r.pexp_loc c (args, typ, body) + ~label:Nolabel ~attrs:r.pexp_attributes ~loc:r.pexp_loc c (args, typ, body) )) $ fmt_atrs ) - | Pexp_infix - ( op - , l - , ({pexp_desc= Pexp_function ([], None, Pfunction_cases (cs, loc, attrs)); pexp_loc; pexp_attributes; _} as r) ) - when not c.conf.fmt_opts.break_infix_before_func.v -> - let cmts_before = Cmts.fmt_before c pexp_loc $ Cmts.fmt_before c loc in - let cmts_after = Cmts.fmt_after c loc $ Cmts.fmt_after c pexp_loc in - let xr = sub_exp ~ctx r in - let parens_r = parenze_exp xr in - let indent = Params.Indent.function_ c.conf ~parens xr in - pro - $ Params.parens_if parens c.conf - (hvbox indent - ( hvbox 0 - ( fmt_expression c (sub_exp ~ctx l) - $ space_break - $ hovbox 2 - ( hvbox 0 - ( fmt_str_loc c op $ space_break $ cmts_before - $ fmt_if parens_r (str "( ") - $ str "function" - $ fmt_extension_suffix c ext ) - $ fmt_attributes c (pexp_attributes @ attrs) ) ) - $ space_break $ fmt_cases c (Exp r) cs - $ fmt_if parens_r (str " )") - $ cmts_after ) ) | Pexp_infix _ -> let op_args = Sugar.Exp.infix c.cmts (prec_ast (Exp exp)) xexp in let inner_wrap = parens || has_attr in @@ -2048,20 +2001,16 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens if parens || not dock_fun_arg then (noop, pro) else (pro, noop) in match last_arg.pexp_desc with - | Pexp_function (_, _, Pfunction_body eN1_body) + | Pexp_function (largs, ltyp, lbody) when List.for_all args_before ~f:(fun (_, eI) -> is_simple c.conf (fun _ -> 0) (sub_exp ~ctx eI) ) -> - (* Last argument is a [fun _ ->]. *) - let xlast_arg = sub_exp ~ctx last_arg in let args = - let break_body = - match eN1_body.pexp_desc with - | Pexp_function ([], None, Pfunction_cases _) -> - break 1 + let indent_body = + match lbody with + | Pfunction_cases _ -> (Params.Indent.docked_function_after_fun c.conf ~parens:true ~lbl ) - | _ -> - break 1 + | Pfunction_body _ -> (Params.Indent.docked_fun c.conf ~source:c.source ~loc:last_arg.pexp_loc ~lbl ) in @@ -2070,82 +2019,17 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens ( intro_epi $ fmt_args_grouped e0 args_before $ space_break $ hvbox 0 x ) - $ break_body + $ break 1 indent_body in let force_closing_paren = if Location.is_single_line pexp_loc c.conf.fmt_opts.margin.v then Fit else Break in - fmt_fun c ~force_closing_paren ~wrap_intro ~label:lbl - ~parens:true xlast_arg + fmt_function ~force_closing_paren ~ctx ~wrap_intro ~label:lbl ~parens:true ~attrs:last_arg.pexp_attributes ~loc:last_arg.pexp_loc c (largs, ltyp, lbody) in hvbox_if has_attr 0 (expr_epi $ Params.parens_if parens c.conf (args $ fmt_atrs)) - | Pexp_function - ([], None, Pfunction_cases ([{pc_lhs; pc_guard= None; pc_rhs}], loc, attrs)) - when List.for_all args_before ~f:(fun (_, eI) -> - is_simple c.conf (fun _ -> 0) (sub_exp ~ctx eI) ) -> - let force = - if - Location.is_single_line last_arg.pexp_loc - c.conf.fmt_opts.margin.v - then Fit - else Break - in - let ctx = Exp last_arg in - (* side effects of Cmts.fmt_before before [fmt_pattern] is - important *) - let leading_cmt = Cmts.fmt_before c pc_lhs.ppat_loc in - hvbox 2 - ( expr_epi - $ Params.parens_if parens c.conf - ( hovbox 4 - ( wrap - ( intro_epi - $ fmt_args_grouped e0 args_before - $ space_break - $ Cmts.fmt_before c last_arg.pexp_loc - $ Cmts.fmt_before c loc - $ fmt_label lbl ":" $ str "(function" - $ fmt_label lbl (str ":") - $ str "(function" - $ fmt_attributes c ~pre:Blank - (last_arg.pexp_attributes @ attrs) ) - $ space_break $ leading_cmt - $ hvbox 0 - ( fmt_pattern c ~pro:(if_newline "| ") - (sub_pat ~ctx pc_lhs) - $ space_break $ str "->" ) - $ space_break - $ cbox 0 (fmt_expression c (sub_exp ~ctx pc_rhs)) - $ closing_paren c ~force - $ Cmts.fmt_after c loc - $ Cmts.fmt_after c last_arg.pexp_loc ) - $ fmt_atrs ) ) - | Pexp_function ([], None, Pfunction_cases (cs, loc, attrs)) - when List.for_all args_before ~f:(fun (_, eI) -> - is_simple c.conf (fun _ -> 0) (sub_exp ~ctx eI) ) -> - let wrap = - if c.conf.fmt_opts.wrap_fun_args.v then hovbox 2 else hvbox 2 - in - let xlast_arg = sub_exp ~ctx last_arg in - let ctx'' = Exp last_arg in - hvbox - (Params.Indent.docked_function c.conf ~parens xlast_arg) - ( expr_epi - $ Params.parens_if parens c.conf - ( wrap - ( intro_epi - $ fmt_args_grouped e0 args_before - $ space_break - $ Cmts.fmt_before c last_arg.pexp_loc - $ fmt_label lbl (str ":") - $ str "(function" - $ fmt_attributes c ~pre:Blank last_arg.pexp_attributes ) - $ space_break $ fmt_cases c ctx'' cs $ closing_paren c - $ Cmts.fmt_after c last_arg.pexp_loc - $ fmt_atrs ) ) | _ -> let fmt_atrs = fmt_attributes c ~pre:(Break (1, -2)) pexp_attributes @@ -2268,27 +2152,24 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens (Params.parens_if parens c.conf ( fmt_expression c (sub_exp ~ctx exp) $ cut_break $ str "." $ fmt_longident_loc c lid $ fmt_atrs ) ) - | Pexp_function (_, _, Pfunction_body _) -> - let xargs, xbody = Sugar.fun_ c.cmts xexp in - let fmt_cstr, xbody = type_constr_and_body c xbody in - (* fmt_type_cstr c ~constraint_ctx:`Fun (sub_typ ~ctx:typ_ctx typ) *) - let body_is_function = - match xbody.ast.pexp_desc with - | Pexp_function ([], None, Pfunction_cases _) -> true - | _ -> false - in - let pre_body, body = fmt_body c ?ext xbody in - let indent = - if body_is_function then - let default_indent = - if Option.is_none eol then 2 - else if c.conf.fmt_opts.let_binding_deindent_fun.v then 1 - else 0 - in - Params.Indent.function_ ~default:default_indent c.conf ~parens xexp - else Params.Indent.fun_ ?eol c.conf - in - let intro = + | Pexp_function (args, typ, (Pfunction_body _ as body)) + | Pexp_function ((_ :: _ as args), typ, body) -> + (* let body_is_function = *) + (* match xbody.ast.pexp_desc with *) + (* | Pexp_function ([], None, Pfunction_cases _) -> true *) + (* | _ -> false *) + (* in *) + (* let indent = *) + (* if body_is_function then *) + (* let default_indent = *) + (* if Option.is_none eol then 2 *) + (* else if c.conf.fmt_opts.let_binding_deindent_fun.v then 1 *) + (* else 0 *) + (* in *) + (* Params.Indent.function_ ~default:default_indent c.conf ~parens xexp *) + (* else Params.Indent.fun_ ?eol c.conf *) + (* in *) + let wrap_intro = let kw = str "fun" $ fmt_extension_suffix c ext @@ -2313,6 +2194,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens $ fmt_attributes c pexp_attributes ) $ break 1 indent $ hvbox 0 (fmt_cases c ctx cs) ) + | Pexp_function ([], Some _, _) -> assert false | Pexp_ident {txt; loc} -> let outer_parens = has_attr && parens in pro @@ -3260,7 +3142,7 @@ and fmt_value_description c ctx vd = (not ( c.conf.fmt_opts.ocp_indent_compat.v && is_arrow_or_poly pval_type ) ) - ~pro_space:true (sub_typ ~ctx pval_type) + (sub_typ ~ctx pval_type) $ fmt_if (not (List.is_empty pval_prim)) (space_break $ str "= ") $ hvbox_if (List.length pval_prim > 1) 0 @@ list pval_prim space_break fmt_val_prim ) @@ -4481,29 +4363,32 @@ and fmt_let c ~rec_flag ~bindings ~parens ~fmt_atrs ~fmt_expr ~loc_in $ fmt_atrs and fmt_value_constraint c vc_opt = - let fmt_sep x = - match c.conf.fmt_opts.break_colon.v with - | `Before -> space_break $ str x $ char ' ' - | `After -> char ' ' $ str x $ space_break - in match vc_opt with | Some vc -> ( let ctx = Vc vc in match vc with | Pvc_constraint {locally_abstract_univars= []; typ} -> - (noop, fmt_type_cstr c (sub_typ ~ctx typ)) + (* Handles breaking the [:] according to [break_colon]. *) + let fmt_typ pro = + fmt_core_type c ?pro (sub_typ ~ctx typ) in +(match c.conf.fmt_opts.break_colon.v with + |`Before -> + noop, fmt_typ (Some ":") + | `After -> + str ":", fmt_typ None +) | Pvc_constraint {locally_abstract_univars= pvars; typ} -> ( match c.conf.fmt_opts.break_colon.v with | `Before -> ( noop - , fmt_sep ":" + , fmt_constraint_sep c ":" $ hvbox 0 ( str "type " $ list pvars (str " ") (fmt_str_loc c) $ str "." $ space_break $ fmt_core_type c (sub_typ ~ctx typ) ) ) | `After -> - ( fmt_sep ":" + ( fmt_constraint_sep c ":" $ hvbox 0 ( str "type " $ list pvars (str " ") (fmt_str_loc c) @@ -4512,8 +4397,8 @@ and fmt_value_constraint c vc_opt = | Pvc_coercion {ground; coercion} -> ( noop , opt ground (fun ty -> - fmt_sep ":" $ fmt_core_type c (sub_typ ~ctx ty) ) - $ fmt_sep ":>" + fmt_constraint_sep c ":" $ fmt_core_type c (sub_typ ~ctx ty) ) + $ fmt_constraint_sep c ":>" $ fmt_core_type c (sub_typ ~ctx coercion) ) ) | None -> (noop, noop) From c8fc8baf2b6d890ebb32da06a155cb4d079f495b Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Thu, 4 Apr 2024 14:57:30 +0200 Subject: [PATCH 015/146] WIP --- lib/Fmt_ast.ml | 50 ++++++++++++++++++++++---------------------------- 1 file changed, 22 insertions(+), 28 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index a6b2cb765d..4b0889932a 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -517,8 +517,8 @@ let fmt_docstring_around_item_attrs ?is_val ?force_before ?fit c attrs = in (doc_before, doc_after, attrs.attrs_before, attrs_after) -let fmt_extension_suffix c ext = - opt ext (fun name -> str "%" $ fmt_str_loc c name) +let fmt_extension_suffix ?epi c ext = + opt ext (fun name -> str "%" $ fmt_str_loc c name $ fmt_opt epi) let is_arrow_or_poly = function | {ptyp_desc= Ptyp_arrow _ | Ptyp_poly _; _} -> true @@ -1428,7 +1428,7 @@ and fmt_indexop_access c ctx ~fmt_atrs ~has_attr ~parens x = (** Format a [Pexp_function]. [wrap_intro] wraps up to after the [->] and is responsible for breaking. *) and fmt_function ?force_closing_paren ~ctx ?(wrap_intro = fun x -> hvbox 2 x $ space_break) ?(box = true) - ~label ?(parens = false) ~attrs ~loc c (args, typ, body) = + ~label ?(parens = false) ?ext ~attrs ~loc c (args, typ, body) = let has_label = match label with Nolabel -> false | _ -> true in (* Make sure the comment is placed after the eventual label but not into the inner box if no label is present. Side effects of Cmts.fmt c.cmts @@ -1452,7 +1452,7 @@ and fmt_function ?force_closing_paren ~ctx ?(wrap_intro = fun x -> hvbox 2 x $ s in let fmt_fun_args_typ args typ = let kw = - str "fun" $ fmt_attributes c attrs + str "fun" $ fmt_extension_suffix ~epi:(str " ") c ext $ fmt_attributes c attrs and args = fmt_expr_fun_args c args and annot = Option.map ~f:fmt_typ typ in @@ -2154,35 +2154,29 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens $ cut_break $ str "." $ fmt_longident_loc c lid $ fmt_atrs ) ) | Pexp_function (args, typ, (Pfunction_body _ as body)) | Pexp_function ((_ :: _ as args), typ, body) -> - (* let body_is_function = *) - (* match xbody.ast.pexp_desc with *) - (* | Pexp_function ([], None, Pfunction_cases _) -> true *) - (* | _ -> false *) - (* in *) - (* let indent = *) - (* if body_is_function then *) - (* let default_indent = *) - (* if Option.is_none eol then 2 *) - (* else if c.conf.fmt_opts.let_binding_deindent_fun.v then 1 *) - (* else 0 *) - (* in *) - (* Params.Indent.function_ ~default:default_indent c.conf ~parens xexp *) - (* else Params.Indent.fun_ ?eol c.conf *) - (* in *) - let wrap_intro = - let kw = - str "fun" - $ fmt_extension_suffix c ext - $ str " " - $ fmt_attributes c pexp_attributes ~suf:" " - and args = fmt_expr_fun_args c xargs in - Params.Exp.box_fun_decl_args c.conf ~parens ~kw ~args ~annot:fmt_cstr + let body_is_function = + match body with + | Pfunction_cases _ -> true + | _ -> false + in + let indent = + if body_is_function then + let default_indent = + if Option.is_none eol then 2 + else if c.conf.fmt_opts.let_binding_deindent_fun.v then 1 + else 0 + in + Params.Indent.function_ ~default:default_indent c.conf ~parens xexp + else Params.Indent.fun_ ?eol c.conf in pro $ hvbox_if (box || body_is_function) indent (Params.Exp.wrap c.conf ~parens ~disambiguate:true ~fits_breaks:false ~offset_closing_paren:(-2) - (hovbox 2 (intro $ str " ->" $ pre_body) $ space_break $ body) ) + ( + fmt_function ~ctx + ~label:Nolabel ?ext ~attrs:pexp_attributes ~loc:pexp_loc c (args, typ, body) + ) ) | Pexp_function ([], None, Pfunction_cases (cs, _, _)) -> let indent = Params.Indent.function_ c.conf ~parens xexp in pro From 8f8eedf987362c82b1d965234ff4736f7c1121b5 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Thu, 4 Apr 2024 18:02:25 +0200 Subject: [PATCH 016/146] Preliminary implementation of Pexp_function --- lib/Fmt_ast.ml | 35 ++++++++++++++++++++--------------- 1 file changed, 20 insertions(+), 15 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 4b0889932a..c2bb528bc8 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -4431,7 +4431,6 @@ and fmt_value_binding c ~rec_flag ?in_ ?epi max (c.conf.fmt_opts.let_binding_indent.v - 1) 0 | _ -> c.conf.fmt_opts.let_binding_indent.v in - let pre_body, body = fmt_body c lb_exp in let pat_has_cmt = Cmts.has_before c.cmts lb_pat.ast.ppat_loc in let toplevel, in_, epi, cmts_before, cmts_after = match in_ with @@ -4452,7 +4451,7 @@ and fmt_value_binding c ~rec_flag ?in_ ?epi , Cmts.Toplevel.fmt_after c lb_loc ) in let ext = lb_attrs.attrs_extension in - let decl_args = + let decl = let decl = fmt_str_loc c lb_op $ fmt_extension_suffix c ext @@ -4466,24 +4465,30 @@ and fmt_value_binding c ~rec_flag ?in_ ?epi (space_break $ wrap_fun_decl_args c (fmt_expr_fun_args c lb_args)) $ fmt_newtypes in - box_fun_decl_args c 4 (Params.Align.fun_decl c.conf ~decl ~pattern ~args) + let decl_args = + box_fun_decl_args c 4 (Params.Align.fun_decl c.conf ~decl ~pattern ~args) + in + hovbox + (Params.Indent.fun_type_annot c.conf) + (decl_args $ fmt_cstr) + in + let decl_and_body = + if lb_pun then decl + else + let pro = + hovbox 2 ( + decl + $ (fmt_or c.conf.fmt_opts.ocp_indent_compat.v + (fits_breaks " =" ~hint:(1000, 0) "=") + (break 1 2 $ str "=") )) $ space_break + in + fmt_expression c ~box:false ~pro lb_exp in doc1 $ cmts_before $ hvbox 0 ( hvbox indent ( hvbox_if toplevel 0 - ( hvbox_if toplevel indent - ( hovbox 2 - ( hovbox - (Params.Indent.fun_type_annot c.conf) - (decl_args $ fmt_cstr) - $ fmt_if (not lb_pun) - (fmt_or c.conf.fmt_opts.ocp_indent_compat.v - (fits_breaks " =" ~hint:(1000, 0) "=") - (break 1 2 $ str "=") ) - $ fmt_if (not lb_pun) pre_body ) - $ fmt_if (not lb_pun) space_break - $ fmt_if (not lb_pun) body ) + ( hvbox_if toplevel indent decl_and_body $ cmts_after $ opt loc_in (Cmts.fmt_before c ~pro:force_break ~epi:noop ~eol:noop) ) From 247c5c6665ce159c5fed7f77938ff551b6d749e8 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Tue, 9 Apr 2024 21:41:09 +0200 Subject: [PATCH 017/146] Fix space around value binding ':' --- lib/Fmt_ast.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index c2bb528bc8..39f302eef0 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -4369,7 +4369,7 @@ and fmt_value_constraint c vc_opt = |`Before -> noop, fmt_typ (Some ":") | `After -> - str ":", fmt_typ None + fmt_constraint_sep c ":", fmt_typ None ) | Pvc_constraint {locally_abstract_univars= pvars; typ} -> ( match c.conf.fmt_opts.break_colon.v with From 8df232a302cbcb0479597bf3df2b27fef9482bc3 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Tue, 9 Apr 2024 21:59:55 +0200 Subject: [PATCH 018/146] Fix AST rules Some patterns on `Pexp_fun _` were translated into `Pexp_function _`, which is too general. --- lib/Ast.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/lib/Ast.ml b/lib/Ast.ml index c728f23cfd..bed7eeef1c 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -180,12 +180,12 @@ module Exp = struct |( {pexp_desc= Pexp_sequence _; _} , (Non_apply | Sequence | Then | ThenElse) ) |( { pexp_desc= - ( Pexp_function (_, _, Pfunction_cases _) | Pexp_match _ | Pexp_try _ + ( Pexp_function (_, Some _, _) | Pexp_function (_, _, Pfunction_cases _) | Pexp_match _ | Pexp_try _ ) ; _ } , (Match | Let_match | Non_apply) ) |( { pexp_desc= - ( Pexp_function _ | Pexp_let _ | Pexp_letop _ | Pexp_letexception _ + ( Pexp_function (_, _, Pfunction_body _) | Pexp_let _ | Pexp_letop _ | Pexp_letexception _ | Pexp_letmodule _ | Pexp_open _ | Pexp_letopen _ ) ; _ } , (Let_match | Non_apply) ) -> @@ -1916,7 +1916,7 @@ end = struct ( Ppat_construct _ | Ppat_exception _ | Ppat_or _ | Ppat_lazy _ | Ppat_tuple _ | Ppat_variant _ | Ppat_list _ ) ; _ } - | Exp {pexp_desc= Pexp_function _; _} ) + | Exp {pexp_desc= Pexp_function (_, _, Pfunction_body _); _} ) , Ppat_alias _ ) |( Pat {ppat_desc= Ppat_lazy _; _} , ( Ppat_construct _ | Ppat_cons _ @@ -1932,14 +1932,14 @@ end = struct |Pat {ppat_desc= Ppat_tuple _; _}, Ppat_tuple _ |Pat _, Ppat_lazy _ |Pat _, Ppat_exception _ - |Exp {pexp_desc= Pexp_function _; _}, Ppat_or _ + |Exp {pexp_desc= Pexp_function (_, _, Pfunction_body _); _}, Ppat_or _ |Cl {pcl_desc= Pcl_fun _; _}, Ppat_variant (_, Some _) |Cl {pcl_desc= Pcl_fun _; _}, Ppat_tuple _ |Cl {pcl_desc= Pcl_fun _; _}, Ppat_construct _ |Cl {pcl_desc= Pcl_fun _; _}, Ppat_alias _ |Cl {pcl_desc= Pcl_fun _; _}, Ppat_lazy _ |(Exp {pexp_desc= Pexp_letop _; _} | Bo _), Ppat_exception _ - |( Exp {pexp_desc= Pexp_function _; _} + |( Exp {pexp_desc= Pexp_function (_, _, Pfunction_body _); _} , ( Ppat_construct _ | Ppat_cons _ | Ppat_lazy _ | Ppat_tuple _ | Ppat_variant _ ) ) -> true From 6e9ac4b0f3287be3ce6025f61d0ba1be614c79bb Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Tue, 9 Apr 2024 22:04:55 +0200 Subject: [PATCH 019/146] Add missing space after 'fun' --- lib/Fmt_ast.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 39f302eef0..f440b6fb5d 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1452,7 +1452,7 @@ and fmt_function ?force_closing_paren ~ctx ?(wrap_intro = fun x -> hvbox 2 x $ s in let fmt_fun_args_typ args typ = let kw = - str "fun" $ fmt_extension_suffix ~epi:(str " ") c ext $ fmt_attributes c attrs + str "fun" $ fmt_extension_suffix ~epi:(str " ") c ext $ fmt_attributes c attrs $ space_break and args = fmt_expr_fun_args c args and annot = Option.map ~f:fmt_typ typ in From 976fe38ff3c48efe3c428acdbd116b575fff8b86 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Tue, 9 Apr 2024 22:46:12 +0200 Subject: [PATCH 020/146] Fix infix followed by fun --- lib/Fmt_ast.ml | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index f440b6fb5d..438efdc5a2 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1834,7 +1834,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens $ Cmts.fmt c loc (str "|>" $ force_newline) $ hvbox c.conf.fmt_opts.extension_indent.v (wrap (str "[") (str "]") - (fmt_function ~ctx ~wrap_intro:(fun x -> + (fmt_function ~ctx:(Exp retn) ~wrap_intro:(fun x -> ( str "%" $ hovbox 2 ( fmt_str_loc c name $ x))) @@ -1904,16 +1904,16 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens ( hovbox 0 ( (fmt_function - ~ctx ~parens:(parens_r || has_attr) ~wrap_intro:(fun intro -> - ( hvbox 2 + ~ctx:(Exp r) ~box:false ~parens:(parens_r || has_attr) ~wrap_intro:(fun intro -> + ( ( hvbox indent_wrap ( fmt_expression ~indent_wrap c (sub_exp ~ctx l) $ space_break - $ hovbox 2 - ( hvbox 0 + $ hovbox 0 + ( ( fmt_str_loc c op $ space_break $ intro))) ) - )) + ) $ space_break) ~label:Nolabel ~attrs:r.pexp_attributes ~loc:r.pexp_loc c (args, typ, body) )) $ fmt_atrs ) @@ -2004,6 +2004,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens | Pexp_function (largs, ltyp, lbody) when List.for_all args_before ~f:(fun (_, eI) -> is_simple c.conf (fun _ -> 0) (sub_exp ~ctx eI) ) -> + let inner_ctx = Exp (last_arg) in let args = let indent_body = match lbody with @@ -2026,7 +2027,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens then Fit else Break in - fmt_function ~force_closing_paren ~ctx ~wrap_intro ~label:lbl ~parens:true ~attrs:last_arg.pexp_attributes ~loc:last_arg.pexp_loc c (largs, ltyp, lbody) + fmt_function ~force_closing_paren ~ctx:inner_ctx ~wrap_intro ~label:lbl ~parens:true ~attrs:last_arg.pexp_attributes ~loc:last_arg.pexp_loc c (largs, ltyp, lbody) in hvbox_if has_attr 0 (expr_epi $ Params.parens_if parens c.conf (args $ fmt_atrs)) From f80a0ceba65c3264ee0b2a61403b2a15fcb95857 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Wed, 10 Apr 2024 10:02:58 +0200 Subject: [PATCH 021/146] Restore let binding docking of 'function' --- lib/Fmt_ast.ml | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 438efdc5a2..3388f89277 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -2180,11 +2180,12 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens ) ) | Pexp_function ([], None, Pfunction_cases (cs, _, _)) -> let indent = Params.Indent.function_ c.conf ~parens xexp in - pro + let outer_pro, inner_pro = if parens then pro, noop else noop, pro in + outer_pro $ Params.Exp.wrap c.conf ~parens ~disambiguate:true ~fits_breaks:false @@ Params.Align.function_ c.conf ~parens ~ctx0 ~self:exp @@ ( hvbox 2 - ( str "function" + (inner_pro $ str "function" $ fmt_extension_suffix c ext $ fmt_attributes c pexp_attributes ) $ break 1 indent @@ -4423,14 +4424,14 @@ and fmt_value_binding c ~rec_flag ?in_ ?epi fmt_docstring_around_item_attrs ~force_before:true c lb_attrs in let fmt_newtypes, fmt_cstr = fmt_value_constraint c lb_typ in - let indent = + let indent, intro_as_pro = match lb_exp.ast.pexp_desc with | Pexp_function (_, _, Pfunction_cases _) -> - c.conf.fmt_opts.function_indent.v + c.conf.fmt_opts.function_indent.v, true | Pexp_function (_, _, Pfunction_body _) when c.conf.fmt_opts.let_binding_deindent_fun.v -> - max (c.conf.fmt_opts.let_binding_indent.v - 1) 0 - | _ -> c.conf.fmt_opts.let_binding_indent.v + max (c.conf.fmt_opts.let_binding_indent.v - 1) 0, false + | _ -> c.conf.fmt_opts.let_binding_indent.v, false in let pat_has_cmt = Cmts.has_before c.cmts lb_pat.ast.ppat_loc in let toplevel, in_, epi, cmts_before, cmts_after = @@ -4483,7 +4484,10 @@ and fmt_value_binding c ~rec_flag ?in_ ?epi (fits_breaks " =" ~hint:(1000, 0) "=") (break 1 2 $ str "=") )) $ space_break in - fmt_expression c ~box:false ~pro lb_exp + if intro_as_pro then + fmt_expression c ~pro ~box:false lb_exp + else + pro$fmt_expression c ~box:false lb_exp in doc1 $ cmts_before $ hvbox 0 From 8885c20e5886d3a35c7fa56dba676c34ac77782d Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Wed, 10 Apr 2024 10:19:53 +0200 Subject: [PATCH 022/146] Fix parenthezed fun indent --- lib/Fmt_ast.ml | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 3388f89277..ee360105b8 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -2172,11 +2172,12 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens in pro $ hvbox_if (box || body_is_function) indent - (Params.Exp.wrap c.conf ~parens ~disambiguate:true - ~fits_breaks:false ~offset_closing_paren:(-2) + ( + (* Params.Exp.wrap c.conf ~parens ~disambiguate:true *) + (* ~fits_breaks:false ~offset_closing_paren:(-2) *) ( fmt_function ~ctx - ~label:Nolabel ?ext ~attrs:pexp_attributes ~loc:pexp_loc c (args, typ, body) + ~label:Nolabel ~parens ?ext ~attrs:pexp_attributes ~loc:pexp_loc c (args, typ, body) ) ) | Pexp_function ([], None, Pfunction_cases (cs, _, _)) -> let indent = Params.Indent.function_ c.conf ~parens xexp in From 78dc6fd2e564eb6375e0c92c6df45b9fe5e69d3a Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Wed, 10 Apr 2024 10:28:29 +0200 Subject: [PATCH 023/146] Fix context passed to fmt_function --- lib/Fmt_ast.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index ee360105b8..9a9108c62f 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1494,7 +1494,7 @@ and fmt_function ?force_closing_paren ~ctx ?(wrap_intro = fun x -> hvbox 2 x $ s $ body $ cls_paren $ Cmts.fmt_after c loc ) -and fmt_label_arg ?(box = true) ?eol c (lbl, ({ast= arg; ctx} as xarg)) = +and fmt_label_arg ?(box = true) ?eol c (lbl, ({ast= arg; _} as xarg)) = match (lbl, arg.pexp_desc) with | (Labelled l | Optional l), Pexp_ident {txt= Lident i; loc} when String.equal l.txt i && List.is_empty arg.pexp_attributes -> @@ -1523,7 +1523,7 @@ and fmt_label_arg ?(box = true) ?eol c (lbl, ({ast= arg; ctx} as xarg)) = ~box xarg ) $ cmts_after ) | (Labelled _ | Optional _), Pexp_function (args, typ, body) -> - fmt_function ~ctx ~label:lbl ~parens:true ~attrs:arg.pexp_attributes ~loc:arg.pexp_loc c (args, typ, body) + fmt_function ~ctx:(Exp arg) ~label:lbl ~parens:true ~attrs:arg.pexp_attributes ~loc:arg.pexp_loc c (args, typ, body) | _ -> let label_sep : t = if box || c.conf.fmt_opts.wrap_fun_args.v then str ":" $ cut_break @@ -1806,7 +1806,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens (Params.parens_if parens c.conf ( hvbox c.conf.fmt_opts.extension_indent.v (wrap (str "[") (str "]") - (fmt_function ~ctx ~wrap_intro:(fun x -> + (fmt_function ~ctx:(Exp call) ~wrap_intro:(fun x -> ( str "%" $ hovbox 2 ( fmt_str_loc c name $ x))) From 9f436e8400c046259aedcd7317508537bd31ad72 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Wed, 10 Apr 2024 10:37:31 +0200 Subject: [PATCH 024/146] Fix dropped attribute on 'function' --- lib/Fmt_ast.ml | 14 ++++++++------ test/passing/dune.inc | 2 +- test/passing/tests/attributes.ml.opts | 1 + 3 files changed, 10 insertions(+), 7 deletions(-) create mode 100644 test/passing/tests/attributes.ml.opts diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 9a9108c62f..8fd21c448a 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1468,14 +1468,16 @@ and fmt_function ?force_closing_paren ~ctx ?(wrap_intro = fun x -> hvbox 2 x $ s fmt_fun_args_typ args typ, fmt_expression c (sub_exp ~ctx body) | [], _, Pfunction_body _ -> assert false | args, typ, Pfunction_cases (cs, _loc, cs_attrs) -> - (* Only [function]. *) - let fun_ = + (* Only [function]. [spilled_attrs] are extra attrs to add to the + [function] keyword. *) + let fun_, spilled_attrs = match args, typ with - | [], None -> noop + | [], None -> noop, attrs | [], Some _ -> assert false - | args, typ -> fmt_fun_args_typ args typ - and function_ = - str "function" $ fmt_attributes c cs_attrs + | args, typ -> fmt_fun_args_typ args typ, [] + in + let function_ = + str "function" $ fmt_attributes c spilled_attrs $ fmt_attributes c cs_attrs in fun_ $ function_, fmt_cases c ctx cs in diff --git a/test/passing/dune.inc b/test/passing/dune.inc index 1f9d1c1cc3..a413ad22da 100644 --- a/test/passing/dune.inc +++ b/test/passing/dune.inc @@ -185,7 +185,7 @@ (action (with-stdout-to attributes.ml.stdout (with-stderr-to attributes.ml.stderr - (run %{bin:ocamlformat} --margin-check %{dep:tests/attributes.ml}))))) + (run %{bin:ocamlformat} --margin-check --max-iter=3 %{dep:tests/attributes.ml}))))) (rule (alias runtest) diff --git a/test/passing/tests/attributes.ml.opts b/test/passing/tests/attributes.ml.opts new file mode 100644 index 0000000000..a2f04741b8 --- /dev/null +++ b/test/passing/tests/attributes.ml.opts @@ -0,0 +1 @@ +--max-iter=3 From a18680cf553ad27f28059f21cb6f8325a0038bd0 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Wed, 10 Apr 2024 10:40:44 +0200 Subject: [PATCH 025/146] Restore 'fun' and 'function' spacing before attrs --- lib/Fmt_ast.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 8fd21c448a..684ed13299 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1452,7 +1452,7 @@ and fmt_function ?force_closing_paren ~ctx ?(wrap_intro = fun x -> hvbox 2 x $ s in let fmt_fun_args_typ args typ = let kw = - str "fun" $ fmt_extension_suffix ~epi:(str " ") c ext $ fmt_attributes c attrs $ space_break + str "fun" $ fmt_extension_suffix ~epi:(str " ") c ext $ fmt_attributes c ~pre:Blank attrs $ space_break and args = fmt_expr_fun_args c args and annot = Option.map ~f:fmt_typ typ in @@ -1477,7 +1477,7 @@ and fmt_function ?force_closing_paren ~ctx ?(wrap_intro = fun x -> hvbox 2 x $ s | args, typ -> fmt_fun_args_typ args typ, [] in let function_ = - str "function" $ fmt_attributes c spilled_attrs $ fmt_attributes c cs_attrs + str "function" $ fmt_attributes c ~pre:Blank spilled_attrs $ fmt_attributes c ~pre:Blank cs_attrs in fun_ $ function_, fmt_cases c ctx cs in From c0bd645f4ea1cf45afe6f0e771ecd00672b7e164 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Wed, 10 Apr 2024 10:44:05 +0200 Subject: [PATCH 026/146] Missing AST rule for fun type constraints --- lib/Ast.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/lib/Ast.ml b/lib/Ast.ml index bed7eeef1c..0f906e582b 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -1016,6 +1016,7 @@ end = struct List.exists en1 ~f:(fun (_, c, _) -> Option.exists c ~f:check_type_constraint ) ) | Pexp_let (lbs, _, _) -> assert (check_let_bindings lbs) + | Pexp_function (_, Some t1, _) -> assert (check_type_constraint t1) | _ -> assert false ) | Fpe _ | Fpc _ -> assert false | Vc c -> assert (check_value_constraint c) From e9024cb8bad665ecf0ac26727fe2af4762fd6d58 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Wed, 10 Apr 2024 10:48:22 +0200 Subject: [PATCH 027/146] Fix special case of 'fun' in some extension points --- lib/Fmt_ast.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 684ed13299..b6021845e3 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1811,7 +1811,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens (fmt_function ~ctx:(Exp call) ~wrap_intro:(fun x -> ( str "%" $ hovbox 2 - ( fmt_str_loc c name $ x))) + ( fmt_str_loc c name $ space_break $ x))) ~label:Nolabel ~parens:false ~attrs:call.pexp_attributes ~loc:call.pexp_loc c (args, typ, body) ) ) @@ -1839,7 +1839,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens (fmt_function ~ctx:(Exp retn) ~wrap_intro:(fun x -> ( str "%" $ hovbox 2 - ( fmt_str_loc c name $ x))) + ( fmt_str_loc c name $ space_break $ x))) ~label:Nolabel ~parens:false ~attrs:retn.pexp_attributes ~loc:retn.pexp_loc c (args, typ, body) ) ) ) ) From e359cd9f1f289ca8225f93dd035490b460bb6f86 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Wed, 10 Apr 2024 12:15:26 +0200 Subject: [PATCH 028/146] Fix misplaced attribute after fun after infix --- lib/Fmt_ast.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index b6021845e3..575d1f9dda 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1904,9 +1904,9 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens pro $ wrap_fits_breaks_if c.conf parens "(" ")" ( hovbox 0 - ( + (wrap_if has_attr (str "(") (str ")") (fmt_function - ~ctx:(Exp r) ~box:false ~parens:(parens_r || has_attr) ~wrap_intro:(fun intro -> + ~ctx:(Exp r) ~box:false ~parens:(parens_r) ~wrap_intro:(fun intro -> ( ( hvbox indent_wrap ( fmt_expression ~indent_wrap c (sub_exp ~ctx l) From 27f7ecdfec1bef9509589d1cbf14d646b4367a5a Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Tue, 16 Apr 2024 15:41:52 +0200 Subject: [PATCH 029/146] Don't fit toplevel 'function's --- lib/Fmt_ast.ml | 17 +++++++++++------ lib/Params.ml | 5 +++-- lib/Params.mli | 1 + 3 files changed, 15 insertions(+), 8 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 575d1f9dda..cdf7cc25c2 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1468,8 +1468,8 @@ and fmt_function ?force_closing_paren ~ctx ?(wrap_intro = fun x -> hvbox 2 x $ s fmt_fun_args_typ args typ, fmt_expression c (sub_exp ~ctx body) | [], _, Pfunction_body _ -> assert false | args, typ, Pfunction_cases (cs, _loc, cs_attrs) -> - (* Only [function]. [spilled_attrs] are extra attrs to add to the - [function] keyword. *) + (* Both [fun] and [function]. [spilled_attrs] are extra attrs to add to + the [function] keyword. *) let fun_, spilled_attrs = match args, typ with | [], None -> noop, attrs @@ -2183,6 +2183,11 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens ) ) | Pexp_function ([], None, Pfunction_cases (cs, _, _)) -> let indent = Params.Indent.function_ c.conf ~parens xexp in + let force_break_cases = + match ctx0, cs with + | Str _, _ :: _ :: _ -> true + | _ -> false + in let outer_pro, inner_pro = if parens then pro, noop else noop, pro in outer_pro $ Params.Exp.wrap c.conf ~parens ~disambiguate:true ~fits_breaks:false @@ -2192,7 +2197,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens $ fmt_extension_suffix c ext $ fmt_attributes c pexp_attributes ) $ break 1 indent - $ hvbox 0 (fmt_cases c ctx cs) ) + $ hvbox 0 (fmt_cases c ~force_break_cases ctx cs) ) | Pexp_function ([], Some _, _) -> assert false | Pexp_ident {txt; loc} -> let outer_parens = has_attr && parens in @@ -3074,9 +3079,9 @@ and fmt_class_type_field c {ast= cf; _} = | Pctf_attribute attr -> fmt_floating_attributes_and_docstrings c [attr] | Pctf_extension ext -> fmt_item_extension c ctx ext -and fmt_cases c ctx cs = list_fl cs (fmt_case c ctx) +and fmt_cases c ?force_break_cases ctx cs = list_fl cs (fmt_case c ?force_break_cases ctx) -and fmt_case c ctx ~first ~last case = +and fmt_case c ?(force_break_cases=false) ctx ~first ~last case = let {pc_lhs; pc_guard; pc_rhs} = case in let xrhs = sub_exp ~ctx pc_rhs in (* side effects of Cmts.fmt_before before [fmt_lhs] is important *) @@ -3090,7 +3095,7 @@ and fmt_case c ctx ~first ~last case = let eol = Option.some_if (Cmts.has_before c.cmts pc_rhs.pexp_loc) force_break in - let p = Params.get_cases c.conf ~ctx ~first ~last ~xbch:xrhs in + let p = Params.get_cases c.conf ~ctx ~first ~last ~force_break_cases ~xbch:xrhs in p.leading_space $ leading_cmt $ p.box_all ( p.box_pattern_arrow diff --git a/lib/Params.ml b/lib/Params.ml index 64bc3f6f69..835e422f70 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -181,7 +181,8 @@ type cases = ; branch_expr: expression Ast.xt ; close_paren_branch: Fmt.t } -let get_cases (c : Conf.t) ~ctx ~first ~last ~xbch:({ast; _} as xast) = +let get_cases (c : Conf.t) ~ctx ~first ~last ~force_break_cases + ~xbch:({ast; _} as xast) = let indent = match (c.fmt_opts.cases_matching_exp_indent.v, (ctx, ast.pexp_desc)) with | ( `Compact @@ -231,7 +232,7 @@ let get_cases (c : Conf.t) ~ctx ~first ~last ~xbch:({ast; _} as xast) = in (fmt_if parens_branch (str " ("), close_paren, xast) in - match c.fmt_opts.break_cases.v with + match if force_break_cases then `All else c.fmt_opts.break_cases.v with | `Fit -> { leading_space= fmt_if (not first) space_break ; bar= fmt_or first (if_newline "| ") (str "| ") diff --git a/lib/Params.mli b/lib/Params.mli index 393c04aeef..200ac143ec 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -88,6 +88,7 @@ val get_cases : -> ctx:Ast.t -> first:bool -> last:bool + -> force_break_cases:bool -> xbch:expression Ast.xt -> cases From 8c07855174d1de4483a1f1633ff8d581b30792ee Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Tue, 16 Apr 2024 15:49:20 +0200 Subject: [PATCH 030/146] Fix unstable vb --- lib/Fmt_ast.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index cdf7cc25c2..a511c12dc8 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -4495,7 +4495,7 @@ and fmt_value_binding c ~rec_flag ?in_ ?epi if intro_as_pro then fmt_expression c ~pro ~box:false lb_exp else - pro$fmt_expression c ~box:false lb_exp + pro$fmt_expression c lb_exp in doc1 $ cmts_before $ hvbox 0 From 75123887fb0e4142cc1313d059c1f316007616ca Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Tue, 16 Apr 2024 15:50:00 +0200 Subject: [PATCH 031/146] Revert "Don't fit toplevel 'function's" This reverts commit 27f7ecdfec1bef9509589d1cbf14d646b4367a5a. --- lib/Fmt_ast.ml | 17 ++++++----------- lib/Params.ml | 5 ++--- lib/Params.mli | 1 - 3 files changed, 8 insertions(+), 15 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index a511c12dc8..da6d335b57 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1468,8 +1468,8 @@ and fmt_function ?force_closing_paren ~ctx ?(wrap_intro = fun x -> hvbox 2 x $ s fmt_fun_args_typ args typ, fmt_expression c (sub_exp ~ctx body) | [], _, Pfunction_body _ -> assert false | args, typ, Pfunction_cases (cs, _loc, cs_attrs) -> - (* Both [fun] and [function]. [spilled_attrs] are extra attrs to add to - the [function] keyword. *) + (* Only [function]. [spilled_attrs] are extra attrs to add to the + [function] keyword. *) let fun_, spilled_attrs = match args, typ with | [], None -> noop, attrs @@ -2183,11 +2183,6 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens ) ) | Pexp_function ([], None, Pfunction_cases (cs, _, _)) -> let indent = Params.Indent.function_ c.conf ~parens xexp in - let force_break_cases = - match ctx0, cs with - | Str _, _ :: _ :: _ -> true - | _ -> false - in let outer_pro, inner_pro = if parens then pro, noop else noop, pro in outer_pro $ Params.Exp.wrap c.conf ~parens ~disambiguate:true ~fits_breaks:false @@ -2197,7 +2192,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens $ fmt_extension_suffix c ext $ fmt_attributes c pexp_attributes ) $ break 1 indent - $ hvbox 0 (fmt_cases c ~force_break_cases ctx cs) ) + $ hvbox 0 (fmt_cases c ctx cs) ) | Pexp_function ([], Some _, _) -> assert false | Pexp_ident {txt; loc} -> let outer_parens = has_attr && parens in @@ -3079,9 +3074,9 @@ and fmt_class_type_field c {ast= cf; _} = | Pctf_attribute attr -> fmt_floating_attributes_and_docstrings c [attr] | Pctf_extension ext -> fmt_item_extension c ctx ext -and fmt_cases c ?force_break_cases ctx cs = list_fl cs (fmt_case c ?force_break_cases ctx) +and fmt_cases c ctx cs = list_fl cs (fmt_case c ctx) -and fmt_case c ?(force_break_cases=false) ctx ~first ~last case = +and fmt_case c ctx ~first ~last case = let {pc_lhs; pc_guard; pc_rhs} = case in let xrhs = sub_exp ~ctx pc_rhs in (* side effects of Cmts.fmt_before before [fmt_lhs] is important *) @@ -3095,7 +3090,7 @@ and fmt_case c ?(force_break_cases=false) ctx ~first ~last case = let eol = Option.some_if (Cmts.has_before c.cmts pc_rhs.pexp_loc) force_break in - let p = Params.get_cases c.conf ~ctx ~first ~last ~force_break_cases ~xbch:xrhs in + let p = Params.get_cases c.conf ~ctx ~first ~last ~xbch:xrhs in p.leading_space $ leading_cmt $ p.box_all ( p.box_pattern_arrow diff --git a/lib/Params.ml b/lib/Params.ml index 835e422f70..64bc3f6f69 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -181,8 +181,7 @@ type cases = ; branch_expr: expression Ast.xt ; close_paren_branch: Fmt.t } -let get_cases (c : Conf.t) ~ctx ~first ~last ~force_break_cases - ~xbch:({ast; _} as xast) = +let get_cases (c : Conf.t) ~ctx ~first ~last ~xbch:({ast; _} as xast) = let indent = match (c.fmt_opts.cases_matching_exp_indent.v, (ctx, ast.pexp_desc)) with | ( `Compact @@ -232,7 +231,7 @@ let get_cases (c : Conf.t) ~ctx ~first ~last ~force_break_cases in (fmt_if parens_branch (str " ("), close_paren, xast) in - match if force_break_cases then `All else c.fmt_opts.break_cases.v with + match c.fmt_opts.break_cases.v with | `Fit -> { leading_space= fmt_if (not first) space_break ; bar= fmt_or first (if_newline "| ") (str "| ") diff --git a/lib/Params.mli b/lib/Params.mli index 200ac143ec..393c04aeef 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -88,7 +88,6 @@ val get_cases : -> ctx:Ast.t -> first:bool -> last:bool - -> force_break_cases:bool -> xbch:expression Ast.xt -> cases From cac739d97cca58bd7ce2061758130c70f4423e44 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Tue, 16 Apr 2024 15:53:23 +0200 Subject: [PATCH 032/146] Promote tests --- test/passing/tests/args_grouped.ml | 8 +- test/passing/tests/attributes.ml | 31 +- test/passing/tests/break_colon-before.ml.ref | 2 +- test/passing/tests/break_colon.ml | 29 +- test/passing/tests/break_colon.ml.err | 1 - .../break_fun_decl-fit_or_vertical.ml.ref | 28 +- .../passing/tests/break_fun_decl-smart.ml.ref | 25 +- test/passing/tests/break_fun_decl-wrap.ml.ref | 25 +- test/passing/tests/break_fun_decl.ml | 25 +- .../tests/break_infix-fit-or-vertical.ml.ref | 14 +- test/passing/tests/break_infix-wrap.ml.ref | 7 +- test/passing/tests/break_infix.ml.ref | 14 +- test/passing/tests/comments-no-wrap.ml.err | 8 +- test/passing/tests/comments-no-wrap.ml.ref | 3 +- test/passing/tests/comments.ml.err | 2 +- test/passing/tests/comments.ml.ref | 3 +- test/passing/tests/disambiguate.ml | 2 +- test/passing/tests/doc_comments-after.ml.ref | 4 +- .../doc_comments-before-except-val.ml.ref | 4 +- test/passing/tests/doc_comments-before.ml.ref | 4 +- test/passing/tests/doc_comments.ml.ref | 4 +- test/passing/tests/extensions-indent.ml.ref | 8 +- test/passing/tests/extensions.ml.ref | 8 +- test/passing/tests/fun_decl.ml | 16 +- test/passing/tests/fun_function.ml | 3 +- test/passing/tests/function_indent.ml.ref | 10 +- test/passing/tests/infix_arg_grouping.ml.ref | 4 +- test/passing/tests/infix_bind-break.ml.ref | 44 +- .../infix_bind-fit_or_vertical-break.ml.ref | 48 +- .../tests/infix_bind-fit_or_vertical.ml.ref | 25 +- test/passing/tests/infix_bind.ml | 25 +- test/passing/tests/issue289.ml | 36 +- test/passing/tests/ite-compact.ml.ref | 10 +- test/passing/tests/ite-compact_closing.ml.ref | 10 +- test/passing/tests/ite-fit_or_vertical.ml.ref | 4 +- .../tests/ite-fit_or_vertical_closing.ml.ref | 4 +- .../ite-fit_or_vertical_no_indicate.ml.ref | 4 +- test/passing/tests/ite-kr.ml.ref | 4 +- test/passing/tests/ite-kr_closing.ml.ref | 4 +- test/passing/tests/ite-no_indicate.ml.ref | 10 +- test/passing/tests/ite.ml.ref | 10 +- test/passing/tests/js_bind.ml.ref | 7 +- test/passing/tests/js_fun.ml.ref | 11 +- test/passing/tests/js_source.ml.err | 11 +- test/passing/tests/js_source.ml.ocp | 169 ++- test/passing/tests/js_source.ml.ref | 1185 +++++++++-------- test/passing/tests/js_upon.ml.ref | 4 +- test/passing/tests/labelled_args-414.ml.ref | 17 +- test/passing/tests/labelled_args.ml | 17 +- .../tests/let_binding-in_indent.ml.ref | 6 +- test/passing/tests/let_binding-indent.ml.ref | 6 +- test/passing/tests/let_binding.ml.ref | 6 +- test/passing/tests/loc_stack.ml.ref | 29 +- test/passing/tests/match.ml | 8 +- test/passing/tests/match2.ml | 11 +- test/passing/tests/max_indent.ml | 4 +- test/passing/tests/object.ml.ref | 8 +- ...ocp_indent_compat-break_colon_after.ml.ref | 20 +- test/passing/tests/ocp_indent_compat.ml | 2 +- .../open-closing-on-separate-line.ml.ref | 16 +- test/passing/tests/open.ml.ref | 16 +- test/passing/tests/polytypes-default.ml.ref | 47 +- .../passing/tests/polytypes-janestreet.ml.ref | 26 +- test/passing/tests/polytypes.ml | 50 +- test/passing/tests/pre_post_extensions.ml | 8 +- test/passing/tests/revapply_ext.ml | 4 +- test/passing/tests/skip.ml | 16 +- test/passing/tests/source.ml.err | 6 +- test/passing/tests/source.ml.ref | 1099 ++++++++------- test/rpc/rpc_test.expected | 13 +- 70 files changed, 1675 insertions(+), 1677 deletions(-) diff --git a/test/passing/tests/args_grouped.ml b/test/passing/tests/args_grouped.ml index 557710a46a..da619cb917 100644 --- a/test/passing/tests/args_grouped.ml +++ b/test/passing/tests/args_grouped.ml @@ -81,13 +81,13 @@ let f = let eradicate_meta_class_is_nullsafe = register ~id:"ERADICATE_META_CLASS_IS_NULLSAFE" - ~hum:"Class is marked @Nullsafe and has 0 issues" - (* Should be enabled for special integrations *) + ~hum: + "Class is marked @Nullsafe and has 0 issues" (* Should be enabled for special integrations *) ~enabled:false Info Eradicate (* TODO *) ~user_documentation:"" let eradicate_meta_class_is_nullsafe = register ~id:"ERADICATE_META_CLASS_IS_NULLSAFE" (* Should be enabled for special integrations *) - ~hum:"Class is marked @Nullsafe and has 0 issues" - (* Should be enabled for special integrations *) + ~hum: + "Class is marked @Nullsafe and has 0 issues" (* Should be enabled for special integrations *) ~enabled:false Info diff --git a/test/passing/tests/attributes.ml b/test/passing/tests/attributes.ml index 2ea68488d3..8f2204aad4 100644 --- a/test/passing/tests/attributes.ml +++ b/test/passing/tests/attributes.ml @@ -381,16 +381,15 @@ let _ = f ((* comments *) 'c' [@attributes]) let _ = function ("foo" [@attr]) -> ("bar" [@attr2]) let _ = function - | ('A' [@attr]) -> ('B' [@attr2]) - | ('A' .. 'B' [@attr2]) -> () + | ('A' [@attr]) -> ('B' [@attr2]) | ('A' .. 'B' [@attr2]) -> () let _ = match x with | _ when f - ~f:(function [@ocaml.warning - (* ....................................... *) - "-4"] _ -> . ) -> + ~f:(function [@ocaml.warning + (* ....................................... *) + "-4"] _ -> . ) -> y let[@a @@ -406,18 +405,18 @@ let[@a with | _ when f - ~f:(function[@ocaml.warning - (* ....................................... *) "-4"] + ~f:(function [@ocaml.warning + (* ....................................... *) "-4"] | _ -> . ) - ~f:(function[@ocaml.warning - (* ....................................... *) - (* ....................................... *) - "foooooooooooooooooooooooooooo \ - fooooooooooooooooooooooooooooooooooooo"] _ -> . ) - ~f:(function[@ocaml.warning - (* ....................................... *) - let x = a and y = b in - x + y] _ -> . ) -> + ~f:(function [@ocaml.warning + (* ....................................... *) + (* ....................................... *) + "foooooooooooooooooooooooooooo \ + fooooooooooooooooooooooooooooooooooooo"] _ -> . ) + ~f:(function [@ocaml.warning + (* ....................................... *) + let x = a and y = b in + x + y] _ -> . ) -> y [@attr (* ... *) diff --git a/test/passing/tests/break_colon-before.ml.ref b/test/passing/tests/break_colon-before.ml.ref index 1568b091ad..eacbae1977 100644 --- a/test/passing/tests/break_colon-before.ml.ref +++ b/test/passing/tests/break_colon-before.ml.ref @@ -74,7 +74,7 @@ let ssmap with type key = string and type data = string and type map = SSMap.map ) - -> unit = + -> unit = () let long_function_name diff --git a/test/passing/tests/break_colon.ml b/test/passing/tests/break_colon.ml index 61c9741e50..ecab151551 100644 --- a/test/passing/tests/break_colon.ml +++ b/test/passing/tests/break_colon.ml @@ -61,31 +61,30 @@ module type M = sig -> unit end -let ssmap : - (module MapT - with type key = string - and type data = string - and type map = SSMap.map ) = +let ssmap : (module MapT + with type key = string + and type data = string + and type map = SSMap.map ) = () -let ssmap : - (module MapT - with type key = string - and type data = string - and type map = SSMap.map ) - -> unit = +let ssmap : (module MapT + with type key = string + and type data = string + and type map = SSMap.map ) + -> unit = () let long_function_name : type a. a long_long_type -> a -> a -> a -> wrap_wrap_wrap -> unit = fun () -> () -let array_fold_transf (f : numbering -> 'a -> numbering * 'b) n (a : 'a array) - : numbering * 'b array = +let array_fold_transf (f : numbering -> 'a -> numbering * 'b) n + (a : 'a array) : numbering * 'b array = match Array.length a with 0 -> (n, [||]) | 1 -> x -let to_clambda_function (id, (function_decl : Flambda.function_declaration)) - : Clambda.ufunction = +let to_clambda_function + (id, (function_decl : Flambda.function_declaration)) : Clambda.ufunction + = (* All that we need in the environment, for translating one closure from a closed set of closures, is the substitutions for variables bound to the various closures in the set. Such closures will always be ... *) diff --git a/test/passing/tests/break_colon.ml.err b/test/passing/tests/break_colon.ml.err index 7ec0d7d643..e69de29bb2 100644 --- a/test/passing/tests/break_colon.ml.err +++ b/test/passing/tests/break_colon.ml.err @@ -1 +0,0 @@ -Warning: tests/break_colon.ml:82 exceeds the margin diff --git a/test/passing/tests/break_fun_decl-fit_or_vertical.ml.ref b/test/passing/tests/break_fun_decl-fit_or_vertical.ml.ref index d93df61cf7..4c4ccae512 100644 --- a/test/passing/tests/break_fun_decl-fit_or_vertical.ml.ref +++ b/test/passing/tests/break_fun_decl-fit_or_vertical.ml.ref @@ -56,17 +56,15 @@ class ffffffffffffffffffff let ffffffffffffffffffff : aaaaaaaaaaaaaaaaaaaaaa -> bbbbbbbbbbbbbbbbbbbbbb = g -let ffffffffffffffffffff : - aaaaaaaaaaaaaaaaaaaaaa - -> bbbbbbbbbbbbbbbbbbbbbb - -> cccccccccccccccccccccc = +let ffffffffffffffffffff : aaaaaaaaaaaaaaaaaaaaaa + -> bbbbbbbbbbbbbbbbbbbbbb + -> cccccccccccccccccccccc = g -let ffffffffffffffffffff : - aaaaaaaaaaaaaaaaaaaaaa - -> bbbbbbbbbbbbbbbbbbbbbb - -> cccccccccccccccccccccc - -> dddddddddddddddddddddd = +let ffffffffffffffffffff : aaaaaaaaaaaaaaaaaaaaaa + -> bbbbbbbbbbbbbbbbbbbbbb + -> cccccccccccccccccccccc + -> dddddddddddddddddddddd = g let fffffffffffffffffffffffffffffffffff x yyyyyyyyyyyyyyyyyyyyyyyyyyy = () @@ -79,8 +77,7 @@ let fffffffffffffffffffffffffffffffffff class ffffffffffffffffffff = object - method ffffffffffffffffffff - : + method ffffffffffffffffffff : aaaaaaaaaaaaaaaaaaaaaa -> bbbbbbbbbbbbbbbbbbbbbb -> cccccccccccccccccccccc @@ -120,14 +117,13 @@ end let _ = fun (module Store : Irmin.Generic_key.S with type repo = repo) - (module Store : Irmin.Generic_key.S with type repo = repo) -> - body + (module Store : Irmin.Generic_key.S with type repo = repo) + -> body let _ = f - (fun - (module Store : Irmin.Generic_key.S with type repo = repo) - (module Store : Irmin.Generic_key.S with type repo = repo) + (fun (module Store : Irmin.Generic_key.S with type repo = repo) + (module Store : Irmin.Generic_key.S with type repo = repo) -> body ) let f diff --git a/test/passing/tests/break_fun_decl-smart.ml.ref b/test/passing/tests/break_fun_decl-smart.ml.ref index c7d3bc4190..4838bd576f 100644 --- a/test/passing/tests/break_fun_decl-smart.ml.ref +++ b/test/passing/tests/break_fun_decl-smart.ml.ref @@ -52,17 +52,15 @@ class ffffffffffffffffffff let ffffffffffffffffffff : aaaaaaaaaaaaaaaaaaaaaa -> bbbbbbbbbbbbbbbbbbbbbb = g -let ffffffffffffffffffff : - aaaaaaaaaaaaaaaaaaaaaa - -> bbbbbbbbbbbbbbbbbbbbbb - -> cccccccccccccccccccccc = +let ffffffffffffffffffff : aaaaaaaaaaaaaaaaaaaaaa + -> bbbbbbbbbbbbbbbbbbbbbb + -> cccccccccccccccccccccc = g -let ffffffffffffffffffff : - aaaaaaaaaaaaaaaaaaaaaa - -> bbbbbbbbbbbbbbbbbbbbbb - -> cccccccccccccccccccccc - -> dddddddddddddddddddddd = +let ffffffffffffffffffff : aaaaaaaaaaaaaaaaaaaaaa + -> bbbbbbbbbbbbbbbbbbbbbb + -> cccccccccccccccccccccc + -> dddddddddddddddddddddd = g let fffffffffffffffffffffffffffffffffff x yyyyyyyyyyyyyyyyyyyyyyyyyyy = () @@ -113,14 +111,13 @@ end let _ = fun (module Store : Irmin.Generic_key.S with type repo = repo) - (module Store : Irmin.Generic_key.S with type repo = repo) -> - body + (module Store : Irmin.Generic_key.S with type repo = repo) + -> body let _ = f - (fun - (module Store : Irmin.Generic_key.S with type repo = repo) - (module Store : Irmin.Generic_key.S with type repo = repo) + (fun (module Store : Irmin.Generic_key.S with type repo = repo) + (module Store : Irmin.Generic_key.S with type repo = repo) -> body ) let f diff --git a/test/passing/tests/break_fun_decl-wrap.ml.ref b/test/passing/tests/break_fun_decl-wrap.ml.ref index 88a8c80cdc..41b4a6cd5f 100644 --- a/test/passing/tests/break_fun_decl-wrap.ml.ref +++ b/test/passing/tests/break_fun_decl-wrap.ml.ref @@ -34,17 +34,15 @@ class ffffffffffffffffffff aaaaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbbb let ffffffffffffffffffff : aaaaaaaaaaaaaaaaaaaaaa -> bbbbbbbbbbbbbbbbbbbbbb = g -let ffffffffffffffffffff : - aaaaaaaaaaaaaaaaaaaaaa - -> bbbbbbbbbbbbbbbbbbbbbb - -> cccccccccccccccccccccc = +let ffffffffffffffffffff : aaaaaaaaaaaaaaaaaaaaaa + -> bbbbbbbbbbbbbbbbbbbbbb + -> cccccccccccccccccccccc = g -let ffffffffffffffffffff : - aaaaaaaaaaaaaaaaaaaaaa - -> bbbbbbbbbbbbbbbbbbbbbb - -> cccccccccccccccccccccc - -> dddddddddddddddddddddd = +let ffffffffffffffffffff : aaaaaaaaaaaaaaaaaaaaaa + -> bbbbbbbbbbbbbbbbbbbbbb + -> cccccccccccccccccccccc + -> dddddddddddddddddddddd = g let fffffffffffffffffffffffffffffffffff x yyyyyyyyyyyyyyyyyyyyyyyyyyy = () @@ -95,14 +93,13 @@ end let _ = fun (module Store : Irmin.Generic_key.S with type repo = repo) - (module Store : Irmin.Generic_key.S with type repo = repo) -> - body + (module Store : Irmin.Generic_key.S with type repo = repo) + -> body let _ = f - (fun - (module Store : Irmin.Generic_key.S with type repo = repo) - (module Store : Irmin.Generic_key.S with type repo = repo) + (fun (module Store : Irmin.Generic_key.S with type repo = repo) + (module Store : Irmin.Generic_key.S with type repo = repo) -> body ) let f (module Store : Irmin.Generic_key.S with type repo = repo) diff --git a/test/passing/tests/break_fun_decl.ml b/test/passing/tests/break_fun_decl.ml index 88a8c80cdc..41b4a6cd5f 100644 --- a/test/passing/tests/break_fun_decl.ml +++ b/test/passing/tests/break_fun_decl.ml @@ -34,17 +34,15 @@ class ffffffffffffffffffff aaaaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbbb let ffffffffffffffffffff : aaaaaaaaaaaaaaaaaaaaaa -> bbbbbbbbbbbbbbbbbbbbbb = g -let ffffffffffffffffffff : - aaaaaaaaaaaaaaaaaaaaaa - -> bbbbbbbbbbbbbbbbbbbbbb - -> cccccccccccccccccccccc = +let ffffffffffffffffffff : aaaaaaaaaaaaaaaaaaaaaa + -> bbbbbbbbbbbbbbbbbbbbbb + -> cccccccccccccccccccccc = g -let ffffffffffffffffffff : - aaaaaaaaaaaaaaaaaaaaaa - -> bbbbbbbbbbbbbbbbbbbbbb - -> cccccccccccccccccccccc - -> dddddddddddddddddddddd = +let ffffffffffffffffffff : aaaaaaaaaaaaaaaaaaaaaa + -> bbbbbbbbbbbbbbbbbbbbbb + -> cccccccccccccccccccccc + -> dddddddddddddddddddddd = g let fffffffffffffffffffffffffffffffffff x yyyyyyyyyyyyyyyyyyyyyyyyyyy = () @@ -95,14 +93,13 @@ end let _ = fun (module Store : Irmin.Generic_key.S with type repo = repo) - (module Store : Irmin.Generic_key.S with type repo = repo) -> - body + (module Store : Irmin.Generic_key.S with type repo = repo) + -> body let _ = f - (fun - (module Store : Irmin.Generic_key.S with type repo = repo) - (module Store : Irmin.Generic_key.S with type repo = repo) + (fun (module Store : Irmin.Generic_key.S with type repo = repo) + (module Store : Irmin.Generic_key.S with type repo = repo) -> body ) let f (module Store : Irmin.Generic_key.S with type repo = repo) diff --git a/test/passing/tests/break_infix-fit-or-vertical.ml.ref b/test/passing/tests/break_infix-fit-or-vertical.ml.ref index 7aa7824b43..f9cc2dd820 100644 --- a/test/passing/tests/break_infix-fit-or-vertical.ml.ref +++ b/test/passing/tests/break_infix-fit-or-vertical.ml.ref @@ -73,13 +73,13 @@ let _ = @@ fooooooooooooooo @@ (fun x -> foooooooooooooo $ fooooooooooooooooooooo) @@ fun x -> - fooooooooooooooo - $ fooooooooooooooooo - $ fooooooooooooooooo - $ fooooooooooooo - $ fooo @@ foooooooooooooooooo - $ fooooooooooooo - $ foooooooooooooooooooo + fooooooooooooooo + $ fooooooooooooooooo + $ fooooooooooooooooo + $ fooooooooooooo + $ fooo @@ foooooooooooooooooo + $ fooooooooooooo + $ foooooooooooooooooooo let _ = a + (b * c) + d diff --git a/test/passing/tests/break_infix-wrap.ml.ref b/test/passing/tests/break_infix-wrap.ml.ref index 3b2545994f..738e65c008 100644 --- a/test/passing/tests/break_infix-wrap.ml.ref +++ b/test/passing/tests/break_infix-wrap.ml.ref @@ -44,9 +44,10 @@ let _ = fooooooooo @@ fooooooooooooooo @@ (fun x -> foooooooooooooo $ fooooooooooooooooooooo) @@ fun x -> - fooooooooooooooo $ fooooooooooooooooo $ fooooooooooooooooo $ fooooooooooooo - $ fooo @@ foooooooooooooooooo - $ fooooooooooooo $ foooooooooooooooooooo + fooooooooooooooo $ fooooooooooooooooo $ fooooooooooooooooo + $ fooooooooooooo + $ fooo @@ foooooooooooooooooo + $ fooooooooooooo $ foooooooooooooooooooo let _ = a + (b * c) + d diff --git a/test/passing/tests/break_infix.ml.ref b/test/passing/tests/break_infix.ml.ref index 71a79f5806..08727b5b3d 100644 --- a/test/passing/tests/break_infix.ml.ref +++ b/test/passing/tests/break_infix.ml.ref @@ -62,13 +62,13 @@ let _ = fooooooooo @@ fooooooooooooooo @@ (fun x -> foooooooooooooo $ fooooooooooooooooooooo) @@ fun x -> - fooooooooooooooo - $ fooooooooooooooooo - $ fooooooooooooooooo - $ fooooooooooooo - $ fooo @@ foooooooooooooooooo - $ fooooooooooooo - $ foooooooooooooooooooo + fooooooooooooooo + $ fooooooooooooooooo + $ fooooooooooooooooo + $ fooooooooooooo + $ fooo @@ foooooooooooooooooo + $ fooooooooooooo + $ foooooooooooooooooooo let _ = a + (b * c) + d diff --git a/test/passing/tests/comments-no-wrap.ml.err b/test/passing/tests/comments-no-wrap.ml.err index 82121cfa75..341f8e8f2a 100644 --- a/test/passing/tests/comments-no-wrap.ml.err +++ b/test/passing/tests/comments-no-wrap.ml.err @@ -1,4 +1,4 @@ -Warning: tests/comments.ml:186 exceeds the margin -Warning: tests/comments.ml:190 exceeds the margin -Warning: tests/comments.ml:250 exceeds the margin -Warning: tests/comments.ml:434 exceeds the margin +Warning: tests/comments.ml:187 exceeds the margin +Warning: tests/comments.ml:191 exceeds the margin +Warning: tests/comments.ml:251 exceeds the margin +Warning: tests/comments.ml:435 exceeds the margin diff --git a/test/passing/tests/comments-no-wrap.ml.ref b/test/passing/tests/comments-no-wrap.ml.ref index cd5bd7c83a..4b7a1b7f9d 100644 --- a/test/passing/tests/comments-no-wrap.ml.ref +++ b/test/passing/tests/comments-no-wrap.ml.ref @@ -112,7 +112,8 @@ module type T = sig and B : sig end end -let f = (* comment *) function x -> x +(* comment *) +let f = function x -> x let foo x = (* comment *) (y : z) diff --git a/test/passing/tests/comments.ml.err b/test/passing/tests/comments.ml.err index 17f191fb4d..8758438258 100644 --- a/test/passing/tests/comments.ml.err +++ b/test/passing/tests/comments.ml.err @@ -1 +1 @@ -Warning: tests/comments.ml:252 exceeds the margin +Warning: tests/comments.ml:253 exceeds the margin diff --git a/test/passing/tests/comments.ml.ref b/test/passing/tests/comments.ml.ref index a637c9b6b3..eff5ba9af9 100644 --- a/test/passing/tests/comments.ml.ref +++ b/test/passing/tests/comments.ml.ref @@ -112,7 +112,8 @@ module type T = sig and B : sig end end -let f = (* comment *) function x -> x +(* comment *) +let f = function x -> x let foo x = (* comment *) (y : z) diff --git a/test/passing/tests/disambiguate.ml b/test/passing/tests/disambiguate.ml index 8b6c295426..f9b90ebe07 100644 --- a/test/passing/tests/disambiguate.ml +++ b/test/passing/tests/disambiguate.ml @@ -1,6 +1,6 @@ [@@@ocamlformat "disambiguate-non-breaking-match"] -let () = r := (fun () -> f () ; g ()) +let () = r := fun () -> f () ; g () let () = r := diff --git a/test/passing/tests/doc_comments-after.ml.ref b/test/passing/tests/doc_comments-after.ml.ref index ad4ad77c2e..2de999dd15 100644 --- a/test/passing/tests/doc_comments-after.ml.ref +++ b/test/passing/tests/doc_comments-after.ml.ref @@ -304,8 +304,8 @@ let a = 1 let _ = f @@ {aaa= aaa bbb ccc; bbb= aaa bbb ccc; ccc= aaa bbb ccc} >>= fun () -> - let _ = x in - f @@ g @@ h @@ fun x -> y + let _ = x in + f @@ g @@ h @@ fun x -> y ]} *) (**{v diff --git a/test/passing/tests/doc_comments-before-except-val.ml.ref b/test/passing/tests/doc_comments-before-except-val.ml.ref index 66cc7751a1..e073f0b56e 100644 --- a/test/passing/tests/doc_comments-before-except-val.ml.ref +++ b/test/passing/tests/doc_comments-before-except-val.ml.ref @@ -304,8 +304,8 @@ let a = 1 let _ = f @@ {aaa= aaa bbb ccc; bbb= aaa bbb ccc; ccc= aaa bbb ccc} >>= fun () -> - let _ = x in - f @@ g @@ h @@ fun x -> y + let _ = x in + f @@ g @@ h @@ fun x -> y ]} *) (**{v diff --git a/test/passing/tests/doc_comments-before.ml.ref b/test/passing/tests/doc_comments-before.ml.ref index ae6ef68376..06750192f3 100644 --- a/test/passing/tests/doc_comments-before.ml.ref +++ b/test/passing/tests/doc_comments-before.ml.ref @@ -304,8 +304,8 @@ let a = 1 let _ = f @@ {aaa= aaa bbb ccc; bbb= aaa bbb ccc; ccc= aaa bbb ccc} >>= fun () -> - let _ = x in - f @@ g @@ h @@ fun x -> y + let _ = x in + f @@ g @@ h @@ fun x -> y ]} *) (**{v diff --git a/test/passing/tests/doc_comments.ml.ref b/test/passing/tests/doc_comments.ml.ref index 66cc7751a1..e073f0b56e 100644 --- a/test/passing/tests/doc_comments.ml.ref +++ b/test/passing/tests/doc_comments.ml.ref @@ -304,8 +304,8 @@ let a = 1 let _ = f @@ {aaa= aaa bbb ccc; bbb= aaa bbb ccc; ccc= aaa bbb ccc} >>= fun () -> - let _ = x in - f @@ g @@ h @@ fun x -> y + let _ = x in + f @@ g @@ h @@ fun x -> y ]} *) (**{v diff --git a/test/passing/tests/extensions-indent.ml.ref b/test/passing/tests/extensions-indent.ml.ref index dec5ab6dba..3d1f5368af 100644 --- a/test/passing/tests/extensions-indent.ml.ref +++ b/test/passing/tests/extensions-indent.ml.ref @@ -432,19 +432,19 @@ let _ = f ((try%ext x with _ -> x) [@attr]) let _ = f ([%ext try x with _ -> x] [@attr]) -let _ = fun%ext x -> x +let _ = fun%ext x -> x let _ = [%ext fun x -> x] -let _ = f (fun%ext x -> x) +let _ = f (fun%ext x -> x) let _ = f [%ext fun x -> x] -let _ = (fun%ext x -> x) [@attr] +let _ = (fun%ext x -> x) [@attr] let _ = [%ext fun x -> x] [@attr] -let _ = f ((fun%ext x -> x) [@attr]) +let _ = f ((fun%ext x -> x) [@attr]) let _ = f ([%ext fun x -> x] [@attr]) diff --git a/test/passing/tests/extensions.ml.ref b/test/passing/tests/extensions.ml.ref index b85bc9347a..00302a598a 100644 --- a/test/passing/tests/extensions.ml.ref +++ b/test/passing/tests/extensions.ml.ref @@ -432,19 +432,19 @@ let _ = f ((try%ext x with _ -> x) [@attr]) let _ = f ([%ext try x with _ -> x] [@attr]) -let _ = fun%ext x -> x +let _ = fun%ext x -> x let _ = [%ext fun x -> x] -let _ = f (fun%ext x -> x) +let _ = f (fun%ext x -> x) let _ = f [%ext fun x -> x] -let _ = (fun%ext x -> x) [@attr] +let _ = (fun%ext x -> x) [@attr] let _ = [%ext fun x -> x] [@attr] -let _ = f ((fun%ext x -> x) [@attr]) +let _ = f ((fun%ext x -> x) [@attr]) let _ = f ([%ext fun x -> x] [@attr]) diff --git a/test/passing/tests/fun_decl.ml b/test/passing/tests/fun_decl.ml index 8973cc2cdc..d79d85002a 100644 --- a/test/passing/tests/fun_decl.ml +++ b/test/passing/tests/fun_decl.ml @@ -6,13 +6,13 @@ let fooo = List.foooo ~f:(fun foooo foooo : bool -> foooooooooooooooooooooo) let _ = fun (x : int) (x : int) (x : int) (x : int) (x : int) : - fooooooooooooooooooooooooooo foooooooooooooo foooooooooo -> - some_large_computation + fooooooooooooooooooooooooooo foooooooooooooo foooooooooo + -> some_large_computation let _ = fun (x : int) (x : int) (x : int) (x : int) (x : int) (x : int) (x : int) : - fooooooooooooooooooooooooooo foooooooooooooo foooooooooo -> - some_large_computation + fooooooooooooooooooooooooooo foooooooooooooo foooooooooo + -> some_large_computation [@@@ocamlformat "wrap-fun-args=false"] @@ -65,8 +65,6 @@ let translate_captured () let f ssssssssss = - String.fold ssssssssss ~init:innnnnnnnnnit ~f:(fun accuuuuuuuuuum -> - function - | '0' -> g accuuuuuuuuuum - | '1' -> h accuuuuuuuuuum - | _ -> i accuuuuuuuuuum ) + String.fold ssssssssss ~init:innnnnnnnnnit + ~f:(fun accuuuuuuuuuum ->function '0' -> g accuuuuuuuuuum + | '1' -> h accuuuuuuuuuum | _ -> i accuuuuuuuuuum ) diff --git a/test/passing/tests/fun_function.ml b/test/passing/tests/fun_function.ml index 4e55f06bc6..3b8174beae 100644 --- a/test/passing/tests/fun_function.ml +++ b/test/passing/tests/fun_function.ml @@ -1,4 +1,3 @@ let s = - List.fold x ~f:(fun y -> function - | Aconstructor avalue -> afunction avalue + List.fold x ~f:(fun y ->function Aconstructor avalue -> afunction avalue | Bconstructor bvalue -> bfunction bvalue ) diff --git a/test/passing/tests/function_indent.ml.ref b/test/passing/tests/function_indent.ml.ref index ad1c0048cc..e3156c2abb 100644 --- a/test/passing/tests/function_indent.ml.ref +++ b/test/passing/tests/function_indent.ml.ref @@ -1,14 +1,14 @@ let foooooooo = function - | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo + | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo let foooooooo = function - | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo - | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo + | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo + | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo let foo = fooooooooo foooooooo ~foooooooo:(function - | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo - | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo ) + | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo + | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo ) let foooooooo = if fooooooooooo then function diff --git a/test/passing/tests/infix_arg_grouping.ml.ref b/test/passing/tests/infix_arg_grouping.ml.ref index aa71b47d83..696b0be2b5 100644 --- a/test/passing/tests/infix_arg_grouping.ml.ref +++ b/test/passing/tests/infix_arg_grouping.ml.ref @@ -109,8 +109,8 @@ let () = (* Keep going... *) another_action |> fun t -> - (* And finally do this *) - final_action t + (* And finally do this *) + final_action t let () = (* Open the repo *) diff --git a/test/passing/tests/infix_bind-break.ml.ref b/test/passing/tests/infix_bind-break.ml.ref index 90ddc7c9ab..3efdd5f371 100644 --- a/test/passing/tests/infix_bind-break.ml.ref +++ b/test/passing/tests/infix_bind-break.ml.ref @@ -1,8 +1,10 @@ f x >>= fun y -> -g y ->>= fun () -> -f x >>= fun y -> g y >>= fun () -> f x >>= fun y -> g y >>= fun () -> y () + g y + >>= fun () -> + f x + >>= fun y -> + g y >>= fun () -> f x >>= fun y -> g y >>= fun () -> y () ;; f x @@ -10,9 +12,11 @@ f x | A -> ( g y >>= fun () -> - f x - >>= fun y -> - g y >>= function x -> ( f x >>= fun y -> g y >>= function _ -> y () ) ) + f x + >>= fun y -> + g y + >>= function + | x -> ( f x >>= fun y -> g y >>= function _ -> y () ) ) ;; eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee |> fun x -> x ;; @@ -29,7 +33,7 @@ eeeeeeeeeeeee eeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeee eeeeeeeeeeeee eeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeee eeeeeeeeeeee eeeeeeeeee |> fun xxxxxxxxxxxxx xxxxxxxxxxxxxx xxxxxxxxxxxxxx xxxxxxxxx -> -xxxxxxxxxxx xxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxx xxxxxxxxxxx + xxxxxxxxxxx xxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxx xxxxxxxxxxx ;; eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee |> fun x -> x ;; @@ -50,7 +54,7 @@ eeeeeeeeeeeee eeeeeeeeeeeeeeeeee eeeeeeeeeeeee eeeeeeeeee |> fun xxxxxxxxxxxxx xxxxxxxxxxxxxx xxxxxxxxxxxxxx xxxxxxxxx -> -xxxxxxxxxxx xxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxx xxxxxxxxxxx + xxxxxxxxxxx xxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxx xxxxxxxxxxx ;; eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee |> function x -> x ;; @@ -98,13 +102,13 @@ let parens = | {pexp_desc= Pexp_function cs; pexp_attributes; pexp_loc} -> update_config_maybe_disabled c pexp_loc pexp_attributes @@ fun c -> - fmt "@ " - $ Cmts.fmt c.cmts pexp_loc - (wrap_if parens "(" ")" - ( fmt "function" - $ fmt_extension_suffix c ext - $ fmt_attributes c ~key:"@" pexp_attributes - $ close_box $ fmt "@ " $ fmt_cases c ctx cs ) ) + fmt "@ " + $ Cmts.fmt c.cmts pexp_loc + (wrap_if parens "(" ")" + ( fmt "function" + $ fmt_extension_suffix c ext + $ fmt_attributes c ~key:"@" pexp_attributes + $ close_box $ fmt "@ " $ fmt_cases c ctx cs ) ) | _ -> close_box $ fmt "@ " $ fmt_expression c ~eol:(fmt "@;<1000 0>") xbody @@ -157,8 +161,8 @@ let _ = foo >>= fun [@warning "-4"] x -> fooooooooooooooooooooooo let _ = foo >>= fun [@warning "-4"] x y -> - fooooooooooooooooooooooo fooooooooooooooooooooooo fooooooooooooooooooooooo - fooooooooooooooooooooooo + fooooooooooooooooooooooo fooooooooooooooooooooooo + fooooooooooooooooooooooo fooooooooooooooooooooooo let _ = foo @@ -169,7 +173,7 @@ let _ = let _ = foo >>= fun (* foo before *) [@warning "-4"] (* foo after *) x -> - fooooooooooooooooooooooo + fooooooooooooooooooooooo let f = Ok () @@ -202,7 +206,7 @@ let f = >>= (* fooooooooooooooo fooooooooooooooo fooooooooooooooo foooooooooooooooo *) fun foooooo fooooo foooo foooooo -> - Ok foooooooooooooooooooooooooooooooooooooooooooooooooo + Ok foooooooooooooooooooooooooooooooooooooooooooooooooo let f = Ok () @@ -235,7 +239,7 @@ let default = command ## hasPermission #= (fun ctx -> foooooooooooooooooo fooooooooooo) ; command ## hasPermission #= (fun ctx -> - foooooooooooooooooo fooooooooooo foooooo fooooooooo foooooooooo ) ; + foooooooooooooooooo fooooooooooo foooooo fooooooooo foooooooooo ) ; foo let _ = ( let* ) x (fun y -> z) diff --git a/test/passing/tests/infix_bind-fit_or_vertical-break.ml.ref b/test/passing/tests/infix_bind-fit_or_vertical-break.ml.ref index 44e7573628..967e84c4a7 100644 --- a/test/passing/tests/infix_bind-fit_or_vertical-break.ml.ref +++ b/test/passing/tests/infix_bind-fit_or_vertical-break.ml.ref @@ -1,8 +1,10 @@ f x >>= fun y -> -g y ->>= fun () -> -f x >>= fun y -> g y >>= fun () -> f x >>= fun y -> g y >>= fun () -> y () + g y + >>= fun () -> + f x + >>= fun y -> + g y >>= fun () -> f x >>= fun y -> g y >>= fun () -> y () ;; f x @@ -10,9 +12,11 @@ f x | A -> ( g y >>= fun () -> - f x - >>= fun y -> - g y >>= function x -> ( f x >>= fun y -> g y >>= function _ -> y () ) ) + f x + >>= fun y -> + g y + >>= function + | x -> ( f x >>= fun y -> g y >>= function _ -> y () ) ) ;; eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee |> fun x -> x ;; @@ -29,7 +33,7 @@ eeeeeeeeeeeee eeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeee eeeeeeeeeeeee eeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeee eeeeeeeeeeee eeeeeeeeee |> fun xxxxxxxxxxxxx xxxxxxxxxxxxxx xxxxxxxxxxxxxx xxxxxxxxx -> -xxxxxxxxxxx xxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxx xxxxxxxxxxx + xxxxxxxxxxx xxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxx xxxxxxxxxxx ;; eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee |> fun x -> x ;; @@ -50,7 +54,7 @@ eeeeeeeeeeeee eeeeeeeeeeeeeeeeee eeeeeeeeeeeee eeeeeeeeee |> fun xxxxxxxxxxxxx xxxxxxxxxxxxxx xxxxxxxxxxxxxx xxxxxxxxx -> -xxxxxxxxxxx xxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxx xxxxxxxxxxx + xxxxxxxxxxx xxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxx xxxxxxxxxxx ;; eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee |> function x -> x ;; @@ -98,15 +102,15 @@ let parens = | {pexp_desc= Pexp_function cs; pexp_attributes; pexp_loc} -> update_config_maybe_disabled c pexp_loc pexp_attributes @@ fun c -> - fmt "@ " - $ Cmts.fmt c.cmts pexp_loc - (wrap_if parens "(" ")" - ( fmt "function" - $ fmt_extension_suffix c ext - $ fmt_attributes c ~key:"@" pexp_attributes - $ close_box - $ fmt "@ " - $ fmt_cases c ctx cs ) ) + fmt "@ " + $ Cmts.fmt c.cmts pexp_loc + (wrap_if parens "(" ")" + ( fmt "function" + $ fmt_extension_suffix c ext + $ fmt_attributes c ~key:"@" pexp_attributes + $ close_box + $ fmt "@ " + $ fmt_cases c ctx cs ) ) | _ -> close_box $ fmt "@ " $ fmt_expression c ~eol:(fmt "@;<1000 0>") xbody @@ -162,8 +166,8 @@ let _ = foo >>= fun [@warning "-4"] x -> fooooooooooooooooooooooo let _ = foo >>= fun [@warning "-4"] x y -> - fooooooooooooooooooooooo fooooooooooooooooooooooo fooooooooooooooooooooooo - fooooooooooooooooooooooo + fooooooooooooooooooooooo fooooooooooooooooooooooo + fooooooooooooooooooooooo fooooooooooooooooooooooo let _ = foo @@ -174,7 +178,7 @@ let _ = let _ = foo >>= fun (* foo before *) [@warning "-4"] (* foo after *) x -> - fooooooooooooooooooooooo + fooooooooooooooooooooooo let f = Ok () @@ -207,7 +211,7 @@ let f = >>= (* fooooooooooooooo fooooooooooooooo fooooooooooooooo foooooooooooooooo *) fun foooooo fooooo foooo foooooo -> - Ok foooooooooooooooooooooooooooooooooooooooooooooooooo + Ok foooooooooooooooooooooooooooooooooooooooooooooooooo let f = Ok () @@ -241,7 +245,7 @@ let default = command ## hasPermission #= (fun ctx -> - foooooooooooooooooo fooooooooooo foooooo fooooooooo foooooooooo ) ; + foooooooooooooooooo fooooooooooo foooooo fooooooooo foooooooooo ) ; foo let _ = ( let* ) x (fun y -> z) diff --git a/test/passing/tests/infix_bind-fit_or_vertical.ml.ref b/test/passing/tests/infix_bind-fit_or_vertical.ml.ref index d87402e3f0..5312fc0acf 100644 --- a/test/passing/tests/infix_bind-fit_or_vertical.ml.ref +++ b/test/passing/tests/infix_bind-fit_or_vertical.ml.ref @@ -1,19 +1,13 @@ f x >>= fun y -> g y >>= fun () -> -f x >>= fun y -> -g y >>= fun () -> -f x >>= fun y -> -g y >>= fun () -> y () +f x >>= fun y -> g y >>= fun () -> f x >>= fun y -> g y >>= fun () -> y () ;; f x >>= function | A -> ( g y >>= fun () -> f x >>= fun y -> - g y >>= function - | x -> ( - f x >>= fun y -> - g y >>= function _ -> y () ) ) + g y >>= function x -> ( f x >>= fun y -> g y >>= function _ -> y () ) ) ;; eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee |> fun x -> x ;; @@ -62,8 +56,7 @@ eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee |> function eeeeeeeeeeeee eeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeee eeeeeeeeeeee eeeeeeeeee -|> function -| x -> x +|> function x -> x ;; eeeeeeeeeeeee eeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeee @@ -147,11 +140,10 @@ let foo = let b = Batch batch in foo -let _ = foo >>= function[@warning "-4"] A -> false | B -> true +let _ = foo >>= function [@warning "-4"] A -> false | B -> true let _ = - foo >>= function[@warning "-4"] - | Afoooooooooooooooooo fooooooooo -> false + foo >>= function [@warning "-4"] Afoooooooooooooooooo fooooooooo -> false | Bfoooooooooooooooooooooo fooooooooo -> true let _ = foo >>= fun [@warning "-4"] x -> fooooooooooooooooooooooo @@ -162,7 +154,7 @@ let _ = fooooooooooooooooooooooo let _ = - foo >>= function(* foo before *) [@warning "-4"] (* foo after *) + foo >>= function (* foo before *) [@warning "-4"] (* foo after *) | Afoooooooooooooooooo fooooooooo -> false | Bfoooooooooooooooooooooo fooooooooo -> true @@ -195,8 +187,7 @@ let f = Ok () >>= (* fooooooooooooooo fooooooooooooooo fooooooooooooooo foooooooooooooooo *) - function - | Foo -> Ok foooooooooooooooooooooooooooooooooooooooooooooooooo + function Foo -> Ok foooooooooooooooooooooooooooooooooooooooooooooooooo (** The tests below are testing a dropped comment with `--no-break-infix-before-func` *) @@ -222,7 +213,7 @@ let encoder f = let default = command##hasPermission #= (fun ctx -> foooooooooooooooooo fooooooooooo) ; command##hasPermission #= (fun ctx -> - foooooooooooooooooo fooooooooooo foooooo fooooooooo foooooooooo) ; + foooooooooooooooooo fooooooooooo foooooo fooooooooo foooooooooo ) ; foo let _ = ( let* ) x (fun y -> z) diff --git a/test/passing/tests/infix_bind.ml b/test/passing/tests/infix_bind.ml index c51734bcb9..b78cdbbe93 100644 --- a/test/passing/tests/infix_bind.ml +++ b/test/passing/tests/infix_bind.ml @@ -1,19 +1,13 @@ f x >>= fun y -> g y >>= fun () -> -f x >>= fun y -> -g y >>= fun () -> -f x >>= fun y -> -g y >>= fun () -> y () +f x >>= fun y -> g y >>= fun () -> f x >>= fun y -> g y >>= fun () -> y () ;; f x >>= function | A -> ( g y >>= fun () -> f x >>= fun y -> - g y >>= function - | x -> ( - f x >>= fun y -> - g y >>= function _ -> y () ) ) + g y >>= function x -> ( f x >>= fun y -> g y >>= function _ -> y () ) ) ;; eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee |> fun x -> x ;; @@ -62,8 +56,7 @@ eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee |> function eeeeeeeeeeeee eeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeee eeeeeeeeeeee eeeeeeeeee -|> function -| x -> x +|> function x -> x ;; eeeeeeeeeeeee eeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeee @@ -142,11 +135,10 @@ let foo = let b = Batch batch in foo -let _ = foo >>= function[@warning "-4"] A -> false | B -> true +let _ = foo >>= function [@warning "-4"] A -> false | B -> true let _ = - foo >>= function[@warning "-4"] - | Afoooooooooooooooooo fooooooooo -> false + foo >>= function [@warning "-4"] Afoooooooooooooooooo fooooooooo -> false | Bfoooooooooooooooooooooo fooooooooo -> true let _ = foo >>= fun [@warning "-4"] x -> fooooooooooooooooooooooo @@ -157,7 +149,7 @@ let _ = fooooooooooooooooooooooo let _ = - foo >>= function(* foo before *) [@warning "-4"] (* foo after *) + foo >>= function (* foo before *) [@warning "-4"] (* foo after *) | Afoooooooooooooooooo fooooooooo -> false | Bfoooooooooooooooooooooo fooooooooo -> true @@ -190,8 +182,7 @@ let f = Ok () >>= (* fooooooooooooooo fooooooooooooooo fooooooooooooooo foooooooooooooooo *) - function - | Foo -> Ok foooooooooooooooooooooooooooooooooooooooooooooooooo + function Foo -> Ok foooooooooooooooooooooooooooooooooooooooooooooooooo (** The tests below are testing a dropped comment with `--no-break-infix-before-func` *) @@ -217,7 +208,7 @@ let encoder f = let default = command##hasPermission #= (fun ctx -> foooooooooooooooooo fooooooooooo) ; command##hasPermission #= (fun ctx -> - foooooooooooooooooo fooooooooooo foooooo fooooooooo foooooooooo) ; + foooooooooooooooooo fooooooooooo foooooo fooooooooo foooooooooo ) ; foo let _ = ( let* ) x (fun y -> z) diff --git a/test/passing/tests/issue289.ml b/test/passing/tests/issue289.ml index a947d82989..352a9ee307 100644 --- a/test/passing/tests/issue289.ml +++ b/test/passing/tests/issue289.ml @@ -3,31 +3,28 @@ let foo = let open Gql in [ field "id" ~doc:"Toy ID." ~args:[] ~typ:(non_null guid) ~resolve:(function - | _ctx -> x.id ) - ; field "id" ~doc:"Toy ID." ~args:[] ~typppp ~resolve:(function _ctx -> - x.id ) + | _ctx -> x.id ) + ; field "id" ~doc:"Toy ID." ~args:[] ~typppp ~resolve:(function + | _ctx -> x.id ) ; field "id" ~doc:"Toy ID." ~args:[] ~typ:(non_null guid) - ~resolve:(function - | A -> x.id - | B -> c ) - ; field "id" ~doc:"Toy ID." ~args:[] ~resolve:(function - | A -> x.id - | B -> c ) + ~resolve:(function A -> x.id | B -> c ) + ; field "id" ~doc:"Toy ID." ~args:[] ~resolve:(function A -> x.id + | B -> c ) ; field "id" ~doc:"Toy ID." ~args:[] ~typppppppppppppppppppp ~resolve:(function - | AAAAAAAAAAAAAAAAAAAa -> x.idddddddddddddddddddddddddd - | BBBBBBBBBBBBBBBB -> ccccccccccccccccccccccc ) + | AAAAAAAAAAAAAAAAAAAa -> x.idddddddddddddddddddddddddd + | BBBBBBBBBBBBBBBB -> ccccccccccccccccccccccc ) ; field "id" ~doc:"Toy ID." ~args:[] ~resolve:(function - | AAAAAAAAAAAAAAAAAAAa -> x.idddddddddddddddddddddddddd - | BBBBBBBBBBBBBBBB -> ccccccccccccccccccccccc ) + | AAAAAAAAAAAAAAAAAAAa -> x.idddddddddddddddddddddddddd + | BBBBBBBBBBBBBBBB -> ccccccccccccccccccccccc ) ; field "id" ~doc:"Toy ID." @@ -64,15 +61,12 @@ let foo = let foo = let open Gql in [ field "id" ~doc:"Toy ID." ~args:[] ~typ:(non_null guid) - ~resolve:(function _ctx -> x.id) - ; field "id" ~doc:"Toy ID." ~args:[] ~typppp ~resolve:(function _ctx -> - x.id ) + ~resolve:(function _ctx -> x.id ) + ; field "id" ~doc:"Toy ID." ~args:[] ~typppp ~resolve:(function + | _ctx -> x.id ) ; field "id" ~doc:"Toy ID." ~args:[] ~typ:(non_null guid) - ~resolve:(function - | A -> x.id - | B -> c ) - ; field "id" ~doc:"Toy ID." ~args:[] ~resolve:(function - | A -> x.id + ~resolve:(function A -> x.id | B -> c ) + ; field "id" ~doc:"Toy ID." ~args:[] ~resolve:(function A -> x.id | B -> c ) ; field "id" ~doc:"Toy ID." ~args:[] ~typppppppppppppppppppp ~resolve:(function diff --git a/test/passing/tests/ite-compact.ml.ref b/test/passing/tests/ite-compact.ml.ref index 38d75617b6..61e49d2eb0 100644 --- a/test/passing/tests/ite-compact.ml.ref +++ b/test/passing/tests/ite-compact.ml.ref @@ -135,10 +135,12 @@ let _ = else ( - ) let _ = - if x then fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz - else fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + if x then + fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + else + fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz let _ = if diff --git a/test/passing/tests/ite-compact_closing.ml.ref b/test/passing/tests/ite-compact_closing.ml.ref index ba050bfa68..788b371767 100644 --- a/test/passing/tests/ite-compact_closing.ml.ref +++ b/test/passing/tests/ite-compact_closing.ml.ref @@ -150,10 +150,12 @@ let _ = else ( - ) let _ = - if x then fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz - else fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + if x then + fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + else + fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz let _ = if diff --git a/test/passing/tests/ite-fit_or_vertical.ml.ref b/test/passing/tests/ite-fit_or_vertical.ml.ref index eee4a817df..32551a4d0f 100644 --- a/test/passing/tests/ite-fit_or_vertical.ml.ref +++ b/test/passing/tests/ite-fit_or_vertical.ml.ref @@ -164,10 +164,10 @@ let _ = let _ = if x then fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz else fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz let _ = if diff --git a/test/passing/tests/ite-fit_or_vertical_closing.ml.ref b/test/passing/tests/ite-fit_or_vertical_closing.ml.ref index 6bfc9ec2ce..b4aab9f9cf 100644 --- a/test/passing/tests/ite-fit_or_vertical_closing.ml.ref +++ b/test/passing/tests/ite-fit_or_vertical_closing.ml.ref @@ -176,10 +176,10 @@ let _ = let _ = if x then fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz else fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz let _ = if diff --git a/test/passing/tests/ite-fit_or_vertical_no_indicate.ml.ref b/test/passing/tests/ite-fit_or_vertical_no_indicate.ml.ref index 411368d842..b07442e27f 100644 --- a/test/passing/tests/ite-fit_or_vertical_no_indicate.ml.ref +++ b/test/passing/tests/ite-fit_or_vertical_no_indicate.ml.ref @@ -164,10 +164,10 @@ let _ = let _ = if x then fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz else fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz let _ = if diff --git a/test/passing/tests/ite-kr.ml.ref b/test/passing/tests/ite-kr.ml.ref index 28d2dbb092..d36a09a267 100644 --- a/test/passing/tests/ite-kr.ml.ref +++ b/test/passing/tests/ite-kr.ml.ref @@ -199,10 +199,10 @@ let _ = let _ = if x then fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz else fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz let _ = if diff --git a/test/passing/tests/ite-kr_closing.ml.ref b/test/passing/tests/ite-kr_closing.ml.ref index 8fc41701c5..1a81f9539a 100644 --- a/test/passing/tests/ite-kr_closing.ml.ref +++ b/test/passing/tests/ite-kr_closing.ml.ref @@ -209,10 +209,10 @@ let _ = let _ = if x then fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz else fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz let _ = if diff --git a/test/passing/tests/ite-no_indicate.ml.ref b/test/passing/tests/ite-no_indicate.ml.ref index 78627d847b..a6e647db75 100644 --- a/test/passing/tests/ite-no_indicate.ml.ref +++ b/test/passing/tests/ite-no_indicate.ml.ref @@ -134,10 +134,12 @@ let _ = else ( - ) let _ = - if x then fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz - else fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + if x then + fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + else + fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz let _ = if diff --git a/test/passing/tests/ite.ml.ref b/test/passing/tests/ite.ml.ref index 38d75617b6..61e49d2eb0 100644 --- a/test/passing/tests/ite.ml.ref +++ b/test/passing/tests/ite.ml.ref @@ -135,10 +135,12 @@ let _ = else ( - ) let _ = - if x then fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz - else fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + if x then + fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + else + fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz let _ = if diff --git a/test/passing/tests/js_bind.ml.ref b/test/passing/tests/js_bind.ml.ref index 4cdbd05986..e0f84775cb 100644 --- a/test/passing/tests/js_bind.ml.ref +++ b/test/passing/tests/js_bind.ml.ref @@ -15,6 +15,7 @@ let old_good = let old_good = foo bar qaz *>>| fun x -> - hey ho lala - *>>> fun y -> - foo bar qaz +>>| fun x -> hey ho lala +>>> fun y -> return (x, y) + hey ho lala + *>>> fun y -> + foo bar qaz + +>>| fun x -> hey ho lala +>>> fun y -> return (x, y) diff --git a/test/passing/tests/js_fun.ml.ref b/test/passing/tests/js_fun.ml.ref index ecd1141eb4..8a3c3aeb7c 100644 --- a/test/passing/tests/js_fun.ml.ref +++ b/test/passing/tests/js_fun.ml.ref @@ -13,13 +13,14 @@ let _ = [f (fun x -> x); f (fun x -> x); f (fun x -> x)] let _ = x >>= fun x -> - (try x with _ -> ()) >>= fun x -> try x with _ -> () >>= fun x -> x + (try x with _ -> ()) + >>= fun x -> try x with _ -> () >>= fun x -> x let () = expr >>| function x -> 3 | y -> 4 let () = expr >>| fun z -> match z with x -> 3 | y -> 4 -let () = expr >>| fun z -> function x -> 3 | y -> 4 +let () = expr >>| fun z ->function x -> 3 | y -> 4 let () = my_func () >>= function A -> 0 | B -> 0 @@ -30,13 +31,13 @@ let () = expr >>| function x -> 3 | y -> 4 let () = expr >>| function x -> 3 | y -> 4 let f = - f >>= m (fun f x -> y) ; + f >>= m (fun f -> fun x -> y) ; z let f = - f |> m (fun f x -> y) ; + f |> m (fun f -> fun x -> y) ; z let f = - f |> m (fun f x -> y) ; + f |> m (fun f -> fun x -> y) ; z diff --git a/test/passing/tests/js_source.ml.err b/test/passing/tests/js_source.ml.err index 15a8d419c1..701e84d882 100644 --- a/test/passing/tests/js_source.ml.err +++ b/test/passing/tests/js_source.ml.err @@ -1,6 +1,7 @@ Warning: tests/js_source.ml:162 exceeds the margin -Warning: tests/js_source.ml:9560 exceeds the margin -Warning: tests/js_source.ml:9664 exceeds the margin -Warning: tests/js_source.ml:9723 exceeds the margin -Warning: tests/js_source.ml:9805 exceeds the margin -Warning: tests/js_source.ml:10304 exceeds the margin +Warning: tests/js_source.ml:2677 exceeds the margin +Warning: tests/js_source.ml:9576 exceeds the margin +Warning: tests/js_source.ml:9680 exceeds the margin +Warning: tests/js_source.ml:9739 exceeds the margin +Warning: tests/js_source.ml:9822 exceeds the margin +Warning: tests/js_source.ml:10330 exceeds the margin diff --git a/test/passing/tests/js_source.ml.ocp b/test/passing/tests/js_source.ml.ocp index e6fec0dcfb..ecc75e50ee 100644 --- a/test/passing/tests/js_source.ml.ocp +++ b/test/passing/tests/js_source.ml.ocp @@ -1041,7 +1041,8 @@ let rec variantize : type t. t ty -> t -> variant = | Record { fields } -> VRecord (List.map - (fun (Field { field_type; label; get }) -> label, variantize field_type (get x)) + (fun (Field { field_type; label; get }) -> + label, variantize field_type (get x)) fields) ;; @@ -1293,10 +1294,11 @@ let ty_abc = and inj : type c. (int -> string -> noarg -> unit, c) ty_sel * c -> [ `A of int | `B of string | `C ] - = function - | Thd, v -> `A v - | Ttl Thd, v -> `B v - | Ttl (Ttl Thd), Noarg -> `C + = + function + | Thd, v -> `A v + | Ttl Thd, v -> `B v + | Ttl (Ttl Thd), Noarg -> `C in (* Coherence of sum_inj and sum_cases is checked by the typing *) Sum @@ -1330,10 +1332,11 @@ let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = | `Cons p -> "Cons", Some (Tdyn (tcons, p))) ; sum_cases = [ "Nil", TCnoarg Thd; "Cons", TCarg (Ttl Thd, tcons) ] ; sum_inj = - (fun (type c) : ((noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist) -> - function - | Thd, Noarg -> `Nil - | Ttl Thd, v -> `Cons v) + (fun (type c) -> + (function + | Thd, Noarg -> `Nil + | Ttl Thd, v -> `Cons v + : (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist)) (* One can also write the type annotation directly *) }) ;; @@ -1570,7 +1573,8 @@ let rec find : type sh. ('a -> 'a -> bool) -> 'a -> (sh, 'a) tree -> (sh, 'a) pa | Ttip -> [] | Tnode m -> if eq n m then [ Phere ] else [] | Tfork (x, y) -> - List.map (fun x -> Pleft x) (find eq n x) @ List.map (fun x -> Pright x) (find eq n y) + List.map (fun x -> Pleft x) (find eq n x) + @ List.map (fun x -> Pright x) (find eq n y) ;; let rec extract : type sh. (sh, 'a) path -> (sh, 'a) tree -> 'a = @@ -2019,7 +2023,7 @@ let rec rep_equal : type a b. a rep -> b rep -> (a, b) equal option = type assoc = Assoc : string * 'a rep * 'a -> assoc let rec assoc : type a. string -> a rep -> assoc list -> a = - fun x r -> function + fun x r ->function | [] -> raise Not_found | Assoc (x', r', v) :: env -> if x = x' @@ -2040,7 +2044,7 @@ type _ term = | Pair : 'a term * 'b term -> ('a * 'b) term let rec eval_term : type a. assoc list -> a term -> a = - fun env -> function + fun env ->function | Var (x, r) -> assoc x r env | Abs (x, r, e) -> fun v -> eval_term (Assoc (x, r, v) :: env) e | Const x -> x @@ -2381,7 +2385,8 @@ let inlineseq_from_astseq seq = | x, Ast_Bold xs -> Bold (List.map (process x) xs) | Kind Maylink, Ast_Link lnk -> Link lnk | Kind Nonlink, Ast_Link _ -> assert false - | Kind Maylink, Ast_Mref (lnk, xs) -> Mref (lnk, List.map (process (Kind Nonlink)) xs) + | Kind Maylink, Ast_Mref (lnk, xs) -> + Mref (lnk, List.map (process (Kind Nonlink)) xs) | Kind Nonlink, Ast_Mref _ -> assert false in List.map (process (Kind Maylink)) seq @@ -2432,8 +2437,7 @@ let eval (type c) (bop : (a, b, c) binop) (x : a constant) - (y : b constant) - : c constant + (y : b constant) : c constant = match bop, x, y with | Eq, Bool x, Bool y -> Bool (if x then y else not y) @@ -2665,23 +2669,24 @@ type ('a, 'result, 'visit_action) context = | Local : ('a, ('a * insert as 'result), 'a local_visit_action) context | Global : ('a, 'a, 'a visit_action) context -let vexpr (type visit_action) : (_, _, visit_action) context -> _ -> visit_action - = function - | Local -> fun _ -> raise Exit - | Global -> fun _ -> raise Exit +let vexpr (type visit_action) : (_, _, visit_action) context -> _ -> visit_action = + function + | Local -> fun _ -> raise Exit + | Global -> fun _ -> raise Exit ;; -let vexpr (type visit_action) : ('a, 'result, visit_action) context -> 'a -> visit_action - = function - | Local -> fun _ -> raise Exit - | Global -> fun _ -> raise Exit +let vexpr (type visit_action) : ('a, 'result, visit_action) context -> 'a -> visit_action = + function + | Local -> fun _ -> raise Exit + | Global -> fun _ -> raise Exit ;; let vexpr (type result) (type visit_action) : (unit, result, visit_action) context -> unit -> visit_action - = function - | Local -> fun _ -> raise Exit - | Global -> fun _ -> raise Exit + = + function + | Local -> fun _ -> raise Exit + | Global -> fun _ -> raise Exit ;; module A = struct @@ -3071,7 +3076,7 @@ let magic : 'a 'b. 'a -> 'b = type (_, +_) eq = Refl : ('a, 'a) eq let magic : 'a 'b. 'a -> 'b = - fun (type a b) (x : a) -> + fun (type a) (type b) (x : a) -> let bad_proof (type a) = (Refl : (< m : a >, < m : a >) eq :> (< m : a >, < >) eq) in let downcast : type a. (a, < >) eq -> < > -> a = fun (type a) (Refl : (a, < >) eq) (s : < >) -> (s :> a) @@ -4307,11 +4312,15 @@ let int_of_sexp _ = 42 let t_of_sexp : 'a. (sexp -> 'a) -> sexp -> 'a t = let _tp_loc = "core_array.ml.t" in - fun _of_a t -> (array_of_sexp _of_a) t + fun _of_a -> fun t -> (array_of_sexp _of_a) t ;; let _ = t_of_sexp -let sexp_of_t : 'a. ('a -> sexp) -> 'a t -> sexp = fun _of_a v -> (sexp_of_array _of_a) v + +let sexp_of_t : 'a. ('a -> sexp) -> 'a t -> sexp = + fun _of_a -> fun v -> (sexp_of_array _of_a) v +;; + let _ = sexp_of_t module T = struct @@ -4358,13 +4367,13 @@ end = struct let t_of_sexp : 'a 'perms. (sexp -> 'a) -> (sexp -> 'perms) -> sexp -> ('a, 'perms) t = let _tp_loc = "core_array.ml.Permissioned.t" in - fun _of_a _of_perms t -> (array_of_sexp _of_a) t + fun _of_a -> fun _of_perms -> fun t -> (array_of_sexp _of_a) t ;; let _ = t_of_sexp let sexp_of_t : 'a 'perms. ('a -> sexp) -> ('perms -> sexp) -> ('a, 'perms) t -> sexp = - fun _of_a _of_perms v -> (sexp_of_array _of_a) v + fun _of_a -> fun _of_perms -> fun v -> (sexp_of_array _of_a) v ;; let _ = sexp_of_t @@ -4378,13 +4387,13 @@ end = struct let t_of_sexp : 'perms. (sexp -> 'perms) -> sexp -> 'perms t = let _tp_loc = "core_array.ml.Permissioned.Int.t" in - fun _of_perms t -> t__of_sexp t + fun _of_perms -> fun t -> t__of_sexp t ;; let _ = t_of_sexp let sexp_of_t : 'perms. ('perms -> sexp) -> 'perms t -> sexp = - fun _of_perms v -> sexp_of_t_ v + fun _of_perms -> fun v -> sexp_of_t_ v ;; let _ = sexp_of_t @@ -4903,7 +4912,10 @@ type t = F(M).t module Common0 = struct type msg = Msg - let handle_msg = ref (function _ -> failwith "Unable to handle message") + let handle_msg = + ref (function + | _ -> failwith "Unable to handle message") + ;; let extend_handle f = let old = !handle_msg in @@ -4920,7 +4932,10 @@ let q' : Common0.msg Queue.t = Common0.q module Common = struct type msg = .. - let handle_msg = ref (function _ -> failwith "Unable to handle message") + let handle_msg = + ref (function + | _ -> failwith "Unable to handle message") + ;; let extend_handle f = let old = !handle_msg in @@ -6767,7 +6782,7 @@ end = M1 ;; -fun (x : M1.t) : M2.t -> x +fun (x : M1.t) -> (x : M2.t) (* fails *) @@ -8643,9 +8658,10 @@ type v = let f : type a b c d e f g. a t * b t * c t * d t * e t * f t * g t * v * (a, b, c, d) u * (e, f, g, g) u -> int - = function - | A, A, A, A, A, A, A, _, U, U -> 1 - | _, _, _, _, _, _, _, G, _, _ -> 1 + = + function + | A, A, A, A, A, A, A, _, U, U -> 1 + | _, _, _, _, _, _, _, G, _, _ -> 1 ;; (*| _ -> _ *) @@ -9453,8 +9469,8 @@ class ['a] c () = let f : type a'. a' = assert false let foo : type a' b'. a' -> b' = fun a -> assert false -let foo : type t'. t' = fun (type t') : t' -> assert false -let foo : 't. 't = fun (type t) : t -> assert false +let foo : type t'. t' = fun (type t') -> (assert false : t') +let foo : 't. 't = fun (type t) -> (assert false : t) let foo : type a' b' c' t. a' -> b' -> c' -> t = fun a b c -> assert false let f x = @@ -9798,8 +9814,9 @@ let _ = match x with | _ when f - ~f:(function [@ocaml.warning - (* ....................................... *) "-4"] _ -> .) -> y + ~f: + (function [@ocaml.warning (* ....................................... *) "-4"] + | _ -> .) -> y ;; let[@a @@ -9814,20 +9831,23 @@ let[@a with | _ when f - ~f:(function[@ocaml.warning (* ....................................... *) "-4"] - | _ -> .) - ~f:(function[@ocaml.warning - (* ....................................... *) - (* ....................................... *) - "foooooooooooooooooooooooooooo \ - fooooooooooooooooooooooooooooooooooooo"] - | _ -> .) - ~f:(function[@ocaml.warning - (* ....................................... *) - let x = a - and y = b in - x + y] - | _ -> .) -> + ~f: + (function [@ocaml.warning (* ....................................... *) "-4"] + | _ -> .) + ~f: + (function [@ocaml.warning + (* ....................................... *) + (* ....................................... *) + "foooooooooooooooooooooooooooo \ + fooooooooooooooooooooooooooooooooooooo"] + | _ -> .) + ~f: + (function [@ocaml.warning + (* ....................................... *) + let x = a + and y = b in + x + y] + | _ -> .) -> y [@attr (* ... *) @@ -9948,8 +9968,8 @@ let _ = let _ = aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa ~bbbbbbbbbbbbbbbbbbbbbbbbbbbb: - (fun - (_ : (ccccccccccccc * ddddddddddddddddddddddddddddd) eeee) -> FFFFFFFFF gg) + (fun (_ : (ccccccccccccc * ddddddddddddddddddddddddddddd) eeee) + -> FFFFFFFFF gg) ~h ;; @@ -10045,7 +10065,11 @@ let _ = fooooooooooo ;; -let _ = foo |> List.map (function A -> do_something ()) +let _ = + foo + |> List.map (function + | A -> do_something ()) +;; let _ = foo @@ -10188,7 +10212,7 @@ let _ = Foooooooooooooooooooo.foooooooooooooooooooo foooooooooooooooooooo foooooooooooooooooooo - (fun x -> function + (fun x ->function | Foooooooooooooooooooo -> foooooooooooooooooooo | Foooooooooooooooooooo -> foooooooooooooooooooo) ;; @@ -10197,7 +10221,7 @@ let _ = Foooooooooooooooooooo.foooooooooooooooooooo foooooooooooooooooooo foooooooooooooooooooo - ~x:(fun x -> function + ~x:(fun x ->function | Foooooooooooooooooooo -> foooooooooooooooooooo | Foooooooooooooooooooo -> foooooooooooooooooooo) ;; @@ -10224,13 +10248,14 @@ let _ = let _ = let x = x in - fun foooooooooooooooooo + fun foooooooooooooooooo foooooooooooooooooo foooooooooooooooooo foooooooooooooooooo - foooooooooooooooooo -> - () + foooooooooooooooooo + foooooooooooooooooo + -> () ;; module type For_let_syntax_local = @@ -10284,10 +10309,11 @@ module M = let _ = Some - (fun fooooooooooooooooooooooooooooooo + (fun + fooooooooooooooooooooooooooooooo + fooooooooooooooooooooooooooooooo fooooooooooooooooooooooooooooooo - fooooooooooooooooooooooooooooooo -> - foo) + -> foo) ;; type t = @@ -10372,8 +10398,8 @@ let () = match () with | _ -> (fun _ : _ -> - match () with - | _ -> ()) + (match () with + | _ -> ())) | _ -> () ;; @@ -10445,7 +10471,8 @@ let _ = let _ = fooooooooooooooooooooooooooooooo - |> foooooooooooooooooooooooooooo ~fooooooooooooooooooooooooooooooo (function foo -> bar) + |> foooooooooooooooooooooooooooo ~fooooooooooooooooooooooooooooooo (function + | foo -> bar) ;; let _ = diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index bdafdd9859..aa0de5ae03 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -403,9 +403,9 @@ type _ foo += A : int -> int foo | B : int foo let get_num : type a. a foo -> a -> a option = fun f i1 -> - match f with - | A i2 -> Some (i1 + i2) - | _ -> None + match f with + | A i2 -> Some (i1 + i2) + | _ -> None ;; (* Extensions must obey constraints *) @@ -933,8 +933,8 @@ let id x = x let idb1 = (fun id -> - let _ = id true in - id) + let _ = id true in + id) id ;; @@ -975,12 +975,12 @@ type variant = let rec variantize : type t. t ty -> t -> variant = fun ty x -> - (* type t is abstract here *) - match ty with - | Int -> VInt x (* in this branch: t = int *) - | String -> VString x (* t = string *) - | List ty1 -> VList (List.map (variantize ty1) x) (* t = 'a list for some 'a *) - | Pair (ty1, ty2) -> VPair (variantize ty1 (fst x), variantize ty2 (snd x)) + (* type t is abstract here *) + match ty with + | Int -> VInt x (* in this branch: t = int *) + | String -> VString x (* t = string *) + | List ty1 -> VList (List.map (variantize ty1) x) (* t = 'a list for some 'a *) + | Pair (ty1, ty2) -> VPair (variantize ty1 (fst x), variantize ty2 (snd x)) ;; (* t = ('a, 'b) for some 'a and 'b *) @@ -989,12 +989,12 @@ exception VariantMismatch let rec devariantize : type t. t ty -> variant -> t = fun ty v -> - match ty, v with - | Int, VInt x -> x - | String, VString x -> x - | List ty1, VList vl -> List.map (devariantize ty1) vl - | Pair (ty1, ty2), VPair (x1, x2) -> devariantize ty1 x1, devariantize ty2 x2 - | _ -> raise VariantMismatch + match ty, v with + | Int, VInt x -> x + | String, VString x -> x + | List ty1, VList vl -> List.map (devariantize ty1) vl + | Pair (ty1, ty2), VPair (x1, x2) -> devariantize ty1 x1, devariantize ty2 x2 + | _ -> raise VariantMismatch ;; (* Handling records *) @@ -1030,19 +1030,20 @@ type variant = let rec variantize : type t. t ty -> t -> variant = fun ty x -> - (* type t is abstract here *) - match ty with - | Int -> VInt x (* in this branch: t = int *) - | String -> VString x (* t = string *) - | List ty1 -> VList (List.map (variantize ty1) x) (* t = 'a list for some 'a *) - | Pair (ty1, ty2) -> - VPair (variantize ty1 (fst x), variantize ty2 (snd x)) - (* t = ('a, 'b) for some 'a and 'b *) - | Record { fields } -> - VRecord - (List.map - (fun (Field { field_type; label; get }) -> label, variantize field_type (get x)) - fields) + (* type t is abstract here *) + match ty with + | Int -> VInt x (* in this branch: t = int *) + | String -> VString x (* t = string *) + | List ty1 -> VList (List.map (variantize ty1) x) (* t = 'a list for some 'a *) + | Pair (ty1, ty2) -> + VPair (variantize ty1 (fst x), variantize ty2 (snd x)) + (* t = ('a, 'b) for some 'a and 'b *) + | Record { fields } -> + VRecord + (List.map + (fun (Field { field_type; label; get }) -> + label, variantize field_type (get x)) + fields) ;; (* Extraction *) @@ -1072,22 +1073,22 @@ and ('a, 'builder, 'b) field_ = let rec devariantize : type t. t ty -> variant -> t = fun ty v -> - match ty, v with - | Int, VInt x -> x - | String, VString x -> x - | List ty1, VList vl -> List.map (devariantize ty1) vl - | Pair (ty1, ty2), VPair (x1, x2) -> devariantize ty1 x1, devariantize ty2 x2 - | Record { fields; create_builder; of_builder }, VRecord fl -> - if List.length fields <> List.length fl then raise VariantMismatch; - let builder = create_builder () in - List.iter2 - (fun (Field { label; field_type; set }) (lab, v) -> - if label <> lab then raise VariantMismatch; - set builder (devariantize field_type v)) - fields - fl; - of_builder builder - | _ -> raise VariantMismatch + match ty, v with + | Int, VInt x -> x + | String, VString x -> x + | List ty1, VList vl -> List.map (devariantize ty1) vl + | Pair (ty1, ty2), VPair (x1, x2) -> devariantize ty1 x1, devariantize ty2 x2 + | Record { fields; create_builder; of_builder }, VRecord fl -> + if List.length fields <> List.length fl then raise VariantMismatch; + let builder = create_builder () in + List.iter2 + (fun (Field { label; field_type; set }) (lab, v) -> + if label <> lab then raise VariantMismatch; + set builder (devariantize field_type v)) + fields + fl; + of_builder builder + | _ -> raise VariantMismatch ;; type my_record = @@ -1170,13 +1171,13 @@ type (_, _) eq = Eq : ('a, 'a) eq let rec eq_sel : type a b c. (a, b) ty_sel -> (a, c) ty_sel -> (b, c) eq option = fun s1 s2 -> - match s1, s2 with - | Thd, Thd -> Some Eq - | Ttl s1, Ttl s2 -> - (match eq_sel s1 s2 with - | None -> None - | Some Eq -> Some Eq) - | _ -> None + match s1, s2 with + | Thd, Thd -> Some Eq + | Ttl s1, Ttl s2 -> + (match eq_sel s1 s2 with + | None -> None + | Some Eq -> Some Eq) + | _ -> None ;; (* Auxiliary function to get the type of a case from its selector *) @@ -1185,16 +1186,16 @@ let rec get_case (b, a) ty_sel -> (string * (e, b) ty_case) list -> string * (a, e) ty option = fun sel cases -> - match cases with - | (name, TCnoarg sel') :: rem -> - (match eq_sel sel sel' with - | None -> get_case sel rem - | Some Eq -> name, None) - | (name, TCarg (sel', ty)) :: rem -> - (match eq_sel sel sel' with - | None -> get_case sel rem - | Some Eq -> name, Some ty) - | [] -> raise Not_found + match cases with + | (name, TCnoarg sel') :: rem -> + (match eq_sel sel sel' with + | None -> get_case sel rem + | Some Eq -> name, None) + | (name, TCarg (sel', ty)) :: rem -> + (match eq_sel sel sel' with + | None -> get_case sel rem + | Some Eq -> name, Some ty) + | [] -> raise Not_found ;; (* Untyped representation of values *) @@ -1214,54 +1215,54 @@ let may_map f = function let rec variantize : type a e. e ty_env -> (a, e) ty -> a -> variant = fun e ty v -> - match ty with - | Int -> VInt v - | String -> VString v - | List t -> VList (List.map (variantize e t) v) - | Option t -> VOption (may_map (variantize e t) v) - | Pair (t1, t2) -> VPair (variantize e t1 (fst v), variantize e t2 (snd v)) - | Rec t -> variantize (Econs (ty, e)) t v - | Pop t -> - (match e with - | Econs (_, e') -> variantize e' t v) - | Var -> - (match e with - | Econs (t, e') -> variantize e' t v) - | Conv (s, proj, inj, t) -> VConv (s, variantize e t (proj v)) - | Sum ops -> - let tag, arg = ops.sum_proj v in - VSum - ( tag - , may_map - (function - | Tdyn (ty, arg) -> variantize e ty arg) - arg ) + match ty with + | Int -> VInt v + | String -> VString v + | List t -> VList (List.map (variantize e t) v) + | Option t -> VOption (may_map (variantize e t) v) + | Pair (t1, t2) -> VPair (variantize e t1 (fst v), variantize e t2 (snd v)) + | Rec t -> variantize (Econs (ty, e)) t v + | Pop t -> + (match e with + | Econs (_, e') -> variantize e' t v) + | Var -> + (match e with + | Econs (t, e') -> variantize e' t v) + | Conv (s, proj, inj, t) -> VConv (s, variantize e t (proj v)) + | Sum ops -> + let tag, arg = ops.sum_proj v in + VSum + ( tag + , may_map + (function + | Tdyn (ty, arg) -> variantize e ty arg) + arg ) ;; let rec devariantize : type t e. e ty_env -> (t, e) ty -> variant -> t = fun e ty v -> - match ty, v with - | Int, VInt x -> x - | String, VString x -> x - | List ty1, VList vl -> List.map (devariantize e ty1) vl - | Pair (ty1, ty2), VPair (x1, x2) -> devariantize e ty1 x1, devariantize e ty2 x2 - | Rec t, _ -> devariantize (Econs (ty, e)) t v - | Pop t, _ -> - (match e with - | Econs (_, e') -> devariantize e' t v) - | Var, _ -> - (match e with - | Econs (t, e') -> devariantize e' t v) - | Conv (s, proj, inj, t), VConv (s', v) when s = s' -> inj (devariantize e t v) - | Sum ops, VSum (tag, a) -> - (try - match List.assoc tag ops.sum_cases, a with - | TCarg (sel, t), Some a -> ops.sum_inj (sel, devariantize e t a) - | TCnoarg sel, None -> ops.sum_inj (sel, Noarg) - | _ -> raise VariantMismatch - with - | Not_found -> raise VariantMismatch) - | _ -> raise VariantMismatch + match ty, v with + | Int, VInt x -> x + | String, VString x -> x + | List ty1, VList vl -> List.map (devariantize e ty1) vl + | Pair (ty1, ty2), VPair (x1, x2) -> devariantize e ty1 x1, devariantize e ty2 x2 + | Rec t, _ -> devariantize (Econs (ty, e)) t v + | Pop t, _ -> + (match e with + | Econs (_, e') -> devariantize e' t v) + | Var, _ -> + (match e with + | Econs (t, e') -> devariantize e' t v) + | Conv (s, proj, inj, t), VConv (s', v) when s = s' -> inj (devariantize e t v) + | Sum ops, VSum (tag, a) -> + (try + match List.assoc tag ops.sum_cases, a with + | TCarg (sel, t), Some a -> ops.sum_inj (sel, devariantize e t a) + | TCnoarg sel, None -> ops.sum_inj (sel, Noarg) + | _ -> raise VariantMismatch + with + | Not_found -> raise VariantMismatch) + | _ -> raise VariantMismatch ;; (* First attempt: represent 1-constructor variants using Conv *) @@ -1293,7 +1294,8 @@ let ty_abc = and inj : type c. (int -> string -> noarg -> unit, c) ty_sel * c -> [ `A of int | `B of string | `C ] - = function + = + function | Thd, v -> `A v | Ttl Thd, v -> `B v | Ttl (Ttl Thd), Noarg -> `C @@ -1321,21 +1323,22 @@ type 'a vlist = let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t -> - let tcons = Pair (Pop t, Var) in - Rec - (Sum - { sum_proj = - (function - | `Nil -> "Nil", None - | `Cons p -> "Cons", Some (Tdyn (tcons, p))) - ; sum_cases = [ "Nil", TCnoarg Thd; "Cons", TCarg (Ttl Thd, tcons) ] - ; sum_inj = - (fun (type c) : ((noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist) -> - function - | Thd, Noarg -> `Nil - | Ttl Thd, v -> `Cons v) - (* One can also write the type annotation directly *) - }) + let tcons = Pair (Pop t, Var) in + Rec + (Sum + { sum_proj = + (function + | `Nil -> "Nil", None + | `Cons p -> "Cons", Some (Tdyn (tcons, p))) + ; sum_cases = [ "Nil", TCnoarg Thd; "Cons", TCarg (Ttl Thd, tcons) ] + ; sum_inj = + (fun (type c) -> + (function + | Thd, Noarg -> `Nil + | Ttl Thd, v -> `Cons v + : (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist)) + (* One can also write the type annotation directly *) + }) ;; let v = variantize Enil (ty_list Int) (`Cons (1, `Cons (2, `Nil))) @@ -1375,15 +1378,15 @@ let ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = (* Breaks: no way to pattern-match on a full recursive type *) let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t -> - let targ = Pair (Pop t, Var) in - Rec - (Sum - ( (function - | `Nil -> "Nil", None - | `Cons p -> "Cons", Some (Tdyn (targ, p))) - , function - | "Nil", None -> `Nil - | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p )) + let targ = Pair (Pop t, Var) in + Rec + (Sum + ( (function + | `Nil -> "Nil", None + | `Cons p -> "Cons", Some (Tdyn (targ, p))) + , function + | "Nil", None -> `Nil + | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p )) ;; (* Define Sum using object instead of record for first-class polymorphism *) @@ -1447,22 +1450,22 @@ type 'a vlist = let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t -> - let tcons = Pair (Pop t, Var) in - Rec - (Sum - (object - method proj = - function - | `Nil -> "Nil", None - | `Cons p -> "Cons", Some (Tdyn (tcons, p)) + let tcons = Pair (Pop t, Var) in + Rec + (Sum + (object + method proj = + function + | `Nil -> "Nil", None + | `Cons p -> "Cons", Some (Tdyn (tcons, p)) - method cases = [ "Nil", TCnoarg Thd; "Cons", TCarg (Ttl Thd, tcons) ] + method cases = [ "Nil", TCnoarg Thd; "Cons", TCarg (Ttl Thd, tcons) ] - method inj : type c. (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist = - function - | Thd, Noarg -> `Nil - | Ttl Thd, v -> `Cons v - end)) + method inj : type c. (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist = + function + | Thd, Noarg -> `Nil + | Ttl Thd, v -> `Cons v + end)) ;; (* @@ -1522,11 +1525,11 @@ type (_, _, _) app = App : ('a, 'p) seq * ('n, 'm, 'p) plus -> ('a, 'n, 'm) app let rec app : type a n m. (a, n) seq -> (a, m) seq -> (a, n, m) app = fun xs ys -> - match xs with - | Snil -> App (ys, PlusZ (length ys)) - | Scons (x, xs') -> - let (App (xs'', pl)) = app xs' ys in - App (Scons (x, xs''), PlusS pl) + match xs with + | Snil -> App (ys, PlusZ (length ys)) + | Scons (x, xs') -> + let (App (xs'', pl)) = app xs' ys in + App (Scons (x, xs''), PlusS pl) ;; (* 3.1 Feature: kinds *) @@ -1566,20 +1569,21 @@ let tree1 = Tfork (Tfork (Ttip, Tnode 4), Tfork (Tnode 4, Tnode 3)) let rec find : type sh. ('a -> 'a -> bool) -> 'a -> (sh, 'a) tree -> (sh, 'a) path list = fun eq n t -> - match t with - | Ttip -> [] - | Tnode m -> if eq n m then [ Phere ] else [] - | Tfork (x, y) -> - List.map (fun x -> Pleft x) (find eq n x) @ List.map (fun x -> Pright x) (find eq n y) + match t with + | Ttip -> [] + | Tnode m -> if eq n m then [ Phere ] else [] + | Tfork (x, y) -> + List.map (fun x -> Pleft x) (find eq n x) + @ List.map (fun x -> Pright x) (find eq n y) ;; let rec extract : type sh. (sh, 'a) path -> (sh, 'a) tree -> 'a = fun p t -> - match p, t with - | Pnone x, Ttip -> x - | Phere, Tnode y -> y - | Pleft p, Tfork (l, _) -> extract p l - | Pright p, Tfork (_, r) -> extract p r + match p, t with + | Pnone x, Ttip -> x + | Phere, Tnode y -> y + | Pleft p, Tfork (l, _) -> extract p l + | Pright p, Tfork (_, r) -> extract p r ;; (* 3.4 Pattern : Witness *) @@ -1604,9 +1608,9 @@ let p1 : (two, one, three) plus = PlusS (PlusS (PlusZ (NS NZ))) let rec summandLessThanSum : type a b c. (a, b, c) plus -> (a, c) le = fun p -> - match p with - | PlusZ n -> LeZ n - | PlusS p' -> LeS (summandLessThanSum p') + match p with + | PlusZ n -> LeZ n + | PlusS p' -> LeS (summandLessThanSum p') ;; (* 3.8 Pattern: Leibniz Equality *) @@ -1617,24 +1621,24 @@ let convert : type a b. (a, b) equal -> a -> b = fun Eq x -> x let rec sameNat : type a b. a nat -> b nat -> (a, b) equal option = fun a b -> - match a, b with - | NZ, NZ -> Some Eq - | NS a', NS b' -> - (match sameNat a' b' with - | Some Eq -> Some Eq - | None -> None) - | _ -> None + match a, b with + | NZ, NZ -> Some Eq + | NS a', NS b' -> + (match sameNat a' b' with + | Some Eq -> Some Eq + | None -> None) + | _ -> None ;; (* Extra: associativity of addition *) let rec plus_func : type a b m n. (a, b, m) plus -> (a, b, n) plus -> (m, n) equal = fun p1 p2 -> - match p1, p2 with - | PlusZ _, PlusZ _ -> Eq - | PlusS p1', PlusS p2' -> - let Eq = plus_func p1' p2' in - Eq + match p1, p2 with + | PlusZ _, PlusZ _ -> Eq + | PlusS p1', PlusS p2' -> + let Eq = plus_func p1' p2' in + Eq ;; let rec plus_assoc @@ -1646,14 +1650,14 @@ let rec plus_assoc -> (m, n) equal = fun p1 p2 p3 p4 -> - match p1, p4 with - | PlusZ b, PlusZ bc -> - let Eq = plus_func p2 p3 in - Eq - | PlusS p1', PlusS p4' -> - let (PlusS p2') = p2 in - let Eq = plus_assoc p1' p2' p3 p4' in - Eq + match p1, p4 with + | PlusZ b, PlusZ bc -> + let Eq = plus_func p2 p3 in + Eq + | PlusS p1', PlusS p4' -> + let (PlusS p2') = p2 in + let Eq = plus_assoc p1' p2' p3 p4' in + Eq ;; (* 3.9 Computing Programs and Properties Simultaneously *) @@ -1679,31 +1683,31 @@ type (_, _) diff = Diff : 'c nat * ('a, 'c, 'b) plus -> ('a, 'b) diff let rec diff : type a b. (a, b) le -> a nat -> b nat -> (a, b) diff = fun le a b -> - match le, a, b with - | LeZ _, _, m -> Diff (m, PlusZ m) - | LeS q, NS x, NS y -> - (match diff q x y with - | Diff (m, p) -> Diff (m, PlusS p)) + match le, a, b with + | LeZ _, _, m -> Diff (m, PlusZ m) + | LeS q, NS x, NS y -> + (match diff q x y with + | Diff (m, p) -> Diff (m, PlusS p)) ;; let rec diff : type a b. (a, b) le -> a nat -> b nat -> (a, b) diff = fun le a b -> - match a, b, le with - (* warning *) - | NZ, m, LeZ _ -> Diff (m, PlusZ m) - | NS x, NS y, LeS q -> - (match diff q x y with - | Diff (m, p) -> Diff (m, PlusS p)) - | _ -> . + match a, b, le with + (* warning *) + | NZ, m, LeZ _ -> Diff (m, PlusZ m) + | NS x, NS y, LeS q -> + (match diff q x y with + | Diff (m, p) -> Diff (m, PlusS p)) + | _ -> . ;; let rec diff : type a b. (a, b) le -> b nat -> (a, b) diff = fun le b -> - match b, le with - | m, LeZ _ -> Diff (m, PlusZ m) - | NS y, LeS q -> - (match diff q y with - | Diff (m, p) -> Diff (m, PlusS p)) + match b, le with + | m, LeZ _ -> Diff (m, PlusZ m) + | NS y, LeS q -> + (match diff q y with + | Diff (m, p) -> Diff (m, PlusS p)) ;; type (_, _) filter = Filter : ('m, 'n) le * ('a, 'm) seq -> ('a, 'n) filter @@ -1715,12 +1719,12 @@ let rec leS' : type m n. (m, n) le -> (m, n succ) le = function let rec filter : type a n. (a -> bool) -> (a, n) seq -> (a, n) filter = fun f s -> - match s with - | Snil -> Filter (LeZ NZ, Snil) - | Scons (a, l) -> - (match filter f l with - | Filter (le, l') -> - if f a then Filter (LeS le, Scons (a, l')) else Filter (leS' le, l')) + match s with + | Snil -> Filter (LeZ NZ, Snil) + | Scons (a, l) -> + (match filter f l with + | Filter (le, l') -> + if f a then Filter (LeS le, Scons (a, l')) else Filter (leS' le, l')) ;; (* 4.1 AVL trees *) @@ -1740,65 +1744,65 @@ let empty = Avl Leaf let rec elem : type h. int -> h avl -> bool = fun x t -> - match t with - | Leaf -> false - | Node (_, l, y, r) -> x = y || if x < y then elem x l else elem x r + match t with + | Leaf -> false + | Node (_, l, y, r) -> x = y || if x < y then elem x l else elem x r ;; let rec rotr : type n. n succ succ avl -> int -> n avl -> (n succ succ avl, n succ succ succ avl) sum = fun tL y tR -> - match tL with - | Node (Same, a, x, b) -> Inr (Node (Less, a, x, Node (More, b, y, tR))) - | Node (More, a, x, b) -> Inl (Node (Same, a, x, Node (Same, b, y, tR))) - | Node (Less, a, x, Node (Same, b, z, c)) -> - Inl (Node (Same, Node (Same, a, x, b), z, Node (Same, c, y, tR))) - | Node (Less, a, x, Node (Less, b, z, c)) -> - Inl (Node (Same, Node (More, a, x, b), z, Node (Same, c, y, tR))) - | Node (Less, a, x, Node (More, b, z, c)) -> - Inl (Node (Same, Node (Same, a, x, b), z, Node (Less, c, y, tR))) + match tL with + | Node (Same, a, x, b) -> Inr (Node (Less, a, x, Node (More, b, y, tR))) + | Node (More, a, x, b) -> Inl (Node (Same, a, x, Node (Same, b, y, tR))) + | Node (Less, a, x, Node (Same, b, z, c)) -> + Inl (Node (Same, Node (Same, a, x, b), z, Node (Same, c, y, tR))) + | Node (Less, a, x, Node (Less, b, z, c)) -> + Inl (Node (Same, Node (More, a, x, b), z, Node (Same, c, y, tR))) + | Node (Less, a, x, Node (More, b, z, c)) -> + Inl (Node (Same, Node (Same, a, x, b), z, Node (Less, c, y, tR))) ;; let rec rotl : type n. n avl -> int -> n succ succ avl -> (n succ succ avl, n succ succ succ avl) sum = fun tL u tR -> - match tR with - | Node (Same, a, x, b) -> Inr (Node (More, Node (Less, tL, u, a), x, b)) - | Node (Less, a, x, b) -> Inl (Node (Same, Node (Same, tL, u, a), x, b)) - | Node (More, Node (Same, a, x, b), y, c) -> - Inl (Node (Same, Node (Same, tL, u, a), x, Node (Same, b, y, c))) - | Node (More, Node (Less, a, x, b), y, c) -> - Inl (Node (Same, Node (More, tL, u, a), x, Node (Same, b, y, c))) - | Node (More, Node (More, a, x, b), y, c) -> - Inl (Node (Same, Node (Same, tL, u, a), x, Node (Less, b, y, c))) + match tR with + | Node (Same, a, x, b) -> Inr (Node (More, Node (Less, tL, u, a), x, b)) + | Node (Less, a, x, b) -> Inl (Node (Same, Node (Same, tL, u, a), x, b)) + | Node (More, Node (Same, a, x, b), y, c) -> + Inl (Node (Same, Node (Same, tL, u, a), x, Node (Same, b, y, c))) + | Node (More, Node (Less, a, x, b), y, c) -> + Inl (Node (Same, Node (More, tL, u, a), x, Node (Same, b, y, c))) + | Node (More, Node (More, a, x, b), y, c) -> + Inl (Node (Same, Node (Same, tL, u, a), x, Node (Less, b, y, c))) ;; let rec ins : type n. int -> n avl -> (n avl, n succ avl) sum = fun x t -> - match t with - | Leaf -> Inr (Node (Same, Leaf, x, Leaf)) - | Node (bal, a, y, b) -> - if x = y - then Inl t - else if x < y - then ( - match ins x a with - | Inl a -> Inl (Node (bal, a, y, b)) - | Inr a -> - (match bal with - | Less -> Inl (Node (Same, a, y, b)) - | Same -> Inr (Node (More, a, y, b)) - | More -> rotr a y b)) - else ( - match ins x b with - | Inl b -> Inl (Node (bal, a, y, b) : n avl) - | Inr b -> - (match bal with - | More -> Inl (Node (Same, a, y, b) : n avl) - | Same -> Inr (Node (Less, a, y, b) : n succ avl) - | Less -> rotl a y b)) + match t with + | Leaf -> Inr (Node (Same, Leaf, x, Leaf)) + | Node (bal, a, y, b) -> + if x = y + then Inl t + else if x < y + then ( + match ins x a with + | Inl a -> Inl (Node (bal, a, y, b)) + | Inr a -> + (match bal with + | Less -> Inl (Node (Same, a, y, b)) + | Same -> Inr (Node (More, a, y, b)) + | More -> rotr a y b)) + else ( + match ins x b with + | Inl b -> Inl (Node (bal, a, y, b) : n avl) + | Inr b -> + (match bal with + | More -> Inl (Node (Same, a, y, b) : n avl) + | Same -> Inr (Node (Less, a, y, b) : n succ avl) + | Less -> rotl a y b)) ;; let insert x (Avl t) = @@ -1827,48 +1831,48 @@ type _ avl_del = let rec del : type n. int -> n avl -> n avl_del = fun y t -> - match t with - | Leaf -> Dsame Leaf - | Node (bal, l, x, r) -> - if x = y - then ( - match r with - | Leaf -> - (match bal with - | Same -> Ddecr (Eq, l) - | More -> Ddecr (Eq, l)) - | Node _ -> - (match bal, del_min r with - | _, (z, Inr r) -> Dsame (Node (bal, l, z, r)) - | Same, (z, Inl r) -> Dsame (Node (More, l, z, r)) - | Less, (z, Inl r) -> Ddecr (Eq, Node (Same, l, z, r)) - | More, (z, Inl r) -> - (match rotr l z r with - | Inl t -> Ddecr (Eq, t) - | Inr t -> Dsame t))) - else if y < x - then ( - match del y l with - | Dsame l -> Dsame (Node (bal, l, x, r)) - | Ddecr (Eq, l) -> - (match bal with - | Same -> Dsame (Node (Less, l, x, r)) - | More -> Ddecr (Eq, Node (Same, l, x, r)) - | Less -> - (match rotl l x r with - | Inl t -> Ddecr (Eq, t) - | Inr t -> Dsame t))) - else ( - match del y r with - | Dsame r -> Dsame (Node (bal, l, x, r)) - | Ddecr (Eq, r) -> - (match bal with - | Same -> Dsame (Node (More, l, x, r)) - | Less -> Ddecr (Eq, Node (Same, l, x, r)) - | More -> - (match rotr l x r with - | Inl t -> Ddecr (Eq, t) - | Inr t -> Dsame t))) + match t with + | Leaf -> Dsame Leaf + | Node (bal, l, x, r) -> + if x = y + then ( + match r with + | Leaf -> + (match bal with + | Same -> Ddecr (Eq, l) + | More -> Ddecr (Eq, l)) + | Node _ -> + (match bal, del_min r with + | _, (z, Inr r) -> Dsame (Node (bal, l, z, r)) + | Same, (z, Inl r) -> Dsame (Node (More, l, z, r)) + | Less, (z, Inl r) -> Ddecr (Eq, Node (Same, l, z, r)) + | More, (z, Inl r) -> + (match rotr l z r with + | Inl t -> Ddecr (Eq, t) + | Inr t -> Dsame t))) + else if y < x + then ( + match del y l with + | Dsame l -> Dsame (Node (bal, l, x, r)) + | Ddecr (Eq, l) -> + (match bal with + | Same -> Dsame (Node (Less, l, x, r)) + | More -> Ddecr (Eq, Node (Same, l, x, r)) + | Less -> + (match rotl l x r with + | Inl t -> Ddecr (Eq, t) + | Inr t -> Dsame t))) + else ( + match del y r with + | Dsame r -> Dsame (Node (bal, l, x, r)) + | Ddecr (Eq, r) -> + (match bal with + | Same -> Dsame (Node (More, l, x, r)) + | Less -> Ddecr (Eq, Node (Same, l, x, r)) + | More -> + (match rotr l x r with + | Inl t -> Ddecr (Eq, t) + | Inr t -> Dsame t))) ;; let delete x (Avl t) = @@ -1914,12 +1918,12 @@ let color : type c n. (c, n) sub_tree -> c crep = function let rec fill : type c n. (c, n) ctxt -> (c, n) sub_tree -> rb_tree = fun ct t -> - match ct with - | CNil -> Root t - | CRed (e, LeftD, uncle, c) -> fill c (Rnode (uncle, e, t)) - | CRed (e, RightD, uncle, c) -> fill c (Rnode (t, e, uncle)) - | CBlk (e, LeftD, uncle, c) -> fill c (Bnode (uncle, e, t)) - | CBlk (e, RightD, uncle, c) -> fill c (Bnode (t, e, uncle)) + match ct with + | CNil -> Root t + | CRed (e, LeftD, uncle, c) -> fill c (Rnode (uncle, e, t)) + | CRed (e, RightD, uncle, c) -> fill c (Rnode (t, e, uncle)) + | CBlk (e, LeftD, uncle, c) -> fill c (Bnode (uncle, e, t)) + | CBlk (e, RightD, uncle, c) -> fill c (Bnode (t, e, uncle)) ;; let recolor d1 pE sib d2 gE uncle t = @@ -1940,28 +1944,28 @@ let rotate d1 pE sib d2 gE uncle (Rnode (x, e, y)) = let rec repair : type c n. (red, n) sub_tree -> (c, n) ctxt -> rb_tree = fun t ct -> - match ct with - | CNil -> Root (blacken t) - | CBlk (e, LeftD, sib, c) -> fill c (Bnode (sib, e, t)) - | CBlk (e, RightD, sib, c) -> fill c (Bnode (t, e, sib)) - | CRed (e, dir, sib, CBlk (e', dir', uncle, ct)) -> - (match color uncle with - | Red -> repair (recolor dir e sib dir' e' (blacken uncle) t) ct - | Black -> fill ct (rotate dir e sib dir' e' uncle t)) + match ct with + | CNil -> Root (blacken t) + | CBlk (e, LeftD, sib, c) -> fill c (Bnode (sib, e, t)) + | CBlk (e, RightD, sib, c) -> fill c (Bnode (t, e, sib)) + | CRed (e, dir, sib, CBlk (e', dir', uncle, ct)) -> + (match color uncle with + | Red -> repair (recolor dir e sib dir' e' (blacken uncle) t) ct + | Black -> fill ct (rotate dir e sib dir' e' uncle t)) ;; let rec ins : type c n. int -> (c, n) sub_tree -> (c, n) ctxt -> rb_tree = fun e t ct -> - match t with - | Rnode (l, e', r) -> - if e < e' - then ins e l (CRed (e', RightD, r, ct)) - else ins e r (CRed (e', LeftD, l, ct)) - | Bnode (l, e', r) -> - if e < e' - then ins e l (CBlk (e', RightD, r, ct)) - else ins e r (CBlk (e', LeftD, l, ct)) - | Bleaf -> repair (Rnode (Bleaf, e, Bleaf)) ct + match t with + | Rnode (l, e', r) -> + if e < e' + then ins e l (CRed (e', RightD, r, ct)) + else ins e r (CRed (e', LeftD, l, ct)) + | Bnode (l, e', r) -> + if e < e' + then ins e l (CBlk (e', RightD, r, ct)) + else ins e r (CBlk (e', LeftD, l, ct)) + | Bleaf -> repair (Rnode (Bleaf, e, Bleaf)) ct ;; let insert e (Root t) = ins e t CNil @@ -1996,38 +2000,38 @@ type (_, _) equal = Eq : ('a, 'a) equal let rec rep_equal : type a b. a rep -> b rep -> (a, b) equal option = fun ra rb -> - match ra, rb with - | Rint, Rint -> Some Eq - | Rbool, Rbool -> Some Eq - | Rpair (a1, a2), Rpair (b1, b2) -> - (match rep_equal a1 b1 with - | None -> None - | Some Eq -> - (match rep_equal a2 b2 with - | None -> None - | Some Eq -> Some Eq)) - | Rfun (a1, a2), Rfun (b1, b2) -> - (match rep_equal a1 b1 with - | None -> None - | Some Eq -> - (match rep_equal a2 b2 with - | None -> None - | Some Eq -> Some Eq)) - | _ -> None + match ra, rb with + | Rint, Rint -> Some Eq + | Rbool, Rbool -> Some Eq + | Rpair (a1, a2), Rpair (b1, b2) -> + (match rep_equal a1 b1 with + | None -> None + | Some Eq -> + (match rep_equal a2 b2 with + | None -> None + | Some Eq -> Some Eq)) + | Rfun (a1, a2), Rfun (b1, b2) -> + (match rep_equal a1 b1 with + | None -> None + | Some Eq -> + (match rep_equal a2 b2 with + | None -> None + | Some Eq -> Some Eq)) + | _ -> None ;; type assoc = Assoc : string * 'a rep * 'a -> assoc let rec assoc : type a. string -> a rep -> assoc list -> a = - fun x r -> function - | [] -> raise Not_found - | Assoc (x', r', v) :: env -> - if x = x' - then ( - match rep_equal r r' with - | None -> failwith ("Wrong type for " ^ x) - | Some Eq -> v) - else assoc x r env + fun x r ->function + | [] -> raise Not_found + | Assoc (x', r', v) :: env -> + if x = x' + then ( + match rep_equal r r' with + | None -> failwith ("Wrong type for " ^ x) + | Some Eq -> v) + else assoc x r env ;; type _ term = @@ -2040,14 +2044,14 @@ type _ term = | Pair : 'a term * 'b term -> ('a * 'b) term let rec eval_term : type a. assoc list -> a term -> a = - fun env -> function - | Var (x, r) -> assoc x r env - | Abs (x, r, e) -> fun v -> eval_term (Assoc (x, r, v) :: env) e - | Const x -> x - | Add -> fun (x, y) -> x + y - | LT -> fun (x, y) -> x < y - | Ap (f, x) -> eval_term env f (eval_term env x) - | Pair (x, y) -> eval_term env x, eval_term env y + fun env ->function + | Var (x, r) -> assoc x r env + | Abs (x, r, e) -> fun v -> eval_term (Assoc (x, r, v) :: env) e + | Const x -> x + | Add -> fun (x, y) -> x + y + | LT -> fun (x, y) -> x < y + | Ap (f, x) -> eval_term env f (eval_term env x) + | Pair (x, y) -> eval_term env x, eval_term env y ;; let ex3 = Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint)))) @@ -2082,12 +2086,12 @@ type _ env = let rec eval_lam : type e t. e env -> (e, t) lam -> t = fun env m -> - match env, m with - | _, Const n -> n - | Econs (_, v, r), Var _ -> v - | Econs (_, _, r), Shift e -> eval_lam r e - | _, Abs (n, body) -> fun x -> eval_lam (Econs (n, x, env)) body - | _, App (f, x) -> eval_lam env f (eval_lam env x) + match env, m with + | _, Const n -> n + | Econs (_, v, r), Var _ -> v + | Econs (_, _, r), Shift e -> eval_lam r e + | _, Abs (n, body) -> fun x -> eval_lam (Econs (n, x, env)) body + | _, App (f, x) -> eval_lam env f (eval_lam env x) ;; type add = Add @@ -2115,17 +2119,17 @@ type _ rep = let rec compare : type a b. a rep -> b rep -> (string, (a, b) equal) sum = fun a b -> - match a, b with - | I, I -> Inr Eq - | Ar (x, y), Ar (s, t) -> - (match compare x s with - | Inl _ as e -> e - | Inr Eq -> - (match compare y t with - | Inl _ as e -> e - | Inr Eq as e -> e)) - | I, Ar _ -> Inl "I <> Ar _" - | Ar _, I -> Inl "Ar _ <> I" + match a, b with + | I, I -> Inr Eq + | Ar (x, y), Ar (s, t) -> + (match compare x s with + | Inl _ as e -> e + | Inr Eq -> + (match compare y t with + | Inl _ as e -> e + | Inr Eq as e -> e)) + | I, Ar _ -> Inl "I <> Ar _" + | Ar _, I -> Inl "Ar _ <> I" ;; type term = @@ -2144,39 +2148,39 @@ type _ checked = let rec lookup : type e. string -> e ctx -> e checked = fun name ctx -> - match ctx with - | Cnil -> Cerror ("Name not found: " ^ name) - | Ccons (l, s, t, rs) -> - if s = name - then Cok (Var l, t) - else ( - match lookup name rs with - | Cerror m -> Cerror m - | Cok (v, t) -> Cok (Shift v, t)) + match ctx with + | Cnil -> Cerror ("Name not found: " ^ name) + | Ccons (l, s, t, rs) -> + if s = name + then Cok (Var l, t) + else ( + match lookup name rs with + | Cerror m -> Cerror m + | Cok (v, t) -> Cok (Shift v, t)) ;; let rec tc : type n e. n nat -> e ctx -> term -> e checked = fun n ctx t -> - match t with - | V s -> lookup s ctx - | Ap (f, x) -> - (match tc n ctx f with - | Cerror _ as e -> e - | Cok (f', ft) -> - (match tc n ctx x with - | Cerror _ as e -> e - | Cok (x', xt) -> - (match ft with - | Ar (a, b) -> - (match compare a xt with - | Inl s -> Cerror s - | Inr Eq -> Cok (App (f', x'), b)) - | _ -> Cerror "Non fun in Ap"))) - | Ab (s, t, body) -> - (match tc (NS n) (Ccons (n, s, t, ctx)) body with - | Cerror _ as e -> e - | Cok (body', et) -> Cok (Abs (n, body'), Ar (t, et))) - | C m -> Cok (Const m, I) + match t with + | V s -> lookup s ctx + | Ap (f, x) -> + (match tc n ctx f with + | Cerror _ as e -> e + | Cok (f', ft) -> + (match tc n ctx x with + | Cerror _ as e -> e + | Cok (x', xt) -> + (match ft with + | Ar (a, b) -> + (match compare a xt with + | Inl s -> Cerror s + | Inr Eq -> Cok (App (f', x'), b)) + | _ -> Cerror "Non fun in Ap"))) + | Ab (s, t, body) -> + (match tc (NS n) (Ccons (n, s, t, ctx)) body with + | Cerror _ as e -> e + | Cok (body', et) -> Cok (Abs (n, body'), Ar (t, et))) + | C m -> Cok (Const m, I) ;; let ctx0 = @@ -2239,21 +2243,21 @@ type (_, _) lam' = Ex : ('m, 's, 't) lam -> ('s, 't) lam' let rec subst : type m1 r t s. (m1, r, t) lam -> (r, s) sub -> (s, t) lam' = fun t s -> - match t, s with - | _, Id -> Ex t - | Const (r, c), sub -> Ex (Const (r, c)) - | Var v, Bind (x, e, r) -> Ex e - | Var v, Push sub -> Ex (Var v) - | Shift e, Bind (_, _, r) -> subst e r - | Shift e, Push sub -> - (match subst e sub with - | Ex a -> Ex (Shift a)) - | App (f, x), sub -> - (match subst f sub, subst x sub with - | Ex g, Ex y -> Ex (App (g, y))) - | Lam (v, x), sub -> - (match subst x (Push sub) with - | Ex body -> Ex (Lam (v, body))) + match t, s with + | _, Id -> Ex t + | Const (r, c), sub -> Ex (Const (r, c)) + | Var v, Bind (x, e, r) -> Ex e + | Var v, Push sub -> Ex (Var v) + | Shift e, Bind (_, _, r) -> subst e r + | Shift e, Push sub -> + (match subst e sub with + | Ex a -> Ex (Shift a)) + | App (f, x), sub -> + (match subst f sub, subst x sub with + | Ex g, Ex y -> Ex (App (g, y))) + | Lam (v, x), sub -> + (match subst x (Push sub) with + | Ex body -> Ex (Lam (v, body))) ;; type closed = rnil @@ -2263,14 +2267,14 @@ let rec rule : type a b. (pval, closed, (a, b) tarr) lam -> (pval, closed, a) lam -> b rlam = fun v1 v2 -> - match v1, v2 with - | Lam (x, body), v -> - (match subst body (Bind (x, v, Id)) with - | Ex term -> - (match mode term with - | Pexp -> Inl term - | Pval -> Inr term)) - | Const (IntTo b, f), Const (IntR, x) -> Inr (Const (b, f x)) + match v1, v2 with + | Lam (x, body), v -> + (match subst body (Bind (x, v, Id)) with + | Ex term -> + (match mode term with + | Pexp -> Inl term + | Pval -> Inr term)) + | Const (IntTo b, f), Const (IntR, x) -> Inr (Const (b, f x)) ;; let rec onestep : type m t. (m, closed, t) lam -> t rlam = function @@ -2300,11 +2304,11 @@ type ('env, 'a) typ = let f : type env a. (env, a) typ -> (env, a) typ -> int = fun ta tb -> - match ta, tb with - | Tint, Tint -> 0 - | Tbool, Tbool -> 1 - | Tvar var, tb -> 2 - | _ -> . (* error *) + match ta, tb with + | Tint, Tint -> 0 + | Tbool, Tbool -> 1 + | Tvar var, tb -> 2 + | _ -> . (* error *) ;; (* let x = f Tint (Tvar Zero) ;; *) @@ -2358,14 +2362,14 @@ type _ linkp = let inlineseq_from_astseq seq = let rec process : type a. a linkp -> ast_t -> a inline_t = fun allow_link ast -> - match allow_link, ast with - | Maylink, Ast_Text txt -> Text txt - | Nonlink, Ast_Text txt -> Text txt - | x, Ast_Bold xs -> Bold (List.map (process x) xs) - | Maylink, Ast_Link lnk -> Link lnk - | Nonlink, Ast_Link _ -> assert false - | Maylink, Ast_Mref (lnk, xs) -> Mref (lnk, List.map (process Nonlink) xs) - | Nonlink, Ast_Mref _ -> assert false + match allow_link, ast with + | Maylink, Ast_Text txt -> Text txt + | Nonlink, Ast_Text txt -> Text txt + | x, Ast_Bold xs -> Bold (List.map (process x) xs) + | Maylink, Ast_Link lnk -> Link lnk + | Nonlink, Ast_Link _ -> assert false + | Maylink, Ast_Mref (lnk, xs) -> Mref (lnk, List.map (process Nonlink) xs) + | Nonlink, Ast_Mref _ -> assert false in List.map (process Maylink) seq ;; @@ -2376,13 +2380,14 @@ type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2 let inlineseq_from_astseq seq = let rec process : type a. a linkp2 -> ast_t -> a inline_t = fun allow_link ast -> - match allow_link, ast with - | Kind _, Ast_Text txt -> Text txt - | x, Ast_Bold xs -> Bold (List.map (process x) xs) - | Kind Maylink, Ast_Link lnk -> Link lnk - | Kind Nonlink, Ast_Link _ -> assert false - | Kind Maylink, Ast_Mref (lnk, xs) -> Mref (lnk, List.map (process (Kind Nonlink)) xs) - | Kind Nonlink, Ast_Mref _ -> assert false + match allow_link, ast with + | Kind _, Ast_Text txt -> Text txt + | x, Ast_Bold xs -> Bold (List.map (process x) xs) + | Kind Maylink, Ast_Link lnk -> Link lnk + | Kind Nonlink, Ast_Link _ -> assert false + | Kind Maylink, Ast_Mref (lnk, xs) -> + Mref (lnk, List.map (process (Kind Nonlink)) xs) + | Kind Nonlink, Ast_Mref _ -> assert false in List.map (process (Kind Maylink)) seq ;; @@ -2413,8 +2418,8 @@ end let of_type : type a. a -> a = fun x -> - match B.f x 4 with - | Eq -> 5 + match B.f x 4 with + | Eq -> 5 ;; type _ constant = @@ -2432,8 +2437,7 @@ let eval (type c) (bop : (a, b, c) binop) (x : a constant) - (y : b constant) - : c constant + (y : b constant) : c constant = match bop, x, y with | Eq, Bool x, Bool y -> Bool (if x then y else not y) @@ -2472,9 +2476,9 @@ type _ wrapPoly = WrapPoly : 'a poly -> ([< `TagA of int | `TagB ] as 'a) wrapPo let example6 : type a. a wrapPoly -> a -> int = fun w -> - match w with - | WrapPoly ATag -> intA - | WrapPoly _ -> intA (* This should not be allowed *) + match w with + | WrapPoly ATag -> intA + | WrapPoly _ -> intA (* This should not be allowed *) ;; let _ = example6 (WrapPoly AandBTags) `TagB (* This causes a seg fault *) @@ -2489,8 +2493,8 @@ struct let f : int S.t ab -> float S.t ab -> string = fun (l : int S.t ab) (r : float S.t ab) -> - match l, r with - | A, B -> "f A B" + match l, r with + | A, B -> "f A B" ;; end @@ -2507,8 +2511,8 @@ struct let f : a S.t ab -> b S.t ab -> string = fun l r -> - match l, r with - | A, B -> "f A B" + match l, r with + | A, B -> "f A B" ;; end @@ -2665,21 +2669,22 @@ type ('a, 'result, 'visit_action) context = | Local : ('a, ('a * insert as 'result), 'a local_visit_action) context | Global : ('a, 'a, 'a visit_action) context -let vexpr (type visit_action) : (_, _, visit_action) context -> _ -> visit_action - = function +let vexpr (type visit_action) : (_, _, visit_action) context -> _ -> visit_action = + function | Local -> fun _ -> raise Exit | Global -> fun _ -> raise Exit ;; -let vexpr (type visit_action) : ('a, 'result, visit_action) context -> 'a -> visit_action - = function +let vexpr (type visit_action) : ('a, 'result, visit_action) context -> 'a -> visit_action = + function | Local -> fun _ -> raise Exit | Global -> fun _ -> raise Exit ;; let vexpr (type result) (type visit_action) : (unit, result, visit_action) context -> unit -> visit_action - = function + = + function | Local -> fun _ -> raise Exit | Global -> fun _ -> raise Exit ;; @@ -2704,9 +2709,9 @@ type _ lst = let rec get_var : type stk ret. (stk s, ret) var -> stk lst -> ret = fun n s -> - match n, s with - | Head, CCons (h, _) -> h - | Tail n', CCons (_, t) -> get_var n' t + match n, s with + | Head, CCons (h, _) -> h + | Tail n', CCons (_, t) -> get_var n' t ;; type 'a t = [< `Foo | `Bar ] as 'a @@ -2817,8 +2822,8 @@ type _ t = let undetected : ('a -> 'b -> nil) t -> 'a n -> 'b n -> unit = fun sh i j -> - let (Cons (Elt dim, _)) = sh in - () + let (Cons (Elt dim, _)) = sh in + () ;; type _ t = T : int t @@ -2903,10 +2908,10 @@ let comp_subst f g (x : 'a fin) = pre_subst f (g x) let rec thin : type n. n succ fin -> n fin -> n succ fin = fun x y -> - match x, y with - | FZ, y -> FS y - | FS x, FZ -> FZ - | FS x, FS y -> FS (thin x y) + match x, y with + | FZ, y -> FS y + | FS x, FZ -> FZ + | FS x, FS y -> FS (thin x y) ;; let bind t f = @@ -2919,24 +2924,24 @@ let bind t f = let rec thick : type n. n succ fin -> n succ fin -> n fin option = fun x y -> - match x, y with - | FZ, FZ -> None - | FZ, FS y -> Some y - | FS x, FZ -> - let IS = fin_succ x in - Some FZ - | FS x, FS y -> - let IS = fin_succ x in - bind (thick x y) (fun x -> Some (FS x)) + match x, y with + | FZ, FZ -> None + | FZ, FS y -> Some y + | FS x, FZ -> + let IS = fin_succ x in + Some FZ + | FS x, FS y -> + let IS = fin_succ x in + bind (thick x y) (fun x -> Some (FS x)) ;; let rec check : type n. n succ fin -> n succ term -> n term option = fun x t -> - match t with - | Var y -> bind (thick x y) (fun x -> Some (Var x)) - | Leaf -> Some Leaf - | Fork (t1, t2) -> - bind (check x t1) (fun t1 -> bind (check x t2) (fun t2 -> Some (Fork (t1, t2)))) + match t with + | Var y -> bind (thick x y) (fun x -> Some (Var x)) + | Leaf -> Some Leaf + | Fork (t1, t2) -> + bind (check x t1) (fun t1 -> bind (check x t2) (fun t2 -> Some (Fork (t1, t2)))) ;; let subst_var x t' y = @@ -2963,9 +2968,9 @@ let rec sub : type m n. (m, n) alist -> m fin -> n term = function let rec append : type m n l. (m, n) alist -> (l, m) alist -> (l, n) alist = fun r s -> - match s with - | Anil -> r - | Asnoc (s, t, x) -> Asnoc (append r s, t, x) + match s with + | Anil -> r + | Asnoc (s, t, x) -> Asnoc (append r s, t, x) ;; type _ ealist = EAlist : ('a, 'b) alist -> 'a ealist @@ -3009,24 +3014,24 @@ let flex_rigid x t = bind (check x t) (fun t' -> Some (asnoc Anil t' x)) let rec amgu : type m. m term -> m term -> m ealist -> m ealist option = fun s t acc -> - match s, t, acc with - | Leaf, Leaf, _ -> Some acc - | Leaf, Fork _, _ -> None - | Fork _, Leaf, _ -> None - | Fork (s1, s2), Fork (t1, t2), _ -> bind (amgu s1 t1 acc) (amgu s2 t2) - | Var x, Var y, EAlist Anil -> - let IS = fin_succ x in - Some (flex_flex x y) - | Var x, t, EAlist Anil -> - let IS = fin_succ x in - flex_rigid x t - | t, Var x, EAlist Anil -> - let IS = fin_succ x in - flex_rigid x t - | s, t, EAlist (Asnoc (d, r, z)) -> - bind - (amgu (subst z r s) (subst z r t) (EAlist d)) - (fun (EAlist d) -> Some (asnoc d r z)) + match s, t, acc with + | Leaf, Leaf, _ -> Some acc + | Leaf, Fork _, _ -> None + | Fork _, Leaf, _ -> None + | Fork (s1, s2), Fork (t1, t2), _ -> bind (amgu s1 t1 acc) (amgu s2 t2) + | Var x, Var y, EAlist Anil -> + let IS = fin_succ x in + Some (flex_flex x y) + | Var x, t, EAlist Anil -> + let IS = fin_succ x in + flex_rigid x t + | t, Var x, EAlist Anil -> + let IS = fin_succ x in + flex_rigid x t + | s, t, EAlist (Asnoc (d, r, z)) -> + bind + (amgu (subst z r s) (subst z r t) (EAlist d)) + (fun (EAlist d) -> Some (asnoc d r z)) ;; let mgu s t = amgu s t (EAlist Anil) @@ -3050,20 +3055,20 @@ type (_, _) eq = Refl : ('a, 'a) eq let magic : 'a 'b. 'a -> 'b = fun (type a b) (x : a) -> - let module M = - (functor - (T : sig - type 'a t - end) - -> - struct - let f (Refl : (a T.t, b T.t) eq) = (x :> b) - end) - (struct - type 'a t = unit - end) - in - M.f Refl + let module M = + (functor + (T : sig + type 'a t + end) + -> + struct + let f (Refl : (a T.t, b T.t) eq) = (x :> b) + end) + (struct + type 'a t = unit + end) + in + M.f Refl ;; (* Variance and subtyping *) @@ -3071,18 +3076,18 @@ let magic : 'a 'b. 'a -> 'b = type (_, +_) eq = Refl : ('a, 'a) eq let magic : 'a 'b. 'a -> 'b = - fun (type a b) (x : a) -> - let bad_proof (type a) = (Refl : (< m : a >, < m : a >) eq :> (< m : a >, < >) eq) in - let downcast : type a. (a, < >) eq -> < > -> a = - fun (type a) (Refl : (a, < >) eq) (s : < >) -> (s :> a) - in - (downcast - bad_proof - (object - method m = x - end - :> < >)) - #m + fun (type a) (type b) (x : a) -> + let bad_proof (type a) = (Refl : (< m : a >, < m : a >) eq :> (< m : a >, < >) eq) in + let downcast : type a. (a, < >) eq -> < > -> a = + fun (type a) (Refl : (a, < >) eq) (s : < >) -> (s :> a) + in + (downcast + bad_proof + (object + method m = x + end + :> < >)) + #m ;; (* Record patterns *) @@ -3532,12 +3537,12 @@ open Typ let rec to_string : 'a. 'a Typ.typ -> 'a -> string = fun (type s) t x -> - match (t : s typ) with - | Int eq -> string_of_int (TypEq.apply eq x) - | String eq -> Printf.sprintf "%S" (TypEq.apply eq x) - | Pair (module P) -> - let x1, x2 = TypEq.apply P.eq x in - Printf.sprintf "(%s,%s)" (to_string P.t1 x1) (to_string P.t2 x2) + match (t : s typ) with + | Int eq -> string_of_int (TypEq.apply eq x) + | String eq -> Printf.sprintf "%S" (TypEq.apply eq x) + | Pair (module P) -> + let x1, x2 = TypEq.apply P.eq x in + Printf.sprintf "(%s,%s)" (to_string P.t1 x1) (to_string P.t2 x2) ;; (* Wrapping maps *) @@ -4307,11 +4312,15 @@ let int_of_sexp _ = 42 let t_of_sexp : 'a. (sexp -> 'a) -> sexp -> 'a t = let _tp_loc = "core_array.ml.t" in - fun _of_a t -> (array_of_sexp _of_a) t + fun _of_a -> fun t -> (array_of_sexp _of_a) t ;; let _ = t_of_sexp -let sexp_of_t : 'a. ('a -> sexp) -> 'a t -> sexp = fun _of_a v -> (sexp_of_array _of_a) v + +let sexp_of_t : 'a. ('a -> sexp) -> 'a t -> sexp = + fun _of_a -> fun v -> (sexp_of_array _of_a) v +;; + let _ = sexp_of_t module T = struct @@ -4358,13 +4367,13 @@ end = struct let t_of_sexp : 'a 'perms. (sexp -> 'a) -> (sexp -> 'perms) -> sexp -> ('a, 'perms) t = let _tp_loc = "core_array.ml.Permissioned.t" in - fun _of_a _of_perms t -> (array_of_sexp _of_a) t + fun _of_a -> fun _of_perms -> fun t -> (array_of_sexp _of_a) t ;; let _ = t_of_sexp let sexp_of_t : 'a 'perms. ('a -> sexp) -> ('perms -> sexp) -> ('a, 'perms) t -> sexp = - fun _of_a _of_perms v -> (sexp_of_array _of_a) v + fun _of_a -> fun _of_perms -> fun v -> (sexp_of_array _of_a) v ;; let _ = sexp_of_t @@ -4378,13 +4387,13 @@ end = struct let t_of_sexp : 'perms. (sexp -> 'perms) -> sexp -> 'perms t = let _tp_loc = "core_array.ml.Permissioned.Int.t" in - fun _of_perms t -> t__of_sexp t + fun _of_perms -> fun t -> t__of_sexp t ;; let _ = t_of_sexp let sexp_of_t : 'perms. ('perms -> sexp) -> 'perms t -> sexp = - fun _of_perms v -> sexp_of_t_ v + fun _of_perms -> fun v -> sexp_of_t_ v ;; let _ = sexp_of_t @@ -4903,7 +4912,10 @@ type t = F(M).t module Common0 = struct type msg = Msg - let handle_msg = ref (function _ -> failwith "Unable to handle message") + let handle_msg = + ref (function + | _ -> failwith "Unable to handle message") + ;; let extend_handle f = let old = !handle_msg in @@ -4920,7 +4932,10 @@ let q' : Common0.msg Queue.t = Common0.q module Common = struct type msg = .. - let handle_msg = ref (function _ -> failwith "Unable to handle message") + let handle_msg = + ref (function + | _ -> failwith "Unable to handle message") + ;; let extend_handle f = let old = !handle_msg in @@ -6767,7 +6782,7 @@ end = M1 ;; -fun (x : M1.t) : M2.t -> x +fun (x : M1.t) -> (x : M2.t) (* fails *) @@ -8643,7 +8658,8 @@ type v = let f : type a b c d e f g. a t * b t * c t * d t * e t * f t * g t * v * (a, b, c, d) u * (e, f, g, g) u -> int - = function + = + function | A, A, A, A, A, A, A, _, U, U -> 1 | _, _, _, _, _, _, _, G, _, _ -> 1 ;; @@ -8719,9 +8735,9 @@ let g : int t -> int = function let h : type a. a t -> a t -> bool = fun x y -> - match x, y with - | Int, Int -> true - | Bool, Bool -> true + match x, y with + | Int, Int -> true + | Bool, Bool -> true ;; type (_, _) cmp = @@ -8774,8 +8790,8 @@ let harder : (zero succ, zero succ, zero succ) plus option -> bool = function let inv_zero : type a b c d. (a, b, c) plus -> (c, d, zero) plus -> bool = fun p1 p2 -> - match p1, p2 with - | Plus0, Plus0 -> true + match p1, p2 with + | Plus0, Plus0 -> true ;; (* Empty match *) @@ -9453,8 +9469,8 @@ class ['a] c () = let f : type a'. a' = assert false let foo : type a' b'. a' -> b' = fun a -> assert false -let foo : type t'. t' = fun (type t') : t' -> assert false -let foo : 't. 't = fun (type t) : t -> assert false +let foo : type t'. t' = fun (type t') -> (assert false : t') +let foo : 't. 't = fun (type t) -> (assert false : t) let foo : type a' b' c' t. a' -> b' -> c' -> t = fun a b c -> assert false let f x = @@ -9580,7 +9596,7 @@ let ssmap let ssmap : (module MapT with type key = string and type data = string and type map = SSMap.map) - -> unit + -> unit = () ;; @@ -9798,8 +9814,9 @@ let _ = match x with | _ when f - ~f:(function [@ocaml.warning - (* ....................................... *) "-4"] _ -> .) -> y + ~f: + (function [@ocaml.warning (* ....................................... *) "-4"] + | _ -> .) -> y ;; let[@a @@ -9814,15 +9831,18 @@ let[@a with | _ when f - ~f:(function[@ocaml.warning (* ....................................... *) "-4"] + ~f: + (function [@ocaml.warning (* ....................................... *) "-4"] | _ -> .) - ~f:(function[@ocaml.warning + ~f: + (function [@ocaml.warning (* ....................................... *) (* ....................................... *) "foooooooooooooooooooooooooooo \ fooooooooooooooooooooooooooooooooooooo"] | _ -> .) - ~f:(function[@ocaml.warning + ~f: + (function [@ocaml.warning (* ....................................... *) let x = a and y = b in @@ -9923,7 +9943,7 @@ let () = very_long_argument_name_one very_long_argument_name_two very_long_argument_name_three - -> ()) + -> ()) ;; let () = @@ -9948,8 +9968,8 @@ let _ = let _ = aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa ~bbbbbbbbbbbbbbbbbbbbbbbbbbbb: - (fun - (_ : (ccccccccccccc * ddddddddddddddddddddddddddddd) eeee) -> FFFFFFFFF gg) + (fun (_ : (ccccccccccccc * ddddddddddddddddddddddddddddd) eeee) + -> FFFFFFFFF gg) ~h ;; @@ -9974,7 +9994,7 @@ type t let pat = String.Search_pattern.create (String.init len ~f:(function - | 0 -> '\n' + | 0 -> '\n' | n when n < len - 1 -> ' ' | _ -> '*')) ;; @@ -10045,12 +10065,16 @@ let _ = fooooooooooo ;; -let _ = foo |> List.map (function A -> do_something ()) +let _ = + foo + |> List.map (function + | A -> do_something ()) +;; let _ = foo |> List.map (function - | A -> do_something () + | A -> do_something () | A -> do_something () | A -> do_something () | A -> do_something () @@ -10188,8 +10212,8 @@ let _ = Foooooooooooooooooooo.foooooooooooooooooooo foooooooooooooooooooo foooooooooooooooooooo - (fun x -> function - | Foooooooooooooooooooo -> foooooooooooooooooooo + (fun x ->function + | Foooooooooooooooooooo -> foooooooooooooooooooo | Foooooooooooooooooooo -> foooooooooooooooooooo) ;; @@ -10197,8 +10221,8 @@ let _ = Foooooooooooooooooooo.foooooooooooooooooooo foooooooooooooooooooo foooooooooooooooooooo - ~x:(fun x -> function - | Foooooooooooooooooooo -> foooooooooooooooooooo + ~x:(fun x ->function + | Foooooooooooooooooooo -> foooooooooooooooooooo | Foooooooooooooooooooo -> foooooooooooooooooooo) ;; @@ -10224,13 +10248,14 @@ let _ = let _ = let x = x in - fun foooooooooooooooooo + fun foooooooooooooooooo foooooooooooooooooo foooooooooooooooooo foooooooooooooooooo - foooooooooooooooooo -> - () + foooooooooooooooooo + foooooooooooooooooo + -> () ;; module type For_let_syntax_local = @@ -10263,10 +10288,10 @@ type input = let x = fun [@foo] x -> - fun [@foo] y -> - object - method x = y - end + fun [@foo] y -> + object + method x = y + end ;; class x = @@ -10284,10 +10309,11 @@ module M = let _ = Some - (fun fooooooooooooooooooooooooooooooo + (fun + fooooooooooooooooooooooooooooooo fooooooooooooooooooooooooooooooo - fooooooooooooooooooooooooooooooo -> - foo) + fooooooooooooooooooooooooooooooo + -> foo) ;; type t = @@ -10372,8 +10398,8 @@ let () = match () with | _ -> (fun _ : _ -> - match () with - | _ -> ()) + (match () with + | _ -> ())) | _ -> () ;; @@ -10445,13 +10471,14 @@ let _ = let _ = fooooooooooooooooooooooooooooooo - |> foooooooooooooooooooooooooooo ~fooooooooooooooooooooooooooooooo (function foo -> bar) + |> foooooooooooooooooooooooooooo ~fooooooooooooooooooooooooooooooo (function + | foo -> bar) ;; let _ = fooooooooooooooooooooooooooooooo |> fooooooooooooooooooooooooooooooo ~fooooooooooooooooooooooooooooooo (function - | Some _ -> foo + | Some _ -> foo | None -> baz) ;; diff --git a/test/passing/tests/js_upon.ml.ref b/test/passing/tests/js_upon.ml.ref index 87df8ba5cb..22b36d5aee 100644 --- a/test/passing/tests/js_upon.ml.ref +++ b/test/passing/tests/js_upon.ml.ref @@ -3,8 +3,8 @@ let f x = (* We don't do this as a matter of style, but the indentation reveals a common mistake. *) >>> fun () -> - don't_wait_for (close fd) ; - bind fd + don't_wait_for (close fd) ; + bind fd let f x = ( stop diff --git a/test/passing/tests/labelled_args-414.ml.ref b/test/passing/tests/labelled_args-414.ml.ref index 6f7577d6aa..0de623ac54 100644 --- a/test/passing/tests/labelled_args-414.ml.ref +++ b/test/passing/tests/labelled_args-414.ml.ref @@ -4,17 +4,14 @@ let _ = let () = very_long_function_name - ~very_long_argument_label:(fun - very_long_argument_name_one - very_long_argument_name_two - very_long_argument_name_three - -> () ) + ~very_long_argument_label:(fun very_long_argument_name_one + very_long_argument_name_two + very_long_argument_name_three + -> () ) let () = very_long_function_name ~very_long_argument_label:(* foo *) - (fun - very_long_argument_name_one - very_long_argument_name_two - very_long_argument_name_three - -> () ) + (fun very_long_argument_name_one very_long_argument_name_two + very_long_argument_name_three + -> () ) diff --git a/test/passing/tests/labelled_args.ml b/test/passing/tests/labelled_args.ml index ed530ced7b..92ab1a0bb2 100644 --- a/test/passing/tests/labelled_args.ml +++ b/test/passing/tests/labelled_args.ml @@ -4,17 +4,14 @@ let _ = let () = very_long_function_name - ~very_long_argument_label:(fun - very_long_argument_name_one - very_long_argument_name_two - very_long_argument_name_three - -> () ) + ~very_long_argument_label:(fun very_long_argument_name_one + very_long_argument_name_two + very_long_argument_name_three + -> () ) let () = very_long_function_name ~very_long_argument_label:(* foo *) - (fun - very_long_argument_name_one - very_long_argument_name_two - very_long_argument_name_three - -> () ) + (fun very_long_argument_name_one very_long_argument_name_two + very_long_argument_name_three + -> () ) diff --git a/test/passing/tests/let_binding-in_indent.ml.ref b/test/passing/tests/let_binding-in_indent.ml.ref index 496d0aef81..55e8c661d1 100644 --- a/test/passing/tests/let_binding-in_indent.ml.ref +++ b/test/passing/tests/let_binding-in_indent.ml.ref @@ -108,8 +108,8 @@ let f aaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbbbbbb cccccccccccccccccccccccc let _ = fun aaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbbbbbb cccccccccccccccccccccccc - dddddddddddddddddd eeeeeeeeeeeeee -> - () + dddddddddddddddddd eeeeeeeeeeeeee + -> () let _ = let (x : int) = x in @@ -237,7 +237,7 @@ let _ = module A = struct let f : int S.t ab -> float S.t ab -> string = fun (l : int S.t ab) (r : float S.t ab) -> - match (l, r) with A, B -> "f A B" + match (l, r) with A, B -> "f A B" ;; end diff --git a/test/passing/tests/let_binding-indent.ml.ref b/test/passing/tests/let_binding-indent.ml.ref index 5e07912e98..79820bef5c 100644 --- a/test/passing/tests/let_binding-indent.ml.ref +++ b/test/passing/tests/let_binding-indent.ml.ref @@ -108,8 +108,8 @@ let f aaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbbbbbb cccccccccccccccccccccccc let _ = fun aaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbbbbbb - cccccccccccccccccccccccc dddddddddddddddddd eeeeeeeeeeeeee -> - () + cccccccccccccccccccccccc dddddddddddddddddd eeeeeeeeeeeeee + -> () let _ = let (x : int) = x in @@ -237,7 +237,7 @@ let _ = module A = struct let f : int S.t ab -> float S.t ab -> string = fun (l : int S.t ab) (r : float S.t ab) -> - match (l, r) with A, B -> "f A B" + match (l, r) with A, B -> "f A B" ;; end diff --git a/test/passing/tests/let_binding.ml.ref b/test/passing/tests/let_binding.ml.ref index 1920f73453..7aea2df0c1 100644 --- a/test/passing/tests/let_binding.ml.ref +++ b/test/passing/tests/let_binding.ml.ref @@ -108,8 +108,8 @@ let f aaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbbbbbb cccccccccccccccccccccccc let _ = fun aaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbbbbbb cccccccccccccccccccccccc - dddddddddddddddddd eeeeeeeeeeeeee -> - () + dddddddddddddddddd eeeeeeeeeeeeee + -> () let _ = let (x : int) = x in @@ -237,7 +237,7 @@ let _ = module A = struct let f : int S.t ab -> float S.t ab -> string = fun (l : int S.t ab) (r : float S.t ab) -> - match (l, r) with A, B -> "f A B" + match (l, r) with A, B -> "f A B" ;; end diff --git a/test/passing/tests/loc_stack.ml.ref b/test/passing/tests/loc_stack.ml.ref index 0c1e5256b5..7b842aca3c 100644 --- a/test/passing/tests/loc_stack.ml.ref +++ b/test/passing/tests/loc_stack.ml.ref @@ -13,19 +13,20 @@ let _ = let should_inline : Llvm.llvalue -> bool = fun llv -> - match Llvm.use_begin llv with - | Some use -> ( - match Llvm.use_succ use with - | Some _ -> ( - (* If we are not in the default context, we can only use the OCAMLPATH + match Llvm.use_begin llv with + | Some use -> ( + match Llvm.use_succ use with + | Some _ -> ( + (* If we are not in the default context, we can only use the OCAMLPATH variable if it is specific to this build context *) - (* CR-someday diml: maybe we should actually clear OCAMLPATH in other + (* CR-someday diml: maybe we should actually clear OCAMLPATH in other build contexts *) - match Llvm.classify_value llv with - | Instruction - ( Trunc | ZExt | SExt | FPToUI | FPToSI | UIToFP | SIToFP | FPTrunc - | FPExt | PtrToInt | IntToPtr | BitCast | AddrSpaceCast ) -> - true (* inline casts *) - | _ -> false (* do not inline if >= 2 uses *) ) - | None -> true ) - | None -> true + match Llvm.classify_value llv with + | Instruction + ( Trunc | ZExt | SExt | FPToUI | FPToSI | UIToFP | SIToFP + | FPTrunc | FPExt | PtrToInt | IntToPtr | BitCast | AddrSpaceCast + ) -> + true (* inline casts *) + | _ -> false (* do not inline if >= 2 uses *) ) + | None -> true ) + | None -> true diff --git a/test/passing/tests/match.ml b/test/passing/tests/match.ml index f9a2b59497..c196e4bc50 100644 --- a/test/passing/tests/match.ml +++ b/test/passing/tests/match.ml @@ -34,16 +34,16 @@ let _ = let x = let g = match x with - | `A -> ( fun id -> function A -> e ; e | _ -> () ) - | `B -> ( fun id -> function A -> e ; e | _ -> () ) + | `A -> ( fun id ->function A -> e ; e | _ -> () ) + | `B -> ( fun id ->function A -> e ; e | _ -> () ) in () let x = let g = match x with - | `A -> ( fun id -> function A -> () | B -> () ) - | `B -> ( fun id -> function A -> () | _ -> () ) + | `A -> ( fun id ->function A -> () | B -> () ) + | `B -> ( fun id ->function A -> () | _ -> () ) in () diff --git a/test/passing/tests/match2.ml b/test/passing/tests/match2.ml index 2db48608f0..9aa038a7b1 100644 --- a/test/passing/tests/match2.ml +++ b/test/passing/tests/match2.ml @@ -55,21 +55,18 @@ let _ = match x with _ -> b >>= fun () -> c [@@@ocamlformat "break-infix-before-func=false"] -let foo = match foo with 1 -> bar >>= ( function _ -> () ) | other -> () +let foo = match foo with 1 -> bar >>= (function _ -> ()) | other -> () let foo = match foo with - | 1 -> bar >>= ( function a -> fooooo | b -> fooooo | _ -> () ) + | 1 -> bar >>= (function a -> fooooo | b -> fooooo | _ -> ()) | other -> () let foo = match foo with | 1 -> - bar >>= ( function - | a -> fooooo - | b -> fooooo - | c -> foooooooo foooooooooo fooooooooooooooooooo () - | _ -> () ) + bar >>= (function a -> fooooo | b -> fooooo + | c -> foooooooo foooooooooo fooooooooooooooooooo () | _ -> () ) | other -> () let _ = diff --git a/test/passing/tests/max_indent.ml b/test/passing/tests/max_indent.ml index afc90a208b..2ae7825a03 100644 --- a/test/passing/tests/max_indent.ml +++ b/test/passing/tests/max_indent.ml @@ -7,8 +7,8 @@ let () = let () = fooooo |> List.iter - (fun - some_really_really_really_long_name_that_doesn't_fit_on_the_line -> + (fun some_really_really_really_long_name_that_doesn't_fit_on_the_line + -> let x = some_really_really_really_long_name_that_doesn't_fit_on_the_line $ y diff --git a/test/passing/tests/object.ml.ref b/test/passing/tests/object.ml.ref index ebf54da2ea..d6a86cdc70 100644 --- a/test/passing/tests/object.ml.ref +++ b/test/passing/tests/object.ml.ref @@ -298,10 +298,10 @@ class a x = object (self) end let x = fun [@foo] x -> - fun [@foo] y -> - object - method x = y - end + fun [@foo] y -> + object + method x = y + end class x = fun [@foo] x -> diff --git a/test/passing/tests/ocp_indent_compat-break_colon_after.ml.ref b/test/passing/tests/ocp_indent_compat-break_colon_after.ml.ref index 4ed2d190af..36ca314095 100644 --- a/test/passing/tests/ocp_indent_compat-break_colon_after.ml.ref +++ b/test/passing/tests/ocp_indent_compat-break_colon_after.ml.ref @@ -62,20 +62,18 @@ module type M = sig -> unit end -let ssmap : - (module MapT - with type key = string - and type data = string - and type map = SSMap.map ) +let ssmap : (module MapT + with type key = string + and type data = string + and type map = SSMap.map ) = () -let ssmap : - (module MapT - with type key = string - and type data = string - and type map = SSMap.map ) - -> unit +let ssmap : (module MapT + with type key = string + and type data = string + and type map = SSMap.map ) + -> unit = () diff --git a/test/passing/tests/ocp_indent_compat.ml b/test/passing/tests/ocp_indent_compat.ml index 0dd986c79c..9e2496b98f 100644 --- a/test/passing/tests/ocp_indent_compat.ml +++ b/test/passing/tests/ocp_indent_compat.ml @@ -76,7 +76,7 @@ let ssmap with type key = string and type data = string and type map = SSMap.map ) - -> unit + -> unit = () diff --git a/test/passing/tests/open-closing-on-separate-line.ml.ref b/test/passing/tests/open-closing-on-separate-line.ml.ref index 93fe77f6ba..ab548e7a1b 100644 --- a/test/passing/tests/open-closing-on-separate-line.ml.ref +++ b/test/passing/tests/open-closing-on-separate-line.ml.ref @@ -370,17 +370,15 @@ let _ : M.([`Foo of foo]) = () let _ : M.N.(foo) = () -let _ : - M.( - foooooooooooooooooooooooooooooooooooooooo - * foooooooooooooooooooooooooooooooooooooooo) = +let _ : M.( + foooooooooooooooooooooooooooooooooooooooo + * foooooooooooooooooooooooooooooooooooooooo) = () -let _ : - M.( - [ `Foo of - foooooooooooooooooooooooooooooooooooooooo - * foooooooooooooooooooooooooooooooooooooooo ]) = +let _ : M.( + [ `Foo of + foooooooooooooooooooooooooooooooooooooooo + * foooooooooooooooooooooooooooooooooooooooo ]) = () let _ : M.((foo[@attr])) = () diff --git a/test/passing/tests/open.ml.ref b/test/passing/tests/open.ml.ref index ae2e66a76f..0c4cf2140d 100644 --- a/test/passing/tests/open.ml.ref +++ b/test/passing/tests/open.ml.ref @@ -357,17 +357,15 @@ let _ : M.([`Foo of foo]) = () let _ : M.N.(foo) = () -let _ : - M.( - foooooooooooooooooooooooooooooooooooooooo - * foooooooooooooooooooooooooooooooooooooooo) = +let _ : M.( + foooooooooooooooooooooooooooooooooooooooo + * foooooooooooooooooooooooooooooooooooooooo) = () -let _ : - M.( - [ `Foo of - foooooooooooooooooooooooooooooooooooooooo - * foooooooooooooooooooooooooooooooooooooooo ]) = +let _ : M.( + [ `Foo of + foooooooooooooooooooooooooooooooooooooooo + * foooooooooooooooooooooooooooooooooooooooo ]) = () let _ : M.((foo[@attr])) = () diff --git a/test/passing/tests/polytypes-default.ml.ref b/test/passing/tests/polytypes-default.ml.ref index 9358065892..9f3c0ea12e 100644 --- a/test/passing/tests/polytypes-default.ml.ref +++ b/test/passing/tests/polytypes-default.ml.ref @@ -1,25 +1,22 @@ let t1 : 'a 'b. 'a t -> b t = () -let t2 : - 'a 'b. - 'a t________________________________ -> - 'b t_______________________________________ = +let t2 : 'a 'b. + 'a t________________________________ -> + 'b t_______________________________________ = () -let t3 : - 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that 'must - 'wrap. - 'a t_________________________________________________ -> - 'b t______________________________________________________________ -> - 'c t______________________________________________________________ = +let t3 : 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that + 'must 'wrap. + 'a t_________________________________________________ -> + 'b t______________________________________________________________ -> + 'c t______________________________________________________________ = () -let t4 : - 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that 'must - 'wrap. - 'a t_________________________________________________ - * 'b t______________________________________________________________ - * 'c t______________________________________________________________ = +let t4 : 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that + 'must 'wrap. + 'a t_________________________________________________ + * 'b t______________________________________________________________ + * 'c t______________________________________________________________ = () let foo : type a. a = @@ -34,16 +31,20 @@ let _ = let id : 'a. 'a -> 'a = fun x -> x in () -let equal_list : - 'a. ('a, 't) gexpr marked list -> ('a, 't) gexpr marked list -> bool = +let equal_list : 'a. + ('a, 't) gexpr marked list -> + ('a, 't) gexpr marked list -> + bool = fun es1 es2 -> - try List.for_all2 equal es1 es2 with Invalid_argument _ -> false + try List.for_all2 equal es1 es2 with Invalid_argument _ -> false -let rec equal_list : - 'a. ('a, 't) gexpr marked list -> ('a, 't) gexpr marked list -> bool = +let rec equal_list : 'a. + ('a, 't) gexpr marked list -> + ('a, 't) gexpr marked list -> + bool = fun es1 es2 -> - try List.for_all2 equal es1 es2 with Invalid_argument _ -> false + try List.for_all2 equal es1 es2 with Invalid_argument _ -> false and equal : 'a. ('a, 't) gexpr marked -> ('a, 't) gexpr marked -> bool = fun (type a) (e1 : (a, 't) gexpr marked) (e2 : (a, 't) gexpr marked) -> - match (Marked.unmark e1, Marked.unmark e2) with x -> x + match (Marked.unmark e1, Marked.unmark e2) with x -> x diff --git a/test/passing/tests/polytypes-janestreet.ml.ref b/test/passing/tests/polytypes-janestreet.ml.ref index a35e53e6b5..40302fa9af 100644 --- a/test/passing/tests/polytypes-janestreet.ml.ref +++ b/test/passing/tests/polytypes-janestreet.ml.ref @@ -2,25 +2,25 @@ let t1 : 'a 'b. 'a t -> b t = () let t2 : 'a 'b. - 'a t________________________________ -> 'b t_______________________________________ + 'a t________________________________ -> 'b t_______________________________________ = () ;; let t3 : 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that 'must 'wrap. - 'a t_________________________________________________ - -> 'b t______________________________________________________________ - -> 'c t______________________________________________________________ + 'a t_________________________________________________ + -> 'b t______________________________________________________________ + -> 'c t______________________________________________________________ = () ;; let t4 : 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that 'must 'wrap. - 'a t_________________________________________________ - * 'b t______________________________________________________________ - * 'c t______________________________________________________________ + 'a t_________________________________________________ + * 'b t______________________________________________________________ + * 'c t______________________________________________________________ = () ;; @@ -41,17 +41,17 @@ let _ = let equal_list : 'a. ('a, 't) gexpr marked list -> ('a, 't) gexpr marked list -> bool = fun es1 es2 -> - try List.for_all2 equal es1 es2 with - | Invalid_argument _ -> false + try List.for_all2 equal es1 es2 with + | Invalid_argument _ -> false ;; let rec equal_list : 'a. ('a, 't) gexpr marked list -> ('a, 't) gexpr marked list -> bool = fun es1 es2 -> - try List.for_all2 equal es1 es2 with - | Invalid_argument _ -> false + try List.for_all2 equal es1 es2 with + | Invalid_argument _ -> false and equal : 'a. ('a, 't) gexpr marked -> ('a, 't) gexpr marked -> bool = fun (type a) (e1 : (a, 't) gexpr marked) (e2 : (a, 't) gexpr marked) -> - match Marked.unmark e1, Marked.unmark e2 with - | x -> x + match Marked.unmark e1, Marked.unmark e2 with + | x -> x ;; diff --git a/test/passing/tests/polytypes.ml b/test/passing/tests/polytypes.ml index 9a9ae969df..d0e4d6ae76 100644 --- a/test/passing/tests/polytypes.ml +++ b/test/passing/tests/polytypes.ml @@ -1,25 +1,25 @@ let t1 : 'a 'b. 'a t -> b t = () -let t2 : - 'a 'b. - 'a t________________________________ - -> 'b t_______________________________________ = +let t2 : 'a 'b. + 'a t________________________________ + -> 'b t_______________________________________ = () -let t3 : - 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that - 'must 'wrap. - 'a t_________________________________________________ - -> 'b t______________________________________________________________ - -> 'c t______________________________________________________________ = +let t3 : 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables + 'that 'must 'wrap. + 'a t_________________________________________________ + -> 'b + t______________________________________________________________ + -> 'c + t______________________________________________________________ = () -let t4 : - 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that - 'must 'wrap. - 'a t_________________________________________________ - * 'b t______________________________________________________________ - * 'c t______________________________________________________________ = +let t4 : 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables + 'that 'must 'wrap. + 'a t_________________________________________________ + * 'b t______________________________________________________________ + * 'c t______________________________________________________________ + = () let foo : type a. a = @@ -34,16 +34,20 @@ let _ = let id : 'a. 'a -> 'a = fun x -> x in () -let equal_list : - 'a. ('a, 't) gexpr marked list -> ('a, 't) gexpr marked list -> bool = +let equal_list : 'a. + ('a, 't) gexpr marked list + -> ('a, 't) gexpr marked list + -> bool = fun es1 es2 -> - try List.for_all2 equal es1 es2 with Invalid_argument _ -> false + try List.for_all2 equal es1 es2 with Invalid_argument _ -> false -let rec equal_list : - 'a. ('a, 't) gexpr marked list -> ('a, 't) gexpr marked list -> bool = +let rec equal_list : 'a. + ('a, 't) gexpr marked list + -> ('a, 't) gexpr marked list + -> bool = fun es1 es2 -> - try List.for_all2 equal es1 es2 with Invalid_argument _ -> false + try List.for_all2 equal es1 es2 with Invalid_argument _ -> false and equal : 'a. ('a, 't) gexpr marked -> ('a, 't) gexpr marked -> bool = fun (type a) (e1 : (a, 't) gexpr marked) (e2 : (a, 't) gexpr marked) -> - match (Marked.unmark e1, Marked.unmark e2) with x -> x + match (Marked.unmark e1, Marked.unmark e2) with x -> x diff --git a/test/passing/tests/pre_post_extensions.ml b/test/passing/tests/pre_post_extensions.ml index ef52df32ba..441165ad8a 100644 --- a/test/passing/tests/pre_post_extensions.ml +++ b/test/passing/tests/pre_post_extensions.ml @@ -1,15 +1,15 @@ let f x = - [%Trace.call fun {pf} -> pf "%i" x] + [%Trace.call fun {pf} ->pf "%i" x] ; print_int x ; x |> - [%Trace.retn fun {pf} -> pf "%i"] + [%Trace.retn fun {pf} ->pf "%i"] let f x = - [%Trace.call fun {pf} : t -> pf "%i" x] + [%Trace.call fun {pf} : t ->pf "%i" x] ; print_int x ; x |> - [%Trace.retn fun {pf} : t -> pf "%i"] + [%Trace.retn fun {pf} : t ->pf "%i"] diff --git a/test/passing/tests/revapply_ext.ml b/test/passing/tests/revapply_ext.ml index 84ad583dbb..ca71645df8 100644 --- a/test/passing/tests/revapply_ext.ml +++ b/test/passing/tests/revapply_ext.ml @@ -2,8 +2,8 @@ let _ = () (* one *) |> - [%ext fun _ -> ()] + [%ext fun _ ->()] let _ = () |> - [%ext fun _ -> ()] + [%ext fun _ ->()] diff --git a/test/passing/tests/skip.ml b/test/passing/tests/skip.ml index 33eb9d37b7..311cfd2033 100644 --- a/test/passing/tests/skip.ml +++ b/test/passing/tests/skip.ml @@ -22,14 +22,10 @@ end module S = struct let x = function - | A, B -> 1 - | BBB, _ -> 2 - | CCCcccc, CCCCCCCC -> (* cmt about 3 *) 3 + | A, B -> 1 | BBB, _ -> 2 | CCCcccc, CCCCCCCC -> (* cmt about 3 *) 3 let x = function - | A, B -> 1 - | BBB, _ -> 2 - | CCCcccc, CCCCCCCC -> (* cmt about 3 *) 3 + | A, B -> 1 | BBB, _ -> 2 | CCCcccc, CCCCCCCC -> (* cmt about 3 *) 3 [@@@ocamlformat "disable"] @@ -41,9 +37,7 @@ module S = struct [@@@ocamlformat "enable"] let x = function - | A, B -> 1 - | BBB, _ -> 2 - | CCCcccc, CCCCCCCC -> (* cmt about 3 *) 3 + | A, B -> 1 | BBB, _ -> 2 | CCCcccc, CCCCCCCC -> (* cmt about 3 *) 3 let _ = let x = 3 in @@ -55,9 +49,7 @@ module S = struct end let x = function - | A, B -> 1 - | BBB, _ -> 2 - | CCCcccc, CCCCCCCC -> (* cmt about 3 *) 3 + | A, B -> 1 | BBB, _ -> 2 | CCCcccc, CCCCCCCC -> (* cmt about 3 *) 3 module type S = sig type t = int * int diff --git a/test/passing/tests/source.ml.err b/test/passing/tests/source.ml.err index e46a533986..81215270b7 100644 --- a/test/passing/tests/source.ml.err +++ b/test/passing/tests/source.ml.err @@ -1,2 +1,4 @@ -Warning: tests/source.ml:704 exceeds the margin -Warning: tests/source.ml:2321 exceeds the margin +Warning: tests/source.ml:703 exceeds the margin +Warning: tests/source.ml:1038 exceeds the margin +Warning: tests/source.ml:1253 exceeds the margin +Warning: tests/source.ml:1391 exceeds the margin diff --git a/test/passing/tests/source.ml.ref b/test/passing/tests/source.ml.ref index 9fb86f2dfd..a0c5a233b0 100644 --- a/test/passing/tests/source.ml.ref +++ b/test/passing/tests/source.ml.ref @@ -57,11 +57,10 @@ let [%foo? Bar x | Baz x] : [%foo? #bar] = [%foo? {x}] [%%foo: module M : [%baz]] -let [%foo: include S with type t = t] : - [%foo: - val x : t +let [%foo: include S with type t = t] : [%foo: + val x : t - val y : t] = + val y : t] = [%foo: type t = t] let int_with_custom_modifier = @@ -957,9 +956,7 @@ module type S3 = sig end let f = function - | Some (module M : S3) when M.x -> 1 - | ((Some _) [@foooo]) -> 2 - | None -> 3 + | Some (module M : S3) when M.x -> 1 | ((Some _) [@foooo]) -> 2 | None -> 3 ;; print_endline @@ -1033,26 +1030,26 @@ type variant = let rec variantize : type t. t ty -> t -> variant = fun ty x -> - (* type t is abstract here *) - match ty with - | Int -> VInt x (* in this branch: t = int *) - | String -> VString x (* t = string *) - | List ty1 -> - VList (List.map (variantize ty1) x) (* t = 'a list for some 'a *) - | Pair (ty1, ty2) -> VPair (variantize ty1 (fst x), variantize ty2 (snd x)) + (* type t is abstract here *) + match ty with + | Int -> VInt x (* in this branch: t = int *) + | String -> VString x (* t = string *) + | List ty1 -> + VList (List.map (variantize ty1) x) (* t = 'a list for some 'a *) + | Pair (ty1, ty2) -> VPair (variantize ty1 (fst x), variantize ty2 (snd x)) (* t = ('a, 'b) for some 'a and 'b *) exception VariantMismatch let rec devariantize : type t. t ty -> variant -> t = fun ty v -> - match (ty, v) with - | Int, VInt x -> x - | String, VString x -> x - | List ty1, VList vl -> List.map (devariantize ty1) vl - | Pair (ty1, ty2), VPair (x1, x2) -> - (devariantize ty1 x1, devariantize ty2 x2) - | _ -> raise VariantMismatch + match (ty, v) with + | Int, VInt x -> x + | String, VString x -> x + | List ty1, VList vl -> List.map (devariantize ty1) vl + | Pair (ty1, ty2), VPair (x1, x2) -> + (devariantize ty1 x1, devariantize ty2 x2) + | _ -> raise VariantMismatch (* Handling records *) @@ -1080,21 +1077,21 @@ type variant = let rec variantize : type t. t ty -> t -> variant = fun ty x -> - (* type t is abstract here *) - match ty with - | Int -> VInt x (* in this branch: t = int *) - | String -> VString x (* t = string *) - | List ty1 -> - VList (List.map (variantize ty1) x) (* t = 'a list for some 'a *) - | Pair (ty1, ty2) -> - VPair (variantize ty1 (fst x), variantize ty2 (snd x)) - (* t = ('a, 'b) for some 'a and 'b *) - | Record {fields} -> - VRecord - (List.map - (fun (Field {field_type; label; get}) -> - (label, variantize field_type (get x)) ) - fields ) + (* type t is abstract here *) + match ty with + | Int -> VInt x (* in this branch: t = int *) + | String -> VString x (* t = string *) + | List ty1 -> + VList (List.map (variantize ty1) x) (* t = 'a list for some 'a *) + | Pair (ty1, ty2) -> + VPair (variantize ty1 (fst x), variantize ty2 (snd x)) + (* t = ('a, 'b) for some 'a and 'b *) + | Record {fields} -> + VRecord + (List.map + (fun (Field {field_type; label; get}) -> + (label, variantize field_type (get x)) ) + fields ) (* Extraction *) @@ -1122,22 +1119,22 @@ and ('a, 'builder, 'b) field_ = let rec devariantize : type t. t ty -> variant -> t = fun ty v -> - match (ty, v) with - | Int, VInt x -> x - | String, VString x -> x - | List ty1, VList vl -> List.map (devariantize ty1) vl - | Pair (ty1, ty2), VPair (x1, x2) -> - (devariantize ty1 x1, devariantize ty2 x2) - | Record {fields; create_builder; of_builder}, VRecord fl -> - if List.length fields <> List.length fl then raise VariantMismatch ; - let builder = create_builder () in - List.iter2 - (fun (Field {label; field_type; set}) (lab, v) -> - if label <> lab then raise VariantMismatch ; - set builder (devariantize field_type v) ) - fields fl ; - of_builder builder - | _ -> raise VariantMismatch + match (ty, v) with + | Int, VInt x -> x + | String, VString x -> x + | List ty1, VList vl -> List.map (devariantize ty1) vl + | Pair (ty1, ty2), VPair (x1, x2) -> + (devariantize ty1 x1, devariantize ty2 x2) + | Record {fields; create_builder; of_builder}, VRecord fl -> + if List.length fields <> List.length fl then raise VariantMismatch ; + let builder = create_builder () in + List.iter2 + (fun (Field {label; field_type; set}) (lab, v) -> + if label <> lab then raise VariantMismatch ; + set builder (devariantize field_type v) ) + fields fl ; + of_builder builder + | _ -> raise VariantMismatch type my_record = {a: int; b: string list} @@ -1212,11 +1209,11 @@ type (_, _) eq = Eq : ('a, 'a) eq let rec eq_sel : type a b c. (a, b) ty_sel -> (a, c) ty_sel -> (b, c) eq option = fun s1 s2 -> - match (s1, s2) with - | Thd, Thd -> Some Eq - | Ttl s1, Ttl s2 -> ( - match eq_sel s1 s2 with None -> None | Some Eq -> Some Eq ) - | _ -> None + match (s1, s2) with + | Thd, Thd -> Some Eq + | Ttl s1, Ttl s2 -> ( + match eq_sel s1 s2 with None -> None | Some Eq -> Some Eq ) + | _ -> None (* Auxiliary function to get the type of a case from its selector *) let rec get_case : type a b e. @@ -1224,16 +1221,16 @@ let rec get_case : type a b e. -> (string * (e, b) ty_case) list -> string * (a, e) ty option = fun sel cases -> - match cases with - | (name, TCnoarg sel') :: rem -> ( - match eq_sel sel sel' with - | None -> get_case sel rem - | Some Eq -> (name, None) ) - | (name, TCarg (sel', ty)) :: rem -> ( - match eq_sel sel sel' with - | None -> get_case sel rem - | Some Eq -> (name, Some ty) ) - | [] -> raise Not_found + match cases with + | (name, TCnoarg sel') :: rem -> ( + match eq_sel sel sel' with + | None -> get_case sel rem + | Some Eq -> (name, None) ) + | (name, TCarg (sel', ty)) :: rem -> ( + match eq_sel sel sel' with + | None -> get_case sel rem + | Some Eq -> (name, Some ty) ) + | [] -> raise Not_found (* Untyped representation of values *) type variant = @@ -1249,42 +1246,42 @@ let may_map f = function Some x -> Some (f x) | None -> None let rec variantize : type a e. e ty_env -> (a, e) ty -> a -> variant = fun e ty v -> - match ty with - | Int -> VInt v - | String -> VString v - | List t -> VList (List.map (variantize e t) v) - | Option t -> VOption (may_map (variantize e t) v) - | Pair (t1, t2) -> VPair (variantize e t1 (fst v), variantize e t2 (snd v)) - | Rec t -> variantize (Econs (ty, e)) t v - | Pop t -> ( match e with Econs (_, e') -> variantize e' t v ) - | Var -> ( match e with Econs (t, e') -> variantize e' t v ) - | Conv (s, proj, inj, t) -> VConv (s, variantize e t (proj v)) - | Sum ops -> - let tag, arg = ops.sum_proj v in - VSum - (tag, may_map (function Tdyn (ty, arg) -> variantize e ty arg) arg) + match ty with + | Int -> VInt v + | String -> VString v + | List t -> VList (List.map (variantize e t) v) + | Option t -> VOption (may_map (variantize e t) v) + | Pair (t1, t2) -> VPair (variantize e t1 (fst v), variantize e t2 (snd v)) + | Rec t -> variantize (Econs (ty, e)) t v + | Pop t -> ( match e with Econs (_, e') -> variantize e' t v ) + | Var -> ( match e with Econs (t, e') -> variantize e' t v ) + | Conv (s, proj, inj, t) -> VConv (s, variantize e t (proj v)) + | Sum ops -> + let tag, arg = ops.sum_proj v in + VSum + (tag, may_map (function Tdyn (ty, arg) -> variantize e ty arg) arg) let rec devariantize : type t e. e ty_env -> (t, e) ty -> variant -> t = fun e ty v -> - match (ty, v) with - | Int, VInt x -> x - | String, VString x -> x - | List ty1, VList vl -> List.map (devariantize e ty1) vl - | Pair (ty1, ty2), VPair (x1, x2) -> - (devariantize e ty1 x1, devariantize e ty2 x2) - | Rec t, _ -> devariantize (Econs (ty, e)) t v - | Pop t, _ -> ( match e with Econs (_, e') -> devariantize e' t v ) - | Var, _ -> ( match e with Econs (t, e') -> devariantize e' t v ) - | Conv (s, proj, inj, t), VConv (s', v) when s = s' -> - inj (devariantize e t v) - | Sum ops, VSum (tag, a) -> ( - try - match (List.assoc tag ops.sum_cases, a) with - | TCarg (sel, t), Some a -> ops.sum_inj (sel, devariantize e t a) - | TCnoarg sel, None -> ops.sum_inj (sel, Noarg) - | _ -> raise VariantMismatch - with Not_found -> raise VariantMismatch ) - | _ -> raise VariantMismatch + match (ty, v) with + | Int, VInt x -> x + | String, VString x -> x + | List ty1, VList vl -> List.map (devariantize e ty1) vl + | Pair (ty1, ty2), VPair (x1, x2) -> + (devariantize e ty1 x1, devariantize e ty2 x2) + | Rec t, _ -> devariantize (Econs (ty, e)) t v + | Pop t, _ -> ( match e with Econs (_, e') -> devariantize e' t v ) + | Var, _ -> ( match e with Econs (t, e') -> devariantize e' t v ) + | Conv (s, proj, inj, t), VConv (s', v) when s = s' -> + inj (devariantize e t v) + | Sum ops, VSum (tag, a) -> ( + try + match (List.assoc tag ops.sum_cases, a) with + | TCarg (sel, t), Some a -> ops.sum_inj (sel, devariantize e t a) + | TCnoarg sel, None -> ops.sum_inj (sel, Noarg) + | _ -> raise VariantMismatch + with Not_found -> raise VariantMismatch ) + | _ -> raise VariantMismatch (* First attempt: represent 1-constructor variants using Conv *) let wrap_A t = Conv ("`A", (fun (`A x) -> x), (fun x -> `A x), t) @@ -1316,10 +1313,9 @@ let ty_abc = (* Define inj in advance to be able to write the type annotation easily *) and inj : type c. (int -> string -> noarg -> unit, c) ty_sel * c - -> [`A of int | `B of string | `C] = function - | Thd, v -> `A v - | Ttl Thd, v -> `B v - | Ttl (Ttl Thd), Noarg -> `C + -> [`A of int | `B of string | `C] = + function + | Thd, v -> `A v | Ttl Thd, v -> `B v | Ttl (Ttl Thd), Noarg -> `C in (* Coherence of sum_inj and sum_cases is checked by the typing *) Sum @@ -1339,21 +1335,19 @@ type 'a vlist = [`Nil | `Cons of 'a * 'a vlist] let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t -> - let tcons = Pair (Pop t, Var) in - Rec - (Sum - { sum_proj= - (function - | `Nil -> ("Nil", None) - | `Cons p -> ("Cons", Some (Tdyn (tcons, p))) ) - ; sum_cases= [("Nil", TCnoarg Thd); ("Cons", TCarg (Ttl Thd, tcons))] - ; sum_inj= - (fun (type c) : - ((noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist) -> - function - | Thd, Noarg -> `Nil - | Ttl Thd, v -> `Cons v ) - (* One can also write the type annotation directly *) } ) + let tcons = Pair (Pop t, Var) in + Rec + (Sum + { sum_proj= + (function + | `Nil -> ("Nil", None) + | `Cons p -> ("Cons", Some (Tdyn (tcons, p))) ) + ; sum_cases= [("Nil", TCnoarg Thd); ("Cons", TCarg (Ttl Thd, tcons))] + ; sum_inj= + (fun (type c) -> + ( function Thd, Noarg -> `Nil | Ttl Thd, v -> `Cons v + : (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist ) ) + (* One can also write the type annotation directly *) } ) let v = variantize Enil (ty_list Int) (`Cons (1, `Cons (2, `Nil))) @@ -1391,16 +1385,16 @@ let ty_abc : ([`A of int | `B of string | `C], 'e) ty = (* Breaks: no way to pattern-match on a full recursive type *) let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t -> - let targ = Pair (Pop t, Var) in - Rec - (Sum - ( (function - | `Nil -> ("Nil", None) | `Cons p -> ("Cons", Some (Tdyn (targ, p))) - ) - , function - | "Nil", None -> `Nil - | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p - ) ) + let targ = Pair (Pop t, Var) in + Rec + (Sum + ( (function + | `Nil -> ("Nil", None) | `Cons p -> ("Cons", Some (Tdyn (targ, p))) + ) + , function + | "Nil", None -> `Nil + | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p + ) ) (* Define Sum using object instead of record for first-class polymorphism *) @@ -1455,22 +1449,22 @@ type 'a vlist = [`Nil | `Cons of 'a * 'a vlist] let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t -> - let tcons = Pair (Pop t, Var) in - Rec - (Sum - (object - method proj = - function - | `Nil -> ("Nil", None) - | `Cons p -> ("Cons", Some (Tdyn (tcons, p))) - - method cases = - [("Nil", TCnoarg Thd); ("Cons", TCarg (Ttl Thd, tcons))] - - method inj : type c. - (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist = - function Thd, Noarg -> `Nil | Ttl Thd, v -> `Cons v - end ) ) + let tcons = Pair (Pop t, Var) in + Rec + (Sum + (object + method proj = + function + | `Nil -> ("Nil", None) + | `Cons p -> ("Cons", Some (Tdyn (tcons, p))) + + method cases = + [("Nil", TCnoarg Thd); ("Cons", TCarg (Ttl Thd, tcons))] + + method inj : type c. + (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist = + function Thd, Noarg -> `Nil | Ttl Thd, v -> `Cons v + end ) ) (* type (_,_) ty_assoc = @@ -1516,8 +1510,7 @@ type (_, _, _) plus = | PlusS : ('a, 'b, 'c) plus -> ('a succ, 'b, 'c succ) plus let rec length : type a n. (a, n) seq -> n nat = function - | Snil -> NZ - | Scons (_, s) -> NS (length s) + | Snil -> NZ | Scons (_, s) -> NS (length s) (* app returns the catenated lists with a witness proving that the size is the sum of its two inputs *) @@ -1526,11 +1519,11 @@ type (_, _, _) app = let rec app : type a n m. (a, n) seq -> (a, m) seq -> (a, n, m) app = fun xs ys -> - match xs with - | Snil -> App (ys, PlusZ (length ys)) - | Scons (x, xs') -> - let (App (xs'', pl)) = app xs' ys in - App (Scons (x, xs''), PlusS pl) + match xs with + | Snil -> App (ys, PlusZ (length ys)) + | Scons (x, xs') -> + let (App (xs'', pl)) = app xs' ys in + App (Scons (x, xs''), PlusS pl) (* 3.1 Feature: kinds *) @@ -1571,20 +1564,20 @@ let tree1 = Tfork (Tfork (Ttip, Tnode 4), Tfork (Tnode 4, Tnode 3)) let rec find : type sh. ('a -> 'a -> bool) -> 'a -> (sh, 'a) tree -> (sh, 'a) path list = fun eq n t -> - match t with - | Ttip -> [] - | Tnode m -> if eq n m then [Phere] else [] - | Tfork (x, y) -> - List.map (fun x -> Pleft x) (find eq n x) - @ List.map (fun x -> Pright x) (find eq n y) + match t with + | Ttip -> [] + | Tnode m -> if eq n m then [Phere] else [] + | Tfork (x, y) -> + List.map (fun x -> Pleft x) (find eq n x) + @ List.map (fun x -> Pright x) (find eq n y) let rec extract : type sh. (sh, 'a) path -> (sh, 'a) tree -> 'a = fun p t -> - match (p, t) with - | Pnone x, Ttip -> x - | Phere, Tnode y -> y - | Pleft p, Tfork (l, _) -> extract p l - | Pright p, Tfork (_, r) -> extract p r + match (p, t) with + | Pnone x, Ttip -> x + | Phere, Tnode y -> y + | Pleft p, Tfork (l, _) -> extract p l + | Pright p, Tfork (_, r) -> extract p r (* 3.4 Pattern : Witness *) @@ -1612,7 +1605,7 @@ let p1 : (two, one, three) plus = PlusS (PlusS (PlusZ (NS NZ))) let rec summandLessThanSum : type a b c. (a, b, c) plus -> (a, c) le = fun p -> - match p with PlusZ n -> LeZ n | PlusS p' -> LeS (summandLessThanSum p') + match p with PlusZ n -> LeZ n | PlusS p' -> LeS (summandLessThanSum p') (* 3.8 Pattern: Leibniz Equality *) @@ -1622,22 +1615,22 @@ let convert : type a b. (a, b) equal -> a -> b = fun Eq x -> x let rec sameNat : type a b. a nat -> b nat -> (a, b) equal option = fun a b -> - match (a, b) with - | NZ, NZ -> Some Eq - | NS a', NS b' -> ( - match sameNat a' b' with Some Eq -> Some Eq | None -> None ) - | _ -> None + match (a, b) with + | NZ, NZ -> Some Eq + | NS a', NS b' -> ( + match sameNat a' b' with Some Eq -> Some Eq | None -> None ) + | _ -> None (* Extra: associativity of addition *) let rec plus_func : type a b m n. (a, b, m) plus -> (a, b, n) plus -> (m, n) equal = fun p1 p2 -> - match (p1, p2) with - | PlusZ _, PlusZ _ -> Eq - | PlusS p1', PlusS p2' -> - let Eq = plus_func p1' p2' in - Eq + match (p1, p2) with + | PlusZ _, PlusZ _ -> Eq + | PlusS p1', PlusS p2' -> + let Eq = plus_func p1' p2' in + Eq let rec plus_assoc : type a b c ab bc m n. (a, b, ab) plus @@ -1646,14 +1639,14 @@ let rec plus_assoc : type a b c ab bc m n. -> (a, bc, n) plus -> (m, n) equal = fun p1 p2 p3 p4 -> - match (p1, p4) with - | PlusZ b, PlusZ bc -> - let Eq = plus_func p2 p3 in - Eq - | PlusS p1', PlusS p4' -> - let (PlusS p2') = p2 in - let Eq = plus_assoc p1' p2' p3 p4' in - Eq + match (p1, p4) with + | PlusZ b, PlusZ bc -> + let Eq = plus_func p2 p3 in + Eq + | PlusS p1', PlusS p4' -> + let (PlusS p2') = p2 in + let Eq = plus_assoc p1' p2' p3 p4' in + Eq (* 3.9 Computing Programs and Properties Simultaneously *) @@ -1671,41 +1664,41 @@ type (_, _) diff = Diff : 'c nat * ('a, 'c, 'b) plus -> ('a, 'b) diff let rec diff : type a b. (a, b) le -> a nat -> b nat -> (a, b) diff = fun le a b -> - match (le, a, b) with - | LeZ _, _, m -> Diff (m, PlusZ m) - | LeS q, NS x, NS y -> ( - match diff q x y with Diff (m, p) -> Diff (m, PlusS p) ) + match (le, a, b) with + | LeZ _, _, m -> Diff (m, PlusZ m) + | LeS q, NS x, NS y -> ( + match diff q x y with Diff (m, p) -> Diff (m, PlusS p) ) let rec diff : type a b. (a, b) le -> a nat -> b nat -> (a, b) diff = fun le a b -> - match (a, b, le) with - (* warning *) - | NZ, m, LeZ _ -> Diff (m, PlusZ m) - | NS x, NS y, LeS q -> ( - match diff q x y with Diff (m, p) -> Diff (m, PlusS p) ) - | _ -> . + match (a, b, le) with + (* warning *) + | NZ, m, LeZ _ -> Diff (m, PlusZ m) + | NS x, NS y, LeS q -> ( + match diff q x y with Diff (m, p) -> Diff (m, PlusS p) ) + | _ -> . let rec diff : type a b. (a, b) le -> b nat -> (a, b) diff = fun le b -> - match (b, le) with - | m, LeZ _ -> Diff (m, PlusZ m) - | NS y, LeS q -> ( match diff q y with Diff (m, p) -> Diff (m, PlusS p) ) + match (b, le) with + | m, LeZ _ -> Diff (m, PlusZ m) + | NS y, LeS q -> ( + match diff q y with Diff (m, p) -> Diff (m, PlusS p) ) type (_, _) filter = Filter : ('m, 'n) le * ('a, 'm) seq -> ('a, 'n) filter let rec leS' : type m n. (m, n) le -> (m, n succ) le = function - | LeZ n -> LeZ (NS n) - | LeS le -> LeS (leS' le) + | LeZ n -> LeZ (NS n) | LeS le -> LeS (leS' le) let rec filter : type a n. (a -> bool) -> (a, n) seq -> (a, n) filter = fun f s -> - match s with - | Snil -> Filter (LeZ NZ, Snil) - | Scons (a, l) -> ( - match filter f l with - | Filter (le, l') -> - if f a then Filter (LeS le, Scons (a, l')) else Filter (leS' le, l') - ) + match s with + | Snil -> Filter (LeZ NZ, Snil) + | Scons (a, l) -> ( + match filter f l with + | Filter (le, l') -> + if f a then Filter (LeS le, Scons (a, l')) else Filter (leS' le, l') + ) (* 4.1 AVL trees *) @@ -1726,9 +1719,9 @@ let empty = Avl Leaf let rec elem : type h. int -> h avl -> bool = fun x t -> - match t with - | Leaf -> false - | Node (_, l, y, r) -> x = y || if x < y then elem x l else elem x r + match t with + | Leaf -> false + | Node (_, l, y, r) -> x = y || if x < y then elem x l else elem x r let rec rotr : type n. n succ succ avl @@ -1736,15 +1729,15 @@ let rec rotr : type n. -> n avl -> (n succ succ avl, n succ succ succ avl) sum = fun tL y tR -> - match tL with - | Node (Same, a, x, b) -> Inr (Node (Less, a, x, Node (More, b, y, tR))) - | Node (More, a, x, b) -> Inl (Node (Same, a, x, Node (Same, b, y, tR))) - | Node (Less, a, x, Node (Same, b, z, c)) -> - Inl (Node (Same, Node (Same, a, x, b), z, Node (Same, c, y, tR))) - | Node (Less, a, x, Node (Less, b, z, c)) -> - Inl (Node (Same, Node (More, a, x, b), z, Node (Same, c, y, tR))) - | Node (Less, a, x, Node (More, b, z, c)) -> - Inl (Node (Same, Node (Same, a, x, b), z, Node (Less, c, y, tR))) + match tL with + | Node (Same, a, x, b) -> Inr (Node (Less, a, x, Node (More, b, y, tR))) + | Node (More, a, x, b) -> Inl (Node (Same, a, x, Node (Same, b, y, tR))) + | Node (Less, a, x, Node (Same, b, z, c)) -> + Inl (Node (Same, Node (Same, a, x, b), z, Node (Same, c, y, tR))) + | Node (Less, a, x, Node (Less, b, z, c)) -> + Inl (Node (Same, Node (More, a, x, b), z, Node (Same, c, y, tR))) + | Node (Less, a, x, Node (More, b, z, c)) -> + Inl (Node (Same, Node (Same, a, x, b), z, Node (Less, c, y, tR))) let rec rotl : type n. n avl @@ -1752,38 +1745,38 @@ let rec rotl : type n. -> n succ succ avl -> (n succ succ avl, n succ succ succ avl) sum = fun tL u tR -> - match tR with - | Node (Same, a, x, b) -> Inr (Node (More, Node (Less, tL, u, a), x, b)) - | Node (Less, a, x, b) -> Inl (Node (Same, Node (Same, tL, u, a), x, b)) - | Node (More, Node (Same, a, x, b), y, c) -> - Inl (Node (Same, Node (Same, tL, u, a), x, Node (Same, b, y, c))) - | Node (More, Node (Less, a, x, b), y, c) -> - Inl (Node (Same, Node (More, tL, u, a), x, Node (Same, b, y, c))) - | Node (More, Node (More, a, x, b), y, c) -> - Inl (Node (Same, Node (Same, tL, u, a), x, Node (Less, b, y, c))) + match tR with + | Node (Same, a, x, b) -> Inr (Node (More, Node (Less, tL, u, a), x, b)) + | Node (Less, a, x, b) -> Inl (Node (Same, Node (Same, tL, u, a), x, b)) + | Node (More, Node (Same, a, x, b), y, c) -> + Inl (Node (Same, Node (Same, tL, u, a), x, Node (Same, b, y, c))) + | Node (More, Node (Less, a, x, b), y, c) -> + Inl (Node (Same, Node (More, tL, u, a), x, Node (Same, b, y, c))) + | Node (More, Node (More, a, x, b), y, c) -> + Inl (Node (Same, Node (Same, tL, u, a), x, Node (Less, b, y, c))) let rec ins : type n. int -> n avl -> (n avl, n succ avl) sum = fun x t -> - match t with - | Leaf -> Inr (Node (Same, Leaf, x, Leaf)) - | Node (bal, a, y, b) -> ( - if x = y then Inl t - else if x < y then - match ins x a with - | Inl a -> Inl (Node (bal, a, y, b)) - | Inr a -> ( - match bal with - | Less -> Inl (Node (Same, a, y, b)) - | Same -> Inr (Node (More, a, y, b)) - | More -> rotr a y b ) - else - match ins x b with - | Inl b -> Inl (Node (bal, a, y, b) : n avl) - | Inr b -> ( - match bal with - | More -> Inl (Node (Same, a, y, b) : n avl) - | Same -> Inr (Node (Less, a, y, b) : n succ avl) - | Less -> rotl a y b ) ) + match t with + | Leaf -> Inr (Node (Same, Leaf, x, Leaf)) + | Node (bal, a, y, b) -> ( + if x = y then Inl t + else if x < y then + match ins x a with + | Inl a -> Inl (Node (bal, a, y, b)) + | Inr a -> ( + match bal with + | Less -> Inl (Node (Same, a, y, b)) + | Same -> Inr (Node (More, a, y, b)) + | More -> rotr a y b ) + else + match ins x b with + | Inl b -> Inl (Node (bal, a, y, b) : n avl) + | Inr b -> ( + match bal with + | More -> Inl (Node (Same, a, y, b) : n avl) + | Same -> Inr (Node (Less, a, y, b) : n succ avl) + | Less -> rotl a y b ) ) let insert x (Avl t) = match ins x t with Inl t -> Avl t | Inr t -> Avl t @@ -1807,41 +1800,44 @@ type _ avl_del = let rec del : type n. int -> n avl -> n avl_del = fun y t -> - match t with - | Leaf -> Dsame Leaf - | Node (bal, l, x, r) -> ( - if x = y then - match r with - | Leaf -> ( - match bal with Same -> Ddecr (Eq, l) | More -> Ddecr (Eq, l) ) - | Node _ -> ( - match (bal, del_min r) with - | _, (z, Inr r) -> Dsame (Node (bal, l, z, r)) - | Same, (z, Inl r) -> Dsame (Node (More, l, z, r)) - | Less, (z, Inl r) -> Ddecr (Eq, Node (Same, l, z, r)) - | More, (z, Inl r) -> ( - match rotr l z r with Inl t -> Ddecr (Eq, t) | Inr t -> Dsame t ) - ) - else if y < x then - match del y l with - | Dsame l -> Dsame (Node (bal, l, x, r)) - | Ddecr (Eq, l) -> ( - match bal with - | Same -> Dsame (Node (Less, l, x, r)) - | More -> Ddecr (Eq, Node (Same, l, x, r)) - | Less -> ( - match rotl l x r with Inl t -> Ddecr (Eq, t) | Inr t -> Dsame t ) - ) - else - match del y r with - | Dsame r -> Dsame (Node (bal, l, x, r)) - | Ddecr (Eq, r) -> ( - match bal with - | Same -> Dsame (Node (More, l, x, r)) - | Less -> Ddecr (Eq, Node (Same, l, x, r)) - | More -> ( - match rotr l x r with Inl t -> Ddecr (Eq, t) | Inr t -> Dsame t ) - ) ) + match t with + | Leaf -> Dsame Leaf + | Node (bal, l, x, r) -> ( + if x = y then + match r with + | Leaf -> ( + match bal with Same -> Ddecr (Eq, l) | More -> Ddecr (Eq, l) ) + | Node _ -> ( + match (bal, del_min r) with + | _, (z, Inr r) -> Dsame (Node (bal, l, z, r)) + | Same, (z, Inl r) -> Dsame (Node (More, l, z, r)) + | Less, (z, Inl r) -> Ddecr (Eq, Node (Same, l, z, r)) + | More, (z, Inl r) -> ( + match rotr l z r with + | Inl t -> Ddecr (Eq, t) + | Inr t -> Dsame t ) ) + else if y < x then + match del y l with + | Dsame l -> Dsame (Node (bal, l, x, r)) + | Ddecr (Eq, l) -> ( + match bal with + | Same -> Dsame (Node (Less, l, x, r)) + | More -> Ddecr (Eq, Node (Same, l, x, r)) + | Less -> ( + match rotl l x r with + | Inl t -> Ddecr (Eq, t) + | Inr t -> Dsame t ) ) + else + match del y r with + | Dsame r -> Dsame (Node (bal, l, x, r)) + | Ddecr (Eq, r) -> ( + match bal with + | Same -> Dsame (Node (More, l, x, r)) + | Less -> Ddecr (Eq, Node (Same, l, x, r)) + | More -> ( + match rotr l x r with + | Inl t -> Ddecr (Eq, t) + | Inr t -> Dsame t ) ) ) let delete x (Avl t) = match del x t with Dsame t -> Avl t | Ddecr (_, t) -> Avl t @@ -1879,18 +1875,16 @@ let blacken = function Rnode (l, e, r) -> Bnode (l, e, r) type _ crep = Red : red crep | Black : black crep let color : type c n. (c, n) sub_tree -> c crep = function - | Bleaf -> Black - | Rnode _ -> Red - | Bnode _ -> Black + | Bleaf -> Black | Rnode _ -> Red | Bnode _ -> Black let rec fill : type c n. (c, n) ctxt -> (c, n) sub_tree -> rb_tree = fun ct t -> - match ct with - | CNil -> Root t - | CRed (e, LeftD, uncle, c) -> fill c (Rnode (uncle, e, t)) - | CRed (e, RightD, uncle, c) -> fill c (Rnode (t, e, uncle)) - | CBlk (e, LeftD, uncle, c) -> fill c (Bnode (uncle, e, t)) - | CBlk (e, RightD, uncle, c) -> fill c (Bnode (t, e, uncle)) + match ct with + | CNil -> Root t + | CRed (e, LeftD, uncle, c) -> fill c (Rnode (uncle, e, t)) + | CRed (e, RightD, uncle, c) -> fill c (Rnode (t, e, uncle)) + | CBlk (e, LeftD, uncle, c) -> fill c (Bnode (uncle, e, t)) + | CBlk (e, RightD, uncle, c) -> fill c (Bnode (t, e, uncle)) let recolor d1 pE sib d2 gE uncle t = match (d1, d2) with @@ -1908,25 +1902,25 @@ let rotate d1 pE sib d2 gE uncle (Rnode (x, e, y)) = let rec repair : type c n. (red, n) sub_tree -> (c, n) ctxt -> rb_tree = fun t ct -> - match ct with - | CNil -> Root (blacken t) - | CBlk (e, LeftD, sib, c) -> fill c (Bnode (sib, e, t)) - | CBlk (e, RightD, sib, c) -> fill c (Bnode (t, e, sib)) - | CRed (e, dir, sib, CBlk (e', dir', uncle, ct)) -> ( - match color uncle with - | Red -> repair (recolor dir e sib dir' e' (blacken uncle) t) ct - | Black -> fill ct (rotate dir e sib dir' e' uncle t) ) + match ct with + | CNil -> Root (blacken t) + | CBlk (e, LeftD, sib, c) -> fill c (Bnode (sib, e, t)) + | CBlk (e, RightD, sib, c) -> fill c (Bnode (t, e, sib)) + | CRed (e, dir, sib, CBlk (e', dir', uncle, ct)) -> ( + match color uncle with + | Red -> repair (recolor dir e sib dir' e' (blacken uncle) t) ct + | Black -> fill ct (rotate dir e sib dir' e' uncle t) ) let rec ins : type c n. int -> (c, n) sub_tree -> (c, n) ctxt -> rb_tree = fun e t ct -> - match t with - | Rnode (l, e', r) -> - if e < e' then ins e l (CRed (e', RightD, r, ct)) - else ins e r (CRed (e', LeftD, l, ct)) - | Bnode (l, e', r) -> - if e < e' then ins e l (CBlk (e', RightD, r, ct)) - else ins e r (CBlk (e', LeftD, l, ct)) - | Bleaf -> repair (Rnode (Bleaf, e, Bleaf)) ct + match t with + | Rnode (l, e', r) -> + if e < e' then ins e l (CRed (e', RightD, r, ct)) + else ins e r (CRed (e', LeftD, l, ct)) + | Bnode (l, e', r) -> + if e < e' then ins e l (CBlk (e', RightD, r, ct)) + else ins e r (CBlk (e', LeftD, l, ct)) + | Bleaf -> repair (Rnode (Bleaf, e, Bleaf)) ct let insert e (Root t) = ins e t CNil @@ -1960,32 +1954,31 @@ type (_, _) equal = Eq : ('a, 'a) equal let rec rep_equal : type a b. a rep -> b rep -> (a, b) equal option = fun ra rb -> - match (ra, rb) with - | Rint, Rint -> Some Eq - | Rbool, Rbool -> Some Eq - | Rpair (a1, a2), Rpair (b1, b2) -> ( - match rep_equal a1 b1 with - | None -> None - | Some Eq -> ( - match rep_equal a2 b2 with None -> None | Some Eq -> Some Eq ) ) - | Rfun (a1, a2), Rfun (b1, b2) -> ( - match rep_equal a1 b1 with - | None -> None - | Some Eq -> ( - match rep_equal a2 b2 with None -> None | Some Eq -> Some Eq ) ) - | _ -> None + match (ra, rb) with + | Rint, Rint -> Some Eq + | Rbool, Rbool -> Some Eq + | Rpair (a1, a2), Rpair (b1, b2) -> ( + match rep_equal a1 b1 with + | None -> None + | Some Eq -> ( + match rep_equal a2 b2 with None -> None | Some Eq -> Some Eq ) ) + | Rfun (a1, a2), Rfun (b1, b2) -> ( + match rep_equal a1 b1 with + | None -> None + | Some Eq -> ( + match rep_equal a2 b2 with None -> None | Some Eq -> Some Eq ) ) + | _ -> None type assoc = Assoc : string * 'a rep * 'a -> assoc let rec assoc : type a. string -> a rep -> assoc list -> a = - fun x r -> function - | [] -> raise Not_found - | Assoc (x', r', v) :: env -> - if x = x' then - match rep_equal r r' with - | None -> failwith ("Wrong type for " ^ x) - | Some Eq -> v - else assoc x r env + fun x r ->function [] -> raise Not_found + | Assoc (x', r', v) :: env -> + if x = x' then + match rep_equal r r' with + | None -> failwith ("Wrong type for " ^ x) + | Some Eq -> v + else assoc x r env type _ term = | Var : string * 'a rep -> 'a term @@ -1997,14 +1990,11 @@ type _ term = | Pair : 'a term * 'b term -> ('a * 'b) term let rec eval_term : type a. assoc list -> a term -> a = - fun env -> function - | Var (x, r) -> assoc x r env - | Abs (x, r, e) -> fun v -> eval_term (Assoc (x, r, v) :: env) e - | Const x -> x - | Add -> fun (x, y) -> x + y - | LT -> fun (x, y) -> x < y - | Ap (f, x) -> eval_term env f (eval_term env x) - | Pair (x, y) -> (eval_term env x, eval_term env y) + fun env ->function Var (x, r) -> assoc x r env + | Abs (x, r, e) -> fun v -> eval_term (Assoc (x, r, v) :: env) e + | Const x -> x | Add -> fun (x, y) -> x + y | LT -> fun (x, y) -> x < y + | Ap (f, x) -> eval_term env f (eval_term env x) + | Pair (x, y) -> (eval_term env x, eval_term env y) let ex3 = Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint)))) @@ -2043,12 +2033,12 @@ type _ env = let rec eval_lam : type e t. e env -> (e, t) lam -> t = fun env m -> - match (env, m) with - | _, Const n -> n - | Econs (_, v, r), Var _ -> v - | Econs (_, _, r), Shift e -> eval_lam r e - | _, Abs (n, body) -> fun x -> eval_lam (Econs (n, x, env)) body - | _, App (f, x) -> eval_lam env f (eval_lam env x) + match (env, m) with + | _, Const n -> n + | Econs (_, v, r), Var _ -> v + | Econs (_, _, r), Shift e -> eval_lam r e + | _, Abs (n, body) -> fun x -> eval_lam (Econs (n, x, env)) body + | _, App (f, x) -> eval_lam env f (eval_lam env x) type add = Add @@ -2083,15 +2073,15 @@ type _ rep = I : int rep | Ar : 'a rep * 'b rep -> ('a -> 'b) rep let rec compare : type a b. a rep -> b rep -> (string, (a, b) equal) sum = fun a b -> - match (a, b) with - | I, I -> Inr Eq - | Ar (x, y), Ar (s, t) -> ( - match compare x s with - | Inl _ as e -> e - | Inr Eq -> ( - match compare y t with Inl _ as e -> e | Inr Eq as e -> e ) ) - | I, Ar _ -> Inl "I <> Ar _" - | Ar _, I -> Inl "Ar _ <> I" + match (a, b) with + | I, I -> Inr Eq + | Ar (x, y), Ar (s, t) -> ( + match compare x s with + | Inl _ as e -> e + | Inr Eq -> ( + match compare y t with Inl _ as e -> e | Inr Eq as e -> e ) ) + | I, Ar _ -> Inl "I <> Ar _" + | Ar _, I -> Inl "Ar _ <> I" type term = | C of int @@ -2109,37 +2099,37 @@ type _ checked = let rec lookup : type e. string -> e ctx -> e checked = fun name ctx -> - match ctx with - | Cnil -> Cerror ("Name not found: " ^ name) - | Ccons (l, s, t, rs) -> ( - if s = name then Cok (Var l, t) - else - match lookup name rs with - | Cerror m -> Cerror m - | Cok (v, t) -> Cok (Shift v, t) ) + match ctx with + | Cnil -> Cerror ("Name not found: " ^ name) + | Ccons (l, s, t, rs) -> ( + if s = name then Cok (Var l, t) + else + match lookup name rs with + | Cerror m -> Cerror m + | Cok (v, t) -> Cok (Shift v, t) ) let rec tc : type n e. n nat -> e ctx -> term -> e checked = fun n ctx t -> - match t with - | V s -> lookup s ctx - | Ap (f, x) -> ( - match tc n ctx f with - | Cerror _ as e -> e - | Cok (f', ft) -> ( - match tc n ctx x with - | Cerror _ as e -> e - | Cok (x', xt) -> ( - match ft with - | Ar (a, b) -> ( - match compare a xt with - | Inl s -> Cerror s - | Inr Eq -> Cok (App (f', x'), b) ) - | _ -> Cerror "Non fun in Ap" ) ) ) - | Ab (s, t, body) -> ( - match tc (NS n) (Ccons (n, s, t, ctx)) body with - | Cerror _ as e -> e - | Cok (body', et) -> Cok (Abs (n, body'), Ar (t, et)) ) - | C m -> Cok (Const m, I) + match t with + | V s -> lookup s ctx + | Ap (f, x) -> ( + match tc n ctx f with + | Cerror _ as e -> e + | Cok (f', ft) -> ( + match tc n ctx x with + | Cerror _ as e -> e + | Cok (x', xt) -> ( + match ft with + | Ar (a, b) -> ( + match compare a xt with + | Inl s -> Cerror s + | Inr Eq -> Cok (App (f', x'), b) ) + | _ -> Cerror "Non fun in Ap" ) ) ) + | Ab (s, t, body) -> ( + match tc (NS n) (Ccons (n, s, t, ctx)) body with + | Cerror _ as e -> e + | Cok (body', et) -> Cok (Abs (n, body'), Ar (t, et)) ) + | C m -> Cok (Const m, I) let ctx0 = Ccons @@ -2211,17 +2201,17 @@ type (_, _) lam' = Ex : ('m, 's, 't) lam -> ('s, 't) lam' let rec subst : type m1 r t s. (m1, r, t) lam -> (r, s) sub -> (s, t) lam' = fun t s -> - match (t, s) with - | _, Id -> Ex t - | Const (r, c), sub -> Ex (Const (r, c)) - | Var v, Bind (x, e, r) -> Ex e - | Var v, Push sub -> Ex (Var v) - | Shift e, Bind (_, _, r) -> subst e r - | Shift e, Push sub -> ( match subst e sub with Ex a -> Ex (Shift a) ) - | App (f, x), sub -> ( - match (subst f sub, subst x sub) with Ex g, Ex y -> Ex (App (g, y)) ) - | Lam (v, x), sub -> ( - match subst x (Push sub) with Ex body -> Ex (Lam (v, body)) ) + match (t, s) with + | _, Id -> Ex t + | Const (r, c), sub -> Ex (Const (r, c)) + | Var v, Bind (x, e, r) -> Ex e + | Var v, Push sub -> Ex (Var v) + | Shift e, Bind (_, _, r) -> subst e r + | Shift e, Push sub -> ( match subst e sub with Ex a -> Ex (Shift a) ) + | App (f, x), sub -> ( + match (subst f sub, subst x sub) with Ex g, Ex y -> Ex (App (g, y)) ) + | Lam (v, x), sub -> ( + match subst x (Push sub) with Ex body -> Ex (Lam (v, body)) ) type closed = rnil @@ -2230,12 +2220,12 @@ type 'a rlam = ((pexp, closed, 'a) lam, (pval, closed, 'a) lam) sum let rec rule : type a b. (pval, closed, (a, b) tarr) lam -> (pval, closed, a) lam -> b rlam = fun v1 v2 -> - match (v1, v2) with - | Lam (x, body), v -> ( - match subst body (Bind (x, v, Id)) with - | Ex term -> ( - match mode term with Pexp -> Inl term | Pval -> Inr term ) ) - | Const (IntTo b, f), Const (IntR, x) -> Inr (Const (b, f x)) + match (v1, v2) with + | Lam (x, body), v -> ( + match subst body (Bind (x, v, Id)) with + | Ex term -> ( + match mode term with Pexp -> Inl term | Pval -> Inr term ) ) + | Const (IntTo b, f), Const (IntR, x) -> Inr (Const (b, f x)) let rec onestep : type m t. (m, closed, t) lam -> t rlam = function | Lam (v, body) -> Inr (Lam (v, body)) @@ -2263,11 +2253,11 @@ type ('env, 'a) typ = let f : type env a. (env, a) typ -> (env, a) typ -> int = fun ta tb -> - match (ta, tb) with - | Tint, Tint -> 0 - | Tbool, Tbool -> 1 - | Tvar var, tb -> 2 - | _ -> . (* error *) + match (ta, tb) with + | Tint, Tint -> 0 + | Tbool, Tbool -> 1 + | Tvar var, tb -> 2 + | _ -> . (* error *) (* let x = f Tint (Tvar Zero) ;; *) type inkind = [`Link | `Nonlink] @@ -2313,14 +2303,15 @@ type _ linkp = Nonlink : [`Nonlink] linkp | Maylink : inkind linkp let inlineseq_from_astseq seq = let rec process : type a. a linkp -> ast_t -> a inline_t = fun allow_link ast -> - match (allow_link, ast) with - | Maylink, Ast_Text txt -> Text txt - | Nonlink, Ast_Text txt -> Text txt - | x, Ast_Bold xs -> Bold (List.map (process x) xs) - | Maylink, Ast_Link lnk -> Link lnk - | Nonlink, Ast_Link _ -> assert false - | Maylink, Ast_Mref (lnk, xs) -> Mref (lnk, List.map (process Nonlink) xs) - | Nonlink, Ast_Mref _ -> assert false + match (allow_link, ast) with + | Maylink, Ast_Text txt -> Text txt + | Nonlink, Ast_Text txt -> Text txt + | x, Ast_Bold xs -> Bold (List.map (process x) xs) + | Maylink, Ast_Link lnk -> Link lnk + | Nonlink, Ast_Link _ -> assert false + | Maylink, Ast_Mref (lnk, xs) -> + Mref (lnk, List.map (process Nonlink) xs) + | Nonlink, Ast_Mref _ -> assert false in List.map (process Maylink) seq @@ -2330,14 +2321,14 @@ type _ linkp2 = Kind : 'a linkp -> ([< inkind] as 'a) linkp2 let inlineseq_from_astseq seq = let rec process : type a. a linkp2 -> ast_t -> a inline_t = fun allow_link ast -> - match (allow_link, ast) with - | Kind _, Ast_Text txt -> Text txt - | x, Ast_Bold xs -> Bold (List.map (process x) xs) - | Kind Maylink, Ast_Link lnk -> Link lnk - | Kind Nonlink, Ast_Link _ -> assert false - | Kind Maylink, Ast_Mref (lnk, xs) -> - Mref (lnk, List.map (process (Kind Nonlink)) xs) - | Kind Nonlink, Ast_Mref _ -> assert false + match (allow_link, ast) with + | Kind _, Ast_Text txt -> Text txt + | x, Ast_Bold xs -> Bold (List.map (process x) xs) + | Kind Maylink, Ast_Link lnk -> Link lnk + | Kind Nonlink, Ast_Link _ -> assert false + | Kind Maylink, Ast_Mref (lnk, xs) -> + Mref (lnk, List.map (process (Kind Nonlink)) xs) + | Kind Nonlink, Ast_Mref _ -> assert false in List.map (process (Kind Maylink)) seq @@ -2348,8 +2339,7 @@ struct type _ t = One : [`One] t | Two : T.two t let add (type a) : a t * a t -> string = function - | One, One -> "two" - | Two, Two -> "four" + | One, One -> "two" | Two, Two -> "four" end module B : sig @@ -2399,9 +2389,9 @@ type _ wrapPoly = let example6 : type a. a wrapPoly -> a -> int = fun w -> - match w with - | WrapPoly ATag -> intA - | WrapPoly _ -> intA (* This should not be allowed *) + match w with + | WrapPoly ATag -> intA + | WrapPoly _ -> intA (* This should not be allowed *) let _ = example6 (WrapPoly AandBTags) `TagB (* This causes a seg fault *) @@ -2413,7 +2403,7 @@ struct let f : int S.t ab -> float S.t ab -> string = fun (l : int S.t ab) (r : float S.t ab) -> - match (l, r) with A, B -> "f A B" + match (l, r) with A, B -> "f A B" end module F (S : sig @@ -2560,20 +2550,26 @@ type ('a, 'result, 'visit_action) context = | Local : ('a, ('a * insert as 'result), 'a local_visit_action) context | Global : ('a, 'a, 'a visit_action) context -let vexpr (type visit_action) : - (_, _, visit_action) context -> _ -> visit_action = function - | Local -> fun _ -> raise Exit - | Global -> fun _ -> raise Exit - -let vexpr (type visit_action) : - ('a, 'result, visit_action) context -> 'a -> visit_action = function - | Local -> fun _ -> raise Exit - | Global -> fun _ -> raise Exit +let vexpr (type visit_action) : (_, _, visit_action) context + -> _ + -> visit_action = + function + | Local -> fun _ -> raise Exit | Global -> fun _ -> raise Exit -let vexpr (type result) (type visit_action) : - (unit, result, visit_action) context -> unit -> visit_action = function - | Local -> fun _ -> raise Exit - | Global -> fun _ -> raise Exit +let vexpr (type visit_action) : ('a, 'result, visit_action) context + -> 'a + -> visit_action = + function + | Local -> fun _ -> raise Exit | Global -> fun _ -> raise Exit + +let vexpr (type result) (type visit_action) : ( unit + , result + , visit_action ) + context + -> unit + -> visit_action = + function + | Local -> fun _ -> raise Exit | Global -> fun _ -> raise Exit module A = struct type nil = Cstr @@ -2591,9 +2587,9 @@ type _ lst = CNil : nil lst | CCons : 'h * 't lst -> ('h -> 't) lst let rec get_var : type stk ret. (stk s, ret) var -> stk lst -> ret = fun n s -> - match (n, s) with - | Head, CCons (h, _) -> h - | Tail n', CCons (_, t) -> get_var n' t + match (n, s) with + | Head, CCons (h, _) -> h + | Tail n', CCons (_, t) -> get_var n' t type 'a t = [< `Foo | `Bar] as 'a @@ -2641,8 +2637,7 @@ let get1 (Cons (x, _) : (_ * 'a, 'a) t) = x (* warn, cf PR#6993 *) let get1' = function - | (Cons (x, _) : (_ * 'a, 'a) t) -> x - | Nil -> assert false + | (Cons (x, _) : (_ * 'a, 'a) t) -> x | Nil -> assert false (* ok *) type _ t = @@ -2695,8 +2690,8 @@ type _ t = Nil : nil t | Cons : ('x, 'fx) elt * 'x t -> 'fx t let undetected : ('a -> 'b -> nil) t -> 'a n -> 'b n -> unit = fun sh i j -> - let (Cons (Elt dim, _)) = sh in - () + let (Cons (Elt dim, _)) = sh in + () type _ t = T : int t @@ -2764,34 +2759,34 @@ let comp_subst f g (x : 'a fin) = pre_subst f (g x) let rec thin : type n. n succ fin -> n fin -> n succ fin = fun x y -> - match (x, y) with - | FZ, y -> FS y - | FS x, FZ -> FZ - | FS x, FS y -> FS (thin x y) + match (x, y) with + | FZ, y -> FS y + | FS x, FZ -> FZ + | FS x, FS y -> FS (thin x y) let bind t f = match t with None -> None | Some x -> f x (* val bind : 'a option -> ('a -> 'b option) -> 'b option *) let rec thick : type n. n succ fin -> n succ fin -> n fin option = fun x y -> - match (x, y) with - | FZ, FZ -> None - | FZ, FS y -> Some y - | FS x, FZ -> - let IS = fin_succ x in - Some FZ - | FS x, FS y -> - let IS = fin_succ x in - bind (thick x y) (fun x -> Some (FS x)) + match (x, y) with + | FZ, FZ -> None + | FZ, FS y -> Some y + | FS x, FZ -> + let IS = fin_succ x in + Some FZ + | FS x, FS y -> + let IS = fin_succ x in + bind (thick x y) (fun x -> Some (FS x)) let rec check : type n. n succ fin -> n succ term -> n term option = fun x t -> - match t with - | Var y -> bind (thick x y) (fun x -> Some (Var x)) - | Leaf -> Some Leaf - | Fork (t1, t2) -> - bind (check x t1) (fun t1 -> - bind (check x t2) (fun t2 -> Some (Fork (t1, t2))) ) + match t with + | Var y -> bind (thick x y) (fun x -> Some (Var x)) + | Leaf -> Some Leaf + | Fork (t1, t2) -> + bind (check x t1) (fun t1 -> + bind (check x t2) (fun t2 -> Some (Fork (t1, t2))) ) let subst_var x t' y = match thick x y with None -> t' | Some y' -> Var y' (* val subst_var : 'a succ fin -> 'a term -> 'a succ fin -> 'a term *) @@ -2806,12 +2801,11 @@ type (_, _) alist = | Asnoc : ('m, 'n) alist * 'm term * 'm succ fin -> ('m succ, 'n) alist let rec sub : type m n. (m, n) alist -> m fin -> n term = function - | Anil -> var - | Asnoc (s, t, x) -> comp_subst (sub s) (subst_var x t) + | Anil -> var | Asnoc (s, t, x) -> comp_subst (sub s) (subst_var x t) let rec append : type m n l. (m, n) alist -> (l, m) alist -> (l, n) alist = fun r s -> - match s with Anil -> r | Asnoc (s, t, x) -> Asnoc (append r s, t, x) + match s with Anil -> r | Asnoc (s, t, x) -> Asnoc (append r s, t, x) type _ ealist = EAlist : ('a, 'b) alist -> 'a ealist @@ -2819,8 +2813,7 @@ let asnoc a t' x = EAlist (Asnoc (a, t', x)) (* Extra work: we need sub to work on ealist too, for examples *) let rec weaken_fin : type n. n fin -> n succ fin = function - | FZ -> FZ - | FS x -> FS (weaken_fin x) + | FZ -> FZ | FS x -> FS (weaken_fin x) let weaken_term t = pre_subst (fun x -> Var (weaken_fin x)) t @@ -2852,24 +2845,24 @@ let flex_rigid x t = bind (check x t) (fun t' -> Some (asnoc Anil t' x)) let rec amgu : type m. m term -> m term -> m ealist -> m ealist option = fun s t acc -> - match (s, t, acc) with - | Leaf, Leaf, _ -> Some acc - | Leaf, Fork _, _ -> None - | Fork _, Leaf, _ -> None - | Fork (s1, s2), Fork (t1, t2), _ -> bind (amgu s1 t1 acc) (amgu s2 t2) - | Var x, Var y, EAlist Anil -> - let IS = fin_succ x in - Some (flex_flex x y) - | Var x, t, EAlist Anil -> - let IS = fin_succ x in - flex_rigid x t - | t, Var x, EAlist Anil -> - let IS = fin_succ x in - flex_rigid x t - | s, t, EAlist (Asnoc (d, r, z)) -> - bind - (amgu (subst z r s) (subst z r t) (EAlist d)) - (fun (EAlist d) -> Some (asnoc d r z)) + match (s, t, acc) with + | Leaf, Leaf, _ -> Some acc + | Leaf, Fork _, _ -> None + | Fork _, Leaf, _ -> None + | Fork (s1, s2), Fork (t1, t2), _ -> bind (amgu s1 t1 acc) (amgu s2 t2) + | Var x, Var y, EAlist Anil -> + let IS = fin_succ x in + Some (flex_flex x y) + | Var x, t, EAlist Anil -> + let IS = fin_succ x in + flex_rigid x t + | t, Var x, EAlist Anil -> + let IS = fin_succ x in + flex_rigid x t + | s, t, EAlist (Asnoc (d, r, z)) -> + bind + (amgu (subst z r s) (subst z r t) (EAlist d)) + (fun (EAlist d) -> Some (asnoc d r z)) let mgu s t = amgu s t (EAlist Anil) (* val mgu : 'a term -> 'a term -> 'a ealist option *) @@ -2890,53 +2883,51 @@ type (_, _) eq = Refl : ('a, 'a) eq let magic : 'a 'b. 'a -> 'b = fun (type a b) (x : a) -> - let module M = - (functor - (T : sig - type 'a t + let module M = + (functor + (T : sig + type 'a t + end) + -> + struct + let f (Refl : (a T.t, b T.t) eq) = (x :> b) end) - -> - struct - let f (Refl : (a T.t, b T.t) eq) = (x :> b) - end) - (struct - type 'a t = unit - end) - in - M.f Refl + (struct + type 'a t = unit + end) + in + M.f Refl (* Variance and subtyping *) type (_, +_) eq = Refl : ('a, 'a) eq let magic : 'a 'b. 'a -> 'b = - fun (type a b) (x : a) -> - let bad_proof (type a) = - (Refl : (< m: a >, < m: a >) eq :> (< m: a >, < >) eq) - in - let downcast : type a. (a, < >) eq -> < > -> a = - fun (type a) (Refl : (a, < >) eq) (s : < >) -> (s :> a) - in - (downcast bad_proof - ( object - method m = x - end - :> < > ) ) - #m + fun (type a) (type b) (x : a) -> + let bad_proof (type a) = + (Refl : (< m: a >, < m: a >) eq :> (< m: a >, < >) eq) + in + let downcast : type a. (a, < >) eq -> < > -> a = + fun (type a) (Refl : (a, < >) eq) (s : < >) -> (s :> a) + in + (downcast bad_proof + ( object + method m = x + end + :> < > ) ) + #m (* Record patterns *) type _ t = IntLit : int t | BoolLit : bool t let check : type s. s t * s -> bool = function - | BoolLit, false -> false - | IntLit, 6 -> false + | BoolLit, false -> false | IntLit, 6 -> false type ('a, 'b) pair = {fst: 'a; snd: 'b} let check : type s. (s t, s) pair -> bool = function - | {fst= BoolLit; snd= false} -> false - | {fst= IntLit; snd= 6} -> false + | {fst= BoolLit; snd= false} -> false | {fst= IntLit; snd= 6} -> false module type S = sig type t [@@immediate] @@ -3364,12 +3355,12 @@ open Typ let rec to_string : 'a. 'a Typ.typ -> 'a -> string = fun (type s) t x -> - match (t : s typ) with - | Int eq -> string_of_int (TypEq.apply eq x) - | String eq -> Printf.sprintf "%S" (TypEq.apply eq x) - | Pair (module P) -> - let x1, x2 = TypEq.apply P.eq x in - Printf.sprintf "(%s,%s)" (to_string P.t1 x1) (to_string P.t2 x2) + match (t : s typ) with + | Int eq -> string_of_int (TypEq.apply eq x) + | String eq -> Printf.sprintf "%S" (TypEq.apply eq x) + | Pair (module P) -> + let x1, x2 = TypEq.apply P.eq x in + Printf.sprintf "(%s,%s)" (to_string P.t1 x1) (to_string P.t2 x2) (* Wrapping maps *) module type MapT = sig @@ -4047,12 +4038,12 @@ let int_of_sexp _ = 42 let t_of_sexp : 'a. (sexp -> 'a) -> sexp -> 'a t = let _tp_loc = "core_array.ml.t" in - fun _of_a t -> (array_of_sexp _of_a) t + fun _of_a -> fun t -> (array_of_sexp _of_a) t let _ = t_of_sexp let sexp_of_t : 'a. ('a -> sexp) -> 'a t -> sexp = - fun _of_a v -> (sexp_of_array _of_a) v + fun _of_a -> fun v -> (sexp_of_array _of_a) v let _ = sexp_of_t @@ -4103,16 +4094,18 @@ end = struct let _ = fun (_ : ('a, 'perms) t) -> () - let t_of_sexp : - 'a 'perms. (sexp -> 'a) -> (sexp -> 'perms) -> sexp -> ('a, 'perms) t = + let t_of_sexp : 'a 'perms. + (sexp -> 'a) -> (sexp -> 'perms) -> sexp -> ('a, 'perms) t + = let _tp_loc = "core_array.ml.Permissioned.t" in - fun _of_a _of_perms t -> (array_of_sexp _of_a) t + fun _of_a -> fun _of_perms -> fun t -> (array_of_sexp _of_a) t let _ = t_of_sexp - let sexp_of_t : - 'a 'perms. ('a -> sexp) -> ('perms -> sexp) -> ('a, 'perms) t -> sexp = - fun _of_a _of_perms v -> (sexp_of_array _of_a) v + let sexp_of_t : 'a 'perms. + ('a -> sexp) -> ('perms -> sexp) -> ('a, 'perms) t -> sexp + = + fun _of_a -> fun _of_perms -> fun v -> (sexp_of_array _of_a) v let _ = sexp_of_t @@ -4125,12 +4118,12 @@ end = struct let t_of_sexp : 'perms. (sexp -> 'perms) -> sexp -> 'perms t = let _tp_loc = "core_array.ml.Permissioned.Int.t" in - fun _of_perms t -> t__of_sexp t + fun _of_perms -> fun t -> t__of_sexp t let _ = t_of_sexp let sexp_of_t : 'perms. ('perms -> sexp) -> 'perms t -> sexp = - fun _of_perms v -> sexp_of_t_ v + fun _of_perms -> fun v -> sexp_of_t_ v let _ = sexp_of_t end @@ -6406,9 +6399,7 @@ module Fpc (X : T with type term = private [> 'a termpc] as 'a) = struct type term = X.term termpc let nnf = function - | `Not (`Atom _) as x -> x - | `Not x -> X.nnf_not x - | x -> X.map X.nnf x + | `Not (`Atom _) as x -> x | `Not x -> X.nnf_not x | x -> X.map X.nnf x let map f : term -> X.term = function | `Not x -> `Not (f x) @@ -6509,7 +6500,7 @@ end = M1 ;; -fun (x : M1.t) : M2.t -> x +fun (x : M1.t) -> (x : M2.t) (* fails *) @@ -7454,8 +7445,7 @@ struct let findMin = function E -> raise Not_found | T (_, x, _, _) -> x let deleteMin = function - | E -> raise Not_found - | T (_, x, a, b) -> merge a b + | E -> raise Not_found | T (_, x, a, b) -> merge a b end module Ints = struct @@ -8398,9 +8388,9 @@ let f : type a b c d e f g. * v * (a, b, c, d) u * (e, f, g, g) u - -> int = function - | A, A, A, A, A, A, A, _, U, U -> 1 - | _, _, _, _, _, _, _, G, _, _ -> 1 + -> int = + function + | A, A, A, A, A, A, A, _, U, U -> 1 | _, _, _, _, _, _, _, G, _, _ -> 1 (*| _ -> _ *) (* Unused cases *) @@ -8478,8 +8468,7 @@ let harder : (zero succ, zero succ, zero succ) plus option -> bool = function | None -> false let harder : (zero succ, zero succ, zero succ) plus option -> bool = function - | None -> false - | Some (PlusS _) -> . + | None -> false | Some (PlusS _) -> . let inv_zero : type a b c d. (a, b, c) plus -> (c, d, zero) plus -> bool = fun p1 p2 -> match (p1, p2) with Plus0, Plus0 -> true @@ -8955,15 +8944,10 @@ let f = function (x [@wee]) -> () let f = function '1' .. '9' | '1' .. '8' -> () | 'a' .. 'z' -> () let f = function - | [|x1; x2|] -> () - | [||] -> () - | ([|x|] [@foo]) -> () - | _ -> () + | [|x1; x2|] -> () | [||] -> () | ([|x|] [@foo]) -> () | _ -> () let g = function - | {l= x} -> () - | ({l1= x; l2= y} [@foo]) -> () - | {l1= x; l2= y; _} -> () + | {l= x} -> () | ({l1= x; l2= y} [@foo]) -> () | {l1= x; l2= y; _} -> () let h = fun ?l:(p = 1) ?y:u ?(x = 3) -> 2 @@ -9041,9 +9025,9 @@ let f : type a'. a' = assert false let foo : type a' b'. a' -> b' = fun a -> assert false -let foo : type t'. t' = fun (type t') : t' -> assert false +let foo : type t'. t' = fun (type t') -> (assert false : t') -let foo : 't. 't = fun (type t) : t -> assert false +let foo : 't. 't = fun (type t) -> (assert false : t) let foo : type a' b' c' t. a' -> b' -> c' -> t = fun a b c -> assert false @@ -9160,31 +9144,28 @@ let formula_base x = #&& (x #<= (Expr.int 4)) #&& ((Expr.int 0) #< x) -let _ = call ~f:(fun pair : (a * b) -> pair) ;; +let _ = call ~f:(fun pair -> (pair : a * b)) ;; f - (fun _ -> function + (fun _ ->function | true -> let () = () in - () - | false -> () ) + () | false -> () ) () ;; f - (fun _ -> function + (fun _ ->function | true -> let () = () in - () - (* comment *) - | false -> () ) + () (* comment *) | false -> () ) () let xxxxxx = let%map (* _____________________________ __________ *) () = yyyyyyyy in {zzzzzzzzzzzzz} -let _ = fun (x : int as 'a) : (int as 'a) -> x +let _ = fun (x : int as 'a) -> (x : int as 'a) let eradicate_meta_class_is_nullsafe = register ~id:"ERADICATE_META_CLASS_IS_NULLSAFE" diff --git a/test/rpc/rpc_test.expected b/test/rpc/rpc_test.expected index cc1322656b..a2970edc4f 100644 --- a/test/rpc/rpc_test.expected +++ b/test/rpc/rpc_test.expected @@ -75,12 +75,11 @@ let ssmap () ' Output: -let ssmap : - (module MapT - with type key = string - and type data = string - and type map = SSMap.map) -> - unit = +let ssmap : (module MapT + with type key = string + and type data = string + and type map = SSMap.map) -> + unit = () [ocf] Config @@ -97,7 +96,7 @@ let ssmap Output: let ssmap : (module MapT with type key = string and type data = string and type map = SSMap.map) - -> unit + -> unit = () ;; From f502604c289e1a5619460978a655328747a1772a Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Tue, 16 Apr 2024 15:53:34 +0200 Subject: [PATCH 033/146] Add missing wrap_intro space --- lib/Fmt_ast.ml | 4 ++-- test/passing/tests/pre_post_extensions.ml | 8 ++++---- test/passing/tests/revapply_ext.ml | 4 ++-- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index da6d335b57..8dea9f7e00 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1811,7 +1811,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens (fmt_function ~ctx:(Exp call) ~wrap_intro:(fun x -> ( str "%" $ hovbox 2 - ( fmt_str_loc c name $ space_break $ x))) + ( fmt_str_loc c name $ space_break $ x))$space_break) ~label:Nolabel ~parens:false ~attrs:call.pexp_attributes ~loc:call.pexp_loc c (args, typ, body) ) ) @@ -1839,7 +1839,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens (fmt_function ~ctx:(Exp retn) ~wrap_intro:(fun x -> ( str "%" $ hovbox 2 - ( fmt_str_loc c name $ space_break $ x))) + ( fmt_str_loc c name $ space_break $ x))$space_break) ~label:Nolabel ~parens:false ~attrs:retn.pexp_attributes ~loc:retn.pexp_loc c (args, typ, body) ) ) ) ) diff --git a/test/passing/tests/pre_post_extensions.ml b/test/passing/tests/pre_post_extensions.ml index 441165ad8a..ef52df32ba 100644 --- a/test/passing/tests/pre_post_extensions.ml +++ b/test/passing/tests/pre_post_extensions.ml @@ -1,15 +1,15 @@ let f x = - [%Trace.call fun {pf} ->pf "%i" x] + [%Trace.call fun {pf} -> pf "%i" x] ; print_int x ; x |> - [%Trace.retn fun {pf} ->pf "%i"] + [%Trace.retn fun {pf} -> pf "%i"] let f x = - [%Trace.call fun {pf} : t ->pf "%i" x] + [%Trace.call fun {pf} : t -> pf "%i" x] ; print_int x ; x |> - [%Trace.retn fun {pf} : t ->pf "%i"] + [%Trace.retn fun {pf} : t -> pf "%i"] diff --git a/test/passing/tests/revapply_ext.ml b/test/passing/tests/revapply_ext.ml index ca71645df8..84ad583dbb 100644 --- a/test/passing/tests/revapply_ext.ml +++ b/test/passing/tests/revapply_ext.ml @@ -2,8 +2,8 @@ let _ = () (* one *) |> - [%ext fun _ ->()] + [%ext fun _ -> ()] let _ = () |> - [%ext fun _ ->()] + [%ext fun _ -> ()] From 8535f4af6dc005cd39fda4390f75c564d7e41fec Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Tue, 16 Apr 2024 16:15:10 +0200 Subject: [PATCH 034/146] Restore let binding type constraints --- lib/Fmt_ast.ml | 38 +++++++++------- test/passing/tests/break_colon-before.ml.ref | 2 +- test/passing/tests/break_colon.ml | 29 ++++++------ test/passing/tests/break_colon.ml.err | 1 + .../break_fun_decl-fit_or_vertical.ml.ref | 19 ++++---- .../passing/tests/break_fun_decl-smart.ml.ref | 16 ++++--- test/passing/tests/break_fun_decl-wrap.ml.ref | 16 ++++--- test/passing/tests/break_fun_decl.ml | 16 ++++--- test/passing/tests/js_source.ml.err | 12 ++--- test/passing/tests/js_source.ml.ocp | 5 ++- test/passing/tests/js_source.ml.ref | 7 +-- ...ocp_indent_compat-break_colon_after.ml.ref | 20 +++++---- test/passing/tests/ocp_indent_compat.ml | 10 ++--- .../open-closing-on-separate-line.ml.ref | 16 ++++--- test/passing/tests/open.ml.ref | 16 ++++--- test/passing/tests/polytypes-default.ml.ref | 41 +++++++++-------- .../passing/tests/polytypes-janestreet.ml.ref | 14 +++--- test/passing/tests/polytypes.ml | 44 +++++++++---------- test/passing/tests/source.ml.err | 8 ++-- test/passing/tests/source.ml.ref | 35 ++++++--------- test/rpc/rpc_test.expected | 15 ++++--- 21 files changed, 196 insertions(+), 184 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 8dea9f7e00..5cb3e09b74 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -745,15 +745,27 @@ and fmt_record_field c ?typ1 ?typ2 ?rhs lid1 = $ cbox 0 (fmt_longident_loc c lid1 $ Cmts.fmt_after c lid1.loc $ fmt_type_rhs) -and fmt_type_cstr c ~ctx ?constraint_ctx typ = +and fmt_type_cstr c ?(pro=":") ?constraint_ctx xtyp = let colon_before = Poly.(c.conf.fmt_opts.break_colon.v = `Before) in - let fmt_typ ?pro t = - fmt_core_type c ?pro ?constraint_ctx ~box:(not colon_before) (sub_typ ~ctx t) - in - cbox_if colon_before 0 @@ - (match typ with + let wrap, inner_pro, box = + if colon_before then + let wrap x = + fits_breaks " " ~hint:(1000, 0) "" $ cbox 0 (str pro $ str " " $ x) + in + wrap, None, false + else + let wrap x = + break 0 ~-1 $ x + in + wrap, Some pro, true + in + wrap (fmt_core_type c ?pro:inner_pro ?constraint_ctx ~box xtyp) + +and fmt_type_pcstr c ~ctx ?constraint_ctx cstr = + let fmt_typ ~pro t = fmt_type_cstr c ~pro ?constraint_ctx (sub_typ ~ctx t) in + match cstr with | Pconstraint t -> fmt_typ ~pro:":" t - | Pcoerce (t1, t2) -> opt t1 (fmt_typ ~pro:":") $ fmt_typ ~pro:":>" t2) + | Pcoerce (t1, t2) -> opt t1 (fmt_typ ~pro:":") $ fmt_typ ~pro:":>" t2 and fmt_arrow_param c ctx {pap_label= lI; pap_loc= locI; pap_type= tI} = let arg_label lbl = @@ -1448,7 +1460,7 @@ and fmt_function ?force_closing_paren ~ctx ?(wrap_intro = fun x -> hvbox 2 x $ s else (str ":", if has_label then break 1 2 else space_break) in let fmt_typ typ = - fmt_type_cstr c ~ctx ~constraint_ctx:`Fun typ + fmt_type_pcstr c ~ctx ~constraint_ctx:`Fun typ in let fmt_fun_args_typ args typ = let kw = @@ -4367,15 +4379,7 @@ and fmt_value_constraint c vc_opt = let ctx = Vc vc in match vc with | Pvc_constraint {locally_abstract_univars= []; typ} -> - (* Handles breaking the [:] according to [break_colon]. *) - let fmt_typ pro = - fmt_core_type c ?pro (sub_typ ~ctx typ) in -(match c.conf.fmt_opts.break_colon.v with - |`Before -> - noop, fmt_typ (Some ":") - | `After -> - fmt_constraint_sep c ":", fmt_typ None -) + (noop, fmt_type_cstr c (sub_typ ~ctx typ)) | Pvc_constraint {locally_abstract_univars= pvars; typ} -> ( match c.conf.fmt_opts.break_colon.v with | `Before -> diff --git a/test/passing/tests/break_colon-before.ml.ref b/test/passing/tests/break_colon-before.ml.ref index eacbae1977..1568b091ad 100644 --- a/test/passing/tests/break_colon-before.ml.ref +++ b/test/passing/tests/break_colon-before.ml.ref @@ -74,7 +74,7 @@ let ssmap with type key = string and type data = string and type map = SSMap.map ) - -> unit = + -> unit = () let long_function_name diff --git a/test/passing/tests/break_colon.ml b/test/passing/tests/break_colon.ml index ecab151551..61c9741e50 100644 --- a/test/passing/tests/break_colon.ml +++ b/test/passing/tests/break_colon.ml @@ -61,30 +61,31 @@ module type M = sig -> unit end -let ssmap : (module MapT - with type key = string - and type data = string - and type map = SSMap.map ) = +let ssmap : + (module MapT + with type key = string + and type data = string + and type map = SSMap.map ) = () -let ssmap : (module MapT - with type key = string - and type data = string - and type map = SSMap.map ) - -> unit = +let ssmap : + (module MapT + with type key = string + and type data = string + and type map = SSMap.map ) + -> unit = () let long_function_name : type a. a long_long_type -> a -> a -> a -> wrap_wrap_wrap -> unit = fun () -> () -let array_fold_transf (f : numbering -> 'a -> numbering * 'b) n - (a : 'a array) : numbering * 'b array = +let array_fold_transf (f : numbering -> 'a -> numbering * 'b) n (a : 'a array) + : numbering * 'b array = match Array.length a with 0 -> (n, [||]) | 1 -> x -let to_clambda_function - (id, (function_decl : Flambda.function_declaration)) : Clambda.ufunction - = +let to_clambda_function (id, (function_decl : Flambda.function_declaration)) + : Clambda.ufunction = (* All that we need in the environment, for translating one closure from a closed set of closures, is the substitutions for variables bound to the various closures in the set. Such closures will always be ... *) diff --git a/test/passing/tests/break_colon.ml.err b/test/passing/tests/break_colon.ml.err index e69de29bb2..7ec0d7d643 100644 --- a/test/passing/tests/break_colon.ml.err +++ b/test/passing/tests/break_colon.ml.err @@ -0,0 +1 @@ +Warning: tests/break_colon.ml:82 exceeds the margin diff --git a/test/passing/tests/break_fun_decl-fit_or_vertical.ml.ref b/test/passing/tests/break_fun_decl-fit_or_vertical.ml.ref index 4c4ccae512..5b1bd7fe2f 100644 --- a/test/passing/tests/break_fun_decl-fit_or_vertical.ml.ref +++ b/test/passing/tests/break_fun_decl-fit_or_vertical.ml.ref @@ -56,15 +56,17 @@ class ffffffffffffffffffff let ffffffffffffffffffff : aaaaaaaaaaaaaaaaaaaaaa -> bbbbbbbbbbbbbbbbbbbbbb = g -let ffffffffffffffffffff : aaaaaaaaaaaaaaaaaaaaaa - -> bbbbbbbbbbbbbbbbbbbbbb - -> cccccccccccccccccccccc = +let ffffffffffffffffffff : + aaaaaaaaaaaaaaaaaaaaaa + -> bbbbbbbbbbbbbbbbbbbbbb + -> cccccccccccccccccccccc = g -let ffffffffffffffffffff : aaaaaaaaaaaaaaaaaaaaaa - -> bbbbbbbbbbbbbbbbbbbbbb - -> cccccccccccccccccccccc - -> dddddddddddddddddddddd = +let ffffffffffffffffffff : + aaaaaaaaaaaaaaaaaaaaaa + -> bbbbbbbbbbbbbbbbbbbbbb + -> cccccccccccccccccccccc + -> dddddddddddddddddddddd = g let fffffffffffffffffffffffffffffffffff x yyyyyyyyyyyyyyyyyyyyyyyyyyy = () @@ -77,7 +79,8 @@ let fffffffffffffffffffffffffffffffffff class ffffffffffffffffffff = object - method ffffffffffffffffffff : + method ffffffffffffffffffff + : aaaaaaaaaaaaaaaaaaaaaa -> bbbbbbbbbbbbbbbbbbbbbb -> cccccccccccccccccccccc diff --git a/test/passing/tests/break_fun_decl-smart.ml.ref b/test/passing/tests/break_fun_decl-smart.ml.ref index 4838bd576f..d12bcdae0a 100644 --- a/test/passing/tests/break_fun_decl-smart.ml.ref +++ b/test/passing/tests/break_fun_decl-smart.ml.ref @@ -52,15 +52,17 @@ class ffffffffffffffffffff let ffffffffffffffffffff : aaaaaaaaaaaaaaaaaaaaaa -> bbbbbbbbbbbbbbbbbbbbbb = g -let ffffffffffffffffffff : aaaaaaaaaaaaaaaaaaaaaa - -> bbbbbbbbbbbbbbbbbbbbbb - -> cccccccccccccccccccccc = +let ffffffffffffffffffff : + aaaaaaaaaaaaaaaaaaaaaa + -> bbbbbbbbbbbbbbbbbbbbbb + -> cccccccccccccccccccccc = g -let ffffffffffffffffffff : aaaaaaaaaaaaaaaaaaaaaa - -> bbbbbbbbbbbbbbbbbbbbbb - -> cccccccccccccccccccccc - -> dddddddddddddddddddddd = +let ffffffffffffffffffff : + aaaaaaaaaaaaaaaaaaaaaa + -> bbbbbbbbbbbbbbbbbbbbbb + -> cccccccccccccccccccccc + -> dddddddddddddddddddddd = g let fffffffffffffffffffffffffffffffffff x yyyyyyyyyyyyyyyyyyyyyyyyyyy = () diff --git a/test/passing/tests/break_fun_decl-wrap.ml.ref b/test/passing/tests/break_fun_decl-wrap.ml.ref index 41b4a6cd5f..f5c072a108 100644 --- a/test/passing/tests/break_fun_decl-wrap.ml.ref +++ b/test/passing/tests/break_fun_decl-wrap.ml.ref @@ -34,15 +34,17 @@ class ffffffffffffffffffff aaaaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbbb let ffffffffffffffffffff : aaaaaaaaaaaaaaaaaaaaaa -> bbbbbbbbbbbbbbbbbbbbbb = g -let ffffffffffffffffffff : aaaaaaaaaaaaaaaaaaaaaa - -> bbbbbbbbbbbbbbbbbbbbbb - -> cccccccccccccccccccccc = +let ffffffffffffffffffff : + aaaaaaaaaaaaaaaaaaaaaa + -> bbbbbbbbbbbbbbbbbbbbbb + -> cccccccccccccccccccccc = g -let ffffffffffffffffffff : aaaaaaaaaaaaaaaaaaaaaa - -> bbbbbbbbbbbbbbbbbbbbbb - -> cccccccccccccccccccccc - -> dddddddddddddddddddddd = +let ffffffffffffffffffff : + aaaaaaaaaaaaaaaaaaaaaa + -> bbbbbbbbbbbbbbbbbbbbbb + -> cccccccccccccccccccccc + -> dddddddddddddddddddddd = g let fffffffffffffffffffffffffffffffffff x yyyyyyyyyyyyyyyyyyyyyyyyyyy = () diff --git a/test/passing/tests/break_fun_decl.ml b/test/passing/tests/break_fun_decl.ml index 41b4a6cd5f..f5c072a108 100644 --- a/test/passing/tests/break_fun_decl.ml +++ b/test/passing/tests/break_fun_decl.ml @@ -34,15 +34,17 @@ class ffffffffffffffffffff aaaaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbbb let ffffffffffffffffffff : aaaaaaaaaaaaaaaaaaaaaa -> bbbbbbbbbbbbbbbbbbbbbb = g -let ffffffffffffffffffff : aaaaaaaaaaaaaaaaaaaaaa - -> bbbbbbbbbbbbbbbbbbbbbb - -> cccccccccccccccccccccc = +let ffffffffffffffffffff : + aaaaaaaaaaaaaaaaaaaaaa + -> bbbbbbbbbbbbbbbbbbbbbb + -> cccccccccccccccccccccc = g -let ffffffffffffffffffff : aaaaaaaaaaaaaaaaaaaaaa - -> bbbbbbbbbbbbbbbbbbbbbb - -> cccccccccccccccccccccc - -> dddddddddddddddddddddd = +let ffffffffffffffffffff : + aaaaaaaaaaaaaaaaaaaaaa + -> bbbbbbbbbbbbbbbbbbbbbb + -> cccccccccccccccccccccc + -> dddddddddddddddddddddd = g let fffffffffffffffffffffffffffffffffff x yyyyyyyyyyyyyyyyyyyyyyyyyyy = () diff --git a/test/passing/tests/js_source.ml.err b/test/passing/tests/js_source.ml.err index 701e84d882..d7396f369e 100644 --- a/test/passing/tests/js_source.ml.err +++ b/test/passing/tests/js_source.ml.err @@ -1,7 +1,7 @@ Warning: tests/js_source.ml:162 exceeds the margin -Warning: tests/js_source.ml:2677 exceeds the margin -Warning: tests/js_source.ml:9576 exceeds the margin -Warning: tests/js_source.ml:9680 exceeds the margin -Warning: tests/js_source.ml:9739 exceeds the margin -Warning: tests/js_source.ml:9822 exceeds the margin -Warning: tests/js_source.ml:10330 exceeds the margin +Warning: tests/js_source.ml:2678 exceeds the margin +Warning: tests/js_source.ml:9577 exceeds the margin +Warning: tests/js_source.ml:9681 exceeds the margin +Warning: tests/js_source.ml:9740 exceeds the margin +Warning: tests/js_source.ml:9823 exceeds the margin +Warning: tests/js_source.ml:10331 exceeds the margin diff --git a/test/passing/tests/js_source.ml.ocp b/test/passing/tests/js_source.ml.ocp index ecc75e50ee..e6b58e2377 100644 --- a/test/passing/tests/js_source.ml.ocp +++ b/test/passing/tests/js_source.ml.ocp @@ -2437,7 +2437,8 @@ let eval (type c) (bop : (a, b, c) binop) (x : a constant) - (y : b constant) : c constant + (y : b constant) + : c constant = match bop, x, y with | Eq, Bool x, Bool y -> Bool (if x then y else not y) @@ -9595,7 +9596,7 @@ let ssmap ;; let ssmap - : (module MapT with type key = string and type data = string and type map = SSMap.map) + : (module MapT with type key = string and type data = string and type map = SSMap.map) -> unit = () diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index aa0de5ae03..c9b0754fa4 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -2437,7 +2437,8 @@ let eval (type c) (bop : (a, b, c) binop) (x : a constant) - (y : b constant) : c constant + (y : b constant) + : c constant = match bop, x, y with | Eq, Bool x, Bool y -> Bool (if x then y else not y) @@ -9595,8 +9596,8 @@ let ssmap ;; let ssmap - : (module MapT with type key = string and type data = string and type map = SSMap.map) - -> unit + : (module MapT with type key = string and type data = string and type map = SSMap.map) + -> unit = () ;; diff --git a/test/passing/tests/ocp_indent_compat-break_colon_after.ml.ref b/test/passing/tests/ocp_indent_compat-break_colon_after.ml.ref index 36ca314095..4ed2d190af 100644 --- a/test/passing/tests/ocp_indent_compat-break_colon_after.ml.ref +++ b/test/passing/tests/ocp_indent_compat-break_colon_after.ml.ref @@ -62,18 +62,20 @@ module type M = sig -> unit end -let ssmap : (module MapT - with type key = string - and type data = string - and type map = SSMap.map ) +let ssmap : + (module MapT + with type key = string + and type data = string + and type map = SSMap.map ) = () -let ssmap : (module MapT - with type key = string - and type data = string - and type map = SSMap.map ) - -> unit +let ssmap : + (module MapT + with type key = string + and type data = string + and type map = SSMap.map ) + -> unit = () diff --git a/test/passing/tests/ocp_indent_compat.ml b/test/passing/tests/ocp_indent_compat.ml index 9e2496b98f..0fe2b3c3eb 100644 --- a/test/passing/tests/ocp_indent_compat.ml +++ b/test/passing/tests/ocp_indent_compat.ml @@ -72,11 +72,11 @@ let ssmap () let ssmap - : (module MapT - with type key = string - and type data = string - and type map = SSMap.map ) - -> unit + : (module MapT + with type key = string + and type data = string + and type map = SSMap.map ) + -> unit = () diff --git a/test/passing/tests/open-closing-on-separate-line.ml.ref b/test/passing/tests/open-closing-on-separate-line.ml.ref index ab548e7a1b..93fe77f6ba 100644 --- a/test/passing/tests/open-closing-on-separate-line.ml.ref +++ b/test/passing/tests/open-closing-on-separate-line.ml.ref @@ -370,15 +370,17 @@ let _ : M.([`Foo of foo]) = () let _ : M.N.(foo) = () -let _ : M.( - foooooooooooooooooooooooooooooooooooooooo - * foooooooooooooooooooooooooooooooooooooooo) = +let _ : + M.( + foooooooooooooooooooooooooooooooooooooooo + * foooooooooooooooooooooooooooooooooooooooo) = () -let _ : M.( - [ `Foo of - foooooooooooooooooooooooooooooooooooooooo - * foooooooooooooooooooooooooooooooooooooooo ]) = +let _ : + M.( + [ `Foo of + foooooooooooooooooooooooooooooooooooooooo + * foooooooooooooooooooooooooooooooooooooooo ]) = () let _ : M.((foo[@attr])) = () diff --git a/test/passing/tests/open.ml.ref b/test/passing/tests/open.ml.ref index 0c4cf2140d..ae2e66a76f 100644 --- a/test/passing/tests/open.ml.ref +++ b/test/passing/tests/open.ml.ref @@ -357,15 +357,17 @@ let _ : M.([`Foo of foo]) = () let _ : M.N.(foo) = () -let _ : M.( - foooooooooooooooooooooooooooooooooooooooo - * foooooooooooooooooooooooooooooooooooooooo) = +let _ : + M.( + foooooooooooooooooooooooooooooooooooooooo + * foooooooooooooooooooooooooooooooooooooooo) = () -let _ : M.( - [ `Foo of - foooooooooooooooooooooooooooooooooooooooo - * foooooooooooooooooooooooooooooooooooooooo ]) = +let _ : + M.( + [ `Foo of + foooooooooooooooooooooooooooooooooooooooo + * foooooooooooooooooooooooooooooooooooooooo ]) = () let _ : M.((foo[@attr])) = () diff --git a/test/passing/tests/polytypes-default.ml.ref b/test/passing/tests/polytypes-default.ml.ref index 9f3c0ea12e..d89282b8b1 100644 --- a/test/passing/tests/polytypes-default.ml.ref +++ b/test/passing/tests/polytypes-default.ml.ref @@ -1,22 +1,25 @@ let t1 : 'a 'b. 'a t -> b t = () -let t2 : 'a 'b. - 'a t________________________________ -> - 'b t_______________________________________ = +let t2 : + 'a 'b. + 'a t________________________________ -> + 'b t_______________________________________ = () -let t3 : 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that - 'must 'wrap. - 'a t_________________________________________________ -> - 'b t______________________________________________________________ -> - 'c t______________________________________________________________ = +let t3 : + 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that 'must + 'wrap. + 'a t_________________________________________________ -> + 'b t______________________________________________________________ -> + 'c t______________________________________________________________ = () -let t4 : 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that - 'must 'wrap. - 'a t_________________________________________________ - * 'b t______________________________________________________________ - * 'c t______________________________________________________________ = +let t4 : + 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that 'must + 'wrap. + 'a t_________________________________________________ + * 'b t______________________________________________________________ + * 'c t______________________________________________________________ = () let foo : type a. a = @@ -31,17 +34,13 @@ let _ = let id : 'a. 'a -> 'a = fun x -> x in () -let equal_list : 'a. - ('a, 't) gexpr marked list -> - ('a, 't) gexpr marked list -> - bool = +let equal_list : + 'a. ('a, 't) gexpr marked list -> ('a, 't) gexpr marked list -> bool = fun es1 es2 -> try List.for_all2 equal es1 es2 with Invalid_argument _ -> false -let rec equal_list : 'a. - ('a, 't) gexpr marked list -> - ('a, 't) gexpr marked list -> - bool = +let rec equal_list : + 'a. ('a, 't) gexpr marked list -> ('a, 't) gexpr marked list -> bool = fun es1 es2 -> try List.for_all2 equal es1 es2 with Invalid_argument _ -> false diff --git a/test/passing/tests/polytypes-janestreet.ml.ref b/test/passing/tests/polytypes-janestreet.ml.ref index 40302fa9af..cc0e91e305 100644 --- a/test/passing/tests/polytypes-janestreet.ml.ref +++ b/test/passing/tests/polytypes-janestreet.ml.ref @@ -2,25 +2,25 @@ let t1 : 'a 'b. 'a t -> b t = () let t2 : 'a 'b. - 'a t________________________________ -> 'b t_______________________________________ + 'a t________________________________ -> 'b t_______________________________________ = () ;; let t3 : 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that 'must 'wrap. - 'a t_________________________________________________ - -> 'b t______________________________________________________________ - -> 'c t______________________________________________________________ + 'a t_________________________________________________ + -> 'b t______________________________________________________________ + -> 'c t______________________________________________________________ = () ;; let t4 : 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that 'must 'wrap. - 'a t_________________________________________________ - * 'b t______________________________________________________________ - * 'c t______________________________________________________________ + 'a t_________________________________________________ + * 'b t______________________________________________________________ + * 'c t______________________________________________________________ = () ;; diff --git a/test/passing/tests/polytypes.ml b/test/passing/tests/polytypes.ml index d0e4d6ae76..2dd753a38c 100644 --- a/test/passing/tests/polytypes.ml +++ b/test/passing/tests/polytypes.ml @@ -1,25 +1,25 @@ let t1 : 'a 'b. 'a t -> b t = () -let t2 : 'a 'b. - 'a t________________________________ - -> 'b t_______________________________________ = +let t2 : + 'a 'b. + 'a t________________________________ + -> 'b t_______________________________________ = () -let t3 : 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables - 'that 'must 'wrap. - 'a t_________________________________________________ - -> 'b - t______________________________________________________________ - -> 'c - t______________________________________________________________ = +let t3 : + 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that + 'must 'wrap. + 'a t_________________________________________________ + -> 'b t______________________________________________________________ + -> 'c t______________________________________________________________ = () -let t4 : 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables - 'that 'must 'wrap. - 'a t_________________________________________________ - * 'b t______________________________________________________________ - * 'c t______________________________________________________________ - = +let t4 : + 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that + 'must 'wrap. + 'a t_________________________________________________ + * 'b t______________________________________________________________ + * 'c t______________________________________________________________ = () let foo : type a. a = @@ -34,17 +34,13 @@ let _ = let id : 'a. 'a -> 'a = fun x -> x in () -let equal_list : 'a. - ('a, 't) gexpr marked list - -> ('a, 't) gexpr marked list - -> bool = +let equal_list : + 'a. ('a, 't) gexpr marked list -> ('a, 't) gexpr marked list -> bool = fun es1 es2 -> try List.for_all2 equal es1 es2 with Invalid_argument _ -> false -let rec equal_list : 'a. - ('a, 't) gexpr marked list - -> ('a, 't) gexpr marked list - -> bool = +let rec equal_list : + 'a. ('a, 't) gexpr marked list -> ('a, 't) gexpr marked list -> bool = fun es1 es2 -> try List.for_all2 equal es1 es2 with Invalid_argument _ -> false diff --git a/test/passing/tests/source.ml.err b/test/passing/tests/source.ml.err index 81215270b7..79fe85e2ad 100644 --- a/test/passing/tests/source.ml.err +++ b/test/passing/tests/source.ml.err @@ -1,4 +1,4 @@ -Warning: tests/source.ml:703 exceeds the margin -Warning: tests/source.ml:1038 exceeds the margin -Warning: tests/source.ml:1253 exceeds the margin -Warning: tests/source.ml:1391 exceeds the margin +Warning: tests/source.ml:704 exceeds the margin +Warning: tests/source.ml:1039 exceeds the margin +Warning: tests/source.ml:1254 exceeds the margin +Warning: tests/source.ml:1392 exceeds the margin diff --git a/test/passing/tests/source.ml.ref b/test/passing/tests/source.ml.ref index a0c5a233b0..b44705c3f0 100644 --- a/test/passing/tests/source.ml.ref +++ b/test/passing/tests/source.ml.ref @@ -57,10 +57,11 @@ let [%foo? Bar x | Baz x] : [%foo? #bar] = [%foo? {x}] [%%foo: module M : [%baz]] -let [%foo: include S with type t = t] : [%foo: - val x : t +let [%foo: include S with type t = t] : + [%foo: + val x : t - val y : t] = + val y : t] = [%foo: type t = t] let int_with_custom_modifier = @@ -2550,24 +2551,18 @@ type ('a, 'result, 'visit_action) context = | Local : ('a, ('a * insert as 'result), 'a local_visit_action) context | Global : ('a, 'a, 'a visit_action) context -let vexpr (type visit_action) : (_, _, visit_action) context - -> _ - -> visit_action = +let vexpr (type visit_action) : + (_, _, visit_action) context -> _ -> visit_action = function | Local -> fun _ -> raise Exit | Global -> fun _ -> raise Exit -let vexpr (type visit_action) : ('a, 'result, visit_action) context - -> 'a - -> visit_action = +let vexpr (type visit_action) : + ('a, 'result, visit_action) context -> 'a -> visit_action = function | Local -> fun _ -> raise Exit | Global -> fun _ -> raise Exit -let vexpr (type result) (type visit_action) : ( unit - , result - , visit_action ) - context - -> unit - -> visit_action = +let vexpr (type result) (type visit_action) : + (unit, result, visit_action) context -> unit -> visit_action = function | Local -> fun _ -> raise Exit | Global -> fun _ -> raise Exit @@ -4094,17 +4089,15 @@ end = struct let _ = fun (_ : ('a, 'perms) t) -> () - let t_of_sexp : 'a 'perms. - (sexp -> 'a) -> (sexp -> 'perms) -> sexp -> ('a, 'perms) t - = + let t_of_sexp : + 'a 'perms. (sexp -> 'a) -> (sexp -> 'perms) -> sexp -> ('a, 'perms) t = let _tp_loc = "core_array.ml.Permissioned.t" in fun _of_a -> fun _of_perms -> fun t -> (array_of_sexp _of_a) t let _ = t_of_sexp - let sexp_of_t : 'a 'perms. - ('a -> sexp) -> ('perms -> sexp) -> ('a, 'perms) t -> sexp - = + let sexp_of_t : + 'a 'perms. ('a -> sexp) -> ('perms -> sexp) -> ('a, 'perms) t -> sexp = fun _of_a -> fun _of_perms -> fun v -> (sexp_of_array _of_a) v let _ = sexp_of_t diff --git a/test/rpc/rpc_test.expected b/test/rpc/rpc_test.expected index a2970edc4f..f528f7e0aa 100644 --- a/test/rpc/rpc_test.expected +++ b/test/rpc/rpc_test.expected @@ -75,11 +75,12 @@ let ssmap () ' Output: -let ssmap : (module MapT - with type key = string - and type data = string - and type map = SSMap.map) -> - unit = +let ssmap : + (module MapT + with type key = string + and type data = string + and type map = SSMap.map) -> + unit = () [ocf] Config @@ -95,8 +96,8 @@ let ssmap ' Output: let ssmap - : (module MapT with type key = string and type data = string and type map = SSMap.map) - -> unit + : (module MapT with type key = string and type data = string and type map = SSMap.map) + -> unit = () ;; From f8dd8add242b76674c9bc25a4f757a2c93360577 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Wed, 17 Apr 2024 16:37:26 +0200 Subject: [PATCH 035/146] Fix spacing after fun%ext Co-authored-by: Emile Trotignon --- lib/Fmt_ast.ml | 2 +- test/passing/tests/extensions-indent.ml.ref | 8 ++++---- test/passing/tests/extensions.ml.ref | 8 ++++---- 3 files changed, 9 insertions(+), 9 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 5cb3e09b74..86f5f8743b 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1464,7 +1464,7 @@ and fmt_function ?force_closing_paren ~ctx ?(wrap_intro = fun x -> hvbox 2 x $ s in let fmt_fun_args_typ args typ = let kw = - str "fun" $ fmt_extension_suffix ~epi:(str " ") c ext $ fmt_attributes c ~pre:Blank attrs $ space_break + str "fun" $ fmt_extension_suffix c ext $ fmt_attributes c ~pre:Blank attrs $ space_break and args = fmt_expr_fun_args c args and annot = Option.map ~f:fmt_typ typ in diff --git a/test/passing/tests/extensions-indent.ml.ref b/test/passing/tests/extensions-indent.ml.ref index 3d1f5368af..dec5ab6dba 100644 --- a/test/passing/tests/extensions-indent.ml.ref +++ b/test/passing/tests/extensions-indent.ml.ref @@ -432,19 +432,19 @@ let _ = f ((try%ext x with _ -> x) [@attr]) let _ = f ([%ext try x with _ -> x] [@attr]) -let _ = fun%ext x -> x +let _ = fun%ext x -> x let _ = [%ext fun x -> x] -let _ = f (fun%ext x -> x) +let _ = f (fun%ext x -> x) let _ = f [%ext fun x -> x] -let _ = (fun%ext x -> x) [@attr] +let _ = (fun%ext x -> x) [@attr] let _ = [%ext fun x -> x] [@attr] -let _ = f ((fun%ext x -> x) [@attr]) +let _ = f ((fun%ext x -> x) [@attr]) let _ = f ([%ext fun x -> x] [@attr]) diff --git a/test/passing/tests/extensions.ml.ref b/test/passing/tests/extensions.ml.ref index 00302a598a..b85bc9347a 100644 --- a/test/passing/tests/extensions.ml.ref +++ b/test/passing/tests/extensions.ml.ref @@ -432,19 +432,19 @@ let _ = f ((try%ext x with _ -> x) [@attr]) let _ = f ([%ext try x with _ -> x] [@attr]) -let _ = fun%ext x -> x +let _ = fun%ext x -> x let _ = [%ext fun x -> x] -let _ = f (fun%ext x -> x) +let _ = f (fun%ext x -> x) let _ = f [%ext fun x -> x] -let _ = (fun%ext x -> x) [@attr] +let _ = (fun%ext x -> x) [@attr] let _ = [%ext fun x -> x] [@attr] -let _ = f ((fun%ext x -> x) [@attr]) +let _ = f ((fun%ext x -> x) [@attr]) let _ = f ([%ext fun x -> x] [@attr]) From b25984bc0022677ae278d5b45494dbed9ffac412 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Fri, 19 Apr 2024 13:39:35 +0200 Subject: [PATCH 036/146] Fix indentation of 'infix fun' The change in ite-fit_or_vertical.ml.ref is not a regression, it's the same as on main. --- lib/Fmt_ast.ml | 34 ++++++------- .../tests/break_infix-fit-or-vertical.ml.ref | 14 +++--- test/passing/tests/break_infix-wrap.ml.ref | 7 ++- test/passing/tests/break_infix.ml.ref | 14 +++--- test/passing/tests/doc_comments-after.ml.ref | 4 +- .../doc_comments-before-except-val.ml.ref | 4 +- test/passing/tests/doc_comments-before.ml.ref | 4 +- test/passing/tests/doc_comments.ml.ref | 4 +- test/passing/tests/infix_arg_grouping.ml.ref | 4 +- test/passing/tests/infix_bind-break.ml.ref | 44 ++++++++--------- .../infix_bind-fit_or_vertical-break.ml.ref | 48 +++++++++---------- test/passing/tests/ite-compact.ml.ref | 10 ++-- test/passing/tests/ite-compact_closing.ml.ref | 10 ++-- test/passing/tests/ite-fit_or_vertical.ml.ref | 4 +- .../tests/ite-fit_or_vertical_closing.ml.ref | 4 +- .../ite-fit_or_vertical_no_indicate.ml.ref | 4 +- test/passing/tests/ite-kr.ml.ref | 4 +- test/passing/tests/ite-kr_closing.ml.ref | 4 +- test/passing/tests/ite-no_indicate.ml.ref | 10 ++-- test/passing/tests/ite.ml.ref | 10 ++-- test/passing/tests/js_bind.ml.ref | 7 ++- test/passing/tests/js_fun.ml.ref | 3 +- test/passing/tests/js_source.ml.ref | 30 ++++++------ test/passing/tests/js_upon.ml.ref | 4 +- test/passing/tests/source.ml.ref | 28 ++++++----- 25 files changed, 149 insertions(+), 164 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 86f5f8743b..46a9f760e3 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -2169,28 +2169,28 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens $ cut_break $ str "." $ fmt_longident_loc c lid $ fmt_atrs ) ) | Pexp_function (args, typ, (Pfunction_body _ as body)) | Pexp_function ((_ :: _ as args), typ, body) -> - let body_is_function = - match body with - | Pfunction_cases _ -> true - | _ -> false - in - let indent = - if body_is_function then - let default_indent = - if Option.is_none eol then 2 - else if c.conf.fmt_opts.let_binding_deindent_fun.v then 1 - else 0 - in - Params.Indent.function_ ~default:default_indent c.conf ~parens xexp - else Params.Indent.fun_ ?eol c.conf - in + (* let body_is_function = *) + (* match body with *) + (* | Pfunction_cases _ -> true *) + (* | _ -> false *) + (* in *) + (* let indent = *) + (* if body_is_function then *) + (* let default_indent = *) + (* if Option.is_none eol then 2 *) + (* else if c.conf.fmt_opts.let_binding_deindent_fun.v then 1 *) + (* else 0 *) + (* in *) + (* Params.Indent.function_ ~default:default_indent c.conf ~parens xexp *) + (* else Params.Indent.fun_ ?eol c.conf *) + (* in *) pro - $ hvbox_if (box || body_is_function) indent + $ ( (* Params.Exp.wrap c.conf ~parens ~disambiguate:true *) (* ~fits_breaks:false ~offset_closing_paren:(-2) *) ( - fmt_function ~ctx + fmt_function ~box ~ctx ~label:Nolabel ~parens ?ext ~attrs:pexp_attributes ~loc:pexp_loc c (args, typ, body) ) ) | Pexp_function ([], None, Pfunction_cases (cs, _, _)) -> diff --git a/test/passing/tests/break_infix-fit-or-vertical.ml.ref b/test/passing/tests/break_infix-fit-or-vertical.ml.ref index f9cc2dd820..7aa7824b43 100644 --- a/test/passing/tests/break_infix-fit-or-vertical.ml.ref +++ b/test/passing/tests/break_infix-fit-or-vertical.ml.ref @@ -73,13 +73,13 @@ let _ = @@ fooooooooooooooo @@ (fun x -> foooooooooooooo $ fooooooooooooooooooooo) @@ fun x -> - fooooooooooooooo - $ fooooooooooooooooo - $ fooooooooooooooooo - $ fooooooooooooo - $ fooo @@ foooooooooooooooooo - $ fooooooooooooo - $ foooooooooooooooooooo + fooooooooooooooo + $ fooooooooooooooooo + $ fooooooooooooooooo + $ fooooooooooooo + $ fooo @@ foooooooooooooooooo + $ fooooooooooooo + $ foooooooooooooooooooo let _ = a + (b * c) + d diff --git a/test/passing/tests/break_infix-wrap.ml.ref b/test/passing/tests/break_infix-wrap.ml.ref index 738e65c008..3b2545994f 100644 --- a/test/passing/tests/break_infix-wrap.ml.ref +++ b/test/passing/tests/break_infix-wrap.ml.ref @@ -44,10 +44,9 @@ let _ = fooooooooo @@ fooooooooooooooo @@ (fun x -> foooooooooooooo $ fooooooooooooooooooooo) @@ fun x -> - fooooooooooooooo $ fooooooooooooooooo $ fooooooooooooooooo - $ fooooooooooooo - $ fooo @@ foooooooooooooooooo - $ fooooooooooooo $ foooooooooooooooooooo + fooooooooooooooo $ fooooooooooooooooo $ fooooooooooooooooo $ fooooooooooooo + $ fooo @@ foooooooooooooooooo + $ fooooooooooooo $ foooooooooooooooooooo let _ = a + (b * c) + d diff --git a/test/passing/tests/break_infix.ml.ref b/test/passing/tests/break_infix.ml.ref index 08727b5b3d..71a79f5806 100644 --- a/test/passing/tests/break_infix.ml.ref +++ b/test/passing/tests/break_infix.ml.ref @@ -62,13 +62,13 @@ let _ = fooooooooo @@ fooooooooooooooo @@ (fun x -> foooooooooooooo $ fooooooooooooooooooooo) @@ fun x -> - fooooooooooooooo - $ fooooooooooooooooo - $ fooooooooooooooooo - $ fooooooooooooo - $ fooo @@ foooooooooooooooooo - $ fooooooooooooo - $ foooooooooooooooooooo + fooooooooooooooo + $ fooooooooooooooooo + $ fooooooooooooooooo + $ fooooooooooooo + $ fooo @@ foooooooooooooooooo + $ fooooooooooooo + $ foooooooooooooooooooo let _ = a + (b * c) + d diff --git a/test/passing/tests/doc_comments-after.ml.ref b/test/passing/tests/doc_comments-after.ml.ref index 2de999dd15..ad4ad77c2e 100644 --- a/test/passing/tests/doc_comments-after.ml.ref +++ b/test/passing/tests/doc_comments-after.ml.ref @@ -304,8 +304,8 @@ let a = 1 let _ = f @@ {aaa= aaa bbb ccc; bbb= aaa bbb ccc; ccc= aaa bbb ccc} >>= fun () -> - let _ = x in - f @@ g @@ h @@ fun x -> y + let _ = x in + f @@ g @@ h @@ fun x -> y ]} *) (**{v diff --git a/test/passing/tests/doc_comments-before-except-val.ml.ref b/test/passing/tests/doc_comments-before-except-val.ml.ref index e073f0b56e..66cc7751a1 100644 --- a/test/passing/tests/doc_comments-before-except-val.ml.ref +++ b/test/passing/tests/doc_comments-before-except-val.ml.ref @@ -304,8 +304,8 @@ let a = 1 let _ = f @@ {aaa= aaa bbb ccc; bbb= aaa bbb ccc; ccc= aaa bbb ccc} >>= fun () -> - let _ = x in - f @@ g @@ h @@ fun x -> y + let _ = x in + f @@ g @@ h @@ fun x -> y ]} *) (**{v diff --git a/test/passing/tests/doc_comments-before.ml.ref b/test/passing/tests/doc_comments-before.ml.ref index 06750192f3..ae6ef68376 100644 --- a/test/passing/tests/doc_comments-before.ml.ref +++ b/test/passing/tests/doc_comments-before.ml.ref @@ -304,8 +304,8 @@ let a = 1 let _ = f @@ {aaa= aaa bbb ccc; bbb= aaa bbb ccc; ccc= aaa bbb ccc} >>= fun () -> - let _ = x in - f @@ g @@ h @@ fun x -> y + let _ = x in + f @@ g @@ h @@ fun x -> y ]} *) (**{v diff --git a/test/passing/tests/doc_comments.ml.ref b/test/passing/tests/doc_comments.ml.ref index e073f0b56e..66cc7751a1 100644 --- a/test/passing/tests/doc_comments.ml.ref +++ b/test/passing/tests/doc_comments.ml.ref @@ -304,8 +304,8 @@ let a = 1 let _ = f @@ {aaa= aaa bbb ccc; bbb= aaa bbb ccc; ccc= aaa bbb ccc} >>= fun () -> - let _ = x in - f @@ g @@ h @@ fun x -> y + let _ = x in + f @@ g @@ h @@ fun x -> y ]} *) (**{v diff --git a/test/passing/tests/infix_arg_grouping.ml.ref b/test/passing/tests/infix_arg_grouping.ml.ref index 696b0be2b5..aa71b47d83 100644 --- a/test/passing/tests/infix_arg_grouping.ml.ref +++ b/test/passing/tests/infix_arg_grouping.ml.ref @@ -109,8 +109,8 @@ let () = (* Keep going... *) another_action |> fun t -> - (* And finally do this *) - final_action t + (* And finally do this *) + final_action t let () = (* Open the repo *) diff --git a/test/passing/tests/infix_bind-break.ml.ref b/test/passing/tests/infix_bind-break.ml.ref index 3efdd5f371..90ddc7c9ab 100644 --- a/test/passing/tests/infix_bind-break.ml.ref +++ b/test/passing/tests/infix_bind-break.ml.ref @@ -1,10 +1,8 @@ f x >>= fun y -> - g y - >>= fun () -> - f x - >>= fun y -> - g y >>= fun () -> f x >>= fun y -> g y >>= fun () -> y () +g y +>>= fun () -> +f x >>= fun y -> g y >>= fun () -> f x >>= fun y -> g y >>= fun () -> y () ;; f x @@ -12,11 +10,9 @@ f x | A -> ( g y >>= fun () -> - f x - >>= fun y -> - g y - >>= function - | x -> ( f x >>= fun y -> g y >>= function _ -> y () ) ) + f x + >>= fun y -> + g y >>= function x -> ( f x >>= fun y -> g y >>= function _ -> y () ) ) ;; eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee |> fun x -> x ;; @@ -33,7 +29,7 @@ eeeeeeeeeeeee eeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeee eeeeeeeeeeeee eeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeee eeeeeeeeeeee eeeeeeeeee |> fun xxxxxxxxxxxxx xxxxxxxxxxxxxx xxxxxxxxxxxxxx xxxxxxxxx -> - xxxxxxxxxxx xxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxx xxxxxxxxxxx +xxxxxxxxxxx xxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxx xxxxxxxxxxx ;; eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee |> fun x -> x ;; @@ -54,7 +50,7 @@ eeeeeeeeeeeee eeeeeeeeeeeeeeeeee eeeeeeeeeeeee eeeeeeeeee |> fun xxxxxxxxxxxxx xxxxxxxxxxxxxx xxxxxxxxxxxxxx xxxxxxxxx -> - xxxxxxxxxxx xxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxx xxxxxxxxxxx +xxxxxxxxxxx xxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxx xxxxxxxxxxx ;; eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee |> function x -> x ;; @@ -102,13 +98,13 @@ let parens = | {pexp_desc= Pexp_function cs; pexp_attributes; pexp_loc} -> update_config_maybe_disabled c pexp_loc pexp_attributes @@ fun c -> - fmt "@ " - $ Cmts.fmt c.cmts pexp_loc - (wrap_if parens "(" ")" - ( fmt "function" - $ fmt_extension_suffix c ext - $ fmt_attributes c ~key:"@" pexp_attributes - $ close_box $ fmt "@ " $ fmt_cases c ctx cs ) ) + fmt "@ " + $ Cmts.fmt c.cmts pexp_loc + (wrap_if parens "(" ")" + ( fmt "function" + $ fmt_extension_suffix c ext + $ fmt_attributes c ~key:"@" pexp_attributes + $ close_box $ fmt "@ " $ fmt_cases c ctx cs ) ) | _ -> close_box $ fmt "@ " $ fmt_expression c ~eol:(fmt "@;<1000 0>") xbody @@ -161,8 +157,8 @@ let _ = foo >>= fun [@warning "-4"] x -> fooooooooooooooooooooooo let _ = foo >>= fun [@warning "-4"] x y -> - fooooooooooooooooooooooo fooooooooooooooooooooooo - fooooooooooooooooooooooo fooooooooooooooooooooooo + fooooooooooooooooooooooo fooooooooooooooooooooooo fooooooooooooooooooooooo + fooooooooooooooooooooooo let _ = foo @@ -173,7 +169,7 @@ let _ = let _ = foo >>= fun (* foo before *) [@warning "-4"] (* foo after *) x -> - fooooooooooooooooooooooo + fooooooooooooooooooooooo let f = Ok () @@ -206,7 +202,7 @@ let f = >>= (* fooooooooooooooo fooooooooooooooo fooooooooooooooo foooooooooooooooo *) fun foooooo fooooo foooo foooooo -> - Ok foooooooooooooooooooooooooooooooooooooooooooooooooo + Ok foooooooooooooooooooooooooooooooooooooooooooooooooo let f = Ok () @@ -239,7 +235,7 @@ let default = command ## hasPermission #= (fun ctx -> foooooooooooooooooo fooooooooooo) ; command ## hasPermission #= (fun ctx -> - foooooooooooooooooo fooooooooooo foooooo fooooooooo foooooooooo ) ; + foooooooooooooooooo fooooooooooo foooooo fooooooooo foooooooooo ) ; foo let _ = ( let* ) x (fun y -> z) diff --git a/test/passing/tests/infix_bind-fit_or_vertical-break.ml.ref b/test/passing/tests/infix_bind-fit_or_vertical-break.ml.ref index 967e84c4a7..44e7573628 100644 --- a/test/passing/tests/infix_bind-fit_or_vertical-break.ml.ref +++ b/test/passing/tests/infix_bind-fit_or_vertical-break.ml.ref @@ -1,10 +1,8 @@ f x >>= fun y -> - g y - >>= fun () -> - f x - >>= fun y -> - g y >>= fun () -> f x >>= fun y -> g y >>= fun () -> y () +g y +>>= fun () -> +f x >>= fun y -> g y >>= fun () -> f x >>= fun y -> g y >>= fun () -> y () ;; f x @@ -12,11 +10,9 @@ f x | A -> ( g y >>= fun () -> - f x - >>= fun y -> - g y - >>= function - | x -> ( f x >>= fun y -> g y >>= function _ -> y () ) ) + f x + >>= fun y -> + g y >>= function x -> ( f x >>= fun y -> g y >>= function _ -> y () ) ) ;; eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee |> fun x -> x ;; @@ -33,7 +29,7 @@ eeeeeeeeeeeee eeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeee eeeeeeeeeeeee eeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeee eeeeeeeeeeee eeeeeeeeee |> fun xxxxxxxxxxxxx xxxxxxxxxxxxxx xxxxxxxxxxxxxx xxxxxxxxx -> - xxxxxxxxxxx xxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxx xxxxxxxxxxx +xxxxxxxxxxx xxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxx xxxxxxxxxxx ;; eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee |> fun x -> x ;; @@ -54,7 +50,7 @@ eeeeeeeeeeeee eeeeeeeeeeeeeeeeee eeeeeeeeeeeee eeeeeeeeee |> fun xxxxxxxxxxxxx xxxxxxxxxxxxxx xxxxxxxxxxxxxx xxxxxxxxx -> - xxxxxxxxxxx xxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxx xxxxxxxxxxx +xxxxxxxxxxx xxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxx xxxxxxxxxxx ;; eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee |> function x -> x ;; @@ -102,15 +98,15 @@ let parens = | {pexp_desc= Pexp_function cs; pexp_attributes; pexp_loc} -> update_config_maybe_disabled c pexp_loc pexp_attributes @@ fun c -> - fmt "@ " - $ Cmts.fmt c.cmts pexp_loc - (wrap_if parens "(" ")" - ( fmt "function" - $ fmt_extension_suffix c ext - $ fmt_attributes c ~key:"@" pexp_attributes - $ close_box - $ fmt "@ " - $ fmt_cases c ctx cs ) ) + fmt "@ " + $ Cmts.fmt c.cmts pexp_loc + (wrap_if parens "(" ")" + ( fmt "function" + $ fmt_extension_suffix c ext + $ fmt_attributes c ~key:"@" pexp_attributes + $ close_box + $ fmt "@ " + $ fmt_cases c ctx cs ) ) | _ -> close_box $ fmt "@ " $ fmt_expression c ~eol:(fmt "@;<1000 0>") xbody @@ -166,8 +162,8 @@ let _ = foo >>= fun [@warning "-4"] x -> fooooooooooooooooooooooo let _ = foo >>= fun [@warning "-4"] x y -> - fooooooooooooooooooooooo fooooooooooooooooooooooo - fooooooooooooooooooooooo fooooooooooooooooooooooo + fooooooooooooooooooooooo fooooooooooooooooooooooo fooooooooooooooooooooooo + fooooooooooooooooooooooo let _ = foo @@ -178,7 +174,7 @@ let _ = let _ = foo >>= fun (* foo before *) [@warning "-4"] (* foo after *) x -> - fooooooooooooooooooooooo + fooooooooooooooooooooooo let f = Ok () @@ -211,7 +207,7 @@ let f = >>= (* fooooooooooooooo fooooooooooooooo fooooooooooooooo foooooooooooooooo *) fun foooooo fooooo foooo foooooo -> - Ok foooooooooooooooooooooooooooooooooooooooooooooooooo + Ok foooooooooooooooooooooooooooooooooooooooooooooooooo let f = Ok () @@ -245,7 +241,7 @@ let default = command ## hasPermission #= (fun ctx -> - foooooooooooooooooo fooooooooooo foooooo fooooooooo foooooooooo ) ; + foooooooooooooooooo fooooooooooo foooooo fooooooooo foooooooooo ) ; foo let _ = ( let* ) x (fun y -> z) diff --git a/test/passing/tests/ite-compact.ml.ref b/test/passing/tests/ite-compact.ml.ref index 61e49d2eb0..38d75617b6 100644 --- a/test/passing/tests/ite-compact.ml.ref +++ b/test/passing/tests/ite-compact.ml.ref @@ -135,12 +135,10 @@ let _ = else ( - ) let _ = - if x then - fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz - else - fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + if x then fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + else fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz let _ = if diff --git a/test/passing/tests/ite-compact_closing.ml.ref b/test/passing/tests/ite-compact_closing.ml.ref index 788b371767..ba050bfa68 100644 --- a/test/passing/tests/ite-compact_closing.ml.ref +++ b/test/passing/tests/ite-compact_closing.ml.ref @@ -150,12 +150,10 @@ let _ = else ( - ) let _ = - if x then - fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz - else - fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + if x then fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + else fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz let _ = if diff --git a/test/passing/tests/ite-fit_or_vertical.ml.ref b/test/passing/tests/ite-fit_or_vertical.ml.ref index 32551a4d0f..eee4a817df 100644 --- a/test/passing/tests/ite-fit_or_vertical.ml.ref +++ b/test/passing/tests/ite-fit_or_vertical.ml.ref @@ -164,10 +164,10 @@ let _ = let _ = if x then fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz else fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz let _ = if diff --git a/test/passing/tests/ite-fit_or_vertical_closing.ml.ref b/test/passing/tests/ite-fit_or_vertical_closing.ml.ref index b4aab9f9cf..6bfc9ec2ce 100644 --- a/test/passing/tests/ite-fit_or_vertical_closing.ml.ref +++ b/test/passing/tests/ite-fit_or_vertical_closing.ml.ref @@ -176,10 +176,10 @@ let _ = let _ = if x then fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz else fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz let _ = if diff --git a/test/passing/tests/ite-fit_or_vertical_no_indicate.ml.ref b/test/passing/tests/ite-fit_or_vertical_no_indicate.ml.ref index b07442e27f..411368d842 100644 --- a/test/passing/tests/ite-fit_or_vertical_no_indicate.ml.ref +++ b/test/passing/tests/ite-fit_or_vertical_no_indicate.ml.ref @@ -164,10 +164,10 @@ let _ = let _ = if x then fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz else fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz let _ = if diff --git a/test/passing/tests/ite-kr.ml.ref b/test/passing/tests/ite-kr.ml.ref index d36a09a267..28d2dbb092 100644 --- a/test/passing/tests/ite-kr.ml.ref +++ b/test/passing/tests/ite-kr.ml.ref @@ -199,10 +199,10 @@ let _ = let _ = if x then fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz else fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz let _ = if diff --git a/test/passing/tests/ite-kr_closing.ml.ref b/test/passing/tests/ite-kr_closing.ml.ref index 1a81f9539a..8fc41701c5 100644 --- a/test/passing/tests/ite-kr_closing.ml.ref +++ b/test/passing/tests/ite-kr_closing.ml.ref @@ -209,10 +209,10 @@ let _ = let _ = if x then fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz else fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz let _ = if diff --git a/test/passing/tests/ite-no_indicate.ml.ref b/test/passing/tests/ite-no_indicate.ml.ref index a6e647db75..78627d847b 100644 --- a/test/passing/tests/ite-no_indicate.ml.ref +++ b/test/passing/tests/ite-no_indicate.ml.ref @@ -134,12 +134,10 @@ let _ = else ( - ) let _ = - if x then - fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz - else - fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + if x then fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + else fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz let _ = if diff --git a/test/passing/tests/ite.ml.ref b/test/passing/tests/ite.ml.ref index 61e49d2eb0..38d75617b6 100644 --- a/test/passing/tests/ite.ml.ref +++ b/test/passing/tests/ite.ml.ref @@ -135,12 +135,10 @@ let _ = else ( - ) let _ = - if x then - fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz - else - fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + if x then fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + else fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz let _ = if diff --git a/test/passing/tests/js_bind.ml.ref b/test/passing/tests/js_bind.ml.ref index e0f84775cb..4cdbd05986 100644 --- a/test/passing/tests/js_bind.ml.ref +++ b/test/passing/tests/js_bind.ml.ref @@ -15,7 +15,6 @@ let old_good = let old_good = foo bar qaz *>>| fun x -> - hey ho lala - *>>> fun y -> - foo bar qaz - +>>| fun x -> hey ho lala +>>> fun y -> return (x, y) + hey ho lala + *>>> fun y -> + foo bar qaz +>>| fun x -> hey ho lala +>>> fun y -> return (x, y) diff --git a/test/passing/tests/js_fun.ml.ref b/test/passing/tests/js_fun.ml.ref index 8a3c3aeb7c..ed721865c3 100644 --- a/test/passing/tests/js_fun.ml.ref +++ b/test/passing/tests/js_fun.ml.ref @@ -13,8 +13,7 @@ let _ = [f (fun x -> x); f (fun x -> x); f (fun x -> x)] let _ = x >>= fun x -> - (try x with _ -> ()) - >>= fun x -> try x with _ -> () >>= fun x -> x + (try x with _ -> ()) >>= fun x -> try x with _ -> () >>= fun x -> x let () = expr >>| function x -> 3 | y -> 4 diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index c9b0754fa4..f832e7de27 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -2024,14 +2024,14 @@ type assoc = Assoc : string * 'a rep * 'a -> assoc let rec assoc : type a. string -> a rep -> assoc list -> a = fun x r ->function - | [] -> raise Not_found - | Assoc (x', r', v) :: env -> - if x = x' - then ( - match rep_equal r r' with - | None -> failwith ("Wrong type for " ^ x) - | Some Eq -> v) - else assoc x r env + | [] -> raise Not_found + | Assoc (x', r', v) :: env -> + if x = x' + then ( + match rep_equal r r' with + | None -> failwith ("Wrong type for " ^ x) + | Some Eq -> v) + else assoc x r env ;; type _ term = @@ -2045,13 +2045,13 @@ type _ term = let rec eval_term : type a. assoc list -> a term -> a = fun env ->function - | Var (x, r) -> assoc x r env - | Abs (x, r, e) -> fun v -> eval_term (Assoc (x, r, v) :: env) e - | Const x -> x - | Add -> fun (x, y) -> x + y - | LT -> fun (x, y) -> x < y - | Ap (f, x) -> eval_term env f (eval_term env x) - | Pair (x, y) -> eval_term env x, eval_term env y + | Var (x, r) -> assoc x r env + | Abs (x, r, e) -> fun v -> eval_term (Assoc (x, r, v) :: env) e + | Const x -> x + | Add -> fun (x, y) -> x + y + | LT -> fun (x, y) -> x < y + | Ap (f, x) -> eval_term env f (eval_term env x) + | Pair (x, y) -> eval_term env x, eval_term env y ;; let ex3 = Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint)))) diff --git a/test/passing/tests/js_upon.ml.ref b/test/passing/tests/js_upon.ml.ref index 22b36d5aee..87df8ba5cb 100644 --- a/test/passing/tests/js_upon.ml.ref +++ b/test/passing/tests/js_upon.ml.ref @@ -3,8 +3,8 @@ let f x = (* We don't do this as a matter of style, but the indentation reveals a common mistake. *) >>> fun () -> - don't_wait_for (close fd) ; - bind fd + don't_wait_for (close fd) ; + bind fd let f x = ( stop diff --git a/test/passing/tests/source.ml.ref b/test/passing/tests/source.ml.ref index b44705c3f0..e2e3e703fa 100644 --- a/test/passing/tests/source.ml.ref +++ b/test/passing/tests/source.ml.ref @@ -1973,13 +1973,14 @@ let rec rep_equal : type a b. a rep -> b rep -> (a, b) equal option = type assoc = Assoc : string * 'a rep * 'a -> assoc let rec assoc : type a. string -> a rep -> assoc list -> a = - fun x r ->function [] -> raise Not_found - | Assoc (x', r', v) :: env -> - if x = x' then - match rep_equal r r' with - | None -> failwith ("Wrong type for " ^ x) - | Some Eq -> v - else assoc x r env + fun x r ->function + | [] -> raise Not_found + | Assoc (x', r', v) :: env -> + if x = x' then + match rep_equal r r' with + | None -> failwith ("Wrong type for " ^ x) + | Some Eq -> v + else assoc x r env type _ term = | Var : string * 'a rep -> 'a term @@ -1991,11 +1992,14 @@ type _ term = | Pair : 'a term * 'b term -> ('a * 'b) term let rec eval_term : type a. assoc list -> a term -> a = - fun env ->function Var (x, r) -> assoc x r env - | Abs (x, r, e) -> fun v -> eval_term (Assoc (x, r, v) :: env) e - | Const x -> x | Add -> fun (x, y) -> x + y | LT -> fun (x, y) -> x < y - | Ap (f, x) -> eval_term env f (eval_term env x) - | Pair (x, y) -> (eval_term env x, eval_term env y) + fun env ->function + | Var (x, r) -> assoc x r env + | Abs (x, r, e) -> fun v -> eval_term (Assoc (x, r, v) :: env) e + | Const x -> x + | Add -> fun (x, y) -> x + y + | LT -> fun (x, y) -> x < y + | Ap (f, x) -> eval_term env f (eval_term env x) + | Pair (x, y) -> (eval_term env x, eval_term env y) let ex3 = Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint)))) From 5a3a6c5490725fe8b4101161dfbafbb4dde9e03c Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Mon, 6 May 2024 18:30:43 +0200 Subject: [PATCH 037/146] dont align function paramater in `let _ = fun` --- lib/Fmt_ast.ml | 22 +++++++++---------- lib/Params.ml | 11 ++++++++-- lib/Params.mli | 3 ++- .../break_fun_decl-fit_or_vertical.ml.ref | 5 +++-- .../passing/tests/break_fun_decl-smart.ml.ref | 5 +++-- test/passing/tests/break_fun_decl-wrap.ml.ref | 5 +++-- test/passing/tests/break_fun_decl.ml | 5 +++-- test/passing/tests/labelled_args-414.ml.ref | 13 ++++++----- test/passing/tests/labelled_args.ml | 13 ++++++----- 9 files changed, 50 insertions(+), 32 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 46a9f760e3..7a59dee3da 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1439,7 +1439,7 @@ and fmt_indexop_access c ctx ~fmt_atrs ~has_attr ~parens x = (** Format a [Pexp_function]. [wrap_intro] wraps up to after the [->] and is responsible for breaking. *) -and fmt_function ?force_closing_paren ~ctx ?(wrap_intro = fun x -> hvbox 2 x $ space_break) ?(box = true) +and fmt_function ?force_closing_paren ~ctx ~ctx0 ?(wrap_intro = fun x -> hvbox 2 x $ space_break) ?(box = true) ~label ?(parens = false) ?ext ~attrs ~loc c (args, typ, body) = let has_label = match label with Nolabel -> false | _ -> true in (* Make sure the comment is placed after the eventual label but not into @@ -1468,7 +1468,7 @@ and fmt_function ?force_closing_paren ~ctx ?(wrap_intro = fun x -> hvbox 2 x $ s and args = fmt_expr_fun_args c args and annot = Option.map ~f:fmt_typ typ in - Params.Exp.box_fun_decl_args c.conf ~parens ~kw ~args ~annot + Params.Exp.box_fun_decl_args ~ctx:ctx0 c.conf ~parens ~kw ~args ~annot $ break 1 (-2) $ str "->" in (* [head] is [fun args ->] or [function]. [body] is an expression or the @@ -1537,7 +1537,7 @@ and fmt_label_arg ?(box = true) ?eol c (lbl, ({ast= arg; _} as xarg)) = ~box xarg ) $ cmts_after ) | (Labelled _ | Optional _), Pexp_function (args, typ, body) -> - fmt_function ~ctx:(Exp arg) ~label:lbl ~parens:true ~attrs:arg.pexp_attributes ~loc:arg.pexp_loc c (args, typ, body) + fmt_function ~ctx:(Exp arg) ~ctx0:xarg.ctx ~label:lbl ~parens:true ~attrs:arg.pexp_attributes ~loc:arg.pexp_loc c (args, typ, body) | _ -> let label_sep : t = if box || c.conf.fmt_opts.wrap_fun_args.v then str ":" $ cut_break @@ -1820,7 +1820,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens (Params.parens_if parens c.conf ( hvbox c.conf.fmt_opts.extension_indent.v (wrap (str "[") (str "]") - (fmt_function ~ctx:(Exp call) ~wrap_intro:(fun x -> + (fmt_function ~ctx:(Exp call) ~ctx0 ~wrap_intro:(fun x -> ( str "%" $ hovbox 2 ( fmt_str_loc c name $ space_break $ x))$space_break) @@ -1848,7 +1848,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens $ Cmts.fmt c loc (str "|>" $ force_newline) $ hvbox c.conf.fmt_opts.extension_indent.v (wrap (str "[") (str "]") - (fmt_function ~ctx:(Exp retn) ~wrap_intro:(fun x -> + (fmt_function ~ctx:(Exp retn) ~ctx0 ~wrap_intro:(fun x -> ( str "%" $ hovbox 2 ( fmt_str_loc c name $ space_break $ x))$space_break) @@ -1918,13 +1918,13 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens ( hovbox 0 (wrap_if has_attr (str "(") (str ")") (fmt_function - ~ctx:(Exp r) ~box:false ~parens:(parens_r) ~wrap_intro:(fun intro -> - ( + ~ctx:(Exp r) ~ctx0 ~box:false ~parens:(parens_r) ~wrap_intro:(fun intro -> + ( ( hvbox indent_wrap ( fmt_expression ~indent_wrap c (sub_exp ~ctx l) $ space_break $ hovbox 0 - ( + ( ( fmt_str_loc c op $ space_break $ intro))) ) ) $ space_break) @@ -2041,7 +2041,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens then Fit else Break in - fmt_function ~force_closing_paren ~ctx:inner_ctx ~wrap_intro ~label:lbl ~parens:true ~attrs:last_arg.pexp_attributes ~loc:last_arg.pexp_loc c (largs, ltyp, lbody) + fmt_function ~force_closing_paren ~ctx:inner_ctx ~ctx0:ctx ~wrap_intro ~label:lbl ~parens:true ~attrs:last_arg.pexp_attributes ~loc:last_arg.pexp_loc c (largs, ltyp, lbody) in hvbox_if has_attr 0 (expr_epi $ Params.parens_if parens c.conf (args $ fmt_atrs)) @@ -2185,12 +2185,12 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens (* else Params.Indent.fun_ ?eol c.conf *) (* in *) pro - $ + $ ( (* Params.Exp.wrap c.conf ~parens ~disambiguate:true *) (* ~fits_breaks:false ~offset_closing_paren:(-2) *) ( - fmt_function ~box ~ctx + fmt_function ~box ~ctx ~ctx0 ~label:Nolabel ~parens ?ext ~attrs:pexp_attributes ~loc:pexp_loc c (args, typ, body) ) ) | Pexp_function ([], None, Pfunction_cases (cs, _, _)) -> diff --git a/lib/Params.ml b/lib/Params.ml index 64bc3f6f69..d02531a391 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -91,10 +91,17 @@ module Exp = struct $ Fmt.fits_breaks ")" ~hint:(1000, offset_closing_paren) ")" | `No -> wrap (str "(") (str ")") k - let box_fun_decl_args c ~parens ~kw ~args ~annot = + let box_fun_decl_args ~ctx c ~parens ~kw ~args ~annot = + let is_let_func = + match ctx with + Ast.Str _ -> + (* special case than aligns the arguments of [let _ = fun ...] *) true | _ -> false + in let box_decl, should_box_args = if ocp c then (hvbox (if parens then 1 else 2), false) - else (hovbox 4, not c.fmt_opts.wrap_fun_args.v) + else + ( (if is_let_func then hovbox 4 else hvbox (if parens then 1 else 2)) + , not c.fmt_opts.wrap_fun_args.v ) in box_decl (kw $ hvbox_if should_box_args 0 args $ fmt_opt annot) end diff --git a/lib/Params.mli b/lib/Params.mli index 393c04aeef..cf85ed64d9 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -37,7 +37,8 @@ module Exp : sig -> Fmt.t val box_fun_decl_args : - Conf.t + ctx:Ast.t + -> Conf.t -> parens:bool -> kw:Fmt.t -> args:Fmt.t diff --git a/test/passing/tests/break_fun_decl-fit_or_vertical.ml.ref b/test/passing/tests/break_fun_decl-fit_or_vertical.ml.ref index 5b1bd7fe2f..a4667b10d9 100644 --- a/test/passing/tests/break_fun_decl-fit_or_vertical.ml.ref +++ b/test/passing/tests/break_fun_decl-fit_or_vertical.ml.ref @@ -125,8 +125,9 @@ let _ = let _ = f - (fun (module Store : Irmin.Generic_key.S with type repo = repo) - (module Store : Irmin.Generic_key.S with type repo = repo) + (fun + (module Store : Irmin.Generic_key.S with type repo = repo) + (module Store : Irmin.Generic_key.S with type repo = repo) -> body ) let f diff --git a/test/passing/tests/break_fun_decl-smart.ml.ref b/test/passing/tests/break_fun_decl-smart.ml.ref index d12bcdae0a..b00e7fd1ae 100644 --- a/test/passing/tests/break_fun_decl-smart.ml.ref +++ b/test/passing/tests/break_fun_decl-smart.ml.ref @@ -118,8 +118,9 @@ let _ = let _ = f - (fun (module Store : Irmin.Generic_key.S with type repo = repo) - (module Store : Irmin.Generic_key.S with type repo = repo) + (fun + (module Store : Irmin.Generic_key.S with type repo = repo) + (module Store : Irmin.Generic_key.S with type repo = repo) -> body ) let f diff --git a/test/passing/tests/break_fun_decl-wrap.ml.ref b/test/passing/tests/break_fun_decl-wrap.ml.ref index f5c072a108..0aa6d3603f 100644 --- a/test/passing/tests/break_fun_decl-wrap.ml.ref +++ b/test/passing/tests/break_fun_decl-wrap.ml.ref @@ -100,8 +100,9 @@ let _ = let _ = f - (fun (module Store : Irmin.Generic_key.S with type repo = repo) - (module Store : Irmin.Generic_key.S with type repo = repo) + (fun + (module Store : Irmin.Generic_key.S with type repo = repo) + (module Store : Irmin.Generic_key.S with type repo = repo) -> body ) let f (module Store : Irmin.Generic_key.S with type repo = repo) diff --git a/test/passing/tests/break_fun_decl.ml b/test/passing/tests/break_fun_decl.ml index f5c072a108..0aa6d3603f 100644 --- a/test/passing/tests/break_fun_decl.ml +++ b/test/passing/tests/break_fun_decl.ml @@ -100,8 +100,9 @@ let _ = let _ = f - (fun (module Store : Irmin.Generic_key.S with type repo = repo) - (module Store : Irmin.Generic_key.S with type repo = repo) + (fun + (module Store : Irmin.Generic_key.S with type repo = repo) + (module Store : Irmin.Generic_key.S with type repo = repo) -> body ) let f (module Store : Irmin.Generic_key.S with type repo = repo) diff --git a/test/passing/tests/labelled_args-414.ml.ref b/test/passing/tests/labelled_args-414.ml.ref index 0de623ac54..9d76e837fd 100644 --- a/test/passing/tests/labelled_args-414.ml.ref +++ b/test/passing/tests/labelled_args-414.ml.ref @@ -4,14 +4,17 @@ let _ = let () = very_long_function_name - ~very_long_argument_label:(fun very_long_argument_name_one - very_long_argument_name_two - very_long_argument_name_three + ~very_long_argument_label:(fun + very_long_argument_name_one + very_long_argument_name_two + very_long_argument_name_three -> () ) let () = very_long_function_name ~very_long_argument_label:(* foo *) - (fun very_long_argument_name_one very_long_argument_name_two - very_long_argument_name_three + (fun + very_long_argument_name_one + very_long_argument_name_two + very_long_argument_name_three -> () ) diff --git a/test/passing/tests/labelled_args.ml b/test/passing/tests/labelled_args.ml index 92ab1a0bb2..e7a25ae703 100644 --- a/test/passing/tests/labelled_args.ml +++ b/test/passing/tests/labelled_args.ml @@ -4,14 +4,17 @@ let _ = let () = very_long_function_name - ~very_long_argument_label:(fun very_long_argument_name_one - very_long_argument_name_two - very_long_argument_name_three + ~very_long_argument_label:(fun + very_long_argument_name_one + very_long_argument_name_two + very_long_argument_name_three -> () ) let () = very_long_function_name ~very_long_argument_label:(* foo *) - (fun very_long_argument_name_one very_long_argument_name_two - very_long_argument_name_three + (fun + very_long_argument_name_one + very_long_argument_name_two + very_long_argument_name_three -> () ) From 207df8b98c3551d41a9e0da7f922734f0179094c Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 13 May 2024 18:55:01 +0200 Subject: [PATCH 038/146] tests Remove now unecessary --max-iter --- test/passing/dune.inc | 2 +- test/passing/tests/attributes.ml.opts | 1 - 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/test/passing/dune.inc b/test/passing/dune.inc index a413ad22da..1f9d1c1cc3 100644 --- a/test/passing/dune.inc +++ b/test/passing/dune.inc @@ -185,7 +185,7 @@ (action (with-stdout-to attributes.ml.stdout (with-stderr-to attributes.ml.stderr - (run %{bin:ocamlformat} --margin-check --max-iter=3 %{dep:tests/attributes.ml}))))) + (run %{bin:ocamlformat} --margin-check %{dep:tests/attributes.ml}))))) (rule (alias runtest) diff --git a/test/passing/tests/attributes.ml.opts b/test/passing/tests/attributes.ml.opts index a2f04741b8..e69de29bb2 100644 --- a/test/passing/tests/attributes.ml.opts +++ b/test/passing/tests/attributes.ml.opts @@ -1 +0,0 @@ ---max-iter=3 From 9958c84b267eb0c7bfcf93137c8ce2f18a36fa51 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 13 May 2024 19:13:11 +0200 Subject: [PATCH 039/146] Format comments after pro in expression This fixes one comment placement bug but introduce an other. --- lib/Fmt_ast.ml | 5 +++-- test/passing/tests/comments-no-wrap.ml.err | 8 ++++---- test/passing/tests/comments-no-wrap.ml.ref | 3 +-- test/passing/tests/comments.ml.err | 2 +- test/passing/tests/comments.ml.ref | 3 +-- test/passing/tests/ite-fit_or_vertical.ml.ref | 8 ++++---- test/passing/tests/ite-fit_or_vertical_closing.ml.ref | 8 ++++---- test/passing/tests/ite-fit_or_vertical_no_indicate.ml.ref | 8 ++++---- test/passing/tests/loc_stack.ml.ref | 3 ++- test/passing/tests/source.ml.ref | 6 +++--- 10 files changed, 27 insertions(+), 27 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 7a59dee3da..dcb5026562 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1782,7 +1782,8 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens update_config_maybe_disabled c pexp_loc pexp_attributes @@ fun c -> Cmts.relocate_wrongfully_attached_cmts c.cmts c.source exp ; - let fmt_cmts = Cmts.fmt c ?eol pexp_loc in + let pro = pro $ Cmts.fmt_before c ?eol pexp_loc in + let fmt_cmts_after k = k $ Cmts.fmt_after c pexp_loc in let fmt_atrs = fmt_attributes c ~pre:Space pexp_attributes in let has_attr = not (List.is_empty pexp_attributes) in let parens = Option.value parens ~default:(parenze_exp xexp) in @@ -1791,7 +1792,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens fmt_args_grouped c ctx ?epi ((Nolabel, e0) :: a1N) in hvbox_if box 0 ~name:"expr" - @@ fmt_cmts + @@ fmt_cmts_after @@ match pexp_desc with | Pexp_apply (_, []) -> impossible "not produced by parser" diff --git a/test/passing/tests/comments-no-wrap.ml.err b/test/passing/tests/comments-no-wrap.ml.err index 341f8e8f2a..82121cfa75 100644 --- a/test/passing/tests/comments-no-wrap.ml.err +++ b/test/passing/tests/comments-no-wrap.ml.err @@ -1,4 +1,4 @@ -Warning: tests/comments.ml:187 exceeds the margin -Warning: tests/comments.ml:191 exceeds the margin -Warning: tests/comments.ml:251 exceeds the margin -Warning: tests/comments.ml:435 exceeds the margin +Warning: tests/comments.ml:186 exceeds the margin +Warning: tests/comments.ml:190 exceeds the margin +Warning: tests/comments.ml:250 exceeds the margin +Warning: tests/comments.ml:434 exceeds the margin diff --git a/test/passing/tests/comments-no-wrap.ml.ref b/test/passing/tests/comments-no-wrap.ml.ref index 4b7a1b7f9d..cd5bd7c83a 100644 --- a/test/passing/tests/comments-no-wrap.ml.ref +++ b/test/passing/tests/comments-no-wrap.ml.ref @@ -112,8 +112,7 @@ module type T = sig and B : sig end end -(* comment *) -let f = function x -> x +let f = (* comment *) function x -> x let foo x = (* comment *) (y : z) diff --git a/test/passing/tests/comments.ml.err b/test/passing/tests/comments.ml.err index 8758438258..17f191fb4d 100644 --- a/test/passing/tests/comments.ml.err +++ b/test/passing/tests/comments.ml.err @@ -1 +1 @@ -Warning: tests/comments.ml:253 exceeds the margin +Warning: tests/comments.ml:252 exceeds the margin diff --git a/test/passing/tests/comments.ml.ref b/test/passing/tests/comments.ml.ref index eff5ba9af9..a637c9b6b3 100644 --- a/test/passing/tests/comments.ml.ref +++ b/test/passing/tests/comments.ml.ref @@ -112,8 +112,7 @@ module type T = sig and B : sig end end -(* comment *) -let f = function x -> x +let f = (* comment *) function x -> x let foo x = (* comment *) (y : z) diff --git a/test/passing/tests/ite-fit_or_vertical.ml.ref b/test/passing/tests/ite-fit_or_vertical.ml.ref index eee4a817df..ad3c2b5512 100644 --- a/test/passing/tests/ite-fit_or_vertical.ml.ref +++ b/test/passing/tests/ite-fit_or_vertical.ml.ref @@ -143,10 +143,10 @@ let foo = let foo = if cmp < 0 then (* foo *) a + b else (* foo *) a - b let foo = - if cmp < 0 then (* ast higher precedence than context: no parens *) - false - else if cmp > 0 then (* context higher prec than ast: add parens *) - true + if cmp < 0 then + (* ast higher precedence than context: no parens *) false + else if cmp > 0 then + (* context higher prec than ast: add parens *) true else if Poly.(assoc_of_prec prec_ast = which_child && which_child <> Non) then foo diff --git a/test/passing/tests/ite-fit_or_vertical_closing.ml.ref b/test/passing/tests/ite-fit_or_vertical_closing.ml.ref index 6bfc9ec2ce..7cf962e6b9 100644 --- a/test/passing/tests/ite-fit_or_vertical_closing.ml.ref +++ b/test/passing/tests/ite-fit_or_vertical_closing.ml.ref @@ -155,10 +155,10 @@ let foo = let foo = if cmp < 0 then (* foo *) a + b else (* foo *) a - b let foo = - if cmp < 0 then (* ast higher precedence than context: no parens *) - false - else if cmp > 0 then (* context higher prec than ast: add parens *) - true + if cmp < 0 then + (* ast higher precedence than context: no parens *) false + else if cmp > 0 then + (* context higher prec than ast: add parens *) true else if Poly.(assoc_of_prec prec_ast = which_child && which_child <> Non) then foo diff --git a/test/passing/tests/ite-fit_or_vertical_no_indicate.ml.ref b/test/passing/tests/ite-fit_or_vertical_no_indicate.ml.ref index 411368d842..bc57a1c7a1 100644 --- a/test/passing/tests/ite-fit_or_vertical_no_indicate.ml.ref +++ b/test/passing/tests/ite-fit_or_vertical_no_indicate.ml.ref @@ -143,10 +143,10 @@ let foo = let foo = if cmp < 0 then (* foo *) a + b else (* foo *) a - b let foo = - if cmp < 0 then (* ast higher precedence than context: no parens *) - false - else if cmp > 0 then (* context higher prec than ast: add parens *) - true + if cmp < 0 then + (* ast higher precedence than context: no parens *) false + else if cmp > 0 then + (* context higher prec than ast: add parens *) true else if Poly.(assoc_of_prec prec_ast = which_child && which_child <> Non) then foo diff --git a/test/passing/tests/loc_stack.ml.ref b/test/passing/tests/loc_stack.ml.ref index 7b842aca3c..5f6517d938 100644 --- a/test/passing/tests/loc_stack.ml.ref +++ b/test/passing/tests/loc_stack.ml.ref @@ -5,7 +5,8 @@ let _ = let _ = (* before match *) - match (* after match *) x with _ -> 1 + match (* after match *) x with + | _ -> 1 let _ = (* before try *) diff --git a/test/passing/tests/source.ml.ref b/test/passing/tests/source.ml.ref index e2e3e703fa..0e693261d4 100644 --- a/test/passing/tests/source.ml.ref +++ b/test/passing/tests/source.ml.ref @@ -9172,10 +9172,10 @@ let eradicate_meta_class_is_nullsafe = ~user_documentation:"" let eradicate_meta_class_is_nullsafe = - register - ~id:"ERADICATE_META_CLASS_IS_NULLSAFE" + register ~id:"ERADICATE_META_CLASS_IS_NULLSAFE" + ~hum: (* Should be enabled for special integrations *) - ~hum:"Class is marked @Nullsafe and has 0 issues" + "Class is marked @Nullsafe and has 0 issues" (* Should be enabled for special integrations *) ~enabled:false Info From 2afbc1ec8270c2a3c7619044ce0b0f52b0a69330 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 13 May 2024 19:14:57 +0200 Subject: [PATCH 040/146] Don't ignore Pfunction_cases loc and attrs No test case could be found but it's safer that way. --- lib/Fmt_ast.ml | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index dcb5026562..7f0321d7d9 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -2194,18 +2194,20 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens fmt_function ~box ~ctx ~ctx0 ~label:Nolabel ~parens ?ext ~attrs:pexp_attributes ~loc:pexp_loc c (args, typ, body) ) ) - | Pexp_function ([], None, Pfunction_cases (cs, _, _)) -> + | Pexp_function ([], None, Pfunction_cases (cs, cs_loc, cs_attrs)) -> let indent = Params.Indent.function_ c.conf ~parens xexp in let outer_pro, inner_pro = if parens then pro, noop else noop, pro in outer_pro $ Params.Exp.wrap c.conf ~parens ~disambiguate:true ~fits_breaks:false @@ Params.Align.function_ c.conf ~parens ~ctx0 ~self:exp - @@ ( hvbox 2 + @@ ( Cmts.fmt_before c cs_loc $ hvbox 2 (inner_pro $ str "function" $ fmt_extension_suffix c ext - $ fmt_attributes c pexp_attributes ) + $ fmt_attributes c pexp_attributes + $ fmt_attributes c cs_attrs ) $ break 1 indent - $ hvbox 0 (fmt_cases c ctx cs) ) + $ hvbox 0 (fmt_cases c ctx cs) + $ Cmts.fmt_after c cs_loc) | Pexp_function ([], Some _, _) -> assert false | Pexp_ident {txt; loc} -> let outer_parens = has_attr && parens in From 202bad49756c40181592a96afef62e623607bb25 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 13 May 2024 19:17:34 +0200 Subject: [PATCH 041/146] Fix missing space in 'fun _ ->function' --- lib/Fmt_ast.ml | 2 +- test/passing/tests/fun_decl.ml | 2 +- test/passing/tests/fun_function.ml | 2 +- test/passing/tests/js_fun.ml.ref | 2 +- test/passing/tests/js_source.ml.ocp | 8 ++++---- test/passing/tests/js_source.ml.ref | 8 ++++---- test/passing/tests/match.ml | 8 ++++---- test/passing/tests/source.ml.ref | 8 ++++---- 8 files changed, 20 insertions(+), 20 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 7f0321d7d9..7163ee03c4 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1486,7 +1486,7 @@ and fmt_function ?force_closing_paren ~ctx ~ctx0 ?(wrap_intro = fun x -> hvbox 2 match args, typ with | [], None -> noop, attrs | [], Some _ -> assert false - | args, typ -> fmt_fun_args_typ args typ, [] + | args, typ -> fmt_fun_args_typ args typ $ space_break, [] in let function_ = str "function" $ fmt_attributes c ~pre:Blank spilled_attrs $ fmt_attributes c ~pre:Blank cs_attrs diff --git a/test/passing/tests/fun_decl.ml b/test/passing/tests/fun_decl.ml index d79d85002a..9073d76bab 100644 --- a/test/passing/tests/fun_decl.ml +++ b/test/passing/tests/fun_decl.ml @@ -66,5 +66,5 @@ let translate_captured let f ssssssssss = String.fold ssssssssss ~init:innnnnnnnnnit - ~f:(fun accuuuuuuuuuum ->function '0' -> g accuuuuuuuuuum + ~f:(fun accuuuuuuuuuum -> function '0' -> g accuuuuuuuuuum | '1' -> h accuuuuuuuuuum | _ -> i accuuuuuuuuuum ) diff --git a/test/passing/tests/fun_function.ml b/test/passing/tests/fun_function.ml index 3b8174beae..7855a766a3 100644 --- a/test/passing/tests/fun_function.ml +++ b/test/passing/tests/fun_function.ml @@ -1,3 +1,3 @@ let s = - List.fold x ~f:(fun y ->function Aconstructor avalue -> afunction avalue + List.fold x ~f:(fun y -> function Aconstructor avalue -> afunction avalue | Bconstructor bvalue -> bfunction bvalue ) diff --git a/test/passing/tests/js_fun.ml.ref b/test/passing/tests/js_fun.ml.ref index ed721865c3..4a85c8f078 100644 --- a/test/passing/tests/js_fun.ml.ref +++ b/test/passing/tests/js_fun.ml.ref @@ -19,7 +19,7 @@ let () = expr >>| function x -> 3 | y -> 4 let () = expr >>| fun z -> match z with x -> 3 | y -> 4 -let () = expr >>| fun z ->function x -> 3 | y -> 4 +let () = expr >>| fun z -> function x -> 3 | y -> 4 let () = my_func () >>= function A -> 0 | B -> 0 diff --git a/test/passing/tests/js_source.ml.ocp b/test/passing/tests/js_source.ml.ocp index e6b58e2377..488a0938bb 100644 --- a/test/passing/tests/js_source.ml.ocp +++ b/test/passing/tests/js_source.ml.ocp @@ -2023,7 +2023,7 @@ let rec rep_equal : type a b. a rep -> b rep -> (a, b) equal option = type assoc = Assoc : string * 'a rep * 'a -> assoc let rec assoc : type a. string -> a rep -> assoc list -> a = - fun x r ->function + fun x r -> function | [] -> raise Not_found | Assoc (x', r', v) :: env -> if x = x' @@ -2044,7 +2044,7 @@ type _ term = | Pair : 'a term * 'b term -> ('a * 'b) term let rec eval_term : type a. assoc list -> a term -> a = - fun env ->function + fun env -> function | Var (x, r) -> assoc x r env | Abs (x, r, e) -> fun v -> eval_term (Assoc (x, r, v) :: env) e | Const x -> x @@ -10213,7 +10213,7 @@ let _ = Foooooooooooooooooooo.foooooooooooooooooooo foooooooooooooooooooo foooooooooooooooooooo - (fun x ->function + (fun x -> function | Foooooooooooooooooooo -> foooooooooooooooooooo | Foooooooooooooooooooo -> foooooooooooooooooooo) ;; @@ -10222,7 +10222,7 @@ let _ = Foooooooooooooooooooo.foooooooooooooooooooo foooooooooooooooooooo foooooooooooooooooooo - ~x:(fun x ->function + ~x:(fun x -> function | Foooooooooooooooooooo -> foooooooooooooooooooo | Foooooooooooooooooooo -> foooooooooooooooooooo) ;; diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index f832e7de27..492671b995 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -2023,7 +2023,7 @@ let rec rep_equal : type a b. a rep -> b rep -> (a, b) equal option = type assoc = Assoc : string * 'a rep * 'a -> assoc let rec assoc : type a. string -> a rep -> assoc list -> a = - fun x r ->function + fun x r -> function | [] -> raise Not_found | Assoc (x', r', v) :: env -> if x = x' @@ -2044,7 +2044,7 @@ type _ term = | Pair : 'a term * 'b term -> ('a * 'b) term let rec eval_term : type a. assoc list -> a term -> a = - fun env ->function + fun env -> function | Var (x, r) -> assoc x r env | Abs (x, r, e) -> fun v -> eval_term (Assoc (x, r, v) :: env) e | Const x -> x @@ -10213,7 +10213,7 @@ let _ = Foooooooooooooooooooo.foooooooooooooooooooo foooooooooooooooooooo foooooooooooooooooooo - (fun x ->function + (fun x -> function | Foooooooooooooooooooo -> foooooooooooooooooooo | Foooooooooooooooooooo -> foooooooooooooooooooo) ;; @@ -10222,7 +10222,7 @@ let _ = Foooooooooooooooooooo.foooooooooooooooooooo foooooooooooooooooooo foooooooooooooooooooo - ~x:(fun x ->function + ~x:(fun x -> function | Foooooooooooooooooooo -> foooooooooooooooooooo | Foooooooooooooooooooo -> foooooooooooooooooooo) ;; diff --git a/test/passing/tests/match.ml b/test/passing/tests/match.ml index c196e4bc50..f9a2b59497 100644 --- a/test/passing/tests/match.ml +++ b/test/passing/tests/match.ml @@ -34,16 +34,16 @@ let _ = let x = let g = match x with - | `A -> ( fun id ->function A -> e ; e | _ -> () ) - | `B -> ( fun id ->function A -> e ; e | _ -> () ) + | `A -> ( fun id -> function A -> e ; e | _ -> () ) + | `B -> ( fun id -> function A -> e ; e | _ -> () ) in () let x = let g = match x with - | `A -> ( fun id ->function A -> () | B -> () ) - | `B -> ( fun id ->function A -> () | _ -> () ) + | `A -> ( fun id -> function A -> () | B -> () ) + | `B -> ( fun id -> function A -> () | _ -> () ) in () diff --git a/test/passing/tests/source.ml.ref b/test/passing/tests/source.ml.ref index 0e693261d4..805b0dd4ce 100644 --- a/test/passing/tests/source.ml.ref +++ b/test/passing/tests/source.ml.ref @@ -1973,7 +1973,7 @@ let rec rep_equal : type a b. a rep -> b rep -> (a, b) equal option = type assoc = Assoc : string * 'a rep * 'a -> assoc let rec assoc : type a. string -> a rep -> assoc list -> a = - fun x r ->function + fun x r -> function | [] -> raise Not_found | Assoc (x', r', v) :: env -> if x = x' then @@ -1992,7 +1992,7 @@ type _ term = | Pair : 'a term * 'b term -> ('a * 'b) term let rec eval_term : type a. assoc list -> a term -> a = - fun env ->function + fun env -> function | Var (x, r) -> assoc x r env | Abs (x, r, e) -> fun v -> eval_term (Assoc (x, r, v) :: env) e | Const x -> x @@ -9144,7 +9144,7 @@ let formula_base x = let _ = call ~f:(fun pair -> (pair : a * b)) ;; f - (fun _ ->function + (fun _ -> function | true -> let () = () in () | false -> () ) @@ -9152,7 +9152,7 @@ f ;; f - (fun _ ->function + (fun _ -> function | true -> let () = () in () (* comment *) | false -> () ) From 7bd9700622e15fe7efabff36e079a8ab12fa47f2 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Wed, 15 May 2024 18:03:29 +0200 Subject: [PATCH 042/146] Remove space in 'function [@attr]' --- lib/Fmt_ast.ml | 6 ++-- test/passing/tests/attributes.ml | 32 +++++++++---------- .../tests/infix_bind-fit_or_vertical.ml.ref | 6 ++-- test/passing/tests/infix_bind.ml | 6 ++-- test/passing/tests/js_source.ml.err | 4 +-- test/passing/tests/js_source.ml.ocp | 15 ++++----- test/passing/tests/js_source.ml.ref | 27 +++++++--------- 7 files changed, 46 insertions(+), 50 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 7163ee03c4..0e3353a57c 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1489,9 +1489,11 @@ and fmt_function ?force_closing_paren ~ctx ~ctx0 ?(wrap_intro = fun x -> hvbox 2 | args, typ -> fmt_fun_args_typ args typ $ space_break, [] in let function_ = - str "function" $ fmt_attributes c ~pre:Blank spilled_attrs $ fmt_attributes c ~pre:Blank cs_attrs + str "function" + $ fmt_attributes c spilled_attrs + $ fmt_attributes c cs_attrs in - fun_ $ function_, fmt_cases c ctx cs + (fun_ $ function_, fmt_cases c ctx cs) in let opn_paren, cls_paren = if parens then str "(", closing_paren c ?force:force_closing_paren ~offset:(-2) diff --git a/test/passing/tests/attributes.ml b/test/passing/tests/attributes.ml index 8f2204aad4..384deeb426 100644 --- a/test/passing/tests/attributes.ml +++ b/test/passing/tests/attributes.ml @@ -138,9 +138,9 @@ let ("" [@test]) = () let _ = f x ~f:(fun [@test] x -> x) -let _ = f x ~f:(function [@test] x -> x) +let _ = f x ~f:(function[@test] x -> x) -let _ = f x ~f:(function [@test] X -> x | X -> x) +let _ = f x ~f:(function[@test] X -> x | X -> x) let () = () @@ -387,9 +387,9 @@ let _ = match x with | _ when f - ~f:(function [@ocaml.warning - (* ....................................... *) - "-4"] _ -> . ) -> + ~f:(function[@ocaml.warning + (* ....................................... *) + "-4"] _ -> . ) -> y let[@a @@ -405,18 +405,18 @@ let[@a with | _ when f - ~f:(function [@ocaml.warning - (* ....................................... *) "-4"] + ~f:(function[@ocaml.warning + (* ....................................... *) "-4"] | _ -> . ) - ~f:(function [@ocaml.warning - (* ....................................... *) - (* ....................................... *) - "foooooooooooooooooooooooooooo \ - fooooooooooooooooooooooooooooooooooooo"] _ -> . ) - ~f:(function [@ocaml.warning - (* ....................................... *) - let x = a and y = b in - x + y] _ -> . ) -> + ~f:(function[@ocaml.warning + (* ....................................... *) + (* ....................................... *) + "foooooooooooooooooooooooooooo \ + fooooooooooooooooooooooooooooooooooooo"] _ -> . ) + ~f:(function[@ocaml.warning + (* ....................................... *) + let x = a and y = b in + x + y] _ -> . ) -> y [@attr (* ... *) diff --git a/test/passing/tests/infix_bind-fit_or_vertical.ml.ref b/test/passing/tests/infix_bind-fit_or_vertical.ml.ref index 5312fc0acf..587dd8ea06 100644 --- a/test/passing/tests/infix_bind-fit_or_vertical.ml.ref +++ b/test/passing/tests/infix_bind-fit_or_vertical.ml.ref @@ -140,10 +140,10 @@ let foo = let b = Batch batch in foo -let _ = foo >>= function [@warning "-4"] A -> false | B -> true +let _ = foo >>= function[@warning "-4"] A -> false | B -> true let _ = - foo >>= function [@warning "-4"] Afoooooooooooooooooo fooooooooo -> false + foo >>= function[@warning "-4"] Afoooooooooooooooooo fooooooooo -> false | Bfoooooooooooooooooooooo fooooooooo -> true let _ = foo >>= fun [@warning "-4"] x -> fooooooooooooooooooooooo @@ -154,7 +154,7 @@ let _ = fooooooooooooooooooooooo let _ = - foo >>= function (* foo before *) [@warning "-4"] (* foo after *) + foo >>= function(* foo before *) [@warning "-4"] (* foo after *) | Afoooooooooooooooooo fooooooooo -> false | Bfoooooooooooooooooooooo fooooooooo -> true diff --git a/test/passing/tests/infix_bind.ml b/test/passing/tests/infix_bind.ml index b78cdbbe93..c2ad1f56ff 100644 --- a/test/passing/tests/infix_bind.ml +++ b/test/passing/tests/infix_bind.ml @@ -135,10 +135,10 @@ let foo = let b = Batch batch in foo -let _ = foo >>= function [@warning "-4"] A -> false | B -> true +let _ = foo >>= function[@warning "-4"] A -> false | B -> true let _ = - foo >>= function [@warning "-4"] Afoooooooooooooooooo fooooooooo -> false + foo >>= function[@warning "-4"] Afoooooooooooooooooo fooooooooo -> false | Bfoooooooooooooooooooooo fooooooooo -> true let _ = foo >>= fun [@warning "-4"] x -> fooooooooooooooooooooooo @@ -149,7 +149,7 @@ let _ = fooooooooooooooooooooooo let _ = - foo >>= function (* foo before *) [@warning "-4"] (* foo after *) + foo >>= function(* foo before *) [@warning "-4"] (* foo after *) | Afoooooooooooooooooo fooooooooo -> false | Bfoooooooooooooooooooooo fooooooooo -> true diff --git a/test/passing/tests/js_source.ml.err b/test/passing/tests/js_source.ml.err index d7396f369e..a8ebe95e04 100644 --- a/test/passing/tests/js_source.ml.err +++ b/test/passing/tests/js_source.ml.err @@ -3,5 +3,5 @@ Warning: tests/js_source.ml:2678 exceeds the margin Warning: tests/js_source.ml:9577 exceeds the margin Warning: tests/js_source.ml:9681 exceeds the margin Warning: tests/js_source.ml:9740 exceeds the margin -Warning: tests/js_source.ml:9823 exceeds the margin -Warning: tests/js_source.ml:10331 exceeds the margin +Warning: tests/js_source.ml:9821 exceeds the margin +Warning: tests/js_source.ml:10328 exceeds the margin diff --git a/test/passing/tests/js_source.ml.ocp b/test/passing/tests/js_source.ml.ocp index 488a0938bb..5604b1aadf 100644 --- a/test/passing/tests/js_source.ml.ocp +++ b/test/passing/tests/js_source.ml.ocp @@ -9814,10 +9814,8 @@ let xxxxxx = let _ = match x with | _ - when f - ~f: - (function [@ocaml.warning (* ....................................... *) "-4"] - | _ -> .) -> y + when f ~f:(function[@ocaml.warning (* ....................................... *) "-4"] + | _ -> .) -> y ;; let[@a @@ -9832,18 +9830,17 @@ let[@a with | _ when f + ~f:(function[@ocaml.warning (* ....................................... *) "-4"] + | _ -> .) ~f: - (function [@ocaml.warning (* ....................................... *) "-4"] - | _ -> .) - ~f: - (function [@ocaml.warning + (function[@ocaml.warning (* ....................................... *) (* ....................................... *) "foooooooooooooooooooooooooooo \ fooooooooooooooooooooooooooooooooooooo"] | _ -> .) ~f: - (function [@ocaml.warning + (function[@ocaml.warning (* ....................................... *) let x = a and y = b in diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index 492671b995..281e495959 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -9814,9 +9814,7 @@ let xxxxxx = let _ = match x with | _ - when f - ~f: - (function [@ocaml.warning (* ....................................... *) "-4"] + when f ~f:(function[@ocaml.warning (* ....................................... *) "-4"] | _ -> .) -> y ;; @@ -9832,22 +9830,21 @@ let[@a with | _ when f - ~f: - (function [@ocaml.warning (* ....................................... *) "-4"] + ~f:(function[@ocaml.warning (* ....................................... *) "-4"] | _ -> .) ~f: - (function [@ocaml.warning - (* ....................................... *) - (* ....................................... *) - "foooooooooooooooooooooooooooo \ - fooooooooooooooooooooooooooooooooooooo"] + (function[@ocaml.warning + (* ....................................... *) + (* ....................................... *) + "foooooooooooooooooooooooooooo \ + fooooooooooooooooooooooooooooooooooooo"] | _ -> .) ~f: - (function [@ocaml.warning - (* ....................................... *) - let x = a - and y = b in - x + y] + (function[@ocaml.warning + (* ....................................... *) + let x = a + and y = b in + x + y] | _ -> .) -> y [@attr From c814fc7cedf2322465e45bf1bf2339964991c5a5 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Wed, 15 May 2024 18:11:59 +0200 Subject: [PATCH 043/146] Restore formatting of '>>= function' In a hacky way --- lib/Fmt_ast.ml | 9 ++++++++- test/passing/tests/infix_bind-fit_or_vertical.ml.ref | 9 ++++++--- test/passing/tests/infix_bind.ml | 9 ++++++--- test/passing/tests/match2.ml | 7 +++++-- 4 files changed, 25 insertions(+), 9 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 0e3353a57c..988c3bf924 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1911,6 +1911,13 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens let xr = sub_exp ~ctx r in let parens_r = parenze_exp xr in let indent_wrap = if parens then -2 else 0 in + let box = + (* TODO: fmt_function should box correctly in the [Pfunction_cases] + case. ~box shouldn't ever be false. *) + match body with + | Pfunction_body _ -> hovbox 0 + | Pfunction_cases _ -> (fun x -> x) + in (* let followed_by_infix_op = *) (* match xbody.ast.pexp_desc with *) (* | Pexp_infix (_, _, {pexp_desc= Pexp_function _; _}) -> true *) @@ -1918,7 +1925,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens (* in *) pro $ wrap_fits_breaks_if c.conf parens "(" ")" - ( hovbox 0 + ( box (wrap_if has_attr (str "(") (str ")") (fmt_function ~ctx:(Exp r) ~ctx0 ~box:false ~parens:(parens_r) ~wrap_intro:(fun intro -> diff --git a/test/passing/tests/infix_bind-fit_or_vertical.ml.ref b/test/passing/tests/infix_bind-fit_or_vertical.ml.ref index 587dd8ea06..eefaa93f6c 100644 --- a/test/passing/tests/infix_bind-fit_or_vertical.ml.ref +++ b/test/passing/tests/infix_bind-fit_or_vertical.ml.ref @@ -56,7 +56,8 @@ eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee |> function eeeeeeeeeeeee eeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeee eeeeeeeeeeee eeeeeeeeee -|> function x -> x +|> function +| x -> x ;; eeeeeeeeeeeee eeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeee @@ -143,7 +144,8 @@ let foo = let _ = foo >>= function[@warning "-4"] A -> false | B -> true let _ = - foo >>= function[@warning "-4"] Afoooooooooooooooooo fooooooooo -> false + foo >>= function[@warning "-4"] + | Afoooooooooooooooooo fooooooooo -> false | Bfoooooooooooooooooooooo fooooooooo -> true let _ = foo >>= fun [@warning "-4"] x -> fooooooooooooooooooooooo @@ -187,7 +189,8 @@ let f = Ok () >>= (* fooooooooooooooo fooooooooooooooo fooooooooooooooo foooooooooooooooo *) - function Foo -> Ok foooooooooooooooooooooooooooooooooooooooooooooooooo + function + | Foo -> Ok foooooooooooooooooooooooooooooooooooooooooooooooooo (** The tests below are testing a dropped comment with `--no-break-infix-before-func` *) diff --git a/test/passing/tests/infix_bind.ml b/test/passing/tests/infix_bind.ml index c2ad1f56ff..2e01dde50d 100644 --- a/test/passing/tests/infix_bind.ml +++ b/test/passing/tests/infix_bind.ml @@ -56,7 +56,8 @@ eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee |> function eeeeeeeeeeeee eeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeee eeeeeeeeeeee eeeeeeeeee -|> function x -> x +|> function +| x -> x ;; eeeeeeeeeeeee eeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeee @@ -138,7 +139,8 @@ let foo = let _ = foo >>= function[@warning "-4"] A -> false | B -> true let _ = - foo >>= function[@warning "-4"] Afoooooooooooooooooo fooooooooo -> false + foo >>= function[@warning "-4"] + | Afoooooooooooooooooo fooooooooo -> false | Bfoooooooooooooooooooooo fooooooooo -> true let _ = foo >>= fun [@warning "-4"] x -> fooooooooooooooooooooooo @@ -182,7 +184,8 @@ let f = Ok () >>= (* fooooooooooooooo fooooooooooooooo fooooooooooooooo foooooooooooooooo *) - function Foo -> Ok foooooooooooooooooooooooooooooooooooooooooooooooooo + function + | Foo -> Ok foooooooooooooooooooooooooooooooooooooooooooooooooo (** The tests below are testing a dropped comment with `--no-break-infix-before-func` *) diff --git a/test/passing/tests/match2.ml b/test/passing/tests/match2.ml index 9aa038a7b1..90d5091693 100644 --- a/test/passing/tests/match2.ml +++ b/test/passing/tests/match2.ml @@ -65,8 +65,11 @@ let foo = let foo = match foo with | 1 -> - bar >>= (function a -> fooooo | b -> fooooo - | c -> foooooooo foooooooooo fooooooooooooooooooo () | _ -> () ) + bar >>= (function + | a -> fooooo + | b -> fooooo + | c -> foooooooo foooooooooo fooooooooooooooooooo () + | _ -> () ) | other -> () let _ = From 822bcf4a2bcf87de84253f6c0c8ea15746c8473e Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Fri, 17 May 2024 10:08:07 +0200 Subject: [PATCH 044/146] Restore docked fun/ction indent and remove one ~box:false This move more of the fun/function indentation code into 'fmt_function'. One instance of '~box:false' is removed in exchange for a special case in Params. --- lib/Fmt_ast.ml | 78 ++++-------- lib/Params.ml | 55 ++++----- lib/Params.mli | 8 +- test/passing/tests/attributes.ml | 11 +- test/passing/tests/fun_decl.ml | 6 +- test/passing/tests/fun_function.ml | 3 +- test/passing/tests/function_indent.ml.ref | 4 +- test/passing/tests/issue289.ml | 18 +-- test/passing/tests/issue289.ml.err | 1 + test/passing/tests/js_source.ml.err | 2 +- test/passing/tests/js_source.ml.ocp | 3 +- test/passing/tests/js_source.ml.ref | 141 +++++++++++----------- test/passing/tests/source.ml.ref | 7 +- 13 files changed, 156 insertions(+), 181 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 988c3bf924..7242968bf7 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1439,7 +1439,7 @@ and fmt_indexop_access c ctx ~fmt_atrs ~has_attr ~parens x = (** Format a [Pexp_function]. [wrap_intro] wraps up to after the [->] and is responsible for breaking. *) -and fmt_function ?force_closing_paren ~ctx ~ctx0 ?(wrap_intro = fun x -> hvbox 2 x $ space_break) ?(box = true) +and fmt_function ?force_closing_paren ~ctx ~ctx0 ?(wrap_intro = fun x -> hovbox 2 x $ space_break) ?box:(should_box = true) ~label ?(parens = false) ?ext ~attrs ~loc c (args, typ, body) = let has_label = match label with Nolabel -> false | _ -> true in (* Make sure the comment is placed after the eventual label but not into @@ -1473,33 +1473,34 @@ and fmt_function ?force_closing_paren ~ctx ~ctx0 ?(wrap_intro = fun x -> hvbox 2 in (* [head] is [fun args ->] or [function]. [body] is an expression or the cases. *) - let head, body = + let head, body, box = match args, typ, body with | (_ :: _), _, Pfunction_body body -> (* Only [fun]. *) - fmt_fun_args_typ args typ, fmt_expression c (sub_exp ~ctx body) + fmt_fun_args_typ args typ, fmt_expression c (sub_exp ~ctx body), hovbox (Params.Indent.fun_ c.conf ~ctx0) | [], _, Pfunction_body _ -> assert false | args, typ, Pfunction_cases (cs, _loc, cs_attrs) -> - (* Only [function]. [spilled_attrs] are extra attrs to add to the - [function] keyword. *) - let fun_, spilled_attrs = + (* [fun _ -> function] or [function]. [spilled_attrs] are extra attrs + to add to the [function] keyword. *) + let fun_, spilled_attrs, box = match args, typ with - | [], None -> noop, attrs + | [], None -> noop, attrs, hvbox (Params.Indent.function_ c.conf ~ctx0 ~parens ~has_label) | [], Some _ -> assert false - | args, typ -> fmt_fun_args_typ args typ $ space_break, [] + | args, typ -> fmt_fun_args_typ args typ $ space_break, [], hvbox (Params.Indent.docked_function_after_fun c.conf ~ctx0 ~parens ~has_label) in let function_ = str "function" $ fmt_attributes c spilled_attrs $ fmt_attributes c cs_attrs in - (fun_ $ function_, fmt_cases c ctx cs) + (fun_ $ function_, hvbox 0 (fmt_cases c ctx cs), box) in let opn_paren, cls_paren = if parens then str "(", closing_paren c ?force:force_closing_paren ~offset:(-2) else noop, noop in - hovbox_if box 2 + let box k = if should_box then box k else k in + box ( wrap_intro (hvbox_if has_cmts_outer 0 ( cmts_outer @@ -1851,7 +1852,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens $ Cmts.fmt c loc (str "|>" $ force_newline) $ hvbox c.conf.fmt_opts.extension_indent.v (wrap (str "[") (str "]") - (fmt_function ~ctx:(Exp retn) ~ctx0 ~wrap_intro:(fun x -> + (fmt_function ~ctx:(Exp retn) ~ctx0 ~wrap_intro:(fun x -> ( str "%" $ hovbox 2 ( fmt_str_loc c name $ space_break $ x))$space_break) @@ -1911,27 +1912,15 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens let xr = sub_exp ~ctx r in let parens_r = parenze_exp xr in let indent_wrap = if parens then -2 else 0 in - let box = - (* TODO: fmt_function should box correctly in the [Pfunction_cases] - case. ~box shouldn't ever be false. *) - match body with - | Pfunction_body _ -> hovbox 0 - | Pfunction_cases _ -> (fun x -> x) - in - (* let followed_by_infix_op = *) - (* match xbody.ast.pexp_desc with *) - (* | Pexp_infix (_, _, {pexp_desc= Pexp_function _; _}) -> true *) - (* | _ -> false *) - (* in *) pro $ wrap_fits_breaks_if c.conf parens "(" ")" - ( box - (wrap_if has_attr (str "(") (str ")") + ( + ( (fmt_function - ~ctx:(Exp r) ~ctx0 ~box:false ~parens:(parens_r) ~wrap_intro:(fun intro -> + ~ctx:(Exp r) ~ctx0:ctx ~parens:(parens_r) ~wrap_intro:(fun intro -> ( ( hvbox indent_wrap - ( fmt_expression ~indent_wrap c (sub_exp ~ctx l) + (fmt_if has_attr (str "(") $ fmt_expression ~indent_wrap c (sub_exp ~ctx l) $ space_break $ hovbox 0 ( @@ -1940,7 +1929,8 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens ) $ space_break) ~label:Nolabel ~attrs:r.pexp_attributes ~loc:r.pexp_loc c (args, typ, body) )) - $ fmt_atrs ) + $ fmt_if has_attr (str ")") + $ fmt_atrs) | Pexp_infix _ -> let op_args = Sugar.Exp.infix c.cmts (prec_ast (Exp exp)) xexp in let inner_wrap = parens || has_attr in @@ -2006,7 +1996,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens $ fmt_atrs ) ) | Pexp_apply (e0, e1N1) -> ( let wrap = - if c.conf.fmt_opts.wrap_fun_args.v then Fn.id else hvbox 2 + if c.conf.fmt_opts.wrap_fun_args.v then hovbox 2 else hvbox 2 in let (lbl, last_arg), args_before = match List.rev e1N1 with @@ -2030,21 +2020,12 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens is_simple c.conf (fun _ -> 0) (sub_exp ~ctx eI) ) -> let inner_ctx = Exp (last_arg) in let args = - let indent_body = - match lbody with - | Pfunction_cases _ -> - (Params.Indent.docked_function_after_fun c.conf - ~parens:true ~lbl ) - | Pfunction_body _ -> - (Params.Indent.docked_fun c.conf ~source:c.source - ~loc:last_arg.pexp_loc ~lbl ) - in let wrap_intro x = wrap ( intro_epi $ fmt_args_grouped e0 args_before $ space_break $ hvbox 0 x ) - $ break 1 indent_body + $ break 1 2 in let force_closing_paren = if Location.is_single_line pexp_loc c.conf.fmt_opts.margin.v @@ -2179,32 +2160,15 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens $ cut_break $ str "." $ fmt_longident_loc c lid $ fmt_atrs ) ) | Pexp_function (args, typ, (Pfunction_body _ as body)) | Pexp_function ((_ :: _ as args), typ, body) -> - (* let body_is_function = *) - (* match body with *) - (* | Pfunction_cases _ -> true *) - (* | _ -> false *) - (* in *) - (* let indent = *) - (* if body_is_function then *) - (* let default_indent = *) - (* if Option.is_none eol then 2 *) - (* else if c.conf.fmt_opts.let_binding_deindent_fun.v then 1 *) - (* else 0 *) - (* in *) - (* Params.Indent.function_ ~default:default_indent c.conf ~parens xexp *) - (* else Params.Indent.fun_ ?eol c.conf *) - (* in *) pro $ ( - (* Params.Exp.wrap c.conf ~parens ~disambiguate:true *) - (* ~fits_breaks:false ~offset_closing_paren:(-2) *) ( fmt_function ~box ~ctx ~ctx0 ~label:Nolabel ~parens ?ext ~attrs:pexp_attributes ~loc:pexp_loc c (args, typ, body) ) ) | Pexp_function ([], None, Pfunction_cases (cs, cs_loc, cs_attrs)) -> - let indent = Params.Indent.function_ c.conf ~parens xexp in + let indent = Params.Indent.function_ c.conf ~ctx0 ~parens ~has_label:false in let outer_pro, inner_pro = if parens then pro, noop else noop, pro in outer_pro $ Params.Exp.wrap c.conf ~parens ~disambiguate:true ~fits_breaks:false diff --git a/lib/Params.ml b/lib/Params.ml index d02531a391..c6758d3b99 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -26,12 +26,6 @@ let is_labelled_arg args exp = | Labelled _, x | Optional _, x -> phys_equal x exp ) args -(** Like [is_labelled_arg] but look at an expression's context. *) -let is_labelled_arg' xexp = - match xexp.Ast.ctx with - | Exp {pexp_desc= Pexp_apply (_, args); _} -> is_labelled_arg args xexp.ast - | _ -> false - let parens_if parens (c : Conf.t) ?(disambiguate = false) k = if disambiguate && c.fmt_opts.disambiguate_non_breaking_match.v then wrap_if_fits_or parens "(" ")" k @@ -686,32 +680,39 @@ module Align = struct end module Indent = struct - let function_ ?(default = 0) (c : Conf.t) ~parens xexp = - match c.fmt_opts.function_indent_nested.v with - | `Always -> c.fmt_opts.function_indent.v - | _ when ocp c && parens && not (is_labelled_arg' xexp) -> default + 1 - | _ -> default - - let fun_ ?eol (c : Conf.t) = - match c.fmt_opts.function_indent_nested.v with - | `Always -> c.fmt_opts.function_indent.v - | _ -> - if Option.is_none eol then 2 - else if c.fmt_opts.let_binding_deindent_fun.v then 1 - else 0 + let ctx_is_infix = function + | Exp { pexp_desc= Pexp_infix ({txt= ":="; _}, _, _); _ } -> false + | Exp { pexp_desc= Pexp_infix _; _ } -> true + | _ -> false + + let function_ ?(default = 0) (c : Conf.t) ~ctx0 ~parens ~has_label = + if ctx_is_infix ctx0 then + if has_label then 2 else 0 + else + match c.fmt_opts.function_indent_nested.v with + | `Always -> c.fmt_opts.function_indent.v + | _ when ocp c && parens && not has_label -> default + 1 + | _ -> default + + let fun_ ?eol (c : Conf.t) ~ctx0 = + if ctx_is_infix ctx0 then + 0 + else + match c.fmt_opts.function_indent_nested.v with + | `Always -> c.fmt_opts.function_indent.v + | _ -> + if Option.is_none eol then 2 + else if c.fmt_opts.let_binding_deindent_fun.v then 1 + else 0 let fun_type_annot c = if ocp c then 2 else 4 let fun_args c = if ocp c then 6 else 4 - let docked_function (c : Conf.t) ~parens xexp = - if ocp c then if parens then 3 else 2 - else - let default = if c.fmt_opts.wrap_fun_args.v then 2 else 4 in - function_ ~default c ~parens:false xexp - - let docked_function_after_fun (c : Conf.t) ~parens ~lbl = - if ocp c then if parens && Poly.equal lbl Nolabel then 3 else 2 else 0 + let docked_function_after_fun (c : Conf.t) ~ctx0 ~parens ~has_label = + if ctx_is_infix ctx0 then + 0 else + if ocp c then if parens && not has_label then 3 else 2 else 0 let fun_args_group (c : Conf.t) ~lbl exp = if not (ocp c) then 2 diff --git a/lib/Params.mli b/lib/Params.mli index cf85ed64d9..b947c430b7 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -191,11 +191,11 @@ module Indent : sig (** Expressions *) val function_ : - ?default:int -> Conf.t -> parens:bool -> expression Ast.xt -> int + ?default:int -> Conf.t -> ctx0:Ast.t -> parens:bool -> has_label:bool -> int (** Check the [function-indent-nested] option, or return [default] (0 if not provided) if the option does not apply. *) - val fun_ : ?eol:Fmt.t -> Conf.t -> int + val fun_ : ?eol:Fmt.t -> Conf.t -> ctx0:Ast.t -> int (** Handle [function-indent-nested]. *) val fun_args : Conf.t -> int @@ -205,10 +205,10 @@ module Indent : sig val docked_fun : Conf.t -> source:Source.t -> loc:Location.t -> lbl:arg_label -> int - val docked_function : Conf.t -> parens:bool -> expression Ast.xt -> int + (* val docked_function : Conf.t -> parens:bool -> expression Ast.xt -> int *) val docked_function_after_fun : - Conf.t -> parens:bool -> lbl:arg_label -> int + Conf.t -> ctx0:Ast.t -> parens:bool -> has_label:bool -> int val fun_args_group : Conf.t -> lbl:arg_label -> expression -> int diff --git a/test/passing/tests/attributes.ml b/test/passing/tests/attributes.ml index 384deeb426..40fafc1a2f 100644 --- a/test/passing/tests/attributes.ml +++ b/test/passing/tests/attributes.ml @@ -389,7 +389,8 @@ let _ = when f ~f:(function[@ocaml.warning (* ....................................... *) - "-4"] _ -> . ) -> + "-4"] + | _ -> . ) -> y let[@a @@ -407,16 +408,18 @@ let[@a when f ~f:(function[@ocaml.warning (* ....................................... *) "-4"] - | _ -> . ) + | _ -> . ) ~f:(function[@ocaml.warning (* ....................................... *) (* ....................................... *) "foooooooooooooooooooooooooooo \ - fooooooooooooooooooooooooooooooooooooo"] _ -> . ) + fooooooooooooooooooooooooooooooooooooo"] + | _ -> . ) ~f:(function[@ocaml.warning (* ....................................... *) let x = a and y = b in - x + y] _ -> . ) -> + x + y] + | _ -> . ) -> y [@attr (* ... *) diff --git a/test/passing/tests/fun_decl.ml b/test/passing/tests/fun_decl.ml index 9073d76bab..c4685cc836 100644 --- a/test/passing/tests/fun_decl.ml +++ b/test/passing/tests/fun_decl.ml @@ -66,5 +66,7 @@ let translate_captured let f ssssssssss = String.fold ssssssssss ~init:innnnnnnnnnit - ~f:(fun accuuuuuuuuuum -> function '0' -> g accuuuuuuuuuum - | '1' -> h accuuuuuuuuuum | _ -> i accuuuuuuuuuum ) + ~f:(fun accuuuuuuuuuum -> function + | '0' -> g accuuuuuuuuuum + | '1' -> h accuuuuuuuuuum + | _ -> i accuuuuuuuuuum ) diff --git a/test/passing/tests/fun_function.ml b/test/passing/tests/fun_function.ml index 7855a766a3..4e55f06bc6 100644 --- a/test/passing/tests/fun_function.ml +++ b/test/passing/tests/fun_function.ml @@ -1,3 +1,4 @@ let s = - List.fold x ~f:(fun y -> function Aconstructor avalue -> afunction avalue + List.fold x ~f:(fun y -> function + | Aconstructor avalue -> afunction avalue | Bconstructor bvalue -> bfunction bvalue ) diff --git a/test/passing/tests/function_indent.ml.ref b/test/passing/tests/function_indent.ml.ref index e3156c2abb..9b95488dca 100644 --- a/test/passing/tests/function_indent.ml.ref +++ b/test/passing/tests/function_indent.ml.ref @@ -7,8 +7,8 @@ let foooooooo = function let foo = fooooooooo foooooooo ~foooooooo:(function - | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo - | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo ) + | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo + | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo ) let foooooooo = if fooooooooooo then function diff --git a/test/passing/tests/issue289.ml b/test/passing/tests/issue289.ml index 352a9ee307..d726f778f2 100644 --- a/test/passing/tests/issue289.ml +++ b/test/passing/tests/issue289.ml @@ -11,9 +11,10 @@ let foo = ~doc:"Toy ID." ~args:[] ~typ:(non_null guid) - ~resolve:(function A -> x.id | B -> c ) - ; field "id" ~doc:"Toy ID." ~args:[] ~resolve:(function A -> x.id - | B -> c ) + ~resolve:(function + | A -> x.id | B -> c ) + ; field "id" ~doc:"Toy ID." ~args:[] ~resolve:(function + | A -> x.id | B -> c ) ; field "id" ~doc:"Toy ID." @@ -60,14 +61,15 @@ let foo = let foo = let open Gql in - [ field "id" ~doc:"Toy ID." ~args:[] ~typ:(non_null guid) - ~resolve:(function _ctx -> x.id ) + [ field "id" ~doc:"Toy ID." ~args:[] ~typ:(non_null guid) ~resolve:(function + | _ctx -> x.id ) ; field "id" ~doc:"Toy ID." ~args:[] ~typppp ~resolve:(function | _ctx -> x.id ) ; field "id" ~doc:"Toy ID." ~args:[] ~typ:(non_null guid) - ~resolve:(function A -> x.id | B -> c ) - ; field "id" ~doc:"Toy ID." ~args:[] ~resolve:(function A -> x.id - | B -> c ) + ~resolve:(function + | A -> x.id | B -> c ) + ; field "id" ~doc:"Toy ID." ~args:[] ~resolve:(function + | A -> x.id | B -> c ) ; field "id" ~doc:"Toy ID." ~args:[] ~typppppppppppppppppppp ~resolve:(function | AAAAAAAAAAAAAAAAAAAa -> x.idddddddddddddddddddddddddd diff --git a/test/passing/tests/issue289.ml.err b/test/passing/tests/issue289.ml.err index bc69eefb66..dd03b71dc8 100644 --- a/test/passing/tests/issue289.ml.err +++ b/test/passing/tests/issue289.ml.err @@ -1 +1,2 @@ Warning: tests/issue289.ml:4 exceeds the margin +Warning: tests/issue289.ml:63 exceeds the margin diff --git a/test/passing/tests/js_source.ml.err b/test/passing/tests/js_source.ml.err index a8ebe95e04..0ffacfd789 100644 --- a/test/passing/tests/js_source.ml.err +++ b/test/passing/tests/js_source.ml.err @@ -4,4 +4,4 @@ Warning: tests/js_source.ml:9577 exceeds the margin Warning: tests/js_source.ml:9681 exceeds the margin Warning: tests/js_source.ml:9740 exceeds the margin Warning: tests/js_source.ml:9821 exceeds the margin -Warning: tests/js_source.ml:10328 exceeds the margin +Warning: tests/js_source.ml:10327 exceeds the margin diff --git a/test/passing/tests/js_source.ml.ocp b/test/passing/tests/js_source.ml.ocp index 5604b1aadf..f865ab9dd0 100644 --- a/test/passing/tests/js_source.ml.ocp +++ b/test/passing/tests/js_source.ml.ocp @@ -9924,8 +9924,7 @@ let bind t ~f = | Sequence { state = seed; next } -> (match next seed with | Done -> Done - | Skip { state = s } -> - Skip { state = empty, Sequence { state = s; next } } + | Skip { state = s } -> Skip { state = empty, Sequence { state = s; next } } | Yield { value = a; state = s } -> Skip { state = f a, Sequence { state = s; next } })) | Skip { state = s } -> Skip { state = Sequence { state = s; next }, rest } diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index 281e495959..8c45f986e4 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -3674,7 +3674,7 @@ let subst_lambda ~subst_rec ~free ~subst : _ lambda -> _ = function let used = free t in let used_expr = Subst.fold subst ~init:[] ~f:(fun ~key ~data acc -> - if Names.mem s used then data :: acc else acc) + if Names.mem s used then data :: acc else acc) in if List.exists used_expr ~f:(fun t -> Names.mem s (free t)) then ( @@ -3912,7 +3912,7 @@ class ['a] lambda_ops (ops : ('a, 'a) #ops Lazy.t) = let used = !!free t in let used_expr = Subst.fold sub ~init:[] ~f:(fun ~key ~data acc -> - if Names.mem s used then data :: acc else acc) + if Names.mem s used then data :: acc else acc) in if List.exists used_expr ~f:(fun t -> Names.mem s (!!free t)) then ( @@ -4154,7 +4154,7 @@ let lambda_ops (ops : ('a, 'a) #ops Lazy.t) = let used = !!free t in let used_expr = Subst.fold sub ~init:[] ~f:(fun ~key ~data acc -> - if Names.mem s used then data :: acc else acc) + if Names.mem s used then data :: acc else acc) in if List.exists used_expr ~f:(fun t -> Names.mem s (!!free t)) then ( @@ -4915,7 +4915,7 @@ module Common0 = struct let handle_msg = ref (function - | _ -> failwith "Unable to handle message") + | _ -> failwith "Unable to handle message") ;; let extend_handle f = @@ -4935,7 +4935,7 @@ module Common = struct let handle_msg = ref (function - | _ -> failwith "Unable to handle message") + | _ -> failwith "Unable to handle message") ;; let extend_handle f = @@ -9622,7 +9622,7 @@ let _ = let _ = List.map rows ~f:(fun row -> - Or_error.try_with (fun () -> fffffffffffffffffffffffff row)) + Or_error.try_with (fun () -> fffffffffffffffffffffffff row)) ;; module type T = sig @@ -9815,7 +9815,7 @@ let _ = match x with | _ when f ~f:(function[@ocaml.warning (* ....................................... *) "-4"] - | _ -> .) -> y + | _ -> .) -> y ;; let[@a @@ -9831,21 +9831,21 @@ let[@a | _ when f ~f:(function[@ocaml.warning (* ....................................... *) "-4"] - | _ -> .) + | _ -> .) ~f: (function[@ocaml.warning (* ....................................... *) (* ....................................... *) "foooooooooooooooooooooooooooo \ fooooooooooooooooooooooooooooooooooooo"] - | _ -> .) + | _ -> .) ~f: (function[@ocaml.warning (* ....................................... *) let x = a and y = b in x + y] - | _ -> .) -> + | _ -> .) -> y [@attr (* ... *) @@ -9855,22 +9855,22 @@ let[@a let x = foo (`A b) ~f:(fun thing -> - something that reaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaally needs wrapping) + something that reaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaally needs wrapping) ;; let x = foo (`A `b) ~f:(fun thing -> - something that reaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaally needs wrapping) + something that reaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaally needs wrapping) ;; let x = foo [ A; B ] ~f:(fun thing -> - something that reaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaally needs wrapping) + something that reaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaally needs wrapping) ;; let x = foo [ [ A ]; B ] ~f:(fun thing -> - something that reaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaally needs wrapping) + something that reaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaally needs wrapping) ;; let x = @@ -9884,9 +9884,9 @@ let x = some_fun________________________________ some_arg______________________________ (fun param -> - do_something (); - do_something_else (); - return_this_value) + do_something (); + do_something_else (); + return_this_value) ;; let x = @@ -9901,36 +9901,35 @@ let x = let x = some_value |> some_fun (fun x -> - do_something (); - do_something_else (); - return_this_value) + do_something (); + do_something_else (); + return_this_value) ;; let x = some_value ^ some_fun (fun x -> - do_something (); - do_something_else (); - return_this_value) + do_something (); + do_something_else (); + return_this_value) ;; let bind t ~f = unfold_step ~f:(function - | Sequence { state = seed; next }, rest -> - (match next seed with - | Done -> - (match rest with - | Sequence { state = seed; next } -> - (match next seed with - | Done -> Done - | Skip { state = s } -> - Skip { state = empty, Sequence { state = s; next } } - | Yield { value = a; state = s } -> - Skip { state = f a, Sequence { state = s; next } })) - | Skip { state = s } -> Skip { state = Sequence { state = s; next }, rest } - | Yield { value = a; state = s } -> - Yield { value = a; state = Sequence { state = s; next }, rest })) + | Sequence { state = seed; next }, rest -> + (match next seed with + | Done -> + (match rest with + | Sequence { state = seed; next } -> + (match next seed with + | Done -> Done + | Skip { state = s } -> Skip { state = empty, Sequence { state = s; next } } + | Yield { value = a; state = s } -> + Skip { state = f a, Sequence { state = s; next } })) + | Skip { state = s } -> Skip { state = Sequence { state = s; next }, rest } + | Yield { value = a; state = s } -> + Yield { value = a; state = Sequence { state = s; next }, rest })) ~init:(empty, t) ;; @@ -9992,7 +9991,7 @@ type t let pat = String.Search_pattern.create (String.init len ~f:(function - | 0 -> '\n' + | 0 -> '\n' | n when n < len - 1 -> ' ' | _ -> '*')) ;; @@ -10032,21 +10031,21 @@ let _ = let _ = foo |> List.map ~f:(fun x -> - do_something (); - do_something (); - do_something (); - do_something (); - do_something_else ()) + do_something (); + do_something (); + do_something (); + do_something (); + do_something_else ()) ;; let _ = foo |> List.map ~f:(fun x -> - do_something (); - do_something (); - do_something (); - do_something (); - do_something_else ()) + do_something (); + do_something (); + do_something (); + do_something (); + do_something_else ()) |> bar ;; @@ -10066,17 +10065,17 @@ let _ = let _ = foo |> List.map (function - | A -> do_something ()) + | A -> do_something ()) ;; let _ = foo |> List.map (function - | A -> do_something () - | A -> do_something () - | A -> do_something () - | A -> do_something () - | A -> do_something_else ()) + | A -> do_something () + | A -> do_something () + | A -> do_something () + | A -> do_something () + | A -> do_something_else ()) |> bar ;; @@ -10212,7 +10211,7 @@ let _ = foooooooooooooooooooo (fun x -> function | Foooooooooooooooooooo -> foooooooooooooooooooo - | Foooooooooooooooooooo -> foooooooooooooooooooo) + | Foooooooooooooooooooo -> foooooooooooooooooooo) ;; let _ = @@ -10221,7 +10220,7 @@ let _ = foooooooooooooooooooo ~x:(fun x -> function | Foooooooooooooooooooo -> foooooooooooooooooooo - | Foooooooooooooooooooo -> foooooooooooooooooooo) + | Foooooooooooooooooooo -> foooooooooooooooooooo) ;; let _ = @@ -10229,9 +10228,9 @@ let _ = foooooooooooooooooooo foooooooooooooooooooo (fun x -> - match foo with - | Foooooooooooooooooooo -> foooooooooooooooooooo - | Foooooooooooooooooooo -> foooooooooooooooooooo) + match foo with + | Foooooooooooooooooooo -> foooooooooooooooooooo + | Foooooooooooooooooooo -> foooooooooooooooooooo) ;; let _ = @@ -10442,9 +10441,9 @@ let _ = let _ = fooooooooooooooooooooooooooooooo |> fooooooooooooooooooooooooooooooo ~fooooooooooooooooooooooooooooooo (fun foo -> - match bar with - | Some _ -> foo - | None -> baz) + match bar with + | Some _ -> foo + | None -> baz) ;; let _ = @@ -10453,31 +10452,31 @@ let _ = ~fooooooooooooooooooooooooooooooo ~fooooooooooooooooooooooooooooooo (fun foo -> - match bar with - | Some _ -> foo - | None -> baz) + match bar with + | Some _ -> foo + | None -> baz) ;; let _ = fooooooooooooooooooooooooooooooo |> fooooooooooooooooooooooooooooooofooooooooooooooooooooooooooooooofoooooooooo (fun foo -> - match bar with - | Some _ -> foo - | None -> baz) + match bar with + | Some _ -> foo + | None -> baz) ;; let _ = fooooooooooooooooooooooooooooooo |> foooooooooooooooooooooooooooo ~fooooooooooooooooooooooooooooooo (function - | foo -> bar) + | foo -> bar) ;; let _ = fooooooooooooooooooooooooooooooo |> fooooooooooooooooooooooooooooooo ~fooooooooooooooooooooooooooooooo (function - | Some _ -> foo - | None -> baz) + | Some _ -> foo + | None -> baz) ;; (* *) diff --git a/test/passing/tests/source.ml.ref b/test/passing/tests/source.ml.ref index 805b0dd4ce..00b6ef62ae 100644 --- a/test/passing/tests/source.ml.ref +++ b/test/passing/tests/source.ml.ref @@ -9147,7 +9147,8 @@ f (fun _ -> function | true -> let () = () in - () | false -> () ) + () + | false -> () ) () ;; @@ -9155,7 +9156,9 @@ f (fun _ -> function | true -> let () = () in - () (* comment *) | false -> () ) + () + (* comment *) + | false -> () ) () let xxxxxx = From 1faea29175009447e7a4ca2e22c6b2225919078c Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Fri, 17 May 2024 10:43:49 +0200 Subject: [PATCH 045/146] Restore inconsistent space between 'function [@attr]' This requires complicated and dangerous checks. To be removed later. --- lib/Fmt_ast.ml | 5 +++-- lib/Params.ml | 16 ++++++++++++++++ lib/Params.mli | 4 ++++ test/passing/tests/attributes.ml | 10 +++++----- test/passing/tests/js_source.ml.err | 4 ++-- test/passing/tests/js_source.ml.ocp | 6 ++++-- test/passing/tests/js_source.ml.ref | 4 +++- 7 files changed, 37 insertions(+), 12 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 7242968bf7..a7dd2d1dc5 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1489,9 +1489,10 @@ and fmt_function ?force_closing_paren ~ctx ~ctx0 ?(wrap_intro = fun x -> hovbox | args, typ -> fmt_fun_args_typ args typ $ space_break, [], hvbox (Params.Indent.docked_function_after_fun c.conf ~ctx0 ~parens ~has_label) in let function_ = + let pre = if Params.Exp.function_attrs_sp c.conf ~ctx0 ~ctx then Some Blank else None in str "function" - $ fmt_attributes c spilled_attrs - $ fmt_attributes c cs_attrs + $ fmt_attributes ?pre c spilled_attrs + $ fmt_attributes ?pre c cs_attrs in (fun_ $ function_, hvbox 0 (fmt_cases c ctx cs), box) in diff --git a/lib/Params.ml b/lib/Params.ml index c6758d3b99..eb4d80c298 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -98,6 +98,22 @@ module Exp = struct , not c.fmt_opts.wrap_fun_args.v ) in box_decl (kw $ hvbox_if should_box_args 0 args $ fmt_opt annot) + + (* if the function is the last argument of an apply and no other arguments + are "complex" (approximation). *) + let function_attrs_sp c ~ctx0 ~ctx = + let arg_is_simple_approx (_, exp) = + Ast.is_simple c (fun _ -> 0) (sub_exp ~ctx:ctx0 exp) + in + match ctx0, ctx with + | Exp { pexp_desc= Pexp_apply (_, args); _ }, Exp exp -> + (match List.rev args with + | [] -> false + | (_, last_arg) :: other_args -> + phys_equal exp last_arg + && List.for_all ~f:arg_is_simple_approx other_args + ) + | _ -> false end module Mod = struct diff --git a/lib/Params.mli b/lib/Params.mli index b947c430b7..ca89f08a76 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -46,6 +46,10 @@ module Exp : sig -> Fmt.t (** Box and assemble the parts [kw] (up to the arguments), [args] and [annot]. *) + + val function_attrs_sp : Conf.t -> ctx0:Ast.t -> ctx:Ast.t -> bool + (** Whether a space should be added between the [function] keyword and the + attributes. *) end module Mod : sig diff --git a/test/passing/tests/attributes.ml b/test/passing/tests/attributes.ml index 40fafc1a2f..1fc7fcec65 100644 --- a/test/passing/tests/attributes.ml +++ b/test/passing/tests/attributes.ml @@ -138,9 +138,9 @@ let ("" [@test]) = () let _ = f x ~f:(fun [@test] x -> x) -let _ = f x ~f:(function[@test] x -> x) +let _ = f x ~f:(function [@test] x -> x) -let _ = f x ~f:(function[@test] X -> x | X -> x) +let _ = f x ~f:(function [@test] X -> x | X -> x) let () = () @@ -387,9 +387,9 @@ let _ = match x with | _ when f - ~f:(function[@ocaml.warning - (* ....................................... *) - "-4"] + ~f:(function [@ocaml.warning + (* ....................................... *) + "-4"] | _ -> . ) -> y diff --git a/test/passing/tests/js_source.ml.err b/test/passing/tests/js_source.ml.err index 0ffacfd789..bac61e98a5 100644 --- a/test/passing/tests/js_source.ml.err +++ b/test/passing/tests/js_source.ml.err @@ -3,5 +3,5 @@ Warning: tests/js_source.ml:2678 exceeds the margin Warning: tests/js_source.ml:9577 exceeds the margin Warning: tests/js_source.ml:9681 exceeds the margin Warning: tests/js_source.ml:9740 exceeds the margin -Warning: tests/js_source.ml:9821 exceeds the margin -Warning: tests/js_source.ml:10327 exceeds the margin +Warning: tests/js_source.ml:9823 exceeds the margin +Warning: tests/js_source.ml:10329 exceeds the margin diff --git a/test/passing/tests/js_source.ml.ocp b/test/passing/tests/js_source.ml.ocp index f865ab9dd0..b144b98643 100644 --- a/test/passing/tests/js_source.ml.ocp +++ b/test/passing/tests/js_source.ml.ocp @@ -9814,8 +9814,10 @@ let xxxxxx = let _ = match x with | _ - when f ~f:(function[@ocaml.warning (* ....................................... *) "-4"] - | _ -> .) -> y + when f + ~f: + (function [@ocaml.warning (* ....................................... *) "-4"] + | _ -> .) -> y ;; let[@a diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index 8c45f986e4..d185690782 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -9814,7 +9814,9 @@ let xxxxxx = let _ = match x with | _ - when f ~f:(function[@ocaml.warning (* ....................................... *) "-4"] + when f + ~f: + (function [@ocaml.warning (* ....................................... *) "-4"] | _ -> .) -> y ;; From d61e362d148f24fc89f4e18b88653c6a65304f2d Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Fri, 17 May 2024 15:46:52 +0200 Subject: [PATCH 046/146] Restore de-indented 'let = fun' --- lib/Params.ml | 14 +- lib/Params.mli | 2 +- test/passing/tests/js_source.ml.err | 12 +- test/passing/tests/js_source.ml.ocp | 6 +- test/passing/tests/js_source.ml.ref | 1002 ++++++++--------- .../tests/let_binding-in_indent.ml.ref | 2 +- test/passing/tests/let_binding-indent.ml.ref | 2 +- test/passing/tests/let_binding.ml.ref | 2 +- test/passing/tests/loc_stack.ml.ref | 29 +- test/passing/tests/object.ml.ref | 8 +- test/passing/tests/polytypes-default.ml.ref | 6 +- .../passing/tests/polytypes-janestreet.ml.ref | 12 +- test/passing/tests/polytypes.ml | 6 +- test/passing/tests/source.ml.err | 3 - test/passing/tests/source.ml.ref | 888 ++++++++------- 15 files changed, 994 insertions(+), 1000 deletions(-) diff --git a/lib/Params.ml b/lib/Params.ml index 6fcb16e19f..7a29b8ccde 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -707,6 +707,10 @@ module Indent = struct | Exp { pexp_desc= Pexp_infix _; _ } -> true | _ -> false + let ctx_is_let = function + | Lb _ | Str _ -> true + | _ -> false + let function_ ?(default = 0) (c : Conf.t) ~ctx0 ~parens ~has_label = if ctx_is_infix ctx0 then if has_label then 2 else 0 @@ -716,16 +720,18 @@ module Indent = struct | _ when ocp c && parens && not has_label -> default + 1 | _ -> default - let fun_ ?eol (c : Conf.t) ~ctx0 = + let fun_ (c : Conf.t) ~ctx0 = if ctx_is_infix ctx0 then 0 else match c.fmt_opts.function_indent_nested.v with | `Always -> c.fmt_opts.function_indent.v | _ -> - if Option.is_none eol then 2 - else if c.fmt_opts.let_binding_deindent_fun.v then 1 - else 0 + if ctx_is_let ctx0 then + if c.fmt_opts.let_binding_deindent_fun.v then 1 + else 0 + else + 2 let fun_type_annot c = if ocp c then 2 else 4 diff --git a/lib/Params.mli b/lib/Params.mli index 13a6713b6c..b096c7bd64 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -198,7 +198,7 @@ module Indent : sig (** Check the [function-indent-nested] option, or return [default] (0 if not provided) if the option does not apply. *) - val fun_ : ?eol:Fmt.t -> Conf.t -> ctx0:Ast.t -> int + val fun_ : Conf.t -> ctx0:Ast.t -> int (** Handle [function-indent-nested]. *) val fun_args : Conf.t -> int diff --git a/test/passing/tests/js_source.ml.err b/test/passing/tests/js_source.ml.err index c5407f9216..b70eaa2415 100644 --- a/test/passing/tests/js_source.ml.err +++ b/test/passing/tests/js_source.ml.err @@ -1,7 +1,7 @@ Warning: tests/js_source.ml:161 exceeds the margin -Warning: tests/js_source.ml:2677 exceeds the margin -Warning: tests/js_source.ml:9576 exceeds the margin -Warning: tests/js_source.ml:9680 exceeds the margin -Warning: tests/js_source.ml:9739 exceeds the margin -Warning: tests/js_source.ml:9822 exceeds the margin -Warning: tests/js_source.ml:10328 exceeds the margin +Warning: tests/js_source.ml:2675 exceeds the margin +Warning: tests/js_source.ml:9574 exceeds the margin +Warning: tests/js_source.ml:9678 exceeds the margin +Warning: tests/js_source.ml:9737 exceeds the margin +Warning: tests/js_source.ml:9820 exceeds the margin +Warning: tests/js_source.ml:10326 exceeds the margin diff --git a/test/passing/tests/js_source.ml.ocp b/test/passing/tests/js_source.ml.ocp index 9e6c63e606..04b818c987 100644 --- a/test/passing/tests/js_source.ml.ocp +++ b/test/passing/tests/js_source.ml.ocp @@ -1040,8 +1040,7 @@ let rec variantize : type t. t ty -> t -> variant = | Record { fields } -> VRecord (List.map - (fun (Field { field_type; label; get }) -> - label, variantize field_type (get x)) + (fun (Field { field_type; label; get }) -> label, variantize field_type (get x)) fields) ;; @@ -1572,8 +1571,7 @@ let rec find : type sh. ('a -> 'a -> bool) -> 'a -> (sh, 'a) tree -> (sh, 'a) pa | Ttip -> [] | Tnode m -> if eq n m then [ Phere ] else [] | Tfork (x, y) -> - List.map (fun x -> Pleft x) (find eq n x) - @ List.map (fun x -> Pright x) (find eq n y) + List.map (fun x -> Pleft x) (find eq n x) @ List.map (fun x -> Pright x) (find eq n y) ;; let rec extract : type sh. (sh, 'a) path -> (sh, 'a) tree -> 'a = diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index c920070302..9085e8d133 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -402,9 +402,9 @@ type _ foo += A : int -> int foo | B : int foo let get_num : type a. a foo -> a -> a option = fun f i1 -> - match f with - | A i2 -> Some (i1 + i2) - | _ -> None + match f with + | A i2 -> Some (i1 + i2) + | _ -> None ;; (* Extensions must obey constraints *) @@ -974,12 +974,12 @@ type variant = let rec variantize : type t. t ty -> t -> variant = fun ty x -> - (* type t is abstract here *) - match ty with - | Int -> VInt x (* in this branch: t = int *) - | String -> VString x (* t = string *) - | List ty1 -> VList (List.map (variantize ty1) x) (* t = 'a list for some 'a *) - | Pair (ty1, ty2) -> VPair (variantize ty1 (fst x), variantize ty2 (snd x)) + (* type t is abstract here *) + match ty with + | Int -> VInt x (* in this branch: t = int *) + | String -> VString x (* t = string *) + | List ty1 -> VList (List.map (variantize ty1) x) (* t = 'a list for some 'a *) + | Pair (ty1, ty2) -> VPair (variantize ty1 (fst x), variantize ty2 (snd x)) ;; (* t = ('a, 'b) for some 'a and 'b *) @@ -988,12 +988,12 @@ exception VariantMismatch let rec devariantize : type t. t ty -> variant -> t = fun ty v -> - match ty, v with - | Int, VInt x -> x - | String, VString x -> x - | List ty1, VList vl -> List.map (devariantize ty1) vl - | Pair (ty1, ty2), VPair (x1, x2) -> devariantize ty1 x1, devariantize ty2 x2 - | _ -> raise VariantMismatch + match ty, v with + | Int, VInt x -> x + | String, VString x -> x + | List ty1, VList vl -> List.map (devariantize ty1) vl + | Pair (ty1, ty2), VPair (x1, x2) -> devariantize ty1 x1, devariantize ty2 x2 + | _ -> raise VariantMismatch ;; (* Handling records *) @@ -1029,20 +1029,19 @@ type variant = let rec variantize : type t. t ty -> t -> variant = fun ty x -> - (* type t is abstract here *) - match ty with - | Int -> VInt x (* in this branch: t = int *) - | String -> VString x (* t = string *) - | List ty1 -> VList (List.map (variantize ty1) x) (* t = 'a list for some 'a *) - | Pair (ty1, ty2) -> - VPair (variantize ty1 (fst x), variantize ty2 (snd x)) - (* t = ('a, 'b) for some 'a and 'b *) - | Record { fields } -> - VRecord - (List.map - (fun (Field { field_type; label; get }) -> - label, variantize field_type (get x)) - fields) + (* type t is abstract here *) + match ty with + | Int -> VInt x (* in this branch: t = int *) + | String -> VString x (* t = string *) + | List ty1 -> VList (List.map (variantize ty1) x) (* t = 'a list for some 'a *) + | Pair (ty1, ty2) -> + VPair (variantize ty1 (fst x), variantize ty2 (snd x)) + (* t = ('a, 'b) for some 'a and 'b *) + | Record { fields } -> + VRecord + (List.map + (fun (Field { field_type; label; get }) -> label, variantize field_type (get x)) + fields) ;; (* Extraction *) @@ -1072,22 +1071,22 @@ and ('a, 'builder, 'b) field_ = let rec devariantize : type t. t ty -> variant -> t = fun ty v -> - match ty, v with - | Int, VInt x -> x - | String, VString x -> x - | List ty1, VList vl -> List.map (devariantize ty1) vl - | Pair (ty1, ty2), VPair (x1, x2) -> devariantize ty1 x1, devariantize ty2 x2 - | Record { fields; create_builder; of_builder }, VRecord fl -> - if List.length fields <> List.length fl then raise VariantMismatch; - let builder = create_builder () in - List.iter2 - (fun (Field { label; field_type; set }) (lab, v) -> - if label <> lab then raise VariantMismatch; - set builder (devariantize field_type v)) - fields - fl; - of_builder builder - | _ -> raise VariantMismatch + match ty, v with + | Int, VInt x -> x + | String, VString x -> x + | List ty1, VList vl -> List.map (devariantize ty1) vl + | Pair (ty1, ty2), VPair (x1, x2) -> devariantize ty1 x1, devariantize ty2 x2 + | Record { fields; create_builder; of_builder }, VRecord fl -> + if List.length fields <> List.length fl then raise VariantMismatch; + let builder = create_builder () in + List.iter2 + (fun (Field { label; field_type; set }) (lab, v) -> + if label <> lab then raise VariantMismatch; + set builder (devariantize field_type v)) + fields + fl; + of_builder builder + | _ -> raise VariantMismatch ;; type my_record = @@ -1170,13 +1169,13 @@ type (_, _) eq = Eq : ('a, 'a) eq let rec eq_sel : type a b c. (a, b) ty_sel -> (a, c) ty_sel -> (b, c) eq option = fun s1 s2 -> - match s1, s2 with - | Thd, Thd -> Some Eq - | Ttl s1, Ttl s2 -> - (match eq_sel s1 s2 with - | None -> None - | Some Eq -> Some Eq) - | _ -> None + match s1, s2 with + | Thd, Thd -> Some Eq + | Ttl s1, Ttl s2 -> + (match eq_sel s1 s2 with + | None -> None + | Some Eq -> Some Eq) + | _ -> None ;; (* Auxiliary function to get the type of a case from its selector *) @@ -1185,16 +1184,16 @@ let rec get_case (b, a) ty_sel -> (string * (e, b) ty_case) list -> string * (a, e) ty option = fun sel cases -> - match cases with - | (name, TCnoarg sel') :: rem -> - (match eq_sel sel sel' with - | None -> get_case sel rem - | Some Eq -> name, None) - | (name, TCarg (sel', ty)) :: rem -> - (match eq_sel sel sel' with - | None -> get_case sel rem - | Some Eq -> name, Some ty) - | [] -> raise Not_found + match cases with + | (name, TCnoarg sel') :: rem -> + (match eq_sel sel sel' with + | None -> get_case sel rem + | Some Eq -> name, None) + | (name, TCarg (sel', ty)) :: rem -> + (match eq_sel sel sel' with + | None -> get_case sel rem + | Some Eq -> name, Some ty) + | [] -> raise Not_found ;; (* Untyped representation of values *) @@ -1214,54 +1213,54 @@ let may_map f = function let rec variantize : type a e. e ty_env -> (a, e) ty -> a -> variant = fun e ty v -> - match ty with - | Int -> VInt v - | String -> VString v - | List t -> VList (List.map (variantize e t) v) - | Option t -> VOption (may_map (variantize e t) v) - | Pair (t1, t2) -> VPair (variantize e t1 (fst v), variantize e t2 (snd v)) - | Rec t -> variantize (Econs (ty, e)) t v - | Pop t -> - (match e with - | Econs (_, e') -> variantize e' t v) - | Var -> - (match e with - | Econs (t, e') -> variantize e' t v) - | Conv (s, proj, inj, t) -> VConv (s, variantize e t (proj v)) - | Sum ops -> - let tag, arg = ops.sum_proj v in - VSum - ( tag - , may_map - (function - | Tdyn (ty, arg) -> variantize e ty arg) - arg ) + match ty with + | Int -> VInt v + | String -> VString v + | List t -> VList (List.map (variantize e t) v) + | Option t -> VOption (may_map (variantize e t) v) + | Pair (t1, t2) -> VPair (variantize e t1 (fst v), variantize e t2 (snd v)) + | Rec t -> variantize (Econs (ty, e)) t v + | Pop t -> + (match e with + | Econs (_, e') -> variantize e' t v) + | Var -> + (match e with + | Econs (t, e') -> variantize e' t v) + | Conv (s, proj, inj, t) -> VConv (s, variantize e t (proj v)) + | Sum ops -> + let tag, arg = ops.sum_proj v in + VSum + ( tag + , may_map + (function + | Tdyn (ty, arg) -> variantize e ty arg) + arg ) ;; let rec devariantize : type t e. e ty_env -> (t, e) ty -> variant -> t = fun e ty v -> - match ty, v with - | Int, VInt x -> x - | String, VString x -> x - | List ty1, VList vl -> List.map (devariantize e ty1) vl - | Pair (ty1, ty2), VPair (x1, x2) -> devariantize e ty1 x1, devariantize e ty2 x2 - | Rec t, _ -> devariantize (Econs (ty, e)) t v - | Pop t, _ -> - (match e with - | Econs (_, e') -> devariantize e' t v) - | Var, _ -> - (match e with - | Econs (t, e') -> devariantize e' t v) - | Conv (s, proj, inj, t), VConv (s', v) when s = s' -> inj (devariantize e t v) - | Sum ops, VSum (tag, a) -> - (try - match List.assoc tag ops.sum_cases, a with - | TCarg (sel, t), Some a -> ops.sum_inj (sel, devariantize e t a) - | TCnoarg sel, None -> ops.sum_inj (sel, Noarg) - | _ -> raise VariantMismatch - with - | Not_found -> raise VariantMismatch) - | _ -> raise VariantMismatch + match ty, v with + | Int, VInt x -> x + | String, VString x -> x + | List ty1, VList vl -> List.map (devariantize e ty1) vl + | Pair (ty1, ty2), VPair (x1, x2) -> devariantize e ty1 x1, devariantize e ty2 x2 + | Rec t, _ -> devariantize (Econs (ty, e)) t v + | Pop t, _ -> + (match e with + | Econs (_, e') -> devariantize e' t v) + | Var, _ -> + (match e with + | Econs (t, e') -> devariantize e' t v) + | Conv (s, proj, inj, t), VConv (s', v) when s = s' -> inj (devariantize e t v) + | Sum ops, VSum (tag, a) -> + (try + match List.assoc tag ops.sum_cases, a with + | TCarg (sel, t), Some a -> ops.sum_inj (sel, devariantize e t a) + | TCnoarg sel, None -> ops.sum_inj (sel, Noarg) + | _ -> raise VariantMismatch + with + | Not_found -> raise VariantMismatch) + | _ -> raise VariantMismatch ;; (* First attempt: represent 1-constructor variants using Conv *) @@ -1322,22 +1321,22 @@ type 'a vlist = let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t -> - let tcons = Pair (Pop t, Var) in - Rec - (Sum - { sum_proj = + let tcons = Pair (Pop t, Var) in + Rec + (Sum + { sum_proj = + (function + | `Nil -> "Nil", None + | `Cons p -> "Cons", Some (Tdyn (tcons, p))) + ; sum_cases = [ "Nil", TCnoarg Thd; "Cons", TCarg (Ttl Thd, tcons) ] + ; sum_inj = + (fun (type c) -> (function - | `Nil -> "Nil", None - | `Cons p -> "Cons", Some (Tdyn (tcons, p))) - ; sum_cases = [ "Nil", TCnoarg Thd; "Cons", TCarg (Ttl Thd, tcons) ] - ; sum_inj = - (fun (type c) -> - (function - | Thd, Noarg -> `Nil - | Ttl Thd, v -> `Cons v - : (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist)) - (* One can also write the type annotation directly *) - }) + | Thd, Noarg -> `Nil + | Ttl Thd, v -> `Cons v + : (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist)) + (* One can also write the type annotation directly *) + }) ;; let v = variantize Enil (ty_list Int) (`Cons (1, `Cons (2, `Nil))) @@ -1377,15 +1376,15 @@ let ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = (* Breaks: no way to pattern-match on a full recursive type *) let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t -> - let targ = Pair (Pop t, Var) in - Rec - (Sum - ( (function - | `Nil -> "Nil", None - | `Cons p -> "Cons", Some (Tdyn (targ, p))) - , function - | "Nil", None -> `Nil - | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p )) + let targ = Pair (Pop t, Var) in + Rec + (Sum + ( (function + | `Nil -> "Nil", None + | `Cons p -> "Cons", Some (Tdyn (targ, p))) + , function + | "Nil", None -> `Nil + | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p )) ;; (* Define Sum using object instead of record for first-class polymorphism *) @@ -1449,22 +1448,22 @@ type 'a vlist = let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t -> - let tcons = Pair (Pop t, Var) in - Rec - (Sum - (object - method proj = - function - | `Nil -> "Nil", None - | `Cons p -> "Cons", Some (Tdyn (tcons, p)) - - method cases = [ "Nil", TCnoarg Thd; "Cons", TCarg (Ttl Thd, tcons) ] - - method inj : type c. (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist = - function - | Thd, Noarg -> `Nil - | Ttl Thd, v -> `Cons v - end)) + let tcons = Pair (Pop t, Var) in + Rec + (Sum + (object + method proj = + function + | `Nil -> "Nil", None + | `Cons p -> "Cons", Some (Tdyn (tcons, p)) + + method cases = [ "Nil", TCnoarg Thd; "Cons", TCarg (Ttl Thd, tcons) ] + + method inj : type c. (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist = + function + | Thd, Noarg -> `Nil + | Ttl Thd, v -> `Cons v + end)) ;; (* @@ -1524,11 +1523,11 @@ type (_, _, _) app = App : ('a, 'p) seq * ('n, 'm, 'p) plus -> ('a, 'n, 'm) app let rec app : type a n m. (a, n) seq -> (a, m) seq -> (a, n, m) app = fun xs ys -> - match xs with - | Snil -> App (ys, PlusZ (length ys)) - | Scons (x, xs') -> - let (App (xs'', pl)) = app xs' ys in - App (Scons (x, xs''), PlusS pl) + match xs with + | Snil -> App (ys, PlusZ (length ys)) + | Scons (x, xs') -> + let (App (xs'', pl)) = app xs' ys in + App (Scons (x, xs''), PlusS pl) ;; (* 3.1 Feature: kinds *) @@ -1568,21 +1567,20 @@ let tree1 = Tfork (Tfork (Ttip, Tnode 4), Tfork (Tnode 4, Tnode 3)) let rec find : type sh. ('a -> 'a -> bool) -> 'a -> (sh, 'a) tree -> (sh, 'a) path list = fun eq n t -> - match t with - | Ttip -> [] - | Tnode m -> if eq n m then [ Phere ] else [] - | Tfork (x, y) -> - List.map (fun x -> Pleft x) (find eq n x) - @ List.map (fun x -> Pright x) (find eq n y) + match t with + | Ttip -> [] + | Tnode m -> if eq n m then [ Phere ] else [] + | Tfork (x, y) -> + List.map (fun x -> Pleft x) (find eq n x) @ List.map (fun x -> Pright x) (find eq n y) ;; let rec extract : type sh. (sh, 'a) path -> (sh, 'a) tree -> 'a = fun p t -> - match p, t with - | Pnone x, Ttip -> x - | Phere, Tnode y -> y - | Pleft p, Tfork (l, _) -> extract p l - | Pright p, Tfork (_, r) -> extract p r + match p, t with + | Pnone x, Ttip -> x + | Phere, Tnode y -> y + | Pleft p, Tfork (l, _) -> extract p l + | Pright p, Tfork (_, r) -> extract p r ;; (* 3.4 Pattern : Witness *) @@ -1607,9 +1605,9 @@ let p1 : (two, one, three) plus = PlusS (PlusS (PlusZ (NS NZ))) let rec summandLessThanSum : type a b c. (a, b, c) plus -> (a, c) le = fun p -> - match p with - | PlusZ n -> LeZ n - | PlusS p' -> LeS (summandLessThanSum p') + match p with + | PlusZ n -> LeZ n + | PlusS p' -> LeS (summandLessThanSum p') ;; (* 3.8 Pattern: Leibniz Equality *) @@ -1620,24 +1618,24 @@ let convert : type a b. (a, b) equal -> a -> b = fun Eq x -> x let rec sameNat : type a b. a nat -> b nat -> (a, b) equal option = fun a b -> - match a, b with - | NZ, NZ -> Some Eq - | NS a', NS b' -> - (match sameNat a' b' with - | Some Eq -> Some Eq - | None -> None) - | _ -> None + match a, b with + | NZ, NZ -> Some Eq + | NS a', NS b' -> + (match sameNat a' b' with + | Some Eq -> Some Eq + | None -> None) + | _ -> None ;; (* Extra: associativity of addition *) let rec plus_func : type a b m n. (a, b, m) plus -> (a, b, n) plus -> (m, n) equal = fun p1 p2 -> - match p1, p2 with - | PlusZ _, PlusZ _ -> Eq - | PlusS p1', PlusS p2' -> - let Eq = plus_func p1' p2' in - Eq + match p1, p2 with + | PlusZ _, PlusZ _ -> Eq + | PlusS p1', PlusS p2' -> + let Eq = plus_func p1' p2' in + Eq ;; let rec plus_assoc @@ -1649,14 +1647,14 @@ let rec plus_assoc -> (m, n) equal = fun p1 p2 p3 p4 -> - match p1, p4 with - | PlusZ b, PlusZ bc -> - let Eq = plus_func p2 p3 in - Eq - | PlusS p1', PlusS p4' -> - let (PlusS p2') = p2 in - let Eq = plus_assoc p1' p2' p3 p4' in - Eq + match p1, p4 with + | PlusZ b, PlusZ bc -> + let Eq = plus_func p2 p3 in + Eq + | PlusS p1', PlusS p4' -> + let (PlusS p2') = p2 in + let Eq = plus_assoc p1' p2' p3 p4' in + Eq ;; (* 3.9 Computing Programs and Properties Simultaneously *) @@ -1682,31 +1680,31 @@ type (_, _) diff = Diff : 'c nat * ('a, 'c, 'b) plus -> ('a, 'b) diff let rec diff : type a b. (a, b) le -> a nat -> b nat -> (a, b) diff = fun le a b -> - match le, a, b with - | LeZ _, _, m -> Diff (m, PlusZ m) - | LeS q, NS x, NS y -> - (match diff q x y with - | Diff (m, p) -> Diff (m, PlusS p)) + match le, a, b with + | LeZ _, _, m -> Diff (m, PlusZ m) + | LeS q, NS x, NS y -> + (match diff q x y with + | Diff (m, p) -> Diff (m, PlusS p)) ;; let rec diff : type a b. (a, b) le -> a nat -> b nat -> (a, b) diff = fun le a b -> - match a, b, le with - (* warning *) - | NZ, m, LeZ _ -> Diff (m, PlusZ m) - | NS x, NS y, LeS q -> - (match diff q x y with - | Diff (m, p) -> Diff (m, PlusS p)) - | _ -> . + match a, b, le with + (* warning *) + | NZ, m, LeZ _ -> Diff (m, PlusZ m) + | NS x, NS y, LeS q -> + (match diff q x y with + | Diff (m, p) -> Diff (m, PlusS p)) + | _ -> . ;; let rec diff : type a b. (a, b) le -> b nat -> (a, b) diff = fun le b -> - match b, le with - | m, LeZ _ -> Diff (m, PlusZ m) - | NS y, LeS q -> - (match diff q y with - | Diff (m, p) -> Diff (m, PlusS p)) + match b, le with + | m, LeZ _ -> Diff (m, PlusZ m) + | NS y, LeS q -> + (match diff q y with + | Diff (m, p) -> Diff (m, PlusS p)) ;; type (_, _) filter = Filter : ('m, 'n) le * ('a, 'm) seq -> ('a, 'n) filter @@ -1718,12 +1716,12 @@ let rec leS' : type m n. (m, n) le -> (m, n succ) le = function let rec filter : type a n. (a -> bool) -> (a, n) seq -> (a, n) filter = fun f s -> - match s with - | Snil -> Filter (LeZ NZ, Snil) - | Scons (a, l) -> - (match filter f l with - | Filter (le, l') -> - if f a then Filter (LeS le, Scons (a, l')) else Filter (leS' le, l')) + match s with + | Snil -> Filter (LeZ NZ, Snil) + | Scons (a, l) -> + (match filter f l with + | Filter (le, l') -> + if f a then Filter (LeS le, Scons (a, l')) else Filter (leS' le, l')) ;; (* 4.1 AVL trees *) @@ -1743,65 +1741,65 @@ let empty = Avl Leaf let rec elem : type h. int -> h avl -> bool = fun x t -> - match t with - | Leaf -> false - | Node (_, l, y, r) -> x = y || if x < y then elem x l else elem x r + match t with + | Leaf -> false + | Node (_, l, y, r) -> x = y || if x < y then elem x l else elem x r ;; let rec rotr : type n. n succ succ avl -> int -> n avl -> (n succ succ avl, n succ succ succ avl) sum = fun tL y tR -> - match tL with - | Node (Same, a, x, b) -> Inr (Node (Less, a, x, Node (More, b, y, tR))) - | Node (More, a, x, b) -> Inl (Node (Same, a, x, Node (Same, b, y, tR))) - | Node (Less, a, x, Node (Same, b, z, c)) -> - Inl (Node (Same, Node (Same, a, x, b), z, Node (Same, c, y, tR))) - | Node (Less, a, x, Node (Less, b, z, c)) -> - Inl (Node (Same, Node (More, a, x, b), z, Node (Same, c, y, tR))) - | Node (Less, a, x, Node (More, b, z, c)) -> - Inl (Node (Same, Node (Same, a, x, b), z, Node (Less, c, y, tR))) + match tL with + | Node (Same, a, x, b) -> Inr (Node (Less, a, x, Node (More, b, y, tR))) + | Node (More, a, x, b) -> Inl (Node (Same, a, x, Node (Same, b, y, tR))) + | Node (Less, a, x, Node (Same, b, z, c)) -> + Inl (Node (Same, Node (Same, a, x, b), z, Node (Same, c, y, tR))) + | Node (Less, a, x, Node (Less, b, z, c)) -> + Inl (Node (Same, Node (More, a, x, b), z, Node (Same, c, y, tR))) + | Node (Less, a, x, Node (More, b, z, c)) -> + Inl (Node (Same, Node (Same, a, x, b), z, Node (Less, c, y, tR))) ;; let rec rotl : type n. n avl -> int -> n succ succ avl -> (n succ succ avl, n succ succ succ avl) sum = fun tL u tR -> - match tR with - | Node (Same, a, x, b) -> Inr (Node (More, Node (Less, tL, u, a), x, b)) - | Node (Less, a, x, b) -> Inl (Node (Same, Node (Same, tL, u, a), x, b)) - | Node (More, Node (Same, a, x, b), y, c) -> - Inl (Node (Same, Node (Same, tL, u, a), x, Node (Same, b, y, c))) - | Node (More, Node (Less, a, x, b), y, c) -> - Inl (Node (Same, Node (More, tL, u, a), x, Node (Same, b, y, c))) - | Node (More, Node (More, a, x, b), y, c) -> - Inl (Node (Same, Node (Same, tL, u, a), x, Node (Less, b, y, c))) + match tR with + | Node (Same, a, x, b) -> Inr (Node (More, Node (Less, tL, u, a), x, b)) + | Node (Less, a, x, b) -> Inl (Node (Same, Node (Same, tL, u, a), x, b)) + | Node (More, Node (Same, a, x, b), y, c) -> + Inl (Node (Same, Node (Same, tL, u, a), x, Node (Same, b, y, c))) + | Node (More, Node (Less, a, x, b), y, c) -> + Inl (Node (Same, Node (More, tL, u, a), x, Node (Same, b, y, c))) + | Node (More, Node (More, a, x, b), y, c) -> + Inl (Node (Same, Node (Same, tL, u, a), x, Node (Less, b, y, c))) ;; let rec ins : type n. int -> n avl -> (n avl, n succ avl) sum = fun x t -> - match t with - | Leaf -> Inr (Node (Same, Leaf, x, Leaf)) - | Node (bal, a, y, b) -> - if x = y - then Inl t - else if x < y - then ( - match ins x a with - | Inl a -> Inl (Node (bal, a, y, b)) - | Inr a -> - (match bal with - | Less -> Inl (Node (Same, a, y, b)) - | Same -> Inr (Node (More, a, y, b)) - | More -> rotr a y b)) - else ( - match ins x b with - | Inl b -> Inl (Node (bal, a, y, b) : n avl) - | Inr b -> - (match bal with - | More -> Inl (Node (Same, a, y, b) : n avl) - | Same -> Inr (Node (Less, a, y, b) : n succ avl) - | Less -> rotl a y b)) + match t with + | Leaf -> Inr (Node (Same, Leaf, x, Leaf)) + | Node (bal, a, y, b) -> + if x = y + then Inl t + else if x < y + then ( + match ins x a with + | Inl a -> Inl (Node (bal, a, y, b)) + | Inr a -> + (match bal with + | Less -> Inl (Node (Same, a, y, b)) + | Same -> Inr (Node (More, a, y, b)) + | More -> rotr a y b)) + else ( + match ins x b with + | Inl b -> Inl (Node (bal, a, y, b) : n avl) + | Inr b -> + (match bal with + | More -> Inl (Node (Same, a, y, b) : n avl) + | Same -> Inr (Node (Less, a, y, b) : n succ avl) + | Less -> rotl a y b)) ;; let insert x (Avl t) = @@ -1830,48 +1828,48 @@ type _ avl_del = let rec del : type n. int -> n avl -> n avl_del = fun y t -> - match t with - | Leaf -> Dsame Leaf - | Node (bal, l, x, r) -> - if x = y - then ( - match r with - | Leaf -> - (match bal with - | Same -> Ddecr (Eq, l) - | More -> Ddecr (Eq, l)) - | Node _ -> - (match bal, del_min r with - | _, (z, Inr r) -> Dsame (Node (bal, l, z, r)) - | Same, (z, Inl r) -> Dsame (Node (More, l, z, r)) - | Less, (z, Inl r) -> Ddecr (Eq, Node (Same, l, z, r)) - | More, (z, Inl r) -> - (match rotr l z r with - | Inl t -> Ddecr (Eq, t) - | Inr t -> Dsame t))) - else if y < x - then ( - match del y l with - | Dsame l -> Dsame (Node (bal, l, x, r)) - | Ddecr (Eq, l) -> - (match bal with - | Same -> Dsame (Node (Less, l, x, r)) - | More -> Ddecr (Eq, Node (Same, l, x, r)) - | Less -> - (match rotl l x r with - | Inl t -> Ddecr (Eq, t) - | Inr t -> Dsame t))) - else ( - match del y r with - | Dsame r -> Dsame (Node (bal, l, x, r)) - | Ddecr (Eq, r) -> - (match bal with - | Same -> Dsame (Node (More, l, x, r)) - | Less -> Ddecr (Eq, Node (Same, l, x, r)) - | More -> - (match rotr l x r with - | Inl t -> Ddecr (Eq, t) - | Inr t -> Dsame t))) + match t with + | Leaf -> Dsame Leaf + | Node (bal, l, x, r) -> + if x = y + then ( + match r with + | Leaf -> + (match bal with + | Same -> Ddecr (Eq, l) + | More -> Ddecr (Eq, l)) + | Node _ -> + (match bal, del_min r with + | _, (z, Inr r) -> Dsame (Node (bal, l, z, r)) + | Same, (z, Inl r) -> Dsame (Node (More, l, z, r)) + | Less, (z, Inl r) -> Ddecr (Eq, Node (Same, l, z, r)) + | More, (z, Inl r) -> + (match rotr l z r with + | Inl t -> Ddecr (Eq, t) + | Inr t -> Dsame t))) + else if y < x + then ( + match del y l with + | Dsame l -> Dsame (Node (bal, l, x, r)) + | Ddecr (Eq, l) -> + (match bal with + | Same -> Dsame (Node (Less, l, x, r)) + | More -> Ddecr (Eq, Node (Same, l, x, r)) + | Less -> + (match rotl l x r with + | Inl t -> Ddecr (Eq, t) + | Inr t -> Dsame t))) + else ( + match del y r with + | Dsame r -> Dsame (Node (bal, l, x, r)) + | Ddecr (Eq, r) -> + (match bal with + | Same -> Dsame (Node (More, l, x, r)) + | Less -> Ddecr (Eq, Node (Same, l, x, r)) + | More -> + (match rotr l x r with + | Inl t -> Ddecr (Eq, t) + | Inr t -> Dsame t))) ;; let delete x (Avl t) = @@ -1917,12 +1915,12 @@ let color : type c n. (c, n) sub_tree -> c crep = function let rec fill : type c n. (c, n) ctxt -> (c, n) sub_tree -> rb_tree = fun ct t -> - match ct with - | CNil -> Root t - | CRed (e, LeftD, uncle, c) -> fill c (Rnode (uncle, e, t)) - | CRed (e, RightD, uncle, c) -> fill c (Rnode (t, e, uncle)) - | CBlk (e, LeftD, uncle, c) -> fill c (Bnode (uncle, e, t)) - | CBlk (e, RightD, uncle, c) -> fill c (Bnode (t, e, uncle)) + match ct with + | CNil -> Root t + | CRed (e, LeftD, uncle, c) -> fill c (Rnode (uncle, e, t)) + | CRed (e, RightD, uncle, c) -> fill c (Rnode (t, e, uncle)) + | CBlk (e, LeftD, uncle, c) -> fill c (Bnode (uncle, e, t)) + | CBlk (e, RightD, uncle, c) -> fill c (Bnode (t, e, uncle)) ;; let recolor d1 pE sib d2 gE uncle t = @@ -1943,28 +1941,28 @@ let rotate d1 pE sib d2 gE uncle (Rnode (x, e, y)) = let rec repair : type c n. (red, n) sub_tree -> (c, n) ctxt -> rb_tree = fun t ct -> - match ct with - | CNil -> Root (blacken t) - | CBlk (e, LeftD, sib, c) -> fill c (Bnode (sib, e, t)) - | CBlk (e, RightD, sib, c) -> fill c (Bnode (t, e, sib)) - | CRed (e, dir, sib, CBlk (e', dir', uncle, ct)) -> - (match color uncle with - | Red -> repair (recolor dir e sib dir' e' (blacken uncle) t) ct - | Black -> fill ct (rotate dir e sib dir' e' uncle t)) + match ct with + | CNil -> Root (blacken t) + | CBlk (e, LeftD, sib, c) -> fill c (Bnode (sib, e, t)) + | CBlk (e, RightD, sib, c) -> fill c (Bnode (t, e, sib)) + | CRed (e, dir, sib, CBlk (e', dir', uncle, ct)) -> + (match color uncle with + | Red -> repair (recolor dir e sib dir' e' (blacken uncle) t) ct + | Black -> fill ct (rotate dir e sib dir' e' uncle t)) ;; let rec ins : type c n. int -> (c, n) sub_tree -> (c, n) ctxt -> rb_tree = fun e t ct -> - match t with - | Rnode (l, e', r) -> - if e < e' - then ins e l (CRed (e', RightD, r, ct)) - else ins e r (CRed (e', LeftD, l, ct)) - | Bnode (l, e', r) -> - if e < e' - then ins e l (CBlk (e', RightD, r, ct)) - else ins e r (CBlk (e', LeftD, l, ct)) - | Bleaf -> repair (Rnode (Bleaf, e, Bleaf)) ct + match t with + | Rnode (l, e', r) -> + if e < e' + then ins e l (CRed (e', RightD, r, ct)) + else ins e r (CRed (e', LeftD, l, ct)) + | Bnode (l, e', r) -> + if e < e' + then ins e l (CBlk (e', RightD, r, ct)) + else ins e r (CBlk (e', LeftD, l, ct)) + | Bleaf -> repair (Rnode (Bleaf, e, Bleaf)) ct ;; let insert e (Root t) = ins e t CNil @@ -1999,24 +1997,24 @@ type (_, _) equal = Eq : ('a, 'a) equal let rec rep_equal : type a b. a rep -> b rep -> (a, b) equal option = fun ra rb -> - match ra, rb with - | Rint, Rint -> Some Eq - | Rbool, Rbool -> Some Eq - | Rpair (a1, a2), Rpair (b1, b2) -> - (match rep_equal a1 b1 with - | None -> None - | Some Eq -> - (match rep_equal a2 b2 with - | None -> None - | Some Eq -> Some Eq)) - | Rfun (a1, a2), Rfun (b1, b2) -> - (match rep_equal a1 b1 with - | None -> None - | Some Eq -> - (match rep_equal a2 b2 with - | None -> None - | Some Eq -> Some Eq)) - | _ -> None + match ra, rb with + | Rint, Rint -> Some Eq + | Rbool, Rbool -> Some Eq + | Rpair (a1, a2), Rpair (b1, b2) -> + (match rep_equal a1 b1 with + | None -> None + | Some Eq -> + (match rep_equal a2 b2 with + | None -> None + | Some Eq -> Some Eq)) + | Rfun (a1, a2), Rfun (b1, b2) -> + (match rep_equal a1 b1 with + | None -> None + | Some Eq -> + (match rep_equal a2 b2 with + | None -> None + | Some Eq -> Some Eq)) + | _ -> None ;; type assoc = Assoc : string * 'a rep * 'a -> assoc @@ -2085,12 +2083,12 @@ type _ env = let rec eval_lam : type e t. e env -> (e, t) lam -> t = fun env m -> - match env, m with - | _, Const n -> n - | Econs (_, v, r), Var _ -> v - | Econs (_, _, r), Shift e -> eval_lam r e - | _, Abs (n, body) -> fun x -> eval_lam (Econs (n, x, env)) body - | _, App (f, x) -> eval_lam env f (eval_lam env x) + match env, m with + | _, Const n -> n + | Econs (_, v, r), Var _ -> v + | Econs (_, _, r), Shift e -> eval_lam r e + | _, Abs (n, body) -> fun x -> eval_lam (Econs (n, x, env)) body + | _, App (f, x) -> eval_lam env f (eval_lam env x) ;; type add = Add @@ -2118,17 +2116,17 @@ type _ rep = let rec compare : type a b. a rep -> b rep -> (string, (a, b) equal) sum = fun a b -> - match a, b with - | I, I -> Inr Eq - | Ar (x, y), Ar (s, t) -> - (match compare x s with - | Inl _ as e -> e - | Inr Eq -> - (match compare y t with - | Inl _ as e -> e - | Inr Eq as e -> e)) - | I, Ar _ -> Inl "I <> Ar _" - | Ar _, I -> Inl "Ar _ <> I" + match a, b with + | I, I -> Inr Eq + | Ar (x, y), Ar (s, t) -> + (match compare x s with + | Inl _ as e -> e + | Inr Eq -> + (match compare y t with + | Inl _ as e -> e + | Inr Eq as e -> e)) + | I, Ar _ -> Inl "I <> Ar _" + | Ar _, I -> Inl "Ar _ <> I" ;; type term = @@ -2147,39 +2145,39 @@ type _ checked = let rec lookup : type e. string -> e ctx -> e checked = fun name ctx -> - match ctx with - | Cnil -> Cerror ("Name not found: " ^ name) - | Ccons (l, s, t, rs) -> - if s = name - then Cok (Var l, t) - else ( - match lookup name rs with - | Cerror m -> Cerror m - | Cok (v, t) -> Cok (Shift v, t)) + match ctx with + | Cnil -> Cerror ("Name not found: " ^ name) + | Ccons (l, s, t, rs) -> + if s = name + then Cok (Var l, t) + else ( + match lookup name rs with + | Cerror m -> Cerror m + | Cok (v, t) -> Cok (Shift v, t)) ;; let rec tc : type n e. n nat -> e ctx -> term -> e checked = fun n ctx t -> - match t with - | V s -> lookup s ctx - | Ap (f, x) -> - (match tc n ctx f with - | Cerror _ as e -> e - | Cok (f', ft) -> - (match tc n ctx x with - | Cerror _ as e -> e - | Cok (x', xt) -> - (match ft with - | Ar (a, b) -> - (match compare a xt with - | Inl s -> Cerror s - | Inr Eq -> Cok (App (f', x'), b)) - | _ -> Cerror "Non fun in Ap"))) - | Ab (s, t, body) -> - (match tc (NS n) (Ccons (n, s, t, ctx)) body with - | Cerror _ as e -> e - | Cok (body', et) -> Cok (Abs (n, body'), Ar (t, et))) - | C m -> Cok (Const m, I) + match t with + | V s -> lookup s ctx + | Ap (f, x) -> + (match tc n ctx f with + | Cerror _ as e -> e + | Cok (f', ft) -> + (match tc n ctx x with + | Cerror _ as e -> e + | Cok (x', xt) -> + (match ft with + | Ar (a, b) -> + (match compare a xt with + | Inl s -> Cerror s + | Inr Eq -> Cok (App (f', x'), b)) + | _ -> Cerror "Non fun in Ap"))) + | Ab (s, t, body) -> + (match tc (NS n) (Ccons (n, s, t, ctx)) body with + | Cerror _ as e -> e + | Cok (body', et) -> Cok (Abs (n, body'), Ar (t, et))) + | C m -> Cok (Const m, I) ;; let ctx0 = @@ -2242,21 +2240,21 @@ type (_, _) lam' = Ex : ('m, 's, 't) lam -> ('s, 't) lam' let rec subst : type m1 r t s. (m1, r, t) lam -> (r, s) sub -> (s, t) lam' = fun t s -> - match t, s with - | _, Id -> Ex t - | Const (r, c), sub -> Ex (Const (r, c)) - | Var v, Bind (x, e, r) -> Ex e - | Var v, Push sub -> Ex (Var v) - | Shift e, Bind (_, _, r) -> subst e r - | Shift e, Push sub -> - (match subst e sub with - | Ex a -> Ex (Shift a)) - | App (f, x), sub -> - (match subst f sub, subst x sub with - | Ex g, Ex y -> Ex (App (g, y))) - | Lam (v, x), sub -> - (match subst x (Push sub) with - | Ex body -> Ex (Lam (v, body))) + match t, s with + | _, Id -> Ex t + | Const (r, c), sub -> Ex (Const (r, c)) + | Var v, Bind (x, e, r) -> Ex e + | Var v, Push sub -> Ex (Var v) + | Shift e, Bind (_, _, r) -> subst e r + | Shift e, Push sub -> + (match subst e sub with + | Ex a -> Ex (Shift a)) + | App (f, x), sub -> + (match subst f sub, subst x sub with + | Ex g, Ex y -> Ex (App (g, y))) + | Lam (v, x), sub -> + (match subst x (Push sub) with + | Ex body -> Ex (Lam (v, body))) ;; type closed = rnil @@ -2266,14 +2264,14 @@ let rec rule : type a b. (pval, closed, (a, b) tarr) lam -> (pval, closed, a) lam -> b rlam = fun v1 v2 -> - match v1, v2 with - | Lam (x, body), v -> - (match subst body (Bind (x, v, Id)) with - | Ex term -> - (match mode term with - | Pexp -> Inl term - | Pval -> Inr term)) - | Const (IntTo b, f), Const (IntR, x) -> Inr (Const (b, f x)) + match v1, v2 with + | Lam (x, body), v -> + (match subst body (Bind (x, v, Id)) with + | Ex term -> + (match mode term with + | Pexp -> Inl term + | Pval -> Inr term)) + | Const (IntTo b, f), Const (IntR, x) -> Inr (Const (b, f x)) ;; let rec onestep : type m t. (m, closed, t) lam -> t rlam = function @@ -2303,11 +2301,11 @@ type ('env, 'a) typ = let f : type env a. (env, a) typ -> (env, a) typ -> int = fun ta tb -> - match ta, tb with - | Tint, Tint -> 0 - | Tbool, Tbool -> 1 - | Tvar var, tb -> 2 - | _ -> . (* error *) + match ta, tb with + | Tint, Tint -> 0 + | Tbool, Tbool -> 1 + | Tvar var, tb -> 2 + | _ -> . (* error *) ;; (* let x = f Tint (Tvar Zero) ;; *) @@ -2417,8 +2415,8 @@ end let of_type : type a. a -> a = fun x -> - match B.f x 4 with - | Eq -> 5 + match B.f x 4 with + | Eq -> 5 ;; type _ constant = @@ -2476,9 +2474,9 @@ type _ wrapPoly = WrapPoly : 'a poly -> ([< `TagA of int | `TagB ] as 'a) wrapPo let example6 : type a. a wrapPoly -> a -> int = fun w -> - match w with - | WrapPoly ATag -> intA - | WrapPoly _ -> intA (* This should not be allowed *) + match w with + | WrapPoly ATag -> intA + | WrapPoly _ -> intA (* This should not be allowed *) ;; let _ = example6 (WrapPoly AandBTags) `TagB (* This causes a seg fault *) @@ -2493,8 +2491,8 @@ struct let f : int S.t ab -> float S.t ab -> string = fun (l : int S.t ab) (r : float S.t ab) -> - match l, r with - | A, B -> "f A B" + match l, r with + | A, B -> "f A B" ;; end @@ -2511,8 +2509,8 @@ struct let f : a S.t ab -> b S.t ab -> string = fun l r -> - match l, r with - | A, B -> "f A B" + match l, r with + | A, B -> "f A B" ;; end @@ -2709,9 +2707,9 @@ type _ lst = let rec get_var : type stk ret. (stk s, ret) var -> stk lst -> ret = fun n s -> - match n, s with - | Head, CCons (h, _) -> h - | Tail n', CCons (_, t) -> get_var n' t + match n, s with + | Head, CCons (h, _) -> h + | Tail n', CCons (_, t) -> get_var n' t ;; type 'a t = [< `Foo | `Bar ] as 'a @@ -2822,8 +2820,8 @@ type _ t = let undetected : ('a -> 'b -> nil) t -> 'a n -> 'b n -> unit = fun sh i j -> - let (Cons (Elt dim, _)) = sh in - () + let (Cons (Elt dim, _)) = sh in + () ;; type _ t = T : int t @@ -2908,10 +2906,10 @@ let comp_subst f g (x : 'a fin) = pre_subst f (g x) let rec thin : type n. n succ fin -> n fin -> n succ fin = fun x y -> - match x, y with - | FZ, y -> FS y - | FS x, FZ -> FZ - | FS x, FS y -> FS (thin x y) + match x, y with + | FZ, y -> FS y + | FS x, FZ -> FZ + | FS x, FS y -> FS (thin x y) ;; let bind t f = @@ -2924,24 +2922,24 @@ let bind t f = let rec thick : type n. n succ fin -> n succ fin -> n fin option = fun x y -> - match x, y with - | FZ, FZ -> None - | FZ, FS y -> Some y - | FS x, FZ -> - let IS = fin_succ x in - Some FZ - | FS x, FS y -> - let IS = fin_succ x in - bind (thick x y) (fun x -> Some (FS x)) + match x, y with + | FZ, FZ -> None + | FZ, FS y -> Some y + | FS x, FZ -> + let IS = fin_succ x in + Some FZ + | FS x, FS y -> + let IS = fin_succ x in + bind (thick x y) (fun x -> Some (FS x)) ;; let rec check : type n. n succ fin -> n succ term -> n term option = fun x t -> - match t with - | Var y -> bind (thick x y) (fun x -> Some (Var x)) - | Leaf -> Some Leaf - | Fork (t1, t2) -> - bind (check x t1) (fun t1 -> bind (check x t2) (fun t2 -> Some (Fork (t1, t2)))) + match t with + | Var y -> bind (thick x y) (fun x -> Some (Var x)) + | Leaf -> Some Leaf + | Fork (t1, t2) -> + bind (check x t1) (fun t1 -> bind (check x t2) (fun t2 -> Some (Fork (t1, t2)))) ;; let subst_var x t' y = @@ -2968,9 +2966,9 @@ let rec sub : type m n. (m, n) alist -> m fin -> n term = function let rec append : type m n l. (m, n) alist -> (l, m) alist -> (l, n) alist = fun r s -> - match s with - | Anil -> r - | Asnoc (s, t, x) -> Asnoc (append r s, t, x) + match s with + | Anil -> r + | Asnoc (s, t, x) -> Asnoc (append r s, t, x) ;; type _ ealist = EAlist : ('a, 'b) alist -> 'a ealist @@ -3014,24 +3012,24 @@ let flex_rigid x t = bind (check x t) (fun t' -> Some (asnoc Anil t' x)) let rec amgu : type m. m term -> m term -> m ealist -> m ealist option = fun s t acc -> - match s, t, acc with - | Leaf, Leaf, _ -> Some acc - | Leaf, Fork _, _ -> None - | Fork _, Leaf, _ -> None - | Fork (s1, s2), Fork (t1, t2), _ -> bind (amgu s1 t1 acc) (amgu s2 t2) - | Var x, Var y, EAlist Anil -> - let IS = fin_succ x in - Some (flex_flex x y) - | Var x, t, EAlist Anil -> - let IS = fin_succ x in - flex_rigid x t - | t, Var x, EAlist Anil -> - let IS = fin_succ x in - flex_rigid x t - | s, t, EAlist (Asnoc (d, r, z)) -> - bind - (amgu (subst z r s) (subst z r t) (EAlist d)) - (fun (EAlist d) -> Some (asnoc d r z)) + match s, t, acc with + | Leaf, Leaf, _ -> Some acc + | Leaf, Fork _, _ -> None + | Fork _, Leaf, _ -> None + | Fork (s1, s2), Fork (t1, t2), _ -> bind (amgu s1 t1 acc) (amgu s2 t2) + | Var x, Var y, EAlist Anil -> + let IS = fin_succ x in + Some (flex_flex x y) + | Var x, t, EAlist Anil -> + let IS = fin_succ x in + flex_rigid x t + | t, Var x, EAlist Anil -> + let IS = fin_succ x in + flex_rigid x t + | s, t, EAlist (Asnoc (d, r, z)) -> + bind + (amgu (subst z r s) (subst z r t) (EAlist d)) + (fun (EAlist d) -> Some (asnoc d r z)) ;; let mgu s t = amgu s t (EAlist Anil) @@ -3055,20 +3053,20 @@ type (_, _) eq = Refl : ('a, 'a) eq let magic : 'a 'b. 'a -> 'b = fun (type a b) (x : a) -> - let module M = - (functor - (T : sig - type 'a t - end) - -> - struct - let f (Refl : (a T.t, b T.t) eq) = (x :> b) - end) - (struct - type 'a t = unit - end) - in - M.f Refl + let module M = + (functor + (T : sig + type 'a t + end) + -> + struct + let f (Refl : (a T.t, b T.t) eq) = (x :> b) + end) + (struct + type 'a t = unit + end) + in + M.f Refl ;; (* Variance and subtyping *) @@ -3077,17 +3075,17 @@ type (_, +_) eq = Refl : ('a, 'a) eq let magic : 'a 'b. 'a -> 'b = fun (type a) (type b) (x : a) -> - let bad_proof (type a) = (Refl : (< m : a >, < m : a >) eq :> (< m : a >, < >) eq) in - let downcast : type a. (a, < >) eq -> < > -> a = - fun (type a) (Refl : (a, < >) eq) (s : < >) -> (s :> a) - in - (downcast - bad_proof - (object - method m = x - end - :> < >)) - #m + let bad_proof (type a) = (Refl : (< m : a >, < m : a >) eq :> (< m : a >, < >) eq) in + let downcast : type a. (a, < >) eq -> < > -> a = + fun (type a) (Refl : (a, < >) eq) (s : < >) -> (s :> a) + in + (downcast + bad_proof + (object + method m = x + end + :> < >)) + #m ;; (* Record patterns *) @@ -3537,12 +3535,12 @@ open Typ let rec to_string : 'a. 'a Typ.typ -> 'a -> string = fun (type s) t x -> - match (t : s typ) with - | Int eq -> string_of_int (TypEq.apply eq x) - | String eq -> Printf.sprintf "%S" (TypEq.apply eq x) - | Pair (module P) -> - let x1, x2 = TypEq.apply P.eq x in - Printf.sprintf "(%s,%s)" (to_string P.t1 x1) (to_string P.t2 x2) + match (t : s typ) with + | Int eq -> string_of_int (TypEq.apply eq x) + | String eq -> Printf.sprintf "%S" (TypEq.apply eq x) + | Pair (module P) -> + let x1, x2 = TypEq.apply P.eq x in + Printf.sprintf "(%s,%s)" (to_string P.t1 x1) (to_string P.t2 x2) ;; (* Wrapping maps *) @@ -8735,9 +8733,9 @@ let g : int t -> int = function let h : type a. a t -> a t -> bool = fun x y -> - match x, y with - | Int, Int -> true - | Bool, Bool -> true + match x, y with + | Int, Int -> true + | Bool, Bool -> true ;; type (_, _) cmp = @@ -8790,8 +8788,8 @@ let harder : (zero succ, zero succ, zero succ) plus option -> bool = function let inv_zero : type a b c d. (a, b, c) plus -> (c, d, zero) plus -> bool = fun p1 p2 -> - match p1, p2 with - | Plus0, Plus0 -> true + match p1, p2 with + | Plus0, Plus0 -> true ;; (* Empty match *) @@ -10286,10 +10284,10 @@ type input = let x = fun [@foo] x -> - fun [@foo] y -> - object - method x = y - end + fun [@foo] y -> + object + method x = y + end ;; class x = diff --git a/test/passing/tests/let_binding-in_indent.ml.ref b/test/passing/tests/let_binding-in_indent.ml.ref index 55e8c661d1..cd290308a6 100644 --- a/test/passing/tests/let_binding-in_indent.ml.ref +++ b/test/passing/tests/let_binding-in_indent.ml.ref @@ -237,7 +237,7 @@ let _ = module A = struct let f : int S.t ab -> float S.t ab -> string = fun (l : int S.t ab) (r : float S.t ab) -> - match (l, r) with A, B -> "f A B" + match (l, r) with A, B -> "f A B" ;; end diff --git a/test/passing/tests/let_binding-indent.ml.ref b/test/passing/tests/let_binding-indent.ml.ref index 79820bef5c..cf74355c1f 100644 --- a/test/passing/tests/let_binding-indent.ml.ref +++ b/test/passing/tests/let_binding-indent.ml.ref @@ -237,7 +237,7 @@ let _ = module A = struct let f : int S.t ab -> float S.t ab -> string = fun (l : int S.t ab) (r : float S.t ab) -> - match (l, r) with A, B -> "f A B" + match (l, r) with A, B -> "f A B" ;; end diff --git a/test/passing/tests/let_binding.ml.ref b/test/passing/tests/let_binding.ml.ref index 7aea2df0c1..6066bc9162 100644 --- a/test/passing/tests/let_binding.ml.ref +++ b/test/passing/tests/let_binding.ml.ref @@ -237,7 +237,7 @@ let _ = module A = struct let f : int S.t ab -> float S.t ab -> string = fun (l : int S.t ab) (r : float S.t ab) -> - match (l, r) with A, B -> "f A B" + match (l, r) with A, B -> "f A B" ;; end diff --git a/test/passing/tests/loc_stack.ml.ref b/test/passing/tests/loc_stack.ml.ref index 5f6517d938..7fdb6ca6c3 100644 --- a/test/passing/tests/loc_stack.ml.ref +++ b/test/passing/tests/loc_stack.ml.ref @@ -14,20 +14,19 @@ let _ = let should_inline : Llvm.llvalue -> bool = fun llv -> - match Llvm.use_begin llv with - | Some use -> ( - match Llvm.use_succ use with - | Some _ -> ( - (* If we are not in the default context, we can only use the OCAMLPATH + match Llvm.use_begin llv with + | Some use -> ( + match Llvm.use_succ use with + | Some _ -> ( + (* If we are not in the default context, we can only use the OCAMLPATH variable if it is specific to this build context *) - (* CR-someday diml: maybe we should actually clear OCAMLPATH in other + (* CR-someday diml: maybe we should actually clear OCAMLPATH in other build contexts *) - match Llvm.classify_value llv with - | Instruction - ( Trunc | ZExt | SExt | FPToUI | FPToSI | UIToFP | SIToFP - | FPTrunc | FPExt | PtrToInt | IntToPtr | BitCast | AddrSpaceCast - ) -> - true (* inline casts *) - | _ -> false (* do not inline if >= 2 uses *) ) - | None -> true ) - | None -> true + match Llvm.classify_value llv with + | Instruction + ( Trunc | ZExt | SExt | FPToUI | FPToSI | UIToFP | SIToFP | FPTrunc + | FPExt | PtrToInt | IntToPtr | BitCast | AddrSpaceCast ) -> + true (* inline casts *) + | _ -> false (* do not inline if >= 2 uses *) ) + | None -> true ) + | None -> true diff --git a/test/passing/tests/object.ml.ref b/test/passing/tests/object.ml.ref index d6a86cdc70..5b7184fdcb 100644 --- a/test/passing/tests/object.ml.ref +++ b/test/passing/tests/object.ml.ref @@ -298,10 +298,10 @@ class a x = object (self) end let x = fun [@foo] x -> - fun [@foo] y -> - object - method x = y - end + fun [@foo] y -> + object + method x = y + end class x = fun [@foo] x -> diff --git a/test/passing/tests/polytypes-default.ml.ref b/test/passing/tests/polytypes-default.ml.ref index d89282b8b1..9358065892 100644 --- a/test/passing/tests/polytypes-default.ml.ref +++ b/test/passing/tests/polytypes-default.ml.ref @@ -37,13 +37,13 @@ let _ = let equal_list : 'a. ('a, 't) gexpr marked list -> ('a, 't) gexpr marked list -> bool = fun es1 es2 -> - try List.for_all2 equal es1 es2 with Invalid_argument _ -> false + try List.for_all2 equal es1 es2 with Invalid_argument _ -> false let rec equal_list : 'a. ('a, 't) gexpr marked list -> ('a, 't) gexpr marked list -> bool = fun es1 es2 -> - try List.for_all2 equal es1 es2 with Invalid_argument _ -> false + try List.for_all2 equal es1 es2 with Invalid_argument _ -> false and equal : 'a. ('a, 't) gexpr marked -> ('a, 't) gexpr marked -> bool = fun (type a) (e1 : (a, 't) gexpr marked) (e2 : (a, 't) gexpr marked) -> - match (Marked.unmark e1, Marked.unmark e2) with x -> x + match (Marked.unmark e1, Marked.unmark e2) with x -> x diff --git a/test/passing/tests/polytypes-janestreet.ml.ref b/test/passing/tests/polytypes-janestreet.ml.ref index cc0e91e305..a35e53e6b5 100644 --- a/test/passing/tests/polytypes-janestreet.ml.ref +++ b/test/passing/tests/polytypes-janestreet.ml.ref @@ -41,17 +41,17 @@ let _ = let equal_list : 'a. ('a, 't) gexpr marked list -> ('a, 't) gexpr marked list -> bool = fun es1 es2 -> - try List.for_all2 equal es1 es2 with - | Invalid_argument _ -> false + try List.for_all2 equal es1 es2 with + | Invalid_argument _ -> false ;; let rec equal_list : 'a. ('a, 't) gexpr marked list -> ('a, 't) gexpr marked list -> bool = fun es1 es2 -> - try List.for_all2 equal es1 es2 with - | Invalid_argument _ -> false + try List.for_all2 equal es1 es2 with + | Invalid_argument _ -> false and equal : 'a. ('a, 't) gexpr marked -> ('a, 't) gexpr marked -> bool = fun (type a) (e1 : (a, 't) gexpr marked) (e2 : (a, 't) gexpr marked) -> - match Marked.unmark e1, Marked.unmark e2 with - | x -> x + match Marked.unmark e1, Marked.unmark e2 with + | x -> x ;; diff --git a/test/passing/tests/polytypes.ml b/test/passing/tests/polytypes.ml index 2dd753a38c..9a9ae969df 100644 --- a/test/passing/tests/polytypes.ml +++ b/test/passing/tests/polytypes.ml @@ -37,13 +37,13 @@ let _ = let equal_list : 'a. ('a, 't) gexpr marked list -> ('a, 't) gexpr marked list -> bool = fun es1 es2 -> - try List.for_all2 equal es1 es2 with Invalid_argument _ -> false + try List.for_all2 equal es1 es2 with Invalid_argument _ -> false let rec equal_list : 'a. ('a, 't) gexpr marked list -> ('a, 't) gexpr marked list -> bool = fun es1 es2 -> - try List.for_all2 equal es1 es2 with Invalid_argument _ -> false + try List.for_all2 equal es1 es2 with Invalid_argument _ -> false and equal : 'a. ('a, 't) gexpr marked -> ('a, 't) gexpr marked -> bool = fun (type a) (e1 : (a, 't) gexpr marked) (e2 : (a, 't) gexpr marked) -> - match (Marked.unmark e1, Marked.unmark e2) with x -> x + match (Marked.unmark e1, Marked.unmark e2) with x -> x diff --git a/test/passing/tests/source.ml.err b/test/passing/tests/source.ml.err index 81215270b7..ac3c8ede0e 100644 --- a/test/passing/tests/source.ml.err +++ b/test/passing/tests/source.ml.err @@ -1,4 +1 @@ Warning: tests/source.ml:703 exceeds the margin -Warning: tests/source.ml:1038 exceeds the margin -Warning: tests/source.ml:1253 exceeds the margin -Warning: tests/source.ml:1391 exceeds the margin diff --git a/test/passing/tests/source.ml.ref b/test/passing/tests/source.ml.ref index 255848e7b1..3965ff8ef5 100644 --- a/test/passing/tests/source.ml.ref +++ b/test/passing/tests/source.ml.ref @@ -1030,26 +1030,26 @@ type variant = let rec variantize : type t. t ty -> t -> variant = fun ty x -> - (* type t is abstract here *) - match ty with - | Int -> VInt x (* in this branch: t = int *) - | String -> VString x (* t = string *) - | List ty1 -> - VList (List.map (variantize ty1) x) (* t = 'a list for some 'a *) - | Pair (ty1, ty2) -> VPair (variantize ty1 (fst x), variantize ty2 (snd x)) + (* type t is abstract here *) + match ty with + | Int -> VInt x (* in this branch: t = int *) + | String -> VString x (* t = string *) + | List ty1 -> + VList (List.map (variantize ty1) x) (* t = 'a list for some 'a *) + | Pair (ty1, ty2) -> VPair (variantize ty1 (fst x), variantize ty2 (snd x)) (* t = ('a, 'b) for some 'a and 'b *) exception VariantMismatch let rec devariantize : type t. t ty -> variant -> t = fun ty v -> - match (ty, v) with - | Int, VInt x -> x - | String, VString x -> x - | List ty1, VList vl -> List.map (devariantize ty1) vl - | Pair (ty1, ty2), VPair (x1, x2) -> - (devariantize ty1 x1, devariantize ty2 x2) - | _ -> raise VariantMismatch + match (ty, v) with + | Int, VInt x -> x + | String, VString x -> x + | List ty1, VList vl -> List.map (devariantize ty1) vl + | Pair (ty1, ty2), VPair (x1, x2) -> + (devariantize ty1 x1, devariantize ty2 x2) + | _ -> raise VariantMismatch (* Handling records *) @@ -1077,21 +1077,21 @@ type variant = let rec variantize : type t. t ty -> t -> variant = fun ty x -> - (* type t is abstract here *) - match ty with - | Int -> VInt x (* in this branch: t = int *) - | String -> VString x (* t = string *) - | List ty1 -> - VList (List.map (variantize ty1) x) (* t = 'a list for some 'a *) - | Pair (ty1, ty2) -> - VPair (variantize ty1 (fst x), variantize ty2 (snd x)) - (* t = ('a, 'b) for some 'a and 'b *) - | Record {fields} -> - VRecord - (List.map - (fun (Field {field_type; label; get}) -> - (label, variantize field_type (get x)) ) - fields ) + (* type t is abstract here *) + match ty with + | Int -> VInt x (* in this branch: t = int *) + | String -> VString x (* t = string *) + | List ty1 -> + VList (List.map (variantize ty1) x) (* t = 'a list for some 'a *) + | Pair (ty1, ty2) -> + VPair (variantize ty1 (fst x), variantize ty2 (snd x)) + (* t = ('a, 'b) for some 'a and 'b *) + | Record {fields} -> + VRecord + (List.map + (fun (Field {field_type; label; get}) -> + (label, variantize field_type (get x)) ) + fields ) (* Extraction *) @@ -1119,22 +1119,22 @@ and ('a, 'builder, 'b) field_ = let rec devariantize : type t. t ty -> variant -> t = fun ty v -> - match (ty, v) with - | Int, VInt x -> x - | String, VString x -> x - | List ty1, VList vl -> List.map (devariantize ty1) vl - | Pair (ty1, ty2), VPair (x1, x2) -> - (devariantize ty1 x1, devariantize ty2 x2) - | Record {fields; create_builder; of_builder}, VRecord fl -> - if List.length fields <> List.length fl then raise VariantMismatch ; - let builder = create_builder () in - List.iter2 - (fun (Field {label; field_type; set}) (lab, v) -> - if label <> lab then raise VariantMismatch ; - set builder (devariantize field_type v) ) - fields fl ; - of_builder builder - | _ -> raise VariantMismatch + match (ty, v) with + | Int, VInt x -> x + | String, VString x -> x + | List ty1, VList vl -> List.map (devariantize ty1) vl + | Pair (ty1, ty2), VPair (x1, x2) -> + (devariantize ty1 x1, devariantize ty2 x2) + | Record {fields; create_builder; of_builder}, VRecord fl -> + if List.length fields <> List.length fl then raise VariantMismatch ; + let builder = create_builder () in + List.iter2 + (fun (Field {label; field_type; set}) (lab, v) -> + if label <> lab then raise VariantMismatch ; + set builder (devariantize field_type v) ) + fields fl ; + of_builder builder + | _ -> raise VariantMismatch type my_record = {a: int; b: string list} @@ -1209,11 +1209,11 @@ type (_, _) eq = Eq : ('a, 'a) eq let rec eq_sel : type a b c. (a, b) ty_sel -> (a, c) ty_sel -> (b, c) eq option = fun s1 s2 -> - match (s1, s2) with - | Thd, Thd -> Some Eq - | Ttl s1, Ttl s2 -> ( - match eq_sel s1 s2 with None -> None | Some Eq -> Some Eq ) - | _ -> None + match (s1, s2) with + | Thd, Thd -> Some Eq + | Ttl s1, Ttl s2 -> ( + match eq_sel s1 s2 with None -> None | Some Eq -> Some Eq ) + | _ -> None (* Auxiliary function to get the type of a case from its selector *) let rec get_case : type a b e. @@ -1221,16 +1221,16 @@ let rec get_case : type a b e. -> (string * (e, b) ty_case) list -> string * (a, e) ty option = fun sel cases -> - match cases with - | (name, TCnoarg sel') :: rem -> ( - match eq_sel sel sel' with - | None -> get_case sel rem - | Some Eq -> (name, None) ) - | (name, TCarg (sel', ty)) :: rem -> ( - match eq_sel sel sel' with - | None -> get_case sel rem - | Some Eq -> (name, Some ty) ) - | [] -> raise Not_found + match cases with + | (name, TCnoarg sel') :: rem -> ( + match eq_sel sel sel' with + | None -> get_case sel rem + | Some Eq -> (name, None) ) + | (name, TCarg (sel', ty)) :: rem -> ( + match eq_sel sel sel' with + | None -> get_case sel rem + | Some Eq -> (name, Some ty) ) + | [] -> raise Not_found (* Untyped representation of values *) type variant = @@ -1246,42 +1246,42 @@ let may_map f = function Some x -> Some (f x) | None -> None let rec variantize : type a e. e ty_env -> (a, e) ty -> a -> variant = fun e ty v -> - match ty with - | Int -> VInt v - | String -> VString v - | List t -> VList (List.map (variantize e t) v) - | Option t -> VOption (may_map (variantize e t) v) - | Pair (t1, t2) -> VPair (variantize e t1 (fst v), variantize e t2 (snd v)) - | Rec t -> variantize (Econs (ty, e)) t v - | Pop t -> ( match e with Econs (_, e') -> variantize e' t v ) - | Var -> ( match e with Econs (t, e') -> variantize e' t v ) - | Conv (s, proj, inj, t) -> VConv (s, variantize e t (proj v)) - | Sum ops -> - let tag, arg = ops.sum_proj v in - VSum - (tag, may_map (function Tdyn (ty, arg) -> variantize e ty arg) arg) + match ty with + | Int -> VInt v + | String -> VString v + | List t -> VList (List.map (variantize e t) v) + | Option t -> VOption (may_map (variantize e t) v) + | Pair (t1, t2) -> VPair (variantize e t1 (fst v), variantize e t2 (snd v)) + | Rec t -> variantize (Econs (ty, e)) t v + | Pop t -> ( match e with Econs (_, e') -> variantize e' t v ) + | Var -> ( match e with Econs (t, e') -> variantize e' t v ) + | Conv (s, proj, inj, t) -> VConv (s, variantize e t (proj v)) + | Sum ops -> + let tag, arg = ops.sum_proj v in + VSum + (tag, may_map (function Tdyn (ty, arg) -> variantize e ty arg) arg) let rec devariantize : type t e. e ty_env -> (t, e) ty -> variant -> t = fun e ty v -> - match (ty, v) with - | Int, VInt x -> x - | String, VString x -> x - | List ty1, VList vl -> List.map (devariantize e ty1) vl - | Pair (ty1, ty2), VPair (x1, x2) -> - (devariantize e ty1 x1, devariantize e ty2 x2) - | Rec t, _ -> devariantize (Econs (ty, e)) t v - | Pop t, _ -> ( match e with Econs (_, e') -> devariantize e' t v ) - | Var, _ -> ( match e with Econs (t, e') -> devariantize e' t v ) - | Conv (s, proj, inj, t), VConv (s', v) when s = s' -> - inj (devariantize e t v) - | Sum ops, VSum (tag, a) -> ( - try - match (List.assoc tag ops.sum_cases, a) with - | TCarg (sel, t), Some a -> ops.sum_inj (sel, devariantize e t a) - | TCnoarg sel, None -> ops.sum_inj (sel, Noarg) - | _ -> raise VariantMismatch - with Not_found -> raise VariantMismatch ) - | _ -> raise VariantMismatch + match (ty, v) with + | Int, VInt x -> x + | String, VString x -> x + | List ty1, VList vl -> List.map (devariantize e ty1) vl + | Pair (ty1, ty2), VPair (x1, x2) -> + (devariantize e ty1 x1, devariantize e ty2 x2) + | Rec t, _ -> devariantize (Econs (ty, e)) t v + | Pop t, _ -> ( match e with Econs (_, e') -> devariantize e' t v ) + | Var, _ -> ( match e with Econs (t, e') -> devariantize e' t v ) + | Conv (s, proj, inj, t), VConv (s', v) when s = s' -> + inj (devariantize e t v) + | Sum ops, VSum (tag, a) -> ( + try + match (List.assoc tag ops.sum_cases, a) with + | TCarg (sel, t), Some a -> ops.sum_inj (sel, devariantize e t a) + | TCnoarg sel, None -> ops.sum_inj (sel, Noarg) + | _ -> raise VariantMismatch + with Not_found -> raise VariantMismatch ) + | _ -> raise VariantMismatch (* First attempt: represent 1-constructor variants using Conv *) let wrap_A t = Conv ("`A", (fun (`A x) -> x), (fun x -> `A x), t) @@ -1335,19 +1335,19 @@ type 'a vlist = [`Nil | `Cons of 'a * 'a vlist] let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t -> - let tcons = Pair (Pop t, Var) in - Rec - (Sum - { sum_proj= - (function - | `Nil -> ("Nil", None) - | `Cons p -> ("Cons", Some (Tdyn (tcons, p))) ) - ; sum_cases= [("Nil", TCnoarg Thd); ("Cons", TCarg (Ttl Thd, tcons))] - ; sum_inj= - (fun (type c) -> - ( function Thd, Noarg -> `Nil | Ttl Thd, v -> `Cons v - : (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist ) ) - (* One can also write the type annotation directly *) } ) + let tcons = Pair (Pop t, Var) in + Rec + (Sum + { sum_proj= + (function + | `Nil -> ("Nil", None) + | `Cons p -> ("Cons", Some (Tdyn (tcons, p))) ) + ; sum_cases= [("Nil", TCnoarg Thd); ("Cons", TCarg (Ttl Thd, tcons))] + ; sum_inj= + (fun (type c) -> + ( function Thd, Noarg -> `Nil | Ttl Thd, v -> `Cons v + : (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist ) ) + (* One can also write the type annotation directly *) } ) let v = variantize Enil (ty_list Int) (`Cons (1, `Cons (2, `Nil))) @@ -1385,16 +1385,16 @@ let ty_abc : ([`A of int | `B of string | `C], 'e) ty = (* Breaks: no way to pattern-match on a full recursive type *) let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t -> - let targ = Pair (Pop t, Var) in - Rec - (Sum - ( (function - | `Nil -> ("Nil", None) | `Cons p -> ("Cons", Some (Tdyn (targ, p))) - ) - , function - | "Nil", None -> `Nil - | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p - ) ) + let targ = Pair (Pop t, Var) in + Rec + (Sum + ( (function + | `Nil -> ("Nil", None) | `Cons p -> ("Cons", Some (Tdyn (targ, p))) + ) + , function + | "Nil", None -> `Nil + | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p + ) ) (* Define Sum using object instead of record for first-class polymorphism *) @@ -1449,22 +1449,22 @@ type 'a vlist = [`Nil | `Cons of 'a * 'a vlist] let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t -> - let tcons = Pair (Pop t, Var) in - Rec - (Sum - (object - method proj = - function - | `Nil -> ("Nil", None) - | `Cons p -> ("Cons", Some (Tdyn (tcons, p))) - - method cases = - [("Nil", TCnoarg Thd); ("Cons", TCarg (Ttl Thd, tcons))] - - method inj : type c. - (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist = - function Thd, Noarg -> `Nil | Ttl Thd, v -> `Cons v - end ) ) + let tcons = Pair (Pop t, Var) in + Rec + (Sum + (object + method proj = + function + | `Nil -> ("Nil", None) + | `Cons p -> ("Cons", Some (Tdyn (tcons, p))) + + method cases = + [("Nil", TCnoarg Thd); ("Cons", TCarg (Ttl Thd, tcons))] + + method inj : type c. + (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist = + function Thd, Noarg -> `Nil | Ttl Thd, v -> `Cons v + end ) ) (* type (_,_) ty_assoc = @@ -1519,11 +1519,11 @@ type (_, _, _) app = let rec app : type a n m. (a, n) seq -> (a, m) seq -> (a, n, m) app = fun xs ys -> - match xs with - | Snil -> App (ys, PlusZ (length ys)) - | Scons (x, xs') -> - let (App (xs'', pl)) = app xs' ys in - App (Scons (x, xs''), PlusS pl) + match xs with + | Snil -> App (ys, PlusZ (length ys)) + | Scons (x, xs') -> + let (App (xs'', pl)) = app xs' ys in + App (Scons (x, xs''), PlusS pl) (* 3.1 Feature: kinds *) @@ -1564,20 +1564,20 @@ let tree1 = Tfork (Tfork (Ttip, Tnode 4), Tfork (Tnode 4, Tnode 3)) let rec find : type sh. ('a -> 'a -> bool) -> 'a -> (sh, 'a) tree -> (sh, 'a) path list = fun eq n t -> - match t with - | Ttip -> [] - | Tnode m -> if eq n m then [Phere] else [] - | Tfork (x, y) -> - List.map (fun x -> Pleft x) (find eq n x) - @ List.map (fun x -> Pright x) (find eq n y) + match t with + | Ttip -> [] + | Tnode m -> if eq n m then [Phere] else [] + | Tfork (x, y) -> + List.map (fun x -> Pleft x) (find eq n x) + @ List.map (fun x -> Pright x) (find eq n y) let rec extract : type sh. (sh, 'a) path -> (sh, 'a) tree -> 'a = fun p t -> - match (p, t) with - | Pnone x, Ttip -> x - | Phere, Tnode y -> y - | Pleft p, Tfork (l, _) -> extract p l - | Pright p, Tfork (_, r) -> extract p r + match (p, t) with + | Pnone x, Ttip -> x + | Phere, Tnode y -> y + | Pleft p, Tfork (l, _) -> extract p l + | Pright p, Tfork (_, r) -> extract p r (* 3.4 Pattern : Witness *) @@ -1605,7 +1605,7 @@ let p1 : (two, one, three) plus = PlusS (PlusS (PlusZ (NS NZ))) let rec summandLessThanSum : type a b c. (a, b, c) plus -> (a, c) le = fun p -> - match p with PlusZ n -> LeZ n | PlusS p' -> LeS (summandLessThanSum p') + match p with PlusZ n -> LeZ n | PlusS p' -> LeS (summandLessThanSum p') (* 3.8 Pattern: Leibniz Equality *) @@ -1615,22 +1615,22 @@ let convert : type a b. (a, b) equal -> a -> b = fun Eq x -> x let rec sameNat : type a b. a nat -> b nat -> (a, b) equal option = fun a b -> - match (a, b) with - | NZ, NZ -> Some Eq - | NS a', NS b' -> ( - match sameNat a' b' with Some Eq -> Some Eq | None -> None ) - | _ -> None + match (a, b) with + | NZ, NZ -> Some Eq + | NS a', NS b' -> ( + match sameNat a' b' with Some Eq -> Some Eq | None -> None ) + | _ -> None (* Extra: associativity of addition *) let rec plus_func : type a b m n. (a, b, m) plus -> (a, b, n) plus -> (m, n) equal = fun p1 p2 -> - match (p1, p2) with - | PlusZ _, PlusZ _ -> Eq - | PlusS p1', PlusS p2' -> - let Eq = plus_func p1' p2' in - Eq + match (p1, p2) with + | PlusZ _, PlusZ _ -> Eq + | PlusS p1', PlusS p2' -> + let Eq = plus_func p1' p2' in + Eq let rec plus_assoc : type a b c ab bc m n. (a, b, ab) plus @@ -1639,14 +1639,14 @@ let rec plus_assoc : type a b c ab bc m n. -> (a, bc, n) plus -> (m, n) equal = fun p1 p2 p3 p4 -> - match (p1, p4) with - | PlusZ b, PlusZ bc -> - let Eq = plus_func p2 p3 in - Eq - | PlusS p1', PlusS p4' -> - let (PlusS p2') = p2 in - let Eq = plus_assoc p1' p2' p3 p4' in - Eq + match (p1, p4) with + | PlusZ b, PlusZ bc -> + let Eq = plus_func p2 p3 in + Eq + | PlusS p1', PlusS p4' -> + let (PlusS p2') = p2 in + let Eq = plus_assoc p1' p2' p3 p4' in + Eq (* 3.9 Computing Programs and Properties Simultaneously *) @@ -1664,26 +1664,25 @@ type (_, _) diff = Diff : 'c nat * ('a, 'c, 'b) plus -> ('a, 'b) diff let rec diff : type a b. (a, b) le -> a nat -> b nat -> (a, b) diff = fun le a b -> - match (le, a, b) with - | LeZ _, _, m -> Diff (m, PlusZ m) - | LeS q, NS x, NS y -> ( - match diff q x y with Diff (m, p) -> Diff (m, PlusS p) ) + match (le, a, b) with + | LeZ _, _, m -> Diff (m, PlusZ m) + | LeS q, NS x, NS y -> ( + match diff q x y with Diff (m, p) -> Diff (m, PlusS p) ) let rec diff : type a b. (a, b) le -> a nat -> b nat -> (a, b) diff = fun le a b -> - match (a, b, le) with - (* warning *) - | NZ, m, LeZ _ -> Diff (m, PlusZ m) - | NS x, NS y, LeS q -> ( - match diff q x y with Diff (m, p) -> Diff (m, PlusS p) ) - | _ -> . + match (a, b, le) with + (* warning *) + | NZ, m, LeZ _ -> Diff (m, PlusZ m) + | NS x, NS y, LeS q -> ( + match diff q x y with Diff (m, p) -> Diff (m, PlusS p) ) + | _ -> . let rec diff : type a b. (a, b) le -> b nat -> (a, b) diff = fun le b -> - match (b, le) with - | m, LeZ _ -> Diff (m, PlusZ m) - | NS y, LeS q -> ( - match diff q y with Diff (m, p) -> Diff (m, PlusS p) ) + match (b, le) with + | m, LeZ _ -> Diff (m, PlusZ m) + | NS y, LeS q -> ( match diff q y with Diff (m, p) -> Diff (m, PlusS p) ) type (_, _) filter = Filter : ('m, 'n) le * ('a, 'm) seq -> ('a, 'n) filter @@ -1692,13 +1691,13 @@ let rec leS' : type m n. (m, n) le -> (m, n succ) le = function let rec filter : type a n. (a -> bool) -> (a, n) seq -> (a, n) filter = fun f s -> - match s with - | Snil -> Filter (LeZ NZ, Snil) - | Scons (a, l) -> ( - match filter f l with - | Filter (le, l') -> - if f a then Filter (LeS le, Scons (a, l')) else Filter (leS' le, l') - ) + match s with + | Snil -> Filter (LeZ NZ, Snil) + | Scons (a, l) -> ( + match filter f l with + | Filter (le, l') -> + if f a then Filter (LeS le, Scons (a, l')) else Filter (leS' le, l') + ) (* 4.1 AVL trees *) @@ -1719,9 +1718,9 @@ let empty = Avl Leaf let rec elem : type h. int -> h avl -> bool = fun x t -> - match t with - | Leaf -> false - | Node (_, l, y, r) -> x = y || if x < y then elem x l else elem x r + match t with + | Leaf -> false + | Node (_, l, y, r) -> x = y || if x < y then elem x l else elem x r let rec rotr : type n. n succ succ avl @@ -1729,15 +1728,15 @@ let rec rotr : type n. -> n avl -> (n succ succ avl, n succ succ succ avl) sum = fun tL y tR -> - match tL with - | Node (Same, a, x, b) -> Inr (Node (Less, a, x, Node (More, b, y, tR))) - | Node (More, a, x, b) -> Inl (Node (Same, a, x, Node (Same, b, y, tR))) - | Node (Less, a, x, Node (Same, b, z, c)) -> - Inl (Node (Same, Node (Same, a, x, b), z, Node (Same, c, y, tR))) - | Node (Less, a, x, Node (Less, b, z, c)) -> - Inl (Node (Same, Node (More, a, x, b), z, Node (Same, c, y, tR))) - | Node (Less, a, x, Node (More, b, z, c)) -> - Inl (Node (Same, Node (Same, a, x, b), z, Node (Less, c, y, tR))) + match tL with + | Node (Same, a, x, b) -> Inr (Node (Less, a, x, Node (More, b, y, tR))) + | Node (More, a, x, b) -> Inl (Node (Same, a, x, Node (Same, b, y, tR))) + | Node (Less, a, x, Node (Same, b, z, c)) -> + Inl (Node (Same, Node (Same, a, x, b), z, Node (Same, c, y, tR))) + | Node (Less, a, x, Node (Less, b, z, c)) -> + Inl (Node (Same, Node (More, a, x, b), z, Node (Same, c, y, tR))) + | Node (Less, a, x, Node (More, b, z, c)) -> + Inl (Node (Same, Node (Same, a, x, b), z, Node (Less, c, y, tR))) let rec rotl : type n. n avl @@ -1745,38 +1744,38 @@ let rec rotl : type n. -> n succ succ avl -> (n succ succ avl, n succ succ succ avl) sum = fun tL u tR -> - match tR with - | Node (Same, a, x, b) -> Inr (Node (More, Node (Less, tL, u, a), x, b)) - | Node (Less, a, x, b) -> Inl (Node (Same, Node (Same, tL, u, a), x, b)) - | Node (More, Node (Same, a, x, b), y, c) -> - Inl (Node (Same, Node (Same, tL, u, a), x, Node (Same, b, y, c))) - | Node (More, Node (Less, a, x, b), y, c) -> - Inl (Node (Same, Node (More, tL, u, a), x, Node (Same, b, y, c))) - | Node (More, Node (More, a, x, b), y, c) -> - Inl (Node (Same, Node (Same, tL, u, a), x, Node (Less, b, y, c))) + match tR with + | Node (Same, a, x, b) -> Inr (Node (More, Node (Less, tL, u, a), x, b)) + | Node (Less, a, x, b) -> Inl (Node (Same, Node (Same, tL, u, a), x, b)) + | Node (More, Node (Same, a, x, b), y, c) -> + Inl (Node (Same, Node (Same, tL, u, a), x, Node (Same, b, y, c))) + | Node (More, Node (Less, a, x, b), y, c) -> + Inl (Node (Same, Node (More, tL, u, a), x, Node (Same, b, y, c))) + | Node (More, Node (More, a, x, b), y, c) -> + Inl (Node (Same, Node (Same, tL, u, a), x, Node (Less, b, y, c))) let rec ins : type n. int -> n avl -> (n avl, n succ avl) sum = fun x t -> - match t with - | Leaf -> Inr (Node (Same, Leaf, x, Leaf)) - | Node (bal, a, y, b) -> ( - if x = y then Inl t - else if x < y then - match ins x a with - | Inl a -> Inl (Node (bal, a, y, b)) - | Inr a -> ( - match bal with - | Less -> Inl (Node (Same, a, y, b)) - | Same -> Inr (Node (More, a, y, b)) - | More -> rotr a y b ) - else - match ins x b with - | Inl b -> Inl (Node (bal, a, y, b) : n avl) - | Inr b -> ( - match bal with - | More -> Inl (Node (Same, a, y, b) : n avl) - | Same -> Inr (Node (Less, a, y, b) : n succ avl) - | Less -> rotl a y b ) ) + match t with + | Leaf -> Inr (Node (Same, Leaf, x, Leaf)) + | Node (bal, a, y, b) -> ( + if x = y then Inl t + else if x < y then + match ins x a with + | Inl a -> Inl (Node (bal, a, y, b)) + | Inr a -> ( + match bal with + | Less -> Inl (Node (Same, a, y, b)) + | Same -> Inr (Node (More, a, y, b)) + | More -> rotr a y b ) + else + match ins x b with + | Inl b -> Inl (Node (bal, a, y, b) : n avl) + | Inr b -> ( + match bal with + | More -> Inl (Node (Same, a, y, b) : n avl) + | Same -> Inr (Node (Less, a, y, b) : n succ avl) + | Less -> rotl a y b ) ) let insert x (Avl t) = match ins x t with Inl t -> Avl t | Inr t -> Avl t @@ -1800,44 +1799,41 @@ type _ avl_del = let rec del : type n. int -> n avl -> n avl_del = fun y t -> - match t with - | Leaf -> Dsame Leaf - | Node (bal, l, x, r) -> ( - if x = y then - match r with - | Leaf -> ( - match bal with Same -> Ddecr (Eq, l) | More -> Ddecr (Eq, l) ) - | Node _ -> ( - match (bal, del_min r) with - | _, (z, Inr r) -> Dsame (Node (bal, l, z, r)) - | Same, (z, Inl r) -> Dsame (Node (More, l, z, r)) - | Less, (z, Inl r) -> Ddecr (Eq, Node (Same, l, z, r)) - | More, (z, Inl r) -> ( - match rotr l z r with - | Inl t -> Ddecr (Eq, t) - | Inr t -> Dsame t ) ) - else if y < x then - match del y l with - | Dsame l -> Dsame (Node (bal, l, x, r)) - | Ddecr (Eq, l) -> ( - match bal with - | Same -> Dsame (Node (Less, l, x, r)) - | More -> Ddecr (Eq, Node (Same, l, x, r)) - | Less -> ( - match rotl l x r with - | Inl t -> Ddecr (Eq, t) - | Inr t -> Dsame t ) ) - else - match del y r with - | Dsame r -> Dsame (Node (bal, l, x, r)) - | Ddecr (Eq, r) -> ( - match bal with - | Same -> Dsame (Node (More, l, x, r)) - | Less -> Ddecr (Eq, Node (Same, l, x, r)) - | More -> ( - match rotr l x r with - | Inl t -> Ddecr (Eq, t) - | Inr t -> Dsame t ) ) ) + match t with + | Leaf -> Dsame Leaf + | Node (bal, l, x, r) -> ( + if x = y then + match r with + | Leaf -> ( + match bal with Same -> Ddecr (Eq, l) | More -> Ddecr (Eq, l) ) + | Node _ -> ( + match (bal, del_min r) with + | _, (z, Inr r) -> Dsame (Node (bal, l, z, r)) + | Same, (z, Inl r) -> Dsame (Node (More, l, z, r)) + | Less, (z, Inl r) -> Ddecr (Eq, Node (Same, l, z, r)) + | More, (z, Inl r) -> ( + match rotr l z r with Inl t -> Ddecr (Eq, t) | Inr t -> Dsame t ) + ) + else if y < x then + match del y l with + | Dsame l -> Dsame (Node (bal, l, x, r)) + | Ddecr (Eq, l) -> ( + match bal with + | Same -> Dsame (Node (Less, l, x, r)) + | More -> Ddecr (Eq, Node (Same, l, x, r)) + | Less -> ( + match rotl l x r with Inl t -> Ddecr (Eq, t) | Inr t -> Dsame t ) + ) + else + match del y r with + | Dsame r -> Dsame (Node (bal, l, x, r)) + | Ddecr (Eq, r) -> ( + match bal with + | Same -> Dsame (Node (More, l, x, r)) + | Less -> Ddecr (Eq, Node (Same, l, x, r)) + | More -> ( + match rotr l x r with Inl t -> Ddecr (Eq, t) | Inr t -> Dsame t ) + ) ) let delete x (Avl t) = match del x t with Dsame t -> Avl t | Ddecr (_, t) -> Avl t @@ -1879,12 +1875,12 @@ let color : type c n. (c, n) sub_tree -> c crep = function let rec fill : type c n. (c, n) ctxt -> (c, n) sub_tree -> rb_tree = fun ct t -> - match ct with - | CNil -> Root t - | CRed (e, LeftD, uncle, c) -> fill c (Rnode (uncle, e, t)) - | CRed (e, RightD, uncle, c) -> fill c (Rnode (t, e, uncle)) - | CBlk (e, LeftD, uncle, c) -> fill c (Bnode (uncle, e, t)) - | CBlk (e, RightD, uncle, c) -> fill c (Bnode (t, e, uncle)) + match ct with + | CNil -> Root t + | CRed (e, LeftD, uncle, c) -> fill c (Rnode (uncle, e, t)) + | CRed (e, RightD, uncle, c) -> fill c (Rnode (t, e, uncle)) + | CBlk (e, LeftD, uncle, c) -> fill c (Bnode (uncle, e, t)) + | CBlk (e, RightD, uncle, c) -> fill c (Bnode (t, e, uncle)) let recolor d1 pE sib d2 gE uncle t = match (d1, d2) with @@ -1902,25 +1898,25 @@ let rotate d1 pE sib d2 gE uncle (Rnode (x, e, y)) = let rec repair : type c n. (red, n) sub_tree -> (c, n) ctxt -> rb_tree = fun t ct -> - match ct with - | CNil -> Root (blacken t) - | CBlk (e, LeftD, sib, c) -> fill c (Bnode (sib, e, t)) - | CBlk (e, RightD, sib, c) -> fill c (Bnode (t, e, sib)) - | CRed (e, dir, sib, CBlk (e', dir', uncle, ct)) -> ( - match color uncle with - | Red -> repair (recolor dir e sib dir' e' (blacken uncle) t) ct - | Black -> fill ct (rotate dir e sib dir' e' uncle t) ) + match ct with + | CNil -> Root (blacken t) + | CBlk (e, LeftD, sib, c) -> fill c (Bnode (sib, e, t)) + | CBlk (e, RightD, sib, c) -> fill c (Bnode (t, e, sib)) + | CRed (e, dir, sib, CBlk (e', dir', uncle, ct)) -> ( + match color uncle with + | Red -> repair (recolor dir e sib dir' e' (blacken uncle) t) ct + | Black -> fill ct (rotate dir e sib dir' e' uncle t) ) let rec ins : type c n. int -> (c, n) sub_tree -> (c, n) ctxt -> rb_tree = fun e t ct -> - match t with - | Rnode (l, e', r) -> - if e < e' then ins e l (CRed (e', RightD, r, ct)) - else ins e r (CRed (e', LeftD, l, ct)) - | Bnode (l, e', r) -> - if e < e' then ins e l (CBlk (e', RightD, r, ct)) - else ins e r (CBlk (e', LeftD, l, ct)) - | Bleaf -> repair (Rnode (Bleaf, e, Bleaf)) ct + match t with + | Rnode (l, e', r) -> + if e < e' then ins e l (CRed (e', RightD, r, ct)) + else ins e r (CRed (e', LeftD, l, ct)) + | Bnode (l, e', r) -> + if e < e' then ins e l (CBlk (e', RightD, r, ct)) + else ins e r (CBlk (e', LeftD, l, ct)) + | Bleaf -> repair (Rnode (Bleaf, e, Bleaf)) ct let insert e (Root t) = ins e t CNil @@ -1954,20 +1950,20 @@ type (_, _) equal = Eq : ('a, 'a) equal let rec rep_equal : type a b. a rep -> b rep -> (a, b) equal option = fun ra rb -> - match (ra, rb) with - | Rint, Rint -> Some Eq - | Rbool, Rbool -> Some Eq - | Rpair (a1, a2), Rpair (b1, b2) -> ( - match rep_equal a1 b1 with - | None -> None - | Some Eq -> ( - match rep_equal a2 b2 with None -> None | Some Eq -> Some Eq ) ) - | Rfun (a1, a2), Rfun (b1, b2) -> ( - match rep_equal a1 b1 with - | None -> None - | Some Eq -> ( - match rep_equal a2 b2 with None -> None | Some Eq -> Some Eq ) ) - | _ -> None + match (ra, rb) with + | Rint, Rint -> Some Eq + | Rbool, Rbool -> Some Eq + | Rpair (a1, a2), Rpair (b1, b2) -> ( + match rep_equal a1 b1 with + | None -> None + | Some Eq -> ( + match rep_equal a2 b2 with None -> None | Some Eq -> Some Eq ) ) + | Rfun (a1, a2), Rfun (b1, b2) -> ( + match rep_equal a1 b1 with + | None -> None + | Some Eq -> ( + match rep_equal a2 b2 with None -> None | Some Eq -> Some Eq ) ) + | _ -> None type assoc = Assoc : string * 'a rep * 'a -> assoc @@ -2037,12 +2033,12 @@ type _ env = let rec eval_lam : type e t. e env -> (e, t) lam -> t = fun env m -> - match (env, m) with - | _, Const n -> n - | Econs (_, v, r), Var _ -> v - | Econs (_, _, r), Shift e -> eval_lam r e - | _, Abs (n, body) -> fun x -> eval_lam (Econs (n, x, env)) body - | _, App (f, x) -> eval_lam env f (eval_lam env x) + match (env, m) with + | _, Const n -> n + | Econs (_, v, r), Var _ -> v + | Econs (_, _, r), Shift e -> eval_lam r e + | _, Abs (n, body) -> fun x -> eval_lam (Econs (n, x, env)) body + | _, App (f, x) -> eval_lam env f (eval_lam env x) type add = Add @@ -2077,15 +2073,15 @@ type _ rep = I : int rep | Ar : 'a rep * 'b rep -> ('a -> 'b) rep let rec compare : type a b. a rep -> b rep -> (string, (a, b) equal) sum = fun a b -> - match (a, b) with - | I, I -> Inr Eq - | Ar (x, y), Ar (s, t) -> ( - match compare x s with - | Inl _ as e -> e - | Inr Eq -> ( - match compare y t with Inl _ as e -> e | Inr Eq as e -> e ) ) - | I, Ar _ -> Inl "I <> Ar _" - | Ar _, I -> Inl "Ar _ <> I" + match (a, b) with + | I, I -> Inr Eq + | Ar (x, y), Ar (s, t) -> ( + match compare x s with + | Inl _ as e -> e + | Inr Eq -> ( + match compare y t with Inl _ as e -> e | Inr Eq as e -> e ) ) + | I, Ar _ -> Inl "I <> Ar _" + | Ar _, I -> Inl "Ar _ <> I" type term = | C of int @@ -2103,37 +2099,37 @@ type _ checked = let rec lookup : type e. string -> e ctx -> e checked = fun name ctx -> - match ctx with - | Cnil -> Cerror ("Name not found: " ^ name) - | Ccons (l, s, t, rs) -> ( - if s = name then Cok (Var l, t) - else - match lookup name rs with - | Cerror m -> Cerror m - | Cok (v, t) -> Cok (Shift v, t) ) + match ctx with + | Cnil -> Cerror ("Name not found: " ^ name) + | Ccons (l, s, t, rs) -> ( + if s = name then Cok (Var l, t) + else + match lookup name rs with + | Cerror m -> Cerror m + | Cok (v, t) -> Cok (Shift v, t) ) let rec tc : type n e. n nat -> e ctx -> term -> e checked = fun n ctx t -> - match t with - | V s -> lookup s ctx - | Ap (f, x) -> ( - match tc n ctx f with - | Cerror _ as e -> e - | Cok (f', ft) -> ( - match tc n ctx x with - | Cerror _ as e -> e - | Cok (x', xt) -> ( - match ft with - | Ar (a, b) -> ( - match compare a xt with - | Inl s -> Cerror s - | Inr Eq -> Cok (App (f', x'), b) ) - | _ -> Cerror "Non fun in Ap" ) ) ) - | Ab (s, t, body) -> ( - match tc (NS n) (Ccons (n, s, t, ctx)) body with - | Cerror _ as e -> e - | Cok (body', et) -> Cok (Abs (n, body'), Ar (t, et)) ) - | C m -> Cok (Const m, I) + match t with + | V s -> lookup s ctx + | Ap (f, x) -> ( + match tc n ctx f with + | Cerror _ as e -> e + | Cok (f', ft) -> ( + match tc n ctx x with + | Cerror _ as e -> e + | Cok (x', xt) -> ( + match ft with + | Ar (a, b) -> ( + match compare a xt with + | Inl s -> Cerror s + | Inr Eq -> Cok (App (f', x'), b) ) + | _ -> Cerror "Non fun in Ap" ) ) ) + | Ab (s, t, body) -> ( + match tc (NS n) (Ccons (n, s, t, ctx)) body with + | Cerror _ as e -> e + | Cok (body', et) -> Cok (Abs (n, body'), Ar (t, et)) ) + | C m -> Cok (Const m, I) let ctx0 = Ccons @@ -2205,17 +2201,17 @@ type (_, _) lam' = Ex : ('m, 's, 't) lam -> ('s, 't) lam' let rec subst : type m1 r t s. (m1, r, t) lam -> (r, s) sub -> (s, t) lam' = fun t s -> - match (t, s) with - | _, Id -> Ex t - | Const (r, c), sub -> Ex (Const (r, c)) - | Var v, Bind (x, e, r) -> Ex e - | Var v, Push sub -> Ex (Var v) - | Shift e, Bind (_, _, r) -> subst e r - | Shift e, Push sub -> ( match subst e sub with Ex a -> Ex (Shift a) ) - | App (f, x), sub -> ( - match (subst f sub, subst x sub) with Ex g, Ex y -> Ex (App (g, y)) ) - | Lam (v, x), sub -> ( - match subst x (Push sub) with Ex body -> Ex (Lam (v, body)) ) + match (t, s) with + | _, Id -> Ex t + | Const (r, c), sub -> Ex (Const (r, c)) + | Var v, Bind (x, e, r) -> Ex e + | Var v, Push sub -> Ex (Var v) + | Shift e, Bind (_, _, r) -> subst e r + | Shift e, Push sub -> ( match subst e sub with Ex a -> Ex (Shift a) ) + | App (f, x), sub -> ( + match (subst f sub, subst x sub) with Ex g, Ex y -> Ex (App (g, y)) ) + | Lam (v, x), sub -> ( + match subst x (Push sub) with Ex body -> Ex (Lam (v, body)) ) type closed = rnil @@ -2224,12 +2220,12 @@ type 'a rlam = ((pexp, closed, 'a) lam, (pval, closed, 'a) lam) sum let rec rule : type a b. (pval, closed, (a, b) tarr) lam -> (pval, closed, a) lam -> b rlam = fun v1 v2 -> - match (v1, v2) with - | Lam (x, body), v -> ( - match subst body (Bind (x, v, Id)) with - | Ex term -> ( - match mode term with Pexp -> Inl term | Pval -> Inr term ) ) - | Const (IntTo b, f), Const (IntR, x) -> Inr (Const (b, f x)) + match (v1, v2) with + | Lam (x, body), v -> ( + match subst body (Bind (x, v, Id)) with + | Ex term -> ( + match mode term with Pexp -> Inl term | Pval -> Inr term ) ) + | Const (IntTo b, f), Const (IntR, x) -> Inr (Const (b, f x)) let rec onestep : type m t. (m, closed, t) lam -> t rlam = function | Lam (v, body) -> Inr (Lam (v, body)) @@ -2257,11 +2253,11 @@ type ('env, 'a) typ = let f : type env a. (env, a) typ -> (env, a) typ -> int = fun ta tb -> - match (ta, tb) with - | Tint, Tint -> 0 - | Tbool, Tbool -> 1 - | Tvar var, tb -> 2 - | _ -> . (* error *) + match (ta, tb) with + | Tint, Tint -> 0 + | Tbool, Tbool -> 1 + | Tvar var, tb -> 2 + | _ -> . (* error *) (* let x = f Tint (Tvar Zero) ;; *) type inkind = [`Link | `Nonlink] @@ -2393,9 +2389,9 @@ type _ wrapPoly = let example6 : type a. a wrapPoly -> a -> int = fun w -> - match w with - | WrapPoly ATag -> intA - | WrapPoly _ -> intA (* This should not be allowed *) + match w with + | WrapPoly ATag -> intA + | WrapPoly _ -> intA (* This should not be allowed *) let _ = example6 (WrapPoly AandBTags) `TagB (* This causes a seg fault *) @@ -2407,7 +2403,7 @@ struct let f : int S.t ab -> float S.t ab -> string = fun (l : int S.t ab) (r : float S.t ab) -> - match (l, r) with A, B -> "f A B" + match (l, r) with A, B -> "f A B" end module F (S : sig @@ -2585,9 +2581,9 @@ type _ lst = CNil : nil lst | CCons : 'h * 't lst -> ('h -> 't) lst let rec get_var : type stk ret. (stk s, ret) var -> stk lst -> ret = fun n s -> - match (n, s) with - | Head, CCons (h, _) -> h - | Tail n', CCons (_, t) -> get_var n' t + match (n, s) with + | Head, CCons (h, _) -> h + | Tail n', CCons (_, t) -> get_var n' t type 'a t = [< `Foo | `Bar] as 'a @@ -2688,8 +2684,8 @@ type _ t = Nil : nil t | Cons : ('x, 'fx) elt * 'x t -> 'fx t let undetected : ('a -> 'b -> nil) t -> 'a n -> 'b n -> unit = fun sh i j -> - let (Cons (Elt dim, _)) = sh in - () + let (Cons (Elt dim, _)) = sh in + () type _ t = T : int t @@ -2757,34 +2753,34 @@ let comp_subst f g (x : 'a fin) = pre_subst f (g x) let rec thin : type n. n succ fin -> n fin -> n succ fin = fun x y -> - match (x, y) with - | FZ, y -> FS y - | FS x, FZ -> FZ - | FS x, FS y -> FS (thin x y) + match (x, y) with + | FZ, y -> FS y + | FS x, FZ -> FZ + | FS x, FS y -> FS (thin x y) let bind t f = match t with None -> None | Some x -> f x (* val bind : 'a option -> ('a -> 'b option) -> 'b option *) let rec thick : type n. n succ fin -> n succ fin -> n fin option = fun x y -> - match (x, y) with - | FZ, FZ -> None - | FZ, FS y -> Some y - | FS x, FZ -> - let IS = fin_succ x in - Some FZ - | FS x, FS y -> - let IS = fin_succ x in - bind (thick x y) (fun x -> Some (FS x)) + match (x, y) with + | FZ, FZ -> None + | FZ, FS y -> Some y + | FS x, FZ -> + let IS = fin_succ x in + Some FZ + | FS x, FS y -> + let IS = fin_succ x in + bind (thick x y) (fun x -> Some (FS x)) let rec check : type n. n succ fin -> n succ term -> n term option = fun x t -> - match t with - | Var y -> bind (thick x y) (fun x -> Some (Var x)) - | Leaf -> Some Leaf - | Fork (t1, t2) -> - bind (check x t1) (fun t1 -> - bind (check x t2) (fun t2 -> Some (Fork (t1, t2))) ) + match t with + | Var y -> bind (thick x y) (fun x -> Some (Var x)) + | Leaf -> Some Leaf + | Fork (t1, t2) -> + bind (check x t1) (fun t1 -> + bind (check x t2) (fun t2 -> Some (Fork (t1, t2))) ) let subst_var x t' y = match thick x y with None -> t' | Some y' -> Var y' (* val subst_var : 'a succ fin -> 'a term -> 'a succ fin -> 'a term *) @@ -2803,7 +2799,7 @@ let rec sub : type m n. (m, n) alist -> m fin -> n term = function let rec append : type m n l. (m, n) alist -> (l, m) alist -> (l, n) alist = fun r s -> - match s with Anil -> r | Asnoc (s, t, x) -> Asnoc (append r s, t, x) + match s with Anil -> r | Asnoc (s, t, x) -> Asnoc (append r s, t, x) type _ ealist = EAlist : ('a, 'b) alist -> 'a ealist @@ -2843,24 +2839,24 @@ let flex_rigid x t = bind (check x t) (fun t' -> Some (asnoc Anil t' x)) let rec amgu : type m. m term -> m term -> m ealist -> m ealist option = fun s t acc -> - match (s, t, acc) with - | Leaf, Leaf, _ -> Some acc - | Leaf, Fork _, _ -> None - | Fork _, Leaf, _ -> None - | Fork (s1, s2), Fork (t1, t2), _ -> bind (amgu s1 t1 acc) (amgu s2 t2) - | Var x, Var y, EAlist Anil -> - let IS = fin_succ x in - Some (flex_flex x y) - | Var x, t, EAlist Anil -> - let IS = fin_succ x in - flex_rigid x t - | t, Var x, EAlist Anil -> - let IS = fin_succ x in - flex_rigid x t - | s, t, EAlist (Asnoc (d, r, z)) -> - bind - (amgu (subst z r s) (subst z r t) (EAlist d)) - (fun (EAlist d) -> Some (asnoc d r z)) + match (s, t, acc) with + | Leaf, Leaf, _ -> Some acc + | Leaf, Fork _, _ -> None + | Fork _, Leaf, _ -> None + | Fork (s1, s2), Fork (t1, t2), _ -> bind (amgu s1 t1 acc) (amgu s2 t2) + | Var x, Var y, EAlist Anil -> + let IS = fin_succ x in + Some (flex_flex x y) + | Var x, t, EAlist Anil -> + let IS = fin_succ x in + flex_rigid x t + | t, Var x, EAlist Anil -> + let IS = fin_succ x in + flex_rigid x t + | s, t, EAlist (Asnoc (d, r, z)) -> + bind + (amgu (subst z r s) (subst z r t) (EAlist d)) + (fun (EAlist d) -> Some (asnoc d r z)) let mgu s t = amgu s t (EAlist Anil) (* val mgu : 'a term -> 'a term -> 'a ealist option *) @@ -2881,20 +2877,20 @@ type (_, _) eq = Refl : ('a, 'a) eq let magic : 'a 'b. 'a -> 'b = fun (type a b) (x : a) -> - let module M = - (functor - (T : sig - type 'a t - end) - -> - struct - let f (Refl : (a T.t, b T.t) eq) = (x :> b) - end) - (struct - type 'a t = unit + let module M = + (functor + (T : sig + type 'a t end) - in - M.f Refl + -> + struct + let f (Refl : (a T.t, b T.t) eq) = (x :> b) + end) + (struct + type 'a t = unit + end) + in + M.f Refl (* Variance and subtyping *) @@ -2902,18 +2898,18 @@ type (_, +_) eq = Refl : ('a, 'a) eq let magic : 'a 'b. 'a -> 'b = fun (type a) (type b) (x : a) -> - let bad_proof (type a) = - (Refl : (< m: a >, < m: a >) eq :> (< m: a >, < >) eq) - in - let downcast : type a. (a, < >) eq -> < > -> a = - fun (type a) (Refl : (a, < >) eq) (s : < >) -> (s :> a) - in - (downcast bad_proof - ( object - method m = x - end - :> < > ) ) - #m + let bad_proof (type a) = + (Refl : (< m: a >, < m: a >) eq :> (< m: a >, < >) eq) + in + let downcast : type a. (a, < >) eq -> < > -> a = + fun (type a) (Refl : (a, < >) eq) (s : < >) -> (s :> a) + in + (downcast bad_proof + ( object + method m = x + end + :> < > ) ) + #m (* Record patterns *) @@ -3353,12 +3349,12 @@ open Typ let rec to_string : 'a. 'a Typ.typ -> 'a -> string = fun (type s) t x -> - match (t : s typ) with - | Int eq -> string_of_int (TypEq.apply eq x) - | String eq -> Printf.sprintf "%S" (TypEq.apply eq x) - | Pair (module P) -> - let x1, x2 = TypEq.apply P.eq x in - Printf.sprintf "(%s,%s)" (to_string P.t1 x1) (to_string P.t2 x2) + match (t : s typ) with + | Int eq -> string_of_int (TypEq.apply eq x) + | String eq -> Printf.sprintf "%S" (TypEq.apply eq x) + | Pair (module P) -> + let x1, x2 = TypEq.apply P.eq x in + Printf.sprintf "(%s,%s)" (to_string P.t1 x1) (to_string P.t2 x2) (* Wrapping maps *) module type MapT = sig From cc905ad85a1aa2c4157ded87e1551a57a7159822 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Fri, 17 May 2024 15:50:26 +0200 Subject: [PATCH 047/146] De-indented 'fun' in 'let in' and consistently in let-ops. --- lib/Params.ml | 2 +- test/passing/tests/break_cases-align.ml.ref | 20 ++++----- test/passing/tests/break_cases-all.ml.ref | 20 ++++----- ...reak_cases-closing_on_separate_line.ml.ref | 24 +++++------ ...ng_on_separate_line_fit_or_vertical.ml.ref | 20 ++++----- ...te_line_leading_nested_match_parens.ml.ref | 24 +++++------ .../tests/break_cases-cosl_lnmp_cmei.ml.ref | 24 +++++------ .../tests/break_cases-fit_or_vertical.ml.ref | 16 +++---- test/passing/tests/break_cases-nested.ml.ref | 10 ++--- .../tests/break_cases-normal_indent.ml.ref | 20 ++++----- .../passing/tests/break_cases-toplevel.ml.ref | 16 +++---- .../passing/tests/break_cases-vertical.ml.ref | 26 +++++------ test/passing/tests/break_cases.ml.ref | 8 ++-- test/passing/tests/js_source.ml.err | 12 +++--- test/passing/tests/js_source.ml.ocp | 3 +- test/passing/tests/js_source.ml.ref | 43 +++++++++---------- test/passing/tests/source.ml.err | 1 + test/passing/tests/source.ml.ref | 33 +++++++------- 18 files changed, 160 insertions(+), 162 deletions(-) diff --git a/lib/Params.ml b/lib/Params.ml index 7a29b8ccde..31e8abba14 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -708,7 +708,7 @@ module Indent = struct | _ -> false let ctx_is_let = function - | Lb _ | Str _ -> true + | Lb _ | Str _ | Exp { pexp_desc= Pexp_let _; _ } | Bo _ -> true | _ -> false let function_ ?(default = 0) (c : Conf.t) ~ctx0 ~parens ~has_label = diff --git a/test/passing/tests/break_cases-align.ml.ref b/test/passing/tests/break_cases-align.ml.ref index 49204efc74..ddf4bdad77 100644 --- a/test/passing/tests/break_cases-align.ml.ref +++ b/test/passing/tests/break_cases-align.ml.ref @@ -18,16 +18,16 @@ let f = 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z - |P - |M -> - match y with - | O -> 5 - | P when h x -> ( - function - | A -> 6 ) + match x with + | E -> 4 + | Z + |P + |M -> + match y with + | O -> 5 + | P when h x -> ( + function + | A -> 6 ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-all.ml.ref b/test/passing/tests/break_cases-all.ml.ref index 8fddf03bf5..a79306595c 100644 --- a/test/passing/tests/break_cases-all.ml.ref +++ b/test/passing/tests/break_cases-all.ml.ref @@ -18,16 +18,16 @@ let f = 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z - |P - |M -> ( - match y with - | O -> 5 - | P when h x -> ( - function - | A -> 6 ) ) + match x with + | E -> 4 + | Z + |P + |M -> ( + match y with + | O -> 5 + | P when h x -> ( + function + | A -> 6 ) ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-closing_on_separate_line.ml.ref b/test/passing/tests/break_cases-closing_on_separate_line.ml.ref index fe8e180d85..e17939d99f 100644 --- a/test/passing/tests/break_cases-closing_on_separate_line.ml.ref +++ b/test/passing/tests/break_cases-closing_on_separate_line.ml.ref @@ -18,18 +18,18 @@ let f = 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z - |P - |M -> ( - match y with - | O -> 5 - | P when h x -> ( - function - | A -> 6 - ) - ) + match x with + | E -> 4 + | Z + |P + |M -> ( + match y with + | O -> 5 + | P when h x -> ( + function + | A -> 6 + ) + ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-closing_on_separate_line_fit_or_vertical.ml.ref b/test/passing/tests/break_cases-closing_on_separate_line_fit_or_vertical.ml.ref index e89bcf7158..05c9c1c2e5 100644 --- a/test/passing/tests/break_cases-closing_on_separate_line_fit_or_vertical.ml.ref +++ b/test/passing/tests/break_cases-closing_on_separate_line_fit_or_vertical.ml.ref @@ -12,16 +12,16 @@ let f = | T | P | U -> 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z | P | M -> ( - match y with - | O -> 5 - | P when h x -> ( - function - | A -> 6 - ) - ) + match x with + | E -> 4 + | Z | P | M -> ( + match y with + | O -> 5 + | P when h x -> ( + function + | A -> 6 + ) + ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-closing_on_separate_line_leading_nested_match_parens.ml.ref b/test/passing/tests/break_cases-closing_on_separate_line_leading_nested_match_parens.ml.ref index 6a5993605b..7bbd9230c5 100644 --- a/test/passing/tests/break_cases-closing_on_separate_line_leading_nested_match_parens.ml.ref +++ b/test/passing/tests/break_cases-closing_on_separate_line_leading_nested_match_parens.ml.ref @@ -18,18 +18,18 @@ let f = 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z - |P - |M -> - ( match y with - | O -> 5 - | P when h x -> - (function - | A -> 6 - ) - ) + match x with + | E -> 4 + | Z + |P + |M -> + ( match y with + | O -> 5 + | P when h x -> + (function + | A -> 6 + ) + ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-cosl_lnmp_cmei.ml.ref b/test/passing/tests/break_cases-cosl_lnmp_cmei.ml.ref index 6b57c38b89..0151d3bbfc 100644 --- a/test/passing/tests/break_cases-cosl_lnmp_cmei.ml.ref +++ b/test/passing/tests/break_cases-cosl_lnmp_cmei.ml.ref @@ -18,18 +18,18 @@ let f = 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z - |P - |M -> - ( match y with - | O -> 5 - | P when h x -> - (function - | A -> 6 - ) - ) + match x with + | E -> 4 + | Z + |P + |M -> + ( match y with + | O -> 5 + | P when h x -> + (function + | A -> 6 + ) + ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-fit_or_vertical.ml.ref b/test/passing/tests/break_cases-fit_or_vertical.ml.ref index 6f66e70307..9627c428ab 100644 --- a/test/passing/tests/break_cases-fit_or_vertical.ml.ref +++ b/test/passing/tests/break_cases-fit_or_vertical.ml.ref @@ -12,14 +12,14 @@ let f = | T | P | U -> 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z | P | M -> ( - match y with - | O -> 5 - | P when h x -> ( - function - | A -> 6 ) ) + match x with + | E -> 4 + | Z | P | M -> ( + match y with + | O -> 5 + | P when h x -> ( + function + | A -> 6 ) ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-nested.ml.ref b/test/passing/tests/break_cases-nested.ml.ref index 734740ce22..200b114b6f 100644 --- a/test/passing/tests/break_cases-nested.ml.ref +++ b/test/passing/tests/break_cases-nested.ml.ref @@ -10,11 +10,11 @@ let f x = function let f = let g = function H when x y <> k -> 2 | T | P | U -> 3 in fun x g t h y u -> - match x with - | E -> - 4 - | Z | P | M -> ( - match y with O -> 5 | P when h x -> ( function A -> 6 ) ) + match x with + | E -> + 4 + | Z | P | M -> ( + match y with O -> 5 | P when h x -> ( function A -> 6 ) ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-normal_indent.ml.ref b/test/passing/tests/break_cases-normal_indent.ml.ref index 03e16db911..5a352b8efb 100644 --- a/test/passing/tests/break_cases-normal_indent.ml.ref +++ b/test/passing/tests/break_cases-normal_indent.ml.ref @@ -18,16 +18,16 @@ let f = 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z - |P - |M -> ( - match y with - | O -> 5 - | P when h x -> ( - function - | A -> 6 ) ) + match x with + | E -> 4 + | Z + |P + |M -> ( + match y with + | O -> 5 + | P when h x -> ( + function + | A -> 6 ) ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-toplevel.ml.ref b/test/passing/tests/break_cases-toplevel.ml.ref index 2e44dab191..b2f69fbdd8 100644 --- a/test/passing/tests/break_cases-toplevel.ml.ref +++ b/test/passing/tests/break_cases-toplevel.ml.ref @@ -13,14 +13,14 @@ let f = | T | P | U -> 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z | P | M -> ( - match y with - | O -> 5 - | P when h x -> ( - function - | A -> 6 ) ) + match x with + | E -> 4 + | Z | P | M -> ( + match y with + | O -> 5 + | P when h x -> ( + function + | A -> 6 ) ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-vertical.ml.ref b/test/passing/tests/break_cases-vertical.ml.ref index 6e575cdf3e..4f602dc2f7 100644 --- a/test/passing/tests/break_cases-vertical.ml.ref +++ b/test/passing/tests/break_cases-vertical.ml.ref @@ -19,19 +19,19 @@ let f = 3 in fun x g t h y u -> - match x with - | E -> - 4 - | Z - |P - |M -> ( - match y with - | O -> - 5 - | P when h x -> ( - function - | A -> - 6 ) ) + match x with + | E -> + 4 + | Z + |P + |M -> ( + match y with + | O -> + 5 + | P when h x -> ( + function + | A -> + 6 ) ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases.ml.ref b/test/passing/tests/break_cases.ml.ref index 438f267754..c789ffa692 100644 --- a/test/passing/tests/break_cases.ml.ref +++ b/test/passing/tests/break_cases.ml.ref @@ -10,10 +10,10 @@ let f x = function let f = let g = function H when x y <> k -> 2 | T | P | U -> 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z | P | M -> ( - match y with O -> 5 | P when h x -> ( function A -> 6 ) ) + match x with + | E -> 4 + | Z | P | M -> ( + match y with O -> 5 | P when h x -> ( function A -> 6 ) ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/js_source.ml.err b/test/passing/tests/js_source.ml.err index b70eaa2415..819ca83dce 100644 --- a/test/passing/tests/js_source.ml.err +++ b/test/passing/tests/js_source.ml.err @@ -1,7 +1,7 @@ Warning: tests/js_source.ml:161 exceeds the margin -Warning: tests/js_source.ml:2675 exceeds the margin -Warning: tests/js_source.ml:9574 exceeds the margin -Warning: tests/js_source.ml:9678 exceeds the margin -Warning: tests/js_source.ml:9737 exceeds the margin -Warning: tests/js_source.ml:9820 exceeds the margin -Warning: tests/js_source.ml:10326 exceeds the margin +Warning: tests/js_source.ml:2674 exceeds the margin +Warning: tests/js_source.ml:9573 exceeds the margin +Warning: tests/js_source.ml:9677 exceeds the margin +Warning: tests/js_source.ml:9736 exceeds the margin +Warning: tests/js_source.ml:9819 exceeds the margin +Warning: tests/js_source.ml:10325 exceeds the margin diff --git a/test/passing/tests/js_source.ml.ocp b/test/passing/tests/js_source.ml.ocp index 04b818c987..1ec9843768 100644 --- a/test/passing/tests/js_source.ml.ocp +++ b/test/passing/tests/js_source.ml.ocp @@ -2382,8 +2382,7 @@ let inlineseq_from_astseq seq = | x, Ast_Bold xs -> Bold (List.map (process x) xs) | Kind Maylink, Ast_Link lnk -> Link lnk | Kind Nonlink, Ast_Link _ -> assert false - | Kind Maylink, Ast_Mref (lnk, xs) -> - Mref (lnk, List.map (process (Kind Nonlink)) xs) + | Kind Maylink, Ast_Mref (lnk, xs) -> Mref (lnk, List.map (process (Kind Nonlink)) xs) | Kind Nonlink, Ast_Mref _ -> assert false in List.map (process (Kind Maylink)) seq diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index 9085e8d133..ef374e6c4c 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -2359,14 +2359,14 @@ type _ linkp = let inlineseq_from_astseq seq = let rec process : type a. a linkp -> ast_t -> a inline_t = fun allow_link ast -> - match allow_link, ast with - | Maylink, Ast_Text txt -> Text txt - | Nonlink, Ast_Text txt -> Text txt - | x, Ast_Bold xs -> Bold (List.map (process x) xs) - | Maylink, Ast_Link lnk -> Link lnk - | Nonlink, Ast_Link _ -> assert false - | Maylink, Ast_Mref (lnk, xs) -> Mref (lnk, List.map (process Nonlink) xs) - | Nonlink, Ast_Mref _ -> assert false + match allow_link, ast with + | Maylink, Ast_Text txt -> Text txt + | Nonlink, Ast_Text txt -> Text txt + | x, Ast_Bold xs -> Bold (List.map (process x) xs) + | Maylink, Ast_Link lnk -> Link lnk + | Nonlink, Ast_Link _ -> assert false + | Maylink, Ast_Mref (lnk, xs) -> Mref (lnk, List.map (process Nonlink) xs) + | Nonlink, Ast_Mref _ -> assert false in List.map (process Maylink) seq ;; @@ -2377,14 +2377,13 @@ type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2 let inlineseq_from_astseq seq = let rec process : type a. a linkp2 -> ast_t -> a inline_t = fun allow_link ast -> - match allow_link, ast with - | Kind _, Ast_Text txt -> Text txt - | x, Ast_Bold xs -> Bold (List.map (process x) xs) - | Kind Maylink, Ast_Link lnk -> Link lnk - | Kind Nonlink, Ast_Link _ -> assert false - | Kind Maylink, Ast_Mref (lnk, xs) -> - Mref (lnk, List.map (process (Kind Nonlink)) xs) - | Kind Nonlink, Ast_Mref _ -> assert false + match allow_link, ast with + | Kind _, Ast_Text txt -> Text txt + | x, Ast_Bold xs -> Bold (List.map (process x) xs) + | Kind Maylink, Ast_Link lnk -> Link lnk + | Kind Nonlink, Ast_Link _ -> assert false + | Kind Maylink, Ast_Mref (lnk, xs) -> Mref (lnk, List.map (process (Kind Nonlink)) xs) + | Kind Nonlink, Ast_Mref _ -> assert false in List.map (process (Kind Maylink)) seq ;; @@ -3661,8 +3660,8 @@ let map_lambda ~map_rec : _ lambda -> _ = function let next_id = let current = ref 3 in fun () -> - incr current; - !current + incr current; + !current ;; let subst_lambda ~subst_rec ~free ~subst : _ lambda -> _ = function @@ -3873,8 +3872,8 @@ type 'a lambda = let next_id = let current = ref 3 in fun () -> - incr current; - !current + incr current; + !current ;; class ['a] lambda_ops (ops : ('a, 'a) #ops Lazy.t) = @@ -4118,8 +4117,8 @@ type 'a lambda = let next_id = let current = ref 3 in fun () -> - incr current; - !current + incr current; + !current ;; let lambda_ops (ops : ('a, 'a) #ops Lazy.t) = diff --git a/test/passing/tests/source.ml.err b/test/passing/tests/source.ml.err index ac3c8ede0e..aee4fc6b97 100644 --- a/test/passing/tests/source.ml.err +++ b/test/passing/tests/source.ml.err @@ -1 +1,2 @@ Warning: tests/source.ml:703 exceeds the margin +Warning: tests/source.ml:2311 exceeds the margin diff --git a/test/passing/tests/source.ml.ref b/test/passing/tests/source.ml.ref index 3965ff8ef5..8b7b9710cf 100644 --- a/test/passing/tests/source.ml.ref +++ b/test/passing/tests/source.ml.ref @@ -2303,15 +2303,14 @@ type _ linkp = Nonlink : [`Nonlink] linkp | Maylink : inkind linkp let inlineseq_from_astseq seq = let rec process : type a. a linkp -> ast_t -> a inline_t = fun allow_link ast -> - match (allow_link, ast) with - | Maylink, Ast_Text txt -> Text txt - | Nonlink, Ast_Text txt -> Text txt - | x, Ast_Bold xs -> Bold (List.map (process x) xs) - | Maylink, Ast_Link lnk -> Link lnk - | Nonlink, Ast_Link _ -> assert false - | Maylink, Ast_Mref (lnk, xs) -> - Mref (lnk, List.map (process Nonlink) xs) - | Nonlink, Ast_Mref _ -> assert false + match (allow_link, ast) with + | Maylink, Ast_Text txt -> Text txt + | Nonlink, Ast_Text txt -> Text txt + | x, Ast_Bold xs -> Bold (List.map (process x) xs) + | Maylink, Ast_Link lnk -> Link lnk + | Nonlink, Ast_Link _ -> assert false + | Maylink, Ast_Mref (lnk, xs) -> Mref (lnk, List.map (process Nonlink) xs) + | Nonlink, Ast_Mref _ -> assert false in List.map (process Maylink) seq @@ -2321,14 +2320,14 @@ type _ linkp2 = Kind : 'a linkp -> ([< inkind] as 'a) linkp2 let inlineseq_from_astseq seq = let rec process : type a. a linkp2 -> ast_t -> a inline_t = fun allow_link ast -> - match (allow_link, ast) with - | Kind _, Ast_Text txt -> Text txt - | x, Ast_Bold xs -> Bold (List.map (process x) xs) - | Kind Maylink, Ast_Link lnk -> Link lnk - | Kind Nonlink, Ast_Link _ -> assert false - | Kind Maylink, Ast_Mref (lnk, xs) -> - Mref (lnk, List.map (process (Kind Nonlink)) xs) - | Kind Nonlink, Ast_Mref _ -> assert false + match (allow_link, ast) with + | Kind _, Ast_Text txt -> Text txt + | x, Ast_Bold xs -> Bold (List.map (process x) xs) + | Kind Maylink, Ast_Link lnk -> Link lnk + | Kind Nonlink, Ast_Link _ -> assert false + | Kind Maylink, Ast_Mref (lnk, xs) -> + Mref (lnk, List.map (process (Kind Nonlink)) xs) + | Kind Nonlink, Ast_Mref _ -> assert false in List.map (process (Kind Maylink)) seq From e762b8e713a5cf0648fa8df29a77ebd7d88ae1c0 Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Wed, 22 May 2024 15:56:09 +0200 Subject: [PATCH 048/146] wip 5.2 --- lib/Fmt_ast.ml | 7 ++++--- lib/Params.ml | 5 +++++ lib/Params.mli | 3 +++ test.ml | 10 ++++++++++ .../tests/break_fun_decl-fit_or_vertical.ml.ref | 4 ++-- test/passing/tests/break_fun_decl-smart.ml.ref | 4 ++-- test/passing/tests/break_fun_decl-wrap.ml.ref | 4 ++-- test/passing/tests/break_fun_decl.ml | 4 ++-- test/passing/tests/fun_decl.ml | 8 ++++---- .../tests/infix_bind-fit_or_vertical.ml.ref | 15 ++++++++++----- test/passing/tests/infix_bind.ml | 15 ++++++++++----- test/passing/tests/let_binding-in_indent.ml.ref | 4 ++-- test/passing/tests/let_binding-indent.ml.ref | 4 ++-- test/passing/tests/let_binding.ml.ref | 4 ++-- 14 files changed, 60 insertions(+), 31 deletions(-) create mode 100644 test.ml diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 3938738f0a..d1e0e37da5 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1475,7 +1475,7 @@ and fmt_function ?force_closing_paren ~ctx ~ctx0 ?(wrap_intro = fun x -> hovbox and annot = Option.map ~f:fmt_typ typ in Params.Exp.box_fun_decl_args ~ctx:ctx0 c.conf ~parens ~kw ~args ~annot - $ break 1 (-2) $ str "->" + $ Params.Exp.break_fun_decl_args ~ctx:ctx0 $ str "->" in (* [head] is [fun args ->] or [function]. [body] is an expression or the cases. *) @@ -1507,6 +1507,7 @@ and fmt_function ?force_closing_paren ~ctx ~ctx0 ?(wrap_intro = fun x -> hovbox else noop, noop in let box k = if should_box then box k else k in + let box = match ctx0 with Str _ -> hvbox_if should_box (Params.Indent.fun_ ~ctx0 c.conf) | _ -> box in box ( wrap_intro (hvbox_if has_cmts_outer 0 @@ -1921,10 +1922,10 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens let indent_wrap = if parens then -2 else 0 in pro $ wrap_fits_breaks_if c.conf parens "(" ")" - ( + ( ( (fmt_function - ~ctx:(Exp r) ~ctx0:ctx ~parens:(parens_r) ~wrap_intro:(fun intro -> + ~ctx:(Exp r) ~ctx0:ctx ~box:false ~parens:(parens_r) ~wrap_intro:(fun intro -> ( ( hvbox indent_wrap (fmt_if has_attr (str "(") $ fmt_expression ~indent_wrap c (sub_exp ~ctx l) diff --git a/lib/Params.ml b/lib/Params.ml index 31e8abba14..8773ebd52f 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -114,6 +114,11 @@ module Exp = struct && List.for_all ~f:arg_is_simple_approx other_args ) | _ -> false + let break_fun_decl_args ~ctx = + match ctx with + Ast.Str _ -> + (* special case that break the arrow in [let _ = fun ... ->] *) (str " ") | _ -> break 1 (-2) + end module Mod = struct diff --git a/lib/Params.mli b/lib/Params.mli index b096c7bd64..f57ecc7ea1 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -50,6 +50,9 @@ module Exp : sig val function_attrs_sp : Conf.t -> ctx0:Ast.t -> ctx:Ast.t -> bool (** Whether a space should be added between the [function] keyword and the attributes. *) + + val break_fun_decl_args : ctx:Ast.t -> Fmt.t + end module Mod : sig diff --git a/test.ml b/test.ml new file mode 100644 index 0000000000..53b1bd9239 --- /dev/null +++ b/test.ml @@ -0,0 +1,10 @@ +let _ = + fun (module Store : Irmin.Generic_key.S with type repo = repo) + (module Store : Irmin.Generic_key.S with type repo = repo) + -> body + +let _ = + f + (fun (module Store : Irmin.Generic_key.S with type repo = repo) + (module Store : Irmin.Generic_key.S with type repo = repo) + -> body ) diff --git a/test/passing/tests/break_fun_decl-fit_or_vertical.ml.ref b/test/passing/tests/break_fun_decl-fit_or_vertical.ml.ref index a4667b10d9..d93df61cf7 100644 --- a/test/passing/tests/break_fun_decl-fit_or_vertical.ml.ref +++ b/test/passing/tests/break_fun_decl-fit_or_vertical.ml.ref @@ -120,8 +120,8 @@ end let _ = fun (module Store : Irmin.Generic_key.S with type repo = repo) - (module Store : Irmin.Generic_key.S with type repo = repo) - -> body + (module Store : Irmin.Generic_key.S with type repo = repo) -> + body let _ = f diff --git a/test/passing/tests/break_fun_decl-smart.ml.ref b/test/passing/tests/break_fun_decl-smart.ml.ref index b00e7fd1ae..c7d3bc4190 100644 --- a/test/passing/tests/break_fun_decl-smart.ml.ref +++ b/test/passing/tests/break_fun_decl-smart.ml.ref @@ -113,8 +113,8 @@ end let _ = fun (module Store : Irmin.Generic_key.S with type repo = repo) - (module Store : Irmin.Generic_key.S with type repo = repo) - -> body + (module Store : Irmin.Generic_key.S with type repo = repo) -> + body let _ = f diff --git a/test/passing/tests/break_fun_decl-wrap.ml.ref b/test/passing/tests/break_fun_decl-wrap.ml.ref index 0aa6d3603f..88a8c80cdc 100644 --- a/test/passing/tests/break_fun_decl-wrap.ml.ref +++ b/test/passing/tests/break_fun_decl-wrap.ml.ref @@ -95,8 +95,8 @@ end let _ = fun (module Store : Irmin.Generic_key.S with type repo = repo) - (module Store : Irmin.Generic_key.S with type repo = repo) - -> body + (module Store : Irmin.Generic_key.S with type repo = repo) -> + body let _ = f diff --git a/test/passing/tests/break_fun_decl.ml b/test/passing/tests/break_fun_decl.ml index 0aa6d3603f..88a8c80cdc 100644 --- a/test/passing/tests/break_fun_decl.ml +++ b/test/passing/tests/break_fun_decl.ml @@ -95,8 +95,8 @@ end let _ = fun (module Store : Irmin.Generic_key.S with type repo = repo) - (module Store : Irmin.Generic_key.S with type repo = repo) - -> body + (module Store : Irmin.Generic_key.S with type repo = repo) -> + body let _ = f diff --git a/test/passing/tests/fun_decl.ml b/test/passing/tests/fun_decl.ml index c4685cc836..cb5db0fcf5 100644 --- a/test/passing/tests/fun_decl.ml +++ b/test/passing/tests/fun_decl.ml @@ -6,13 +6,13 @@ let fooo = List.foooo ~f:(fun foooo foooo : bool -> foooooooooooooooooooooo) let _ = fun (x : int) (x : int) (x : int) (x : int) (x : int) : - fooooooooooooooooooooooooooo foooooooooooooo foooooooooo - -> some_large_computation + fooooooooooooooooooooooooooo foooooooooooooo foooooooooo -> + some_large_computation let _ = fun (x : int) (x : int) (x : int) (x : int) (x : int) (x : int) (x : int) : - fooooooooooooooooooooooooooo foooooooooooooo foooooooooo - -> some_large_computation + fooooooooooooooooooooooooooo foooooooooooooo foooooooooo -> + some_large_computation [@@@ocamlformat "wrap-fun-args=false"] diff --git a/test/passing/tests/infix_bind-fit_or_vertical.ml.ref b/test/passing/tests/infix_bind-fit_or_vertical.ml.ref index eefaa93f6c..ceb07cb7c3 100644 --- a/test/passing/tests/infix_bind-fit_or_vertical.ml.ref +++ b/test/passing/tests/infix_bind-fit_or_vertical.ml.ref @@ -13,12 +13,14 @@ f x >>= function eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee |> fun x -> x ;; eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee -|> fun xxxxxx xxxxxxxxxx xxxxxxxx xxxxxxxx -> x +|> fun xxxxxx xxxxxxxxxx xxxxxxxx xxxxxxxx -> +x ;; eeeeeeeeeeeee eeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeee eeeeeeeeeeee eeeeeeeeee -|> fun x -> x +|> fun x -> +x ;; eeeeeeeeeeeee eeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeee @@ -30,13 +32,15 @@ xxxxxxxxxxx xxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxx xxxxxxxxxxx eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee |> fun x -> x ;; eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee -|> fun xxxxxx xxxxxxxxxx xxxxxxxx xxxxxxxx -> x +|> fun xxxxxx xxxxxxxxxx xxxxxxxx xxxxxxxx -> +x ;; eeeeeeeeeeeee eeeeeeeeeeeeeeeeee |> fun xxxxxxxxx xxxxxxxxxxxxx -> x ;; eeeeeeeeeeeee eeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeee -|> fun xxxxxxxx xxxxxxxxx xxxxxxxxxxxxx -> x +|> fun xxxxxxxx xxxxxxxxx xxxxxxxxxxxxx -> +x ;; eeeeeeeeeeeee eeeeeeeeeeeeeeeeee |> fun xxxxxxxxxxxxx -> @@ -129,7 +133,8 @@ let end_gen_implementation ?toplevel ~ppf_dump ( clambda ++ Profile.record "cmm" (Cmmgen.compunit ~ppf_dump) ++ Profile.record "compile_phrases" (List.iter (compile_phrase ~ppf_dump)) - ++ fun () -> () ) ; + ++ fun () -> + () ) ; fooooooooooooooo let foo = diff --git a/test/passing/tests/infix_bind.ml b/test/passing/tests/infix_bind.ml index 2e01dde50d..2a3a31d274 100644 --- a/test/passing/tests/infix_bind.ml +++ b/test/passing/tests/infix_bind.ml @@ -13,12 +13,14 @@ f x >>= function eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee |> fun x -> x ;; eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee -|> fun xxxxxx xxxxxxxxxx xxxxxxxx xxxxxxxx -> x +|> fun xxxxxx xxxxxxxxxx xxxxxxxx xxxxxxxx -> +x ;; eeeeeeeeeeeee eeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeee eeeeeeeeeeee eeeeeeeeee -|> fun x -> x +|> fun x -> +x ;; eeeeeeeeeeeee eeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeee @@ -30,13 +32,15 @@ xxxxxxxxxxx xxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxx xxxxxxxxxxx eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee |> fun x -> x ;; eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee -|> fun xxxxxx xxxxxxxxxx xxxxxxxx xxxxxxxx -> x +|> fun xxxxxx xxxxxxxxxx xxxxxxxx xxxxxxxx -> +x ;; eeeeeeeeeeeee eeeeeeeeeeeeeeeeee |> fun xxxxxxxxx xxxxxxxxxxxxx -> x ;; eeeeeeeeeeeee eeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeee -|> fun xxxxxxxx xxxxxxxxx xxxxxxxxxxxxx -> x +|> fun xxxxxxxx xxxxxxxxx xxxxxxxxxxxxx -> +x ;; eeeeeeeeeeeee eeeeeeeeeeeeeeeeee |> fun xxxxxxxxxxxxx -> @@ -124,7 +128,8 @@ let end_gen_implementation ?toplevel ~ppf_dump ( clambda ++ Profile.record "cmm" (Cmmgen.compunit ~ppf_dump) ++ Profile.record "compile_phrases" (List.iter (compile_phrase ~ppf_dump)) - ++ fun () -> () ) ; + ++ fun () -> + () ) ; fooooooooooooooo let foo = diff --git a/test/passing/tests/let_binding-in_indent.ml.ref b/test/passing/tests/let_binding-in_indent.ml.ref index cd290308a6..496d0aef81 100644 --- a/test/passing/tests/let_binding-in_indent.ml.ref +++ b/test/passing/tests/let_binding-in_indent.ml.ref @@ -108,8 +108,8 @@ let f aaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbbbbbb cccccccccccccccccccccccc let _ = fun aaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbbbbbb cccccccccccccccccccccccc - dddddddddddddddddd eeeeeeeeeeeeee - -> () + dddddddddddddddddd eeeeeeeeeeeeee -> + () let _ = let (x : int) = x in diff --git a/test/passing/tests/let_binding-indent.ml.ref b/test/passing/tests/let_binding-indent.ml.ref index cf74355c1f..5e07912e98 100644 --- a/test/passing/tests/let_binding-indent.ml.ref +++ b/test/passing/tests/let_binding-indent.ml.ref @@ -108,8 +108,8 @@ let f aaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbbbbbb cccccccccccccccccccccccc let _ = fun aaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbbbbbb - cccccccccccccccccccccccc dddddddddddddddddd eeeeeeeeeeeeee - -> () + cccccccccccccccccccccccc dddddddddddddddddd eeeeeeeeeeeeee -> + () let _ = let (x : int) = x in diff --git a/test/passing/tests/let_binding.ml.ref b/test/passing/tests/let_binding.ml.ref index 6066bc9162..1920f73453 100644 --- a/test/passing/tests/let_binding.ml.ref +++ b/test/passing/tests/let_binding.ml.ref @@ -108,8 +108,8 @@ let f aaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbbbbbb cccccccccccccccccccccccc let _ = fun aaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbbbbbb cccccccccccccccccccccccc - dddddddddddddddddd eeeeeeeeeeeeee - -> () + dddddddddddddddddd eeeeeeeeeeeeee -> + () let _ = let (x : int) = x in From 718bab2d90b47c3ba0439175f60a9135a138cece Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Thu, 23 May 2024 11:21:06 +0200 Subject: [PATCH 049/146] break infix --- lib/Fmt_ast.ml | 2 +- .../tests/infix_bind-fit_or_vertical.ml.ref | 15 +++++---------- test/passing/tests/infix_bind.ml | 15 +++++---------- 3 files changed, 11 insertions(+), 21 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index d1e0e37da5..86574b1814 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1925,7 +1925,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens ( ( (fmt_function - ~ctx:(Exp r) ~ctx0:ctx ~box:false ~parens:(parens_r) ~wrap_intro:(fun intro -> + ~ctx:(Exp r) ~ctx0:ctx (*~box:false to fix regression on infix *) ~parens:(parens_r) ~wrap_intro:(fun intro -> ( ( hvbox indent_wrap (fmt_if has_attr (str "(") $ fmt_expression ~indent_wrap c (sub_exp ~ctx l) diff --git a/test/passing/tests/infix_bind-fit_or_vertical.ml.ref b/test/passing/tests/infix_bind-fit_or_vertical.ml.ref index ceb07cb7c3..eefaa93f6c 100644 --- a/test/passing/tests/infix_bind-fit_or_vertical.ml.ref +++ b/test/passing/tests/infix_bind-fit_or_vertical.ml.ref @@ -13,14 +13,12 @@ f x >>= function eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee |> fun x -> x ;; eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee -|> fun xxxxxx xxxxxxxxxx xxxxxxxx xxxxxxxx -> -x +|> fun xxxxxx xxxxxxxxxx xxxxxxxx xxxxxxxx -> x ;; eeeeeeeeeeeee eeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeee eeeeeeeeeeee eeeeeeeeee -|> fun x -> -x +|> fun x -> x ;; eeeeeeeeeeeee eeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeee @@ -32,15 +30,13 @@ xxxxxxxxxxx xxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxx xxxxxxxxxxx eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee |> fun x -> x ;; eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee -|> fun xxxxxx xxxxxxxxxx xxxxxxxx xxxxxxxx -> -x +|> fun xxxxxx xxxxxxxxxx xxxxxxxx xxxxxxxx -> x ;; eeeeeeeeeeeee eeeeeeeeeeeeeeeeee |> fun xxxxxxxxx xxxxxxxxxxxxx -> x ;; eeeeeeeeeeeee eeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeee -|> fun xxxxxxxx xxxxxxxxx xxxxxxxxxxxxx -> -x +|> fun xxxxxxxx xxxxxxxxx xxxxxxxxxxxxx -> x ;; eeeeeeeeeeeee eeeeeeeeeeeeeeeeee |> fun xxxxxxxxxxxxx -> @@ -133,8 +129,7 @@ let end_gen_implementation ?toplevel ~ppf_dump ( clambda ++ Profile.record "cmm" (Cmmgen.compunit ~ppf_dump) ++ Profile.record "compile_phrases" (List.iter (compile_phrase ~ppf_dump)) - ++ fun () -> - () ) ; + ++ fun () -> () ) ; fooooooooooooooo let foo = diff --git a/test/passing/tests/infix_bind.ml b/test/passing/tests/infix_bind.ml index 2a3a31d274..2e01dde50d 100644 --- a/test/passing/tests/infix_bind.ml +++ b/test/passing/tests/infix_bind.ml @@ -13,14 +13,12 @@ f x >>= function eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee |> fun x -> x ;; eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee -|> fun xxxxxx xxxxxxxxxx xxxxxxxx xxxxxxxx -> -x +|> fun xxxxxx xxxxxxxxxx xxxxxxxx xxxxxxxx -> x ;; eeeeeeeeeeeee eeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeee eeeeeeeeeeee eeeeeeeeee -|> fun x -> -x +|> fun x -> x ;; eeeeeeeeeeeee eeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeee @@ -32,15 +30,13 @@ xxxxxxxxxxx xxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxx xxxxxxxxxxx eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee |> fun x -> x ;; eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee -|> fun xxxxxx xxxxxxxxxx xxxxxxxx xxxxxxxx -> -x +|> fun xxxxxx xxxxxxxxxx xxxxxxxx xxxxxxxx -> x ;; eeeeeeeeeeeee eeeeeeeeeeeeeeeeee |> fun xxxxxxxxx xxxxxxxxxxxxx -> x ;; eeeeeeeeeeeee eeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeee -|> fun xxxxxxxx xxxxxxxxx xxxxxxxxxxxxx -> -x +|> fun xxxxxxxx xxxxxxxxx xxxxxxxxxxxxx -> x ;; eeeeeeeeeeeee eeeeeeeeeeeeeeeeee |> fun xxxxxxxxxxxxx -> @@ -128,8 +124,7 @@ let end_gen_implementation ?toplevel ~ppf_dump ( clambda ++ Profile.record "cmm" (Cmmgen.compunit ~ppf_dump) ++ Profile.record "compile_phrases" (List.iter (compile_phrase ~ppf_dump)) - ++ fun () -> - () ) ; + ++ fun () -> () ) ; fooooooooooooooo let foo = From f2eabc44f93b2b548e25bc2b16b408a9943d4eed Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Thu, 23 May 2024 11:21:25 +0200 Subject: [PATCH 050/146] remove useless file --- test.ml | 10 ---------- 1 file changed, 10 deletions(-) delete mode 100644 test.ml diff --git a/test.ml b/test.ml deleted file mode 100644 index 53b1bd9239..0000000000 --- a/test.ml +++ /dev/null @@ -1,10 +0,0 @@ -let _ = - fun (module Store : Irmin.Generic_key.S with type repo = repo) - (module Store : Irmin.Generic_key.S with type repo = repo) - -> body - -let _ = - f - (fun (module Store : Irmin.Generic_key.S with type repo = repo) - (module Store : Irmin.Generic_key.S with type repo = repo) - -> body ) From b2fc016a6cafe39067a6e3372704c256cceed2e2 Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Thu, 23 May 2024 11:38:04 +0200 Subject: [PATCH 051/146] better implementation --- lib/Fmt_ast.ml | 4 ++-- lib/Params.ml | 46 +++++++++++++++++++++++++++------------------- lib/Params.mli | 5 ++--- 3 files changed, 31 insertions(+), 24 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 86574b1814..f70545cc9b 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1483,7 +1483,8 @@ and fmt_function ?force_closing_paren ~ctx ~ctx0 ?(wrap_intro = fun x -> hovbox match args, typ, body with | (_ :: _), _, Pfunction_body body -> (* Only [fun]. *) - fmt_fun_args_typ args typ, fmt_expression c (sub_exp ~ctx body), hovbox (Params.Indent.fun_ c.conf ~ctx0) + fmt_fun_args_typ args typ, fmt_expression c (sub_exp ~ctx body), + (Params.Exp.box_fun_expr c.conf ~ctx0) | [], _, Pfunction_body _ -> assert false | args, typ, Pfunction_cases (cs, _loc, cs_attrs) -> (* [fun _ -> function] or [function]. [spilled_attrs] are extra attrs @@ -1507,7 +1508,6 @@ and fmt_function ?force_closing_paren ~ctx ~ctx0 ?(wrap_intro = fun x -> hovbox else noop, noop in let box k = if should_box then box k else k in - let box = match ctx0 with Str _ -> hvbox_if should_box (Params.Indent.fun_ ~ctx0 c.conf) | _ -> box in box ( wrap_intro (hvbox_if has_cmts_outer 0 diff --git a/lib/Params.ml b/lib/Params.ml index 8773ebd52f..1662710f69 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -26,6 +26,15 @@ let is_labelled_arg args exp = | Labelled _, x | Optional _, x -> phys_equal x exp ) args +let ctx_is_infix = function +| Exp { pexp_desc= Pexp_infix ({txt= ":="; _}, _, _); _ } -> false + | Exp { pexp_desc= Pexp_infix _; _ } -> true + | _ -> false + + let ctx_is_let = function + | Lb _ | Str _ | Exp { pexp_desc= Pexp_let _; _ } | Bo _ -> true + | _ -> false + let parens_if parens (c : Conf.t) ?(disambiguate = false) k = if disambiguate && c.fmt_opts.disambiguate_non_breaking_match.v then wrap_if_fits_or parens "(" ")" k @@ -99,6 +108,23 @@ module Exp = struct in box_decl (kw $ hvbox_if should_box_args 0 args $ fmt_opt annot) + let box_fun_expr (c: Conf.t) ~ctx0 = + let indent = + if ctx_is_infix ctx0 then + 0 + else + match c.fmt_opts.function_indent_nested.v with + | `Always -> c.fmt_opts.function_indent.v + | _ -> + if ctx_is_let ctx0 then + if c.fmt_opts.let_binding_deindent_fun.v then 1 + else 0 + else + 2 in + ( match ctx0 with + | Str _ -> hvbox indent + | _ -> hovbox indent) + (* if the function is the last argument of an apply and no other arguments are "complex" (approximation). *) let function_attrs_sp c ~ctx0 ~ctx = @@ -707,14 +733,7 @@ module Align = struct end module Indent = struct - let ctx_is_infix = function - | Exp { pexp_desc= Pexp_infix ({txt= ":="; _}, _, _); _ } -> false - | Exp { pexp_desc= Pexp_infix _; _ } -> true - | _ -> false - let ctx_is_let = function - | Lb _ | Str _ | Exp { pexp_desc= Pexp_let _; _ } | Bo _ -> true - | _ -> false let function_ ?(default = 0) (c : Conf.t) ~ctx0 ~parens ~has_label = if ctx_is_infix ctx0 then @@ -725,18 +744,7 @@ module Indent = struct | _ when ocp c && parens && not has_label -> default + 1 | _ -> default - let fun_ (c : Conf.t) ~ctx0 = - if ctx_is_infix ctx0 then - 0 - else - match c.fmt_opts.function_indent_nested.v with - | `Always -> c.fmt_opts.function_indent.v - | _ -> - if ctx_is_let ctx0 then - if c.fmt_opts.let_binding_deindent_fun.v then 1 - else 0 - else - 2 + let fun_type_annot c = if ocp c then 2 else 4 diff --git a/lib/Params.mli b/lib/Params.mli index f57ecc7ea1..80c4c79453 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -47,6 +47,8 @@ module Exp : sig (** Box and assemble the parts [kw] (up to the arguments), [args] and [annot]. *) + val box_fun_expr : Conf.t -> ctx0:Ast.t -> Fmt.t -> Fmt.t + val function_attrs_sp : Conf.t -> ctx0:Ast.t -> ctx:Ast.t -> bool (** Whether a space should be added between the [function] keyword and the attributes. *) @@ -201,9 +203,6 @@ module Indent : sig (** Check the [function-indent-nested] option, or return [default] (0 if not provided) if the option does not apply. *) - val fun_ : Conf.t -> ctx0:Ast.t -> int - (** Handle [function-indent-nested]. *) - val fun_args : Conf.t -> int val fun_type_annot : Conf.t -> int From 4ca59f5408368fa0ff6274f077526b978de35000 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Fri, 24 May 2024 10:31:19 +0200 Subject: [PATCH 052/146] Restore indentation of 'fun' after a 'let in' --- lib/Fmt_ast.ml | 2 +- lib/Params.ml | 22 ++++++++++------ lib/Params.mli | 2 +- test/passing/tests/break_cases-align.ml.ref | 20 +++++++------- test/passing/tests/break_cases-all.ml.ref | 20 +++++++------- ...reak_cases-closing_on_separate_line.ml.ref | 24 ++++++++--------- ...ng_on_separate_line_fit_or_vertical.ml.ref | 20 +++++++------- ...te_line_leading_nested_match_parens.ml.ref | 24 ++++++++--------- .../tests/break_cases-cosl_lnmp_cmei.ml.ref | 24 ++++++++--------- .../tests/break_cases-fit_or_vertical.ml.ref | 16 ++++++------ test/passing/tests/break_cases-nested.ml.ref | 10 +++---- .../tests/break_cases-normal_indent.ml.ref | 20 +++++++------- .../passing/tests/break_cases-toplevel.ml.ref | 16 ++++++------ .../passing/tests/break_cases-vertical.ml.ref | 26 +++++++++---------- test/passing/tests/break_cases.ml.ref | 8 +++--- test/passing/tests/js_source.ml.ref | 12 ++++----- 16 files changed, 136 insertions(+), 130 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index f70545cc9b..f4598c7c78 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1484,7 +1484,7 @@ and fmt_function ?force_closing_paren ~ctx ~ctx0 ?(wrap_intro = fun x -> hovbox | (_ :: _), _, Pfunction_body body -> (* Only [fun]. *) fmt_fun_args_typ args typ, fmt_expression c (sub_exp ~ctx body), - (Params.Exp.box_fun_expr c.conf ~ctx0) + (Params.Exp.box_fun_expr c.conf ~ctx0 ~ctx) | [], _, Pfunction_body _ -> assert false | args, typ, Pfunction_cases (cs, _loc, cs_attrs) -> (* [fun _ -> function] or [function]. [spilled_attrs] are extra attrs diff --git a/lib/Params.ml b/lib/Params.ml index 1662710f69..6bca5ec6f9 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -31,9 +31,15 @@ let ctx_is_infix = function | Exp { pexp_desc= Pexp_infix _; _ } -> true | _ -> false - let ctx_is_let = function - | Lb _ | Str _ | Exp { pexp_desc= Pexp_let _; _ } | Bo _ -> true - | _ -> false +(** [ctx_is_let ~ctx ctx0] checks whether [ctx0] is a let binding containing + [ctx]. *) +let ctx_is_let ~ctx = function + | Lb _ | Str _ | Bo _ -> true + | Exp { pexp_desc= Pexp_let (_, rhs, _); _ } -> + (match ctx with + | Exp exp -> not (phys_equal rhs exp) + | _ -> false) + | _ -> false let parens_if parens (c : Conf.t) ?(disambiguate = false) k = if disambiguate && c.fmt_opts.disambiguate_non_breaking_match.v then @@ -108,15 +114,15 @@ module Exp = struct in box_decl (kw $ hvbox_if should_box_args 0 args $ fmt_opt annot) - let box_fun_expr (c: Conf.t) ~ctx0 = + let box_fun_expr (c: Conf.t) ~ctx0 ~ctx = let indent = - if ctx_is_infix ctx0 then - 0 - else + if ctx_is_infix ctx0 then + 0 + else match c.fmt_opts.function_indent_nested.v with | `Always -> c.fmt_opts.function_indent.v | _ -> - if ctx_is_let ctx0 then + if ctx_is_let ~ctx ctx0 then if c.fmt_opts.let_binding_deindent_fun.v then 1 else 0 else diff --git a/lib/Params.mli b/lib/Params.mli index 80c4c79453..44e38c5eca 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -47,7 +47,7 @@ module Exp : sig (** Box and assemble the parts [kw] (up to the arguments), [args] and [annot]. *) - val box_fun_expr : Conf.t -> ctx0:Ast.t -> Fmt.t -> Fmt.t + val box_fun_expr : Conf.t -> ctx0:Ast.t -> ctx:Ast.t -> Fmt.t -> Fmt.t val function_attrs_sp : Conf.t -> ctx0:Ast.t -> ctx:Ast.t -> bool (** Whether a space should be added between the [function] keyword and the diff --git a/test/passing/tests/break_cases-align.ml.ref b/test/passing/tests/break_cases-align.ml.ref index ddf4bdad77..49204efc74 100644 --- a/test/passing/tests/break_cases-align.ml.ref +++ b/test/passing/tests/break_cases-align.ml.ref @@ -18,16 +18,16 @@ let f = 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z - |P - |M -> - match y with - | O -> 5 - | P when h x -> ( - function - | A -> 6 ) + match x with + | E -> 4 + | Z + |P + |M -> + match y with + | O -> 5 + | P when h x -> ( + function + | A -> 6 ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-all.ml.ref b/test/passing/tests/break_cases-all.ml.ref index a79306595c..8fddf03bf5 100644 --- a/test/passing/tests/break_cases-all.ml.ref +++ b/test/passing/tests/break_cases-all.ml.ref @@ -18,16 +18,16 @@ let f = 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z - |P - |M -> ( - match y with - | O -> 5 - | P when h x -> ( - function - | A -> 6 ) ) + match x with + | E -> 4 + | Z + |P + |M -> ( + match y with + | O -> 5 + | P when h x -> ( + function + | A -> 6 ) ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-closing_on_separate_line.ml.ref b/test/passing/tests/break_cases-closing_on_separate_line.ml.ref index e17939d99f..fe8e180d85 100644 --- a/test/passing/tests/break_cases-closing_on_separate_line.ml.ref +++ b/test/passing/tests/break_cases-closing_on_separate_line.ml.ref @@ -18,18 +18,18 @@ let f = 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z - |P - |M -> ( - match y with - | O -> 5 - | P when h x -> ( - function - | A -> 6 - ) - ) + match x with + | E -> 4 + | Z + |P + |M -> ( + match y with + | O -> 5 + | P when h x -> ( + function + | A -> 6 + ) + ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-closing_on_separate_line_fit_or_vertical.ml.ref b/test/passing/tests/break_cases-closing_on_separate_line_fit_or_vertical.ml.ref index 05c9c1c2e5..e89bcf7158 100644 --- a/test/passing/tests/break_cases-closing_on_separate_line_fit_or_vertical.ml.ref +++ b/test/passing/tests/break_cases-closing_on_separate_line_fit_or_vertical.ml.ref @@ -12,16 +12,16 @@ let f = | T | P | U -> 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z | P | M -> ( - match y with - | O -> 5 - | P when h x -> ( - function - | A -> 6 - ) - ) + match x with + | E -> 4 + | Z | P | M -> ( + match y with + | O -> 5 + | P when h x -> ( + function + | A -> 6 + ) + ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-closing_on_separate_line_leading_nested_match_parens.ml.ref b/test/passing/tests/break_cases-closing_on_separate_line_leading_nested_match_parens.ml.ref index 7bbd9230c5..6a5993605b 100644 --- a/test/passing/tests/break_cases-closing_on_separate_line_leading_nested_match_parens.ml.ref +++ b/test/passing/tests/break_cases-closing_on_separate_line_leading_nested_match_parens.ml.ref @@ -18,18 +18,18 @@ let f = 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z - |P - |M -> - ( match y with - | O -> 5 - | P when h x -> - (function - | A -> 6 - ) - ) + match x with + | E -> 4 + | Z + |P + |M -> + ( match y with + | O -> 5 + | P when h x -> + (function + | A -> 6 + ) + ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-cosl_lnmp_cmei.ml.ref b/test/passing/tests/break_cases-cosl_lnmp_cmei.ml.ref index 0151d3bbfc..6b57c38b89 100644 --- a/test/passing/tests/break_cases-cosl_lnmp_cmei.ml.ref +++ b/test/passing/tests/break_cases-cosl_lnmp_cmei.ml.ref @@ -18,18 +18,18 @@ let f = 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z - |P - |M -> - ( match y with - | O -> 5 - | P when h x -> - (function - | A -> 6 - ) - ) + match x with + | E -> 4 + | Z + |P + |M -> + ( match y with + | O -> 5 + | P when h x -> + (function + | A -> 6 + ) + ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-fit_or_vertical.ml.ref b/test/passing/tests/break_cases-fit_or_vertical.ml.ref index 9627c428ab..6f66e70307 100644 --- a/test/passing/tests/break_cases-fit_or_vertical.ml.ref +++ b/test/passing/tests/break_cases-fit_or_vertical.ml.ref @@ -12,14 +12,14 @@ let f = | T | P | U -> 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z | P | M -> ( - match y with - | O -> 5 - | P when h x -> ( - function - | A -> 6 ) ) + match x with + | E -> 4 + | Z | P | M -> ( + match y with + | O -> 5 + | P when h x -> ( + function + | A -> 6 ) ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-nested.ml.ref b/test/passing/tests/break_cases-nested.ml.ref index 200b114b6f..734740ce22 100644 --- a/test/passing/tests/break_cases-nested.ml.ref +++ b/test/passing/tests/break_cases-nested.ml.ref @@ -10,11 +10,11 @@ let f x = function let f = let g = function H when x y <> k -> 2 | T | P | U -> 3 in fun x g t h y u -> - match x with - | E -> - 4 - | Z | P | M -> ( - match y with O -> 5 | P when h x -> ( function A -> 6 ) ) + match x with + | E -> + 4 + | Z | P | M -> ( + match y with O -> 5 | P when h x -> ( function A -> 6 ) ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-normal_indent.ml.ref b/test/passing/tests/break_cases-normal_indent.ml.ref index 5a352b8efb..03e16db911 100644 --- a/test/passing/tests/break_cases-normal_indent.ml.ref +++ b/test/passing/tests/break_cases-normal_indent.ml.ref @@ -18,16 +18,16 @@ let f = 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z - |P - |M -> ( - match y with - | O -> 5 - | P when h x -> ( - function - | A -> 6 ) ) + match x with + | E -> 4 + | Z + |P + |M -> ( + match y with + | O -> 5 + | P when h x -> ( + function + | A -> 6 ) ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-toplevel.ml.ref b/test/passing/tests/break_cases-toplevel.ml.ref index b2f69fbdd8..2e44dab191 100644 --- a/test/passing/tests/break_cases-toplevel.ml.ref +++ b/test/passing/tests/break_cases-toplevel.ml.ref @@ -13,14 +13,14 @@ let f = | T | P | U -> 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z | P | M -> ( - match y with - | O -> 5 - | P when h x -> ( - function - | A -> 6 ) ) + match x with + | E -> 4 + | Z | P | M -> ( + match y with + | O -> 5 + | P when h x -> ( + function + | A -> 6 ) ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-vertical.ml.ref b/test/passing/tests/break_cases-vertical.ml.ref index 4f602dc2f7..6e575cdf3e 100644 --- a/test/passing/tests/break_cases-vertical.ml.ref +++ b/test/passing/tests/break_cases-vertical.ml.ref @@ -19,19 +19,19 @@ let f = 3 in fun x g t h y u -> - match x with - | E -> - 4 - | Z - |P - |M -> ( - match y with - | O -> - 5 - | P when h x -> ( - function - | A -> - 6 ) ) + match x with + | E -> + 4 + | Z + |P + |M -> ( + match y with + | O -> + 5 + | P when h x -> ( + function + | A -> + 6 ) ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases.ml.ref b/test/passing/tests/break_cases.ml.ref index c789ffa692..438f267754 100644 --- a/test/passing/tests/break_cases.ml.ref +++ b/test/passing/tests/break_cases.ml.ref @@ -10,10 +10,10 @@ let f x = function let f = let g = function H when x y <> k -> 2 | T | P | U -> 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z | P | M -> ( - match y with O -> 5 | P when h x -> ( function A -> 6 ) ) + match x with + | E -> 4 + | Z | P | M -> ( + match y with O -> 5 | P when h x -> ( function A -> 6 ) ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index ef374e6c4c..1e8ad2236b 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -3660,8 +3660,8 @@ let map_lambda ~map_rec : _ lambda -> _ = function let next_id = let current = ref 3 in fun () -> - incr current; - !current + incr current; + !current ;; let subst_lambda ~subst_rec ~free ~subst : _ lambda -> _ = function @@ -3872,8 +3872,8 @@ type 'a lambda = let next_id = let current = ref 3 in fun () -> - incr current; - !current + incr current; + !current ;; class ['a] lambda_ops (ops : ('a, 'a) #ops Lazy.t) = @@ -4117,8 +4117,8 @@ type 'a lambda = let next_id = let current = ref 3 in fun () -> - incr current; - !current + incr current; + !current ;; let lambda_ops (ops : ('a, 'a) #ops Lazy.t) = From d1f68dca45a0b0e17c027bdba3441cedb1fd88b7 Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Fri, 24 May 2024 14:14:55 +0200 Subject: [PATCH 053/146] diff on js pattern --- test/passing/tests/js_pattern.ml.ref | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/passing/tests/js_pattern.ml.ref b/test/passing/tests/js_pattern.ml.ref index 2a75f4f5b1..88a0d83be2 100644 --- a/test/passing/tests/js_pattern.ml.ref +++ b/test/passing/tests/js_pattern.ml.ref @@ -9,7 +9,7 @@ let f x = match x with _ -> 0 let f x = match x with _ -> 0 let check_price t = function - | {Exec.trade_at_settlement= None | Some false} -> () + | {Exec.trade_at_settlement= None | Some false} -> () let check_price t = function simpler -> () | other -> () From 173329e836b7f065894e2983342bb1c289ec2f3a Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Fri, 24 May 2024 14:46:30 +0200 Subject: [PATCH 054/146] Remove special implementation of 'function' without 'fun' This brings some regressions: - Disambiguation parentheses in case of one-liner 'function' are gone. - Doesn't format the same way when `~box:false` (eg. rhs of a 'if then') --- lib/Fmt_ast.ml | 29 +++++++++-------------- lib/Params.ml | 4 ---- test/passing/tests/disambiguate.ml | 2 +- test/passing/tests/function_indent.ml.ref | 14 +++++------ test/passing/tests/js_source.ml.err | 12 +++++----- test/passing/tests/js_source.ml.ocp | 23 ++++++++---------- test/passing/tests/js_source.ml.ref | 23 ++++++++---------- test/passing/tests/source.ml.err | 3 ++- test/passing/tests/source.ml.ref | 18 +++++--------- 9 files changed, 53 insertions(+), 75 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index f4598c7c78..97401296c1 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1479,12 +1479,12 @@ and fmt_function ?force_closing_paren ~ctx ~ctx0 ?(wrap_intro = fun x -> hovbox in (* [head] is [fun args ->] or [function]. [body] is an expression or the cases. *) - let head, body, box = + let head, body, box, closing_paren_offset = match args, typ, body with | (_ :: _), _, Pfunction_body body -> (* Only [fun]. *) fmt_fun_args_typ args typ, fmt_expression c (sub_exp ~ctx body), - (Params.Exp.box_fun_expr c.conf ~ctx0 ~ctx) + (Params.Exp.box_fun_expr c.conf ~ctx0 ~ctx), ~-2 | [], _, Pfunction_body _ -> assert false | args, typ, Pfunction_cases (cs, _loc, cs_attrs) -> (* [fun _ -> function] or [function]. [spilled_attrs] are extra attrs @@ -1498,13 +1498,16 @@ and fmt_function ?force_closing_paren ~ctx ~ctx0 ?(wrap_intro = fun x -> hovbox let function_ = let pre = if Params.Exp.function_attrs_sp c.conf ~ctx0 ~ctx then Some Blank else None in str "function" + $ fmt_extension_suffix c ext $ fmt_attributes ?pre c spilled_attrs $ fmt_attributes ?pre c cs_attrs in - (fun_ $ function_, hvbox 0 (fmt_cases c ctx cs), box) + (fun_ $ function_, hvbox 0 (fmt_cases c ctx cs), box, 0) in + (* TODO: Disambiguating parentheses in case of one-liner 'function'. + See 'Params.Exp.wrap c.conf ~parens ~disambiguate:true' *) let opn_paren, cls_paren = - if parens then str "(", closing_paren c ?force:force_closing_paren ~offset:(-2) + if parens then str "(", closing_paren c ?force:force_closing_paren ~offset:closing_paren_offset else noop, noop in let box k = if should_box then box k else k in @@ -2175,20 +2178,10 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens fmt_function ~box ~ctx ~ctx0 ~label:Nolabel ~parens ?ext ~attrs:pexp_attributes ~loc:pexp_loc c (args, typ, body) ) ) - | Pexp_function ([], None, Pfunction_cases (cs, cs_loc, cs_attrs)) -> - let indent = Params.Indent.function_ c.conf ~ctx0 ~parens ~has_label:false in - let outer_pro, inner_pro = if parens then pro, noop else noop, pro in - outer_pro - $ Params.Exp.wrap c.conf ~parens ~disambiguate:true ~fits_breaks:false - @@ Params.Align.function_ c.conf ~parens ~ctx0 ~self:exp - @@ ( Cmts.fmt_before c cs_loc $ hvbox 2 - (inner_pro $ str "function" - $ fmt_extension_suffix c ext - $ fmt_attributes c pexp_attributes - $ fmt_attributes c cs_attrs ) - $ break 1 indent - $ hvbox 0 (fmt_cases c ctx cs) - $ Cmts.fmt_after c cs_loc) + | Pexp_function ([], None, (Pfunction_cases _ as body)) -> + let wrap_intro intro = hovbox 2 (pro $ intro) $ space_break in + fmt_function ~wrap_intro ~box ~ctx ~ctx0 ~label:Nolabel ~parens ?ext + ~attrs:pexp_attributes ~loc:pexp_loc c ([], None, body) | Pexp_function ([], Some _, _) -> assert false | Pexp_ident {txt; loc} -> let outer_parens = has_attr && parens in diff --git a/lib/Params.ml b/lib/Params.ml index 6bca5ec6f9..81df73a6ff 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -739,8 +739,6 @@ module Align = struct end module Indent = struct - - let function_ ?(default = 0) (c : Conf.t) ~ctx0 ~parens ~has_label = if ctx_is_infix ctx0 then if has_label then 2 else 0 @@ -750,8 +748,6 @@ module Indent = struct | _ when ocp c && parens && not has_label -> default + 1 | _ -> default - - let fun_type_annot c = if ocp c then 2 else 4 let fun_args c = if ocp c then 6 else 4 diff --git a/test/passing/tests/disambiguate.ml b/test/passing/tests/disambiguate.ml index f9b90ebe07..2b00176118 100644 --- a/test/passing/tests/disambiguate.ml +++ b/test/passing/tests/disambiguate.ml @@ -7,7 +7,7 @@ let () = fun () -> f () ; g () ; g () ; g () ; g () ; g () ; g () ; g () ; g () ; g () -let () = r := (function () -> f () ; g ()) +let () = r := function () -> f () ; g () let () = r := diff --git a/test/passing/tests/function_indent.ml.ref b/test/passing/tests/function_indent.ml.ref index 9b95488dca..d6f219e6a4 100644 --- a/test/passing/tests/function_indent.ml.ref +++ b/test/passing/tests/function_indent.ml.ref @@ -1,9 +1,9 @@ let foooooooo = function - | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo + | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo let foooooooo = function - | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo - | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo + | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo + | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo let foo = fooooooooo foooooooo ~foooooooo:(function @@ -12,8 +12,8 @@ let foo = let foooooooo = if fooooooooooo then function - | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo - | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo + | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo + | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo else function - | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo - | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo + | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo + | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo diff --git a/test/passing/tests/js_source.ml.err b/test/passing/tests/js_source.ml.err index 819ca83dce..04946533e1 100644 --- a/test/passing/tests/js_source.ml.err +++ b/test/passing/tests/js_source.ml.err @@ -1,7 +1,7 @@ Warning: tests/js_source.ml:161 exceeds the margin -Warning: tests/js_source.ml:2674 exceeds the margin -Warning: tests/js_source.ml:9573 exceeds the margin -Warning: tests/js_source.ml:9677 exceeds the margin -Warning: tests/js_source.ml:9736 exceeds the margin -Warning: tests/js_source.ml:9819 exceeds the margin -Warning: tests/js_source.ml:10325 exceeds the margin +Warning: tests/js_source.ml:2673 exceeds the margin +Warning: tests/js_source.ml:9570 exceeds the margin +Warning: tests/js_source.ml:9674 exceeds the margin +Warning: tests/js_source.ml:9733 exceeds the margin +Warning: tests/js_source.ml:9816 exceeds the margin +Warning: tests/js_source.ml:10322 exceeds the margin diff --git a/test/passing/tests/js_source.ml.ocp b/test/passing/tests/js_source.ml.ocp index 1ec9843768..682e175bc3 100644 --- a/test/passing/tests/js_source.ml.ocp +++ b/test/passing/tests/js_source.ml.ocp @@ -1292,11 +1292,10 @@ let ty_abc = and inj : type c. (int -> string -> noarg -> unit, c) ty_sel * c -> [ `A of int | `B of string | `C ] - = - function - | Thd, v -> `A v - | Ttl Thd, v -> `B v - | Ttl (Ttl Thd), Noarg -> `C + = function + | Thd, v -> `A v + | Ttl Thd, v -> `B v + | Ttl (Ttl Thd), Noarg -> `C in (* Coherence of sum_inj and sum_cases is checked by the typing *) Sum @@ -2680,10 +2679,9 @@ let vexpr (type visit_action) : ('a, 'result, visit_action) context -> 'a -> vis let vexpr (type result) (type visit_action) : (unit, result, visit_action) context -> unit -> visit_action - = - function - | Local -> fun _ -> raise Exit - | Global -> fun _ -> raise Exit + = function + | Local -> fun _ -> raise Exit + | Global -> fun _ -> raise Exit ;; module A = struct @@ -8655,10 +8653,9 @@ type v = let f : type a b c d e f g. a t * b t * c t * d t * e t * f t * g t * v * (a, b, c, d) u * (e, f, g, g) u -> int - = - function - | A, A, A, A, A, A, A, _, U, U -> 1 - | _, _, _, _, _, _, _, G, _, _ -> 1 + = function + | A, A, A, A, A, A, A, _, U, U -> 1 + | _, _, _, _, _, _, _, G, _, _ -> 1 ;; (*| _ -> _ *) diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index 1e8ad2236b..be4391702a 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -1292,8 +1292,7 @@ let ty_abc = and inj : type c. (int -> string -> noarg -> unit, c) ty_sel * c -> [ `A of int | `B of string | `C ] - = - function + = function | Thd, v -> `A v | Ttl Thd, v -> `B v | Ttl (Ttl Thd), Noarg -> `C @@ -1326,8 +1325,8 @@ let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = (Sum { sum_proj = (function - | `Nil -> "Nil", None - | `Cons p -> "Cons", Some (Tdyn (tcons, p))) + | `Nil -> "Nil", None + | `Cons p -> "Cons", Some (Tdyn (tcons, p))) ; sum_cases = [ "Nil", TCnoarg Thd; "Cons", TCarg (Ttl Thd, tcons) ] ; sum_inj = (fun (type c) -> @@ -1363,9 +1362,9 @@ let ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = (* Could also use [get_case] for proj, but direct definition is shorter *) Sum ( (function - | `A n -> "A", Some (Tdyn (Int, n)) - | `B s -> "B", Some (Tdyn (String, s)) - | `C -> "C", None) + | `A n -> "A", Some (Tdyn (Int, n)) + | `B s -> "B", Some (Tdyn (String, s)) + | `C -> "C", None) , function | "A", Some (Tdyn (Int, n)) -> `A n | "B", Some (Tdyn (String, s)) -> `B s @@ -1380,8 +1379,8 @@ let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = Rec (Sum ( (function - | `Nil -> "Nil", None - | `Cons p -> "Cons", Some (Tdyn (targ, p))) + | `Nil -> "Nil", None + | `Cons p -> "Cons", Some (Tdyn (targ, p))) , function | "Nil", None -> `Nil | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p )) @@ -2680,8 +2679,7 @@ let vexpr (type visit_action) : ('a, 'result, visit_action) context -> 'a -> vis let vexpr (type result) (type visit_action) : (unit, result, visit_action) context -> unit -> visit_action - = - function + = function | Local -> fun _ -> raise Exit | Global -> fun _ -> raise Exit ;; @@ -8655,8 +8653,7 @@ type v = let f : type a b c d e f g. a t * b t * c t * d t * e t * f t * g t * v * (a, b, c, d) u * (e, f, g, g) u -> int - = - function + = function | A, A, A, A, A, A, A, _, U, U -> 1 | _, _, _, _, _, _, _, G, _, _ -> 1 ;; diff --git a/test/passing/tests/source.ml.err b/test/passing/tests/source.ml.err index aee4fc6b97..0f415a0b6e 100644 --- a/test/passing/tests/source.ml.err +++ b/test/passing/tests/source.ml.err @@ -1,2 +1,3 @@ Warning: tests/source.ml:703 exceeds the margin -Warning: tests/source.ml:2311 exceeds the margin +Warning: tests/source.ml:1390 exceeds the margin +Warning: tests/source.ml:2309 exceeds the margin diff --git a/test/passing/tests/source.ml.ref b/test/passing/tests/source.ml.ref index 8b7b9710cf..a1971359ef 100644 --- a/test/passing/tests/source.ml.ref +++ b/test/passing/tests/source.ml.ref @@ -1313,8 +1313,7 @@ let ty_abc = (* Define inj in advance to be able to write the type annotation easily *) and inj : type c. (int -> string -> noarg -> unit, c) ty_sel * c - -> [`A of int | `B of string | `C] = - function + -> [`A of int | `B of string | `C] = function | Thd, v -> `A v | Ttl Thd, v -> `B v | Ttl (Ttl Thd), Noarg -> `C in (* Coherence of sum_inj and sum_cases is checked by the typing *) @@ -1389,8 +1388,7 @@ let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = Rec (Sum ( (function - | `Nil -> ("Nil", None) | `Cons p -> ("Cons", Some (Tdyn (targ, p))) - ) + | `Nil -> ("Nil", None) | `Cons p -> ("Cons", Some (Tdyn (targ, p))) ) , function | "Nil", None -> `Nil | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p @@ -2550,18 +2548,15 @@ type ('a, 'result, 'visit_action) context = | Global : ('a, 'a, 'a visit_action) context let vexpr (type visit_action) : - (_, _, visit_action) context -> _ -> visit_action = - function + (_, _, visit_action) context -> _ -> visit_action = function | Local -> fun _ -> raise Exit | Global -> fun _ -> raise Exit let vexpr (type visit_action) : - ('a, 'result, visit_action) context -> 'a -> visit_action = - function + ('a, 'result, visit_action) context -> 'a -> visit_action = function | Local -> fun _ -> raise Exit | Global -> fun _ -> raise Exit let vexpr (type result) (type visit_action) : - (unit, result, visit_action) context -> unit -> visit_action = - function + (unit, result, visit_action) context -> unit -> visit_action = function | Local -> fun _ -> raise Exit | Global -> fun _ -> raise Exit module A = struct @@ -8379,8 +8374,7 @@ let f : type a b c d e f g. * v * (a, b, c, d) u * (e, f, g, g) u - -> int = - function + -> int = function | A, A, A, A, A, A, A, _, U, U -> 1 | _, _, _, _, _, _, _, G, _, _ -> 1 (*| _ -> _ *) From b8a26cb8d7ed365783d57ff51f3e7f04425e0a8e Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Fri, 24 May 2024 14:56:07 +0200 Subject: [PATCH 055/146] Dock 'fun _ -> function' like 'function' This removes a special case and improves ocp-indent-compat in the janestreet profile. --- lib/Fmt_ast.ml | 16 +++---------- test/passing/tests/js_source.ml.err | 12 +++++----- test/passing/tests/js_source.ml.ocp | 36 ++++++++++++++--------------- test/passing/tests/js_source.ml.ref | 6 ++--- test/passing/tests/source.ml.err | 2 +- test/passing/tests/source.ml.ref | 3 +-- 6 files changed, 30 insertions(+), 45 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 97401296c1..5262d353ec 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -2169,20 +2169,10 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens (Params.parens_if parens c.conf ( fmt_expression c (sub_exp ~ctx exp) $ cut_break $ str "." $ fmt_longident_loc c lid $ fmt_atrs ) ) - | Pexp_function (args, typ, (Pfunction_body _ as body)) - | Pexp_function ((_ :: _ as args), typ, body) -> - pro - $ - ( - ( - fmt_function ~box ~ctx ~ctx0 - ~label:Nolabel ~parens ?ext ~attrs:pexp_attributes ~loc:pexp_loc c (args, typ, body) - ) ) - | Pexp_function ([], None, (Pfunction_cases _ as body)) -> + | Pexp_function (args, typ, body) -> let wrap_intro intro = hovbox 2 (pro $ intro) $ space_break in - fmt_function ~wrap_intro ~box ~ctx ~ctx0 ~label:Nolabel ~parens ?ext - ~attrs:pexp_attributes ~loc:pexp_loc c ([], None, body) - | Pexp_function ([], Some _, _) -> assert false + fmt_function ~wrap_intro ~box ~ctx ~ctx0 + ~label:Nolabel ~parens ?ext ~attrs:pexp_attributes ~loc:pexp_loc c (args, typ, body) | Pexp_ident {txt; loc} -> let outer_parens = has_attr && parens in pro diff --git a/test/passing/tests/js_source.ml.err b/test/passing/tests/js_source.ml.err index 04946533e1..56eda390f0 100644 --- a/test/passing/tests/js_source.ml.err +++ b/test/passing/tests/js_source.ml.err @@ -1,7 +1,7 @@ Warning: tests/js_source.ml:161 exceeds the margin -Warning: tests/js_source.ml:2673 exceeds the margin -Warning: tests/js_source.ml:9570 exceeds the margin -Warning: tests/js_source.ml:9674 exceeds the margin -Warning: tests/js_source.ml:9733 exceeds the margin -Warning: tests/js_source.ml:9816 exceeds the margin -Warning: tests/js_source.ml:10322 exceeds the margin +Warning: tests/js_source.ml:2671 exceeds the margin +Warning: tests/js_source.ml:9568 exceeds the margin +Warning: tests/js_source.ml:9672 exceeds the margin +Warning: tests/js_source.ml:9731 exceeds the margin +Warning: tests/js_source.ml:9814 exceeds the margin +Warning: tests/js_source.ml:10320 exceeds the margin diff --git a/test/passing/tests/js_source.ml.ocp b/test/passing/tests/js_source.ml.ocp index 682e175bc3..0fe707c5d2 100644 --- a/test/passing/tests/js_source.ml.ocp +++ b/test/passing/tests/js_source.ml.ocp @@ -2018,16 +2018,15 @@ let rec rep_equal : type a b. a rep -> b rep -> (a, b) equal option = type assoc = Assoc : string * 'a rep * 'a -> assoc -let rec assoc : type a. string -> a rep -> assoc list -> a = - fun x r -> function - | [] -> raise Not_found - | Assoc (x', r', v) :: env -> - if x = x' - then ( - match rep_equal r r' with - | None -> failwith ("Wrong type for " ^ x) - | Some Eq -> v) - else assoc x r env +let rec assoc : type a. string -> a rep -> assoc list -> a = fun x r -> function + | [] -> raise Not_found + | Assoc (x', r', v) :: env -> + if x = x' + then ( + match rep_equal r r' with + | None -> failwith ("Wrong type for " ^ x) + | Some Eq -> v) + else assoc x r env ;; type _ term = @@ -2039,15 +2038,14 @@ type _ term = | Ap : ('a -> 'b) term * 'a term -> 'b term | Pair : 'a term * 'b term -> ('a * 'b) term -let rec eval_term : type a. assoc list -> a term -> a = - fun env -> function - | Var (x, r) -> assoc x r env - | Abs (x, r, e) -> fun v -> eval_term (Assoc (x, r, v) :: env) e - | Const x -> x - | Add -> fun (x, y) -> x + y - | LT -> fun (x, y) -> x < y - | Ap (f, x) -> eval_term env f (eval_term env x) - | Pair (x, y) -> eval_term env x, eval_term env y +let rec eval_term : type a. assoc list -> a term -> a = fun env -> function + | Var (x, r) -> assoc x r env + | Abs (x, r, e) -> fun v -> eval_term (Assoc (x, r, v) :: env) e + | Const x -> x + | Add -> fun (x, y) -> x + y + | LT -> fun (x, y) -> x < y + | Ap (f, x) -> eval_term env f (eval_term env x) + | Pair (x, y) -> eval_term env x, eval_term env y ;; let ex3 = Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint)))) diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index be4391702a..1552186583 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -2018,8 +2018,7 @@ let rec rep_equal : type a b. a rep -> b rep -> (a, b) equal option = type assoc = Assoc : string * 'a rep * 'a -> assoc -let rec assoc : type a. string -> a rep -> assoc list -> a = - fun x r -> function +let rec assoc : type a. string -> a rep -> assoc list -> a = fun x r -> function | [] -> raise Not_found | Assoc (x', r', v) :: env -> if x = x' @@ -2039,8 +2038,7 @@ type _ term = | Ap : ('a -> 'b) term * 'a term -> 'b term | Pair : 'a term * 'b term -> ('a * 'b) term -let rec eval_term : type a. assoc list -> a term -> a = - fun env -> function +let rec eval_term : type a. assoc list -> a term -> a = fun env -> function | Var (x, r) -> assoc x r env | Abs (x, r, e) -> fun v -> eval_term (Assoc (x, r, v) :: env) e | Const x -> x diff --git a/test/passing/tests/source.ml.err b/test/passing/tests/source.ml.err index 0f415a0b6e..8e1cc7a17b 100644 --- a/test/passing/tests/source.ml.err +++ b/test/passing/tests/source.ml.err @@ -1,3 +1,3 @@ Warning: tests/source.ml:703 exceeds the margin Warning: tests/source.ml:1390 exceeds the margin -Warning: tests/source.ml:2309 exceeds the margin +Warning: tests/source.ml:2308 exceeds the margin diff --git a/test/passing/tests/source.ml.ref b/test/passing/tests/source.ml.ref index a1971359ef..c55e247c99 100644 --- a/test/passing/tests/source.ml.ref +++ b/test/passing/tests/source.ml.ref @@ -1984,8 +1984,7 @@ type _ term = | Ap : ('a -> 'b) term * 'a term -> 'b term | Pair : 'a term * 'b term -> ('a * 'b) term -let rec eval_term : type a. assoc list -> a term -> a = - fun env -> function +let rec eval_term : type a. assoc list -> a term -> a = fun env -> function | Var (x, r) -> assoc x r env | Abs (x, r, e) -> fun v -> eval_term (Assoc (x, r, v) :: env) e | Const x -> x From e2887d5ccedeb5dbca15e8bad0d5f979378cc3c1 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Fri, 24 May 2024 15:30:58 +0200 Subject: [PATCH 056/146] Names for the new boxes --- lib/Params.ml | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/lib/Params.ml b/lib/Params.ml index 81df73a6ff..59eefd43d5 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -106,10 +106,11 @@ module Exp = struct Ast.Str _ -> (* special case than aligns the arguments of [let _ = fun ...] *) true | _ -> false in + let name = "Params.box_fun_decl_args" in let box_decl, should_box_args = - if ocp c then (hvbox (if parens then 1 else 2), false) + if ocp c then (hvbox ~name (if parens then 1 else 2), false) else - ( (if is_let_func then hovbox 4 else hvbox (if parens then 1 else 2)) + ( (if is_let_func then hovbox ~name 4 else hvbox ~name (if parens then 1 else 2)) , not c.fmt_opts.wrap_fun_args.v ) in box_decl (kw $ hvbox_if should_box_args 0 args $ fmt_opt annot) @@ -127,9 +128,10 @@ module Exp = struct else 0 else 2 in + let name = "Params.box_fun_expr" in ( match ctx0 with - | Str _ -> hvbox indent - | _ -> hovbox indent) + | Str _ -> hvbox ~name indent + | _ -> hovbox ~name indent) (* if the function is the last argument of an apply and no other arguments are "complex" (approximation). *) From 0e10ae11d23839403f5df17ecda6a5bdbff130cc Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Fri, 24 May 2024 15:50:00 +0200 Subject: [PATCH 057/146] Fix indentation of '(* cmt *) fun _ ->' --- lib/Fmt_ast.ml | 10 +++++++++- test/passing/tests/fun_decl.ml | 13 +++++++++++++ 2 files changed, 22 insertions(+), 1 deletion(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 5262d353ec..e09e96f819 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1796,7 +1796,15 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens update_config_maybe_disabled c pexp_loc pexp_attributes @@ fun c -> Cmts.relocate_wrongfully_attached_cmts c.cmts c.source exp ; - let pro = pro $ Cmts.fmt_before c ?eol pexp_loc in + let pro = + (* Some expressions format the 'pro' and comments differently. *) + let cmts_in_pro = + match exp.pexp_desc with + | Pexp_function _ -> noop + | _ -> Cmts.fmt_before c ?eol pexp_loc + in + pro $ cmts_in_pro + in let fmt_cmts_after k = k $ Cmts.fmt_after c pexp_loc in let fmt_atrs = fmt_attributes c ~pre:Space pexp_attributes in let has_attr = not (List.is_empty pexp_attributes) in diff --git a/test/passing/tests/fun_decl.ml b/test/passing/tests/fun_decl.ml index cb5db0fcf5..6b1ede0aa8 100644 --- a/test/passing/tests/fun_decl.ml +++ b/test/passing/tests/fun_decl.ml @@ -70,3 +70,16 @@ let f ssssssssss = | '0' -> g accuuuuuuuuuum | '1' -> h accuuuuuuuuuum | _ -> i accuuuuuuuuuum ) + +let f _ = + let foooooooooooooooooooooooooooo = foooooooooooooooooooooooooooo in + fun x -> + let foooooooooooooooooooooooooooo = foooooooooooooooooooooooooooo in + x + +let f _ = + let foooooooooooooooooooooooooooo = foooooooooooooooooooooooooooo in + (* foo *) + fun x -> + let foooooooooooooooooooooooooooo = foooooooooooooooooooooooooooo in + x From 46b16b1cdab1d983ea8197e3124fb950cab070a8 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 27 May 2024 14:42:12 +0200 Subject: [PATCH 058/146] Revert change to test/passing/tests/args_grouped.ml --- test/passing/tests/args_grouped.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/test/passing/tests/args_grouped.ml b/test/passing/tests/args_grouped.ml index da619cb917..557710a46a 100644 --- a/test/passing/tests/args_grouped.ml +++ b/test/passing/tests/args_grouped.ml @@ -81,13 +81,13 @@ let f = let eradicate_meta_class_is_nullsafe = register ~id:"ERADICATE_META_CLASS_IS_NULLSAFE" - ~hum: - "Class is marked @Nullsafe and has 0 issues" (* Should be enabled for special integrations *) + ~hum:"Class is marked @Nullsafe and has 0 issues" + (* Should be enabled for special integrations *) ~enabled:false Info Eradicate (* TODO *) ~user_documentation:"" let eradicate_meta_class_is_nullsafe = register ~id:"ERADICATE_META_CLASS_IS_NULLSAFE" (* Should be enabled for special integrations *) - ~hum: - "Class is marked @Nullsafe and has 0 issues" (* Should be enabled for special integrations *) + ~hum:"Class is marked @Nullsafe and has 0 issues" + (* Should be enabled for special integrations *) ~enabled:false Info From b24f9d8a5e0e298d3581760e3d5fb40ddba35f81 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 27 May 2024 17:55:58 +0200 Subject: [PATCH 059/146] Box debug not showing break_unless_newline and fits_or_breaks Format the box_debug output as length 0 with pp_print_as and remove the indentation in the output HTML. This was interfering with many instances of break_unless_newline and fits_or_breaks and caused hair loss during previous debugging sessions. --- lib/box_debug.ml | 91 +++++++++++++++++++++++------------------------- 1 file changed, 44 insertions(+), 47 deletions(-) diff --git a/lib/box_debug.ml b/lib/box_debug.ml index f76d968183..26dfdfb420 100644 --- a/lib/box_debug.ml +++ b/lib/box_debug.ml @@ -60,10 +60,16 @@ let css = let debug = ref false +let fprintf_as_0 fs fmt = Format_.kasprintf (Format_.pp_print_as fs 0) fmt + +let debugf fs fmt = + (* Print the debug as length 0 to not disturb complex breaks. *) + if !debug then fprintf_as_0 fs fmt else Format_.ifprintf fs fmt + let with_box k fs = let g = !debug in debug := true ; - fprintf fs + fprintf_as_0 fs {| @@ -72,39 +78,34 @@ let with_box k fs = - %t +|} + css ; + k fs ; + fprintf_as_0 fs {| -|} - css k ; +|} ; debug := g +let pp_box_name fs = function + | Some n -> Format_.fprintf fs ":%s" n + | None -> () + +let pp_box_indent fs = function 0 -> () | i -> Format_.fprintf fs "(%d)" i + let box_open ?name box_kind n fs = - if !debug then ( - let name = - match name with - | Some s -> sprintf "%s:%s" box_kind s - | None -> box_kind - in - let name = if n = 0 then name else sprintf "%s(%d)" name n in - open_vbox 0 ; - fprintf fs "
" ; - pp_print_break fs 1 2 ; - fprintf fs "

%s

" name ; - pp_print_break fs 1 2 ) - -let box_close fs = - if !debug then ( - pp_close_box fs () ; pp_print_break fs 0 0 ; fprintf fs "
" ) + debugf fs "

%s%a%a

" box_kind + pp_box_name name pp_box_indent n + +let box_close fs = debugf fs "
" let break fs n o = - if !debug then - fprintf fs - "
(%i,%i)break %i \ - %i
" - n o n o + debugf fs + "
(%i,%i)break %i \ + %i
" + n o n o -let pp_keyword fs s = fprintf fs "%s" s +let pp_keyword fs s = fprintf_as_0 fs "%s" s let _pp_format_lit fs = let open CamlinternalFormatBasics in @@ -145,30 +146,26 @@ let fmt fs f = else false let cbreak fs ~fits:(s1, i, s2) ~breaks:(s3, j, s4) = - if !debug then - fprintf fs - "
(%s,%i,%s) (%s,%i,%s)cbreak ~fits:(%S, %i, %S) ~breaks:(%S, %i, \ - %S)
" - s1 i s2 s3 j s4 s1 i s2 s3 j s4 + debugf fs + "
(%s,%i,%s) (%s,%i,%s)cbreak ~fits:(%S, %i, %S) ~breaks:(%S, %i, \ + %S)
" + s1 i s2 s3 j s4 s1 i s2 s3 j s4 let if_newline fs s = - if !debug then - fprintf fs - "
(%s)if_newline %S
" - s s + debugf fs + "
(%s)if_newline %S
" + s s let break_unless_newline fs n o = - if !debug then - fprintf fs - "
(%i,%i)break_unless_newline %i %i
" - n o n o + debugf fs + "
(%i,%i)break_unless_newline %i %i
" + n o n o let fits_or_breaks fs fits n o breaks = - if !debug then - fprintf fs - "
(%s,%i,%i,%s)fits_or_breaks %S %i %i %S
" - fits n o breaks fits n o breaks + debugf fs + "
(%s,%i,%i,%s)fits_or_breaks %S %i %i %S
" + fits n o breaks fits n o breaks From 7c525f7e1490d94965e9f2d0f950833c4f0308a0 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Tue, 28 May 2024 15:19:22 +0200 Subject: [PATCH 060/146] Fix break-colon=before regression This might also contain a bug fix compared to master. --- lib/Fmt_ast.ml | 23 +++++++++---------- test/passing/tests/break_colon-before.ml.ref | 8 +++---- test/passing/tests/js_source.ml.err | 12 +++++----- test/passing/tests/js_source.ml.ocp | 5 ++-- test/passing/tests/js_source.ml.ref | 5 ++-- test/passing/tests/ocp_indent_compat.ml | 8 +++---- .../passing/tests/polytypes-janestreet.ml.ref | 10 ++++---- test/rpc/rpc_test.expected | 2 +- 8 files changed, 35 insertions(+), 38 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index e09e96f819..83221e36f6 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -747,19 +747,18 @@ and fmt_record_field c ?typ1 ?typ2 ?rhs lid1 = and fmt_type_cstr c ?(pro=":") ?constraint_ctx xtyp = let colon_before = Poly.(c.conf.fmt_opts.break_colon.v = `Before) in - let wrap, inner_pro, box = - if colon_before then - let wrap x = - fits_breaks " " ~hint:(1000, 0) "" $ cbox 0 (str pro $ str " " $ x) - in + let wrap, inner_pro, box = + match xtyp.ast.ptyp_desc with + | (Ptyp_poly (_, { ptyp_desc= Ptyp_arrow _; _ }) + | Ptyp_arrow _) when colon_before -> + let outer_pro = fits_breaks (pro ^ " ") (pro ^ " ") in + let pre_break = if colon_before then fits_breaks " " ~hint:(1000, 0) "" else break 0 ~-1 in + let wrap x = pre_break $ cbox 0 (outer_pro $ x) in wrap, None, false - else - let wrap x = - break 0 ~-1 $ x - in - wrap, Some pro, true - in - wrap (fmt_core_type c ?pro:inner_pro ?constraint_ctx ~box xtyp) + | _ -> + (fun k -> break 0 ~-1 $ k), Some pro, true + in + wrap (fmt_core_type c ?pro:inner_pro ?constraint_ctx ~box xtyp) and fmt_type_pcstr c ~ctx ?constraint_ctx cstr = let fmt_typ ~pro t = fmt_type_cstr c ~pro ?constraint_ctx (sub_typ ~ctx t) in diff --git a/test/passing/tests/break_colon-before.ml.ref b/test/passing/tests/break_colon-before.ml.ref index 1568b091ad..73278765a3 100644 --- a/test/passing/tests/break_colon-before.ml.ref +++ b/test/passing/tests/break_colon-before.ml.ref @@ -70,10 +70,10 @@ let ssmap () let ssmap - : (module MapT - with type key = string - and type data = string - and type map = SSMap.map ) + : (module MapT + with type key = string + and type data = string + and type map = SSMap.map ) -> unit = () diff --git a/test/passing/tests/js_source.ml.err b/test/passing/tests/js_source.ml.err index 56eda390f0..21d457b07f 100644 --- a/test/passing/tests/js_source.ml.err +++ b/test/passing/tests/js_source.ml.err @@ -1,7 +1,7 @@ Warning: tests/js_source.ml:161 exceeds the margin -Warning: tests/js_source.ml:2671 exceeds the margin -Warning: tests/js_source.ml:9568 exceeds the margin -Warning: tests/js_source.ml:9672 exceeds the margin -Warning: tests/js_source.ml:9731 exceeds the margin -Warning: tests/js_source.ml:9814 exceeds the margin -Warning: tests/js_source.ml:10320 exceeds the margin +Warning: tests/js_source.ml:2670 exceeds the margin +Warning: tests/js_source.ml:9567 exceeds the margin +Warning: tests/js_source.ml:9671 exceeds the margin +Warning: tests/js_source.ml:9730 exceeds the margin +Warning: tests/js_source.ml:9813 exceeds the margin +Warning: tests/js_source.ml:10319 exceeds the margin diff --git a/test/passing/tests/js_source.ml.ocp b/test/passing/tests/js_source.ml.ocp index 0fe707c5d2..1271423b4a 100644 --- a/test/passing/tests/js_source.ml.ocp +++ b/test/passing/tests/js_source.ml.ocp @@ -2430,8 +2430,7 @@ let eval (type c) (bop : (a, b, c) binop) (x : a constant) - (y : b constant) - : c constant + (y : b constant) : c constant = match bop, x, y with | Eq, Bool x, Bool y -> Bool (if x then y else not y) @@ -9587,7 +9586,7 @@ let ssmap ;; let ssmap - : (module MapT with type key = string and type data = string and type map = SSMap.map) + : (module MapT with type key = string and type data = string and type map = SSMap.map) -> unit = () diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index 1552186583..1fbc8eb06c 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -2430,8 +2430,7 @@ let eval (type c) (bop : (a, b, c) binop) (x : a constant) - (y : b constant) - : c constant + (y : b constant) : c constant = match bop, x, y with | Eq, Bool x, Bool y -> Bool (if x then y else not y) @@ -9587,7 +9586,7 @@ let ssmap ;; let ssmap - : (module MapT with type key = string and type data = string and type map = SSMap.map) + : (module MapT with type key = string and type data = string and type map = SSMap.map) -> unit = () diff --git a/test/passing/tests/ocp_indent_compat.ml b/test/passing/tests/ocp_indent_compat.ml index b95a6fcc11..d29c4d0524 100644 --- a/test/passing/tests/ocp_indent_compat.ml +++ b/test/passing/tests/ocp_indent_compat.ml @@ -73,10 +73,10 @@ let ssmap () let ssmap - : (module MapT - with type key = string - and type data = string - and type map = SSMap.map ) + : (module MapT + with type key = string + and type data = string + and type map = SSMap.map ) -> unit = () diff --git a/test/passing/tests/polytypes-janestreet.ml.ref b/test/passing/tests/polytypes-janestreet.ml.ref index a35e53e6b5..4e0a802758 100644 --- a/test/passing/tests/polytypes-janestreet.ml.ref +++ b/test/passing/tests/polytypes-janestreet.ml.ref @@ -1,14 +1,14 @@ let t1 : 'a 'b. 'a t -> b t = () let t2 - : 'a 'b. + : 'a 'b. 'a t________________________________ -> 'b t_______________________________________ = () ;; let t3 - : 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that 'must 'wrap. + : 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that 'must 'wrap. 'a t_________________________________________________ -> 'b t______________________________________________________________ -> 'c t______________________________________________________________ @@ -18,9 +18,9 @@ let t3 let t4 : 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that 'must 'wrap. - 'a t_________________________________________________ - * 'b t______________________________________________________________ - * 'c t______________________________________________________________ + 'a t_________________________________________________ + * 'b t______________________________________________________________ + * 'c t______________________________________________________________ = () ;; diff --git a/test/rpc/rpc_test.expected b/test/rpc/rpc_test.expected index f528f7e0aa..cc1322656b 100644 --- a/test/rpc/rpc_test.expected +++ b/test/rpc/rpc_test.expected @@ -96,7 +96,7 @@ let ssmap ' Output: let ssmap - : (module MapT with type key = string and type data = string and type map = SSMap.map) + : (module MapT with type key = string and type data = string and type map = SSMap.map) -> unit = () From 371ec86c55af5e3307b1d0a2020e3259645c172c Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Tue, 28 May 2024 17:26:29 +0200 Subject: [PATCH 061/146] WIP : fix issue 289 This is in a weird state, it has some useful effect but not everything was checked, and it does introduce new diffs --- lib/Fmt_ast.ml | 21 +- lib/Params.ml | 38 ++- lib/Params.mli | 2 +- test.ml | 11 + test/passing/tests/apply.ml | 2 +- test/passing/tests/attributes.ml | 13 +- test/passing/tests/break_cases-align.ml.ref | 22 +- test/passing/tests/break_cases-all.ml.ref | 22 +- ...reak_cases-closing_on_separate_line.ml.ref | 30 +- ...ng_on_separate_line_fit_or_vertical.ml.ref | 26 +- ...te_line_leading_nested_match_parens.ml.ref | 32 +- .../tests/break_cases-cosl_lnmp_cmei.ml.ref | 32 +- .../tests/break_cases-fit_or_vertical.ml.ref | 18 +- test/passing/tests/break_cases-nested.ml.ref | 10 +- .../tests/break_cases-normal_indent.ml.ref | 22 +- .../passing/tests/break_cases-toplevel.ml.ref | 18 +- .../passing/tests/break_cases-vertical.ml.ref | 30 +- test/passing/tests/break_cases.ml.ref | 8 +- test/passing/tests/disambiguate.ml | 6 +- test/passing/tests/eliom_ext.eliom | 2 +- test/passing/tests/exp_grouping.ml.ref | 10 +- test/passing/tests/fun_decl.ml | 46 +-- test/passing/tests/fun_function.ml | 4 +- .../tests/function_indent-never.ml.ref | 3 +- test/passing/tests/function_indent.ml.ref | 3 +- .../indicate_multiline_delimiters-cosl.ml.ref | 6 +- ...indicate_multiline_delimiters-space.ml.ref | 2 +- .../tests/indicate_multiline_delimiters.ml | 2 +- test/passing/tests/issue1750.ml | 83 +++-- test/passing/tests/issue1750.ml.err | 27 ++ test/passing/tests/issue289.ml | 24 +- test/passing/tests/issue289.ml.err | 2 +- test/passing/tests/ite-compact_closing.ml.ref | 6 +- .../tests/ite-fit_or_vertical_closing.ml.ref | 6 +- test/passing/tests/ite-kr_closing.ml.ref | 6 +- test/passing/tests/ite-kw_first.ml.ref | 4 +- .../passing/tests/ite-kw_first_closing.ml.ref | 10 +- .../tests/ite-kw_first_no_indicate.ml.ref | 4 +- test/passing/tests/ite-vertical.ml.ref | 4 +- test/passing/tests/js_pattern.ml.ref | 2 +- test/passing/tests/js_source.ml.ref | 68 ++-- test/passing/tests/max_indent.ml | 21 +- test/passing/tests/object.ml.ref | 8 +- test/passing/tests/skip.ml | 16 +- test/passing/tests/source.ml.err | 4 +- test/passing/tests/source.ml.ref | 313 ++++++++++-------- 46 files changed, 584 insertions(+), 465 deletions(-) create mode 100644 test.ml diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 83221e36f6..fae2337cb6 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1444,7 +1444,7 @@ and fmt_indexop_access c ctx ~fmt_atrs ~has_attr ~parens x = (** Format a [Pexp_function]. [wrap_intro] wraps up to after the [->] and is responsible for breaking. *) -and fmt_function ?force_closing_paren ~ctx ~ctx0 ?(wrap_intro = fun x -> hovbox 2 x $ space_break) ?box:(should_box = true) +and fmt_function ?force_closing_paren ~ctx ~ctx0 ~wrap_intro ?box:(should_box = true) ~label ?(parens = false) ?ext ~attrs ~loc c (args, typ, body) = let has_label = match label with Nolabel -> false | _ -> true in (* Make sure the comment is placed after the eventual label but not into @@ -1483,7 +1483,7 @@ and fmt_function ?force_closing_paren ~ctx ~ctx0 ?(wrap_intro = fun x -> hovbox | (_ :: _), _, Pfunction_body body -> (* Only [fun]. *) fmt_fun_args_typ args typ, fmt_expression c (sub_exp ~ctx body), - (Params.Exp.box_fun_expr c.conf ~ctx0 ~ctx), ~-2 + (Params.Exp.box_fun_expr c.conf ~ctx0 ~ctx ~parens ~has_label), ~-2 | [], _, Pfunction_body _ -> assert false | args, typ, Pfunction_cases (cs, _loc, cs_attrs) -> (* [fun _ -> function] or [function]. [spilled_attrs] are extra attrs @@ -1492,7 +1492,11 @@ and fmt_function ?force_closing_paren ~ctx ~ctx0 ?(wrap_intro = fun x -> hovbox match args, typ with | [], None -> noop, attrs, hvbox (Params.Indent.function_ c.conf ~ctx0 ~parens ~has_label) | [], Some _ -> assert false - | args, typ -> fmt_fun_args_typ args typ $ space_break, [], hvbox (Params.Indent.docked_function_after_fun c.conf ~ctx0 ~parens ~has_label) + | args, typ -> + ( fmt_fun_args_typ args typ $ space_break, + [], + hvbox (Params.Indent.docked_function_after_fun c.conf ~ctx0 ~parens ~has_label) + ) in let function_ = let pre = if Params.Exp.function_attrs_sp c.conf ~ctx0 ~ctx then Some Blank else None in @@ -1501,7 +1505,7 @@ and fmt_function ?force_closing_paren ~ctx ~ctx0 ?(wrap_intro = fun x -> hovbox $ fmt_attributes ?pre c spilled_attrs $ fmt_attributes ?pre c cs_attrs in - (fun_ $ function_, hvbox 0 (fmt_cases c ctx cs), box, 0) + (fun_ $ function_, (fmt_cases c ctx cs), box, 0) in (* TODO: Disambiguating parentheses in case of one-liner 'function'. See 'Params.Exp.wrap c.conf ~parens ~disambiguate:true' *) @@ -1550,7 +1554,8 @@ and fmt_label_arg ?(box = true) ?eol c (lbl, ({ast= arg; _} as xarg)) = ~box xarg ) $ cmts_after ) | (Labelled _ | Optional _), Pexp_function (args, typ, body) -> - fmt_function ~ctx:(Exp arg) ~ctx0:xarg.ctx ~label:lbl ~parens:true ~attrs:arg.pexp_attributes ~loc:arg.pexp_loc c (args, typ, body) + let wrap_intro x = hovbox 2 x $ space_break in + fmt_function ~ctx:(Exp arg) ~wrap_intro ~ctx0:xarg.ctx ~label:lbl ~parens:true ~attrs:arg.pexp_attributes ~loc:arg.pexp_loc c (args, typ, body) | _ -> let label_sep : t = if box || c.conf.fmt_opts.wrap_fun_args.v then str ":" $ cut_break @@ -2042,15 +2047,15 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens wrap ( intro_epi $ fmt_args_grouped e0 args_before - $ space_break $ hvbox 0 x ) - $ break 1 2 + $ break 1 0 $ hvbox 0 x ) + $ break 1 0 in let force_closing_paren = if Location.is_single_line pexp_loc c.conf.fmt_opts.margin.v then Fit else Break in - fmt_function ~force_closing_paren ~ctx:inner_ctx ~ctx0:ctx ~wrap_intro ~label:lbl ~parens:true ~attrs:last_arg.pexp_attributes ~loc:last_arg.pexp_loc c (largs, ltyp, lbody) + fmt_function~force_closing_paren ~ctx:inner_ctx ~ctx0:ctx ~wrap_intro ~label:lbl ~parens:true ~attrs:last_arg.pexp_attributes ~loc:last_arg.pexp_loc c (largs, ltyp, lbody) in hvbox_if has_attr 0 (expr_epi $ Params.parens_if parens c.conf (args $ fmt_atrs)) diff --git a/lib/Params.ml b/lib/Params.ml index 59eefd43d5..9e14043678 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -31,6 +31,10 @@ let ctx_is_infix = function | Exp { pexp_desc= Pexp_infix _; _ } -> true | _ -> false +let ctx_is_apply = function + | Exp { pexp_desc= Pexp_apply _; _ } -> true + | _ -> false + (** [ctx_is_let ~ctx ctx0] checks whether [ctx0] is a let binding containing [ctx]. *) let ctx_is_let ~ctx = function @@ -115,10 +119,11 @@ module Exp = struct in box_decl (kw $ hvbox_if should_box_args 0 args $ fmt_opt annot) - let box_fun_expr (c: Conf.t) ~ctx0 ~ctx = + let box_fun_expr (c: Conf.t) ~ctx0 ~ctx ~parens:_ ~has_label = let indent = - if ctx_is_infix ctx0 then - 0 + if ctx_is_infix ctx0 then ( + if ocp c && has_label then 2 + else 0 ) else match c.fmt_opts.function_indent_nested.v with | `Always -> c.fmt_opts.function_indent.v @@ -126,8 +131,10 @@ module Exp = struct if ctx_is_let ~ctx ctx0 then if c.fmt_opts.let_binding_deindent_fun.v then 1 else 0 + else if ocp c && ctx_is_apply ctx0 && not has_label then 4 + else if ocp c then 2 else - 2 in + 4 in let name = "Params.box_fun_expr" in ( match ctx0 with | Str _ -> hvbox ~name indent @@ -742,13 +749,20 @@ end module Indent = struct let function_ ?(default = 0) (c : Conf.t) ~ctx0 ~parens ~has_label = + let r= if ctx_is_infix ctx0 then if has_label then 2 else 0 else + let extra = (if c.fmt_opts.wrap_fun_args.v then 2 else match ctx0 with Str _ -> 2 | _ -> 4) in match c.fmt_opts.function_indent_nested.v with - | `Always -> c.fmt_opts.function_indent.v - | _ when ocp c && parens && not has_label -> default + 1 - | _ -> default + | `Always -> c.fmt_opts.function_indent.v + extra + | _ when ocp c && ctx_is_apply ctx0 && not has_label -> default + 3 + | _ when ocp c && parens && not has_label -> default + 1 + | _ when ocp c -> default + | _ -> + default + extra in + r + let fun_type_annot c = if ocp c then 2 else 4 @@ -756,8 +770,14 @@ module Indent = struct let docked_function_after_fun (c : Conf.t) ~ctx0 ~parens ~has_label = if ctx_is_infix ctx0 then - 0 else - if ocp c then if parens && not has_label then 3 else 2 else 0 + 0 + else + 2 + + if ocp c then + if parens && not has_label then + 3 + else 2 + else 2 let fun_args_group (c : Conf.t) ~lbl exp = if not (ocp c) then 2 diff --git a/lib/Params.mli b/lib/Params.mli index 44e38c5eca..714af16aca 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -47,7 +47,7 @@ module Exp : sig (** Box and assemble the parts [kw] (up to the arguments), [args] and [annot]. *) - val box_fun_expr : Conf.t -> ctx0:Ast.t -> ctx:Ast.t -> Fmt.t -> Fmt.t + val box_fun_expr : Conf.t -> ctx0:Ast.t -> ctx:Ast.t -> parens:bool -> has_label:bool -> Fmt.t -> Fmt.t val function_attrs_sp : Conf.t -> ctx0:Ast.t -> ctx:Ast.t -> bool (** Whether a space should be added between the [function] keyword and the diff --git a/test.ml b/test.ml new file mode 100644 index 0000000000..0a462ec12a --- /dev/null +++ b/test.ml @@ -0,0 +1,11 @@ +[@@@ocamlformat "profile=janestreet"] + +let _ = + foo + |> List.map ~f:(fun x -> + do_something (); + do_something (); + do_something (); + do_something (); + do_something_else ()) +;; diff --git a/test/passing/tests/apply.ml b/test/passing/tests/apply.ml index 80592b7297..471359bfa9 100644 --- a/test/passing/tests/apply.ml +++ b/test/passing/tests/apply.ml @@ -63,7 +63,7 @@ let whatever_labelled a_function_name long_list_one some_other_thing = ListLabels.map long_list_one ~f:(fun long_list_one_elt -> do_something_with_a_function_and_some_things a_function_name long_list_one_elt some_other_thing - ) + ) ;; (a - b) () ;; diff --git a/test/passing/tests/attributes.ml b/test/passing/tests/attributes.ml index d7acf36c9b..bd43ab429a 100644 --- a/test/passing/tests/attributes.ml +++ b/test/passing/tests/attributes.ml @@ -381,7 +381,8 @@ let _ = f ((* comments *) 'c' [@attributes]) let _ = function ("foo" [@attr]) -> ("bar" [@attr2]) let _ = function - | ('A' [@attr]) -> ('B' [@attr2]) | ('A' .. 'B' [@attr2]) -> () + | ('A' [@attr]) -> ('B' [@attr2]) + | ('A' .. 'B' [@attr2]) -> () let _ = match x with @@ -408,18 +409,18 @@ let[@a when f ~f:(function[@ocaml.warning (* ....................................... *) "-4"] - | _ -> . ) + | _ -> . ) ~f:(function[@ocaml.warning (* ....................................... *) (* ....................................... *) "foooooooooooooooooooooooooooo \ fooooooooooooooooooooooooooooooooooooo"] - | _ -> . ) + | _ -> . ) ~f:(function[@ocaml.warning (* ....................................... *) let x = a and y = b in x + y] - | _ -> . ) -> + | _ -> . ) -> y [@attr (* ... *) @@ -448,7 +449,9 @@ let () = @@ S.tok begin [@warning "-4"] fun ev -> - match ev with Cbor_event.Reserved int -> Some int | _ -> None + match ev with + | Cbor_event.Reserved int -> Some int + | _ -> None end in () diff --git a/test/passing/tests/break_cases-align.ml.ref b/test/passing/tests/break_cases-align.ml.ref index 49204efc74..cc1c13db5e 100644 --- a/test/passing/tests/break_cases-align.ml.ref +++ b/test/passing/tests/break_cases-align.ml.ref @@ -18,16 +18,16 @@ let f = 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z - |P - |M -> - match y with - | O -> 5 - | P when h x -> ( - function - | A -> 6 ) + match x with + | E -> 4 + | Z + |P + |M -> + match y with + | O -> 5 + | P when h x -> ( + function + | A -> 6 ) let foo = List.map ~f:(fun x g t h y u -> @@ -40,7 +40,7 @@ let foo = | O -> 5 | P when h x -> ( function - | A -> 6 ) ) ; + | A -> 6 ) ) ; List.map ~f:(fun x g t h y u -> fooooooooooooo foooooooo ; ( match k with diff --git a/test/passing/tests/break_cases-all.ml.ref b/test/passing/tests/break_cases-all.ml.ref index 8fddf03bf5..97f61b0f7e 100644 --- a/test/passing/tests/break_cases-all.ml.ref +++ b/test/passing/tests/break_cases-all.ml.ref @@ -18,16 +18,16 @@ let f = 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z - |P - |M -> ( - match y with - | O -> 5 - | P when h x -> ( - function - | A -> 6 ) ) + match x with + | E -> 4 + | Z + |P + |M -> ( + match y with + | O -> 5 + | P when h x -> ( + function + | A -> 6 ) ) let foo = List.map ~f:(fun x g t h y u -> @@ -40,7 +40,7 @@ let foo = | O -> 5 | P when h x -> ( function - | A -> 6 ) ) ) ; + | A -> 6 ) ) ) ; List.map ~f:(fun x g t h y u -> fooooooooooooo foooooooo ; ( match k with diff --git a/test/passing/tests/break_cases-closing_on_separate_line.ml.ref b/test/passing/tests/break_cases-closing_on_separate_line.ml.ref index fe8e180d85..9ad2ce13d1 100644 --- a/test/passing/tests/break_cases-closing_on_separate_line.ml.ref +++ b/test/passing/tests/break_cases-closing_on_separate_line.ml.ref @@ -18,18 +18,18 @@ let f = 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z - |P - |M -> ( - match y with - | O -> 5 - | P when h x -> ( - function - | A -> 6 - ) - ) + match x with + | E -> 4 + | Z + |P + |M -> ( + match y with + | O -> 5 + | P when h x -> ( + function + | A -> 6 + ) + ) let foo = List.map ~f:(fun x g t h y u -> @@ -42,17 +42,17 @@ let foo = | O -> 5 | P when h x -> ( function - | A -> 6 + | A -> 6 ) ) - ) ; + ) ; List.map ~f:(fun x g t h y u -> fooooooooooooo foooooooo ; ( match k with | foooo -> foooooooo ) ; fooooooooooooooo fooooooooooooo - ) + ) ;; match x with diff --git a/test/passing/tests/break_cases-closing_on_separate_line_fit_or_vertical.ml.ref b/test/passing/tests/break_cases-closing_on_separate_line_fit_or_vertical.ml.ref index e89bcf7158..a46970e3ca 100644 --- a/test/passing/tests/break_cases-closing_on_separate_line_fit_or_vertical.ml.ref +++ b/test/passing/tests/break_cases-closing_on_separate_line_fit_or_vertical.ml.ref @@ -12,16 +12,16 @@ let f = | T | P | U -> 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z | P | M -> ( - match y with - | O -> 5 - | P when h x -> ( - function - | A -> 6 - ) - ) + match x with + | E -> 4 + | Z | P | M -> ( + match y with + | O -> 5 + | P when h x -> ( + function + | A -> 6 + ) + ) let foo = List.map ~f:(fun x g t h y u -> @@ -32,17 +32,17 @@ let foo = | O -> 5 | P when h x -> ( function - | A -> 6 + | A -> 6 ) ) - ) ; + ) ; List.map ~f:(fun x g t h y u -> fooooooooooooo foooooooo ; ( match k with | foooo -> foooooooo ) ; fooooooooooooooo fooooooooooooo - ) + ) ;; match x with diff --git a/test/passing/tests/break_cases-closing_on_separate_line_leading_nested_match_parens.ml.ref b/test/passing/tests/break_cases-closing_on_separate_line_leading_nested_match_parens.ml.ref index 6a5993605b..27ceaf0d75 100644 --- a/test/passing/tests/break_cases-closing_on_separate_line_leading_nested_match_parens.ml.ref +++ b/test/passing/tests/break_cases-closing_on_separate_line_leading_nested_match_parens.ml.ref @@ -18,18 +18,18 @@ let f = 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z - |P - |M -> - ( match y with - | O -> 5 - | P when h x -> - (function - | A -> 6 - ) - ) + match x with + | E -> 4 + | Z + |P + |M -> + ( match y with + | O -> 5 + | P when h x -> + (function + | A -> 6 + ) + ) let foo = List.map ~f:(fun x g t h y u -> @@ -42,17 +42,17 @@ let foo = | O -> 5 | P when h x -> (function - | A -> 6 - ) + | A -> 6 + ) ) - ) ; + ) ; List.map ~f:(fun x g t h y u -> fooooooooooooo foooooooo ; ( match k with | foooo -> foooooooo ) ; fooooooooooooooo fooooooooooooo - ) + ) ;; match x with diff --git a/test/passing/tests/break_cases-cosl_lnmp_cmei.ml.ref b/test/passing/tests/break_cases-cosl_lnmp_cmei.ml.ref index 6b57c38b89..f668e17ddb 100644 --- a/test/passing/tests/break_cases-cosl_lnmp_cmei.ml.ref +++ b/test/passing/tests/break_cases-cosl_lnmp_cmei.ml.ref @@ -18,18 +18,18 @@ let f = 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z - |P - |M -> - ( match y with - | O -> 5 - | P when h x -> - (function - | A -> 6 - ) - ) + match x with + | E -> 4 + | Z + |P + |M -> + ( match y with + | O -> 5 + | P when h x -> + (function + | A -> 6 + ) + ) let foo = List.map ~f:(fun x g t h y u -> @@ -42,17 +42,17 @@ let foo = | O -> 5 | P when h x -> (function - | A -> 6 - ) + | A -> 6 + ) ) - ) ; + ) ; List.map ~f:(fun x g t h y u -> fooooooooooooo foooooooo ; ( match k with | foooo -> foooooooo ) ; fooooooooooooooo fooooooooooooo - ) + ) ;; match x with diff --git a/test/passing/tests/break_cases-fit_or_vertical.ml.ref b/test/passing/tests/break_cases-fit_or_vertical.ml.ref index 6f66e70307..d24959f06b 100644 --- a/test/passing/tests/break_cases-fit_or_vertical.ml.ref +++ b/test/passing/tests/break_cases-fit_or_vertical.ml.ref @@ -12,14 +12,14 @@ let f = | T | P | U -> 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z | P | M -> ( - match y with - | O -> 5 - | P when h x -> ( - function - | A -> 6 ) ) + match x with + | E -> 4 + | Z | P | M -> ( + match y with + | O -> 5 + | P when h x -> ( + function + | A -> 6 ) ) let foo = List.map ~f:(fun x g t h y u -> @@ -30,7 +30,7 @@ let foo = | O -> 5 | P when h x -> ( function - | A -> 6 ) ) ) ; + | A -> 6 ) ) ) ; List.map ~f:(fun x g t h y u -> fooooooooooooo foooooooo ; ( match k with diff --git a/test/passing/tests/break_cases-nested.ml.ref b/test/passing/tests/break_cases-nested.ml.ref index 734740ce22..32f4743310 100644 --- a/test/passing/tests/break_cases-nested.ml.ref +++ b/test/passing/tests/break_cases-nested.ml.ref @@ -10,11 +10,11 @@ let f x = function let f = let g = function H when x y <> k -> 2 | T | P | U -> 3 in fun x g t h y u -> - match x with - | E -> - 4 - | Z | P | M -> ( - match y with O -> 5 | P when h x -> ( function A -> 6 ) ) + match x with + | E -> + 4 + | Z | P | M -> ( + match y with O -> 5 | P when h x -> ( function A -> 6 ) ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-normal_indent.ml.ref b/test/passing/tests/break_cases-normal_indent.ml.ref index 03e16db911..86fca7e929 100644 --- a/test/passing/tests/break_cases-normal_indent.ml.ref +++ b/test/passing/tests/break_cases-normal_indent.ml.ref @@ -18,16 +18,16 @@ let f = 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z - |P - |M -> ( - match y with - | O -> 5 - | P when h x -> ( - function - | A -> 6 ) ) + match x with + | E -> 4 + | Z + |P + |M -> ( + match y with + | O -> 5 + | P when h x -> ( + function + | A -> 6 ) ) let foo = List.map ~f:(fun x g t h y u -> @@ -40,7 +40,7 @@ let foo = | O -> 5 | P when h x -> ( function - | A -> 6 ) ) ) ; + | A -> 6 ) ) ) ; List.map ~f:(fun x g t h y u -> fooooooooooooo foooooooo ; ( match k with diff --git a/test/passing/tests/break_cases-toplevel.ml.ref b/test/passing/tests/break_cases-toplevel.ml.ref index 2e44dab191..2d8828ee9a 100644 --- a/test/passing/tests/break_cases-toplevel.ml.ref +++ b/test/passing/tests/break_cases-toplevel.ml.ref @@ -13,14 +13,14 @@ let f = | T | P | U -> 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z | P | M -> ( - match y with - | O -> 5 - | P when h x -> ( - function - | A -> 6 ) ) + match x with + | E -> 4 + | Z | P | M -> ( + match y with + | O -> 5 + | P when h x -> ( + function + | A -> 6 ) ) let foo = List.map ~f:(fun x g t h y u -> @@ -31,7 +31,7 @@ let foo = | O -> 5 | P when h x -> ( function - | A -> 6 ) ) ) ; + | A -> 6 ) ) ) ; List.map ~f:(fun x g t h y u -> fooooooooooooo foooooooo ; ( match k with diff --git a/test/passing/tests/break_cases-vertical.ml.ref b/test/passing/tests/break_cases-vertical.ml.ref index 6e575cdf3e..2bba9fc079 100644 --- a/test/passing/tests/break_cases-vertical.ml.ref +++ b/test/passing/tests/break_cases-vertical.ml.ref @@ -19,19 +19,19 @@ let f = 3 in fun x g t h y u -> - match x with - | E -> - 4 - | Z - |P - |M -> ( - match y with - | O -> - 5 - | P when h x -> ( - function - | A -> - 6 ) ) + match x with + | E -> + 4 + | Z + |P + |M -> ( + match y with + | O -> + 5 + | P when h x -> ( + function + | A -> + 6 ) ) let foo = List.map ~f:(fun x g t h y u -> @@ -46,8 +46,8 @@ let foo = 5 | P when h x -> ( function - | A -> - 6 ) ) ) ; + | A -> + 6 ) ) ) ; List.map ~f:(fun x g t h y u -> fooooooooooooo foooooooo ; ( match k with diff --git a/test/passing/tests/break_cases.ml.ref b/test/passing/tests/break_cases.ml.ref index 438f267754..f7c8dffad6 100644 --- a/test/passing/tests/break_cases.ml.ref +++ b/test/passing/tests/break_cases.ml.ref @@ -10,10 +10,10 @@ let f x = function let f = let g = function H when x y <> k -> 2 | T | P | U -> 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z | P | M -> ( - match y with O -> 5 | P when h x -> ( function A -> 6 ) ) + match x with + | E -> 4 + | Z | P | M -> ( + match y with O -> 5 | P when h x -> ( function A -> 6 ) ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/disambiguate.ml b/test/passing/tests/disambiguate.ml index 2b00176118..a6c1e619bd 100644 --- a/test/passing/tests/disambiguate.ml +++ b/test/passing/tests/disambiguate.ml @@ -5,15 +5,15 @@ let () = r := fun () -> f () ; g () let () = r := fun () -> - f () ; g () ; g () ; g () ; g () ; g () ; g () ; g () ; g () ; g () + f () ; g () ; g () ; g () ; g () ; g () ; g () ; g () ; g () ; g () let () = r := function () -> f () ; g () let () = r := function - | () -> - f () ; g () ; g () ; g () ; g () ; g () ; g () ; g () ; g () ; g () + | () -> + f () ; g () ; g () ; g () ; g () ; g () ; g () ; g () ; g () ; g () let () = r := (match () with () -> f () ; g ()) diff --git a/test/passing/tests/eliom_ext.eliom b/test/passing/tests/eliom_ext.eliom index 9b5632b28d..29010494f5 100644 --- a/test/passing/tests/eliom_ext.eliom +++ b/test/passing/tests/eliom_ext.eliom @@ -20,7 +20,7 @@ let%client () = (* NB The service underlying the server_function isn't available on the client before loading the page. *) ~foo:(fun () -> - Lwt.async (fun () -> log "Hello from the client to the server!") ) + Lwt.async (fun () -> log "Hello from the client to the server!") ) bar [%%shared diff --git a/test/passing/tests/exp_grouping.ml.ref b/test/passing/tests/exp_grouping.ml.ref index 1cf112ff77..32a071cb27 100644 --- a/test/passing/tests/exp_grouping.ml.ref +++ b/test/passing/tests/exp_grouping.ml.ref @@ -18,11 +18,11 @@ let () = List.iter begin fun v -> - (* do a lot of things *) - let a = "a" in - let b = "b" in - let c = "c" in - () + (* do a lot of things *) + let a = "a" in + let b = "b" in + let c = "c" in + () end values diff --git a/test/passing/tests/fun_decl.ml b/test/passing/tests/fun_decl.ml index 6b1ede0aa8..72dca43b79 100644 --- a/test/passing/tests/fun_decl.ml +++ b/test/passing/tests/fun_decl.ml @@ -19,18 +19,18 @@ let _ = let to_loc_trace ?(desc_of_source = fun source -> - let callsite = Source.call_site source in - Format.asprintf - "return from %a" - Typ.Procname.pp - (CallSite.pname callsite)) ?(source_should_nest = fun _ -> true) + let callsite = Source.call_site source in + Format.asprintf + "return from %a" + Typ.Procname.pp + (CallSite.pname callsite)) ?(source_should_nest = fun _ -> true) ?(desc_of_sink = fun sink -> - let callsite = Sink.call_site sink in - Format.asprintf - "call to %a" - Typ.Procname.pp - (CallSite.pname callsite)) ?(sink_should_nest = fun _ -> true) + let callsite = Sink.call_site sink in + Format.asprintf + "call to %a" + Typ.Procname.pp + (CallSite.pname callsite)) ?(sink_should_nest = fun _ -> true) (passthroughs, sources, sinks) = () @@ -46,14 +46,14 @@ let translate_captured let to_loc_trace ?(desc_of_source = fun source -> - let callsite = Source.call_site source in - Format.asprintf "return from %a" Typ.Procname.pp - (CallSite.pname callsite)) ?(source_should_nest = fun _ -> true) + let callsite = Source.call_site source in + Format.asprintf "return from %a" Typ.Procname.pp + (CallSite.pname callsite)) ?(source_should_nest = fun _ -> true) ?(desc_of_sink = fun sink -> - let callsite = Sink.call_site sink in - Format.asprintf "call to %a" Typ.Procname.pp - (CallSite.pname callsite)) ?(sink_should_nest = fun _ -> true) + let callsite = Sink.call_site sink in + Format.asprintf "call to %a" Typ.Procname.pp + (CallSite.pname callsite)) ?(sink_should_nest = fun _ -> true) (passthroughs, sources, sinks) = () @@ -67,19 +67,19 @@ let translate_captured let f ssssssssss = String.fold ssssssssss ~init:innnnnnnnnnit ~f:(fun accuuuuuuuuuum -> function - | '0' -> g accuuuuuuuuuum - | '1' -> h accuuuuuuuuuum - | _ -> i accuuuuuuuuuum ) + | '0' -> g accuuuuuuuuuum + | '1' -> h accuuuuuuuuuum + | _ -> i accuuuuuuuuuum ) let f _ = let foooooooooooooooooooooooooooo = foooooooooooooooooooooooooooo in fun x -> - let foooooooooooooooooooooooooooo = foooooooooooooooooooooooooooo in - x + let foooooooooooooooooooooooooooo = foooooooooooooooooooooooooooo in + x let f _ = let foooooooooooooooooooooooooooo = foooooooooooooooooooooooooooo in (* foo *) fun x -> - let foooooooooooooooooooooooooooo = foooooooooooooooooooooooooooo in - x + let foooooooooooooooooooooooooooo = foooooooooooooooooooooooooooo in + x diff --git a/test/passing/tests/fun_function.ml b/test/passing/tests/fun_function.ml index 4e55f06bc6..a6fef8fbdc 100644 --- a/test/passing/tests/fun_function.ml +++ b/test/passing/tests/fun_function.ml @@ -1,4 +1,4 @@ let s = List.fold x ~f:(fun y -> function - | Aconstructor avalue -> afunction avalue - | Bconstructor bvalue -> bfunction bvalue ) + | Aconstructor avalue -> afunction avalue + | Bconstructor bvalue -> bfunction bvalue ) diff --git a/test/passing/tests/function_indent-never.ml.ref b/test/passing/tests/function_indent-never.ml.ref index 729445cab6..2f0cb275c7 100644 --- a/test/passing/tests/function_indent-never.ml.ref +++ b/test/passing/tests/function_indent-never.ml.ref @@ -14,6 +14,5 @@ let foooooooo = if fooooooooooo then function | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo - else function - | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo + else function fooooooooooooooooooooooo -> foooooooooooooooooooooooooo | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo diff --git a/test/passing/tests/function_indent.ml.ref b/test/passing/tests/function_indent.ml.ref index d6f219e6a4..e17091083f 100644 --- a/test/passing/tests/function_indent.ml.ref +++ b/test/passing/tests/function_indent.ml.ref @@ -14,6 +14,5 @@ let foooooooo = if fooooooooooo then function | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo - else function - | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo + else function fooooooooooooooooooooooo -> foooooooooooooooooooooooooo | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo diff --git a/test/passing/tests/indicate_multiline_delimiters-cosl.ml.ref b/test/passing/tests/indicate_multiline_delimiters-cosl.ml.ref index 764a7fa7a1..262bece425 100644 --- a/test/passing/tests/indicate_multiline_delimiters-cosl.ml.ref +++ b/test/passing/tests/indicate_multiline_delimiters-cosl.ml.ref @@ -41,14 +41,14 @@ let raise fmt = let contrived = List.map ~f:(fun aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa -> - f aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - ) + f aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + ) l let contrived = List.map l ~f:(fun aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa -> f aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - ) + ) let x = match y with diff --git a/test/passing/tests/indicate_multiline_delimiters-space.ml.ref b/test/passing/tests/indicate_multiline_delimiters-space.ml.ref index b8a491787a..158b9a970c 100644 --- a/test/passing/tests/indicate_multiline_delimiters-space.ml.ref +++ b/test/passing/tests/indicate_multiline_delimiters-space.ml.ref @@ -37,7 +37,7 @@ let raise fmt = let contrived = List.map ~f:(fun aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa -> - f aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa ) + f aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa ) l let contrived = diff --git a/test/passing/tests/indicate_multiline_delimiters.ml b/test/passing/tests/indicate_multiline_delimiters.ml index 317d579957..164bbbb62c 100644 --- a/test/passing/tests/indicate_multiline_delimiters.ml +++ b/test/passing/tests/indicate_multiline_delimiters.ml @@ -37,7 +37,7 @@ let raise fmt = let contrived = List.map ~f:(fun aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa -> - f aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa) + f aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa) l let contrived = diff --git a/test/passing/tests/issue1750.ml b/test/passing/tests/issue1750.ml index 32b5c8a3fd..aa92e99651 100644 --- a/test/passing/tests/issue1750.ml +++ b/test/passing/tests/issue1750.ml @@ -27,55 +27,66 @@ let _ = let _ = function | [%p function - | [%p - function - | [%p - function + | [%p + function | [%p function - | [%p - function - | [%p - function + | [%p + function | [%p function - | [%p - function - | [%p - function + | [%p + function | [%p function - | [%p - function - | [%p - function + | [%p + function | [%p function - | [%p - function - | [%p - function + | [%p + function | [%p function - | [%p - function - | _ -> - ()] - -> - ()] -> + | [%p + function + | [%p + function + | + [%p + function + | + [%p + function + | + [%p + function + | + [%p + function + | _ + -> + ()] + -> + ()] + -> + ()] + -> + ()] + -> + ()] + -> + ()] + -> + ()] + -> ()] -> - ()] -> - ()] -> + ()] -> ()] -> - ()] -> - ()] -> + ()] -> ()] -> - ()] -> - ()] -> + ()] -> ()] -> - ()] -> - ()] -> + ()] -> ()] -> - ()] -> - ()] -> + ()] -> () diff --git a/test/passing/tests/issue1750.ml.err b/test/passing/tests/issue1750.ml.err index ab36531f86..bf121f014e 100644 --- a/test/passing/tests/issue1750.ml.err +++ b/test/passing/tests/issue1750.ml.err @@ -1,2 +1,29 @@ Warning: tests/issue1750.ml:20 exceeds the margin +Warning: tests/issue1750.ml:50 exceeds the margin +Warning: tests/issue1750.ml:51 exceeds the margin +Warning: tests/issue1750.ml:52 exceeds the margin +Warning: tests/issue1750.ml:53 exceeds the margin +Warning: tests/issue1750.ml:54 exceeds the margin +Warning: tests/issue1750.ml:55 exceeds the margin +Warning: tests/issue1750.ml:56 exceeds the margin +Warning: tests/issue1750.ml:57 exceeds the margin +Warning: tests/issue1750.ml:58 exceeds the margin +Warning: tests/issue1750.ml:59 exceeds the margin Warning: tests/issue1750.ml:60 exceeds the margin +Warning: tests/issue1750.ml:61 exceeds the margin +Warning: tests/issue1750.ml:62 exceeds the margin +Warning: tests/issue1750.ml:63 exceeds the margin +Warning: tests/issue1750.ml:64 exceeds the margin +Warning: tests/issue1750.ml:65 exceeds the margin +Warning: tests/issue1750.ml:66 exceeds the margin +Warning: tests/issue1750.ml:67 exceeds the margin +Warning: tests/issue1750.ml:68 exceeds the margin +Warning: tests/issue1750.ml:69 exceeds the margin +Warning: tests/issue1750.ml:70 exceeds the margin +Warning: tests/issue1750.ml:71 exceeds the margin +Warning: tests/issue1750.ml:72 exceeds the margin +Warning: tests/issue1750.ml:73 exceeds the margin +Warning: tests/issue1750.ml:74 exceeds the margin +Warning: tests/issue1750.ml:75 exceeds the margin +Warning: tests/issue1750.ml:76 exceeds the margin +Warning: tests/issue1750.ml:77 exceeds the margin diff --git a/test/passing/tests/issue289.ml b/test/passing/tests/issue289.ml index d726f778f2..3e7a389384 100644 --- a/test/passing/tests/issue289.ml +++ b/test/passing/tests/issue289.ml @@ -3,29 +3,31 @@ let foo = let open Gql in [ field "id" ~doc:"Toy ID." ~args:[] ~typ:(non_null guid) ~resolve:(function - | _ctx -> x.id ) + | _ctx -> x.id ) ; field "id" ~doc:"Toy ID." ~args:[] ~typppp ~resolve:(function - | _ctx -> x.id ) + | _ctx -> x.id ) ; field "id" ~doc:"Toy ID." ~args:[] ~typ:(non_null guid) ~resolve:(function - | A -> x.id | B -> c ) + | A -> x.id + | B -> c ) ; field "id" ~doc:"Toy ID." ~args:[] ~resolve:(function - | A -> x.id | B -> c ) + | A -> x.id + | B -> c ) ; field "id" ~doc:"Toy ID." ~args:[] ~typppppppppppppppppppp ~resolve:(function - | AAAAAAAAAAAAAAAAAAAa -> x.idddddddddddddddddddddddddd - | BBBBBBBBBBBBBBBB -> ccccccccccccccccccccccc ) + | AAAAAAAAAAAAAAAAAAAa -> x.idddddddddddddddddddddddddd + | BBBBBBBBBBBBBBBB -> ccccccccccccccccccccccc ) ; field "id" ~doc:"Toy ID." ~args:[] ~resolve:(function - | AAAAAAAAAAAAAAAAAAAa -> x.idddddddddddddddddddddddddd - | BBBBBBBBBBBBBBBB -> ccccccccccccccccccccccc ) + | AAAAAAAAAAAAAAAAAAAa -> x.idddddddddddddddddddddddddd + | BBBBBBBBBBBBBBBB -> ccccccccccccccccccccccc ) ; field "id" ~doc:"Toy ID." @@ -67,9 +69,11 @@ let foo = | _ctx -> x.id ) ; field "id" ~doc:"Toy ID." ~args:[] ~typ:(non_null guid) ~resolve:(function - | A -> x.id | B -> c ) + | A -> x.id + | B -> c ) ; field "id" ~doc:"Toy ID." ~args:[] ~resolve:(function - | A -> x.id | B -> c ) + | A -> x.id + | B -> c ) ; field "id" ~doc:"Toy ID." ~args:[] ~typppppppppppppppppppp ~resolve:(function | AAAAAAAAAAAAAAAAAAAa -> x.idddddddddddddddddddddddddd diff --git a/test/passing/tests/issue289.ml.err b/test/passing/tests/issue289.ml.err index dd03b71dc8..6044abcdbd 100644 --- a/test/passing/tests/issue289.ml.err +++ b/test/passing/tests/issue289.ml.err @@ -1,2 +1,2 @@ Warning: tests/issue289.ml:4 exceeds the margin -Warning: tests/issue289.ml:63 exceeds the margin +Warning: tests/issue289.ml:65 exceeds the margin diff --git a/test/passing/tests/ite-compact_closing.ml.ref b/test/passing/tests/ite-compact_closing.ml.ref index ba050bfa68..dd0ea0071c 100644 --- a/test/passing/tests/ite-compact_closing.ml.ref +++ b/test/passing/tests/ite-compact_closing.ml.ref @@ -100,7 +100,7 @@ let foo = fooooooooooooooooooo fooooooooooooooo foooooooooooo ; List.foo ~fooooooo:foooooooooooooooo ~foo:(fun fooooooooo -> fooooooooooooo - ) + ) ) else if cond2 then ( arm2 ; @@ -108,7 +108,7 @@ let foo = fooooooooooooooooooo fooooooooooooooo foooooooooooo ; List.foo ~fooooooo:foooooooooooooooo ~foo:(fun fooooooooo -> fooooooooooooo - ) + ) ) else ( arm3 ; @@ -116,7 +116,7 @@ let foo = fooooooooooooooooooo fooooooooooooooo foooooooooooo ; List.foo ~fooooooo:foooooooooooooooo ~foo:(fun fooooooooo -> fooooooooooooo - ) + ) ) let foo = diff --git a/test/passing/tests/ite-fit_or_vertical_closing.ml.ref b/test/passing/tests/ite-fit_or_vertical_closing.ml.ref index 7cf962e6b9..d58dfac9f1 100644 --- a/test/passing/tests/ite-fit_or_vertical_closing.ml.ref +++ b/test/passing/tests/ite-fit_or_vertical_closing.ml.ref @@ -120,21 +120,21 @@ let foo = fooooooooooooooooooo fooooooooooooooo foooooooooooo ; List.foo ~fooooooo:foooooooooooooooo ~foo:(fun fooooooooo -> fooooooooooooo - ) + ) ) else if cond2 then ( arm2 ; foooooooooooooo ; fooooooooooooooooooo fooooooooooooooo foooooooooooo ; List.foo ~fooooooo:foooooooooooooooo ~foo:(fun fooooooooo -> fooooooooooooo - ) + ) ) else ( arm3 ; foooooooooooooo ; fooooooooooooooooooo fooooooooooooooo foooooooooooo ; List.foo ~fooooooo:foooooooooooooooo ~foo:(fun fooooooooo -> fooooooooooooo - ) + ) ) let foo = diff --git a/test/passing/tests/ite-kr_closing.ml.ref b/test/passing/tests/ite-kr_closing.ml.ref index 8fc41701c5..417c3c9ca8 100644 --- a/test/passing/tests/ite-kr_closing.ml.ref +++ b/test/passing/tests/ite-kr_closing.ml.ref @@ -141,21 +141,21 @@ let foo = fooooooooooooooooooo fooooooooooooooo foooooooooooo ; List.foo ~fooooooo:foooooooooooooooo ~foo:(fun fooooooooo -> fooooooooooooo - ) + ) ) else if cond2 then ( arm2 ; foooooooooooooo ; fooooooooooooooooooo fooooooooooooooo foooooooooooo ; List.foo ~fooooooo:foooooooooooooooo ~foo:(fun fooooooooo -> fooooooooooooo - ) + ) ) else ( arm3 ; foooooooooooooo ; fooooooooooooooooooo fooooooooooooooo foooooooooooo ; List.foo ~fooooooo:foooooooooooooooo ~foo:(fun fooooooooo -> fooooooooooooo - ) + ) ) let foo = diff --git a/test/passing/tests/ite-kw_first.ml.ref b/test/passing/tests/ite-kw_first.ml.ref index a95a92faad..288051d2f5 100644 --- a/test/passing/tests/ite-kw_first.ml.ref +++ b/test/passing/tests/ite-kw_first.ml.ref @@ -159,10 +159,10 @@ let _ = if x then fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz else fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz let _ = if diff --git a/test/passing/tests/ite-kw_first_closing.ml.ref b/test/passing/tests/ite-kw_first_closing.ml.ref index e2316835df..e25ec25996 100644 --- a/test/passing/tests/ite-kw_first_closing.ml.ref +++ b/test/passing/tests/ite-kw_first_closing.ml.ref @@ -114,7 +114,7 @@ let foo = fooooooooooooooooooo fooooooooooooooo foooooooooooo ; List.foo ~fooooooo:foooooooooooooooo ~foo:(fun fooooooooo -> fooooooooooooo - ) + ) ) else if cond2 then ( @@ -123,7 +123,7 @@ let foo = fooooooooooooooooooo fooooooooooooooo foooooooooooo ; List.foo ~fooooooo:foooooooooooooooo ~foo:(fun fooooooooo -> fooooooooooooo - ) + ) ) else ( arm3 ; @@ -131,7 +131,7 @@ let foo = fooooooooooooooooooo fooooooooooooooo foooooooooooo ; List.foo ~fooooooo:foooooooooooooooo ~foo:(fun fooooooooo -> fooooooooooooo - ) + ) ) let foo = @@ -174,10 +174,10 @@ let _ = if x then fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz else fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz let _ = if diff --git a/test/passing/tests/ite-kw_first_no_indicate.ml.ref b/test/passing/tests/ite-kw_first_no_indicate.ml.ref index 35c906e623..30b261f1c9 100644 --- a/test/passing/tests/ite-kw_first_no_indicate.ml.ref +++ b/test/passing/tests/ite-kw_first_no_indicate.ml.ref @@ -158,10 +158,10 @@ let _ = if x then fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz else fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz let _ = if diff --git a/test/passing/tests/ite-vertical.ml.ref b/test/passing/tests/ite-vertical.ml.ref index 62def39502..6f8fdf5880 100644 --- a/test/passing/tests/ite-vertical.ml.ref +++ b/test/passing/tests/ite-vertical.ml.ref @@ -195,10 +195,10 @@ let _ = let _ = if x then fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz else fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz let _ = if diff --git a/test/passing/tests/js_pattern.ml.ref b/test/passing/tests/js_pattern.ml.ref index 88a0d83be2..2a75f4f5b1 100644 --- a/test/passing/tests/js_pattern.ml.ref +++ b/test/passing/tests/js_pattern.ml.ref @@ -9,7 +9,7 @@ let f x = match x with _ -> 0 let f x = match x with _ -> 0 let check_price t = function - | {Exec.trade_at_settlement= None | Some false} -> () + | {Exec.trade_at_settlement= None | Some false} -> () let check_price t = function simpler -> () | other -> () diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index 1fbc8eb06c..7635acc9f6 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -3665,7 +3665,7 @@ let subst_lambda ~subst_rec ~free ~subst : _ lambda -> _ = function let used = free t in let used_expr = Subst.fold subst ~init:[] ~f:(fun ~key ~data acc -> - if Names.mem s used then data :: acc else acc) + if Names.mem s used then data :: acc else acc) in if List.exists used_expr ~f:(fun t -> Names.mem s (free t)) then ( @@ -3903,7 +3903,7 @@ class ['a] lambda_ops (ops : ('a, 'a) #ops Lazy.t) = let used = !!free t in let used_expr = Subst.fold sub ~init:[] ~f:(fun ~key ~data acc -> - if Names.mem s used then data :: acc else acc) + if Names.mem s used then data :: acc else acc) in if List.exists used_expr ~f:(fun t -> Names.mem s (!!free t)) then ( @@ -4145,7 +4145,7 @@ let lambda_ops (ops : ('a, 'a) #ops Lazy.t) = let used = !!free t in let used_expr = Subst.fold sub ~init:[] ~f:(fun ~key ~data acc -> - if Names.mem s used then data :: acc else acc) + if Names.mem s used then data :: acc else acc) in if List.exists used_expr ~f:(fun t -> Names.mem s (!!free t)) then ( @@ -9612,7 +9612,7 @@ let _ = let _ = List.map rows ~f:(fun row -> - Or_error.try_with (fun () -> fffffffffffffffffffffffff row)) + Or_error.try_with (fun () -> fffffffffffffffffffffffff row)) ;; module type T = sig @@ -9807,7 +9807,7 @@ let _ = when f ~f: (function [@ocaml.warning (* ....................................... *) "-4"] - | _ -> .) -> y + | _ -> .) -> y ;; let[@a @@ -9847,22 +9847,22 @@ let[@a let x = foo (`A b) ~f:(fun thing -> - something that reaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaally needs wrapping) + something that reaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaally needs wrapping) ;; let x = foo (`A `b) ~f:(fun thing -> - something that reaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaally needs wrapping) + something that reaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaally needs wrapping) ;; let x = foo [ A; B ] ~f:(fun thing -> - something that reaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaally needs wrapping) + something that reaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaally needs wrapping) ;; let x = foo [ [ A ]; B ] ~f:(fun thing -> - something that reaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaally needs wrapping) + something that reaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaally needs wrapping) ;; let x = @@ -9885,9 +9885,9 @@ let x = some_fun________________________________ some_arg______________________________ ~f:(fun param -> - do_something (); - do_something_else (); - return_this_value) + do_something (); + do_something_else (); + return_this_value) ;; let x = @@ -9983,9 +9983,9 @@ type t let pat = String.Search_pattern.create (String.init len ~f:(function - | 0 -> '\n' - | n when n < len - 1 -> ' ' - | _ -> '*')) + | 0 -> '\n' + | n when n < len - 1 -> ' ' + | _ -> '*')) ;; type t = @@ -10015,29 +10015,29 @@ let _ = fooooooooooooooooooooooooooooooooooooooo fooooooooooooooooooooooooooooooooooooooo ~f:(fun (type a) foooooooooooooooooooooooooooooooooo : 'a -> - match fooooooooooooooooooooooooooooooooooooooo with - | Fooooooooooooooooooooooooooooooooooooooo -> x - | Fooooooooooooooooooooooooooooooooooooooo -> x) + match fooooooooooooooooooooooooooooooooooooooo with + | Fooooooooooooooooooooooooooooooooooooooo -> x + | Fooooooooooooooooooooooooooooooooooooooo -> x) ;; let _ = foo |> List.map ~f:(fun x -> - do_something (); - do_something (); - do_something (); - do_something (); - do_something_else ()) + do_something (); + do_something (); + do_something (); + do_something (); + do_something_else ()) ;; let _ = foo |> List.map ~f:(fun x -> - do_something (); - do_something (); - do_something (); - do_something (); - do_something_else ()) + do_something (); + do_something (); + do_something (); + do_something (); + do_something_else ()) |> bar ;; @@ -10230,9 +10230,9 @@ let _ = foooooooooooooooooooo foooooooooooooooooooo ~x:(fun x -> - match foo with - | Foooooooooooooooooooo -> foooooooooooooooooooo - | Foooooooooooooooooooo -> foooooooooooooooooooo) + match foo with + | Foooooooooooooooooooo -> foooooooooooooooooooo + | Foooooooooooooooooooo -> foooooooooooooooooooo) ;; let _ = @@ -10420,9 +10420,9 @@ let _ = |> fooooooooooooooooooooooooooooooo ~fooooooooooooooooooooooooooooooo ~fooooooooooooooooooooooooooooooo:(fun foo -> - match bar with - | Some _ -> foo - | None -> baz) + match bar with + | Some _ -> foo + | None -> baz) ;; let _ = diff --git a/test/passing/tests/max_indent.ml b/test/passing/tests/max_indent.ml index 2ae7825a03..5f7f5bc5e1 100644 --- a/test/passing/tests/max_indent.ml +++ b/test/passing/tests/max_indent.ml @@ -1,19 +1,18 @@ let () = fooooo |> List.iter (fun x -> - let x = x $ y in - fooooooooooo x ) + let x = x $ y in + fooooooooooo x ) let () = fooooo |> List.iter (fun some_really_really_really_long_name_that_doesn't_fit_on_the_line -> - let x = - some_really_really_really_long_name_that_doesn't_fit_on_the_line - $ y - in - fooooooooooo x ) + let x = + some_really_really_really_long_name_that_doesn't_fit_on_the_line $ y + in + fooooooooooo x ) let foooooooooo = foooooooooooooooooooooo @@ -73,19 +72,19 @@ let foooooooooooooooooooooooooooooooo = let x = some_fun________________________________ some_arg______________________________ (fun param -> - do_something () ; do_something_else () ; return_this_value ) + do_something () ; do_something_else () ; return_this_value ) let x = some_fun________________________________ some_arg______________________________ ~f:(fun param -> - do_something () ; do_something_else () ; return_this_value ) + do_something () ; do_something_else () ; return_this_value ) let x = some_value |> some_fun (fun x -> - do_something () ; do_something_else () ; return_this_value ) + do_something () ; do_something_else () ; return_this_value ) let x = some_value ^ some_fun (fun x -> - do_something () ; do_something_else () ; return_this_value ) + do_something () ; do_something_else () ; return_this_value ) diff --git a/test/passing/tests/object.ml.ref b/test/passing/tests/object.ml.ref index 5b7184fdcb..9e2ba89157 100644 --- a/test/passing/tests/object.ml.ref +++ b/test/passing/tests/object.ml.ref @@ -219,7 +219,7 @@ let o = -> bool tttttttttttttttt rrrrrrrrrrrrrrrrrrrrr rrrrrrrrrrrrrrrrrrrrr rrrrrrrrrrrrrrrrrrrrrrr = fun (a, op, b) -> - Int_bin_comparison (self#expression a, op, self#expression b) + Int_bin_comparison (self#expression a, op, self#expression b) end class f = fun [@inline] (b [@inline]) -> object end @@ -299,9 +299,9 @@ class a x = object (self) end let x = fun [@foo] x -> fun [@foo] y -> - object - method x = y - end + object + method x = y + end class x = fun [@foo] x -> diff --git a/test/passing/tests/skip.ml b/test/passing/tests/skip.ml index 311cfd2033..33eb9d37b7 100644 --- a/test/passing/tests/skip.ml +++ b/test/passing/tests/skip.ml @@ -22,10 +22,14 @@ end module S = struct let x = function - | A, B -> 1 | BBB, _ -> 2 | CCCcccc, CCCCCCCC -> (* cmt about 3 *) 3 + | A, B -> 1 + | BBB, _ -> 2 + | CCCcccc, CCCCCCCC -> (* cmt about 3 *) 3 let x = function - | A, B -> 1 | BBB, _ -> 2 | CCCcccc, CCCCCCCC -> (* cmt about 3 *) 3 + | A, B -> 1 + | BBB, _ -> 2 + | CCCcccc, CCCCCCCC -> (* cmt about 3 *) 3 [@@@ocamlformat "disable"] @@ -37,7 +41,9 @@ module S = struct [@@@ocamlformat "enable"] let x = function - | A, B -> 1 | BBB, _ -> 2 | CCCcccc, CCCCCCCC -> (* cmt about 3 *) 3 + | A, B -> 1 + | BBB, _ -> 2 + | CCCcccc, CCCCCCCC -> (* cmt about 3 *) 3 let _ = let x = 3 in @@ -49,7 +55,9 @@ module S = struct end let x = function - | A, B -> 1 | BBB, _ -> 2 | CCCcccc, CCCCCCCC -> (* cmt about 3 *) 3 + | A, B -> 1 + | BBB, _ -> 2 + | CCCcccc, CCCCCCCC -> (* cmt about 3 *) 3 module type S = sig type t = int * int diff --git a/test/passing/tests/source.ml.err b/test/passing/tests/source.ml.err index 8e1cc7a17b..68ebdc8223 100644 --- a/test/passing/tests/source.ml.err +++ b/test/passing/tests/source.ml.err @@ -1,3 +1,3 @@ Warning: tests/source.ml:703 exceeds the margin -Warning: tests/source.ml:1390 exceeds the margin -Warning: tests/source.ml:2308 exceeds the margin +Warning: tests/source.ml:1351 exceeds the margin +Warning: tests/source.ml:2319 exceeds the margin diff --git a/test/passing/tests/source.ml.ref b/test/passing/tests/source.ml.ref index c55e247c99..45ab9a907b 100644 --- a/test/passing/tests/source.ml.ref +++ b/test/passing/tests/source.ml.ref @@ -956,7 +956,9 @@ module type S3 = sig end let f = function - | Some (module M : S3) when M.x -> 1 | ((Some _) [@foooo]) -> 2 | None -> 3 + | Some (module M : S3) when M.x -> 1 + | ((Some _) [@foooo]) -> 2 + | None -> 3 ;; print_endline @@ -1314,7 +1316,9 @@ let ty_abc = and inj : type c. (int -> string -> noarg -> unit, c) ty_sel * c -> [`A of int | `B of string | `C] = function - | Thd, v -> `A v | Ttl Thd, v -> `B v | Ttl (Ttl Thd), Noarg -> `C + | Thd, v -> `A v + | Ttl Thd, v -> `B v + | Ttl (Ttl Thd), Noarg -> `C in (* Coherence of sum_inj and sum_cases is checked by the typing *) Sum @@ -1339,14 +1343,14 @@ let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = (Sum { sum_proj= (function - | `Nil -> ("Nil", None) - | `Cons p -> ("Cons", Some (Tdyn (tcons, p))) ) + | `Nil -> ("Nil", None) + | `Cons p -> ("Cons", Some (Tdyn (tcons, p))) ) ; sum_cases= [("Nil", TCnoarg Thd); ("Cons", TCarg (Ttl Thd, tcons))] ; sum_inj= (fun (type c) -> - ( function Thd, Noarg -> `Nil | Ttl Thd, v -> `Cons v - : (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist ) ) - (* One can also write the type annotation directly *) } ) + ( function Thd, Noarg -> `Nil | Ttl Thd, v -> `Cons v + : (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist ) ) + (* One can also write the type annotation directly *) } ) let v = variantize Enil (ty_list Int) (`Cons (1, `Cons (2, `Nil))) @@ -1372,14 +1376,14 @@ let ty_abc : ([`A of int | `B of string | `C], 'e) ty = (* Could also use [get_case] for proj, but direct definition is shorter *) Sum ( (function - | `A n -> ("A", Some (Tdyn (Int, n))) - | `B s -> ("B", Some (Tdyn (String, s))) - | `C -> ("C", None) ) + | `A n -> ("A", Some (Tdyn (Int, n))) + | `B s -> ("B", Some (Tdyn (String, s))) + | `C -> ("C", None) ) , function - | "A", Some (Tdyn (Int, n)) -> `A n - | "B", Some (Tdyn (String, s)) -> `B s - | "C", None -> `C - | _ -> invalid_arg "ty_abc" ) + | "A", Some (Tdyn (Int, n)) -> `A n + | "B", Some (Tdyn (String, s)) -> `B s + | "C", None -> `C + | _ -> invalid_arg "ty_abc" ) (* Breaks: no way to pattern-match on a full recursive type *) let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = @@ -1388,11 +1392,12 @@ let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = Rec (Sum ( (function - | `Nil -> ("Nil", None) | `Cons p -> ("Cons", Some (Tdyn (targ, p))) ) + | `Nil -> ("Nil", None) + | `Cons p -> ("Cons", Some (Tdyn (targ, p))) ) , function - | "Nil", None -> `Nil - | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p - ) ) + | "Nil", None -> `Nil + | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> + `Cons p ) ) (* Define Sum using object instead of record for first-class polymorphism *) @@ -1427,9 +1432,9 @@ let ty_abc : (([`A of int | `B of string | `C] as 'a), 'e) ty = (object method proj = function - | `A n -> ("A", Some (Tdyn (Int, n))) - | `B s -> ("B", Some (Tdyn (String, s))) - | `C -> ("C", None) + | `A n -> ("A", Some (Tdyn (Int, n))) + | `B s -> ("B", Some (Tdyn (String, s))) + | `C -> ("C", None) method cases = [ ("A", TCarg (Thd, Int)) @@ -1440,7 +1445,9 @@ let ty_abc : (([`A of int | `B of string | `C] as 'a), 'e) ty = (int -> string -> noarg -> unit, c) ty_sel * c -> [`A of int | `B of string | `C] = function - | Thd, v -> `A v | Ttl Thd, v -> `B v | Ttl (Ttl Thd), Noarg -> `C + | Thd, v -> `A v + | Ttl Thd, v -> `B v + | Ttl (Ttl Thd), Noarg -> `C end ) type 'a vlist = [`Nil | `Cons of 'a * 'a vlist] @@ -1453,8 +1460,8 @@ let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = (object method proj = function - | `Nil -> ("Nil", None) - | `Cons p -> ("Cons", Some (Tdyn (tcons, p))) + | `Nil -> ("Nil", None) + | `Cons p -> ("Cons", Some (Tdyn (tcons, p))) method cases = [("Nil", TCnoarg Thd); ("Cons", TCarg (Ttl Thd, tcons))] @@ -1508,7 +1515,8 @@ type (_, _, _) plus = | PlusS : ('a, 'b, 'c) plus -> ('a succ, 'b, 'c succ) plus let rec length : type a n. (a, n) seq -> n nat = function - | Snil -> NZ | Scons (_, s) -> NS (length s) + | Snil -> NZ + | Scons (_, s) -> NS (length s) (* app returns the catenated lists with a witness proving that the size is the sum of its two inputs *) @@ -1685,7 +1693,8 @@ let rec diff : type a b. (a, b) le -> b nat -> (a, b) diff = type (_, _) filter = Filter : ('m, 'n) le * ('a, 'm) seq -> ('a, 'n) filter let rec leS' : type m n. (m, n) le -> (m, n succ) le = function - | LeZ n -> LeZ (NS n) | LeS le -> LeS (leS' le) + | LeZ n -> LeZ (NS n) + | LeS le -> LeS (leS' le) let rec filter : type a n. (a -> bool) -> (a, n) seq -> (a, n) filter = fun f s -> @@ -1869,7 +1878,9 @@ let blacken = function Rnode (l, e, r) -> Bnode (l, e, r) type _ crep = Red : red crep | Black : black crep let color : type c n. (c, n) sub_tree -> c crep = function - | Bleaf -> Black | Rnode _ -> Red | Bnode _ -> Black + | Bleaf -> Black + | Rnode _ -> Red + | Bnode _ -> Black let rec fill : type c n. (c, n) ctxt -> (c, n) sub_tree -> rb_tree = fun ct t -> @@ -2335,7 +2346,8 @@ struct type _ t = One : [`One] t | Two : T.two t let add (type a) : a t * a t -> string = function - | One, One -> "two" | Two, Two -> "four" + | One, One -> "two" + | Two, Two -> "four" end module B : sig @@ -2548,15 +2560,18 @@ type ('a, 'result, 'visit_action) context = let vexpr (type visit_action) : (_, _, visit_action) context -> _ -> visit_action = function - | Local -> fun _ -> raise Exit | Global -> fun _ -> raise Exit + | Local -> fun _ -> raise Exit + | Global -> fun _ -> raise Exit let vexpr (type visit_action) : ('a, 'result, visit_action) context -> 'a -> visit_action = function - | Local -> fun _ -> raise Exit | Global -> fun _ -> raise Exit + | Local -> fun _ -> raise Exit + | Global -> fun _ -> raise Exit let vexpr (type result) (type visit_action) : (unit, result, visit_action) context -> unit -> visit_action = function - | Local -> fun _ -> raise Exit | Global -> fun _ -> raise Exit + | Local -> fun _ -> raise Exit + | Global -> fun _ -> raise Exit module A = struct type nil = Cstr @@ -2624,7 +2639,8 @@ let get1 (Cons (x, _) : (_ * 'a, 'a) t) = x (* warn, cf PR#6993 *) let get1' = function - | (Cons (x, _) : (_ * 'a, 'a) t) -> x | Nil -> assert false + | (Cons (x, _) : (_ * 'a, 'a) t) -> x + | Nil -> assert false (* ok *) type _ t = @@ -2788,7 +2804,8 @@ type (_, _) alist = | Asnoc : ('m, 'n) alist * 'm term * 'm succ fin -> ('m succ, 'n) alist let rec sub : type m n. (m, n) alist -> m fin -> n term = function - | Anil -> var | Asnoc (s, t, x) -> comp_subst (sub s) (subst_var x t) + | Anil -> var + | Asnoc (s, t, x) -> comp_subst (sub s) (subst_var x t) let rec append : type m n l. (m, n) alist -> (l, m) alist -> (l, n) alist = fun r s -> @@ -2800,7 +2817,8 @@ let asnoc a t' x = EAlist (Asnoc (a, t', x)) (* Extra work: we need sub to work on ealist too, for examples *) let rec weaken_fin : type n. n fin -> n succ fin = function - | FZ -> FZ | FS x -> FS (weaken_fin x) + | FZ -> FZ + | FS x -> FS (weaken_fin x) let weaken_term t = pre_subst (fun x -> Var (weaken_fin x)) t @@ -2909,12 +2927,14 @@ let magic : 'a 'b. 'a -> 'b = type _ t = IntLit : int t | BoolLit : bool t let check : type s. s t * s -> bool = function - | BoolLit, false -> false | IntLit, 6 -> false + | BoolLit, false -> false + | IntLit, 6 -> false type ('a, 'b) pair = {fst: 'a; snd: 'b} let check : type s. (s t, s) pair -> bool = function - | {fst= BoolLit; snd= false} -> false | {fst= IntLit; snd= 6} -> false + | {fst= BoolLit; snd= false} -> false + | {fst= IntLit; snd= 6} -> false module type S = sig type t [@@immediate] @@ -3659,35 +3679,37 @@ class ['a] lambda_ops (ops : ('a, 'a) #ops Lazy.t) = method free = function - | #var as x -> var#free x - | `Abs (s, t) -> Names.remove s (!!free t) - | `App (t1, t2) -> Names.union (!!free t1) (!!free t2) + | #var as x -> var#free x + | `Abs (s, t) -> Names.remove s (!!free t) + | `App (t1, t2) -> Names.union (!!free t1) (!!free t2) method map ~f = function - | #var as x -> x - | `Abs (s, t) as l -> - let t' = f t in - if t == t' then l else `Abs (s, t') - | `App (t1, t2) as l -> - let t'1 = f t1 and t'2 = f t2 in - if t'1 == t1 && t'2 == t2 then l else `App (t'1, t'2) + | #var as x -> x + | `Abs (s, t) as l -> + let t' = f t in + if t == t' then l else `Abs (s, t') + | `App (t1, t2) as l -> + let t'1 = f t1 and t'2 = f t2 in + if t'1 == t1 && t'2 == t2 then l else `App (t'1, t'2) method subst ~sub = function - | #var as x -> var#subst ~sub x - | `Abs (s, t) as l -> - let used = !!free t in - let used_expr = - Subst.fold sub ~init:[] ~f:(fun ~key ~data acc -> - if Names.mem s used then data :: acc else acc ) - in - if List.exists used_expr ~f:(fun t -> Names.mem s (!!free t)) then - let name = s ^ string_of_int (next_id ()) in - `Abs - (name, !!subst ~sub:(Subst.add ~key:s ~data:(`Var name) sub) t) - else self#map ~f:(!!subst ~sub:(Subst.remove s sub)) l - | `App _ as l -> self#map ~f:(!!subst ~sub) l + | #var as x -> var#subst ~sub x + | `Abs (s, t) as l -> + let used = !!free t in + let used_expr = + Subst.fold sub ~init:[] ~f:(fun ~key ~data acc -> + if Names.mem s used then data :: acc else acc ) + in + if List.exists used_expr ~f:(fun t -> Names.mem s (!!free t)) + then + let name = s ^ string_of_int (next_id ()) in + `Abs + ( name + , !!subst ~sub:(Subst.add ~key:s ~data:(`Var name) sub) t ) + else self#map ~f:(!!subst ~sub:(Subst.remove s sub)) l + | `App _ as l -> self#map ~f:(!!subst ~sub) l method eval l = match self#map ~f:!!eval l with @@ -3719,30 +3741,30 @@ class ['a] expr_ops (ops : ('a, 'a) #ops Lazy.t) = method free = function - | #var as x -> var#free x - | `Num _ -> Names.empty - | `Add (x, y) -> Names.union (!!free x) (!!free y) - | `Neg x -> !!free x - | `Mult (x, y) -> Names.union (!!free x) (!!free y) + | #var as x -> var#free x + | `Num _ -> Names.empty + | `Add (x, y) -> Names.union (!!free x) (!!free y) + | `Neg x -> !!free x + | `Mult (x, y) -> Names.union (!!free x) (!!free y) method map ~f = function - | #var as x -> x - | `Num _ as x -> x - | `Add (x, y) as e -> - let x' = f x and y' = f y in - if x == x' && y == y' then e else `Add (x', y') - | `Neg x as e -> - let x' = f x in - if x == x' then e else `Neg x' - | `Mult (x, y) as e -> - let x' = f x and y' = f y in - if x == x' && y == y' then e else `Mult (x', y') + | #var as x -> x + | `Num _ as x -> x + | `Add (x, y) as e -> + let x' = f x and y' = f y in + if x == x' && y == y' then e else `Add (x', y') + | `Neg x as e -> + let x' = f x in + if x == x' then e else `Neg x' + | `Mult (x, y) as e -> + let x' = f x and y' = f y in + if x == x' && y == y' then e else `Mult (x', y') method subst ~sub = function - | #var as x -> var#subst ~sub x - | #expr as e -> self#map ~f:(!!subst ~sub) e + | #var as x -> var#subst ~sub x + | #expr as e -> self#map ~f:(!!subst ~sub) e method eval (#expr as e) = match self#map ~f:!!eval e with @@ -3771,7 +3793,8 @@ class ['a] lexpr_ops (ops : ('a, 'a) #ops Lazy.t) = method subst ~sub = function - | #lambda as x -> lambda#subst ~sub x | #expr as x -> expr#subst ~sub x + | #lambda as x -> lambda#subst ~sub x + | #expr as x -> expr#subst ~sub x method eval = function #lambda as x -> lambda#eval x | #expr as x -> expr#eval x @@ -3869,35 +3892,37 @@ let lambda_ops (ops : ('a, 'a) #ops Lazy.t) = object (self : ([> 'a lambda], 'a lambda) #ops) method free = function - | #var as x -> var#free x - | `Abs (s, t) -> Names.remove s (!!free t) - | `App (t1, t2) -> Names.union (!!free t1) (!!free t2) + | #var as x -> var#free x + | `Abs (s, t) -> Names.remove s (!!free t) + | `App (t1, t2) -> Names.union (!!free t1) (!!free t2) method private map ~f = function - | #var as x -> x - | `Abs (s, t) as l -> - let t' = f t in - if t == t' then l else `Abs (s, t') - | `App (t1, t2) as l -> - let t'1 = f t1 and t'2 = f t2 in - if t'1 == t1 && t'2 == t2 then l else `App (t'1, t'2) + | #var as x -> x + | `Abs (s, t) as l -> + let t' = f t in + if t == t' then l else `Abs (s, t') + | `App (t1, t2) as l -> + let t'1 = f t1 and t'2 = f t2 in + if t'1 == t1 && t'2 == t2 then l else `App (t'1, t'2) method subst ~sub = function - | #var as x -> var#subst ~sub x - | `Abs (s, t) as l -> - let used = !!free t in - let used_expr = - Subst.fold sub ~init:[] ~f:(fun ~key ~data acc -> - if Names.mem s used then data :: acc else acc ) - in - if List.exists used_expr ~f:(fun t -> Names.mem s (!!free t)) then - let name = s ^ string_of_int (next_id ()) in - `Abs - (name, !!subst ~sub:(Subst.add ~key:s ~data:(`Var name) sub) t) - else self#map ~f:(!!subst ~sub:(Subst.remove s sub)) l - | `App _ as l -> self#map ~f:(!!subst ~sub) l + | #var as x -> var#subst ~sub x + | `Abs (s, t) as l -> + let used = !!free t in + let used_expr = + Subst.fold sub ~init:[] ~f:(fun ~key ~data acc -> + if Names.mem s used then data :: acc else acc ) + in + if List.exists used_expr ~f:(fun t -> Names.mem s (!!free t)) + then + let name = s ^ string_of_int (next_id ()) in + `Abs + ( name + , !!subst ~sub:(Subst.add ~key:s ~data:(`Var name) sub) t ) + else self#map ~f:(!!subst ~sub:(Subst.remove s sub)) l + | `App _ as l -> self#map ~f:(!!subst ~sub) l method eval l = match self#map ~f:!!eval l with @@ -3926,30 +3951,30 @@ let expr_ops (ops : ('a, 'a) #ops Lazy.t) = object (self : ([> 'a expr], 'a expr) #ops) method free = function - | #var as x -> var#free x - | `Num _ -> Names.empty - | `Add (x, y) -> Names.union (!!free x) (!!free y) - | `Neg x -> !!free x - | `Mult (x, y) -> Names.union (!!free x) (!!free y) + | #var as x -> var#free x + | `Num _ -> Names.empty + | `Add (x, y) -> Names.union (!!free x) (!!free y) + | `Neg x -> !!free x + | `Mult (x, y) -> Names.union (!!free x) (!!free y) method private map ~f = function - | #var as x -> x - | `Num _ as x -> x - | `Add (x, y) as e -> - let x' = f x and y' = f y in - if x == x' && y == y' then e else `Add (x', y') - | `Neg x as e -> - let x' = f x in - if x == x' then e else `Neg x' - | `Mult (x, y) as e -> - let x' = f x and y' = f y in - if x == x' && y == y' then e else `Mult (x', y') + | #var as x -> x + | `Num _ as x -> x + | `Add (x, y) as e -> + let x' = f x and y' = f y in + if x == x' && y == y' then e else `Add (x', y') + | `Neg x as e -> + let x' = f x in + if x == x' then e else `Neg x' + | `Mult (x, y) as e -> + let x' = f x and y' = f y in + if x == x' && y == y' then e else `Mult (x', y') method subst ~sub = function - | #var as x -> var#subst ~sub x - | #expr as e -> self#map ~f:(!!subst ~sub) e + | #var as x -> var#subst ~sub x + | #expr as e -> self#map ~f:(!!subst ~sub) e method eval (#expr as e) = match self#map ~f:!!eval e with @@ -3976,7 +4001,8 @@ let lexpr_ops (ops : ('a, 'a) #ops Lazy.t) = method subst ~sub = function - | #lambda as x -> lambda#subst ~sub x | #expr as x -> expr#subst ~sub x + | #lambda as x -> lambda#subst ~sub x + | #expr as x -> expr#subst ~sub x method eval = function #lambda as x -> lambda#eval x | #expr as x -> expr#eval x @@ -5969,15 +5995,15 @@ class virtual ['a, 'cursor] storage_base = method fold : 'b. ('a -> int -> 'b -> 'b) -> 'b -> 'b = fun f a0 -> - let cur = self#first in - let rec loop count a = - if count >= self#len then a - else - let a' = f cur#get count a in - cur#incr () ; - loop (count + 1) a' - in - loop 0 a0 + let cur = self#first in + let rec loop count a = + if count >= self#len then a + else + let a' = f cur#get count a in + cur#incr () ; + loop (count + 1) a' + in + loop 0 a0 method iter proc = let p = self#first in @@ -6384,7 +6410,9 @@ module Fpc (X : T with type term = private [> 'a termpc] as 'a) = struct type term = X.term termpc let nnf = function - | `Not (`Atom _) as x -> x | `Not x -> X.nnf_not x | x -> X.map X.nnf x + | `Not (`Atom _) as x -> x + | `Not x -> X.nnf_not x + | x -> X.map X.nnf x let map f : term -> X.term = function | `Not x -> `Not (f x) @@ -7430,7 +7458,8 @@ struct let findMin = function E -> raise Not_found | T (_, x, _, _) -> x let deleteMin = function - | E -> raise Not_found | T (_, x, a, b) -> merge a b + | E -> raise Not_found + | T (_, x, a, b) -> merge a b end module Ints = struct @@ -8374,7 +8403,8 @@ let f : type a b c d e f g. * (a, b, c, d) u * (e, f, g, g) u -> int = function - | A, A, A, A, A, A, A, _, U, U -> 1 | _, _, _, _, _, _, _, G, _, _ -> 1 + | A, A, A, A, A, A, A, _, U, U -> 1 + | _, _, _, _, _, _, _, G, _, _ -> 1 (*| _ -> _ *) (* Unused cases *) @@ -8452,7 +8482,8 @@ let harder : (zero succ, zero succ, zero succ) plus option -> bool = function | None -> false let harder : (zero succ, zero succ, zero succ) plus option -> bool = function - | None -> false | Some (PlusS _) -> . + | None -> false + | Some (PlusS _) -> . let inv_zero : type a b c d. (a, b, c) plus -> (c, d, zero) plus -> bool = fun p1 p2 -> match (p1, p2) with Plus0, Plus0 -> true @@ -8928,10 +8959,15 @@ let f = function (x [@wee]) -> () let f = function '1' .. '9' | '1' .. '8' -> () | 'a' .. 'z' -> () let f = function - | [|x1; x2|] -> () | [||] -> () | ([|x|] [@foo]) -> () | _ -> () + | [|x1; x2|] -> () + | [||] -> () + | ([|x|] [@foo]) -> () + | _ -> () let g = function - | {l= x} -> () | ({l1= x; l2= y} [@foo]) -> () | {l1= x; l2= y; _} -> () + | {l= x} -> () + | ({l1= x; l2= y} [@foo]) -> () + | {l1= x; l2= y; _} -> () let h = fun ?l:(p = 1) ?y:u ?(x = 3) -> 2 @@ -9134,8 +9170,7 @@ f (fun _ -> function | true -> let () = () in - () - | false -> () ) + () | false -> () ) () ;; @@ -9143,9 +9178,7 @@ f (fun _ -> function | true -> let () = () in - () - (* comment *) - | false -> () ) + () (* comment *) | false -> () ) () let xxxxxx = From 402ef9308991eb5014ee335691b00e3e59886b3b Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Wed, 24 Jul 2024 13:55:52 +0200 Subject: [PATCH 062/146] fix disambiguate-non-breaking-match --- lib/Fmt_ast.ml | 30 ++++++++++++++++++++---------- test/passing/tests/disambiguate.ml | 4 ++-- 2 files changed, 22 insertions(+), 12 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index fae2337cb6..1f05fe4029 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1507,22 +1507,31 @@ and fmt_function ?force_closing_paren ~ctx ~ctx0 ~wrap_intro ?box:(should_box = in (fun_ $ function_, (fmt_cases c ctx cs), box, 0) in - (* TODO: Disambiguating parentheses in case of one-liner 'function'. - See 'Params.Exp.wrap c.conf ~parens ~disambiguate:true' *) let opn_paren, cls_paren = if parens then str "(", closing_paren c ?force:force_closing_paren ~offset:closing_paren_offset else noop, noop in + (* When the option disambiguate_non_breaking_match is set, if the function + fits on one line it has to have parens. [fit_breaks] is used for that. It + cannot be used directly with [opn_paren] because its deep inside other boxes + that will not be broken. Because of this we wrap the whole with another pair + of parens, although only if the regular one are absent. *) + let disambiguate_parens_wrap = + if not parens && c.conf.fmt_opts.disambiguate_non_breaking_match.v then + wrap (fits_breaks "(" "") (fits_breaks ")" "") + else Fn.id + in let box k = if should_box then box k else k in box - ( wrap_intro - (hvbox_if has_cmts_outer 0 - ( cmts_outer - $ hvbox 2 - ( fmt_label label label_sep $ cmts_inner - $ opn_paren - $ head ) ) ) - $ body $ cls_paren + ( disambiguate_parens_wrap + ( wrap_intro + (hvbox_if has_cmts_outer 0 + ( cmts_outer + $ hvbox 2 + ( fmt_label label label_sep $ cmts_inner + $ opn_paren + $ head ) ) ) + $ body $ cls_paren ) $ Cmts.fmt_after c loc ) and fmt_label_arg ?(box = true) ?eol c (lbl, ({ast= arg; _} as xarg)) = @@ -2183,6 +2192,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens $ cut_break $ str "." $ fmt_longident_loc c lid $ fmt_atrs ) ) | Pexp_function (args, typ, body) -> let wrap_intro intro = hovbox 2 (pro $ intro) $ space_break in + fmt_function ~wrap_intro ~box ~ctx ~ctx0 ~label:Nolabel ~parens ?ext ~attrs:pexp_attributes ~loc:pexp_loc c (args, typ, body) | Pexp_ident {txt; loc} -> diff --git a/test/passing/tests/disambiguate.ml b/test/passing/tests/disambiguate.ml index a6c1e619bd..ee5b98f238 100644 --- a/test/passing/tests/disambiguate.ml +++ b/test/passing/tests/disambiguate.ml @@ -1,13 +1,13 @@ [@@@ocamlformat "disambiguate-non-breaking-match"] -let () = r := fun () -> f () ; g () +let () = r := (fun () -> f () ; g ()) let () = r := fun () -> f () ; g () ; g () ; g () ; g () ; g () ; g () ; g () ; g () ; g () -let () = r := function () -> f () ; g () +let () = r := (function () -> f () ; g ()) let () = r := From 4ac8bf11017751af704cbb128c5b312cb70a1a46 Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Wed, 24 Jul 2024 17:01:33 +0200 Subject: [PATCH 063/146] fix parens space in match2 --- lib/Fmt_ast.ml | 27 +++++++++++++++++++++------ test/passing/tests/match2.ml | 6 +++--- 2 files changed, 24 insertions(+), 9 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 1f05fe4029..c199b023a5 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -161,11 +161,13 @@ let box_fun_sig_args c = | `Fit_or_vertical -> hvbox | `Wrap | `Smart -> hovbox -let closing_paren ?force ?(offset = 0) c = - match c.conf.fmt_opts.indicate_multiline_delimiters.v with - | `No -> str ")" - | `Space -> fits_breaks ")" " )" ?force - | `Closing_on_separate_line -> fits_breaks ")" ")" ~hint:(1000, offset) +let closing_paren ?(force_space=false) ?force ?(offset = 0) c = + if force_space then str " )" + else + match c.conf.fmt_opts.indicate_multiline_delimiters.v with + | `No -> str ")" + | `Space -> fits_breaks ")" " )" ?force + | `Closing_on_separate_line -> fits_breaks ")" ")" ~hint:(1000, offset) let maybe_disabled_k c (loc : Location.t) (l : attributes) f k = if not c.conf.opr_opts.disable.v then f c @@ -1476,6 +1478,9 @@ and fmt_function ?force_closing_paren ~ctx ~ctx0 ~wrap_intro ?box:(should_box = Params.Exp.box_fun_decl_args ~ctx:ctx0 c.conf ~parens ~kw ~args ~annot $ Params.Exp.break_fun_decl_args ~ctx:ctx0 $ str "->" in + let lead_with_function_kw = + match args, body with | [], Pfunction_cases _ -> true | _ -> false + in (* [head] is [fun args ->] or [function]. [body] is an expression or the cases. *) let head, body, box, closing_paren_offset = @@ -1507,10 +1512,20 @@ and fmt_function ?force_closing_paren ~ctx ~ctx0 ~wrap_intro ?box:(should_box = in (fun_ $ function_, (fmt_cases c ctx cs), box, 0) in + let space_opn_parens, space_cls_parens = + match ctx0 with + | Exp ({pexp_desc=Pexp_infix _; _}) + when lead_with_function_kw && not c.conf.fmt_opts.break_infix_before_func.v -> + str " ", true + | _ -> noop,false + in let opn_paren, cls_paren = - if parens then str "(", closing_paren c ?force:force_closing_paren ~offset:closing_paren_offset + if parens then + ( str "(" $ space_opn_parens + , closing_paren c ~force_space:space_cls_parens ?force:force_closing_paren ~offset:closing_paren_offset) else noop, noop in + (* When the option disambiguate_non_breaking_match is set, if the function fits on one line it has to have parens. [fit_breaks] is used for that. It cannot be used directly with [opn_paren] because its deep inside other boxes diff --git a/test/passing/tests/match2.ml b/test/passing/tests/match2.ml index 90d5091693..2db48608f0 100644 --- a/test/passing/tests/match2.ml +++ b/test/passing/tests/match2.ml @@ -55,17 +55,17 @@ let _ = match x with _ -> b >>= fun () -> c [@@@ocamlformat "break-infix-before-func=false"] -let foo = match foo with 1 -> bar >>= (function _ -> ()) | other -> () +let foo = match foo with 1 -> bar >>= ( function _ -> () ) | other -> () let foo = match foo with - | 1 -> bar >>= (function a -> fooooo | b -> fooooo | _ -> ()) + | 1 -> bar >>= ( function a -> fooooo | b -> fooooo | _ -> () ) | other -> () let foo = match foo with | 1 -> - bar >>= (function + bar >>= ( function | a -> fooooo | b -> fooooo | c -> foooooooo foooooooooo fooooooooooooooooooo () From a8b5ab741245bbbadd1afbfb68e3936bc1bca0f9 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 22 Jul 2024 14:16:35 +0200 Subject: [PATCH 064/146] Safer box_fun_expr --- lib/Params.ml | 45 +++++++++++++++++++++++++++------------------ 1 file changed, 27 insertions(+), 18 deletions(-) diff --git a/lib/Params.ml b/lib/Params.ml index 9e14043678..03a399b6d3 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -26,14 +26,28 @@ let is_labelled_arg args exp = | Labelled _, x | Optional _, x -> phys_equal x exp ) args +(** Whether [exp] occurs in [args] as a labelled argument. *) +let is_unlabelled_arg args exp = + List.exists + ~f:(function + | Nolabel, x -> phys_equal x exp + | Labelled _, _ | Optional _, _ -> false ) + args + let ctx_is_infix = function -| Exp { pexp_desc= Pexp_infix ({txt= ":="; _}, _, _); _ } -> false - | Exp { pexp_desc= Pexp_infix _; _ } -> true - | _ -> false + | Exp {pexp_desc= Pexp_infix ({txt= ":="; _}, _, _); _} -> false + | Exp {pexp_desc= Pexp_infix _; _} -> true + | _ -> false let ctx_is_apply = function - | Exp { pexp_desc= Pexp_apply _; _ } -> true - | _ -> false + | Exp {pexp_desc= Pexp_apply _; _} -> true + | _ -> false + +let ctx_is_apply_and_exp_is_arg ~ctx ctx0 = + match (ctx, ctx0) with + | Exp exp, Exp {pexp_desc= Pexp_apply (_, args); _} -> + is_unlabelled_arg args exp + | _ -> false (** [ctx_is_let ~ctx ctx0] checks whether [ctx0] is a let binding containing [ctx]. *) @@ -119,26 +133,21 @@ module Exp = struct in box_decl (kw $ hvbox_if should_box_args 0 args $ fmt_opt annot) - let box_fun_expr (c: Conf.t) ~ctx0 ~ctx ~parens:_ ~has_label = + let box_fun_expr (c : Conf.t) ~ctx0 ~ctx ~parens:_ ~has_label = let indent = - if ctx_is_infix ctx0 then ( - if ocp c && has_label then 2 - else 0 ) + if ctx_is_infix ctx0 then if ocp c && has_label then 2 else 0 else match c.fmt_opts.function_indent_nested.v with | `Always -> c.fmt_opts.function_indent.v | _ -> if ctx_is_let ~ctx ctx0 then - if c.fmt_opts.let_binding_deindent_fun.v then 1 - else 0 - else if ocp c && ctx_is_apply ctx0 && not has_label then 4 - else if ocp c then 2 - else - 4 in + if c.fmt_opts.let_binding_deindent_fun.v then 1 else 0 + else if ocp c then + if ctx_is_apply_and_exp_is_arg ~ctx ctx0 then 4 else 2 + else 4 + in let name = "Params.box_fun_expr" in - ( match ctx0 with - | Str _ -> hvbox ~name indent - | _ -> hovbox ~name indent) + match ctx0 with Str _ -> hvbox ~name indent | _ -> hovbox ~name indent (* if the function is the last argument of an apply and no other arguments are "complex" (approximation). *) From b09e7ca31592043c15fd4baae8b3089a849b4e94 Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Thu, 25 Jul 2024 15:38:45 +0200 Subject: [PATCH 065/146] fix beginend --- lib/Params.ml | 5 +++++ test/passing/tests/attributes.ml | 4 +--- test/passing/tests/exp_grouping.ml.ref | 10 +++++----- 3 files changed, 11 insertions(+), 8 deletions(-) diff --git a/lib/Params.ml b/lib/Params.ml index 03a399b6d3..bcd6a8983a 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -43,6 +43,10 @@ let ctx_is_apply = function | Exp {pexp_desc= Pexp_apply _; _} -> true | _ -> false +let ctx_is_beginend = function +| Exp {pexp_desc= Pexp_beginend _; _} -> true +| _ -> false + let ctx_is_apply_and_exp_is_arg ~ctx ctx0 = match (ctx, ctx0) with | Exp exp, Exp {pexp_desc= Pexp_apply (_, args); _} -> @@ -136,6 +140,7 @@ module Exp = struct let box_fun_expr (c : Conf.t) ~ctx0 ~ctx ~parens:_ ~has_label = let indent = if ctx_is_infix ctx0 then if ocp c && has_label then 2 else 0 + else if ctx_is_beginend ctx0 then 2 else match c.fmt_opts.function_indent_nested.v with | `Always -> c.fmt_opts.function_indent.v diff --git a/test/passing/tests/attributes.ml b/test/passing/tests/attributes.ml index bd43ab429a..5232127915 100644 --- a/test/passing/tests/attributes.ml +++ b/test/passing/tests/attributes.ml @@ -449,9 +449,7 @@ let () = @@ S.tok begin [@warning "-4"] fun ev -> - match ev with - | Cbor_event.Reserved int -> Some int - | _ -> None + match ev with Cbor_event.Reserved int -> Some int | _ -> None end in () diff --git a/test/passing/tests/exp_grouping.ml.ref b/test/passing/tests/exp_grouping.ml.ref index 32a071cb27..1cf112ff77 100644 --- a/test/passing/tests/exp_grouping.ml.ref +++ b/test/passing/tests/exp_grouping.ml.ref @@ -18,11 +18,11 @@ let () = List.iter begin fun v -> - (* do a lot of things *) - let a = "a" in - let b = "b" in - let c = "c" in - () + (* do a lot of things *) + let a = "a" in + let b = "b" in + let c = "c" in + () end values From 559847201f868aa6eea429f2c720a349288b2b60 Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Thu, 25 Jul 2024 16:11:08 +0200 Subject: [PATCH 066/146] fix indent of funs that are not args --- test/passing/tests/break_cases-align.ml.ref | 20 +++++----- test/passing/tests/break_cases-all.ml.ref | 20 +++++----- ...reak_cases-closing_on_separate_line.ml.ref | 24 +++++------ ...ng_on_separate_line_fit_or_vertical.ml.ref | 20 +++++----- ...te_line_leading_nested_match_parens.ml.ref | 24 +++++------ .../tests/break_cases-cosl_lnmp_cmei.ml.ref | 24 +++++------ .../tests/break_cases-fit_or_vertical.ml.ref | 16 ++++---- test/passing/tests/break_cases-nested.ml.ref | 10 ++--- .../tests/break_cases-normal_indent.ml.ref | 20 +++++----- .../passing/tests/break_cases-toplevel.ml.ref | 16 ++++---- .../passing/tests/break_cases-vertical.ml.ref | 26 ++++++------ test/passing/tests/break_cases.ml.ref | 8 ++-- test/passing/tests/disambiguate.ml | 2 +- test/passing/tests/fun_decl.ml | 40 +++++++++---------- test/passing/tests/ite-kw_first.ml.ref | 4 +- .../passing/tests/ite-kw_first_closing.ml.ref | 4 +- .../tests/ite-kw_first_no_indicate.ml.ref | 4 +- test/passing/tests/ite-vertical.ml.ref | 4 +- test/passing/tests/object.ml.ref | 8 ++-- test/passing/tests/source.ml.err | 1 - test/passing/tests/source.ml.ref | 24 +++++------ 21 files changed, 159 insertions(+), 160 deletions(-) diff --git a/test/passing/tests/break_cases-align.ml.ref b/test/passing/tests/break_cases-align.ml.ref index cc1c13db5e..c44ab7cdc0 100644 --- a/test/passing/tests/break_cases-align.ml.ref +++ b/test/passing/tests/break_cases-align.ml.ref @@ -18,16 +18,16 @@ let f = 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z - |P - |M -> - match y with - | O -> 5 - | P when h x -> ( - function - | A -> 6 ) + match x with + | E -> 4 + | Z + |P + |M -> + match y with + | O -> 5 + | P when h x -> ( + function + | A -> 6 ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-all.ml.ref b/test/passing/tests/break_cases-all.ml.ref index 97f61b0f7e..9fba453aa1 100644 --- a/test/passing/tests/break_cases-all.ml.ref +++ b/test/passing/tests/break_cases-all.ml.ref @@ -18,16 +18,16 @@ let f = 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z - |P - |M -> ( - match y with - | O -> 5 - | P when h x -> ( - function - | A -> 6 ) ) + match x with + | E -> 4 + | Z + |P + |M -> ( + match y with + | O -> 5 + | P when h x -> ( + function + | A -> 6 ) ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-closing_on_separate_line.ml.ref b/test/passing/tests/break_cases-closing_on_separate_line.ml.ref index 9ad2ce13d1..4cd44edf32 100644 --- a/test/passing/tests/break_cases-closing_on_separate_line.ml.ref +++ b/test/passing/tests/break_cases-closing_on_separate_line.ml.ref @@ -18,18 +18,18 @@ let f = 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z - |P - |M -> ( - match y with - | O -> 5 - | P when h x -> ( - function - | A -> 6 - ) - ) + match x with + | E -> 4 + | Z + |P + |M -> ( + match y with + | O -> 5 + | P when h x -> ( + function + | A -> 6 + ) + ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-closing_on_separate_line_fit_or_vertical.ml.ref b/test/passing/tests/break_cases-closing_on_separate_line_fit_or_vertical.ml.ref index a46970e3ca..785eb32a0e 100644 --- a/test/passing/tests/break_cases-closing_on_separate_line_fit_or_vertical.ml.ref +++ b/test/passing/tests/break_cases-closing_on_separate_line_fit_or_vertical.ml.ref @@ -12,16 +12,16 @@ let f = | T | P | U -> 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z | P | M -> ( - match y with - | O -> 5 - | P when h x -> ( - function - | A -> 6 - ) - ) + match x with + | E -> 4 + | Z | P | M -> ( + match y with + | O -> 5 + | P when h x -> ( + function + | A -> 6 + ) + ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-closing_on_separate_line_leading_nested_match_parens.ml.ref b/test/passing/tests/break_cases-closing_on_separate_line_leading_nested_match_parens.ml.ref index 27ceaf0d75..4d1e4f97ce 100644 --- a/test/passing/tests/break_cases-closing_on_separate_line_leading_nested_match_parens.ml.ref +++ b/test/passing/tests/break_cases-closing_on_separate_line_leading_nested_match_parens.ml.ref @@ -18,18 +18,18 @@ let f = 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z - |P - |M -> - ( match y with - | O -> 5 - | P when h x -> - (function - | A -> 6 - ) - ) + match x with + | E -> 4 + | Z + |P + |M -> + ( match y with + | O -> 5 + | P when h x -> + (function + | A -> 6 + ) + ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-cosl_lnmp_cmei.ml.ref b/test/passing/tests/break_cases-cosl_lnmp_cmei.ml.ref index f668e17ddb..2638a869bf 100644 --- a/test/passing/tests/break_cases-cosl_lnmp_cmei.ml.ref +++ b/test/passing/tests/break_cases-cosl_lnmp_cmei.ml.ref @@ -18,18 +18,18 @@ let f = 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z - |P - |M -> - ( match y with - | O -> 5 - | P when h x -> - (function - | A -> 6 - ) - ) + match x with + | E -> 4 + | Z + |P + |M -> + ( match y with + | O -> 5 + | P when h x -> + (function + | A -> 6 + ) + ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-fit_or_vertical.ml.ref b/test/passing/tests/break_cases-fit_or_vertical.ml.ref index d24959f06b..984d52607a 100644 --- a/test/passing/tests/break_cases-fit_or_vertical.ml.ref +++ b/test/passing/tests/break_cases-fit_or_vertical.ml.ref @@ -12,14 +12,14 @@ let f = | T | P | U -> 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z | P | M -> ( - match y with - | O -> 5 - | P when h x -> ( - function - | A -> 6 ) ) + match x with + | E -> 4 + | Z | P | M -> ( + match y with + | O -> 5 + | P when h x -> ( + function + | A -> 6 ) ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-nested.ml.ref b/test/passing/tests/break_cases-nested.ml.ref index 32f4743310..734740ce22 100644 --- a/test/passing/tests/break_cases-nested.ml.ref +++ b/test/passing/tests/break_cases-nested.ml.ref @@ -10,11 +10,11 @@ let f x = function let f = let g = function H when x y <> k -> 2 | T | P | U -> 3 in fun x g t h y u -> - match x with - | E -> - 4 - | Z | P | M -> ( - match y with O -> 5 | P when h x -> ( function A -> 6 ) ) + match x with + | E -> + 4 + | Z | P | M -> ( + match y with O -> 5 | P when h x -> ( function A -> 6 ) ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-normal_indent.ml.ref b/test/passing/tests/break_cases-normal_indent.ml.ref index 86fca7e929..eef84feda8 100644 --- a/test/passing/tests/break_cases-normal_indent.ml.ref +++ b/test/passing/tests/break_cases-normal_indent.ml.ref @@ -18,16 +18,16 @@ let f = 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z - |P - |M -> ( - match y with - | O -> 5 - | P when h x -> ( - function - | A -> 6 ) ) + match x with + | E -> 4 + | Z + |P + |M -> ( + match y with + | O -> 5 + | P when h x -> ( + function + | A -> 6 ) ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-toplevel.ml.ref b/test/passing/tests/break_cases-toplevel.ml.ref index 2d8828ee9a..2aa64cdd7e 100644 --- a/test/passing/tests/break_cases-toplevel.ml.ref +++ b/test/passing/tests/break_cases-toplevel.ml.ref @@ -13,14 +13,14 @@ let f = | T | P | U -> 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z | P | M -> ( - match y with - | O -> 5 - | P when h x -> ( - function - | A -> 6 ) ) + match x with + | E -> 4 + | Z | P | M -> ( + match y with + | O -> 5 + | P when h x -> ( + function + | A -> 6 ) ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-vertical.ml.ref b/test/passing/tests/break_cases-vertical.ml.ref index 2bba9fc079..d81829d49e 100644 --- a/test/passing/tests/break_cases-vertical.ml.ref +++ b/test/passing/tests/break_cases-vertical.ml.ref @@ -19,19 +19,19 @@ let f = 3 in fun x g t h y u -> - match x with - | E -> - 4 - | Z - |P - |M -> ( - match y with - | O -> - 5 - | P when h x -> ( - function - | A -> - 6 ) ) + match x with + | E -> + 4 + | Z + |P + |M -> ( + match y with + | O -> + 5 + | P when h x -> ( + function + | A -> + 6 ) ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases.ml.ref b/test/passing/tests/break_cases.ml.ref index f7c8dffad6..438f267754 100644 --- a/test/passing/tests/break_cases.ml.ref +++ b/test/passing/tests/break_cases.ml.ref @@ -10,10 +10,10 @@ let f x = function let f = let g = function H when x y <> k -> 2 | T | P | U -> 3 in fun x g t h y u -> - match x with - | E -> 4 - | Z | P | M -> ( - match y with O -> 5 | P when h x -> ( function A -> 6 ) ) + match x with + | E -> 4 + | Z | P | M -> ( + match y with O -> 5 | P when h x -> ( function A -> 6 ) ) let foo = List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/disambiguate.ml b/test/passing/tests/disambiguate.ml index ee5b98f238..4b401e4013 100644 --- a/test/passing/tests/disambiguate.ml +++ b/test/passing/tests/disambiguate.ml @@ -5,7 +5,7 @@ let () = r := (fun () -> f () ; g ()) let () = r := fun () -> - f () ; g () ; g () ; g () ; g () ; g () ; g () ; g () ; g () ; g () + f () ; g () ; g () ; g () ; g () ; g () ; g () ; g () ; g () ; g () let () = r := (function () -> f () ; g ()) diff --git a/test/passing/tests/fun_decl.ml b/test/passing/tests/fun_decl.ml index 72dca43b79..189f52e6ae 100644 --- a/test/passing/tests/fun_decl.ml +++ b/test/passing/tests/fun_decl.ml @@ -19,18 +19,18 @@ let _ = let to_loc_trace ?(desc_of_source = fun source -> - let callsite = Source.call_site source in - Format.asprintf - "return from %a" - Typ.Procname.pp - (CallSite.pname callsite)) ?(source_should_nest = fun _ -> true) + let callsite = Source.call_site source in + Format.asprintf + "return from %a" + Typ.Procname.pp + (CallSite.pname callsite)) ?(source_should_nest = fun _ -> true) ?(desc_of_sink = fun sink -> - let callsite = Sink.call_site sink in - Format.asprintf - "call to %a" - Typ.Procname.pp - (CallSite.pname callsite)) ?(sink_should_nest = fun _ -> true) + let callsite = Sink.call_site sink in + Format.asprintf + "call to %a" + Typ.Procname.pp + (CallSite.pname callsite)) ?(sink_should_nest = fun _ -> true) (passthroughs, sources, sinks) = () @@ -46,14 +46,14 @@ let translate_captured let to_loc_trace ?(desc_of_source = fun source -> - let callsite = Source.call_site source in - Format.asprintf "return from %a" Typ.Procname.pp - (CallSite.pname callsite)) ?(source_should_nest = fun _ -> true) + let callsite = Source.call_site source in + Format.asprintf "return from %a" Typ.Procname.pp + (CallSite.pname callsite)) ?(source_should_nest = fun _ -> true) ?(desc_of_sink = fun sink -> - let callsite = Sink.call_site sink in - Format.asprintf "call to %a" Typ.Procname.pp - (CallSite.pname callsite)) ?(sink_should_nest = fun _ -> true) + let callsite = Sink.call_site sink in + Format.asprintf "call to %a" Typ.Procname.pp + (CallSite.pname callsite)) ?(sink_should_nest = fun _ -> true) (passthroughs, sources, sinks) = () @@ -74,12 +74,12 @@ let f ssssssssss = let f _ = let foooooooooooooooooooooooooooo = foooooooooooooooooooooooooooo in fun x -> - let foooooooooooooooooooooooooooo = foooooooooooooooooooooooooooo in - x + let foooooooooooooooooooooooooooo = foooooooooooooooooooooooooooo in + x let f _ = let foooooooooooooooooooooooooooo = foooooooooooooooooooooooooooo in (* foo *) fun x -> - let foooooooooooooooooooooooooooo = foooooooooooooooooooooooooooo in - x + let foooooooooooooooooooooooooooo = foooooooooooooooooooooooooooo in + x diff --git a/test/passing/tests/ite-kw_first.ml.ref b/test/passing/tests/ite-kw_first.ml.ref index 288051d2f5..a95a92faad 100644 --- a/test/passing/tests/ite-kw_first.ml.ref +++ b/test/passing/tests/ite-kw_first.ml.ref @@ -159,10 +159,10 @@ let _ = if x then fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz else fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz let _ = if diff --git a/test/passing/tests/ite-kw_first_closing.ml.ref b/test/passing/tests/ite-kw_first_closing.ml.ref index e25ec25996..9b6a5de915 100644 --- a/test/passing/tests/ite-kw_first_closing.ml.ref +++ b/test/passing/tests/ite-kw_first_closing.ml.ref @@ -174,10 +174,10 @@ let _ = if x then fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz else fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz let _ = if diff --git a/test/passing/tests/ite-kw_first_no_indicate.ml.ref b/test/passing/tests/ite-kw_first_no_indicate.ml.ref index 30b261f1c9..35c906e623 100644 --- a/test/passing/tests/ite-kw_first_no_indicate.ml.ref +++ b/test/passing/tests/ite-kw_first_no_indicate.ml.ref @@ -158,10 +158,10 @@ let _ = if x then fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz else fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz let _ = if diff --git a/test/passing/tests/ite-vertical.ml.ref b/test/passing/tests/ite-vertical.ml.ref index 6f8fdf5880..62def39502 100644 --- a/test/passing/tests/ite-vertical.ml.ref +++ b/test/passing/tests/ite-vertical.ml.ref @@ -195,10 +195,10 @@ let _ = let _ = if x then fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz else fun xxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz -> - xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz + xxxxxxxxx yyyyyyyyyy zzzzzzzzzzzz let _ = if diff --git a/test/passing/tests/object.ml.ref b/test/passing/tests/object.ml.ref index 9e2ba89157..5b7184fdcb 100644 --- a/test/passing/tests/object.ml.ref +++ b/test/passing/tests/object.ml.ref @@ -219,7 +219,7 @@ let o = -> bool tttttttttttttttt rrrrrrrrrrrrrrrrrrrrr rrrrrrrrrrrrrrrrrrrrr rrrrrrrrrrrrrrrrrrrrrrr = fun (a, op, b) -> - Int_bin_comparison (self#expression a, op, self#expression b) + Int_bin_comparison (self#expression a, op, self#expression b) end class f = fun [@inline] (b [@inline]) -> object end @@ -299,9 +299,9 @@ class a x = object (self) end let x = fun [@foo] x -> fun [@foo] y -> - object - method x = y - end + object + method x = y + end class x = fun [@foo] x -> diff --git a/test/passing/tests/source.ml.err b/test/passing/tests/source.ml.err index 68ebdc8223..171999d3fd 100644 --- a/test/passing/tests/source.ml.err +++ b/test/passing/tests/source.ml.err @@ -1,3 +1,2 @@ Warning: tests/source.ml:703 exceeds the margin -Warning: tests/source.ml:1351 exceeds the margin Warning: tests/source.ml:2319 exceeds the margin diff --git a/test/passing/tests/source.ml.ref b/test/passing/tests/source.ml.ref index 45ab9a907b..5ac6cc7004 100644 --- a/test/passing/tests/source.ml.ref +++ b/test/passing/tests/source.ml.ref @@ -1348,9 +1348,9 @@ let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = ; sum_cases= [("Nil", TCnoarg Thd); ("Cons", TCarg (Ttl Thd, tcons))] ; sum_inj= (fun (type c) -> - ( function Thd, Noarg -> `Nil | Ttl Thd, v -> `Cons v - : (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist ) ) - (* One can also write the type annotation directly *) } ) + ( function Thd, Noarg -> `Nil | Ttl Thd, v -> `Cons v + : (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist ) ) + (* One can also write the type annotation directly *) } ) let v = variantize Enil (ty_list Int) (`Cons (1, `Cons (2, `Nil))) @@ -5995,15 +5995,15 @@ class virtual ['a, 'cursor] storage_base = method fold : 'b. ('a -> int -> 'b -> 'b) -> 'b -> 'b = fun f a0 -> - let cur = self#first in - let rec loop count a = - if count >= self#len then a - else - let a' = f cur#get count a in - cur#incr () ; - loop (count + 1) a' - in - loop 0 a0 + let cur = self#first in + let rec loop count a = + if count >= self#len then a + else + let a' = f cur#get count a in + cur#incr () ; + loop (count + 1) a' + in + loop 0 a0 method iter proc = let p = self#first in From 69ed0c1fa48ed5cbcceb156e74fb03c3176b7153 Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Thu, 25 Jul 2024 16:11:26 +0200 Subject: [PATCH 067/146] to fixup with previous --- lib/Params.ml | 22 ++++++++++++++++++---- 1 file changed, 18 insertions(+), 4 deletions(-) diff --git a/lib/Params.ml b/lib/Params.ml index bcd6a8983a..74e9b14936 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -34,6 +34,13 @@ let is_unlabelled_arg args exp = | Labelled _, _ | Optional _, _ -> false ) args +let is_arg args exp = + List.exists + ~f:(function + | Nolabel, x -> phys_equal x exp + | Labelled _, x | Optional _, x -> phys_equal x exp ) + args + let ctx_is_infix = function | Exp {pexp_desc= Pexp_infix ({txt= ":="; _}, _, _); _} -> false | Exp {pexp_desc= Pexp_infix _; _} -> true @@ -47,12 +54,18 @@ let ctx_is_beginend = function | Exp {pexp_desc= Pexp_beginend _; _} -> true | _ -> false -let ctx_is_apply_and_exp_is_arg ~ctx ctx0 = +let ctx_is_apply_and_exp_is_unlabelled_arg ~ctx ctx0 = match (ctx, ctx0) with | Exp exp, Exp {pexp_desc= Pexp_apply (_, args); _} -> is_unlabelled_arg args exp | _ -> false + let ctx_is_apply_and_exp_is_arg ~ctx ctx0 = + match (ctx, ctx0) with + | Exp exp, Exp {pexp_desc= Pexp_apply (_, args); _} -> + is_arg args exp + | _ -> false + (** [ctx_is_let ~ctx ctx0] checks whether [ctx0] is a let binding containing [ctx]. *) let ctx_is_let ~ctx = function @@ -140,7 +153,7 @@ module Exp = struct let box_fun_expr (c : Conf.t) ~ctx0 ~ctx ~parens:_ ~has_label = let indent = if ctx_is_infix ctx0 then if ocp c && has_label then 2 else 0 - else if ctx_is_beginend ctx0 then 2 + else if ctx_is_beginend ctx0 then 2 else match c.fmt_opts.function_indent_nested.v with | `Always -> c.fmt_opts.function_indent.v @@ -148,8 +161,9 @@ module Exp = struct if ctx_is_let ~ctx ctx0 then if c.fmt_opts.let_binding_deindent_fun.v then 1 else 0 else if ocp c then - if ctx_is_apply_and_exp_is_arg ~ctx ctx0 then 4 else 2 - else 4 + if ctx_is_apply_and_exp_is_unlabelled_arg ~ctx ctx0 then 4 else 2 + else if ctx_is_apply_and_exp_is_arg ~ctx ctx0 then 4 + else 2 in let name = "Params.box_fun_expr" in match ctx0 with Str _ -> hvbox ~name indent | _ -> hovbox ~name indent From 019ac6031da3cec77cc64ee5a706a992ba9cc32c Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Thu, 25 Jul 2024 16:16:23 +0200 Subject: [PATCH 068/146] cleanup useless clause --- lib/Params.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/lib/Params.ml b/lib/Params.ml index 74e9b14936..212940f4c1 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -153,7 +153,6 @@ module Exp = struct let box_fun_expr (c : Conf.t) ~ctx0 ~ctx ~parens:_ ~has_label = let indent = if ctx_is_infix ctx0 then if ocp c && has_label then 2 else 0 - else if ctx_is_beginend ctx0 then 2 else match c.fmt_opts.function_indent_nested.v with | `Always -> c.fmt_opts.function_indent.v From 83057579b7bdda48656f3abe86e62bdde054dfcb Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Thu, 25 Jul 2024 16:36:15 +0200 Subject: [PATCH 069/146] finish cleanup --- lib/Params.ml | 4 ---- 1 file changed, 4 deletions(-) diff --git a/lib/Params.ml b/lib/Params.ml index 212940f4c1..38e1f077d3 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -50,10 +50,6 @@ let ctx_is_apply = function | Exp {pexp_desc= Pexp_apply _; _} -> true | _ -> false -let ctx_is_beginend = function -| Exp {pexp_desc= Pexp_beginend _; _} -> true -| _ -> false - let ctx_is_apply_and_exp_is_unlabelled_arg ~ctx ctx0 = match (ctx, ctx0) with | Exp exp, Exp {pexp_desc= Pexp_apply (_, args); _} -> From 2a2cf32667f926e0d35001b4cbe2fd1699c51f7d Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Thu, 25 Jul 2024 16:56:36 +0200 Subject: [PATCH 070/146] Remove test.ml --- test.ml | 11 ----------- 1 file changed, 11 deletions(-) delete mode 100644 test.ml diff --git a/test.ml b/test.ml deleted file mode 100644 index 0a462ec12a..0000000000 --- a/test.ml +++ /dev/null @@ -1,11 +0,0 @@ -[@@@ocamlformat "profile=janestreet"] - -let _ = - foo - |> List.map ~f:(fun x -> - do_something (); - do_something (); - do_something (); - do_something (); - do_something_else ()) -;; From 4600df0a6aa1311a9199d3a1fdd9e45ddc0ccfe3 Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Thu, 25 Jul 2024 17:13:38 +0200 Subject: [PATCH 071/146] fix janestreet indent --- lib/Fmt_ast.ml | 2 +- lib/Params.ml | 8 ++------ lib/Params.mli | 2 +- test/passing/tests/js_source.ml.ref | 22 +++++++++++----------- 4 files changed, 15 insertions(+), 19 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index c199b023a5..d8868a52ad 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1495,7 +1495,7 @@ and fmt_function ?force_closing_paren ~ctx ~ctx0 ~wrap_intro ?box:(should_box = to add to the [function] keyword. *) let fun_, spilled_attrs, box = match args, typ with - | [], None -> noop, attrs, hvbox (Params.Indent.function_ c.conf ~ctx0 ~parens ~has_label) + | [], None -> noop, attrs, hvbox (Params.Indent.function_ c.conf ~ctx ~ctx0 ~parens ~has_label) | [], Some _ -> assert false | args, typ -> ( fmt_fun_args_typ args typ $ space_break, diff --git a/lib/Params.ml b/lib/Params.ml index 38e1f077d3..6f16438d3b 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -46,10 +46,6 @@ let ctx_is_infix = function | Exp {pexp_desc= Pexp_infix _; _} -> true | _ -> false -let ctx_is_apply = function - | Exp {pexp_desc= Pexp_apply _; _} -> true - | _ -> false - let ctx_is_apply_and_exp_is_unlabelled_arg ~ctx ctx0 = match (ctx, ctx0) with | Exp exp, Exp {pexp_desc= Pexp_apply (_, args); _} -> @@ -771,7 +767,7 @@ module Align = struct end module Indent = struct - let function_ ?(default = 0) (c : Conf.t) ~ctx0 ~parens ~has_label = + let function_ ?(default = 0) (c : Conf.t) ~ctx ~ctx0 ~parens ~has_label = let r= if ctx_is_infix ctx0 then if has_label then 2 else 0 @@ -779,7 +775,7 @@ module Indent = struct let extra = (if c.fmt_opts.wrap_fun_args.v then 2 else match ctx0 with Str _ -> 2 | _ -> 4) in match c.fmt_opts.function_indent_nested.v with | `Always -> c.fmt_opts.function_indent.v + extra - | _ when ocp c && ctx_is_apply ctx0 && not has_label -> default + 3 + | _ when ocp c && ctx_is_apply_and_exp_is_unlabelled_arg ~ctx ctx0 -> default + 2 | _ when ocp c && parens && not has_label -> default + 1 | _ when ocp c -> default | _ -> diff --git a/lib/Params.mli b/lib/Params.mli index 714af16aca..f0d708eb20 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -199,7 +199,7 @@ module Indent : sig (** Expressions *) val function_ : - ?default:int -> Conf.t -> ctx0:Ast.t -> parens:bool -> has_label:bool -> int + ?default:int -> Conf.t -> ctx:Ast.t -> ctx0:Ast.t -> parens:bool -> has_label:bool -> int (** Check the [function-indent-nested] option, or return [default] (0 if not provided) if the option does not apply. *) diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index 7635acc9f6..5e37225062 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -4906,7 +4906,7 @@ module Common0 = struct let handle_msg = ref (function - | _ -> failwith "Unable to handle message") + | _ -> failwith "Unable to handle message") ;; let extend_handle f = @@ -4926,7 +4926,7 @@ module Common = struct let handle_msg = ref (function - | _ -> failwith "Unable to handle message") + | _ -> failwith "Unable to handle message") ;; let extend_handle f = @@ -10057,17 +10057,17 @@ let _ = let _ = foo |> List.map (function - | A -> do_something ()) + | A -> do_something ()) ;; let _ = foo |> List.map (function - | A -> do_something () - | A -> do_something () - | A -> do_something () - | A -> do_something () - | A -> do_something_else ()) + | A -> do_something () + | A -> do_something () + | A -> do_something () + | A -> do_something () + | A -> do_something_else ()) |> bar ;; @@ -10461,14 +10461,14 @@ let _ = let _ = fooooooooooooooooooooooooooooooo |> foooooooooooooooooooooooooooo ~fooooooooooooooooooooooooooooooo (function - | foo -> bar) + | foo -> bar) ;; let _ = fooooooooooooooooooooooooooooooo |> fooooooooooooooooooooooooooooooo ~fooooooooooooooooooooooooooooooo (function - | Some _ -> foo - | None -> baz) + | Some _ -> foo + | None -> baz) ;; (* *) From eb30a4e35c440b7eeb91cd996d6cd0a35c82e220 Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Thu, 25 Jul 2024 17:42:31 +0200 Subject: [PATCH 072/146] fix closing paren on sperate line indentation --- lib/Fmt_ast.ml | 14 ++++++++++---- lib/Params.ml | 2 +- lib/Params.mli | 3 ++- test/passing/tests/apply.ml | 2 +- .../break_cases-closing_on_separate_line.ml.ref | 4 ++-- ...closing_on_separate_line_fit_or_vertical.ml.ref | 4 ++-- ...eparate_line_leading_nested_match_parens.ml.ref | 4 ++-- .../tests/break_cases-cosl_lnmp_cmei.ml.ref | 4 ++-- .../indicate_multiline_delimiters-cosl.ml.ref | 4 ++-- test/passing/tests/ite-compact_closing.ml.ref | 6 +++--- .../tests/ite-fit_or_vertical_closing.ml.ref | 6 +++--- test/passing/tests/ite-kr_closing.ml.ref | 6 +++--- test/passing/tests/ite-kw_first_closing.ml.ref | 6 +++--- 13 files changed, 36 insertions(+), 29 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index d8868a52ad..9df1f5c1e4 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1487,8 +1487,15 @@ and fmt_function ?force_closing_paren ~ctx ~ctx0 ~wrap_intro ?box:(should_box = match args, typ, body with | (_ :: _), _, Pfunction_body body -> (* Only [fun]. *) - fmt_fun_args_typ args typ, fmt_expression c (sub_exp ~ctx body), - (Params.Exp.box_fun_expr c.conf ~ctx0 ~ctx ~parens ~has_label), ~-2 + let head = fmt_fun_args_typ args typ in + let body = fmt_expression c (sub_exp ~ctx body) in + let box, closing_paren_offset = + Params.Exp.box_fun_expr c.conf ~ctx0 ~ctx ~parens ~has_label + in + let closing_paren_offset = + if should_box then closing_paren_offset else ~-2 + in + head, body, box, closing_paren_offset | [], _, Pfunction_body _ -> assert false | args, typ, Pfunction_cases (cs, _loc, cs_attrs) -> (* [fun _ -> function] or [function]. [spilled_attrs] are extra attrs @@ -2206,8 +2213,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens ( fmt_expression c (sub_exp ~ctx exp) $ cut_break $ str "." $ fmt_longident_loc c lid $ fmt_atrs ) ) | Pexp_function (args, typ, body) -> - let wrap_intro intro = hovbox 2 (pro $ intro) $ space_break in - + let wrap_intro intro = hovbox ~name:"fmt_expression | Pexp_function" 2 (pro $ intro) $ space_break in fmt_function ~wrap_intro ~box ~ctx ~ctx0 ~label:Nolabel ~parens ?ext ~attrs:pexp_attributes ~loc:pexp_loc c (args, typ, body) | Pexp_ident {txt; loc} -> diff --git a/lib/Params.ml b/lib/Params.ml index 6f16438d3b..b6c40cc02a 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -157,7 +157,7 @@ module Exp = struct else 2 in let name = "Params.box_fun_expr" in - match ctx0 with Str _ -> hvbox ~name indent | _ -> hovbox ~name indent + (match ctx0 with Str _ -> hvbox ~name indent | _ -> hovbox ~name indent), (~- indent) (* if the function is the last argument of an apply and no other arguments are "complex" (approximation). *) diff --git a/lib/Params.mli b/lib/Params.mli index f0d708eb20..3d50f850f2 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -47,7 +47,8 @@ module Exp : sig (** Box and assemble the parts [kw] (up to the arguments), [args] and [annot]. *) - val box_fun_expr : Conf.t -> ctx0:Ast.t -> ctx:Ast.t -> parens:bool -> has_label:bool -> Fmt.t -> Fmt.t + (** return a box with an indent and minus the value of the indent to be used for a closing parenthesis *) + val box_fun_expr : Conf.t -> ctx0:Ast.t -> ctx:Ast.t -> parens:bool -> has_label:bool -> (Fmt.t -> Fmt.t) * int val function_attrs_sp : Conf.t -> ctx0:Ast.t -> ctx:Ast.t -> bool (** Whether a space should be added between the [function] keyword and the diff --git a/test/passing/tests/apply.ml b/test/passing/tests/apply.ml index 471359bfa9..80592b7297 100644 --- a/test/passing/tests/apply.ml +++ b/test/passing/tests/apply.ml @@ -63,7 +63,7 @@ let whatever_labelled a_function_name long_list_one some_other_thing = ListLabels.map long_list_one ~f:(fun long_list_one_elt -> do_something_with_a_function_and_some_things a_function_name long_list_one_elt some_other_thing - ) + ) ;; (a - b) () ;; diff --git a/test/passing/tests/break_cases-closing_on_separate_line.ml.ref b/test/passing/tests/break_cases-closing_on_separate_line.ml.ref index 4cd44edf32..f1ac7f354b 100644 --- a/test/passing/tests/break_cases-closing_on_separate_line.ml.ref +++ b/test/passing/tests/break_cases-closing_on_separate_line.ml.ref @@ -45,14 +45,14 @@ let foo = | A -> 6 ) ) - ) ; + ) ; List.map ~f:(fun x g t h y u -> fooooooooooooo foooooooo ; ( match k with | foooo -> foooooooo ) ; fooooooooooooooo fooooooooooooo - ) + ) ;; match x with diff --git a/test/passing/tests/break_cases-closing_on_separate_line_fit_or_vertical.ml.ref b/test/passing/tests/break_cases-closing_on_separate_line_fit_or_vertical.ml.ref index 785eb32a0e..fde9b15a12 100644 --- a/test/passing/tests/break_cases-closing_on_separate_line_fit_or_vertical.ml.ref +++ b/test/passing/tests/break_cases-closing_on_separate_line_fit_or_vertical.ml.ref @@ -35,14 +35,14 @@ let foo = | A -> 6 ) ) - ) ; + ) ; List.map ~f:(fun x g t h y u -> fooooooooooooo foooooooo ; ( match k with | foooo -> foooooooo ) ; fooooooooooooooo fooooooooooooo - ) + ) ;; match x with diff --git a/test/passing/tests/break_cases-closing_on_separate_line_leading_nested_match_parens.ml.ref b/test/passing/tests/break_cases-closing_on_separate_line_leading_nested_match_parens.ml.ref index 4d1e4f97ce..31094773b1 100644 --- a/test/passing/tests/break_cases-closing_on_separate_line_leading_nested_match_parens.ml.ref +++ b/test/passing/tests/break_cases-closing_on_separate_line_leading_nested_match_parens.ml.ref @@ -45,14 +45,14 @@ let foo = | A -> 6 ) ) - ) ; + ) ; List.map ~f:(fun x g t h y u -> fooooooooooooo foooooooo ; ( match k with | foooo -> foooooooo ) ; fooooooooooooooo fooooooooooooo - ) + ) ;; match x with diff --git a/test/passing/tests/break_cases-cosl_lnmp_cmei.ml.ref b/test/passing/tests/break_cases-cosl_lnmp_cmei.ml.ref index 2638a869bf..946483fdc9 100644 --- a/test/passing/tests/break_cases-cosl_lnmp_cmei.ml.ref +++ b/test/passing/tests/break_cases-cosl_lnmp_cmei.ml.ref @@ -45,14 +45,14 @@ let foo = | A -> 6 ) ) - ) ; + ) ; List.map ~f:(fun x g t h y u -> fooooooooooooo foooooooo ; ( match k with | foooo -> foooooooo ) ; fooooooooooooooo fooooooooooooo - ) + ) ;; match x with diff --git a/test/passing/tests/indicate_multiline_delimiters-cosl.ml.ref b/test/passing/tests/indicate_multiline_delimiters-cosl.ml.ref index 262bece425..db4fc85e2d 100644 --- a/test/passing/tests/indicate_multiline_delimiters-cosl.ml.ref +++ b/test/passing/tests/indicate_multiline_delimiters-cosl.ml.ref @@ -42,13 +42,13 @@ let contrived = List.map ~f:(fun aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa -> f aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - ) + ) l let contrived = List.map l ~f:(fun aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa -> f aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - ) + ) let x = match y with diff --git a/test/passing/tests/ite-compact_closing.ml.ref b/test/passing/tests/ite-compact_closing.ml.ref index dd0ea0071c..ba050bfa68 100644 --- a/test/passing/tests/ite-compact_closing.ml.ref +++ b/test/passing/tests/ite-compact_closing.ml.ref @@ -100,7 +100,7 @@ let foo = fooooooooooooooooooo fooooooooooooooo foooooooooooo ; List.foo ~fooooooo:foooooooooooooooo ~foo:(fun fooooooooo -> fooooooooooooo - ) + ) ) else if cond2 then ( arm2 ; @@ -108,7 +108,7 @@ let foo = fooooooooooooooooooo fooooooooooooooo foooooooooooo ; List.foo ~fooooooo:foooooooooooooooo ~foo:(fun fooooooooo -> fooooooooooooo - ) + ) ) else ( arm3 ; @@ -116,7 +116,7 @@ let foo = fooooooooooooooooooo fooooooooooooooo foooooooooooo ; List.foo ~fooooooo:foooooooooooooooo ~foo:(fun fooooooooo -> fooooooooooooo - ) + ) ) let foo = diff --git a/test/passing/tests/ite-fit_or_vertical_closing.ml.ref b/test/passing/tests/ite-fit_or_vertical_closing.ml.ref index d58dfac9f1..7cf962e6b9 100644 --- a/test/passing/tests/ite-fit_or_vertical_closing.ml.ref +++ b/test/passing/tests/ite-fit_or_vertical_closing.ml.ref @@ -120,21 +120,21 @@ let foo = fooooooooooooooooooo fooooooooooooooo foooooooooooo ; List.foo ~fooooooo:foooooooooooooooo ~foo:(fun fooooooooo -> fooooooooooooo - ) + ) ) else if cond2 then ( arm2 ; foooooooooooooo ; fooooooooooooooooooo fooooooooooooooo foooooooooooo ; List.foo ~fooooooo:foooooooooooooooo ~foo:(fun fooooooooo -> fooooooooooooo - ) + ) ) else ( arm3 ; foooooooooooooo ; fooooooooooooooooooo fooooooooooooooo foooooooooooo ; List.foo ~fooooooo:foooooooooooooooo ~foo:(fun fooooooooo -> fooooooooooooo - ) + ) ) let foo = diff --git a/test/passing/tests/ite-kr_closing.ml.ref b/test/passing/tests/ite-kr_closing.ml.ref index 417c3c9ca8..8fc41701c5 100644 --- a/test/passing/tests/ite-kr_closing.ml.ref +++ b/test/passing/tests/ite-kr_closing.ml.ref @@ -141,21 +141,21 @@ let foo = fooooooooooooooooooo fooooooooooooooo foooooooooooo ; List.foo ~fooooooo:foooooooooooooooo ~foo:(fun fooooooooo -> fooooooooooooo - ) + ) ) else if cond2 then ( arm2 ; foooooooooooooo ; fooooooooooooooooooo fooooooooooooooo foooooooooooo ; List.foo ~fooooooo:foooooooooooooooo ~foo:(fun fooooooooo -> fooooooooooooo - ) + ) ) else ( arm3 ; foooooooooooooo ; fooooooooooooooooooo fooooooooooooooo foooooooooooo ; List.foo ~fooooooo:foooooooooooooooo ~foo:(fun fooooooooo -> fooooooooooooo - ) + ) ) let foo = diff --git a/test/passing/tests/ite-kw_first_closing.ml.ref b/test/passing/tests/ite-kw_first_closing.ml.ref index 9b6a5de915..e2316835df 100644 --- a/test/passing/tests/ite-kw_first_closing.ml.ref +++ b/test/passing/tests/ite-kw_first_closing.ml.ref @@ -114,7 +114,7 @@ let foo = fooooooooooooooooooo fooooooooooooooo foooooooooooo ; List.foo ~fooooooo:foooooooooooooooo ~foo:(fun fooooooooo -> fooooooooooooo - ) + ) ) else if cond2 then ( @@ -123,7 +123,7 @@ let foo = fooooooooooooooooooo fooooooooooooooo foooooooooooo ; List.foo ~fooooooo:foooooooooooooooo ~foo:(fun fooooooooo -> fooooooooooooo - ) + ) ) else ( arm3 ; @@ -131,7 +131,7 @@ let foo = fooooooooooooooooooo fooooooooooooooo foooooooooooo ; List.foo ~fooooooo:foooooooooooooooo ~foo:(fun fooooooooo -> fooooooooooooo - ) + ) ) let foo = From c3af44965ca98ac6f35b00afdae5d608aed13b7a Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Thu, 25 Jul 2024 18:21:41 +0200 Subject: [PATCH 073/146] Tweak 'function' indentation --- lib/Params.ml | 69 +++--- test/passing/tests/break_cases-align.ml.ref | 4 +- test/passing/tests/break_cases-all.ml.ref | 4 +- ...reak_cases-closing_on_separate_line.ml.ref | 4 +- ...ng_on_separate_line_fit_or_vertical.ml.ref | 4 +- ...te_line_leading_nested_match_parens.ml.ref | 8 +- .../tests/break_cases-cosl_lnmp_cmei.ml.ref | 8 +- .../tests/break_cases-fit_or_vertical.ml.ref | 4 +- .../tests/break_cases-normal_indent.ml.ref | 4 +- .../passing/tests/break_cases-toplevel.ml.ref | 4 +- .../passing/tests/break_cases-vertical.ml.ref | 8 +- test/passing/tests/disambiguate.ml | 4 +- .../tests/function_indent-never.ml.ref | 6 + test/passing/tests/function_indent.ml | 5 + test/passing/tests/function_indent.ml.ref | 10 +- test/passing/tests/issue1750.ml | 83 +++---- test/passing/tests/issue1750.ml.err | 27 --- test/passing/tests/issue289.ml | 20 +- test/passing/tests/js_source.ml.err | 2 +- test/passing/tests/js_source.ml.ocp | 3 +- test/passing/tests/js_source.ml.ref | 41 ++-- test/passing/tests/source.ml.ref | 220 +++++++++--------- 22 files changed, 253 insertions(+), 289 deletions(-) diff --git a/lib/Params.ml b/lib/Params.ml index b6c40cc02a..9b7fc1ec77 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -26,37 +26,20 @@ let is_labelled_arg args exp = | Labelled _, x | Optional _, x -> phys_equal x exp ) args -(** Whether [exp] occurs in [args] as a labelled argument. *) -let is_unlabelled_arg args exp = - List.exists - ~f:(function - | Nolabel, x -> phys_equal x exp - | Labelled _, _ | Optional _, _ -> false ) - args - -let is_arg args exp = - List.exists - ~f:(function - | Nolabel, x -> phys_equal x exp - | Labelled _, x | Optional _, x -> phys_equal x exp ) - args - let ctx_is_infix = function | Exp {pexp_desc= Pexp_infix ({txt= ":="; _}, _, _); _} -> false | Exp {pexp_desc= Pexp_infix _; _} -> true | _ -> false -let ctx_is_apply_and_exp_is_unlabelled_arg ~ctx ctx0 = +(** Return [None] if [ctx0] is not an application or [ctx] is not one of its + argument. *) +let ctx_is_apply_and_exp_is_arg ~ctx ctx0 = match (ctx, ctx0) with | Exp exp, Exp {pexp_desc= Pexp_apply (_, args); _} -> - is_unlabelled_arg args exp - | _ -> false - - let ctx_is_apply_and_exp_is_arg ~ctx ctx0 = - match (ctx, ctx0) with - | Exp exp, Exp {pexp_desc= Pexp_apply (_, args); _} -> - is_arg args exp - | _ -> false + List.find_map + ~f:(fun (lbl, x) -> if phys_equal x exp then Some lbl else None) + args + | _ -> None (** [ctx_is_let ~ctx ctx0] checks whether [ctx0] is a let binding containing [ctx]. *) @@ -151,10 +134,12 @@ module Exp = struct | _ -> if ctx_is_let ~ctx ctx0 then if c.fmt_opts.let_binding_deindent_fun.v then 1 else 0 - else if ocp c then - if ctx_is_apply_and_exp_is_unlabelled_arg ~ctx ctx0 then 4 else 2 - else if ctx_is_apply_and_exp_is_arg ~ctx ctx0 then 4 - else 2 + else + match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with + | Some Nolabel when ocp c -> 4 + | _ when ocp c -> 2 + | Some _ -> 4 + | None -> 2 in let name = "Params.box_fun_expr" in (match ctx0 with Str _ -> hvbox ~name indent | _ -> hovbox ~name indent), (~- indent) @@ -768,20 +753,22 @@ end module Indent = struct let function_ ?(default = 0) (c : Conf.t) ~ctx ~ctx0 ~parens ~has_label = - let r= - if ctx_is_infix ctx0 then - if has_label then 2 else 0 + if ctx_is_infix ctx0 then if has_label then 2 else 0 else - let extra = (if c.fmt_opts.wrap_fun_args.v then 2 else match ctx0 with Str _ -> 2 | _ -> 4) in - match c.fmt_opts.function_indent_nested.v with - | `Always -> c.fmt_opts.function_indent.v + extra - | _ when ocp c && ctx_is_apply_and_exp_is_unlabelled_arg ~ctx ctx0 -> default + 2 - | _ when ocp c && parens && not has_label -> default + 1 - | _ when ocp c -> default - | _ -> - default + extra in - r - + let extra = + if c.fmt_opts.wrap_fun_args.v then 0 + else match ctx0 with Str _ -> 2 | _ -> 0 + in + if Poly.equal c.fmt_opts.function_indent_nested.v `Always then + c.fmt_opts.function_indent.v + extra + else + match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with + | Some _ -> default + 2 + | None -> + if parens && not has_label then + if ocp c then default + 1 else default + else if ocp c then default + else default + extra let fun_type_annot c = if ocp c then 2 else 4 diff --git a/test/passing/tests/break_cases-align.ml.ref b/test/passing/tests/break_cases-align.ml.ref index c44ab7cdc0..49204efc74 100644 --- a/test/passing/tests/break_cases-align.ml.ref +++ b/test/passing/tests/break_cases-align.ml.ref @@ -27,7 +27,7 @@ let f = | O -> 5 | P when h x -> ( function - | A -> 6 ) + | A -> 6 ) let foo = List.map ~f:(fun x g t h y u -> @@ -40,7 +40,7 @@ let foo = | O -> 5 | P when h x -> ( function - | A -> 6 ) ) ; + | A -> 6 ) ) ; List.map ~f:(fun x g t h y u -> fooooooooooooo foooooooo ; ( match k with diff --git a/test/passing/tests/break_cases-all.ml.ref b/test/passing/tests/break_cases-all.ml.ref index 9fba453aa1..8fddf03bf5 100644 --- a/test/passing/tests/break_cases-all.ml.ref +++ b/test/passing/tests/break_cases-all.ml.ref @@ -27,7 +27,7 @@ let f = | O -> 5 | P when h x -> ( function - | A -> 6 ) ) + | A -> 6 ) ) let foo = List.map ~f:(fun x g t h y u -> @@ -40,7 +40,7 @@ let foo = | O -> 5 | P when h x -> ( function - | A -> 6 ) ) ) ; + | A -> 6 ) ) ) ; List.map ~f:(fun x g t h y u -> fooooooooooooo foooooooo ; ( match k with diff --git a/test/passing/tests/break_cases-closing_on_separate_line.ml.ref b/test/passing/tests/break_cases-closing_on_separate_line.ml.ref index f1ac7f354b..fe8e180d85 100644 --- a/test/passing/tests/break_cases-closing_on_separate_line.ml.ref +++ b/test/passing/tests/break_cases-closing_on_separate_line.ml.ref @@ -27,7 +27,7 @@ let f = | O -> 5 | P when h x -> ( function - | A -> 6 + | A -> 6 ) ) @@ -42,7 +42,7 @@ let foo = | O -> 5 | P when h x -> ( function - | A -> 6 + | A -> 6 ) ) ) ; diff --git a/test/passing/tests/break_cases-closing_on_separate_line_fit_or_vertical.ml.ref b/test/passing/tests/break_cases-closing_on_separate_line_fit_or_vertical.ml.ref index fde9b15a12..e89bcf7158 100644 --- a/test/passing/tests/break_cases-closing_on_separate_line_fit_or_vertical.ml.ref +++ b/test/passing/tests/break_cases-closing_on_separate_line_fit_or_vertical.ml.ref @@ -19,7 +19,7 @@ let f = | O -> 5 | P when h x -> ( function - | A -> 6 + | A -> 6 ) ) @@ -32,7 +32,7 @@ let foo = | O -> 5 | P when h x -> ( function - | A -> 6 + | A -> 6 ) ) ) ; diff --git a/test/passing/tests/break_cases-closing_on_separate_line_leading_nested_match_parens.ml.ref b/test/passing/tests/break_cases-closing_on_separate_line_leading_nested_match_parens.ml.ref index 31094773b1..6a5993605b 100644 --- a/test/passing/tests/break_cases-closing_on_separate_line_leading_nested_match_parens.ml.ref +++ b/test/passing/tests/break_cases-closing_on_separate_line_leading_nested_match_parens.ml.ref @@ -27,8 +27,8 @@ let f = | O -> 5 | P when h x -> (function - | A -> 6 - ) + | A -> 6 + ) ) let foo = @@ -42,8 +42,8 @@ let foo = | O -> 5 | P when h x -> (function - | A -> 6 - ) + | A -> 6 + ) ) ) ; List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-cosl_lnmp_cmei.ml.ref b/test/passing/tests/break_cases-cosl_lnmp_cmei.ml.ref index 946483fdc9..6b57c38b89 100644 --- a/test/passing/tests/break_cases-cosl_lnmp_cmei.ml.ref +++ b/test/passing/tests/break_cases-cosl_lnmp_cmei.ml.ref @@ -27,8 +27,8 @@ let f = | O -> 5 | P when h x -> (function - | A -> 6 - ) + | A -> 6 + ) ) let foo = @@ -42,8 +42,8 @@ let foo = | O -> 5 | P when h x -> (function - | A -> 6 - ) + | A -> 6 + ) ) ) ; List.map ~f:(fun x g t h y u -> diff --git a/test/passing/tests/break_cases-fit_or_vertical.ml.ref b/test/passing/tests/break_cases-fit_or_vertical.ml.ref index 984d52607a..6f66e70307 100644 --- a/test/passing/tests/break_cases-fit_or_vertical.ml.ref +++ b/test/passing/tests/break_cases-fit_or_vertical.ml.ref @@ -19,7 +19,7 @@ let f = | O -> 5 | P when h x -> ( function - | A -> 6 ) ) + | A -> 6 ) ) let foo = List.map ~f:(fun x g t h y u -> @@ -30,7 +30,7 @@ let foo = | O -> 5 | P when h x -> ( function - | A -> 6 ) ) ) ; + | A -> 6 ) ) ) ; List.map ~f:(fun x g t h y u -> fooooooooooooo foooooooo ; ( match k with diff --git a/test/passing/tests/break_cases-normal_indent.ml.ref b/test/passing/tests/break_cases-normal_indent.ml.ref index eef84feda8..03e16db911 100644 --- a/test/passing/tests/break_cases-normal_indent.ml.ref +++ b/test/passing/tests/break_cases-normal_indent.ml.ref @@ -27,7 +27,7 @@ let f = | O -> 5 | P when h x -> ( function - | A -> 6 ) ) + | A -> 6 ) ) let foo = List.map ~f:(fun x g t h y u -> @@ -40,7 +40,7 @@ let foo = | O -> 5 | P when h x -> ( function - | A -> 6 ) ) ) ; + | A -> 6 ) ) ) ; List.map ~f:(fun x g t h y u -> fooooooooooooo foooooooo ; ( match k with diff --git a/test/passing/tests/break_cases-toplevel.ml.ref b/test/passing/tests/break_cases-toplevel.ml.ref index 2aa64cdd7e..2e44dab191 100644 --- a/test/passing/tests/break_cases-toplevel.ml.ref +++ b/test/passing/tests/break_cases-toplevel.ml.ref @@ -20,7 +20,7 @@ let f = | O -> 5 | P when h x -> ( function - | A -> 6 ) ) + | A -> 6 ) ) let foo = List.map ~f:(fun x g t h y u -> @@ -31,7 +31,7 @@ let foo = | O -> 5 | P when h x -> ( function - | A -> 6 ) ) ) ; + | A -> 6 ) ) ) ; List.map ~f:(fun x g t h y u -> fooooooooooooo foooooooo ; ( match k with diff --git a/test/passing/tests/break_cases-vertical.ml.ref b/test/passing/tests/break_cases-vertical.ml.ref index d81829d49e..6e575cdf3e 100644 --- a/test/passing/tests/break_cases-vertical.ml.ref +++ b/test/passing/tests/break_cases-vertical.ml.ref @@ -30,8 +30,8 @@ let f = 5 | P when h x -> ( function - | A -> - 6 ) ) + | A -> + 6 ) ) let foo = List.map ~f:(fun x g t h y u -> @@ -46,8 +46,8 @@ let foo = 5 | P when h x -> ( function - | A -> - 6 ) ) ) ; + | A -> + 6 ) ) ) ; List.map ~f:(fun x g t h y u -> fooooooooooooo foooooooo ; ( match k with diff --git a/test/passing/tests/disambiguate.ml b/test/passing/tests/disambiguate.ml index 4b401e4013..8b6c295426 100644 --- a/test/passing/tests/disambiguate.ml +++ b/test/passing/tests/disambiguate.ml @@ -12,8 +12,8 @@ let () = r := (function () -> f () ; g ()) let () = r := function - | () -> - f () ; g () ; g () ; g () ; g () ; g () ; g () ; g () ; g () ; g () + | () -> + f () ; g () ; g () ; g () ; g () ; g () ; g () ; g () ; g () ; g () let () = r := (match () with () -> f () ; g ()) diff --git a/test/passing/tests/function_indent-never.ml.ref b/test/passing/tests/function_indent-never.ml.ref index 2f0cb275c7..12b07056bd 100644 --- a/test/passing/tests/function_indent-never.ml.ref +++ b/test/passing/tests/function_indent-never.ml.ref @@ -10,6 +10,12 @@ let foo = | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo ) +let foo = + fooooooooo foooooooo foooooooo foooooooo foooooooo foooooooo + ~foooooooo:(function + | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo + | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo ) + let foooooooo = if fooooooooooo then function | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo diff --git a/test/passing/tests/function_indent.ml b/test/passing/tests/function_indent.ml index 606fc3bc97..173574d8ba 100644 --- a/test/passing/tests/function_indent.ml +++ b/test/passing/tests/function_indent.ml @@ -10,6 +10,11 @@ let foo = | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo) +let foo = + fooooooooo foooooooo foooooooo foooooooo foooooooo foooooooo ~foooooooo:(function + | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo + | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo ) + let foooooooo = if fooooooooooo then function diff --git a/test/passing/tests/function_indent.ml.ref b/test/passing/tests/function_indent.ml.ref index e17091083f..a66e0ceecb 100644 --- a/test/passing/tests/function_indent.ml.ref +++ b/test/passing/tests/function_indent.ml.ref @@ -7,8 +7,14 @@ let foooooooo = function let foo = fooooooooo foooooooo ~foooooooo:(function - | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo - | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo ) + | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo + | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo ) + +let foo = + fooooooooo foooooooo foooooooo foooooooo foooooooo foooooooo + ~foooooooo:(function + | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo + | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo ) let foooooooo = if fooooooooooo then function diff --git a/test/passing/tests/issue1750.ml b/test/passing/tests/issue1750.ml index aa92e99651..32b5c8a3fd 100644 --- a/test/passing/tests/issue1750.ml +++ b/test/passing/tests/issue1750.ml @@ -27,66 +27,55 @@ let _ = let _ = function | [%p function - | [%p - function + | [%p + function + | [%p + function | [%p function - | [%p - function + | [%p + function + | [%p + function | [%p function - | [%p - function + | [%p + function + | [%p + function | [%p function - | [%p - function + | [%p + function + | [%p + function | [%p function - | [%p - function + | [%p + function + | [%p + function | [%p function - | [%p - function - | [%p - function - | - [%p - function - | - [%p - function - | - [%p - function - | - [%p - function - | _ - -> - ()] - -> - ()] - -> - ()] - -> - ()] - -> - ()] - -> - ()] - -> - ()] - -> + | [%p + function + | _ -> + ()] + -> + ()] -> ()] -> - ()] -> + ()] -> + ()] -> ()] -> - ()] -> + ()] -> + ()] -> ()] -> - ()] -> + ()] -> + ()] -> ()] -> - ()] -> + ()] -> + ()] -> ()] -> - ()] -> + ()] -> + ()] -> () diff --git a/test/passing/tests/issue1750.ml.err b/test/passing/tests/issue1750.ml.err index bf121f014e..ab36531f86 100644 --- a/test/passing/tests/issue1750.ml.err +++ b/test/passing/tests/issue1750.ml.err @@ -1,29 +1,2 @@ Warning: tests/issue1750.ml:20 exceeds the margin -Warning: tests/issue1750.ml:50 exceeds the margin -Warning: tests/issue1750.ml:51 exceeds the margin -Warning: tests/issue1750.ml:52 exceeds the margin -Warning: tests/issue1750.ml:53 exceeds the margin -Warning: tests/issue1750.ml:54 exceeds the margin -Warning: tests/issue1750.ml:55 exceeds the margin -Warning: tests/issue1750.ml:56 exceeds the margin -Warning: tests/issue1750.ml:57 exceeds the margin -Warning: tests/issue1750.ml:58 exceeds the margin -Warning: tests/issue1750.ml:59 exceeds the margin Warning: tests/issue1750.ml:60 exceeds the margin -Warning: tests/issue1750.ml:61 exceeds the margin -Warning: tests/issue1750.ml:62 exceeds the margin -Warning: tests/issue1750.ml:63 exceeds the margin -Warning: tests/issue1750.ml:64 exceeds the margin -Warning: tests/issue1750.ml:65 exceeds the margin -Warning: tests/issue1750.ml:66 exceeds the margin -Warning: tests/issue1750.ml:67 exceeds the margin -Warning: tests/issue1750.ml:68 exceeds the margin -Warning: tests/issue1750.ml:69 exceeds the margin -Warning: tests/issue1750.ml:70 exceeds the margin -Warning: tests/issue1750.ml:71 exceeds the margin -Warning: tests/issue1750.ml:72 exceeds the margin -Warning: tests/issue1750.ml:73 exceeds the margin -Warning: tests/issue1750.ml:74 exceeds the margin -Warning: tests/issue1750.ml:75 exceeds the margin -Warning: tests/issue1750.ml:76 exceeds the margin -Warning: tests/issue1750.ml:77 exceeds the margin diff --git a/test/passing/tests/issue289.ml b/test/passing/tests/issue289.ml index 3e7a389384..c5fd362fd5 100644 --- a/test/passing/tests/issue289.ml +++ b/test/passing/tests/issue289.ml @@ -3,31 +3,31 @@ let foo = let open Gql in [ field "id" ~doc:"Toy ID." ~args:[] ~typ:(non_null guid) ~resolve:(function - | _ctx -> x.id ) + | _ctx -> x.id ) ; field "id" ~doc:"Toy ID." ~args:[] ~typppp ~resolve:(function - | _ctx -> x.id ) + | _ctx -> x.id ) ; field "id" ~doc:"Toy ID." ~args:[] ~typ:(non_null guid) ~resolve:(function - | A -> x.id - | B -> c ) + | A -> x.id + | B -> c ) ; field "id" ~doc:"Toy ID." ~args:[] ~resolve:(function - | A -> x.id - | B -> c ) + | A -> x.id + | B -> c ) ; field "id" ~doc:"Toy ID." ~args:[] ~typppppppppppppppppppp ~resolve:(function - | AAAAAAAAAAAAAAAAAAAa -> x.idddddddddddddddddddddddddd - | BBBBBBBBBBBBBBBB -> ccccccccccccccccccccccc ) + | AAAAAAAAAAAAAAAAAAAa -> x.idddddddddddddddddddddddddd + | BBBBBBBBBBBBBBBB -> ccccccccccccccccccccccc ) ; field "id" ~doc:"Toy ID." ~args:[] ~resolve:(function - | AAAAAAAAAAAAAAAAAAAa -> x.idddddddddddddddddddddddddd - | BBBBBBBBBBBBBBBB -> ccccccccccccccccccccccc ) + | AAAAAAAAAAAAAAAAAAAa -> x.idddddddddddddddddddddddddd + | BBBBBBBBBBBBBBBB -> ccccccccccccccccccccccc ) ; field "id" ~doc:"Toy ID." diff --git a/test/passing/tests/js_source.ml.err b/test/passing/tests/js_source.ml.err index 21d457b07f..65746b4035 100644 --- a/test/passing/tests/js_source.ml.err +++ b/test/passing/tests/js_source.ml.err @@ -4,4 +4,4 @@ Warning: tests/js_source.ml:9567 exceeds the margin Warning: tests/js_source.ml:9671 exceeds the margin Warning: tests/js_source.ml:9730 exceeds the margin Warning: tests/js_source.ml:9813 exceeds the margin -Warning: tests/js_source.ml:10319 exceeds the margin +Warning: tests/js_source.ml:10320 exceeds the margin diff --git a/test/passing/tests/js_source.ml.ocp b/test/passing/tests/js_source.ml.ocp index 1271423b4a..1d4cf9f0b4 100644 --- a/test/passing/tests/js_source.ml.ocp +++ b/test/passing/tests/js_source.ml.ocp @@ -9916,7 +9916,8 @@ let bind t ~f = | Sequence { state = seed; next } -> (match next seed with | Done -> Done - | Skip { state = s } -> Skip { state = empty, Sequence { state = s; next } } + | Skip { state = s } -> + Skip { state = empty, Sequence { state = s; next } } | Yield { value = a; state = s } -> Skip { state = f a, Sequence { state = s; next } })) | Skip { state = s } -> Skip { state = Sequence { state = s; next }, rest } diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index 5e37225062..56651877dd 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -9807,7 +9807,7 @@ let _ = when f ~f: (function [@ocaml.warning (* ....................................... *) "-4"] - | _ -> .) -> y + | _ -> .) -> y ;; let[@a @@ -9823,21 +9823,21 @@ let[@a | _ when f ~f:(function[@ocaml.warning (* ....................................... *) "-4"] - | _ -> .) + | _ -> .) ~f: (function[@ocaml.warning (* ....................................... *) (* ....................................... *) "foooooooooooooooooooooooooooo \ fooooooooooooooooooooooooooooooooooooo"] - | _ -> .) + | _ -> .) ~f: (function[@ocaml.warning (* ....................................... *) let x = a and y = b in x + y] - | _ -> .) -> + | _ -> .) -> y [@attr (* ... *) @@ -9909,19 +9909,20 @@ let x = let bind t ~f = unfold_step ~f:(function - | Sequence { state = seed; next }, rest -> - (match next seed with - | Done -> - (match rest with - | Sequence { state = seed; next } -> - (match next seed with - | Done -> Done - | Skip { state = s } -> Skip { state = empty, Sequence { state = s; next } } - | Yield { value = a; state = s } -> - Skip { state = f a, Sequence { state = s; next } })) - | Skip { state = s } -> Skip { state = Sequence { state = s; next }, rest } - | Yield { value = a; state = s } -> - Yield { value = a; state = Sequence { state = s; next }, rest })) + | Sequence { state = seed; next }, rest -> + (match next seed with + | Done -> + (match rest with + | Sequence { state = seed; next } -> + (match next seed with + | Done -> Done + | Skip { state = s } -> + Skip { state = empty, Sequence { state = s; next } } + | Yield { value = a; state = s } -> + Skip { state = f a, Sequence { state = s; next } })) + | Skip { state = s } -> Skip { state = Sequence { state = s; next }, rest } + | Yield { value = a; state = s } -> + Yield { value = a; state = Sequence { state = s; next }, rest })) ~init:(empty, t) ;; @@ -9983,9 +9984,9 @@ type t let pat = String.Search_pattern.create (String.init len ~f:(function - | 0 -> '\n' - | n when n < len - 1 -> ' ' - | _ -> '*')) + | 0 -> '\n' + | n when n < len - 1 -> ' ' + | _ -> '*')) ;; type t = diff --git a/test/passing/tests/source.ml.ref b/test/passing/tests/source.ml.ref index 5ac6cc7004..1dd612fabb 100644 --- a/test/passing/tests/source.ml.ref +++ b/test/passing/tests/source.ml.ref @@ -1343,8 +1343,8 @@ let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = (Sum { sum_proj= (function - | `Nil -> ("Nil", None) - | `Cons p -> ("Cons", Some (Tdyn (tcons, p))) ) + | `Nil -> ("Nil", None) + | `Cons p -> ("Cons", Some (Tdyn (tcons, p))) ) ; sum_cases= [("Nil", TCnoarg Thd); ("Cons", TCarg (Ttl Thd, tcons))] ; sum_inj= (fun (type c) -> @@ -1376,14 +1376,14 @@ let ty_abc : ([`A of int | `B of string | `C], 'e) ty = (* Could also use [get_case] for proj, but direct definition is shorter *) Sum ( (function - | `A n -> ("A", Some (Tdyn (Int, n))) - | `B s -> ("B", Some (Tdyn (String, s))) - | `C -> ("C", None) ) + | `A n -> ("A", Some (Tdyn (Int, n))) + | `B s -> ("B", Some (Tdyn (String, s))) + | `C -> ("C", None) ) , function - | "A", Some (Tdyn (Int, n)) -> `A n - | "B", Some (Tdyn (String, s)) -> `B s - | "C", None -> `C - | _ -> invalid_arg "ty_abc" ) + | "A", Some (Tdyn (Int, n)) -> `A n + | "B", Some (Tdyn (String, s)) -> `B s + | "C", None -> `C + | _ -> invalid_arg "ty_abc" ) (* Breaks: no way to pattern-match on a full recursive type *) let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = @@ -1392,12 +1392,12 @@ let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = Rec (Sum ( (function - | `Nil -> ("Nil", None) - | `Cons p -> ("Cons", Some (Tdyn (targ, p))) ) + | `Nil -> ("Nil", None) + | `Cons p -> ("Cons", Some (Tdyn (targ, p))) ) , function - | "Nil", None -> `Nil - | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> - `Cons p ) ) + | "Nil", None -> `Nil + | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p + ) ) (* Define Sum using object instead of record for first-class polymorphism *) @@ -1432,9 +1432,9 @@ let ty_abc : (([`A of int | `B of string | `C] as 'a), 'e) ty = (object method proj = function - | `A n -> ("A", Some (Tdyn (Int, n))) - | `B s -> ("B", Some (Tdyn (String, s))) - | `C -> ("C", None) + | `A n -> ("A", Some (Tdyn (Int, n))) + | `B s -> ("B", Some (Tdyn (String, s))) + | `C -> ("C", None) method cases = [ ("A", TCarg (Thd, Int)) @@ -1445,9 +1445,9 @@ let ty_abc : (([`A of int | `B of string | `C] as 'a), 'e) ty = (int -> string -> noarg -> unit, c) ty_sel * c -> [`A of int | `B of string | `C] = function - | Thd, v -> `A v - | Ttl Thd, v -> `B v - | Ttl (Ttl Thd), Noarg -> `C + | Thd, v -> `A v + | Ttl Thd, v -> `B v + | Ttl (Ttl Thd), Noarg -> `C end ) type 'a vlist = [`Nil | `Cons of 'a * 'a vlist] @@ -1460,8 +1460,8 @@ let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = (object method proj = function - | `Nil -> ("Nil", None) - | `Cons p -> ("Cons", Some (Tdyn (tcons, p))) + | `Nil -> ("Nil", None) + | `Cons p -> ("Cons", Some (Tdyn (tcons, p))) method cases = [("Nil", TCnoarg Thd); ("Cons", TCarg (Ttl Thd, tcons))] @@ -3679,37 +3679,35 @@ class ['a] lambda_ops (ops : ('a, 'a) #ops Lazy.t) = method free = function - | #var as x -> var#free x - | `Abs (s, t) -> Names.remove s (!!free t) - | `App (t1, t2) -> Names.union (!!free t1) (!!free t2) + | #var as x -> var#free x + | `Abs (s, t) -> Names.remove s (!!free t) + | `App (t1, t2) -> Names.union (!!free t1) (!!free t2) method map ~f = function - | #var as x -> x - | `Abs (s, t) as l -> - let t' = f t in - if t == t' then l else `Abs (s, t') - | `App (t1, t2) as l -> - let t'1 = f t1 and t'2 = f t2 in - if t'1 == t1 && t'2 == t2 then l else `App (t'1, t'2) + | #var as x -> x + | `Abs (s, t) as l -> + let t' = f t in + if t == t' then l else `Abs (s, t') + | `App (t1, t2) as l -> + let t'1 = f t1 and t'2 = f t2 in + if t'1 == t1 && t'2 == t2 then l else `App (t'1, t'2) method subst ~sub = function - | #var as x -> var#subst ~sub x - | `Abs (s, t) as l -> - let used = !!free t in - let used_expr = - Subst.fold sub ~init:[] ~f:(fun ~key ~data acc -> - if Names.mem s used then data :: acc else acc ) - in - if List.exists used_expr ~f:(fun t -> Names.mem s (!!free t)) - then - let name = s ^ string_of_int (next_id ()) in - `Abs - ( name - , !!subst ~sub:(Subst.add ~key:s ~data:(`Var name) sub) t ) - else self#map ~f:(!!subst ~sub:(Subst.remove s sub)) l - | `App _ as l -> self#map ~f:(!!subst ~sub) l + | #var as x -> var#subst ~sub x + | `Abs (s, t) as l -> + let used = !!free t in + let used_expr = + Subst.fold sub ~init:[] ~f:(fun ~key ~data acc -> + if Names.mem s used then data :: acc else acc ) + in + if List.exists used_expr ~f:(fun t -> Names.mem s (!!free t)) then + let name = s ^ string_of_int (next_id ()) in + `Abs + (name, !!subst ~sub:(Subst.add ~key:s ~data:(`Var name) sub) t) + else self#map ~f:(!!subst ~sub:(Subst.remove s sub)) l + | `App _ as l -> self#map ~f:(!!subst ~sub) l method eval l = match self#map ~f:!!eval l with @@ -3741,30 +3739,30 @@ class ['a] expr_ops (ops : ('a, 'a) #ops Lazy.t) = method free = function - | #var as x -> var#free x - | `Num _ -> Names.empty - | `Add (x, y) -> Names.union (!!free x) (!!free y) - | `Neg x -> !!free x - | `Mult (x, y) -> Names.union (!!free x) (!!free y) + | #var as x -> var#free x + | `Num _ -> Names.empty + | `Add (x, y) -> Names.union (!!free x) (!!free y) + | `Neg x -> !!free x + | `Mult (x, y) -> Names.union (!!free x) (!!free y) method map ~f = function - | #var as x -> x - | `Num _ as x -> x - | `Add (x, y) as e -> - let x' = f x and y' = f y in - if x == x' && y == y' then e else `Add (x', y') - | `Neg x as e -> - let x' = f x in - if x == x' then e else `Neg x' - | `Mult (x, y) as e -> - let x' = f x and y' = f y in - if x == x' && y == y' then e else `Mult (x', y') + | #var as x -> x + | `Num _ as x -> x + | `Add (x, y) as e -> + let x' = f x and y' = f y in + if x == x' && y == y' then e else `Add (x', y') + | `Neg x as e -> + let x' = f x in + if x == x' then e else `Neg x' + | `Mult (x, y) as e -> + let x' = f x and y' = f y in + if x == x' && y == y' then e else `Mult (x', y') method subst ~sub = function - | #var as x -> var#subst ~sub x - | #expr as e -> self#map ~f:(!!subst ~sub) e + | #var as x -> var#subst ~sub x + | #expr as e -> self#map ~f:(!!subst ~sub) e method eval (#expr as e) = match self#map ~f:!!eval e with @@ -3793,8 +3791,8 @@ class ['a] lexpr_ops (ops : ('a, 'a) #ops Lazy.t) = method subst ~sub = function - | #lambda as x -> lambda#subst ~sub x - | #expr as x -> expr#subst ~sub x + | #lambda as x -> lambda#subst ~sub x + | #expr as x -> expr#subst ~sub x method eval = function #lambda as x -> lambda#eval x | #expr as x -> expr#eval x @@ -3892,37 +3890,35 @@ let lambda_ops (ops : ('a, 'a) #ops Lazy.t) = object (self : ([> 'a lambda], 'a lambda) #ops) method free = function - | #var as x -> var#free x - | `Abs (s, t) -> Names.remove s (!!free t) - | `App (t1, t2) -> Names.union (!!free t1) (!!free t2) + | #var as x -> var#free x + | `Abs (s, t) -> Names.remove s (!!free t) + | `App (t1, t2) -> Names.union (!!free t1) (!!free t2) method private map ~f = function - | #var as x -> x - | `Abs (s, t) as l -> - let t' = f t in - if t == t' then l else `Abs (s, t') - | `App (t1, t2) as l -> - let t'1 = f t1 and t'2 = f t2 in - if t'1 == t1 && t'2 == t2 then l else `App (t'1, t'2) + | #var as x -> x + | `Abs (s, t) as l -> + let t' = f t in + if t == t' then l else `Abs (s, t') + | `App (t1, t2) as l -> + let t'1 = f t1 and t'2 = f t2 in + if t'1 == t1 && t'2 == t2 then l else `App (t'1, t'2) method subst ~sub = function - | #var as x -> var#subst ~sub x - | `Abs (s, t) as l -> - let used = !!free t in - let used_expr = - Subst.fold sub ~init:[] ~f:(fun ~key ~data acc -> - if Names.mem s used then data :: acc else acc ) - in - if List.exists used_expr ~f:(fun t -> Names.mem s (!!free t)) - then - let name = s ^ string_of_int (next_id ()) in - `Abs - ( name - , !!subst ~sub:(Subst.add ~key:s ~data:(`Var name) sub) t ) - else self#map ~f:(!!subst ~sub:(Subst.remove s sub)) l - | `App _ as l -> self#map ~f:(!!subst ~sub) l + | #var as x -> var#subst ~sub x + | `Abs (s, t) as l -> + let used = !!free t in + let used_expr = + Subst.fold sub ~init:[] ~f:(fun ~key ~data acc -> + if Names.mem s used then data :: acc else acc ) + in + if List.exists used_expr ~f:(fun t -> Names.mem s (!!free t)) then + let name = s ^ string_of_int (next_id ()) in + `Abs + (name, !!subst ~sub:(Subst.add ~key:s ~data:(`Var name) sub) t) + else self#map ~f:(!!subst ~sub:(Subst.remove s sub)) l + | `App _ as l -> self#map ~f:(!!subst ~sub) l method eval l = match self#map ~f:!!eval l with @@ -3951,30 +3947,30 @@ let expr_ops (ops : ('a, 'a) #ops Lazy.t) = object (self : ([> 'a expr], 'a expr) #ops) method free = function - | #var as x -> var#free x - | `Num _ -> Names.empty - | `Add (x, y) -> Names.union (!!free x) (!!free y) - | `Neg x -> !!free x - | `Mult (x, y) -> Names.union (!!free x) (!!free y) + | #var as x -> var#free x + | `Num _ -> Names.empty + | `Add (x, y) -> Names.union (!!free x) (!!free y) + | `Neg x -> !!free x + | `Mult (x, y) -> Names.union (!!free x) (!!free y) method private map ~f = function - | #var as x -> x - | `Num _ as x -> x - | `Add (x, y) as e -> - let x' = f x and y' = f y in - if x == x' && y == y' then e else `Add (x', y') - | `Neg x as e -> - let x' = f x in - if x == x' then e else `Neg x' - | `Mult (x, y) as e -> - let x' = f x and y' = f y in - if x == x' && y == y' then e else `Mult (x', y') + | #var as x -> x + | `Num _ as x -> x + | `Add (x, y) as e -> + let x' = f x and y' = f y in + if x == x' && y == y' then e else `Add (x', y') + | `Neg x as e -> + let x' = f x in + if x == x' then e else `Neg x' + | `Mult (x, y) as e -> + let x' = f x and y' = f y in + if x == x' && y == y' then e else `Mult (x', y') method subst ~sub = function - | #var as x -> var#subst ~sub x - | #expr as e -> self#map ~f:(!!subst ~sub) e + | #var as x -> var#subst ~sub x + | #expr as e -> self#map ~f:(!!subst ~sub) e method eval (#expr as e) = match self#map ~f:!!eval e with @@ -4001,8 +3997,8 @@ let lexpr_ops (ops : ('a, 'a) #ops Lazy.t) = method subst ~sub = function - | #lambda as x -> lambda#subst ~sub x - | #expr as x -> expr#subst ~sub x + | #lambda as x -> lambda#subst ~sub x + | #expr as x -> expr#subst ~sub x method eval = function #lambda as x -> lambda#eval x | #expr as x -> expr#eval x From e7aa06b731b63ffded97b55e94db104bf5a45947 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Thu, 25 Jul 2024 18:36:26 +0200 Subject: [PATCH 074/146] Tweak 'fun -> function' indentation --- lib/Params.ml | 9 ++------- test/passing/tests/fun_decl.ml | 12 +++++++++--- test/passing/tests/fun_function.ml | 4 ++-- test/passing/tests/js_source.ml.ref | 8 ++++---- 4 files changed, 17 insertions(+), 16 deletions(-) diff --git a/lib/Params.ml b/lib/Params.ml index 9b7fc1ec77..94db220d3f 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -774,16 +774,11 @@ module Indent = struct let fun_args c = if ocp c then 6 else 4 - let docked_function_after_fun (c : Conf.t) ~ctx0 ~parens ~has_label = + let docked_function_after_fun (_c : Conf.t) ~ctx0 ~parens:_ ~has_label:_ = if ctx_is_infix ctx0 then 0 else - 2 + - if ocp c then - if parens && not has_label then - 3 - else 2 - else 2 + 2 let fun_args_group (c : Conf.t) ~lbl exp = if not (ocp c) then 2 diff --git a/test/passing/tests/fun_decl.ml b/test/passing/tests/fun_decl.ml index 189f52e6ae..410a6b4549 100644 --- a/test/passing/tests/fun_decl.ml +++ b/test/passing/tests/fun_decl.ml @@ -67,9 +67,15 @@ let translate_captured let f ssssssssss = String.fold ssssssssss ~init:innnnnnnnnnit ~f:(fun accuuuuuuuuuum -> function - | '0' -> g accuuuuuuuuuum - | '1' -> h accuuuuuuuuuum - | _ -> i accuuuuuuuuuum ) + | '0' -> g accuuuuuuuuuum + | '1' -> h accuuuuuuuuuum + | _ -> i accuuuuuuuuuum ) + +let f ssssssssss = + String.fold ssssssssss ~init:innnnnnnnnnit ~f:(function + | '0' -> g accuuuuuuuuuum + | '1' -> h accuuuuuuuuuum + | _ -> i accuuuuuuuuuum ) let f _ = let foooooooooooooooooooooooooooo = foooooooooooooooooooooooooooo in diff --git a/test/passing/tests/fun_function.ml b/test/passing/tests/fun_function.ml index a6fef8fbdc..4e55f06bc6 100644 --- a/test/passing/tests/fun_function.ml +++ b/test/passing/tests/fun_function.ml @@ -1,4 +1,4 @@ let s = List.fold x ~f:(fun y -> function - | Aconstructor avalue -> afunction avalue - | Bconstructor bvalue -> bfunction bvalue ) + | Aconstructor avalue -> afunction avalue + | Bconstructor bvalue -> bfunction bvalue ) diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index 56651877dd..b7429563c1 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -10203,8 +10203,8 @@ let _ = foooooooooooooooooooo foooooooooooooooooooo (fun x -> function - | Foooooooooooooooooooo -> foooooooooooooooooooo - | Foooooooooooooooooooo -> foooooooooooooooooooo) + | Foooooooooooooooooooo -> foooooooooooooooooooo + | Foooooooooooooooooooo -> foooooooooooooooooooo) ;; let _ = @@ -10212,8 +10212,8 @@ let _ = foooooooooooooooooooo foooooooooooooooooooo ~x:(fun x -> function - | Foooooooooooooooooooo -> foooooooooooooooooooo - | Foooooooooooooooooooo -> foooooooooooooooooooo) + | Foooooooooooooooooooo -> foooooooooooooooooooo + | Foooooooooooooooooooo -> foooooooooooooooooooo) ;; let _ = From a78c9cdb04c23ad2e6459cc55933dced1b79c639 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Thu, 25 Jul 2024 18:38:27 +0200 Subject: [PATCH 075/146] Remove unused Params.Indent.docked_fun --- lib/Params.ml | 11 ----------- lib/Params.mli | 5 ----- 2 files changed, 16 deletions(-) diff --git a/lib/Params.ml b/lib/Params.ml index 94db220d3f..d34ed39ef0 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -787,17 +787,6 @@ module Indent = struct | Pexp_function _ -> 2 | _ -> ( match lbl with Nolabel -> 3 | _ -> 2 ) - let docked_fun (c : Conf.t) ~source ~loc ~lbl = - if not (ocp c) then 2 - else - let loc, if_breaks = - match lbl with - | Nolabel -> (loc, 3) - | Optional x | Labelled x -> (x.loc, 2) - in - if Source.begins_line ~ignore_spaces:true source loc then if_breaks - else 0 - let record_docstring (c : Conf.t) = if ocp c then match c.fmt_opts.break_separators.v with `Before -> 0 | `After -> 2 diff --git a/lib/Params.mli b/lib/Params.mli index 3d50f850f2..f6d553e38f 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -208,11 +208,6 @@ module Indent : sig val fun_type_annot : Conf.t -> int - val docked_fun : - Conf.t -> source:Source.t -> loc:Location.t -> lbl:arg_label -> int - - (* val docked_function : Conf.t -> parens:bool -> expression Ast.xt -> int *) - val docked_function_after_fun : Conf.t -> ctx0:Ast.t -> parens:bool -> has_label:bool -> int From 258e79b41870a1d8fd163f00f81ebbf5f57a8683 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Thu, 25 Jul 2024 18:46:47 +0200 Subject: [PATCH 076/146] Tweak labelled 'fun' indentation --- lib/Params.ml | 30 +++++++++++-------- test/passing/tests/eliom_ext.eliom | 2 +- .../indicate_multiline_delimiters-cosl.ml.ref | 2 +- ...indicate_multiline_delimiters-space.ml.ref | 2 +- .../tests/indicate_multiline_delimiters.ml | 2 +- 5 files changed, 22 insertions(+), 16 deletions(-) diff --git a/lib/Params.ml b/lib/Params.ml index d34ed39ef0..ed35e9481d 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -41,6 +41,13 @@ let ctx_is_apply_and_exp_is_arg ~ctx ctx0 = args | _ -> None +let ctx_is_apply_and_exp_is_last_arg ~ctx ctx0 = + match (ctx, ctx0) with + | Exp exp, Exp {pexp_desc= Pexp_apply (_, args); _} -> + let _, last_arg = List.last_exn args in + Poly.equal last_arg exp + | _ -> false + (** [ctx_is_let ~ctx ctx0] checks whether [ctx0] is a let binding containing [ctx]. *) let ctx_is_let ~ctx = function @@ -128,21 +135,20 @@ module Exp = struct let box_fun_expr (c : Conf.t) ~ctx0 ~ctx ~parens:_ ~has_label = let indent = if ctx_is_infix ctx0 then if ocp c && has_label then 2 else 0 + else if Poly.equal c.fmt_opts.function_indent_nested.v `Always then + c.fmt_opts.function_indent.v + else if ctx_is_let ~ctx ctx0 then + if c.fmt_opts.let_binding_deindent_fun.v then 1 else 0 else - match c.fmt_opts.function_indent_nested.v with - | `Always -> c.fmt_opts.function_indent.v - | _ -> - if ctx_is_let ~ctx ctx0 then - if c.fmt_opts.let_binding_deindent_fun.v then 1 else 0 - else - match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with - | Some Nolabel when ocp c -> 4 - | _ when ocp c -> 2 - | Some _ -> 4 - | None -> 2 + match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with + | Some Nolabel when ocp c -> 4 + | _ when ocp c -> 2 + | Some _ when ctx_is_apply_and_exp_is_last_arg ~ctx ctx0 -> 4 + | _ -> 2 in let name = "Params.box_fun_expr" in - (match ctx0 with Str _ -> hvbox ~name indent | _ -> hovbox ~name indent), (~- indent) + let mkbox = match ctx0 with Str _ -> hvbox | _ -> hovbox in + (mkbox ~name indent, ~-indent) (* if the function is the last argument of an apply and no other arguments are "complex" (approximation). *) diff --git a/test/passing/tests/eliom_ext.eliom b/test/passing/tests/eliom_ext.eliom index 29010494f5..9b5632b28d 100644 --- a/test/passing/tests/eliom_ext.eliom +++ b/test/passing/tests/eliom_ext.eliom @@ -20,7 +20,7 @@ let%client () = (* NB The service underlying the server_function isn't available on the client before loading the page. *) ~foo:(fun () -> - Lwt.async (fun () -> log "Hello from the client to the server!") ) + Lwt.async (fun () -> log "Hello from the client to the server!") ) bar [%%shared diff --git a/test/passing/tests/indicate_multiline_delimiters-cosl.ml.ref b/test/passing/tests/indicate_multiline_delimiters-cosl.ml.ref index db4fc85e2d..764a7fa7a1 100644 --- a/test/passing/tests/indicate_multiline_delimiters-cosl.ml.ref +++ b/test/passing/tests/indicate_multiline_delimiters-cosl.ml.ref @@ -41,7 +41,7 @@ let raise fmt = let contrived = List.map ~f:(fun aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa -> - f aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + f aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa ) l diff --git a/test/passing/tests/indicate_multiline_delimiters-space.ml.ref b/test/passing/tests/indicate_multiline_delimiters-space.ml.ref index 158b9a970c..b8a491787a 100644 --- a/test/passing/tests/indicate_multiline_delimiters-space.ml.ref +++ b/test/passing/tests/indicate_multiline_delimiters-space.ml.ref @@ -37,7 +37,7 @@ let raise fmt = let contrived = List.map ~f:(fun aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa -> - f aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa ) + f aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa ) l let contrived = diff --git a/test/passing/tests/indicate_multiline_delimiters.ml b/test/passing/tests/indicate_multiline_delimiters.ml index 164bbbb62c..317d579957 100644 --- a/test/passing/tests/indicate_multiline_delimiters.ml +++ b/test/passing/tests/indicate_multiline_delimiters.ml @@ -37,7 +37,7 @@ let raise fmt = let contrived = List.map ~f:(fun aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa -> - f aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa) + f aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa) l let contrived = From 93e101dd98d7a293bae62d56fc353c69f11a2f4a Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Thu, 25 Jul 2024 18:59:44 +0200 Subject: [PATCH 077/146] Don't unbox functions passed as args --- lib/Fmt_ast.ml | 5 +---- test/passing/tests/js_source.ml.ref | 4 ++-- test/passing/tests/source.ml.ref | 7 +++++-- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 9df1f5c1e4..fbe6c560f5 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1603,9 +1603,6 @@ and expression_width c xe = and fmt_args_grouped ?epi:(global_epi = noop) c ctx args = let fmt_arg c ~first:_ ~last (lbl, arg) = let ({ast; _} as xarg) = sub_exp ~ctx arg in - let box = - match ast.pexp_desc with Pexp_function _ -> Some false | _ -> None - in let break_after = match (ast.pexp_desc, c.conf.fmt_opts.break_string_literals.v) with | Pexp_constant _, `Auto when not last -> @@ -1614,7 +1611,7 @@ and fmt_args_grouped ?epi:(global_epi = noop) c ctx args = in hovbox (Params.Indent.fun_args_group c.conf ~lbl ast) - (fmt_label_arg c ?box (lbl, xarg) $ break_after) + (fmt_label_arg c (lbl, xarg) $ break_after) $ fmt_if (not last) (break_unless_newline 1 0) in let fmt_args ~first ~last args = diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index b7429563c1..09fa046996 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -1081,8 +1081,8 @@ let rec devariantize : type t. t ty -> variant -> t = let builder = create_builder () in List.iter2 (fun (Field { label; field_type; set }) (lab, v) -> - if label <> lab then raise VariantMismatch; - set builder (devariantize field_type v)) + if label <> lab then raise VariantMismatch; + set builder (devariantize field_type v)) fields fl; of_builder builder diff --git a/test/passing/tests/source.ml.ref b/test/passing/tests/source.ml.ref index 1dd612fabb..24654729f0 100644 --- a/test/passing/tests/source.ml.ref +++ b/test/passing/tests/source.ml.ref @@ -9166,7 +9166,8 @@ f (fun _ -> function | true -> let () = () in - () | false -> () ) + () + | false -> () ) () ;; @@ -9174,7 +9175,9 @@ f (fun _ -> function | true -> let () = () in - () (* comment *) | false -> () ) + () + (* comment *) + | false -> () ) () let xxxxxx = From e57f7f595d33e137b4e6d92e3e174bd2462a169a Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Thu, 25 Jul 2024 19:22:11 +0200 Subject: [PATCH 078/146] ocp-indent: Restore indentation of docked 'fun' args Sadly, this brings back the '~source' argument. All the test changes in this commit that contain an infix operator are not fixes. --- lib/Fmt_ast.ml | 2 +- lib/Params.ml | 18 +++-- lib/Params.mli | 2 +- test/passing/tests/js_source.ml.ref | 108 ++++++++++++++-------------- 4 files changed, 68 insertions(+), 62 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index fbe6c560f5..bef490c95c 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1490,7 +1490,7 @@ and fmt_function ?force_closing_paren ~ctx ~ctx0 ~wrap_intro ?box:(should_box = let head = fmt_fun_args_typ args typ in let body = fmt_expression c (sub_exp ~ctx body) in let box, closing_paren_offset = - Params.Exp.box_fun_expr c.conf ~ctx0 ~ctx ~parens ~has_label + Params.Exp.box_fun_expr c.conf ~source:c.source ~ctx0 ~ctx ~parens ~has_label in let closing_paren_offset = if should_box then closing_paren_offset else ~-2 diff --git a/lib/Params.ml b/lib/Params.ml index ed35e9481d..c634ec1b32 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -132,19 +132,25 @@ module Exp = struct in box_decl (kw $ hvbox_if should_box_args 0 args $ fmt_opt annot) - let box_fun_expr (c : Conf.t) ~ctx0 ~ctx ~parens:_ ~has_label = + let box_fun_expr (c : Conf.t) ~source ~ctx0 ~ctx ~parens ~has_label:_ = let indent = - if ctx_is_infix ctx0 then if ocp c && has_label then 2 else 0 + if ctx_is_infix ctx0 then 0 else if Poly.equal c.fmt_opts.function_indent_nested.v `Always then c.fmt_opts.function_indent.v else if ctx_is_let ~ctx ctx0 then if c.fmt_opts.let_binding_deindent_fun.v then 1 else 0 else + if ocp c then + let begins_line loc = Source.begins_line ~ignore_spaces:true source loc in match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with - | Some Nolabel when ocp c -> 4 - | _ when ocp c -> 2 - | Some _ when ctx_is_apply_and_exp_is_last_arg ~ctx ctx0 -> 4 - | _ -> 2 + | Some Nolabel -> + if ctx_is_apply_and_exp_is_last_arg ~ctx ctx0 then 5 else 3 + | Some (Labelled x | Optional x) -> + (* if ctx_is_apply_and_exp_is_last_arg ~ctx ctx0 then 2 else *) + if begins_line x.loc then 4 else 2 + | None -> if parens then 3 else 2 + else + if ctx_is_apply_and_exp_is_last_arg ~ctx ctx0 then 4 else 2 in let name = "Params.box_fun_expr" in let mkbox = match ctx0 with Str _ -> hvbox | _ -> hovbox in diff --git a/lib/Params.mli b/lib/Params.mli index f6d553e38f..60b7fa7ab4 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -48,7 +48,7 @@ module Exp : sig [annot]. *) (** return a box with an indent and minus the value of the indent to be used for a closing parenthesis *) - val box_fun_expr : Conf.t -> ctx0:Ast.t -> ctx:Ast.t -> parens:bool -> has_label:bool -> (Fmt.t -> Fmt.t) * int + val box_fun_expr : Conf.t -> source:Source.t -> ctx0:Ast.t -> ctx:Ast.t -> parens:bool -> has_label:bool -> (Fmt.t -> Fmt.t) * int val function_attrs_sp : Conf.t -> ctx0:Ast.t -> ctx:Ast.t -> bool (** Whether a space should be added between the [function] keyword and the diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index 09fa046996..33316477f0 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -932,8 +932,8 @@ let id x = x let idb1 = (fun id -> - let _ = id true in - id) + let _ = id true in + id) id ;; @@ -1081,8 +1081,8 @@ let rec devariantize : type t. t ty -> variant -> t = let builder = create_builder () in List.iter2 (fun (Field { label; field_type; set }) (lab, v) -> - if label <> lab then raise VariantMismatch; - set builder (devariantize field_type v)) + if label <> lab then raise VariantMismatch; + set builder (devariantize field_type v)) fields fl; of_builder builder @@ -1330,11 +1330,11 @@ let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = ; sum_cases = [ "Nil", TCnoarg Thd; "Cons", TCarg (Ttl Thd, tcons) ] ; sum_inj = (fun (type c) -> - (function - | Thd, Noarg -> `Nil - | Ttl Thd, v -> `Cons v - : (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist)) - (* One can also write the type annotation directly *) + (function + | Thd, Noarg -> `Nil + | Ttl Thd, v -> `Cons v + : (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist)) + (* One can also write the type annotation directly *) }) ;; @@ -9876,34 +9876,34 @@ let x = some_fun________________________________ some_arg______________________________ (fun param -> - do_something (); - do_something_else (); - return_this_value) + do_something (); + do_something_else (); + return_this_value) ;; let x = some_fun________________________________ some_arg______________________________ ~f:(fun param -> - do_something (); - do_something_else (); - return_this_value) + do_something (); + do_something_else (); + return_this_value) ;; let x = some_value |> some_fun (fun x -> - do_something (); - do_something_else (); - return_this_value) + do_something (); + do_something_else (); + return_this_value) ;; let x = some_value ^ some_fun (fun x -> - do_something (); - do_something_else (); - return_this_value) + do_something (); + do_something_else (); + return_this_value) ;; let bind t ~f = @@ -10016,9 +10016,9 @@ let _ = fooooooooooooooooooooooooooooooooooooooo fooooooooooooooooooooooooooooooooooooooo ~f:(fun (type a) foooooooooooooooooooooooooooooooooo : 'a -> - match fooooooooooooooooooooooooooooooooooooooo with - | Fooooooooooooooooooooooooooooooooooooooo -> x - | Fooooooooooooooooooooooooooooooooooooooo -> x) + match fooooooooooooooooooooooooooooooooooooooo with + | Fooooooooooooooooooooooooooooooooooooooo -> x + | Fooooooooooooooooooooooooooooooooooooooo -> x) ;; let _ = @@ -10076,17 +10076,17 @@ let _ = foo |> List.double_map ~f1:(fun x -> - do_something (); - do_something (); - do_something (); - do_something (); - do_something_else ()) + do_something (); + do_something (); + do_something (); + do_something (); + do_something_else ()) ~f2:(fun x -> - do_something (); - do_something (); - do_something (); - do_something (); - do_something_else ()) + do_something (); + do_something (); + do_something (); + do_something (); + do_something_else ()) |> bar ;; @@ -10221,9 +10221,9 @@ let _ = foooooooooooooooooooo foooooooooooooooooooo (fun x -> - match foo with - | Foooooooooooooooooooo -> foooooooooooooooooooo - | Foooooooooooooooooooo -> foooooooooooooooooooo) + match foo with + | Foooooooooooooooooooo -> foooooooooooooooooooo + | Foooooooooooooooooooo -> foooooooooooooooooooo) ;; let _ = @@ -10231,9 +10231,9 @@ let _ = foooooooooooooooooooo foooooooooooooooooooo ~x:(fun x -> - match foo with - | Foooooooooooooooooooo -> foooooooooooooooooooo - | Foooooooooooooooooooo -> foooooooooooooooooooo) + match foo with + | Foooooooooooooooooooo -> foooooooooooooooooooo + | Foooooooooooooooooooo -> foooooooooooooooooooo) ;; let _ = @@ -10388,8 +10388,8 @@ let () = match () with | _ -> (fun _ : _ -> - (match () with - | _ -> ())) + (match () with + | _ -> ())) | _ -> () ;; @@ -10421,9 +10421,9 @@ let _ = |> fooooooooooooooooooooooooooooooo ~fooooooooooooooooooooooooooooooo ~fooooooooooooooooooooooooooooooo:(fun foo -> - match bar with - | Some _ -> foo - | None -> baz) + match bar with + | Some _ -> foo + | None -> baz) ;; let _ = @@ -10434,9 +10434,9 @@ let _ = let _ = fooooooooooooooooooooooooooooooo |> fooooooooooooooooooooooooooooooo ~fooooooooooooooooooooooooooooooo (fun foo -> - match bar with - | Some _ -> foo - | None -> baz) + match bar with + | Some _ -> foo + | None -> baz) ;; let _ = @@ -10445,18 +10445,18 @@ let _ = ~fooooooooooooooooooooooooooooooo ~fooooooooooooooooooooooooooooooo (fun foo -> - match bar with - | Some _ -> foo - | None -> baz) + match bar with + | Some _ -> foo + | None -> baz) ;; let _ = fooooooooooooooooooooooooooooooo |> fooooooooooooooooooooooooooooooofooooooooooooooooooooooooooooooofoooooooooo (fun foo -> - match bar with - | Some _ -> foo - | None -> baz) + match bar with + | Some _ -> foo + | None -> baz) ;; let _ = From 91978f8da333c8cf49493a29bb3718c2cb4dc643 Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Fri, 26 Jul 2024 15:54:39 +0200 Subject: [PATCH 079/146] fix hovbox in `else function ...` block --- lib/Fmt_ast.ml | 9 ++++++++- lib/Params.ml | 2 +- test/passing/tests/function_indent-never.ml.ref | 3 ++- test/passing/tests/function_indent.ml.ref | 3 ++- 4 files changed, 13 insertions(+), 4 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index bef490c95c..dee3c7b2b0 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1517,7 +1517,14 @@ and fmt_function ?force_closing_paren ~ctx ~ctx0 ~wrap_intro ?box:(should_box = $ fmt_attributes ?pre c spilled_attrs $ fmt_attributes ?pre c cs_attrs in - (fun_ $ function_, (fmt_cases c ctx cs), box, 0) + let box_cases = + match ctx0 with + | Exp ({pexp_desc = Pexp_ifthenelse _; _}) + when Stdlib.(c.conf.fmt_opts.if_then_else.v = `Compact) -> + hvbox ~name:"cases box" 0 + | _ -> Fn.id + in + (fun_ $ function_, box_cases (fmt_cases c ctx cs), box, 0) in let space_opn_parens, space_cls_parens = match ctx0 with diff --git a/lib/Params.ml b/lib/Params.ml index c634ec1b32..254e8053b0 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -604,7 +604,7 @@ let get_if_then_else (c : Conf.t) ~first ~last ~parens_bch ~parens_prev_bch let branch_pro = fmt_or (beginend || parens_bch) (str " ") (break 1 2) in match c.fmt_opts.if_then_else.v with | `Compact -> - { box_branch= hovbox 2 + { box_branch= hovbox ~name:"Params.get_if_then_else `Compact" 2 ; cond= cond () ; box_keyword_and_expr= Fn.id ; branch_pro= fmt_or (beginend || parens_bch) (str " ") space_break diff --git a/test/passing/tests/function_indent-never.ml.ref b/test/passing/tests/function_indent-never.ml.ref index 12b07056bd..de82a9280f 100644 --- a/test/passing/tests/function_indent-never.ml.ref +++ b/test/passing/tests/function_indent-never.ml.ref @@ -20,5 +20,6 @@ let foooooooo = if fooooooooooo then function | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo - else function fooooooooooooooooooooooo -> foooooooooooooooooooooooooo + else function + | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo diff --git a/test/passing/tests/function_indent.ml.ref b/test/passing/tests/function_indent.ml.ref index a66e0ceecb..63903bc063 100644 --- a/test/passing/tests/function_indent.ml.ref +++ b/test/passing/tests/function_indent.ml.ref @@ -20,5 +20,6 @@ let foooooooo = if fooooooooooo then function | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo - else function fooooooooooooooooooooooo -> foooooooooooooooooooooooooo + else function + | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo From 637bda9828a33ae9ae879af364abf22547d365a0 Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Mon, 29 Jul 2024 14:32:35 +0200 Subject: [PATCH 080/146] add stacktraces to the html debug output --- lib/Conf.ml | 4 ++- lib/Fmt.ml | 28 +++++++++++++------- lib/box_debug.ml | 68 ++++++++++++++++++++++++++++++++++-------------- 3 files changed, 70 insertions(+), 30 deletions(-) diff --git a/lib/Conf.ml b/lib/Conf.ml index 741a32f495..0f1413b582 100644 --- a/lib/Conf.ml +++ b/lib/Conf.ml @@ -1401,7 +1401,9 @@ module Operational = struct let debug = let doc = "Generate debugging output." in Decl.flag ~default ~names:["g"; "debug"] ~doc ~kind - (fun conf elt -> update conf ~f:(fun f -> {f with debug= elt})) + (fun conf elt -> + if elt.v then Box_debug.enable_stacktraces := true ; + update conf ~f:(fun f -> {f with debug= elt}) ) (fun conf -> conf.opr_opts.debug) let disable = diff --git a/lib/Fmt.ml b/lib/Fmt.ml index f84eb67acf..3706fd3127 100644 --- a/lib/Fmt.ml +++ b/lib/Fmt.ml @@ -88,30 +88,36 @@ let with_box_debug k = with_pp (Box_debug.with_box (fun fs -> eval fs k)) (** Break hints and format strings --------------------------------------*) let break n o = + let stack = Box_debug.get_stack () in with_pp (fun fs -> - Box_debug.break fs n o ; + Box_debug.break fs n o ~stack ; Format_.pp_print_break fs n o ) let force_break = break 1000 0 let space_break = + (* a stack is useless here, this would require adding a unit parameter *) + let stack = "" in with_pp (fun fs -> - Box_debug.space_break fs ; + Box_debug.space_break ~stack fs ; Format_.pp_print_space fs () ) let cut_break = + let stack = Box_debug.get_stack () in with_pp (fun fs -> - Box_debug.cut_break fs ; + Box_debug.cut_break ~stack fs ; Format_.pp_print_cut fs () ) let force_newline = + let stack = Box_debug.get_stack () in with_pp (fun fs -> - Box_debug.force_newline fs ; + Box_debug.force_newline ~stack fs ; Format_.pp_force_newline fs () ) let cbreak ~fits ~breaks = + let stack = Box_debug.get_stack () in with_pp (fun fs -> - Box_debug.cbreak fs ~fits ~breaks ; + Box_debug.cbreak fs ~stack ~fits ~breaks ; Format_.pp_print_custom_break fs ~fits ~breaks ) let noop = with_pp (fun _ -> ()) @@ -245,27 +251,31 @@ let wrap_fits_breaks ?(space = true) conf x = let apply_max_indent n = Option.value_map !max_indent ~f:(min n) ~default:n let open_box ?name n = + let stack = Box_debug.get_stack () in with_pp (fun fs -> let n = apply_max_indent n in - Box_debug.box_open ?name "b" n fs ; + Box_debug.box_open ~stack ?name "b" n fs ; Format_.pp_open_box fs n ) and open_vbox ?name n = + let stack = Box_debug.get_stack () in with_pp (fun fs -> let n = apply_max_indent n in - Box_debug.box_open ?name "v" n fs ; + Box_debug.box_open ~stack ?name "v" n fs ; Format_.pp_open_vbox fs n ) and open_hvbox ?name n = + let stack = Box_debug.get_stack () in with_pp (fun fs -> let n = apply_max_indent n in - Box_debug.box_open ?name "hv" n fs ; + Box_debug.box_open ~stack ?name "hv" n fs ; Format_.pp_open_hvbox fs n ) and open_hovbox ?name n = + let stack = Box_debug.get_stack () in with_pp (fun fs -> let n = apply_max_indent n in - Box_debug.box_open ?name "hov" n fs ; + Box_debug.box_open ~stack ?name "hov" n fs ; Format_.pp_open_hovbox fs n ) and close_box = diff --git a/lib/box_debug.ml b/lib/box_debug.ml index 819f87dcd2..78546d8342 100644 --- a/lib/box_debug.ml +++ b/lib/box_debug.ml @@ -44,22 +44,31 @@ let css = } .tooltiptext { visibility: hidden; - width: 120px; + width: min-content; + white-space: pre; background-color: black; color: #fff; - text-align: center; - padding: 5px 0; + text-align: left; + padding: 5px 5px; border-radius: 6px; position: absolute; z-index: 1; } - .break:hover .tooltiptext { + + div:hover>.tooltiptext, span:hover>.tooltiptext { visibility: visible; } |} let debug = ref false +let enable_stacktraces = ref false + +let get_stack () = + if !enable_stacktraces then + Stdlib.Printexc.(30 |> get_callstack |> raw_backtrace_to_string) + else "" + let fprintf_as_0 fs fmt = Format_.kasprintf (Format_.pp_print_as fs 0) fmt let debugf fs fmt = @@ -93,25 +102,44 @@ let pp_box_name fs = function let pp_box_indent fs = function 0 -> () | i -> Format_.fprintf fs "(%d)" i -let box_open ?name box_kind n fs = - debugf fs "

%s%a%a

" box_kind - pp_box_name name pp_box_indent n +let stack_tooltip fs stack = + debugf fs "%s" stack + +let box_open ?name ~stack box_kind n fs = + debugf fs "

%s%a%a%a

" + box_kind pp_box_name name stack_tooltip stack pp_box_indent n let box_close fs = debugf fs "
" -let break fs n o = +let break fs n o ~stack = debugf fs - "
(%i,%i)break %i \ - %i
" - n o n o + "
(%i,%i)break %i %i\n\ + %s
" + n o n o stack + +let space_break fs ~stack = + debugf fs "
space_break%a
" + stack_tooltip stack + +let cut_break fs ~stack = + debugf fs "
cut_break%a
" stack_tooltip + stack + +let force_newline fs ~stack = + debugf fs "
force_newline%a
" + stack_tooltip stack -let space_break fs = - debugf fs "
space_break
" +let space_break fs ~stack = + debugf fs "
space_break%a
" + stack_tooltip stack -let cut_break fs = debugf fs "
cut_break
" +let cut_break fs ~stack = + debugf fs "
cut_break%a
" stack_tooltip + stack -let force_newline fs = - debugf fs "
force_newline
" +let force_newline fs ~stack = + debugf fs "
force_newline%a
" + stack_tooltip stack let pp_keyword fs s = fprintf_as_0 fs "%s" s @@ -153,12 +181,12 @@ let fmt fs f = _format_string fs fmt ; true ) else false -let cbreak fs ~fits:(s1, i, s2) ~breaks:(s3, j, s4) = +let cbreak fs ~stack ~fits:(s1, i, s2) ~breaks:(s3, j, s4) = debugf fs "
(%s,%i,%s) (%s,%i,%s)cbreak ~fits:(%S, %i, %S) ~breaks:(%S, %i, \ - %S)
" - s1 i s2 s3 j s4 s1 i s2 s3 j s4 + class=\"tooltiptext\">cbreak ~fits:(%S, %i, %S) ~breaks:(%S, %i, %S)\n\ + %s
" + s1 i s2 s3 j s4 s1 i s2 s3 j s4 stack let if_newline fs s = debugf fs From caee894531d73787a7ace6b6faebe95bf21beebe Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Mon, 29 Jul 2024 16:33:39 +0200 Subject: [PATCH 081/146] fix wrongful squash and answer review --- lib/Fmt.ml | 6 ++---- lib/box_debug.ml | 24 +++++++----------------- 2 files changed, 9 insertions(+), 21 deletions(-) diff --git a/lib/Fmt.ml b/lib/Fmt.ml index 3706fd3127..88fee3f582 100644 --- a/lib/Fmt.ml +++ b/lib/Fmt.ml @@ -97,15 +97,13 @@ let force_break = break 1000 0 let space_break = (* a stack is useless here, this would require adding a unit parameter *) - let stack = "" in with_pp (fun fs -> - Box_debug.space_break ~stack fs ; + Box_debug.space_break fs ; Format_.pp_print_space fs () ) let cut_break = - let stack = Box_debug.get_stack () in with_pp (fun fs -> - Box_debug.cut_break ~stack fs ; + Box_debug.cut_break fs ; Format_.pp_print_cut fs () ) let force_newline = diff --git a/lib/box_debug.ml b/lib/box_debug.ml index 78546d8342..7b1c7bdcca 100644 --- a/lib/box_debug.ml +++ b/lib/box_debug.ml @@ -103,9 +103,11 @@ let pp_box_name fs = function let pp_box_indent fs = function 0 -> () | i -> Format_.fprintf fs "(%d)" i let stack_tooltip fs stack = - debugf fs "%s" stack + match stack with + | Some stack -> debugf fs "%s" stack + | None -> () -let box_open ?name ~stack box_kind n fs = +let box_open ?name ?stack box_kind n fs = debugf fs "

%s%a%a%a

" box_kind pp_box_name name stack_tooltip stack pp_box_indent n @@ -117,27 +119,15 @@ let break fs n o ~stack = %s
" n o n o stack -let space_break fs ~stack = - debugf fs "
space_break%a
" - stack_tooltip stack - -let cut_break fs ~stack = - debugf fs "
cut_break%a
" stack_tooltip - stack - -let force_newline fs ~stack = - debugf fs "
force_newline%a
" - stack_tooltip stack - -let space_break fs ~stack = +let space_break ?stack fs = debugf fs "
space_break%a
" stack_tooltip stack -let cut_break fs ~stack = +let cut_break ?stack fs = debugf fs "
cut_break%a
" stack_tooltip stack -let force_newline fs ~stack = +let force_newline ?stack fs = debugf fs "
force_newline%a
" stack_tooltip stack From 07927f8a80d6094c7edf21ee671786511c67605f Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Mon, 29 Jul 2024 17:48:53 +0200 Subject: [PATCH 082/146] Fmt.str also produces stack information --- lib/Fmt.ml | 10 ++++++++-- lib/box_debug.ml | 7 +++++++ 2 files changed, 15 insertions(+), 2 deletions(-) diff --git a/lib/Fmt.ml b/lib/Fmt.ml index 88fee3f582..c13b3649fb 100644 --- a/lib/Fmt.ml +++ b/lib/Fmt.ml @@ -140,9 +140,15 @@ let char c = with_pp (fun fs -> Format_.pp_print_char fs c) let utf8_length s = Uuseg_string.fold_utf_8 `Grapheme_cluster (fun n _ -> n + 1) 0 s -let str_as n s = with_pp (fun fs -> Format_.pp_print_as fs n s) +let str_as n s = + let stack = Box_debug.get_stack () in + with_pp (fun fs -> + Box_debug.start_str fs; + Format_.pp_print_as fs n s; + Box_debug.end_str ~stack fs) -let str s = if String.is_empty s then noop else str_as (utf8_length s) s +let str s = + if String.is_empty s then noop else str_as (utf8_length s) s let sp = function | Blank -> char ' ' diff --git a/lib/box_debug.ml b/lib/box_debug.ml index 7b1c7bdcca..06a0a7006b 100644 --- a/lib/box_debug.ml +++ b/lib/box_debug.ml @@ -53,6 +53,7 @@ let css = border-radius: 6px; position: absolute; z-index: 1; + font-size: 10px; } div:hover>.tooltiptext, span:hover>.tooltiptext { @@ -131,6 +132,12 @@ let force_newline ?stack fs = debugf fs "
force_newline%a
" stack_tooltip stack +let start_str fs = + debugf fs "" + +let end_str ?stack fs = debugf fs "%a" stack_tooltip stack + + let pp_keyword fs s = fprintf_as_0 fs "%s" s let _pp_format_lit fs = From 49246e0d88afcad23b482f3b4b6bf5f6c958e876 Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Tue, 30 Jul 2024 17:07:33 +0200 Subject: [PATCH 083/146] fix args in fun box --- lib/Fmt_ast.ml | 11 +++++----- lib/Params.ml | 22 ++++++++++++++----- lib/Params.mli | 3 ++- .../break_fun_decl-fit_or_vertical.ml.ref | 6 ++--- .../passing/tests/break_fun_decl-smart.ml.ref | 6 ++--- test/passing/tests/break_fun_decl-wrap.ml.ref | 6 ++--- test/passing/tests/break_fun_decl.ml | 6 ++--- test/passing/tests/js_source.ml.ref | 2 +- test/passing/tests/labelled_args-414.ml.ref | 10 ++++----- test/passing/tests/labelled_args.ml | 10 ++++----- test/passing/tests/max_indent.ml | 5 +++-- 11 files changed, 50 insertions(+), 37 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index dee3c7b2b0..7db6b55604 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1446,7 +1446,7 @@ and fmt_indexop_access c ctx ~fmt_atrs ~has_attr ~parens x = (** Format a [Pexp_function]. [wrap_intro] wraps up to after the [->] and is responsible for breaking. *) -and fmt_function ?force_closing_paren ~ctx ~ctx0 ~wrap_intro ?box:(should_box = true) +and fmt_function ?(last_arg=false) ?force_closing_paren ~ctx ~ctx0 ~wrap_intro ?box:(should_box = true) ~label ?(parens = false) ?ext ~attrs ~loc c (args, typ, body) = let has_label = match label with Nolabel -> false | _ -> true in (* Make sure the comment is placed after the eventual label but not into @@ -1471,12 +1471,13 @@ and fmt_function ?force_closing_paren ~ctx ~ctx0 ~wrap_intro ?box:(should_box = in let fmt_fun_args_typ args typ = let kw = - str "fun" $ fmt_extension_suffix c ext $ fmt_attributes c ~pre:Blank attrs $ space_break + str "fun" $ fmt_extension_suffix c ext $ fmt_attributes c ~pre:Blank attrs + $ (if last_arg then break 1 2 else break 1 0) and args = fmt_expr_fun_args c args and annot = Option.map ~f:fmt_typ typ in - Params.Exp.box_fun_decl_args ~ctx:ctx0 c.conf ~parens ~kw ~args ~annot - $ Params.Exp.break_fun_decl_args ~ctx:ctx0 $ str "->" + Params.Exp.box_fun_decl_args ~kw_in_box:(not last_arg) ~ctx:ctx0 c.conf ~parens ~kw ~args ~annot + $ Params.Exp.break_fun_decl_args ~ctx:ctx0 ~last_arg $ str "->" in let lead_with_function_kw = match args, body with | [], Pfunction_cases _ -> true | _ -> false @@ -2090,7 +2091,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens then Fit else Break in - fmt_function~force_closing_paren ~ctx:inner_ctx ~ctx0:ctx ~wrap_intro ~label:lbl ~parens:true ~attrs:last_arg.pexp_attributes ~loc:last_arg.pexp_loc c (largs, ltyp, lbody) + fmt_function ~last_arg:true ~force_closing_paren ~ctx:inner_ctx ~ctx0:ctx ~wrap_intro ~label:lbl ~parens:true ~attrs:last_arg.pexp_attributes ~loc:last_arg.pexp_loc c (largs, ltyp, lbody) in hvbox_if has_attr 0 (expr_epi $ Params.parens_if parens c.conf (args $ fmt_atrs)) diff --git a/lib/Params.ml b/lib/Params.ml index 254e8053b0..79efcef469 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -117,7 +117,7 @@ module Exp = struct $ Fmt.fits_breaks ")" ~hint:(1000, offset_closing_paren) ")" | `No -> wrap (str "(") (str ")") k - let box_fun_decl_args ~ctx c ~parens ~kw ~args ~annot = + let box_fun_decl_args ~ctx ?(kw_in_box=true) c ~parens ~kw ~args ~annot = let is_let_func = match ctx with Ast.Str _ -> @@ -127,10 +127,18 @@ module Exp = struct let box_decl, should_box_args = if ocp c then (hvbox ~name (if parens then 1 else 2), false) else - ( (if is_let_func then hovbox ~name 4 else hvbox ~name (if parens then 1 else 2)) + ( + ( if is_let_func + then hovbox ~name 4 + else hvbox ~name (if parens then 1 else 2) ) , not c.fmt_opts.wrap_fun_args.v ) in - box_decl (kw $ hvbox_if should_box_args 0 args $ fmt_opt annot) + let box_decl = + if not kw_in_box then hvbox ~name 0 + else box_decl + in + let kw_out_of_box, kw_in_box = if kw_in_box then noop, kw else kw, noop in + kw_out_of_box $ box_decl (kw_in_box $ hvbox_if should_box_args 0 args $ fmt_opt annot) let box_fun_expr (c : Conf.t) ~source ~ctx0 ~ctx ~parens ~has_label:_ = let indent = @@ -171,10 +179,12 @@ module Exp = struct && List.for_all ~f:arg_is_simple_approx other_args ) | _ -> false - let break_fun_decl_args ~ctx = + let break_fun_decl_args ~ctx ~last_arg = match ctx with - Ast.Str _ -> - (* special case that break the arrow in [let _ = fun ... ->] *) (str " ") | _ -> break 1 (-2) + | Ast.Str _ -> + (* special case that break the arrow in [let _ = fun ... ->] *) + (str " ") + | _ -> break 1 (if last_arg then 0 else (-2)) end diff --git a/lib/Params.mli b/lib/Params.mli index 60b7fa7ab4..aa24d9710a 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -38,6 +38,7 @@ module Exp : sig val box_fun_decl_args : ctx:Ast.t + -> ?kw_in_box:bool -> Conf.t -> parens:bool -> kw:Fmt.t @@ -54,7 +55,7 @@ module Exp : sig (** Whether a space should be added between the [function] keyword and the attributes. *) - val break_fun_decl_args : ctx:Ast.t -> Fmt.t + val break_fun_decl_args : ctx:Ast.t -> last_arg:bool -> Fmt.t end diff --git a/test/passing/tests/break_fun_decl-fit_or_vertical.ml.ref b/test/passing/tests/break_fun_decl-fit_or_vertical.ml.ref index d93df61cf7..a64269cd7d 100644 --- a/test/passing/tests/break_fun_decl-fit_or_vertical.ml.ref +++ b/test/passing/tests/break_fun_decl-fit_or_vertical.ml.ref @@ -126,9 +126,9 @@ let _ = let _ = f (fun - (module Store : Irmin.Generic_key.S with type repo = repo) - (module Store : Irmin.Generic_key.S with type repo = repo) - -> body ) + (module Store : Irmin.Generic_key.S with type repo = repo) + (module Store : Irmin.Generic_key.S with type repo = repo) + -> body ) let f (module Store : Irmin.Generic_key.S with type repo = repo) diff --git a/test/passing/tests/break_fun_decl-smart.ml.ref b/test/passing/tests/break_fun_decl-smart.ml.ref index c7d3bc4190..55a4a10d01 100644 --- a/test/passing/tests/break_fun_decl-smart.ml.ref +++ b/test/passing/tests/break_fun_decl-smart.ml.ref @@ -119,9 +119,9 @@ let _ = let _ = f (fun - (module Store : Irmin.Generic_key.S with type repo = repo) - (module Store : Irmin.Generic_key.S with type repo = repo) - -> body ) + (module Store : Irmin.Generic_key.S with type repo = repo) + (module Store : Irmin.Generic_key.S with type repo = repo) + -> body ) let f (module Store : Irmin.Generic_key.S with type repo = repo) diff --git a/test/passing/tests/break_fun_decl-wrap.ml.ref b/test/passing/tests/break_fun_decl-wrap.ml.ref index 88a8c80cdc..49c0427d6a 100644 --- a/test/passing/tests/break_fun_decl-wrap.ml.ref +++ b/test/passing/tests/break_fun_decl-wrap.ml.ref @@ -101,9 +101,9 @@ let _ = let _ = f (fun - (module Store : Irmin.Generic_key.S with type repo = repo) - (module Store : Irmin.Generic_key.S with type repo = repo) - -> body ) + (module Store : Irmin.Generic_key.S with type repo = repo) + (module Store : Irmin.Generic_key.S with type repo = repo) + -> body ) let f (module Store : Irmin.Generic_key.S with type repo = repo) (module Store : Irmin.Generic_key.S with type repo = repo) = diff --git a/test/passing/tests/break_fun_decl.ml b/test/passing/tests/break_fun_decl.ml index 88a8c80cdc..49c0427d6a 100644 --- a/test/passing/tests/break_fun_decl.ml +++ b/test/passing/tests/break_fun_decl.ml @@ -101,9 +101,9 @@ let _ = let _ = f (fun - (module Store : Irmin.Generic_key.S with type repo = repo) - (module Store : Irmin.Generic_key.S with type repo = repo) - -> body ) + (module Store : Irmin.Generic_key.S with type repo = repo) + (module Store : Irmin.Generic_key.S with type repo = repo) + -> body ) let f (module Store : Irmin.Generic_key.S with type repo = repo) (module Store : Irmin.Generic_key.S with type repo = repo) = diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index 33316477f0..40e858d089 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -9933,7 +9933,7 @@ let () = very_long_argument_name_one very_long_argument_name_two very_long_argument_name_three - -> ()) + -> ()) ;; let () = diff --git a/test/passing/tests/labelled_args-414.ml.ref b/test/passing/tests/labelled_args-414.ml.ref index 9d76e837fd..6f7577d6aa 100644 --- a/test/passing/tests/labelled_args-414.ml.ref +++ b/test/passing/tests/labelled_args-414.ml.ref @@ -5,10 +5,10 @@ let _ = let () = very_long_function_name ~very_long_argument_label:(fun - very_long_argument_name_one - very_long_argument_name_two - very_long_argument_name_three - -> () ) + very_long_argument_name_one + very_long_argument_name_two + very_long_argument_name_three + -> () ) let () = very_long_function_name @@ -17,4 +17,4 @@ let () = very_long_argument_name_one very_long_argument_name_two very_long_argument_name_three - -> () ) + -> () ) diff --git a/test/passing/tests/labelled_args.ml b/test/passing/tests/labelled_args.ml index e7a25ae703..ed530ced7b 100644 --- a/test/passing/tests/labelled_args.ml +++ b/test/passing/tests/labelled_args.ml @@ -5,10 +5,10 @@ let _ = let () = very_long_function_name ~very_long_argument_label:(fun - very_long_argument_name_one - very_long_argument_name_two - very_long_argument_name_three - -> () ) + very_long_argument_name_one + very_long_argument_name_two + very_long_argument_name_three + -> () ) let () = very_long_function_name @@ -17,4 +17,4 @@ let () = very_long_argument_name_one very_long_argument_name_two very_long_argument_name_three - -> () ) + -> () ) diff --git a/test/passing/tests/max_indent.ml b/test/passing/tests/max_indent.ml index 5f7f5bc5e1..984dd7e166 100644 --- a/test/passing/tests/max_indent.ml +++ b/test/passing/tests/max_indent.ml @@ -7,8 +7,9 @@ let () = let () = fooooo |> List.iter - (fun some_really_really_really_long_name_that_doesn't_fit_on_the_line - -> + (fun + some_really_really_really_long_name_that_doesn't_fit_on_the_line + -> let x = some_really_really_really_long_name_that_doesn't_fit_on_the_line $ y in From 21b59ff7916f8b48ff843108c0ad12f95e6d98ac Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Tue, 30 Jul 2024 14:25:10 +0200 Subject: [PATCH 084/146] Fix regression with break_colon=before and ocp-indent-compat --- lib/Fmt_ast.ml | 7 ++++++- test/passing/tests/break_colon-before.ml.ref | 8 ++++---- 2 files changed, 10 insertions(+), 5 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 7db6b55604..0cbb2f1f67 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -753,7 +753,12 @@ and fmt_type_cstr c ?(pro=":") ?constraint_ctx xtyp = match xtyp.ast.ptyp_desc with | (Ptyp_poly (_, { ptyp_desc= Ptyp_arrow _; _ }) | Ptyp_arrow _) when colon_before -> - let outer_pro = fits_breaks (pro ^ " ") (pro ^ " ") in + let outer_pro = + if c.conf.fmt_opts.ocp_indent_compat.v then + fits_breaks (pro ^ " ") (pro ^ " ") + else + str pro $ str " " + in let pre_break = if colon_before then fits_breaks " " ~hint:(1000, 0) "" else break 0 ~-1 in let wrap x = pre_break $ cbox 0 (outer_pro $ x) in wrap, None, false diff --git a/test/passing/tests/break_colon-before.ml.ref b/test/passing/tests/break_colon-before.ml.ref index 73278765a3..1568b091ad 100644 --- a/test/passing/tests/break_colon-before.ml.ref +++ b/test/passing/tests/break_colon-before.ml.ref @@ -70,10 +70,10 @@ let ssmap () let ssmap - : (module MapT - with type key = string - and type data = string - and type map = SSMap.map ) + : (module MapT + with type key = string + and type data = string + and type map = SSMap.map ) -> unit = () From 03484d46e17188e654325468c706b030f2f82d8b Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Wed, 31 Jul 2024 12:10:15 +0200 Subject: [PATCH 085/146] fixes yesterday's regression --- lib/Fmt_ast.ml | 12 ++++++++---- lib/Params.ml | 4 ++-- lib/Params.mli | 2 +- .../tests/break_fun_decl-fit_or_vertical.ml.ref | 6 +++--- test/passing/tests/break_fun_decl-smart.ml.ref | 6 +++--- test/passing/tests/break_fun_decl-wrap.ml.ref | 6 +++--- test/passing/tests/break_fun_decl.ml | 6 +++--- test/passing/tests/max_indent.ml | 4 ++-- 8 files changed, 25 insertions(+), 21 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 7db6b55604..0171b46feb 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1458,13 +1458,17 @@ and fmt_function ?(last_arg=false) ?force_closing_paren ~ctx ~ctx0 ~wrap_intro ? let cmts = Cmts.fmt_before ?eol c loc in if has_label then (false, noop, cmts) else (has_cmts, cmts, noop) in - let (label_sep : t), _break_fun = + let (label_sep : t), break_fun = (* Break between the label and the fun to avoid ocp-indent's alignment. If a label is present, arguments should be indented more than the arrow and the eventually breaking [fun] keyword. *) if c.conf.fmt_opts.ocp_indent_compat.v then (str ":" $ cut_break, break 1 2) - else (str ":", if has_label then break 1 2 else space_break) + else + (str ":" + , if has_label + then break 1 2 + else break 1 0) in let fmt_typ typ = fmt_type_pcstr c ~ctx ~constraint_ctx:`Fun typ @@ -1472,12 +1476,12 @@ and fmt_function ?(last_arg=false) ?force_closing_paren ~ctx ~ctx0 ~wrap_intro ? let fmt_fun_args_typ args typ = let kw = str "fun" $ fmt_extension_suffix c ext $ fmt_attributes c ~pre:Blank attrs - $ (if last_arg then break 1 2 else break 1 0) + $ (if last_arg then break_fun else break 1 0) and args = fmt_expr_fun_args c args and annot = Option.map ~f:fmt_typ typ in Params.Exp.box_fun_decl_args ~kw_in_box:(not last_arg) ~ctx:ctx0 c.conf ~parens ~kw ~args ~annot - $ Params.Exp.break_fun_decl_args ~ctx:ctx0 ~last_arg $ str "->" + $ Params.Exp.break_fun_decl_args ~ctx:ctx0 ~last_arg ~has_label $ str "->" in let lead_with_function_kw = match args, body with | [], Pfunction_cases _ -> true | _ -> false diff --git a/lib/Params.ml b/lib/Params.ml index 79efcef469..92bd50fb1e 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -179,12 +179,12 @@ module Exp = struct && List.for_all ~f:arg_is_simple_approx other_args ) | _ -> false - let break_fun_decl_args ~ctx ~last_arg = + let break_fun_decl_args ~ctx ~last_arg ~has_label = match ctx with | Ast.Str _ -> (* special case that break the arrow in [let _ = fun ... ->] *) (str " ") - | _ -> break 1 (if last_arg then 0 else (-2)) + | _ -> break 1 (if last_arg && has_label then 0 else (-2)) end diff --git a/lib/Params.mli b/lib/Params.mli index aa24d9710a..cc38e11f70 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -55,7 +55,7 @@ module Exp : sig (** Whether a space should be added between the [function] keyword and the attributes. *) - val break_fun_decl_args : ctx:Ast.t -> last_arg:bool -> Fmt.t + val break_fun_decl_args : ctx:Ast.t -> last_arg:bool -> has_label:bool -> Fmt.t end diff --git a/test/passing/tests/break_fun_decl-fit_or_vertical.ml.ref b/test/passing/tests/break_fun_decl-fit_or_vertical.ml.ref index a64269cd7d..d93df61cf7 100644 --- a/test/passing/tests/break_fun_decl-fit_or_vertical.ml.ref +++ b/test/passing/tests/break_fun_decl-fit_or_vertical.ml.ref @@ -126,9 +126,9 @@ let _ = let _ = f (fun - (module Store : Irmin.Generic_key.S with type repo = repo) - (module Store : Irmin.Generic_key.S with type repo = repo) - -> body ) + (module Store : Irmin.Generic_key.S with type repo = repo) + (module Store : Irmin.Generic_key.S with type repo = repo) + -> body ) let f (module Store : Irmin.Generic_key.S with type repo = repo) diff --git a/test/passing/tests/break_fun_decl-smart.ml.ref b/test/passing/tests/break_fun_decl-smart.ml.ref index 55a4a10d01..c7d3bc4190 100644 --- a/test/passing/tests/break_fun_decl-smart.ml.ref +++ b/test/passing/tests/break_fun_decl-smart.ml.ref @@ -119,9 +119,9 @@ let _ = let _ = f (fun - (module Store : Irmin.Generic_key.S with type repo = repo) - (module Store : Irmin.Generic_key.S with type repo = repo) - -> body ) + (module Store : Irmin.Generic_key.S with type repo = repo) + (module Store : Irmin.Generic_key.S with type repo = repo) + -> body ) let f (module Store : Irmin.Generic_key.S with type repo = repo) diff --git a/test/passing/tests/break_fun_decl-wrap.ml.ref b/test/passing/tests/break_fun_decl-wrap.ml.ref index 49c0427d6a..88a8c80cdc 100644 --- a/test/passing/tests/break_fun_decl-wrap.ml.ref +++ b/test/passing/tests/break_fun_decl-wrap.ml.ref @@ -101,9 +101,9 @@ let _ = let _ = f (fun - (module Store : Irmin.Generic_key.S with type repo = repo) - (module Store : Irmin.Generic_key.S with type repo = repo) - -> body ) + (module Store : Irmin.Generic_key.S with type repo = repo) + (module Store : Irmin.Generic_key.S with type repo = repo) + -> body ) let f (module Store : Irmin.Generic_key.S with type repo = repo) (module Store : Irmin.Generic_key.S with type repo = repo) = diff --git a/test/passing/tests/break_fun_decl.ml b/test/passing/tests/break_fun_decl.ml index 49c0427d6a..88a8c80cdc 100644 --- a/test/passing/tests/break_fun_decl.ml +++ b/test/passing/tests/break_fun_decl.ml @@ -101,9 +101,9 @@ let _ = let _ = f (fun - (module Store : Irmin.Generic_key.S with type repo = repo) - (module Store : Irmin.Generic_key.S with type repo = repo) - -> body ) + (module Store : Irmin.Generic_key.S with type repo = repo) + (module Store : Irmin.Generic_key.S with type repo = repo) + -> body ) let f (module Store : Irmin.Generic_key.S with type repo = repo) (module Store : Irmin.Generic_key.S with type repo = repo) = diff --git a/test/passing/tests/max_indent.ml b/test/passing/tests/max_indent.ml index 984dd7e166..89e7b40654 100644 --- a/test/passing/tests/max_indent.ml +++ b/test/passing/tests/max_indent.ml @@ -8,8 +8,8 @@ let () = fooooo |> List.iter (fun - some_really_really_really_long_name_that_doesn't_fit_on_the_line - -> + some_really_really_really_long_name_that_doesn't_fit_on_the_line + -> let x = some_really_really_really_long_name_that_doesn't_fit_on_the_line $ y in From a5aae14e60b1512198e06fc377e8c6e022cfa0bc Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Wed, 31 Jul 2024 14:14:29 +0200 Subject: [PATCH 086/146] Fix indentation of 'f (fun -> )' after a comment --- lib/Fmt_ast.ml | 9 +++++---- test/passing/tests/fun_decl.ml | 6 ++++++ 2 files changed, 11 insertions(+), 4 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 01f81a6783..c9b1795462 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -2089,10 +2089,11 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens let inner_ctx = Exp (last_arg) in let args = let wrap_intro x = - wrap - ( intro_epi - $ fmt_args_grouped e0 args_before - $ break 1 0 $ hvbox 0 x ) + hvbox 0 ( + intro_epi + $ wrap + ( fmt_args_grouped e0 args_before + $ break 1 0 $ hvbox 0 x )) $ break 1 0 in let force_closing_paren = diff --git a/test/passing/tests/fun_decl.ml b/test/passing/tests/fun_decl.ml index 410a6b4549..a8683cec55 100644 --- a/test/passing/tests/fun_decl.ml +++ b/test/passing/tests/fun_decl.ml @@ -89,3 +89,9 @@ let f _ = fun x -> let foooooooooooooooooooooooooooo = foooooooooooooooooooooooooooo in x + +let space_break = + (* a stack is useless here, this would require adding a unit parameter *) + with_pp (fun fs -> + Box_debug.space_break fs ; + Format_.pp_print_space fs () ) From 8e94981bc77e5f4b9f9bb2fdb955097b341cab82 Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Thu, 1 Aug 2024 14:05:25 +0200 Subject: [PATCH 087/146] fix last regression before formatting the pr It does not change anything in the test suite which is weird. --- lib/Params.ml | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/lib/Params.ml b/lib/Params.ml index 92bd50fb1e..ed861a611a 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -48,6 +48,21 @@ let ctx_is_apply_and_exp_is_last_arg ~ctx ctx0 = Poly.equal last_arg exp | _ -> false + let ctx_is_apply_and_exp_is_last_arg_and_other_args_are_simple c ~ctx ctx0 = + match (ctx, ctx0) with + | Exp exp, Exp {pexp_desc= Pexp_apply (_, args); _} -> + let (_lbl, last_arg), args_before = + match List.rev args with + | [] -> assert false + | hd :: tl -> (hd, List.rev tl) + in + let args_are_simple = + List.for_all args_before ~f:(fun (_, eI) -> + is_simple c (fun _ -> 0) (sub_exp ~ctx:ctx0 eI) ) + in + Poly.equal last_arg exp && args_are_simple + | _ -> false + (** [ctx_is_let ~ctx ctx0] checks whether [ctx0] is a let binding containing [ctx]. *) let ctx_is_let ~ctx = function @@ -157,8 +172,10 @@ module Exp = struct (* if ctx_is_apply_and_exp_is_last_arg ~ctx ctx0 then 2 else *) if begins_line x.loc then 4 else 2 | None -> if parens then 3 else 2 - else - if ctx_is_apply_and_exp_is_last_arg ~ctx ctx0 then 4 else 2 + else if ctx_is_apply_and_exp_is_last_arg_and_other_args_are_simple c ~ctx ctx0 + then 4 + else 2 + in let name = "Params.box_fun_expr" in let mkbox = match ctx0 with Str _ -> hvbox | _ -> hovbox in From 040d9b2c3884d5bcd302da08cfe78c112f42fbbb Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Thu, 1 Aug 2024 14:16:55 +0200 Subject: [PATCH 088/146] add stack traces to break_unless_newline and others --- lib/Fmt.ml | 9 ++++++--- lib/box_debug.ml | 18 +++++++++--------- 2 files changed, 15 insertions(+), 12 deletions(-) diff --git a/lib/Fmt.ml b/lib/Fmt.ml index c13b3649fb..2aaef5a73e 100644 --- a/lib/Fmt.ml +++ b/lib/Fmt.ml @@ -196,13 +196,15 @@ let fmt_opt o = Option.value o ~default:noop (** Conditional on immediately following a line break -------------------*) let if_newline s = + let stack = Box_debug.get_stack () in with_pp (fun fs -> - Box_debug.if_newline fs s ; + Box_debug.if_newline fs ~stack s ; Format_.pp_print_string_if_newline fs s ) let break_unless_newline n o = + let stack = Box_debug.get_stack () in with_pp (fun fs -> - Box_debug.break_unless_newline fs n o ; + Box_debug.break_unless_newline fs ~stack n o ; Format_.pp_print_or_newline fs n o "" "" ) (** Conditional on breaking of enclosing box ----------------------------*) @@ -210,8 +212,9 @@ let break_unless_newline n o = type behavior = Fit | Break let fits_or_breaks ~level fits nspaces offset breaks = + let stack = Box_debug.get_stack () in with_pp (fun fs -> - Box_debug.fits_or_breaks fs fits nspaces offset breaks ; + Box_debug.fits_or_breaks fs ~stack fits nspaces offset breaks ; Format_.pp_print_fits_or_breaks fs ~level fits nspaces offset breaks ) let fits_breaks ?force ?(hint = (0, Int.min_value)) ?(level = 0) fits breaks diff --git a/lib/box_debug.ml b/lib/box_debug.ml index 06a0a7006b..db36dd645d 100644 --- a/lib/box_debug.ml +++ b/lib/box_debug.ml @@ -185,20 +185,20 @@ let cbreak fs ~stack ~fits:(s1, i, s2) ~breaks:(s3, j, s4) = %s" s1 i s2 s3 j s4 s1 i s2 s3 j s4 stack -let if_newline fs s = +let if_newline fs ~stack s = debugf fs "
(%s)if_newline %S
" - s s + class=\"tooltiptext\">if_newline %S\n%s" + s s stack -let break_unless_newline fs n o = +let break_unless_newline fs ~stack n o = debugf fs "
(%i,%i)break_unless_newline %i %i
" - n o n o + class=\"tooltiptext\">break_unless_newline %i %i\n%s" + n o n o stack -let fits_or_breaks fs fits n o breaks = +let fits_or_breaks fs ~stack fits n o breaks = debugf fs "
(%s,%i,%i,%s)fits_or_breaks %S %i %i %S
" - fits n o breaks fits n o breaks + class=\"tooltiptext\">fits_or_breaks %S %i %i %S\n%s" + fits n o breaks fits n o breaks stack From 5a6e4bd5f98a52f1086422d70c0b1f88cf78a550 Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Thu, 1 Aug 2024 14:26:54 +0200 Subject: [PATCH 089/146] format format ! --- lib-rpc/protocol.ml | 7 +- lib/Ast.ml | 58 +++++---- lib/Cmts.ml | 3 +- lib/Conf.ml | 12 +- lib/Fmt.ml | 9 +- lib/Fmt_ast.ml | 294 ++++++++++++++++++++++++-------------------- lib/Params.ml | 99 +++++++-------- lib/Params.mli | 21 +++- lib/box_debug.ml | 13 +- 9 files changed, 272 insertions(+), 244 deletions(-) diff --git a/lib-rpc/protocol.ml b/lib-rpc/protocol.ml index 73ee89d4c6..69e4259348 100644 --- a/lib-rpc/protocol.ml +++ b/lib-rpc/protocol.ml @@ -49,7 +49,8 @@ module Make (IO : IO.S) = struct let to_sexp = let open Csexp in function - | `Version v -> List [Atom "Version"; Atom v] | _ -> assert false + | `Version v -> List [Atom "Version"; Atom v] + | _ -> assert false let output oc t = IO.write oc [to_sexp t] end @@ -109,8 +110,8 @@ module Make (IO : IO.S) = struct let csexp_to_config csexpl = List.filter_map (function - | List [Atom name; Atom value] -> Some (name, value) | _ -> None - ) + | List [Atom name; Atom value] -> Some (name, value) + | _ -> None ) csexpl in read ic diff --git a/lib/Ast.ml b/lib/Ast.ml index 0f906e582b..0443eed590 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -145,8 +145,7 @@ module Exp = struct let has_trailing_attributes {pexp_desc; pexp_attributes; _} = match pexp_desc with - | Pexp_function _ | Pexp_ifthenelse _ | Pexp_match _ - |Pexp_try _ -> + | Pexp_function _ | Pexp_ifthenelse _ | Pexp_match _ | Pexp_try _ -> false | _ -> List.exists pexp_attributes ~f:(Fn.non Attr.is_doc) @@ -180,12 +179,14 @@ module Exp = struct |( {pexp_desc= Pexp_sequence _; _} , (Non_apply | Sequence | Then | ThenElse) ) |( { pexp_desc= - ( Pexp_function (_, Some _, _) | Pexp_function (_, _, Pfunction_cases _) | Pexp_match _ | Pexp_try _ - ) + ( Pexp_function (_, Some _, _) + | Pexp_function (_, _, Pfunction_cases _) + | Pexp_match _ | Pexp_try _ ) ; _ } , (Match | Let_match | Non_apply) ) |( { pexp_desc= - ( Pexp_function (_, _, Pfunction_body _) | Pexp_let _ | Pexp_letop _ | Pexp_letexception _ + ( Pexp_function (_, _, Pfunction_body _) + | Pexp_let _ | Pexp_letop _ | Pexp_letexception _ | Pexp_letmodule _ | Pexp_open _ | Pexp_letopen _ ) ; _ } , (Let_match | Non_apply) ) -> @@ -1216,8 +1217,7 @@ end = struct let check_class_function_params = List.exists ~f:check_class_function_param in - let check_cases = - List.exists ~f:(fun c -> c.pc_lhs == pat) in + let check_cases = List.exists ~f:(fun c -> c.pc_lhs == pat) in match ctx with | Pld (PPat (p1, _)) -> assert (p1 == pat) | Pld _ -> assert false @@ -1275,14 +1275,11 @@ end = struct | Pexp_function (params, _, body) -> let check_body = match body with - Pfunction_body _ -> false - | Pfunction_cases (cases, _, _) -> - check_cases cases + | Pfunction_body _ -> false + | Pfunction_cases (cases, _, _) -> check_cases cases in assert ( - List.exists ~f:check_expr_function_param params - || check_body - )) + List.exists ~f:check_expr_function_param params || check_body ) ) | Fpe ctx -> assert (check_expr_function_param ctx) | Fpc ctx -> assert (check_class_function_param ctx) | Vc _ -> assert false @@ -1350,9 +1347,9 @@ end = struct in let check_cases = List.exists ~f:(function - | {pc_guard= Some g; _} when g == exp -> true - | {pc_rhs; _} when pc_rhs == exp -> true - | _ -> false ) + | {pc_guard= Some g; _} when g == exp -> true + | {pc_rhs; _} when pc_rhs == exp -> true + | _ -> false ) in match ctx with | Pld (PPat (_, Some e1)) -> assert (e1 == exp) @@ -1375,15 +1372,16 @@ end = struct let f {pbop_exp; _} = pbop_exp == exp in assert (f let_ || List.exists ~f ands || body == exp) | (Pexp_match (e, _) | Pexp_try (e, _)) when e == exp -> () - | Pexp_match (_, cases) | Pexp_try (_, cases) - -> + | Pexp_match (_, cases) | Pexp_try (_, cases) -> assert (check_cases cases) | Pexp_function (params, _, body) -> - let check_body = match body with + let check_body = + match body with | Pfunction_body body -> body == exp | Pfunction_cases (cases, _, _) -> check_cases cases in - assert (List.exists ~f:check_expr_function_param params || check_body) + assert ( + List.exists ~f:check_expr_function_param params || check_body ) | Pexp_indexop_access {pia_lhs; pia_kind= Builtin idx; pia_rhs; _} -> assert ( pia_lhs == exp || idx == exp @@ -2021,8 +2019,8 @@ end = struct | Pexp_match _ when match cls with Then -> true | _ -> false -> false | Pexp_function (_, _, Pfunction_cases (cases, _, _)) - | Pexp_match (_, cases) | Pexp_try (_, cases) - -> + |Pexp_match (_, cases) + |Pexp_try (_, cases) -> continue (List.last_exn cases).pc_rhs | Pexp_apply (_, args) -> continue (snd (List.last_exn args)) | Pexp_tuple es -> continue (List.last_exn es) @@ -2090,15 +2088,16 @@ end = struct | Pexp_extension (ext, PStr [{pstr_desc= Pstr_eval (e, _); _}]) when Source.extension_using_sugar ~name:ext ~payload:e.pexp_loc -> ( match e.pexp_desc with - | Pexp_function (_, _, Pfunction_cases (cases, _, _)) - | Pexp_match (_, cases) | Pexp_try (_, cases) - -> + | Pexp_function (_, _, Pfunction_cases (cases, _, _)) + |Pexp_match (_, cases) + |Pexp_try (_, cases) -> List.iter cases ~f:(fun case -> mark_parenzed_inner_nested_match case.pc_rhs ) ; true | _ -> continue e ) | Pexp_function (_, _, Pfunction_cases (cases, _, _)) - | Pexp_match (_, cases) | Pexp_try (_, cases) -> + |Pexp_match (_, cases) + |Pexp_try (_, cases) -> List.iter cases ~f:(fun case -> mark_parenzed_inner_nested_match case.pc_rhs ) ; true @@ -2268,15 +2267,14 @@ end = struct [ { pstr_desc= Pstr_eval ( { pexp_desc= - ( - Pexp_function (_, _, Pfunction_cases (cases, _, _)) - + ( Pexp_function + (_, _, Pfunction_cases (cases, _, _)) | Pexp_match (_, cases) | Pexp_try (_, cases) ) ; _ } , _ ) ; _ } ] ) - | Pexp_function (_, _, Pfunction_cases (cases, _, _)) + |Pexp_function (_, _, Pfunction_cases (cases, _, _)) |Pexp_match (_, cases) |Pexp_try (_, cases) -> if !leading_nested_match_parens then diff --git a/lib/Cmts.ml b/lib/Cmts.ml index 5d0fe82caf..045126d280 100644 --- a/lib/Cmts.ml +++ b/lib/Cmts.ml @@ -457,7 +457,8 @@ let break_comment_group source a b = Location.line_difference a b = 0 && List.is_empty (Source.tokens_between source a.loc_end b.loc_start - ~filter:(function _ -> true) ) + ~filter:(function + | _ -> true ) ) in not (vertical_align || horizontal_align) diff --git a/lib/Conf.ml b/lib/Conf.ml index 0f1413b582..a2709d23b3 100644 --- a/lib/Conf.ml +++ b/lib/Conf.ml @@ -442,8 +442,7 @@ module Formatting = struct in Decl.choice ~names ~all ~default ~doc ~kind (fun conf elt -> - update conf ~f:(fun f -> {f with break_collection_expressions= elt}) - ) + update conf ~f:(fun f -> {f with break_collection_expressions= elt}) ) (fun conf -> conf.fmt_opts.break_collection_expressions) let break_colon = @@ -597,8 +596,7 @@ module Formatting = struct Decl.choice ~names ~all ~default ~doc ~kind (fun conf elt -> update conf ~f:(fun f -> - {f with break_struct= Elt.make Poly.(elt.v = `Force) elt.from} ) - ) + {f with break_struct= Elt.make Poly.(elt.v = `Force) elt.from} ) ) (fun conf -> let elt = conf.fmt_opts.break_struct in if elt.v then Elt.make `Force elt.from @@ -895,8 +893,7 @@ module Formatting = struct in Decl.choice ~names ~all ~default ~doc ~kind (fun conf elt -> - update conf ~f:(fun f -> {f with indicate_nested_or_patterns= elt}) - ) + update conf ~f:(fun f -> {f with indicate_nested_or_patterns= elt}) ) (fun conf -> conf.fmt_opts.indicate_nested_or_patterns) let infix_precedence = @@ -923,8 +920,7 @@ module Formatting = struct let names = ["leading-nested-match-parens"] in Decl.flag ~names ~default ~doc ~kind ~allow_inline:false (fun conf elt -> - update conf ~f:(fun f -> {f with leading_nested_match_parens= elt}) - ) + update conf ~f:(fun f -> {f with leading_nested_match_parens= elt}) ) (fun conf -> conf.fmt_opts.leading_nested_match_parens) let let_and = diff --git a/lib/Fmt.ml b/lib/Fmt.ml index 2aaef5a73e..2fb707203b 100644 --- a/lib/Fmt.ml +++ b/lib/Fmt.ml @@ -143,12 +143,11 @@ let utf8_length s = let str_as n s = let stack = Box_debug.get_stack () in with_pp (fun fs -> - Box_debug.start_str fs; - Format_.pp_print_as fs n s; - Box_debug.end_str ~stack fs) + Box_debug.start_str fs ; + Format_.pp_print_as fs n s ; + Box_debug.end_str ~stack fs ) -let str s = - if String.is_empty s then noop else str_as (utf8_length s) s +let str s = if String.is_empty s then noop else str_as (utf8_length s) s let sp = function | Blank -> char ' ' diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index c9b1795462..99ea6a606b 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -161,7 +161,7 @@ let box_fun_sig_args c = | `Fit_or_vertical -> hvbox | `Wrap | `Smart -> hovbox -let closing_paren ?(force_space=false) ?force ?(offset = 0) c = +let closing_paren ?(force_space = false) ?force ?(offset = 0) c = if force_space then str " )" else match c.conf.fmt_opts.indicate_multiline_delimiters.v with @@ -747,31 +747,34 @@ and fmt_record_field c ?typ1 ?typ2 ?rhs lid1 = $ cbox 0 (fmt_longident_loc c lid1 $ Cmts.fmt_after c lid1.loc $ fmt_type_rhs) -and fmt_type_cstr c ?(pro=":") ?constraint_ctx xtyp = +and fmt_type_cstr c ?(pro = ":") ?constraint_ctx xtyp = let colon_before = Poly.(c.conf.fmt_opts.break_colon.v = `Before) in let wrap, inner_pro, box = match xtyp.ast.ptyp_desc with - | (Ptyp_poly (_, { ptyp_desc= Ptyp_arrow _; _ }) - | Ptyp_arrow _) when colon_before -> + | (Ptyp_poly (_, {ptyp_desc= Ptyp_arrow _; _}) | Ptyp_arrow _) + when colon_before -> let outer_pro = if c.conf.fmt_opts.ocp_indent_compat.v then fits_breaks (pro ^ " ") (pro ^ " ") - else - str pro $ str " " + else str pro $ str " " + in + let pre_break = + if colon_before then fits_breaks " " ~hint:(1000, 0) "" + else break 0 ~-1 in - let pre_break = if colon_before then fits_breaks " " ~hint:(1000, 0) "" else break 0 ~-1 in let wrap x = pre_break $ cbox 0 (outer_pro $ x) in - wrap, None, false - | _ -> - (fun k -> break 0 ~-1 $ k), Some pro, true + (wrap, None, false) + | _ -> ((fun k -> break 0 ~-1 $ k), Some pro, true) in wrap (fmt_core_type c ?pro:inner_pro ?constraint_ctx ~box xtyp) and fmt_type_pcstr c ~ctx ?constraint_ctx cstr = - let fmt_typ ~pro t = fmt_type_cstr c ~pro ?constraint_ctx (sub_typ ~ctx t) in + let fmt_typ ~pro t = + fmt_type_cstr c ~pro ?constraint_ctx (sub_typ ~ctx t) + in match cstr with - | Pconstraint t -> fmt_typ ~pro:":" t - | Pcoerce (t1, t2) -> opt t1 (fmt_typ ~pro:":") $ fmt_typ ~pro:":>" t2 + | Pconstraint t -> fmt_typ ~pro:":" t + | Pcoerce (t1, t2) -> opt t1 (fmt_typ ~pro:":") $ fmt_typ ~pro:":>" t2 and fmt_arrow_param c ctx {pap_label= lI; pap_loc= locI; pap_type= tI} = let arg_label lbl = @@ -825,9 +828,7 @@ and fmt_core_type c ?(box = true) ?pro ?constraint_ctx let {ptyp_desc; ptyp_attributes; ptyp_loc; _} = typ in update_config_maybe_disabled c ptyp_loc ptyp_attributes @@ fun c -> - ( match pro with - | Some pro -> (fmt_constraint_sep c pro) - | None -> noop ) + (match pro with Some pro -> fmt_constraint_sep c pro | None -> noop) $ let doc, atrs = doc_atrs ptyp_attributes in Cmts.fmt c ptyp_loc @@ -1451,8 +1452,9 @@ and fmt_indexop_access c ctx ~fmt_atrs ~has_attr ~parens x = (** Format a [Pexp_function]. [wrap_intro] wraps up to after the [->] and is responsible for breaking. *) -and fmt_function ?(last_arg=false) ?force_closing_paren ~ctx ~ctx0 ~wrap_intro ?box:(should_box = true) - ~label ?(parens = false) ?ext ~attrs ~loc c (args, typ, body) = +and fmt_function ?(last_arg = false) ?force_closing_paren ~ctx ~ctx0 + ~wrap_intro ?box:(should_box = true) ~label ?(parens = false) ?ext ~attrs + ~loc c (args, typ, body) = let has_label = match label with Nolabel -> false | _ -> true in (* Make sure the comment is placed after the eventual label but not into the inner box if no label is present. Side effects of Cmts.fmt c.cmts @@ -1469,59 +1471,66 @@ and fmt_function ?(last_arg=false) ?force_closing_paren ~ctx ~ctx0 ~wrap_intro ? arrow and the eventually breaking [fun] keyword. *) if c.conf.fmt_opts.ocp_indent_compat.v then (str ":" $ cut_break, break 1 2) - else - (str ":" - , if has_label - then break 1 2 - else break 1 0) - in - let fmt_typ typ = - fmt_type_pcstr c ~ctx ~constraint_ctx:`Fun typ + else (str ":", if has_label then break 1 2 else break 1 0) in + let fmt_typ typ = fmt_type_pcstr c ~ctx ~constraint_ctx:`Fun typ in let fmt_fun_args_typ args typ = let kw = - str "fun" $ fmt_extension_suffix c ext $ fmt_attributes c ~pre:Blank attrs - $ (if last_arg then break_fun else break 1 0) + str "fun" + $ fmt_extension_suffix c ext + $ fmt_attributes c ~pre:Blank attrs + $ if last_arg then break_fun else break 1 0 and args = fmt_expr_fun_args c args - and annot = Option.map ~f:fmt_typ typ - in - Params.Exp.box_fun_decl_args ~kw_in_box:(not last_arg) ~ctx:ctx0 c.conf ~parens ~kw ~args ~annot - $ Params.Exp.break_fun_decl_args ~ctx:ctx0 ~last_arg ~has_label $ str "->" + and annot = Option.map ~f:fmt_typ typ in + Params.Exp.box_fun_decl_args ~kw_in_box:(not last_arg) ~ctx:ctx0 c.conf + ~parens ~kw ~args ~annot + $ Params.Exp.break_fun_decl_args ~ctx:ctx0 ~last_arg ~has_label + $ str "->" in let lead_with_function_kw = - match args, body with | [], Pfunction_cases _ -> true | _ -> false + match (args, body) with [], Pfunction_cases _ -> true | _ -> false in (* [head] is [fun args ->] or [function]. [body] is an expression or the cases. *) let head, body, box, closing_paren_offset = - match args, typ, body with - | (_ :: _), _, Pfunction_body body -> + match (args, typ, body) with + | _ :: _, _, Pfunction_body body -> (* Only [fun]. *) - let head = fmt_fun_args_typ args typ in - let body = fmt_expression c (sub_exp ~ctx body) in - let box, closing_paren_offset = - Params.Exp.box_fun_expr c.conf ~source:c.source ~ctx0 ~ctx ~parens ~has_label - in - let closing_paren_offset = - if should_box then closing_paren_offset else ~-2 - in - head, body, box, closing_paren_offset + let head = fmt_fun_args_typ args typ in + let body = fmt_expression c (sub_exp ~ctx body) in + let box, closing_paren_offset = + Params.Exp.box_fun_expr c.conf ~source:c.source ~ctx0 ~ctx ~parens + ~has_label + in + let closing_paren_offset = + if should_box then closing_paren_offset else ~-2 + in + (head, body, box, closing_paren_offset) | [], _, Pfunction_body _ -> assert false | args, typ, Pfunction_cases (cs, _loc, cs_attrs) -> (* [fun _ -> function] or [function]. [spilled_attrs] are extra attrs to add to the [function] keyword. *) let fun_, spilled_attrs, box = - match args, typ with - | [], None -> noop, attrs, hvbox (Params.Indent.function_ c.conf ~ctx ~ctx0 ~parens ~has_label) + match (args, typ) with + | [], None -> + ( noop + , attrs + , hvbox + (Params.Indent.function_ c.conf ~ctx ~ctx0 ~parens + ~has_label ) ) | [], Some _ -> assert false | args, typ -> - ( fmt_fun_args_typ args typ $ space_break, - [], - hvbox (Params.Indent.docked_function_after_fun c.conf ~ctx0 ~parens ~has_label) - ) + ( fmt_fun_args_typ args typ $ space_break + , [] + , hvbox + (Params.Indent.docked_function_after_fun c.conf ~ctx0 + ~parens ~has_label ) ) in let function_ = - let pre = if Params.Exp.function_attrs_sp c.conf ~ctx0 ~ctx then Some Blank else None in + let pre = + if Params.Exp.function_attrs_sp c.conf ~ctx0 ~ctx then Some Blank + else None + in str "function" $ fmt_extension_suffix c ext $ fmt_attributes ?pre c spilled_attrs @@ -1529,7 +1538,7 @@ and fmt_function ?(last_arg=false) ?force_closing_paren ~ctx ~ctx0 ~wrap_intro ? in let box_cases = match ctx0 with - | Exp ({pexp_desc = Pexp_ifthenelse _; _}) + | Exp {pexp_desc= Pexp_ifthenelse _; _} when Stdlib.(c.conf.fmt_opts.if_then_else.v = `Compact) -> hvbox ~name:"cases box" 0 | _ -> Fn.id @@ -1538,39 +1547,40 @@ and fmt_function ?(last_arg=false) ?force_closing_paren ~ctx ~ctx0 ~wrap_intro ? in let space_opn_parens, space_cls_parens = match ctx0 with - | Exp ({pexp_desc=Pexp_infix _; _}) - when lead_with_function_kw && not c.conf.fmt_opts.break_infix_before_func.v -> - str " ", true - | _ -> noop,false + | Exp {pexp_desc= Pexp_infix _; _} + when lead_with_function_kw + && not c.conf.fmt_opts.break_infix_before_func.v -> + (str " ", true) + | _ -> (noop, false) in let opn_paren, cls_paren = if parens then ( str "(" $ space_opn_parens - , closing_paren c ~force_space:space_cls_parens ?force:force_closing_paren ~offset:closing_paren_offset) - else noop, noop + , closing_paren c ~force_space:space_cls_parens + ?force:force_closing_paren ~offset:closing_paren_offset ) + else (noop, noop) in - - (* When the option disambiguate_non_breaking_match is set, if the function - fits on one line it has to have parens. [fit_breaks] is used for that. It - cannot be used directly with [opn_paren] because its deep inside other boxes - that will not be broken. Because of this we wrap the whole with another pair - of parens, although only if the regular one are absent. *) + (* When the option disambiguate_non_breaking_match is set, if the function + fits on one line it has to have parens. [fit_breaks] is used for that. + It cannot be used directly with [opn_paren] because its deep inside + other boxes that will not be broken. Because of this we wrap the whole + with another pair of parens, although only if the regular one are + absent. *) let disambiguate_parens_wrap = - if not parens && c.conf.fmt_opts.disambiguate_non_breaking_match.v then + if (not parens) && c.conf.fmt_opts.disambiguate_non_breaking_match.v then wrap (fits_breaks "(" "") (fits_breaks ")" "") else Fn.id in let box k = if should_box then box k else k in box ( disambiguate_parens_wrap - ( wrap_intro - (hvbox_if has_cmts_outer 0 - ( cmts_outer - $ hvbox 2 - ( fmt_label label label_sep $ cmts_inner - $ opn_paren - $ head ) ) ) - $ body $ cls_paren ) + ( wrap_intro + (hvbox_if has_cmts_outer 0 + ( cmts_outer + $ hvbox 2 + (fmt_label label label_sep $ cmts_inner $ opn_paren $ head) + ) ) + $ body $ cls_paren ) $ Cmts.fmt_after c loc ) and fmt_label_arg ?(box = true) ?eol c (lbl, ({ast= arg; _} as xarg)) = @@ -1602,8 +1612,10 @@ and fmt_label_arg ?(box = true) ?eol c (lbl, ({ast= arg; _} as xarg)) = ~box xarg ) $ cmts_after ) | (Labelled _ | Optional _), Pexp_function (args, typ, body) -> - let wrap_intro x = hovbox 2 x $ space_break in - fmt_function ~ctx:(Exp arg) ~wrap_intro ~ctx0:xarg.ctx ~label:lbl ~parens:true ~attrs:arg.pexp_attributes ~loc:arg.pexp_loc c (args, typ, body) + let wrap_intro x = hovbox 2 x $ space_break in + fmt_function ~ctx:(Exp arg) ~wrap_intro ~ctx0:xarg.ctx ~label:lbl + ~parens:true ~attrs:arg.pexp_attributes ~loc:arg.pexp_loc c + (args, typ, body) | _ -> let label_sep : t = if box || c.conf.fmt_opts.wrap_fun_args.v then str ":" $ cut_break @@ -1873,7 +1885,12 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens ( name , PStr [ ( { pstr_desc= - Pstr_eval (({pexp_desc= Pexp_function (args, typ, (Pfunction_body _ as body)); _} as call), []) + Pstr_eval + ( ( { pexp_desc= + Pexp_function + (args, typ, (Pfunction_body _ as body)) + ; _ } as call ) + , [] ) ; pstr_loc= _ } as _pld ) ] ) ; _ } , e2 ) -> @@ -1892,13 +1909,14 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens (Params.parens_if parens c.conf ( hvbox c.conf.fmt_opts.extension_indent.v (wrap (str "[") (str "]") - (fmt_function ~ctx:(Exp call) ~ctx0 ~wrap_intro:(fun x -> - ( str "%" - $ hovbox 2 - ( fmt_str_loc c name $ space_break $ x))$space_break) - ~label:Nolabel ~parens:false ~attrs:call.pexp_attributes ~loc:call.pexp_loc c (args, typ, body) - ) - ) + (fmt_function ~ctx:(Exp call) ~ctx0 + ~wrap_intro:(fun x -> + str "%" + $ hovbox 2 (fmt_str_loc c name $ space_break $ x) + $ space_break ) + ~label:Nolabel ~parens:false + ~attrs:call.pexp_attributes ~loc:call.pexp_loc c + (args, typ, body) ) ) $ space_break $ str ";" $ space_break $ list grps (str " ;" $ force_break) fmt_grp ) ) | Pexp_infix @@ -1909,7 +1927,12 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens ( name , PStr [ ( { pstr_desc= - Pstr_eval (({pexp_desc= Pexp_function (args, typ, (Pfunction_body _ as body)); _} as retn), []) + Pstr_eval + ( ( { pexp_desc= + Pexp_function + (args, typ, (Pfunction_body _ as body)) + ; _ } as retn ) + , [] ) ; pstr_loc= _ } as _pld ) ] ) ; _ } ) -> pro @@ -1920,13 +1943,14 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens $ Cmts.fmt c loc (str "|>" $ force_newline) $ hvbox c.conf.fmt_opts.extension_indent.v (wrap (str "[") (str "]") - (fmt_function ~ctx:(Exp retn) ~ctx0 ~wrap_intro:(fun x -> - ( str "%" - $ hovbox 2 - ( fmt_str_loc c name $ space_break $ x))$space_break) - ~label:Nolabel ~parens:false ~attrs:retn.pexp_attributes ~loc:retn.pexp_loc c (args, typ, body) - ) - ) ) ) + (fmt_function ~ctx:(Exp retn) ~ctx0 + ~wrap_intro:(fun x -> + str "%" + $ hovbox 2 (fmt_str_loc c name $ space_break $ x) + $ space_break ) + ~label:Nolabel ~parens:false + ~attrs:retn.pexp_attributes ~loc:retn.pexp_loc c + (args, typ, body) ) ) ) ) | Pexp_infix ({txt= ":="; loc}, r, v) when is_simple c.conf (expression_width c) (sub_exp ~ctx r) -> let bol_indent = Params.Indent.assignment_operator_bol c.conf in @@ -1974,31 +1998,27 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens ( fmt_expression c (sub_exp ~ctx l) $ hvbox 0 (fmt_str_loc c op) $ fmt_expression c (sub_exp ~ctx r) ) - | Pexp_infix - (op, l, ({pexp_desc= Pexp_function (args, typ, body); _} as r)) + | Pexp_infix (op, l, ({pexp_desc= Pexp_function (args, typ, body); _} as r)) when not c.conf.fmt_opts.break_infix_before_func.v -> let xr = sub_exp ~ctx r in let parens_r = parenze_exp xr in let indent_wrap = if parens then -2 else 0 in pro $ wrap_fits_breaks_if c.conf parens "(" ")" - ( - ( - (fmt_function - ~ctx:(Exp r) ~ctx0:ctx (*~box:false to fix regression on infix *) ~parens:(parens_r) ~wrap_intro:(fun intro -> - ( - ( hvbox indent_wrap - (fmt_if has_attr (str "(") $ fmt_expression ~indent_wrap c (sub_exp ~ctx l) - $ space_break - $ hovbox 0 - ( - ( fmt_str_loc c op $ space_break $ intro))) - ) - ) $ space_break) - ~label:Nolabel ~attrs:r.pexp_attributes ~loc:r.pexp_loc c (args, typ, body) - )) - $ fmt_if has_attr (str ")") - $ fmt_atrs) + ( fmt_function ~ctx:(Exp r) + ~ctx0:ctx (*~box:false to fix regression on infix *) + ~parens:parens_r + ~wrap_intro:(fun intro -> + hvbox indent_wrap + ( fmt_if has_attr (str "(") + $ fmt_expression ~indent_wrap c (sub_exp ~ctx l) + $ space_break + $ hovbox 0 (fmt_str_loc c op $ space_break $ intro) ) + $ space_break ) + ~label:Nolabel ~attrs:r.pexp_attributes ~loc:r.pexp_loc c + (args, typ, body) + $ fmt_if has_attr (str ")") + $ fmt_atrs ) | Pexp_infix _ -> let op_args = Sugar.Exp.infix c.cmts (prec_ast (Exp exp)) xexp in let inner_wrap = parens || has_attr in @@ -2086,14 +2106,14 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens | Pexp_function (largs, ltyp, lbody) when List.for_all args_before ~f:(fun (_, eI) -> is_simple c.conf (fun _ -> 0) (sub_exp ~ctx eI) ) -> - let inner_ctx = Exp (last_arg) in + let inner_ctx = Exp last_arg in let args = let wrap_intro x = - hvbox 0 ( - intro_epi + hvbox 0 + ( intro_epi $ wrap - ( fmt_args_grouped e0 args_before - $ break 1 0 $ hvbox 0 x )) + (fmt_args_grouped e0 args_before $ break 1 0 $ hvbox 0 x) + ) $ break 1 0 in let force_closing_paren = @@ -2101,7 +2121,10 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens then Fit else Break in - fmt_function ~last_arg:true ~force_closing_paren ~ctx:inner_ctx ~ctx0:ctx ~wrap_intro ~label:lbl ~parens:true ~attrs:last_arg.pexp_attributes ~loc:last_arg.pexp_loc c (largs, ltyp, lbody) + fmt_function ~last_arg:true ~force_closing_paren ~ctx:inner_ctx + ~ctx0:ctx ~wrap_intro ~label:lbl ~parens:true + ~attrs:last_arg.pexp_attributes ~loc:last_arg.pexp_loc c + (largs, ltyp, lbody) in hvbox_if has_attr 0 (expr_epi $ Params.parens_if parens c.conf (args $ fmt_atrs)) @@ -2228,9 +2251,12 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens ( fmt_expression c (sub_exp ~ctx exp) $ cut_break $ str "." $ fmt_longident_loc c lid $ fmt_atrs ) ) | Pexp_function (args, typ, body) -> - let wrap_intro intro = hovbox ~name:"fmt_expression | Pexp_function" 2 (pro $ intro) $ space_break in - fmt_function ~wrap_intro ~box ~ctx ~ctx0 - ~label:Nolabel ~parens ?ext ~attrs:pexp_attributes ~loc:pexp_loc c (args, typ, body) + let wrap_intro intro = + hovbox ~name:"fmt_expression | Pexp_function" 2 (pro $ intro) + $ space_break + in + fmt_function ~wrap_intro ~box ~ctx ~ctx0 ~label:Nolabel ~parens ?ext + ~attrs:pexp_attributes ~loc:pexp_loc c (args, typ, body) | Pexp_ident {txt; loc} -> let outer_parens = has_attr && parens in pro @@ -4462,11 +4488,11 @@ and fmt_value_binding c ~rec_flag ?in_ ?epi let indent, intro_as_pro = match lb_exp.ast.pexp_desc with | Pexp_function (_, _, Pfunction_cases _) -> - c.conf.fmt_opts.function_indent.v, true + (c.conf.fmt_opts.function_indent.v, true) | Pexp_function (_, _, Pfunction_body _) when c.conf.fmt_opts.let_binding_deindent_fun.v -> - max (c.conf.fmt_opts.let_binding_indent.v - 1) 0, false - | _ -> c.conf.fmt_opts.let_binding_indent.v, false + (max (c.conf.fmt_opts.let_binding_indent.v - 1) 0, false) + | _ -> (c.conf.fmt_opts.let_binding_indent.v, false) in let pat_has_cmt = Cmts.has_before c.cmts lb_pat.ast.ppat_loc in let toplevel, in_, epi, cmts_before, cmts_after = @@ -4503,26 +4529,24 @@ and fmt_value_binding c ~rec_flag ?in_ ?epi $ fmt_newtypes in let decl_args = - box_fun_decl_args c 4 (Params.Align.fun_decl c.conf ~decl ~pattern ~args) + box_fun_decl_args c 4 + (Params.Align.fun_decl c.conf ~decl ~pattern ~args) in - hovbox - (Params.Indent.fun_type_annot c.conf) - (decl_args $ fmt_cstr) + hovbox (Params.Indent.fun_type_annot c.conf) (decl_args $ fmt_cstr) in let decl_and_body = if lb_pun then decl else let pro = - hovbox 2 ( - decl - $ (fmt_or c.conf.fmt_opts.ocp_indent_compat.v - (fits_breaks " =" ~hint:(1000, 0) "=") - (break 1 2 $ str "=") )) $ space_break + hovbox 2 + ( decl + $ fmt_or c.conf.fmt_opts.ocp_indent_compat.v + (fits_breaks " =" ~hint:(1000, 0) "=") + (break 1 2 $ str "=") ) + $ space_break in - if intro_as_pro then - fmt_expression c ~pro ~box:false lb_exp - else - pro$fmt_expression c lb_exp + if intro_as_pro then fmt_expression c ~pro ~box:false lb_exp + else pro $ fmt_expression c lb_exp in doc1 $ cmts_before $ hvbox 0 diff --git a/lib/Params.ml b/lib/Params.ml index ed861a611a..f01c770e9d 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -48,29 +48,27 @@ let ctx_is_apply_and_exp_is_last_arg ~ctx ctx0 = Poly.equal last_arg exp | _ -> false - let ctx_is_apply_and_exp_is_last_arg_and_other_args_are_simple c ~ctx ctx0 = - match (ctx, ctx0) with - | Exp exp, Exp {pexp_desc= Pexp_apply (_, args); _} -> - let (_lbl, last_arg), args_before = - match List.rev args with - | [] -> assert false - | hd :: tl -> (hd, List.rev tl) - in - let args_are_simple = - List.for_all args_before ~f:(fun (_, eI) -> +let ctx_is_apply_and_exp_is_last_arg_and_other_args_are_simple c ~ctx ctx0 = + match (ctx, ctx0) with + | Exp exp, Exp {pexp_desc= Pexp_apply (_, args); _} -> + let (_lbl, last_arg), args_before = + match List.rev args with + | [] -> assert false + | hd :: tl -> (hd, List.rev tl) + in + let args_are_simple = + List.for_all args_before ~f:(fun (_, eI) -> is_simple c (fun _ -> 0) (sub_exp ~ctx:ctx0 eI) ) - in - Poly.equal last_arg exp && args_are_simple - | _ -> false + in + Poly.equal last_arg exp && args_are_simple + | _ -> false (** [ctx_is_let ~ctx ctx0] checks whether [ctx0] is a let binding containing [ctx]. *) let ctx_is_let ~ctx = function | Lb _ | Str _ | Bo _ -> true - | Exp { pexp_desc= Pexp_let (_, rhs, _); _ } -> - (match ctx with - | Exp exp -> not (phys_equal rhs exp) - | _ -> false) + | Exp {pexp_desc= Pexp_let (_, rhs, _); _} -> ( + match ctx with Exp exp -> not (phys_equal rhs exp) | _ -> false ) | _ -> false let parens_if parens (c : Conf.t) ?(disambiguate = false) k = @@ -132,28 +130,28 @@ module Exp = struct $ Fmt.fits_breaks ")" ~hint:(1000, offset_closing_paren) ")" | `No -> wrap (str "(") (str ")") k - let box_fun_decl_args ~ctx ?(kw_in_box=true) c ~parens ~kw ~args ~annot = + let box_fun_decl_args ~ctx ?(kw_in_box = true) c ~parens ~kw ~args ~annot = let is_let_func = match ctx with - Ast.Str _ -> - (* special case than aligns the arguments of [let _ = fun ...] *) true | _ -> false + | Ast.Str _ -> + (* special case than aligns the arguments of [let _ = fun ...] *) + true + | _ -> false in let name = "Params.box_fun_decl_args" in let box_decl, should_box_args = if ocp c then (hvbox ~name (if parens then 1 else 2), false) else - ( - ( if is_let_func - then hovbox ~name 4 + ( ( if is_let_func then hovbox ~name 4 else hvbox ~name (if parens then 1 else 2) ) , not c.fmt_opts.wrap_fun_args.v ) in - let box_decl = - if not kw_in_box then hvbox ~name 0 - else box_decl + let box_decl = if not kw_in_box then hvbox ~name 0 else box_decl in + let kw_out_of_box, kw_in_box = + if kw_in_box then (noop, kw) else (kw, noop) in - let kw_out_of_box, kw_in_box = if kw_in_box then noop, kw else kw, noop in - kw_out_of_box $ box_decl (kw_in_box $ hvbox_if should_box_args 0 args $ fmt_opt annot) + kw_out_of_box + $ box_decl (kw_in_box $ hvbox_if should_box_args 0 args $ fmt_opt annot) let box_fun_expr (c : Conf.t) ~source ~ctx0 ~ctx ~parens ~has_label:_ = let indent = @@ -162,9 +160,10 @@ module Exp = struct c.fmt_opts.function_indent.v else if ctx_is_let ~ctx ctx0 then if c.fmt_opts.let_binding_deindent_fun.v then 1 else 0 - else - if ocp c then - let begins_line loc = Source.begins_line ~ignore_spaces:true source loc in + else if ocp c then + let begins_line loc = + Source.begins_line ~ignore_spaces:true source loc + in match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with | Some Nolabel -> if ctx_is_apply_and_exp_is_last_arg ~ctx ctx0 then 5 else 3 @@ -172,10 +171,11 @@ module Exp = struct (* if ctx_is_apply_and_exp_is_last_arg ~ctx ctx0 then 2 else *) if begins_line x.loc then 4 else 2 | None -> if parens then 3 else 2 - else if ctx_is_apply_and_exp_is_last_arg_and_other_args_are_simple c ~ctx ctx0 - then 4 + else if + ctx_is_apply_and_exp_is_last_arg_and_other_args_are_simple c ~ctx + ctx0 + then 4 else 2 - in let name = "Params.box_fun_expr" in let mkbox = match ctx0 with Str _ -> hvbox | _ -> hovbox in @@ -187,22 +187,21 @@ module Exp = struct let arg_is_simple_approx (_, exp) = Ast.is_simple c (fun _ -> 0) (sub_exp ~ctx:ctx0 exp) in - match ctx0, ctx with - | Exp { pexp_desc= Pexp_apply (_, args); _ }, Exp exp -> - (match List.rev args with - | [] -> false - | (_, last_arg) :: other_args -> - phys_equal exp last_arg - && List.for_all ~f:arg_is_simple_approx other_args - ) + match (ctx0, ctx) with + | Exp {pexp_desc= Pexp_apply (_, args); _}, Exp exp -> ( + match List.rev args with + | [] -> false + | (_, last_arg) :: other_args -> + phys_equal exp last_arg + && List.for_all ~f:arg_is_simple_approx other_args ) | _ -> false + let break_fun_decl_args ~ctx ~last_arg ~has_label = match ctx with | Ast.Str _ -> - (* special case that break the arrow in [let _ = fun ... ->] *) - (str " ") - | _ -> break 1 (if last_arg && has_label then 0 else (-2)) - + (* special case that break the arrow in [let _ = fun ... ->] *) + str " " + | _ -> break 1 (if last_arg && has_label then 0 else -2) end module Mod = struct @@ -718,8 +717,7 @@ let get_if_then_else (c : Conf.t) ~first ~last ~parens_bch ~parens_prev_bch ; box_keyword_and_expr= (fun k -> hvbox 2 - (fmt_or (Option.is_some xcond) (str "then") (str "else") $ k) - ) + (fmt_or (Option.is_some xcond) (str "then") (str "else") $ k) ) ; branch_pro= fmt_or (beginend || parens_bch) (str " ") space_break ; wrap_parens= wrap_parens @@ -814,10 +812,7 @@ module Indent = struct let fun_args c = if ocp c then 6 else 4 let docked_function_after_fun (_c : Conf.t) ~ctx0 ~parens:_ ~has_label:_ = - if ctx_is_infix ctx0 then - 0 - else - 2 + if ctx_is_infix ctx0 then 0 else 2 let fun_args_group (c : Conf.t) ~lbl exp = if not (ocp c) then 2 diff --git a/lib/Params.mli b/lib/Params.mli index cc38e11f70..829f6c10a2 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -48,15 +48,22 @@ module Exp : sig (** Box and assemble the parts [kw] (up to the arguments), [args] and [annot]. *) + val box_fun_expr : + Conf.t + -> source:Source.t + -> ctx0:Ast.t + -> ctx:Ast.t + -> parens:bool + -> has_label:bool + -> (Fmt.t -> Fmt.t) * int (** return a box with an indent and minus the value of the indent to be used for a closing parenthesis *) - val box_fun_expr : Conf.t -> source:Source.t -> ctx0:Ast.t -> ctx:Ast.t -> parens:bool -> has_label:bool -> (Fmt.t -> Fmt.t) * int val function_attrs_sp : Conf.t -> ctx0:Ast.t -> ctx:Ast.t -> bool (** Whether a space should be added between the [function] keyword and the attributes. *) - val break_fun_decl_args : ctx:Ast.t -> last_arg:bool -> has_label:bool -> Fmt.t - + val break_fun_decl_args : + ctx:Ast.t -> last_arg:bool -> has_label:bool -> Fmt.t end module Mod : sig @@ -201,7 +208,13 @@ module Indent : sig (** Expressions *) val function_ : - ?default:int -> Conf.t -> ctx:Ast.t -> ctx0:Ast.t -> parens:bool -> has_label:bool -> int + ?default:int + -> Conf.t + -> ctx:Ast.t + -> ctx0:Ast.t + -> parens:bool + -> has_label:bool + -> int (** Check the [function-indent-nested] option, or return [default] (0 if not provided) if the option does not apply. *) diff --git a/lib/box_debug.ml b/lib/box_debug.ml index db36dd645d..a2af7e73ab 100644 --- a/lib/box_debug.ml +++ b/lib/box_debug.ml @@ -132,12 +132,10 @@ let force_newline ?stack fs = debugf fs "
force_newline%a
" stack_tooltip stack -let start_str fs = - debugf fs "" +let start_str fs = debugf fs "" let end_str ?stack fs = debugf fs "%a" stack_tooltip stack - let pp_keyword fs s = fprintf_as_0 fs "%s" s let _pp_format_lit fs = @@ -188,17 +186,20 @@ let cbreak fs ~stack ~fits:(s1, i, s2) ~breaks:(s3, j, s4) = let if_newline fs ~stack s = debugf fs "
(%s)if_newline %S\n%s
" + class=\"tooltiptext\">if_newline %S\n\ + %s
" s s stack let break_unless_newline fs ~stack n o = debugf fs "
(%i,%i)break_unless_newline %i %i\n%s
" + class=\"tooltiptext\">break_unless_newline %i %i\n\ + %s" n o n o stack let fits_or_breaks fs ~stack fits n o breaks = debugf fs "
(%s,%i,%i,%s)fits_or_breaks %S %i %i %S\n%s
" + class=\"tooltiptext\">fits_or_breaks %S %i %i %S\n\ + %s" fits n o breaks fits n o breaks stack From f9ae5ae58731b4cc24e91cd4e8923ba7031f6fc1 Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Thu, 1 Aug 2024 15:07:31 +0200 Subject: [PATCH 090/146] fix comment in if-then-else --- lib/Fmt_ast.ml | 2 +- test/passing/tests/ite-fit_or_vertical.ml.ref | 8 ++++---- test/passing/tests/ite-fit_or_vertical_closing.ml.ref | 8 ++++---- test/passing/tests/ite-fit_or_vertical_no_indicate.ml.ref | 8 ++++---- test/passing/tests/source.ml.ref | 6 +++--- 5 files changed, 16 insertions(+), 16 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 99ea6a606b..75b2f4e59c 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1864,7 +1864,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens | Pexp_function _ -> noop | _ -> Cmts.fmt_before c ?eol pexp_loc in - pro $ cmts_in_pro + cmts_in_pro $ pro in let fmt_cmts_after k = k $ Cmts.fmt_after c pexp_loc in let fmt_atrs = fmt_attributes c ~pre:Space pexp_attributes in diff --git a/test/passing/tests/ite-fit_or_vertical.ml.ref b/test/passing/tests/ite-fit_or_vertical.ml.ref index ad3c2b5512..eee4a817df 100644 --- a/test/passing/tests/ite-fit_or_vertical.ml.ref +++ b/test/passing/tests/ite-fit_or_vertical.ml.ref @@ -143,10 +143,10 @@ let foo = let foo = if cmp < 0 then (* foo *) a + b else (* foo *) a - b let foo = - if cmp < 0 then - (* ast higher precedence than context: no parens *) false - else if cmp > 0 then - (* context higher prec than ast: add parens *) true + if cmp < 0 then (* ast higher precedence than context: no parens *) + false + else if cmp > 0 then (* context higher prec than ast: add parens *) + true else if Poly.(assoc_of_prec prec_ast = which_child && which_child <> Non) then foo diff --git a/test/passing/tests/ite-fit_or_vertical_closing.ml.ref b/test/passing/tests/ite-fit_or_vertical_closing.ml.ref index 7cf962e6b9..6bfc9ec2ce 100644 --- a/test/passing/tests/ite-fit_or_vertical_closing.ml.ref +++ b/test/passing/tests/ite-fit_or_vertical_closing.ml.ref @@ -155,10 +155,10 @@ let foo = let foo = if cmp < 0 then (* foo *) a + b else (* foo *) a - b let foo = - if cmp < 0 then - (* ast higher precedence than context: no parens *) false - else if cmp > 0 then - (* context higher prec than ast: add parens *) true + if cmp < 0 then (* ast higher precedence than context: no parens *) + false + else if cmp > 0 then (* context higher prec than ast: add parens *) + true else if Poly.(assoc_of_prec prec_ast = which_child && which_child <> Non) then foo diff --git a/test/passing/tests/ite-fit_or_vertical_no_indicate.ml.ref b/test/passing/tests/ite-fit_or_vertical_no_indicate.ml.ref index bc57a1c7a1..411368d842 100644 --- a/test/passing/tests/ite-fit_or_vertical_no_indicate.ml.ref +++ b/test/passing/tests/ite-fit_or_vertical_no_indicate.ml.ref @@ -143,10 +143,10 @@ let foo = let foo = if cmp < 0 then (* foo *) a + b else (* foo *) a - b let foo = - if cmp < 0 then - (* ast higher precedence than context: no parens *) false - else if cmp > 0 then - (* context higher prec than ast: add parens *) true + if cmp < 0 then (* ast higher precedence than context: no parens *) + false + else if cmp > 0 then (* context higher prec than ast: add parens *) + true else if Poly.(assoc_of_prec prec_ast = which_child && which_child <> Non) then foo diff --git a/test/passing/tests/source.ml.ref b/test/passing/tests/source.ml.ref index 24654729f0..d6a932ad56 100644 --- a/test/passing/tests/source.ml.ref +++ b/test/passing/tests/source.ml.ref @@ -9194,10 +9194,10 @@ let eradicate_meta_class_is_nullsafe = ~user_documentation:"" let eradicate_meta_class_is_nullsafe = - register ~id:"ERADICATE_META_CLASS_IS_NULLSAFE" - ~hum: + register + ~id:"ERADICATE_META_CLASS_IS_NULLSAFE" (* Should be enabled for special integrations *) - "Class is marked @Nullsafe and has 0 issues" + ~hum:"Class is marked @Nullsafe and has 0 issues" (* Should be enabled for special integrations *) ~enabled:false Info From 1b7355f6bb3d32bd3277f87f0dcb66aea2ced0f2 Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Thu, 1 Aug 2024 15:40:01 +0200 Subject: [PATCH 091/146] fix infix bind --- lib/Fmt_ast.ml | 8 +++++++- test/passing/tests/infix_bind-fit_or_vertical.ml.ref | 10 ++++++++-- test/passing/tests/infix_bind.ml | 10 ++++++++-- 3 files changed, 23 insertions(+), 5 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 75b2f4e59c..f05d1b5096 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -2003,6 +2003,12 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens let xr = sub_exp ~ctx r in let parens_r = parenze_exp xr in let indent_wrap = if parens then -2 else 0 in + let followed_by_infix_op = + match body with + | Pfunction_body {pexp_desc=Pexp_infix (_, _, {pexp_desc= Pexp_function _; _}); _} -> + true + | _ -> false + in pro $ wrap_fits_breaks_if c.conf parens "(" ")" ( fmt_function ~ctx:(Exp r) @@ -2014,7 +2020,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens $ fmt_expression ~indent_wrap c (sub_exp ~ctx l) $ space_break $ hovbox 0 (fmt_str_loc c op $ space_break $ intro) ) - $ space_break ) + $ (fmt_or followed_by_infix_op force_break space_break) ) ~label:Nolabel ~attrs:r.pexp_attributes ~loc:r.pexp_loc c (args, typ, body) $ fmt_if has_attr (str ")") diff --git a/test/passing/tests/infix_bind-fit_or_vertical.ml.ref b/test/passing/tests/infix_bind-fit_or_vertical.ml.ref index eefaa93f6c..b7fba5c4e8 100644 --- a/test/passing/tests/infix_bind-fit_or_vertical.ml.ref +++ b/test/passing/tests/infix_bind-fit_or_vertical.ml.ref @@ -1,13 +1,19 @@ f x >>= fun y -> g y >>= fun () -> -f x >>= fun y -> g y >>= fun () -> f x >>= fun y -> g y >>= fun () -> y () +f x >>= fun y -> +g y >>= fun () -> +f x >>= fun y -> +g y >>= fun () -> y () ;; f x >>= function | A -> ( g y >>= fun () -> f x >>= fun y -> - g y >>= function x -> ( f x >>= fun y -> g y >>= function _ -> y () ) ) + g y >>= function + | x -> ( + f x >>= fun y -> + g y >>= function _ -> y () ) ) ;; eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee |> fun x -> x ;; diff --git a/test/passing/tests/infix_bind.ml b/test/passing/tests/infix_bind.ml index 2e01dde50d..0d4fcf4645 100644 --- a/test/passing/tests/infix_bind.ml +++ b/test/passing/tests/infix_bind.ml @@ -1,13 +1,19 @@ f x >>= fun y -> g y >>= fun () -> -f x >>= fun y -> g y >>= fun () -> f x >>= fun y -> g y >>= fun () -> y () +f x >>= fun y -> +g y >>= fun () -> +f x >>= fun y -> +g y >>= fun () -> y () ;; f x >>= function | A -> ( g y >>= fun () -> f x >>= fun y -> - g y >>= function x -> ( f x >>= fun y -> g y >>= function _ -> y () ) ) + g y >>= function + | x -> ( + f x >>= fun y -> + g y >>= function _ -> y () ) ) ;; eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee |> fun x -> x ;; From 4b16ccb4343f262cfa574a0539ff4754f187bc73 Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Thu, 1 Aug 2024 15:40:20 +0200 Subject: [PATCH 092/146] format format 2 --- lib/Fmt_ast.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index f05d1b5096..f9fc3976f6 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -2005,7 +2005,9 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens let indent_wrap = if parens then -2 else 0 in let followed_by_infix_op = match body with - | Pfunction_body {pexp_desc=Pexp_infix (_, _, {pexp_desc= Pexp_function _; _}); _} -> + | Pfunction_body + {pexp_desc= Pexp_infix (_, _, {pexp_desc= Pexp_function _; _}); _} + -> true | _ -> false in @@ -2020,7 +2022,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens $ fmt_expression ~indent_wrap c (sub_exp ~ctx l) $ space_break $ hovbox 0 (fmt_str_loc c op $ space_break $ intro) ) - $ (fmt_or followed_by_infix_op force_break space_break) ) + $ fmt_or followed_by_infix_op force_break space_break ) ~label:Nolabel ~attrs:r.pexp_attributes ~loc:r.pexp_loc c (args, typ, body) $ fmt_if has_attr (str ")") From 6d3ce5f7adb8489f5546156244055ebc7decd2aa Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Thu, 1 Aug 2024 16:33:20 +0200 Subject: [PATCH 093/146] issue289 fix --- lib/Params.ml | 4 ++-- test/passing/tests/issue289.ml | 20 ++++++++++---------- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/lib/Params.ml b/lib/Params.ml index f01c770e9d..95bcc4d11f 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -794,13 +794,13 @@ module Indent = struct else let extra = if c.fmt_opts.wrap_fun_args.v then 0 - else match ctx0 with Str _ -> 2 | _ -> 0 + else match ctx0 with Str _ -> 2 | _ -> 2 in if Poly.equal c.fmt_opts.function_indent_nested.v `Always then c.fmt_opts.function_indent.v + extra else match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with - | Some _ -> default + 2 + | Some _ -> default + 2 + if ocp c then 0 else extra | None -> if parens && not has_label then if ocp c then default + 1 else default diff --git a/test/passing/tests/issue289.ml b/test/passing/tests/issue289.ml index c5fd362fd5..3e7a389384 100644 --- a/test/passing/tests/issue289.ml +++ b/test/passing/tests/issue289.ml @@ -3,31 +3,31 @@ let foo = let open Gql in [ field "id" ~doc:"Toy ID." ~args:[] ~typ:(non_null guid) ~resolve:(function - | _ctx -> x.id ) + | _ctx -> x.id ) ; field "id" ~doc:"Toy ID." ~args:[] ~typppp ~resolve:(function - | _ctx -> x.id ) + | _ctx -> x.id ) ; field "id" ~doc:"Toy ID." ~args:[] ~typ:(non_null guid) ~resolve:(function - | A -> x.id - | B -> c ) + | A -> x.id + | B -> c ) ; field "id" ~doc:"Toy ID." ~args:[] ~resolve:(function - | A -> x.id - | B -> c ) + | A -> x.id + | B -> c ) ; field "id" ~doc:"Toy ID." ~args:[] ~typppppppppppppppppppp ~resolve:(function - | AAAAAAAAAAAAAAAAAAAa -> x.idddddddddddddddddddddddddd - | BBBBBBBBBBBBBBBB -> ccccccccccccccccccccccc ) + | AAAAAAAAAAAAAAAAAAAa -> x.idddddddddddddddddddddddddd + | BBBBBBBBBBBBBBBB -> ccccccccccccccccccccccc ) ; field "id" ~doc:"Toy ID." ~args:[] ~resolve:(function - | AAAAAAAAAAAAAAAAAAAa -> x.idddddddddddddddddddddddddd - | BBBBBBBBBBBBBBBB -> ccccccccccccccccccccccc ) + | AAAAAAAAAAAAAAAAAAAa -> x.idddddddddddddddddddddddddd + | BBBBBBBBBBBBBBBB -> ccccccccccccccccccccccc ) ; field "id" ~doc:"Toy ID." From 3464d63014c325f1f9fe497d3b9e38f3302a874c Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Fri, 2 Aug 2024 14:22:34 +0200 Subject: [PATCH 094/146] Fix indentation of 'let _ = fun _ -> fun _ ->' The original formatting might be considered a bug, which is reimplemented here. --- lib/Params.ml | 14 ++++++++------ test/passing/tests/fun_decl.ml | 7 +++++++ test/passing/tests/js_source.ml.ref | 6 +++--- test/passing/tests/object.ml.ref | 6 +++--- 4 files changed, 21 insertions(+), 12 deletions(-) diff --git a/lib/Params.ml b/lib/Params.ml index 95bcc4d11f..73dbbda19d 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -63,12 +63,14 @@ let ctx_is_apply_and_exp_is_last_arg_and_other_args_are_simple c ~ctx ctx0 = Poly.equal last_arg exp && args_are_simple | _ -> false -(** [ctx_is_let ~ctx ctx0] checks whether [ctx0] is a let binding containing - [ctx]. *) -let ctx_is_let ~ctx = function +(** [ctx_is_let_or_fun ~ctx ctx0] checks whether [ctx0] is a let binding containing + [ctx] or a [fun] with [ctx] on the RHS. *) +let ctx_is_let_or_fun ~ctx = function | Lb _ | Str _ | Bo _ -> true - | Exp {pexp_desc= Pexp_let (_, rhs, _); _} -> ( - match ctx with Exp exp -> not (phys_equal rhs exp) | _ -> false ) + | Exp {pexp_desc= Pexp_let (_, rhs, _); _} -> + ( match ctx with Exp exp -> not (phys_equal rhs exp) | _ -> false ) + | Exp {pexp_desc= Pexp_function (_, _, Pfunction_body rhs); _} -> + ( match ctx with Exp exp -> phys_equal rhs exp | _ -> false ) | _ -> false let parens_if parens (c : Conf.t) ?(disambiguate = false) k = @@ -158,7 +160,7 @@ module Exp = struct if ctx_is_infix ctx0 then 0 else if Poly.equal c.fmt_opts.function_indent_nested.v `Always then c.fmt_opts.function_indent.v - else if ctx_is_let ~ctx ctx0 then + else if ctx_is_let_or_fun ~ctx ctx0 then if c.fmt_opts.let_binding_deindent_fun.v then 1 else 0 else if ocp c then let begins_line loc = diff --git a/test/passing/tests/fun_decl.ml b/test/passing/tests/fun_decl.ml index a8683cec55..2e2e7c95a1 100644 --- a/test/passing/tests/fun_decl.ml +++ b/test/passing/tests/fun_decl.ml @@ -14,6 +14,13 @@ let _ = fooooooooooooooooooooooooooo foooooooooooooo foooooooooo -> some_large_computation +let () = + fun x : int -> + fun r : int -> + fun u -> + foooooooooooooooooooooooooooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooooooooooooooooooooooooooo + [@@@ocamlformat "wrap-fun-args=false"] let to_loc_trace diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index 40e858d089..f4b9930648 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -10279,9 +10279,9 @@ type input = let x = fun [@foo] x -> fun [@foo] y -> - object - method x = y - end + object + method x = y + end ;; class x = diff --git a/test/passing/tests/object.ml.ref b/test/passing/tests/object.ml.ref index 5b7184fdcb..ebf54da2ea 100644 --- a/test/passing/tests/object.ml.ref +++ b/test/passing/tests/object.ml.ref @@ -299,9 +299,9 @@ class a x = object (self) end let x = fun [@foo] x -> fun [@foo] y -> - object - method x = y - end + object + method x = y + end class x = fun [@foo] x -> From 1e582f8e1aa9609db26d6d1bbbf8b87360fe0ff1 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Fri, 2 Aug 2024 14:24:53 +0200 Subject: [PATCH 095/146] fmt --- lib/Params.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lib/Params.ml b/lib/Params.ml index 73dbbda19d..85c5671a15 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -67,10 +67,10 @@ let ctx_is_apply_and_exp_is_last_arg_and_other_args_are_simple c ~ctx ctx0 = [ctx] or a [fun] with [ctx] on the RHS. *) let ctx_is_let_or_fun ~ctx = function | Lb _ | Str _ | Bo _ -> true - | Exp {pexp_desc= Pexp_let (_, rhs, _); _} -> - ( match ctx with Exp exp -> not (phys_equal rhs exp) | _ -> false ) - | Exp {pexp_desc= Pexp_function (_, _, Pfunction_body rhs); _} -> - ( match ctx with Exp exp -> phys_equal rhs exp | _ -> false ) + | Exp {pexp_desc= Pexp_let (_, rhs, _); _} -> ( + match ctx with Exp exp -> not (phys_equal rhs exp) | _ -> false ) + | Exp {pexp_desc= Pexp_function (_, _, Pfunction_body rhs); _} -> ( + match ctx with Exp exp -> phys_equal rhs exp | _ -> false ) | _ -> false let parens_if parens (c : Conf.t) ?(disambiguate = false) k = From 17d1796978f64d1c32af0eb19aaf0688661eb3bd Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Tue, 3 Sep 2024 15:24:49 +0200 Subject: [PATCH 096/146] fix issue with single case function --- lib/Fmt_ast.ml | 14 +++++++++++++- lib/Params.ml | 6 +++++- lib/Params.mli | 2 ++ test/passing/tests/attributes.ml | 6 ++---- test/passing/tests/issue289.ml | 10 +++++----- test/passing/tests/js_source.ml.err | 10 +++++----- test/passing/tests/js_source.ml.ocp | 22 +++++----------------- test/passing/tests/js_source.ml.ref | 24 ++++++------------------ 8 files changed, 43 insertions(+), 51 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index f9fc3976f6..941489afed 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1543,7 +1543,19 @@ and fmt_function ?(last_arg = false) ?force_closing_paren ~ctx ~ctx0 hvbox ~name:"cases box" 0 | _ -> Fn.id in - (fun_ $ function_, box_cases (fmt_cases c ctx cs), box, 0) + let box, cases = + match cs with + | [{pc_lhs; pc_guard= _; pc_rhs}] + when Params.Exp.single_line_function ~ctx ~ctx0 ~args -> + hovbox 4 , + hvbox 0 + ( fmt_pattern c ~pro:(if_newline "| ") (sub_pat ~ctx pc_lhs) + $ space_break $ str "->" ) + $ space_break + $ cbox 0 (fmt_expression c (sub_exp ~ctx pc_rhs)) + | _ -> box, fmt_cases c ctx cs + in + (fun_ $ function_, box_cases cases, box, 0) in let space_opn_parens, space_cls_parens = match ctx0 with diff --git a/lib/Params.ml b/lib/Params.ml index 85c5671a15..2fbab066bd 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -204,6 +204,9 @@ module Exp = struct (* special case that break the arrow in [let _ = fun ... ->] *) str " " | _ -> break 1 (if last_arg && has_label then 0 else -2) + + let single_line_function ~ctx ~ctx0 ~args = + ctx_is_apply_and_exp_is_last_arg ~ctx ctx0 && List.is_empty args end module Mod = struct @@ -719,7 +722,8 @@ let get_if_then_else (c : Conf.t) ~first ~last ~parens_bch ~parens_prev_bch ; box_keyword_and_expr= (fun k -> hvbox 2 - (fmt_or (Option.is_some xcond) (str "then") (str "else") $ k) ) + (fmt_or (Option.is_some xcond) (str "then") (str "else") $ k) + ) ; branch_pro= fmt_or (beginend || parens_bch) (str " ") space_break ; wrap_parens= wrap_parens diff --git a/lib/Params.mli b/lib/Params.mli index 829f6c10a2..822849c6da 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -64,6 +64,8 @@ module Exp : sig val break_fun_decl_args : ctx:Ast.t -> last_arg:bool -> has_label:bool -> Fmt.t + + val single_line_function : ctx:Ast.t -> ctx0:Ast.t -> args:'a list -> bool end module Mod : sig diff --git a/test/passing/tests/attributes.ml b/test/passing/tests/attributes.ml index 5232127915..4a2fec66b0 100644 --- a/test/passing/tests/attributes.ml +++ b/test/passing/tests/attributes.ml @@ -390,8 +390,7 @@ let _ = when f ~f:(function [@ocaml.warning (* ....................................... *) - "-4"] - | _ -> . ) -> + "-4"] _ -> . ) -> y let[@a @@ -419,8 +418,7 @@ let[@a ~f:(function[@ocaml.warning (* ....................................... *) let x = a and y = b in - x + y] - | _ -> . ) -> + x + y] _ -> . ) -> y [@attr (* ... *) diff --git a/test/passing/tests/issue289.ml b/test/passing/tests/issue289.ml index 3e7a389384..5037fbc0f3 100644 --- a/test/passing/tests/issue289.ml +++ b/test/passing/tests/issue289.ml @@ -4,8 +4,8 @@ let foo = let open Gql in [ field "id" ~doc:"Toy ID." ~args:[] ~typ:(non_null guid) ~resolve:(function | _ctx -> x.id ) - ; field "id" ~doc:"Toy ID." ~args:[] ~typppp ~resolve:(function - | _ctx -> x.id ) + ; field "id" ~doc:"Toy ID." ~args:[] ~typppp ~resolve:(function _ctx -> + x.id ) ; field "id" ~doc:"Toy ID." @@ -64,9 +64,9 @@ let foo = let foo = let open Gql in [ field "id" ~doc:"Toy ID." ~args:[] ~typ:(non_null guid) ~resolve:(function - | _ctx -> x.id ) - ; field "id" ~doc:"Toy ID." ~args:[] ~typppp ~resolve:(function - | _ctx -> x.id ) + | _ctx -> x.id ) + ; field "id" ~doc:"Toy ID." ~args:[] ~typppp ~resolve:(function _ctx -> + x.id ) ; field "id" ~doc:"Toy ID." ~args:[] ~typ:(non_null guid) ~resolve:(function | A -> x.id diff --git a/test/passing/tests/js_source.ml.err b/test/passing/tests/js_source.ml.err index 65746b4035..db36e4260e 100644 --- a/test/passing/tests/js_source.ml.err +++ b/test/passing/tests/js_source.ml.err @@ -1,7 +1,7 @@ Warning: tests/js_source.ml:161 exceeds the margin Warning: tests/js_source.ml:2670 exceeds the margin -Warning: tests/js_source.ml:9567 exceeds the margin -Warning: tests/js_source.ml:9671 exceeds the margin -Warning: tests/js_source.ml:9730 exceeds the margin -Warning: tests/js_source.ml:9813 exceeds the margin -Warning: tests/js_source.ml:10320 exceeds the margin +Warning: tests/js_source.ml:9561 exceeds the margin +Warning: tests/js_source.ml:9665 exceeds the margin +Warning: tests/js_source.ml:9724 exceeds the margin +Warning: tests/js_source.ml:9807 exceeds the margin +Warning: tests/js_source.ml:10309 exceeds the margin diff --git a/test/passing/tests/js_source.ml.ocp b/test/passing/tests/js_source.ml.ocp index 1d4cf9f0b4..da0c0d92d7 100644 --- a/test/passing/tests/js_source.ml.ocp +++ b/test/passing/tests/js_source.ml.ocp @@ -4904,10 +4904,7 @@ type t = F(M).t module Common0 = struct type msg = Msg - let handle_msg = - ref (function - | _ -> failwith "Unable to handle message") - ;; + let handle_msg = ref (function _ -> failwith "Unable to handle message") let extend_handle f = let old = !handle_msg in @@ -4924,10 +4921,7 @@ let q' : Common0.msg Queue.t = Common0.q module Common = struct type msg = .. - let handle_msg = - ref (function - | _ -> failwith "Unable to handle message") - ;; + let handle_msg = ref (function _ -> failwith "Unable to handle message") let extend_handle f = let old = !handle_msg in @@ -9836,8 +9830,7 @@ let[@a (* ....................................... *) let x = a and y = b in - x + y] - | _ -> .) -> + x + y] _ -> .) -> y [@attr (* ... *) @@ -10055,11 +10048,7 @@ let _ = fooooooooooo ;; -let _ = - foo - |> List.map (function - | A -> do_something ()) -;; +let _ = foo |> List.map (function A -> do_something ()) let _ = foo @@ -10461,8 +10450,7 @@ let _ = let _ = fooooooooooooooooooooooooooooooo - |> foooooooooooooooooooooooooooo ~fooooooooooooooooooooooooooooooo (function - | foo -> bar) + |> foooooooooooooooooooooooooooo ~fooooooooooooooooooooooooooooooo (function foo -> bar) ;; let _ = diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index f4b9930648..c4414643a8 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -4904,10 +4904,7 @@ type t = F(M).t module Common0 = struct type msg = Msg - let handle_msg = - ref (function - | _ -> failwith "Unable to handle message") - ;; + let handle_msg = ref (function _ -> failwith "Unable to handle message") let extend_handle f = let old = !handle_msg in @@ -4924,10 +4921,7 @@ let q' : Common0.msg Queue.t = Common0.q module Common = struct type msg = .. - let handle_msg = - ref (function - | _ -> failwith "Unable to handle message") - ;; + let handle_msg = ref (function _ -> failwith "Unable to handle message") let extend_handle f = let old = !handle_msg in @@ -9807,7 +9801,7 @@ let _ = when f ~f: (function [@ocaml.warning (* ....................................... *) "-4"] - | _ -> .) -> y + | _ -> .) -> y ;; let[@a @@ -9836,8 +9830,7 @@ let[@a (* ....................................... *) let x = a and y = b in - x + y] - | _ -> .) -> + x + y] _ -> .) -> y [@attr (* ... *) @@ -10055,11 +10048,7 @@ let _ = fooooooooooo ;; -let _ = - foo - |> List.map (function - | A -> do_something ()) -;; +let _ = foo |> List.map (function A -> do_something ()) let _ = foo @@ -10461,8 +10450,7 @@ let _ = let _ = fooooooooooooooooooooooooooooooo - |> foooooooooooooooooooooooooooo ~fooooooooooooooooooooooooooooooo (function - | foo -> bar) + |> foooooooooooooooooooooooooooo ~fooooooooooooooooooooooooooooooo (function foo -> bar) ;; let _ = From d4564e4c04884f41a5e9b3c1295b1e18d7db1d96 Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Tue, 3 Sep 2024 15:25:00 +0200 Subject: [PATCH 097/146] todo for this branch --- TODO.md | 111 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 111 insertions(+) create mode 100644 TODO.md diff --git a/TODO.md b/TODO.md new file mode 100644 index 0000000000..91a724a4d5 --- /dev/null +++ b/TODO.md @@ -0,0 +1,111 @@ +## On fait pas si trop dur: + +```diff + let f ssssssssss = +- String.fold ssssssssss ~init:innnnnnnnnnit ~f:(fun accuuuuuuuuuum -> +- function ++ String.fold ssssssssss ~init:innnnnnnnnnit ++ ~f:(fun accuuuuuuuuuum -> function + | '0' -> g accuuuuuuuuuum + | '1' -> h accuuuuuuuuuum + | _ -> i accuuuuuuuuuum ) +``` + +```diff + let default = + command##hasPermission #= (fun ctx -> foooooooooooooooooo fooooooooooo) ; + command##hasPermission #= (fun ctx -> +- foooooooooooooooooo fooooooooooo foooooo fooooooooo foooooooooo) ; ++ foooooooooooooooooo fooooooooooo foooooo fooooooooo foooooooooo ) ; + foo +``` + +```diff +-let rec assoc : type a. string -> a rep -> assoc list -> a = +- fun x r -> function ++let rec assoc : type a. string -> a rep -> assoc list -> a = fun x r -> function + | [] -> raise Not_found + | Assoc (x', r', v) :: env -> + if x = x' +``` + +### Janestreet + +```diff + Sum + ( (function +- | `A n -> "A", Some (Tdyn (Int, n)) +- | `B s -> "B", Some (Tdyn (String, s)) +- | `C -> "C", None) ++ | `A n -> "A", Some (Tdyn (Int, n)) ++ | `B s -> "B", Some (Tdyn (String, s)) ++ | `C -> "C", None) + , function +``` + + +```diff + let x = + some_value + |> some_fun (fun x -> +- do_something (); +- do_something_else (); +- return_this_value) ++ do_something (); ++ do_something_else (); ++ return_this_value) + ;; +``` + +```diff + foo + |> List.double_map + ~f1:(fun x -> +- do_something (); +- do_something (); +- do_something (); +- do_something (); +- do_something_else ()) ++ do_something (); ++ do_something (); ++ do_something (); ++ do_something (); ++ do_something_else ()) + ~f2:(fun x -> +- do_something (); +- do_something (); +- do_something (); +- do_something (); +- do_something_else ()) ++ do_something (); ++ do_something (); ++ do_something (); ++ do_something (); ++ do_something_else ()) + |> bar + ;; +``` + +```diff + match () with + | _ -> + (fun _ : _ -> +- match () with +- | _ -> ()) ++ (match () with ++ | _ -> ())) + | _ -> () + ;; +``` + +```diff + let _ = + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + ~bbbbbbbbbbbbbbbbbbbbbbbbbbbb: +- (fun +- (_ : (ccccccccccccc * ddddddddddddddddddddddddddddd) eeee) -> FFFFFFFFF gg) ++ (fun (_ : (ccccccccccccc * ddddddddddddddddddddddddddddd) eeee) ++ -> FFFFFFFFF gg) + ~h + ;; +``` \ No newline at end of file From 6b01076b818b5a9c77b059dc88cb8b193d536b49 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Tue, 3 Sep 2024 16:06:05 +0200 Subject: [PATCH 098/146] Fix (function) indent with janestreet profile --- TODO.md | 15 +-------------- lib/Params.ml | 2 +- test/passing/tests/js_source.ml.ref | 14 +++++++------- 3 files changed, 9 insertions(+), 22 deletions(-) diff --git a/TODO.md b/TODO.md index 91a724a4d5..f064ec981b 100644 --- a/TODO.md +++ b/TODO.md @@ -31,19 +31,6 @@ ### Janestreet -```diff - Sum - ( (function -- | `A n -> "A", Some (Tdyn (Int, n)) -- | `B s -> "B", Some (Tdyn (String, s)) -- | `C -> "C", None) -+ | `A n -> "A", Some (Tdyn (Int, n)) -+ | `B s -> "B", Some (Tdyn (String, s)) -+ | `C -> "C", None) - , function -``` - - ```diff let x = some_value @@ -108,4 +95,4 @@ + -> FFFFFFFFF gg) ~h ;; -``` \ No newline at end of file +``` diff --git a/lib/Params.ml b/lib/Params.ml index 2fbab066bd..fe3661ee34 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -809,7 +809,7 @@ module Indent = struct | Some _ -> default + 2 + if ocp c then 0 else extra | None -> if parens && not has_label then - if ocp c then default + 1 else default + if ocp c then default + 2 else default else if ocp c then default else default + extra diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index c4414643a8..bcd5480f01 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -1325,8 +1325,8 @@ let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = (Sum { sum_proj = (function - | `Nil -> "Nil", None - | `Cons p -> "Cons", Some (Tdyn (tcons, p))) + | `Nil -> "Nil", None + | `Cons p -> "Cons", Some (Tdyn (tcons, p))) ; sum_cases = [ "Nil", TCnoarg Thd; "Cons", TCarg (Ttl Thd, tcons) ] ; sum_inj = (fun (type c) -> @@ -1362,9 +1362,9 @@ let ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = (* Could also use [get_case] for proj, but direct definition is shorter *) Sum ( (function - | `A n -> "A", Some (Tdyn (Int, n)) - | `B s -> "B", Some (Tdyn (String, s)) - | `C -> "C", None) + | `A n -> "A", Some (Tdyn (Int, n)) + | `B s -> "B", Some (Tdyn (String, s)) + | `C -> "C", None) , function | "A", Some (Tdyn (Int, n)) -> `A n | "B", Some (Tdyn (String, s)) -> `B s @@ -1379,8 +1379,8 @@ let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = Rec (Sum ( (function - | `Nil -> "Nil", None - | `Cons p -> "Cons", Some (Tdyn (targ, p))) + | `Nil -> "Nil", None + | `Cons p -> "Cons", Some (Tdyn (targ, p))) , function | "Nil", None -> `Nil | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p )) From 6b294ad110a2876087bf0c8f1b35791aae84cdc7 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Tue, 3 Sep 2024 16:52:01 +0200 Subject: [PATCH 099/146] janestreet: Tweak indent of docked (fun . -> .) --- TODO.md | 13 ------------- lib/Params.ml | 24 +++++++++++------------- test/passing/tests/js_source.ml.ref | 18 +++++++++--------- 3 files changed, 20 insertions(+), 35 deletions(-) diff --git a/TODO.md b/TODO.md index f064ec981b..3b323adea8 100644 --- a/TODO.md +++ b/TODO.md @@ -31,19 +31,6 @@ ### Janestreet -```diff - let x = - some_value - |> some_fun (fun x -> -- do_something (); -- do_something_else (); -- return_this_value) -+ do_something (); -+ do_something_else (); -+ return_this_value) - ;; -``` - ```diff foo |> List.double_map diff --git a/lib/Params.ml b/lib/Params.ml index fe3661ee34..48e45a5181 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -36,18 +36,15 @@ let ctx_is_infix = function let ctx_is_apply_and_exp_is_arg ~ctx ctx0 = match (ctx, ctx0) with | Exp exp, Exp {pexp_desc= Pexp_apply (_, args); _} -> + let last_lbl, last_arg = List.last_exn args in + if phys_equal last_arg exp then + Some (last_lbl, exp, true) + else List.find_map - ~f:(fun (lbl, x) -> if phys_equal x exp then Some lbl else None) + ~f:(fun (lbl, x) -> if phys_equal x exp then Some (lbl, exp, false) else None) args | _ -> None -let ctx_is_apply_and_exp_is_last_arg ~ctx ctx0 = - match (ctx, ctx0) with - | Exp exp, Exp {pexp_desc= Pexp_apply (_, args); _} -> - let _, last_arg = List.last_exn args in - Poly.equal last_arg exp - | _ -> false - let ctx_is_apply_and_exp_is_last_arg_and_other_args_are_simple c ~ctx ctx0 = match (ctx, ctx0) with | Exp exp, Exp {pexp_desc= Pexp_apply (_, args); _} -> @@ -167,10 +164,9 @@ module Exp = struct Source.begins_line ~ignore_spaces:true source loc in match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with - | Some Nolabel -> - if ctx_is_apply_and_exp_is_last_arg ~ctx ctx0 then 5 else 3 - | Some (Labelled x | Optional x) -> - (* if ctx_is_apply_and_exp_is_last_arg ~ctx ctx0 then 2 else *) + | Some (Nolabel, fun_exp, is_last_arg) -> + if begins_line fun_exp.pexp_loc then if is_last_arg then 5 else 3 else 2 + | Some ((Labelled x | Optional x), _, _) -> if begins_line x.loc then 4 else 2 | None -> if parens then 3 else 2 else if @@ -206,7 +202,9 @@ module Exp = struct | _ -> break 1 (if last_arg && has_label then 0 else -2) let single_line_function ~ctx ~ctx0 ~args = - ctx_is_apply_and_exp_is_last_arg ~ctx ctx0 && List.is_empty args + match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with + | Some (_, _, true) -> List.is_empty args + | _ -> false end module Mod = struct diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index bcd5480f01..9189aa48ba 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -9886,17 +9886,17 @@ let x = let x = some_value |> some_fun (fun x -> - do_something (); - do_something_else (); - return_this_value) + do_something (); + do_something_else (); + return_this_value) ;; let x = some_value ^ some_fun (fun x -> - do_something (); - do_something_else (); - return_this_value) + do_something (); + do_something_else (); + return_this_value) ;; let bind t ~f = @@ -10423,9 +10423,9 @@ let _ = let _ = fooooooooooooooooooooooooooooooo |> fooooooooooooooooooooooooooooooo ~fooooooooooooooooooooooooooooooo (fun foo -> - match bar with - | Some _ -> foo - | None -> baz) + match bar with + | Some _ -> foo + | None -> baz) ;; let _ = From 0472038b39ca54ccc575f1cc7c1ebb29bdb932b6 Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Wed, 4 Sep 2024 16:28:51 +0200 Subject: [PATCH 100/146] fix let-binding-deindent-fun and aslo format according to previous commit --- lib/Cmts.ml | 3 +- lib/Fmt_ast.ml | 14 +- lib/Params.ml | 20 +- lib/Params.mli | 2 +- test/passing/dune.inc | 18 ++ .../tests/let_binding-deindent-fun.ml.err | 1 + .../tests/let_binding-deindent-fun.ml.opts | 1 + .../tests/let_binding-deindent-fun.ml.ref | 271 ++++++++++++++++++ .../tests/let_binding-in_indent.ml.ref | 8 + test/passing/tests/let_binding-indent.ml.ref | 9 + test/passing/tests/let_binding.ml | 11 + test/passing/tests/let_binding.ml.ref | 8 + 12 files changed, 347 insertions(+), 19 deletions(-) create mode 100644 test/passing/tests/let_binding-deindent-fun.ml.err create mode 100644 test/passing/tests/let_binding-deindent-fun.ml.opts create mode 100644 test/passing/tests/let_binding-deindent-fun.ml.ref diff --git a/lib/Cmts.ml b/lib/Cmts.ml index 045126d280..c6235f77f8 100644 --- a/lib/Cmts.ml +++ b/lib/Cmts.ml @@ -457,8 +457,7 @@ let break_comment_group source a b = Location.line_difference a b = 0 && List.is_empty (Source.tokens_between source a.loc_end b.loc_start - ~filter:(function - | _ -> true ) ) + ~filter:(function _ -> true ) ) in not (vertical_align || horizontal_align) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 941489afed..3dc76b9f9a 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1547,13 +1547,13 @@ and fmt_function ?(last_arg = false) ?force_closing_paren ~ctx ~ctx0 match cs with | [{pc_lhs; pc_guard= _; pc_rhs}] when Params.Exp.single_line_function ~ctx ~ctx0 ~args -> - hovbox 4 , - hvbox 0 - ( fmt_pattern c ~pro:(if_newline "| ") (sub_pat ~ctx pc_lhs) - $ space_break $ str "->" ) - $ space_break - $ cbox 0 (fmt_expression c (sub_exp ~ctx pc_rhs)) - | _ -> box, fmt_cases c ctx cs + ( hovbox 4 + , hvbox 0 + ( fmt_pattern c ~pro:(if_newline "| ") (sub_pat ~ctx pc_lhs) + $ space_break $ str "->" ) + $ space_break + $ cbox 0 (fmt_expression c (sub_exp ~ctx pc_rhs)) ) + | _ -> (box, fmt_cases c ctx cs) in (fun_ $ function_, box_cases cases, box, 0) in diff --git a/lib/Params.ml b/lib/Params.ml index 48e45a5181..96a41b7837 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -37,12 +37,12 @@ let ctx_is_apply_and_exp_is_arg ~ctx ctx0 = match (ctx, ctx0) with | Exp exp, Exp {pexp_desc= Pexp_apply (_, args); _} -> let last_lbl, last_arg = List.last_exn args in - if phys_equal last_arg exp then - Some (last_lbl, exp, true) + if phys_equal last_arg exp then Some (last_lbl, exp, true) else - List.find_map - ~f:(fun (lbl, x) -> if phys_equal x exp then Some (lbl, exp, false) else None) - args + List.find_map + ~f:(fun (lbl, x) -> + if phys_equal x exp then Some (lbl, exp, false) else None ) + args | _ -> None let ctx_is_apply_and_exp_is_last_arg_and_other_args_are_simple c ~ctx ctx0 = @@ -63,7 +63,9 @@ let ctx_is_apply_and_exp_is_last_arg_and_other_args_are_simple c ~ctx ctx0 = (** [ctx_is_let_or_fun ~ctx ctx0] checks whether [ctx0] is a let binding containing [ctx] or a [fun] with [ctx] on the RHS. *) let ctx_is_let_or_fun ~ctx = function - | Lb _ | Str _ | Bo _ -> true + | Str {pstr_desc= Pstr_value _; _} -> true + | Str _ -> false + | Lb _ | Bo _ -> true | Exp {pexp_desc= Pexp_let (_, rhs, _); _} -> ( match ctx with Exp exp -> not (phys_equal rhs exp) | _ -> false ) | Exp {pexp_desc= Pexp_function (_, _, Pfunction_body rhs); _} -> ( @@ -165,7 +167,8 @@ module Exp = struct in match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with | Some (Nolabel, fun_exp, is_last_arg) -> - if begins_line fun_exp.pexp_loc then if is_last_arg then 5 else 3 else 2 + if begins_line fun_exp.pexp_loc then if is_last_arg then 5 else 3 + else 2 | Some ((Labelled x | Optional x), _, _) -> if begins_line x.loc then 4 else 2 | None -> if parens then 3 else 2 @@ -720,8 +723,7 @@ let get_if_then_else (c : Conf.t) ~first ~last ~parens_bch ~parens_prev_bch ; box_keyword_and_expr= (fun k -> hvbox 2 - (fmt_or (Option.is_some xcond) (str "then") (str "else") $ k) - ) + (fmt_or (Option.is_some xcond) (str "then") (str "else") $ k) ) ; branch_pro= fmt_or (beginend || parens_bch) (str " ") space_break ; wrap_parens= wrap_parens diff --git a/lib/Params.mli b/lib/Params.mli index 822849c6da..7e3c94b6c7 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -65,7 +65,7 @@ module Exp : sig val break_fun_decl_args : ctx:Ast.t -> last_arg:bool -> has_label:bool -> Fmt.t - val single_line_function : ctx:Ast.t -> ctx0:Ast.t -> args:'a list -> bool + val single_line_function : ctx:Ast.t -> ctx0:Ast.t -> args:'a list -> bool end module Mod : sig diff --git a/test/passing/dune.inc b/test/passing/dune.inc index 9a1f00a0cc..61a6b0e853 100644 --- a/test/passing/dune.inc +++ b/test/passing/dune.inc @@ -3464,6 +3464,24 @@ (package ocamlformat) (action (diff tests/lazy.ml.err lazy.ml.stderr))) +(rule + (deps tests/.ocamlformat ) + (package ocamlformat) + (action + (with-stdout-to let_binding-deindent-fun.ml.stdout + (with-stderr-to let_binding-deindent-fun.ml.stderr + (run %{bin:ocamlformat} --margin-check --no-let-binding-deindent-fun %{dep:tests/let_binding.ml}))))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/let_binding-deindent-fun.ml.ref let_binding-deindent-fun.ml.stdout))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/let_binding-deindent-fun.ml.err let_binding-deindent-fun.ml.stderr))) + (rule (deps tests/.ocamlformat ) (package ocamlformat) diff --git a/test/passing/tests/let_binding-deindent-fun.ml.err b/test/passing/tests/let_binding-deindent-fun.ml.err new file mode 100644 index 0000000000..b503ec1354 --- /dev/null +++ b/test/passing/tests/let_binding-deindent-fun.ml.err @@ -0,0 +1 @@ +Warning: tests/let_binding.ml:265 exceeds the margin diff --git a/test/passing/tests/let_binding-deindent-fun.ml.opts b/test/passing/tests/let_binding-deindent-fun.ml.opts new file mode 100644 index 0000000000..e67d267be8 --- /dev/null +++ b/test/passing/tests/let_binding-deindent-fun.ml.opts @@ -0,0 +1 @@ +--no-let-binding-deindent-fun \ No newline at end of file diff --git a/test/passing/tests/let_binding-deindent-fun.ml.ref b/test/passing/tests/let_binding-deindent-fun.ml.ref new file mode 100644 index 0000000000..33cef1365c --- /dev/null +++ b/test/passing/tests/let_binding-deindent-fun.ml.ref @@ -0,0 +1,271 @@ +(* Note that {[ let ident : typ = exp ]} is different from {[ let (ident : + typ) = exp ]}. The difference should be maintained *) + +let (_ : int) = x1 + +let (x : int) = x2 + +let (_ : int) = x3 + +let x : int = x4 + +let _ = + let (x : int) = x in + let x : int = x in + let (_ : int) = x in + let _ : int = x in + () + +let%ext (_ : int) = x1 + +let%ext (x : int) = x2 + +let%ext (_ : int) = x3 + +let%ext x : int = x4 + +let%ext _ = + let%ext (x : int) = x in + let%ext x : int = x in + let%ext (_ : int) = x in + let%ext (_ : int) = x in + () + +let [%ext let x = 3] = 2 + +let [%ext: [%exp let x = 3]] = 2 + +let f : 'a. 'a ty -> 'a = fun y -> g y + +let f (A _ | B | C) = () + +let f + ( AAAAAAAAAAAAAAAAAAAAAAAAAAAAa _ | BBBBBBBBBBBBBBBBBBBBBbb + | CCCCCCCCCCCCCCCCCCCCCCccccc ) = + () + +let f + ( AAAAAAAAAAAAAAAAAAAAAAAAAAAAa + ( EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEe | FFFFFFFFFFFFFFFFFFFFFFFFFFf + | GGGGGGGGGGGGGGGGGGGGGGGGGGGGGGggggggggg ) + | BBBBBBBBBBBBBBBBBBBBBbb | CCCCCCCCCCCCCCCCCCCCCCccccc ) = + () + +let f (AAA (EEEEEEE | FFFFF | GGGGG) | BBBBBB | CCCCCCC) = () + +let f = function AAA (EEEEEEE | FFFFF | GGGGG) | BBBBBB | CCCCCCC -> () + +let f = function EEEEEEE | F | GGGGG | B | CCCCCCC -> () + +let f = function + | EEEEEEE | FFFFFFFFFFFFFFFFFFFFFFF | GGGGG + |BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBbb | CCCCCCC -> + () + +let (_ : t -> t -> int) = (compare : int list -> int list -> int) + +let _ = + let[@test] rec f = x in + y + +module Let_and_compact = struct + [@@@ocamlformat "let-and=compact"] + + let x = 2 + + and y = 2 + + let _ = + let x = 2 and y = 2 in + 3 + + let _ = + let%ext x = 2 and y = 2 in + 3 +end + +module Let_and_sparse = struct + [@@@ocamlformat "let-and=sparse"] + + let x = 2 + + and y = 2 + + let _ = + let x = 2 + and y = 2 in + 3 + + let _ = + let%ext x = 2 + and y = 2 in + 3 +end + +let f aaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbbbbbb cccccccccccccccccccccccc + dddddddddddddddddd eeeeeeeeeeeeee = + () + +let _ = + fun aaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbbbbbb cccccccccccccccccccccccc + dddddddddddddddddd eeeeeeeeeeeeee -> + () + +let _ = + let (x : int) = x in + let x : int = x in + let (_ : int) = x in + let _ : int = x in + let%ext (x : int) = x in + let%ext x : int = x in + let%ext (_ : int) = x in + let%ext _ : int = x in + () + +let fooo = fooooooooooo [@@foo] + +let fooo = fooooooooooo [@@foo] + +and fooo = fooooooooooo [@@foo] +;; + +let foooo = fooooooooo [@@foo] in +fooooooooooooooooooooo + +let[@foo] fooo = fooooooooooo + +let[@foo] fooo = fooooooooooo + +and[@foo] fooo = fooooooooooo +;; + +let[@foo] foooo = fooooooooo in +fooooooooooooooooooooo + +let a : int = 0 + +let b = (0 : int) + +let _ = + let+ a = b in + c + +let _ = + let+ a = b and+ c = d in + e + +let _ = + if true then a + else + let+ a = b in + c + +let _ = + if true then + let+ a = b in + c + else d + +let _ = + match a with + | a -> ( + match a with + | a -> ( + let+ a = b in + match a with a -> a ) ) + +let _ = + match a with + | a -> ( + match a with + | a -> ( + let+ a = b in + match a with a -> a ) + | b -> c ) + +let _ = + let+ a b = c in + d + +let _ = + f + (let+ a b = c in + d ) + +let () = + let* x = 1 (* blah *) and* y = 2 in + () + +let x = () +(* after x *) + +let y = () + +let x = () +(* after x *) + +and y = () + +(** doc x *) +let x = () [@@foo] +(* after x *) + +(** doc y *) +let y = () [@@foo] +(* after y *) + +(** doc x *) +let x = () +(* after x *) + +(** doc y *) +and y = () [@@foo] +(* after y *) + +let _ = + let* () = + (* xxx *) + xxx + and* () = + (* yyy *) + yyy + in + zzz + +[@@@ocamlformat "let-binding-spacing=double-semicolon"] + +module A = struct + let f : int S.t ab -> float S.t ab -> string = + fun (l : int S.t ab) (r : float S.t ab) -> + match (l, r) with A, B -> "f A B" + ;; +end + +let (A (a, _, b) | B (b, a)) = A (1, 2, 3) + +let copy from ~into : unit = + let ({ pulse_captured_vars_length_contradictions + ; pulse_summaries_count + ; topl_reachable_calls + ; timeouts + ; timings } [@warning "+9"] ) = + () + in + () +;; + +let {x; y} : foo = bar + +let ({x; y} : foo) = bar + +let a, b = (raise Exit : int * int) + +let a, b = (raise Exit : int * int) + +let _ = + fun xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx : _ -> + match () with _ -> () +;; + +fun xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx : _ -> + match () with _ -> () diff --git a/test/passing/tests/let_binding-in_indent.ml.ref b/test/passing/tests/let_binding-in_indent.ml.ref index 496d0aef81..5563c1a853 100644 --- a/test/passing/tests/let_binding-in_indent.ml.ref +++ b/test/passing/tests/let_binding-in_indent.ml.ref @@ -261,3 +261,11 @@ let ({x; y} : foo) = bar let a, b = (raise Exit : int * int) let a, b = (raise Exit : int * int) + +let _ = + fun xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx : _ -> + match () with _ -> () +;; + +fun xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx : _ -> + match () with _ -> () diff --git a/test/passing/tests/let_binding-indent.ml.ref b/test/passing/tests/let_binding-indent.ml.ref index 5e07912e98..b52b28d7c1 100644 --- a/test/passing/tests/let_binding-indent.ml.ref +++ b/test/passing/tests/let_binding-indent.ml.ref @@ -261,3 +261,12 @@ let ({x; y} : foo) = bar let a, b = (raise Exit : int * int) let a, b = (raise Exit : int * int) + +let _ = + fun xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx : + _ -> + match () with _ -> () +;; + +fun xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx : _ -> + match () with _ -> () diff --git a/test/passing/tests/let_binding.ml b/test/passing/tests/let_binding.ml index d01ee58177..a1537a7729 100644 --- a/test/passing/tests/let_binding.ml +++ b/test/passing/tests/let_binding.ml @@ -249,3 +249,14 @@ let ({ x; y } : foo) = bar let a, b = (raise Exit : int * int) let (a, b) = (raise Exit : int * int) +;; + +let _ = + fun xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx : _ -> + match () with + | _ -> () +;; + +fun xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx : _ -> + match () with + | _ -> () diff --git a/test/passing/tests/let_binding.ml.ref b/test/passing/tests/let_binding.ml.ref index 1920f73453..0778a3f7ff 100644 --- a/test/passing/tests/let_binding.ml.ref +++ b/test/passing/tests/let_binding.ml.ref @@ -261,3 +261,11 @@ let ({x; y} : foo) = bar let a, b = (raise Exit : int * int) let a, b = (raise Exit : int * int) + +let _ = + fun xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx : _ -> + match () with _ -> () +;; + +fun xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx : _ -> + match () with _ -> () From 2eed680c395648cb71a48f3235be7d6a0c6e61e9 Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Wed, 4 Sep 2024 16:48:37 +0200 Subject: [PATCH 101/146] fix extra indent given to fun in parens --- TODO.md | 12 ------------ lib/Fmt_ast.ml | 2 +- lib/Params.ml | 9 +++++++-- lib/Params.mli | 1 - test/passing/tests/js_source.ml.ref | 14 +++++++------- 5 files changed, 15 insertions(+), 23 deletions(-) diff --git a/TODO.md b/TODO.md index 3b323adea8..4beb978080 100644 --- a/TODO.md +++ b/TODO.md @@ -60,18 +60,6 @@ ;; ``` -```diff - match () with - | _ -> - (fun _ : _ -> -- match () with -- | _ -> ()) -+ (match () with -+ | _ -> ())) - | _ -> () - ;; -``` - ```diff let _ = aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 3dc76b9f9a..7c8d8f882d 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1499,7 +1499,7 @@ and fmt_function ?(last_arg = false) ?force_closing_paren ~ctx ~ctx0 let head = fmt_fun_args_typ args typ in let body = fmt_expression c (sub_exp ~ctx body) in let box, closing_paren_offset = - Params.Exp.box_fun_expr c.conf ~source:c.source ~ctx0 ~ctx ~parens + Params.Exp.box_fun_expr c.conf ~source:c.source ~ctx0 ~ctx ~has_label in let closing_paren_offset = diff --git a/lib/Params.ml b/lib/Params.ml index 96a41b7837..2fef7c94f9 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -45,6 +45,11 @@ let ctx_is_apply_and_exp_is_arg ~ctx ctx0 = args | _ -> None +let ctx_is_apply_and_exp_is_func ~ctx ctx0 = + match (ctx, ctx0) with + | Exp exp, Exp {pexp_desc= Pexp_apply (func, _); _} -> phys_equal func exp + | _ -> false + let ctx_is_apply_and_exp_is_last_arg_and_other_args_are_simple c ~ctx ctx0 = match (ctx, ctx0) with | Exp exp, Exp {pexp_desc= Pexp_apply (_, args); _} -> @@ -154,7 +159,7 @@ module Exp = struct kw_out_of_box $ box_decl (kw_in_box $ hvbox_if should_box_args 0 args $ fmt_opt annot) - let box_fun_expr (c : Conf.t) ~source ~ctx0 ~ctx ~parens ~has_label:_ = + let box_fun_expr (c : Conf.t) ~source ~ctx0 ~ctx ~has_label:_ = let indent = if ctx_is_infix ctx0 then 0 else if Poly.equal c.fmt_opts.function_indent_nested.v `Always then @@ -171,7 +176,7 @@ module Exp = struct else 2 | Some ((Labelled x | Optional x), _, _) -> if begins_line x.loc then 4 else 2 - | None -> if parens then 3 else 2 + | None -> if ctx_is_apply_and_exp_is_func ~ctx ctx0 then 3 else 2 else if ctx_is_apply_and_exp_is_last_arg_and_other_args_are_simple c ~ctx ctx0 diff --git a/lib/Params.mli b/lib/Params.mli index 7e3c94b6c7..e9dcf522f5 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -53,7 +53,6 @@ module Exp : sig -> source:Source.t -> ctx0:Ast.t -> ctx:Ast.t - -> parens:bool -> has_label:bool -> (Fmt.t -> Fmt.t) * int (** return a box with an indent and minus the value of the indent to be used for a closing parenthesis *) diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index 9189aa48ba..38ab7db4cf 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -1330,11 +1330,11 @@ let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = ; sum_cases = [ "Nil", TCnoarg Thd; "Cons", TCarg (Ttl Thd, tcons) ] ; sum_inj = (fun (type c) -> - (function - | Thd, Noarg -> `Nil - | Ttl Thd, v -> `Cons v - : (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist)) - (* One can also write the type annotation directly *) + (function + | Thd, Noarg -> `Nil + | Ttl Thd, v -> `Cons v + : (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist)) + (* One can also write the type annotation directly *) }) ;; @@ -10377,8 +10377,8 @@ let () = match () with | _ -> (fun _ : _ -> - (match () with - | _ -> ())) + (match () with + | _ -> ())) | _ -> () ;; From dbc48ea1c0cb724694319fbbdc3e64c6c3aee92c Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Thu, 5 Sep 2024 10:34:14 +0200 Subject: [PATCH 102/146] ocp: Tweak indent of labelled fun This doesn't entirely solve an issue but makes it slightly smaller. --- lib/Fmt_ast.ml | 15 +++++++++++---- lib/Params.ml | 10 ++++++++-- lib/Params.mli | 4 ++++ test/passing/tests/js_source.ml.err | 2 +- test/passing/tests/js_source.ml.ocp | 3 +-- test/passing/tests/js_source.ml.ref | 5 ++--- 6 files changed, 27 insertions(+), 12 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 7c8d8f882d..83934ecfde 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1474,6 +1474,14 @@ and fmt_function ?(last_arg = false) ?force_closing_paren ~ctx ~ctx0 else (str ":", if has_label then break 1 2 else break 1 0) in let fmt_typ typ = fmt_type_pcstr c ~ctx ~constraint_ctx:`Fun typ in + let arrow_in_head, arrow_in_body = + let arrow = + Params.Exp.break_fun_decl_args ~ctx:ctx0 ~last_arg ~has_label + $ str "->" + in + if c.conf.fmt_opts.ocp_indent_compat.v then (noop, arrow) + else (arrow, noop) + in let fmt_fun_args_typ args typ = let kw = str "fun" @@ -1483,9 +1491,8 @@ and fmt_function ?(last_arg = false) ?force_closing_paren ~ctx ~ctx0 and args = fmt_expr_fun_args c args and annot = Option.map ~f:fmt_typ typ in Params.Exp.box_fun_decl_args ~kw_in_box:(not last_arg) ~ctx:ctx0 c.conf - ~parens ~kw ~args ~annot - $ Params.Exp.break_fun_decl_args ~ctx:ctx0 ~last_arg ~has_label - $ str "->" + ~parens ~kw ~args ~annot ~epi:arrow_in_body + $ arrow_in_head in let lead_with_function_kw = match (args, body) with [], Pfunction_cases _ -> true | _ -> false @@ -1589,7 +1596,7 @@ and fmt_function ?(last_arg = false) ?force_closing_paren ~ctx ~ctx0 ( wrap_intro (hvbox_if has_cmts_outer 0 ( cmts_outer - $ hvbox 2 + $ Params.Exp.box_fun_decl c.conf (fmt_label label label_sep $ cmts_inner $ opn_paren $ head) ) ) $ body $ cls_paren ) diff --git a/lib/Params.ml b/lib/Params.ml index 2fef7c94f9..dc74e16016 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -136,7 +136,8 @@ module Exp = struct $ Fmt.fits_breaks ")" ~hint:(1000, offset_closing_paren) ")" | `No -> wrap (str "(") (str ")") k - let box_fun_decl_args ~ctx ?(kw_in_box = true) c ~parens ~kw ~args ~annot = + let box_fun_decl_args ~ctx ?(kw_in_box = true) ?epi c ~parens ~kw ~args + ~annot = let is_let_func = match ctx with | Ast.Str _ -> @@ -157,7 +158,10 @@ module Exp = struct if kw_in_box then (noop, kw) else (kw, noop) in kw_out_of_box - $ box_decl (kw_in_box $ hvbox_if should_box_args 0 args $ fmt_opt annot) + $ box_decl + ( kw_in_box + $ hvbox_if should_box_args 0 args + $ fmt_opt annot $ fmt_opt epi ) let box_fun_expr (c : Conf.t) ~source ~ctx0 ~ctx ~has_label:_ = let indent = @@ -213,6 +217,8 @@ module Exp = struct match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with | Some (_, _, true) -> List.is_empty args | _ -> false + + let box_fun_decl c k = if ocp c then hvbox 2 k else hvbox 2 k end module Mod = struct diff --git a/lib/Params.mli b/lib/Params.mli index e9dcf522f5..1a4a10e8f9 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -39,6 +39,7 @@ module Exp : sig val box_fun_decl_args : ctx:Ast.t -> ?kw_in_box:bool + -> ?epi:Fmt.t -> Conf.t -> parens:bool -> kw:Fmt.t @@ -65,6 +66,9 @@ module Exp : sig ctx:Ast.t -> last_arg:bool -> has_label:bool -> Fmt.t val single_line_function : ctx:Ast.t -> ctx0:Ast.t -> args:'a list -> bool + + val box_fun_decl : Conf.t -> Fmt.t -> Fmt.t + (** Box a function decl from the label to the arrow. *) end module Mod : sig diff --git a/test/passing/tests/js_source.ml.err b/test/passing/tests/js_source.ml.err index db36e4260e..2f81c60f21 100644 --- a/test/passing/tests/js_source.ml.err +++ b/test/passing/tests/js_source.ml.err @@ -4,4 +4,4 @@ Warning: tests/js_source.ml:9561 exceeds the margin Warning: tests/js_source.ml:9665 exceeds the margin Warning: tests/js_source.ml:9724 exceeds the margin Warning: tests/js_source.ml:9807 exceeds the margin -Warning: tests/js_source.ml:10309 exceeds the margin +Warning: tests/js_source.ml:10308 exceeds the margin diff --git a/test/passing/tests/js_source.ml.ocp b/test/passing/tests/js_source.ml.ocp index da0c0d92d7..79aa6d65b9 100644 --- a/test/passing/tests/js_source.ml.ocp +++ b/test/passing/tests/js_source.ml.ocp @@ -9951,8 +9951,7 @@ let _ = let _ = aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa ~bbbbbbbbbbbbbbbbbbbbbbbbbbbb: - (fun (_ : (ccccccccccccc * ddddddddddddddddddddddddddddd) eeee) - -> FFFFFFFFF gg) + (fun (_ : (ccccccccccccc * ddddddddddddddddddddddddddddd) eeee) -> FFFFFFFFF gg) ~h ;; diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index 38ab7db4cf..6c52152a6f 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -9926,7 +9926,7 @@ let () = very_long_argument_name_one very_long_argument_name_two very_long_argument_name_three - -> ()) + -> ()) ;; let () = @@ -9951,8 +9951,7 @@ let _ = let _ = aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa ~bbbbbbbbbbbbbbbbbbbbbbbbbbbb: - (fun (_ : (ccccccccccccc * ddddddddddddddddddddddddddddd) eeee) - -> FFFFFFFFF gg) + (fun (_ : (ccccccccccccc * ddddddddddddddddddddddddddddd) eeee) -> FFFFFFFFF gg) ~h ;; From 6930d766c838923b9d1d808214a9ad32e382cbe0 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Thu, 5 Sep 2024 14:44:44 +0200 Subject: [PATCH 103/146] ocp: Tweak indentation of labelled fun body --- TODO.md | 12 ------------ lib/Params.ml | 10 ++++++++-- 2 files changed, 8 insertions(+), 14 deletions(-) diff --git a/TODO.md b/TODO.md index 4beb978080..06c4f785fe 100644 --- a/TODO.md +++ b/TODO.md @@ -59,15 +59,3 @@ |> bar ;; ``` - -```diff - let _ = - aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - ~bbbbbbbbbbbbbbbbbbbbbbbbbbbb: -- (fun -- (_ : (ccccccccccccc * ddddddddddddddddddddddddddddd) eeee) -> FFFFFFFFF gg) -+ (fun (_ : (ccccccccccccc * ddddddddddddddddddddddddddddd) eeee) -+ -> FFFFFFFFF gg) - ~h - ;; -``` diff --git a/lib/Params.ml b/lib/Params.ml index dc74e16016..d5c07c54e2 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -178,8 +178,14 @@ module Exp = struct | Some (Nolabel, fun_exp, is_last_arg) -> if begins_line fun_exp.pexp_loc then if is_last_arg then 5 else 3 else 2 - | Some ((Labelled x | Optional x), _, _) -> - if begins_line x.loc then 4 else 2 + | Some ((Labelled x | Optional x), fun_exp, is_last_arg) -> + if begins_line fun_exp.pexp_loc then + (* The [fun] had to break after the label, nested boxes must be + indented less. The last argument is special as the box + structure is different. *) + if is_last_arg then 4 else 2 + else if begins_line x.loc then 4 + else 2 | None -> if ctx_is_apply_and_exp_is_func ~ctx ctx0 then 3 else 2 else if ctx_is_apply_and_exp_is_last_arg_and_other_args_are_simple c ~ctx From 980be25bb4b0e532e9f856e5a8775dbb643627e0 Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Thu, 5 Sep 2024 14:53:54 +0200 Subject: [PATCH 104/146] chases regressions for js profile --- lib-rpc/protocol.ml | 6 ++---- lib/Fmt_ast.ml | 22 +++++++++++++--------- lib/Params.ml | 15 ++++++++++++++- lib/Params.mli | 3 +++ test/passing/tests/attributes.ml | 3 +-- test/passing/tests/js_source.ml.ref | 20 ++++++++++---------- test/passing/tests/source.ml.err | 3 ++- test/passing/tests/source.ml.ref | 13 ++++--------- 8 files changed, 49 insertions(+), 36 deletions(-) diff --git a/lib-rpc/protocol.ml b/lib-rpc/protocol.ml index 69e4259348..5de7b70521 100644 --- a/lib-rpc/protocol.ml +++ b/lib-rpc/protocol.ml @@ -49,8 +49,7 @@ module Make (IO : IO.S) = struct let to_sexp = let open Csexp in function - | `Version v -> List [Atom "Version"; Atom v] - | _ -> assert false + | `Version v -> List [Atom "Version"; Atom v] | _ -> assert false let output oc t = IO.write oc [to_sexp t] end @@ -110,8 +109,7 @@ module Make (IO : IO.S) = struct let csexp_to_config csexpl = List.filter_map (function - | List [Atom name; Atom value] -> Some (name, value) - | _ -> None ) + | List [Atom name; Atom value] -> Some (name, value) | _ -> None ) csexpl in read ic diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 7c8d8f882d..7db47b4788 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1455,6 +1455,13 @@ and fmt_indexop_access c ctx ~fmt_atrs ~has_attr ~parens x = and fmt_function ?(last_arg = false) ?force_closing_paren ~ctx ~ctx0 ~wrap_intro ?box:(should_box = true) ~label ?(parens = false) ?ext ~attrs ~loc c (args, typ, body) = + let should_box = + should_box + || + match (args, typ, body) with + | _ :: _, _, Pfunction_cases _ -> true + | _ -> false + in let has_label = match label with Nolabel -> false | _ -> true in (* Make sure the comment is placed after the eventual label but not into the inner box if no label is present. Side effects of Cmts.fmt c.cmts @@ -1536,13 +1543,7 @@ and fmt_function ?(last_arg = false) ?force_closing_paren ~ctx ~ctx0 $ fmt_attributes ?pre c spilled_attrs $ fmt_attributes ?pre c cs_attrs in - let box_cases = - match ctx0 with - | Exp {pexp_desc= Pexp_ifthenelse _; _} - when Stdlib.(c.conf.fmt_opts.if_then_else.v = `Compact) -> - hvbox ~name:"cases box" 0 - | _ -> Fn.id - in + let box_cases = Params.Exp.box_function_cases c.conf ~ctx ~ctx0 in let box, cases = match cs with | [{pc_lhs; pc_guard= _; pc_rhs}] @@ -1625,7 +1626,7 @@ and fmt_label_arg ?(box = true) ?eol c (lbl, ({ast= arg; _} as xarg)) = $ cmts_after ) | (Labelled _ | Optional _), Pexp_function (args, typ, body) -> let wrap_intro x = hovbox 2 x $ space_break in - fmt_function ~ctx:(Exp arg) ~wrap_intro ~ctx0:xarg.ctx ~label:lbl + fmt_function ~box ~ctx:(Exp arg) ~wrap_intro ~ctx0:xarg.ctx ~label:lbl ~parens:true ~attrs:arg.pexp_attributes ~loc:arg.pexp_loc c (args, typ, body) | _ -> @@ -1644,6 +1645,9 @@ and expression_width c xe = and fmt_args_grouped ?epi:(global_epi = noop) c ctx args = let fmt_arg c ~first:_ ~last (lbl, arg) = let ({ast; _} as xarg) = sub_exp ~ctx arg in + let box = + match ast.pexp_desc with Pexp_function _ -> Some false | _ -> None + in let break_after = match (ast.pexp_desc, c.conf.fmt_opts.break_string_literals.v) with | Pexp_constant _, `Auto when not last -> @@ -1652,7 +1656,7 @@ and fmt_args_grouped ?epi:(global_epi = noop) c ctx args = in hovbox (Params.Indent.fun_args_group c.conf ~lbl ast) - (fmt_label_arg c (lbl, xarg) $ break_after) + (fmt_label_arg c ?box (lbl, xarg) $ break_after) $ fmt_if (not last) (break_unless_newline 1 0) in let fmt_args ~first ~last args = diff --git a/lib/Params.ml b/lib/Params.ml index 2fef7c94f9..85b742d41f 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -213,6 +213,19 @@ module Exp = struct match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with | Some (_, _, true) -> List.is_empty args | _ -> false + + let box_function_cases c ~ctx ~ctx0 = + match ctx0 with + | Exp {pexp_desc= Pexp_ifthenelse _; _} + when Stdlib.(Conf.(c.fmt_opts.if_then_else.v) = `Compact) -> + hvbox ~name:"cases box" 0 + | _ -> + if + ctx_is_apply_and_exp_is_last_arg_and_other_args_are_simple c ~ctx + ctx0 + || ctx_is_let_or_fun ~ctx ctx0 + then Fn.id + else hvbox 0 end module Mod = struct @@ -829,7 +842,7 @@ module Indent = struct if not (ocp c) then 2 else match exp.pexp_desc with - | Pexp_function _ -> 2 + | Pexp_function ([], None, Pfunction_cases _) -> 2 | _ -> ( match lbl with Nolabel -> 3 | _ -> 2 ) let record_docstring (c : Conf.t) = diff --git a/lib/Params.mli b/lib/Params.mli index e9dcf522f5..2774d8e5a9 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -57,6 +57,9 @@ module Exp : sig -> (Fmt.t -> Fmt.t) * int (** return a box with an indent and minus the value of the indent to be used for a closing parenthesis *) + val box_function_cases : + Conf.t -> ctx:Ast.t -> ctx0:Ast.t -> Fmt.t -> Fmt.t + val function_attrs_sp : Conf.t -> ctx0:Ast.t -> ctx:Ast.t -> bool (** Whether a space should be added between the [function] keyword and the attributes. *) diff --git a/test/passing/tests/attributes.ml b/test/passing/tests/attributes.ml index 4a2fec66b0..0027cc3557 100644 --- a/test/passing/tests/attributes.ml +++ b/test/passing/tests/attributes.ml @@ -413,8 +413,7 @@ let[@a (* ....................................... *) (* ....................................... *) "foooooooooooooooooooooooooooo \ - fooooooooooooooooooooooooooooooooooooo"] - | _ -> . ) + fooooooooooooooooooooooooooooooooooooo"] _ -> . ) ~f:(function[@ocaml.warning (* ....................................... *) let x = a and y = b in diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index 38ab7db4cf..1ad33e31ed 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -10065,17 +10065,17 @@ let _ = foo |> List.double_map ~f1:(fun x -> - do_something (); - do_something (); - do_something (); - do_something (); - do_something_else ()) + do_something (); + do_something (); + do_something (); + do_something (); + do_something_else ()) ~f2:(fun x -> - do_something (); - do_something (); - do_something (); - do_something (); - do_something_else ()) + do_something (); + do_something (); + do_something (); + do_something (); + do_something_else ()) |> bar ;; diff --git a/test/passing/tests/source.ml.err b/test/passing/tests/source.ml.err index 171999d3fd..fe96d40db5 100644 --- a/test/passing/tests/source.ml.err +++ b/test/passing/tests/source.ml.err @@ -1,2 +1,3 @@ Warning: tests/source.ml:703 exceeds the margin -Warning: tests/source.ml:2319 exceeds the margin +Warning: tests/source.ml:1394 exceeds the margin +Warning: tests/source.ml:2316 exceeds the margin diff --git a/test/passing/tests/source.ml.ref b/test/passing/tests/source.ml.ref index d6a932ad56..499e0e12a7 100644 --- a/test/passing/tests/source.ml.ref +++ b/test/passing/tests/source.ml.ref @@ -1392,8 +1392,7 @@ let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = Rec (Sum ( (function - | `Nil -> ("Nil", None) - | `Cons p -> ("Cons", Some (Tdyn (targ, p))) ) + | `Nil -> ("Nil", None) | `Cons p -> ("Cons", Some (Tdyn (targ, p))) ) , function | "Nil", None -> `Nil | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p @@ -1445,9 +1444,7 @@ let ty_abc : (([`A of int | `B of string | `C] as 'a), 'e) ty = (int -> string -> noarg -> unit, c) ty_sel * c -> [`A of int | `B of string | `C] = function - | Thd, v -> `A v - | Ttl Thd, v -> `B v - | Ttl (Ttl Thd), Noarg -> `C + | Thd, v -> `A v | Ttl Thd, v -> `B v | Ttl (Ttl Thd), Noarg -> `C end ) type 'a vlist = [`Nil | `Cons of 'a * 'a vlist] @@ -3791,8 +3788,7 @@ class ['a] lexpr_ops (ops : ('a, 'a) #ops Lazy.t) = method subst ~sub = function - | #lambda as x -> lambda#subst ~sub x - | #expr as x -> expr#subst ~sub x + | #lambda as x -> lambda#subst ~sub x | #expr as x -> expr#subst ~sub x method eval = function #lambda as x -> lambda#eval x | #expr as x -> expr#eval x @@ -3997,8 +3993,7 @@ let lexpr_ops (ops : ('a, 'a) #ops Lazy.t) = method subst ~sub = function - | #lambda as x -> lambda#subst ~sub x - | #expr as x -> expr#subst ~sub x + | #lambda as x -> lambda#subst ~sub x | #expr as x -> expr#subst ~sub x method eval = function #lambda as x -> lambda#eval x | #expr as x -> expr#eval x From 22d258e1457e3821e9dc5f30c14b37b4f6925d39 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Thu, 5 Sep 2024 15:03:47 +0200 Subject: [PATCH 105/146] Restore indentation of 'let _ = fun _ -> function' --- TODO.md | 9 -------- lib/Fmt_ast.ml | 6 ++--- lib/Params.ml | 11 +++++++-- test/passing/tests/js_source.ml.err | 12 +++++----- test/passing/tests/js_source.ml.ocp | 36 +++++++++++++++-------------- test/passing/tests/js_source.ml.ref | 6 +++-- test/passing/tests/source.ml.err | 2 +- test/passing/tests/source.ml.ref | 5 ++-- 8 files changed, 45 insertions(+), 42 deletions(-) diff --git a/TODO.md b/TODO.md index 06c4f785fe..e31f0d9bfc 100644 --- a/TODO.md +++ b/TODO.md @@ -20,15 +20,6 @@ foo ``` -```diff --let rec assoc : type a. string -> a rep -> assoc list -> a = -- fun x r -> function -+let rec assoc : type a. string -> a rep -> assoc list -> a = fun x r -> function - | [] -> raise Not_found - | Assoc (x', r', v) :: env -> - if x = x' -``` - ### Janestreet ```diff diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index f30ef9fc75..73d3470183 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -4518,10 +4518,10 @@ and fmt_value_binding c ~rec_flag ?in_ ?epi let fmt_newtypes, fmt_cstr = fmt_value_constraint c lb_typ in let indent, intro_as_pro = match lb_exp.ast.pexp_desc with - | Pexp_function (_, _, Pfunction_cases _) -> + | Pexp_function ([], None, Pfunction_cases _) -> (c.conf.fmt_opts.function_indent.v, true) - | Pexp_function (_, _, Pfunction_body _) - when c.conf.fmt_opts.let_binding_deindent_fun.v -> + | Pexp_function (_, _, _) when c.conf.fmt_opts.let_binding_deindent_fun.v + -> (max (c.conf.fmt_opts.let_binding_indent.v - 1) 0, false) | _ -> (c.conf.fmt_opts.let_binding_indent.v, false) in diff --git a/lib/Params.ml b/lib/Params.ml index f1099c5b06..63058ad1fa 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -236,6 +236,7 @@ module Exp = struct || ctx_is_let_or_fun ~ctx ctx0 then Fn.id else hvbox 0 + let box_fun_decl c k = if ocp c then hvbox 2 k else hvbox 2 k end @@ -846,8 +847,14 @@ module Indent = struct let fun_args c = if ocp c then 6 else 4 - let docked_function_after_fun (_c : Conf.t) ~ctx0 ~parens:_ ~has_label:_ = - if ctx_is_infix ctx0 then 0 else 2 + let docked_function_after_fun (c : Conf.t) ~ctx0 ~parens:_ ~has_label:_ = + match ctx0 with + | Str _ -> + (* Cases must be 2-indented relative to the [let], even when + [let_binding_deindent_fun] is on. *) + if c.fmt_opts.let_binding_deindent_fun.v then 1 else 0 + | _ when ctx_is_infix ctx0 -> 0 + | _ -> 2 let fun_args_group (c : Conf.t) ~lbl exp = if not (ocp c) then 2 diff --git a/test/passing/tests/js_source.ml.err b/test/passing/tests/js_source.ml.err index 2f81c60f21..bf5421b2fa 100644 --- a/test/passing/tests/js_source.ml.err +++ b/test/passing/tests/js_source.ml.err @@ -1,7 +1,7 @@ Warning: tests/js_source.ml:161 exceeds the margin -Warning: tests/js_source.ml:2670 exceeds the margin -Warning: tests/js_source.ml:9561 exceeds the margin -Warning: tests/js_source.ml:9665 exceeds the margin -Warning: tests/js_source.ml:9724 exceeds the margin -Warning: tests/js_source.ml:9807 exceeds the margin -Warning: tests/js_source.ml:10308 exceeds the margin +Warning: tests/js_source.ml:2672 exceeds the margin +Warning: tests/js_source.ml:9563 exceeds the margin +Warning: tests/js_source.ml:9667 exceeds the margin +Warning: tests/js_source.ml:9726 exceeds the margin +Warning: tests/js_source.ml:9809 exceeds the margin +Warning: tests/js_source.ml:10310 exceeds the margin diff --git a/test/passing/tests/js_source.ml.ocp b/test/passing/tests/js_source.ml.ocp index 79aa6d65b9..280c4d3b86 100644 --- a/test/passing/tests/js_source.ml.ocp +++ b/test/passing/tests/js_source.ml.ocp @@ -2018,15 +2018,16 @@ let rec rep_equal : type a b. a rep -> b rep -> (a, b) equal option = type assoc = Assoc : string * 'a rep * 'a -> assoc -let rec assoc : type a. string -> a rep -> assoc list -> a = fun x r -> function - | [] -> raise Not_found - | Assoc (x', r', v) :: env -> - if x = x' - then ( - match rep_equal r r' with - | None -> failwith ("Wrong type for " ^ x) - | Some Eq -> v) - else assoc x r env +let rec assoc : type a. string -> a rep -> assoc list -> a = + fun x r -> function + | [] -> raise Not_found + | Assoc (x', r', v) :: env -> + if x = x' + then ( + match rep_equal r r' with + | None -> failwith ("Wrong type for " ^ x) + | Some Eq -> v) + else assoc x r env ;; type _ term = @@ -2038,14 +2039,15 @@ type _ term = | Ap : ('a -> 'b) term * 'a term -> 'b term | Pair : 'a term * 'b term -> ('a * 'b) term -let rec eval_term : type a. assoc list -> a term -> a = fun env -> function - | Var (x, r) -> assoc x r env - | Abs (x, r, e) -> fun v -> eval_term (Assoc (x, r, v) :: env) e - | Const x -> x - | Add -> fun (x, y) -> x + y - | LT -> fun (x, y) -> x < y - | Ap (f, x) -> eval_term env f (eval_term env x) - | Pair (x, y) -> eval_term env x, eval_term env y +let rec eval_term : type a. assoc list -> a term -> a = + fun env -> function + | Var (x, r) -> assoc x r env + | Abs (x, r, e) -> fun v -> eval_term (Assoc (x, r, v) :: env) e + | Const x -> x + | Add -> fun (x, y) -> x + y + | LT -> fun (x, y) -> x < y + | Ap (f, x) -> eval_term env f (eval_term env x) + | Pair (x, y) -> eval_term env x, eval_term env y ;; let ex3 = Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint)))) diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index bf40333c26..0d3875bb51 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -2018,7 +2018,8 @@ let rec rep_equal : type a b. a rep -> b rep -> (a, b) equal option = type assoc = Assoc : string * 'a rep * 'a -> assoc -let rec assoc : type a. string -> a rep -> assoc list -> a = fun x r -> function +let rec assoc : type a. string -> a rep -> assoc list -> a = + fun x r -> function | [] -> raise Not_found | Assoc (x', r', v) :: env -> if x = x' @@ -2038,7 +2039,8 @@ type _ term = | Ap : ('a -> 'b) term * 'a term -> 'b term | Pair : 'a term * 'b term -> ('a * 'b) term -let rec eval_term : type a. assoc list -> a term -> a = fun env -> function +let rec eval_term : type a. assoc list -> a term -> a = + fun env -> function | Var (x, r) -> assoc x r env | Abs (x, r, e) -> fun v -> eval_term (Assoc (x, r, v) :: env) e | Const x -> x diff --git a/test/passing/tests/source.ml.err b/test/passing/tests/source.ml.err index fe96d40db5..4ad8a5d4dd 100644 --- a/test/passing/tests/source.ml.err +++ b/test/passing/tests/source.ml.err @@ -1,3 +1,3 @@ Warning: tests/source.ml:703 exceeds the margin Warning: tests/source.ml:1394 exceeds the margin -Warning: tests/source.ml:2316 exceeds the margin +Warning: tests/source.ml:2317 exceeds the margin diff --git a/test/passing/tests/source.ml.ref b/test/passing/tests/source.ml.ref index 499e0e12a7..af858fc777 100644 --- a/test/passing/tests/source.ml.ref +++ b/test/passing/tests/source.ml.ref @@ -1974,7 +1974,7 @@ let rec rep_equal : type a b. a rep -> b rep -> (a, b) equal option = type assoc = Assoc : string * 'a rep * 'a -> assoc let rec assoc : type a. string -> a rep -> assoc list -> a = - fun x r -> function + fun x r -> function | [] -> raise Not_found | Assoc (x', r', v) :: env -> if x = x' then @@ -1992,7 +1992,8 @@ type _ term = | Ap : ('a -> 'b) term * 'a term -> 'b term | Pair : 'a term * 'b term -> ('a * 'b) term -let rec eval_term : type a. assoc list -> a term -> a = fun env -> function +let rec eval_term : type a. assoc list -> a term -> a = + fun env -> function | Var (x, r) -> assoc x r env | Abs (x, r, e) -> fun v -> eval_term (Assoc (x, r, v) :: env) e | Const x -> x From e9dc8a7cee80af48a9809faa2867ad4427cfe065 Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Thu, 5 Sep 2024 15:26:14 +0200 Subject: [PATCH 106/146] update js todo --- TODO.md | 105 ++++++++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 79 insertions(+), 26 deletions(-) diff --git a/TODO.md b/TODO.md index e31f0d9bfc..af0764de77 100644 --- a/TODO.md +++ b/TODO.md @@ -23,30 +23,83 @@ ### Janestreet ```diff - foo - |> List.double_map - ~f1:(fun x -> -- do_something (); -- do_something (); -- do_something (); -- do_something (); -- do_something_else ()) -+ do_something (); -+ do_something (); -+ do_something (); -+ do_something (); -+ do_something_else ()) - ~f2:(fun x -> -- do_something (); -- do_something (); -- do_something (); -- do_something (); -- do_something_else ()) -+ do_something (); -+ do_something (); -+ do_something (); -+ do_something (); -+ do_something_else ()) - |> bar - ;; +let eval + (type a) + (type b) + (type c) + (bop : (a, b, c) binop) + (x : a constant) + (y : b constant) + : c constant + = + match bop, x, y with + | Eq, Bool x, Bool y -> Bool (if x then y else not y) + | Leq, Int x, Int y -> Bool (x <= y) + | Leq, Bool x, Bool y -> Bool (x <= y) + | Add, Int x, Int y -> Int (x + y) +;; +``` + +``` +let vexpr (type visit_action) : ('a, 'result, visit_action) context -> 'a -> visit_action + = function + | Local -> fun _ -> raise Exit + | Global -> fun _ -> raise Exit +;; +``` + +``` +let () = + very_long_function_name + ~very_long_argument_label: + (fun + very_long_argument_name_one + very_long_argument_name_two + very_long_argument_name_three + -> ()) +;; +``` + +``` +let _ = + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + ~bbbbbbbbbbbbbbbbbbbbbbbbbbbb: + (fun + (_ : (ccccccccccccc * ddddddddddddddddddddddddddddd) eeee) -> FFFFFFFFF gg) + ~h +;; +``` + +``` +let _ = + let x = x in + fun foooooooooooooooooo + foooooooooooooooooo + foooooooooooooooooo + foooooooooooooooooo + foooooooooooooooooo + foooooooooooooooooo -> + () +;; +``` + +``` +let _ = + Some + (fun fooooooooooooooooooooooooooooooo + fooooooooooooooooooooooooooooooo + fooooooooooooooooooooooooooooooo -> + foo) +;; +``` + ``` +let () = + match () with + | _ -> + (fun _ : _ -> + match () with + | _ -> ()) + | _ -> () +;; +``` \ No newline at end of file From 0db3cb9cdad596007a4ec4a8c39e344d232d966c Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Thu, 5 Sep 2024 15:31:22 +0200 Subject: [PATCH 107/146] Update TODO.md for the ocamlformat profile --- TODO.md | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/TODO.md b/TODO.md index af0764de77..a3f7b4b413 100644 --- a/TODO.md +++ b/TODO.md @@ -20,6 +20,21 @@ foo ``` +```diff +let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = + fun t -> + let targ = Pair (Pop t, Var) in + Rec + (Sum + ( (function + | `Nil -> ("Nil", None) | `Cons p -> ("Cons", Some (Tdyn (targ, p))) + ) + , function + | "Nil", None -> `Nil + | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p + ) ) +``` + ### Janestreet ```diff @@ -102,4 +117,4 @@ let () = | _ -> ()) | _ -> () ;; -``` \ No newline at end of file +``` From ee55c7c3c088d78de8b8e65ccd95b8af1f557014 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Thu, 5 Sep 2024 15:49:32 +0200 Subject: [PATCH 108/146] Update source-conventional.ml.ref --- test/passing/tests/source-conventional.ml.err | 6 ++-- test/passing/tests/source-conventional.ml.ref | 34 +++++++++---------- 2 files changed, 19 insertions(+), 21 deletions(-) diff --git a/test/passing/tests/source-conventional.ml.err b/test/passing/tests/source-conventional.ml.err index 4dc692a474..0b8847ab9c 100644 --- a/test/passing/tests/source-conventional.ml.err +++ b/test/passing/tests/source-conventional.ml.err @@ -1,6 +1,6 @@ Warning: tests/source.ml:927 exceeds the margin Warning: tests/source.ml:1002 exceeds the margin Warning: tests/source.ml:1225 exceeds the margin -Warning: tests/source.ml:1342 exceeds the margin -Warning: tests/source.ml:6617 exceeds the margin -Warning: tests/source.ml:7075 exceeds the margin +Warning: tests/source.ml:1340 exceeds the margin +Warning: tests/source.ml:6615 exceeds the margin +Warning: tests/source.ml:7073 exceeds the margin diff --git a/test/passing/tests/source-conventional.ml.ref b/test/passing/tests/source-conventional.ml.ref index e0885dd89d..5c6bfdbcf9 100644 --- a/test/passing/tests/source-conventional.ml.ref +++ b/test/passing/tests/source-conventional.ml.ref @@ -1226,12 +1226,10 @@ let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = | `Nil -> ("Nil", None) | `Cons p -> ("Cons", Some (Tdyn (tcons, p)))); sum_cases = [ ("Nil", TCnoarg Thd); ("Cons", TCarg (Ttl Thd, tcons)) ]; sum_inj = - (fun (type c) : - ((noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist) -> - function - | Thd, Noarg -> `Nil - | Ttl Thd, v -> `Cons v) - (* One can also write the type annotation directly *); + (fun (type c) -> + (function Thd, Noarg -> `Nil | Ttl Thd, v -> `Cons v + : (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist)) + (* One can also write the type annotation directly *); }) let v = variantize Enil (ty_list Int) (`Cons (1, `Cons (2, `Nil))) @@ -2714,7 +2712,7 @@ let magic : 'a 'b. 'a -> 'b = type (_, +_) eq = Refl : ('a, 'a) eq let magic : 'a 'b. 'a -> 'b = - fun (type a b) (x : a) -> + fun (type a) (type b) (x : a) -> let bad_proof (type a) = (Refl : (< m : a >, < m : a >) eq :> (< m : a >, < >) eq) in @@ -3845,12 +3843,12 @@ let int_of_sexp _ = 42 let t_of_sexp : 'a. (sexp -> 'a) -> sexp -> 'a t = let _tp_loc = "core_array.ml.t" in - fun _of_a t -> (array_of_sexp _of_a) t + fun _of_a -> fun t -> (array_of_sexp _of_a) t let _ = t_of_sexp let sexp_of_t : 'a. ('a -> sexp) -> 'a t -> sexp = - fun _of_a v -> (sexp_of_array _of_a) v + fun _of_a -> fun v -> (sexp_of_array _of_a) v let _ = sexp_of_t @@ -3898,13 +3896,13 @@ end = struct let t_of_sexp : 'a 'perms. (sexp -> 'a) -> (sexp -> 'perms) -> sexp -> ('a, 'perms) t = let _tp_loc = "core_array.ml.Permissioned.t" in - fun _of_a _of_perms t -> (array_of_sexp _of_a) t + fun _of_a -> fun _of_perms -> fun t -> (array_of_sexp _of_a) t let _ = t_of_sexp let sexp_of_t : 'a 'perms. ('a -> sexp) -> ('perms -> sexp) -> ('a, 'perms) t -> sexp = - fun _of_a _of_perms v -> (sexp_of_array _of_a) v + fun _of_a -> fun _of_perms -> fun v -> (sexp_of_array _of_a) v let _ = sexp_of_t @@ -3917,12 +3915,12 @@ end = struct let t_of_sexp : 'perms. (sexp -> 'perms) -> sexp -> 'perms t = let _tp_loc = "core_array.ml.Permissioned.Int.t" in - fun _of_perms t -> t__of_sexp t + fun _of_perms -> fun t -> t__of_sexp t let _ = t_of_sexp let sexp_of_t : 'perms. ('perms -> sexp) -> 'perms t -> sexp = - fun _of_perms v -> sexp_of_t_ v + fun _of_perms -> fun v -> sexp_of_t_ v let _ = sexp_of_t end @@ -6184,7 +6182,7 @@ end = M1 ;; -fun (x : M1.t) : M2.t -> x +fun (x : M1.t) -> (x : M2.t) (* fails *) @@ -8551,8 +8549,8 @@ class ['a] c () = let f : type a'. a' = assert false let foo : type a' b'. a' -> b' = fun a -> assert false -let foo : type t'. t' = fun (type t') : t' -> assert false -let foo : 't. 't = fun (type t) : t -> assert false +let foo : type t'. t' = fun (type t') -> (assert false : t') +let foo : 't. 't = fun (type t) -> (assert false : t) let foo : type a' b' c' t. a' -> b' -> c' -> t = fun a b c -> assert false let f x = @@ -8654,7 +8652,7 @@ let formula_base x = #&& (x #<= (Expr.int 4)) #&& ((Expr.int 0) #< x) -let _ = call ~f:(fun pair : (a * b) -> pair);; +let _ = call ~f:(fun pair -> (pair : a * b));; f (fun _ -> function @@ -8681,7 +8679,7 @@ let xxxxxx = in { zzzzzzzzzzzzz } -let _ = fun (x : int as 'a) : (int as 'a) -> x +let _ = fun (x : int as 'a) -> (x : int as 'a) let eradicate_meta_class_is_nullsafe = register ~id:"ERADICATE_META_CLASS_IS_NULLSAFE" From 9fe2727516955a3fb02d8ec2c4dfb3e5074b8b23 Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Fri, 6 Sep 2024 14:52:02 +0200 Subject: [PATCH 109/146] fix break before arrow js --- TODO.md | 20 +++++--------------- lib/Fmt_ast.ml | 8 ++++---- lib/Params.ml | 6 ++++-- lib/Params.mli | 2 +- test/passing/tests/js_source.ml.err | 2 +- test/passing/tests/js_source.ml.ocp | 12 ++++-------- test/passing/tests/js_source.ml.ref | 14 +++++--------- 7 files changed, 24 insertions(+), 40 deletions(-) diff --git a/TODO.md b/TODO.md index af0764de77..6a518457a2 100644 --- a/TODO.md +++ b/TODO.md @@ -40,7 +40,7 @@ let eval ;; ``` -``` +```ocaml let vexpr (type visit_action) : ('a, 'result, visit_action) context -> 'a -> visit_action = function | Local -> fun _ -> raise Exit @@ -48,7 +48,7 @@ let vexpr (type visit_action) : ('a, 'result, visit_action) context -> 'a -> vis ;; ``` -``` +```ocaml let () = very_long_function_name ~very_long_argument_label: @@ -60,7 +60,7 @@ let () = ;; ``` -``` +```ocaml let _ = aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa ~bbbbbbbbbbbbbbbbbbbbbbbbbbbb: @@ -70,7 +70,7 @@ let _ = ;; ``` -``` +```ocaml let _ = let x = x in fun foooooooooooooooooo @@ -83,17 +83,7 @@ let _ = ;; ``` -``` -let _ = - Some - (fun fooooooooooooooooooooooooooooooo - fooooooooooooooooooooooooooooooo - fooooooooooooooooooooooooooooooo -> - foo) -;; -``` - -``` +```ocaml let () = match () with | _ -> diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 73d3470183..ddbfe180df 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1477,13 +1477,13 @@ and fmt_function ?(last_arg = false) ?force_closing_paren ~ctx ~ctx0 If a label is present, arguments should be indented more than the arrow and the eventually breaking [fun] keyword. *) if c.conf.fmt_opts.ocp_indent_compat.v then - (str ":" $ cut_break, break 1 2) - else (str ":", if has_label then break 1 2 else break 1 0) + (str ":" $ cut_break, if last_arg then break 1 2 else str " ") + else (str ":", if last_arg && has_label then break 1 2 else break 1 0) in let fmt_typ typ = fmt_type_pcstr c ~ctx ~constraint_ctx:`Fun typ in let arrow_in_head, arrow_in_body = let arrow = - Params.Exp.break_fun_decl_args ~ctx:ctx0 ~last_arg ~has_label + Params.Exp.break_fun_decl_args c.conf ~ctx:ctx0 ~last_arg ~has_label $ str "->" in if c.conf.fmt_opts.ocp_indent_compat.v then (noop, arrow) @@ -1494,7 +1494,7 @@ and fmt_function ?(last_arg = false) ?force_closing_paren ~ctx ~ctx0 str "fun" $ fmt_extension_suffix c ext $ fmt_attributes c ~pre:Blank attrs - $ if last_arg then break_fun else break 1 0 + $ break_fun and args = fmt_expr_fun_args c args and annot = Option.map ~f:fmt_typ typ in Params.Exp.box_fun_decl_args ~kw_in_box:(not last_arg) ~ctx:ctx0 c.conf diff --git a/lib/Params.ml b/lib/Params.ml index 63058ad1fa..986b70f9bf 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -212,12 +212,14 @@ module Exp = struct && List.for_all ~f:arg_is_simple_approx other_args ) | _ -> false - let break_fun_decl_args ~ctx ~last_arg ~has_label = + let break_fun_decl_args c ~ctx ~last_arg ~has_label = match ctx with + | _ when not last_arg && ocp c -> str " " | Ast.Str _ -> (* special case that break the arrow in [let _ = fun ... ->] *) str " " - | _ -> break 1 (if last_arg && has_label then 0 else -2) + | _ -> + break 1 (if last_arg && has_label && not (ocp c) then 0 else -2) let single_line_function ~ctx ~ctx0 ~args = match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with diff --git a/lib/Params.mli b/lib/Params.mli index 71e819e69e..df2e30ec9a 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -66,7 +66,7 @@ module Exp : sig attributes. *) val break_fun_decl_args : - ctx:Ast.t -> last_arg:bool -> has_label:bool -> Fmt.t + Conf.t -> ctx:Ast.t -> last_arg:bool -> has_label:bool -> Fmt.t val single_line_function : ctx:Ast.t -> ctx0:Ast.t -> args:'a list -> bool diff --git a/test/passing/tests/js_source.ml.err b/test/passing/tests/js_source.ml.err index bf5421b2fa..71f6981171 100644 --- a/test/passing/tests/js_source.ml.err +++ b/test/passing/tests/js_source.ml.err @@ -4,4 +4,4 @@ Warning: tests/js_source.ml:9563 exceeds the margin Warning: tests/js_source.ml:9667 exceeds the margin Warning: tests/js_source.ml:9726 exceeds the margin Warning: tests/js_source.ml:9809 exceeds the margin -Warning: tests/js_source.ml:10310 exceeds the margin +Warning: tests/js_source.ml:10306 exceeds the margin diff --git a/test/passing/tests/js_source.ml.ocp b/test/passing/tests/js_source.ml.ocp index 280c4d3b86..06149f2330 100644 --- a/test/passing/tests/js_source.ml.ocp +++ b/test/passing/tests/js_source.ml.ocp @@ -10228,14 +10228,12 @@ let _ = let _ = let x = x in - fun + fun foooooooooooooooooo foooooooooooooooooo foooooooooooooooooo foooooooooooooooooo foooooooooooooooooo - foooooooooooooooooo - foooooooooooooooooo - -> () + foooooooooooooooooo -> () ;; module type For_let_syntax_local = @@ -10289,11 +10287,9 @@ module M = let _ = Some - (fun - fooooooooooooooooooooooooooooooo - fooooooooooooooooooooooooooooooo + (fun fooooooooooooooooooooooooooooooo fooooooooooooooooooooooooooooooo - -> foo) + fooooooooooooooooooooooooooooooo -> foo) ;; type t = diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index 0d3875bb51..30eeb91f97 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -9928,7 +9928,7 @@ let () = very_long_argument_name_one very_long_argument_name_two very_long_argument_name_three - -> ()) + -> ()) ;; let () = @@ -10228,14 +10228,12 @@ let _ = let _ = let x = x in - fun + fun foooooooooooooooooo foooooooooooooooooo foooooooooooooooooo foooooooooooooooooo foooooooooooooooooo - foooooooooooooooooo - foooooooooooooooooo - -> () + foooooooooooooooooo -> () ;; module type For_let_syntax_local = @@ -10289,11 +10287,9 @@ module M = let _ = Some - (fun - fooooooooooooooooooooooooooooooo - fooooooooooooooooooooooooooooooo + (fun fooooooooooooooooooooooooooooooo fooooooooooooooooooooooooooooooo - -> foo) + fooooooooooooooooooooooooooooooo -> foo) ;; type t = From e9cf89a06b31cf8cb064c1831d8e28b2288bdde2 Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Fri, 6 Sep 2024 15:43:50 +0200 Subject: [PATCH 110/146] fmt --- lib/Params.ml | 5 ++--- lib/Params.mli | 2 +- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/lib/Params.ml b/lib/Params.ml index 986b70f9bf..b1e49ba364 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -214,12 +214,11 @@ module Exp = struct let break_fun_decl_args c ~ctx ~last_arg ~has_label = match ctx with - | _ when not last_arg && ocp c -> str " " + | _ when (not last_arg) && ocp c -> str " " | Ast.Str _ -> (* special case that break the arrow in [let _ = fun ... ->] *) str " " - | _ -> - break 1 (if last_arg && has_label && not (ocp c) then 0 else -2) + | _ -> break 1 (if last_arg && has_label && not (ocp c) then 0 else -2) let single_line_function ~ctx ~ctx0 ~args = match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with diff --git a/lib/Params.mli b/lib/Params.mli index df2e30ec9a..867eda78b7 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -66,7 +66,7 @@ module Exp : sig attributes. *) val break_fun_decl_args : - Conf.t -> ctx:Ast.t -> last_arg:bool -> has_label:bool -> Fmt.t + Conf.t -> ctx:Ast.t -> last_arg:bool -> has_label:bool -> Fmt.t val single_line_function : ctx:Ast.t -> ctx0:Ast.t -> args:'a list -> bool From fbcf842b6f4897dc03caf66fbe8b8ffa089c8968 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Tue, 10 Sep 2024 11:04:23 +0200 Subject: [PATCH 111/146] ocp: Tweak breaking of 'let _ = function' --- TODO.md | 26 -------------------------- lib/Fmt_ast.ml | 15 +++++++++------ test/passing/tests/js_source.ml.err | 1 - test/passing/tests/js_source.ml.ocp | 16 ++++++++-------- test/passing/tests/js_source.ml.ref | 8 ++++---- 5 files changed, 21 insertions(+), 45 deletions(-) diff --git a/TODO.md b/TODO.md index b3657c2b34..7fc3230643 100644 --- a/TODO.md +++ b/TODO.md @@ -37,32 +37,6 @@ let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = ### Janestreet -```diff -let eval - (type a) - (type b) - (type c) - (bop : (a, b, c) binop) - (x : a constant) - (y : b constant) - : c constant - = - match bop, x, y with - | Eq, Bool x, Bool y -> Bool (if x then y else not y) - | Leq, Int x, Int y -> Bool (x <= y) - | Leq, Bool x, Bool y -> Bool (x <= y) - | Add, Int x, Int y -> Int (x + y) -;; -``` - -```ocaml -let vexpr (type visit_action) : ('a, 'result, visit_action) context -> 'a -> visit_action - = function - | Local -> fun _ -> raise Exit - | Global -> fun _ -> raise Exit -;; -``` - ```ocaml let () = very_long_function_name diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index ddbfe180df..c1fdbe487d 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -4569,12 +4569,15 @@ and fmt_value_binding c ~rec_flag ?in_ ?epi if lb_pun then decl else let pro = - hovbox 2 - ( decl - $ fmt_or c.conf.fmt_opts.ocp_indent_compat.v - (fits_breaks " =" ~hint:(1000, 0) "=") - (break 1 2 $ str "=") ) - $ space_break + if c.conf.fmt_opts.ocp_indent_compat.v then + let box = + match lb_exp.ast.pexp_desc with + | Pexp_function ([], None, Pfunction_cases _) -> false + | _ -> true + in + hvbox_if box 2 (decl $ fits_breaks " =" ~hint:(1000, 0) "=") + $ space_break + else hovbox 2 (decl $ break 1 2 $ str "=") $ space_break in if intro_as_pro then fmt_expression c ~pro ~box:false lb_exp else pro $ fmt_expression c lb_exp diff --git a/test/passing/tests/js_source.ml.err b/test/passing/tests/js_source.ml.err index 71f6981171..06809dd778 100644 --- a/test/passing/tests/js_source.ml.err +++ b/test/passing/tests/js_source.ml.err @@ -1,5 +1,4 @@ Warning: tests/js_source.ml:161 exceeds the margin -Warning: tests/js_source.ml:2672 exceeds the margin Warning: tests/js_source.ml:9563 exceeds the margin Warning: tests/js_source.ml:9667 exceeds the margin Warning: tests/js_source.ml:9726 exceeds the margin diff --git a/test/passing/tests/js_source.ml.ocp b/test/passing/tests/js_source.ml.ocp index 06149f2330..4d54fc48fb 100644 --- a/test/passing/tests/js_source.ml.ocp +++ b/test/passing/tests/js_source.ml.ocp @@ -2664,16 +2664,16 @@ type ('a, 'result, 'visit_action) context = | Local : ('a, ('a * insert as 'result), 'a local_visit_action) context | Global : ('a, 'a, 'a visit_action) context -let vexpr (type visit_action) : (_, _, visit_action) context -> _ -> visit_action = - function - | Local -> fun _ -> raise Exit - | Global -> fun _ -> raise Exit +let vexpr (type visit_action) : (_, _, visit_action) context -> _ -> visit_action + = function + | Local -> fun _ -> raise Exit + | Global -> fun _ -> raise Exit ;; -let vexpr (type visit_action) : ('a, 'result, visit_action) context -> 'a -> visit_action = - function - | Local -> fun _ -> raise Exit - | Global -> fun _ -> raise Exit +let vexpr (type visit_action) : ('a, 'result, visit_action) context -> 'a -> visit_action + = function + | Local -> fun _ -> raise Exit + | Global -> fun _ -> raise Exit ;; let vexpr (type result) (type visit_action) diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index 30eeb91f97..d31b5e5a46 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -2664,14 +2664,14 @@ type ('a, 'result, 'visit_action) context = | Local : ('a, ('a * insert as 'result), 'a local_visit_action) context | Global : ('a, 'a, 'a visit_action) context -let vexpr (type visit_action) : (_, _, visit_action) context -> _ -> visit_action = - function +let vexpr (type visit_action) : (_, _, visit_action) context -> _ -> visit_action + = function | Local -> fun _ -> raise Exit | Global -> fun _ -> raise Exit ;; -let vexpr (type visit_action) : ('a, 'result, visit_action) context -> 'a -> visit_action = - function +let vexpr (type visit_action) : ('a, 'result, visit_action) context -> 'a -> visit_action + = function | Local -> fun _ -> raise Exit | Global -> fun _ -> raise Exit ;; From 29663ca9736a9966f0eea9a3adc57da9ad60d07f Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Tue, 10 Sep 2024 14:42:21 +0200 Subject: [PATCH 112/146] Safety rule for 'fun _ -> (function ...)' No related bugs have been found but this rule is better explicit. --- lib/Ast.ml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/lib/Ast.ml b/lib/Ast.ml index 0443eed590..1c2ad44751 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -2259,6 +2259,10 @@ end = struct , {pexp_desc= Pexp_construct _ | Pexp_cons _; _} ) when e == exp -> true + | ( Exp {pexp_desc= Pexp_function (_, _, Pfunction_body e); _} + , {pexp_desc= Pexp_function (_, _, Pfunction_cases _); _} ) + when e == exp -> + true | Exp {pexp_desc; _}, _ -> ( match pexp_desc with | Pexp_extension From ef6cad542f159eb773e710e7a265f038c9c9c506 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Tue, 10 Sep 2024 14:51:24 +0200 Subject: [PATCH 113/146] The 'match -> (fun -> (match' diff is not a problem It's probably due to the change in AST representation for the type annotation. --- TODO.md | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/TODO.md b/TODO.md index 7fc3230643..9ae62676e6 100644 --- a/TODO.md +++ b/TODO.md @@ -71,14 +71,3 @@ let _ = () ;; ``` - -```ocaml -let () = - match () with - | _ -> - (fun _ : _ -> - match () with - | _ -> ()) - | _ -> () -;; -``` From 3fcfc06eab3df78bcf52b7d81d388e250d9b6ae9 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Wed, 11 Sep 2024 18:14:00 +0200 Subject: [PATCH 114/146] ocp: Tweak break after 'fun ->' depending on context --- TODO.md | 13 ------------- lib/Fmt_ast.ml | 2 +- lib/Params.ml | 11 +++++++++-- lib/Params.mli | 1 + test/passing/tests/js_source.ml.err | 2 +- test/passing/tests/js_source.ml.ocp | 3 ++- test/passing/tests/js_source.ml.ref | 3 ++- 7 files changed, 16 insertions(+), 19 deletions(-) diff --git a/TODO.md b/TODO.md index 9ae62676e6..8e3f1b04db 100644 --- a/TODO.md +++ b/TODO.md @@ -58,16 +58,3 @@ let _ = ~h ;; ``` - -```ocaml -let _ = - let x = x in - fun foooooooooooooooooo - foooooooooooooooooo - foooooooooooooooooo - foooooooooooooooooo - foooooooooooooooooo - foooooooooooooooooo -> - () -;; -``` diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index c1fdbe487d..3c46793152 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1514,7 +1514,7 @@ and fmt_function ?(last_arg = false) ?force_closing_paren ~ctx ~ctx0 let body = fmt_expression c (sub_exp ~ctx body) in let box, closing_paren_offset = Params.Exp.box_fun_expr c.conf ~source:c.source ~ctx0 ~ctx - ~has_label + ~has_label ~parens in let closing_paren_offset = if should_box then closing_paren_offset else ~-2 diff --git a/lib/Params.ml b/lib/Params.ml index b1e49ba364..1570202766 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -163,7 +163,7 @@ module Exp = struct $ hvbox_if should_box_args 0 args $ fmt_opt annot $ fmt_opt epi ) - let box_fun_expr (c : Conf.t) ~source ~ctx0 ~ctx ~has_label:_ = + let box_fun_expr (c : Conf.t) ~source ~ctx0 ~ctx ~has_label:_ ~parens = let indent = if ctx_is_infix ctx0 then 0 else if Poly.equal c.fmt_opts.function_indent_nested.v `Always then @@ -194,7 +194,14 @@ module Exp = struct else 2 in let name = "Params.box_fun_expr" in - let mkbox = match ctx0 with Str _ -> hvbox | _ -> hovbox in + let mkbox = + match ctx0 with + | Str _ -> hvbox + | _ -> + (* JS: The body of a [fun] must break if the intro is too large, + except if the [fun] is small and parenthesed. *) + if ocp c && not parens then hvbox else hovbox + in (mkbox ~name indent, ~-indent) (* if the function is the last argument of an apply and no other arguments diff --git a/lib/Params.mli b/lib/Params.mli index 867eda78b7..f4f5b33002 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -55,6 +55,7 @@ module Exp : sig -> ctx0:Ast.t -> ctx:Ast.t -> has_label:bool + -> parens:bool -> (Fmt.t -> Fmt.t) * int (** return a box with an indent and minus the value of the indent to be used for a closing parenthesis *) diff --git a/test/passing/tests/js_source.ml.err b/test/passing/tests/js_source.ml.err index 06809dd778..e6e62ccb92 100644 --- a/test/passing/tests/js_source.ml.err +++ b/test/passing/tests/js_source.ml.err @@ -3,4 +3,4 @@ Warning: tests/js_source.ml:9563 exceeds the margin Warning: tests/js_source.ml:9667 exceeds the margin Warning: tests/js_source.ml:9726 exceeds the margin Warning: tests/js_source.ml:9809 exceeds the margin -Warning: tests/js_source.ml:10306 exceeds the margin +Warning: tests/js_source.ml:10307 exceeds the margin diff --git a/test/passing/tests/js_source.ml.ocp b/test/passing/tests/js_source.ml.ocp index 4d54fc48fb..f85857c963 100644 --- a/test/passing/tests/js_source.ml.ocp +++ b/test/passing/tests/js_source.ml.ocp @@ -10233,7 +10233,8 @@ let _ = foooooooooooooooooo foooooooooooooooooo foooooooooooooooooo - foooooooooooooooooo -> () + foooooooooooooooooo -> + () ;; module type For_let_syntax_local = diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index d31b5e5a46..6647ed4499 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -10233,7 +10233,8 @@ let _ = foooooooooooooooooo foooooooooooooooooo foooooooooooooooooo - foooooooooooooooooo -> () + foooooooooooooooooo -> + () ;; module type For_let_syntax_local = From 68a1a0c01a918458119d2daf73299fbba189dff7 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Thu, 12 Sep 2024 14:38:57 +0200 Subject: [PATCH 115/146] Update TODO.md --- TODO.md | 12 ------------ 1 file changed, 12 deletions(-) diff --git a/TODO.md b/TODO.md index 8e3f1b04db..96a16126dd 100644 --- a/TODO.md +++ b/TODO.md @@ -37,18 +37,6 @@ let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = ### Janestreet -```ocaml -let () = - very_long_function_name - ~very_long_argument_label: - (fun - very_long_argument_name_one - very_long_argument_name_two - very_long_argument_name_three - -> ()) -;; -``` - ```ocaml let _ = aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa From 17aa326a632ea6d74bc1c305b2d9a7c40c875290 Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Thu, 12 Sep 2024 16:47:37 +0200 Subject: [PATCH 116/146] fix js labelled arg fun formating --- lib/Fmt_ast.ml | 9 +++++---- lib/Params.ml | 24 +++++++++++++++++++++--- lib/Params.mli | 7 +++++++ test/passing/tests/js_source.ml.err | 2 +- test/passing/tests/js_source.ml.ocp | 3 ++- test/passing/tests/js_source.ml.ref | 3 ++- 6 files changed, 38 insertions(+), 10 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 3c46793152..c0e4159f5e 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1472,13 +1472,14 @@ and fmt_function ?(last_arg = false) ?force_closing_paren ~ctx ~ctx0 let cmts = Cmts.fmt_before ?eol c loc in if has_label then (false, noop, cmts) else (has_cmts, cmts, noop) in - let (label_sep : t), break_fun = + let break_fun = Params.Exp.break_fun_kw c.conf ~ctx ~ctx0 ~last_arg ~has_label in + let (label_sep : t) = (* Break between the label and the fun to avoid ocp-indent's alignment. If a label is present, arguments should be indented more than the arrow and the eventually breaking [fun] keyword. *) if c.conf.fmt_opts.ocp_indent_compat.v then - (str ":" $ cut_break, if last_arg then break 1 2 else str " ") - else (str ":", if last_arg && has_label then break 1 2 else break 1 0) + (str ":" $ cut_break) + else (str ":") in let fmt_typ typ = fmt_type_pcstr c ~ctx ~constraint_ctx:`Fun typ in let arrow_in_head, arrow_in_body = @@ -1497,7 +1498,7 @@ and fmt_function ?(last_arg = false) ?force_closing_paren ~ctx ~ctx0 $ break_fun and args = fmt_expr_fun_args c args and annot = Option.map ~f:fmt_typ typ in - Params.Exp.box_fun_decl_args ~kw_in_box:(not last_arg) ~ctx:ctx0 c.conf + Params.Exp.box_fun_decl_args ~kw_in_box:(not last_arg) ~ctx ~ctx0 c.conf ~parens ~kw ~args ~annot ~epi:arrow_in_body $ arrow_in_head in diff --git a/lib/Params.ml b/lib/Params.ml index 1570202766..0a2d1c2039 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -136,18 +136,36 @@ module Exp = struct $ Fmt.fits_breaks ")" ~hint:(1000, offset_closing_paren) ")" | `No -> wrap (str "(") (str ")") k - let box_fun_decl_args ~ctx ?(kw_in_box = true) ?epi c ~parens ~kw ~args +let break_fun_kw c ~ctx ~ctx0 ~last_arg ~has_label = + let is_labelled_arg = + match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with + | Some (( (Labelled _) | (Optional _) ), _, _ ) -> + true + | _ -> false + in + if Conf.(c.fmt_opts.ocp_indent_compat.v) then + ( if last_arg || is_labelled_arg then break 1 2 else str " ") + else ( if last_arg && has_label then break 1 2 else break 1 0) + + let box_fun_decl_args ~ctx ~ctx0 ?(kw_in_box = true) ?epi c ~parens ~kw ~args ~annot = let is_let_func = - match ctx with + match ctx0 with | Ast.Str _ -> (* special case than aligns the arguments of [let _ = fun ...] *) true | _ -> false in + let is_labelled_arg = + match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with + | Some (( (Labelled _) | (Optional _) ), _, _ ) -> + true + | _ -> false + in let name = "Params.box_fun_decl_args" in let box_decl, should_box_args = - if ocp c then (hvbox ~name (if parens then 1 else 2), false) + if ocp c then ( + if is_labelled_arg then Fn.id, false else hvbox ~name (if parens then 1 else 2), false) else ( ( if is_let_func then hovbox ~name 4 else hvbox ~name (if parens then 1 else 2) ) diff --git a/lib/Params.mli b/lib/Params.mli index f4f5b33002..086b87f38f 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -38,6 +38,7 @@ module Exp : sig val box_fun_decl_args : ctx:Ast.t + -> ctx0:Ast.t -> ?kw_in_box:bool -> ?epi:Fmt.t -> Conf.t @@ -49,6 +50,12 @@ module Exp : sig (** Box and assemble the parts [kw] (up to the arguments), [args] and [annot]. *) + val break_fun_kw : Conf_t.t -> + ctx:Ast.t -> + ctx0: Ast.t -> + last_arg:bool -> + has_label:bool -> + Fmt.t val box_fun_expr : Conf.t -> source:Source.t diff --git a/test/passing/tests/js_source.ml.err b/test/passing/tests/js_source.ml.err index e6e62ccb92..c22587505a 100644 --- a/test/passing/tests/js_source.ml.err +++ b/test/passing/tests/js_source.ml.err @@ -3,4 +3,4 @@ Warning: tests/js_source.ml:9563 exceeds the margin Warning: tests/js_source.ml:9667 exceeds the margin Warning: tests/js_source.ml:9726 exceeds the margin Warning: tests/js_source.ml:9809 exceeds the margin -Warning: tests/js_source.ml:10307 exceeds the margin +Warning: tests/js_source.ml:10308 exceeds the margin diff --git a/test/passing/tests/js_source.ml.ocp b/test/passing/tests/js_source.ml.ocp index f85857c963..800b870ede 100644 --- a/test/passing/tests/js_source.ml.ocp +++ b/test/passing/tests/js_source.ml.ocp @@ -9953,7 +9953,8 @@ let _ = let _ = aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa ~bbbbbbbbbbbbbbbbbbbbbbbbbbbb: - (fun (_ : (ccccccccccccc * ddddddddddddddddddddddddddddd) eeee) -> FFFFFFFFF gg) + (fun + (_ : (ccccccccccccc * ddddddddddddddddddddddddddddd) eeee) -> FFFFFFFFF gg) ~h ;; diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index 6647ed4499..e6f089312f 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -9953,7 +9953,8 @@ let _ = let _ = aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa ~bbbbbbbbbbbbbbbbbbbbbbbbbbbb: - (fun (_ : (ccccccccccccc * ddddddddddddddddddddddddddddd) eeee) -> FFFFFFFFF gg) + (fun + (_ : (ccccccccccccc * ddddddddddddddddddddddddddddd) eeee) -> FFFFFFFFF gg) ~h ;; From 9d324fafa747d213d3918dbaff6d5dc969fd5896 Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Fri, 13 Sep 2024 12:22:55 +0200 Subject: [PATCH 117/146] fix js `fun a : t` --- lib/Fmt_ast.ml | 34 +++++++++++++++++++---------- lib/Params.ml | 32 +++++++++++++-------------- lib/Params.mli | 16 ++++++++------ test/passing/tests/js_source.ml.err | 10 ++++----- test/passing/tests/js_source.ml.ocp | 3 ++- test/passing/tests/js_source.ml.ref | 3 ++- 6 files changed, 57 insertions(+), 41 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index c0e4159f5e..8a00b8affb 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -407,10 +407,10 @@ let virtual_or_override = function | Cfk_concrete (Fresh, _, _) -> noop (** Format the [:] before a type constraint. *) -let fmt_constraint_sep c sep = +let fmt_constraint_sep ?(pro_space = true) c sep = match c.conf.fmt_opts.break_colon.v with - | `Before -> space_break $ str sep $ char ' ' - | `After -> char ' ' $ str sep $ space_break + | `Before -> fmt_if pro_space space_break $ str sep $ str " " + | `After -> fmt_if pro_space (str " ") $ str sep $ space_break let fmt_parsed_docstring c ~loc ?pro ~epi input parsed = assert (not (String.is_empty input)) ; @@ -764,9 +764,18 @@ and fmt_type_cstr c ?(pro = ":") ?constraint_ctx xtyp = in let wrap x = pre_break $ cbox 0 (outer_pro $ x) in (wrap, None, false) - | _ -> ((fun k -> break 0 ~-1 $ k), Some pro, true) + | _ -> + ( (fun k -> + fmt_or colon_before + (fits_breaks " " ~hint:(1000, 0) "") + (break 0 (-1)) + $ cbox_if colon_before 0 k ) + , Some pro + , true ) in - wrap (fmt_core_type c ?pro:inner_pro ?constraint_ctx ~box xtyp) + wrap + (fmt_core_type c ?pro:inner_pro ~pro_space:(not colon_before) + ?constraint_ctx ~box xtyp ) and fmt_type_pcstr c ~ctx ?constraint_ctx cstr = let fmt_typ ~pro t = @@ -821,14 +830,16 @@ and fmt_arrow_type c ~ctx ?indent ~parens ~parent_has_parens args fmt_ret_typ [xtyp] should be parenthesized. [constraint_ctx] gives the higher context of the expression, i.e. if the expression is part of a `fun` expression. *) -and fmt_core_type c ?(box = true) ?pro ?constraint_ctx +and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx ({ast= typ; ctx} as xtyp) = protect c (Typ typ) @@ let {ptyp_desc; ptyp_attributes; ptyp_loc; _} = typ in update_config_maybe_disabled c ptyp_loc ptyp_attributes @@ fun c -> - (match pro with Some pro -> fmt_constraint_sep c pro | None -> noop) + ( match pro with + | Some pro -> fmt_constraint_sep ~pro_space c pro + | None -> noop ) $ let doc, atrs = doc_atrs ptyp_attributes in Cmts.fmt c ptyp_loc @@ -1472,14 +1483,15 @@ and fmt_function ?(last_arg = false) ?force_closing_paren ~ctx ~ctx0 let cmts = Cmts.fmt_before ?eol c loc in if has_label then (false, noop, cmts) else (has_cmts, cmts, noop) in - let break_fun = Params.Exp.break_fun_kw c.conf ~ctx ~ctx0 ~last_arg ~has_label in + let break_fun = + Params.Exp.break_fun_kw c.conf ~ctx ~ctx0 ~last_arg ~has_label + in let (label_sep : t) = (* Break between the label and the fun to avoid ocp-indent's alignment. If a label is present, arguments should be indented more than the arrow and the eventually breaking [fun] keyword. *) - if c.conf.fmt_opts.ocp_indent_compat.v then - (str ":" $ cut_break) - else (str ":") + if c.conf.fmt_opts.ocp_indent_compat.v then str ":" $ cut_break + else str ":" in let fmt_typ typ = fmt_type_pcstr c ~ctx ~constraint_ctx:`Fun typ in let arrow_in_head, arrow_in_body = diff --git a/lib/Params.ml b/lib/Params.ml index 0a2d1c2039..b1287410dc 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -136,19 +136,19 @@ module Exp = struct $ Fmt.fits_breaks ")" ~hint:(1000, offset_closing_paren) ")" | `No -> wrap (str "(") (str ")") k -let break_fun_kw c ~ctx ~ctx0 ~last_arg ~has_label = - let is_labelled_arg = - match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with - | Some (( (Labelled _) | (Optional _) ), _, _ ) -> - true - | _ -> false - in - if Conf.(c.fmt_opts.ocp_indent_compat.v) then - ( if last_arg || is_labelled_arg then break 1 2 else str " ") - else ( if last_arg && has_label then break 1 2 else break 1 0) + let break_fun_kw c ~ctx ~ctx0 ~last_arg ~has_label = + let is_labelled_arg = + match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with + | Some ((Labelled _ | Optional _), _, _) -> true + | _ -> false + in + if Conf.(c.fmt_opts.ocp_indent_compat.v) then + if last_arg || is_labelled_arg then break 1 2 else str " " + else if last_arg && has_label then break 1 2 + else break 1 0 - let box_fun_decl_args ~ctx ~ctx0 ?(kw_in_box = true) ?epi c ~parens ~kw ~args - ~annot = + let box_fun_decl_args ~ctx ~ctx0 ?(kw_in_box = true) ?epi c ~parens ~kw + ~args ~annot = let is_let_func = match ctx0 with | Ast.Str _ -> @@ -158,14 +158,14 @@ let break_fun_kw c ~ctx ~ctx0 ~last_arg ~has_label = in let is_labelled_arg = match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with - | Some (( (Labelled _) | (Optional _) ), _, _ ) -> - true + | Some ((Labelled _ | Optional _), _, _) -> true | _ -> false in let name = "Params.box_fun_decl_args" in let box_decl, should_box_args = - if ocp c then ( - if is_labelled_arg then Fn.id, false else hvbox ~name (if parens then 1 else 2), false) + if ocp c then + if is_labelled_arg then (Fn.id, false) + else (hvbox ~name (if parens then 1 else 2), false) else ( ( if is_let_func then hovbox ~name 4 else hvbox ~name (if parens then 1 else 2) ) diff --git a/lib/Params.mli b/lib/Params.mli index 086b87f38f..edfd5621d0 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -38,7 +38,7 @@ module Exp : sig val box_fun_decl_args : ctx:Ast.t - -> ctx0:Ast.t + -> ctx0:Ast.t -> ?kw_in_box:bool -> ?epi:Fmt.t -> Conf.t @@ -50,12 +50,14 @@ module Exp : sig (** Box and assemble the parts [kw] (up to the arguments), [args] and [annot]. *) - val break_fun_kw : Conf_t.t -> - ctx:Ast.t -> - ctx0: Ast.t -> - last_arg:bool -> - has_label:bool -> - Fmt.t + val break_fun_kw : + Conf_t.t + -> ctx:Ast.t + -> ctx0:Ast.t + -> last_arg:bool + -> has_label:bool + -> Fmt.t + val box_fun_expr : Conf.t -> source:Source.t diff --git a/test/passing/tests/js_source.ml.err b/test/passing/tests/js_source.ml.err index c22587505a..10bcf7adaf 100644 --- a/test/passing/tests/js_source.ml.err +++ b/test/passing/tests/js_source.ml.err @@ -1,6 +1,6 @@ Warning: tests/js_source.ml:161 exceeds the margin -Warning: tests/js_source.ml:9563 exceeds the margin -Warning: tests/js_source.ml:9667 exceeds the margin -Warning: tests/js_source.ml:9726 exceeds the margin -Warning: tests/js_source.ml:9809 exceeds the margin -Warning: tests/js_source.ml:10308 exceeds the margin +Warning: tests/js_source.ml:9564 exceeds the margin +Warning: tests/js_source.ml:9668 exceeds the margin +Warning: tests/js_source.ml:9727 exceeds the margin +Warning: tests/js_source.ml:9810 exceeds the margin +Warning: tests/js_source.ml:10309 exceeds the margin diff --git a/test/passing/tests/js_source.ml.ocp b/test/passing/tests/js_source.ml.ocp index 800b870ede..ccb8ef6212 100644 --- a/test/passing/tests/js_source.ml.ocp +++ b/test/passing/tests/js_source.ml.ocp @@ -2432,7 +2432,8 @@ let eval (type c) (bop : (a, b, c) binop) (x : a constant) - (y : b constant) : c constant + (y : b constant) + : c constant = match bop, x, y with | Eq, Bool x, Bool y -> Bool (if x then y else not y) diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index e6f089312f..41f4ed5aaf 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -2432,7 +2432,8 @@ let eval (type c) (bop : (a, b, c) binop) (x : a constant) - (y : b constant) : c constant + (y : b constant) + : c constant = match bop, x, y with | Eq, Bool x, Bool y -> Bool (if x then y else not y) From 2cf5308c1b86de424fa43bb43ec1345183846b7a Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Fri, 20 Sep 2024 17:37:54 +0200 Subject: [PATCH 118/146] test: Remove --max-iter in issue289.ml --- test/passing/dune.inc | 2 +- test/passing/tests/issue289.ml.opts | 1 - 2 files changed, 1 insertion(+), 2 deletions(-) delete mode 100644 test/passing/tests/issue289.ml.opts diff --git a/test/passing/dune.inc b/test/passing/dune.inc index 1e38b8b886..64339c49d2 100644 --- a/test/passing/dune.inc +++ b/test/passing/dune.inc @@ -2753,7 +2753,7 @@ (action (with-stdout-to issue289.ml.stdout (with-stderr-to issue289.ml.stderr - (run %{bin:ocamlformat} --margin-check --max-iter=3 %{dep:tests/issue289.ml}))))) + (run %{bin:ocamlformat} --margin-check %{dep:tests/issue289.ml}))))) (rule (alias runtest) diff --git a/test/passing/tests/issue289.ml.opts b/test/passing/tests/issue289.ml.opts deleted file mode 100644 index a2f04741b8..0000000000 --- a/test/passing/tests/issue289.ml.opts +++ /dev/null @@ -1 +0,0 @@ ---max-iter=3 From d05ebe01f3264d39166a76830728f6ae3514b13b Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 23 Sep 2024 10:54:43 +0200 Subject: [PATCH 119/146] CI: Disable ocp-indent comparaison for janestreet Show the regressions instead. --- .github/workflows/build-linux.yml | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/.github/workflows/build-linux.yml b/.github/workflows/build-linux.yml index 4aa385cf7e..404c110b0f 100644 --- a/.github/workflows/build-linux.yml +++ b/.github/workflows/build-linux.yml @@ -66,10 +66,11 @@ jobs: - conventional - ocamlformat - janestreet - include: - - ocp_indent: true - ocp_indent_config: JaneStreet - profile: janestreet + # To enable comparing with ocp-indent: + # include: + # - ocp_indent: true + # ocp_indent_config: JaneStreet + # profile: janestreet steps: - name: Install ocp-indent From fc1d8dbb63900f86cefbeeb105a33fdce2e20eb2 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Tue, 24 Sep 2024 14:38:54 +0200 Subject: [PATCH 120/146] Update TODO.ml --- TODO.md | 134 ++++++++++++++++++++++++++++++++++++-------------------- 1 file changed, 87 insertions(+), 47 deletions(-) diff --git a/TODO.md b/TODO.md index 96a16126dd..1a8d87318c 100644 --- a/TODO.md +++ b/TODO.md @@ -1,48 +1,88 @@ -## On fait pas si trop dur: - -```diff - let f ssssssssss = -- String.fold ssssssssss ~init:innnnnnnnnnit ~f:(fun accuuuuuuuuuum -> -- function -+ String.fold ssssssssss ~init:innnnnnnnnnit -+ ~f:(fun accuuuuuuuuuum -> function - | '0' -> g accuuuuuuuuuum - | '1' -> h accuuuuuuuuuum - | _ -> i accuuuuuuuuuum ) -``` - -```diff - let default = - command##hasPermission #= (fun ctx -> foooooooooooooooooo fooooooooooo) ; - command##hasPermission #= (fun ctx -> -- foooooooooooooooooo fooooooooooo foooooo fooooooooo foooooooooo) ; -+ foooooooooooooooooo fooooooooooo foooooo fooooooooo foooooooooo ) ; - foo -``` - -```diff -let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = - fun t -> - let targ = Pair (Pop t, Var) in - Rec - (Sum - ( (function - | `Nil -> ("Nil", None) | `Cons p -> ("Cons", Some (Tdyn (targ, p))) - ) - , function - | "Nil", None -> `Nil - | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p - ) ) -``` - -### Janestreet - -```ocaml -let _ = - aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - ~bbbbbbbbbbbbbbbbbbbbbbbbbbbb: - (fun - (_ : (ccccccccccccc * ddddddddddddddddddddddddddddd) eeee) -> FFFFFFFFF gg) - ~h -;; +## Conventional + +Arrow changed position: + +``` + let sorted_values = + List.sort + ~compare:(fun +- { Diagnostic.location = loc1 } { Diagnostic.location = loc2 } -> +- Option.compare Location.compare loc1 loc2) ++ { Diagnostic.location = loc1 } ++ { Diagnostic.location = loc2 } ++ -> Option.compare Location.compare loc1 loc2) + values + in + List.map +``` + +Function cases changed indentation + +``` + | EArr l -> + EArr + (List.map l ~f:(function +- | ElementHole -> ElementHole +- | Element e -> Element (m#expression e) +- | ElementSpread e -> ElementSpread (m#expression e))) ++ | ElementHole -> ElementHole ++ | Element e -> Element (m#expression e) ++ | ElementSpread e -> ElementSpread (m#expression e))) ``` + +Disambiguating parentheses not needed for `function` after infix: + +``` + let print_merlin_conf ~selected_context file = + to_local ~selected_context file +- >>| (function ++ >>| ( function + | Error s -> Merlin_conf.make_error s +- | Ok file -> load_merlin_file file) ++ | Ok file -> load_merlin_file file ) + >>| Merlin_conf.to_stdout +``` + +Function cases started wrapping after infix: + +``` + let try_run_and_capture ?cwd prog args = + run_process ?cwd prog args ~split:true >>| function +- | Ok x -> Some x +- | Error _ -> None ++ | Ok x -> Some x | Error _ -> None +``` + +Argument list of a `fun` started breaking: + +``` + let new_specialised_args = + Variable.Map.mapi +- (fun new_inner_var (definition : Definition.t) : +- Flambda.specialised_to -> ++ (fun ++ new_inner_var ++ (definition : Definition.t) ++ : ++ Flambda.specialised_to ++ -> +``` + +Argument list of a `fun` changed indentation: + +``` + method class_infos : 'a. ('a -> 'res) -> 'a class_infos -> 'res = +- fun _a +- { pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes } -> ++ fun ++ _a ++ { pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes } ++ -> + let pci_virt = self#virtual_flag pci_virt in + let pci_params = + self#list +``` + +## Janestreet + +AST changed on `code/ocaml/testsuite/tests/runtime-objects/toplevel_lets.ml`. From 4833e14cf93b69b0afea75ad5421880d69246298 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Tue, 24 Sep 2024 15:48:23 +0200 Subject: [PATCH 121/146] test: Add labelled_args example --- test/passing/tests/labelled_args-414.ml.ref | 9 +++++++++ test/passing/tests/labelled_args.ml | 9 +++++++++ 2 files changed, 18 insertions(+) diff --git a/test/passing/tests/labelled_args-414.ml.ref b/test/passing/tests/labelled_args-414.ml.ref index 6f7577d6aa..4cc1713732 100644 --- a/test/passing/tests/labelled_args-414.ml.ref +++ b/test/passing/tests/labelled_args-414.ml.ref @@ -18,3 +18,12 @@ let () = very_long_argument_name_two very_long_argument_name_three -> () ) + +let () = + very_long_function_name + ~very_long_argument_label:(fun + very_long_argument_name_one + very_long_argument_name_two + very_long_argument_name_three + -> () ) + foo diff --git a/test/passing/tests/labelled_args.ml b/test/passing/tests/labelled_args.ml index ed530ced7b..808b89fa85 100644 --- a/test/passing/tests/labelled_args.ml +++ b/test/passing/tests/labelled_args.ml @@ -18,3 +18,12 @@ let () = very_long_argument_name_two very_long_argument_name_three -> () ) + +let () = + very_long_function_name + ~very_long_argument_label:(fun + very_long_argument_name_one + very_long_argument_name_two + very_long_argument_name_three + -> () ) + foo From a397f1421718606ff322349f8b332b7405fb2c40 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Tue, 24 Sep 2024 15:50:51 +0200 Subject: [PATCH 122/146] Fix indentation of labelled fun args --- lib/Fmt_ast.ml | 11 ++--- lib/Params.ml | 44 ++++++++++++------- lib/Params.mli | 4 +- test/passing/tests/js_source.ml.ref | 6 +-- test/passing/tests/labelled_args-414.ml.ref | 20 ++++++--- test/passing/tests/labelled_args.ml | 20 ++++++--- .../tests/let_binding-deindent-fun.ml.err | 1 - .../tests/let_binding-deindent-fun.ml.ref | 3 +- test/passing/tests/max_indent.ml | 3 +- 9 files changed, 69 insertions(+), 43 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 8a00b8affb..52444e1bf0 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1499,8 +1499,9 @@ and fmt_function ?(last_arg = false) ?force_closing_paren ~ctx ~ctx0 Params.Exp.break_fun_decl_args c.conf ~ctx:ctx0 ~last_arg ~has_label $ str "->" in - if c.conf.fmt_opts.ocp_indent_compat.v then (noop, arrow) - else (arrow, noop) + (* if c.conf.fmt_opts.ocp_indent_compat.v then *) + (noop, arrow) + (* else (arrow, noop) *) in let fmt_fun_args_typ args typ = let kw = @@ -1510,8 +1511,8 @@ and fmt_function ?(last_arg = false) ?force_closing_paren ~ctx ~ctx0 $ break_fun and args = fmt_expr_fun_args c args and annot = Option.map ~f:fmt_typ typ in - Params.Exp.box_fun_decl_args ~kw_in_box:(not last_arg) ~ctx ~ctx0 c.conf - ~parens ~kw ~args ~annot ~epi:arrow_in_body + Params.Exp.box_fun_decl_args ~last_arg ~ctx ~ctx0 c.conf ~parens ~kw + ~args ~annot ~epi:arrow_in_body $ arrow_in_head in let lead_with_function_kw = @@ -1610,7 +1611,7 @@ and fmt_function ?(last_arg = false) ?force_closing_paren ~ctx ~ctx0 ( wrap_intro (hvbox_if has_cmts_outer 0 ( cmts_outer - $ Params.Exp.box_fun_decl c.conf + $ Params.Exp.box_fun_decl ~ctx0 c.conf (fmt_label label label_sep $ cmts_inner $ opn_paren $ head) ) ) $ body $ cls_paren ) diff --git a/lib/Params.ml b/lib/Params.ml index b1287410dc..3f42ab87eb 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -136,7 +136,7 @@ module Exp = struct $ Fmt.fits_breaks ")" ~hint:(1000, offset_closing_paren) ")" | `No -> wrap (str "(") (str ")") k - let break_fun_kw c ~ctx ~ctx0 ~last_arg ~has_label = + let break_fun_kw c ~ctx ~ctx0 ~last_arg ~has_label:_ = let is_labelled_arg = match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with | Some ((Labelled _ | Optional _), _, _) -> true @@ -144,10 +144,10 @@ module Exp = struct in if Conf.(c.fmt_opts.ocp_indent_compat.v) then if last_arg || is_labelled_arg then break 1 2 else str " " - else if last_arg && has_label then break 1 2 + else if is_labelled_arg then break 1 2 else break 1 0 - let box_fun_decl_args ~ctx ~ctx0 ?(kw_in_box = true) ?epi c ~parens ~kw + let box_fun_decl_args ~ctx ~ctx0 ?(last_arg = false) ?epi c ~parens ~kw ~args ~annot = let is_let_func = match ctx0 with @@ -156,30 +156,36 @@ module Exp = struct true | _ -> false in - let is_labelled_arg = - match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with - | Some ((Labelled _ | Optional _), _, _) -> true - | _ -> false - in + let kw_in_box = (not last_arg) && ocp c in let name = "Params.box_fun_decl_args" in let box_decl, should_box_args = if ocp c then + let is_labelled_arg = + match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with + | Some ((Labelled _ | Optional _), _, _) -> true + | _ -> false + in if is_labelled_arg then (Fn.id, false) else (hvbox ~name (if parens then 1 else 2), false) else - ( ( if is_let_func then hovbox ~name 4 - else hvbox ~name (if parens then 1 else 2) ) - , not c.fmt_opts.wrap_fun_args.v ) + (* The box for the arguments after [let _ = fun] is different than + for other [fun] expressions. *) + let box = + if is_let_func then if kw_in_box then hovbox ~name 4 else Fn.id + else + match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with + | Some _ -> hvbox ~name (if parens then 0 else 2) + | None -> Fn.id + in + (box, not c.fmt_opts.wrap_fun_args.v) in - let box_decl = if not kw_in_box then hvbox ~name 0 else box_decl in let kw_out_of_box, kw_in_box = if kw_in_box then (noop, kw) else (kw, noop) in kw_out_of_box $ box_decl ( kw_in_box - $ hvbox_if should_box_args 0 args - $ fmt_opt annot $ fmt_opt epi ) + $ hvbox_if should_box_args 0 (args $ fmt_opt annot $ fmt_opt epi) ) let box_fun_expr (c : Conf.t) ~source ~ctx0 ~ctx ~has_label:_ ~parens = let indent = @@ -237,13 +243,13 @@ module Exp = struct && List.for_all ~f:arg_is_simple_approx other_args ) | _ -> false - let break_fun_decl_args c ~ctx ~last_arg ~has_label = + let break_fun_decl_args c ~ctx ~last_arg ~has_label:_ = match ctx with | _ when (not last_arg) && ocp c -> str " " | Ast.Str _ -> (* special case that break the arrow in [let _ = fun ... ->] *) str " " - | _ -> break 1 (if last_arg && has_label && not (ocp c) then 0 else -2) + | _ -> break 1 ~-2 let single_line_function ~ctx ~ctx0 ~args = match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with @@ -263,7 +269,11 @@ module Exp = struct then Fn.id else hvbox 0 - let box_fun_decl c k = if ocp c then hvbox 2 k else hvbox 2 k + let box_fun_decl ~ctx0 c k = + match ctx0 with + | _ when ocp c -> hvbox 2 k + | Str _ -> hovbox 4 k + | _ -> hovbox 2 k end module Mod = struct diff --git a/lib/Params.mli b/lib/Params.mli index edfd5621d0..bc1a2606ae 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -39,7 +39,7 @@ module Exp : sig val box_fun_decl_args : ctx:Ast.t -> ctx0:Ast.t - -> ?kw_in_box:bool + -> ?last_arg:bool -> ?epi:Fmt.t -> Conf.t -> parens:bool @@ -80,7 +80,7 @@ module Exp : sig val single_line_function : ctx:Ast.t -> ctx0:Ast.t -> args:'a list -> bool - val box_fun_decl : Conf.t -> Fmt.t -> Fmt.t + val box_fun_decl : ctx0:Ast.t -> Conf.t -> Fmt.t -> Fmt.t (** Box a function decl from the label to the arrow. *) end diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index 41f4ed5aaf..708f7e0869 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -9927,9 +9927,9 @@ let () = ~very_long_argument_label: (fun very_long_argument_name_one - very_long_argument_name_two - very_long_argument_name_three - -> ()) + very_long_argument_name_two + very_long_argument_name_three + -> ()) ;; let () = diff --git a/test/passing/tests/labelled_args-414.ml.ref b/test/passing/tests/labelled_args-414.ml.ref index 4cc1713732..1be599b534 100644 --- a/test/passing/tests/labelled_args-414.ml.ref +++ b/test/passing/tests/labelled_args-414.ml.ref @@ -12,8 +12,7 @@ let () = let () = very_long_function_name - ~very_long_argument_label:(* foo *) - (fun + ~very_long_argument_label:(* foo *) (fun very_long_argument_name_one very_long_argument_name_two very_long_argument_name_three @@ -22,8 +21,17 @@ let () = let () = very_long_function_name ~very_long_argument_label:(fun - very_long_argument_name_one - very_long_argument_name_two - very_long_argument_name_three - -> () ) + very_long_argument_name_one + very_long_argument_name_two + very_long_argument_name_three + -> () ) + foo + +let () = + very_long_function_name + ~very_long_argument_label:(* foo *) (fun + very_long_argument_name_one + very_long_argument_name_two + very_long_argument_name_three + -> () ) foo diff --git a/test/passing/tests/labelled_args.ml b/test/passing/tests/labelled_args.ml index 808b89fa85..5a9aa95eea 100644 --- a/test/passing/tests/labelled_args.ml +++ b/test/passing/tests/labelled_args.ml @@ -12,8 +12,7 @@ let () = let () = very_long_function_name - ~very_long_argument_label:(* foo *) - (fun + ~very_long_argument_label:(* foo *) (fun very_long_argument_name_one very_long_argument_name_two very_long_argument_name_three @@ -22,8 +21,17 @@ let () = let () = very_long_function_name ~very_long_argument_label:(fun - very_long_argument_name_one - very_long_argument_name_two - very_long_argument_name_three - -> () ) + very_long_argument_name_one + very_long_argument_name_two + very_long_argument_name_three + -> () ) + foo + +let () = + very_long_function_name + ~very_long_argument_label:(* foo *) (fun + very_long_argument_name_one + very_long_argument_name_two + very_long_argument_name_three + -> () ) foo diff --git a/test/passing/tests/let_binding-deindent-fun.ml.err b/test/passing/tests/let_binding-deindent-fun.ml.err index b503ec1354..e69de29bb2 100644 --- a/test/passing/tests/let_binding-deindent-fun.ml.err +++ b/test/passing/tests/let_binding-deindent-fun.ml.err @@ -1 +0,0 @@ -Warning: tests/let_binding.ml:265 exceeds the margin diff --git a/test/passing/tests/let_binding-deindent-fun.ml.ref b/test/passing/tests/let_binding-deindent-fun.ml.ref index 33cef1365c..8b7c1c8ff2 100644 --- a/test/passing/tests/let_binding-deindent-fun.ml.ref +++ b/test/passing/tests/let_binding-deindent-fun.ml.ref @@ -263,7 +263,8 @@ let a, b = (raise Exit : int * int) let a, b = (raise Exit : int * int) let _ = - fun xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx : _ -> + fun xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx : + _ -> match () with _ -> () ;; diff --git a/test/passing/tests/max_indent.ml b/test/passing/tests/max_indent.ml index 89e7b40654..3729a01093 100644 --- a/test/passing/tests/max_indent.ml +++ b/test/passing/tests/max_indent.ml @@ -8,8 +8,7 @@ let () = fooooo |> List.iter (fun - some_really_really_really_long_name_that_doesn't_fit_on_the_line - -> + some_really_really_really_long_name_that_doesn't_fit_on_the_line -> let x = some_really_really_really_long_name_that_doesn't_fit_on_the_line $ y in From 3bde601b294d6c50eca6629297ac336783dd5e92 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 30 Sep 2024 15:14:57 +0200 Subject: [PATCH 123/146] Remove unecessary arguments in Params --- lib/Fmt_ast.ml | 29 +++++++++-------------------- lib/Params.ml | 8 ++++---- lib/Params.mli | 14 +++----------- 3 files changed, 16 insertions(+), 35 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 52444e1bf0..43b1814f63 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1483,9 +1483,7 @@ and fmt_function ?(last_arg = false) ?force_closing_paren ~ctx ~ctx0 let cmts = Cmts.fmt_before ?eol c loc in if has_label then (false, noop, cmts) else (has_cmts, cmts, noop) in - let break_fun = - Params.Exp.break_fun_kw c.conf ~ctx ~ctx0 ~last_arg ~has_label - in + let break_fun = Params.Exp.break_fun_kw c.conf ~ctx ~ctx0 ~last_arg in let (label_sep : t) = (* Break between the label and the fun to avoid ocp-indent's alignment. If a label is present, arguments should be indented more than the @@ -1494,15 +1492,6 @@ and fmt_function ?(last_arg = false) ?force_closing_paren ~ctx ~ctx0 else str ":" in let fmt_typ typ = fmt_type_pcstr c ~ctx ~constraint_ctx:`Fun typ in - let arrow_in_head, arrow_in_body = - let arrow = - Params.Exp.break_fun_decl_args c.conf ~ctx:ctx0 ~last_arg ~has_label - $ str "->" - in - (* if c.conf.fmt_opts.ocp_indent_compat.v then *) - (noop, arrow) - (* else (arrow, noop) *) - in let fmt_fun_args_typ args typ = let kw = str "fun" @@ -1510,10 +1499,12 @@ and fmt_function ?(last_arg = false) ?force_closing_paren ~ctx ~ctx0 $ fmt_attributes c ~pre:Blank attrs $ break_fun and args = fmt_expr_fun_args c args - and annot = Option.map ~f:fmt_typ typ in + and annot = Option.map ~f:fmt_typ typ + and epi = + Params.Exp.break_fun_decl_args c.conf ~ctx:ctx0 ~last_arg $ str "->" + in Params.Exp.box_fun_decl_args ~last_arg ~ctx ~ctx0 c.conf ~parens ~kw - ~args ~annot ~epi:arrow_in_body - $ arrow_in_head + ~args ~annot ~epi in let lead_with_function_kw = match (args, body) with [], Pfunction_cases _ -> true | _ -> false @@ -1527,8 +1518,7 @@ and fmt_function ?(last_arg = false) ?force_closing_paren ~ctx ~ctx0 let head = fmt_fun_args_typ args typ in let body = fmt_expression c (sub_exp ~ctx body) in let box, closing_paren_offset = - Params.Exp.box_fun_expr c.conf ~source:c.source ~ctx0 ~ctx - ~has_label ~parens + Params.Exp.box_fun_expr c.conf ~source:c.source ~ctx0 ~ctx ~parens in let closing_paren_offset = if should_box then closing_paren_offset else ~-2 @@ -1550,9 +1540,8 @@ and fmt_function ?(last_arg = false) ?force_closing_paren ~ctx ~ctx0 | args, typ -> ( fmt_fun_args_typ args typ $ space_break , [] - , hvbox - (Params.Indent.docked_function_after_fun c.conf ~ctx0 - ~parens ~has_label ) ) + , hvbox (Params.Indent.docked_function_after_fun c.conf ~ctx0) + ) in let function_ = let pre = diff --git a/lib/Params.ml b/lib/Params.ml index 3f42ab87eb..3a6650979e 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -136,7 +136,7 @@ module Exp = struct $ Fmt.fits_breaks ")" ~hint:(1000, offset_closing_paren) ")" | `No -> wrap (str "(") (str ")") k - let break_fun_kw c ~ctx ~ctx0 ~last_arg ~has_label:_ = + let break_fun_kw c ~ctx ~ctx0 ~last_arg = let is_labelled_arg = match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with | Some ((Labelled _ | Optional _), _, _) -> true @@ -187,7 +187,7 @@ module Exp = struct ( kw_in_box $ hvbox_if should_box_args 0 (args $ fmt_opt annot $ fmt_opt epi) ) - let box_fun_expr (c : Conf.t) ~source ~ctx0 ~ctx ~has_label:_ ~parens = + let box_fun_expr (c : Conf.t) ~source ~ctx0 ~ctx ~parens = let indent = if ctx_is_infix ctx0 then 0 else if Poly.equal c.fmt_opts.function_indent_nested.v `Always then @@ -243,7 +243,7 @@ module Exp = struct && List.for_all ~f:arg_is_simple_approx other_args ) | _ -> false - let break_fun_decl_args c ~ctx ~last_arg ~has_label:_ = + let break_fun_decl_args c ~ctx ~last_arg = match ctx with | _ when (not last_arg) && ocp c -> str " " | Ast.Str _ -> @@ -883,7 +883,7 @@ module Indent = struct let fun_args c = if ocp c then 6 else 4 - let docked_function_after_fun (c : Conf.t) ~ctx0 ~parens:_ ~has_label:_ = + let docked_function_after_fun (c : Conf.t) ~ctx0 = match ctx0 with | Str _ -> (* Cases must be 2-indented relative to the [let], even when diff --git a/lib/Params.mli b/lib/Params.mli index bc1a2606ae..a1ea51c48a 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -51,19 +51,13 @@ module Exp : sig [annot]. *) val break_fun_kw : - Conf_t.t - -> ctx:Ast.t - -> ctx0:Ast.t - -> last_arg:bool - -> has_label:bool - -> Fmt.t + Conf_t.t -> ctx:Ast.t -> ctx0:Ast.t -> last_arg:bool -> Fmt.t val box_fun_expr : Conf.t -> source:Source.t -> ctx0:Ast.t -> ctx:Ast.t - -> has_label:bool -> parens:bool -> (Fmt.t -> Fmt.t) * int (** return a box with an indent and minus the value of the indent to be used for a closing parenthesis *) @@ -75,8 +69,7 @@ module Exp : sig (** Whether a space should be added between the [function] keyword and the attributes. *) - val break_fun_decl_args : - Conf.t -> ctx:Ast.t -> last_arg:bool -> has_label:bool -> Fmt.t + val break_fun_decl_args : Conf.t -> ctx:Ast.t -> last_arg:bool -> Fmt.t val single_line_function : ctx:Ast.t -> ctx0:Ast.t -> args:'a list -> bool @@ -240,8 +233,7 @@ module Indent : sig val fun_type_annot : Conf.t -> int - val docked_function_after_fun : - Conf.t -> ctx0:Ast.t -> parens:bool -> has_label:bool -> int + val docked_function_after_fun : Conf.t -> ctx0:Ast.t -> int val fun_args_group : Conf.t -> lbl:arg_label -> expression -> int From c0d36ac4db148fb31af2d435f707e1ed0c3d8a23 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 30 Sep 2024 15:15:53 +0200 Subject: [PATCH 124/146] Update TODO.ml --- TODO.md | 16 ---------------- 1 file changed, 16 deletions(-) diff --git a/TODO.md b/TODO.md index 1a8d87318c..6fe419e732 100644 --- a/TODO.md +++ b/TODO.md @@ -1,21 +1,5 @@ ## Conventional -Arrow changed position: - -``` - let sorted_values = - List.sort - ~compare:(fun -- { Diagnostic.location = loc1 } { Diagnostic.location = loc2 } -> -- Option.compare Location.compare loc1 loc2) -+ { Diagnostic.location = loc1 } -+ { Diagnostic.location = loc2 } -+ -> Option.compare Location.compare loc1 loc2) - values - in - List.map -``` - Function cases changed indentation ``` From dc871a8b2eaf56ce32bc21a2b2f664f12e466471 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 30 Sep 2024 15:17:54 +0200 Subject: [PATCH 125/146] Fix break after label and comment --- lib/Params.ml | 2 +- test/passing/tests/labelled_args-414.ml.ref | 6 ++++-- test/passing/tests/labelled_args.ml | 6 ++++-- 3 files changed, 9 insertions(+), 5 deletions(-) diff --git a/lib/Params.ml b/lib/Params.ml index 3a6650979e..f28b85ed1c 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -273,7 +273,7 @@ module Exp = struct match ctx0 with | _ when ocp c -> hvbox 2 k | Str _ -> hovbox 4 k - | _ -> hovbox 2 k + | _ -> hvbox 2 k end module Mod = struct diff --git a/test/passing/tests/labelled_args-414.ml.ref b/test/passing/tests/labelled_args-414.ml.ref index 1be599b534..de6a8e5433 100644 --- a/test/passing/tests/labelled_args-414.ml.ref +++ b/test/passing/tests/labelled_args-414.ml.ref @@ -12,7 +12,8 @@ let () = let () = very_long_function_name - ~very_long_argument_label:(* foo *) (fun + ~very_long_argument_label:(* foo *) + (fun very_long_argument_name_one very_long_argument_name_two very_long_argument_name_three @@ -29,7 +30,8 @@ let () = let () = very_long_function_name - ~very_long_argument_label:(* foo *) (fun + ~very_long_argument_label:(* foo *) + (fun very_long_argument_name_one very_long_argument_name_two very_long_argument_name_three diff --git a/test/passing/tests/labelled_args.ml b/test/passing/tests/labelled_args.ml index 5a9aa95eea..d0a6ad47b9 100644 --- a/test/passing/tests/labelled_args.ml +++ b/test/passing/tests/labelled_args.ml @@ -12,7 +12,8 @@ let () = let () = very_long_function_name - ~very_long_argument_label:(* foo *) (fun + ~very_long_argument_label:(* foo *) + (fun very_long_argument_name_one very_long_argument_name_two very_long_argument_name_three @@ -29,7 +30,8 @@ let () = let () = very_long_function_name - ~very_long_argument_label:(* foo *) (fun + ~very_long_argument_label:(* foo *) + (fun very_long_argument_name_one very_long_argument_name_two very_long_argument_name_three From b8b1419f8380d25cd2aeff3d14e480d57fbc4279 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 30 Sep 2024 15:21:17 +0200 Subject: [PATCH 126/146] js: Fix labelled fun args indent --- lib/Params.ml | 2 +- test/passing/tests/js_source.ml.ref | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/lib/Params.ml b/lib/Params.ml index f28b85ed1c..1f3714b481 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -165,7 +165,7 @@ module Exp = struct | Some ((Labelled _ | Optional _), _, _) -> true | _ -> false in - if is_labelled_arg then (Fn.id, false) + if is_labelled_arg then (Fn.id, true) else (hvbox ~name (if parens then 1 else 2), false) else (* The box for the arguments after [let _ = fun] is different than diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index 708f7e0869..41f4ed5aaf 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -9927,9 +9927,9 @@ let () = ~very_long_argument_label: (fun very_long_argument_name_one - very_long_argument_name_two - very_long_argument_name_three - -> ()) + very_long_argument_name_two + very_long_argument_name_three + -> ()) ;; let () = From 5b20205c9581f6fd20e99bff814df1feffa44716 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 30 Sep 2024 15:46:06 +0200 Subject: [PATCH 127/146] Simplify Params.Indent.function_ --- lib/Fmt_ast.ml | 4 +--- lib/Params.ml | 21 +++++++++------------ lib/Params.mli | 9 +-------- 3 files changed, 11 insertions(+), 23 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 43b1814f63..f3c7356fc7 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1533,9 +1533,7 @@ and fmt_function ?(last_arg = false) ?force_closing_paren ~ctx ~ctx0 | [], None -> ( noop , attrs - , hvbox - (Params.Indent.function_ c.conf ~ctx ~ctx0 ~parens - ~has_label ) ) + , hvbox (Params.Indent.function_ c.conf ~ctx ~ctx0 ~parens) ) | [], Some _ -> assert false | args, typ -> ( fmt_fun_args_typ args typ $ space_break diff --git a/lib/Params.ml b/lib/Params.ml index 1f3714b481..884b50c9bd 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -861,23 +861,20 @@ module Align = struct end module Indent = struct - let function_ ?(default = 0) (c : Conf.t) ~ctx ~ctx0 ~parens ~has_label = - if ctx_is_infix ctx0 then if has_label then 2 else 0 + let function_ (c : Conf.t) ~ctx ~ctx0 ~parens = + if ctx_is_infix ctx0 then 0 else - let extra = - if c.fmt_opts.wrap_fun_args.v then 0 - else match ctx0 with Str _ -> 2 | _ -> 2 - in + let extra = if c.fmt_opts.wrap_fun_args.v then 0 else 2 in if Poly.equal c.fmt_opts.function_indent_nested.v `Always then c.fmt_opts.function_indent.v + extra + else if ocp c then + match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with + | Some _ -> 2 + | None -> if parens then 2 else 0 else match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with - | Some _ -> default + 2 + if ocp c then 0 else extra - | None -> - if parens && not has_label then - if ocp c then default + 2 else default - else if ocp c then default - else default + extra + | Some _ -> 2 + extra + | None -> extra let fun_type_annot c = if ocp c then 2 else 4 diff --git a/lib/Params.mli b/lib/Params.mli index a1ea51c48a..85c6289d3b 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -218,14 +218,7 @@ module Indent : sig (** Expressions *) - val function_ : - ?default:int - -> Conf.t - -> ctx:Ast.t - -> ctx0:Ast.t - -> parens:bool - -> has_label:bool - -> int + val function_ : Conf.t -> ctx:Ast.t -> ctx0:Ast.t -> parens:bool -> int (** Check the [function-indent-nested] option, or return [default] (0 if not provided) if the option does not apply. *) From a1650d067cb0c86ff73ee34d0384e99651e72d00 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 30 Sep 2024 16:35:59 +0200 Subject: [PATCH 128/146] Fix indentation of labelled 'function' --- TODO.md | 14 ------------ lib/Cmts.ml | 2 +- lib/Fmt_ast.ml | 22 ++++++++++++++----- test/passing/tests/source-conventional.ml.ref | 9 ++++++++ test/passing/tests/source.ml | 9 ++++++++ test/passing/tests/source.ml.ref | 9 ++++++++ 6 files changed, 44 insertions(+), 21 deletions(-) diff --git a/TODO.md b/TODO.md index 6fe419e732..182183f7c6 100644 --- a/TODO.md +++ b/TODO.md @@ -1,19 +1,5 @@ ## Conventional -Function cases changed indentation - -``` - | EArr l -> - EArr - (List.map l ~f:(function -- | ElementHole -> ElementHole -- | Element e -> Element (m#expression e) -- | ElementSpread e -> ElementSpread (m#expression e))) -+ | ElementHole -> ElementHole -+ | Element e -> Element (m#expression e) -+ | ElementSpread e -> ElementSpread (m#expression e))) -``` - Disambiguating parentheses not needed for `function` after infix: ``` diff --git a/lib/Cmts.ml b/lib/Cmts.ml index c6235f77f8..820851ac14 100644 --- a/lib/Cmts.ml +++ b/lib/Cmts.ml @@ -457,7 +457,7 @@ let break_comment_group source a b = Location.line_difference a b = 0 && List.is_empty (Source.tokens_between source a.loc_end b.loc_start - ~filter:(function _ -> true ) ) + ~filter:(function _ -> true )) in not (vertical_align || horizontal_align) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index f3c7356fc7..ef0e2d09b9 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -2139,13 +2139,21 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens when List.for_all args_before ~f:(fun (_, eI) -> is_simple c.conf (fun _ -> 0) (sub_exp ~ctx eI) ) -> let inner_ctx = Exp last_arg in + let inner_parens, outer_parens = + match lbody with + | Pfunction_cases _ when not c.conf.fmt_opts.ocp_indent_compat.v + -> + (parens, false) + | _ -> (false, parens) + in let args = let wrap_intro x = - hvbox 0 - ( intro_epi - $ wrap - (fmt_args_grouped e0 args_before $ break 1 0 $ hvbox 0 x) - ) + fmt_if inner_parens (str "(") + $ hvbox 0 + ( intro_epi + $ wrap + ( fmt_args_grouped e0 args_before + $ break 1 0 $ hvbox 0 x ) ) $ break 1 0 in let force_closing_paren = @@ -2159,7 +2167,9 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens (largs, ltyp, lbody) in hvbox_if has_attr 0 - (expr_epi $ Params.parens_if parens c.conf (args $ fmt_atrs)) + ( expr_epi + $ Params.parens_if outer_parens c.conf + (args $ fmt_atrs $ fmt_if inner_parens (str ")")) ) | _ -> let fmt_atrs = fmt_attributes c ~pre:(Break (1, -2)) pexp_attributes diff --git a/test/passing/tests/source-conventional.ml.ref b/test/passing/tests/source-conventional.ml.ref index 5c6bfdbcf9..6eedd3842e 100644 --- a/test/passing/tests/source-conventional.ml.ref +++ b/test/passing/tests/source-conventional.ml.ref @@ -8697,3 +8697,12 @@ let eradicate_meta_class_is_nullsafe = ~enabled:false Info let () = match () with _ -> ( fun _ : _ -> match () with _ -> ()) | _ -> () + +let f = function + | Foo -> bar + | EArr l -> + EArr + (List.map l ~f:(function + | ElementHole -> ElementHole + | Element e -> Element (m#expression e) + | ElementSpread e -> ElementSpread (m#expression e))) diff --git a/test/passing/tests/source.ml b/test/passing/tests/source.ml index 7d764f9e4d..a5eeb3f195 100644 --- a/test/passing/tests/source.ml +++ b/test/passing/tests/source.ml @@ -7423,3 +7423,12 @@ let () = | _ -> ()) | _ -> () ;; + +let f = function + | Foo -> bar + | EArr l -> + EArr + (List.map l ~f:(function + | ElementHole -> ElementHole + | Element e -> Element (m#expression e) + | ElementSpread e -> ElementSpread (m#expression e))) diff --git a/test/passing/tests/source.ml.ref b/test/passing/tests/source.ml.ref index af858fc777..0daf566753 100644 --- a/test/passing/tests/source.ml.ref +++ b/test/passing/tests/source.ml.ref @@ -9199,3 +9199,12 @@ let eradicate_meta_class_is_nullsafe = let () = match () with _ -> ( fun _ : _ -> match () with _ -> () ) | _ -> () + +let f = function + | Foo -> bar + | EArr l -> + EArr + (List.map l ~f:(function + | ElementHole -> ElementHole + | Element e -> Element (m#expression e) + | ElementSpread e -> ElementSpread (m#expression e) )) From 4b196f1d045fd5f0b963164f4b6aa0a10186ddcb Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 30 Sep 2024 16:59:23 +0200 Subject: [PATCH 129/146] Remove a diff that is not a bug --- TODO.md | 13 ------------- lib/Fmt_ast.ml | 2 ++ 2 files changed, 2 insertions(+), 13 deletions(-) diff --git a/TODO.md b/TODO.md index 182183f7c6..2dd17e2b25 100644 --- a/TODO.md +++ b/TODO.md @@ -1,18 +1,5 @@ ## Conventional -Disambiguating parentheses not needed for `function` after infix: - -``` - let print_merlin_conf ~selected_context file = - to_local ~selected_context file -- >>| (function -+ >>| ( function - | Error s -> Merlin_conf.make_error s -- | Ok file -> load_merlin_file file) -+ | Ok file -> load_merlin_file file ) - >>| Merlin_conf.to_stdout -``` - Function cases started wrapping after infix: ``` diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index ef0e2d09b9..5407cec5e6 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -2140,6 +2140,8 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens is_simple c.conf (fun _ -> 0) (sub_exp ~ctx eI) ) -> let inner_ctx = Exp last_arg in let inner_parens, outer_parens = + (* Don't disambiguate parentheses in some cases, also affect + indentation. *) match lbody with | Pfunction_cases _ when not c.conf.fmt_opts.ocp_indent_compat.v -> From 694514a6c62073d954cdeaaf522a0db145605186 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Thu, 3 Oct 2024 14:17:01 +0200 Subject: [PATCH 130/146] Fix breaking of function cases after infix --- TODO.md | 8 -- lib-rpc/protocol.ml | 3 +- lib/Fmt_ast.ml | 74 +++++++++++-------- lib/Params.ml | 41 +++++----- lib/Params.mli | 8 +- test/passing/tests/infix_bind-break.ml.ref | 2 +- .../infix_bind-fit_or_vertical-break.ml.ref | 2 +- test/passing/tests/source-conventional.ml.err | 6 +- test/passing/tests/source-conventional.ml.ref | 19 +++-- test/passing/tests/source.ml.err | 3 +- test/passing/tests/source.ml.ref | 13 +++- 11 files changed, 103 insertions(+), 76 deletions(-) diff --git a/TODO.md b/TODO.md index 2dd17e2b25..ebe7801803 100644 --- a/TODO.md +++ b/TODO.md @@ -2,14 +2,6 @@ Function cases started wrapping after infix: -``` - let try_run_and_capture ?cwd prog args = - run_process ?cwd prog args ~split:true >>| function -- | Ok x -> Some x -- | Error _ -> None -+ | Ok x -> Some x | Error _ -> None -``` - Argument list of a `fun` started breaking: ``` diff --git a/lib-rpc/protocol.ml b/lib-rpc/protocol.ml index 5de7b70521..b3cdaad088 100644 --- a/lib-rpc/protocol.ml +++ b/lib-rpc/protocol.ml @@ -49,7 +49,8 @@ module Make (IO : IO.S) = struct let to_sexp = let open Csexp in function - | `Version v -> List [Atom "Version"; Atom v] | _ -> assert false + | `Version v -> List [Atom "Version"; Atom v] + | _ -> assert false let output oc t = IO.write oc [to_sexp t] end diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 5407cec5e6..5d9a70b3e5 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1516,7 +1516,7 @@ and fmt_function ?(last_arg = false) ?force_closing_paren ~ctx ~ctx0 | _ :: _, _, Pfunction_body body -> (* Only [fun]. *) let head = fmt_fun_args_typ args typ in - let body = fmt_expression c (sub_exp ~ctx body) in + let body ~pro = pro $ fmt_expression c (sub_exp ~ctx body) in let box, closing_paren_offset = Params.Exp.box_fun_expr c.conf ~source:c.source ~ctx0 ~ctx ~parens in @@ -1551,7 +1551,17 @@ and fmt_function ?(last_arg = false) ?force_closing_paren ~ctx ~ctx0 $ fmt_attributes ?pre c spilled_attrs $ fmt_attributes ?pre c cs_attrs in - let box_cases = Params.Exp.box_function_cases c.conf ~ctx ~ctx0 in + let box_cases ~pro cases = + let pro_inner, pro_outer, indent = + (* Formatting of if-then-else relies on the ~box argument. *) + match (args, should_box) with + | [], true -> (pro, noop, None) + | _ -> (noop, pro, Some 0) + in + pro_outer + $ Params.Exp.box_function_cases c.conf ?indent ~ctx ~ctx0 ~parens + (pro_inner $ cases) + in let box, cases = match cs with | [{pc_lhs; pc_guard= _; pc_rhs}] @@ -1592,17 +1602,18 @@ and fmt_function ?(last_arg = false) ?force_closing_paren ~ctx ~ctx0 wrap (fits_breaks "(" "") (fits_breaks ")" "") else Fn.id in + let body = + let pro = + wrap_intro + (hvbox_if has_cmts_outer 0 + ( cmts_outer + $ Params.Exp.box_fun_decl ~ctx0 c.conf + (fmt_label label label_sep $ cmts_inner $ opn_paren $ head) ) ) + in + body ~pro $ cls_paren + in let box k = if should_box then box k else k in - box - ( disambiguate_parens_wrap - ( wrap_intro - (hvbox_if has_cmts_outer 0 - ( cmts_outer - $ Params.Exp.box_fun_decl ~ctx0 c.conf - (fmt_label label label_sep $ cmts_inner $ opn_paren $ head) - ) ) - $ body $ cls_paren ) - $ Cmts.fmt_after c loc ) + box (disambiguate_parens_wrap body $ Cmts.fmt_after c loc) and fmt_label_arg ?(box = true) ?eol c (lbl, ({ast= arg; _} as xarg)) = match (lbl, arg.pexp_desc) with @@ -1796,15 +1807,16 @@ and fmt_infix_op_args c ~parens xexp op_args = (* Indentation of docked fun or function start before the operator. *) hovbox 2 (fmt_expression c ~parens ~box:false ~pro xarg) else - let expr_box = - match xarg.ast.pexp_desc with - | Pexp_function _ -> Some false - | _ -> None - in - hvbox 0 - ( pro - $ hovbox_if (not very_last) 2 - (fmt_expression c ?box:expr_box ~parens xarg) ) + match xarg.ast.pexp_desc with + | Pexp_function _ -> + let pro = pro $ fmt_if parens (str "(") in + hvbox 0 + ( fmt_expression c ~pro ~parens:false xarg + $ fmt_if parens (str ")") ) + | _ -> + hvbox 0 + ( pro + $ hovbox_if (not very_last) 2 (fmt_expression c ~parens xarg) ) in let fmt_op_arg_group ~first:first_grp ~last:last_grp args = let indent = if first_grp && parens then -2 else 0 in @@ -3091,9 +3103,9 @@ and fmt_class_field c {ast= cf; _} = let fmt_atrs = fmt_item_attributes c ~pre:(Break (1, 0)) atrs in let ctx = Clf cf in (fun k -> - fmt_cmts_before - $ hvbox 0 ~name:"clf" - (hvbox 0 (doc_before $ k $ fmt_atrs $ doc_after) $ fmt_cmts_after) ) + fmt_cmts_before + $ hvbox 0 ~name:"clf" + (hvbox 0 (doc_before $ k $ fmt_atrs $ doc_after) $ fmt_cmts_after)) @@ match cf.pcf_desc with | Pcf_inherit (override, cl, parent) -> @@ -3150,10 +3162,10 @@ and fmt_class_type_field c {ast= cf; _} = let fmt_atrs = fmt_item_attributes c ~pre:(Break (1, 0)) atrs in let ctx = Ctf cf in (fun k -> - fmt_cmts_before - $ hvbox 0 ~name:"ctf" - ( hvbox 0 (doc_before $ hvbox 0 k $ fmt_atrs $ doc_after) - $ fmt_cmts_after ) ) + fmt_cmts_before + $ hvbox 0 ~name:"ctf" + ( hvbox 0 (doc_before $ hvbox 0 k $ fmt_atrs $ doc_after) + $ fmt_cmts_after )) @@ match cf.pctf_desc with | Pctf_inherit ct -> @@ -4364,9 +4376,9 @@ and fmt_structure_item c ~last:last_item ~semisemi {ctx= parent_ctx; ast= si} let fmt_cmts_before = Cmts.Toplevel.fmt_before c si.pstr_loc in let fmt_cmts_after = Cmts.Toplevel.fmt_after c si.pstr_loc in (fun k -> - fmt_cmts_before - $ hvbox 0 ~name:"stri" - (box_semisemi c ~parent_ctx semisemi (k $ fmt_cmts_after)) ) + fmt_cmts_before + $ hvbox 0 ~name:"stri" + (box_semisemi c ~parent_ctx semisemi (k $ fmt_cmts_after))) @@ match si.pstr_desc with | Pstr_attribute attr -> fmt_floating_attributes_and_docstrings c [attr] diff --git a/lib/Params.ml b/lib/Params.ml index 884b50c9bd..804c5540f2 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -256,18 +256,38 @@ module Exp = struct | Some (_, _, true) -> List.is_empty args | _ -> false - let box_function_cases c ~ctx ~ctx0 = + let indent_function (c : Conf.t) ~ctx ~ctx0 ~parens = + if ctx_is_infix ctx0 then 0 + else + let extra = if c.fmt_opts.wrap_fun_args.v then 0 else 2 in + if Poly.equal c.fmt_opts.function_indent_nested.v `Always then + c.fmt_opts.function_indent.v + extra + else if ocp c then + match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with + | Some _ -> 2 + | None -> if parens then 2 else 0 + else + match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with + | Some _ -> 2 + extra + | None -> extra + + let box_function_cases c ?indent ~ctx ~ctx0 ~parens = + let indent = + match indent with + | Some i -> i + | None -> indent_function c ~ctx ~ctx0 ~parens + in match ctx0 with | Exp {pexp_desc= Pexp_ifthenelse _; _} when Stdlib.(Conf.(c.fmt_opts.if_then_else.v) = `Compact) -> - hvbox ~name:"cases box" 0 + hvbox ~name:"cases box" indent | _ -> if ctx_is_apply_and_exp_is_last_arg_and_other_args_are_simple c ~ctx ctx0 || ctx_is_let_or_fun ~ctx ctx0 then Fn.id - else hvbox 0 + else hvbox indent let box_fun_decl ~ctx0 c k = match ctx0 with @@ -861,20 +881,7 @@ module Align = struct end module Indent = struct - let function_ (c : Conf.t) ~ctx ~ctx0 ~parens = - if ctx_is_infix ctx0 then 0 - else - let extra = if c.fmt_opts.wrap_fun_args.v then 0 else 2 in - if Poly.equal c.fmt_opts.function_indent_nested.v `Always then - c.fmt_opts.function_indent.v + extra - else if ocp c then - match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with - | Some _ -> 2 - | None -> if parens then 2 else 0 - else - match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with - | Some _ -> 2 + extra - | None -> extra + let function_ = Exp.indent_function let fun_type_annot c = if ocp c then 2 else 4 diff --git a/lib/Params.mli b/lib/Params.mli index 85c6289d3b..b83463fb71 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -63,7 +63,13 @@ module Exp : sig (** return a box with an indent and minus the value of the indent to be used for a closing parenthesis *) val box_function_cases : - Conf.t -> ctx:Ast.t -> ctx0:Ast.t -> Fmt.t -> Fmt.t + Conf.t + -> ?indent:int + -> ctx:Ast.t + -> ctx0:Ast.t + -> parens:bool + -> Fmt.t + -> Fmt.t val function_attrs_sp : Conf.t -> ctx0:Ast.t -> ctx:Ast.t -> bool (** Whether a space should be added between the [function] keyword and the diff --git a/test/passing/tests/infix_bind-break.ml.ref b/test/passing/tests/infix_bind-break.ml.ref index 90ddc7c9ab..746115f597 100644 --- a/test/passing/tests/infix_bind-break.ml.ref +++ b/test/passing/tests/infix_bind-break.ml.ref @@ -235,7 +235,7 @@ let default = command ## hasPermission #= (fun ctx -> foooooooooooooooooo fooooooooooo) ; command ## hasPermission #= (fun ctx -> - foooooooooooooooooo fooooooooooo foooooo fooooooooo foooooooooo ) ; + foooooooooooooooooo fooooooooooo foooooo fooooooooo foooooooooo) ; foo let _ = ( let* ) x (fun y -> z) diff --git a/test/passing/tests/infix_bind-fit_or_vertical-break.ml.ref b/test/passing/tests/infix_bind-fit_or_vertical-break.ml.ref index 44e7573628..995019849b 100644 --- a/test/passing/tests/infix_bind-fit_or_vertical-break.ml.ref +++ b/test/passing/tests/infix_bind-fit_or_vertical-break.ml.ref @@ -241,7 +241,7 @@ let default = command ## hasPermission #= (fun ctx -> - foooooooooooooooooo fooooooooooo foooooo fooooooooo foooooooooo ) ; + foooooooooooooooooo fooooooooooo foooooo fooooooooo foooooooooo) ; foo let _ = ( let* ) x (fun y -> z) diff --git a/test/passing/tests/source-conventional.ml.err b/test/passing/tests/source-conventional.ml.err index 0b8847ab9c..5d8f8ebb5e 100644 --- a/test/passing/tests/source-conventional.ml.err +++ b/test/passing/tests/source-conventional.ml.err @@ -1,6 +1,4 @@ Warning: tests/source.ml:927 exceeds the margin Warning: tests/source.ml:1002 exceeds the margin -Warning: tests/source.ml:1225 exceeds the margin -Warning: tests/source.ml:1340 exceeds the margin -Warning: tests/source.ml:6615 exceeds the margin -Warning: tests/source.ml:7073 exceeds the margin +Warning: tests/source.ml:6622 exceeds the margin +Warning: tests/source.ml:7080 exceeds the margin diff --git a/test/passing/tests/source-conventional.ml.ref b/test/passing/tests/source-conventional.ml.ref index 6eedd3842e..3532b02f41 100644 --- a/test/passing/tests/source-conventional.ml.ref +++ b/test/passing/tests/source-conventional.ml.ref @@ -1223,7 +1223,8 @@ let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = { sum_proj = (function - | `Nil -> ("Nil", None) | `Cons p -> ("Cons", Some (Tdyn (tcons, p)))); + | `Nil -> ("Nil", None) + | `Cons p -> ("Cons", Some (Tdyn (tcons, p)))); sum_cases = [ ("Nil", TCnoarg Thd); ("Cons", TCarg (Ttl Thd, tcons)) ]; sum_inj = (fun (type c) -> @@ -1272,7 +1273,8 @@ let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = Rec (Sum ( (function - | `Nil -> ("Nil", None) | `Cons p -> ("Cons", Some (Tdyn (targ, p)))), + | `Nil -> ("Nil", None) + | `Cons p -> ("Cons", Some (Tdyn (targ, p)))), function | "Nil", None -> `Nil | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p )) @@ -1325,7 +1327,9 @@ let ty_abc : (([ `A of int | `B of string | `C ] as 'a), 'e) ty = (int -> string -> noarg -> unit, c) ty_sel * c -> [ `A of int | `B of string | `C ] = function - | Thd, v -> `A v | Ttl Thd, v -> `B v | Ttl (Ttl Thd), Noarg -> `C + | Thd, v -> `A v + | Ttl Thd, v -> `B v + | Ttl (Ttl Thd), Noarg -> `C end) type 'a vlist = [ `Nil | `Cons of 'a * 'a vlist ] @@ -1338,7 +1342,8 @@ let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = (object method proj = function - | `Nil -> ("Nil", None) | `Cons p -> ("Cons", Some (Tdyn (tcons, p))) + | `Nil -> ("Nil", None) + | `Cons p -> ("Cons", Some (Tdyn (tcons, p))) method cases = [ ("Nil", TCnoarg Thd); ("Cons", TCarg (Ttl Thd, tcons)) ] @@ -3576,7 +3581,8 @@ class ['a] lexpr_ops (ops : ('a, 'a) #ops Lazy.t) = method subst ~sub = function - | #lambda as x -> lambda#subst ~sub x | #expr as x -> expr#subst ~sub x + | #lambda as x -> lambda#subst ~sub x + | #expr as x -> expr#subst ~sub x method eval = function #lambda as x -> lambda#eval x | #expr as x -> expr#eval x @@ -3788,7 +3794,8 @@ let lexpr_ops (ops : ('a, 'a) #ops Lazy.t) = method subst ~sub = function - | #lambda as x -> lambda#subst ~sub x | #expr as x -> expr#subst ~sub x + | #lambda as x -> lambda#subst ~sub x + | #expr as x -> expr#subst ~sub x method eval = function #lambda as x -> lambda#eval x | #expr as x -> expr#eval x diff --git a/test/passing/tests/source.ml.err b/test/passing/tests/source.ml.err index 4ad8a5d4dd..5f176914ff 100644 --- a/test/passing/tests/source.ml.err +++ b/test/passing/tests/source.ml.err @@ -1,3 +1,2 @@ Warning: tests/source.ml:703 exceeds the margin -Warning: tests/source.ml:1394 exceeds the margin -Warning: tests/source.ml:2317 exceeds the margin +Warning: tests/source.ml:2320 exceeds the margin diff --git a/test/passing/tests/source.ml.ref b/test/passing/tests/source.ml.ref index 0daf566753..92e288dcd3 100644 --- a/test/passing/tests/source.ml.ref +++ b/test/passing/tests/source.ml.ref @@ -1392,7 +1392,8 @@ let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = Rec (Sum ( (function - | `Nil -> ("Nil", None) | `Cons p -> ("Cons", Some (Tdyn (targ, p))) ) + | `Nil -> ("Nil", None) + | `Cons p -> ("Cons", Some (Tdyn (targ, p))) ) , function | "Nil", None -> `Nil | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p @@ -1444,7 +1445,9 @@ let ty_abc : (([`A of int | `B of string | `C] as 'a), 'e) ty = (int -> string -> noarg -> unit, c) ty_sel * c -> [`A of int | `B of string | `C] = function - | Thd, v -> `A v | Ttl Thd, v -> `B v | Ttl (Ttl Thd), Noarg -> `C + | Thd, v -> `A v + | Ttl Thd, v -> `B v + | Ttl (Ttl Thd), Noarg -> `C end ) type 'a vlist = [`Nil | `Cons of 'a * 'a vlist] @@ -3789,7 +3792,8 @@ class ['a] lexpr_ops (ops : ('a, 'a) #ops Lazy.t) = method subst ~sub = function - | #lambda as x -> lambda#subst ~sub x | #expr as x -> expr#subst ~sub x + | #lambda as x -> lambda#subst ~sub x + | #expr as x -> expr#subst ~sub x method eval = function #lambda as x -> lambda#eval x | #expr as x -> expr#eval x @@ -3994,7 +3998,8 @@ let lexpr_ops (ops : ('a, 'a) #ops Lazy.t) = method subst ~sub = function - | #lambda as x -> lambda#subst ~sub x | #expr as x -> expr#subst ~sub x + | #lambda as x -> lambda#subst ~sub x + | #expr as x -> expr#subst ~sub x method eval = function #lambda as x -> lambda#eval x | #expr as x -> expr#eval x From 7c93e9a355ba80ba19548dc5e9837ac4109cb0bb Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Thu, 3 Oct 2024 14:19:40 +0200 Subject: [PATCH 131/146] Clarify TODO.md --- TODO.md | 15 +++++---------- 1 file changed, 5 insertions(+), 10 deletions(-) diff --git a/TODO.md b/TODO.md index ebe7801803..a3b2cc893e 100644 --- a/TODO.md +++ b/TODO.md @@ -5,16 +5,11 @@ Function cases started wrapping after infix: Argument list of a `fun` started breaking: ``` - let new_specialised_args = - Variable.Map.mapi -- (fun new_inner_var (definition : Definition.t) : -- Flambda.specialised_to -> -+ (fun -+ new_inner_var -+ (definition : Definition.t) -+ : -+ Flambda.specialised_to -+ -> +let new_specialised_args = + Variable.Map.mapi + (fun new_inner_var______ (definition : Definition.t) : + Flambda.specialised_to -> ()) + foo ``` Argument list of a `fun` changed indentation: From d98957c0ae3e13ffdd83913a7615afdb2afbc13b Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Tue, 8 Oct 2024 11:55:57 +0200 Subject: [PATCH 132/146] Re-implement inconsistent formatting of fun arguments --- lib/Params.ml | 10 ++++++++-- .../tests/break_fun_decl-fit_or_vertical.ml.ref | 17 +++++++++++++++++ test/passing/tests/break_fun_decl-smart.ml.ref | 17 +++++++++++++++++ test/passing/tests/break_fun_decl-wrap.ml.ref | 17 +++++++++++++++++ test/passing/tests/break_fun_decl.ml | 17 +++++++++++++++++ 5 files changed, 76 insertions(+), 2 deletions(-) diff --git a/lib/Params.ml b/lib/Params.ml index 804c5540f2..045a68c444 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -145,7 +145,8 @@ module Exp = struct if Conf.(c.fmt_opts.ocp_indent_compat.v) then if last_arg || is_labelled_arg then break 1 2 else str " " else if is_labelled_arg then break 1 2 - else break 1 0 + else if last_arg then break 1 0 + else str " " let box_fun_decl_args ~ctx ~ctx0 ?(last_arg = false) ?epi c ~parens ~kw ~args ~annot = @@ -174,7 +175,12 @@ module Exp = struct if is_let_func then if kw_in_box then hovbox ~name 4 else Fn.id else match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with - | Some _ -> hvbox ~name (if parens then 0 else 2) + | Some (_, _, true) -> + (* Is last arg. *) hvbox ~name (if parens then 0 else 2) + | Some (Nolabel, _, false) -> + (* TODO: Inconsistent formatting of fun args. *) + hovbox ~name 0 + | Some ((Labelled _ | Optional _), _, false) -> hvbox ~name 0 | None -> Fn.id in (box, not c.fmt_opts.wrap_fun_args.v) diff --git a/test/passing/tests/break_fun_decl-fit_or_vertical.ml.ref b/test/passing/tests/break_fun_decl-fit_or_vertical.ml.ref index d93df61cf7..74c628a8c3 100644 --- a/test/passing/tests/break_fun_decl-fit_or_vertical.ml.ref +++ b/test/passing/tests/break_fun_decl-fit_or_vertical.ml.ref @@ -134,3 +134,20 @@ let f (module Store : Irmin.Generic_key.S with type repo = repo) (module Store : Irmin.Generic_key.S with type repo = repo) = body + +(* Inconsistent formatting of fun arguments. *) + +let new_specialised_args = + Variable.Map.mapi + (fun new_inner_var______ (definition : Definition.t) : + Flambda.specialised_to -> () ) + foo + +let new_specialised_args = + Variable.Map.mapi + (fun + new_inner_var______ + (definition : Definition.t) + : + Flambda.specialised_to + -> () ) diff --git a/test/passing/tests/break_fun_decl-smart.ml.ref b/test/passing/tests/break_fun_decl-smart.ml.ref index c7d3bc4190..9aa19ddd4e 100644 --- a/test/passing/tests/break_fun_decl-smart.ml.ref +++ b/test/passing/tests/break_fun_decl-smart.ml.ref @@ -127,3 +127,20 @@ let f (module Store : Irmin.Generic_key.S with type repo = repo) (module Store : Irmin.Generic_key.S with type repo = repo) = body + +(* Inconsistent formatting of fun arguments. *) + +let new_specialised_args = + Variable.Map.mapi + (fun new_inner_var______ (definition : Definition.t) : + Flambda.specialised_to -> () ) + foo + +let new_specialised_args = + Variable.Map.mapi + (fun + new_inner_var______ + (definition : Definition.t) + : + Flambda.specialised_to + -> () ) diff --git a/test/passing/tests/break_fun_decl-wrap.ml.ref b/test/passing/tests/break_fun_decl-wrap.ml.ref index 88a8c80cdc..051e97b450 100644 --- a/test/passing/tests/break_fun_decl-wrap.ml.ref +++ b/test/passing/tests/break_fun_decl-wrap.ml.ref @@ -108,3 +108,20 @@ let _ = let f (module Store : Irmin.Generic_key.S with type repo = repo) (module Store : Irmin.Generic_key.S with type repo = repo) = body + +(* Inconsistent formatting of fun arguments. *) + +let new_specialised_args = + Variable.Map.mapi + (fun new_inner_var______ (definition : Definition.t) : + Flambda.specialised_to -> () ) + foo + +let new_specialised_args = + Variable.Map.mapi + (fun + new_inner_var______ + (definition : Definition.t) + : + Flambda.specialised_to + -> () ) diff --git a/test/passing/tests/break_fun_decl.ml b/test/passing/tests/break_fun_decl.ml index 88a8c80cdc..051e97b450 100644 --- a/test/passing/tests/break_fun_decl.ml +++ b/test/passing/tests/break_fun_decl.ml @@ -108,3 +108,20 @@ let _ = let f (module Store : Irmin.Generic_key.S with type repo = repo) (module Store : Irmin.Generic_key.S with type repo = repo) = body + +(* Inconsistent formatting of fun arguments. *) + +let new_specialised_args = + Variable.Map.mapi + (fun new_inner_var______ (definition : Definition.t) : + Flambda.specialised_to -> () ) + foo + +let new_specialised_args = + Variable.Map.mapi + (fun + new_inner_var______ + (definition : Definition.t) + : + Flambda.specialised_to + -> () ) From 59c2b01ebc783fdecae1615822f6fadedaab609c Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Tue, 8 Oct 2024 12:02:53 +0200 Subject: [PATCH 133/146] Restore method indentation --- TODO.md | 25 ------------------------- lib/Params.ml | 4 ++++ test/passing/tests/class_expr.ml | 10 ++++++++++ test/passing/tests/class_expr.ml.err | 1 + 4 files changed, 15 insertions(+), 25 deletions(-) create mode 100644 test/passing/tests/class_expr.ml.err diff --git a/TODO.md b/TODO.md index a3b2cc893e..c78086782d 100644 --- a/TODO.md +++ b/TODO.md @@ -2,31 +2,6 @@ Function cases started wrapping after infix: -Argument list of a `fun` started breaking: - -``` -let new_specialised_args = - Variable.Map.mapi - (fun new_inner_var______ (definition : Definition.t) : - Flambda.specialised_to -> ()) - foo -``` - -Argument list of a `fun` changed indentation: - -``` - method class_infos : 'a. ('a -> 'res) -> 'a class_infos -> 'res = -- fun _a -- { pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes } -> -+ fun -+ _a -+ { pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes } -+ -> - let pci_virt = self#virtual_flag pci_virt in - let pci_params = - self#list -``` - ## Janestreet AST changed on `code/ocaml/testsuite/tests/runtime-objects/toplevel_lets.ml`. diff --git a/lib/Params.ml b/lib/Params.ml index 045a68c444..08da15f2e2 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -255,6 +255,9 @@ module Exp = struct | Ast.Str _ -> (* special case that break the arrow in [let _ = fun ... ->] *) str " " + | Clf _ -> + (* special case for methods. *) + str " " | _ -> break 1 ~-2 let single_line_function ~ctx ~ctx0 ~args = @@ -299,6 +302,7 @@ module Exp = struct match ctx0 with | _ when ocp c -> hvbox 2 k | Str _ -> hovbox 4 k + | Clf _ -> hovbox 4 k | _ -> hvbox 2 k end diff --git a/test/passing/tests/class_expr.ml b/test/passing/tests/class_expr.ml index cc5a371a3a..f667e84954 100644 --- a/test/passing/tests/class_expr.ml +++ b/test/passing/tests/class_expr.ml @@ -5,3 +5,13 @@ class c `I = x class c i = x class c (* xx *) i (* yy *) = x + +class c = + object + method class_infos : 'a. ('a -> 'res) -> 'a class_infos -> 'res = + fun _a + {pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes} -> + let pci_virt = self#virtual_flag pci_virt in + let pci_params = self#list in + () + end diff --git a/test/passing/tests/class_expr.ml.err b/test/passing/tests/class_expr.ml.err new file mode 100644 index 0000000000..b81006f75d --- /dev/null +++ b/test/passing/tests/class_expr.ml.err @@ -0,0 +1 @@ +Warning: tests/class_expr.ml:12 exceeds the margin From 6ece6c4688e0f899336f3044409be015121a8989 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Tue, 8 Oct 2024 17:58:53 +0200 Subject: [PATCH 134/146] Update TODO.ml --- TODO.md | 191 ++++++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 187 insertions(+), 4 deletions(-) diff --git a/TODO.md b/TODO.md index c78086782d..86b0a45b0e 100644 --- a/TODO.md +++ b/TODO.md @@ -1,7 +1,190 @@ -## Conventional +## Conventional profile -Function cases started wrapping after infix: +`fun` indent at toplevel but not at tail -## Janestreet +``` + let fmt_atrs = fmt_item_attributes c ~pre:(Break (1, 0)) atrs in + let ctx = Ctf cf in + (fun k -> +- fmt_cmts_before +- $ hvbox 0 ~name:"ctf" +- (hvbox 0 (doc_before $ hvbox 0 k $ fmt_atrs $ doc_after) +- $ fmt_cmts_after)) ++ fmt_cmts_before ++ $ hvbox 0 ~name:"ctf" ++ (hvbox 0 (doc_before $ hvbox 0 k $ fmt_atrs $ doc_after) $ fmt_cmts_after)) + @@ +``` -AST changed on `code/ocaml/testsuite/tests/runtime-objects/toplevel_lets.ml`. +Argument-list indentation at toplevel + +``` +let create = + let drop_suffix name = + if Sys.win32 + then Option.value ~default:name (String.drop_suffix name ~suffix:".exe") + else name + in + fun (context : Context.t) + ~(local_bins : origin Appendable_list.t Filename.Map.t Memo.Lazy.t) -> + let local_bins = + Memo.lazy_ (fun () -> + let+ local_bins = Memo.Lazy.force local_bins in + Filename.Map.to_list_map local_bins ~f:(fun name sources -> + let sources = Appendable_list.to_list sources in + drop_suffix name, Origin sources) + |> Filename.Map.of_list_exn) + in + { context; local_bins } +``` + +Argument-list wrapping at toplevel + +``` +- fun ~dir ~scope ~target_dir ~sctx ~requires_link ~mode +- (mel : Melange_stanzas.Emit.t) -> ++ fun ~dir ++ ~scope ++ ~target_dir ++ ~sctx ++ ~requires_link ++ ~mode ++ (mel : Melange_stanzas.Emit.t) ++ -> + let build_js = build_js ~sctx ~mode ~module_systems:mel.module_systems in +``` + +Indentation of `fun` in a match clause + +``` +let rec expression : Typedtree.expression -> term_judg = + fun exp -> match exp.exp_desc with + | Texp_ident (pth, _, _) -> + path pth + | Texp_let (rec_flag, bindings, body) -> + (* + G |- : m -| G' + G' |- body : m + ------------------------------- + G |- let in body : m + *) + value_bindings rec_flag bindings >> expression body + | Texp_letmodule (x, _, _, mexp, e) -> + module_binding (x, mexp) >> expression e + | Texp_match (e, cases, eff_cases, _) -> + (* TODO: update comment below for eff_cases + (Gi; mi |- pi -> ei : m)^i + G |- e : sum(mi)^i + ---------------------------------------------- + G + sum(Gi)^i |- match e with (pi -> ei)^i : m + *) + (fun mode -> + let pat_envs, pat_modes = + List.split (List.map (fun c -> case c mode) cases) in + let env_e = expression e (List.fold_left Mode.join Ignore pat_modes) in + let eff_envs, eff_modes = + List.split (List.map (fun c -> case c mode) eff_cases) in + let eff_e = expression e (List.fold_left Mode.join Ignore eff_modes) in + Env.join_list + ((Env.join_list (env_e :: pat_envs)) :: (eff_e :: eff_envs))) +``` + +## Janestreet profile + +`function` after infix indentation + +``` + Protocol.Init.read_input ic + >>= (function +- | `Version v when v = latest -> return (get_client ~pid ic oc v) +- | `Version v -> +- (match others with +- | h :: _ when v = h -> return (get_client ~pid ic oc v) +- | _ -> aux others) +- | `Unknown -> aux others +- | `Halt -> +- return +- (Error +- (`Msg +- "OCamlFormat-RPC did not respond. Check that a compatible version of \ +- the OCamlFormat RPC server (ocamlformat-rpc >= 0.18.0) is \ +- installed."))) ++ | `Version v when v = latest -> return (get_client ~pid ic oc v) ++ | `Version v -> ++ (match others with ++ | h :: _ when v = h -> return (get_client ~pid ic oc v) ++ | _ -> aux others) ++ | `Unknown -> aux others ++ | `Halt -> ++ return ++ (Error ++ (`Msg ++ "OCamlFormat-RPC did not respond. Check that a compatible version of \ ++ the OCamlFormat RPC server (ocamlformat-rpc >= 0.18.0) is installed."))) + in + aux versions +``` + +`fun -> function` argument + +``` + List.fold_left + (fun acc -> function +- | List [ Atom name; Atom value ] -> (name, value) :: acc +- | _ -> acc) ++ | List [ Atom name; Atom value ] -> (name, value) :: acc ++ | _ -> acc) + [] + l + |> List.rev +``` + +`fun` at toplevel but not tail + +``` + let fmt_atrs = fmt_item_attributes c ~pre:(Break (1, 0)) atrs in + let ctx = Ctf cf in + (fun k -> +- fmt_cmts_before +- $ hvbox +- 0 +- ~name:"ctf" +- (hvbox 0 (doc_before $ hvbox 0 k $ fmt_atrs $ doc_after) $ fmt_cmts_after)) ++ fmt_cmts_before ++ $ hvbox ++ 0 ++ ~name:"ctf" ++ (hvbox 0 (doc_before $ hvbox 0 k $ fmt_atrs $ doc_after) $ fmt_cmts_after)) + @@ +``` + +`fun` argument-list unwrapped at toplevel + +``` + -> acc + -> acc Lwt.t + = +- fun ~order ~force ~cache ~uniq ~pre ~post ~path ?depth ~node ~contents ~tree t acc -> ++ fun ~order ++ ~force ++ ~cache ++ ~uniq ++ ~pre ++ ~post ++ ~path ++ ?depth ++ ~node ++ ~contents ++ ~tree ++ t ++ acc -> + let env = t.info.env in +``` + +Break after `->` at toplevel + +``` +- fun s m -> List.fold_right (fun it env -> structure_item it m env) s.str_items Env.empty ++ fun s m -> ++ List.fold_right (fun it env -> structure_item it m env) s.str_items Env.empty +``` From 20efdce13d36fded41d8b05b56cb2a9e08cf64b3 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Thu, 10 Oct 2024 15:21:40 +0200 Subject: [PATCH 135/146] TODO.ml: This is a fix. The diff is due to inconsistent boxing in presence of a comment. The formatting of the `fun` now is the same as before if the comment was removed. The break behavior after the `->` is also different. --- TODO.md | 43 ------------------------------------------- 1 file changed, 43 deletions(-) diff --git a/TODO.md b/TODO.md index 86b0a45b0e..095469fa5b 100644 --- a/TODO.md +++ b/TODO.md @@ -54,41 +54,6 @@ Argument-list wrapping at toplevel let build_js = build_js ~sctx ~mode ~module_systems:mel.module_systems in ``` -Indentation of `fun` in a match clause - -``` -let rec expression : Typedtree.expression -> term_judg = - fun exp -> match exp.exp_desc with - | Texp_ident (pth, _, _) -> - path pth - | Texp_let (rec_flag, bindings, body) -> - (* - G |- : m -| G' - G' |- body : m - ------------------------------- - G |- let in body : m - *) - value_bindings rec_flag bindings >> expression body - | Texp_letmodule (x, _, _, mexp, e) -> - module_binding (x, mexp) >> expression e - | Texp_match (e, cases, eff_cases, _) -> - (* TODO: update comment below for eff_cases - (Gi; mi |- pi -> ei : m)^i - G |- e : sum(mi)^i - ---------------------------------------------- - G + sum(Gi)^i |- match e with (pi -> ei)^i : m - *) - (fun mode -> - let pat_envs, pat_modes = - List.split (List.map (fun c -> case c mode) cases) in - let env_e = expression e (List.fold_left Mode.join Ignore pat_modes) in - let eff_envs, eff_modes = - List.split (List.map (fun c -> case c mode) eff_cases) in - let eff_e = expression e (List.fold_left Mode.join Ignore eff_modes) in - Env.join_list - ((Env.join_list (env_e :: pat_envs)) :: (eff_e :: eff_envs))) -``` - ## Janestreet profile `function` after infix indentation @@ -180,11 +145,3 @@ let rec expression : Typedtree.expression -> term_judg = + acc -> let env = t.info.env in ``` - -Break after `->` at toplevel - -``` -- fun s m -> List.fold_right (fun it env -> structure_item it m env) s.str_items Env.empty -+ fun s m -> -+ List.fold_right (fun it env -> structure_item it m env) s.str_items Env.empty -``` From 0f1d888651c86e1e0b0203bf02f34524db84e9fe Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Thu, 10 Oct 2024 15:33:29 +0200 Subject: [PATCH 136/146] TODO.ml: Not a bug This is the normal formatting for argument lists. Previous version of ocamlformat would format the same if the argument list was 3 characters longer. The change is that the `->` keyword no longer exceed the margin. --- TODO.md | 23 ----------------------- 1 file changed, 23 deletions(-) diff --git a/TODO.md b/TODO.md index 095469fa5b..523210bb7e 100644 --- a/TODO.md +++ b/TODO.md @@ -122,26 +122,3 @@ Argument-list wrapping at toplevel + (hvbox 0 (doc_before $ hvbox 0 k $ fmt_atrs $ doc_after) $ fmt_cmts_after)) @@ ``` - -`fun` argument-list unwrapped at toplevel - -``` - -> acc - -> acc Lwt.t - = -- fun ~order ~force ~cache ~uniq ~pre ~post ~path ?depth ~node ~contents ~tree t acc -> -+ fun ~order -+ ~force -+ ~cache -+ ~uniq -+ ~pre -+ ~post -+ ~path -+ ?depth -+ ~node -+ ~contents -+ ~tree -+ t -+ acc -> - let env = t.info.env in -``` From ef86c825e5e42f3d46f927a616c6bf5cdb9a140b Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Thu, 10 Oct 2024 15:43:28 +0200 Subject: [PATCH 137/146] Fix indentation of `fun` on the left of an infix --- TODO.md | 35 ---------------------------------- lib/Fmt_ast.ml | 20 +++++++++---------- lib/Params.ml | 12 ++++++++++-- test/passing/tests/fun_decl.ml | 6 ++++++ 4 files changed, 26 insertions(+), 47 deletions(-) diff --git a/TODO.md b/TODO.md index 523210bb7e..dbfa7a3771 100644 --- a/TODO.md +++ b/TODO.md @@ -1,21 +1,5 @@ ## Conventional profile -`fun` indent at toplevel but not at tail - -``` - let fmt_atrs = fmt_item_attributes c ~pre:(Break (1, 0)) atrs in - let ctx = Ctf cf in - (fun k -> -- fmt_cmts_before -- $ hvbox 0 ~name:"ctf" -- (hvbox 0 (doc_before $ hvbox 0 k $ fmt_atrs $ doc_after) -- $ fmt_cmts_after)) -+ fmt_cmts_before -+ $ hvbox 0 ~name:"ctf" -+ (hvbox 0 (doc_before $ hvbox 0 k $ fmt_atrs $ doc_after) $ fmt_cmts_after)) - @@ -``` - Argument-list indentation at toplevel ``` @@ -103,22 +87,3 @@ Argument-list wrapping at toplevel l |> List.rev ``` - -`fun` at toplevel but not tail - -``` - let fmt_atrs = fmt_item_attributes c ~pre:(Break (1, 0)) atrs in - let ctx = Ctf cf in - (fun k -> -- fmt_cmts_before -- $ hvbox -- 0 -- ~name:"ctf" -- (hvbox 0 (doc_before $ hvbox 0 k $ fmt_atrs $ doc_after) $ fmt_cmts_after)) -+ fmt_cmts_before -+ $ hvbox -+ 0 -+ ~name:"ctf" -+ (hvbox 0 (doc_before $ hvbox 0 k $ fmt_atrs $ doc_after) $ fmt_cmts_after)) - @@ -``` diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 2b5dde7352..cc9f5b8557 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -3110,9 +3110,9 @@ and fmt_class_field c {ast= cf; _} = let fmt_atrs = fmt_item_attributes c ~pre:(Break (1, 0)) atrs in let ctx = Clf cf in (fun k -> - fmt_cmts_before - $ hvbox 0 ~name:"clf" - (hvbox 0 (doc_before $ k $ fmt_atrs $ doc_after) $ fmt_cmts_after)) + fmt_cmts_before + $ hvbox 0 ~name:"clf" + (hvbox 0 (doc_before $ k $ fmt_atrs $ doc_after) $ fmt_cmts_after)) @@ match cf.pcf_desc with | Pcf_inherit (override, cl, parent) -> @@ -3169,10 +3169,10 @@ and fmt_class_type_field c {ast= cf; _} = let fmt_atrs = fmt_item_attributes c ~pre:(Break (1, 0)) atrs in let ctx = Ctf cf in (fun k -> - fmt_cmts_before - $ hvbox 0 ~name:"ctf" - ( hvbox 0 (doc_before $ hvbox 0 k $ fmt_atrs $ doc_after) - $ fmt_cmts_after )) + fmt_cmts_before + $ hvbox 0 ~name:"ctf" + ( hvbox 0 (doc_before $ hvbox 0 k $ fmt_atrs $ doc_after) + $ fmt_cmts_after )) @@ match cf.pctf_desc with | Pctf_inherit ct -> @@ -4383,9 +4383,9 @@ and fmt_structure_item c ~last:last_item ~semisemi {ctx= parent_ctx; ast= si} let fmt_cmts_before = Cmts.Toplevel.fmt_before c si.pstr_loc in let fmt_cmts_after = Cmts.Toplevel.fmt_after c si.pstr_loc in (fun k -> - fmt_cmts_before - $ hvbox 0 ~name:"stri" - (box_semisemi c ~parent_ctx semisemi (k $ fmt_cmts_after))) + fmt_cmts_before + $ hvbox 0 ~name:"stri" + (box_semisemi c ~parent_ctx semisemi (k $ fmt_cmts_after))) @@ match si.pstr_desc with | Pstr_attribute attr -> fmt_floating_attributes_and_docstrings c [attr] diff --git a/lib/Params.ml b/lib/Params.ml index 08da15f2e2..8c1434437f 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -31,6 +31,14 @@ let ctx_is_infix = function | Exp {pexp_desc= Pexp_infix _; _} -> true | _ -> false +let ctx_is_rhs_of_infix ~ctx0 ~ctx = + match (ctx0, ctx) with + | Exp {pexp_desc= Pexp_infix ({txt= ":="; _}, _, _); _}, _ -> false + | Exp {pexp_desc= Pexp_infix (_, _, rhs); _}, Exp ctx + when phys_equal rhs ctx -> + true + | _ -> false + (** Return [None] if [ctx0] is not an application or [ctx] is not one of its argument. *) let ctx_is_apply_and_exp_is_arg ~ctx ctx0 = @@ -195,7 +203,7 @@ module Exp = struct let box_fun_expr (c : Conf.t) ~source ~ctx0 ~ctx ~parens = let indent = - if ctx_is_infix ctx0 then 0 + if ctx_is_rhs_of_infix ~ctx0 ~ctx then 0 else if Poly.equal c.fmt_opts.function_indent_nested.v `Always then c.fmt_opts.function_indent.v else if ctx_is_let_or_fun ~ctx ctx0 then @@ -266,7 +274,7 @@ module Exp = struct | _ -> false let indent_function (c : Conf.t) ~ctx ~ctx0 ~parens = - if ctx_is_infix ctx0 then 0 + if ctx_is_rhs_of_infix ~ctx0 ~ctx then 0 else let extra = if c.fmt_opts.wrap_fun_args.v then 0 else 2 in if Poly.equal c.fmt_opts.function_indent_nested.v `Always then diff --git a/test/passing/tests/fun_decl.ml b/test/passing/tests/fun_decl.ml index 2e2e7c95a1..6f31002813 100644 --- a/test/passing/tests/fun_decl.ml +++ b/test/passing/tests/fun_decl.ml @@ -102,3 +102,9 @@ let space_break = with_pp (fun fs -> Box_debug.space_break fs ; Format_.pp_print_space fs () ) + +let _ = + (fun k -> + let _ = 42 in + ()) + @@ () From 071054747200087289ecc1529d4fb7b5bca633bc Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Thu, 10 Oct 2024 15:50:33 +0200 Subject: [PATCH 138/146] Fix indent of 'fun -> function' arguments --- TODO.md | 14 -------------- lib/Fmt_ast.ml | 5 +++-- lib/Params.ml | 6 +++++- lib/Params.mli | 3 ++- 4 files changed, 10 insertions(+), 18 deletions(-) diff --git a/TODO.md b/TODO.md index dbfa7a3771..c0b9663761 100644 --- a/TODO.md +++ b/TODO.md @@ -73,17 +73,3 @@ Argument-list wrapping at toplevel in aux versions ``` - -`fun -> function` argument - -``` - List.fold_left - (fun acc -> function -- | List [ Atom name; Atom value ] -> (name, value) :: acc -- | _ -> acc) -+ | List [ Atom name; Atom value ] -> (name, value) :: acc -+ | _ -> acc) - [] - l - |> List.rev -``` diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index cc9f5b8557..d01aae62ba 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1538,8 +1538,9 @@ and fmt_function ?(last_arg = false) ?force_closing_paren ~ctx ~ctx0 | args, typ -> ( fmt_fun_args_typ args typ $ space_break , [] - , hvbox (Params.Indent.docked_function_after_fun c.conf ~ctx0) - ) + , hvbox + (Params.Indent.docked_function_after_fun c.conf ~parens + ~ctx0 ~ctx ) ) in let function_ = let pre = diff --git a/lib/Params.ml b/lib/Params.ml index 8c1434437f..7844c9f1d3 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -905,13 +905,17 @@ module Indent = struct let fun_args c = if ocp c then 6 else 4 - let docked_function_after_fun (c : Conf.t) ~ctx0 = + let docked_function_after_fun (c : Conf.t) ~parens ~ctx0 ~ctx = match ctx0 with | Str _ -> (* Cases must be 2-indented relative to the [let], even when [let_binding_deindent_fun] is on. *) if c.fmt_opts.let_binding_deindent_fun.v then 1 else 0 | _ when ctx_is_infix ctx0 -> 0 + | _ when ocp c -> ( + match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with + | Some (_, _, false) when parens -> (* Not last argument *) 3 + | _ -> 2 ) | _ -> 2 let fun_args_group (c : Conf.t) ~lbl exp = diff --git a/lib/Params.mli b/lib/Params.mli index b83463fb71..803172821a 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -232,7 +232,8 @@ module Indent : sig val fun_type_annot : Conf.t -> int - val docked_function_after_fun : Conf.t -> ctx0:Ast.t -> int + val docked_function_after_fun : + Conf.t -> parens:bool -> ctx0:Ast.t -> ctx:Ast.t -> int val fun_args_group : Conf.t -> lbl:arg_label -> expression -> int From 9d5313702bb42a805d55e7d0b7212ac81b8f15d5 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Thu, 10 Oct 2024 17:03:29 +0200 Subject: [PATCH 139/146] Fix indent of 'fun -> function' exprs --- lib/Params.ml | 4 ++-- test/passing/tests/function_indent-never.ml.ref | 8 ++++++++ test/passing/tests/function_indent.ml | 10 ++++++++++ test/passing/tests/function_indent.ml.ref | 8 ++++++++ test/passing/tests/js_source.ml | 10 ++++++++++ test/passing/tests/js_source.ml.ocp | 10 ++++++++++ test/passing/tests/js_source.ml.ref | 10 ++++++++++ 7 files changed, 58 insertions(+), 2 deletions(-) diff --git a/lib/Params.ml b/lib/Params.ml index 7844c9f1d3..cf62acbb8c 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -914,8 +914,8 @@ module Indent = struct | _ when ctx_is_infix ctx0 -> 0 | _ when ocp c -> ( match ctx_is_apply_and_exp_is_arg ~ctx ctx0 with - | Some (_, _, false) when parens -> (* Not last argument *) 3 - | _ -> 2 ) + | Some (_, _, true) -> (* Last argument *) 2 + | _ -> if parens then 3 else 2 ) | _ -> 2 let fun_args_group (c : Conf.t) ~lbl exp = diff --git a/test/passing/tests/function_indent-never.ml.ref b/test/passing/tests/function_indent-never.ml.ref index de82a9280f..91dd9466df 100644 --- a/test/passing/tests/function_indent-never.ml.ref +++ b/test/passing/tests/function_indent-never.ml.ref @@ -23,3 +23,11 @@ let foooooooo = else function | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo + +let _ = + { foo= + (fun _ -> function + | _ -> + let _ = 42 in + () + | () -> () ) } diff --git a/test/passing/tests/function_indent.ml b/test/passing/tests/function_indent.ml index 173574d8ba..c51d9d0a2e 100644 --- a/test/passing/tests/function_indent.ml +++ b/test/passing/tests/function_indent.ml @@ -24,3 +24,13 @@ let foooooooo = function | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo + +let _ = + { foo = + (fun _ -> function + | _ -> + let _ = 42 in + () + | () -> ()) + } +;; diff --git a/test/passing/tests/function_indent.ml.ref b/test/passing/tests/function_indent.ml.ref index 63903bc063..41ad106a3a 100644 --- a/test/passing/tests/function_indent.ml.ref +++ b/test/passing/tests/function_indent.ml.ref @@ -23,3 +23,11 @@ let foooooooo = else function | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo | fooooooooooooooooooooooo -> foooooooooooooooooooooooooo + +let _ = + { foo= + (fun _ -> function + | _ -> + let _ = 42 in + () + | () -> () ) } diff --git a/test/passing/tests/js_source.ml b/test/passing/tests/js_source.ml index b08792ee18..d5377b9847 100644 --- a/test/passing/tests/js_source.ml +++ b/test/passing/tests/js_source.ml @@ -8193,3 +8193,13 @@ end ] ;; *) + +let _ = + { foo = + (fun _ -> function + | _ -> + let _ = 42 in + () + | () -> ()) + } +;; diff --git a/test/passing/tests/js_source.ml.ocp b/test/passing/tests/js_source.ml.ocp index ccb8ef6212..3be7bd3c08 100644 --- a/test/passing/tests/js_source.ml.ocp +++ b/test/passing/tests/js_source.ml.ocp @@ -10482,3 +10482,13 @@ module type M = sig end (*$ let _ = [ x (* *); y ] *) + +let _ = + { foo = + (fun _ -> function + | _ -> + let _ = 42 in + () + | () -> ()) + } +;; diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index 41f4ed5aaf..9f3df92bf1 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -10482,3 +10482,13 @@ module type M = sig end (*$ let _ = [ x (* *); y ] *) + +let _ = + { foo = + (fun _ -> function + | _ -> + let _ = 42 in + () + | () -> ()) + } +;; From 0a3198bc9def35dd6976d525a715668c8c5b78b5 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Thu, 10 Oct 2024 17:11:52 +0200 Subject: [PATCH 140/146] js: Fix indent of 'function' after infix --- TODO.md | 34 ------------------- lib/Params.ml | 3 +- .../tests/function_indent-never.ml.ref | 8 +++++ test/passing/tests/function_indent.ml | 8 +++++ test/passing/tests/function_indent.ml.ref | 8 +++++ test/passing/tests/js_source.ml | 9 +++++ test/passing/tests/js_source.ml.ocp | 9 +++++ test/passing/tests/js_source.ml.ref | 9 +++++ 8 files changed, 53 insertions(+), 35 deletions(-) diff --git a/TODO.md b/TODO.md index c0b9663761..4a8434f407 100644 --- a/TODO.md +++ b/TODO.md @@ -39,37 +39,3 @@ Argument-list wrapping at toplevel ``` ## Janestreet profile - -`function` after infix indentation - -``` - Protocol.Init.read_input ic - >>= (function -- | `Version v when v = latest -> return (get_client ~pid ic oc v) -- | `Version v -> -- (match others with -- | h :: _ when v = h -> return (get_client ~pid ic oc v) -- | _ -> aux others) -- | `Unknown -> aux others -- | `Halt -> -- return -- (Error -- (`Msg -- "OCamlFormat-RPC did not respond. Check that a compatible version of \ -- the OCamlFormat RPC server (ocamlformat-rpc >= 0.18.0) is \ -- installed."))) -+ | `Version v when v = latest -> return (get_client ~pid ic oc v) -+ | `Version v -> -+ (match others with -+ | h :: _ when v = h -> return (get_client ~pid ic oc v) -+ | _ -> aux others) -+ | `Unknown -> aux others -+ | `Halt -> -+ return -+ (Error -+ (`Msg -+ "OCamlFormat-RPC did not respond. Check that a compatible version of \ -+ the OCamlFormat RPC server (ocamlformat-rpc >= 0.18.0) is installed."))) - in - aux versions -``` diff --git a/lib/Params.ml b/lib/Params.ml index cf62acbb8c..601c2d1874 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -274,7 +274,8 @@ module Exp = struct | _ -> false let indent_function (c : Conf.t) ~ctx ~ctx0 ~parens = - if ctx_is_rhs_of_infix ~ctx0 ~ctx then 0 + if ctx_is_rhs_of_infix ~ctx0 ~ctx then + if ocp c then (* Assume parentheses will be outputed *) 1 else 0 else let extra = if c.fmt_opts.wrap_fun_args.v then 0 else 2 in if Poly.equal c.fmt_opts.function_indent_nested.v `Always then diff --git a/test/passing/tests/function_indent-never.ml.ref b/test/passing/tests/function_indent-never.ml.ref index 91dd9466df..52443ae384 100644 --- a/test/passing/tests/function_indent-never.ml.ref +++ b/test/passing/tests/function_indent-never.ml.ref @@ -31,3 +31,11 @@ let _ = let _ = 42 in () | () -> () ) } + +let _ = + match () with + | _ -> ( + f + >>= function + | `Fooooooooooooooooooooooooooooooooooooooo -> 1 + | `Baaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaar -> 2 ) diff --git a/test/passing/tests/function_indent.ml b/test/passing/tests/function_indent.ml index c51d9d0a2e..e75d785480 100644 --- a/test/passing/tests/function_indent.ml +++ b/test/passing/tests/function_indent.ml @@ -34,3 +34,11 @@ let _ = | () -> ()) } ;; + +let _ = + match () with + | _ -> ( + f + >>= function + | `Fooooooooooooooooooooooooooooooooooooooo -> 1 + | `Baaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaar -> 2 ) diff --git a/test/passing/tests/function_indent.ml.ref b/test/passing/tests/function_indent.ml.ref index 41ad106a3a..6ab531abab 100644 --- a/test/passing/tests/function_indent.ml.ref +++ b/test/passing/tests/function_indent.ml.ref @@ -31,3 +31,11 @@ let _ = let _ = 42 in () | () -> () ) } + +let _ = + match () with + | _ -> ( + f + >>= function + | `Fooooooooooooooooooooooooooooooooooooooo -> 1 + | `Baaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaar -> 2 ) diff --git a/test/passing/tests/js_source.ml b/test/passing/tests/js_source.ml index d5377b9847..05e8188b17 100644 --- a/test/passing/tests/js_source.ml +++ b/test/passing/tests/js_source.ml @@ -8203,3 +8203,12 @@ let _ = | () -> ()) } ;; + +let _ = + match () with + | _ -> + f + >>= (function + | `Fooooooooooooooooooooooooooooooooooooooo -> 1 + | `Baaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaar -> 2) +;; diff --git a/test/passing/tests/js_source.ml.ocp b/test/passing/tests/js_source.ml.ocp index 3be7bd3c08..6a614119c0 100644 --- a/test/passing/tests/js_source.ml.ocp +++ b/test/passing/tests/js_source.ml.ocp @@ -10492,3 +10492,12 @@ let _ = | () -> ()) } ;; + +let _ = + match () with + | _ -> + f + >>= (function + | `Fooooooooooooooooooooooooooooooooooooooo -> 1 + | `Baaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaar -> 2) +;; diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index 9f3df92bf1..a8f9a23aa5 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -10492,3 +10492,12 @@ let _ = | () -> ()) } ;; + +let _ = + match () with + | _ -> + f + >>= (function + | `Fooooooooooooooooooooooooooooooooooooooo -> 1 + | `Baaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaar -> 2) +;; From 79330feeec02ce9316e8e2f804d7310f0125f3a2 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Fri, 11 Oct 2024 11:57:49 +0200 Subject: [PATCH 141/146] Fix disambiguating parentheses and indentation of `function` after infix --- lib/Fmt_ast.ml | 12 ++++-------- lib/Params.ml | 3 +-- test/passing/tests/fun_decl.ml | 2 +- test/passing/tests/infix_bind-break.ml.ref | 2 +- .../infix_bind-fit_or_vertical-break.ml.ref | 2 +- test/passing/tests/js_source.ml | 18 ++++++++++++++++++ test/passing/tests/js_source.ml.ocp | 18 ++++++++++++++++++ test/passing/tests/js_source.ml.ref | 18 ++++++++++++++++++ 8 files changed, 62 insertions(+), 13 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index d01aae62ba..ff95dd416e 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1812,11 +1812,7 @@ and fmt_infix_op_args c ~parens xexp op_args = hovbox 2 (fmt_expression c ~parens ~box:false ~pro xarg) else match xarg.ast.pexp_desc with - | Pexp_function _ -> - let pro = pro $ fmt_if parens (str "(") in - hvbox 0 - ( fmt_expression c ~pro ~parens:false xarg - $ fmt_if parens (str ")") ) + | Pexp_function _ -> hvbox 0 (fmt_expression c ~pro ~parens xarg) | _ -> hvbox 0 ( pro @@ -3113,7 +3109,7 @@ and fmt_class_field c {ast= cf; _} = (fun k -> fmt_cmts_before $ hvbox 0 ~name:"clf" - (hvbox 0 (doc_before $ k $ fmt_atrs $ doc_after) $ fmt_cmts_after)) + (hvbox 0 (doc_before $ k $ fmt_atrs $ doc_after) $ fmt_cmts_after) ) @@ match cf.pcf_desc with | Pcf_inherit (override, cl, parent) -> @@ -3173,7 +3169,7 @@ and fmt_class_type_field c {ast= cf; _} = fmt_cmts_before $ hvbox 0 ~name:"ctf" ( hvbox 0 (doc_before $ hvbox 0 k $ fmt_atrs $ doc_after) - $ fmt_cmts_after )) + $ fmt_cmts_after ) ) @@ match cf.pctf_desc with | Pctf_inherit ct -> @@ -4386,7 +4382,7 @@ and fmt_structure_item c ~last:last_item ~semisemi {ctx= parent_ctx; ast= si} (fun k -> fmt_cmts_before $ hvbox 0 ~name:"stri" - (box_semisemi c ~parent_ctx semisemi (k $ fmt_cmts_after))) + (box_semisemi c ~parent_ctx semisemi (k $ fmt_cmts_after)) ) @@ match si.pstr_desc with | Pstr_attribute attr -> fmt_floating_attributes_and_docstrings c [attr] diff --git a/lib/Params.ml b/lib/Params.ml index 601c2d1874..e8860c1eea 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -274,8 +274,7 @@ module Exp = struct | _ -> false let indent_function (c : Conf.t) ~ctx ~ctx0 ~parens = - if ctx_is_rhs_of_infix ~ctx0 ~ctx then - if ocp c then (* Assume parentheses will be outputed *) 1 else 0 + if ctx_is_rhs_of_infix ~ctx0 ~ctx then if ocp c && parens then 1 else 0 else let extra = if c.fmt_opts.wrap_fun_args.v then 0 else 2 in if Poly.equal c.fmt_opts.function_indent_nested.v `Always then diff --git a/test/passing/tests/fun_decl.ml b/test/passing/tests/fun_decl.ml index 6f31002813..73a701e4a3 100644 --- a/test/passing/tests/fun_decl.ml +++ b/test/passing/tests/fun_decl.ml @@ -106,5 +106,5 @@ let space_break = let _ = (fun k -> let _ = 42 in - ()) + () ) @@ () diff --git a/test/passing/tests/infix_bind-break.ml.ref b/test/passing/tests/infix_bind-break.ml.ref index 890020500f..fd74ad8e83 100644 --- a/test/passing/tests/infix_bind-break.ml.ref +++ b/test/passing/tests/infix_bind-break.ml.ref @@ -235,7 +235,7 @@ let default = command##hasPermission#=(fun ctx -> foooooooooooooooooo fooooooooooo) ; command##hasPermission#=(fun ctx -> foooooooooooooooooo fooooooooooo foooooo fooooooooo - foooooooooo) ; + foooooooooo ) ; foo let _ = ( let* ) x (fun y -> z) diff --git a/test/passing/tests/infix_bind-fit_or_vertical-break.ml.ref b/test/passing/tests/infix_bind-fit_or_vertical-break.ml.ref index bb81ae2d83..7037020d0e 100644 --- a/test/passing/tests/infix_bind-fit_or_vertical-break.ml.ref +++ b/test/passing/tests/infix_bind-fit_or_vertical-break.ml.ref @@ -240,7 +240,7 @@ let default = command##hasPermission#=(fun ctx -> foooooooooooooooooo fooooooooooo) ; command##hasPermission#=(fun ctx -> foooooooooooooooooo fooooooooooo foooooo fooooooooo - foooooooooo) ; + foooooooooo ) ; foo let _ = ( let* ) x (fun y -> z) diff --git a/test/passing/tests/js_source.ml b/test/passing/tests/js_source.ml index 05e8188b17..6da8328149 100644 --- a/test/passing/tests/js_source.ml +++ b/test/passing/tests/js_source.ml @@ -8212,3 +8212,21 @@ let _ = | `Fooooooooooooooooooooooooooooooooooooooo -> 1 | `Baaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaar -> 2) ;; + +let _ = + match () with + | _ -> + f + >>= (function + | `Fooooooooooooooooooooooooooooooooooooooo -> 1 + | `Baaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaar -> 2) + >>= foo +;; + +let exists t key = + S.Tree.kind t.tree (path key) + >|= function + | Some `Contents -> Ok (Some `Value) + | Some `Node -> Ok (Some `Dictionary) + | None -> Ok None +;; diff --git a/test/passing/tests/js_source.ml.ocp b/test/passing/tests/js_source.ml.ocp index 6a614119c0..8c97ec47e8 100644 --- a/test/passing/tests/js_source.ml.ocp +++ b/test/passing/tests/js_source.ml.ocp @@ -10501,3 +10501,21 @@ let _ = | `Fooooooooooooooooooooooooooooooooooooooo -> 1 | `Baaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaar -> 2) ;; + +let _ = + match () with + | _ -> + f + >>= (function + | `Fooooooooooooooooooooooooooooooooooooooo -> 1 + | `Baaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaar -> 2) + >>= foo +;; + +let exists t key = + S.Tree.kind t.tree (path key) + >|= function + | Some `Contents -> Ok (Some `Value) + | Some `Node -> Ok (Some `Dictionary) + | None -> Ok None +;; diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index a8f9a23aa5..2103a382fb 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -10501,3 +10501,21 @@ let _ = | `Fooooooooooooooooooooooooooooooooooooooo -> 1 | `Baaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaar -> 2) ;; + +let _ = + match () with + | _ -> + f + >>= (function + | `Fooooooooooooooooooooooooooooooooooooooo -> 1 + | `Baaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaar -> 2) + >>= foo +;; + +let exists t key = + S.Tree.kind t.tree (path key) + >|= function + | Some `Contents -> Ok (Some `Value) + | Some `Node -> Ok (Some `Dictionary) + | None -> Ok None +;; From 1a30c467a70ecc210fdb185f2c0c7bb1ba405691 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 14 Oct 2024 11:51:11 +0200 Subject: [PATCH 142/146] Adjust indentation of 'let in fun' --- lib/Params.ml | 4 ++-- test/passing/tests/fun_decl.ml | 7 +++++++ 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/lib/Params.ml b/lib/Params.ml index e8860c1eea..4aeca606fa 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -309,8 +309,8 @@ module Exp = struct let box_fun_decl ~ctx0 c k = match ctx0 with | _ when ocp c -> hvbox 2 k - | Str _ -> hovbox 4 k - | Clf _ -> hovbox 4 k + | Str _ | Lb _ | Clf _ + | Exp {pexp_desc=Pexp_let _;_} -> hovbox 4 k | _ -> hvbox 2 k end diff --git a/test/passing/tests/fun_decl.ml b/test/passing/tests/fun_decl.ml index 73a701e4a3..f77b32c404 100644 --- a/test/passing/tests/fun_decl.ml +++ b/test/passing/tests/fun_decl.ml @@ -108,3 +108,10 @@ let _ = let _ = 42 in () ) @@ () + +let _ = + let _ = () in + fun (context : Context.t) + ~(local_bins : origin Appendable_list.t Filename.Map.t Memo.Lazy.t) -> + let _ = () in + () From d421d8dd4ca2415dcd5fa41318e7d5492f790d6f Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 14 Oct 2024 16:54:33 +0200 Subject: [PATCH 143/146] Update TODO.ml --- TODO.md | 38 -------------------------------------- 1 file changed, 38 deletions(-) diff --git a/TODO.md b/TODO.md index 4a8434f407..627e26d8b0 100644 --- a/TODO.md +++ b/TODO.md @@ -1,41 +1,3 @@ ## Conventional profile -Argument-list indentation at toplevel - -``` -let create = - let drop_suffix name = - if Sys.win32 - then Option.value ~default:name (String.drop_suffix name ~suffix:".exe") - else name - in - fun (context : Context.t) - ~(local_bins : origin Appendable_list.t Filename.Map.t Memo.Lazy.t) -> - let local_bins = - Memo.lazy_ (fun () -> - let+ local_bins = Memo.Lazy.force local_bins in - Filename.Map.to_list_map local_bins ~f:(fun name sources -> - let sources = Appendable_list.to_list sources in - drop_suffix name, Origin sources) - |> Filename.Map.of_list_exn) - in - { context; local_bins } -``` - -Argument-list wrapping at toplevel - -``` -- fun ~dir ~scope ~target_dir ~sctx ~requires_link ~mode -- (mel : Melange_stanzas.Emit.t) -> -+ fun ~dir -+ ~scope -+ ~target_dir -+ ~sctx -+ ~requires_link -+ ~mode -+ (mel : Melange_stanzas.Emit.t) -+ -> - let build_js = build_js ~sctx ~mode ~module_systems:mel.module_systems in -``` - ## Janestreet profile From b80f229253ac131c1ab71400a7689a8e0fbcfb1e Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 14 Oct 2024 16:54:41 +0200 Subject: [PATCH 144/146] fmt --- lib/Params.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/lib/Params.ml b/lib/Params.ml index 4aeca606fa..e59c3ea401 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -309,8 +309,7 @@ module Exp = struct let box_fun_decl ~ctx0 c k = match ctx0 with | _ when ocp c -> hvbox 2 k - | Str _ | Lb _ | Clf _ - | Exp {pexp_desc=Pexp_let _;_} -> hovbox 4 k + | Str _ | Lb _ | Clf _ | Exp {pexp_desc= Pexp_let _; _} -> hovbox 4 k | _ -> hvbox 2 k end From 620702d8273b64ab029104b93a7964d5c164063a Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 14 Oct 2024 17:07:22 +0200 Subject: [PATCH 145/146] Update CHANGES --- CHANGES.md | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index cc47dff279..73f40f236b 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -8,9 +8,10 @@ profile. This started with version 0.26.0. ### Added -- Support OCaml 5.2 syntax (#2519, @Julow) - This includes: - + Local open in types. +- \* Support OCaml 5.2 syntax (#2519, #2544, @Julow, @EmileTrotignon) + This includes local open in types and changed syntax for functions. + This might change the formatting of some functions due to the formatting code + being completely rewritten. - Allow a custom command to be used to run ocamlformat in the emacs plugin (#2577, @gridbugs) ### Changed From 20cb0e6862b6eb629d64c804442bf8c710e4ac2a Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 14 Oct 2024 17:07:38 +0200 Subject: [PATCH 146/146] Remove TODO.ml --- TODO.md | 3 --- 1 file changed, 3 deletions(-) delete mode 100644 TODO.md diff --git a/TODO.md b/TODO.md deleted file mode 100644 index 627e26d8b0..0000000000 --- a/TODO.md +++ /dev/null @@ -1,3 +0,0 @@ -## Conventional profile - -## Janestreet profile