diff --git a/.github/workflows/build-others.yml b/.github/workflows/build-others.yml index d1b170456a..ce12dfb019 100644 --- a/.github/workflows/build-others.yml +++ b/.github/workflows/build-others.yml @@ -35,9 +35,6 @@ jobs: uses: ocaml/setup-ocaml@v3 with: ocaml-compiler: ${{ matrix.ocaml-compiler }} - opam-repositories: | - opam-repository-mingw: https://github.com/ocaml-opam/opam-repository-mingw.git#sunset - default: https://github.com/ocaml/opam-repository.git - name: Opam dependencies run: opam install --deps-only -t . diff --git a/lib/Ast.ml b/lib/Ast.ml index 877c94c4ca..d566f6a148 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -337,18 +337,24 @@ let rec mty_is_simple x = | Pmty_signature {psg_items= _ :: _; _} |Pmty_with (_, _ :: _ :: _) |Pmty_extension _ - |Pmty_functor (_, _) + |Pmty_functor (_, _, _) |Pmty_strengthen _ -> false - | Pmty_gen (_, t) -> mty_is_simple t | Pmty_typeof e -> mod_is_simple e | Pmty_with (t, ([] | [_])) -> mty_is_simple t +and mode_is_simple = function [] -> true | _ :: _ -> false + +and option_is_simple is_simple = function + | None -> true + | Some x -> is_simple x + and mod_is_simple x = match x.pmod_desc with | Pmod_ident _ | Pmod_unpack _ | Pmod_structure [] | Pmod_hole -> true | Pmod_structure (_ :: _) | Pmod_extension _ | Pmod_functor (_, _) -> false - | Pmod_constraint (e, t) -> mod_is_simple e && mty_is_simple t + | Pmod_constraint (e, t, m) -> + mod_is_simple e && option_is_simple mty_is_simple t && mode_is_simple m | Pmod_apply (a, b) -> mod_is_simple a && mod_is_simple b | Pmod_apply_unit (a, _) -> mod_is_simple a @@ -726,7 +732,7 @@ module T = struct | Pat of pattern | Exp of expression | Fp of function_param - | Vc of value_constraint + | Vc of value_constraint * modes | Lb of value_binding | Mb of module_binding | Md of module_declaration @@ -751,7 +757,9 @@ module T = struct | Pat p -> Format.fprintf fs "Pat:@\n%a" Printast.pattern p | Exp e -> Format.fprintf fs "Exp:@\n%a" Printast.expression e | Fp p -> Format.fprintf fs "Fp:@\n%a" Printast.function_param p - | Vc c -> Format.fprintf fs "Vc:@\n%a" Printast.value_constraint c + | Vc (c, m) -> + Format.fprintf fs "Vc:@\n%a@\n%a" Printast.value_constraint c + (Printast.modes 0) m | Lb b -> Format.fprintf fs "Lb:@\n%a" Printast.value_binding b | Mb m -> Format.fprintf fs "Mb:@\n%a" Printast.module_binding m | Md m -> Format.fprintf fs "Md:@\n%a" Printast.module_declaration m @@ -1100,7 +1108,7 @@ end = struct | Pexp_let (lbs, _) -> assert (check_let_bindings lbs) | _ -> assert false ) | Fp _ -> assert false - | Vc c -> assert (check_value_constraint c) + | Vc (c, _) -> assert (check_value_constraint c) | Lb _ -> assert false | Mb _ -> assert false | Md _ -> assert false @@ -2011,6 +2019,13 @@ end = struct | { ast= {ptyp_desc= Ptyp_arrow _ | Ptyp_tuple _; _} ; ctx= Typ {ptyp_desc= Ptyp_class _; _} } -> true + | { ast= {ptyp_desc= Ptyp_arrow _; _} + ; ctx= + ( Pat {ppat_desc= Ppat_constraint (_, _, modes); _} + | Vc (_, modes) + | Exp {pexp_desc= Pexp_constraint (_, _, modes); _} ) } + when not (List.is_empty modes) -> + true | { ast= {ptyp_desc= Ptyp_alias _; _} ; ctx= ( Str {pstr_desc= Pstr_typext _; _} diff --git a/lib/Ast.mli b/lib/Ast.mli index b11ed647d6..f5a45bda7f 100644 --- a/lib/Ast.mli +++ b/lib/Ast.mli @@ -113,7 +113,7 @@ type t = | Pat of pattern | Exp of expression | Fp of function_param - | Vc of value_constraint + | Vc of value_constraint * modes | Lb of value_binding | Mb of module_binding | Md of module_declaration diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index eac28dc7e3..12b670fa0e 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -24,11 +24,16 @@ type c = ; cmts: Cmts.t ; fmt_code: Fmt_odoc.fmt_code } -type modals = No_modals | Modes of modes | Modalities of modalities +(* CR zqian: mode_crossing should just take [modalities] *) +type modals = + | No_modals + | Modes of modes + | Modalities of modalities + | Mode_crossing of modes let is_empty_modals = function - | No_modals | Modes [] | Modalities [] -> true - | Modes (_ :: _) | Modalities (_ :: _) -> false + | No_modals | Modes [] | Modalities [] | Mode_crossing [] -> true + | Modes (_ :: _) | Modalities (_ :: _) | Mode_crossing (_ :: _) -> false module Cmts = struct include Cmts @@ -572,11 +577,12 @@ let let_binding_can_be_punned ~binding ~is_ext = ; lb_pat ; lb_args ; lb_typ + ; lb_modes ; lb_exp ; lb_pun= _ ; lb_attrs= _ ; lb_local - ; lb_modes + ; lb_modes_binding ; lb_loc= _ } : Sugar.Let_binding.t ) = binding @@ -586,10 +592,11 @@ let let_binding_can_be_punned ~binding ~is_ext = , lb_pat.ast.ppat_desc , lb_exp.ast.pexp_desc , lb_typ + , lb_modes , lb_args , (lb_pat.ast.ppat_attributes, lb_exp.ast.pexp_attributes) , lb_local - , lb_modes ) + , lb_modes_binding ) with | ( (* Binding must be inside an extension node (we do not pun operators) *) true @@ -599,6 +606,8 @@ let let_binding_can_be_punned ~binding ~is_ext = Pexp_ident {txt= Lident right; _} , (* There cannot be a type annotation on the [let] *) None + , (* There cannot be a mode annotation *) + [] , (* This cannot be a lambda *) [] , (* There must be no attrs on either side *) @@ -743,7 +752,7 @@ and fmt_payload c ctx pld = fmt_if (not (List.is_empty mex)) "@ " $ fmt_structure c ctx mex | PSig ({psg_modalities; _} as mty) -> fmt ":" - $ fmt_modals ~pro:(fmt " ") c ~ats:`Two (Modalities psg_modalities) + $ fmt_modals ~pro:(fmt " ") c (Modalities psg_modalities) $ fmt "@ " $ fmt_signature c ctx {mty with psg_modalities= []} | PTyp typ -> fmt ":@ " $ fmt_core_type c (sub_typ ~ctx typ) @@ -771,17 +780,20 @@ and fmt_record_field c ?typ1 ?typ2 ?rhs lid1 = $ cbox 0 (fmt_longident_loc c lid1 $ Cmts.fmt_after c lid1.loc $ fmt_type_rhs) -and fmt_type_cstr c ?constraint_ctx xtyp = +and fmt_type_cstr c ?constraint_ctx ?constraint_modes xtyp = let colon_before = Poly.(c.conf.fmt_opts.break_colon.v = `Before) in fmt_or_k colon_before (fits_breaks " " ~hint:(1000, 0) "") (fmt "@;<0 -1>") $ cbox_if colon_before 0 - (fmt_core_type c ~pro:":" ?constraint_ctx ~pro_space:(not colon_before) - ~box:(not colon_before) xtyp ) + (fmt_core_type c ~pro:":" ?constraint_ctx ?constraint_modes + ~pro_space:(not colon_before) ~box:(not colon_before) xtyp ) and type_constr_and_body c xbody = let body = xbody.ast in match xbody.ast.pexp_desc with - | Pexp_constraint (exp, Some typ, []) -> + | Pexp_constraint (exp, typ, ([] as modes)) + |Pexp_constraint (exp, (None as typ), modes) + (* [fun x : ret_t @ ret_mode ->] is banned in the parser, so don't move the + constraint if there are both a type and modes. *) -> Cmts.relocate c.cmts ~src:body.pexp_loc ~before:exp.pexp_loc ~after:exp.pexp_loc ; let typ_ctx = Exp body in @@ -793,24 +805,29 @@ and type_constr_and_body c xbody = in Exp Ast_helper.(Exp.fun_ param exp) in - ( Some (fmt_type_cstr c ~constraint_ctx:`Fun (sub_typ ~ctx:typ_ctx typ)) - , sub_exp ~ctx:exp_ctx exp ) + let fmt_typ = + match typ with + | Some typ -> + fmt_type_cstr c ~constraint_ctx:`Fun ~constraint_modes:modes + (sub_typ ~ctx:typ_ctx typ) + | None -> noop + in + (Some (fmt_typ $ fmt_modals c (Modes modes)), sub_exp ~ctx:exp_ctx exp) | _ -> (None, xbody) -and fmt_modals ?(pro = fmt "@ ") c ~ats modals = - let fmt_ats = - match ats with `Zero -> str "" | `One -> str "@ " | `Two -> str "@@ " - in +and fmt_modals ?(pro = fmt "@ ") c modals = let fmt_modal {txt; loc} = Cmts.fmt c loc (str txt) ~eol:(fmt "@ ") in let fmt_mode {txt= Mode mode; loc} = fmt_modal {txt= mode; loc} in let fmt_modality {txt= Modality modality; loc} = fmt_modal {txt= modality; loc} in - let fmt_modals = + let fmt_ats, fmt_modals = match modals with - | No_modals -> noop - | Modes modes -> list modes "@ " fmt_mode - | Modalities modalities -> list modalities "@ " fmt_modality + | No_modals -> (noop, noop) + | Modes modes -> (fmt "@@ ", list modes "@ " fmt_mode) + | Modalities modalities -> + (fmt "@@@@ ", list modalities "@ " fmt_modality) + | Mode_crossing modes -> (noop, list modes "@ " fmt_mode) in fmt_if_k (not (is_empty_modals modals)) (pro $ fmt_ats $ hvbox 0 fmt_modals) @@ -853,7 +870,7 @@ and fmt_jkind c ~ctx {txt= jkd; loc} = | Default | Abbreviation _ | Kind_of _ -> assert false ) | _ -> false in - let mode_fmt = hvbox 0 (fmt_modals ~ats:`Zero c (Modes modes)) in + let mode_fmt = hvbox 0 (fmt_modals c (Mode_crossing modes)) in let fmt = fmt_jkind c ~ctx:inner_ctx jkind $ fmt "@ mod" $ Cmts.fmt_within c loc $ mode_fmt @@ -878,7 +895,7 @@ and fmt_jkind c ~ctx {txt= jkd; loc} = $ hvbox_if (not (List.is_empty ms)) 3 - (fmt_modals c ~pro:(fmt " ") ~ats:`Two (Modalities ms)) + (fmt_modals c ~pro:(fmt " ") (Modalities ms)) in (parens, fmt) | Kind_of type_ -> @@ -941,7 +958,7 @@ and fmt_arrow_param ~return c ctx | None -> core_type | Some f -> hovbox 2 (f $ core_type) in - let modes = fmt_modals c ~ats:`One (Modes mI) in + let modes = fmt_modals c (Modes mI) in hvbox 0 (Cmts.fmt_before c locI $ arg $ modes) (** Format [Ptyp_arrow]. [indent] can be used to override the indentation @@ -982,7 +999,7 @@ and fmt_arrow_type c ~ctx ?indent ~parens ~parent_has_parens args fmt_ret_typ gets support for them, we should remove tydecl_param and go with whatever their solution is. *) and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx - ?(tydecl_param = false) ({ast= typ; ctx} as xtyp) = + ?constraint_modes ?(tydecl_param = false) ({ast= typ; ctx} as xtyp) = protect c (Typ typ) @@ let {ptyp_desc; ptyp_attributes; ptyp_loc; _} = typ in @@ -1031,8 +1048,8 @@ and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx in let ctx = Typ typ in let parenze_constraint_ctx = - match constraint_ctx with - | Some `Fun when not parens -> true + match (constraint_ctx, constraint_modes) with + | (Some `Fun, _ | _, Some (_ :: _)) when not parens -> true | _ -> false in match ptyp_desc with @@ -1091,7 +1108,7 @@ and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx ( hovbox_if (not box) 0 (list a1N "@ " (fmt_type_var_with_parenze ~have_tick:true c)) $ fmt ".@ " - $ fmt_core_type c ~box:true (sub_typ ~ctx t) ) + $ fmt_core_type c ~box:true ?constraint_modes (sub_typ ~ctx t) ) | Ptyp_tuple typs -> hvbox 0 (wrap_if parenze_constraint_ctx "(" ")" @@ -1360,7 +1377,9 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false) | names -> hvbox 0 (Params.parens c.conf - (str "type " $ list names "@ " (fmt_str_loc c)) ) + ( str "type " + $ list names "@ " + (fmt_type_var_with_parenze ~have_tick:false c) ) ) $ fmt "@ " ) $ fmt_pattern c (sub_pat ~ctx pat) ) ) | Ppat_variant (lbl, None) -> variant_var c lbl @@ -1503,14 +1522,13 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false) ( match ctx0 with | Exp {pexp_desc= Pexp_let _; _} -> fmt "@ : " | _ -> fmt " :@ " ) - $ fmt_core_type c (sub_typ ~ctx typ) + $ fmt_core_type c ~constraint_modes:modes (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) $ fmt_typ - $ fmt_modals c ~ats (Modes modes) ) ) + $ fmt_modals c (Modes modes) ) ) | Ppat_type lid -> fmt_longident_loc c ~pre:"#" lid | Ppat_lazy pat -> cbox 2 @@ -1571,9 +1589,6 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false) and fmt_fun_args c args = let fmt_fun_arg (a : function_param) = - let a = - {a with pparam_desc= Sugar.remove_local_attrs c.cmts a.pparam_desc} - in let ctx = Fp a in Cmts.fmt c a.pparam_loc @@ @@ -2567,8 +2582,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_modals c ~ats:`Two (Modes modes) ) + $ fmt_core_type c ~constraint_modes:modes (sub_typ ~ctx t) + $ fmt_modals c (Modes modes) ) $ fmt_atrs ) ) | Pexp_construct ({txt= Lident (("()" | "[]") as txt); loc}, None) -> let opn = char txt.[0] and cls = char txt.[1] in @@ -2757,7 +2772,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens let xbody = sub_mod ~ctx pmod in let xbody, xmty = match xbody.ast with - | { pmod_desc= Pmod_constraint (body_me, body_mt) + | { pmod_desc= Pmod_constraint (body_me, Some body_mt, _) ; pmod_loc ; pmod_attributes= [] } -> Cmts.relocate c.cmts ~src:pmod_loc ~before:body_me.pmod_loc @@ -3729,7 +3744,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_modals c ~ats:`Two (Modalities pval_modalities) + $ fmt_modals c (Modalities pval_modalities) $ fmt_if (not (List.is_empty pval_prim)) "@ = " $ hvbox_if (List.length pval_prim > 1) 0 @@ list pval_prim "@;" fmt_val_prim ) @@ -3939,8 +3954,7 @@ and fmt_label_declaration c ctx ?(last = false) decl = $ fmt_if field_loose " " $ fmt ":" ) $ fmt "@ " $ fmt_core_type c (sub_typ ~ctx pld_type) ) - $ fmt_modals c ~ats:`Two (Modalities pld_modalities) - ) + $ fmt_modals c (Modalities pld_modalities) ) $ fmt_semicolon ) $ cmt_after_type ) $ fmt_attributes c ~pre:(Break (1, 1)) atrs ) @@ -4002,8 +4016,7 @@ and fmt_constructor_arguments ?vars c ctx ~pre = function Cmts.fmt c pca_loc @@ hvbox 0 ( fmt_core_type_gf c ctx pca_type - $ fmt_modals c ~ats:`Two (Modalities pca_modalities) - ) ) ) + $ fmt_modals c (Modalities pca_modalities) ) ) ) in pre $ vars $ cargs | Pcstr_record (loc, lds) -> @@ -4133,7 +4146,7 @@ and fmt_extension_constructor c ctx ec = and fmt_functor_param c ctx {loc; txt= arg} = match arg with | Unit -> Cmts.fmt c loc (wrap "(" ")" (Cmts.fmt_within c loc)) - | Named (name, mt) -> + | Named (name, mt, _) -> let xmt = sub_mty ~ctx mt in hvbox 0 (Cmts.fmt c loc @@ -4167,7 +4180,7 @@ and fmt_module_type c ?(rec_ = false) ({ast= mty; _} as xmty) = ; pro= Some ( before $ str "sig" - $ fmt_modals c ~ats:`Two (Modalities psg_modalities) + $ fmt_modals c (Modalities psg_modalities) $ fmt_if empty " " ) ; psp= fmt_if (not empty) "@;<1000 2>" ; bdy= @@ -4181,7 +4194,15 @@ and fmt_module_type c ?(rec_ = false) ({ast= mty; _} as xmty) = Some ( str "end" $ after $ fmt_attributes_and_docstrings c pmty_attributes ) } - | Pmty_functor (args, mt) -> + | Pmty_functor (args, mt, _mm) -> + let rec pull_args_from_ret args mt = + match (mt.pmty_desc, mt.pmty_attributes) with + | Pmty_functor (args', mt', _mm), [] -> + let args', mt' = pull_args_from_ret args' mt' in + (args @ args', mt') + | _ -> (args, mt) + in + let args, mt = pull_args_from_ret args mt in let blk = fmt_module_type c (sub_mty ~ctx mt) in { blk with pro= @@ -4198,20 +4219,6 @@ and fmt_module_type c ?(rec_ = false) ({ast= mty; _} as xmty) = fmt_or_k (Option.is_none blk.pro) (fits_breaks " " ~hint:(1, 2) "") blk.psp } - | Pmty_gen (gen_loc, mt) -> - let blk = fmt_module_type c (sub_mty ~ctx mt) in - { blk with - pro= - Some - ( Cmts.fmt_before c pmty_loc - $ Cmts.fmt c gen_loc (wrap "(" ")" (Cmts.fmt_within c gen_loc)) - $ fmt "@;<1 2>->" - $ opt blk.pro (fun pro -> str " " $ pro) ) - ; epi= Some (fmt_opt blk.epi $ Cmts.fmt_after c pmty_loc) - ; psp= - fmt_or_k (Option.is_none blk.pro) - (fits_breaks " " ~hint:(1, 2) "") - blk.psp } | Pmty_with _ -> let wcs, mt = Sugar.mod_with (sub_mty ~ctx mty) in let fmt_cstr ~first ~last:_ wc = @@ -4290,7 +4297,7 @@ and fmt_module_type c ?(rec_ = false) ({ast= mty; _} as xmty) = ; epi= Some epi1 } and fmt_signature c ctx sg = - fmt_modals c ~ats:`Two (Modalities sg.psg_modalities) + fmt_modals c (Modalities sg.psg_modalities) $ fmt_signature_item_list c ctx sg.psg_items and fmt_signature_item_list c ctx itms = @@ -4379,7 +4386,7 @@ and fmt_signature_item c ?ext {ast= si; _} = $ fmt_item_attributes c ~pre:(Break (1, 0)) atrs $ fmt_modals ~pro:(fmt_or has_attrs "@ " " ") - c ~ats:`Two (Modalities modalities) ) + c (Modalities modalities) ) $ doc_after ) | Psig_modtype mtd -> fmt_module_type_declaration c ctx mtd | Psig_modtypesubst mtd -> fmt_module_type_declaration ~eqty:":=" c ctx mtd @@ -4504,7 +4511,7 @@ and fmt_module c ctx ?rec_ ?epi ?(can_sparse = false) keyword ?(eqty = "=") match txt with | Unit -> (pro $ Cmts.fmt c loc (wrap "(" ")" (Cmts.fmt_within c loc)), noop) - | Named (name, mt) -> + | Named (name, mt, _mm) -> if args_p.dock then (* All signatures, put the [epi] into the box of the next arg and don't break. *) @@ -4537,7 +4544,7 @@ and fmt_module c ctx ?rec_ ?epi ?(can_sparse = false) keyword ?(eqty = "=") $ wrap_if (not (is_empty_modals modals)) "(" ")" - (fmt_str_loc_opt c name $ fmt_modals c ~ats:`One modals) + (fmt_str_loc_opt c name $ fmt_modals c modals) in let compact = Poly.(c.conf.fmt_opts.let_module.v = `Compact) || not can_sparse @@ -4579,6 +4586,7 @@ and fmt_module_declaration c ~rec_flag ~first {ast= pmd; _} = ; pmd_modalities ; pmd_args ; pmd_type + ; pmd_mode= _ ; pmd_ext_attrs= attrs ; pmd_loc } = pmd @@ -4791,7 +4799,8 @@ and fmt_module_expr ?(dock_struct = true) c ({ast= m; _} as xmod) = let blk_a = fmt_module_expr c (sub_mod ~ctx me_a) in fmt_mod_apply c ctx ~parens ~dock_struct pmod_loc pmod_attributes me_f (`Block (blk_a, Mod.is_simple me_a)) - | Pmod_constraint (me, mt) -> + | Pmod_constraint (me, mt, _mm) -> + let mt = match mt with None -> assert false | Some mt -> mt in let blk_e = fmt_module_expr c (sub_mod ~ctx me) in let blk_t = fmt_module_type c (sub_mty ~ctx mt) in let has_epi = @@ -5075,18 +5084,21 @@ and fmt_let c ~ext ~rec_flag ~bindings ~parens ~fmt_atrs ~fmt_expr ~body_loc $ hvbox 0 fmt_expr ) ) $ fmt_atrs -and fmt_value_constraint c vc_opt = +and fmt_value_constraint c vc_opt modes = let fmt_sep x = match c.conf.fmt_opts.break_colon.v with | `Before -> fmt "@ " $ str x $ char ' ' | `After -> char ' ' $ str x $ fmt "@ " in + let fmt_modes = fmt_modals c (Modes modes) in match vc_opt with | Some vc -> ( - let ctx = Vc vc in + let ctx = Vc (vc, modes) in match vc with | Pvc_constraint {locally_abstract_univars= []; typ} -> - (noop, fmt_type_cstr c (sub_typ ~ctx typ)) + ( noop + , fmt_type_cstr ~constraint_modes:modes c (sub_typ ~ctx typ) + , fmt_modes ) | Pvc_constraint {locally_abstract_univars= pvars; typ} -> ( match c.conf.fmt_opts.break_colon.v with | `Before -> @@ -5097,7 +5109,9 @@ and fmt_value_constraint c vc_opt = $ list pvars " " (fmt_type_var_with_parenze ~have_tick:false c) $ fmt ".@ " - $ fmt_core_type c (sub_typ ~ctx typ) ) ) + $ fmt_core_type ~constraint_modes:modes c + (sub_typ ~ctx typ) ) + , fmt_modes ) | `After -> ( fmt_sep ":" $ hvbox 0 @@ -5105,31 +5119,40 @@ and fmt_value_constraint c vc_opt = $ list pvars " " (fmt_type_var_with_parenze ~have_tick:false c) $ str "." ) - , fmt "@ " $ fmt_core_type c (sub_typ ~ctx typ) ) ) + , fmt "@ " + $ fmt_core_type ~constraint_modes:modes c (sub_typ ~ctx typ) + , fmt_modes ) ) | Pvc_coercion {ground; coercion} -> ( noop , opt ground (fun ty -> - fmt_sep ":" $ fmt_core_type c (sub_typ ~ctx ty) ) + fmt_sep ":" + $ fmt_core_type ~constraint_modes:modes c (sub_typ ~ctx ty) ) $ fmt_sep ":>" - $ fmt_core_type c (sub_typ ~ctx coercion) ) ) - | None -> (noop, noop) + $ fmt_core_type ~constraint_modes:modes c (sub_typ ~ctx coercion) + , fmt_modes ) ) + | None -> (noop, noop, fmt_modes) and fmt_value_binding c ~rec_flag ?(punned_in_output = false) ?ext ?in_ ?epi { lb_op ; lb_pat ; lb_args ; lb_typ + ; lb_modes ; lb_exp ; lb_attrs ; lb_local - ; lb_modes + ; lb_modes_binding ; lb_loc ; lb_pun= punned_in_source } = update_config_maybe_disabled c lb_loc lb_attrs @@ fun c -> let doc1, atrs = doc_atrs lb_attrs in let doc2, atrs = doc_atrs atrs in - let fmt_newtypes, fmt_cstr = fmt_value_constraint c lb_typ in + let modes_binding = Modes lb_modes_binding in + let fmt_modes_binding = fmt_modals c modes_binding in + let fmt_newtypes, fmt_cstr, fmt_modes = + fmt_value_constraint c lb_typ lb_modes + in let indent = match lb_exp.ast.pexp_desc with | Pexp_function _ -> c.conf.fmt_opts.function_indent.v @@ -5174,8 +5197,7 @@ and fmt_value_binding c ~rec_flag ?(punned_in_output = false) ?ext ?in_ ?epi , 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 + let has_modes_binding = not (is_empty_modals modes_binding) in fmt_docstring c ~epi:(fmt "@\n") doc1 $ cmts_before $ hvbox 0 @@ -5192,21 +5214,17 @@ and fmt_value_binding c ~rec_flag ?(punned_in_output = false) ?ext ?in_ ?epi $ fmt_if rec_flag " rec" $ fmt_if lb_local " local_" $ fmt_or pat_has_cmt "@ " " " - $ wrap_if (has_args && has_modes) "(" ")" + $ Params.parens_if + (has_args && has_modes_binding) + c.conf ( fmt_pattern c lb_pat - $ fmt_if_k - (has_args || not has_cstr) - (fmt_modals c ~ats:`One - (Modes lb_modes) ) ) ) + $ fmt_modes_binding ) ) $ fmt_if_k has_args ( fmt "@ " $ wrap_fun_decl_args c (fmt_fun_args c lb_args) ) $ fmt_newtypes ) - $ fmt_cstr - $ fmt_if_k - ((not has_args) && has_cstr) - (fmt_modals c ~ats:`Two (Modes lb_modes)) ) + $ fmt_cstr $ fmt_modes ) $ fmt_if_k (not punned_in_output) (fmt_or_k c.conf.fmt_opts.ocp_indent_compat.v (fits_breaks " =" ~hint:(1000, 0) "=") @@ -5229,7 +5247,7 @@ and fmt_module_binding c ~rec_flag ~first {ast= pmb; _} = let xbody = sub_mod ~ctx pmb.pmb_expr in let xbody, xmty = match xbody.ast with - | { pmod_desc= Pmod_constraint (body_me, body_mt) + | { pmod_desc= Pmod_constraint (body_me, Some body_mt, _) ; pmod_loc ; pmod_attributes= [] } -> Cmts.relocate c.cmts ~src:pmod_loc ~before:body_me.pmod_loc @@ -5351,12 +5369,12 @@ let fmt_file (type a) ~ctx ~fmt_code ~debug (fragment : a Extended_ast.t) let c = {source; cmts; conf; debug; fmt_code} in match (fragment, itms) with | Signature, {psg_items= []; psg_modalities; _} -> - fmt_modals ~pro:noop c ~ats:`Two (Modalities psg_modalities) + fmt_modals ~pro:noop c (Modalities psg_modalities) $ Cmts.fmt_after ~pro:noop c Location.none | Structure, [] | Use_file, [] -> Cmts.fmt_after ~pro:noop c Location.none | Structure, l -> Chunk.split_and_fmt Structure c ctx l | Signature, {psg_modalities; psg_items= l; _} -> - fmt_modals ~pro:noop c ~ats:`Two (Modalities psg_modalities) + fmt_modals ~pro:noop c (Modalities psg_modalities) $ fmt_if (not (List.is_empty psg_modalities)) "\n@;<1000 0>" $ Chunk.split_and_fmt Signature c ctx l | Use_file, l -> Chunk.split_and_fmt Use_file c ctx l diff --git a/lib/Params.ml b/lib/Params.ml index e41248bbcb..203fa878f2 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -110,7 +110,8 @@ module Mod = struct ( _ , { pmty_desc= Pmty_signature _ | Pmty_typeof {pmod_desc= Pmod_structure _; _} - ; _ } ) -> + ; _ } + , _ ) -> true | _ -> false diff --git a/lib/Sugar.ml b/lib/Sugar.ml index 4e28fd5390..d6a4ca5d25 100644 --- a/lib/Sugar.ml +++ b/lib/Sugar.ml @@ -124,16 +124,6 @@ let cl_fun ?(will_keep_first_ast_node = true) cmts xexp = in fun_ ~will_keep_first_ast_node xexp -let remove_local_attrs cmts param = - match param with - | Pparam_newtype _ -> param - | Pparam_val (_, label, default, pattern) -> - let ppat_attributes, is_local = - check_local_attr_and_reloc_cmts cmts pattern.ppat_attributes - pattern.ppat_loc - in - Pparam_val (is_local, label, default, {pattern with ppat_attributes}) - let get_jkind_of_legacy_attr attr = match (attr.attr_name.txt, attr.attr_payload) with | ("ocaml.immediate64" | "immediate64"), PStr [] -> @@ -275,17 +265,18 @@ module Let_binding = struct ; lb_pat: pattern xt ; lb_args: function_param list ; lb_typ: value_constraint option + ; lb_modes: modes ; lb_exp: expression xt ; lb_pun: bool ; lb_attrs: attribute list ; lb_local: bool - ; lb_modes: mode loc list + ; lb_modes_binding: modes ; 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, Some typ, []) + | Pexp_constraint (exp, Some typ, modes) 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 ; @@ -303,23 +294,31 @@ module Let_binding = struct in ( xargs , Some (Pvc_constraint {locally_abstract_univars= []; typ}) + , modes , 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, Some typ, []) when not (List.is_empty xargs) -> + | Pexp_constraint (exp, Some typ, modes) when not (List.is_empty xargs) + -> Cmts.relocate cmts ~src:body.pexp_loc ~before:exp.pexp_loc ~after:exp.pexp_loc ; ( xargs , Some (Pvc_constraint {locally_abstract_univars= []; typ}) + , modes , sub_exp ~ctx exp ) + | Pexp_constraint (exp, None, modes) when not (List.is_empty xargs) -> + Cmts.relocate cmts ~src:body.pexp_loc ~before:exp.pexp_loc + ~after:exp.pexp_loc ; + (xargs, None, modes, sub_exp ~ctx exp) | Pexp_coerce (exp, typ1, typ2) when Source.type_constraint_is_first typ2 exp.pexp_loc -> Cmts.relocate cmts ~src:body.pexp_loc ~before:exp.pexp_loc ~after:exp.pexp_loc ; ( xargs , Some (Pvc_coercion {ground= typ1; coercion= typ2}) + , [] , sub_exp ~ctx exp ) - | _ -> (xargs, None, xbody) + | _ -> (xargs, None, [], xbody) let split_fun_args cmts xpat xbody = let xargs, xbody = @@ -329,150 +328,21 @@ module Let_binding = struct | _ -> ([], xbody) in match (xbody.ast.pexp_desc, xpat.ast.ppat_desc) with - | Pexp_constraint _, Ppat_constraint _ -> (xargs, None, xbody) + | Pexp_constraint _, Ppat_constraint _ -> (xargs, None, [], xbody) | _ -> split_annot cmts xargs xbody - (** Conservatively decides when to use the [let local_ ...] sugar. - - Putting [local_] on the left-hand-side of a simple variable binding - is sugar for putting it on the right-hand-side. - - {[ - let x = local_ expression (* parses the exact same as *) - let local_ x = expression - ]} - - We have to be careful about trying to sugar something that isn't - already sugared, though. - - {[ - let (x, y) = local_ expression (* parses while *) - let local_ (x, y) = expression (* does not *) - - let local_ f x = expression (* parses the same as *) - let f = local_ fun x -> expression (* and not as *) - let f x = local_ expression - ]} - - Ocamlformat checks that the formatting output does not change - the parsed ast, which catches and fails on these cases. - It also, however, fails even on changes to the ast that don't - have any semantic difference. - - {[ - let x : string = local_ expression (* means the same thing as *) - let local_ x : string = expression (* but parses differently *) - ]} - - Currently, if there is any type annotation or coercion on the let - binding, then sugaring the [local_] will create a different - parsetree, so we just avoid sugaring in these cases. - *) - let local_pattern_can_be_sugared pvb_pat pvb_constraint exp_loc cmts = - (* If the original code was sugared, preserve that always. *) - let _, already_sugared = - check_local_attr_and_reloc_cmts cmts pvb_pat.ppat_attributes - pvb_pat.ppat_loc - in - (* Don't wipe away comments before [local_]. *) - let comment_before = Cmts.has_before cmts exp_loc in - already_sugared - || (not comment_before) - && - match pvb_pat.ppat_desc with - | Ppat_var _ -> ( - match pvb_constraint with - | None -> - (* [ let x = local_ "hi" ] *) - true - | Some (Pvc_constraint _) -> - (* [ let x : string = local_ "hi" ] [ let x : 'a. string = - local_ "hi" ] *) - false - | Some (Pvc_coercion _) -> - (* [ let x : string :> string = local_ "hi" ] [ let x :> string - = local_ "hi" ] *) - false ) - | _ -> false - - 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 - ( { pexp_desc= Pexp_extension ({txt= extension_local; _}, PStr []) - ; _ } - , [(Nolabel, sbody)] ) - when Conf.is_jane_street_local_annotation "local" - ~test:extension_local -> - let is_local_pattern, sbody = - (* The pattern part must still be rewritten as the parser - duplicated the type annotations and extensions into the - pattern and the expression. *) - if - local_pattern_can_be_sugared pvb_pat pvb_constraint - pvb_expr.pexp_loc cmts - then - let sattrs, _ = - check_local_attr_and_reloc_cmts cmts sbody.pexp_attributes - sbody.pexp_loc - in - (true, {sbody with pexp_attributes= sattrs}) - else (false, pvb_expr) - in - let pattrs, _ = - check_local_attr_and_reloc_cmts cmts pvb_pat.ppat_attributes - pvb_pat.ppat_loc - in - let pat = {pvb_pat with ppat_attributes= pattrs} in - let fake_ctx = - let pvb = - { pvb_pat= pat - ; pvb_expr= sbody - ; pvb_is_pun - ; pvb_attributes= [] - ; pvb_loc= Location.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) - in + let type_cstr cmts ~ctx pvb_pat pvb_expr = let lb_pat = sub_pat ~ctx pvb_pat and lb_exp = sub_exp ~ctx pvb_expr in - (is_local_pattern, lb_pat, lb_exp) - - 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) = sub_pat ~ctx lb_pat.ast in let pat_is_extension {ppat_desc; _} = match ppat_desc with Ppat_extension _ -> true | _ -> false in let xbody = sub_exp ~ctx lb_exp.ast in - let pat, xargs, typ, exp = + let pat, xargs, typ, mode, exp = if (not (List.is_empty xbody.ast.pexp_attributes)) || pat_is_extension pat - then (xpat, [], None, xbody) + then (xpat, [], None, [], xbody) else let xpat = match xpat.ast.ppat_desc with @@ -481,10 +351,10 @@ module Let_binding = struct sub_pat ~ctx:xpat.ctx p | _ -> xpat in - let xargs, typ, xbody = split_fun_args cmts xpat xbody in - (xpat, xargs, typ, xbody) + let xargs, typ, mode, xbody = split_fun_args cmts xpat xbody in + (xpat, xargs, typ, mode, xbody) in - (is_local_pattern, pat, xargs, typ, exp) + (pat, xargs, typ, mode, exp) let should_desugar_args pat typ = match (pat.ast, typ) with @@ -498,25 +368,26 @@ module Let_binding = struct ; pvb_is_pun ; pvb_attributes ; pvb_loc - ; pvb_modes } = - let islocal, lb_pat, lb_exp = - maybe_sugar_local cmts ~ctx pvb_pat pvb_modes pvb_expr pvb_is_pun - pvb_constraint + ; pvb_modes + ; pvb_local } = + let lb_pat = sub_pat ~ctx pvb_pat + and lb_exp = sub_exp ~ctx pvb_expr and lb_typ = pvb_constraint in - let lb_args, lb_typ, lb_exp = + let (lb_args, lb_typ, lb_modes, lb_exp), lb_modes_binding = if should_desugar_args lb_pat lb_typ then - split_fun_args cmts lb_pat lb_exp - else ([], lb_typ, lb_exp) + (split_fun_args cmts lb_pat lb_exp, pvb_modes) + else (([], lb_typ, pvb_modes, lb_exp), []) in { lb_op= Location.{txt= (if first then "let" else "and"); loc= none} ; lb_pat ; lb_args ; lb_typ + ; lb_modes ; lb_exp ; lb_pun= pvb_is_pun ; lb_attrs= pvb_attributes - ; lb_local= islocal - ; lb_modes= pvb_modes + ; lb_local= pvb_local + ; lb_modes_binding ; lb_loc= pvb_loc } let of_let_bindings cmts ~ctx = @@ -524,17 +395,18 @@ module Let_binding = struct let of_binding_ops cmts ~ctx bos = List.map bos ~f:(fun bo -> - let islocal, lb_pat, lb_args, lb_typ, lb_exp = - type_cstr cmts ~ctx bo.pbop_pat bo.pbop_exp false None + let lb_pat, lb_args, lb_typ, lb_modes, lb_exp = + type_cstr cmts ~ctx bo.pbop_pat bo.pbop_exp in { lb_op= bo.pbop_op ; lb_pat ; lb_args ; lb_typ + ; lb_modes ; lb_exp ; lb_pun= bo.pbop_is_pun ; lb_attrs= [] - ; lb_local= islocal - ; lb_modes= [] + ; lb_local= false + ; lb_modes_binding= [] ; lb_loc= bo.pbop_loc } ) end diff --git a/lib/Sugar.mli b/lib/Sugar.mli index 61c9580e29..596f430a91 100644 --- a/lib/Sugar.mli +++ b/lib/Sugar.mli @@ -43,8 +43,6 @@ val cl_fun : and the body of the function [exp]. [will_keep_first_ast_node] is set by default, otherwise the [exp] is returned without modification. *) -val remove_local_attrs : Cmts.t -> function_param_desc -> function_param_desc - val rewrite_type_declaration_imm_attr_to_jkind_annot : Cmts.t -> type_declaration -> type_declaration (** Rewrites [@@immediate] to [_ : immediate] and do the same for [@@immediate64]. @@ -80,11 +78,13 @@ module Let_binding : sig ; lb_pat: pattern Ast.xt ; lb_args: function_param list ; lb_typ: value_constraint option + (** the type on the RHS of the binding *) + ; lb_modes: modes (** the modes on the RHS of the binding *) ; lb_exp: expression Ast.xt ; lb_pun: bool ; lb_attrs: attribute list - ; lb_local: bool - ; lb_modes: mode loc list + ; lb_local: bool (** the local_ on the bound value (not RHS) *) + ; lb_modes_binding: modes (** modes on the bound value (not RHS) *) ; lb_loc: Location.t } val of_let_binding : diff --git a/test/passing/dune.inc b/test/passing/dune.inc index 1a0081c5d2..5c112bf20c 100644 --- a/test/passing/dune.inc +++ b/test/passing/dune.inc @@ -2753,7 +2753,7 @@ (action (with-stdout-to default_modalities.ml.stdout (with-stderr-to default_modalities.ml.stderr - (run %{bin:ocamlformat} --margin-check --max-iters=3 %{dep:tests/default_modalities.ml}))))) + (run %{bin:ocamlformat} --margin-check --max-iters=5 %{dep:tests/default_modalities.ml}))))) (rule (alias runtest) @@ -8931,7 +8931,7 @@ (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}))))) + (run %{bin:ocamlformat} --margin-check --ocaml-version=4.14.0 --max-iter=5 %{dep:tests/modes.ml}))))) (rule (alias runtest) @@ -8949,7 +8949,7 @@ (action (with-stdout-to modes.ml.stdout (with-stderr-to modes.ml.stderr - (run %{bin:ocamlformat} --margin-check %{dep:tests/modes.ml}))))) + (run %{bin:ocamlformat} --margin-check --max-iters=5 %{dep:tests/modes.ml}))))) (rule (alias runtest) diff --git a/test/passing/tests/default_modalities.ml.opts b/test/passing/tests/default_modalities.ml.opts index d4626ceab5..559617f4de 100644 --- a/test/passing/tests/default_modalities.ml.opts +++ b/test/passing/tests/default_modalities.ml.opts @@ -1 +1 @@ ---max-iters=3 +--max-iters=5 diff --git a/test/passing/tests/function_constraint.ml b/test/passing/tests/function_constraint.ml index 86b6e34f99..c7ec27cc39 100644 --- a/test/passing/tests/function_constraint.ml +++ b/test/passing/tests/function_constraint.ml @@ -15,21 +15,21 @@ let (* 1 *) f (* 2 *) x (* 3 *) y (* 4 *) = let[@a1] f (x[@a2]) (y[@a3]) = (()[@a4] : unit[@a5]) (* RHS annotated with a type and mode *) -let f (type a) = (() : unit @@ local) +let f (type a) = (() : unit @ local) let (* 1 *) f (* 2 *) ((* 3 *) type (* 4 *) a (* 5 *)) (* 6 *) = (* 7 *) - (* 8 *) ( (* 9 *) () : (* 10 *) unit (* 11 *) @@ (* 12 *) local (* 13 *) ) -let[@a1] f (type a) = (()[@a2] : unit [@a3] @@ local) + (* 8 *) ( (* 9 *) () : (* 10 *) unit (* 11 *) @ (* 12 *) local (* 13 *) ) +let[@a1] f (type a) = (()[@a2] : (unit [@a3]) @ local) -let f (type a : value) = (() : unit @@ local) +let f (type a : value) = (() : unit @ local) let (* 1 *) f (* 2 *) ((* 3 *) type (* 4 *) a (* 5 *) : (* 6 *) value (* 7 *)) (* 8 *) = - (* 9 *) ((* 10 *) () (* 11 *) : (* 12 *) unit (* 13 *) @@ (* 14 *) local (* 15 *)) + (* 9 *) ((* 10 *) () (* 11 *) : (* 12 *) unit (* 13 *) @ (* 14 *) local (* 15 *)) (* 16 *) -let[@a1] f (type a : value) = (()[@a2] : unit[@a3] @@ local) +let[@a1] f (type a : value) = (()[@a2] : (unit[@a3]) @ local) -let f x y = (() : unit @@ local) +let f x y = (() : unit @ local) let (* 1 *) f (* 2 *) x (* 3 *) y (* 4 *) = (* 5 *) - ((* 6 *) () (* 7 *) : (* 8 *) unit (* 9 *) @@ (* 10 *) local (* 11 *)) (* 12 *) -let[@a1] f (x[@a2]) (y[@a3]) = (()[@a4] : unit[@a5] @@ local) + ((* 6 *) () (* 7 *) : (* 8 *) unit (* 9 *) @ (* 10 *) local (* 11 *)) (* 12 *) +let[@a1] f (x[@a2]) (y[@a3]) = (()[@a4] : (unit[@a5]) @ local) (* LHS and RHS annotated with the same type *) let f (type a) : unit = (() : unit) diff --git a/test/passing/tests/function_constraint.ml.err b/test/passing/tests/function_constraint.ml.err index 2f088ac897..9bce3f1cbe 100644 --- a/test/passing/tests/function_constraint.ml.err +++ b/test/passing/tests/function_constraint.ml.err @@ -1,4 +1,4 @@ -Warning: tests/function_constraint.ml:307 exceeds the margin -Warning: tests/function_constraint.ml:309 exceeds the margin -Warning: tests/function_constraint.ml:310 exceeds the margin -Warning: tests/function_constraint.ml:314 exceeds the margin +Warning: tests/function_constraint.ml:313 exceeds the margin +Warning: tests/function_constraint.ml:315 exceeds the margin +Warning: tests/function_constraint.ml:316 exceeds the margin +Warning: tests/function_constraint.ml:320 exceeds the margin diff --git a/test/passing/tests/function_constraint.ml.js-ref b/test/passing/tests/function_constraint.ml.js-ref index 39f733495a..6be345bf15 100644 --- a/test/passing/tests/function_constraint.ml.js-ref +++ b/test/passing/tests/function_constraint.ml.js-ref @@ -46,47 +46,58 @@ let (* 1 *) f (* 2 *) x (* 3 *) y : (* 8 *) unit (* 9 *) = let[@a1] f (x [@a2]) (y [@a3]) : (unit[@a5]) = () [@a4] (* RHS annotated with a type and mode *) -let f (type a) = (() : unit @@ local) +let f (type a) : unit @ local = () let (* 1 *) f (type (* 3 *) (* 4 *) a (* 5 *)) + : (* 10 *) unit (* 11 *) @ (* 12 *) local (* 13 *) = (* 2 *) (* 6 *) (* 7 *) (* 8 *) - ((* 9 *) () : (* 10 *) unit (* 11 *) @@ (* 12 *) local (* 13 *)) + (* 9 *) + () ;; -let[@a1] f (type a) = (() [@a2] : (unit[@a3]) @@ local) -let f (type a : value) = (() : unit @@ local) +let[@a1] f (type a) : (unit[@a3]) @ local = () [@a2] +let f (type a : value) : unit @ local = () let (* 1 *) f (type (* 3 *) (* 4 *) a (* 5 *) : (* 6 *) value (* 7 *)) + : (* 12 *) unit (* 13 *) @ (* 14 *) local (* 15 *) = (* 2 *) (* 8 *) (* 9 *) - ((* 10 *) () (* 11 *) : (* 12 *) unit (* 13 *) @@ (* 14 *) local (* 15 *)) + (* 10 *) + () ;; +(* 11 *) + (* 16 *) -let[@a1] f (type a : value) = (() [@a2] : (unit[@a3]) @@ local) -let f x y = (() : unit @@ local) +let[@a1] f (type a : value) : (unit[@a3]) @ local = () [@a2] +let f x y : unit @ local = () + +let (* 1 *) f (* 2 *) x (* 3 *) y : (* 8 *) unit (* 9 *) @ (* 10 *) local (* 11 *) = + (* 4 *) -let (* 1 *) f (* 2 *) x (* 3 *) y (* 4 *) = (* 5 *) - ((* 6 *) () (* 7 *) : (* 8 *) unit (* 9 *) @@ (* 10 *) local (* 11 *)) + (* 6 *) + () ;; +(* 7 *) + (* 12 *) -let[@a1] f (x [@a2]) (y [@a3]) = (() [@a4] : (unit[@a5]) @@ local) +let[@a1] f (x [@a2]) (y [@a3]) : (unit[@a5]) @ local = () [@a4] (* LHS and RHS annotated with the same type *) let f (type a) : unit = (() : unit) diff --git a/test/passing/tests/function_constraint.ml.ref b/test/passing/tests/function_constraint.ml.ref index fb96634b6d..0d6aa231e9 100644 --- a/test/passing/tests/function_constraint.ml.ref +++ b/test/passing/tests/function_constraint.ml.ref @@ -40,42 +40,51 @@ let (* 1 *) f (* 2 *) x (* 3 *) y : (* 8 *) unit (* 9 *) = let[@a1] f (x [@a2]) (y [@a3]) : (unit[@a5]) = () [@a4] (* RHS annotated with a type and mode *) -let f (type a) = (() : unit @@ local) +let f (type a) : unit @ local = () let (* 1 *) f (type (* 3 *) (* 4 *) - a (* 5 *) ) = + a (* 5 *) ) : (* 10 *) unit (* 11 *) @ (* 12 *) local (* 13 *) = (* 2 *) (* 6 *) (* 7 *) (* 8 *) - ((* 9 *) () : (* 10 *) unit (* 11 *) @@ (* 12 *) local (* 13 *)) + (* 9 *) + () -let[@a1] f (type a) = (() [@a2] : (unit[@a3]) @@ local) +let[@a1] f (type a) : (unit[@a3]) @ local = () [@a2] -let f (type a : value) = (() : unit @@ local) +let f (type a : value) : unit @ local = () let (* 1 *) f (type (* 3 *) (* 4 *) - a (* 5 *) : (* 6 *) value (* 7 *) ) = + a (* 5 *) : (* 6 *) value (* 7 *) ) : (* 12 *) unit (* 13 *) + @ (* 14 *) local (* 15 *) = (* 2 *) (* 8 *) (* 9 *) - ((* 10 *) () (* 11 *) : (* 12 *) unit (* 13 *) @@ (* 14 *) local (* 15 *)) + (* 10 *) + () +(* 11 *) (* 16 *) -let[@a1] f (type a : value) = (() [@a2] : (unit[@a3]) @@ local) +let[@a1] f (type a : value) : (unit[@a3]) @ local = () [@a2] -let f x y = (() : unit @@ local) +let f x y : unit @ local = () + +let (* 1 *) f (* 2 *) x (* 3 *) y : (* 8 *) unit (* 9 *) + @ (* 10 *) local (* 11 *) = + (* 4 *) -let (* 1 *) f (* 2 *) x (* 3 *) y (* 4 *) = (* 5 *) - ((* 6 *) () (* 7 *) : (* 8 *) unit (* 9 *) @@ (* 10 *) local (* 11 *)) + (* 6 *) + () +(* 7 *) (* 12 *) -let[@a1] f (x [@a2]) (y [@a3]) = (() [@a4] : (unit[@a5]) @@ local) +let[@a1] f (x [@a2]) (y [@a3]) : (unit[@a5]) @ local = () [@a4] (* LHS and RHS annotated with the same type *) let f (type a) : unit = (() : unit) @@ -160,9 +169,8 @@ let[@a1] f (x [@a2]) (y [@a3]) : (unit[@a4]) = (() [@a5] : (int[@a6])) (* LHS annotated with a mode, RHS annotated with a type *) let (f @ local) (type a) : unit = () -let - ((* 1 *) - (* 2 *) f (* 3 *) @ (* 4 *) local (* 5 *)) +let ((* 1 *) + (* 2 *) f (* 3 *) @ (* 4 *) local (* 5 *) ) (type (* 7 *) (* 8 *) a (* 9 *) ) : (* 14 *) unit (* 15 *) = @@ -178,9 +186,8 @@ let[@a1] (f @ local) (type a) : (unit[@a3]) = () [@a2] let (f @ local) (type a : value) : unit = () -let - ((* 1 *) - (* 2 *) f (* 3 *) @ (* 4 *) local (* 5 *)) +let ((* 1 *) + (* 2 *) f (* 3 *) @ (* 4 *) local (* 5 *) ) (type (* 7 *) (* 8 *) a (* 9 *) : (* 10 *) value (* 11 *) ) : (* 16 *) unit (* 17 *) = @@ -196,9 +203,8 @@ let[@a1] (f @ local) (type a : value) : (unit[@a3]) = () [@a2] let (f @ local) x y : unit = () -let - ((* 1 *) - (* 2 *) f (* 3 *) @ (* 4 *) local (* 5 *)) (* 6 *) x (* 7 *) y : +let ((* 1 *) + (* 2 *) f (* 3 *) @ (* 4 *) local (* 5 *) ) (* 6 *) x (* 7 *) y : (* 12 *) unit (* 13 *) = (* 8 *) diff --git a/test/passing/tests/generative.ml.js-ref b/test/passing/tests/generative.ml.js-ref index 714c01bb78..166248c658 100644 --- a/test/passing/tests/generative.ml.js-ref +++ b/test/passing/tests/generative.ml.js-ref @@ -3,7 +3,7 @@ module M = Generative () module M = String_id (M) () module F2 : functor () -> sig end = F1 module F2 : functor () () -> sig end = F1 -module F2 : (*xx*) ( (*yy*) ) (*zz*) -> sig end = F1 -module F2 : () -> functor [@attr] () () -> sig end = F1 -module F2 : () -> functor () () () -> sig end = F1 -module F2 : () -> () -> () -> functor () () () -> sig end = F1 +module F2 : (*xx*) functor ( (*yy*) ) (*zz*) -> sig end = F1 +module F2 : functor () -> functor [@attr] () () -> sig end = F1 +module F2 : functor () () () () -> sig end = F1 +module F2 : functor () () () () () () -> sig end = F1 diff --git a/test/passing/tests/generative.ml.ref b/test/passing/tests/generative.ml.ref index a0701006cd..bd22c02221 100644 --- a/test/passing/tests/generative.ml.ref +++ b/test/passing/tests/generative.ml.ref @@ -7,10 +7,10 @@ module F2 : functor () -> sig end = F1 module F2 : functor () () -> sig end = F1 -module F2 : (*xx*) ( (*yy*) ) (*zz*) -> sig end = F1 +module F2 : (*xx*) functor ( (*yy*) ) (*zz*) -> sig end = F1 -module F2 : () -> functor [@attr] () () -> sig end = F1 +module F2 : functor () -> functor [@attr] () () -> sig end = F1 -module F2 : () -> functor () () () -> sig end = F1 +module F2 : functor () () () () -> sig end = F1 -module F2 : () -> () -> () -> functor () () () -> sig end = F1 +module F2 : functor () () () () () () -> sig end = F1 diff --git a/test/passing/tests/label_option_default_args.ml.js-ref b/test/passing/tests/label_option_default_args.ml.js-ref index 4316d6d6b8..84cce2a20f 100644 --- a/test/passing/tests/label_option_default_args.ml.js-ref +++ b/test/passing/tests/label_option_default_args.ml.js-ref @@ -56,7 +56,10 @@ let (* 0 *) f ?l: ((* 2 *) (* 3 *) - x (* 4 *) : (* 5 *) t (* 6 *) = (* 7 *) d (* 8 *)) + x + (* 4 *) : + (* 5 *) t (* 6 *) = + (* 7 *) d (* 8 *)) (* 9 *) = e diff --git a/test/passing/tests/label_option_default_args.ml.ref b/test/passing/tests/label_option_default_args.ml.ref index b52ea12563..dff4c77b4c 100644 --- a/test/passing/tests/label_option_default_args.ml.ref +++ b/test/passing/tests/label_option_default_args.ml.ref @@ -74,7 +74,10 @@ let (* 0 *) f (* 1 *) ?l: ((* 2 *) (* 3 *) - x (* 4 *) : (* 5 *) t (* 6 *) = (* 7 *) d (* 8 *)) (* 9 *) = + x + (* 4 *) : + (* 5 *) t (* 6 *) = + (* 7 *) d (* 8 *)) (* 9 *) = e let f ?l:(C x = d) = e diff --git a/test/passing/tests/local.ml.js-ref b/test/passing/tests/local.ml.js-ref index 2e7edbe1e2..230a2ddd84 100644 --- a/test/passing/tests/local.ml.js-ref +++ b/test/passing/tests/local.ml.js-ref @@ -46,7 +46,7 @@ let () = exclave_ r let local_ x : string = "hi" let (x : string) = local_ "hi" let (x : string) = exclave_ "hi" -let local_ x = ("hi" : string) +let x = local_ ("hi" : string) let x = exclave_ ("hi" : string) let x : 'a. 'a -> 'a = local_ "hi" let x : 'a. 'a -> 'a = exclave_ "hi" diff --git a/test/passing/tests/local.ml.ref b/test/passing/tests/local.ml.ref index 573cb2ed44..5e9681f805 100644 --- a/test/passing/tests/local.ml.ref +++ b/test/passing/tests/local.ml.ref @@ -56,7 +56,7 @@ let (x : string) = local_ "hi" let (x : string) = exclave_ "hi" -let local_ x = ("hi" : string) +let x = local_ ("hi" : string) let x = exclave_ ("hi" : string) diff --git a/test/passing/tests/local_erased.ml.js-ref b/test/passing/tests/local_erased.ml.js-ref index c02956337d..7a59a181f9 100644 --- a/test/passing/tests/local_erased.ml.js-ref +++ b/test/passing/tests/local_erased.ml.js-ref @@ -51,7 +51,7 @@ let () = exclave_ r let local_ x : string = "hi" let (x : string) = local_ "hi" let (x : string) = exclave_ "hi" -let local_ x = ("hi" : string) +let x = local_ ("hi" : string) let x = exclave_ ("hi" : string) let x : 'a. 'a -> 'a = local_ "hi" let x : 'a. 'a -> 'a = exclave_ "hi" diff --git a/test/passing/tests/modes-erased.ml.js-ref b/test/passing/tests/modes-erased.ml.js-ref index 97bfa3cb8c..68c864f1ec 100644 --- a/test/passing/tests/modes-erased.ml.js-ref +++ b/test/passing/tests/modes-erased.ml.js-ref @@ -12,31 +12,32 @@ 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 : typ @ mode1 mode2 = y + let x : typ1 typ2 @ mode1 mode2 = y + let x : (typ1 -> typ2) @ mode1 mode2 = y + let x : (typ1 @ mode1 -> typ2 @ mode2) @ mode3 mode4 = y + let x : (typ1 * typ2) @ mode1 mode2 = y let x @ mode = x and y @ mode = y - and z : typ @@ mode = z + and z : typ @ mode = z let () = let x @ mode = y in - let x : typ @@ mode = y in + let x : typ @ mode = y in let x @ mode = x and y @ mode = y - and z : typ @@ mode = z in + 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 : typ @ mode = y in let%ext x @ mode = x and y @ mode = y - and z : typ @@ mode = z in + and z : typ @ mode = z in () ;; @@ -47,182 +48,190 @@ module Let_bindings = struct 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) + 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)) + (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) + | x -> (x : _ @ mode) + | y -> (y : _ @ mode)) + ; fun1 = (fun ?(x = (x : _ @ mode)) () @ mode -> (y : _ @ mode)) + ; fun2 = (fun ?(x = (x : _ @ mode)) () @ mode1 -> (y : _ @ mode2)) + ; fun3 = (fun ?(x = (x : _ @ mode)) () @ mode1 -> (y : t @ mode2)) + ; fun4 = (fun ?(x = (x : _ @ mode)) () -> (y : _ @ mode)) + ; fun5 = (fun ?(x = (x : _ @ mode)) () -> (y : t @ 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)) + (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)) + (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)) + ((x : _ @ mode); + (y : _ @ mode)) ; while1 = - while (x : _ @@ mode) do - (y : _ @@ mode) + while (x : _ @ mode) do + (y : _ @ mode) done ; for1 = - for i = (x : _ @@ mode) to (y : _ @@ mode) do - (z : _ @@ mode) + 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 = {} + ; constraint1 = ((x : _ @ mode) : _ @ mode) + ; coerce1 = ((x : _ @ mode) :> _) + ; send1 = (x : _ @ mode)#y + ; setinstvar1 = x <- (x : _ @ mode) + ; override1 = {} ; letmodule1 = (let module M = ME in - (x : _ @@ mode)) + (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)) + (x : _ @ mode)) + ; assert1 = assert (x : _ @ mode) + ; lazy1 = lazy (x : _ @ mode) + ; newtype1 = (fun (type t) @ mode -> (x : _ @ mode)) + ; open1 = M.((x : _ @ mode)) ; letopen1 = (let open M in - (x : _ @@ mode)) + (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) + (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) + { ident1 = (x : _ @ mode) + ; constant1 = ("" : _ @ mode) ; let1 = (let x = y in z : _ - @@ mode) + @ mode) ; function1 = (function | x -> x | y -> y : _ - @@ mode) - ; fun1 = (fun x -> y : _ @@ mode) - ; apply1 = (f x : _ @@ mode) + @ mode) + ; fun1 = (fun x @ mode -> y : _ @ mode) + ; fun2 = (fun x @ mode1 -> y : _ @ mode2) + ; fun3 = (fun x @ mode1 -> y : t @ mode2) + ; fun4 = (fun x -> y : _ @ mode) + ; fun5 = (fun x -> y : t @ mode) + ; apply1 = (f x : _ @ mode) ; match1 = ((match x with | y -> y | z -> z) : _ - @@ mode) + @ 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) + @ 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) + @ mode) ; while1 = while x do y done - @@ mode + @ 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) + @ 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) + @ 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) + @ mode) + ; assert1 = (assert x : _ @ mode) + ; lazy1 = (lazy x : _ @ mode) + ; object1 = (object end : _ @ mode) + ; newtype1 = (fun (type t) @ mode -> x : _ @ mode) + ; pack1 = ((module M) : _ @ mode) + ; pack2 = ((module M : S) : _ @ mode) + ; open1 = (M.(x y) : _ @ mode) ; letopen1 = (let open M in x : _ - @@ mode) + @ 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) + @ mode) + ; extension1 = ([%ext] : _ @ mode) + ; hole1 = (_ : _ @ mode) + ; cons1 = (x :: y :: z : _ @ mode) + ; prefix1 = (!x : _ @ mode) + ; infix1 = (x + y : _ @ mode) } ;; end @@ -231,8 +240,8 @@ 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) + let x : (lhs @ mode1 -> rhs @ mode2) @ mode3 = y + let x = (expr : (lhs @ mode1 -> rhs @ mode2) @ mode3) end module Modalities_on_record_fields = struct @@ -266,34 +275,49 @@ module type Value_descriptions = sig 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) arg1 arg2 @ mode1 = x + let (f @ mode) arg1 arg2 : typ @ mode1 = x + let (f @ mode1 mode2) arg1 arg2 @ mode1 = x let (f @ mode) (arg @ mode) - (arg : typ @@ mode) + (arg : typ @ mode) ~lbl:(arg @ mode) - ~lbl:(arg : typ @@ mode) + ~lbl:(arg : typ @ mode) ~(arg @ mode) - ~(arg : typ @@ mode) + ~(arg : typ @ mode) ?lbl:(arg @ mode) - ?lbl:(arg : typ @@ mode) + ?lbl:(arg : typ @ mode) ?lbl:(arg @ mode = value) - ?lbl:(arg : typ @@ mode = value) + ?lbl:(arg : typ @ mode = value) ?(arg @ mode) - ?(arg : typ @@ mode) + ?(arg : typ @ mode) ?(arg @ mode = value) - ?(arg : typ @@ mode = value) - : typ + ?(arg : typ @ mode = value) + : typ @ mode1 = value ;; end +module LATs = struct + let f : 'a. (b -> c) @ mode = fun x -> y + let f : ('a : k). (b -> c) @ mode = fun x -> y + let f : 'a. (b @ mode1 -> c @ mode2) @ mode3 = fun x -> y + let f : ('a : k). (b @ mode1 -> c @ mode2) @ mode3 = fun x -> y + + let (* aaa *) f (* bbb *) + : (* ccc *) ('a (* ddd *) : (* eee *) k). + ((* fff *) b (* ggg *) @ (* hhh *) mode1 (* iii *) + -> (* jjj *) c (* kkk *) @ (* lll *) mode2) (* mmm *) @ (* nnn *) mode3 (* ooo *) + = + (* ppp *) fun (* qqq *) x -> y + ;; +end + module No_illegal_sugaring = struct - let y = { x = (x : t @@ mode) } - let y = { x :> t = (x : t @@ mode) } + let y = { x = (x : t @ mode) } + let y = { x :> t = (x : t @ mode) } end module Line_breaking = struct @@ -305,14 +329,14 @@ module Line_breaking = struct ;; let long_value_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - : t @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + : 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 + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 = 1 ;; @@ -322,13 +346,13 @@ module Line_breaking = struct let x = (long_expr_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : t - @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) ;; let x = (long_expr_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) ;; end @@ -374,27 +398,27 @@ module Line_breaking = struct 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) + : (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) + : (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 @@ -461,10 +485,10 @@ module Line_breaking = struct @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) (long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : t - @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) (long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) @ mode1 mode2 mode3 = a ;; @@ -475,14 +499,14 @@ module Interaction_with_existing_syntax = struct (* let bindings *) let local_ x @ mode1 mode2 = y - let local_ x : typ1 typ2 @@ 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) + let x : (local_ lhs @ mode1 -> local_ rhs @ mode2) @ mode3 = y + let x = (expr : (local_ lhs @ mode1 -> local_ rhs @ mode2) @ mode3) (* modalities on record fields *) diff --git a/test/passing/tests/modes-erased.ml.ref b/test/passing/tests/modes-erased.ml.ref index 5b5328aeaa..d985f9fc60 100644 --- a/test/passing/tests/modes-erased.ml.ref +++ b/test/passing/tests/modes-erased.ml.ref @@ -21,6 +21,8 @@ module Let_bindings = struct let x : typ1 -> typ2 = y + let x : typ1 -> typ2 = y + let x : typ1 * typ2 = y let x = x @@ -67,6 +69,10 @@ module Expressions = struct (z : _) ) ; function1= (function x -> (x : _) | y -> (y : _)) ; fun1= (fun ?(x = (x : _)) () : _ -> y) + ; fun2= (fun ?(x = (x : _)) () : _ -> y) + ; fun3= (fun ?(x = (x : _)) () : t -> y) + ; fun4= (fun ?(x = (x : _)) () : _ -> y) + ; fun5= (fun ?(x = (x : _)) () : t -> y) ; apply1= (x : _) (y : _) ; apply2= f ~lbl:(x : _) ; apply3= f ~x:(x : _) @@ -133,6 +139,10 @@ module Expressions = struct : _ ) ; function1= (function x -> x | y -> y : _) ; fun1= (fun x -> y : _) + ; fun2= (fun x -> y : _) + ; fun3= (fun x -> y : t) + ; fun4= (fun x -> y : _) + ; fun5= (fun x -> y : t) ; apply1= (f x : _) ; match1= (match x with y -> y | z -> z : _) ; try1= (try x with y -> y | z -> z : _) @@ -156,12 +166,12 @@ module Expressions = struct while x do y done - @@ mode + @ mode ; for1= for x = y to z do a done - @@ mode + @ mode ; constraint1= ((x : _) : _) ; coerce1= ((x :> _) : _) ; send1= (x#y : _) @@ -251,6 +261,35 @@ module Let_bound_functions = struct value end +module LATs = struct + let f : 'a. b -> c = fun x -> y + + let f : 'a. b -> c = fun x -> y + + let f : 'a. b -> c = fun x -> y + + let f : 'a. b -> c = fun x -> y + + let (* aaa *) f (* bbb *) : + (* ccc *) + 'a (* ddd *). + (* eee *) + (* fff *) + b + (* ggg *) + -> (* hhh *) + (* iii *) + (* jjj *) + c + (* kkk *) + (* lll *) + (* mmm *) = + (* nnn *) + (* ooo *) + (* ppp *) + fun (* qqq *) x -> y +end + module No_illegal_sugaring = struct let y = {x: t} diff --git a/test/passing/tests/modes-ocaml_version.ml.opts b/test/passing/tests/modes-ocaml_version.ml.opts index 0bc303a746..3f9bf63fad 100644 --- a/test/passing/tests/modes-ocaml_version.ml.opts +++ b/test/passing/tests/modes-ocaml_version.ml.opts @@ -1 +1,2 @@ --ocaml-version=4.14.0 +--max-iter=5 diff --git a/test/passing/tests/modes-ocaml_version.ml.ref b/test/passing/tests/modes-ocaml_version.ml.ref index 9a6d57c42b..0e37e2e59d 100644 --- a/test/passing/tests/modes-ocaml_version.ml.ref +++ b/test/passing/tests/modes-ocaml_version.ml.ref @@ -15,31 +15,33 @@ module Let_bindings = struct let x @ mode1 mode2 = y - let x : typ @@ 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 : (typ1 -> typ2) @ mode1 mode2 = y - let x : typ1 * typ2 @@ mode1 mode2 = y + let x : (typ1 @ mode1 -> typ2 @ mode2) @ mode3 mode4 = y + + let x : (typ1 * typ2) @ mode1 mode2 = y let x @ mode = x and y @ mode = y - and z : typ @@ mode = z + 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 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 + let%ext x : typ @ mode = y in + let%ext x @ mode = x and y @ mode = y and z : typ @ mode = z in () external x : typ @@ mode1 mode2 = "" @@ -52,158 +54,166 @@ module Let_bindings = struct end module Expressions = struct - let x = (expr : typ @@ mode1 mode2) + 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) + 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) + (let x = (x : _ @ mode) and y = (y : _ @ mode) in + (z : _ @ mode) ) + ; function1= (function x -> (x : _ @ mode) | y -> (y : _ @ mode)) + ; fun1= (fun ?(x = (x : _ @ mode)) () @ mode -> (y : _ @ mode)) + ; fun2= (fun ?(x = (x : _ @ mode)) () @ mode1 -> (y : _ @ mode2)) + ; fun3= (fun ?(x = (x : _ @ mode)) () @ mode1 -> (y : t @ mode2)) + ; fun4= (fun ?(x = (x : _ @ mode)) () -> (y : _ @ mode)) + ; fun5= (fun ?(x = (x : _ @ mode)) () -> (y : t @ 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)) + ( 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) ) + ( (x : _ @ mode) ; + (y : _ @ mode) ) ; while1= - while (x : _ @@ mode) do - (y : _ @@ mode) + while (x : _ @ mode) do + (y : _ @ mode) done ; for1= - for i = (x : _ @@ mode) to (y : _ @@ mode) do - (z : _ @@ mode) + 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= {} + ; constraint1= ((x : _ @ mode) : _ @ mode) + ; coerce1= ((x : _ @ mode) :> _) + ; send1= (x : _ @ mode)#y + ; setinstvar1= x <- (x : _ @ mode) + ; override1= {} ; letmodule1= (let module M = ME in - (x : _ @@ mode) ) + (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)) + (x : _ @ mode) ) + ; assert1= assert (x : _ @ mode) + ; lazy1= lazy (x : _ @ mode) + ; newtype1= (fun (type t) @ mode -> (x : _ @ mode)) + ; open1= M.((x : _ @ mode)) ; letopen1= (let open M in - (x : _ @@ mode) ) + (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) } + (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) + { 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) + @ mode ) + ; function1= (function x -> x | y -> y : _ @ mode) + ; fun1= (fun x @ mode -> y : _ @ mode) + ; fun2= (fun x @ mode1 -> y : _ @ mode2) + ; fun3= (fun x @ mode1 -> y : t @ mode2) + ; fun4= (fun x -> y : _ @ mode) + ; fun5= (fun x -> y : t @ 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 + @ 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) + @ 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 ) + @ 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) + @ mode ) + ; assert1= (assert x : _ @ mode) + ; lazy1= (lazy x : _ @ mode) + ; object1= (object end : _ @ mode) + ; newtype1= (fun (type t) @ mode -> x : _ @ mode) + ; pack1= ((module M) : _ @ mode) + ; pack2= ((module M : S) : _ @ mode) + ; open1= (M.(x y) : _ @ mode) ; letopen1= ( let open M in x : _ - @@ mode ) + @ 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) } + @ mode ) + ; extension1= ([%ext] : _ @ mode) + ; hole1= (_ : _ @ mode) + ; cons1= (x :: y :: z : _ @ mode) + ; prefix1= (!x : _ @ mode) + ; infix1= (x + y : _ @ mode) } end module Arrow_params = struct @@ -212,9 +222,9 @@ module Arrow_params = struct type t = arg1 @ mode1 -> lbl:arg2 @ mode2 -> ?lbl:arg3 @ mode3 -> res @ mode4 - let x : lhs @ mode1 -> rhs @ mode2 @@ mode3 = y + let x : (lhs @ mode1 -> rhs @ mode2) @ mode3 = y - let x = (expr : lhs @ mode1 -> rhs @ mode2 @@ mode3) + let x = (expr : (lhs @ mode1 -> rhs @ mode2) @ mode3) end module Modalities_on_record_fields = struct @@ -250,24 +260,42 @@ module type Value_descriptions = sig end module Let_bound_functions = struct - let (f @ mode) arg1 arg2 = x + let (f @ mode) arg1 arg2 @ mode1 = x - let (f @ mode) arg1 arg2 : typ = x + let (f @ mode) arg1 arg2 : typ @ mode1 = x - let (f @ mode1 mode2) arg1 arg2 = x + let (f @ mode1 mode2) arg1 arg2 @ mode1 = 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 = + 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 @ mode1 = value end +module LATs = struct + let f : 'a. (b -> c) @ mode = fun x -> y + + let f : ('a : k). (b -> c) @ mode = fun x -> y + + let f : 'a. (b @ mode1 -> c @ mode2) @ mode3 = fun x -> y + + let f : ('a : k). (b @ mode1 -> c @ mode2) @ mode3 = fun x -> y + + let (* aaa *) f (* bbb *) : + (* ccc *) + ('a (* ddd *) : (* eee *) k). + ((* fff *) b (* ggg *) @ (* hhh *) mode1 (* iii *) + -> (* jjj *) c (* kkk *) @ (* lll *) mode2) (* mmm *) + @ (* nnn *) mode3 (* ooo *) = + (* ppp *) fun (* qqq *) x -> y +end + module No_illegal_sugaring = struct - let y = {x= (x : t @@ mode)} + let y = {x= (x : t @ mode)} - let y = {x:> t = (x : t @@ mode)} + let y = {x:> t = (x : t @ mode)} end module Line_breaking = struct @@ -277,12 +305,12 @@ module Line_breaking = struct 1 let long_value_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : t - @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 = + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 = 1 let long_value_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 = + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 = 1 end @@ -290,12 +318,12 @@ module Line_breaking = struct let x = ( long_expr_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : t - @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 ) + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 ) let x = ( long_expr_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 ) + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 ) end module Arrow_params = struct @@ -341,26 +369,26 @@ module Line_breaking = struct 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 ) + : ( 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 ) + : ( 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 @@ -418,15 +446,16 @@ module Line_breaking = struct module Let_bound_functions = struct let (long_fun_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) + @ 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 ) + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 ) (long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 ) = + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 ) + @ mode1 mode2 mode3 = a end end @@ -436,15 +465,15 @@ module Interaction_with_existing_syntax = struct let local_ x @ mode1 mode2 = y - let local_ x : typ1 typ2 @@ 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 : (local_ lhs @ mode1 -> local_ rhs @ mode2) @ mode3 = y - let x = (expr : local_ lhs @ mode1 -> local_ rhs @ mode2 @@ mode3) + let x = (expr : (local_ lhs @ mode1 -> local_ rhs @ mode2) @ mode3) (* modalities on record fields *) diff --git a/test/passing/tests/modes.ml b/test/passing/tests/modes.ml index 97bfa3cb8c..070686c3af 100644 --- a/test/passing/tests/modes.ml +++ b/test/passing/tests/modes.ml @@ -12,217 +12,226 @@ 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 : typ @ mode1 mode2 = y + let x : typ1 typ2 @ mode1 mode2 = y + let x : (typ1 -> typ2) @ mode1 mode2 = y + let x : (typ1 @ mode1 -> typ2 @ mode2) @ mode3 mode4 = y + let x : typ1 * typ2 @ mode1 mode2 = y let x @ mode = x and y @ mode = y - and z : typ @@ mode = z + and z : typ @ mode = z let () = let x @ mode = y in - let x : typ @@ mode = y in + let x : typ @ mode = y in let x @ mode = x and y @ mode = y - and z : typ @@ mode = z in + 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 : typ @ mode = y in let%ext x @ mode = x and y @ mode = y - and z : typ @@ mode = z in + and z : typ @ mode = z in () ;; external x : typ @@ mode1 mode2 = "" external x : typ1 typ2 @@ mode1 mode2 = "" - external x : typ1 -> typ2 @@ mode1 mode2 = "" + external x : (typ1 -> typ2) @@ mode1 mode2 = "" external x : typ1 * typ2 @@ mode1 mode2 = "" 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) + 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)) + (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) + | x -> (x : _ @ mode) + | y -> (y : _ @ mode)) + ; fun1 = (fun ?(x = (x : _ @ mode)) () @ mode -> (y : _ @ mode)) + ; fun2 = (fun ?(x = (x : _ @ mode)) () @ mode1 -> (y : _ @ mode2)) + ; fun3 = (fun ?(x = (x : _ @ mode)) () @ mode1 -> (y : t @ mode2)) + ; fun4 = (fun ?(x = (x : _ @ mode)) () -> (y : _ @ mode)) + ; fun5 = (fun ?(x = (x : _ @ mode)) () -> (y : t @ 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)) + (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)) + (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)) + ((x : _ @ mode); + (y : _ @ mode)) ; while1 = - while (x : _ @@ mode) do - (y : _ @@ mode) + while (x : _ @ mode) do + (y : _ @ mode) done ; for1 = - for i = (x : _ @@ mode) to (y : _ @@ mode) do - (z : _ @@ mode) + 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 = {} + ; constraint1 = ((x : _ @ mode) : _ @ mode) + ; coerce1 = ((x : _ @ mode) :> _) + ; send1 = (x : _ @ mode)#y + ; setinstvar1 = x <- (x : _ @ mode) + ; override1 = {} ; letmodule1 = (let module M = ME in - (x : _ @@ mode)) + (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)) + (x : _ @ mode)) + ; assert1 = assert (x : _ @ mode) + ; lazy1 = lazy (x : _ @ mode) + ; newtype1 = (fun (type t) @ mode -> (x : _ @ mode)) + ; open1 = M.((x : _ @ mode)) ; letopen1 = (let open M in - (x : _ @@ mode)) + (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) + (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) + { ident1 = (x : _ @ mode) + ; constant1 = ("" : _ @ mode) ; let1 = (let x = y in z : _ - @@ mode) + @ mode) ; function1 = (function | x -> x | y -> y : _ - @@ mode) - ; fun1 = (fun x -> y : _ @@ mode) - ; apply1 = (f x : _ @@ mode) + @ mode) + ; fun1 = (fun x @ mode -> y : _ @ mode) + ; fun2 = (fun x @ mode1 -> y : _ @ mode2) + ; fun3 = (fun x @ mode1 -> y : t @ mode2) + ; fun4 = (fun x -> y : _ @ mode) + ; fun5 = (fun x -> y : t @ mode) + ; apply1 = (f x : _ @ mode) ; match1 = ((match x with | y -> y | z -> z) : _ - @@ mode) + @ 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) + @ 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) + @ mode) ; while1 = while x do y done - @@ mode + @ 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) + @ 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) + @ 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) + @ mode) + ; assert1 = (assert x : _ @ mode) + ; lazy1 = (lazy x : _ @ mode) + ; object1 = (object end : _ @ mode) + ; newtype1 = (fun (type t) @ mode -> x : _ @ mode) + ; pack1 = ((module M) : _ @ mode) + ; pack2 = ((module M : S) : _ @ mode) + ; open1 = (M.(x y) : _ @ mode) ; letopen1 = (let open M in x : _ - @@ mode) + @ 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) + @ mode) + ; extension1 = ([%ext] : _ @ mode) + ; hole1 = (_ : _ @ mode) + ; cons1 = (x :: y :: z : _ @ mode) + ; prefix1 = (!x : _ @ mode) + ; infix1 = (x + y : _ @ mode) } ;; end @@ -231,8 +240,8 @@ 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) + let x : (lhs @ mode1 -> rhs @ mode2) @ mode3 = y + let x = (expr : (lhs @ mode1 -> rhs @ mode2) @ mode3) end module Modalities_on_record_fields = struct @@ -261,39 +270,51 @@ module type Value_descriptions = sig val x : typ1 * typ2 @@ mode1 mode2 external x : typ @@ mode1 mode2 = "" external x : typ1 typ2 @@ mode1 mode2 = "" - external x : typ1 -> typ2 @@ mode1 mode2 = "" + external x : (typ1 -> typ2) @@ mode1 mode2 = "" external 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) arg1 arg2 @ mode1 = x + let (f @ mode) arg1 arg2 : typ @ mode1 = x + let (f @ mode1 mode2) arg1 arg2 @ mode1 = x let (f @ mode) (arg @ mode) - (arg : typ @@ mode) + (arg : typ @ mode) ~lbl:(arg @ mode) - ~lbl:(arg : typ @@ mode) + ~lbl:(arg : typ @ mode) ~(arg @ mode) - ~(arg : typ @@ mode) + ~(arg : typ @ mode) ?lbl:(arg @ mode) - ?lbl:(arg : typ @@ mode) + ?lbl:(arg : typ @ mode) ?lbl:(arg @ mode = value) - ?lbl:(arg : typ @@ mode = value) + ?lbl:(arg : typ @ mode = value) ?(arg @ mode) - ?(arg : typ @@ mode) + ?(arg : typ @ mode) ?(arg @ mode = value) - ?(arg : typ @@ mode = value) - : typ + ?(arg : typ @ mode = value) + : typ @ mode1 = value ;; end +module LATs = struct + let f : 'a. (b -> c) @ mode = fun x -> y + let f : ('a : k). (b -> c) @ mode = fun x -> y + let f : 'a. (b @ mode1 -> c @ mode2) @ mode3 = fun x -> y + let f : ('a : k). (b @ mode1 -> c @ mode2) @ mode3 = fun x -> y + let (* aaa *) f (* bbb *) : (* ccc *) ('a (* ddd *) : (* eee *) k). + (* fff *) (b (* ggg *) @ (* hhh *) mode1 (* iii *) + -> (* jjj *) c (* kkk *) @ (* lll *) mode2) (* mmm *) + @ (* nnn *) mode3 (* ooo *) + = (* ppp *) fun (* qqq *) x -> y +end + module No_illegal_sugaring = struct - let y = { x = (x : t @@ mode) } - let y = { x :> t = (x : t @@ mode) } + let y = { x = (x : t @ mode) } + let y = { x :> t = (x : t @ mode) } end module Line_breaking = struct @@ -305,14 +326,14 @@ module Line_breaking = struct ;; let long_value_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - : t @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + : 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 + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 = 1 ;; @@ -322,13 +343,13 @@ module Line_breaking = struct let x = (long_expr_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : t - @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) ;; let x = (long_expr_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) ;; end @@ -374,27 +395,27 @@ module Line_breaking = struct let x = (expr - : arg @ mode1 mode2 + : (arg @ mode1 mode2 -> arg @ mode1 mode2 -> arg @ mode1 mode2 -> arg @ mode1 mode2 -> arg @ mode1 mode2 -> arg @ mode1 mode2 - -> arg @ mode1 mode2 - @@ mode1 mode2) + -> arg @ mode1 mode2) + @ mode1 mode2) ;; let x = (expr - : long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + : (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) + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) + @ mode1 mode2) ;; end @@ -461,10 +482,11 @@ module Line_breaking = struct @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) (long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : t - @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) (long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) + @ mode1 mode2 mode3 = a ;; @@ -475,14 +497,14 @@ module Interaction_with_existing_syntax = struct (* let bindings *) let local_ x @ mode1 mode2 = y - let local_ x : typ1 typ2 @@ 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) + let x : (local_ lhs @ mode1 -> local_ rhs @ mode2) @ mode3 = y + let x = (expr : (local_ lhs @ mode1 -> local_ rhs @ mode2) @ mode3) (* modalities on record fields *) diff --git a/test/passing/tests/modes.ml.js-ref b/test/passing/tests/modes.ml.js-ref index 97bfa3cb8c..68c864f1ec 100644 --- a/test/passing/tests/modes.ml.js-ref +++ b/test/passing/tests/modes.ml.js-ref @@ -12,31 +12,32 @@ 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 : typ @ mode1 mode2 = y + let x : typ1 typ2 @ mode1 mode2 = y + let x : (typ1 -> typ2) @ mode1 mode2 = y + let x : (typ1 @ mode1 -> typ2 @ mode2) @ mode3 mode4 = y + let x : (typ1 * typ2) @ mode1 mode2 = y let x @ mode = x and y @ mode = y - and z : typ @@ mode = z + and z : typ @ mode = z let () = let x @ mode = y in - let x : typ @@ mode = y in + let x : typ @ mode = y in let x @ mode = x and y @ mode = y - and z : typ @@ mode = z in + 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 : typ @ mode = y in let%ext x @ mode = x and y @ mode = y - and z : typ @@ mode = z in + and z : typ @ mode = z in () ;; @@ -47,182 +48,190 @@ module Let_bindings = struct 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) + 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)) + (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) + | x -> (x : _ @ mode) + | y -> (y : _ @ mode)) + ; fun1 = (fun ?(x = (x : _ @ mode)) () @ mode -> (y : _ @ mode)) + ; fun2 = (fun ?(x = (x : _ @ mode)) () @ mode1 -> (y : _ @ mode2)) + ; fun3 = (fun ?(x = (x : _ @ mode)) () @ mode1 -> (y : t @ mode2)) + ; fun4 = (fun ?(x = (x : _ @ mode)) () -> (y : _ @ mode)) + ; fun5 = (fun ?(x = (x : _ @ mode)) () -> (y : t @ 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)) + (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)) + (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)) + ((x : _ @ mode); + (y : _ @ mode)) ; while1 = - while (x : _ @@ mode) do - (y : _ @@ mode) + while (x : _ @ mode) do + (y : _ @ mode) done ; for1 = - for i = (x : _ @@ mode) to (y : _ @@ mode) do - (z : _ @@ mode) + 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 = {} + ; constraint1 = ((x : _ @ mode) : _ @ mode) + ; coerce1 = ((x : _ @ mode) :> _) + ; send1 = (x : _ @ mode)#y + ; setinstvar1 = x <- (x : _ @ mode) + ; override1 = {} ; letmodule1 = (let module M = ME in - (x : _ @@ mode)) + (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)) + (x : _ @ mode)) + ; assert1 = assert (x : _ @ mode) + ; lazy1 = lazy (x : _ @ mode) + ; newtype1 = (fun (type t) @ mode -> (x : _ @ mode)) + ; open1 = M.((x : _ @ mode)) ; letopen1 = (let open M in - (x : _ @@ mode)) + (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) + (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) + { ident1 = (x : _ @ mode) + ; constant1 = ("" : _ @ mode) ; let1 = (let x = y in z : _ - @@ mode) + @ mode) ; function1 = (function | x -> x | y -> y : _ - @@ mode) - ; fun1 = (fun x -> y : _ @@ mode) - ; apply1 = (f x : _ @@ mode) + @ mode) + ; fun1 = (fun x @ mode -> y : _ @ mode) + ; fun2 = (fun x @ mode1 -> y : _ @ mode2) + ; fun3 = (fun x @ mode1 -> y : t @ mode2) + ; fun4 = (fun x -> y : _ @ mode) + ; fun5 = (fun x -> y : t @ mode) + ; apply1 = (f x : _ @ mode) ; match1 = ((match x with | y -> y | z -> z) : _ - @@ mode) + @ 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) + @ 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) + @ mode) ; while1 = while x do y done - @@ mode + @ 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) + @ 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) + @ 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) + @ mode) + ; assert1 = (assert x : _ @ mode) + ; lazy1 = (lazy x : _ @ mode) + ; object1 = (object end : _ @ mode) + ; newtype1 = (fun (type t) @ mode -> x : _ @ mode) + ; pack1 = ((module M) : _ @ mode) + ; pack2 = ((module M : S) : _ @ mode) + ; open1 = (M.(x y) : _ @ mode) ; letopen1 = (let open M in x : _ - @@ mode) + @ 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) + @ mode) + ; extension1 = ([%ext] : _ @ mode) + ; hole1 = (_ : _ @ mode) + ; cons1 = (x :: y :: z : _ @ mode) + ; prefix1 = (!x : _ @ mode) + ; infix1 = (x + y : _ @ mode) } ;; end @@ -231,8 +240,8 @@ 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) + let x : (lhs @ mode1 -> rhs @ mode2) @ mode3 = y + let x = (expr : (lhs @ mode1 -> rhs @ mode2) @ mode3) end module Modalities_on_record_fields = struct @@ -266,34 +275,49 @@ module type Value_descriptions = sig 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) arg1 arg2 @ mode1 = x + let (f @ mode) arg1 arg2 : typ @ mode1 = x + let (f @ mode1 mode2) arg1 arg2 @ mode1 = x let (f @ mode) (arg @ mode) - (arg : typ @@ mode) + (arg : typ @ mode) ~lbl:(arg @ mode) - ~lbl:(arg : typ @@ mode) + ~lbl:(arg : typ @ mode) ~(arg @ mode) - ~(arg : typ @@ mode) + ~(arg : typ @ mode) ?lbl:(arg @ mode) - ?lbl:(arg : typ @@ mode) + ?lbl:(arg : typ @ mode) ?lbl:(arg @ mode = value) - ?lbl:(arg : typ @@ mode = value) + ?lbl:(arg : typ @ mode = value) ?(arg @ mode) - ?(arg : typ @@ mode) + ?(arg : typ @ mode) ?(arg @ mode = value) - ?(arg : typ @@ mode = value) - : typ + ?(arg : typ @ mode = value) + : typ @ mode1 = value ;; end +module LATs = struct + let f : 'a. (b -> c) @ mode = fun x -> y + let f : ('a : k). (b -> c) @ mode = fun x -> y + let f : 'a. (b @ mode1 -> c @ mode2) @ mode3 = fun x -> y + let f : ('a : k). (b @ mode1 -> c @ mode2) @ mode3 = fun x -> y + + let (* aaa *) f (* bbb *) + : (* ccc *) ('a (* ddd *) : (* eee *) k). + ((* fff *) b (* ggg *) @ (* hhh *) mode1 (* iii *) + -> (* jjj *) c (* kkk *) @ (* lll *) mode2) (* mmm *) @ (* nnn *) mode3 (* ooo *) + = + (* ppp *) fun (* qqq *) x -> y + ;; +end + module No_illegal_sugaring = struct - let y = { x = (x : t @@ mode) } - let y = { x :> t = (x : t @@ mode) } + let y = { x = (x : t @ mode) } + let y = { x :> t = (x : t @ mode) } end module Line_breaking = struct @@ -305,14 +329,14 @@ module Line_breaking = struct ;; let long_value_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - : t @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 + : 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 + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 = 1 ;; @@ -322,13 +346,13 @@ module Line_breaking = struct let x = (long_expr_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : t - @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) ;; let x = (long_expr_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) ;; end @@ -374,27 +398,27 @@ module Line_breaking = struct 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) + : (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) + : (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 @@ -461,10 +485,10 @@ module Line_breaking = struct @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) (long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : t - @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) (long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) @ mode1 mode2 mode3 = a ;; @@ -475,14 +499,14 @@ module Interaction_with_existing_syntax = struct (* let bindings *) let local_ x @ mode1 mode2 = y - let local_ x : typ1 typ2 @@ 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) + let x : (local_ lhs @ mode1 -> local_ rhs @ mode2) @ mode3 = y + let x = (expr : (local_ lhs @ mode1 -> local_ rhs @ mode2) @ mode3) (* modalities on record fields *) diff --git a/test/passing/tests/modes.ml.opts b/test/passing/tests/modes.ml.opts new file mode 100644 index 0000000000..559617f4de --- /dev/null +++ b/test/passing/tests/modes.ml.opts @@ -0,0 +1 @@ +--max-iters=5 diff --git a/test/passing/tests/modes.ml.ref b/test/passing/tests/modes.ml.ref index 9a6d57c42b..0e37e2e59d 100644 --- a/test/passing/tests/modes.ml.ref +++ b/test/passing/tests/modes.ml.ref @@ -15,31 +15,33 @@ module Let_bindings = struct let x @ mode1 mode2 = y - let x : typ @@ 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 : (typ1 -> typ2) @ mode1 mode2 = y - let x : typ1 * typ2 @@ mode1 mode2 = y + let x : (typ1 @ mode1 -> typ2 @ mode2) @ mode3 mode4 = y + + let x : (typ1 * typ2) @ mode1 mode2 = y let x @ mode = x and y @ mode = y - and z : typ @@ mode = z + 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 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 + let%ext x : typ @ mode = y in + let%ext x @ mode = x and y @ mode = y and z : typ @ mode = z in () external x : typ @@ mode1 mode2 = "" @@ -52,158 +54,166 @@ module Let_bindings = struct end module Expressions = struct - let x = (expr : typ @@ mode1 mode2) + 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) + 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) + (let x = (x : _ @ mode) and y = (y : _ @ mode) in + (z : _ @ mode) ) + ; function1= (function x -> (x : _ @ mode) | y -> (y : _ @ mode)) + ; fun1= (fun ?(x = (x : _ @ mode)) () @ mode -> (y : _ @ mode)) + ; fun2= (fun ?(x = (x : _ @ mode)) () @ mode1 -> (y : _ @ mode2)) + ; fun3= (fun ?(x = (x : _ @ mode)) () @ mode1 -> (y : t @ mode2)) + ; fun4= (fun ?(x = (x : _ @ mode)) () -> (y : _ @ mode)) + ; fun5= (fun ?(x = (x : _ @ mode)) () -> (y : t @ 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)) + ( 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) ) + ( (x : _ @ mode) ; + (y : _ @ mode) ) ; while1= - while (x : _ @@ mode) do - (y : _ @@ mode) + while (x : _ @ mode) do + (y : _ @ mode) done ; for1= - for i = (x : _ @@ mode) to (y : _ @@ mode) do - (z : _ @@ mode) + 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= {} + ; constraint1= ((x : _ @ mode) : _ @ mode) + ; coerce1= ((x : _ @ mode) :> _) + ; send1= (x : _ @ mode)#y + ; setinstvar1= x <- (x : _ @ mode) + ; override1= {} ; letmodule1= (let module M = ME in - (x : _ @@ mode) ) + (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)) + (x : _ @ mode) ) + ; assert1= assert (x : _ @ mode) + ; lazy1= lazy (x : _ @ mode) + ; newtype1= (fun (type t) @ mode -> (x : _ @ mode)) + ; open1= M.((x : _ @ mode)) ; letopen1= (let open M in - (x : _ @@ mode) ) + (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) } + (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) + { 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) + @ mode ) + ; function1= (function x -> x | y -> y : _ @ mode) + ; fun1= (fun x @ mode -> y : _ @ mode) + ; fun2= (fun x @ mode1 -> y : _ @ mode2) + ; fun3= (fun x @ mode1 -> y : t @ mode2) + ; fun4= (fun x -> y : _ @ mode) + ; fun5= (fun x -> y : t @ 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 + @ 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) + @ 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 ) + @ 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) + @ mode ) + ; assert1= (assert x : _ @ mode) + ; lazy1= (lazy x : _ @ mode) + ; object1= (object end : _ @ mode) + ; newtype1= (fun (type t) @ mode -> x : _ @ mode) + ; pack1= ((module M) : _ @ mode) + ; pack2= ((module M : S) : _ @ mode) + ; open1= (M.(x y) : _ @ mode) ; letopen1= ( let open M in x : _ - @@ mode ) + @ 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) } + @ mode ) + ; extension1= ([%ext] : _ @ mode) + ; hole1= (_ : _ @ mode) + ; cons1= (x :: y :: z : _ @ mode) + ; prefix1= (!x : _ @ mode) + ; infix1= (x + y : _ @ mode) } end module Arrow_params = struct @@ -212,9 +222,9 @@ module Arrow_params = struct type t = arg1 @ mode1 -> lbl:arg2 @ mode2 -> ?lbl:arg3 @ mode3 -> res @ mode4 - let x : lhs @ mode1 -> rhs @ mode2 @@ mode3 = y + let x : (lhs @ mode1 -> rhs @ mode2) @ mode3 = y - let x = (expr : lhs @ mode1 -> rhs @ mode2 @@ mode3) + let x = (expr : (lhs @ mode1 -> rhs @ mode2) @ mode3) end module Modalities_on_record_fields = struct @@ -250,24 +260,42 @@ module type Value_descriptions = sig end module Let_bound_functions = struct - let (f @ mode) arg1 arg2 = x + let (f @ mode) arg1 arg2 @ mode1 = x - let (f @ mode) arg1 arg2 : typ = x + let (f @ mode) arg1 arg2 : typ @ mode1 = x - let (f @ mode1 mode2) arg1 arg2 = x + let (f @ mode1 mode2) arg1 arg2 @ mode1 = 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 = + 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 @ mode1 = value end +module LATs = struct + let f : 'a. (b -> c) @ mode = fun x -> y + + let f : ('a : k). (b -> c) @ mode = fun x -> y + + let f : 'a. (b @ mode1 -> c @ mode2) @ mode3 = fun x -> y + + let f : ('a : k). (b @ mode1 -> c @ mode2) @ mode3 = fun x -> y + + let (* aaa *) f (* bbb *) : + (* ccc *) + ('a (* ddd *) : (* eee *) k). + ((* fff *) b (* ggg *) @ (* hhh *) mode1 (* iii *) + -> (* jjj *) c (* kkk *) @ (* lll *) mode2) (* mmm *) + @ (* nnn *) mode3 (* ooo *) = + (* ppp *) fun (* qqq *) x -> y +end + module No_illegal_sugaring = struct - let y = {x= (x : t @@ mode)} + let y = {x= (x : t @ mode)} - let y = {x:> t = (x : t @@ mode)} + let y = {x:> t = (x : t @ mode)} end module Line_breaking = struct @@ -277,12 +305,12 @@ module Line_breaking = struct 1 let long_value_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : t - @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 = + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 = 1 let long_value_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 = + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 = 1 end @@ -290,12 +318,12 @@ module Line_breaking = struct let x = ( long_expr_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : t - @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 ) + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 ) let x = ( long_expr_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 ) + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 ) end module Arrow_params = struct @@ -341,26 +369,26 @@ module Line_breaking = struct 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 ) + : ( 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 ) + : ( 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 @@ -418,15 +446,16 @@ module Line_breaking = struct module Let_bound_functions = struct let (long_fun_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8) + @ 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 ) + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 ) (long_arg_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa : long_type_aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - @@ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 ) = + @ mode1 mode2 mode3 mode4 mode5 mode6 mode7 mode8 ) + @ mode1 mode2 mode3 = a end end @@ -436,15 +465,15 @@ module Interaction_with_existing_syntax = struct let local_ x @ mode1 mode2 = y - let local_ x : typ1 typ2 @@ 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 : (local_ lhs @ mode1 -> local_ rhs @ mode2) @ mode3 = y - let x = (expr : local_ lhs @ mode1 -> local_ rhs @ mode2 @@ mode3) + let x = (expr : (local_ lhs @ mode1 -> local_ rhs @ mode2) @ mode3) (* modalities on record fields *) diff --git a/test/passing/tests/modes_attrs.ml b/test/passing/tests/modes_attrs.ml index 124d7d7988..18e2066baa 100644 --- a/test/passing/tests/modes_attrs.ml +++ b/test/passing/tests/modes_attrs.ml @@ -1,13 +1,13 @@ (* let bindings *) let[@attr] x @ mode1 mode2 = y -let[@attr] x : typ @@ 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]) +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 *) @@ -16,14 +16,14 @@ 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] +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 *) diff --git a/test/passing/tests/modes_attrs.ml.js-ref b/test/passing/tests/modes_attrs.ml.js-ref index c07e2f6955..7d5f8ad5b7 100644 --- a/test/passing/tests/modes_attrs.ml.js-ref +++ b/test/passing/tests/modes_attrs.ml.js-ref @@ -1,13 +1,13 @@ (* let bindings *) let[@attr] x @ mode1 mode2 = y -let[@attr] x : typ @@ 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]) +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 *) @@ -16,14 +16,14 @@ 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] +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 *) diff --git a/test/passing/tests/modes_attrs.ml.ref b/test/passing/tests/modes_attrs.ml.ref index 43b4c4b29e..8b59896f05 100644 --- a/test/passing/tests/modes_attrs.ml.ref +++ b/test/passing/tests/modes_attrs.ml.ref @@ -2,15 +2,15 @@ let[@attr] x @ mode1 mode2 = y -let[@attr] x : typ @@ mode1 mode2 = y +let[@attr] x : typ @ mode1 mode2 = y (* expressions *) -let x = (expr [@attr] : typ @@ mode1 mode2) +let x = (expr [@attr] : typ @ mode1 mode2) -let x = (expr : (typ[@attr]) @@ mode1 mode2) +let x = (expr : (typ[@attr]) @ mode1 mode2) -let x = ((expr : typ @@ mode1 mode2) [@attr]) +let x = ((expr : typ @ mode1 mode2) [@attr]) (* lhs/rhs of arrows *) @@ -22,21 +22,21 @@ 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[@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[@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 : (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 [@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[@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[@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[@attr]) @ m5 m6) @ m7 m8) -let x = (expr : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8) [@@attr] +let x = (expr : (lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6) @ m7 m8) [@@attr] (* modalities on record fields *) diff --git a/test/passing/tests/modes_cmts-break_separators_after.ml.err b/test/passing/tests/modes_cmts-break_separators_after.ml.err new file mode 100644 index 0000000000..009c6f1df7 --- /dev/null +++ b/test/passing/tests/modes_cmts-break_separators_after.ml.err @@ -0,0 +1,19 @@ +Warning: tests/modes_cmts.ml:118 exceeds the margin +Warning: tests/modes_cmts.ml:120 exceeds the margin +Warning: tests/modes_cmts.ml:122 exceeds the margin +Warning: tests/modes_cmts.ml:124 exceeds the margin +Warning: tests/modes_cmts.ml:126 exceeds the margin +Warning: tests/modes_cmts.ml:128 exceeds the margin +Warning: tests/modes_cmts.ml:130 exceeds the margin +Warning: tests/modes_cmts.ml:132 exceeds the margin +Warning: tests/modes_cmts.ml:134 exceeds the margin +Warning: tests/modes_cmts.ml:136 exceeds the margin +Warning: tests/modes_cmts.ml:138 exceeds the margin +Warning: tests/modes_cmts.ml:140 exceeds the margin +Warning: tests/modes_cmts.ml:142 exceeds the margin +Warning: tests/modes_cmts.ml:144 exceeds the margin +Warning: tests/modes_cmts.ml:146 exceeds the margin +Warning: tests/modes_cmts.ml:148 exceeds the margin +Warning: tests/modes_cmts.ml:150 exceeds the margin +Warning: tests/modes_cmts.ml:152 exceeds the margin +Warning: tests/modes_cmts.ml:154 exceeds the margin diff --git a/test/passing/tests/modes_cmts-break_separators_after.ml.ref b/test/passing/tests/modes_cmts-break_separators_after.ml.ref index 0cd07c5a14..61a0a239ab 100644 --- a/test/passing/tests/modes_cmts-break_separators_after.ml.ref +++ b/test/passing/tests/modes_cmts-break_separators_after.ml.ref @@ -16,37 +16,37 @@ let x @ mode1 mode2 (* cmt *) = y let x @ mode1 mode2 = (* cmt *) y -let (* cmt *) x : typ @@ mode1 mode2 = y +let (* cmt *) x : typ @ mode1 mode2 = y -let x (* cmt *) : typ @@ mode1 mode2 = y +let x (* cmt *) : 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 @@ (* cmt *) mode1 mode2 = y +let x : typ @ (* cmt *) mode1 mode2 = y -let x : typ @@ mode1 (* cmt *) mode2 = y +let x : typ @ mode1 (* cmt *) mode2 = y -let x : typ @@ mode1 mode2 (* cmt *) = y +let x : typ @ mode1 mode2 (* cmt *) = 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 = ((* cmt *) expr : typ @ mode1 mode2) -let x = (expr (* cmt *) : typ @@ mode1 mode2) +let x = (expr (* cmt *) : 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 @@ (* cmt *) mode1 mode2) +let x = (expr : typ @ (* cmt *) mode1 mode2) -let x = (expr : typ @@ mode1 (* cmt *) mode2) +let x = (expr : typ @ mode1 (* cmt *) mode2) -let x = (expr : typ @@ mode1 mode2 (* cmt *)) +let x = (expr : typ @ mode1 mode2 (* cmt *)) (* lhs/rhs of arrows *) @@ -80,81 +80,82 @@ 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 : ((* 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 @ (* 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 (* 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 -> (* 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 @ (* 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 (* 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 -> (* 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 @ (* 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 (* 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 @@ (* 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 (* cmt *) m8 = y -let x : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 (* cmt *) = 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 : (* 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 @ (* 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 (* 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 -> (* 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 @ (* 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 (* 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 -> (* 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 @ (* 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 (* 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 @@ (* 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 (* 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 *)) -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 *) @@ -353,7 +354,7 @@ 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) (* cmt *) (arg1 @ mode2) (arg2 @ mode3) : typ = x let (f @ mode1) (arg1 (* cmt *) @ mode2) (arg2 @ mode3) : typ = x @@ -363,7 +364,7 @@ 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) (* cmt *) (arg2 @ mode3) : typ = x let (f @ mode1) (arg1 @ mode2) (arg2 (* cmt *) @ mode3) : typ = x diff --git a/test/passing/tests/modes_cmts.ml b/test/passing/tests/modes_cmts.ml index 46c9d72edd..c2a87f7b70 100644 --- a/test/passing/tests/modes_cmts.ml +++ b/test/passing/tests/modes_cmts.ml @@ -10,24 +10,24 @@ 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 +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 *)) +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 *) @@ -47,44 +47,44 @@ 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 *) +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 *) diff --git a/test/passing/tests/modes_cmts.ml.err b/test/passing/tests/modes_cmts.ml.err new file mode 100644 index 0000000000..009c6f1df7 --- /dev/null +++ b/test/passing/tests/modes_cmts.ml.err @@ -0,0 +1,19 @@ +Warning: tests/modes_cmts.ml:118 exceeds the margin +Warning: tests/modes_cmts.ml:120 exceeds the margin +Warning: tests/modes_cmts.ml:122 exceeds the margin +Warning: tests/modes_cmts.ml:124 exceeds the margin +Warning: tests/modes_cmts.ml:126 exceeds the margin +Warning: tests/modes_cmts.ml:128 exceeds the margin +Warning: tests/modes_cmts.ml:130 exceeds the margin +Warning: tests/modes_cmts.ml:132 exceeds the margin +Warning: tests/modes_cmts.ml:134 exceeds the margin +Warning: tests/modes_cmts.ml:136 exceeds the margin +Warning: tests/modes_cmts.ml:138 exceeds the margin +Warning: tests/modes_cmts.ml:140 exceeds the margin +Warning: tests/modes_cmts.ml:142 exceeds the margin +Warning: tests/modes_cmts.ml:144 exceeds the margin +Warning: tests/modes_cmts.ml:146 exceeds the margin +Warning: tests/modes_cmts.ml:148 exceeds the margin +Warning: tests/modes_cmts.ml:150 exceeds the margin +Warning: tests/modes_cmts.ml:152 exceeds the margin +Warning: tests/modes_cmts.ml:154 exceeds the margin diff --git a/test/passing/tests/modes_cmts.ml.js-ref b/test/passing/tests/modes_cmts.ml.js-ref index 4f63e2b258..23c1914c9e 100644 --- a/test/passing/tests/modes_cmts.ml.js-ref +++ b/test/passing/tests/modes_cmts.ml.js-ref @@ -10,24 +10,24 @@ 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 +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 *)) +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 *) @@ -47,44 +47,44 @@ 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 *) +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 *) @@ -299,12 +299,12 @@ 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) (* 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) (* 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 diff --git a/test/passing/tests/modes_cmts.ml.ref b/test/passing/tests/modes_cmts.ml.ref index b56a87b986..1e283ee250 100644 --- a/test/passing/tests/modes_cmts.ml.ref +++ b/test/passing/tests/modes_cmts.ml.ref @@ -16,37 +16,37 @@ let x @ mode1 mode2 (* cmt *) = y let x @ mode1 mode2 = (* cmt *) y -let (* cmt *) x : typ @@ mode1 mode2 = y +let (* cmt *) x : typ @ mode1 mode2 = y -let x (* cmt *) : typ @@ mode1 mode2 = y +let x (* cmt *) : 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 @@ (* cmt *) mode1 mode2 = y +let x : typ @ (* cmt *) mode1 mode2 = y -let x : typ @@ mode1 (* cmt *) mode2 = y +let x : typ @ mode1 (* cmt *) mode2 = y -let x : typ @@ mode1 mode2 (* cmt *) = y +let x : typ @ mode1 mode2 (* cmt *) = 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 = ((* cmt *) expr : typ @ mode1 mode2) -let x = (expr (* cmt *) : typ @@ mode1 mode2) +let x = (expr (* cmt *) : 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 @@ (* cmt *) mode1 mode2) +let x = (expr : typ @ (* cmt *) mode1 mode2) -let x = (expr : typ @@ mode1 (* cmt *) mode2) +let x = (expr : typ @ mode1 (* cmt *) mode2) -let x = (expr : typ @@ mode1 mode2 (* cmt *)) +let x = (expr : typ @ mode1 mode2 (* cmt *)) (* lhs/rhs of arrows *) @@ -80,81 +80,82 @@ 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 : ((* 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 @ (* 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 (* 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 -> (* 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 @ (* 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 (* 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 -> (* 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 @ (* 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 (* 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 @@ (* 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 (* cmt *) m8 = y -let x : lhs @ m1 m2 -> mhs @ m3 m4 -> rhs @ m5 m6 @@ m7 m8 (* cmt *) = 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 : (* 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 @ (* 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 (* 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 -> (* 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 @ (* 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 (* 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 -> (* 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 @ (* 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 (* 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 @@ (* 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 (* 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 *)) -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 *) @@ -353,7 +354,7 @@ 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) (* cmt *) (arg1 @ mode2) (arg2 @ mode3) : typ = x let (f @ mode1) (arg1 (* cmt *) @ mode2) (arg2 @ mode3) : typ = x @@ -363,7 +364,7 @@ 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) (* cmt *) (arg2 @ mode3) : typ = x let (f @ mode1) (arg1 @ mode2) (arg2 (* cmt *) @ mode3) : typ = x diff --git a/test/passing/tests/module_modes.mli b/test/passing/tests/module_modes.mli index 1e1b0b37d7..cef916df22 100644 --- a/test/passing/tests/module_modes.mli +++ b/test/passing/tests/module_modes.mli @@ -15,7 +15,7 @@ module T : sig @@ nonportable val portable : t @@ nonportable end -module (T @ nonportable) : sig @@ portable +module (T @@ nonportable) : sig @@ portable val portable : t val nonportable : t @@ nonportable end diff --git a/test/passing/tests/module_modes.mli.js-ref b/test/passing/tests/module_modes.mli.js-ref index 1e1b0b37d7..cef916df22 100644 --- a/test/passing/tests/module_modes.mli.js-ref +++ b/test/passing/tests/module_modes.mli.js-ref @@ -15,7 +15,7 @@ module T : sig @@ nonportable val portable : t @@ nonportable end -module (T @ nonportable) : sig @@ portable +module (T @@ nonportable) : sig @@ portable val portable : t val nonportable : t @@ nonportable end diff --git a/test/passing/tests/module_modes.mli.ref b/test/passing/tests/module_modes.mli.ref index ef6943efdf..8f5638b393 100644 --- a/test/passing/tests/module_modes.mli.ref +++ b/test/passing/tests/module_modes.mli.ref @@ -18,7 +18,7 @@ module T : sig @@ nonportable val portable : t @@ nonportable end -module (T @ nonportable) : sig @@ portable +module (T @@ nonportable) : sig @@ portable val portable : t val nonportable : t @@ nonportable diff --git a/test/passing/tests/shortcut_ext_attr.ml b/test/passing/tests/shortcut_ext_attr.ml index 9707c46aed..b7bdebcfb2 100644 --- a/test/passing/tests/shortcut_ext_attr.ml +++ b/test/passing/tests/shortcut_ext_attr.ml @@ -80,7 +80,6 @@ module M = (functor [@foo] (M : S) -> (val x) [@foo] (struct end [@foo])) (* Module type expression *) module type S = functor [@foo1] (M : S) - -> functor (_ : (module type of M) [@foo2]) -> sig end [@foo3] diff --git a/test/passing/tests/shortcut_ext_attr.ml.js-ref b/test/passing/tests/shortcut_ext_attr.ml.js-ref index 8501044053..b63aadfaf1 100644 --- a/test/passing/tests/shortcut_ext_attr.ml.js-ref +++ b/test/passing/tests/shortcut_ext_attr.ml.js-ref @@ -72,11 +72,8 @@ type t = [%foo: ((module M)[@foo])] module M = (functor [@foo] (M : S) -> (val x) [@foo] (struct end [@foo])) (* Module type expression *) -module type S = functor [@foo1] - (M : S) - -> functor - (_ : (module type of M) [@foo2]) - -> sig end [@foo3] +module type S = functor [@foo1] (M : S) (_ : (module type of M) [@foo2]) -> sig end +[@foo3] (* Structure items *) let%foo[@foo] x = 4 diff --git a/test/passing/tests/source.ml.err b/test/passing/tests/source.ml.err index fa52eef06b..8717f5adbe 100644 --- a/test/passing/tests/source.ml.err +++ b/test/passing/tests/source.ml.err @@ -1,7 +1,7 @@ -Warning: tests/source.ml:702 exceeds the margin -Warning: tests/source.ml:2318 exceeds the margin -Warning: tests/source.ml:9291 exceeds the margin -Warning: tests/source.ml:9299 exceeds the margin -Warning: tests/source.ml:9305 exceeds the margin -Warning: tests/source.ml:9782 exceeds the margin -Warning: tests/source.ml:9882 exceeds the margin +Warning: tests/source.ml:701 exceeds the margin +Warning: tests/source.ml:2317 exceeds the margin +Warning: tests/source.ml:9290 exceeds the margin +Warning: tests/source.ml:9298 exceeds the margin +Warning: tests/source.ml:9304 exceeds the margin +Warning: tests/source.ml:9781 exceeds the margin +Warning: tests/source.ml:9881 exceeds the margin diff --git a/test/passing/tests/source.ml.js-ref b/test/passing/tests/source.ml.js-ref index 7e1a1af25b..c12c044847 100644 --- a/test/passing/tests/source.ml.js-ref +++ b/test/passing/tests/source.ml.js-ref @@ -158,9 +158,7 @@ type t = [%foo: ((module M)[@foo])] module M = (functor [@foo] (M : S) -> (val x) [@foo] (struct end [@foo])) (* Module type expression *) -module type S = functor [@foo] (M : S) -> functor (_ : (module type of M) [@foo]) -> sig end -[@foo] - +module type S = functor [@foo] (M : S) (_ : (module type of M) [@foo]) -> sig end [@foo] module type S = functor (_ : S) (_ : S) -> S module type S = functor (_ : functor (_ : S) -> S) -> S module type S = functor (M : S) (_ : S) -> S diff --git a/test/passing/tests/source.ml.ref b/test/passing/tests/source.ml.ref index 6d4ba63a0e..69af15e910 100644 --- a/test/passing/tests/source.ml.ref +++ b/test/passing/tests/source.ml.ref @@ -184,7 +184,6 @@ module M = (functor [@foo] (M : S) -> (val x) [@foo] (struct end [@foo])) (* Module type expression *) module type S = functor [@foo] (M : S) - -> functor (_ : (module type of M) [@foo]) -> sig end [@foo] diff --git a/vendor/ocaml-common/warnings.ml b/vendor/ocaml-common/warnings.ml index 0ea3da8d5b..66237c1fe0 100644 --- a/vendor/ocaml-common/warnings.ml +++ b/vendor/ocaml-common/warnings.ml @@ -130,7 +130,7 @@ type t = | Unchecked_zero_alloc_attribute (* 199 *) | Unboxing_impossible (* 210 *) | Mod_by_top of string (* 211 *) - | Unnecessary_allow_any_kind (* 212 *) + (* 212 taken *) (* If you remove a warning, leave a hole in the numbering. NEVER change the numbers of existing warnings. @@ -220,7 +220,6 @@ let number = function | Unchecked_zero_alloc_attribute -> 199 | Unboxing_impossible -> 210 | Mod_by_top _ -> 211 - | Unnecessary_allow_any_kind -> 212 ;; (* DO NOT REMOVE the ;; above: it is used by the testsuite/ests/warnings/mnemonics.mll test to determine where @@ -601,11 +600,6 @@ let descriptions = [ names = ["mod-by-top"]; description = "Including the top-most element of an axis in a kind's modifiers is a no-op."; since = since 4 14 }; - { number = 212; - names = ["unnecessary-allow-any-kind"]; - description = "[@@unsafe_allow_any_kind_in_{impl,intf}] attributes included \ - on a type and a signature with matching kinds"; - since = since 5 1 }; ] let name_to_number = @@ -1257,10 +1251,6 @@ let message = function "%s is the top-most modifier.\n\ Modifying by a top element is a no-op." modifier - | Unnecessary_allow_any_kind -> - Printf.sprintf - "[@@allow_any_kind_in_intf] and [@@allow_any_kind_in_impl] set on a \n\ - type, but the kind matches. The attributes can be removed." ;; let nerrors = ref 0 diff --git a/vendor/ocaml-common/warnings.mli b/vendor/ocaml-common/warnings.mli index 3da8d8db77..71d8c676b1 100644 --- a/vendor/ocaml-common/warnings.mli +++ b/vendor/ocaml-common/warnings.mli @@ -136,7 +136,6 @@ type t = | Unchecked_zero_alloc_attribute (* 199 *) | Unboxing_impossible (* 210 *) | Mod_by_top of string (* 211 *) - | Unnecessary_allow_any_kind (* 212 *) type alert = {kind:string; message:string; def:loc; use:loc} diff --git a/vendor/parser-extended/ast_helper.ml b/vendor/parser-extended/ast_helper.ml index 4aeecbb6da..9e5eced3b4 100644 --- a/vendor/parser-extended/ast_helper.ml +++ b/vendor/parser-extended/ast_helper.ml @@ -208,8 +208,7 @@ module Mty = struct let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a) let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a) let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a) - let functor_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_functor (a, b)) - let gen ?loc ?attrs a b = mk ?loc ?attrs (Pmty_gen (a, b)) + let functor_ ?loc ?attrs a b c = mk ?loc ?attrs (Pmty_functor (a, b, c)) let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b)) let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a) let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a) @@ -226,7 +225,8 @@ let mk ?(loc = !default_loc) ?(attrs = []) d = let functor_ ?loc ?attrs arg body = mk ?loc ?attrs (Pmod_functor (arg, body)) let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2)) - let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty)) + let constraint_ ?loc ?attrs ty mode m = + mk ?loc ?attrs (Pmod_constraint (m, ty, mode)) let unpack ?loc ?attrs a b c = mk ?loc ?attrs (Pmod_unpack (a, b, c)) let apply_unit ?loc ?attrs a b = mk ?loc ?attrs (Pmod_apply_unit (a, b)) let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a) @@ -395,12 +395,13 @@ end module Md = struct let mk ?(loc = !default_loc) ?(attrs=Attr.ext_attrs ()) - ?(docs = empty_docs) ?(text = []) name modalities args typ = + ?(docs = empty_docs) ?(text = []) name modalities args typ mode = { pmd_name = name; pmd_modalities = modalities; pmd_args = args; pmd_type = typ; + pmd_mode = mode; pmd_ext_attrs = add_text_attrs' text (add_docs_attrs' docs attrs); pmd_loc = loc; } @@ -465,12 +466,13 @@ end module Vb = struct let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(text = []) ?value_constraint ?(modes = []) ~is_pun pat expr = + ?(text = []) ?value_constraint ?(modes = []) ~local ~is_pun pat expr = { pvb_pat = pat; pvb_expr = expr; pvb_constraint=value_constraint; pvb_modes=modes; + pvb_local=local; pvb_is_pun=is_pun; pvb_attributes = add_text_attrs text (add_docs_attrs docs attrs); diff --git a/vendor/parser-extended/ast_mapper.ml b/vendor/parser-extended/ast_mapper.ml index 901e8b8492..68f4056746 100644 --- a/vendor/parser-extended/ast_mapper.ml +++ b/vendor/parser-extended/ast_mapper.ml @@ -379,7 +379,8 @@ let map_functor_param sub {loc; txt} = let txt = match txt with | Unit -> Unit - | Named (s, mt) -> Named (map_loc sub s, sub.module_type sub mt) + | Named (s, mt, mm) -> + Named (map_loc sub s, sub.module_type sub mt, sub.modes sub mm) in {loc; txt} @@ -394,14 +395,11 @@ module MT = struct | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s) | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s) | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg) - | Pmty_functor (params, mt) -> + | Pmty_functor (params, mt, mm) -> functor_ ~loc ~attrs (List.map (map_functor_param sub) params) (sub.module_type sub mt) - | Pmty_gen (arg_loc, mt) -> - gen ~loc ~attrs - (sub.location sub arg_loc) - (sub.module_type sub mt) + (sub.modes sub mm) | Pmty_with (mt, l) -> with_ ~loc ~attrs (sub.module_type sub mt) (List.map (sub.with_constraint sub) l) @@ -479,9 +477,9 @@ module M = struct apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) | Pmod_apply_unit (me, lc) -> apply_unit ~loc ~attrs (sub.module_expr sub me) (sub.location sub lc) - | Pmod_constraint (m, mty) -> - constraint_ ~loc ~attrs (sub.module_expr sub m) - (sub.module_type sub mty) + | Pmod_constraint (m, mty, mm) -> + constraint_ ~loc ~attrs (Option.map (sub.module_type sub) mty) + (sub.modes sub mm) (sub.module_expr sub m) | Pmod_unpack (e, ty1, ty2) -> unpack ~loc ~attrs (sub.expr sub e) @@ -744,7 +742,7 @@ module P = struct | Ppat_construct (l, p) -> construct ~loc ~attrs (map_loc sub l) (map_opt - (fun (vl, p) -> List.map (map_loc sub) vl, sub.pat sub p) + (fun (vl, p) -> List.map (map_type_var sub) vl, sub.pat sub p) p) | Ppat_variant (l, p) -> variant ~loc ~attrs (variant_var sub l) (map_opt (sub.pat sub) p) @@ -914,12 +912,13 @@ let default_mapper = binding_op = E.map_binding_op; module_declaration = - (fun this {pmd_name; pmd_modalities; pmd_args; pmd_type; pmd_ext_attrs; pmd_loc} -> + (fun this {pmd_name; pmd_modalities; pmd_args; pmd_type; pmd_mode; pmd_ext_attrs; pmd_loc} -> Md.mk (map_loc this pmd_name) (this.modalities this pmd_modalities) (List.map (map_functor_param this) pmd_args) (this.module_type this pmd_type) + (this.modes this pmd_mode) ~attrs:(this.ext_attrs this pmd_ext_attrs) ~loc:(this.location this pmd_loc) ); @@ -984,7 +983,7 @@ let default_mapper = ); value_binding = - (fun this {pvb_pat; pvb_expr; pvb_constraint; pvb_is_pun; pvb_attributes; pvb_loc; pvb_modes} -> + (fun this {pvb_pat; pvb_expr; pvb_constraint; pvb_is_pun; pvb_attributes; pvb_loc; pvb_modes; pvb_local} -> let map_ct (ct:Parsetree.value_constraint) = match ct with | Pvc_constraint {locally_abstract_univars=vars; typ} -> Pvc_constraint @@ -1005,6 +1004,7 @@ let default_mapper = ~loc:(this.location this pvb_loc) ~attrs:(this.attributes this pvb_attributes) ~modes:(this.modes this pvb_modes) + ~local:pvb_local ); value_bindings = PVB.map_value_bindings; diff --git a/vendor/parser-extended/dune b/vendor/parser-extended/dune index 448c9e1cad..925dd4527d 100644 --- a/vendor/parser-extended/dune +++ b/vendor/parser-extended/dune @@ -18,6 +18,7 @@ :standard --lalr --strict + --explain --unused-token COMMENT --unused-token diff --git a/vendor/parser-extended/parser.mly b/vendor/parser-extended/parser.mly index 739106d68c..c58901adce 100644 --- a/vendor/parser-extended/parser.mly +++ b/vendor/parser-extended/parser.mly @@ -60,7 +60,7 @@ let pv_of_priv = function let mkvarinj s l = mkloc s (make_loc l) let mktyp ~loc ?attrs d = Typ.mk ~loc:(make_loc loc) ?attrs d let mkpat ~loc d = Pat.mk ~loc:(make_loc loc) d -let mkexp ~loc d = Exp.mk ~loc:(make_loc loc) d +let mkexp ~loc ?attrs d = Exp.mk ~loc:(make_loc loc) ?attrs d let mkmty ~loc ?attrs d = Mty.mk ~loc:(make_loc loc) ?attrs d let mksig ~loc d = Sig.mk ~loc:(make_loc loc) d let mkmod ~loc ?attrs d = Mod.mk ~loc:(make_loc loc) ?attrs d @@ -201,9 +201,36 @@ let mkuplus ~oploc name arg = Pexp_prefix(mkoperator ~loc:oploc ("~" ^ name), arg) let mkpat_with_modes ~loc ~pat ~cty ~modes = + match pat.ppat_desc with + | Ppat_constraint (pat', cty', modes') -> + begin match cty, cty' with + | Some _, None -> + { pat with + ppat_desc = Ppat_constraint (pat', cty, modes @ modes'); + ppat_loc = make_loc loc + } + | None, _ -> + { pat with + ppat_desc = Ppat_constraint (pat', cty', modes @ modes'); + ppat_loc = make_loc loc + } + | _ -> + mkpat ~loc (Ppat_constraint (pat, cty, modes)) + end + | _ -> + begin match cty, modes with + | None, [] -> pat + | cty, modes -> mkpat ~loc (Ppat_constraint (pat, cty, modes)) + end + +let mkexp_constraint ~loc ~modes exp cty = match cty, modes with - | None, [] -> pat - | cty, modes -> mkpat ~loc (Ppat_constraint (pat, cty, modes)) + | None, [] -> exp + | cty, modes -> mkexp ~loc (Pexp_constraint (exp, cty, modes)) + +let ghexp_constraint ~loc ~modes exp cty = + let exp = mkexp_constraint ~loc ~modes exp cty in + { exp with pexp_loc = { exp.pexp_loc with loc_ghost = true }} let local_ext_loc = mknoloc "extension.local" @@ -225,28 +252,21 @@ let mktyp_stack typ = if Erase_jane_syntax.should_erase () then typ else {typ with ptyp_attributes = local_attr :: typ.ptyp_attributes} -let wrap_exp_stack exp = - if Erase_jane_syntax.should_erase () then exp else - {exp with pexp_attributes = local_attr :: exp.pexp_attributes} - -let mkexp_local_if p ~loc exp = - if p then mkexp_stack ~loc exp else exp - let mkpat_local_if p pat = if p then mkpat_stack pat else pat let mktyp_local_if p typ = if p then mktyp_stack typ else typ -let mktyp_modes modes = - (* Jane Street: This is horrible temporary code until we properly add - support for more modes. *) - let is_local = - match modes with - | [] -> false - | _ :: _ -> true - in - mktyp_local_if is_local +let split_local_from_attrs atrs = + match + List.partition (fun a -> + if a.attr_name.txt = local_ext_loc.txt + then true + else false ) atrs + with + | [], atrs -> (false, atrs) + | _ :: _, atrs -> (true, atrs) let exclave_ext_loc = mknoloc "extension.exclave" @@ -352,13 +372,7 @@ 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 ~modes e t = - match t with - | Pconstraint t -> Pexp_constraint(e, Some t, modes) - | Pcoerce(t1, t2) -> Pexp_coerce(e, t1, t2) -let mkexp_constraint ~loc ~modes e t = - mkexp ~loc (mkexp_desc_constraint ~modes e t) let erase_str_items str = if not (Erase_jane_syntax.should_erase ()) @@ -473,6 +487,21 @@ let removed_string_set loc = let not_expecting loc nonterm = raise Syntaxerr.(Error(Not_expecting(make_loc loc, nonterm))) +let mkexp_type_constraint_with_modes ?(ghost=false) ~loc ~modes ?ty e = + match ty with + | None -> + let mk = if ghost then ghexp_constraint else mkexp_constraint in + mk ~loc ~modes e None + | Some (Pconstraint t) -> + let mk = if ghost then ghexp_constraint else mkexp_constraint in + mk ~loc ~modes e (Some t) + | Some (Pcoerce(t1, t2)) -> + match modes with + | [] -> + let mk = if ghost then ghexp else mkexp ?attrs:None in + mk ~loc (Pexp_coerce(e, t1, t2)) + | _ :: _ -> not_expecting loc "mode annotations" + let mk_builtin_indexop_expr ~loc (pia_lhs, _dot, pia_paren, idx, pia_rhs) = mkexp ~loc (Pexp_indexop_access @@ -525,12 +554,14 @@ let mk_newtypes ~loc newtypes exp = List.fold_right (fun newtype exp -> mkexp (Pexp_newtype (newtype, exp))) newtypes exp -let wrap_type_annotation ~loc ~modes newtypes core_type body = - let mkexp, ghtyp = mkexp ~loc, ghtyp ~loc in +(* The [typloc] argument is used to adjust a location for something we're + parsing a bit differently than upstream. See comment about [Pvc_constraint] + in [let_binding_body_no_punning]. *) +let wrap_type_annotation ~loc ?(typloc=loc) ~modes newtypes core_type body = let mk_newtypes = mk_newtypes ~loc in - let exp = mkexp(Pexp_constraint(body,Some core_type,modes)) in + let exp = mkexp_constraint ~loc ~modes body (Some core_type) in let exp = mk_newtypes newtypes exp in - (exp, ghtyp(Ptyp_poly(newtypes, core_type))) + (exp, ghtyp ~loc:typloc (Ptyp_poly (newtypes, core_type))) let wrap_exp_attrs ~loc body (ext, attrs) = let ghexp = ghexp ~loc in @@ -637,6 +668,7 @@ type let_binding = lb_constraint: value_constraint option; lb_is_pun: bool; lb_modes: mode Location.loc list; + lb_local: bool; lb_attributes: attributes; lb_docs: docs Lazy.t; lb_text: text Lazy.t; @@ -647,13 +679,14 @@ type let_bindings' = lbs_rec: rec_flag; lbs_extension: string Asttypes.loc option } -let mklb first ~loc (p, e, typ, modes, is_pun) attrs = +let mklb first ~loc (p, e, typ, modes, local, is_pun) attrs = { lb_pattern = p; lb_expression = e; lb_constraint=typ; lb_is_pun = is_pun; lb_modes = modes; + lb_local = local; lb_attributes = attrs; lb_docs = symbol_docs_lazy loc; lb_text = (if first then empty_text_lazy @@ -679,6 +712,7 @@ let mk_let_bindings { lbs_bindings; lbs_rec; lbs_extension } = (fun lb -> Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes ~modes:lb.lb_modes + ~local:lb.lb_local ~docs:(Lazy.force lb.lb_docs) ~text:(Lazy.force lb.lb_text) ?value_constraint:lb.lb_constraint ~is_pun:lb.lb_is_pun @@ -756,20 +790,20 @@ let convert_jkind_to_legacy_attr = (* NOTE: An alternate approach for performing the erasure of %call_pos and %src_pos could have been doing it as a ppx transformation instead of performing the erasing inside of ocamlformat. *) -let erase_call_pos_pattern ~pattern ~arg_label ~loc = +let erase_call_pos_pattern ~arg_label ~default ~pattern ~loc = if not (Erase_jane_syntax.should_erase ()) - then arg_label, pattern, None + then arg_label, default, pattern else ( match arg_label, pattern.ppat_desc with | ( Labelled l , Ppat_constraint (pat, Some { ptyp_desc = Ptyp_extension ({ txt = "call_pos"; loc = _ }, _); _ }, _) ) -> ( Optional l - , pat , Some (Ast_helper.Exp.ident - { loc; txt = Ldot (Ldot (Lident "Stdlib", "Lexing"), "dummy_pos") }) ) - | _ -> arg_label, pattern, None) + { loc; txt = Ldot (Ldot (Lident "Stdlib", "Lexing"), "dummy_pos") }) + , pat) + | _ -> arg_label, default, pattern) ;; let erase_call_pos_type ~arg_label ~arg_type ~loc = @@ -1109,6 +1143,8 @@ The precedences must be listed from low to high. { mkexp ~loc:$sloc $1 } %inline mkpat(symb): symb { mkpat ~loc:$sloc $1 } +%inline mkpat_(symb): symb + { mkpat ~loc:$sloc $1 } %inline mktyp(symb): symb { mktyp ~loc:$sloc $1 } %inline mkstr(symb): symb @@ -1468,8 +1504,9 @@ functor_arg: LPAREN RPAREN { mkloc Unit (make_loc $sloc) } | (* An argument accompanied with an explicit type. *) - LPAREN x = mkrhs(module_name) COLON mty = module_type RPAREN - { mkloc (Named (x, mty)) (make_loc $sloc) } + LPAREN x = mkrhs(module_name) COLON mty_mm = module_type_with_optional_modes RPAREN + { let mty, mm = mty_mm in + mkloc (Named (x, mty, mm)) (make_loc $sloc) } ; module_name: @@ -1538,8 +1575,9 @@ module_expr: paren_module_expr: (* A module expression annotated with a module type. *) - LPAREN me = module_expr COLON mty = module_type RPAREN - { mkmod ~loc:$sloc (Pmod_constraint(me, mty)) } + LPAREN me = module_expr mty_mm = module_constraint RPAREN + { let mty, mm = mty_mm in + mkmod ~loc:$sloc (Pmod_constraint(me, mty, mm)) } | LPAREN module_expr COLON module_type error { unclosed "(" $loc($1) ")" $loc($5) } | (* A module expression within parentheses. *) @@ -1667,6 +1705,14 @@ structure_item: Pstr_module body } ; +%inline module_constraint: + COLON mty_mm = module_type_with_optional_modes + { let mty, mm = mty_mm in + (Some mty, mm) + } + | at_mode_expr + { (None, $1) } + (* The body (right-hand side) of a module binding. *) module_binding_body: EQUAL me = module_expr @@ -1674,8 +1720,10 @@ module_binding_body: | COLON error { expecting $loc($1) "=" } | mkmod( - COLON mty = module_type EQUAL me = module_expr - { Pmod_constraint(me, mty) } + mty_mm = module_constraint EQUAL me = module_expr + { + let mty, mm = mty_mm in + Pmod_constraint(me, mty, mm) } (* | arg_and_pos = functor_arg body = module_binding_body { let (_, arg) = arg_and_pos in @@ -1810,47 +1858,52 @@ open_description: /* Module types */ -module_type: +module_type_atomic: | SIG attrs = attributes s = signature END { mkmty ~loc:$sloc ~attrs (Pmty_signature s) } | SIG attributes signature error { unclosed "sig" $loc($1) "end" $loc($4) } | STRUCT error { expecting $loc($1) "sig" } + | LPAREN module_type RPAREN + { $2 } + | LPAREN module_type error + { unclosed "(" $loc($1) ")" $loc($3) } + + | mkmty( + mkrhs(mty_longident) + { Pmty_ident $1 } +/* | LPAREN MODULE mkrhs(mod_longident) RPAREN + { Pmty_alias $3 } */ + ) + { $1 } +; + +module_type: + | module_type_atomic { $1 } | FUNCTOR attrs = attributes args = nonempty_functor_args - MINUSGREATER mty = module_type + MINUSGREATER mty_mm = module_type_with_optional_modes %prec below_WITH - { let mty = - match attrs, mty with - | [], {pmty_desc= Pmty_functor (args', mty'); pmty_attributes= []; _} -> - Pmty_functor (args @ args', mty') - | [], {pmty_desc= Pmty_gen (loc, mty'); pmty_attributes= []; _} -> - Pmty_functor (args @ [mkloc Unit loc], mty') - | _ -> Pmty_functor (args, mty) - in + { let mty, mm = mty_mm in + let mty = Pmty_functor (args, mty, mm) in mkmty ~loc:$sloc ~attrs mty } | MODULE TYPE OF attributes module_expr %prec below_LBRACKETAT { mkmty ~loc:$sloc ~attrs:$4 (Pmty_typeof $5) } - | LPAREN module_type RPAREN - { $2 } - | LPAREN module_type error - { unclosed "(" $loc($1) ")" $loc($3) } | module_type attribute { Mty.attr $1 $2 } | mkmty( - mkrhs(mty_longident) - { Pmty_ident $1 } - | LPAREN RPAREN MINUSGREATER module_type - { let arg_loc = make_loc ($startpos($1), $endpos($2)) in - Pmty_gen(arg_loc, $4) } - | module_type MINUSGREATER module_type + functor_arg MINUSGREATER mty_mm = module_type_with_optional_modes + %prec below_WITH + { let mty, mm = mty_mm in + Pmty_functor([$1], mty, mm) } + | module_type_with_optional_modes MINUSGREATER module_type_with_optional_modes %prec below_WITH - { let arg_loc = make_loc $loc($1) in - Pmty_functor([mkloc (Named (mknoloc None, $1)) arg_loc], $3) } + { let mty0, mm0 = $1 in + let mty1, mm1 = $3 in + let arg_loc = make_loc $loc($1) in + Pmty_functor([mkloc (Named (mknoloc None, mty0, mm0)) arg_loc], mty1, mm1) } | module_type WITH separated_nonempty_llist(AND, with_constraint) { Pmty_with($1, $3) } -/* | LPAREN MODULE mkrhs(mod_longident) RPAREN - { Pmty_alias $3 } */ | module_type WITH mkrhs(mod_ext_longident) { Pmty_strengthen($1,$3) } | extension @@ -1858,6 +1911,11 @@ module_type: ) { $1 } ; + +%inline module_type_with_optional_modes: + | module_type { $1, [] } + | module_type_atomic at_mode_expr { $1, $2 } + (* A signature, which appears between SIG and END (among other places), is a list of signature elements. *) signature: @@ -1933,50 +1991,57 @@ signature_item: %inline module_declaration: MODULE ext = ext attrs1 = attributes - name_ = module_name_modal(at_modalities_expr) - args = functor_args - COLON - body = module_type + name_ = module_name_modal(atat_modalities_expr) + body = module_declaration_body( + module_type optional_atat_modalities_expr { ($1, $2) } + ) attrs2 = post_item_attributes { let attrs = Attr.ext_attrs ?ext ~before:attrs1 ~after:attrs2 () in let loc = make_loc $sloc in let docs = symbol_docs $sloc in - let name, modalities = name_ in - Md.mk name modalities args body ~attrs ~loc ~docs + let name, modalities' = name_ in + let args, ret_mty, ret_modes, modalities = + match body with + | Left (mty, modalities) -> [], mty, [], modalities + | Right (args, ret_mty, ret_modes) -> args, ret_mty, ret_modes, [] + in + let modalities = modalities' @ modalities in + Md.mk name modalities args ret_mty ret_modes ~attrs ~loc ~docs } ; -(* Module arguments are attached to declarations -(* The body (right-hand side) of a module declaration. *) -module_declaration_body: - COLON mty = module_type - { mty } +(* The body (right-hand side) of a module declaration. +Return [Left (mty, modalities)] if it has no parameter, +or [Right (args, ret_mty, ret_mode)] if it does. *) +module_declaration_body(module_type_with_optional_modal_expr): + COLON mty_mm = module_type_with_optional_modal_expr + { Either.Left mty_mm } | EQUAL error { expecting $loc($1) ":" } - | mkmty( - arg_and_pos = functor_arg body = module_declaration_body - { let (_, arg) = arg_and_pos in - Pmty_functor(arg, body) } - ) - { $1 } + | arg = functor_arg body = module_declaration_body(module_type_with_optional_modes) + { match body with + | Either.Left (mty, modes) -> Right ([arg], mty, modes) + | Either.Right (args, mty, modes) -> Right (arg :: args, mty, modes) + } ; -*) (* A module alias declaration (in a signature). *) %inline module_alias: MODULE ext = ext attrs1 = attributes - name_ = module_name_modal(at_modalities_expr) + name_ = module_name_modal(atat_modalities_expr) EQUAL body = module_expr_alias + modalities = optional_atat_modalities_expr attrs2 = post_item_attributes { let attrs = Attr.ext_attrs ?ext ~before:attrs1 ~after:attrs2 () in let loc = make_loc $sloc in let docs = symbol_docs $sloc in - let name, modalities = name_ in - Md.mk name modalities [] body ~attrs ~loc ~docs + let name, modalities' = name_ in + let modalities = modalities' @ modalities in + Md.mk name modalities [] body [] ~attrs ~loc ~docs } ; %inline module_expr_alias: @@ -2014,12 +2079,13 @@ MODULE name = mkrhs(module_name) COLON mty = module_type + modalities = optional_atat_modalities_expr attrs2 = post_item_attributes { let attrs = Attr.ext_attrs ?ext ~before:attrs1 ~after:attrs2 () in let loc = make_loc $sloc in let docs = symbol_docs $sloc in - Md.mk name [] [] mty ~attrs ~loc ~docs + Md.mk name modalities [] mty [] ~attrs ~loc ~docs } ; %inline and_module_declaration: @@ -2028,13 +2094,14 @@ MODULE name = mkrhs(module_name) COLON mty = module_type + modalities = optional_atat_modalities_expr attrs2 = post_item_attributes { let attrs = Attr.ext_attrs ~before:attrs1 ~after:attrs2 () in let docs = symbol_docs $sloc in let loc = make_loc $sloc in let text = symbol_text $symbolstartpos in - Md.mk name [] [] mty ~attrs ~loc ~text ~docs + Md.mk name modalities [] mty [] ~attrs ~loc ~text ~docs } ; @@ -2104,7 +2171,7 @@ class_fun_binding: COLON class_type EQUAL class_expr { Pcl_constraint($4, $2) } | labeled_simple_pattern class_fun_binding - { let (_, l,o,p) = $1 in Pcl_fun(l, o, p, $2) } + { let (l,o,p) = $1 in Pcl_fun(l, o, p, $2) } ) { $1 } ; @@ -2160,7 +2227,7 @@ class_fun_def: mkclass( labeled_simple_pattern MINUSGREATER e = class_expr | labeled_simple_pattern e = class_fun_def - { let (_, l,o,p) = $1 in Pcl_fun(l, o, p, e) } + { let (l,o,p) = $1 in Pcl_fun(l, o, p, e) } ) { $1 } ; %inline class_structure: @@ -2170,7 +2237,7 @@ class_fun_def: class_self_pattern: LPAREN pattern RPAREN { Some (reloc_pat ~loc:$sloc $2) } - | mkpat(LPAREN pattern COLON core_type RPAREN + | mkpat_(LPAREN pattern COLON core_type RPAREN { Ppat_constraint($2, Some $4, []) }) { Some $1 } | /* empty */ @@ -2217,7 +2284,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 ~modes:[] $7 $5 in + { let e = mkexp_type_constraint_with_modes ~loc:$sloc ~modes:[] $7 ~ty:$5 in ($4, mv_of_mut $3, Cfk_concrete ($1, e)), $2 } ; @@ -2448,70 +2515,33 @@ seq_expr: let payload = PStr [mkstrexp seq []] in mkexp ~loc:$sloc (Pexp_extension ($4, payload)) } ; -labeled_simple_pattern: - 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) } +labeled_simple_pattern_: + QUESTION LPAREN label_let_pattern opt_default RPAREN + { (Optional (mkrhs (fst $3) $sloc), $4, snd $3) } | QUESTION label_var - { false, mk_optional (fst $2) $sloc, None, snd $2 } - | 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) } + { (Optional (mkrhs (fst $2) $sloc), None, snd $2) } + | OPTLABEL LPAREN let_pattern opt_default RPAREN + { (Optional (mkrhs $1 $sloc), $4, $3) } | OPTLABEL pattern_var - { false, mk_optional $1 $sloc, None, $2 } - | 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 = - erase_call_pos_pattern - ~pattern:pat - ~arg_label:(mk_labelled lbl $sloc) - ~loc:(make_loc $sloc) - in - $3, arg_label, default_value, mkpat_local_if $3 pat - } + { (Optional (mkrhs $1 $sloc), None, $2) } + | TILDE LPAREN label_let_pattern RPAREN + { (Labelled (mkrhs (fst $3) $sloc), None, snd $3) } | TILDE label_var - { false, mk_labelled (fst $2) $sloc, None, snd $2 } - | LABEL simple_pattern - { let arg_label, pat, default_value = - erase_call_pos_pattern - ~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 = - erase_call_pos_pattern - ~pattern:(mkpat_stack $4) - ~arg_label:(mk_labelled $1 $sloc) - ~loc:(make_loc $sloc) - in - true, arg_label, default_value, pat } - | simple_pattern - { false, Nolabel, None, $1 } - | 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 } + { (Labelled (mkrhs (fst $2) $sloc), None, snd $2) } + | LABEL simple_pattern_extend_modes_or_poly + { (Labelled (mkrhs $1 $sloc), None, $2) } + | simple_pattern_extend_modes_or_poly + { (Nolabel, None, $1) } ; +labeled_simple_pattern: + labeled_simple_pattern_ { + let arg_label, default, pattern = $1 in + erase_call_pos_pattern ~arg_label ~default ~pattern ~loc:(make_loc $sloc) + } + pattern_var: - mkpat( + mkpat_( mkrhs(LIDENT) { Ppat_var $1 } | UNDERSCORE { Ppat_any } ) { $1 } @@ -2521,20 +2551,26 @@ pattern_var: preceded(EQUAL, seq_expr)? { $1 } ; -label_let_pattern: - 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, pat, Some cty, modes + +optional_poly_type_and_modes: + { None, [] } + | at_mode_expr + { None, $1 } + | COLON cty_mm = poly_type_with_optional_modes + { let cty, mm = cty_mm in + Some cty, mm } - | x = label_var COLON - cty = mktyp (vars = typevar_list DOT ty = core_type { Ptyp_poly (vars, ty) }) - modes = optional_atat_mode_expr +; + +label_let_pattern: + modes0 = optional_mode_expr_legacy x = label_var + cty_modes1 = optional_poly_type_and_modes { let lab, pat = x in - lab, pat, Some cty, modes + let cty, modes1 = cty_modes1 in + let loc = $startpos(modes0), $endpos(cty_modes1) in + let pat = mkpat_with_modes ~loc ~pat ~cty ~modes:modes1 in + let pat = mkpat_local_if modes0 pat in + lab, pat } ; %inline label_var: @@ -2542,22 +2578,44 @@ label_let_pattern: { ($1.Location.txt, mkpat ~loc:$sloc (Ppat_var $1)) } ; let_pattern: - 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 } + modes0 = optional_mode_expr_legacy pat = pattern + cty_modes1 = optional_poly_type_and_modes + { + let cty, modes1 = cty_modes1 in + let loc = $startpos(modes0), $endpos(cty_modes1) in + let pat = mkpat_with_modes ~loc ~pat ~cty ~modes:modes1 in + mkpat_local_if modes0 pat + } ; -%inline poly_pattern: - 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 } -; +(* simple_pattern extended with poly_type and modes *) +simple_pattern_extend_modes_or_poly: + simple_pattern { $1 } + | LPAREN pattern_with_modes_or_poly RPAREN + { $2 } + +pattern_with_modes_or_poly: + modes0 = mode_expr_legacy pat = pattern cty_modes1 = optional_poly_type_and_modes + { + let cty, modes1 = cty_modes1 in + let loc = $startpos(modes0), $endpos(cty_modes1) in + let pat = mkpat_with_modes ~loc ~pat ~cty:cty ~modes:modes1 in + let () = modes0 in + mkpat_local_if true pat + } + | pat = pattern COLON cty_modes = poly_type_with_modes + { + let cty, modes = cty_modes in + mkpat_with_modes ~loc:$sloc ~pat ~cty:(Some cty) ~modes + } + | pat = pattern modes = at_mode_expr + { + mkpat_with_modes ~loc:$sloc ~pat ~cty:None ~modes + } + | pat = pattern COLON cty = strictly_poly_type + { + mkpat_with_modes ~loc:$sloc ~pat ~cty:(Some cty) ~modes:[] + } %inline indexop_expr(dot, index, right): | array=simple_expr d=dot LPAREN i=index RPAREN r=right @@ -2714,8 +2772,8 @@ simple_expr: | LPAREN seq_expr error { unclosed "(" $loc($1) ")" $loc($3) } | LPAREN seq_expr type_constraint_with_modes RPAREN - { let t, m = $3 in - mkexp_constraint ~loc:$sloc ~modes:m $2 t } + { let ty, modes = $3 in + mkexp_type_constraint_with_modes ~ghost:true ~loc:$sloc ~modes $2 ~ty } | 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 @@ -2950,33 +3008,41 @@ 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) ~modes:[] - (mkexpvar ~loc:$loc(label) label) ty } + mkexp_type_constraint_with_modes ~loc:($startpos($2), $endpos) ~modes:[] + (mkexpvar ~loc:$loc(label) label) ~ty } | QUESTION label = LIDENT { let loc = $loc(label) in mk_optional label $sloc, mkexpvar ~loc label } | OPTLABEL simple_expr %prec below_HASH { mk_optional $1 $sloc, $2 } ; -%inline lident_list: - xs = mkrhs(LIDENT)+ - { xs } -; %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 + | COLON core_type_with_optional_modes { + let typ, mm = $2 in + Some(Pvc_constraint { locally_abstract_univars=[]; typ }), mm } ; + +%inline empty_list: { [] } + +%inline let_ident_with_modes: + optional_mode_expr_legacy let_ident + { (mkpat_local_if $1 $2, []) } + | LPAREN let_ident at_mode_expr RPAREN + { ($2, $3) } + let_binding_body_no_punning: - let_ident strict_binding - { ($1, $2, None, []) } - | optional_local let_ident constraint_ EQUAL seq_expr - { let v = $2 in (* PR#7344 *) - let typ, modes = $3 in + let_ident_with_modes strict_binding + { let v, modes = $1 in + (v, $2, None, modes) } + | let_ident_with_modes constraint_ EQUAL seq_expr + { let v, modes0 = $1 in + let typ, modes1 = $2 in + let modes = modes0 @ modes1 in let t = Option.map (function | Pconstraint typ -> @@ -2984,22 +3050,23 @@ let_binding_body_no_punning: | 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, t, modes) + (v, $4, t, modes) } - | 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 $7 in - (pat, exp, Some (Pvc_constraint { locally_abstract_univars = []; typ=t }), modes) + | let_ident_with_modes COLON strictly_poly_type_with_optional_modes EQUAL seq_expr + { let v, modes0 = $1 in + let typ, modes1 = $3 in + let modes = modes0 @ modes1 in + (v, $5, Some (Pvc_constraint { locally_abstract_univars = []; typ }), + modes) } - | let_ident COLON TYPE newtypes DOT core_type modes=optional_atat_mode_expr EQUAL seq_expr + | let_ident_with_modes COLON TYPE ntys = newtypes DOT cty = core_type modes1 = empty_list EQUAL e = seq_expr + | let_ident_with_modes COLON TYPE ntys = newtypes DOT cty = tuple_type modes1=at_mode_expr EQUAL e = seq_expr { let constraint' = - Pvc_constraint { locally_abstract_univars=$4; typ = $6} + Pvc_constraint { locally_abstract_univars=ntys; typ = cty} in - ($1, $9, Some constraint', modes) } + let v, modes0 = $1 in + let modes = modes0 @ modes1 in + (v, e, Some constraint', modes) } | pattern_no_exn EQUAL seq_expr { ($1, $3, None, []) } | simple_pattern_not_ident pvc_modes EQUAL seq_expr @@ -3007,19 +3074,16 @@ let_binding_body_no_punning: let pvc, modes = $2 in ($1, $4, pvc, modes) } - | LOCAL let_ident local_strict_binding - { ($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,modes = $1 in (p,e,c,modes,false) } + { let p,e,c,modes = $1 in + let islocal, ppat_attributes = split_local_from_attrs p.ppat_attributes in + let p = {p with ppat_attributes} in + (p,e,c,modes,islocal,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, [], false, 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 @@ -3080,8 +3144,9 @@ letop_bindings: fun_binding: strict_binding { $1 } - | type_constraint EQUAL seq_expr - { mkexp_constraint ~loc:$sloc ~modes:[] $3 $1 } + | constraint_ EQUAL seq_expr + { let ty, modes = $1 in + mkexp_type_constraint_with_modes ~loc:$sloc ~modes $3 ?ty } ; strict_binding: EQUAL seq_expr @@ -3095,27 +3160,6 @@ strict_binding: RPAREN fun_binding { mk_newtypes ~loc:$sloc [name, jkind] $7 } ; -local_fun_binding: - local_strict_binding - { $1 } - | type_constraint EQUAL seq_expr - { wrap_exp_stack (mkexp_constraint ~loc:$sloc ~modes:[] $3 $1) } -; -local_strict_binding: - EQUAL seq_expr - { $2 } - | labeled_simple_pattern local_fun_binding - { - let is_local, l, o, p = $1 in - let pparam = { pparam_loc = make_loc $sloc; pparam_desc = Pparam_val (is_local, l, o, p) } in - ghexp ~loc:$sloc (Pexp_fun(pparam, $2)) } - | LPAREN TYPE newtypes RPAREN local_fun_binding - { mk_newtypes ~loc:$sloc $3 $5 } - | LPAREN TYPE - name=mkrhs(LIDENT {Some $1}) COLON jkind=jkind_annotation - RPAREN fun_binding - { mk_newtypes ~loc:$sloc [name, jkind] $7 } -; %inline match_cases: xs = preceded_or_separated_nonempty_llist(BAR, match_case) { xs } @@ -3130,15 +3174,22 @@ match_case: ; fun_param: | labeled_simple_pattern - { let is_local, l, o, p = $1 in - { pparam_loc = make_loc $sloc; pparam_desc = Pparam_val (is_local, l, o, p) } } + { let l, o, p = $1 in + let islocal, ppat_attributes = split_local_from_attrs p.ppat_attributes in + let p = {p with ppat_attributes} in + { pparam_loc = make_loc $sloc; pparam_desc = Pparam_val (islocal, l, o, p) } } +; +optional_atomic_constraint_: + | COLON atomic_type { (Some (Pconstraint $2), [])} + | at_mode_expr { (None, $1)} + | { (None, []) } ; fun_def: - MINUSGREATER seq_expr - { $2 } - | mkexp(COLON atomic_type MINUSGREATER seq_expr - { Pexp_constraint ($4, Some $2, []) }) - { $1 } + optional_atomic_constraint_ MINUSGREATER seq_expr + { + let ty, modes = $1 in + mkexp_type_constraint_with_modes ~ghost:true ~loc:$sloc ~modes $3 ?ty + } /* Cf #5939: we used to accept (fun p when e0 -> e) */ | fun_param fun_def { ghexp ~loc:$sloc (Pexp_fun($1, $2)) } @@ -3195,8 +3246,8 @@ fun_def: | TILDE LPAREN label = LIDENT ty = type_constraint RPAREN %prec below_HASH { let lbl = ghrhs label $loc(label) in Some lbl, - mkexp_constraint - ~loc:($startpos($2), $endpos) ~modes:[] (mkexpvar ~loc:$loc(label) label) ty } + mkexp_type_constraint_with_modes + ~loc:($startpos($2), $endpos) ~modes:[] (mkexpvar ~loc:$loc(label) label) ~ty } ; reversed_labeled_tuple_body: (* > 2 elements *) @@ -3224,8 +3275,8 @@ reversed_labeled_tuple_body: COMMA x2 = labeled_tuple_element { let x1 = - mkexp_constraint - ~loc:($startpos($2), $endpos) ~modes:[] (mkexpvar ~loc:$loc(l1) l1) ty1 + mkexp_type_constraint_with_modes + ~loc:($startpos($2), $endpos) ~modes:[] (mkexpvar ~loc:$loc(l1) l1) ~ty:ty1 in let label = ghrhs l1 $loc(l1) in [ x2; Some label, x1] } @@ -3244,7 +3295,7 @@ record_expr_content: | label = mkrhs(label_longident) c = type_constraint? eo = preceded(EQUAL, expr)? - { label, c, eo } + { label, (c : type_constraint option), eo } ; %inline object_expr_content: xs = separated_or_terminated_nonempty_list(SEMI, object_expr_field) @@ -3267,7 +3318,7 @@ record_expr_content: es = separated_or_terminated_nonempty_list(SEMI, expr) { es } ; -type_constraint: +type_constraint: (* : type_constraint *) | COLON core_type { Pconstraint $2 } | COLON core_type COLONGREATER core_type { Pcoerce (Some $2, $4) } | COLONGREATER core_type { Pcoerce (None, $2) } @@ -3276,8 +3327,17 @@ type_constraint: ; %inline type_constraint_with_modes: - | type_constraint optional_atat_mode_expr - { $1, $2 } + | COLON core_type_with_optional_modes { + let cty, mm = $2 in + Pconstraint cty, mm } + | COLON core_type COLONGREATER core_type_with_optional_modes { + let cty, mm = $4 in + Pcoerce (Some $2, cty), mm } + | COLONGREATER core_type_with_optional_modes { + let cty, mm = $2 in + Pcoerce (None, cty), mm } + | COLON error { syntax_error() } + | COLONGREATER error { syntax_error() } ; %inline constraint_: @@ -3343,7 +3403,7 @@ pattern_no_exn: { Pat.attr $1 $2 } | pattern_gen { $1 } - | mkpat( + | mkpat_( self AS mkrhs(val_ident) { Ppat_alias($1, $3) } | self AS error @@ -3429,12 +3489,16 @@ reversed_labeled_tuple_pattern(self): pattern_gen: simple_pattern { $1 } - | mkpat( + | mkpat_( mkrhs(constr_longident) pattern %prec prec_constr_appl { Ppat_construct($1, Some ([], $2)) } - | constr=mkrhs(constr_longident) LPAREN TYPE newtypes=lident_list RPAREN + | constr=mkrhs(constr_longident) LPAREN TYPE newtypes=newtypes RPAREN pat=simple_pattern { Ppat_construct(constr, Some (newtypes, pat)) } + | constr=mkrhs(constr_longident) + LPAREN TYPE ty=mkrhs(LIDENT {Some $1}) COLON jkind=jkind_annotation RPAREN + pat=simple_pattern + { Ppat_construct(constr, Some ([(ty,jkind)], pat)) } | name_tag pattern %prec prec_constr_appl { Ppat_variant($1, Some $2) } ) { $1 } @@ -3442,7 +3506,7 @@ pattern_gen: { mkpat_attrs ~loc:$sloc (Ppat_lazy $3) $2} ; simple_pattern: - mkpat(mkrhs(val_ident) %prec below_EQUAL + mkpat_(mkrhs(val_ident) %prec below_EQUAL { Ppat_var ($1) }) { $1 } | simple_pattern_not_ident { $1 } @@ -3457,11 +3521,12 @@ simple_pattern_not_ident: { mkpat_attrs ~loc:$sloc (Ppat_unpack ($4, None)) $3 } | LPAREN MODULE ext_attributes mkrhs(module_name) COLON package_type RPAREN { mkpat_attrs ~loc:$sloc (Ppat_unpack ($4, Some $6)) $3 } - | mkpat(simple_pattern_not_ident_) + | simple_pattern_not_ident_ { $1 } ; %inline simple_pattern_not_ident_: - | UNDERSCORE + mkpat ( + UNDERSCORE { Ppat_any } | signed_constant { Ppat_constant $1 } @@ -3496,14 +3561,9 @@ simple_pattern_not_ident: { unclosed "(" $loc($1) ")" $loc($7) } | extension { Ppat_extension $1 } - | LPAREN sub_pat=pattern modes=at_mode_expr RPAREN - { match modes with - | [] -> - (* This is possible when we are erasing jane syntax *) - sub_pat.ppat_desc - | modes -> Ppat_constraint(sub_pat, None, modes) } - | LPAREN pattern COLON core_type modes=optional_atat_mode_expr RPAREN - { Ppat_constraint($2, Some $4, modes) } + ) { $1 } + | LPAREN pattern COLON core_type RPAREN + { mkpat_with_modes ~loc:$sloc ~pat:$2 ~cty:(Some $4) ~modes:[] } ; simple_delimited_pattern: @@ -4073,16 +4133,50 @@ with_type_binder: typevar_list DOT X { Ptyp_poly($1, $3) } ; +%inline strictly_poly(X): +| mktyp(poly(X)) + { $1 } +; + possibly_poly(X): X { $1 } -| mktyp(poly(X)) +| strictly_poly(X) { $1 } ; %inline poly_type: possibly_poly(core_type) { $1 } ; + +%inline strictly_poly_type: + strictly_poly(core_type) + { $1 } +; + +%inline strictly_poly_tuple_type: + strictly_poly(tuple_type) + { $1 } + +%inline poly_tuple_type: + | tuple_type { $1 } + | strictly_poly_tuple_type { $1 } +; + +%inline poly_type_with_modes: + | poly_tuple_type at_mode_expr { $1, $2 } +; + +%inline poly_type_with_optional_modes: + | poly_type_with_modes { $1 } + | poly_type { $1, [] } +; + +%inline strictly_poly_type_with_optional_modes: + | strictly_poly_type { $1, [] } + | strictly_poly_tuple_type at_mode_expr { $1, $2 } +; + %inline poly_type_no_attr: possibly_poly(core_type_no_attr) { $1 } @@ -4101,6 +4195,10 @@ core_type: { Typ.attr $1 $2 } ; +%inline core_type_with_optional_modes: + core_type { $1, [] } + | tuple_type at_mode_expr { $1, $2 } + (* A core type without attributes is currently defined as an alias type, but this could change in the future if new forms of types are introduced. From the outside, one should use core_type_no_attr. *) @@ -4150,12 +4248,11 @@ function_type: strict_function_or_labeled_tuple_type: | mktyp( label = arg_label - local = mode_flags domain_with_modes = with_optional_mode_expr(extra_rhs(param_type)) MINUSGREATER codomain = strict_function_or_labeled_tuple_type - { let (domain, _), arg_modes = domain_with_modes in - let type_ = mktyp_modes local domain in + { let local, (domain, _), arg_modes = domain_with_modes in + let type_ = mktyp_local_if local domain in let loc = make_loc $sloc in let label, type_ = erase_call_pos_type @@ -4181,14 +4278,12 @@ strict_function_or_labeled_tuple_type: { $1 } | mktyp( label = arg_label - arg_local = mode_flags domain_with_modes = with_optional_mode_expr(extra_rhs(param_type)) MINUSGREATER - ret_local = mode_flags codomain_with_modes = with_optional_mode_expr(tuple_type) %prec MINUSGREATER - { let (domain, _), arg_modes = domain_with_modes in - let (codomain, _), ret_modes = codomain_with_modes in + { let arg_local, (domain, _), arg_modes = domain_with_modes in + let ret_local, (codomain, _), ret_modes = codomain_with_modes in let loc = make_loc $sloc in let label, domain = erase_call_pos_type @@ -4199,12 +4294,12 @@ strict_function_or_labeled_tuple_type: let arrow_type = { pap_label = label; pap_loc = make_loc $sloc; - pap_type = mktyp_modes arg_local domain; + pap_type = mktyp_local_if arg_local domain; pap_modes = arg_modes } in let codomain = - mktyp_modes ret_local (maybe_curry_typ codomain) + mktyp_local_if ret_local (maybe_curry_typ codomain) in Ptyp_arrow([arrow_type], codomain, ret_modes) } @@ -4224,12 +4319,11 @@ strict_function_or_labeled_tuple_type: cases we are in. *) | mktyp( label = LIDENT COLON - unique_local = mode_flags 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 local, (tuple, tuple_loc), arg_modes = tuple_with_modes in let ty, ltys = tuple in let label = mk_labelled label $loc(label) in let domain = @@ -4239,7 +4333,7 @@ strict_function_or_labeled_tuple_type: let arrow_type = { pap_label = label; pap_loc = make_loc $sloc; - pap_type = mktyp_modes unique_local domain; + pap_type = mktyp_local_if local domain; pap_modes = arg_modes } in @@ -4253,14 +4347,12 @@ strict_function_or_labeled_tuple_type: { $1 } | mktyp( label = LIDENT COLON - arg_unique_local = mode_flags tuple_with_modes = with_optional_mode_expr(proper_tuple_type) MINUSGREATER - ret_unique_local = mode_flags 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 arg_local, (tuple, tuple_loc), arg_modes = tuple_with_modes in + let ret_local, (codomain, _), ret_modes = codomain_with_modes in let ty, ltys = tuple in let label = mk_labelled label $loc(label) in let domain = @@ -4270,12 +4362,12 @@ strict_function_or_labeled_tuple_type: let arrow_type = { pap_label = label; pap_loc = make_loc $sloc; - pap_type = mktyp_modes arg_unique_local domain; + pap_type = mktyp_local_if arg_local domain; pap_modes = arg_modes } in Ptyp_arrow([arrow_type], - mktyp_modes ret_unique_local (maybe_curry_typ codomain), + mktyp_local_if ret_local (maybe_curry_typ codomain), ret_modes) } ) @@ -4303,21 +4395,16 @@ strict_function_or_labeled_tuple_type: | /* empty */ { Nolabel } ; -%inline optional_local: - | /* empty */ - { false } +/* Legacy mode annotations */ +%inline mode_expr_legacy: | LOCAL - { true } -; -(* jane street: hackily copied and modified from our parser - to be replaced with the - exact version from our parser when ocamlformat is updated for uniqueness. *) -%inline mode_flag: - | LOCAL - { $sloc } + { () } ; -%inline mode_flags: - | flags = iloption(mode_flag+) - { flags } +%inline optional_mode_expr_legacy: + | /* empty */ + { false } + | mode_expr_legacy + {let () = $1 in true} ; /* New mode annotation, introduced by AT or ATAT */ @@ -4349,21 +4436,11 @@ at_mode_expr: ; %inline with_optional_mode_expr(ty): - | ty=ty m=optional_at_mode_expr { - (ty, $loc(ty)), m + | m0=optional_mode_expr_legacy ty=ty m1=optional_at_mode_expr { + m0, (ty, $loc(ty)), m1 } ; -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: @@ -4381,16 +4458,16 @@ atat_mode_expr: $1 } -at_modalities_expr: - | AT modalities {$2} - | AT error { expecting $loc($2) "modality expression" } +atat_modalities_expr: + | ATAT modalities {$2} + | ATAT error { expecting $loc($2) "modality expression" } ; optional_atat_modalities_expr: | %prec below_HASH { [] } - | ATAT modalities { $2 } - | ATAT error { expecting $loc($2) "modality expression" } + | atat_modalities_expr + { $1 } ; %inline stack(exp): diff --git a/vendor/parser-extended/parsetree.mli b/vendor/parser-extended/parsetree.mli index a307b265fc..5a1a7ddc26 100644 --- a/vendor/parser-extended/parsetree.mli +++ b/vendor/parser-extended/parsetree.mli @@ -308,7 +308,7 @@ and pattern_desc = - If Closed, [n >= 2] - If Open, [n >= 1] *) - | Ppat_construct of Longident.t loc * (string loc list * pattern) option + | Ppat_construct of Longident.t loc * (ty_var list * pattern) option (** [Ppat_construct(C, args)] represents: - [C] when [args] is [None], - [C P] when [args] is [Some ([], P)] @@ -1034,10 +1034,8 @@ and module_type = and module_type_desc = | Pmty_ident of Longident.t loc (** [Pmty_ident(S)] represents [S] *) | Pmty_signature of signature (** [sig ... end] *) - | Pmty_functor of functor_parameter loc list * module_type - (** [functor (X1 : MT1) ... (Xn : MTn) -> MT] *) - | Pmty_gen of Location.t * module_type - (** [() -> MT] *) + | Pmty_functor of functor_parameter loc list * module_type * modes + (** [functor (X1 : MT1) ... (Xn : MTn) -> MT @ MM] *) | Pmty_with of module_type * with_constraint list (** [MT with ...] *) | Pmty_typeof of module_expr (** [module type of ME] *) | Pmty_extension of extension (** [[%id]] *) @@ -1046,10 +1044,10 @@ and module_type_desc = and functor_parameter = | Unit (** [()] *) - | Named of string option loc * module_type - (** [Named(name, MT)] represents: - - [(X : MT)] when [name] is [Some X], - - [(_ : MT)] when [name] is [None] *) + | Named of string option loc * module_type * modes + (** [Named(name, MT, MM)] represents: + - [(X : MT @ MM)] when [name] is [Some X], + - [(_ : MT @ MM)] when [name] is [None] *) and signature = { @@ -1098,6 +1096,7 @@ and module_declaration = pmd_modalities: modalities; pmd_args: functor_parameter loc list; pmd_type: module_type; + pmd_mode: modes; pmd_ext_attrs : ext_attrs; pmd_loc: Location.t; } @@ -1199,7 +1198,11 @@ and module_expr_desc = | Pmod_apply of module_expr * module_expr (** [ME1(ME2)] *) | Pmod_apply_unit of module_expr * Location.t (** [ME1()]. The location argument correspond to the [()]. *) - | Pmod_constraint of module_expr * module_type (** [(ME : MT)] *) + | Pmod_constraint of module_expr * module_type option * modes + (** - [(ME : MT @ modes)] + - [(ME @ modes)] + - [(ME : MT)] + *) | Pmod_unpack of expression * package_type option * package_type option (** [(val E : M1 :> M2)] *) | Pmod_extension of extension (** [[%id]] *) @@ -1266,7 +1269,10 @@ and value_binding = pvb_pat: pattern; pvb_expr: expression; pvb_constraint: value_constraint option; - pvb_modes: mode loc list; + (** the modes on the bound value (not the RHS) *) + pvb_modes: modes; + (** the local_ on the bound value (not the RHS) *) + pvb_local: bool; 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 357b38d553..5655bd5e95 100644 --- a/vendor/parser-extended/printast.ml +++ b/vendor/parser-extended/printast.ml @@ -342,7 +342,7 @@ and pattern i ppf x = line i ppf "Ppat_construct %a\n" fmt_longident_loc li; option i (fun i ppf (vl, p) -> - list i string_loc ppf vl; + list i typevar ppf vl; pattern i ppf p) ppf po | Ppat_variant (l, po) -> @@ -974,9 +974,10 @@ and functor_parameter i ppf x = match x.txt with | Unit -> line i ppf "Unit\n" - | Named (s, mt) -> + | Named (s, mt, mm) -> line i ppf "Named %a\n" fmt_str_opt_loc s; - module_type i ppf mt + module_type i ppf mt; + modes i ppf mm and module_type i ppf x = line i ppf "module_type %a\n" fmt_location x.pmty_loc; @@ -988,13 +989,11 @@ and module_type i ppf x = | Pmty_signature (s) -> line i ppf "Pmty_signature\n"; signature i ppf s; - | Pmty_functor (params, mt) -> + | Pmty_functor (params, mt, mm) -> line i ppf "Pmty_functor\n"; list i functor_parameter ppf params; - module_type i ppf mt - | Pmty_gen (loc, mt) -> - line i ppf "Pmty_gen %a\n" fmt_location loc; - module_type i ppf mt + module_type i ppf mt; + modes i ppf mm | Pmty_with (mt, l) -> line i ppf "Pmty_with\n"; module_type i ppf mt; @@ -1121,10 +1120,11 @@ and module_expr i ppf x = line i ppf "Pmod_apply\n"; module_expr i ppf me1; module_expr i ppf me2; - | Pmod_constraint (me, mt) -> + | Pmod_constraint (me, mt, mm) -> line i ppf "Pmod_constraint\n"; module_expr i ppf me; - module_type i ppf mt; + Option.iter (module_type i ppf) mt; + modes i ppf mm | Pmod_unpack (e, ty1, ty2) -> line i ppf "Pmod_unpack\n"; expression i ppf e; diff --git a/vendor/parser-jane/for-ocaml-common/warnings.ml b/vendor/parser-jane/for-ocaml-common/warnings.ml index 0ea3da8d5b..66237c1fe0 100644 --- a/vendor/parser-jane/for-ocaml-common/warnings.ml +++ b/vendor/parser-jane/for-ocaml-common/warnings.ml @@ -130,7 +130,7 @@ type t = | Unchecked_zero_alloc_attribute (* 199 *) | Unboxing_impossible (* 210 *) | Mod_by_top of string (* 211 *) - | Unnecessary_allow_any_kind (* 212 *) + (* 212 taken *) (* If you remove a warning, leave a hole in the numbering. NEVER change the numbers of existing warnings. @@ -220,7 +220,6 @@ let number = function | Unchecked_zero_alloc_attribute -> 199 | Unboxing_impossible -> 210 | Mod_by_top _ -> 211 - | Unnecessary_allow_any_kind -> 212 ;; (* DO NOT REMOVE the ;; above: it is used by the testsuite/ests/warnings/mnemonics.mll test to determine where @@ -601,11 +600,6 @@ let descriptions = [ names = ["mod-by-top"]; description = "Including the top-most element of an axis in a kind's modifiers is a no-op."; since = since 4 14 }; - { number = 212; - names = ["unnecessary-allow-any-kind"]; - description = "[@@unsafe_allow_any_kind_in_{impl,intf}] attributes included \ - on a type and a signature with matching kinds"; - since = since 5 1 }; ] let name_to_number = @@ -1257,10 +1251,6 @@ let message = function "%s is the top-most modifier.\n\ Modifying by a top element is a no-op." modifier - | Unnecessary_allow_any_kind -> - Printf.sprintf - "[@@allow_any_kind_in_intf] and [@@allow_any_kind_in_impl] set on a \n\ - type, but the kind matches. The attributes can be removed." ;; let nerrors = ref 0 diff --git a/vendor/parser-jane/for-ocaml-common/warnings.mli b/vendor/parser-jane/for-ocaml-common/warnings.mli index 3da8d8db77..71d8c676b1 100644 --- a/vendor/parser-jane/for-ocaml-common/warnings.mli +++ b/vendor/parser-jane/for-ocaml-common/warnings.mli @@ -136,7 +136,6 @@ type t = | Unchecked_zero_alloc_attribute (* 199 *) | Unboxing_impossible (* 210 *) | Mod_by_top of string (* 211 *) - | Unnecessary_allow_any_kind (* 212 *) type alert = {kind:string; message:string; def:loc; use:loc} diff --git a/vendor/parser-jane/for-parser-standard/ast_mapper.ml b/vendor/parser-jane/for-parser-standard/ast_mapper.ml index b6c2557984..e909abc2aa 100644 --- a/vendor/parser-jane/for-parser-standard/ast_mapper.ml +++ b/vendor/parser-jane/for-parser-standard/ast_mapper.ml @@ -649,7 +649,12 @@ module P = struct | Ppat_construct (l, p) -> construct ~loc ~attrs (map_loc sub l) (map_opt - (fun (vl, p) -> List.map (map_loc sub) vl, sub.pat sub p) + (fun (vl, p) -> + List.map + (fun (v, jk) -> + map_loc sub v, Option.map (sub.jkind_annotation sub) jk) + vl, + sub.pat sub p) p) | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) | Ppat_record (lpl, cf) -> diff --git a/vendor/parser-jane/for-parser-standard/parser.mly b/vendor/parser-jane/for-parser-standard/parser.mly index 32b4282857..cf0941671b 100644 --- a/vendor/parser-jane/for-parser-standard/parser.mly +++ b/vendor/parser-jane/for-parser-standard/parser.mly @@ -777,6 +777,18 @@ let mkfunction ~loc ~attrs params body_constraint body = attrs end +let mk_functor_typ args mty_mm = + let mty, _ = + List.fold_left (fun (mty, mm) (startpos, arg) -> + let mty = + mkmty ~loc:(startpos, mty.pmty_loc.loc_end) (Pmty_functor (arg, mty, mm)) + in + let mm = [] in + mty, mm) + mty_mm args + in + mty + (* Alternatively, we could keep the generic module type in the Parsetree and extract the package type during type-checking. In that case, the assertions below should be turned into explicit checks. *) @@ -1601,8 +1613,9 @@ functor_arg: LPAREN RPAREN { $startpos, Unit } | (* An argument accompanied with an explicit type. *) - LPAREN x = mkrhs(module_name) COLON mty = module_type mm = optional_atat_mode_expr RPAREN - { $startpos, Named (x, mty, mm) } + LPAREN x = mkrhs(module_name) COLON mty_mm = module_type_with_optional_modes RPAREN + { let mty, mm = mty_mm in + $startpos, Named (x, mty, mm) } ; module_name: @@ -1671,10 +1684,9 @@ module_expr: paren_module_expr: (* A module expression annotated with a module type. *) - LPAREN me = module_expr COLON mty = module_type mm = optional_atat_mode_expr RPAREN - { mkmod ~loc:$sloc (Pmod_constraint(me, Some mty, mm)) } - | LPAREN me = module_expr mm = at_mode_expr RPAREN - { mkmod ~loc:$sloc (Pmod_constraint(me, None, mm)) } + LPAREN me = module_expr mty_mm = module_constraint RPAREN + { let mty, mm = mty_mm in + mkmod ~loc:$sloc (Pmod_constraint(me, mty, mm)) } | LPAREN module_expr COLON module_type error { unclosed "(" $loc($1) ")" $loc($5) } | (* A module expression within parentheses. *) @@ -1803,6 +1815,14 @@ structure_item: Pstr_module body, ext } ; +%inline module_constraint: + COLON mty_mm = module_type_with_optional_modes + { let mty, mm = mty_mm in + (Some mty, mm) + } + | at_mode_expr + { (None, $1) } + (* The body (right-hand side) of a module binding. *) module_binding_body: EQUAL me = module_expr @@ -1810,10 +1830,10 @@ module_binding_body: | COLON error { expecting $loc($1) "=" } | mkmod( - COLON mty = module_type mm = optional_atat_mode_expr EQUAL me = module_expr - { Pmod_constraint(me, Some mty, mm) } - | mm = at_mode_expr EQUAL me = module_expr - { Pmod_constraint(me, None, mm) } + mty_mm = module_constraint EQUAL me = module_expr + { + let mty, mm = mty_mm in + Pmod_constraint(me, mty, mm) } | arg_and_pos = functor_arg body = module_binding_body { let (_, arg) = arg_and_pos in Pmod_functor(arg, body) } @@ -1952,48 +1972,48 @@ open_description: /* Module types */ -module_type: +module_type_atomic: | SIG attrs = attributes s = signature END { mkmty ~loc:$sloc ~attrs (Pmty_signature s) } | SIG attributes signature error { unclosed "sig" $loc($1) "end" $loc($4) } | STRUCT error { expecting $loc($1) "sig" } - | FUNCTOR attrs = attributes args = functor_args - MINUSGREATER mty = module_type mm = optional_at_mode_expr - %prec below_WITH - { wrap_mty_attrs ~loc:$sloc attrs ( - (* return modes go to the innermost functor arrow; - all other return modes are empty *) - let mty, mm = - List.fold_left (fun (acc, mm) (startpos, arg) -> - mkmty ~loc:(startpos, $endpos) (Pmty_functor (arg, acc, mm)), [] - ) (mty, mm) args - in - match mm with - | [] -> mty - | _ :: _ -> assert false - ) } - | MODULE TYPE OF attributes module_expr %prec below_LBRACKETAT - { mkmty ~loc:$sloc ~attrs:$4 (Pmty_typeof $5) } | LPAREN module_type RPAREN { $2 } | LPAREN module_type error { unclosed "(" $loc($1) ")" $loc($3) } - | module_type attribute - { Mty.attr $1 $2 } | mkmty( mkrhs(mty_longident) { Pmty_ident $1 } - | LPAREN RPAREN MINUSGREATER module_type optional_at_mode_expr - { Pmty_functor(Unit, $4, $5) } - | module_type m1=optional_at_mode_expr MINUSGREATER module_type m2=optional_at_mode_expr +/* | LPAREN MODULE mkrhs(mod_longident) RPAREN + { Pmty_alias $3 } */ + ) + { $1 } +; + +module_type: + | module_type_atomic { $1 } + | FUNCTOR attrs = attributes args = functor_args + MINUSGREATER mty_mm = module_type_with_optional_modes + %prec below_WITH + { wrap_mty_attrs ~loc:$sloc attrs (mk_functor_typ args mty_mm) } + | args = functor_args + MINUSGREATER mty_mm = module_type_with_optional_modes + %prec below_WITH + { mk_functor_typ args mty_mm } + | MODULE TYPE OF attributes module_expr %prec below_LBRACKETAT + { mkmty ~loc:$sloc ~attrs:$4 (Pmty_typeof $5) } + | module_type attribute + { Mty.attr $1 $2 } + | mkmty( + module_type_with_optional_modes MINUSGREATER module_type_with_optional_modes %prec below_WITH - { Pmty_functor(Named (mknoloc None, $1, m1), $4, m2) } + { let mty0, mm0 = $1 in + let mty1, mm1 = $3 in + Pmty_functor(Named (mknoloc None, mty0, mm0), mty1, mm1) } | module_type WITH separated_nonempty_llist(AND, with_constraint) { Pmty_with($1, $3) } -/* | LPAREN MODULE mkrhs(mod_longident) RPAREN - { Pmty_alias $3 } */ | extension { Pmty_extension $1 } | module_type WITH mkrhs(mod_ext_longident) @@ -2001,6 +2021,11 @@ module_type: ) { $1 } ; + +%inline module_type_with_optional_modes: + | module_type { $1, [] } + | module_type_atomic at_mode_expr { $1, $2 } + (* A signature, which appears between SIG and END (among other places), is a list of signature elements. *) signature: @@ -2076,8 +2101,10 @@ signature_item: %inline module_declaration: MODULE ext = ext attrs1 = attributes - name_ = module_name_modal(at_modalities_expr) - body = module_declaration_body(optional_atat_modalities_expr) + name_ = module_name_modal(atat_modalities_expr) + body = module_declaration_body( + module_type optional_atat_modalities_expr { ($1, $2) } + ) attrs2 = post_item_attributes { let attrs = attrs1 @ attrs2 in @@ -2091,13 +2118,13 @@ signature_item: ; (* The body (right-hand side) of a module declaration. *) -module_declaration_body(optional_atat_modal_expr): - COLON mty = module_type mm = optional_atat_modal_expr - { mty, mm } +module_declaration_body(module_type_with_optional_modal_expr): + COLON mty_mm = module_type_with_optional_modal_expr + { mty_mm } | EQUAL error { expecting $loc($1) ":" } | mkmty( - arg_and_pos = functor_arg body = module_declaration_body(optional_atat_mode_expr) + arg_and_pos = functor_arg body = module_declaration_body(module_type_with_optional_modes) { let (_, arg) = arg_and_pos in let (ret, mret) = body in Pmty_functor(arg, ret, mret) } @@ -2109,10 +2136,10 @@ module_declaration_body(optional_atat_modal_expr): %inline module_alias: MODULE ext = ext attrs1 = attributes - name_ = module_name_modal(at_modalities_expr) + name_ = module_name_modal(atat_modalities_expr) EQUAL body = module_expr_alias - modalities = optional_at_modalities_expr + modalities = optional_atat_modalities_expr attrs2 = post_item_attributes { let attrs = attrs1 @ attrs2 in @@ -2619,73 +2646,22 @@ seq_expr: ; labeled_simple_pattern: - QUESTION LPAREN modes0=optional_mode_expr_legacy x=label_let_pattern opt_default RPAREN - { let lbl, pat, cty, modes = x in - let loc = $startpos(modes0), $endpos(x) in - (Optional lbl, $5, - mkpat_with_modes ~loc ~pat ~cty ~modes:(modes0 @ modes)) - } + QUESTION LPAREN label_let_pattern opt_default RPAREN + { (Optional (fst $3), $4, snd $3) } | QUESTION label_var { (Optional (fst $2), None, snd $2) } - | OPTLABEL LPAREN modes0=optional_mode_expr_legacy x=let_pattern opt_default RPAREN - { let pat, cty, modes = x in - let loc = $startpos(modes0), $endpos(x) in - (Optional $1, $5, - mkpat_with_modes ~loc ~pat ~cty ~modes:(modes0 @ modes)) - } + | OPTLABEL LPAREN let_pattern opt_default RPAREN + { (Optional $1, $4, $3) } | OPTLABEL pattern_var { (Optional $1, None, $2) } - | TILDE LPAREN modes0=optional_mode_expr_legacy x=label_let_pattern RPAREN - { let lbl, pat, cty, modes = x in - let loc = $startpos(modes0), $endpos(x) in - (Labelled lbl, None, - mkpat_with_modes ~loc ~pat ~cty ~modes:(modes0 @ modes)) - } + | TILDE LPAREN label_let_pattern RPAREN + { (Labelled (fst $3), None, snd $3) } | TILDE label_var { (Labelled (fst $2), None, snd $2) } - | LABEL simple_pattern + | LABEL simple_pattern_extend_modes_or_poly { (Labelled $1, None, $2) } - | LABEL LPAREN modes0=optional_mode_expr_legacy x=let_pattern_required_modes RPAREN - { let pat, cty, modes = x in - let loc = $startpos(modes0), $endpos(x) in - (Labelled $1, None, - mkpat_with_modes ~loc ~pat ~cty ~modes:(modes0 @ modes)) - } - | LABEL LPAREN modes=mode_expr_legacy pat=pattern RPAREN - { let loc = $startpos(modes), $endpos(pat) in - (Labelled $1, None, - mkpat_with_modes ~loc ~pat ~cty:None ~modes) - } - | simple_pattern + | simple_pattern_extend_modes_or_poly { (Nolabel, None, $1) } - | LPAREN modes=mode_expr_legacy x=let_pattern_no_modes RPAREN - { let pat, cty = x in - let loc = $startpos(modes), $endpos(x) in - (Nolabel, None, - mkpat_with_modes ~loc ~pat ~cty ~modes) - } - | LPAREN modes0=optional_mode_expr_legacy x=let_pattern_required_modes RPAREN - { let pat, cty, modes = x in - let loc = $startpos(modes0), $endpos(x) in - (Nolabel, None, - mkpat_with_modes ~loc ~pat ~cty ~modes:(modes0 @ modes)) - } - | LABEL LPAREN x=poly_pattern_no_modes RPAREN - { let pat, cty = x in - (Labelled $1, None, - mkpat_with_modes ~loc:$loc(x) ~pat ~cty ~modes:[]) - } - | LABEL LPAREN modes=mode_expr_legacy x=poly_pattern_no_modes RPAREN - { let pat, cty = x in - let loc = $startpos(modes), $endpos(x) in - (Labelled $1, None, - mkpat_with_modes ~loc ~pat ~cty ~modes) - } - | LPAREN x=poly_pattern_no_modes RPAREN - { let pat, cty = x in - (Nolabel, None, - mkpat_with_modes ~loc:$loc(x) ~pat ~cty ~modes:[]) - } ; pattern_var: @@ -2699,23 +2675,26 @@ pattern_var: preceded(EQUAL, seq_expr)? { $1 } ; -label_let_pattern: - 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, pat, Some cty, modes + +optional_poly_type_and_modes: + { None, [] } + | at_mode_expr + { None, $1 } + | COLON cty_mm = poly_type_with_optional_modes + { let cty, mm = cty_mm in + Some cty, mm } - | x = label_var COLON - cty = mktyp (bound_vars = typevar_list - DOT - inner_type = core_type - { Ptyp_poly (bound_vars, inner_type) }) - modes = optional_atat_mode_expr +; + +label_let_pattern: + modes0 = optional_mode_expr_legacy x = label_var + cty_modes1 = optional_poly_type_and_modes { let lab, pat = x in - lab, pat, Some cty, modes + let cty, modes1 = cty_modes1 in + let modes = modes0 @ modes1 in + let loc = $startpos(modes0), $endpos(cty_modes1) in + let pat = mkpat_with_modes ~loc ~pat ~cty ~modes in + lab, pat } ; %inline label_var: @@ -2723,46 +2702,43 @@ label_let_pattern: { ($1.Location.txt, mkpat ~loc:$sloc (Ppat_var $1)) } ; let_pattern: - x=let_pattern_awaiting_at_modes modes=optional_at_mode_expr - { let pat, cty = x in pat, cty, modes } - | x=let_pattern_awaiting_atat_modes modes=optional_atat_mode_expr - { let pat, cty = x in pat, cty, modes } - | LPAREN let_pattern_required_modes RPAREN { $2 } -; - -let_pattern_required_modes: - x=let_pattern_awaiting_at_modes modes=at_mode_expr - { let pat, cty = x in pat, cty, modes } - | x=let_pattern_awaiting_atat_modes modes=atat_mode_expr - { let pat, cty = x in pat, cty, modes } - | LPAREN let_pattern_required_modes RPAREN { $2 } -; - -let_pattern_no_modes: - x=let_pattern_awaiting_at_modes { x } - | x=let_pattern_awaiting_atat_modes { x } -; - -%inline let_pattern_awaiting_atat_modes: - pat=pattern COLON cty=core_type - { pat, Some cty } - | poly_pattern_no_modes - { $1 } + modes0 = optional_mode_expr_legacy pat = pattern + cty_modes1 = optional_poly_type_and_modes + { + let cty, modes1 = cty_modes1 in + let modes = modes0 @ modes1 in + let loc = $startpos(modes0), $endpos(cty_modes1) in + mkpat_with_modes ~loc ~pat ~cty ~modes + } ; -%inline let_pattern_awaiting_at_modes: - pat=pattern { pat, None } -; +(* simple_pattern extended with poly_type and modes *) +simple_pattern_extend_modes_or_poly: + simple_pattern { $1 } + | LPAREN pattern_with_modes_or_poly RPAREN + { $2 } -%inline poly_pattern_no_modes: - pat = pattern - COLON - cty = mktyp(bound_vars = typevar_list - DOT - inner_type = core_type - { Ptyp_poly (bound_vars, inner_type) }) - { pat, Some cty } -; +pattern_with_modes_or_poly: + modes0 = mode_expr_legacy pat = pattern cty_modes1 = optional_poly_type_and_modes + { + let cty, modes1 = cty_modes1 in + let modes = modes0 @ modes1 in + let loc = $startpos(modes0), $endpos(cty_modes1) in + mkpat_with_modes ~loc ~pat ~cty:cty ~modes + } + | pat = pattern COLON cty_modes = poly_type_with_modes + { + let cty, modes = cty_modes in + mkpat_with_modes ~loc:$sloc ~pat ~cty:(Some cty) ~modes + } + | pat = pattern modes = at_mode_expr + { + mkpat_with_modes ~loc:$sloc ~pat ~cty:None ~modes + } + | pat = pattern COLON cty = strictly_poly_type + { + mkpat_with_modes ~loc:$sloc ~pat ~cty:(Some cty) ~modes:[] + } %inline indexop_expr(dot, index, right): | array=simple_expr d=dot LPAREN i=index RPAREN r=right @@ -2785,10 +2761,10 @@ let_pattern_no_modes: %inline qualified_dotop: ioption(DOT mod_longident {$2}) DOTOP { $1, $2 }; optional_atomic_constraint_: - | COLON atomic_type optional_atat_mode_expr { + | COLON atomic_type { { ret_type_constraint = Some (Pconstraint $2) ; mode_annotations = [] - ; ret_mode_annotations = $3 + ; ret_mode_annotations = [] } } | at_mode_expr { @@ -3154,27 +3130,34 @@ labeled_simple_expr: | OPTLABEL simple_expr %prec below_HASH { (Optional $1, $2) } ; -%inline lident_list: - xs = mkrhs(LIDENT)+ - { xs } -; %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 + | COLON core_type_with_optional_modes { + let typ, mm = $2 in + Some(Pvc_constraint { locally_abstract_univars=[]; typ }), mm } ; + +%inline empty_list: { [] } + +%inline let_ident_with_modes: + optional_mode_expr_legacy let_ident + { ($2, $1) } + | LPAREN let_ident at_mode_expr RPAREN + { ($2, $3) } + let_binding_body_no_punning: - let_ident strict_binding - { ($1, $2, None, []) } - | modes0 = optional_mode_expr_legacy let_ident constraint_ EQUAL seq_expr + let_ident_with_modes strict_binding_modes + { let v, modes = $1 in + (v, $2 modes, None, modes) } + | let_ident_with_modes constraint_ EQUAL seq_expr (* CR zqian: modes are duplicated, and one of them needs to be made ghost to make internal tools happy. We should try to avoid that. *) - { let v = $2 in (* PR#7344 *) - let typ, modes1 = $3 in + { let v, modes0 = $1 in + let typ, modes1 = $2 in let t = Option.map (function | Pconstraint t -> @@ -3183,17 +3166,17 @@ let_binding_body_no_punning: ) typ in let modes = modes0 @ modes1 in - (v, $5, t, modes) + (v, $4, t, modes) } - | modes0 = optional_mode_expr_legacy let_ident COLON poly(core_type) modes1 = optional_atat_mode_expr EQUAL seq_expr - { let bound_vars, inner_type = $4 in - let ltyp = Ptyp_poly (bound_vars, inner_type) in - let typ = ghtyp ~loc:$loc($4) ltyp in + | let_ident_with_modes COLON strictly_poly_type_with_optional_modes EQUAL seq_expr + { let v, modes0 = $1 in + let typ, modes1 = $3 in let modes = modes0 @ modes1 in - ($2, $7, Some (Pvc_constraint { locally_abstract_univars = []; typ }), + (v, $5, Some (Pvc_constraint { locally_abstract_univars = []; typ }), modes) } - | let_ident COLON TYPE newtypes DOT core_type modes=optional_atat_mode_expr EQUAL seq_expr + | let_ident_with_modes COLON TYPE ntys = newtypes DOT cty = core_type modes1 = empty_list EQUAL e = seq_expr + | let_ident_with_modes COLON TYPE ntys = newtypes DOT cty = tuple_type modes1=at_mode_expr EQUAL e = seq_expr (* The code upstream looks like: {[ let constraint' = @@ -3210,10 +3193,12 @@ let_binding_body_no_punning: version, even though we are creating a slightly different [core_type]. *) { let exp, poly = - wrap_type_annotation ~loc:$sloc ~modes:[] ~typloc:$loc($6) $4 $6 $9 + wrap_type_annotation ~loc:$sloc ~modes:[] ~typloc:$loc(cty) ntys cty e in - let loc = ($startpos($1), $endpos($6)) in - (ghpat_with_modes ~loc ~pat:$1 ~cty:(Some poly) ~modes:[], exp, None, modes) + let v, modes0 = $1 in + let modes = modes0 @ modes1 in + let loc = ($startpos($1), $endpos(modes1)) in + (ghpat_with_modes ~loc ~pat:v ~cty:(Some poly) ~modes:[], exp, None, modes) } | pattern_no_exn EQUAL seq_expr { ($1, $3, None, []) } @@ -3222,14 +3207,6 @@ let_binding_body_no_punning: let pvc, modes = $2 in ($1, $4, pvc, modes) } - | modes=mode_expr_legacy let_ident strict_binding_modes - { - ($2, $3 modes, None, modes) - } - | LPAREN let_ident modes=at_mode_expr RPAREN strict_binding_modes - { - ($2, $5 modes, None, modes) - } ; let_binding_body: | let_binding_body_no_punning @@ -3507,8 +3484,17 @@ type_constraint: ; %inline type_constraint_with_modes: - | type_constraint optional_atat_mode_expr - { $1, $2 } + | COLON core_type_with_optional_modes { + let cty, mm = $2 in + Pconstraint cty, mm } + | COLON core_type COLONGREATER core_type_with_optional_modes { + let cty, mm = $4 in + Pcoerce (Some $2, cty), mm } + | COLONGREATER core_type_with_optional_modes { + let cty, mm = $2 in + Pcoerce (None, cty), mm } + | COLON error { syntax_error() } + | COLONGREATER error { syntax_error() } ; %inline constraint_: @@ -3653,9 +3639,13 @@ pattern_gen: | mkpat( mkrhs(constr_longident) pattern %prec prec_constr_appl { Ppat_construct($1, Some ([], $2)) } - | constr=mkrhs(constr_longident) LPAREN TYPE newtypes=lident_list RPAREN + | constr=mkrhs(constr_longident) LPAREN TYPE newtypes=newtypes RPAREN pat=simple_pattern { Ppat_construct(constr, Some (newtypes, pat)) } + | constr=mkrhs(constr_longident) + LPAREN TYPE ty=mkrhs(LIDENT) COLON jkind=jkind_annotation RPAREN + pat=simple_pattern + { Ppat_construct(constr, Some ([(ty,Some jkind)], pat)) } | name_tag pattern %prec prec_constr_appl { Ppat_variant($1, Some $2) } ) { $1 } @@ -3720,24 +3710,8 @@ simple_pattern_not_ident: | extension { Ppat_extension $1 } ) { $1 } - (* CR modes: when modes on patterns are fully supported, replace the below - cases with these two *) - (* | LPAREN pattern modes=at_mode_expr RPAREN - * { mkpat ~loc:$sloc (Ppat_constraint($2, None, modes)) } - * | LPAREN pattern COLON core_type modes=optional_atat_mode_expr RPAREN - * { mkpat ~loc:$sloc (Ppat_constraint($2, Some $4, modes)) } *) | LPAREN pattern COLON core_type RPAREN { mkpat_with_modes ~loc:$sloc ~pat:$2 ~cty:(Some $4) ~modes:[] } - (* CR cgunn: figure out how to get these errors to work without reduce/reduce - conflicts *) - (* | LPAREN pattern COLON core_type ATAT error - * { - * raise (Syntaxerr.Error (Syntaxerr.Modes_on_pattern (make_loc $sloc))) - * } - * | LPAREN pattern AT error - * { - * raise (Syntaxerr.Error (Syntaxerr.Modes_on_pattern (make_loc $sloc))) - * } *) ; simple_delimited_pattern: @@ -4305,17 +4279,51 @@ with_type_binder: typevar_list DOT X { ($1, $3) } ; -possibly_poly(X): - X - { $1 } +%inline strictly_poly(X): | poly(X) { let bound_vars, inner_type = $1 in mktyp ~loc:$sloc (Ptyp_poly (bound_vars, inner_type)) } ; + +possibly_poly(X): + X + { $1 } +| strictly_poly(X) + { $1 } +; %inline poly_type: possibly_poly(core_type) { $1 } ; + +%inline strictly_poly_type: + strictly_poly(core_type) + { $1 } +; + +%inline strictly_poly_tuple_type: + strictly_poly(tuple_type) + { $1 } + +%inline poly_tuple_type: + | tuple_type { $1 } + | strictly_poly_tuple_type { $1 } +; + +%inline poly_type_with_modes: + | poly_tuple_type at_mode_expr { $1, $2 } +; + +%inline poly_type_with_optional_modes: + | poly_type_with_modes { $1 } + | poly_type { $1, [] } +; + +%inline strictly_poly_type_with_optional_modes: + | strictly_poly_type { $1, [] } + | strictly_poly_tuple_type at_mode_expr { $1, $2 } +; + %inline poly_type_no_attr: possibly_poly(core_type_no_attr) { $1 } @@ -4334,6 +4342,10 @@ core_type: { Typ.attr $1 $2 } ; +%inline core_type_with_optional_modes: + core_type { $1, [] } + | tuple_type at_mode_expr { $1, $2 } + (* A core type without attributes is currently defined as an alias type, but this could change in the future if new forms of types are introduced. From the outside, one should use core_type_no_attr. *) @@ -4511,15 +4523,6 @@ at_mode_expr: } ; -atat_mode_expr: - | ATAT mode_expr {$2} - | ATAT error { expecting $loc($2) "mode expression" } -; - -%inline optional_atat_mode_expr: - | { [] } - | atat_mode_expr {$1} -; /* Modalities */ @@ -4529,22 +4532,16 @@ atat_mode_expr: %inline modalities: | modality+ { $1 } -at_modalities_expr: - | AT modalities {$2} - | AT error { expecting $loc($2) "modality expression" } +atat_modalities_expr: + | ATAT modalities {$2} + | ATAT error { expecting $loc($2) "modality expression" } ; optional_atat_modalities_expr: | %prec below_HASH { [] } - | ATAT modalities { $2 } - | ATAT error { expecting $loc($2) "modality expression" } -; - -optional_at_modalities_expr: - | { [] } - | AT modalities { $2 } - | AT error { expecting $loc($2) "modality expression" } + | atat_modalities_expr + { $1 } ; %inline stack(expr): diff --git a/vendor/parser-jane/for-parser-standard/parsetree.mli b/vendor/parser-jane/for-parser-standard/parsetree.mli index b3b6958df2..1e990f50f2 100644 --- a/vendor/parser-jane/for-parser-standard/parsetree.mli +++ b/vendor/parser-jane/for-parser-standard/parsetree.mli @@ -290,13 +290,17 @@ and pattern_desc = - If Closed, [n >= 2] - If Open, [n >= 1] *) - | Ppat_construct of Longident.t loc * (string loc list * pattern) option + | Ppat_construct of + Longident.t loc + * ((string loc * jkind_annotation option) list * pattern) option (** [Ppat_construct(C, args)] represents: - [C] when [args] is [None], - [C P] when [args] is [Some ([], P)] - [C (P1, ..., Pn)] when [args] is [Some ([], Ppat_tuple [P1; ...; Pn])] - - [C (type a b) P] when [args] is [Some ([a; b], P)] + - [C (type a b) P] when [args] is [Some ([a, None; b, None], P)] + - [C (type (a : k) b) P] + when [args] is [Some ([a, Some k; b, None], P)] *) | Ppat_variant of label * pattern option (** [Ppat_variant(`A, pat)] represents: diff --git a/vendor/parser-jane/for-parser-standard/printast.ml b/vendor/parser-jane/for-parser-standard/printast.ml index cb4f26d8d3..a00b64d328 100644 --- a/vendor/parser-jane/for-parser-standard/printast.ml +++ b/vendor/parser-jane/for-parser-standard/printast.ml @@ -255,7 +255,11 @@ and pattern i ppf x = line i ppf "Ppat_construct %a\n" fmt_longident_loc li; option i (fun i ppf (vl, p) -> - list i string_loc ppf vl; + list i + (fun i ppf (v, jk) -> + string_loc i ppf v; + jkind_annotation_opt i ppf jk) + ppf vl; pattern i ppf p) ppf po | Ppat_variant (l, po) -> diff --git a/vendor/parser-jane/imported_commit.txt b/vendor/parser-jane/imported_commit.txt index e4612f2649..87cec39daa 100644 --- a/vendor/parser-jane/imported_commit.txt +++ b/vendor/parser-jane/imported_commit.txt @@ -1 +1 @@ -54526415fb861b64ec6bc088518da739983eb6f9 +00efa7cc0cdc1d919cce8449f243866c60493349 diff --git a/vendor/parser-standard/ast_mapper.ml b/vendor/parser-standard/ast_mapper.ml index 9ed8eb88a8..a4beb3aab7 100644 --- a/vendor/parser-standard/ast_mapper.ml +++ b/vendor/parser-standard/ast_mapper.ml @@ -651,7 +651,12 @@ module P = struct | Ppat_construct (l, p) -> construct ~loc ~attrs (map_loc sub l) (map_opt - (fun (vl, p) -> List.map (map_loc sub) vl, sub.pat sub p) + (fun (vl, p) -> + List.map + (fun (v, jk) -> + map_loc sub v, Option.map (sub.jkind_annotation sub) jk) + vl, + sub.pat sub p) p) | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) | Ppat_record (lpl, cf) -> diff --git a/vendor/parser-standard/parser.mly b/vendor/parser-standard/parser.mly index adc4436fde..71e9462676 100644 --- a/vendor/parser-standard/parser.mly +++ b/vendor/parser-standard/parser.mly @@ -804,6 +804,18 @@ let mkfunction ~loc ~attrs params body_constraint body = attrs end +let mk_functor_typ args mty_mm = + let mty, _ = + List.fold_left (fun (mty, mm) (startpos, arg) -> + let mty = + mkmty ~loc:(startpos, mty.pmty_loc.loc_end) (Pmty_functor (arg, mty, mm)) + in + let mm = [] in + mty, mm) + mty_mm args + in + mty + (* Alternatively, we could keep the generic module type in the Parsetree and extract the package type during type-checking. In that case, the assertions below should be turned into explicit checks. *) @@ -1632,8 +1644,9 @@ functor_arg: LPAREN RPAREN { $startpos, Unit } | (* An argument accompanied with an explicit type. *) - LPAREN x = mkrhs(module_name) COLON mty = module_type mm = optional_atat_mode_expr RPAREN - { $startpos, Named (x, mty, mm) } + LPAREN x = mkrhs(module_name) COLON mty_mm = module_type_with_optional_modes RPAREN + { let mty, mm = mty_mm in + $startpos, Named (x, mty, mm) } ; module_name: @@ -1705,10 +1718,9 @@ module_expr: paren_module_expr: (* A module expression annotated with a module type. *) - LPAREN me = module_expr COLON mty = module_type mm = optional_atat_mode_expr RPAREN - { mkmod ~loc:$sloc (Pmod_constraint(me, Some mty, mm)) } - | LPAREN me = module_expr mm = at_mode_expr RPAREN - { mkmod ~loc:$sloc (Pmod_constraint(me, None, mm)) } + LPAREN me = module_expr mty_mm = module_constraint RPAREN + { let mty, mm = mty_mm in + mkmod ~loc:$sloc (Pmod_constraint(me, mty, mm)) } | LPAREN module_expr COLON module_type error { unclosed "(" $loc($1) ")" $loc($5) } | (* A module expression within parentheses. *) @@ -1837,6 +1849,14 @@ structure_item: Pstr_module body, ext } ; +%inline module_constraint: + COLON mty_mm = module_type_with_optional_modes + { let mty, mm = mty_mm in + (Some mty, mm) + } + | at_mode_expr + { (None, $1) } + (* The body (right-hand side) of a module binding. *) module_binding_body: EQUAL me = module_expr @@ -1844,10 +1864,10 @@ module_binding_body: | COLON error { expecting $loc($1) "=" } | mkmod( - COLON mty = module_type mm = optional_atat_mode_expr EQUAL me = module_expr - { Pmod_constraint(me, Some mty, mm) } - | mm = at_mode_expr EQUAL me = module_expr - { Pmod_constraint(me, None, mm) } + mty_mm = module_constraint EQUAL me = module_expr + { + let mty, mm = mty_mm in + Pmod_constraint(me, mty, mm) } | arg_and_pos = functor_arg body = module_binding_body { let (_, arg) = arg_and_pos in Pmod_functor(arg, body) } @@ -1986,48 +2006,48 @@ open_description: /* Module types */ -module_type: +module_type_atomic: | SIG attrs = attributes s = signature END { mkmty ~loc:$sloc ~attrs (Pmty_signature s) } | SIG attributes signature error { unclosed "sig" $loc($1) "end" $loc($4) } | STRUCT error { expecting $loc($1) "sig" } - | FUNCTOR attrs = attributes args = functor_args - MINUSGREATER mty = module_type mm = optional_at_mode_expr - %prec below_WITH - { wrap_mty_attrs ~loc:$sloc attrs ( - (* return modes go to the innermost functor arrow; - all other return modes are empty *) - let mty, mm = - List.fold_left (fun (acc, mm) (startpos, arg) -> - mkmty ~loc:(startpos, $endpos) (Pmty_functor (arg, acc, mm)), [] - ) (mty, mm) args - in - match mm with - | [] -> mty - | _ :: _ -> assert false - ) } - | MODULE TYPE OF attributes module_expr %prec below_LBRACKETAT - { mkmty ~loc:$sloc ~attrs:$4 (Pmty_typeof $5) } | LPAREN module_type RPAREN { $2 } | LPAREN module_type error { unclosed "(" $loc($1) ")" $loc($3) } - | module_type attribute - { Mty.attr $1 $2 } | mkmty( mkrhs(mty_longident) { Pmty_ident $1 } - | LPAREN RPAREN MINUSGREATER module_type optional_at_mode_expr - { Pmty_functor(Unit, $4, $5) } - | module_type m1=optional_at_mode_expr MINUSGREATER module_type m2=optional_at_mode_expr +/* | LPAREN MODULE mkrhs(mod_longident) RPAREN + { Pmty_alias $3 } */ + ) + { $1 } +; + +module_type: + | module_type_atomic { $1 } + | FUNCTOR attrs = attributes args = functor_args + MINUSGREATER mty_mm = module_type_with_optional_modes + %prec below_WITH + { wrap_mty_attrs ~loc:$sloc attrs (mk_functor_typ args mty_mm) } + | args = functor_args + MINUSGREATER mty_mm = module_type_with_optional_modes + %prec below_WITH + { mk_functor_typ args mty_mm } + | MODULE TYPE OF attributes module_expr %prec below_LBRACKETAT + { mkmty ~loc:$sloc ~attrs:$4 (Pmty_typeof $5) } + | module_type attribute + { Mty.attr $1 $2 } + | mkmty( + module_type_with_optional_modes MINUSGREATER module_type_with_optional_modes %prec below_WITH - { Pmty_functor(Named (mknoloc None, $1, m1), $4, m2) } + { let mty0, mm0 = $1 in + let mty1, mm1 = $3 in + Pmty_functor(Named (mknoloc None, mty0, mm0), mty1, mm1) } | module_type WITH separated_nonempty_llist(AND, with_constraint) { Pmty_with($1, $3) } -/* | LPAREN MODULE mkrhs(mod_longident) RPAREN - { Pmty_alias $3 } */ | extension { Pmty_extension $1 } | module_type WITH mkrhs(mod_ext_longident) @@ -2035,6 +2055,11 @@ module_type: ) { $1 } ; + +%inline module_type_with_optional_modes: + | module_type { $1, [] } + | module_type_atomic at_mode_expr { $1, $2 } + (* A signature, which appears between SIG and END (among other places), is a list of signature elements. *) signature: @@ -2111,8 +2136,10 @@ signature_item: %inline module_declaration: MODULE ext = ext attrs1 = attributes - name_ = module_name_modal(at_modalities_expr) - body = module_declaration_body(optional_atat_modalities_expr) + name_ = module_name_modal(atat_modalities_expr) + body = module_declaration_body( + module_type optional_atat_modalities_expr { ($1, $2) } + ) attrs2 = post_item_attributes { let attrs = attrs1 @ attrs2 in @@ -2126,13 +2153,13 @@ signature_item: ; (* The body (right-hand side) of a module declaration. *) -module_declaration_body(optional_atat_modal_expr): - COLON mty = module_type mm = optional_atat_modal_expr - { mty, mm } +module_declaration_body(module_type_with_optional_modal_expr): + COLON mty_mm = module_type_with_optional_modal_expr + { mty_mm } | EQUAL error { expecting $loc($1) ":" } | mkmty( - arg_and_pos = functor_arg body = module_declaration_body(optional_atat_mode_expr) + arg_and_pos = functor_arg body = module_declaration_body(module_type_with_optional_modes) { let (_, arg) = arg_and_pos in let (ret, mret) = body in Pmty_functor(arg, ret, mret) } @@ -2144,10 +2171,10 @@ module_declaration_body(optional_atat_modal_expr): %inline module_alias: MODULE ext = ext attrs1 = attributes - name_ = module_name_modal(at_modalities_expr) + name_ = module_name_modal(atat_modalities_expr) EQUAL body = module_expr_alias - modalities = optional_at_modalities_expr + modalities = optional_atat_modalities_expr attrs2 = post_item_attributes { let attrs = attrs1 @ attrs2 in @@ -2654,73 +2681,22 @@ seq_expr: ; labeled_simple_pattern: - QUESTION LPAREN modes0=optional_mode_expr_legacy x=label_let_pattern opt_default RPAREN - { let lbl, pat, cty, modes = x in - let loc = $startpos(modes0), $endpos(x) in - (Optional lbl, $5, - mkpat_with_modes ~loc ~pat ~cty ~modes:(modes0 @ modes)) - } + QUESTION LPAREN label_let_pattern opt_default RPAREN + { (Optional (fst $3), $4, snd $3) } | QUESTION label_var { (Optional (fst $2), None, snd $2) } - | OPTLABEL LPAREN modes0=optional_mode_expr_legacy x=let_pattern opt_default RPAREN - { let pat, cty, modes = x in - let loc = $startpos(modes0), $endpos(x) in - (Optional $1, $5, - mkpat_with_modes ~loc ~pat ~cty ~modes:(modes0 @ modes)) - } + | OPTLABEL LPAREN let_pattern opt_default RPAREN + { (Optional $1, $4, $3) } | OPTLABEL pattern_var { (Optional $1, None, $2) } - | TILDE LPAREN modes0=optional_mode_expr_legacy x=label_let_pattern RPAREN - { let lbl, pat, cty, modes = x in - let loc = $startpos(modes0), $endpos(x) in - (Labelled lbl, None, - mkpat_with_modes ~loc ~pat ~cty ~modes:(modes0 @ modes)) - } + | TILDE LPAREN label_let_pattern RPAREN + { (Labelled (fst $3), None, snd $3) } | TILDE label_var { (Labelled (fst $2), None, snd $2) } - | LABEL simple_pattern + | LABEL simple_pattern_extend_modes_or_poly { (Labelled $1, None, $2) } - | LABEL LPAREN modes0=optional_mode_expr_legacy x=let_pattern_required_modes RPAREN - { let pat, cty, modes = x in - let loc = $startpos(modes0), $endpos(x) in - (Labelled $1, None, - mkpat_with_modes ~loc ~pat ~cty ~modes:(modes0 @ modes)) - } - | LABEL LPAREN modes=mode_expr_legacy pat=pattern RPAREN - { let loc = $startpos(modes), $endpos(pat) in - (Labelled $1, None, - mkpat_with_modes ~loc ~pat ~cty:None ~modes) - } - | simple_pattern + | simple_pattern_extend_modes_or_poly { (Nolabel, None, $1) } - | LPAREN modes=mode_expr_legacy x=let_pattern_no_modes RPAREN - { let pat, cty = x in - let loc = $startpos(modes), $endpos(x) in - (Nolabel, None, - mkpat_with_modes ~loc ~pat ~cty ~modes) - } - | LPAREN modes0=optional_mode_expr_legacy x=let_pattern_required_modes RPAREN - { let pat, cty, modes = x in - let loc = $startpos(modes0), $endpos(x) in - (Nolabel, None, - mkpat_with_modes ~loc ~pat ~cty ~modes:(modes0 @ modes)) - } - | LABEL LPAREN x=poly_pattern_no_modes RPAREN - { let pat, cty = x in - (Labelled $1, None, - mkpat_with_modes ~loc:$loc(x) ~pat ~cty ~modes:[]) - } - | LABEL LPAREN modes=mode_expr_legacy x=poly_pattern_no_modes RPAREN - { let pat, cty = x in - let loc = $startpos(modes), $endpos(x) in - (Labelled $1, None, - mkpat_with_modes ~loc ~pat ~cty ~modes) - } - | LPAREN x=poly_pattern_no_modes RPAREN - { let pat, cty = x in - (Nolabel, None, - mkpat_with_modes ~loc:$loc(x) ~pat ~cty ~modes:[]) - } ; pattern_var: @@ -2734,23 +2710,26 @@ pattern_var: preceded(EQUAL, seq_expr)? { $1 } ; -label_let_pattern: - 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, pat, Some cty, modes + +optional_poly_type_and_modes: + { None, [] } + | at_mode_expr + { None, $1 } + | COLON cty_mm = poly_type_with_optional_modes + { let cty, mm = cty_mm in + Some cty, mm } - | x = label_var COLON - cty = mktyp (bound_vars = typevar_list - DOT - inner_type = core_type - { Ptyp_poly (bound_vars, inner_type) }) - modes = optional_atat_mode_expr +; + +label_let_pattern: + modes0 = optional_mode_expr_legacy x = label_var + cty_modes1 = optional_poly_type_and_modes { let lab, pat = x in - lab, pat, Some cty, modes + let cty, modes1 = cty_modes1 in + let modes = modes0 @ modes1 in + let loc = $startpos(modes0), $endpos(cty_modes1) in + let pat = mkpat_with_modes ~loc ~pat ~cty ~modes in + lab, pat } ; %inline label_var: @@ -2758,46 +2737,43 @@ label_let_pattern: { ($1.Location.txt, mkpat ~loc:$sloc (Ppat_var $1)) } ; let_pattern: - x=let_pattern_awaiting_at_modes modes=optional_at_mode_expr - { let pat, cty = x in pat, cty, modes } - | x=let_pattern_awaiting_atat_modes modes=optional_atat_mode_expr - { let pat, cty = x in pat, cty, modes } - | LPAREN let_pattern_required_modes RPAREN { $2 } -; - -let_pattern_required_modes: - x=let_pattern_awaiting_at_modes modes=at_mode_expr - { let pat, cty = x in pat, cty, modes } - | x=let_pattern_awaiting_atat_modes modes=atat_mode_expr - { let pat, cty = x in pat, cty, modes } - | LPAREN let_pattern_required_modes RPAREN { $2 } -; - -let_pattern_no_modes: - x=let_pattern_awaiting_at_modes { x } - | x=let_pattern_awaiting_atat_modes { x } -; - -%inline let_pattern_awaiting_atat_modes: - pat=pattern COLON cty=core_type - { pat, Some cty } - | poly_pattern_no_modes - { $1 } + modes0 = optional_mode_expr_legacy pat = pattern + cty_modes1 = optional_poly_type_and_modes + { + let cty, modes1 = cty_modes1 in + let modes = modes0 @ modes1 in + let loc = $startpos(modes0), $endpos(cty_modes1) in + mkpat_with_modes ~loc ~pat ~cty ~modes + } ; -%inline let_pattern_awaiting_at_modes: - pat=pattern { pat, None } -; +(* simple_pattern extended with poly_type and modes *) +simple_pattern_extend_modes_or_poly: + simple_pattern { $1 } + | LPAREN pattern_with_modes_or_poly RPAREN + { $2 } -%inline poly_pattern_no_modes: - pat = pattern - COLON - cty = mktyp(bound_vars = typevar_list - DOT - inner_type = core_type - { Ptyp_poly (bound_vars, inner_type) }) - { pat, Some cty } -; +pattern_with_modes_or_poly: + modes0 = mode_expr_legacy pat = pattern cty_modes1 = optional_poly_type_and_modes + { + let cty, modes1 = cty_modes1 in + let modes = modes0 @ modes1 in + let loc = $startpos(modes0), $endpos(cty_modes1) in + mkpat_with_modes ~loc ~pat ~cty:cty ~modes + } + | pat = pattern COLON cty_modes = poly_type_with_modes + { + let cty, modes = cty_modes in + mkpat_with_modes ~loc:$sloc ~pat ~cty:(Some cty) ~modes + } + | pat = pattern modes = at_mode_expr + { + mkpat_with_modes ~loc:$sloc ~pat ~cty:None ~modes + } + | pat = pattern COLON cty = strictly_poly_type + { + mkpat_with_modes ~loc:$sloc ~pat ~cty:(Some cty) ~modes:[] + } %inline indexop_expr(dot, index, right): | array=simple_expr d=dot LPAREN i=index RPAREN r=right @@ -2820,10 +2796,10 @@ let_pattern_no_modes: %inline qualified_dotop: ioption(DOT mod_longident {$2}) DOTOP { $1, $2 }; optional_atomic_constraint_: - | COLON atomic_type optional_atat_mode_expr { + | COLON atomic_type { { ret_type_constraint = Some (Pconstraint $2) ; mode_annotations = [] - ; ret_mode_annotations = $3 + ; ret_mode_annotations = [] } } | at_mode_expr { @@ -3189,27 +3165,34 @@ labeled_simple_expr: | OPTLABEL simple_expr %prec below_HASH { (Optional $1, $2) } ; -%inline lident_list: - xs = mkrhs(LIDENT)+ - { xs } -; %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 + | COLON core_type_with_optional_modes { + let typ, mm = $2 in + Some(Pvc_constraint { locally_abstract_univars=[]; typ }), mm } ; + +%inline empty_list: { [] } + +%inline let_ident_with_modes: + optional_mode_expr_legacy let_ident + { ($2, $1) } + | LPAREN let_ident at_mode_expr RPAREN + { ($2, $3) } + let_binding_body_no_punning: - let_ident strict_binding - { ($1, $2, None, []) } - | modes0 = optional_mode_expr_legacy let_ident constraint_ EQUAL seq_expr + let_ident_with_modes strict_binding_modes + { let v, modes = $1 in + (v, $2 modes, None, modes) } + | let_ident_with_modes constraint_ EQUAL seq_expr (* CR zqian: modes are duplicated, and one of them needs to be made ghost to make internal tools happy. We should try to avoid that. *) - { let v = $2 in (* PR#7344 *) - let typ, modes1 = $3 in + { let v, modes0 = $1 in + let typ, modes1 = $2 in let t = Option.map (function | Pconstraint t -> @@ -3218,17 +3201,17 @@ let_binding_body_no_punning: ) typ in let modes = modes0 @ modes1 in - (v, $5, t, modes) + (v, $4, t, modes) } - | modes0 = optional_mode_expr_legacy let_ident COLON poly(core_type) modes1 = optional_atat_mode_expr EQUAL seq_expr - { let bound_vars, inner_type = $4 in - let ltyp = Ptyp_poly (bound_vars, inner_type) in - let typ = ghtyp ~loc:$loc($4) ltyp in + | let_ident_with_modes COLON strictly_poly_type_with_optional_modes EQUAL seq_expr + { let v, modes0 = $1 in + let typ, modes1 = $3 in let modes = modes0 @ modes1 in - ($2, $7, Some (Pvc_constraint { locally_abstract_univars = []; typ }), + (v, $5, Some (Pvc_constraint { locally_abstract_univars = []; typ }), modes) } - | let_ident COLON TYPE newtypes DOT core_type modes=optional_atat_mode_expr EQUAL seq_expr + | let_ident_with_modes COLON TYPE ntys = newtypes DOT cty = core_type modes1 = empty_list EQUAL e = seq_expr + | let_ident_with_modes COLON TYPE ntys = newtypes DOT cty = tuple_type modes1=at_mode_expr EQUAL e = seq_expr (* The code upstream looks like: {[ let constraint' = @@ -3245,10 +3228,12 @@ let_binding_body_no_punning: version, even though we are creating a slightly different [core_type]. *) { let exp, poly = - wrap_type_annotation ~loc:$sloc ~modes:[] ~typloc:$loc($6) $4 $6 $9 + wrap_type_annotation ~loc:$sloc ~modes:[] ~typloc:$loc(cty) ntys cty e in - let loc = ($startpos($1), $endpos($6)) in - (ghpat_with_modes ~loc ~pat:$1 ~cty:(Some poly) ~modes:[], exp, None, modes) + let v, modes0 = $1 in + let modes = modes0 @ modes1 in + let loc = ($startpos($1), $endpos(modes1)) in + (ghpat_with_modes ~loc ~pat:v ~cty:(Some poly) ~modes:[], exp, None, modes) } | pattern_no_exn EQUAL seq_expr { ($1, $3, None, []) } @@ -3257,14 +3242,6 @@ let_binding_body_no_punning: let pvc, modes = $2 in ($1, $4, pvc, modes) } - | modes=mode_expr_legacy let_ident strict_binding_modes - { - ($2, $3 modes, None, modes) - } - | LPAREN let_ident modes=at_mode_expr RPAREN strict_binding_modes - { - ($2, $5 modes, None, modes) - } ; let_binding_body: | let_binding_body_no_punning @@ -3542,8 +3519,17 @@ type_constraint: ; %inline type_constraint_with_modes: - | type_constraint optional_atat_mode_expr - { $1, $2 } + | COLON core_type_with_optional_modes { + let cty, mm = $2 in + Pconstraint cty, mm } + | COLON core_type COLONGREATER core_type_with_optional_modes { + let cty, mm = $4 in + Pcoerce (Some $2, cty), mm } + | COLONGREATER core_type_with_optional_modes { + let cty, mm = $2 in + Pcoerce (None, cty), mm } + | COLON error { syntax_error() } + | COLONGREATER error { syntax_error() } ; %inline constraint_: @@ -3688,9 +3674,13 @@ pattern_gen: | mkpat( mkrhs(constr_longident) pattern %prec prec_constr_appl { Ppat_construct($1, Some ([], $2)) } - | constr=mkrhs(constr_longident) LPAREN TYPE newtypes=lident_list RPAREN + | constr=mkrhs(constr_longident) LPAREN TYPE newtypes=newtypes RPAREN pat=simple_pattern { Ppat_construct(constr, Some (newtypes, pat)) } + | constr=mkrhs(constr_longident) + LPAREN TYPE ty=mkrhs(LIDENT) COLON jkind=jkind_annotation RPAREN + pat=simple_pattern + { Ppat_construct(constr, Some ([(ty,Some jkind)], pat)) } | name_tag pattern %prec prec_constr_appl { Ppat_variant($1, Some $2) } ) { $1 } @@ -3755,24 +3745,8 @@ simple_pattern_not_ident: | extension { Ppat_extension $1 } ) { $1 } - (* CR modes: when modes on patterns are fully supported, replace the below - cases with these two *) - (* | LPAREN pattern modes=at_mode_expr RPAREN - * { mkpat ~loc:$sloc (Ppat_constraint($2, None, modes)) } - * | LPAREN pattern COLON core_type modes=optional_atat_mode_expr RPAREN - * { mkpat ~loc:$sloc (Ppat_constraint($2, Some $4, modes)) } *) | LPAREN pattern COLON core_type RPAREN { mkpat_with_modes ~loc:$sloc ~pat:$2 ~cty:(Some $4) ~modes:[] } - (* CR cgunn: figure out how to get these errors to work without reduce/reduce - conflicts *) - (* | LPAREN pattern COLON core_type ATAT error - * { - * raise (Syntaxerr.Error (Syntaxerr.Modes_on_pattern (make_loc $sloc))) - * } - * | LPAREN pattern AT error - * { - * raise (Syntaxerr.Error (Syntaxerr.Modes_on_pattern (make_loc $sloc))) - * } *) ; simple_delimited_pattern: @@ -4340,17 +4314,51 @@ with_type_binder: typevar_list DOT X { ($1, $3) } ; -possibly_poly(X): - X - { $1 } +%inline strictly_poly(X): | poly(X) { let bound_vars, inner_type = $1 in mktyp ~loc:$sloc (Ptyp_poly (bound_vars, inner_type)) } ; + +possibly_poly(X): + X + { $1 } +| strictly_poly(X) + { $1 } +; %inline poly_type: possibly_poly(core_type) { $1 } ; + +%inline strictly_poly_type: + strictly_poly(core_type) + { $1 } +; + +%inline strictly_poly_tuple_type: + strictly_poly(tuple_type) + { $1 } + +%inline poly_tuple_type: + | tuple_type { $1 } + | strictly_poly_tuple_type { $1 } +; + +%inline poly_type_with_modes: + | poly_tuple_type at_mode_expr { $1, $2 } +; + +%inline poly_type_with_optional_modes: + | poly_type_with_modes { $1 } + | poly_type { $1, [] } +; + +%inline strictly_poly_type_with_optional_modes: + | strictly_poly_type { $1, [] } + | strictly_poly_tuple_type at_mode_expr { $1, $2 } +; + %inline poly_type_no_attr: possibly_poly(core_type_no_attr) { $1 } @@ -4369,6 +4377,10 @@ core_type: { Typ.attr $1 $2 } ; +%inline core_type_with_optional_modes: + core_type { $1, [] } + | tuple_type at_mode_expr { $1, $2 } + (* A core type without attributes is currently defined as an alias type, but this could change in the future if new forms of types are introduced. From the outside, one should use core_type_no_attr. *) @@ -4546,15 +4558,6 @@ at_mode_expr: } ; -atat_mode_expr: - | ATAT mode_expr {$2} - | ATAT error { expecting $loc($2) "mode expression" } -; - -%inline optional_atat_mode_expr: - | { [] } - | atat_mode_expr {$1} -; /* Modalities */ @@ -4564,22 +4567,16 @@ atat_mode_expr: %inline modalities: | modality+ { $1 } -at_modalities_expr: - | AT modalities {$2} - | AT error { expecting $loc($2) "modality expression" } +atat_modalities_expr: + | ATAT modalities {$2} + | ATAT error { expecting $loc($2) "modality expression" } ; optional_atat_modalities_expr: | %prec below_HASH { [] } - | ATAT modalities { $2 } - | ATAT error { expecting $loc($2) "modality expression" } -; - -optional_at_modalities_expr: - | { [] } - | AT modalities { $2 } - | AT error { expecting $loc($2) "modality expression" } + | atat_modalities_expr + { $1 } ; %inline stack(expr): diff --git a/vendor/parser-standard/parsetree.mli b/vendor/parser-standard/parsetree.mli index b66cdf4423..f88f245e15 100644 --- a/vendor/parser-standard/parsetree.mli +++ b/vendor/parser-standard/parsetree.mli @@ -290,13 +290,17 @@ and pattern_desc = - If Closed, [n >= 2] - If Open, [n >= 1] *) - | Ppat_construct of Longident.t loc * (string loc list * pattern) option + | Ppat_construct of + Longident.t loc + * ((string loc * jkind_annotation option) list * pattern) option (** [Ppat_construct(C, args)] represents: - [C] when [args] is [None], - [C P] when [args] is [Some ([], P)] - [C (P1, ..., Pn)] when [args] is [Some ([], Ppat_tuple [P1; ...; Pn])] - - [C (type a b) P] when [args] is [Some ([a; b], P)] + - [C (type a b) P] when [args] is [Some ([a, None; b, None], P)] + - [C (type (a : k) b) P] + when [args] is [Some ([a, Some k; b, None], P)] *) | Ppat_variant of label * pattern option (** [Ppat_variant(`A, pat)] represents: diff --git a/vendor/parser-standard/printast.ml b/vendor/parser-standard/printast.ml index 829daab242..1957d5ef20 100644 --- a/vendor/parser-standard/printast.ml +++ b/vendor/parser-standard/printast.ml @@ -255,7 +255,11 @@ and pattern i ppf x = line i ppf "Ppat_construct %a\n" fmt_longident_loc li; option i (fun i ppf (vl, p) -> - list i string_loc ppf vl; + list i + (fun i ppf (v, jk) -> + string_loc i ppf v; + jkind_annotation_opt i ppf jk) + ppf vl; pattern i ppf p) ppf po | Ppat_variant (l, po) ->