From f396402d5b14d0a64abece33ba6825e6b125d9e9 Mon Sep 17 00:00:00 2001 From: Charlie Gunn Date: Fri, 24 May 2024 15:45:41 -0400 Subject: [PATCH] Parse new local syntax, but ignore when formatting. Signed-off-by: Charlie Gunn Signed-off-by: Thomas Del Vecchio Add tests. Signed-off-by: Thomas Del Vecchio Remove code to recognize ast pattern that no longer exists. Signed-off-by: Thomas Del Vecchio Support modes on arrow types. Signed-off-by: Thomas Del Vecchio Update normalize mapper to prevent bad sugaring. Signed-off-by: Thomas Del Vecchio Fix ast mapper to not drop modes and modalities in various places. Signed-off-by: Thomas Del Vecchio Support modes on value bindings. Signed-off-by: Thomas Del Vecchio Add support for modes in pattern constraints and expression constraints. Signed-off-by: Thomas Del Vecchio Support modalities on record declarations. Signed-off-by: Thomas Del Vecchio Support modalities on value declarations. Signed-off-by: Thomas Del Vecchio Fix test; in [let (pat @ mode) = exp], the mode is actually attached to the value binding, not the pattern. Signed-off-by: Thomas Del Vecchio Add tests for comments. Signed-off-by: Thomas Del Vecchio Fix moving comment in record fields. Signed-off-by: Thomas Del Vecchio Add tests and make minor changes for formatting with line breaks. Signed-off-by: Thomas Del Vecchio Test in conjunction with old syntax. Signed-off-by: Thomas Del Vecchio Fix formatting of tuple patterns where els have modes. Signed-off-by: Thomas Del Vecchio Add labeled tuple pattern tests. Signed-off-by: Thomas Del Vecchio Fix labeled tuple pattern punning with modes. Signed-off-by: Thomas Del Vecchio Fix invalid punning of labeled tuple expressions with modes. Signed-off-by: Thomas Del Vecchio Add tests for attributes. Signed-off-by: Thomas Del Vecchio Fix issue with comments after [@] and [@@]. Signed-off-by: Thomas Del Vecchio Fix modes on let-bound tuple patterns. Signed-off-by: Thomas Del Vecchio Fix parens around aliased patterns with modes Signed-off-by: Thomas Del Vecchio Fix tuple patterns with local exprs. Signed-off-by: Thomas Del Vecchio Fix let class expressions. Signed-off-by: Thomas Del Vecchio Move tests of modes on patterns to failing. Signed-off-by: Thomas Del Vecchio Fix incorrect dependencies in test causing CI failure. Signed-off-by: Thomas Del Vecchio Rework logic for handling comments after types in label declarations. Signed-off-by: Thomas Del Vecchio Extend tests of label declarations. Signed-off-by: Thomas Del Vecchio Add tests for --break-separators=after. Signed-off-by: Thomas Del Vecchio --- lib/Ast.ml | 85 ++- lib/Exposed.ml | 13 +- lib/Extended_ast.ml | 20 +- lib/Fmt_ast.ml | 177 ++++-- lib/Normalize_extended_ast.ml | 5 +- lib/Sugar.ml | 80 +-- lib/Sugar.mli | 3 +- test/cli/debug.t | 24 + test/failing/dune.inc | 13 + test/failing/tests/modes_on_patterns.ml | 191 +++++++ .../tests/modes_on_patterns.ml.broken-ref | 9 + test/passing/dune.inc | 184 ++++++- test/passing/tests/local.ml.js-ref | 22 +- test/passing/tests/local.ml.ref | 22 +- .../passing/tests/modes-ocaml_version.ml.opts | 1 + test/passing/tests/modes-ocaml_version.ml.ref | 471 ++++++++++++++++ .../tests/modes-ocaml_version.ml.why-no-js | 1 + test/passing/tests/modes.ml | 519 ++++++++++++++++++ test/passing/tests/modes.ml.js-ref | 519 ++++++++++++++++++ test/passing/tests/modes.ml.ref | 471 ++++++++++++++++ test/passing/tests/modes_attrs.ml | 68 +++ test/passing/tests/modes_attrs.ml.js-ref | 68 +++ test/passing/tests/modes_attrs.ml.ref | 102 ++++ .../modes_cmts-break_separators_after.ml.opts | 1 + .../modes_cmts-break_separators_after.ml.ref | 377 +++++++++++++ ...s_cmts-break_separators_after.ml.why-no-js | 1 + test/passing/tests/modes_cmts.ml | 212 +++++++ test/passing/tests/modes_cmts.ml.js-ref | 315 +++++++++++ test/passing/tests/modes_cmts.ml.ref | 377 +++++++++++++ test/passing/tests/modes_cmts_move.ml | 20 + test/passing/tests/modes_cmts_move.ml.js-ref | 20 + test/passing/tests/modes_cmts_move.ml.ref | 29 + test/passing/tests/print_config.ml.deps | 1 + vendor/parser-extended/ast_helper.ml | 24 +- vendor/parser-extended/ast_mapper.ml | 50 +- vendor/parser-extended/lexer.mll | 2 + vendor/parser-extended/parser.mly | 374 +++++++++---- vendor/parser-extended/parsetree.mli | 35 +- vendor/parser-extended/printast.ml | 48 +- vendor/parser-standard/lexer.mll | 2 + 40 files changed, 4636 insertions(+), 320 deletions(-) create mode 100644 test/failing/tests/modes_on_patterns.ml create mode 100644 test/failing/tests/modes_on_patterns.ml.broken-ref create mode 100644 test/passing/tests/modes-ocaml_version.ml.opts create mode 100644 test/passing/tests/modes-ocaml_version.ml.ref create mode 100644 test/passing/tests/modes-ocaml_version.ml.why-no-js create mode 100644 test/passing/tests/modes.ml create mode 100644 test/passing/tests/modes.ml.js-ref create mode 100644 test/passing/tests/modes.ml.ref create mode 100644 test/passing/tests/modes_attrs.ml create mode 100644 test/passing/tests/modes_attrs.ml.js-ref create mode 100644 test/passing/tests/modes_attrs.ml.ref create mode 100644 test/passing/tests/modes_cmts-break_separators_after.ml.opts create mode 100644 test/passing/tests/modes_cmts-break_separators_after.ml.ref create mode 100644 test/passing/tests/modes_cmts-break_separators_after.ml.why-no-js create mode 100644 test/passing/tests/modes_cmts.ml create mode 100644 test/passing/tests/modes_cmts.ml.js-ref create mode 100644 test/passing/tests/modes_cmts.ml.ref create mode 100644 test/passing/tests/modes_cmts_move.ml create mode 100644 test/passing/tests/modes_cmts_move.ml.js-ref create mode 100644 test/passing/tests/modes_cmts_move.ml.ref diff --git a/lib/Ast.ml b/lib/Ast.ml index 1a091a404f..aede9e264b 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -73,8 +73,8 @@ type cls = Let_match | Match | Non_apply | Sequence | Then | ThenElse module Token = struct let is_infix = function - | Parser.AMPERAMPER | AMPERSAND | ANDOP _ | BAR | BARBAR | COLON - |COLONCOLON | COLONEQUAL | DOTDOT | DOTOP _ | EQUAL | GREATER + | Parser.AMPERAMPER | AMPERSAND | ANDOP _ | AT | ATAT | BAR | BARBAR + |COLON | COLONCOLON | COLONEQUAL | DOTDOT | DOTOP _ | EQUAL | GREATER |HASHOP _ | INFIXOP0 _ | INFIXOP1 _ | INFIXOP2 _ | INFIXOP3 _ |INFIXOP4 _ | LESS | LESSMINUS | LETOP _ | MINUS | MINUSDOT |MINUSGREATER | PERCENT | PLUS | PLUSDOT | PLUSEQ | SLASH | STAR -> @@ -929,7 +929,7 @@ end = struct let fst_f (tI, _) = typ == tI in let snd_f (_, tI) = typ == tI in let check_cstr = function - | Pcstr_tuple t1N -> List.exists t1N ~f + | Pcstr_tuple t1N -> List.exists t1N ~f:(fun carg -> f carg.pca_type) | Pcstr_record (_, ld1N) -> List.exists ld1N ~f:(fun {pld_type; _} -> typ == pld_type) in @@ -974,7 +974,7 @@ end = struct | Ptyp_extension _ -> () | Ptyp_any | Ptyp_var _ -> assert false | Ptyp_alias (t1, _) | Ptyp_poly (_, t1) -> assert (typ == t1) - | Ptyp_arrow (t, t2) -> + | Ptyp_arrow (t, t2, _) -> assert (List.exists t ~f:(fun x -> typ == x.pap_type) || typ == t2) | Ptyp_tuple t1N | Ptyp_unboxed_tuple t1N -> assert (List.exists t1N ~f:(fun (_, t) -> f t)) @@ -1016,7 +1016,7 @@ end = struct | Pcty_signature {pcsig_self; _} -> Option.exists pcsig_self ~f ) | Pat ctx -> ( match ctx.ppat_desc with - | Ppat_constraint (_, t1) -> assert (typ == t1) + | Ppat_constraint (_, Some t1, _) -> assert (typ == t1) | Ppat_extension (_, PTyp t) -> assert (typ == t) | Ppat_unpack (_, Some (_, l)) -> assert (List.exists l ~f:(fun (_, t) -> typ == t)) @@ -1026,7 +1026,7 @@ end = struct | Exp ctx -> ( match ctx.pexp_desc with | Pexp_pack (_, Some (_, it1N)) -> assert (List.exists it1N ~f:snd_f) - | Pexp_constraint (_, t1) + | Pexp_constraint (_, Some t1, _) |Pexp_coerce (_, None, t1) |Pexp_poly (_, Some t1) |Pexp_extension (_, PTyp t1) -> @@ -1101,21 +1101,25 @@ end = struct | Pcf_inherit (_, _, _) -> false | Pcf_val (_, _, Cfk_virtual t) -> typ == t | Pcf_val - (_, _, Cfk_concrete (_, {pexp_desc= Pexp_constraint (_, t); _})) - -> + ( _ + , _ + , Cfk_concrete + (_, {pexp_desc= Pexp_constraint (_, Some t, _); _}) ) -> typ == t | Pcf_val (_, _, Cfk_concrete _) -> false | Pcf_method (_, _, Cfk_virtual t) -> typ == t | Pcf_method - (_, _, Cfk_concrete (_, {pexp_desc= Pexp_constraint (_, t); _})) - -> + ( _ + , _ + , Cfk_concrete + (_, {pexp_desc= Pexp_constraint (_, Some t, _); _}) ) -> typ == t | Pcf_method (_, _, Cfk_concrete (_, {pexp_desc= Pexp_poly (e, topt); _})) -> let rec loop = function | {pexp_desc= Pexp_newtype (_, e); _} -> loop e - | {pexp_desc= Pexp_constraint (_, t); _} -> t == typ + | {pexp_desc= Pexp_constraint (_, Some t, _); _} -> t == typ | {pexp_desc= Pexp_fun (_, e); _} -> loop e | _ -> false in @@ -1306,7 +1310,7 @@ end = struct ppat == pat || match ppat.ppat_desc with - | Ppat_constraint (p, _) -> p == pat + | Ppat_constraint (p, _, _) -> p == pat | _ -> false in let check_bindings l = @@ -1336,7 +1340,7 @@ end = struct assert (List.exists p1N ~f:(fun (_, _, x) -> Option.exists x ~f)) | Ppat_or l -> assert (List.exists ~f:(fun p -> p == pat) l) | Ppat_alias (p1, _) - |Ppat_constraint (p1, _) + |Ppat_constraint (p1, _, _) |Ppat_construct (_, Some (_, p1)) |Ppat_exception p1 |Ppat_lazy p1 @@ -1493,7 +1497,7 @@ end = struct | Pexp_assert e |Pexp_beginend e |Pexp_parens e - |Pexp_constraint (e, _) + |Pexp_constraint (e, _, _) |Pexp_coerce (e, _, _) |Pexp_field (e, _) |Pexp_lazy e @@ -1562,7 +1566,7 @@ end = struct x == exp || match x with - | {pexp_desc= Pexp_constraint (e, _); _} -> loop e + | {pexp_desc= Pexp_constraint (e, _, _); _} -> loop e | _ -> false in loop e @@ -1575,7 +1579,7 @@ end = struct || match x with | {pexp_desc= Pexp_newtype (_, e); _} -> loop e - | {pexp_desc= Pexp_constraint (e, _); _} -> loop e + | {pexp_desc= Pexp_constraint (e, _, _); _} -> loop e | {pexp_desc= Pexp_fun (_, e); _} -> loop e | _ -> false in @@ -1642,12 +1646,13 @@ end = struct let open Prec in let open Assoc in let is_tuple_lvl1_in_constructor ty = function - | {pcd_args= Pcstr_tuple t1N; _} -> List.exists t1N ~f:(phys_equal ty) + | {pcd_args= Pcstr_tuple t1N; _} -> + List.exists t1N ~f:(fun carg -> carg.pca_type |> phys_equal ty) | _ -> false in let is_tuple_lvl1_in_ext_constructor ty = function | {pext_kind= Pext_decl (_, Pcstr_tuple t1N, _); _} -> - List.exists t1N ~f:(phys_equal ty) + List.exists t1N ~f:(fun carg -> carg.pca_type |> phys_equal ty) | _ -> false in let constructor_cxt_prec_of_inner = function @@ -1677,7 +1682,7 @@ end = struct | {ctx= Str _; ast= Typ _; _} -> None | {ctx= Typ {ptyp_desc; _}; ast= Typ typ; _} -> ( match ptyp_desc with - | Ptyp_arrow (t, _) -> + | Ptyp_arrow (t, _, _) -> let assoc = if List.exists t ~f:(fun x -> x.pap_type == typ) then Left else Right @@ -1935,7 +1940,9 @@ end = struct ; ctx= Td {ptype_kind= Ptype_variant l; _} } when List.exists l ~f:(fun c -> match c.pcd_args with - | Pcstr_tuple l -> List.exists l ~f:(phys_equal typ) + | Pcstr_tuple l -> + List.exists l ~f:(fun carg -> + carg.pca_type |> phys_equal typ ) | _ -> false ) -> true | { ast= {ptyp_desc= Ptyp_alias _ | Ptyp_arrow _ | Ptyp_tuple _; _} @@ -1953,7 +1960,7 @@ end = struct | {ast= {ptyp_desc= Ptyp_var (_, l); _}; ctx= _} when Option.is_some l -> true | { ast= {ptyp_desc= Ptyp_tuple ((Some _, _) :: _); _} - ; ctx= Typ {ptyp_desc= Ptyp_arrow (args, _); _} } + ; ctx= Typ {ptyp_desc= Ptyp_arrow (args, _, _); _} } when List.exists args ~f:(fun arg -> arg.pap_type == typ) -> true | _ -> ( @@ -2017,20 +2024,40 @@ end = struct | _ -> true ) | Fp {pparam_desc= Pparam_val (_, _, _, _); _}, Ppat_cons _ -> true | Pat {ppat_desc= Ppat_construct _; _}, Ppat_cons _ -> true - | Fp _, Ppat_constraint (_, {ptyp_desc= Ptyp_poly _; _}) -> true - | _, Ppat_constraint (_, {ptyp_desc= Ptyp_poly _; _}) -> false + | Fp _, Ppat_constraint (_, Some {ptyp_desc= Ptyp_poly _; _}, _) -> true + | _, Ppat_constraint (_, Some {ptyp_desc= Ptyp_poly _; _}, _) -> false | ( Exp {pexp_desc= Pexp_letop _; _} , ( Ppat_construct (_, Some _) | Ppat_cons _ | Ppat_variant (_, Some _) | Ppat_or _ | Ppat_alias _ - | Ppat_constraint ({ppat_desc= Ppat_any; _}, _) ) ) -> + | Ppat_constraint ({ppat_desc= Ppat_any; _}, _, _) + | Ppat_constraint (_, _, _ :: _) ) ) -> true - | Lb _, Ppat_constraint ({ppat_desc= Ppat_any; _}, _) -> true - | Lb _, Ppat_constraint ({ppat_desc= Ppat_tuple _; _}, _) -> false + | Lb _, Ppat_constraint ({ppat_desc= Ppat_any; _}, _, _) -> true + | Lb _, Ppat_constraint ({ppat_desc= Ppat_tuple _; _}, _, _) -> false | ( Exp {pexp_desc= Pexp_letop _; _} - , Ppat_constraint ({ppat_desc= Ppat_tuple _; _}, _) ) -> + , Ppat_constraint ({ppat_desc= Ppat_tuple _; _}, _, _) ) -> false + (* Modes on elements of let-bound tuple patterns require the tuple to be + parenthesized *) + | (Str _ | Exp _ | Cl _), Ppat_tuple (els, _) + when List.exists els ~f:(function + | _, {ppat_desc= Ppat_constraint (_, None, _ :: _); _} -> true + | _ -> false ) -> + true + (* Modes on let-bound tuple patterns require the tuple to be + parenthesized *) + | ( ( Str {pstr_desc= Pstr_value bindings; _} + | Exp {pexp_desc= Pexp_let (bindings, _); _} + | Cl {pcl_desc= Pcl_let (bindings, _); _} ) + , Ppat_tuple _ ) + when let binding = + List.find_exn bindings.pvbs_bindings ~f:(fun binding -> + binding.pvb_pat == pat ) + in + not (List.is_empty binding.pvb_modes) -> + true | _, Ppat_constraint _ |_, Ppat_unpack _ |( Pat @@ -2329,7 +2356,7 @@ end = struct |Pexp_open (_, e) |Pexp_fun (_, e) |Pexp_newtype (_, e) - |Pexp_constraint (e, _) + |Pexp_constraint (e, _, _) |Pexp_coerce (e, _, _) when e == exp -> false @@ -2433,7 +2460,7 @@ end = struct | Exp {pexp_desc= Pexp_indexop_access {pia_kind= Builtin idx; _}; _}, _ when idx == exp -> false - | ( Exp {pexp_desc= Pexp_constraint (e, _) | Pexp_coerce (e, _, _); _} + | ( Exp {pexp_desc= Pexp_constraint (e, _, _) | Pexp_coerce (e, _, _); _} , {pexp_desc= Pexp_tuple _ | Pexp_match _ | Pexp_try _; _} ) when e == exp && !ocp_indent_compat -> true diff --git a/lib/Exposed.ml b/lib/Exposed.ml index 48078e9f33..195588a3f7 100644 --- a/lib/Exposed.ml +++ b/lib/Exposed.ml @@ -14,7 +14,7 @@ open Extended_ast module Left = struct let rec core_type typ = match typ.ptyp_desc with - | Ptyp_arrow (t :: _, _) -> core_type t.pap_type + | Ptyp_arrow (t :: _, _, _) -> core_type t.pap_type | Ptyp_tuple l -> ( match List.hd_exn l with | Some _, _ -> false @@ -31,7 +31,7 @@ module Right = struct | {ptyp_attributes= _ :: _; _} -> false | {ptyp_desc; _} -> ( match ptyp_desc with - | Ptyp_arrow (_, t) -> core_type t + | Ptyp_arrow (_, t, []) -> core_type t | Ptyp_tuple l -> ( match List.last_exn l with | Some _, _ -> false @@ -43,12 +43,17 @@ module Right = struct | Pcstr_record _ -> false | Pcstr_tuple args -> ( match List.last args with - | Some {ptyp_desc= Ptyp_arrow _; _} -> + | Some {pca_modalities= _ :: _; _} -> + (* Modalities are the right-most part of a construct argument: + + type a = A of t * u @@ modality *) + false + | Some {pca_type= {ptyp_desc= Ptyp_arrow _; _}; _} -> (* Arrows are wrapped in parens in this position: type a = A of (t -> <..>) *) false - | Some last -> core_type last + | Some {pca_type; _} -> core_type pca_type | None -> false ) let extension_constructor = function diff --git a/lib/Extended_ast.ml b/lib/Extended_ast.ml index 8d81789f2e..ac4b659717 100644 --- a/lib/Extended_ast.ml +++ b/lib/Extended_ast.ml @@ -80,7 +80,8 @@ module Parse = struct ( { pexp_desc= Pexp_ident {txt= v_txt; _} ; pexp_attributes= [] ; _ } - , t1 ) + , Some t1 + , [] ) ; pexp_attributes= [] ; _ } ) when enable_short_field_annot @@ -94,7 +95,8 @@ module Parse = struct ( { pexp_desc= Pexp_ident {txt= v_txt; _} ; pexp_attributes= [] ; _ } - , t1 ) + , Some t1 + , [] ) ; pexp_attributes= [] ; _ } ) when enable_short_field_annot @@ -147,7 +149,8 @@ module Parse = struct ( { ppat_desc= Ppat_var {txt= v_txt; _} ; ppat_attributes= [] ; _ } - , t ) + , Some t + , [] ) ; ppat_attributes= [] ; _ } ) when enable_short_field_annot @@ -182,7 +185,8 @@ module Parse = struct | { ppat_desc= Ppat_constraint ( {ppat_desc= Ppat_unpack (name, None); ppat_attributes= []; _} - , {ptyp_desc= Ptyp_package pt; ptyp_attributes= []; _} ) + , Some {ptyp_desc= Ptyp_package pt; ptyp_attributes= []; _} + , [] ) ; _ } as p -> {p with ppat_desc= Ppat_unpack (name, Some pt)} | p -> Ast_mapper.default_mapper.pat m p @@ -228,8 +232,12 @@ module Parse = struct ; pexp_attributes= [] ; pexp_loc ; _ } - , {ptyp_desc= Ptyp_package pt; ptyp_attributes= []; ptyp_loc; _} - ) + , Some + { ptyp_desc= Ptyp_package pt + ; ptyp_attributes= [] + ; ptyp_loc + ; _ } + , [] ) ; _ } as p when Migrate_ast.Location.compare_start ptyp_loc pexp_loc > 0 -> (* Match locations to differentiate between the two position for diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index d97fa7806a..bde9e5fb9c 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -586,6 +586,7 @@ let let_binding_can_be_punned ~binding ~parsed_ext = ; lb_pun= _ ; lb_attrs= _ ; lb_local + ; lb_modes ; lb_loc= _ } : Sugar.Let_binding.t ) = binding @@ -597,7 +598,8 @@ let let_binding_can_be_punned ~binding ~parsed_ext = , lb_typ , lb_args , (lb_pat.ast.ppat_attributes, lb_exp.ast.pexp_attributes) - , lb_local ) + , lb_local + , lb_modes ) with | ( (* Binding must be inside an extension node (we do not pun operators) *) Some _ @@ -612,7 +614,9 @@ let let_binding_can_be_punned ~binding ~parsed_ext = , (* There must be no attrs on either side *) ([], []) , (* This must not be a [let local_] binding *) - false ) + false + , (* There cannot be any mode annotations *) + [] ) when (* LHS and RHS variable names must be the same *) String.equal left right -> true @@ -789,7 +793,7 @@ and fmt_type_cstr c ?constraint_ctx xtyp = and type_constr_and_body c xbody = let body = xbody.ast in match xbody.ast.pexp_desc with - | Pexp_constraint (exp, typ) -> + | Pexp_constraint (exp, Some typ, []) -> Cmts.relocate c.cmts ~src:body.pexp_loc ~before:exp.pexp_loc ~after:exp.pexp_loc ; let typ_ctx = Exp body in @@ -805,10 +809,26 @@ and type_constr_and_body c xbody = , sub_exp ~ctx:exp_ctx exp ) | _ -> (None, xbody) +and fmt_modalities c modalities = + let fmt_modality {txt= Modality modality; loc} = + Cmts.fmt c loc (str modality) + in + if List.is_empty modalities then noop + else fmt "@ @@@@ " $ list modalities " " fmt_modality + +and fmt_modes ~ats c modes = + let fmt_mode {txt= Mode mode; loc} = Cmts.fmt c loc (str mode) in + if List.is_empty modes then noop + else + let fmt_ats = + match ats with `One -> fmt "@ @@ " | `Two -> fmt "@ @@@@ " + in + fmt_ats $ list modes " " fmt_mode + (* Jane street: This is used to print both arrow param types and arrow return types. The ~return parameter distinguishes. *) and fmt_arrow_param ~return c ctx - ({pap_label= lI; pap_loc= locI; pap_type= tI}, localI) = + ({pap_label= lI; pap_loc= locI; pap_type= tI; pap_modes= mI}, localI) = let arg_label lbl = match lbl with | Nolabel -> if localI then Some (str "local_ ") else None @@ -818,15 +838,14 @@ and fmt_arrow_param ~return c ctx in let xtI = sub_typ ~ctx tI in (* Jane Street: as a special case, labeled tuple types in function returns - need parens if the return is [local_] AND the first element has a label. - We _should_ put this logic in [parenze_typ] or a similar place, but we - can't because of the horrible hack where the attribute encoding [local_] - is actually removed from the type before printing it. - - Note that when [unique_] and [once_] arrive, similar logic will be - needed. *) + need parens if the return is [local_] or has modes AND the first element + has a label. We _should_ put this logic in [parenze_typ] or a similar + place, but we can't because of the horrible hack where the attribute + encoding [local_] is actually removed from the type before printing + it. *) let labeled_tuple_ret_parens = - return && localI + return + && (localI || not (List.is_empty mI)) && match tI.ptyp_desc with | Ptyp_tuple ((Some _, _) :: _) -> true @@ -840,7 +859,8 @@ and fmt_arrow_param ~return c ctx | None -> core_type | Some f -> hovbox 2 (f $ core_type) in - hvbox 0 (Cmts.fmt_before c locI $ arg) + let modes = fmt_modes c mI ~ats:`One in + hvbox 0 (Cmts.fmt_before c locI $ arg $ modes) (** Format [Ptyp_arrow]. [indent] can be used to override the indentation added for the break-separators option. [parent_has_parens] is used to @@ -941,11 +961,11 @@ and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx $ fmt "@ as@ " $ fmt_type_var_with_parenze ~have_tick:true c str ) ) | Ptyp_any -> str "_" - | Ptyp_arrow (args, ret_typ) -> + | Ptyp_arrow (args, ret_typ, modes) -> Cmts.relocate c.cmts ~src:ptyp_loc ~before:(List.hd_exn args).pap_type.ptyp_loc ~after:ret_typ.ptyp_loc ; let args, ret_typ, ctx = - Sugar.decompose_arrow c.cmts ctx args ret_typ + Sugar.decompose_arrow c.cmts ctx args (ret_typ, modes) in let indent = match pro with @@ -1212,7 +1232,7 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false) in let punned_with_constraint = match pat.ast.ppat_desc with - | Ppat_constraint ({ppat_desc= Ppat_var var; _}, _) -> + | Ppat_constraint ({ppat_desc= Ppat_var var; _}, _, []) -> String.equal var.txt lbl.txt && List.is_empty pat.ast.ppat_attributes | _ -> false @@ -1385,14 +1405,22 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false) $ fmt_or_k nested (fits_breaks (if parens then ")" else "") "") (fits_breaks (if parens then ")" else "") ~hint:(1, 2) ")") ) - | Ppat_constraint (pat, typ) -> + | Ppat_constraint (_, None, []) -> assert false + | Ppat_constraint (pat, maybe_typ, modes) -> + let fmt_typ = + match maybe_typ with + | None -> noop + | Some typ -> + ( match ctx0 with + | Exp {pexp_desc= Pexp_let _; _} -> fmt "@ : " + | _ -> fmt " :@ " ) + $ fmt_core_type c (sub_typ ~ctx typ) + in + let ats = if Option.is_some maybe_typ then `Two else `One in hvbox 2 (Params.parens_if parens c.conf ( fmt_pattern c (sub_pat ~ctx pat) - $ ( match ctx0 with - | Exp {pexp_desc= Pexp_let _; _} -> fmt "@ : " - | _ -> fmt " :@ " ) - $ fmt_core_type c (sub_typ ~ctx typ) ) ) + $ fmt_typ $ fmt_modes c ~ats modes ) ) | Ppat_type lid -> fmt_longident_loc c ~pre:"#" lid | Ppat_lazy pat -> cbox 2 @@ -1469,6 +1497,7 @@ and fmt_fun_args c args = ( { ppat_desc= Ppat_var {txt; loc= _} ; ppat_attributes= [] ; _ } + , _ , _ ) ) ; ppat_attributes= [] ; _ } as pat ) ) @@ -1527,7 +1556,7 @@ and fmt_fun_args c args = , Optional l , Some exp , ( { ppat_desc= - Ppat_constraint ({ppat_desc= Ppat_var {txt; loc= _}; _}, _) + Ppat_constraint ({ppat_desc= Ppat_var {txt; loc= _}; _}, _, _) ; ppat_attributes= [] ; _ } as pat ) ) when String.equal l.txt txt -> @@ -1693,7 +1722,8 @@ and fmt_label_arg ?(box = true) ?eol c (lbl, ({ast= arg; _} as xarg)) = when String.equal l.txt i && List.is_empty arg.pexp_attributes -> Cmts.fmt c loc @@ Cmts.fmt c ?eol arg.pexp_loc @@ fmt_label lbl "" | ( (Labelled l | Optional l) - , Pexp_constraint ({pexp_desc= Pexp_ident {txt= Lident i; _}; _}, _) ) + , Pexp_constraint ({pexp_desc= Pexp_ident {txt= Lident i; _}; _}, _, []) + ) when String.equal l.txt i && List.is_empty arg.pexp_attributes && Ocaml_version.( @@ -2430,7 +2460,8 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens (parens || not (List.is_empty pexp_attributes)) c.conf (fmt_constant c const $ fmt_atrs) - | Pexp_constraint (e, t) -> + | Pexp_constraint (_, None, _) -> assert false + | Pexp_constraint (e, Some t, modes) -> pro $ hvbox (Params.Indent.exp_constraint c.conf) @@ -2438,7 +2469,8 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens ( wrap_fits_breaks ~space:false c.conf "(" ")" ( fmt_expression c (sub_exp ~ctx e) $ fmt "@ : " - $ fmt_core_type c (sub_typ ~ctx t) ) + $ fmt_core_type c (sub_typ ~ctx t) + $ fmt_modes c ~ats:`Two modes ) $ fmt_atrs ) ) | Pexp_construct ({txt= Lident (("()" | "[]") as txt); loc}, None) -> let opn = char txt.[0] and cls = char txt.[1] in @@ -2889,7 +2921,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens let punned_with_constraint = match exp.ast.pexp_desc with | Pexp_constraint - ({pexp_desc= Pexp_ident {txt= Lident var; _}; _}, _) -> + ({pexp_desc= Pexp_ident {txt= Lident var; _}; _}, _, []) -> String.equal var lbl.txt && List.is_empty exp.ast.pexp_attributes | _ -> false @@ -3349,7 +3381,7 @@ and fmt_class_field_kind c ctx = function ; _ } ) -> ( let rec cleanup names e args' = match (e, args') with - | {pexp_desc= Pexp_constraint (e, t); _}, [] -> + | {pexp_desc= Pexp_constraint (e, Some t, []); _}, [] -> Some (List.rev names, t, e) | ( {pexp_desc= Pexp_newtype ((({txt; _}, _) as newtyp), body); _} , ({txt= txt'; _}, _) :: args ) @@ -3384,7 +3416,7 @@ and fmt_class_field_kind c ctx = function in let ty, e = match (xbody.ast, poly) with - | {pexp_desc= Pexp_constraint (e, t); pexp_loc; _}, None -> + | {pexp_desc= Pexp_constraint (e, Some t, []); pexp_loc; _}, None -> Cmts.relocate c.cmts ~src:pexp_loc ~before:t.ptyp_loc ~after:e.pexp_loc ; (Some t, sub_exp ~ctx e) @@ -3402,7 +3434,7 @@ and fmt_class_field_kind c ctx = function | Cfk_concrete (_, e) -> let ty, e = match e with - | {pexp_desc= Pexp_constraint (e, t); _} -> (Some t, e) + | {pexp_desc= Pexp_constraint (e, Some t, []); _} -> (Some t, e) | _ -> (None, e) in ( opt ty (fun t -> fmt "@ : " $ fmt_core_type c (sub_typ ~ctx t)) @@ -3547,8 +3579,12 @@ and fmt_case c ctx ~first ~last case = $ p.close_paren_branch ) ) and fmt_value_description ?ext c ctx vd = - let {pval_name= {txt; loc}; pval_type; pval_prim; pval_attributes; pval_loc} - = + let { pval_name= {txt; loc} + ; pval_type + ; pval_prim + ; pval_attributes + ; pval_loc + ; pval_modalities } = vd in update_config_maybe_disabled c pval_loc pval_attributes @@ -3580,6 +3616,7 @@ and fmt_value_description ?ext c ctx vd = ( c.conf.fmt_opts.ocp_indent_compat.v && is_arrow_or_poly pval_type ) ) ~pro_space:true (sub_typ ~ctx pval_type) + $ fmt_modalities c pval_modalities $ fmt_if (not (List.is_empty pval_prim)) "@ = " $ hvbox_if (List.length pval_prim > 1) 0 @@ list pval_prim "@;" fmt_val_prim ) @@ -3723,11 +3760,23 @@ and fmt_type_declaration c ?ext ?(pre = "") ?name ?(eq = "=") {ast= decl; _} $ doc_after ) and fmt_label_declaration c ctx ?(last = false) decl = - let {pld_mutable; pld_name; pld_type; pld_loc; pld_attributes} = decl in + let { pld_mutable + ; pld_name + ; pld_type + ; pld_loc + ; pld_attributes + ; pld_modalities } = + decl + in update_config_maybe_disabled c pld_loc pld_attributes @@ fun c -> let doc, atrs = doc_atrs pld_attributes in - let cmt_after_type = Cmts.fmt_after c pld_type.ptyp_loc in + let cmt_after_type = + Cmts.fmt_after c + ( match List.last pld_modalities with + | None -> pld_type.ptyp_loc + | Some last -> last.loc ) + in let field_loose = match c.conf.fmt_opts.field_space.v with | `Loose -> true @@ -3755,14 +3804,19 @@ and fmt_label_declaration c ctx ?(last = false) decl = ( hvbox 3 ( hvbox 4 ( hvbox 2 - ( hovbox 2 - ( fmt_mutable_flag ~pro:noop ~epi:(fmt "@ ") c - pld_mutable - $ fmt_if (Option.is_some global_attr_opt) "global_ " - $ fmt_str_loc c pld_name $ fmt_if field_loose " " - $ fmt ":" ) - $ fmt "@ " - $ fmt_core_type c (sub_typ ~ctx pld_type) + ( hvbox 0 + ( hvbox 2 + ( hovbox 2 + ( fmt_mutable_flag ~pro:noop ~epi:(fmt "@ ") + c pld_mutable + $ fmt_if + (Option.is_some global_attr_opt) + "global_ " + $ fmt_str_loc c pld_name + $ fmt_if field_loose " " $ fmt ":" ) + $ fmt "@ " + $ fmt_core_type c (sub_typ ~ctx pld_type) ) + $ fmt_modalities c pld_modalities ) $ fmt_semicolon ) $ cmt_after_type ) $ fmt_attributes c ~pre:(Break (1, 1)) atrs ) @@ -3806,25 +3860,27 @@ and fmt_constructor_declaration c ctx ~first ~last:_ cstr_decl = and fmt_core_type_gf c ctx typ = let {ptyp_attributes; _} = typ in let global_attr_opt, _ = split_global_flags_from_attrs ptyp_attributes in - ( match global_attr_opt with - | Some attr -> - Cmts.relocate_all_to_after c.cmts ~src:attr.attr_loc - ~after:typ.ptyp_loc - | None -> () ) ; fmt_if (Option.is_some global_attr_opt) "global_ " $ fmt_core_type c (sub_typ ~ctx typ) and fmt_constructor_arguments ?vars c ctx ~pre = function - | Pcstr_tuple typs -> + | Pcstr_tuple cargs -> let vars = match vars with Some vars -> fmt "@ " $ vars | None -> noop - and typs = - match typs with + and cargs = + match cargs with | [] -> noop | _ :: _ -> - fmt "@ " $ hvbox 0 (list typs "@ * " (fmt_core_type_gf c ctx)) + fmt "@ " + $ hvbox 0 + (list cargs "@ * " + (fun {pca_type; pca_loc; pca_modalities} -> + Cmts.fmt c pca_loc + @@ hvbox 0 + ( fmt_core_type_gf c ctx pca_type + $ fmt_modalities c pca_modalities ) ) ) in - pre $ vars $ typs + pre $ vars $ cargs | Pcstr_record (loc, lds) -> let vars = match vars with Some vars -> fmt "@ " $ vars | None -> noop @@ -4859,6 +4915,7 @@ and fmt_value_binding c ~rec_flag ?ext ?parsed_ext ?in_ ?epi ; lb_exp ; lb_attrs ; lb_local + ; lb_modes ; lb_loc ; lb_pun= punned_in_source } as binding ) = update_config_maybe_disabled c lb_loc lb_attrs @@ -4918,6 +4975,9 @@ and fmt_value_binding c ~rec_flag ?ext ?parsed_ext ?in_ ?epi , Cmts.Toplevel.fmt_before c lb_loc , Cmts.Toplevel.fmt_after c lb_loc ) in + let has_args = not (List.is_empty lb_args) in + let has_cstr = Option.is_some lb_typ in + let has_modes = not (List.is_empty lb_modes) in fmt_docstring c ~epi:(fmt "@\n") doc1 $ cmts_before $ hvbox 0 @@ -4934,14 +4994,21 @@ and fmt_value_binding c ~rec_flag ?ext ?parsed_ext ?in_ ?epi $ fmt_if rec_flag " rec" $ fmt_if lb_local " local_" $ fmt_or pat_has_cmt "@ " " " - $ fmt_pattern c lb_pat ) - $ fmt_if_k - (not (List.is_empty lb_args)) + $ wrap_if (has_args && has_modes) "(" ")" + ( fmt_pattern c lb_pat + $ fmt_if_k + (has_args || not has_cstr) + (fmt_modes c ~ats:`One lb_modes) ) + ) + $ fmt_if_k has_args ( fmt "@ " $ wrap_fun_decl_args c (fmt_fun_args c lb_args) ) $ fmt_newtypes ) - $ fmt_cstr ) + $ fmt_cstr + $ fmt_if_k + ((not has_args) && has_cstr) + (fmt_modes c ~ats:`Two lb_modes) ) $ fmt_if_k (not punned_in_output) (fmt_or_k c.conf.fmt_opts.ocp_indent_compat.v (fits_breaks " =" ~hint:(1000, 0) "=") diff --git a/lib/Normalize_extended_ast.ml b/lib/Normalize_extended_ast.ml index 4632ab3a7c..533e276416 100644 --- a/lib/Normalize_extended_ast.ml +++ b/lib/Normalize_extended_ast.ml @@ -142,9 +142,10 @@ let make_mapper ~ignore_doc_comments ~normalize_doc = let exp = {exp with pexp_loc_stack= []} in let {pexp_desc; pexp_loc= loc1; pexp_attributes= attrs1; _} = exp in match pexp_desc with - | Pexp_poly ({pexp_desc= Pexp_constraint (e, t); _}, None) -> + | Pexp_poly ({pexp_desc= Pexp_constraint (e, Some t, []); _}, None) -> m.expr m {exp with pexp_desc= Pexp_poly (e, Some t)} - | Pexp_constraint (e, {ptyp_desc= Ptyp_poly ([], _t); _}) -> m.expr m e + | Pexp_constraint (e, Some {ptyp_desc= Ptyp_poly ([], _t); _}, []) -> + m.expr m e | Pexp_sequence ( exp1 , { pexp_desc= Pexp_sequence (exp2, exp3) diff --git a/lib/Sugar.ml b/lib/Sugar.ml index 20e0983a1c..aab59200da 100644 --- a/lib/Sugar.ml +++ b/lib/Sugar.ml @@ -35,7 +35,7 @@ let check_local_attr_and_reloc_cmts cmts attrs loc = this to pass some internal ocamlformat sanity checks. It's not the cleanest solution in a vacuum, but is perhaps the one that will cause the fewest merge conflicts in the future. *) -let decompose_arrow cmts ctx ctl ct2 = +let decompose_arrow cmts ctx ctl (ct2, m2) = let pull_out_local ap = let ptyp_attributes, local = check_local_attr_and_reloc_cmts cmts ap.pap_type.ptyp_attributes @@ -51,11 +51,14 @@ let decompose_arrow cmts ctx ctl ct2 = let ap = { pap_label= Nolabel ; pap_loc= ct2.ptyp_loc - ; pap_type= {ct2 with ptyp_attributes} } + ; pap_type= {ct2 with ptyp_attributes} + ; pap_modes= m2 } in (ap, local) in - let ctx_typ = Ptyp_arrow (List.map ~f:fst args, res_ap.pap_type) in + let ctx_typ = + Ptyp_arrow (List.map ~f:fst args, res_ap.pap_type, res_ap.pap_modes) + in let ctx = match ctx with | Typ cty -> Typ {cty with ptyp_desc= ctx_typ} @@ -275,12 +278,13 @@ module Let_binding = struct ; lb_pun: bool ; lb_attrs: attribute list ; lb_local: bool + ; lb_modes: mode loc list ; lb_loc: Location.t } let split_annot cmts xargs ({ast= body; _} as xbody) = let ctx = Exp body in match body.pexp_desc with - | Pexp_constraint (exp, typ) + | Pexp_constraint (exp, Some typ, []) when Source.type_constraint_is_first typ exp.pexp_loc -> Cmts.relocate cmts ~src:body.pexp_loc ~before:exp.pexp_loc ~after:exp.pexp_loc ; @@ -301,7 +305,7 @@ module Let_binding = struct , sub_exp ~ctx:exp_ctx exp ) (* The type constraint is always printed before the declaration for functions, for other value bindings we preserve its position. *) - | Pexp_constraint (exp, typ) when not (List.is_empty xargs) -> + | Pexp_constraint (exp, Some typ, []) when not (List.is_empty xargs) -> Cmts.relocate cmts ~src:body.pexp_loc ~before:exp.pexp_loc ~after:exp.pexp_loc ; ( xargs @@ -390,8 +394,8 @@ module Let_binding = struct false ) | _ -> false - let maybe_sugar_local cmts ~ctx pvb_pat pvb_expr pvb_is_pun pvb_constraint - = + let maybe_sugar_local cmts ~ctx pvb_pat pvb_modes pvb_expr pvb_is_pun + pvb_constraint = let is_local_pattern, ctx, pvb_pat, pvb_expr = match pvb_expr.pexp_desc with | Pexp_apply @@ -421,13 +425,31 @@ module Let_binding = struct in let pat = {pvb_pat with ppat_attributes= pattrs} in let fake_ctx = - Lb + let pvb = { pvb_pat= pat ; pvb_expr= sbody ; pvb_is_pun ; pvb_attributes= [] ; pvb_loc= Location.none - ; pvb_constraint= None } + ; pvb_constraint= None + ; pvb_modes } + in + match ctx with + | Str ({pstr_desc= Pstr_value pvbs; _} as str) -> + Str + { str with + pstr_desc= Pstr_value {pvbs with pvbs_bindings= [pvb]} } + | Exp ({pexp_desc= Pexp_let (pvbs, body); _} as exp) -> + Exp + { exp with + pexp_desc= + Pexp_let ({pvbs with pvbs_bindings= [pvb]}, body) } + | Cl ({pcl_desc= Pcl_let (pvbs, body); _} as cl) -> + Cl + { cl with + pcl_desc= Pcl_let ({pvbs with pvbs_bindings= [pvb]}, body) + } + | _ -> Lb pvb in (is_local_pattern, fake_ctx, pat, sbody) | _ -> (false, ctx, pvb_pat, pvb_expr) @@ -437,27 +459,10 @@ module Let_binding = struct let type_cstr cmts ~ctx pvb_pat pvb_expr pvb_is_pun pvb_constraint = let is_local_pattern, lb_pat, lb_exp = - maybe_sugar_local cmts ~ctx pvb_pat pvb_expr pvb_is_pun pvb_constraint - in - let ({ast= pat; _} as xpat) = - match (lb_pat.ast.ppat_desc, lb_exp.ast.pexp_desc) with - (* recognize and undo the pattern of code introduced by - ocaml/ocaml@fd0dc6a0fbf73323c37a73ea7e8ffc150059d6ff to fix - https://caml.inria.fr/mantis/view.php?id=7344 *) - | ( Ppat_constraint - ( ({ppat_desc= Ppat_var _; _} as pat) - , {ptyp_desc= Ptyp_poly ([], typ1); _} ) - , Pexp_constraint (_, typ2) ) - when equal_core_type typ1 typ2 -> - Cmts.relocate cmts ~src:lb_pat.ast.ppat_loc ~before:pat.ppat_loc - ~after:pat.ppat_loc ; - sub_pat ~ctx:(Pat lb_pat.ast) pat - | ( Ppat_constraint (_, {ptyp_desc= Ptyp_poly (_, typ1); _}) - , Pexp_coerce (_, _, typ2) ) - when equal_core_type typ1 typ2 -> - sub_pat ~ctx lb_pat.ast - | _ -> sub_pat ~ctx lb_pat.ast + maybe_sugar_local cmts ~ctx pvb_pat [] pvb_expr pvb_is_pun + pvb_constraint in + let ({ast= pat; _} as xpat) = sub_pat ~ctx lb_pat.ast in let pat_is_extension {ppat_desc; _} = match ppat_desc with Ppat_extension _ -> true | _ -> false in @@ -470,7 +475,8 @@ module Let_binding = struct else let xpat = match xpat.ast.ppat_desc with - | Ppat_constraint (p, {ptyp_desc= Ptyp_poly ([], _); _}) -> + | Ppat_constraint (p, Some {ptyp_desc= Ptyp_poly ([], _); _}, []) + -> sub_pat ~ctx:xpat.ctx p | _ -> xpat in @@ -485,10 +491,16 @@ module Let_binding = struct | _ -> false let of_let_binding cmts ~ctx ~first - {pvb_pat; pvb_expr; pvb_constraint; pvb_is_pun; pvb_attributes; pvb_loc} - = + { pvb_pat + ; pvb_expr + ; pvb_constraint + ; pvb_is_pun + ; pvb_attributes + ; pvb_loc + ; pvb_modes } = let islocal, lb_pat, lb_exp = - maybe_sugar_local cmts ~ctx pvb_pat pvb_expr pvb_is_pun pvb_constraint + maybe_sugar_local cmts ~ctx pvb_pat pvb_modes pvb_expr pvb_is_pun + pvb_constraint and lb_typ = pvb_constraint in let lb_args, lb_typ, lb_exp = if should_desugar_args lb_pat lb_typ then @@ -503,6 +515,7 @@ module Let_binding = struct ; lb_pun= pvb_is_pun ; lb_attrs= pvb_attributes ; lb_local= islocal + ; lb_modes= pvb_modes ; lb_loc= pvb_loc } let of_let_bindings cmts ~ctx = @@ -521,5 +534,6 @@ module Let_binding = struct ; lb_pun= bo.pbop_is_pun ; lb_attrs= [] ; lb_local= islocal + ; lb_modes= [] ; lb_loc= bo.pbop_loc } ) end diff --git a/lib/Sugar.mli b/lib/Sugar.mli index 2d3a158c07..61c9580e29 100644 --- a/lib/Sugar.mli +++ b/lib/Sugar.mli @@ -17,7 +17,7 @@ val decompose_arrow : Cmts.t -> Ast.t -> arrow_param list - -> core_type + -> core_type * mode loc list -> (arrow_param * bool) list * (arrow_param * bool) * Ast.t (** [decompose_arrow ctl ct2] returns a list of arrow params, where the last is a dummy param corresponding to ct2 (the return type) and a bool @@ -84,6 +84,7 @@ module Let_binding : sig ; lb_pun: bool ; lb_attrs: attribute list ; lb_local: bool + ; lb_modes: mode loc list ; lb_loc: Location.t } val of_let_binding : diff --git a/test/cli/debug.t b/test/cli/debug.t index d78e677bf0..cd7a54ee1d 100644 --- a/test/cli/debug.t +++ b/test/cli/debug.t @@ -32,6 +32,8 @@ expression (a.ml[4,59+4]..[4,59+7]) Pexp_ident "A.x" (a.ml[4,59+4]..[4,59+7]) ] + modes + [] ] ] @@ -60,6 +62,8 @@ expression (a.ml[4,59+4]..[4,59+7]) Pexp_ident "A.x" (a.ml[4,59+4]..[4,59+7]) ] + modes + [] ] ] @@ -88,6 +92,8 @@ expression (a.ml[2,34+23]..[2,34+26]) Pexp_ident "A.x" (a.ml[2,34+23]..[2,34+26]) ] + modes + [] ] ] @@ -115,6 +121,8 @@ expression (a.ml[2,34+23]..[2,34+26]) Pexp_ident "A.x" (a.ml[2,34+23]..[2,34+26]) ] + modes + [] ] ] @@ -178,9 +186,13 @@ within: (* within unit #2 *) after: (* after unit *) None + modes + [] ] expression (a.ml[6,233+2]..[6,233+3]) Pexp_ident "x" (a.ml[6,233+2]..[6,233+3]) + modes + [] ] ] @@ -231,9 +243,13 @@ within: (* within unit #2 *) after: (* after unit *) None + modes + [] ] expression (a.ml[6,233+2]..[6,233+3]) Pexp_ident "x" (a.ml[6,233+2]..[6,233+3]) + modes + [] ] ] @@ -284,9 +300,13 @@ within: (* within unit #1 *) within: (* within unit #2 *) None + modes + [] ] expression (a.ml[13,265+2]..[13,265+3]) Pexp_ident "x" (a.ml[13,265+2]..[13,265+3]) + modes + [] ] ] @@ -336,9 +356,13 @@ within: (* within unit #1 *) within: (* within unit #2 *) None + modes + [] ] expression (a.ml[13,265+2]..[13,265+3]) Pexp_ident "x" (a.ml[13,265+2]..[13,265+3]) + modes + [] ] ] diff --git a/test/failing/dune.inc b/test/failing/dune.inc index 0f34fe779d..adf1a542b9 100644 --- a/test/failing/dune.inc +++ b/test/failing/dune.inc @@ -233,6 +233,19 @@ (package ocamlformat) (action (diff tests/misc_2019.ml.broken-ref misc_2019.ml.output))) +(rule + (deps tests/.ocamlformat ) + (package ocamlformat) + (action + (with-outputs-to modes_on_patterns.ml.output + (with-accepted-exit-codes 1 + (run %{bin:ocamlformat} %{dep:tests/modes_on_patterns.ml}))))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/modes_on_patterns.ml.broken-ref modes_on_patterns.ml.output))) + (rule (deps tests/.ocamlformat ) (package ocamlformat) diff --git a/test/failing/tests/modes_on_patterns.ml b/test/failing/tests/modes_on_patterns.ml new file mode 100644 index 0000000000..6762770900 --- /dev/null +++ b/test/failing/tests/modes_on_patterns.ml @@ -0,0 +1,191 @@ +(* Modes on arbitrary patterns were supported in the parser during development of + ocamlformat support for modes, but were later unsupported in the parser, causing + the below tests to fail. If patterns are ever again supported in the parser, move + these tests back to [test/passing/modes*.ml]. *) + +module Patterns = struct + (* [let (pat @ mode) = x] parses as a mode on the let binding, not on the pattern *) + let pat @ mode = x + let (pat : typ @@ mode) = x + + (* [let (pat @ mode), (pat @ mode) = x] currently does not parse *) + let ((pat @ mode), (pat @ mode)) = x + + let () = + let ((pat @ mode), (pat @ mode)) = x in + () + ;; + + let { a = (a @ mode); b = (b1 @ mode), (b2 @ mode); c = (c : typ @@ mode) } = x + let (A ((a @ mode), (b @ mode))) = x + let (A (a @ mode) @ mode) = x + + (* mode constraints in other patterns *) + let { alias1 = (x @ mode) as y + ; alias2 = (x : typ @@ mode) as y + ; tuple1 = (x @ mode), (y @ mode) + ; tuple2 = (x : typ @@ mode), (y : typ @@ mode) + ; tuple3 = ~x:(x @ mode), ~y:(y @ mode) + ; tuple4 = ~x:(x : typ @@ mode), ~y:(y : typ @@ mode) + ; construct1 = A (x @ mode) + ; construct2 = A ((x, y) @ mode) + ; construct3 = A ((x @ mode), (y @ mode)) + ; construct4 = A (x : typ @@ mode) + ; construct5 = A ((x, y) : typ @@ mode) + ; construct6 = A ((x : typ @@ mode), (y : typ @@ mode)) + ; variant1 = `A (x @ mode) + ; variant2 = `A ((x, y) @ mode) + ; variant3 = `A ((x @ mode), (y @ mode)) + ; variant4 = `A (x : typ @@ mode) + ; variant5 = `A ((x, y) : typ @@ mode) + ; variant6 = `A ((x : typ @@ mode), (y : typ @@ mode)) + ; array1 = [| (x @ mode) |] + ; array2 = [| (x : typ @@ mode) |] + ; list1 = [ (x @ mode) ] + ; list2 = [ (x : typ @@ mode) ] + ; or1 = (x @ mode) | (y @ mode) + ; or2 = (x : typ @@ mode) | (y : typ @@ mode) + ; constraint1 = ((x @ mode) @ mode) + ; constraint2 = ((x : typ @@ mode) @ mode) + ; constraint3 = ((x @ mode) : typ @@ mode) + ; constraint4 = ((x : typ @@ mode) : typ @@ mode) + ; lazy1 = (lazy (x @ mode)) + ; lazy2 = (lazy (x : typ @@ mode)) + ; exception1 = (exception (x @ mode)) + ; exception2 = (exception (x : typ @@ mode)) + ; extension1 = [%ext? (x @ mode)] + ; extension2 = [%ext? (x : typ @@ mode)] + ; open1 = M.((X @ mode)) + ; open2 = M.((X : typ @@ mode)) + ; cons1 = (x @ mode) :: (y @ mode) :: (z @ mode) + ; cons2 = (x : typ @@ mode) :: (y : typ @@ mode) :: (z : typ @@ mode) + } + = + x + ;; + + (* other patterns in mode constraints *) + let { any1 = (_ @ mode) + ; any2 = (_ : typ @@ mode) + ; var1 = (x @ mode) + ; var2 = (x : typ @@ mode) + ; alias1 = (A as x @ mode) + ; alias2 = (A as x : typ @@ mode) + ; constant1 = ("" @ mode) + ; constant2 = ("" : typ @@ mode) + ; interval1 = ('a' .. 'z' @ mode) + ; interval2 = ('a' .. 'z' : typ @@ mode) + ; tuple1 = ((x, y) @ mode) + ; tuple2 = ((x, y) : typ @@ mode) + ; tuple3 = ((~x, ~y) @ mode) + ; tuple4 = ((~x, ~y) : typ @@ mode) + ; construct1 = (A @ mode) + ; construct2 = (A x @ mode) + ; construct3 = (A (x, y) @ mode) + ; construct4 = (A { x; y } @ mode) + ; construct5 = (A : typ @@ mode) + ; construct6 = (A x : typ @@ mode) + ; construct7 = (A (x, y) : typ @@ mode) + ; construct8 = (A { x; y } : typ @@ mode) + ; variant1 = (`A @ mode) + ; variant2 = (`A x @ mode) + ; variant3 = (`A (x, y) @ mode) + ; variant4 = (`A : typ @@ mode) + ; variant5 = (`A x : typ @@ mode) + ; variant6 = (`A (x, y) : typ @@ mode) + ; record1 = ({ x } @ mode) + ; record2 = ({ x } : typ @@ mode) + ; array1 = ([| x |] @ mode) + ; array2 = ([| x |] : typ @@ mode) + ; list1 = ([ x ] @ mode) + ; list2 = ([ x ] : typ @@ mode) + ; or1 = (x | y @ mode) + ; or2 = (x | y : typ @@ mode) + ; constraint1 = ((x @ mode) @ mode) + ; constraint2 = ((x : typ @@ mode) @ mode) + ; constraint3 = ((x @ mode) : typ @@ mode) + ; constraint4 = ((x : typ @@ mode) : typ @@ mode) + ; type1 = (#x @ mode) + ; type2 = (#x : typ @@ mode) + ; lazy1 = ((lazy x) @ mode) + ; lazy2 = ((lazy x) : typ @@ mode) + ; unpack1 = ((module P) @ mode) + ; unpack2 = ((module P) : typ @@ mode) + ; unpack3 = ((module P : S) @ mode) + ; unpack4 = ((module P : S) : typ @@ mode) + ; exception1 = ((exception E) @ mode) + ; exception2 = ((exception E) : typ @@ mode) + ; extension1 = ([%ext] @ mode) + ; extension2 = ([%ext] : typ @@ mode) + ; open1 = (M.(X x) @ mode) + ; open2 = (M.(X x) : typ @@ mode) + ; cons1 = (a :: b :: c @ mode) + ; cons2 = (a :: b :: c : typ @@ mode) + } + = + x + ;; +end + +module No_illegal_sugaring = struct + let { x = (x : t @@ mode) } = y + + let () = + let ((module M) : (module T) @@ mode) = ((module M) : (module T) @@ mode) in + () + ;; + + let (~x:(x @ mode), ~y:(y @ mode)) = ~x:(x : _ @@ mode), ~y:(y : _ @@ mode) +end + +module Line_breaking = struct + module Patterns = struct + let long_pat_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + = + x + ;; + + let (long_pat_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : + t + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) + = + x + ;; + + let (long_pat_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : + long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) + = + x + ;; + end +end + +module Regressions = struct + class t = + let ((x @ mode), (y @ mode)) = x in + object end +end + +module Attrs = struct + let (pat [@attr]) @ mode = x + let ((pat [@attr]) : typ @@ mode) = x + let (pat : (typ[@attr]) @@ mode) = x + let ((pat : typ @@ mode) [@attr]) = x +end + +module Comments = struct + let (* cmt *) pat @ mode = x + let pat (* cmt *) @ mode = x + let pat @ (* cmt *) mode = x + let pat @ mode (* cmt *) = x + let (* cmt *) (pat : typ @@ mode) = x + let ((* cmt *) pat : typ @@ mode) = x + let (pat (* cmt *) : typ @@ mode) = x + let (pat : (* cmt *) typ @@ mode) = x + let (pat : typ (* cmt *) @@ mode) = x + let (pat : typ @@ (* cmt *) mode) = x + let (pat : typ @@ mode (* cmt *)) = x + let (pat : typ @@ mode) (* cmt *) = x +end diff --git a/test/failing/tests/modes_on_patterns.ml.broken-ref b/test/failing/tests/modes_on_patterns.ml.broken-ref new file mode 100644 index 0000000000..85efc7886a --- /dev/null +++ b/test/failing/tests/modes_on_patterns.ml.broken-ref @@ -0,0 +1,9 @@ +ocamlformat: ignoring "tests/modes_on_patterns.ml" (syntax error) +File "tests/modes_on_patterns.ml", line 9, characters 17-19: +9 | let (pat : typ @@ mode) = x + ^^ +Error: Syntax error: ')' expected +File "tests/modes_on_patterns.ml", line 9, characters 6-7: +9 | let (pat : typ @@ mode) = x + ^ + This '(' might be unmatched diff --git a/test/passing/dune.inc b/test/passing/dune.inc index c76e485715..5763984999 100644 --- a/test/passing/dune.inc +++ b/test/passing/dune.inc @@ -8023,6 +8023,186 @@ (package ocamlformat) (action (diff tests/mod_type_subst.ml.js-err mod_type_subst.ml.js-stderr))) +(rule + (deps tests/.ocamlformat ) + (package ocamlformat) + (action + (with-stdout-to modes-ocaml_version.ml.stdout + (with-stderr-to modes-ocaml_version.ml.stderr + (run %{bin:ocamlformat} --margin-check --ocaml-version=4.14.0 %{dep:tests/modes.ml}))))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/modes-ocaml_version.ml.ref modes-ocaml_version.ml.stdout))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/modes-ocaml_version.ml.err modes-ocaml_version.ml.stderr))) + +(rule + (deps tests/.ocamlformat ) + (package ocamlformat) + (action + (with-stdout-to modes.ml.stdout + (with-stderr-to modes.ml.stderr + (run %{bin:ocamlformat} --margin-check %{dep:tests/modes.ml}))))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/modes.ml.ref modes.ml.stdout))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/modes.ml.err modes.ml.stderr))) + +(rule + (deps tests/.ocamlformat ) + (package ocamlformat) + (action + (with-stdout-to modes.ml.js-stdout + (with-stderr-to modes.ml.js-stderr + (run %{bin:ocamlformat} --profile=janestreet --enable-outside-detected-project --disable-conf-files %{dep:tests/modes.ml}))))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/modes.ml.js-ref modes.ml.js-stdout))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/modes.ml.js-err modes.ml.js-stderr))) + +(rule + (deps tests/.ocamlformat ) + (package ocamlformat) + (action + (with-stdout-to modes_attrs.ml.stdout + (with-stderr-to modes_attrs.ml.stderr + (run %{bin:ocamlformat} --margin-check %{dep:tests/modes_attrs.ml}))))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/modes_attrs.ml.ref modes_attrs.ml.stdout))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/modes_attrs.ml.err modes_attrs.ml.stderr))) + +(rule + (deps tests/.ocamlformat ) + (package ocamlformat) + (action + (with-stdout-to modes_attrs.ml.js-stdout + (with-stderr-to modes_attrs.ml.js-stderr + (run %{bin:ocamlformat} --profile=janestreet --enable-outside-detected-project --disable-conf-files %{dep:tests/modes_attrs.ml}))))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/modes_attrs.ml.js-ref modes_attrs.ml.js-stdout))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/modes_attrs.ml.js-err modes_attrs.ml.js-stderr))) + +(rule + (deps tests/.ocamlformat ) + (package ocamlformat) + (action + (with-stdout-to modes_cmts-break_separators_after.ml.stdout + (with-stderr-to modes_cmts-break_separators_after.ml.stderr + (run %{bin:ocamlformat} --margin-check --break-separators=after %{dep:tests/modes_cmts.ml}))))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/modes_cmts-break_separators_after.ml.ref modes_cmts-break_separators_after.ml.stdout))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/modes_cmts-break_separators_after.ml.err modes_cmts-break_separators_after.ml.stderr))) + +(rule + (deps tests/.ocamlformat ) + (package ocamlformat) + (action + (with-stdout-to modes_cmts.ml.stdout + (with-stderr-to modes_cmts.ml.stderr + (run %{bin:ocamlformat} --margin-check %{dep:tests/modes_cmts.ml}))))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/modes_cmts.ml.ref modes_cmts.ml.stdout))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/modes_cmts.ml.err modes_cmts.ml.stderr))) + +(rule + (deps tests/.ocamlformat ) + (package ocamlformat) + (action + (with-stdout-to modes_cmts.ml.js-stdout + (with-stderr-to modes_cmts.ml.js-stderr + (run %{bin:ocamlformat} --profile=janestreet --enable-outside-detected-project --disable-conf-files %{dep:tests/modes_cmts.ml}))))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/modes_cmts.ml.js-ref modes_cmts.ml.js-stdout))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/modes_cmts.ml.js-err modes_cmts.ml.js-stderr))) + +(rule + (deps tests/.ocamlformat ) + (package ocamlformat) + (action + (with-stdout-to modes_cmts_move.ml.stdout + (with-stderr-to modes_cmts_move.ml.stderr + (run %{bin:ocamlformat} --margin-check %{dep:tests/modes_cmts_move.ml}))))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/modes_cmts_move.ml.ref modes_cmts_move.ml.stdout))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/modes_cmts_move.ml.err modes_cmts_move.ml.stderr))) + +(rule + (deps tests/.ocamlformat ) + (package ocamlformat) + (action + (with-stdout-to modes_cmts_move.ml.js-stdout + (with-stderr-to modes_cmts_move.ml.js-stderr + (run %{bin:ocamlformat} --profile=janestreet --enable-outside-detected-project --disable-conf-files %{dep:tests/modes_cmts_move.ml}))))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/modes_cmts_move.ml.js-ref modes_cmts_move.ml.js-stdout))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/modes_cmts_move.ml.js-err modes_cmts_move.ml.js-stderr))) + (rule (deps tests/.ocamlformat ) (package ocamlformat) @@ -9285,7 +9465,7 @@ (action (diff tests/prefix_infix.ml.js-err prefix_infix.ml.js-stderr))) (rule - (deps tests/.ocamlformat tests/dir1/dir2/.ocamlformat tests/dir1/dir2/print_config.ml) + (deps tests/.ocamlformat tests/dir1/.ocamlformat tests/dir1/dir2/.ocamlformat tests/dir1/dir2/print_config.ml) (enabled_if (<> %{os_type} Win32)) (package ocamlformat) (action @@ -9306,7 +9486,7 @@ (action (diff tests/print_config.ml.err print_config.ml.stderr))) (rule - (deps tests/.ocamlformat tests/dir1/dir2/.ocamlformat tests/dir1/dir2/print_config.ml) + (deps tests/.ocamlformat tests/dir1/.ocamlformat tests/dir1/dir2/.ocamlformat tests/dir1/dir2/print_config.ml) (enabled_if (<> %{os_type} Win32)) (package ocamlformat) (action diff --git a/test/passing/tests/local.ml.js-ref b/test/passing/tests/local.ml.js-ref index 117c86e492..82bcfed941 100644 --- a/test/passing/tests/local.ml.js-ref +++ b/test/passing/tests/local.ml.js-ref @@ -143,25 +143,25 @@ type 'a r = type 'a r = | Foo of - global_ (* a *) - (* b *) - (* c *) + (* a *) + (* b *) + global_ (* c *) (* d *) 'a | Bar of 'a - * global_ (* e *) - (* f *) - (* g *) - (* h *) + * (* e *) + (* f *) + global_ (* g *) + (* h *) 'a | Baz of global_ int * string - * global_ (* i *) - (* j *) - (* k *) - (* l *) + * (* i *) + (* j *) + global_ (* k *) + (* l *) 'a let () = diff --git a/test/passing/tests/local.ml.ref b/test/passing/tests/local.ml.ref index f4e5e0d700..3f1974facc 100644 --- a/test/passing/tests/local.ml.ref +++ b/test/passing/tests/local.ml.ref @@ -152,25 +152,25 @@ type 'a r = type 'a r = | Foo of - global_ (* a *) - (* b *) - (* c *) + (* a *) + (* b *) + global_ (* c *) (* d *) 'a | Bar of 'a - * global_ (* e *) - (* f *) - (* g *) - (* h *) + * (* e *) + (* f *) + global_ (* g *) + (* h *) 'a | Baz of global_ int * string - * global_ (* i *) - (* j *) - (* k *) - (* l *) + * (* i *) + (* j *) + global_ (* k *) + (* l *) 'a let () = diff --git a/test/passing/tests/modes-ocaml_version.ml.opts b/test/passing/tests/modes-ocaml_version.ml.opts new file mode 100644 index 0000000000..0bc303a746 --- /dev/null +++ b/test/passing/tests/modes-ocaml_version.ml.opts @@ -0,0 +1 @@ +--ocaml-version=4.14.0 diff --git a/test/passing/tests/modes-ocaml_version.ml.ref b/test/passing/tests/modes-ocaml_version.ml.ref new file mode 100644 index 0000000000..913e47c89b --- /dev/null +++ b/test/passing/tests/modes-ocaml_version.ml.ref @@ -0,0 +1,471 @@ +(* The first half of this file tests basic formatting of the [@]-based mode + syntax in various positions to make sure we are able to handle them all, + and that they are correctly parenthesized. The second half more thoroughly + checks formatting when there are line breaks in various positions. *) + +(* Modes on arbitrary patterns were supported in the parser during + development of ocamlformat support for modes, but were later unsupported + in the parser. Tests of modes on patterns have thus been moved to + [test/failing/tests/modes_on_patterns.ml]. If patterns are ever again + supported in the parser, move those tests back to this file (and other + [modes*.ml] files in this directory). *) + +module Let_bindings = struct + let x @ mode = y + + let x @ mode1 mode2 = y + + let x : typ @@ mode1 mode2 = y + + let x : typ1 typ2 @@ mode1 mode2 = y + + let x : typ1 -> typ2 @@ mode1 mode2 = y + + let x : typ1 * typ2 @@ mode1 mode2 = y + + let x @ mode = x + + and y @ mode = y + + and z : typ @@ mode = z + + let () = + let x @ mode = y in + let x : typ @@ mode = y in + let x @ mode = x and y @ mode = y and z : typ @@ mode = z in + () + + let () = + let%bind x @ mode = y in + let%map x @ mode = y in + let%ext x : typ @@ mode = y in + let%ext x @ mode = x and y @ mode = y and z : typ @@ mode = z in + () +end + +module Expressions = struct + let x = (expr : typ @@ mode1 mode2) + + let x = (expr : typ1 typ2 @@ mode1 mode2) + + let x = (expr : typ1 -> typ2 @@ mode1 mode2) + + let x = (expr : typ1 * typ2 @@ mode1 mode2) + + (* mode constraints in expressions *) + let x = + { let1= + (let x = (x : _ @@ mode) and y = (y : _ @@ mode) in + (z : _ @@ mode) ) + ; function1= (function x -> (x : _ @@ mode) | y -> (y : _ @@ mode)) + ; fun1= (fun ?(x = (x : _ @@ mode)) () -> (y : _ @@ mode)) + ; apply1= (x : _ @@ mode) (y : _ @@ mode) + ; apply2= f ~lbl:(x : _ @@ mode) + ; apply3= f ~x:(x : _ @@ mode) + ; apply4= f ?lbl:(x : _ @@ mode) + ; apply5= f ?x:(x : _ @@ mode) + ; match1= + ( match (x : _ @@ mode) with + | y -> (y : _ @@ mode) + | z -> (z : _ @@ mode) ) + ; try1= (try (x : _ @@ mode) with y -> (y : _ @@ mode)) + ; tuple1= ((x : _ @@ mode), (y : _ @@ mode)) + ; tuple2= (~x:(x : _ @@ mode), ~y:(z : _ @@ mode)) + ; construct1= A (x : _ @@ mode) + ; construct2= A ((x : _ @@ mode), (y : _ @@ mode)) + ; variant1= `A (x : _ @@ mode) + ; variant2= `A ((x : _ @@ mode), (y : _ @@ mode)) + ; field1= (x : _ @@ mode).x + ; setfield1= (x : _ @@ mode).x <- (y : _ @@ mode) + ; array1= [|(x : _ @@ mode); (y : _ @@ mode)|] + ; array2= [:(x : _ @@ mode); (y : _ @@ mode):] + ; list1= [(x : _ @@ mode); (y : _ @@ mode)] + ; ite1= (if (x : _ @@ mode) then (y : _ @@ mode) else (z : _ @@ mode)) + ; sequence1= + ( (x : _ @@ mode) ; + (y : _ @@ mode) ) + ; while1= + while (x : _ @@ mode) do + (y : _ @@ mode) + done + ; for1= + for i = (x : _ @@ mode) to (y : _ @@ mode) do + (z : _ @@ mode) + done + ; constraint1= ((x : _ @@ mode) : _ @@ mode) + ; coerce1= ((x : _ @@ mode) :> _) + ; send1= (x : _ @@ mode)#y + ; setinstvar1= x <- (x : _ @@ mode) + ; override1= {} + ; letmodule1= + (let module M = ME in + (x : _ @@ mode) ) + ; letexception1= + (let exception E in + (x : _ @@ mode) ) + ; assert1= assert (x : _ @@ mode) + ; lazy1= lazy (x : _ @@ mode) + ; newtype1= (fun (type t) -> (x : _ @@ mode)) + ; open1= M.((x : _ @@ mode)) + ; letopen1= + (let open M in + (x : _ @@ mode) ) + ; letop1= + (let* x = (x : _ @@ mode) in + (y : _ @@ mode) ) + ; extension1= [%ext (x : _ @@ mode)] + ; cons1= (x : _ @@ mode) :: (y : _ @@ mode) :: (z : _ @@ mode) + ; prefix1= !(x : _ @@ mode) + ; infix1= (x : _ @@ mode) + (y : _ @@ mode) } + + (* expressions in mode constraints *) + let x = + { ident1= (x : _ @@ mode) + ; constant1= ("" : _ @@ mode) + ; let1= + ( let x = y in + z + : _ + @@ mode ) + ; function1= (function x -> x | y -> y : _ @@ mode) + ; fun1= (fun x -> y : _ @@ mode) + ; apply1= (f x : _ @@ mode) + ; match1= (match x with y -> y | z -> z : _ @@ mode) + ; try1= (try x with y -> y | z -> z : _ @@ mode) + ; tuple1= ((x, y) : _ @@ mode) + ; tuple2= ((~x, ~y) : _ @@ mode) + ; construct1= (A : _ @@ mode) + ; construct2= (A x : _ @@ mode) + ; construct3= (A (x, y) : _ @@ mode) + ; construct4= (A {x} : _ @@ mode) + ; variant1= (`A : _ @@ mode) + ; variant2= (`A x : _ @@ mode) + ; record1= ({x} : _ @@ mode) + ; field1= (x.y : _ @@ mode) + ; setfield1= (x.y <- z : _ @@ mode) + ; array1= ([|x|] : _ @@ mode) + ; array2= ([:x:] : _ @@ mode) + ; list1= ([x] : _ @@ mode) + ; ite1= (if x then y else z : _ @@ mode) + ; sequence1= (x ; y : _ @@ mode) + ; while1= + while x do + y + done + @@ mode + ; for1= + for x = y to z do + a + done + @@ mode + ; constraint1= ((x : _ @@ mode) : _ @@ mode) + ; coerce1= ((x :> _) : _ @@ mode) + ; send1= (x#y : _ @@ mode) + ; new1= (new x : _ @@ mode) + ; setinstvar1= (x <- 2 : _ @@ mode) + ; override1= ({} : _ @@ mode) + ; letmodule1= + ( let module M = ME in + x + : _ + @@ mode ) + ; letexception1= + ( let exception E in + x + : _ + @@ mode ) + ; assert1= (assert x : _ @@ mode) + ; lazy1= (lazy x : _ @@ mode) + ; object1= (object end : _ @@ mode) + ; newtype1= (fun (type t) -> x : _ @@ mode) + ; pack1= ((module M) : _ @@ mode) + ; pack2= ((module M : S) : _ @@ mode) + ; open1= (M.(x y) : _ @@ mode) + ; letopen1= + ( let open M in + x + : _ + @@ mode ) + ; letop1= + ( let* x = y in + z + : _ + @@ mode ) + ; extension1= ([%ext] : _ @@ mode) + ; hole1= (_ : _ @@ mode) + ; cons1= (x :: y :: z : _ @@ mode) + ; prefix1= (!x : _ @@ mode) + ; infix1= (x + y : _ @@ mode) } +end + +module Arrow_params = struct + type t = lhs @ mode1 mode2 -> rhs @ mode3 mode4 + + type t = + arg1 @ mode1 -> lbl:arg2 @ mode2 -> ?lbl:arg3 @ mode3 -> res @ mode4 + + let x : lhs @ mode1 -> rhs @ mode2 @@ mode3 = y + + let x = (expr : lhs @ mode1 -> rhs @ mode2 @@ mode3) +end + +module Modalities_on_record_fields = struct + type t = {x: t @@ mode1 mode2; mutable x: t @@ mode1 mode2} + + type t = A of {x: t @@ mode1 mode2} +end + +module Modalities_on_construct_arguments = struct + type t = A of typ @@ mode1 mode2 | B of typ1 @@ mode1 * typ2 @@ mode2 + + type t = + | A : typ @@ mode1 mode2 -> t + | B : typ1 @@ mode1 * typ2 @@ mode2 -> t +end + +module type Value_descriptions = sig + val x : typ @@ mode1 mode2 + + val x : typ1 typ2 @@ mode1 mode2 + + val x : typ1 -> typ2 @@ mode1 mode2 + + val x : typ1 * typ2 @@ mode1 mode2 +end + +module Let_bound_functions = struct + let (f @ mode) arg1 arg2 = x + + let (f @ mode) arg1 arg2 : typ = x + + let (f @ mode1 mode2) arg1 arg2 = x + + let (f @ mode) (arg @ mode) (arg : typ @@ mode) ~lbl:(arg @ mode) + ~lbl:(arg : typ @@ mode) ~(arg @ mode) ~(arg : typ @@ mode) + ?lbl:(arg @ mode) ?lbl:(arg : typ @@ mode) ?lbl:(arg @ mode = value) + ?lbl:(arg : typ @@ mode = value) ?(arg @ mode) ?(arg : typ @@ mode) + ?(arg @ mode = value) ?(arg : typ @@ mode = value) : typ = + value +end + +module No_illegal_sugaring = struct + let y = {x= (x : t @@ mode)} + + let y = {x:> t = (x : t @@ mode)} +end + +module Line_breaking = struct + module Let_bindings = struct + let long_value_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 = + 1 + + let long_value_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : t + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 = + 1 + + let long_value_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : + long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 = + 1 + end + + module Expressions = struct + let x = + ( long_expr_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + : t + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 ) + + let x = + ( long_expr_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + : long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 ) + end + + module Arrow_params = struct + type t = + arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + + type t = + long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> label:long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> ?label:long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> long_result_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + + let x : + arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 = + y + + let x : + long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> label:long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> ?label:long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> long_result_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 = + y + + let x = + ( expr + : arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + @@ mode1 mode2 ) + + let x = + ( expr + : long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> label:long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> ?label:long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> long_result_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + @@ mode1 mode2 ) + end + + module Modalities_on_record_fields = struct + type t = + { long_field_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa: t + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + ; mutable long_field_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa: t + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + ; long_field_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa: + long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 } + + type t = + | A of + { long_field_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa: t + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + ; mutable long_field_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa: t + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + ; long_field_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa: + long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 } + end + + module Modalities_on_constructor_arguments = struct + type t = + | A of + long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + * long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + * long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + * short_type @@ mode1 mode2 + + type t = + | A : + long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + * long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + * long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + * short_type @@ mode1 mode2 + -> t + end + + module type Value_descriptions = sig + val long_value_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : t + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + + val long_value_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : + long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + end + + module Let_bound_functions = struct + let (long_fun_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) + (long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 ) + (long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : + t + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 ) + (long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : + long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 ) = + a + end +end + +module Interaction_with_existing_syntax = struct + (* let bindings *) + + let local_ x @ mode1 mode2 = y + + let local_ x : typ1 typ2 @@ mode1 mode2 = y + + (* lhs/rhs of arrows *) + + type t = local_ lhs @ mode1 -> local_ mhs @ mode2 -> local_ rhs @ mode3 + + let x : local_ lhs @ mode1 -> local_ rhs @ mode2 @@ mode3 = y + + let x = (expr : local_ lhs @ mode1 -> local_ rhs @ mode2 @@ mode3) + + (* modalities on record fields *) + + type t = {global_ x: t @@ mode1 mode2} + + type t = A of {global_ x: t @@ mode1 mode2} + + (* modalities on constructor arguments *) + + type t = + | A of global_ typ @@ mode1 mode2 + | B of global_ typ1 @@ mode1 * global_ typ2 @@ mode2 + + type t = + | A : global_ typ @@ mode1 mode2 -> t + | B : global_ typ1 @@ mode1 * global_ typ2 @@ mode2 -> t +end + +module Regressions = struct + let x = + a_long_expression_that_has_its_own_line + @ (* a long comment that comes after the [@] *) + a_long_expression_that_comes_after_the_comment + + let (x, y) @ mode = + let (x, y) @ mode = (x, y) in + (x, y) + + let (t as t) @ mode = local_ + let (t as t) @ mode = local_ t in + t + + let (x, y) @ mode = local_ + let (x, y) @ mode = local_ t in + t + + class t = + let (x, y) @ mode = x in + object end +end diff --git a/test/passing/tests/modes-ocaml_version.ml.why-no-js b/test/passing/tests/modes-ocaml_version.ml.why-no-js new file mode 100644 index 0000000000..ce796b84ef --- /dev/null +++ b/test/passing/tests/modes-ocaml_version.ml.why-no-js @@ -0,0 +1 @@ +The purpose of this test is to evaluate against the ocaml-version option, which is not compatible with js-ref. diff --git a/test/passing/tests/modes.ml b/test/passing/tests/modes.ml new file mode 100644 index 0000000000..863391c008 --- /dev/null +++ b/test/passing/tests/modes.ml @@ -0,0 +1,519 @@ +(* The first half of this file tests basic formatting of the [@]-based mode syntax + in various positions to make sure we are able to handle them all, and that + they are correctly parenthesized. The second half more thoroughly checks + formatting when there are line breaks in various positions. *) + +(* Modes on arbitrary patterns were supported in the parser during development of + ocamlformat support for modes, but were later unsupported in the parser. Tests of + modes on patterns have thus been moved to [test/failing/tests/modes_on_patterns.ml]. + If patterns are ever again supported in the parser, move those tests back to this + file (and other [modes*.ml] files in this directory). *) + +module Let_bindings = struct + let x @ mode = y + let x @ mode1 mode2 = y + let x : typ @@ mode1 mode2 = y + let x : typ1 typ2 @@ mode1 mode2 = y + let x : typ1 -> typ2 @@ mode1 mode2 = y + let x : typ1 * typ2 @@ mode1 mode2 = y + + let x @ mode = x + and y @ mode = y + and z : typ @@ mode = z + + let () = + let x @ mode = y in + let x : typ @@ mode = y in + let x @ mode = x + and y @ mode = y + and z : typ @@ mode = z in + () + ;; + + let () = + let%bind x @ mode = y in + let%map x @ mode = y in + let%ext x : typ @@ mode = y in + let%ext x @ mode = x + and y @ mode = y + and z : typ @@ mode = z in + () + ;; +end + +module Expressions = struct + let x = (expr : typ @@ mode1 mode2) + let x = (expr : typ1 typ2 @@ mode1 mode2) + let x = (expr : typ1 -> typ2 @@ mode1 mode2) + let x = (expr : typ1 * typ2 @@ mode1 mode2) + + (* mode constraints in expressions *) + let x = + { let1 = + (let x = (x : _ @@ mode) + and y = (y : _ @@ mode) in + (z : _ @@ mode)) + ; function1 = + (function + | x -> (x : _ @@ mode) + | y -> (y : _ @@ mode)) + ; fun1 = (fun ?(x = (x : _ @@ mode)) () -> (y : _ @@ mode)) + ; apply1 = (x : _ @@ mode) (y : _ @@ mode) + ; apply2 = f ~lbl:(x : _ @@ mode) + ; apply3 = f ~x:(x : _ @@ mode) + ; apply4 = f ?lbl:(x : _ @@ mode) + ; apply5 = f ?x:(x : _ @@ mode) + ; match1 = + (match (x : _ @@ mode) with + | y -> (y : _ @@ mode) + | z -> (z : _ @@ mode)) + ; try1 = + (try (x : _ @@ mode) with + | y -> (y : _ @@ mode)) + ; tuple1 = (x : _ @@ mode), (y : _ @@ mode) + ; tuple2 = ~x:(x : _ @@ mode), ~y:(z : _ @@ mode) + ; construct1 = A (x : _ @@ mode) + ; construct2 = A ((x : _ @@ mode), (y : _ @@ mode)) + ; variant1 = `A (x : _ @@ mode) + ; variant2 = `A ((x : _ @@ mode), (y : _ @@ mode)) + ; field1 = (x : _ @@ mode).x + ; setfield1 = (x : _ @@ mode).x <- (y : _ @@ mode) + ; array1 = [| (x : _ @@ mode); (y : _ @@ mode) |] + ; array2 = [: (x : _ @@ mode); (y : _ @@ mode) :] + ; list1 = [ (x : _ @@ mode); (y : _ @@ mode) ] + ; ite1 = (if (x : _ @@ mode) then (y : _ @@ mode) else (z : _ @@ mode)) + ; sequence1 = + ((x : _ @@ mode); + (y : _ @@ mode)) + ; while1 = + while (x : _ @@ mode) do + (y : _ @@ mode) + done + ; for1 = + for i = (x : _ @@ mode) to (y : _ @@ mode) do + (z : _ @@ mode) + done + ; constraint1 = ((x : _ @@ mode) : _ @@ mode) + ; coerce1 = ((x : _ @@ mode) :> _) + ; send1 = (x : _ @@ mode)#y + ; setinstvar1 = x <- (x : _ @@ mode) + ; override1 = {} + ; letmodule1 = + (let module M = ME in + (x : _ @@ mode)) + ; letexception1 = + (let exception E in + (x : _ @@ mode)) + ; assert1 = assert (x : _ @@ mode) + ; lazy1 = lazy (x : _ @@ mode) + ; newtype1 = (fun (type t) -> (x : _ @@ mode)) + ; open1 = M.((x : _ @@ mode)) + ; letopen1 = + (let open M in + (x : _ @@ mode)) + ; letop1 = + (let* x = (x : _ @@ mode) in + (y : _ @@ mode)) + ; extension1 = [%ext (x : _ @@ mode)] + ; cons1 = (x : _ @@ mode) :: (y : _ @@ mode) :: (z : _ @@ mode) + ; prefix1 = !(x : _ @@ mode) + ; infix1 = (x : _ @@ mode) + (y : _ @@ mode) + } + ;; + + (* expressions in mode constraints *) + let x = + { ident1 = (x : _ @@ mode) + ; constant1 = ("" : _ @@ mode) + ; let1 = + (let x = y in + z + : _ + @@ mode) + ; function1 = + (function + | x -> x + | y -> y + : _ + @@ mode) + ; fun1 = (fun x -> y : _ @@ mode) + ; apply1 = (f x : _ @@ mode) + ; match1 = + ((match x with + | y -> y + | z -> z) + : _ + @@ mode) + ; try1 = + ((try x with + | y -> y + | z -> z) + : _ + @@ mode) + ; tuple1 = ((x, y) : _ @@ mode) + ; tuple2 = ((~x, ~y) : _ @@ mode) + ; construct1 = (A : _ @@ mode) + ; construct2 = (A x : _ @@ mode) + ; construct3 = (A (x, y) : _ @@ mode) + ; construct4 = (A { x } : _ @@ mode) + ; variant1 = (`A : _ @@ mode) + ; variant2 = (`A x : _ @@ mode) + ; record1 = ({ x } : _ @@ mode) + ; field1 = (x.y : _ @@ mode) + ; setfield1 = (x.y <- z : _ @@ mode) + ; array1 = ([| x |] : _ @@ mode) + ; array2 = ([: x :] : _ @@ mode) + ; list1 = ([ x ] : _ @@ mode) + ; ite1 = (if x then y else z : _ @@ mode) + ; sequence1 = + (x; + y + : _ + @@ mode) + ; while1 = + while x do + y + done + @@ mode + ; for1 = + for x = y to z do + a + done + @@ mode + ; constraint1 = ((x : _ @@ mode) : _ @@ mode) + ; coerce1 = ((x :> _) : _ @@ mode) + ; send1 = (x#y : _ @@ mode) + ; new1 = (new x : _ @@ mode) + ; setinstvar1 = (x <- 2 : _ @@ mode) + ; override1 = ({} : _ @@ mode) + ; letmodule1 = + (let module M = ME in + x + : _ + @@ mode) + ; letexception1 = + (let exception E in + x + : _ + @@ mode) + ; assert1 = (assert x : _ @@ mode) + ; lazy1 = (lazy x : _ @@ mode) + ; object1 = (object end : _ @@ mode) + ; newtype1 = (fun (type t) -> x : _ @@ mode) + ; pack1 = ((module M) : _ @@ mode) + ; pack2 = ((module M : S) : _ @@ mode) + ; open1 = (M.(x y) : _ @@ mode) + ; letopen1 = + (let open M in + x + : _ + @@ mode) + ; letop1 = + (let* x = y in + z + : _ + @@ mode) + ; extension1 = ([%ext] : _ @@ mode) + ; hole1 = (_ : _ @@ mode) + ; cons1 = (x :: y :: z : _ @@ mode) + ; prefix1 = (!x : _ @@ mode) + ; infix1 = (x + y : _ @@ mode) + } + ;; +end + +module Arrow_params = struct + type t = lhs @ mode1 mode2 -> rhs @ mode3 mode4 + type t = arg1 @ mode1 -> lbl:arg2 @ mode2 -> ?lbl:arg3 @ mode3 -> res @ mode4 + + let x : lhs @ mode1 -> rhs @ mode2 @@ mode3 = y + let x = (expr : lhs @ mode1 -> rhs @ mode2 @@ mode3) +end + +module Modalities_on_record_fields = struct + type t = + { x : t @@ mode1 mode2 + ; mutable x : t @@ mode1 mode2 + } + + type t = A of { x : t @@ mode1 mode2 } +end + +module Modalities_on_construct_arguments = struct + type t = + | A of typ @@ mode1 mode2 + | B of typ1 @@ mode1 * typ2 @@ mode2 + + type t = + | A : typ @@ mode1 mode2 -> t + | B : typ1 @@ mode1 * typ2 @@ mode2 -> t +end + +module type Value_descriptions = sig + val x : typ @@ mode1 mode2 + val x : typ1 typ2 @@ mode1 mode2 + val x : typ1 -> typ2 @@ mode1 mode2 + val x : typ1 * typ2 @@ mode1 mode2 +end + +module Let_bound_functions = struct + let (f @ mode) arg1 arg2 = x + let (f @ mode) arg1 arg2 : typ = x + let (f @ mode1 mode2) arg1 arg2 = x + + let (f @ mode) + (arg @ mode) + (arg : typ @@ mode) + ~lbl:(arg @ mode) + ~lbl:(arg : typ @@ mode) + ~(arg @ mode) + ~(arg : typ @@ mode) + ?lbl:(arg @ mode) + ?lbl:(arg : typ @@ mode) + ?lbl:(arg @ mode = value) + ?lbl:(arg : typ @@ mode = value) + ?(arg @ mode) + ?(arg : typ @@ mode) + ?(arg @ mode = value) + ?(arg : typ @@ mode = value) + : typ + = + value + ;; +end + +module No_illegal_sugaring = struct + let y = { x = (x : t @@ mode) } + let y = { x :> t = (x : t @@ mode) } +end + +module Line_breaking = struct + module Let_bindings = struct + let long_value_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + = + 1 + ;; + + let long_value_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + : t @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + = + 1 + ;; + + let long_value_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + : long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + = + 1 + ;; + end + + module Expressions = struct + let x = + (long_expr_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + : t + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) + ;; + + let x = + (long_expr_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + : long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) + ;; + end + + module Arrow_params = struct + type t = + arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + + type t = + long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> label:long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> ?label:long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> long_result_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + + let x + : arg @ mode1 mode2 -> arg @ mode1 mode2 -> arg @ mode1 mode2 -> arg @ mode1 mode2 + -> arg @ mode1 mode2 -> arg @ mode1 mode2 -> arg @ mode1 mode2 + = + y + ;; + + let x + : long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> label:long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> ?label:long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> long_result_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + = + y + ;; + + let x = + (expr + : arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + @@ mode1 mode2) + ;; + + let x = + (expr + : long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> label:long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> ?label:long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> long_result_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + @@ mode1 mode2) + ;; + end + + module Modalities_on_record_fields = struct + type t = + { long_field_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : t + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + ; mutable long_field_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : t + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + ; long_field_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : + long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + } + + type t = + | A of + { long_field_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : t + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + ; mutable long_field_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : t + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + ; long_field_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : + long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + } + end + + module Modalities_on_constructor_arguments = struct + type t = + | A of + long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + * long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + * long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + * short_type @@ mode1 mode2 + + type t = + | A : + long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + * long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + * long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + * short_type @@ mode1 mode2 + -> t + end + + module type Value_descriptions = sig + val long_value_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + : t + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + + val long_value_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + : long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + end + + module Let_bound_functions = struct + let (long_fun_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) + (long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) + (long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : + t + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) + (long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : + long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) + = + a + ;; + end +end + +module Interaction_with_existing_syntax = struct + (* let bindings *) + + let local_ x @ mode1 mode2 = y + let local_ x : typ1 typ2 @@ mode1 mode2 = y + + (* lhs/rhs of arrows *) + + type t = local_ lhs @ mode1 -> local_ mhs @ mode2 -> local_ rhs @ mode3 + + let x : local_ lhs @ mode1 -> local_ rhs @ mode2 @@ mode3 = y + let x = (expr : local_ lhs @ mode1 -> local_ rhs @ mode2 @@ mode3) + + (* modalities on record fields *) + + type t = { global_ x : t @@ mode1 mode2 } + type t = A of { global_ x : t @@ mode1 mode2 } + + (* modalities on constructor arguments *) + + type t = + | A of global_ typ @@ mode1 mode2 + | B of global_ typ1 @@ mode1 * global_ typ2 @@ mode2 + + type t = + | A : global_ typ @@ mode1 mode2 -> t + | B : global_ typ1 @@ mode1 * global_ typ2 @@ mode2 -> t +end + +module Regressions = struct + let x = + a_long_expression_that_has_its_own_line + @ (* a long comment that comes after the [@] *) + a_long_expression_that_comes_after_the_comment + ;; + + let (x, y) @ mode = + let (x, y) @ mode = x, y in + x, y + ;; + + let (t as t) @ mode = local_ + let (t as t) @ mode = local_ t in + t + ;; + + let (x, y) @ mode = local_ + let (x, y) @ mode = local_ t in + t + ;; + + class t = + let (x, y) @ mode = x in + object end +end diff --git a/test/passing/tests/modes.ml.js-ref b/test/passing/tests/modes.ml.js-ref new file mode 100644 index 0000000000..863391c008 --- /dev/null +++ b/test/passing/tests/modes.ml.js-ref @@ -0,0 +1,519 @@ +(* The first half of this file tests basic formatting of the [@]-based mode syntax + in various positions to make sure we are able to handle them all, and that + they are correctly parenthesized. The second half more thoroughly checks + formatting when there are line breaks in various positions. *) + +(* Modes on arbitrary patterns were supported in the parser during development of + ocamlformat support for modes, but were later unsupported in the parser. Tests of + modes on patterns have thus been moved to [test/failing/tests/modes_on_patterns.ml]. + If patterns are ever again supported in the parser, move those tests back to this + file (and other [modes*.ml] files in this directory). *) + +module Let_bindings = struct + let x @ mode = y + let x @ mode1 mode2 = y + let x : typ @@ mode1 mode2 = y + let x : typ1 typ2 @@ mode1 mode2 = y + let x : typ1 -> typ2 @@ mode1 mode2 = y + let x : typ1 * typ2 @@ mode1 mode2 = y + + let x @ mode = x + and y @ mode = y + and z : typ @@ mode = z + + let () = + let x @ mode = y in + let x : typ @@ mode = y in + let x @ mode = x + and y @ mode = y + and z : typ @@ mode = z in + () + ;; + + let () = + let%bind x @ mode = y in + let%map x @ mode = y in + let%ext x : typ @@ mode = y in + let%ext x @ mode = x + and y @ mode = y + and z : typ @@ mode = z in + () + ;; +end + +module Expressions = struct + let x = (expr : typ @@ mode1 mode2) + let x = (expr : typ1 typ2 @@ mode1 mode2) + let x = (expr : typ1 -> typ2 @@ mode1 mode2) + let x = (expr : typ1 * typ2 @@ mode1 mode2) + + (* mode constraints in expressions *) + let x = + { let1 = + (let x = (x : _ @@ mode) + and y = (y : _ @@ mode) in + (z : _ @@ mode)) + ; function1 = + (function + | x -> (x : _ @@ mode) + | y -> (y : _ @@ mode)) + ; fun1 = (fun ?(x = (x : _ @@ mode)) () -> (y : _ @@ mode)) + ; apply1 = (x : _ @@ mode) (y : _ @@ mode) + ; apply2 = f ~lbl:(x : _ @@ mode) + ; apply3 = f ~x:(x : _ @@ mode) + ; apply4 = f ?lbl:(x : _ @@ mode) + ; apply5 = f ?x:(x : _ @@ mode) + ; match1 = + (match (x : _ @@ mode) with + | y -> (y : _ @@ mode) + | z -> (z : _ @@ mode)) + ; try1 = + (try (x : _ @@ mode) with + | y -> (y : _ @@ mode)) + ; tuple1 = (x : _ @@ mode), (y : _ @@ mode) + ; tuple2 = ~x:(x : _ @@ mode), ~y:(z : _ @@ mode) + ; construct1 = A (x : _ @@ mode) + ; construct2 = A ((x : _ @@ mode), (y : _ @@ mode)) + ; variant1 = `A (x : _ @@ mode) + ; variant2 = `A ((x : _ @@ mode), (y : _ @@ mode)) + ; field1 = (x : _ @@ mode).x + ; setfield1 = (x : _ @@ mode).x <- (y : _ @@ mode) + ; array1 = [| (x : _ @@ mode); (y : _ @@ mode) |] + ; array2 = [: (x : _ @@ mode); (y : _ @@ mode) :] + ; list1 = [ (x : _ @@ mode); (y : _ @@ mode) ] + ; ite1 = (if (x : _ @@ mode) then (y : _ @@ mode) else (z : _ @@ mode)) + ; sequence1 = + ((x : _ @@ mode); + (y : _ @@ mode)) + ; while1 = + while (x : _ @@ mode) do + (y : _ @@ mode) + done + ; for1 = + for i = (x : _ @@ mode) to (y : _ @@ mode) do + (z : _ @@ mode) + done + ; constraint1 = ((x : _ @@ mode) : _ @@ mode) + ; coerce1 = ((x : _ @@ mode) :> _) + ; send1 = (x : _ @@ mode)#y + ; setinstvar1 = x <- (x : _ @@ mode) + ; override1 = {} + ; letmodule1 = + (let module M = ME in + (x : _ @@ mode)) + ; letexception1 = + (let exception E in + (x : _ @@ mode)) + ; assert1 = assert (x : _ @@ mode) + ; lazy1 = lazy (x : _ @@ mode) + ; newtype1 = (fun (type t) -> (x : _ @@ mode)) + ; open1 = M.((x : _ @@ mode)) + ; letopen1 = + (let open M in + (x : _ @@ mode)) + ; letop1 = + (let* x = (x : _ @@ mode) in + (y : _ @@ mode)) + ; extension1 = [%ext (x : _ @@ mode)] + ; cons1 = (x : _ @@ mode) :: (y : _ @@ mode) :: (z : _ @@ mode) + ; prefix1 = !(x : _ @@ mode) + ; infix1 = (x : _ @@ mode) + (y : _ @@ mode) + } + ;; + + (* expressions in mode constraints *) + let x = + { ident1 = (x : _ @@ mode) + ; constant1 = ("" : _ @@ mode) + ; let1 = + (let x = y in + z + : _ + @@ mode) + ; function1 = + (function + | x -> x + | y -> y + : _ + @@ mode) + ; fun1 = (fun x -> y : _ @@ mode) + ; apply1 = (f x : _ @@ mode) + ; match1 = + ((match x with + | y -> y + | z -> z) + : _ + @@ mode) + ; try1 = + ((try x with + | y -> y + | z -> z) + : _ + @@ mode) + ; tuple1 = ((x, y) : _ @@ mode) + ; tuple2 = ((~x, ~y) : _ @@ mode) + ; construct1 = (A : _ @@ mode) + ; construct2 = (A x : _ @@ mode) + ; construct3 = (A (x, y) : _ @@ mode) + ; construct4 = (A { x } : _ @@ mode) + ; variant1 = (`A : _ @@ mode) + ; variant2 = (`A x : _ @@ mode) + ; record1 = ({ x } : _ @@ mode) + ; field1 = (x.y : _ @@ mode) + ; setfield1 = (x.y <- z : _ @@ mode) + ; array1 = ([| x |] : _ @@ mode) + ; array2 = ([: x :] : _ @@ mode) + ; list1 = ([ x ] : _ @@ mode) + ; ite1 = (if x then y else z : _ @@ mode) + ; sequence1 = + (x; + y + : _ + @@ mode) + ; while1 = + while x do + y + done + @@ mode + ; for1 = + for x = y to z do + a + done + @@ mode + ; constraint1 = ((x : _ @@ mode) : _ @@ mode) + ; coerce1 = ((x :> _) : _ @@ mode) + ; send1 = (x#y : _ @@ mode) + ; new1 = (new x : _ @@ mode) + ; setinstvar1 = (x <- 2 : _ @@ mode) + ; override1 = ({} : _ @@ mode) + ; letmodule1 = + (let module M = ME in + x + : _ + @@ mode) + ; letexception1 = + (let exception E in + x + : _ + @@ mode) + ; assert1 = (assert x : _ @@ mode) + ; lazy1 = (lazy x : _ @@ mode) + ; object1 = (object end : _ @@ mode) + ; newtype1 = (fun (type t) -> x : _ @@ mode) + ; pack1 = ((module M) : _ @@ mode) + ; pack2 = ((module M : S) : _ @@ mode) + ; open1 = (M.(x y) : _ @@ mode) + ; letopen1 = + (let open M in + x + : _ + @@ mode) + ; letop1 = + (let* x = y in + z + : _ + @@ mode) + ; extension1 = ([%ext] : _ @@ mode) + ; hole1 = (_ : _ @@ mode) + ; cons1 = (x :: y :: z : _ @@ mode) + ; prefix1 = (!x : _ @@ mode) + ; infix1 = (x + y : _ @@ mode) + } + ;; +end + +module Arrow_params = struct + type t = lhs @ mode1 mode2 -> rhs @ mode3 mode4 + type t = arg1 @ mode1 -> lbl:arg2 @ mode2 -> ?lbl:arg3 @ mode3 -> res @ mode4 + + let x : lhs @ mode1 -> rhs @ mode2 @@ mode3 = y + let x = (expr : lhs @ mode1 -> rhs @ mode2 @@ mode3) +end + +module Modalities_on_record_fields = struct + type t = + { x : t @@ mode1 mode2 + ; mutable x : t @@ mode1 mode2 + } + + type t = A of { x : t @@ mode1 mode2 } +end + +module Modalities_on_construct_arguments = struct + type t = + | A of typ @@ mode1 mode2 + | B of typ1 @@ mode1 * typ2 @@ mode2 + + type t = + | A : typ @@ mode1 mode2 -> t + | B : typ1 @@ mode1 * typ2 @@ mode2 -> t +end + +module type Value_descriptions = sig + val x : typ @@ mode1 mode2 + val x : typ1 typ2 @@ mode1 mode2 + val x : typ1 -> typ2 @@ mode1 mode2 + val x : typ1 * typ2 @@ mode1 mode2 +end + +module Let_bound_functions = struct + let (f @ mode) arg1 arg2 = x + let (f @ mode) arg1 arg2 : typ = x + let (f @ mode1 mode2) arg1 arg2 = x + + let (f @ mode) + (arg @ mode) + (arg : typ @@ mode) + ~lbl:(arg @ mode) + ~lbl:(arg : typ @@ mode) + ~(arg @ mode) + ~(arg : typ @@ mode) + ?lbl:(arg @ mode) + ?lbl:(arg : typ @@ mode) + ?lbl:(arg @ mode = value) + ?lbl:(arg : typ @@ mode = value) + ?(arg @ mode) + ?(arg : typ @@ mode) + ?(arg @ mode = value) + ?(arg : typ @@ mode = value) + : typ + = + value + ;; +end + +module No_illegal_sugaring = struct + let y = { x = (x : t @@ mode) } + let y = { x :> t = (x : t @@ mode) } +end + +module Line_breaking = struct + module Let_bindings = struct + let long_value_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + = + 1 + ;; + + let long_value_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + : t @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + = + 1 + ;; + + let long_value_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + : long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + = + 1 + ;; + end + + module Expressions = struct + let x = + (long_expr_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + : t + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) + ;; + + let x = + (long_expr_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + : long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) + ;; + end + + module Arrow_params = struct + type t = + arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + + type t = + long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> label:long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> ?label:long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> long_result_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + + let x + : arg @ mode1 mode2 -> arg @ mode1 mode2 -> arg @ mode1 mode2 -> arg @ mode1 mode2 + -> arg @ mode1 mode2 -> arg @ mode1 mode2 -> arg @ mode1 mode2 + = + y + ;; + + let x + : long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> label:long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> ?label:long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> long_result_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + = + y + ;; + + let x = + (expr + : arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + @@ mode1 mode2) + ;; + + let x = + (expr + : long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> label:long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> ?label:long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> long_result_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + @@ mode1 mode2) + ;; + end + + module Modalities_on_record_fields = struct + type t = + { long_field_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : t + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + ; mutable long_field_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : t + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + ; long_field_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : + long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + } + + type t = + | A of + { long_field_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : t + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + ; mutable long_field_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : t + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + ; long_field_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : + long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + } + end + + module Modalities_on_constructor_arguments = struct + type t = + | A of + long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + * long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + * long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + * short_type @@ mode1 mode2 + + type t = + | A : + long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + * long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + * long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + * short_type @@ mode1 mode2 + -> t + end + + module type Value_descriptions = sig + val long_value_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + : t + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + + val long_value_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + : long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + end + + module Let_bound_functions = struct + let (long_fun_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) + (long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) + (long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : + t + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) + (long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : + long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) + = + a + ;; + end +end + +module Interaction_with_existing_syntax = struct + (* let bindings *) + + let local_ x @ mode1 mode2 = y + let local_ x : typ1 typ2 @@ mode1 mode2 = y + + (* lhs/rhs of arrows *) + + type t = local_ lhs @ mode1 -> local_ mhs @ mode2 -> local_ rhs @ mode3 + + let x : local_ lhs @ mode1 -> local_ rhs @ mode2 @@ mode3 = y + let x = (expr : local_ lhs @ mode1 -> local_ rhs @ mode2 @@ mode3) + + (* modalities on record fields *) + + type t = { global_ x : t @@ mode1 mode2 } + type t = A of { global_ x : t @@ mode1 mode2 } + + (* modalities on constructor arguments *) + + type t = + | A of global_ typ @@ mode1 mode2 + | B of global_ typ1 @@ mode1 * global_ typ2 @@ mode2 + + type t = + | A : global_ typ @@ mode1 mode2 -> t + | B : global_ typ1 @@ mode1 * global_ typ2 @@ mode2 -> t +end + +module Regressions = struct + let x = + a_long_expression_that_has_its_own_line + @ (* a long comment that comes after the [@] *) + a_long_expression_that_comes_after_the_comment + ;; + + let (x, y) @ mode = + let (x, y) @ mode = x, y in + x, y + ;; + + let (t as t) @ mode = local_ + let (t as t) @ mode = local_ t in + t + ;; + + let (x, y) @ mode = local_ + let (x, y) @ mode = local_ t in + t + ;; + + class t = + let (x, y) @ mode = x in + object end +end diff --git a/test/passing/tests/modes.ml.ref b/test/passing/tests/modes.ml.ref new file mode 100644 index 0000000000..913e47c89b --- /dev/null +++ b/test/passing/tests/modes.ml.ref @@ -0,0 +1,471 @@ +(* The first half of this file tests basic formatting of the [@]-based mode + syntax in various positions to make sure we are able to handle them all, + and that they are correctly parenthesized. The second half more thoroughly + checks formatting when there are line breaks in various positions. *) + +(* Modes on arbitrary patterns were supported in the parser during + development of ocamlformat support for modes, but were later unsupported + in the parser. Tests of modes on patterns have thus been moved to + [test/failing/tests/modes_on_patterns.ml]. If patterns are ever again + supported in the parser, move those tests back to this file (and other + [modes*.ml] files in this directory). *) + +module Let_bindings = struct + let x @ mode = y + + let x @ mode1 mode2 = y + + let x : typ @@ mode1 mode2 = y + + let x : typ1 typ2 @@ mode1 mode2 = y + + let x : typ1 -> typ2 @@ mode1 mode2 = y + + let x : typ1 * typ2 @@ mode1 mode2 = y + + let x @ mode = x + + and y @ mode = y + + and z : typ @@ mode = z + + let () = + let x @ mode = y in + let x : typ @@ mode = y in + let x @ mode = x and y @ mode = y and z : typ @@ mode = z in + () + + let () = + let%bind x @ mode = y in + let%map x @ mode = y in + let%ext x : typ @@ mode = y in + let%ext x @ mode = x and y @ mode = y and z : typ @@ mode = z in + () +end + +module Expressions = struct + let x = (expr : typ @@ mode1 mode2) + + let x = (expr : typ1 typ2 @@ mode1 mode2) + + let x = (expr : typ1 -> typ2 @@ mode1 mode2) + + let x = (expr : typ1 * typ2 @@ mode1 mode2) + + (* mode constraints in expressions *) + let x = + { let1= + (let x = (x : _ @@ mode) and y = (y : _ @@ mode) in + (z : _ @@ mode) ) + ; function1= (function x -> (x : _ @@ mode) | y -> (y : _ @@ mode)) + ; fun1= (fun ?(x = (x : _ @@ mode)) () -> (y : _ @@ mode)) + ; apply1= (x : _ @@ mode) (y : _ @@ mode) + ; apply2= f ~lbl:(x : _ @@ mode) + ; apply3= f ~x:(x : _ @@ mode) + ; apply4= f ?lbl:(x : _ @@ mode) + ; apply5= f ?x:(x : _ @@ mode) + ; match1= + ( match (x : _ @@ mode) with + | y -> (y : _ @@ mode) + | z -> (z : _ @@ mode) ) + ; try1= (try (x : _ @@ mode) with y -> (y : _ @@ mode)) + ; tuple1= ((x : _ @@ mode), (y : _ @@ mode)) + ; tuple2= (~x:(x : _ @@ mode), ~y:(z : _ @@ mode)) + ; construct1= A (x : _ @@ mode) + ; construct2= A ((x : _ @@ mode), (y : _ @@ mode)) + ; variant1= `A (x : _ @@ mode) + ; variant2= `A ((x : _ @@ mode), (y : _ @@ mode)) + ; field1= (x : _ @@ mode).x + ; setfield1= (x : _ @@ mode).x <- (y : _ @@ mode) + ; array1= [|(x : _ @@ mode); (y : _ @@ mode)|] + ; array2= [:(x : _ @@ mode); (y : _ @@ mode):] + ; list1= [(x : _ @@ mode); (y : _ @@ mode)] + ; ite1= (if (x : _ @@ mode) then (y : _ @@ mode) else (z : _ @@ mode)) + ; sequence1= + ( (x : _ @@ mode) ; + (y : _ @@ mode) ) + ; while1= + while (x : _ @@ mode) do + (y : _ @@ mode) + done + ; for1= + for i = (x : _ @@ mode) to (y : _ @@ mode) do + (z : _ @@ mode) + done + ; constraint1= ((x : _ @@ mode) : _ @@ mode) + ; coerce1= ((x : _ @@ mode) :> _) + ; send1= (x : _ @@ mode)#y + ; setinstvar1= x <- (x : _ @@ mode) + ; override1= {} + ; letmodule1= + (let module M = ME in + (x : _ @@ mode) ) + ; letexception1= + (let exception E in + (x : _ @@ mode) ) + ; assert1= assert (x : _ @@ mode) + ; lazy1= lazy (x : _ @@ mode) + ; newtype1= (fun (type t) -> (x : _ @@ mode)) + ; open1= M.((x : _ @@ mode)) + ; letopen1= + (let open M in + (x : _ @@ mode) ) + ; letop1= + (let* x = (x : _ @@ mode) in + (y : _ @@ mode) ) + ; extension1= [%ext (x : _ @@ mode)] + ; cons1= (x : _ @@ mode) :: (y : _ @@ mode) :: (z : _ @@ mode) + ; prefix1= !(x : _ @@ mode) + ; infix1= (x : _ @@ mode) + (y : _ @@ mode) } + + (* expressions in mode constraints *) + let x = + { ident1= (x : _ @@ mode) + ; constant1= ("" : _ @@ mode) + ; let1= + ( let x = y in + z + : _ + @@ mode ) + ; function1= (function x -> x | y -> y : _ @@ mode) + ; fun1= (fun x -> y : _ @@ mode) + ; apply1= (f x : _ @@ mode) + ; match1= (match x with y -> y | z -> z : _ @@ mode) + ; try1= (try x with y -> y | z -> z : _ @@ mode) + ; tuple1= ((x, y) : _ @@ mode) + ; tuple2= ((~x, ~y) : _ @@ mode) + ; construct1= (A : _ @@ mode) + ; construct2= (A x : _ @@ mode) + ; construct3= (A (x, y) : _ @@ mode) + ; construct4= (A {x} : _ @@ mode) + ; variant1= (`A : _ @@ mode) + ; variant2= (`A x : _ @@ mode) + ; record1= ({x} : _ @@ mode) + ; field1= (x.y : _ @@ mode) + ; setfield1= (x.y <- z : _ @@ mode) + ; array1= ([|x|] : _ @@ mode) + ; array2= ([:x:] : _ @@ mode) + ; list1= ([x] : _ @@ mode) + ; ite1= (if x then y else z : _ @@ mode) + ; sequence1= (x ; y : _ @@ mode) + ; while1= + while x do + y + done + @@ mode + ; for1= + for x = y to z do + a + done + @@ mode + ; constraint1= ((x : _ @@ mode) : _ @@ mode) + ; coerce1= ((x :> _) : _ @@ mode) + ; send1= (x#y : _ @@ mode) + ; new1= (new x : _ @@ mode) + ; setinstvar1= (x <- 2 : _ @@ mode) + ; override1= ({} : _ @@ mode) + ; letmodule1= + ( let module M = ME in + x + : _ + @@ mode ) + ; letexception1= + ( let exception E in + x + : _ + @@ mode ) + ; assert1= (assert x : _ @@ mode) + ; lazy1= (lazy x : _ @@ mode) + ; object1= (object end : _ @@ mode) + ; newtype1= (fun (type t) -> x : _ @@ mode) + ; pack1= ((module M) : _ @@ mode) + ; pack2= ((module M : S) : _ @@ mode) + ; open1= (M.(x y) : _ @@ mode) + ; letopen1= + ( let open M in + x + : _ + @@ mode ) + ; letop1= + ( let* x = y in + z + : _ + @@ mode ) + ; extension1= ([%ext] : _ @@ mode) + ; hole1= (_ : _ @@ mode) + ; cons1= (x :: y :: z : _ @@ mode) + ; prefix1= (!x : _ @@ mode) + ; infix1= (x + y : _ @@ mode) } +end + +module Arrow_params = struct + type t = lhs @ mode1 mode2 -> rhs @ mode3 mode4 + + type t = + arg1 @ mode1 -> lbl:arg2 @ mode2 -> ?lbl:arg3 @ mode3 -> res @ mode4 + + let x : lhs @ mode1 -> rhs @ mode2 @@ mode3 = y + + let x = (expr : lhs @ mode1 -> rhs @ mode2 @@ mode3) +end + +module Modalities_on_record_fields = struct + type t = {x: t @@ mode1 mode2; mutable x: t @@ mode1 mode2} + + type t = A of {x: t @@ mode1 mode2} +end + +module Modalities_on_construct_arguments = struct + type t = A of typ @@ mode1 mode2 | B of typ1 @@ mode1 * typ2 @@ mode2 + + type t = + | A : typ @@ mode1 mode2 -> t + | B : typ1 @@ mode1 * typ2 @@ mode2 -> t +end + +module type Value_descriptions = sig + val x : typ @@ mode1 mode2 + + val x : typ1 typ2 @@ mode1 mode2 + + val x : typ1 -> typ2 @@ mode1 mode2 + + val x : typ1 * typ2 @@ mode1 mode2 +end + +module Let_bound_functions = struct + let (f @ mode) arg1 arg2 = x + + let (f @ mode) arg1 arg2 : typ = x + + let (f @ mode1 mode2) arg1 arg2 = x + + let (f @ mode) (arg @ mode) (arg : typ @@ mode) ~lbl:(arg @ mode) + ~lbl:(arg : typ @@ mode) ~(arg @ mode) ~(arg : typ @@ mode) + ?lbl:(arg @ mode) ?lbl:(arg : typ @@ mode) ?lbl:(arg @ mode = value) + ?lbl:(arg : typ @@ mode = value) ?(arg @ mode) ?(arg : typ @@ mode) + ?(arg @ mode = value) ?(arg : typ @@ mode = value) : typ = + value +end + +module No_illegal_sugaring = struct + let y = {x= (x : t @@ mode)} + + let y = {x:> t = (x : t @@ mode)} +end + +module Line_breaking = struct + module Let_bindings = struct + let long_value_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 = + 1 + + let long_value_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : t + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 = + 1 + + let long_value_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : + long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 = + 1 + end + + module Expressions = struct + let x = + ( long_expr_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + : t + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 ) + + let x = + ( long_expr_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + : long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 ) + end + + module Arrow_params = struct + type t = + arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + + type t = + long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> label:long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> ?label:long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> long_result_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + + let x : + arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 = + y + + let x : + long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> label:long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> ?label:long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> long_result_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 = + y + + let x = + ( expr + : arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + -> arg @ mode1 mode2 + @@ mode1 mode2 ) + + let x = + ( expr + : long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> label:long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> ?label:long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + -> long_result_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + @@ mode1 mode2 ) + end + + module Modalities_on_record_fields = struct + type t = + { long_field_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa: t + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + ; mutable long_field_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa: t + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + ; long_field_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa: + long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 } + + type t = + | A of + { long_field_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa: t + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + ; mutable long_field_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa: t + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + ; long_field_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa: + long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 } + end + + module Modalities_on_constructor_arguments = struct + type t = + | A of + long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + * long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + * long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + * short_type @@ mode1 mode2 + + type t = + | A : + long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + * long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + * long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + * short_type @@ mode1 mode2 + -> t + end + + module type Value_descriptions = sig + val long_value_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : t + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + + val long_value_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : + long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + end + + module Let_bound_functions = struct + let (long_fun_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) + (long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 ) + (long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : + t + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 ) + (long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : + long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 ) = + a + end +end + +module Interaction_with_existing_syntax = struct + (* let bindings *) + + let local_ x @ mode1 mode2 = y + + let local_ x : typ1 typ2 @@ mode1 mode2 = y + + (* lhs/rhs of arrows *) + + type t = local_ lhs @ mode1 -> local_ mhs @ mode2 -> local_ rhs @ mode3 + + let x : local_ lhs @ mode1 -> local_ rhs @ mode2 @@ mode3 = y + + let x = (expr : local_ lhs @ mode1 -> local_ rhs @ mode2 @@ mode3) + + (* modalities on record fields *) + + type t = {global_ x: t @@ mode1 mode2} + + type t = A of {global_ x: t @@ mode1 mode2} + + (* modalities on constructor arguments *) + + type t = + | A of global_ typ @@ mode1 mode2 + | B of global_ typ1 @@ mode1 * global_ typ2 @@ mode2 + + type t = + | A : global_ typ @@ mode1 mode2 -> t + | B : global_ typ1 @@ mode1 * global_ typ2 @@ mode2 -> t +end + +module Regressions = struct + let x = + a_long_expression_that_has_its_own_line + @ (* a long comment that comes after the [@] *) + a_long_expression_that_comes_after_the_comment + + let (x, y) @ mode = + let (x, y) @ mode = (x, y) in + (x, y) + + let (t as t) @ mode = local_ + let (t as t) @ mode = local_ t in + t + + let (x, y) @ mode = local_ + let (x, y) @ mode = local_ t in + t + + class t = + let (x, y) @ mode = x in + object end +end diff --git a/test/passing/tests/modes_attrs.ml b/test/passing/tests/modes_attrs.ml new file mode 100644 index 0000000000..75db8804ee --- /dev/null +++ b/test/passing/tests/modes_attrs.ml @@ -0,0 +1,68 @@ +(* let bindings *) + +let[@attr] x @ mode1 mode2 = y +let[@attr] x : typ @@ mode1 mode2 = y + +(* expressions *) + +let x = (expr [@attr] : typ @@ mode1 mode2) +let x = (expr : (typ[@attr]) @@ mode1 mode2) +let x = ((expr : typ @@ mode1 mode2) [@attr]) + +(* lhs/rhs of arrows *) + +type t = (lhs[@attr]) @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 +type t = lhs @ m1 m2 -> (mhs[@attr]) @ m3 m4 -> rhs @ m5 m6 +type t = lhs @ m1 m2 -> mhs @ m3 m4 -> (rhs[@attr]) @ m5 m6 +type t = lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 [@@attr] + +let x : (lhs[@attr]) @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y +let x : lhs @ m1 m2 -> (mhs[@attr]) @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> (rhs[@attr]) @ m5 m6 @@ m7 m8 = y +let x = (expr [@attr] : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) +let x = (expr : (lhs[@attr]) @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) +let x = (expr : lhs @ m1 m2 -> (mhs[@attr]) @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> (rhs[@attr]) @ m5 m6 @@ m7 m8) +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) [@@attr] + +(* modalities on record fields *) + +type t = { x : (t[@attr]) @@ mode1 mode2 } +type t = { x : t @@ mode1 mode2 } +type t = { x : t @@ mode1 mode2 [@attr] } +type t = { mutable x : (t[@attr]) @@ mode1 mode2 } +type t = { mutable x : t @@ mode1 mode2 [@attr] } + +(* modalities on constructor arguments *) + +type t = + | A of (t1[@attr]) @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * (t2[@attr]) @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * ((t3[@attr]) @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> (t4[@attr]) @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * ((t3 @ m5 -> t4 @ m6)[@attr]) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 [@attr] + +type t = + | A : (t1[@attr]) @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * (t2[@attr]) @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * ((t3[@attr]) @ m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> (t4[@attr]) @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * ((t3 @ m5 -> t4 @ m6)[@attr]) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t [@attr] + +(* value descriptions *) + +module type S = sig + val x : (t1[@attr]) @ m1 m2 -> t2 @ m3 m4 @@ m5 m6 + val x : t1 @ m1 m2 -> (t2[@attr]) @ m3 m4 @@ m5 m6 + val x : t1 @ m1 m2 -> t2 @ m3 m4 @@ m5 m6 [@@attr] +end + +(* let-bound functions *) + +let[@attr] (f @ mode1) (arg1 @ mode2) (arg2 @ mode3) : typ = x +let (f @ mode1) ((arg1 [@attr]) @ mode2) (arg2 @ mode3) : typ = x +let (f @ mode1) (arg1 @ mode2) ((arg2 [@attr]) @ mode3) : typ = x +let (f @ mode1) (arg1 @ mode2) (arg2 @ mode3) : (typ[@attr]) = x +let (f @ mode1) (arg1 @ mode2) (arg2 @ mode3) : typ = x [@@attr] diff --git a/test/passing/tests/modes_attrs.ml.js-ref b/test/passing/tests/modes_attrs.ml.js-ref new file mode 100644 index 0000000000..75db8804ee --- /dev/null +++ b/test/passing/tests/modes_attrs.ml.js-ref @@ -0,0 +1,68 @@ +(* let bindings *) + +let[@attr] x @ mode1 mode2 = y +let[@attr] x : typ @@ mode1 mode2 = y + +(* expressions *) + +let x = (expr [@attr] : typ @@ mode1 mode2) +let x = (expr : (typ[@attr]) @@ mode1 mode2) +let x = ((expr : typ @@ mode1 mode2) [@attr]) + +(* lhs/rhs of arrows *) + +type t = (lhs[@attr]) @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 +type t = lhs @ m1 m2 -> (mhs[@attr]) @ m3 m4 -> rhs @ m5 m6 +type t = lhs @ m1 m2 -> mhs @ m3 m4 -> (rhs[@attr]) @ m5 m6 +type t = lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 [@@attr] + +let x : (lhs[@attr]) @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y +let x : lhs @ m1 m2 -> (mhs[@attr]) @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> (rhs[@attr]) @ m5 m6 @@ m7 m8 = y +let x = (expr [@attr] : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) +let x = (expr : (lhs[@attr]) @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) +let x = (expr : lhs @ m1 m2 -> (mhs[@attr]) @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> (rhs[@attr]) @ m5 m6 @@ m7 m8) +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) [@@attr] + +(* modalities on record fields *) + +type t = { x : (t[@attr]) @@ mode1 mode2 } +type t = { x : t @@ mode1 mode2 } +type t = { x : t @@ mode1 mode2 [@attr] } +type t = { mutable x : (t[@attr]) @@ mode1 mode2 } +type t = { mutable x : t @@ mode1 mode2 [@attr] } + +(* modalities on constructor arguments *) + +type t = + | A of (t1[@attr]) @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * (t2[@attr]) @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * ((t3[@attr]) @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> (t4[@attr]) @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * ((t3 @ m5 -> t4 @ m6)[@attr]) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 [@attr] + +type t = + | A : (t1[@attr]) @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * (t2[@attr]) @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * ((t3[@attr]) @ m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> (t4[@attr]) @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * ((t3 @ m5 -> t4 @ m6)[@attr]) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t [@attr] + +(* value descriptions *) + +module type S = sig + val x : (t1[@attr]) @ m1 m2 -> t2 @ m3 m4 @@ m5 m6 + val x : t1 @ m1 m2 -> (t2[@attr]) @ m3 m4 @@ m5 m6 + val x : t1 @ m1 m2 -> t2 @ m3 m4 @@ m5 m6 [@@attr] +end + +(* let-bound functions *) + +let[@attr] (f @ mode1) (arg1 @ mode2) (arg2 @ mode3) : typ = x +let (f @ mode1) ((arg1 [@attr]) @ mode2) (arg2 @ mode3) : typ = x +let (f @ mode1) (arg1 @ mode2) ((arg2 [@attr]) @ mode3) : typ = x +let (f @ mode1) (arg1 @ mode2) (arg2 @ mode3) : (typ[@attr]) = x +let (f @ mode1) (arg1 @ mode2) (arg2 @ mode3) : typ = x [@@attr] diff --git a/test/passing/tests/modes_attrs.ml.ref b/test/passing/tests/modes_attrs.ml.ref new file mode 100644 index 0000000000..d0b0cad478 --- /dev/null +++ b/test/passing/tests/modes_attrs.ml.ref @@ -0,0 +1,102 @@ +(* let bindings *) + +let[@attr] x @ mode1 mode2 = y + +let[@attr] x : typ @@ mode1 mode2 = y + +(* expressions *) + +let x = (expr [@attr] : typ @@ mode1 mode2) + +let x = (expr : (typ[@attr]) @@ mode1 mode2) + +let x = ((expr : typ @@ mode1 mode2) [@attr]) + +(* lhs/rhs of arrows *) + +type t = (lhs[@attr]) @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 + +type t = lhs @ m1 m2 -> (mhs[@attr]) @ m3 m4 -> rhs @ m5 m6 + +type t = lhs @ m1 m2 -> mhs @ m3 m4 -> (rhs[@attr]) @ m5 m6 + +type t = lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 [@@attr] + +let x : (lhs[@attr]) @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y + +let x : lhs @ m1 m2 -> (mhs[@attr]) @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y + +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> (rhs[@attr]) @ m5 m6 @@ m7 m8 = y + +let x = (expr [@attr] : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) + +let x = (expr : (lhs[@attr]) @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) + +let x = (expr : lhs @ m1 m2 -> (mhs[@attr]) @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) + +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> (rhs[@attr]) @ m5 m6 @@ m7 m8) + +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) [@@attr] + +(* modalities on record fields *) + +type t = {x: (t[@attr]) @@ mode1 mode2} + +type t = {x: t @@ mode1 mode2} + +type t = {x: t @@ mode1 mode2 [@attr]} + +type t = {mutable x: (t[@attr]) @@ mode1 mode2} + +type t = {mutable x: t @@ mode1 mode2 [@attr]} + +(* modalities on constructor arguments *) + +type t = + | A of (t1[@attr]) @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * (t2[@attr]) @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * ((t3[@attr]) @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> (t4[@attr]) @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * ((t3 @ m5 -> t4 @ m6)[@attr]) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 [@attr] + +type t = + | A : + (t1[@attr]) @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 * (t2[@attr]) @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 * t2 @@ m3 m4 * ((t3[@attr]) @ m5 -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> (t4[@attr]) @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 * t2 @@ m3 m4 * ((t3 @ m5 -> t4 @ m6)[@attr]) @@ m7 m8 + -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t + [@attr] + +(* value descriptions *) + +module type S = sig + val x : (t1[@attr]) @ m1 m2 -> t2 @ m3 m4 @@ m5 m6 + + val x : t1 @ m1 m2 -> (t2[@attr]) @ m3 m4 @@ m5 m6 + + val x : t1 @ m1 m2 -> t2 @ m3 m4 @@ m5 m6 [@@attr] +end + +(* let-bound functions *) + +let[@attr] (f @ mode1) (arg1 @ mode2) (arg2 @ mode3) : typ = x + +let (f @ mode1) ((arg1 [@attr]) @ mode2) (arg2 @ mode3) : typ = x + +let (f @ mode1) (arg1 @ mode2) ((arg2 [@attr]) @ mode3) : typ = x + +let (f @ mode1) (arg1 @ mode2) (arg2 @ mode3) : (typ[@attr]) = x + +let (f @ mode1) (arg1 @ mode2) (arg2 @ mode3) : typ = x [@@attr] diff --git a/test/passing/tests/modes_cmts-break_separators_after.ml.opts b/test/passing/tests/modes_cmts-break_separators_after.ml.opts new file mode 100644 index 0000000000..c01404ad83 --- /dev/null +++ b/test/passing/tests/modes_cmts-break_separators_after.ml.opts @@ -0,0 +1 @@ +--break-separators=after diff --git a/test/passing/tests/modes_cmts-break_separators_after.ml.ref b/test/passing/tests/modes_cmts-break_separators_after.ml.ref new file mode 100644 index 0000000000..0cd07c5a14 --- /dev/null +++ b/test/passing/tests/modes_cmts-break_separators_after.ml.ref @@ -0,0 +1,377 @@ +(* Check that comments are not dropped or moved in unusual ways. A few + commented out tests where comments move have explanations, and are tested + in [modes_cmts_move.ml]. *) + +(* let bindings *) + +let (* cmt *) x @ mode1 mode2 = y + +let x (* cmt *) @ mode1 mode2 = y + +let x @ (* cmt *) mode1 mode2 = y + +let x @ mode1 (* cmt *) mode2 = y + +let x @ mode1 mode2 (* cmt *) = y + +let x @ mode1 mode2 = (* cmt *) y + +let (* cmt *) x : typ @@ mode1 mode2 = y + +let x (* cmt *) : typ @@ mode1 mode2 = y + +let x : (* cmt *) typ @@ mode1 mode2 = y + +let x : typ (* cmt *) @@ mode1 mode2 = y + +let x : typ @@ (* cmt *) mode1 mode2 = y + +let x : typ @@ mode1 (* cmt *) mode2 = y + +let x : typ @@ mode1 mode2 (* cmt *) = y + +let x : typ @@ mode1 mode2 = (* cmt *) y + +(* expressions *) + +let x = ((* cmt *) expr : typ @@ mode1 mode2) + +let x = (expr (* cmt *) : typ @@ mode1 mode2) + +let x = (expr : (* cmt *) typ @@ mode1 mode2) + +let x = (expr : typ (* cmt *) @@ mode1 mode2) + +let x = (expr : typ @@ (* cmt *) mode1 mode2) + +let x = (expr : typ @@ mode1 (* cmt *) mode2) + +let x = (expr : typ @@ mode1 mode2 (* cmt *)) + +(* lhs/rhs of arrows *) + +type t = (* cmt *) lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 + +type t = lhs (* cmt *) @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 + +type t = lhs @ (* cmt *) m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 + +type t = lhs @ m1 (* cmt *) m2 -> mhs @ m3 m4 -> rhs @ m5 m6 + +type t = lhs @ m1 m2 (* cmt *) -> mhs @ m3 m4 -> rhs @ m5 m6 + +type t = lhs @ m1 m2 -> (* cmt *) mhs @ m3 m4 -> rhs @ m5 m6 + +type t = lhs @ m1 m2 -> mhs (* cmt *) @ m3 m4 -> rhs @ m5 m6 + +type t = lhs @ m1 m2 -> mhs @ (* cmt *) m3 m4 -> rhs @ m5 m6 + +type t = lhs @ m1 m2 -> mhs @ m3 (* cmt *) m4 -> rhs @ m5 m6 + +type t = lhs @ m1 m2 -> mhs @ m3 m4 (* cmt *) -> rhs @ m5 m6 + +type t = lhs @ m1 m2 -> mhs @ m3 m4 -> (* cmt *) rhs @ m5 m6 + +type t = lhs @ m1 m2 -> mhs @ m3 m4 -> rhs (* cmt *) @ m5 m6 + +type t = lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ (* cmt *) m5 m6 + +type t = lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 (* cmt *) m6 + +type t = lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 (* cmt *) + +let x : (* cmt *) lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y + +let x : lhs (* cmt *) @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y + +let x : lhs @ (* cmt *) m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y + +let x : lhs @ m1 (* cmt *) m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y + +let x : lhs @ m1 m2 (* cmt *) -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y + +let x : lhs @ m1 m2 -> (* cmt *) mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y + +let x : lhs @ m1 m2 -> mhs (* cmt *) @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y + +let x : lhs @ m1 m2 -> mhs @ (* cmt *) m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y + +let x : lhs @ m1 m2 -> mhs @ m3 (* cmt *) m4 -> rhs @ m5 m6 @@ m7 m8 = y + +let x : lhs @ m1 m2 -> mhs @ m3 m4 (* cmt *) -> rhs @ m5 m6 @@ m7 m8 = y + +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> (* cmt *) rhs @ m5 m6 @@ m7 m8 = y + +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs (* cmt *) @ m5 m6 @@ m7 m8 = y + +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ (* cmt *) m5 m6 @@ m7 m8 = y + +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 (* cmt *) m6 @@ m7 m8 = y + +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 (* cmt *) @@ m7 m8 = y + +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ (* cmt *) m7 m8 = y + +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 (* cmt *) m8 = y + +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 (* cmt *) = y + +let x = (expr (* cmt *) : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) + +let x = (expr : (* cmt *) lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) + +let x = (expr : lhs (* cmt *) @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) + +let x = (expr : lhs @ (* cmt *) m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) + +let x = (expr : lhs @ m1 (* cmt *) m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) + +let x = (expr : lhs @ m1 m2 (* cmt *) -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) + +let x = (expr : lhs @ m1 m2 -> (* cmt *) mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) + +let x = (expr : lhs @ m1 m2 -> mhs (* cmt *) @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) + +let x = (expr : lhs @ m1 m2 -> mhs @ (* cmt *) m3 m4 -> rhs @ m5 m6 @@ m7 m8) + +let x = (expr : lhs @ m1 m2 -> mhs @ m3 (* cmt *) m4 -> rhs @ m5 m6 @@ m7 m8) + +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 (* cmt *) -> rhs @ m5 m6 @@ m7 m8) + +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> (* cmt *) rhs @ m5 m6 @@ m7 m8) + +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs (* cmt *) @ m5 m6 @@ m7 m8) + +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ (* cmt *) m5 m6 @@ m7 m8) + +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 (* cmt *) m6 @@ m7 m8) + +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 (* cmt *) @@ m7 m8) + +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ (* cmt *) m7 m8) + +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 (* cmt *) m8) + +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 (* cmt *)) + +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) (* cmt *) + +(* modalities on record fields *) + +type t = {x (* cmt *): t @@ mode1 mode2; y: t @@ mode1 mode2} + +type t = {x: (* cmt *) t @@ mode1 mode2; y: t @@ mode1 mode2} + +type t = {x: t (* cmt *) @@ mode1 mode2; y: t @@ mode1 mode2} + +type t = {x: t @@ (* cmt *) mode1 mode2; y: t @@ mode1 mode2} + +type t = {x: t @@ mode1 (* cmt *) mode2; y: t @@ mode1 mode2} + +type t = {x: t @@ mode1 mode2; (* cmt *) y: t @@ mode1 mode2} + +type t = {x: t @@ mode1 mode2; (* cmt *) y: t @@ mode1 mode2} + +type t = {x: t @@ mode1 mode2; y (* cmt *): t @@ mode1 mode2} + +type t = {x: t @@ mode1 mode2; y: (* cmt *) t @@ mode1 mode2} + +type t = {x: t @@ mode1 mode2; y: t (* cmt *) @@ mode1 mode2} + +type t = {x: t @@ mode1 mode2; y: t @@ (* cmt *) mode1 mode2} + +type t = {x: t @@ mode1 mode2; y: t @@ mode1 (* cmt *) mode2} + +type t = {x: t @@ mode1 mode2; y: t @@ mode1 mode2 (* cmt *)} + +type t = {mutable x (* cmt *): t @@ mode1 mode2; y: t @@ mode1 mode2} + +type t = {mutable x: (* cmt *) t @@ mode1 mode2; y: t @@ mode1 mode2} + +type t = {mutable x: t (* cmt *) @@ mode1 mode2; y: t @@ mode1 mode2} + +type t = {mutable x: t @@ (* cmt *) mode1 mode2; y: t @@ mode1 mode2} + +type t = {mutable x: t @@ mode1 (* cmt *) mode2; y: t @@ mode1 mode2} + +type t = {mutable x: t @@ mode1 mode2; (* cmt *) y: t @@ mode1 mode2} + +type t = {mutable x: t @@ mode1 mode2; (* cmt *) y: t @@ mode1 mode2} + +type t = {mutable x: t @@ mode1 mode2; y (* cmt *): t @@ mode1 mode2} + +type t = {mutable x: t @@ mode1 mode2; y: (* cmt *) t @@ mode1 mode2} + +type t = {mutable x: t @@ mode1 mode2; y: t (* cmt *) @@ mode1 mode2} + +type t = {mutable x: t @@ mode1 mode2; y: t @@ (* cmt *) mode1 mode2} + +type t = {mutable x: t @@ mode1 mode2; y: t @@ mode1 (* cmt *) mode2} + +type t = {mutable x: t @@ mode1 mode2; y: t @@ mode1 mode2 (* cmt *)} + +(* modalities on constructor arguments *) + +type t = + | A of (* cmt *) t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 (* cmt *) @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ (* cmt *) m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 (* cmt *) m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 (* cmt *) * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * (* cmt *) t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 (* cmt *) @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ (* cmt *) m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 (* cmt *) m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 (* cmt *) * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (* cmt *) (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * ((* cmt *) t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 (* cmt *) @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ (* cmt *) m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 (* cmt *) -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> (* cmt *) t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 (* cmt *) @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ (* cmt *) m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6 (* cmt *)) @@ m7 m8 + (* | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) (* cmt *) @@ m7 + m8 *) + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ (* cmt *) m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 (* cmt *) m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 (* cmt *) + +type t = + | A : + (* cmt *) t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 (* cmt *) @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ (* cmt *) m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 (* cmt *) m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 (* cmt *) * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 * (* cmt *) t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 * t2 (* cmt *) @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 * t2 @@ (* cmt *) m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 * t2 @@ m3 (* cmt *) m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 * t2 @@ m3 m4 (* cmt *) * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 * t2 @@ m3 m4 * (* cmt *) (t3 @ m5 -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 * t2 @@ m3 m4 * ((* cmt *) t3 @ m5 -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 (* cmt *) @ m5 -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ (* cmt *) m5 -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 (* cmt *) -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> (* cmt *) t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 (* cmt *) @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ (* cmt *) m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6 (* cmt *)) @@ m7 m8 + -> t + (* Comment moves between [@@] and [m7]: | A : t1 @@ m1 m2 * t2 @@ m3 m4 * + (t3 @ m5 -> t4 @ m6) (* cmt *) @@ m7 m8 -> t *) + | A : + t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ (* cmt *) m7 m8 + -> t + | A : + t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 (* cmt *) m8 + -> t + | A : + t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 (* cmt *) + -> t + +(* value descriptions *) + +module type S = sig + val x : (* cmt *) t1 @ m1 m2 -> t2 @ m3 m4 @@ m5 m6 + + val x : t1 (* cmt *) @ m1 m2 -> t2 @ m3 m4 @@ m5 m6 + + val x : t1 @ (* cmt *) m1 m2 -> t2 @ m3 m4 @@ m5 m6 + + val x : t1 @ m1 (* cmt *) m2 -> t2 @ m3 m4 @@ m5 m6 + + val x : t1 @ m1 m2 (* cmt *) -> t2 @ m3 m4 @@ m5 m6 + + val x : t1 @ m1 m2 -> (* cmt *) t2 @ m3 m4 @@ m5 m6 + + val x : t1 @ m1 m2 -> t2 (* cmt *) @ m3 m4 @@ m5 m6 + + val x : t1 @ m1 m2 -> t2 @ (* cmt *) m3 m4 @@ m5 m6 + + val x : t1 @ m1 m2 -> t2 @ m3 (* cmt *) m4 @@ m5 m6 + + val x : t1 @ m1 m2 -> t2 @ m3 m4 (* cmt *) @@ m5 m6 + + val x : t1 @ m1 m2 -> t2 @ m3 m4 @@ (* cmt *) m5 m6 + + val x : t1 @ m1 m2 -> t2 @ m3 m4 @@ m5 (* cmt *) m6 + + val x : t1 @ m1 m2 -> t2 @ m3 m4 @@ m5 m6 (* cmt *) +end + +(* let-bound functions *) + +(* Comment moves to between [(] and [f]: let (* cmt *) (f @ mode1) (arg1 @ + mode2) (arg2 @ mode3) : typ = x *) + +let ((* cmt *) f @ mode1) (arg1 @ mode2) (arg2 @ mode3) : typ = x + +let (f (* cmt *) @ mode1) (arg1 @ mode2) (arg2 @ mode3) : typ = x + +let (f @ (* cmt *) mode1) (arg1 @ mode2) (arg2 @ mode3) : typ = x + +let (f @ mode1 (* cmt *)) (arg1 @ mode2) (arg2 @ mode3) : typ = x + +let (f @ mode1) (* cmt *) (arg1 @ mode2) (arg2 @ mode3) : typ = x + +let (f @ mode1) ((* cmt *) arg1 @ mode2) (arg2 @ mode3) : typ = x + +let (f @ mode1) (arg1 (* cmt *) @ mode2) (arg2 @ mode3) : typ = x + +let (f @ mode1) (arg1 @ (* cmt *) mode2) (arg2 @ mode3) : typ = x + +let (f @ mode1) (arg1 @ mode2 (* cmt *)) (arg2 @ mode3) : typ = x + +let (f @ mode1) (arg1 @ mode2) (* cmt *) (arg2 @ mode3) : typ = x + +let (f @ mode1) (arg1 @ mode2) ((* cmt *) arg2 @ mode3) : typ = x + +let (f @ mode1) (arg1 @ mode2) (arg2 (* cmt *) @ mode3) : typ = x + +let (f @ mode1) (arg1 @ mode2) (arg2 @ (* cmt *) mode3) : typ = x + +let (f @ mode1) (arg1 @ mode2) (arg2 @ mode3 (* cmt *)) : typ = x + +(* Comment moves to after [=], but not because of modes: let (f @ mode1) + (arg1 @ mode2) (arg2 @ mode3) (* cmt *) : typ = x *) + +let (f @ mode1) (arg1 @ mode2) (arg2 @ mode3) : (* cmt *) typ = x diff --git a/test/passing/tests/modes_cmts-break_separators_after.ml.why-no-js b/test/passing/tests/modes_cmts-break_separators_after.ml.why-no-js new file mode 100644 index 0000000000..45bdf675a8 --- /dev/null +++ b/test/passing/tests/modes_cmts-break_separators_after.ml.why-no-js @@ -0,0 +1 @@ +This tests the behavior of a particular option which would be overriden by [.js-ref]. diff --git a/test/passing/tests/modes_cmts.ml b/test/passing/tests/modes_cmts.ml new file mode 100644 index 0000000000..46c9d72edd --- /dev/null +++ b/test/passing/tests/modes_cmts.ml @@ -0,0 +1,212 @@ +(* Check that comments are not dropped or moved in unusual ways. + A few commented out tests where comments move have explanations, and are + tested in [modes_cmts_move.ml]. *) + +(* let bindings *) + +let (* cmt *) x @ mode1 mode2 = y +let x (* cmt *) @ mode1 mode2 = y +let x @ (* cmt *) mode1 mode2 = y +let x @ mode1 (* cmt *) mode2 = y +let x @ mode1 mode2 (* cmt *) = y +let x @ mode1 mode2 = (* cmt *) y +let (* cmt *) x : typ @@ mode1 mode2 = y +let x (* cmt *) : typ @@ mode1 mode2 = y +let x : (* cmt *) typ @@ mode1 mode2 = y +let x : typ (* cmt *) @@ mode1 mode2 = y +let x : typ @@ (* cmt *) mode1 mode2 = y +let x : typ @@ mode1 (* cmt *) mode2 = y +let x : typ @@ mode1 mode2 (* cmt *) = y +let x : typ @@ mode1 mode2 = (* cmt *) y + +(* expressions *) + +let x = ((* cmt *) expr : typ @@ mode1 mode2) +let x = (expr (* cmt *) : typ @@ mode1 mode2) +let x = (expr : (* cmt *) typ @@ mode1 mode2) +let x = (expr : typ (* cmt *) @@ mode1 mode2) +let x = (expr : typ @@ (* cmt *) mode1 mode2) +let x = (expr : typ @@ mode1 (* cmt *) mode2) +let x = (expr : typ @@ mode1 mode2 (* cmt *)) + +(* lhs/rhs of arrows *) + +type t = (* cmt *) lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 +type t = lhs (* cmt *) @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 +type t = lhs @ (* cmt *) m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 +type t = lhs @ m1 (* cmt *) m2 -> mhs @ m3 m4 -> rhs @ m5 m6 +type t = lhs @ m1 m2 (* cmt *) -> mhs @ m3 m4 -> rhs @ m5 m6 +type t = lhs @ m1 m2 -> (* cmt *) mhs @ m3 m4 -> rhs @ m5 m6 +type t = lhs @ m1 m2 -> mhs (* cmt *) @ m3 m4 -> rhs @ m5 m6 +type t = lhs @ m1 m2 -> mhs @ (* cmt *) m3 m4 -> rhs @ m5 m6 +type t = lhs @ m1 m2 -> mhs @ m3 (* cmt *) m4 -> rhs @ m5 m6 +type t = lhs @ m1 m2 -> mhs @ m3 m4 (* cmt *) -> rhs @ m5 m6 +type t = lhs @ m1 m2 -> mhs @ m3 m4 -> (* cmt *) rhs @ m5 m6 +type t = lhs @ m1 m2 -> mhs @ m3 m4 -> rhs (* cmt *) @ m5 m6 +type t = lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ (* cmt *) m5 m6 +type t = lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 (* cmt *) m6 +type t = lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 (* cmt *) + +let x : (* cmt *) lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y +let x : lhs (* cmt *) @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y +let x : lhs @ (* cmt *) m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y +let x : lhs @ m1 (* cmt *) m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y +let x : lhs @ m1 m2 (* cmt *) -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y +let x : lhs @ m1 m2 -> (* cmt *) mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y +let x : lhs @ m1 m2 -> mhs (* cmt *) @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y +let x : lhs @ m1 m2 -> mhs @ (* cmt *) m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y +let x : lhs @ m1 m2 -> mhs @ m3 (* cmt *) m4 -> rhs @ m5 m6 @@ m7 m8 = y +let x : lhs @ m1 m2 -> mhs @ m3 m4 (* cmt *) -> rhs @ m5 m6 @@ m7 m8 = y +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> (* cmt *) rhs @ m5 m6 @@ m7 m8 = y +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs (* cmt *) @ m5 m6 @@ m7 m8 = y +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ (* cmt *) m5 m6 @@ m7 m8 = y +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 (* cmt *) m6 @@ m7 m8 = y +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 (* cmt *) @@ m7 m8 = y +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ (* cmt *) m7 m8 = y +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 (* cmt *) m8 = y +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 (* cmt *) = y +let x = (expr (* cmt *) : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) +let x = (expr : (* cmt *) lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) +let x = (expr : lhs (* cmt *) @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) +let x = (expr : lhs @ (* cmt *) m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) +let x = (expr : lhs @ m1 (* cmt *) m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) +let x = (expr : lhs @ m1 m2 (* cmt *) -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) +let x = (expr : lhs @ m1 m2 -> (* cmt *) mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) +let x = (expr : lhs @ m1 m2 -> mhs (* cmt *) @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) +let x = (expr : lhs @ m1 m2 -> mhs @ (* cmt *) m3 m4 -> rhs @ m5 m6 @@ m7 m8) +let x = (expr : lhs @ m1 m2 -> mhs @ m3 (* cmt *) m4 -> rhs @ m5 m6 @@ m7 m8) +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 (* cmt *) -> rhs @ m5 m6 @@ m7 m8) +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> (* cmt *) rhs @ m5 m6 @@ m7 m8) +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs (* cmt *) @ m5 m6 @@ m7 m8) +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ (* cmt *) m5 m6 @@ m7 m8) +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 (* cmt *) m6 @@ m7 m8) +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 (* cmt *) @@ m7 m8) +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ (* cmt *) m7 m8) +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 (* cmt *) m8) +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 (* cmt *)) +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) (* cmt *) + +(* modalities on record fields *) + +type t = { x (* cmt *) : t @@ mode1 mode2; y : t @@ mode1 mode2 } +type t = { x : (* cmt *) t @@ mode1 mode2; y : t @@ mode1 mode2 } +type t = { x : t (* cmt *) @@ mode1 mode2; y : t @@ mode1 mode2 } +type t = { x : t @@ (* cmt *) mode1 mode2; y : t @@ mode1 mode2 } +type t = { x : t @@ mode1 (* cmt *) mode2; y : t @@ mode1 mode2 } +type t = { x : t @@ mode1 mode2 (* cmt *); y : t @@ mode1 mode2 } +type t = { x : t @@ mode1 mode2; (* cmt *) y : t @@ mode1 mode2 } +type t = { x : t @@ mode1 mode2; y (* cmt *) : t @@ mode1 mode2 } +type t = { x : t @@ mode1 mode2; y : (* cmt *) t @@ mode1 mode2 } +type t = { x : t @@ mode1 mode2; y : t (* cmt *) @@ mode1 mode2 } +type t = { x : t @@ mode1 mode2; y : t @@ (* cmt *) mode1 mode2 } +type t = { x : t @@ mode1 mode2; y : t @@ mode1 (* cmt *) mode2 } +type t = { x : t @@ mode1 mode2; y : t @@ mode1 mode2 (* cmt *) } +type t = { mutable x (* cmt *) : t @@ mode1 mode2; y : t @@ mode1 mode2 } +type t = { mutable x : (* cmt *) t @@ mode1 mode2; y : t @@ mode1 mode2 } +type t = { mutable x : t (* cmt *) @@ mode1 mode2; y : t @@ mode1 mode2 } +type t = { mutable x : t @@ (* cmt *) mode1 mode2; y : t @@ mode1 mode2 } +type t = { mutable x : t @@ mode1 (* cmt *) mode2; y : t @@ mode1 mode2 } +type t = { mutable x : t @@ mode1 mode2 (* cmt *); y : t @@ mode1 mode2 } +type t = { mutable x : t @@ mode1 mode2; (* cmt *) y : t @@ mode1 mode2 } +type t = { mutable x : t @@ mode1 mode2; y (* cmt *) : t @@ mode1 mode2 } +type t = { mutable x : t @@ mode1 mode2; y : (* cmt *) t @@ mode1 mode2 } +type t = { mutable x : t @@ mode1 mode2; y : t (* cmt *) @@ mode1 mode2 } +type t = { mutable x : t @@ mode1 mode2; y : t @@ (* cmt *) mode1 mode2 } +type t = { mutable x : t @@ mode1 mode2; y : t @@ mode1 (* cmt *) mode2 } +type t = { mutable x : t @@ mode1 mode2; y : t @@ mode1 mode2 (* cmt *) } + +(* modalities on constructor arguments *) + +type t = + | A of (* cmt *) t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 (* cmt *) @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ (* cmt *) m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 (* cmt *) m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 (* cmt *) * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * (* cmt *) t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 (* cmt *) @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ (* cmt *) m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 (* cmt *) m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 (* cmt *) * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (* cmt *) (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * ((* cmt *) t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 (* cmt *) @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ (* cmt *) m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 (* cmt *) -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> (* cmt *) t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 (* cmt *) @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ (* cmt *) m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6 (* cmt *)) @@ m7 m8 + (* | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) (* cmt *) @@ m7 m8 *) + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ (* cmt *) m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 (* cmt *) m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 (* cmt *) + +type t = + | A : (* cmt *) t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 (* cmt *) @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ (* cmt *) m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 (* cmt *) m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 (* cmt *) * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * (* cmt *) t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 (* cmt *) @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ (* cmt *) m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 (* cmt *) m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 (* cmt *) * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (* cmt *) (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * ((* cmt *) t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 (* cmt *) @ m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ (* cmt *) m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 (* cmt *) -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> (* cmt *) t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 (* cmt *) @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ (* cmt *) m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6 (* cmt *)) @@ m7 m8 -> t + (* Comment moves between [@@] and [m7]: + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) (* cmt *) @@ m7 m8 -> t *) + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ (* cmt *) m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 (* cmt *) m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 (* cmt *) -> t + +(* value descriptions *) + +module type S = sig + val x : (* cmt *) t1 @ m1 m2 -> t2 @ m3 m4 @@ m5 m6 + val x : t1 (* cmt *) @ m1 m2 -> t2 @ m3 m4 @@ m5 m6 + val x : t1 @ (* cmt *) m1 m2 -> t2 @ m3 m4 @@ m5 m6 + val x : t1 @ m1 (* cmt *) m2 -> t2 @ m3 m4 @@ m5 m6 + val x : t1 @ m1 m2 (* cmt *) -> t2 @ m3 m4 @@ m5 m6 + val x : t1 @ m1 m2 -> (* cmt *) t2 @ m3 m4 @@ m5 m6 + val x : t1 @ m1 m2 -> t2 (* cmt *) @ m3 m4 @@ m5 m6 + val x : t1 @ m1 m2 -> t2 @ (* cmt *) m3 m4 @@ m5 m6 + val x : t1 @ m1 m2 -> t2 @ m3 (* cmt *) m4 @@ m5 m6 + val x : t1 @ m1 m2 -> t2 @ m3 m4 (* cmt *) @@ m5 m6 + val x : t1 @ m1 m2 -> t2 @ m3 m4 @@ (* cmt *) m5 m6 + val x : t1 @ m1 m2 -> t2 @ m3 m4 @@ m5 (* cmt *) m6 + val x : t1 @ m1 m2 -> t2 @ m3 m4 @@ m5 m6 (* cmt *) +end + +(* let-bound functions *) + +(* Comment moves to between [(] and [f]: + let (* cmt *) (f @ mode1) (arg1 @ mode2) (arg2 @ mode3) : typ = x *) + +let ((* cmt *) f @ mode1) (arg1 @ mode2) (arg2 @ mode3) : typ = x +let (f (* cmt *) @ mode1) (arg1 @ mode2) (arg2 @ mode3) : typ = x +let (f @ (* cmt *) mode1) (arg1 @ mode2) (arg2 @ mode3) : typ = x +let (f @ mode1 (* cmt *)) (arg1 @ mode2) (arg2 @ mode3) : typ = x +let (f @ mode1) (* cmt *) (arg1 @ mode2) (arg2 @ mode3) : typ = x +let (f @ mode1) ((* cmt *) arg1 @ mode2) (arg2 @ mode3) : typ = x +let (f @ mode1) (arg1 (* cmt *) @ mode2) (arg2 @ mode3) : typ = x +let (f @ mode1) (arg1 @ (* cmt *) mode2) (arg2 @ mode3) : typ = x +let (f @ mode1) (arg1 @ mode2 (* cmt *)) (arg2 @ mode3) : typ = x +let (f @ mode1) (arg1 @ mode2) (* cmt *) (arg2 @ mode3) : typ = x +let (f @ mode1) (arg1 @ mode2) ((* cmt *) arg2 @ mode3) : typ = x +let (f @ mode1) (arg1 @ mode2) (arg2 (* cmt *) @ mode3) : typ = x +let (f @ mode1) (arg1 @ mode2) (arg2 @ (* cmt *) mode3) : typ = x +let (f @ mode1) (arg1 @ mode2) (arg2 @ mode3 (* cmt *)) : typ = x + +(* Comment moves to after [=], but not because of modes: + let (f @ mode1) (arg1 @ mode2) (arg2 @ mode3) (* cmt *) : typ = x *) + +let (f @ mode1) (arg1 @ mode2) (arg2 @ mode3) : (* cmt *) typ = x diff --git a/test/passing/tests/modes_cmts.ml.js-ref b/test/passing/tests/modes_cmts.ml.js-ref new file mode 100644 index 0000000000..4f63e2b258 --- /dev/null +++ b/test/passing/tests/modes_cmts.ml.js-ref @@ -0,0 +1,315 @@ +(* Check that comments are not dropped or moved in unusual ways. + A few commented out tests where comments move have explanations, and are + tested in [modes_cmts_move.ml]. *) + +(* let bindings *) + +let (* cmt *) x @ mode1 mode2 = y +let x (* cmt *) @ mode1 mode2 = y +let x @ (* cmt *) mode1 mode2 = y +let x @ mode1 (* cmt *) mode2 = y +let x @ mode1 mode2 (* cmt *) = y +let x @ mode1 mode2 = (* cmt *) y +let (* cmt *) x : typ @@ mode1 mode2 = y +let x (* cmt *) : typ @@ mode1 mode2 = y +let x : (* cmt *) typ @@ mode1 mode2 = y +let x : typ (* cmt *) @@ mode1 mode2 = y +let x : typ @@ (* cmt *) mode1 mode2 = y +let x : typ @@ mode1 (* cmt *) mode2 = y +let x : typ @@ mode1 mode2 (* cmt *) = y +let x : typ @@ mode1 mode2 = (* cmt *) y + +(* expressions *) + +let x = ((* cmt *) expr : typ @@ mode1 mode2) +let x = (expr (* cmt *) : typ @@ mode1 mode2) +let x = (expr : (* cmt *) typ @@ mode1 mode2) +let x = (expr : typ (* cmt *) @@ mode1 mode2) +let x = (expr : typ @@ (* cmt *) mode1 mode2) +let x = (expr : typ @@ mode1 (* cmt *) mode2) +let x = (expr : typ @@ mode1 mode2 (* cmt *)) + +(* lhs/rhs of arrows *) + +type t = (* cmt *) lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 +type t = lhs (* cmt *) @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 +type t = lhs @ (* cmt *) m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 +type t = lhs @ m1 (* cmt *) m2 -> mhs @ m3 m4 -> rhs @ m5 m6 +type t = lhs @ m1 m2 (* cmt *) -> mhs @ m3 m4 -> rhs @ m5 m6 +type t = lhs @ m1 m2 -> (* cmt *) mhs @ m3 m4 -> rhs @ m5 m6 +type t = lhs @ m1 m2 -> mhs (* cmt *) @ m3 m4 -> rhs @ m5 m6 +type t = lhs @ m1 m2 -> mhs @ (* cmt *) m3 m4 -> rhs @ m5 m6 +type t = lhs @ m1 m2 -> mhs @ m3 (* cmt *) m4 -> rhs @ m5 m6 +type t = lhs @ m1 m2 -> mhs @ m3 m4 (* cmt *) -> rhs @ m5 m6 +type t = lhs @ m1 m2 -> mhs @ m3 m4 -> (* cmt *) rhs @ m5 m6 +type t = lhs @ m1 m2 -> mhs @ m3 m4 -> rhs (* cmt *) @ m5 m6 +type t = lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ (* cmt *) m5 m6 +type t = lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 (* cmt *) m6 +type t = lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 (* cmt *) + +let x : (* cmt *) lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y +let x : lhs (* cmt *) @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y +let x : lhs @ (* cmt *) m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y +let x : lhs @ m1 (* cmt *) m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y +let x : lhs @ m1 m2 (* cmt *) -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y +let x : lhs @ m1 m2 -> (* cmt *) mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y +let x : lhs @ m1 m2 -> mhs (* cmt *) @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y +let x : lhs @ m1 m2 -> mhs @ (* cmt *) m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y +let x : lhs @ m1 m2 -> mhs @ m3 (* cmt *) m4 -> rhs @ m5 m6 @@ m7 m8 = y +let x : lhs @ m1 m2 -> mhs @ m3 m4 (* cmt *) -> rhs @ m5 m6 @@ m7 m8 = y +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> (* cmt *) rhs @ m5 m6 @@ m7 m8 = y +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs (* cmt *) @ m5 m6 @@ m7 m8 = y +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ (* cmt *) m5 m6 @@ m7 m8 = y +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 (* cmt *) m6 @@ m7 m8 = y +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 (* cmt *) @@ m7 m8 = y +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ (* cmt *) m7 m8 = y +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 (* cmt *) m8 = y +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 (* cmt *) = y +let x = (expr (* cmt *) : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) +let x = (expr : (* cmt *) lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) +let x = (expr : lhs (* cmt *) @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) +let x = (expr : lhs @ (* cmt *) m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) +let x = (expr : lhs @ m1 (* cmt *) m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) +let x = (expr : lhs @ m1 m2 (* cmt *) -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) +let x = (expr : lhs @ m1 m2 -> (* cmt *) mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) +let x = (expr : lhs @ m1 m2 -> mhs (* cmt *) @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) +let x = (expr : lhs @ m1 m2 -> mhs @ (* cmt *) m3 m4 -> rhs @ m5 m6 @@ m7 m8) +let x = (expr : lhs @ m1 m2 -> mhs @ m3 (* cmt *) m4 -> rhs @ m5 m6 @@ m7 m8) +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 (* cmt *) -> rhs @ m5 m6 @@ m7 m8) +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> (* cmt *) rhs @ m5 m6 @@ m7 m8) +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs (* cmt *) @ m5 m6 @@ m7 m8) +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ (* cmt *) m5 m6 @@ m7 m8) +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 (* cmt *) m6 @@ m7 m8) +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 (* cmt *) @@ m7 m8) +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ (* cmt *) m7 m8) +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 (* cmt *) m8) +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 (* cmt *)) +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) (* cmt *) + +(* modalities on record fields *) + +type t = + { x (* cmt *) : t @@ mode1 mode2 + ; y : t @@ mode1 mode2 + } + +type t = + { x : (* cmt *) t @@ mode1 mode2 + ; y : t @@ mode1 mode2 + } + +type t = + { x : t (* cmt *) @@ mode1 mode2 + ; y : t @@ mode1 mode2 + } + +type t = + { x : t @@ (* cmt *) mode1 mode2 + ; y : t @@ mode1 mode2 + } + +type t = + { x : t @@ mode1 (* cmt *) mode2 + ; y : t @@ mode1 mode2 + } + +type t = + { x : t @@ mode1 mode2 (* cmt *) + ; y : t @@ mode1 mode2 + } + +type t = + { x : t @@ mode1 mode2 + ; (* cmt *) y : t @@ mode1 mode2 + } + +type t = + { x : t @@ mode1 mode2 + ; y (* cmt *) : t @@ mode1 mode2 + } + +type t = + { x : t @@ mode1 mode2 + ; y : (* cmt *) t @@ mode1 mode2 + } + +type t = + { x : t @@ mode1 mode2 + ; y : t (* cmt *) @@ mode1 mode2 + } + +type t = + { x : t @@ mode1 mode2 + ; y : t @@ (* cmt *) mode1 mode2 + } + +type t = + { x : t @@ mode1 mode2 + ; y : t @@ mode1 (* cmt *) mode2 + } + +type t = + { x : t @@ mode1 mode2 + ; y : t @@ mode1 mode2 (* cmt *) + } + +type t = + { mutable x (* cmt *) : t @@ mode1 mode2 + ; y : t @@ mode1 mode2 + } + +type t = + { mutable x : (* cmt *) t @@ mode1 mode2 + ; y : t @@ mode1 mode2 + } + +type t = + { mutable x : t (* cmt *) @@ mode1 mode2 + ; y : t @@ mode1 mode2 + } + +type t = + { mutable x : t @@ (* cmt *) mode1 mode2 + ; y : t @@ mode1 mode2 + } + +type t = + { mutable x : t @@ mode1 (* cmt *) mode2 + ; y : t @@ mode1 mode2 + } + +type t = + { mutable x : t @@ mode1 mode2 (* cmt *) + ; y : t @@ mode1 mode2 + } + +type t = + { mutable x : t @@ mode1 mode2 + ; (* cmt *) y : t @@ mode1 mode2 + } + +type t = + { mutable x : t @@ mode1 mode2 + ; y (* cmt *) : t @@ mode1 mode2 + } + +type t = + { mutable x : t @@ mode1 mode2 + ; y : (* cmt *) t @@ mode1 mode2 + } + +type t = + { mutable x : t @@ mode1 mode2 + ; y : t (* cmt *) @@ mode1 mode2 + } + +type t = + { mutable x : t @@ mode1 mode2 + ; y : t @@ (* cmt *) mode1 mode2 + } + +type t = + { mutable x : t @@ mode1 mode2 + ; y : t @@ mode1 (* cmt *) mode2 + } + +type t = + { mutable x : t @@ mode1 mode2 + ; y : t @@ mode1 mode2 (* cmt *) + } + +(* modalities on constructor arguments *) + +type t = + | A of (* cmt *) t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 (* cmt *) @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ (* cmt *) m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 (* cmt *) m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 (* cmt *) * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * (* cmt *) t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 (* cmt *) @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ (* cmt *) m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 (* cmt *) m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 (* cmt *) * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (* cmt *) (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * ((* cmt *) t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 (* cmt *) @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ (* cmt *) m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 (* cmt *) -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> (* cmt *) t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 (* cmt *) @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ (* cmt *) m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6 (* cmt *)) @@ m7 m8 + (* | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) (* cmt *) @@ m7 m8 *) + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ (* cmt *) m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 (* cmt *) m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 (* cmt *) + +type t = + | A : (* cmt *) t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 (* cmt *) @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ (* cmt *) m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 (* cmt *) m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 (* cmt *) * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * (* cmt *) t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 (* cmt *) @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ (* cmt *) m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 (* cmt *) m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 (* cmt *) * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (* cmt *) (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * ((* cmt *) t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 (* cmt *) @ m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ (* cmt *) m5 -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 (* cmt *) -> t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> (* cmt *) t4 @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 (* cmt *) @ m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ (* cmt *) m6) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6 (* cmt *)) @@ m7 m8 -> t + (* Comment moves between [@@] and [m7]: + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) (* cmt *) @@ m7 m8 -> t *) + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ (* cmt *) m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 (* cmt *) m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 (* cmt *) -> t + +(* value descriptions *) + +module type S = sig + val x : (* cmt *) t1 @ m1 m2 -> t2 @ m3 m4 @@ m5 m6 + val x : t1 (* cmt *) @ m1 m2 -> t2 @ m3 m4 @@ m5 m6 + val x : t1 @ (* cmt *) m1 m2 -> t2 @ m3 m4 @@ m5 m6 + val x : t1 @ m1 (* cmt *) m2 -> t2 @ m3 m4 @@ m5 m6 + val x : t1 @ m1 m2 (* cmt *) -> t2 @ m3 m4 @@ m5 m6 + val x : t1 @ m1 m2 -> (* cmt *) t2 @ m3 m4 @@ m5 m6 + val x : t1 @ m1 m2 -> t2 (* cmt *) @ m3 m4 @@ m5 m6 + val x : t1 @ m1 m2 -> t2 @ (* cmt *) m3 m4 @@ m5 m6 + val x : t1 @ m1 m2 -> t2 @ m3 (* cmt *) m4 @@ m5 m6 + val x : t1 @ m1 m2 -> t2 @ m3 m4 (* cmt *) @@ m5 m6 + val x : t1 @ m1 m2 -> t2 @ m3 m4 @@ (* cmt *) m5 m6 + val x : t1 @ m1 m2 -> t2 @ m3 m4 @@ m5 (* cmt *) m6 + val x : t1 @ m1 m2 -> t2 @ m3 m4 @@ m5 m6 (* cmt *) +end + +(* let-bound functions *) + +(* Comment moves to between [(] and [f]: + let (* cmt *) (f @ mode1) (arg1 @ mode2) (arg2 @ mode3) : typ = x *) + +let ((* cmt *) f @ mode1) (arg1 @ mode2) (arg2 @ mode3) : typ = x +let (f (* cmt *) @ mode1) (arg1 @ mode2) (arg2 @ mode3) : typ = x +let (f @ (* cmt *) mode1) (arg1 @ mode2) (arg2 @ mode3) : typ = x +let (f @ mode1 (* cmt *)) (arg1 @ mode2) (arg2 @ mode3) : typ = x +let (f @ mode1) (* cmt *) (arg1 @ mode2) (arg2 @ mode3) : typ = x +let (f @ mode1) ((* cmt *) arg1 @ mode2) (arg2 @ mode3) : typ = x +let (f @ mode1) (arg1 (* cmt *) @ mode2) (arg2 @ mode3) : typ = x +let (f @ mode1) (arg1 @ (* cmt *) mode2) (arg2 @ mode3) : typ = x +let (f @ mode1) (arg1 @ mode2 (* cmt *)) (arg2 @ mode3) : typ = x +let (f @ mode1) (arg1 @ mode2) (* cmt *) (arg2 @ mode3) : typ = x +let (f @ mode1) (arg1 @ mode2) ((* cmt *) arg2 @ mode3) : typ = x +let (f @ mode1) (arg1 @ mode2) (arg2 (* cmt *) @ mode3) : typ = x +let (f @ mode1) (arg1 @ mode2) (arg2 @ (* cmt *) mode3) : typ = x +let (f @ mode1) (arg1 @ mode2) (arg2 @ mode3 (* cmt *)) : typ = x + +(* Comment moves to after [=], but not because of modes: + let (f @ mode1) (arg1 @ mode2) (arg2 @ mode3) (* cmt *) : typ = x *) + +let (f @ mode1) (arg1 @ mode2) (arg2 @ mode3) : (* cmt *) typ = x diff --git a/test/passing/tests/modes_cmts.ml.ref b/test/passing/tests/modes_cmts.ml.ref new file mode 100644 index 0000000000..b56a87b986 --- /dev/null +++ b/test/passing/tests/modes_cmts.ml.ref @@ -0,0 +1,377 @@ +(* Check that comments are not dropped or moved in unusual ways. A few + commented out tests where comments move have explanations, and are tested + in [modes_cmts_move.ml]. *) + +(* let bindings *) + +let (* cmt *) x @ mode1 mode2 = y + +let x (* cmt *) @ mode1 mode2 = y + +let x @ (* cmt *) mode1 mode2 = y + +let x @ mode1 (* cmt *) mode2 = y + +let x @ mode1 mode2 (* cmt *) = y + +let x @ mode1 mode2 = (* cmt *) y + +let (* cmt *) x : typ @@ mode1 mode2 = y + +let x (* cmt *) : typ @@ mode1 mode2 = y + +let x : (* cmt *) typ @@ mode1 mode2 = y + +let x : typ (* cmt *) @@ mode1 mode2 = y + +let x : typ @@ (* cmt *) mode1 mode2 = y + +let x : typ @@ mode1 (* cmt *) mode2 = y + +let x : typ @@ mode1 mode2 (* cmt *) = y + +let x : typ @@ mode1 mode2 = (* cmt *) y + +(* expressions *) + +let x = ((* cmt *) expr : typ @@ mode1 mode2) + +let x = (expr (* cmt *) : typ @@ mode1 mode2) + +let x = (expr : (* cmt *) typ @@ mode1 mode2) + +let x = (expr : typ (* cmt *) @@ mode1 mode2) + +let x = (expr : typ @@ (* cmt *) mode1 mode2) + +let x = (expr : typ @@ mode1 (* cmt *) mode2) + +let x = (expr : typ @@ mode1 mode2 (* cmt *)) + +(* lhs/rhs of arrows *) + +type t = (* cmt *) lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 + +type t = lhs (* cmt *) @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 + +type t = lhs @ (* cmt *) m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 + +type t = lhs @ m1 (* cmt *) m2 -> mhs @ m3 m4 -> rhs @ m5 m6 + +type t = lhs @ m1 m2 (* cmt *) -> mhs @ m3 m4 -> rhs @ m5 m6 + +type t = lhs @ m1 m2 -> (* cmt *) mhs @ m3 m4 -> rhs @ m5 m6 + +type t = lhs @ m1 m2 -> mhs (* cmt *) @ m3 m4 -> rhs @ m5 m6 + +type t = lhs @ m1 m2 -> mhs @ (* cmt *) m3 m4 -> rhs @ m5 m6 + +type t = lhs @ m1 m2 -> mhs @ m3 (* cmt *) m4 -> rhs @ m5 m6 + +type t = lhs @ m1 m2 -> mhs @ m3 m4 (* cmt *) -> rhs @ m5 m6 + +type t = lhs @ m1 m2 -> mhs @ m3 m4 -> (* cmt *) rhs @ m5 m6 + +type t = lhs @ m1 m2 -> mhs @ m3 m4 -> rhs (* cmt *) @ m5 m6 + +type t = lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ (* cmt *) m5 m6 + +type t = lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 (* cmt *) m6 + +type t = lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 (* cmt *) + +let x : (* cmt *) lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y + +let x : lhs (* cmt *) @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y + +let x : lhs @ (* cmt *) m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y + +let x : lhs @ m1 (* cmt *) m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y + +let x : lhs @ m1 m2 (* cmt *) -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y + +let x : lhs @ m1 m2 -> (* cmt *) mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y + +let x : lhs @ m1 m2 -> mhs (* cmt *) @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y + +let x : lhs @ m1 m2 -> mhs @ (* cmt *) m3 m4 -> rhs @ m5 m6 @@ m7 m8 = y + +let x : lhs @ m1 m2 -> mhs @ m3 (* cmt *) m4 -> rhs @ m5 m6 @@ m7 m8 = y + +let x : lhs @ m1 m2 -> mhs @ m3 m4 (* cmt *) -> rhs @ m5 m6 @@ m7 m8 = y + +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> (* cmt *) rhs @ m5 m6 @@ m7 m8 = y + +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs (* cmt *) @ m5 m6 @@ m7 m8 = y + +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ (* cmt *) m5 m6 @@ m7 m8 = y + +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 (* cmt *) m6 @@ m7 m8 = y + +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 (* cmt *) @@ m7 m8 = y + +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ (* cmt *) m7 m8 = y + +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 (* cmt *) m8 = y + +let x : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 (* cmt *) = y + +let x = (expr (* cmt *) : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) + +let x = (expr : (* cmt *) lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) + +let x = (expr : lhs (* cmt *) @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) + +let x = (expr : lhs @ (* cmt *) m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) + +let x = (expr : lhs @ m1 (* cmt *) m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) + +let x = (expr : lhs @ m1 m2 (* cmt *) -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) + +let x = (expr : lhs @ m1 m2 -> (* cmt *) mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) + +let x = (expr : lhs @ m1 m2 -> mhs (* cmt *) @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) + +let x = (expr : lhs @ m1 m2 -> mhs @ (* cmt *) m3 m4 -> rhs @ m5 m6 @@ m7 m8) + +let x = (expr : lhs @ m1 m2 -> mhs @ m3 (* cmt *) m4 -> rhs @ m5 m6 @@ m7 m8) + +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 (* cmt *) -> rhs @ m5 m6 @@ m7 m8) + +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> (* cmt *) rhs @ m5 m6 @@ m7 m8) + +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs (* cmt *) @ m5 m6 @@ m7 m8) + +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ (* cmt *) m5 m6 @@ m7 m8) + +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 (* cmt *) m6 @@ m7 m8) + +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 (* cmt *) @@ m7 m8) + +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ (* cmt *) m7 m8) + +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 (* cmt *) m8) + +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 (* cmt *)) + +let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) (* cmt *) + +(* modalities on record fields *) + +type t = {x (* cmt *): t @@ mode1 mode2; y: t @@ mode1 mode2} + +type t = {x: (* cmt *) t @@ mode1 mode2; y: t @@ mode1 mode2} + +type t = {x: t (* cmt *) @@ mode1 mode2; y: t @@ mode1 mode2} + +type t = {x: t @@ (* cmt *) mode1 mode2; y: t @@ mode1 mode2} + +type t = {x: t @@ mode1 (* cmt *) mode2; y: t @@ mode1 mode2} + +type t = {x: t @@ mode1 mode2 (* cmt *); y: t @@ mode1 mode2} + +type t = {x: t @@ mode1 mode2; (* cmt *) y: t @@ mode1 mode2} + +type t = {x: t @@ mode1 mode2; y (* cmt *): t @@ mode1 mode2} + +type t = {x: t @@ mode1 mode2; y: (* cmt *) t @@ mode1 mode2} + +type t = {x: t @@ mode1 mode2; y: t (* cmt *) @@ mode1 mode2} + +type t = {x: t @@ mode1 mode2; y: t @@ (* cmt *) mode1 mode2} + +type t = {x: t @@ mode1 mode2; y: t @@ mode1 (* cmt *) mode2} + +type t = {x: t @@ mode1 mode2; y: t @@ mode1 mode2 (* cmt *)} + +type t = {mutable x (* cmt *): t @@ mode1 mode2; y: t @@ mode1 mode2} + +type t = {mutable x: (* cmt *) t @@ mode1 mode2; y: t @@ mode1 mode2} + +type t = {mutable x: t (* cmt *) @@ mode1 mode2; y: t @@ mode1 mode2} + +type t = {mutable x: t @@ (* cmt *) mode1 mode2; y: t @@ mode1 mode2} + +type t = {mutable x: t @@ mode1 (* cmt *) mode2; y: t @@ mode1 mode2} + +type t = {mutable x: t @@ mode1 mode2 (* cmt *); y: t @@ mode1 mode2} + +type t = {mutable x: t @@ mode1 mode2; (* cmt *) y: t @@ mode1 mode2} + +type t = {mutable x: t @@ mode1 mode2; y (* cmt *): t @@ mode1 mode2} + +type t = {mutable x: t @@ mode1 mode2; y: (* cmt *) t @@ mode1 mode2} + +type t = {mutable x: t @@ mode1 mode2; y: t (* cmt *) @@ mode1 mode2} + +type t = {mutable x: t @@ mode1 mode2; y: t @@ (* cmt *) mode1 mode2} + +type t = {mutable x: t @@ mode1 mode2; y: t @@ mode1 (* cmt *) mode2} + +type t = {mutable x: t @@ mode1 mode2; y: t @@ mode1 mode2 (* cmt *)} + +(* modalities on constructor arguments *) + +type t = + | A of (* cmt *) t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 (* cmt *) @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ (* cmt *) m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 (* cmt *) m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 (* cmt *) * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * (* cmt *) t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 (* cmt *) @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ (* cmt *) m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 (* cmt *) m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 (* cmt *) * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (* cmt *) (t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * ((* cmt *) t3 @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 (* cmt *) @ m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ (* cmt *) m5 -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 (* cmt *) -> t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> (* cmt *) t4 @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 (* cmt *) @ m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ (* cmt *) m6) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6 (* cmt *)) @@ m7 m8 + (* | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) (* cmt *) @@ m7 + m8 *) + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ (* cmt *) m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 (* cmt *) m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 (* cmt *) + +type t = + | A : + (* cmt *) t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 (* cmt *) @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ (* cmt *) m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 (* cmt *) m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 (* cmt *) * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 * (* cmt *) t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 * t2 (* cmt *) @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 * t2 @@ (* cmt *) m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 * t2 @@ m3 (* cmt *) m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 * t2 @@ m3 m4 (* cmt *) * (t3 @ m5 -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 * t2 @@ m3 m4 * (* cmt *) (t3 @ m5 -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 * t2 @@ m3 m4 * ((* cmt *) t3 @ m5 -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 (* cmt *) @ m5 -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ (* cmt *) m5 -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 (* cmt *) -> t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> (* cmt *) t4 @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 (* cmt *) @ m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ (* cmt *) m6) @@ m7 m8 + -> t + | A : + t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6 (* cmt *)) @@ m7 m8 + -> t + (* Comment moves between [@@] and [m7]: | A : t1 @@ m1 m2 * t2 @@ m3 m4 * + (t3 @ m5 -> t4 @ m6) (* cmt *) @@ m7 m8 -> t *) + | A : + t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ (* cmt *) m7 m8 + -> t + | A : + t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 (* cmt *) m8 + -> t + | A : + t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 (* cmt *) + -> t + +(* value descriptions *) + +module type S = sig + val x : (* cmt *) t1 @ m1 m2 -> t2 @ m3 m4 @@ m5 m6 + + val x : t1 (* cmt *) @ m1 m2 -> t2 @ m3 m4 @@ m5 m6 + + val x : t1 @ (* cmt *) m1 m2 -> t2 @ m3 m4 @@ m5 m6 + + val x : t1 @ m1 (* cmt *) m2 -> t2 @ m3 m4 @@ m5 m6 + + val x : t1 @ m1 m2 (* cmt *) -> t2 @ m3 m4 @@ m5 m6 + + val x : t1 @ m1 m2 -> (* cmt *) t2 @ m3 m4 @@ m5 m6 + + val x : t1 @ m1 m2 -> t2 (* cmt *) @ m3 m4 @@ m5 m6 + + val x : t1 @ m1 m2 -> t2 @ (* cmt *) m3 m4 @@ m5 m6 + + val x : t1 @ m1 m2 -> t2 @ m3 (* cmt *) m4 @@ m5 m6 + + val x : t1 @ m1 m2 -> t2 @ m3 m4 (* cmt *) @@ m5 m6 + + val x : t1 @ m1 m2 -> t2 @ m3 m4 @@ (* cmt *) m5 m6 + + val x : t1 @ m1 m2 -> t2 @ m3 m4 @@ m5 (* cmt *) m6 + + val x : t1 @ m1 m2 -> t2 @ m3 m4 @@ m5 m6 (* cmt *) +end + +(* let-bound functions *) + +(* Comment moves to between [(] and [f]: let (* cmt *) (f @ mode1) (arg1 @ + mode2) (arg2 @ mode3) : typ = x *) + +let ((* cmt *) f @ mode1) (arg1 @ mode2) (arg2 @ mode3) : typ = x + +let (f (* cmt *) @ mode1) (arg1 @ mode2) (arg2 @ mode3) : typ = x + +let (f @ (* cmt *) mode1) (arg1 @ mode2) (arg2 @ mode3) : typ = x + +let (f @ mode1 (* cmt *)) (arg1 @ mode2) (arg2 @ mode3) : typ = x + +let (f @ mode1) (* cmt *) (arg1 @ mode2) (arg2 @ mode3) : typ = x + +let (f @ mode1) ((* cmt *) arg1 @ mode2) (arg2 @ mode3) : typ = x + +let (f @ mode1) (arg1 (* cmt *) @ mode2) (arg2 @ mode3) : typ = x + +let (f @ mode1) (arg1 @ (* cmt *) mode2) (arg2 @ mode3) : typ = x + +let (f @ mode1) (arg1 @ mode2 (* cmt *)) (arg2 @ mode3) : typ = x + +let (f @ mode1) (arg1 @ mode2) (* cmt *) (arg2 @ mode3) : typ = x + +let (f @ mode1) (arg1 @ mode2) ((* cmt *) arg2 @ mode3) : typ = x + +let (f @ mode1) (arg1 @ mode2) (arg2 (* cmt *) @ mode3) : typ = x + +let (f @ mode1) (arg1 @ mode2) (arg2 @ (* cmt *) mode3) : typ = x + +let (f @ mode1) (arg1 @ mode2) (arg2 @ mode3 (* cmt *)) : typ = x + +(* Comment moves to after [=], but not because of modes: let (f @ mode1) + (arg1 @ mode2) (arg2 @ mode3) (* cmt *) : typ = x *) + +let (f @ mode1) (arg1 @ mode2) (arg2 @ mode3) : (* cmt *) typ = x diff --git a/test/passing/tests/modes_cmts_move.ml b/test/passing/tests/modes_cmts_move.ml new file mode 100644 index 0000000000..2c8abc89ca --- /dev/null +++ b/test/passing/tests/modes_cmts_move.ml @@ -0,0 +1,20 @@ +(* This comment moves for similar reason to existing behavior as shown below. + In particular, the operator ([@@] / [->]) does not carry a source locaion, + and the comment attaches to the location of the identifier on the right side + of the operator rather than the left due to the parenthesis. Fixing this would + require messing with the comment association logic, which is difficult. *) +type t = A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) (* cmt *) @@ m7 m8 +type t = A of (t -> u) (* cmt *) @@ m +type t = A of ((t -> u) (* cmt *) -> m) + +(* This comment attaches to the [f]; the syntax [(f @ mode1)] doesn't have its own + location to latch onto. This seems like a rare position to put a comment, so it doesn't + seem worth changing the parser to be able to differentiate the following two. *) +let (* cmt *) (f @ mode1) (arg1 @ mode2) (arg2 @ mode3) : typ = x +let (* cmt *) (f @ mode) arg = x +let ((* cmt *) f @ mode) arg = x + +(* This comment moves due to existing behavior as shown below. *) +let (f @ mode1) (arg1 @ mode2) (arg2 @ mode3) (* cmt *) : typ = x +let f (arg @ mode) (* cmt *) : typ = x +let f (arg : typ) (* cmt *) : typ = x diff --git a/test/passing/tests/modes_cmts_move.ml.js-ref b/test/passing/tests/modes_cmts_move.ml.js-ref new file mode 100644 index 0000000000..a00e3f0dc8 --- /dev/null +++ b/test/passing/tests/modes_cmts_move.ml.js-ref @@ -0,0 +1,20 @@ +(* This comment moves for similar reason to existing behavior as shown below. + In particular, the operator ([@@] / [->]) does not carry a source locaion, + and the comment attaches to the location of the identifier on the right side + of the operator rather than the left due to the parenthesis. Fixing this would + require messing with the comment association logic, which is difficult. *) +type t = A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ (* cmt *) m7 m8 +type t = A of (t -> u) @@ (* cmt *) m +type t = A of ((t -> u) -> (* cmt *) m) + +(* This comment attaches to the [f]; the syntax [(f @ mode1)] doesn't have its own + location to latch onto. This seems like a rare position to put a comment, so it doesn't + seem worth changing the parser to be able to differentiate the following two. *) +let ((* cmt *) f @ mode1) (arg1 @ mode2) (arg2 @ mode3) : typ = x +let ((* cmt *) f @ mode) arg = x +let ((* cmt *) f @ mode) arg = x + +(* This comment moves due to existing behavior as shown below. *) +let (f @ mode1) (arg1 @ mode2) (arg2 @ mode3) : typ = (* cmt *) x +let f (arg @ mode) : typ = (* cmt *) x +let f (arg : typ) : typ = (* cmt *) x diff --git a/test/passing/tests/modes_cmts_move.ml.ref b/test/passing/tests/modes_cmts_move.ml.ref new file mode 100644 index 0000000000..8e24f84890 --- /dev/null +++ b/test/passing/tests/modes_cmts_move.ml.ref @@ -0,0 +1,29 @@ +(* This comment moves for similar reason to existing behavior as shown below. + In particular, the operator ([@@] / [->]) does not carry a source locaion, + and the comment attaches to the location of the identifier on the right + side of the operator rather than the left due to the parenthesis. Fixing + this would require messing with the comment association logic, which is + difficult. *) +type t = + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ (* cmt *) m7 m8 + +type t = A of (t -> u) @@ (* cmt *) m + +type t = A of ((t -> u) -> (* cmt *) m) + +(* This comment attaches to the [f]; the syntax [(f @ mode1)] doesn't have + its own location to latch onto. This seems like a rare position to put a + comment, so it doesn't seem worth changing the parser to be able to + differentiate the following two. *) +let ((* cmt *) f @ mode1) (arg1 @ mode2) (arg2 @ mode3) : typ = x + +let ((* cmt *) f @ mode) arg = x + +let ((* cmt *) f @ mode) arg = x + +(* This comment moves due to existing behavior as shown below. *) +let (f @ mode1) (arg1 @ mode2) (arg2 @ mode3) : typ = (* cmt *) x + +let f (arg @ mode) : typ = (* cmt *) x + +let f (arg : typ) : typ = (* cmt *) x diff --git a/test/passing/tests/print_config.ml.deps b/test/passing/tests/print_config.ml.deps index e0e0c6b879..5a790bdf26 100644 --- a/test/passing/tests/print_config.ml.deps +++ b/test/passing/tests/print_config.ml.deps @@ -1,2 +1,3 @@ +tests/dir1/.ocamlformat tests/dir1/dir2/.ocamlformat tests/dir1/dir2/print_config.ml diff --git a/vendor/parser-extended/ast_helper.ml b/vendor/parser-extended/ast_helper.ml index 2bfb6ab2f2..e183b54f90 100644 --- a/vendor/parser-extended/ast_helper.ml +++ b/vendor/parser-extended/ast_helper.ml @@ -69,7 +69,7 @@ module Typ = struct let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a) - let arrow ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_arrow (a, b)) + let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c)) let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a) let unboxed_tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_unboxed_tuple a) let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b)) @@ -107,7 +107,7 @@ module Pat = struct let array ?loc ?attrs a b = mk ?loc ?attrs (Ppat_array (a, b)) let list ?loc ?attrs a = mk ?loc ?attrs (Ppat_list a) let or_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_or a) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b)) + let constraint_ ?loc ?attrs a b c = mk ?loc ?attrs (Ppat_constraint (a, b, c)) let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a) let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a) let unpack ?loc ?attrs a b = mk ?loc ?attrs (Ppat_unpack (a, b)) @@ -146,7 +146,7 @@ module Exp = struct let sequence ?loc ?attrs a b = mk ?loc ?attrs (Pexp_sequence (a, b)) let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b)) let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b)) + let constraint_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_constraint (a, b, c)) let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c)) let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b)) let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a) @@ -369,10 +369,11 @@ end module Val = struct let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(prim = []) name typ = + ?(prim = []) ?(modalities = []) name typ = { pval_name = name; pval_type = typ; + pval_modalities = modalities; pval_attributes = add_docs_attrs docs attrs; pval_loc = loc; pval_prim = prim; @@ -448,12 +449,13 @@ end module Vb = struct let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(text = []) ?value_constraint ~is_pun pat expr = + ?(text = []) ?value_constraint ?(modes = []) ~is_pun pat expr = { pvb_pat = pat; pvb_expr = expr; pvb_constraint=value_constraint; - pvb_is_pun = is_pun; + pvb_modes=modes; + pvb_is_pun=is_pun; pvb_attributes = add_text_attrs text (add_docs_attrs docs attrs); pvb_loc = loc; @@ -509,11 +511,19 @@ module Type = struct pcd_attributes = add_info_attrs info attrs; } + let constructor_arg ?(loc = !default_loc) ?(modalities = []) typ = + { + pca_modalities = modalities; + pca_type = typ; + pca_loc = loc; + } + let field ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(mut = Immutable) name typ = + ?(mut = Immutable) ?(modalities = []) name typ = { pld_name = name; pld_mutable = mut; + pld_modalities = modalities; pld_type = typ; pld_loc = loc; pld_attributes = add_info_attrs info attrs; diff --git a/vendor/parser-extended/ast_mapper.ml b/vendor/parser-extended/ast_mapper.ml index 940ab9ac8d..064125ad36 100644 --- a/vendor/parser-extended/ast_mapper.ml +++ b/vendor/parser-extended/ast_mapper.ml @@ -15,10 +15,8 @@ (* A generic Parsetree mapping class *) -(* [@@@ocaml.warning "+9"] (* Ensure that record patterns don't miss any field. *) -*) open Parsetree open Ast_helper @@ -30,6 +28,8 @@ type mapper = { arg_label: mapper -> Asttypes.arg_label -> Asttypes.arg_label; attribute: mapper -> attribute -> attribute; attributes: mapper -> attribute list -> attribute list; + modes : mapper -> mode loc list -> mode loc list; + modalities : mapper -> modality loc list -> modality loc list; ext_attrs: mapper -> ext_attrs -> ext_attrs; binding_op: mapper -> binding_op -> binding_op; case: mapper -> case -> case; @@ -188,22 +188,23 @@ module T = struct in Of.mk ~loc ~attrs desc - let map_arrow_param sub {pap_label; pap_loc; pap_type} = + let map_arrow_param sub {pap_label; pap_loc; pap_type; pap_modes} = let pap_label = sub.arg_label sub pap_label in let pap_loc = sub.location sub pap_loc in let pap_type = sub.typ sub pap_type in - {pap_label; pap_loc; pap_type} + let pap_modes = sub.modes sub pap_modes in + {pap_label; pap_loc; pap_type; pap_modes} - let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = + let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs; ptyp_loc_stack = _} = let open Typ in let loc = sub.location sub loc in let attrs = sub.attributes sub attrs in match desc with | Ptyp_any -> any ~loc ~attrs () | Ptyp_var s -> var ~loc ~attrs (map_type_var sub s) - | Ptyp_arrow (params, t2) -> + | Ptyp_arrow (params, t2, m2) -> arrow ~loc ~attrs (List.map (map_arrow_param sub) params) - (sub.typ sub t2) + (sub.typ sub t2) (sub.modes sub m2) | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (fun (lbl, t) -> map_opt (map_loc sub) lbl, sub.typ sub t) tyl) | Ptyp_unboxed_tuple tyl -> @@ -259,8 +260,14 @@ module T = struct | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) | Ptype_open -> Ptype_open + let map_constructor_argument sub x = + let pca_type = sub.typ sub x.pca_type in + let pca_loc = sub.location sub x.pca_loc in + let pca_modalities = sub.modalities sub x.pca_modalities in + { pca_type; pca_loc; pca_modalities } + let map_constructor_arguments sub = function - | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) + | Pcstr_tuple l -> Pcstr_tuple (List.map (map_constructor_argument sub) l) | Pcstr_record (loc, l) -> let loc = sub.location sub loc in let l = List.map (sub.label_declaration sub) l in @@ -541,7 +548,7 @@ module E = struct let if_attrs = sub.attributes sub if_attrs in { if_cond; if_body; if_attrs } - let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = + let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs; pexp_loc_stack = _} = let open Exp in let loc = sub.location sub loc in let attrs = sub.attributes sub attrs in @@ -602,8 +609,8 @@ module E = struct | Pexp_coerce (e, t1, t2) -> coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1) (sub.typ sub t2) - | Pexp_constraint (e, t) -> - constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) + | Pexp_constraint (e, t, m) -> + constraint_ ~loc ~attrs (sub.expr sub e) (Option.map (sub.typ sub) t) (sub.modes sub m) | Pexp_send (e, s) -> send ~loc ~attrs (sub.expr sub e) (map_loc sub s) | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid) @@ -681,7 +688,7 @@ end module P = struct (* Patterns *) - let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = + let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs; ppat_loc_stack = _} = let open Pat in let loc = sub.location sub loc in let attrs = sub.attributes sub attrs in @@ -717,8 +724,8 @@ module P = struct array ~loc ~attrs (Flag.map_mutable sub mf) (List.map (sub.pat sub) pl) | Ppat_list pl -> list ~loc ~attrs (List.map (sub.pat sub) pl) | Ppat_or pl -> or_ ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_constraint (p, t) -> - constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t) + | Ppat_constraint (p, t, m) -> + constraint_ ~loc ~attrs (sub.pat sub p) (Option.map (sub.typ sub) t) (sub.modes sub m) | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p) | Ppat_unpack (s, pt) -> @@ -835,13 +842,14 @@ let default_mapper = extension_constructor = T.map_extension_constructor; value_description = (fun this {pval_name; pval_type; pval_prim; pval_loc; - pval_attributes} -> + pval_attributes; pval_modalities} -> Val.mk (map_loc this pval_name) (this.typ this pval_type) ~attrs:(this.attributes this pval_attributes) ~loc:(this.location this pval_loc) ~prim:(List.map (map_loc this) pval_prim) + ~modalities:(this.modalities this pval_modalities) ); pat = P.map; @@ -918,7 +926,7 @@ let default_mapper = ); value_binding = - (fun this {pvb_pat; pvb_expr; pvb_constraint; pvb_is_pun; pvb_attributes; pvb_loc} -> + (fun this {pvb_pat; pvb_expr; pvb_constraint; pvb_is_pun; pvb_attributes; pvb_loc; pvb_modes} -> let map_ct (ct:Parsetree.value_constraint) = match ct with | Pvc_constraint {locally_abstract_univars=vars; typ} -> Pvc_constraint @@ -938,6 +946,7 @@ let default_mapper = ~is_pun:pvb_is_pun ~loc:(this.location this pvb_loc) ~attrs:(this.attributes this pvb_attributes) + ~modes:(this.modes this pvb_modes) ); value_bindings = PVB.map_value_bindings; @@ -954,13 +963,14 @@ let default_mapper = ); label_declaration = - (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} -> + (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes; pld_modalities} -> Type.field (map_loc this pld_name) (this.typ this pld_type) ~mut:(Flag.map_mutable this pld_mutable) ~loc:(this.location this pld_loc) ~attrs:(this.attributes this pld_attributes) + ~modalities:(this.modalities this pld_modalities) ); cases = (fun this l -> List.map (this.case this) l); @@ -1020,4 +1030,10 @@ let default_mapper = (fun this p -> { prepl_phrase= this.toplevel_phrase this p.prepl_phrase ; prepl_output= p.prepl_output } ); + + modes = (fun this m -> + List.map (map_loc this) m); + + modalities = (fun this m -> + List.map (map_loc this) m); } diff --git a/vendor/parser-extended/lexer.mll b/vendor/parser-extended/lexer.mll index 91d89e4185..fa6a20599e 100644 --- a/vendor/parser-extended/lexer.mll +++ b/vendor/parser-extended/lexer.mll @@ -803,6 +803,8 @@ rule token = parse { PREFIXOP op } | ['=' '<' '>' '|' '&' '$'] symbolchar * as op { INFIXOP0 op } + | "@" { AT } + | "@@" { ATAT } | ['@' '^'] symbolchar * as op { INFIXOP1 op } | ['+' '-'] symbolchar * as op diff --git a/vendor/parser-extended/parser.mly b/vendor/parser-extended/parser.mly index e9ebe20ee3..022b996838 100644 --- a/vendor/parser-extended/parser.mly +++ b/vendor/parser-extended/parser.mly @@ -204,6 +204,10 @@ let mkuplus ~oploc name arg = | _ -> Pexp_prefix(mkoperator ~loc:oploc ("~" ^ name), arg) +let mkpat_with_modes ~loc ~pat ~cty ~modes = + match cty, modes with + | None, [] -> pat + | cty, modes -> mkpat ~loc (Ppat_constraint (pat, cty, modes)) let local_ext_loc = mknoloc "extension.local" @@ -347,13 +351,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_desc_constraint e t = +let mkexp_desc_constraint ~modes e t = match t with - | Pconstraint t -> Pexp_constraint(e, t) + | Pconstraint t -> Pexp_constraint(e, Some t, modes) | Pcoerce(t1, t2) -> Pexp_coerce(e, t1, t2) -let mkexp_constraint ~loc e t = - mkexp ~loc (mkexp_desc_constraint e t) +let mkexp_constraint ~loc ~modes e t = + mkexp ~loc (mkexp_desc_constraint ~modes e t) (* let mkexp_opt_constraint ~loc e = function @@ -489,10 +493,10 @@ let mk_newtypes ~loc newtypes exp = List.fold_right (fun newtype exp -> mkexp (Pexp_newtype (newtype, exp))) newtypes exp -let wrap_type_annotation ~loc newtypes core_type body = +let wrap_type_annotation ~loc ~modes newtypes core_type body = let mkexp, ghtyp = mkexp ~loc, ghtyp ~loc in let mk_newtypes = mk_newtypes ~loc in - let exp = mkexp(Pexp_constraint(body,core_type)) in + let exp = mkexp(Pexp_constraint(body,Some core_type,modes)) in let exp = mk_newtypes newtypes exp in (exp, ghtyp(Ptyp_poly(newtypes, core_type))) @@ -591,6 +595,7 @@ type let_binding = lb_expression: expression; lb_constraint: value_constraint option; lb_is_pun: bool; + lb_modes: mode Location.loc list; lb_attributes: attributes; lb_docs: docs Lazy.t; lb_text: text Lazy.t; @@ -601,12 +606,13 @@ type let_bindings' = lbs_rec: rec_flag; lbs_extension: string Asttypes.loc option } -let mklb first ~loc (p, e, typ, is_pun) attrs = +let mklb first ~loc (p, e, typ, modes, is_pun) attrs = { lb_pattern = p; lb_expression = e; lb_constraint=typ; lb_is_pun = is_pun; + lb_modes = modes; lb_attributes = attrs; lb_docs = symbol_docs_lazy loc; lb_text = (if first then empty_text_lazy @@ -631,6 +637,7 @@ let mk_let_bindings { lbs_bindings; lbs_rec; lbs_extension } = List.rev_map (fun lb -> Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes + ~modes:lb.lb_modes ~docs:(Lazy.force lb.lb_docs) ~text:(Lazy.force lb.lb_text) ?value_constraint:lb.lb_constraint ~is_pun:lb.lb_is_pun @@ -716,7 +723,7 @@ let transl_label ~pattern ~arg_label ~loc = match arg_label, pattern.ppat_desc with | ( Labelled l , Ppat_constraint - (pat, { ptyp_desc = Ptyp_extension ({ txt = "call_pos"; loc = _ }, _); _ }) ) -> + (pat, Some { ptyp_desc = Ptyp_extension ({ txt = "call_pos"; loc = _ }, _); _ }, _) ) -> ( Optional l , pat , Some @@ -785,7 +792,9 @@ let transl_label ~pattern ~arg_label ~loc = %token IN "in" %token INCLUDE "include" %token INFIXOP0 "!=" (* just an example *) -%token INFIXOP1 "@" (* just an example *) +%token AT "@" (* mode expression *) +%token ATAT "@@" (* mode expression *) +%token INFIXOP1 "^" (* just an example *) %token INFIXOP2 "+!" (* chosen with care; see above *) %token INFIXOP3 "land" (* just an example *) %token INFIXOP4 "**" (* just an example *) @@ -927,7 +936,7 @@ The precedences must be listed from low to high. %right AMPERSAND AMPERAMPER /* expr (e && e && e) */ %nonassoc below_EQUAL %left INFIXOP0 EQUAL LESS GREATER /* expr (e OP e OP e) */ -%right INFIXOP1 /* expr (e OP e OP e) */ +%right ATAT AT INFIXOP1 /* expr (e OP e OP e) */ %nonassoc below_LBRACKETAT %nonassoc LBRACKETAT %right COLONCOLON /* expr (e :: e :: e) */ @@ -2081,7 +2090,7 @@ class_self_pattern: LPAREN pattern RPAREN { Some (reloc_pat ~loc:$sloc $2) } | mkpat(LPAREN pattern COLON core_type RPAREN - { Ppat_constraint($2, $4) }) + { Ppat_constraint($2, Some $4, []) }) { Some $1 } | /* empty */ { None } @@ -2127,7 +2136,7 @@ value: { ($4, mv_of_mut $3, Cfk_concrete ($1, $6)), $2 } | override_flag attributes mutable_flag mkrhs(label) type_constraint EQUAL seq_expr - { let e = mkexp_constraint ~loc:$sloc $7 $5 in + { let e = mkexp_constraint ~loc:$sloc ~modes:[] $7 $5 in ($4, mv_of_mut $3, Cfk_concrete ($1, e)), $2 } ; @@ -2156,7 +2165,7 @@ method_: (* it seems odd to use the global ~loc here while poly_exp_loc is tighter, but this is what ocamlyacc does; TODO improve parser.mly *) - wrap_type_annotation ~loc:$sloc $7 $9 $11 in + wrap_type_annotation ~loc:$sloc ~modes:[] $7 $9 $11 in ghexp ~loc:poly_exp_loc (Pexp_poly(exp, Some poly)) in ($4, pv_of_priv $3, Cfk_concrete ($1, poly_exp)), $2 } @@ -2176,6 +2185,7 @@ class_type: pap_label = label; pap_loc = make_loc $sloc; pap_type = domain; + pap_modes = [] } in let params, codomain = @@ -2358,36 +2368,42 @@ seq_expr: mkexp ~loc:$sloc (Pexp_extension ($4, payload)) } ; labeled_simple_pattern: - QUESTION LPAREN optional_local label_let_pattern opt_default RPAREN - { $3, mk_optional (fst $4) $sloc, $5, mkpat_local_if $3 (snd $4) } + QUESTION LPAREN optional_local x=label_let_pattern opt_default RPAREN + { let lbl, pat, cty, modes = x in + $3, mk_optional lbl $sloc, $5, + mkpat_local_if $3 (mkpat_with_modes ~loc:$loc(x) ~pat ~cty ~modes) } | QUESTION label_var { false, mk_optional (fst $2) $sloc, None, snd $2 } - | OPTLABEL LPAREN optional_local let_pattern opt_default RPAREN - { $3, mk_optional $1 $sloc, $5, mkpat_local_if $3 $4 } + | OPTLABEL LPAREN optional_local x=let_pattern opt_default RPAREN + { let pat, cty, modes = x in + $3, mk_optional $1 $sloc, $5, + mkpat_local_if $3 (mkpat_with_modes ~loc:$loc(x) ~pat ~cty ~modes) } | OPTLABEL pattern_var { false, mk_optional $1 $sloc, None, $2 } - | TILDE LPAREN optional_local label_let_pattern RPAREN - { let arg_label, pat, default_value = - transl_label - ~pattern:(snd $4) - ~arg_label:(mk_labelled (fst $4) $sloc) + | TILDE LPAREN optional_local x=label_let_pattern RPAREN + { let lbl, pat, cty, modes = x in + let pat = mkpat_with_modes ~loc:$loc(x) ~pat ~cty ~modes in + let arg_label, pat, default_value = + transl_label + ~pattern:pat + ~arg_label:(mk_labelled lbl $sloc) ~loc:(make_loc $sloc) - in + in $3, arg_label, default_value, mkpat_local_if $3 pat } | TILDE label_var { false, mk_labelled (fst $2) $sloc, None, snd $2 } | LABEL simple_pattern - { let arg_label, pat, default_value = - transl_label + { let arg_label, pat, default_value = + transl_label ~pattern:($2) ~arg_label:(mk_labelled $1 $sloc) ~loc:(make_loc $sloc) in false, arg_label, default_value, pat } | LABEL LPAREN LOCAL pattern RPAREN - { let arg_label, pat, default_value = - transl_label + { let arg_label, pat, default_value = + transl_label ~pattern:(mkpat_stack $4) ~arg_label:(mk_labelled $1 $sloc) ~loc:(make_loc $sloc) @@ -2395,14 +2411,22 @@ labeled_simple_pattern: true, arg_label, default_value, pat } | simple_pattern { false, Nolabel, None, $1 } - | LPAREN LOCAL let_pattern RPAREN - { true, Nolabel, None, mkpat_stack $3 } - | LABEL LPAREN poly_pattern RPAREN - { false, mk_labelled $1 $sloc, None, $3 } - | LABEL LPAREN LOCAL poly_pattern RPAREN - { true, mk_labelled $1 $sloc, None, mkpat_stack $4 } - | LPAREN poly_pattern RPAREN - { false, Nolabel, None, $2 } + | LPAREN LOCAL x=let_pattern RPAREN + { let pat, cty, modes = x in + true, Nolabel, None, + mkpat_stack (mkpat_with_modes ~loc:$loc(x) ~pat ~cty ~modes) } + | LABEL LPAREN x=poly_pattern RPAREN + { let pat, cty, modes = x in + false, mk_labelled $1 $sloc, None, + mkpat_with_modes ~loc:$loc(x) ~pat ~cty ~modes } + | LABEL LPAREN LOCAL x=poly_pattern RPAREN + { let pat, cty, modes = x in + true, mk_labelled $1 $sloc, None, + mkpat_stack (mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes) } + | LPAREN x=poly_pattern RPAREN + { let pat, cty, modes = x in + false, Nolabel, None, + mkpat_with_modes ~loc:$loc(x) ~pat ~cty ~modes } ; pattern_var: @@ -2417,39 +2441,41 @@ pattern_var: { $1 } ; label_let_pattern: - x = label_var - { x } - | x = label_var COLON cty = core_type + x = label_var modes = optional_at_mode_expr + { let lab, pat = x in + lab, pat, None, modes + } + | x = label_var COLON cty = core_type modes = optional_atat_mode_expr { let lab, pat = x in - lab, - mkpat ~loc:$sloc (Ppat_constraint (pat, cty)) } + lab, pat, Some cty, modes + } | x = label_var COLON - cty = mktyp (vars = typevar_list DOT ty = core_type { Ptyp_poly (vars, ty) }) + cty = mktyp (vars = typevar_list DOT ty = core_type { Ptyp_poly (vars, ty) }) + modes = optional_atat_mode_expr { let lab, pat = x in - lab, - mkpat ~loc:$sloc (Ppat_constraint (pat, cty)) } + lab, pat, Some cty, modes + } ; %inline label_var: mkrhs(LIDENT) { ($1.Location.txt, mkpat ~loc:$sloc (Ppat_var $1)) } ; let_pattern: - pattern - { $1 } - | mkpat(pattern COLON core_type - { Ppat_constraint($1, $3) }) - { $1 } + pat=pattern modes=optional_at_mode_expr + { pat, None, modes } + | pat=pattern COLON cty=core_type modes=optional_atat_mode_expr + { pat, Some cty, modes } | poly_pattern { $1 } ; + %inline poly_pattern: - mkpat( - pat = pattern - COLON - cty = mktyp(vars = typevar_list DOT ty = core_type - { Ptyp_poly(vars, ty) }) - { Ppat_constraint(pat, cty) }) - { $1 } + pat = pattern + COLON + cty = mktyp(vars = typevar_list DOT ty = core_type + { Ptyp_poly(vars, ty) }) + modes = optional_atat_mode_expr + { pat, Some cty, modes } ; %inline indexop_expr(dot, index, right): @@ -2594,8 +2620,9 @@ simple_expr: | _ -> reloc_exp ~loc:$sloc e } | LPAREN seq_expr error { unclosed "(" $loc($1) ")" $loc($3) } - | LPAREN seq_expr type_constraint RPAREN - { mkexp_constraint ~loc:$sloc $2 $3 } + | LPAREN seq_expr type_constraint_with_modes RPAREN + { let t, m = $3 in + mkexp_constraint ~loc:$sloc ~modes:m $2 t } | indexop_expr(DOT, seq_expr, { None }) { mk_builtin_indexop_expr ~loc:$sloc $1 } (* Immutable array indexing is a regular operator, so it doesn't need its own @@ -2819,7 +2846,7 @@ labeled_simple_expr: mk_labelled label $sloc, mkexpvar ~loc label } | TILDE LPAREN label = LIDENT ty = type_constraint RPAREN { mk_labelled label $sloc, - mkexp_constraint ~loc:($startpos($2), $endpos) + mkexp_constraint ~loc:($startpos($2), $endpos) ~modes:[] (mkexpvar ~loc:$loc(label) label) ty } | QUESTION label = LIDENT { let loc = $loc(label) in @@ -2834,46 +2861,61 @@ labeled_simple_expr: %inline let_ident: val_ident { mkpatvar ~loc:$sloc $1 } ; +%inline pvc_modes: + | at_mode_expr {None, $1} + | COLON core_type optional_atat_mode_expr { + Some(Pvc_constraint { locally_abstract_univars=[]; typ=$2 }), $3 + } +; let_binding_body_no_punning: let_ident strict_binding - { ($1, $2, None) } - | optional_local let_ident type_constraint EQUAL seq_expr + { ($1, $2, None, []) } + | optional_local let_ident constraint_ EQUAL seq_expr { let v = $2 in (* PR#7344 *) + let typ, modes = $3 in let t = - match $3 with + Option.map (function | Pconstraint typ -> Pvc_constraint { locally_abstract_univars = []; typ } | Pcoerce (ground, coercion) -> Pvc_coercion { ground; coercion } + ) typ in let pat = mkpat_local_if $1 v in let exp = mkexp_local_if $1 ~loc:$sloc $5 in - (pat, exp, Some t) + (pat, exp, t, modes) } - | optional_local let_ident COLON poly(core_type) EQUAL seq_expr + | optional_local let_ident COLON poly(core_type) modes=optional_atat_mode_expr EQUAL seq_expr { let t = ghtyp ~loc:($loc($4)) $4 in let pat = mkpat_local_if $1 $2 in - let exp = mkexp_local_if $1 ~loc:$sloc $6 in - (pat, exp, Some (Pvc_constraint { locally_abstract_univars = []; typ=t })) + let exp = mkexp_local_if $1 ~loc:$sloc $7 in + (pat, exp, Some (Pvc_constraint { locally_abstract_univars = []; typ=t }), modes) } - | let_ident COLON TYPE newtypes DOT core_type EQUAL seq_expr + | let_ident COLON TYPE newtypes DOT core_type modes=optional_atat_mode_expr EQUAL seq_expr { let constraint' = Pvc_constraint { locally_abstract_univars=$4; typ = $6} in - ($1, $8, Some constraint') } + ($1, $9, Some constraint', modes) } | pattern_no_exn EQUAL seq_expr - { ($1, $3, None) } - | simple_pattern_not_ident COLON core_type EQUAL seq_expr - { ($1, $5, Some(Pvc_constraint { locally_abstract_univars=[]; typ=$3 })) } + { ($1, $3, None, []) } + | simple_pattern_not_ident pvc_modes EQUAL seq_expr + { + let pvc, modes = $2 in + ($1, $4, pvc, modes) + } | LOCAL let_ident local_strict_binding - { ($2, mkexp_stack ~loc:$sloc $3, None) } + { ($2, mkexp_stack ~loc:$sloc $3, None, []) } + | LPAREN let_ident modes=at_mode_expr RPAREN strict_binding + { + ($2, $5, None, modes) + } ; let_binding_body: | let_binding_body_no_punning - { let p,e,c = $1 in (p,e,c,false) } + { let p,e,c,modes = $1 in (p,e,c,modes,false) } /* BEGIN AVOID */ | val_ident %prec below_HASH - { (mkpatvar ~loc:$loc $1, mkexpvar ~loc:$loc $1, None, true) } + { (mkpatvar ~loc:$loc $1, mkexpvar ~loc:$loc $1, None, [], true) } (* The production that allows puns is marked so that [make list-parse-errors] does not attempt to exploit it. That would be problematic because it would then generate bindings such as [let x], which are rejected by the @@ -2916,7 +2958,7 @@ letop_binding_body: { (mkpatvar ~loc:$loc $1, mkexpvar ~loc:$loc $1, true) } | pat = simple_pattern COLON typ = core_type EQUAL exp = seq_expr { let loc = ($startpos(pat), $endpos(typ)) in - (ghpat ~loc (Ppat_constraint(pat, typ)), exp, false) } + (ghpat ~loc (Ppat_constraint(pat, Some typ, [])), exp, false) } | pat = pattern_no_exn EQUAL exp = seq_expr { (pat, exp, false) } ; @@ -2935,7 +2977,7 @@ fun_binding: strict_binding { $1 } | type_constraint EQUAL seq_expr - { mkexp_constraint ~loc:$sloc $3 $1 } + { mkexp_constraint ~loc:$sloc ~modes:[] $3 $1 } ; strict_binding: EQUAL seq_expr @@ -2953,7 +2995,7 @@ local_fun_binding: local_strict_binding { $1 } | type_constraint EQUAL seq_expr - { wrap_exp_stack (mkexp_constraint ~loc:$sloc $3 $1) } + { wrap_exp_stack (mkexp_constraint ~loc:$sloc ~modes:[] $3 $1) } ; local_strict_binding: EQUAL seq_expr @@ -2991,7 +3033,7 @@ fun_def: MINUSGREATER seq_expr { $2 } | mkexp(COLON atomic_type MINUSGREATER seq_expr - { Pexp_constraint ($4, $2) }) + { Pexp_constraint ($4, Some $2, []) }) { $1 } /* Cf #5939: we used to accept (fun p when e0 -> e) */ | fun_param fun_def @@ -3050,7 +3092,7 @@ fun_def: { let lbl = ghrhs label $loc(label) in Some lbl, mkexp_constraint - ~loc:($startpos($2), $endpos) (mkexpvar ~loc:$loc(label) label) ty } + ~loc:($startpos($2), $endpos) ~modes:[] (mkexpvar ~loc:$loc(label) label) ty } ; reversed_labeled_tuple_body: (* > 2 elements *) @@ -3079,7 +3121,7 @@ reversed_labeled_tuple_body: x2 = labeled_tuple_element { let x1 = mkexp_constraint - ~loc:($startpos($2), $endpos) (mkexpvar ~loc:$loc(l1) l1) ty1 + ~loc:($startpos($2), $endpos) ~modes:[] (mkexpvar ~loc:$loc(l1) l1) ty1 in let label = ghrhs l1 $loc(l1) in [ x2; Some label, x1] } @@ -3129,6 +3171,19 @@ type_constraint: | COLONGREATER error { syntax_error() } ; +%inline type_constraint_with_modes: + | type_constraint optional_atat_mode_expr + { $1, $2 } +; + +%inline constraint_: + | type_constraint_with_modes + { let ty, modes = $1 in + Some ty, modes } + | at_mode_expr + { None, $1 } +; + (* the thing between the [type] and the [.] in [let : type <>. 'a -> 'a = ...] *) newtypes: (* : (string with_loc * jkind_annotation option) list *) @@ -3233,7 +3288,7 @@ pattern_no_exn: { let loc = $loc(label) in let pat = mkpatvar ~loc label in let lbl = ghrhs label loc in - Some lbl, mkpat ~loc (Ppat_constraint (pat, cty)) } + Some lbl, mkpat_with_modes ~loc ~modes:[] ~pat ~cty:(Some cty) } %inline labeled_tuple_pat_element_noprec(self): | self { None, $1 } @@ -3248,7 +3303,7 @@ pattern_no_exn: { let loc = $loc(label) in let pat = mkpatvar ~loc label in let lbl = ghrhs label loc in - Some lbl, mkpat ~loc (Ppat_constraint (pat, cty)) } + Some lbl, mkpat_with_modes ~loc ~modes:[] ~pat ~cty:(Some cty) } labeled_tuple_pat_element_list(self): | labeled_tuple_pat_element_list(self) COMMA labeled_tuple_pat_element(self) @@ -3328,8 +3383,6 @@ simple_pattern_not_ident: { expecting $loc($4) "pattern" } | LPAREN pattern error { unclosed "(" $loc($1) ")" $loc($3) } - | LPAREN pattern COLON core_type RPAREN - { Ppat_constraint($2, $4) } | LPAREN pattern COLON core_type error { unclosed "(" $loc($1) ")" $loc($5) } | LPAREN pattern COLON error @@ -3339,6 +3392,10 @@ simple_pattern_not_ident: { unclosed "(" $loc($1) ")" $loc($7) } | extension { Ppat_extension $1 } + | LPAREN pattern modes=at_mode_expr RPAREN + { Ppat_constraint($2, None, modes) } + | LPAREN pattern COLON core_type modes=optional_atat_mode_expr RPAREN + { Ppat_constraint($2, Some $4, modes) } ; simple_delimited_pattern: @@ -3399,11 +3456,12 @@ value_description: id = mkrhs(val_ident) COLON ty = possibly_poly(core_type) + modalities = optional_atat_modalities_expr attrs2 = post_item_attributes { let attrs = attrs1 @ attrs2 in let loc = make_loc $sloc in let docs = symbol_docs $sloc in - Val.mk id ty ~attrs ~loc ~docs, + Val.mk id ty ~modalities ~attrs ~loc ~docs, ext } ; @@ -3717,15 +3775,15 @@ generalized_constructor_arguments: { ($2,Pcstr_tuple [],Some $4) } ; -%inline atomic_type_gbl: - gbl = global_flag cty = atomic_type { - mkcty_global_maybe gbl cty -} +%inline constructor_argument: + gbl=global_flag cty=atomic_type m1=optional_atat_modalities_expr { + let cty = mkcty_global_maybe gbl cty in + Type.constructor_arg cty ~modalities:m1 ~loc:(make_loc $sloc) + } ; constructor_arguments: - | tys = inline_separated_nonempty_llist(STAR, atomic_type_gbl) - %prec below_HASH + | tys = inline_separated_nonempty_llist(STAR, constructor_argument) { Pcstr_tuple tys } | LBRACE label_declarations RBRACE { Pcstr_record (make_loc $sloc, $2) } @@ -3736,23 +3794,23 @@ label_declarations: | label_declaration_semi label_declarations { $1 :: $2 } ; label_declaration: - mutable_or_global_flag mkrhs(label) COLON poly_type_no_attr attributes + mutable_or_global_flag mkrhs(label) COLON poly_type_no_attr m1=optional_atat_modalities_expr attributes { let info = symbol_info $endpos in let mut, gbl = $1 in mkld_global_maybe gbl - (Type.field $2 $4 ~mut ~attrs:$5 ~loc:(make_loc $sloc) ~info) } + (Type.field $2 $4 ~mut ~modalities:m1 ~attrs:$6 ~loc:(make_loc $sloc) ~info) } ; label_declaration_semi: - mutable_or_global_flag mkrhs(label) COLON poly_type_no_attr attributes + mutable_or_global_flag mkrhs(label) COLON poly_type_no_attr m1=optional_atat_modalities_expr attributes SEMI attributes { let info = - match rhs_info $endpos($5) with + match rhs_info $endpos($6) with | Some _ as info_before_semi -> info_before_semi | None -> symbol_info $endpos in let mut, gbl = $1 in mkld_global_maybe gbl - (Type.field $2 $4 ~mut ~attrs:($5 @ $7) ~loc:(make_loc $sloc) ~info) } + (Type.field $2 $4 ~mut ~modalities:m1 ~attrs:($6 @ $8) ~loc:(make_loc $sloc) ~info) } ; /* Type Extensions */ @@ -3938,10 +3996,11 @@ strict_function_or_labeled_tuple_type: | mktyp( label = arg_label local = mode_flags - domain = extra_rhs(param_type) + domain_with_modes = with_optional_mode_expr(extra_rhs(param_type)) MINUSGREATER codomain = strict_function_or_labeled_tuple_type - { let type_ = mktyp_modes local domain in + { let (domain, _), arg_modes = domain_with_modes in + let type_ = mktyp_modes local domain in let label, type_ = if not (Erase_jane_syntax.should_erase ()) then label, type_ @@ -3956,34 +4015,43 @@ strict_function_or_labeled_tuple_type: [] ) | _ -> label, type_) in - let arrow_type = { pap_label = label; pap_loc = make_loc $sloc; pap_type = type_ } in - let params, codomain = + let arrow_type = { + pap_label = label; + pap_loc = make_loc $sloc; + pap_type = type_; + pap_modes = arg_modes + } + in + let params, codomain, ret_modes = match codomain.ptyp_attributes, codomain.ptyp_desc with - | [], Ptyp_arrow (params, codomain) -> params, codomain - | _, _ -> [], codomain + | [], Ptyp_arrow (params, codomain, ret_modes) -> params, codomain, ret_modes + | _, _ -> [], codomain, [] in - Ptyp_arrow (arrow_type :: params, codomain) + Ptyp_arrow (arrow_type :: params, codomain, ret_modes) } ) { $1 } | mktyp( label = arg_label arg_local = mode_flags - domain = extra_rhs(param_type) + domain_with_modes = with_optional_mode_expr(extra_rhs(param_type)) MINUSGREATER ret_local = mode_flags - codomain = tuple_type + codomain_with_modes = with_optional_mode_expr(tuple_type) %prec MINUSGREATER - { let arrow_type = { + { let (domain, _), arg_modes = domain_with_modes in + let (codomain, _), ret_modes = codomain_with_modes in + let arrow_type = { pap_label = label; pap_loc = make_loc $sloc; - pap_type = mktyp_modes arg_local domain + pap_type = mktyp_modes arg_local domain; + pap_modes = arg_modes } in let codomain = mktyp_modes ret_local (maybe_curry_typ codomain) in - Ptyp_arrow([arrow_type], codomain) + Ptyp_arrow([arrow_type], codomain, ret_modes) } ) { $1 } @@ -4002,51 +4070,58 @@ strict_function_or_labeled_tuple_type: | mktyp( label = LIDENT COLON unique_local = mode_flags - tuple = proper_tuple_type + tuple_with_modes = with_optional_mode_expr(proper_tuple_type) MINUSGREATER codomain = strict_function_or_labeled_tuple_type { + let (tuple, tuple_loc), arg_modes = tuple_with_modes in let ty, ltys = tuple in let label = mk_labelled label $loc(label) in let domain = - mktyp ~loc:$loc(tuple) (Ptyp_tuple ((None, ty) :: ltys)) + mktyp ~loc:tuple_loc (Ptyp_tuple ((None, ty) :: ltys)) in - let domain = extra_rhs_core_type domain ~pos:$endpos(tuple) in + let domain = extra_rhs_core_type domain ~pos:(snd tuple_loc) in let arrow_type = { pap_label = label; pap_loc = make_loc $sloc; - pap_type = mktyp_modes unique_local domain + pap_type = mktyp_modes unique_local domain; + pap_modes = arg_modes } in - let params, codomain = + let params, codomain, ret_modes = match codomain.ptyp_attributes, codomain.ptyp_desc with - | [], Ptyp_arrow (params, codomain) -> params, codomain - | _, _ -> [], codomain + | [], Ptyp_arrow (params, codomain, ret_modes) -> params, codomain, ret_modes + | _, _ -> [], codomain, [] in - Ptyp_arrow(arrow_type :: params, codomain) } + Ptyp_arrow(arrow_type :: params, codomain, ret_modes) } ) { $1 } | mktyp( label = LIDENT COLON arg_unique_local = mode_flags - tuple = proper_tuple_type + tuple_with_modes = with_optional_mode_expr(proper_tuple_type) MINUSGREATER ret_unique_local = mode_flags - codomain = tuple_type - { let ty, ltys = tuple in + codomain_with_modes = with_optional_mode_expr(tuple_type) + %prec MINUSGREATER + { let (tuple, tuple_loc), arg_modes = tuple_with_modes in + let (codomain, _), ret_modes = codomain_with_modes in + let ty, ltys = tuple in let label = mk_labelled label $loc(label) in let domain = - mktyp ~loc:$loc(tuple) (Ptyp_tuple ((None, ty) :: ltys)) + mktyp ~loc:tuple_loc (Ptyp_tuple ((None, ty) :: ltys)) in - let domain = extra_rhs_core_type domain ~pos:$endpos(tuple) in + let domain = extra_rhs_core_type domain ~pos:(snd tuple_loc) in let arrow_type = { pap_label = label; pap_loc = make_loc $sloc; - pap_type = mktyp_modes arg_unique_local domain + pap_type = mktyp_modes arg_unique_local domain; + pap_modes = arg_modes } in Ptyp_arrow([arrow_type], - mktyp_modes ret_unique_local (maybe_curry_typ codomain)) + mktyp_modes ret_unique_local (maybe_curry_typ codomain), + ret_modes) } ) { $1 } @@ -4089,6 +4164,58 @@ strict_function_or_labeled_tuple_type: | flags = iloption(mode_flag+) { flags } ; + +/* New mode annotation, introduced by AT or ATAT */ +%inline mode: + | LIDENT { mkloc (Mode $1) (make_loc $sloc) } +; + +%inline mode_expr: + | mode+ { $1 } +; + +at_mode_expr: + | AT mode_expr {$2} + | AT error { expecting $loc($2) "mode expression" } +; + +%inline optional_at_mode_expr: + | { [] } + | at_mode_expr {$1} +; + +%inline with_optional_mode_expr(ty): + | ty=ty m=optional_at_mode_expr { + (ty, $loc(ty)), m + } +; + +atat_mode_expr: + | ATAT mode_expr {$2} + | ATAT error { expecting $loc($2) "mode expression" } +; + +%inline optional_atat_mode_expr: + | { [] } + | atat_mode_expr {$1} +; + +/* Modalities */ + +%inline modality: + | LIDENT { mkloc (Modality $1) (make_loc $sloc) } + +%inline modalities: + | modality+ { $1 } + +optional_atat_modalities_expr: + | %prec below_HASH + { [] } + | ATAT modalities { $2 } + | ATAT error { expecting $loc($2) "modality expression" } +; + + (* Tuple types include: - atomic types (see below); - proper tuple types: int * int * int list @@ -4382,6 +4509,9 @@ operator: ; %inline infix_operator: | op = INFIXOP0 { op } + /* Still support the two symbols as infix operators */ + | AT {"@"} + | ATAT {"@@"} | op = INFIXOP1 { op } | op = INFIXOP2 { op } | op = INFIXOP3 { op } diff --git a/vendor/parser-extended/parsetree.mli b/vendor/parser-extended/parsetree.mli index 1d85d2377d..53dfa9f291 100644 --- a/vendor/parser-extended/parsetree.mli +++ b/vendor/parser-extended/parsetree.mli @@ -68,6 +68,10 @@ type constant = { type location_stack = Location.t list +type modality = | Modality of string [@@unboxed] + +type mode = | Mode of string [@@unboxed] + (** {1 Extension points} *) type attribute = { @@ -118,18 +122,19 @@ and arrow_param = pap_label: arg_label; pap_loc: Location.t; (** Location also including the codomain. *) pap_type: core_type; + pap_modes: mode loc list; } and core_type_desc = | Ptyp_any (** [_] *) | Ptyp_var of ty_var (** A type variable such as ['a] *) - | Ptyp_arrow of arrow_param list * core_type - (** [Ptyp_arrow(lbl, T1, T2)] represents: - - [T1 -> T2] when [lbl] is + | Ptyp_arrow of arrow_param list * core_type * mode loc list + (** [Ptyp_arrow([lbl, T1, M1], T2, M2)] represents: + - [T1 @ M1 -> T2 @ M2] when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]}, - - [~l:T1 -> T2] when [lbl] is + - [~l:(T1 @ M1) -> T2 @ M2] when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled]}, - - [?l:T1 -> T2] when [lbl] is + - [?l:(T1 @ M1) -> T2 @ M2] when [lbl] is {{!Asttypes.arg_label.Optional}[Optional]}. *) | Ptyp_tuple of (string loc option * core_type) list @@ -327,7 +332,11 @@ and pattern_desc = Pattern [[: P1; ...; Pn :]] (flag = Immutable) *) | Ppat_list of pattern list (** Pattern [[ P1; ...; Pn ]] *) | Ppat_or of pattern list (** Pattern [P1 | ... | Pn] *) - | Ppat_constraint of pattern * core_type (** Pattern [(P : T)] *) + | Ppat_constraint of pattern * core_type option * mode loc list + (** [Ppat_constraint(P, tyopt, modes)] represents: + - [(P : ty @@ modes)] when [tyopt] is [Some ty] + - [(P @ modes)] when [tyopt] is [None] + *) | Ppat_type of Longident.t loc (** Pattern [#tconst] *) | Ppat_lazy of pattern (** Pattern [lazy P] *) | Ppat_unpack of string option loc * package_type option @@ -449,7 +458,7 @@ and expression_desc = - [for i = E1 downto E2 do E3 done] when [direction] is {{!Asttypes.direction_flag.Downto}[Downto]} *) - | Pexp_constraint of expression * core_type (** [(E : T)] *) + | Pexp_constraint of expression * core_type option * mode loc list (** [(E : T @@ modes)] *) | Pexp_coerce of expression * core_type option * core_type (** [Pexp_coerce(E, from, T)] represents - [(E :> T)] when [from] is [None], @@ -623,6 +632,7 @@ and value_description = { pval_name: string loc; pval_type: core_type; + pval_modalities: modality loc list; pval_prim: string loc list; pval_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) pval_loc: Location.t; @@ -686,6 +696,7 @@ and label_declaration = { pld_name: string loc; pld_mutable: mutable_flag; + pld_modalities: modality loc list; pld_type: core_type; pld_loc: Location.t; pld_attributes: attributes; (** [l : T [\@id1] [\@id2]] *) @@ -711,8 +722,15 @@ and constructor_declaration = pcd_attributes: attributes; (** [C of ... [\@id1] [\@id2]] *) } +and constructor_argument = + { + pca_modalities: modality loc list; + pca_type: core_type; + pca_loc: Location.t; + } + and constructor_arguments = - | Pcstr_tuple of core_type list + | Pcstr_tuple of constructor_argument list | Pcstr_record of Location.t * label_declaration list (** Values of type {!constructor_declaration} represents the constructor arguments of: @@ -1208,6 +1226,7 @@ and value_binding = pvb_pat: pattern; pvb_expr: expression; pvb_constraint: value_constraint option; + pvb_modes: mode loc list; pvb_is_pun: bool; pvb_attributes: attributes; pvb_loc: Location.t; diff --git a/vendor/parser-extended/printast.ml b/vendor/parser-extended/printast.ml index 8ec320bd47..a08dd0688e 100644 --- a/vendor/parser-extended/printast.ml +++ b/vendor/parser-extended/printast.ml @@ -226,6 +226,18 @@ let labeled_tuple_element f i ppf (l, ct) = option i string_loc ppf l; f i ppf ct +let modalities i ppf modalities = + line i ppf "modalities\n"; + list i string_loc ppf ( + List.map (Location.map (fun (Modality x) -> x)) modalities + ) + +let modes i ppf modes = + line i ppf "modes\n"; + list i string_loc ppf ( + List.map (Location.map (fun (Mode x) -> x)) modes + ) + let rec core_type i ppf x = line i ppf "core_type %a\n" fmt_location x.ptyp_loc; attributes i ppf x.ptyp_attributes; @@ -234,10 +246,11 @@ let rec core_type i ppf x = | Ptyp_any -> line i ppf "Ptyp_any\n"; | Ptyp_var (s) -> line i ppf "Ptyp_var %a\n" fmt_ty_var s; - | Ptyp_arrow (params, ct2) -> + | Ptyp_arrow (params, ct2, m2) -> line i ppf "Ptyp_arrow\n"; list i arrow_param ppf params; core_type i ppf ct2; + modes i ppf m2; | Ptyp_tuple l -> line i ppf "Ptyp_tuple\n"; list i labeled_core_type ppf l; @@ -276,10 +289,11 @@ let rec core_type i ppf x = list i core_type ppf l (* End Jane Street extension *) -and arrow_param i ppf {pap_label; pap_loc; pap_type} = +and arrow_param i ppf {pap_label; pap_loc; pap_type; pap_modes} = line i ppf "arrow_param %a\n" fmt_location pap_loc; arg_label i ppf pap_label; - core_type i ppf pap_type + core_type i ppf pap_type; + modes i ppf pap_modes and object_field i ppf x = line i ppf "object_field %a\n" fmt_location x.pof_loc; @@ -355,10 +369,11 @@ and pattern i ppf x = | Ppat_lazy p -> line i ppf "Ppat_lazy\n"; pattern i ppf p; - | Ppat_constraint (p, ct) -> + | Ppat_constraint (p, ct, m) -> line i ppf "Ppat_constraint\n"; pattern i ppf p; - core_type i ppf ct; + option i core_type ppf ct; + modes i ppf m; | Ppat_type (li) -> line i ppf "Ppat_type\n"; longident_loc i ppf li @@ -469,10 +484,11 @@ and expression i ppf x = expression i ppf e1; expression i ppf e2; expression i ppf e3; - | Pexp_constraint (e, ct) -> + | Pexp_constraint (e, ct, m) -> line i ppf "Pexp_constraint\n"; expression i ppf e; - core_type i ppf ct; + option i core_type ppf ct; + modes i ppf m; | Pexp_coerce (e, cto1, cto2) -> line i ppf "Pexp_coerce\n"; expression i ppf e; @@ -635,10 +651,11 @@ and type_constraint i ppf constraint_ = 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; + x.pval_name fmt_location x.pval_loc; attributes i ppf x.pval_attributes; core_type (i+1) ppf x.pval_type; - list (i+1) string_loc ppf x.pval_prim + list (i+1) string_loc ppf x.pval_prim; + modalities (i+1) ppf x.pval_modalities and type_parameter i ppf (x, _variance) = core_type i ppf x @@ -1159,14 +1176,20 @@ and constructor_decl i ppf constructor_arguments (i+1) ppf pcd_args; option (i+1) core_type ppf pcd_res +and constructor_argument i ppf {pca_modalities; pca_type; pca_loc} = + line i ppf "%a\n" fmt_location pca_loc; + modalities (i+1) ppf pca_modalities; + core_type (i+1) ppf pca_type + and constructor_arguments i ppf = function - | Pcstr_tuple l -> list i core_type ppf l + | Pcstr_tuple l -> list i constructor_argument ppf l | Pcstr_record (_, l) -> list i label_decl ppf l -and label_decl i ppf {pld_name; pld_mutable; pld_type; pld_loc; pld_attributes}= +and label_decl i ppf {pld_name; pld_mutable; pld_modalities; pld_type; pld_loc; pld_attributes}= line i ppf "%a\n" fmt_location pld_loc; attributes i ppf pld_attributes; line (i+1) ppf "%a\n" fmt_mutable_flag pld_mutable; + modalities (i+1) ppf pld_modalities; line (i+1) ppf "%a" fmt_string_loc pld_name; core_type (i+1) ppf pld_type @@ -1189,7 +1212,8 @@ and value_binding i ppf x = attributes (i+1) ppf x.pvb_attributes; pattern (i+1) ppf x.pvb_pat; Option.iter (value_constraint (i+1) ppf) x.pvb_constraint; - expression (i+1) ppf x.pvb_expr + expression (i+1) ppf x.pvb_expr; + modes (i+1) ppf x.pvb_modes and value_constraint i ppf x = let pp_sep ppf () = Format.fprintf ppf "@ "; in diff --git a/vendor/parser-standard/lexer.mll b/vendor/parser-standard/lexer.mll index 0cf438a196..4004356c0a 100644 --- a/vendor/parser-standard/lexer.mll +++ b/vendor/parser-standard/lexer.mll @@ -780,6 +780,8 @@ rule token = parse { PREFIXOP op } | ['=' '<' '>' '|' '&' '$'] symbolchar * as op { INFIXOP0 op } + | "@" { AT } + | "@@" { ATAT } | ['@' '^'] symbolchar * as op { INFIXOP1 op } | ['+' '-'] symbolchar * as op