diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 3679f7ef99..eac4558380 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -538,17 +538,16 @@ let fmt_quoted_string key ext s = function (str (Format_.sprintf "|%s}" delim)) (str s) -let type_var_has_layout_annot (_, layout_opt) = Option.is_some layout_opt +let type_var_has_jkind_annot (_, jkind_opt) = Option.is_some jkind_opt -let layout_to_string = function Layout s -> s +let jkind_to_string = function Layout s -> s -let fmt_layout_str ~c ~loc string = - fmt "@ :@ " $ Cmts.fmt c loc @@ str string +let fmt_jkind_str ~c ~loc string = fmt "@ :@ " $ Cmts.fmt c loc @@ str string -let fmt_layout c l = fmt_layout_str ~c ~loc:l.loc (layout_to_string l.txt) +let fmt_jkind c l = fmt_jkind_str ~c ~loc:l.loc (jkind_to_string l.txt) let fmt_type_var ~have_tick c s = - let {txt= name_opt; loc= name_loc}, layout_opt = s in + let {txt= name_opt; loc= name_loc}, jkind_opt = s in ( Cmts.fmt c name_loc @@ match name_opt with @@ -562,10 +561,10 @@ let fmt_type_var ~have_tick c s = (String.length var_name > 1 && Char.equal var_name.[1] '\'') " " ) $ str var_name ) - $ Option.value_map layout_opt ~default:noop ~f:(fmt_layout c) + $ Option.value_map jkind_opt ~default:noop ~f:(fmt_jkind c) let fmt_type_var_with_parenze ~have_tick c s = - wrap_if (type_var_has_layout_annot s) "(" ")" (fmt_type_var ~have_tick c s) + wrap_if (type_var_has_jkind_annot s) "(" ")" (fmt_type_var ~have_tick c s) let split_global_flags_from_attrs atrs = match @@ -3534,7 +3533,7 @@ and fmt_tydcl_params c ctx params = | [(p, _)] -> ( false , match p.ptyp_desc with - | Ptyp_var s -> type_var_has_layout_annot s + | Ptyp_var s -> type_var_has_jkind_annot s | _ -> false ) | _ :: _ :: _ -> (false, true) in @@ -3563,7 +3562,7 @@ and fmt_type_declaration c ?ext ?(pre = "") ?name ?(eq = "=") {ast= decl; _} @@ let decl = if Erase_jane_syntax.should_erase () then decl - else Sugar.rewrite_type_declaration_imm_attr_to_layout_annot c.cmts decl + else Sugar.rewrite_type_declaration_imm_attr_to_jkind_annot c.cmts decl in let { ptype_name= {txt; loc} ; ptype_params @@ -3573,7 +3572,7 @@ and fmt_type_declaration c ?ext ?(pre = "") ?name ?(eq = "=") {ast= decl; _} ; ptype_manifest= m ; ptype_attributes ; ptype_loc - ; ptype_layout } = + ; ptype_jkind } = decl in update_config_maybe_disabled c ptype_loc ptype_attributes @@ -3602,7 +3601,7 @@ and fmt_type_declaration c ?ext ?(pre = "") ?name ?(eq = "=") {ast= decl; _} 0 ( fmt_tydcl_params c ctx ptype_params $ Option.value_map name ~default:(str txt) ~f:(fmt_longident_loc c) - $ fmt_opt (Option.map ~f:(fmt_layout c) ptype_layout) ) + $ fmt_opt (Option.map ~f:(fmt_jkind c) ptype_jkind) ) $ k ) in let fmt_manifest_kind = diff --git a/lib/Normalize_std_ast.ml b/lib/Normalize_std_ast.ml index 3cf7ce94ca..0b11501ff5 100644 --- a/lib/Normalize_std_ast.ml +++ b/lib/Normalize_std_ast.ml @@ -29,7 +29,7 @@ let is_erasable_jane_syntax attr = "erasable jane syntax" *) || String.equal "extension.curry" name -(* Immediate layout annotations should be treated the same as their attribute +(* Immediate jkind annotations should be treated the same as their attribute counterparts *) let normalize_immediate_annot_and_attrs attrs = let overwrite_attr_name attr new_name = @@ -39,8 +39,8 @@ let normalize_immediate_annot_and_attrs attrs = in let attrs, _ = List.fold attrs ~init:([], false) - ~f:(fun (new_attrs, deleted_layout_annot) attr -> - let new_attr, just_deleted_layout_annot = + ~f:(fun (new_attrs, deleted_jkind_annot) attr -> + let new_attr, just_deleted_jkind_annot = match (attr.attr_name.txt, attr.attr_payload) with (* We also have to normalize "ocaml.immediate" into "immediate" for this to work. Since if we rewrite [@@ocaml.immediate] into an @@ -49,10 +49,19 @@ let normalize_immediate_annot_and_attrs attrs = | ( "jane.erasable.layouts.annot" , PStr [ { pstr_desc= - Pstr_eval - ( { pexp_desc= Pexp_ident {txt= Lident "immediate"; _} - ; _ } - , _ ) + Pstr_attribute + { attr_name= {txt= "jane.erasable.layouts.prim"; _} + ; attr_payload= + PStr + [ { pstr_desc= + Pstr_eval + ( { pexp_desc= + Pexp_ident + {txt= Lident "immediate"; _} + ; _ } + , _ ) + ; _ } ] + ; _ } ; _ } ] ) -> (Some (overwrite_attr_name attr "immediate"), true) | "ocaml.immediate", PStr [] -> @@ -60,16 +69,24 @@ let normalize_immediate_annot_and_attrs attrs = | ( "jane.erasable.layouts.annot" , PStr [ { pstr_desc= - Pstr_eval - ( { pexp_desc= - Pexp_ident {txt= Lident "immediate64"; _} - ; _ } - , _ ) + Pstr_attribute + { attr_name= {txt= "jane.erasable.layouts.prim"; _} + ; attr_payload= + PStr + [ { pstr_desc= + Pstr_eval + ( { pexp_desc= + Pexp_ident + {txt= Lident "immediate64"; _} + ; _ } + , _ ) + ; _ } ] + ; _ } ; _ } ] ) -> (Some (overwrite_attr_name attr "immediate64"), true) | "ocaml.immediate64", PStr [] -> (Some (overwrite_attr_name attr "immediate64"), false) - | "jane.erasable.layouts", PStr [] when deleted_layout_annot -> + | "jane.erasable.layouts", PStr [] when deleted_jkind_annot -> (* Only remove [jane.erasable.layouts] if we previously rewrote an associated [jane.erasable.layouts.annot] *) (None, false) @@ -80,7 +97,7 @@ let normalize_immediate_annot_and_attrs attrs = | Some new_attr -> new_attr :: new_attrs | None -> new_attrs in - (new_attrs, deleted_layout_annot || just_deleted_layout_annot) ) + (new_attrs, deleted_jkind_annot || just_deleted_jkind_annot) ) in List.rev attrs diff --git a/lib/Sugar.ml b/lib/Sugar.ml index 34df1c1429..20e0983a1c 100644 --- a/lib/Sugar.ml +++ b/lib/Sugar.ml @@ -131,31 +131,31 @@ let remove_local_attrs cmts param = in Pparam_val (is_local, label, default, {pattern with ppat_attributes}) -let get_layout_of_legacy_attr attr = +let get_jkind_of_legacy_attr attr = match (attr.attr_name.txt, attr.attr_payload) with | ("ocaml.immediate64" | "immediate64"), PStr [] -> Some (Layout "immediate64") | ("ocaml.immediate" | "immediate"), PStr [] -> Some (Layout "immediate") | _ -> None -let rewrite_type_declaration_imm_attr_to_layout_annot cmts decl = +let rewrite_type_declaration_imm_attr_to_jkind_annot cmts decl = let immediate_attrs, remaining_attrs = decl.ptype_attributes |> List.partition_map ~f:(fun attr -> - match get_layout_of_legacy_attr attr with - | Some layout -> First (layout, attr) + match get_jkind_of_legacy_attr attr with + | Some jkind -> First (jkind, attr) | None -> Second attr ) in - match (decl.ptype_layout, immediate_attrs) with - | None, [(layout, attr)] -> - (* We only do this rewrite if (1.) there's no layout annotation already + match (decl.ptype_jkind, immediate_attrs) with + | None, [(jkind, attr)] -> + (* We only do this rewrite if (1.) there's no jkind annotation already present and (2.) only one immediate attribute is attached *) - let ptype_layout = Some Location.(mknoloc layout) in + let ptype_jkind = Some Location.(mknoloc jkind) in Cmts.relocate_all_to_before cmts ~src:attr.attr_name.loc ~before:decl.ptype_loc ; Cmts.relocate_all_to_before cmts ~src:attr.attr_loc ~before:decl.ptype_loc ; - {decl with ptype_attributes= remaining_attrs; ptype_layout} + {decl with ptype_attributes= remaining_attrs; ptype_jkind} | _ -> decl module Exp = struct diff --git a/lib/Sugar.mli b/lib/Sugar.mli index 636e5081fc..2d3a158c07 100644 --- a/lib/Sugar.mli +++ b/lib/Sugar.mli @@ -45,10 +45,10 @@ val cl_fun : val remove_local_attrs : Cmts.t -> function_param_desc -> function_param_desc -val rewrite_type_declaration_imm_attr_to_layout_annot : +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]. - This only happens if there's no existing layout annotation AND there's only + This only happens if there's no existing jkind annotation AND there's only one immediacy attribute. *) module Exp : sig diff --git a/vendor/ocaml-common/warnings.ml b/vendor/ocaml-common/warnings.ml index 5a51b5afc4..8367cf64ea 100644 --- a/vendor/ocaml-common/warnings.ml +++ b/vendor/ocaml-common/warnings.ml @@ -112,7 +112,7 @@ type t = | Unerasable_position_argument (* 188 *) | Unnecessarily_partial_tuple_pattern (* 189 *) | Probe_name_too_long of string (* 190 *) - | Unchecked_property_attribute of string (* 199 *) + | Unchecked_zero_alloc_attribute (* 199 *) | Unboxing_impossible (* 210 *) | Redundant_modality of string (* 250 *) @@ -199,7 +199,7 @@ let number = function | Unerasable_position_argument -> 188 | Unnecessarily_partial_tuple_pattern -> 189 | Probe_name_too_long _ -> 190 - | Unchecked_property_attribute _ -> 199 + | Unchecked_zero_alloc_attribute -> 199 | Unboxing_impossible -> 210 | Redundant_modality _ -> 250 ;; @@ -561,7 +561,7 @@ let descriptions = [ description = "Probe name must be at most 100 characters long."; since = since 4 14 }; { number = 199; - names = ["unchecked-property-attribute"]; + names = ["unchecked-zero-alloc-attribute"]; description = "A property of a function that was \ optimized away cannot be checked."; since = since 4 14 }; @@ -1189,12 +1189,11 @@ let message = function Printf.sprintf "This probe name is too long: `%s'. \ Probe names must be at most 100 characters long." name - | Unchecked_property_attribute property -> - Printf.sprintf "the %S attribute cannot be checked.\n\ + | Unchecked_zero_alloc_attribute -> + Printf.sprintf "the zero_alloc attribute cannot be checked.\n\ The function it is attached to was optimized away. \n\ You can try to mark this function as [@inline never] \n\ or move the attribute to the relevant callers of this function." - property | Unboxing_impossible -> Printf.sprintf "This [@unboxed] attribute cannot be used.\n\ diff --git a/vendor/ocaml-common/warnings.mli b/vendor/ocaml-common/warnings.mli index bbfee99950..c045c0ee80 100644 --- a/vendor/ocaml-common/warnings.mli +++ b/vendor/ocaml-common/warnings.mli @@ -116,7 +116,7 @@ type t = | Unerasable_position_argument (* 188 *) | Unnecessarily_partial_tuple_pattern (* 189 *) | Probe_name_too_long of string (* 190 *) - | Unchecked_property_attribute of string (* 199 *) + | Unchecked_zero_alloc_attribute (* 199 *) | Unboxing_impossible (* 210 *) | Redundant_modality of string (* 250 *) diff --git a/vendor/parser-extended/ast_helper.ml b/vendor/parser-extended/ast_helper.ml index e0955147a3..d17e852e6c 100644 --- a/vendor/parser-extended/ast_helper.ml +++ b/vendor/parser-extended/ast_helper.ml @@ -476,7 +476,7 @@ module Type = struct let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) ?(text = []) ?(params = []) - ?layout + ?jkind ?(cstrs = []) ?(kind = Ptype_abstract) ?(priv = Public) @@ -492,7 +492,7 @@ module Type = struct ptype_attributes = add_text_attrs text (add_docs_attrs docs attrs); ptype_loc = loc; - ptype_layout = layout; + ptype_jkind = jkind; } let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) diff --git a/vendor/parser-extended/ast_mapper.ml b/vendor/parser-extended/ast_mapper.ml index 4c33cf976c..3c8e641ce7 100644 --- a/vendor/parser-extended/ast_mapper.ml +++ b/vendor/parser-extended/ast_mapper.ml @@ -236,12 +236,12 @@ module T = struct ptype_manifest; ptype_attributes; ptype_loc; - ptype_layout; + ptype_jkind; } = let loc = sub.location sub ptype_loc in let attrs = sub.attributes sub ptype_attributes in Type.mk ~loc ~attrs (map_loc sub ptype_name) - ?layout:(ptype_layout) + ?jkind:(ptype_jkind) ~params:(List.map (map_fst (sub.typ sub)) ptype_params) ~priv:(Flag.map_private sub ptype_private) ~cstrs:(List.map diff --git a/vendor/parser-extended/asttypes.mli b/vendor/parser-extended/asttypes.mli index baa6eb37c3..a8479b4b81 100644 --- a/vendor/parser-extended/asttypes.mli +++ b/vendor/parser-extended/asttypes.mli @@ -61,10 +61,10 @@ type 'a loc = 'a Location.loc = { loc : Location.t; } -type const_layout = Layout of string [@@unboxed] +type const_jkind = Layout of string [@@unboxed] -type layout_annotation = const_layout loc -type ty_var = string option loc * layout_annotation option +type jkind_annotation = const_jkind loc +type ty_var = string option loc * jkind_annotation option type label = string diff --git a/vendor/parser-extended/parser.mly b/vendor/parser-extended/parser.mly index bf9089780d..21439b6c17 100644 --- a/vendor/parser-extended/parser.mly +++ b/vendor/parser-extended/parser.mly @@ -699,7 +699,7 @@ let mk_directive ~loc name arg = pdir_loc = make_loc loc; } -let convert_layout_to_legacy_attr = +let convert_jkind_to_legacy_attr = let mk ~loc name = [Attr.mk ~loc (mkloc name loc) (PStr [])] in function | {txt = Layout "immediate"; loc} -> mk ~loc "immediate" @@ -2503,10 +2503,10 @@ expr: { let loc = $sloc in wrap_exp_attrs ~loc (mk_newtypes ~loc $5 $7) $2 } | FUN ext_attributes LPAREN TYPE - name=mkrhs(LIDENT {Some $1}) COLON layout=layout_annotation + name=mkrhs(LIDENT {Some $1}) COLON jkind=jkind_annotation RPAREN fun_def { let loc = $sloc in - wrap_exp_attrs ~loc (mk_newtypes ~loc:$sloc [name, layout] $9) $2 } + wrap_exp_attrs ~loc (mk_newtypes ~loc:$sloc [name, jkind] $9) $2 } | expr attribute { Exp.attr $1 $2 } /* BEGIN AVOID */ @@ -2942,9 +2942,9 @@ strict_binding: | LPAREN TYPE newtypes RPAREN fun_binding { mk_newtypes ~loc:$sloc $3 $5 } | LPAREN TYPE - name=mkrhs(LIDENT {Some $1}) COLON layout=layout_annotation + name=mkrhs(LIDENT {Some $1}) COLON jkind=jkind_annotation RPAREN fun_binding - { mk_newtypes ~loc:$sloc [name, layout] $7 } + { mk_newtypes ~loc:$sloc [name, jkind] $7 } ; local_fun_binding: local_strict_binding @@ -2963,9 +2963,9 @@ local_strict_binding: | LPAREN TYPE newtypes RPAREN local_fun_binding { mk_newtypes ~loc:$sloc $3 $5 } | LPAREN TYPE - name=mkrhs(LIDENT {Some $1}) COLON layout=layout_annotation + name=mkrhs(LIDENT {Some $1}) COLON jkind=jkind_annotation RPAREN fun_binding - { mk_newtypes ~loc:$sloc [name, layout] $7 } + { mk_newtypes ~loc:$sloc [name, jkind] $7 } ; %inline match_cases: xs = preceded_or_separated_nonempty_llist(BAR, match_case) @@ -2996,9 +2996,9 @@ fun_def: | LPAREN TYPE newtypes RPAREN fun_def { mk_newtypes ~loc:$sloc $3 $5 } | LPAREN TYPE - name=mkrhs(LIDENT {Some $1}) COLON layout=layout_annotation + name=mkrhs(LIDENT {Some $1}) COLON jkind=jkind_annotation RPAREN fun_def - { mk_newtypes ~loc:$sloc [name, layout] $7 } + { mk_newtypes ~loc:$sloc [name, jkind] $7 } ; (* Parsing labeled tuple expressions @@ -3128,16 +3128,16 @@ type_constraint: (* the thing between the [type] and the [.] in [let : type <>. 'a -> 'a = ...] *) -newtypes: (* : (string with_loc * layout_annotation option) list *) +newtypes: (* : (string with_loc * jkind_annotation option) list *) newtype+ { $1 } -newtype: (* : string with_loc * layout_annotation option *) +newtype: (* : string with_loc * jkind_annotation option *) mkrhs(LIDENT {Some $1}) { $1, None } | LPAREN - name=mkrhs(LIDENT {Some $1}) COLON layout=layout_annotation + name=mkrhs(LIDENT {Some $1}) COLON jkind=jkind_annotation RPAREN - { name, layout } + { name, jkind } /* Patterns */ @@ -3463,18 +3463,18 @@ generic_type_declaration(flag, kind): flag = flag params = type_parameters id = mkrhs(LIDENT) - layout_and_attr = layout_attr_opt + jkind_and_attr = jkind_attr_opt kind_priv_manifest = kind cstrs = constraints attrs2 = post_item_attributes { let (kind, priv, manifest) = kind_priv_manifest in - let (layout, attrs3) = layout_and_attr in + let (jkind, attrs3) = jkind_and_attr in let docs = symbol_docs $sloc in let attrs = attrs1 @ attrs2 @ attrs3 in let loc = make_loc $sloc in (flag, ext), - Type.mk id ~params ?layout ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs + Type.mk id ~params ?jkind ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs } ; %inline generic_and_type_declaration(kind): @@ -3482,18 +3482,18 @@ generic_type_declaration(flag, kind): attrs1 = attributes params = type_parameters id = mkrhs(LIDENT) - layout_and_attr = layout_attr_opt + jkind_and_attr = jkind_attr_opt kind_priv_manifest = kind cstrs = constraints attrs2 = post_item_attributes { let (kind, priv, manifest) = kind_priv_manifest in - let (layout, attrs3) = layout_and_attr in + let (jkind, attrs3) = jkind_and_attr in let docs = symbol_docs $sloc in let attrs = attrs1 @ attrs2 @ attrs3 in let loc = make_loc $sloc in let text = symbol_text $symbolstartpos in - Type.mk id ~params ?layout ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ~text + Type.mk id ~params ?jkind ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ~text } ; %inline constraints: @@ -3546,44 +3546,44 @@ type_parameters: { ps } ; -layout_annotation_gen: +jkind_annotation_gen: ident { let loc = make_loc $sloc in (mkloc (Layout $1) loc) } -layout_annotation: (* : layout_annotation *) - layout_annotation_gen +jkind_annotation: (* : jkind_annotation *) + jkind_annotation_gen { if Erase_jane_syntax.should_erase () then None else Some $1 } ; -layout_attr_opt: +jkind_attr_opt: /* empty */ { None, [] } - | COLON layout_annotation_gen + | COLON jkind_annotation_gen { if Erase_jane_syntax.should_erase () - then None, convert_layout_to_legacy_attr $2 + then None, convert_jkind_to_legacy_attr $2 else Some $2, [] } ; -%inline type_param_with_layout: +%inline type_param_with_jkind: name=mkrhs(tyvar_name_or_underscore) attrs=attributes COLON - layout=layout_annotation - { let descr = Ptyp_var (name, layout) in + jkind=jkind_annotation + { let descr = Ptyp_var (name, jkind) in mktyp ~loc:$sloc ~attrs descr } ; parenthesized_type_parameter: type_parameter { $1 } - | type_variance type_param_with_layout + | type_variance type_param_with_jkind { $2, $1 } ; @@ -3839,14 +3839,14 @@ with_type_binder: /* Polymorphic types */ -%inline typevar: (* : string with_loc * layout_annotation option *) +%inline typevar: (* : string with_loc * jkind_annotation option *) QUOTE mkrhs(ident {Some $1}) { $2, None } - | LPAREN QUOTE mkrhs(ident {Some $1}) COLON layout=layout_annotation RPAREN - { $3, layout } + | LPAREN QUOTE mkrhs(ident {Some $1}) COLON jkind=jkind_annotation RPAREN + { $3, jkind } ; %inline typevar_list: - (* : (string with_loc * layout_annotation option) list *) + (* : (string with_loc * jkind_annotation option) list *) nonempty_llist(typevar) { $1 } ; @@ -3905,14 +3905,14 @@ alias_type: LPAREN name=mkrhs(tyvar_name_or_underscore) COLON - layout = layout_annotation + jkind = jkind_annotation RPAREN - { match layout, name.txt with + { match jkind, name.txt with | None, None -> assert (Erase_jane_syntax.should_erase ()); aliased_type | _ -> - mktyp ~loc:$sloc (Ptyp_alias (aliased_type, (name, layout))) } + mktyp ~loc:$sloc (Ptyp_alias (aliased_type, (name, jkind))) } ; (* Function types include: @@ -4169,10 +4169,10 @@ atomic_type: { Ptyp_variant($3, Closed, Some $5) } | extension { Ptyp_extension $1 } - | LPAREN QUOTE name=mkrhs(ident {Some $1}) COLON layout=layout_annotation RPAREN - { Ptyp_var (name, layout) } - | LPAREN mkrhs(UNDERSCORE {None}) COLON layout=layout_annotation RPAREN - { Ptyp_var ($2, layout) } + | LPAREN QUOTE name=mkrhs(ident {Some $1}) COLON jkind=jkind_annotation RPAREN + { Ptyp_var (name, jkind) } + | LPAREN mkrhs(UNDERSCORE {None}) COLON jkind=jkind_annotation RPAREN + { Ptyp_var ($2, jkind) } ) { $1 } /* end mktyp group */ diff --git a/vendor/parser-extended/parsetree.mli b/vendor/parser-extended/parsetree.mli index 7b1f6e5e6b..f600957ec5 100644 --- a/vendor/parser-extended/parsetree.mli +++ b/vendor/parser-extended/parsetree.mli @@ -625,7 +625,7 @@ and type_declaration = ptype_manifest: core_type option; (** represents [= T] *) ptype_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) ptype_loc: Location.t; - ptype_layout: layout_annotation option; + ptype_jkind: jkind_annotation option; } (** Here are type declarations and their representation, diff --git a/vendor/parser-extended/printast.ml b/vendor/parser-extended/printast.ml index 75092776a8..356af4a8fb 100644 --- a/vendor/parser-extended/printast.ml +++ b/vendor/parser-extended/printast.ml @@ -200,14 +200,14 @@ let paren_kind i ppf = function | Brace -> line i ppf "Brace\n" | Bracket -> line i ppf "Bracket\n" -let layout_to_string = function +let jkind_to_string = function | Layout s -> s -let fmt_layout_opt ppf l = Format.fprintf ppf "%s" - (Option.value ~default:"none" (Option.map (fun l -> layout_to_string l.txt) l)) +let fmt_jkind_opt ppf l = Format.fprintf ppf "%s" + (Option.value ~default:"none" (Option.map (fun l -> jkind_to_string l.txt) l)) -let fmt_ty_var ppf (name, layout) = - Format.fprintf ppf "%a:%a" fmt_str_opt_loc name fmt_layout_opt layout +let fmt_ty_var ppf (name, jkind) = + Format.fprintf ppf "%a:%a" fmt_str_opt_loc name fmt_jkind_opt jkind let tuple_component_label i ppf = function | None -> line i ppf "Label: None\n" @@ -643,7 +643,7 @@ and type_declaration i ppf x = line i ppf "ptype_private = %a\n" fmt_private_flag x.ptype_private; line i ppf "ptype_manifest =\n"; option (i+1) core_type ppf x.ptype_manifest; - line i ppf "ptype_layout = %a\n" fmt_layout_opt x.ptype_layout + line i ppf "ptype_jkind = %a\n" fmt_jkind_opt x.ptype_jkind and attribute i ppf k a = line i ppf "%s %a %a\n" k fmt_string_loc a.attr_name fmt_location a.attr_loc; diff --git a/vendor/parser-jane/for-ocaml-common/warnings.ml b/vendor/parser-jane/for-ocaml-common/warnings.ml index d1bf6efd11..31f90cdb50 100644 --- a/vendor/parser-jane/for-ocaml-common/warnings.ml +++ b/vendor/parser-jane/for-ocaml-common/warnings.ml @@ -112,7 +112,7 @@ type t = | Unerasable_position_argument (* 188 *) | Unnecessarily_partial_tuple_pattern (* 189 *) | Probe_name_too_long of string (* 190 *) - | Unchecked_property_attribute of string (* 199 *) + | Unchecked_zero_alloc_attribute (* 199 *) | Unboxing_impossible (* 210 *) | Redundant_modality of string (* 250 *) @@ -199,7 +199,7 @@ let number = function | Unerasable_position_argument -> 188 | Unnecessarily_partial_tuple_pattern -> 189 | Probe_name_too_long _ -> 190 - | Unchecked_property_attribute _ -> 199 + | Unchecked_zero_alloc_attribute -> 199 | Unboxing_impossible -> 210 | Redundant_modality _ -> 250 ;; @@ -561,7 +561,7 @@ let descriptions = [ description = "Probe name must be at most 100 characters long."; since = since 4 14 }; { number = 199; - names = ["unchecked-property-attribute"]; + names = ["unchecked-zero-alloc-attribute"]; description = "A property of a function that was \ optimized away cannot be checked."; since = since 4 14 }; @@ -1183,12 +1183,11 @@ let message = function Printf.sprintf "This probe name is too long: `%s'. \ Probe names must be at most 100 characters long." name - | Unchecked_property_attribute property -> - Printf.sprintf "the %S attribute cannot be checked.\n\ + | Unchecked_zero_alloc_attribute -> + Printf.sprintf "the zero_alloc attribute cannot be checked.\n\ The function it is attached to was optimized away. \n\ You can try to mark this function as [@inline never] \n\ or move the attribute to the relevant callers of this function." - property | Unboxing_impossible -> Printf.sprintf "This [@unboxed] attribute cannot be used.\n\ diff --git a/vendor/parser-jane/for-ocaml-common/warnings.mli b/vendor/parser-jane/for-ocaml-common/warnings.mli index bbfee99950..c045c0ee80 100644 --- a/vendor/parser-jane/for-ocaml-common/warnings.mli +++ b/vendor/parser-jane/for-ocaml-common/warnings.mli @@ -116,7 +116,7 @@ type t = | Unerasable_position_argument (* 188 *) | Unnecessarily_partial_tuple_pattern (* 189 *) | Probe_name_too_long of string (* 190 *) - | Unchecked_property_attribute of string (* 199 *) + | Unchecked_zero_alloc_attribute (* 199 *) | Unboxing_impossible (* 210 *) | Redundant_modality of string (* 250 *) diff --git a/vendor/parser-jane/for-parser-standard/ast_mapper.ml b/vendor/parser-jane/for-parser-standard/ast_mapper.ml index 64cb2a41ec..2c269089fb 100644 --- a/vendor/parser-jane/for-parser-standard/ast_mapper.ml +++ b/vendor/parser-jane/for-parser-standard/ast_mapper.ml @@ -54,7 +54,7 @@ type mapper = { include_declaration: mapper -> include_declaration -> include_declaration; include_description: mapper -> include_description -> include_description; jkind_annotation: - mapper -> Jane_asttypes.const_jkind -> Jane_asttypes.const_jkind; + mapper -> Jane_syntax.Jkind.t -> Jane_syntax.Jkind.t; label_declaration: mapper -> label_declaration -> label_declaration; location: mapper -> Location.t -> Location.t; module_binding: mapper -> module_binding -> module_binding; @@ -415,11 +415,23 @@ module MT = struct | Ifsig_include_functor incl -> Ifsig_include_functor (sub.include_description sub incl) + module L = Jane_syntax.Layouts + + let map_sig_layout sub : L.signature_item -> L.signature_item = + function + | Lsig_kind_abbrev (name, jkind) -> + Lsig_kind_abbrev ( + map_loc sub name, + map_loc_txt sub sub.jkind_annotation jkind + ) + let map_signature_item_jst sub : Jane_syntax.Signature_item.t -> Jane_syntax.Signature_item.t = function | Jsig_include_functor ifincl -> Jsig_include_functor (map_sig_include_functor sub ifincl) + | Jsig_layout sigi -> + Jsig_layout (map_sig_layout sub sigi) let map_signature_item sub ({psig_desc = desc; psig_loc = loc} as sigi) = let open Sig in @@ -429,6 +441,8 @@ module MT = struct match sub.signature_item_jane_syntax sub jsigi with | Jsig_include_functor incl -> Jane_syntax.Include_functor.sig_item_of ~loc incl + | Jsig_layout sigi -> + Jane_syntax.Layouts.sig_item_of ~loc sigi end | None -> match desc with @@ -496,11 +510,23 @@ module M = struct | Ifstr_include_functor incl -> Ifstr_include_functor (sub.include_declaration sub incl) + module L = Jane_syntax.Layouts + + let map_str_layout sub : L.structure_item -> L.structure_item = + function + | Lstr_kind_abbrev (name, jkind) -> + Lstr_kind_abbrev ( + map_loc sub name, + map_loc_txt sub sub.jkind_annotation jkind + ) + let map_structure_item_jst sub : Jane_syntax.Structure_item.t -> Jane_syntax.Structure_item.t = function | Jstr_include_functor ifincl -> Jstr_include_functor (map_str_include_functor sub ifincl) + | Jstr_layout stri -> + Jstr_layout (map_str_layout sub stri) let map_structure_item sub ({pstr_loc = loc; pstr_desc = desc} as stri) = let open Str in @@ -510,6 +536,8 @@ module M = struct match sub.structure_item_jane_syntax sub jstri with | Jstr_include_functor incl -> Jane_syntax.Include_functor.str_item_of ~loc incl + | Jstr_layout stri -> + Jane_syntax.Layouts.str_item_of ~loc stri end | None -> match desc with @@ -1079,7 +1107,20 @@ let default_mapper = | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g) ); - jkind_annotation = (fun _this l -> l); + jkind_annotation = (fun this -> + let open Jane_syntax in + function + | Default -> Default + | Primitive_layout_or_abbreviation s -> + let {txt; loc} = + map_loc this (s : Jkind.Const.t :> _ loc) + in + Primitive_layout_or_abbreviation (Jkind.Const.mk txt loc) + | Mod (t, mode_list) -> + Mod (this.jkind_annotation this t, this.modes this mode_list) + | With (t, ty) -> + With (this.jkind_annotation this t, this.typ this ty) + | Kind_of ty -> Kind_of (this.typ this ty)); expr_jane_syntax = E.map_jst; extension_constructor_jane_syntax = T.map_extension_constructor_jst; diff --git a/vendor/parser-jane/for-parser-standard/asttypes.mli b/vendor/parser-jane/for-parser-standard/asttypes.mli index 08bf72d3c5..d4d7b10f62 100644 --- a/vendor/parser-jane/for-parser-standard/asttypes.mli +++ b/vendor/parser-jane/for-parser-standard/asttypes.mli @@ -20,10 +20,6 @@ *) -(** (Jane Street specific; delete when upstreaming.) - Don't add new types to this file; add them to [jane_asttypes.mli] instead. - This file is considered part of the parse tree, which we can't modify. *) - (* Do not add to this type; it is no longer used in the compiler but is required by ppxlib. *) type constant = diff --git a/vendor/parser-jane/for-parser-standard/jane_asttypes.ml b/vendor/parser-jane/for-parser-standard/jane_asttypes.ml deleted file mode 100644 index 3d6dfb1d35..0000000000 --- a/vendor/parser-jane/for-parser-standard/jane_asttypes.ml +++ /dev/null @@ -1,21 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Nick Roberts, Jane Street, New York *) -(* *) -(* Copyright 2023 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -type const_jkind = string - -let jkind_of_string x = x - -let jkind_to_string x = x - -type jkind_annotation = const_jkind Location.loc diff --git a/vendor/parser-jane/for-parser-standard/jane_asttypes.mli b/vendor/parser-jane/for-parser-standard/jane_asttypes.mli deleted file mode 100644 index 36a09d981d..0000000000 --- a/vendor/parser-jane/for-parser-standard/jane_asttypes.mli +++ /dev/null @@ -1,37 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Antal Spector-Zabusky, Jane Street, New York *) -(* *) -(* Copyright 2023 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Auxiliary Jane Street extensions to AST types used by parsetree and - typedtree. - - This file exists because [Asttypes] is considered part of the parse tree, - and we can't modify the parse tree. This also enables us to build other - files with the upstream compiler as long as [jane_asttypes.mli] is present; - see Note [Buildable with upstream] in jane_syntax.mli for details on that. - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -(** [const_jkind] is private to limit confusion with type variables, which - are also strings in the parser. -*) -type const_jkind - -val jkind_of_string : string -> const_jkind - -val jkind_to_string : const_jkind -> string - -type jkind_annotation = const_jkind Location.loc diff --git a/vendor/parser-jane/for-parser-standard/jane_syntax.ml b/vendor/parser-jane/for-parser-standard/jane_syntax.ml index 3bd961fef6..8998adbe94 100644 --- a/vendor/parser-jane/for-parser-standard/jane_syntax.ml +++ b/vendor/parser-jane/for-parser-standard/jane_syntax.ml @@ -1,5 +1,4 @@ open Asttypes -open Jane_asttypes open Parsetree open Jane_syntax_parsing @@ -184,6 +183,20 @@ module type Payload_protocol = sig end end +module type Structure_item_encodable = sig + type t + + val of_structure_item : structure_item -> t loc option + + val to_structure_item : t loc -> structure_item + + (** For error messages: a name that can be used to identify the + [t] being converted to and from string, and its indefinite + article (either "a" or "an"). + *) + val indefinite_article_and_name : string * string +end + module type Stringable = sig type t @@ -198,16 +211,30 @@ module type Stringable = sig val indefinite_article_and_name : string * string end -module Make_payload_protocol_of_stringable (Stringable : Stringable) : - Payload_protocol with type t := Stringable.t = struct - module Encode = struct - let as_expr t_loc = - let string = Stringable.to_string t_loc.txt in +module Make_structure_item_encodable_of_stringable (Stringable : Stringable) : + Structure_item_encodable with type t = Stringable.t = struct + include Stringable + + let to_structure_item t_loc = + let string = Stringable.to_string t_loc.txt in + let expr = Ast_helper.Exp.ident (Location.mkloc (Longident.Lident string) t_loc.loc) + in + { pstr_desc = Pstr_eval (expr, []); pstr_loc = Location.none } - let structure_item_of_expr expr = - { pstr_desc = Pstr_eval (expr, []); pstr_loc = Location.none } + let of_structure_item = function + | { pstr_desc = Pstr_eval ({ pexp_desc = Pexp_ident payload_lid; _ }, _) } + -> ( + match Stringable.of_string (Longident.last payload_lid.txt) with + | Some t -> Some (Location.mkloc t payload_lid.loc) + | None -> None) + | _ -> None +end +module Make_payload_protocol_of_structure_item_encodable + (Encodable : Structure_item_encodable) : + Payload_protocol with type t := Encodable.t = struct + module Encode = struct let structure_item_of_none = { pstr_desc = Pstr_attribute @@ -218,14 +245,10 @@ module Make_payload_protocol_of_stringable (Stringable : Stringable) : pstr_loc = Location.none } - let as_payload t_loc = - let expr = as_expr t_loc in - PStr [structure_item_of_expr expr] + let as_payload t_loc = PStr [Encodable.to_structure_item t_loc] let list_as_payload t_locs = - let items = - List.map (fun t_loc -> structure_item_of_expr (as_expr t_loc)) t_locs - in + let items = List.map Encodable.to_structure_item t_locs in PStr items let option_list_as_payload t_locs = @@ -233,7 +256,7 @@ module Make_payload_protocol_of_stringable (Stringable : Stringable) : List.map (function | None -> structure_item_of_none - | Some t_loc -> structure_item_of_expr (as_expr t_loc)) + | Some t_loc -> Encodable.to_structure_item t_loc) t_locs in PStr items @@ -244,7 +267,7 @@ module Make_payload_protocol_of_stringable (Stringable : Stringable) : let report_error ~loc = function | Unknown_payload payload -> - let indefinite_article, name = Stringable.indefinite_article_and_name in + let indefinite_article, name = Encodable.indefinite_article_and_name in Location.errorf ~loc "Attribute payload does not name %s %s:@;%a" indefinite_article name (Printast.payload 0) payload @@ -263,35 +286,25 @@ module Make_payload_protocol_of_stringable (Stringable : Stringable) : open struct exception Unexpected - let from_expr = function - | { pexp_desc = Pexp_ident payload_lid; _ } -> - let t = - match Stringable.of_string (Longident.last payload_lid.txt) with - | None -> raise Unexpected - | Some t -> t - in - Location.mkloc t payload_lid.loc - | _ -> raise Unexpected - - let expr_of_structure_item = function - | { pstr_desc = Pstr_eval (expr, _) } -> expr - | _ -> raise Unexpected - let is_none_structure_item = function | { pstr_desc = Pstr_attribute { attr_name = { txt = "jane.none" } } } -> true | _ -> false + let from_structure_item item = + match Encodable.of_structure_item item with + | Some t_loc -> t_loc + | None -> raise Unexpected + let from_payload payload = match payload with - | PStr [item] -> from_expr (expr_of_structure_item item) + | PStr [item] -> from_structure_item item | _ -> raise Unexpected let list_from_payload payload = match payload with - | PStr items -> - List.map (fun item -> from_expr (expr_of_structure_item item)) items + | PStr items -> List.map (fun item -> from_structure_item item) items | _ -> raise Unexpected let option_list_from_payload payload = @@ -301,7 +314,7 @@ module Make_payload_protocol_of_stringable (Stringable : Stringable) : (fun item -> if is_none_structure_item item then None - else Some (from_expr (expr_of_structure_item item))) + else Some (from_structure_item item)) items | _ -> raise Unexpected end @@ -320,27 +333,168 @@ module Make_payload_protocol_of_stringable (Stringable : Stringable) : end end -module Stringable_const_jkind = struct - type t = const_jkind +module Make_payload_protocol_of_stringable (Stringable : Stringable) : + Payload_protocol with type t := Stringable.t = + Make_payload_protocol_of_structure_item_encodable + (Make_structure_item_encodable_of_stringable (Stringable)) + +(* only used for [Jkind] below *) +module Mode = struct + module Protocol = Make_payload_protocol_of_stringable (struct + type t = mode + + let indefinite_article_and_name = "a", "mode" + + let to_string (Mode s) = s - let indefinite_article_and_name = "a", "layout" + let of_string' s = Mode s - let to_string = jkind_to_string + let of_string s = Some (of_string' s) + end) - let of_string t = Some (jkind_of_string t) + let list_as_payload = Protocol.Encode.list_as_payload + + let list_from_payload = Protocol.Decode.list_from_payload end -module Jkinds_pprint = struct - let const_jkind fmt cl = - Format.pp_print_string fmt (Stringable_const_jkind.to_string cl) +module Jkind = struct + module Const : sig + type raw = string + + type t = private raw loc + + val mk : string -> Location.t -> t - let jkind_annotation fmt ann = const_jkind fmt ann.txt + val of_structure_item : structure_item -> t option + + val to_structure_item : t -> structure_item + end = struct + type raw = string + + module Protocol = Make_structure_item_encodable_of_stringable (struct + type t = raw + + let indefinite_article_and_name = "a", "primitive kind" + + let to_string t = t + + let of_string t = Some t + end) + + type t = raw loc + + let mk txt loc : t = { txt; loc } + + let of_structure_item = Protocol.of_structure_item + + let to_structure_item = Protocol.to_structure_item + end + + type t = + | Default + | Primitive_layout_or_abbreviation of Const.t + | Mod of t * mode loc list + | With of t * core_type + | Kind_of of core_type + + type annotation = t loc + + let indefinite_article_and_name = "a", "kind" + + let prefix = "jane.erasable.layouts." + + let struct_item_of_attr attr = + { pstr_desc = Pstr_attribute attr; pstr_loc = Location.none } + + let struct_item_to_attr item = + match item with + | { pstr_desc = Pstr_attribute attr; _ } -> Some attr + | _ -> None + + let struct_item_of_type ty = + { pstr_desc = + Pstr_type + (Recursive, [Ast_helper.Type.mk ~manifest:ty (Location.mknoloc "t")]); + pstr_loc = Location.none + } + + let struct_item_to_type item = + match item with + | { pstr_desc = Pstr_type (Recursive, [decl]); _ } -> decl.ptype_manifest + | _ -> None + + let struct_item_of_list name list loc = + struct_item_of_attr + { attr_name = Location.mknoloc (prefix ^ name); + attr_payload = PStr list; + attr_loc = loc + } + + let struct_item_to_list item = + let strip_prefix s = + let prefix_len = String.length prefix in + String.sub s prefix_len (String.length s - prefix_len) + in + match item with + | { pstr_desc = + Pstr_attribute + { attr_name = name; attr_payload = PStr list; attr_loc = loc }; + _ + } + when String.starts_with ~prefix name.txt -> + Some (strip_prefix name.txt, list, loc) + | _ -> None + + let rec to_structure_item t_loc = + let to_structure_item t = to_structure_item (Location.mknoloc t) in + match t_loc.txt with + | Default -> struct_item_of_list "default" [] t_loc.loc + | Primitive_layout_or_abbreviation c -> + struct_item_of_list "prim" [Const.to_structure_item c] t_loc.loc + | Mod (t, modes) -> + let mode_list_item = + struct_item_of_attr + { attr_name = Location.mknoloc (prefix ^ "mod"); + attr_payload = Mode.list_as_payload modes; + attr_loc = Location.none + } + in + struct_item_of_list "mod" [to_structure_item t; mode_list_item] t_loc.loc + | With (t, ty) -> + struct_item_of_list "with" + [to_structure_item t; struct_item_of_type ty] + t_loc.loc + | Kind_of ty -> + struct_item_of_list "kind_of" [struct_item_of_type ty] t_loc.loc + + let rec of_structure_item item = + let bind = Option.bind in + let ret loc v = Some (Location.mkloc v loc) in + match struct_item_to_list item with + | Some ("default", [], loc) -> ret loc Default + | Some ("mod", [item_of_t; item_of_mode_expr], loc) -> + bind (of_structure_item item_of_t) (fun { txt = t } -> + bind (struct_item_to_attr item_of_mode_expr) (fun attr -> + let modes = + Mode.list_from_payload ~loc attr.attr_payload + in + ret loc (Mod (t, modes)))) + | Some ("with", [item_of_t; item_of_ty], loc) -> + bind (of_structure_item item_of_t) (fun { txt = t } -> + bind (struct_item_to_type item_of_ty) (fun ty -> + ret loc (With (t, ty)))) + | Some ("kind_of", [item_of_ty], loc) -> + bind (struct_item_to_type item_of_ty) (fun ty -> ret loc (Kind_of ty)) + | Some ("prim", [item], loc) -> + bind (Const.of_structure_item item) (fun c -> + ret loc (Primitive_layout_or_abbreviation c)) + | Some _ | None -> None end (** Jkind annotations' encoding as attribute payload, used in both n-ary functions and jkinds. *) module Jkind_annotation : sig - include Payload_protocol with type t := const_jkind + include Payload_protocol with type t := Jkind.t module Decode : sig include module type of Decode @@ -349,10 +503,10 @@ module Jkind_annotation : sig loc:Location.t -> string Location.loc list -> payload -> - (string Location.loc * jkind_annotation option) list + (string Location.loc * Jkind.annotation option) list end end = struct - module Protocol = Make_payload_protocol_of_stringable (Stringable_const_jkind) + module Protocol = Make_payload_protocol_of_structure_item_encodable (Jkind) (*******************************************************) (* Conversions with a payload *) @@ -364,20 +518,12 @@ end = struct module Desugaring_error = struct type error = - | Wrong_number_of_jkinds of int * jkind_annotation option list + | Wrong_number_of_jkinds of int * Jkind.annotation option list let report_error ~loc = function - | Wrong_number_of_jkinds (n, jkinds) -> + | Wrong_number_of_jkinds (n, _jkinds) -> Location.errorf ~loc - "Wrong number of layouts in an layout attribute;@;\ - expecting %i but got this list:@;\ - %a" - n - (Format.pp_print_list - (Format.pp_print_option - ~none:(fun ppf () -> Format.fprintf ppf "None") - Jkinds_pprint.jkind_annotation)) - jkinds + "Wrong number of kinds in an kind attribute;@;expecting %i." n exception Error of Location.t * error @@ -658,7 +804,7 @@ module N_ary_functions = struct type function_param_desc = | Pparam_val of arg_label * expression option * pattern - | Pparam_newtype of string loc * jkind_annotation option + | Pparam_newtype of string loc * Jkind.annotation option type function_param = { pparam_desc : function_param_desc; @@ -689,7 +835,7 @@ module N_ary_functions = struct type t = | Top_level | Fun_then of after_fun - | Jkind_annotation of const_jkind loc + | Jkind_annotation of Jkind.annotation (* We return an [of_suffix_result] from [of_suffix] rather than having [of_suffix] interpret the payload for two reasons: @@ -743,7 +889,7 @@ module N_ary_functions = struct | Expected_constraint_or_coerce | Expected_function_cases of Attribute_node.t | Expected_fun_or_newtype of Attribute_node.t - | Expected_newtype_with_jkind_annotation of jkind_annotation + | Expected_newtype_with_jkind_annotation of Jkind.annotation | Parameterless_function let report_error ~loc = function @@ -1187,6 +1333,13 @@ module Labeled_tuples = struct labeled_components, ptyp_attributes | _ -> Desugaring_error.raise typ.ptyp_loc Malformed + (* We wrap labeled tuple expressions in an additional extension node + so that tools that inspect the OCaml syntax tree are less likely + to treat a labeled tuple as a regular tuple. + *) + let labeled_tuple_extension_node_name = + Embedded_name.of_feature feature [] |> Embedded_name.to_string + let expr_of ~loc el = match check_for_any_label el with | No_labels el -> Ast_helper.Exp.tuple ~loc el @@ -1195,7 +1348,10 @@ module Labeled_tuples = struct Expression.make_entire_jane_syntax ~loc feature (fun () -> let names = List.map (fun (label, _) -> string_of_label label) el in Expression.make_jane_syntax feature names - @@ Ast_helper.Exp.tuple (List.map snd el)) + @@ Ast_helper.Exp.apply + (Ast_helper.Exp.extension + (Location.mknoloc labeled_tuple_extension_node_name, PStr [])) + [Nolabel, Ast_helper.Exp.tuple (List.map snd el)]) (* Returns remaining unconsumed attributes *) let of_expr expr = @@ -1203,7 +1359,10 @@ module Labeled_tuples = struct expand_labeled_tuple_extension expr.pexp_loc expr.pexp_attributes in match expr.pexp_desc with - | Pexp_tuple components -> + | Pexp_apply + ( { pexp_desc = Pexp_extension (name, PStr []) }, + [(Nolabel, { pexp_desc = Pexp_tuple components; _ })] ) + when String.equal name.txt labeled_tuple_extension_node_name -> if List.length labels <> List.length components then Desugaring_error.raise expr.pexp_loc Malformed; let labeled_components = @@ -1320,35 +1479,36 @@ module Layouts = struct type nonrec expression = | Lexp_constant of constant - | Lexp_newtype of string loc * jkind_annotation * expression + | Lexp_newtype of string loc * Jkind.annotation * expression type nonrec pattern = Lpat_constant of constant type nonrec core_type = | Ltyp_var of { name : string option; - jkind : jkind_annotation + jkind : Jkind.annotation } | Ltyp_poly of - { bound_vars : (string loc * jkind_annotation option) list; + { bound_vars : (string loc * Jkind.annotation option) list; inner_type : core_type } | Ltyp_alias of { aliased_type : core_type; name : string option; - jkind : jkind_annotation + jkind : Jkind.annotation } type nonrec extension_constructor = | Lext_decl of - (string Location.loc * jkind_annotation option) list + (string Location.loc * Jkind.annotation option) list * constructor_arguments * Parsetree.core_type option - (*******************************************************) - (* Pretty-printing *) + type signature_item = + | Lsig_kind_abbrev of string Location.loc * Jkind.annotation - module Pprint = Jkinds_pprint + type structure_item = + | Lstr_kind_abbrev of string Location.loc * Jkind.annotation (*******************************************************) (* Errors *) @@ -1696,6 +1856,56 @@ module Layouts = struct let of_type_declaration = Type_declaration.make_of_ast ~of_ast_internal:of_type_declaration_internal + + (*********************************************************) + (* Constructing a [signature_item] for kind_abbrev *) + + let attr_name_of { txt = name; loc } = + let embed = Embedded_name.of_feature feature ["kind_abbrev"; name] in + Location.mkloc (Embedded_name.to_string embed) loc + + let of_attr_name { txt = attr_name; loc } = + let name = + match Embedded_name.of_string attr_name with + | Some (Ok embed) -> ( + match Embedded_name.components embed with + | _ :: ["kind_abbrev"; name] -> name + | _ -> failwith "Malformed [kind_abbrev] attribute") + | None | Some (Error _) -> failwith "Malformed [kind_abbrev] attribute" + in + Location.mkloc name loc + + let sig_item_of ~loc = function + | Lsig_kind_abbrev (name, jkind) -> + (* See Note [Wrapping with make_entire_jane_syntax] *) + Signature_item.make_entire_jane_syntax ~loc feature (fun () -> + let payload = Encode.as_payload jkind in + Ast_helper.Sig.attribute + (Ast_helper.Attr.mk (attr_name_of name) payload)) + + let of_sig_item sigi = + match sigi.psig_desc with + | Psig_attribute { attr_name; attr_payload; _ } -> + Lsig_kind_abbrev + ( of_attr_name attr_name, + Decode.from_payload ~loc:sigi.psig_loc attr_payload ) + | _ -> failwith "Malformed [kind_abbrev] in signature" + + let str_item_of ~loc = function + | Lstr_kind_abbrev (name, jkind) -> + (* See Note [Wrapping with make_entire_jane_syntax] *) + Structure_item.make_entire_jane_syntax ~loc feature (fun () -> + let payload = Encode.as_payload jkind in + Ast_helper.Str.attribute + (Ast_helper.Attr.mk (attr_name_of name) payload)) + + let of_str_item stri = + match stri.pstr_desc with + | Pstr_attribute { attr_name; attr_payload; _ } -> + Lstr_kind_abbrev + ( of_attr_name attr_name, + Decode.from_payload ~loc:stri.pstr_loc attr_payload ) + | _ -> failwith "Malformed [kind_abbrev] in structure" end (******************************************************************************) @@ -1854,24 +2064,32 @@ module Module_type = struct end module Signature_item = struct - type t = Jsig_include_functor of Include_functor.signature_item + type t = + | Jsig_include_functor of Include_functor.signature_item + | Jsig_layout of Layouts.signature_item let of_ast_internal (feat : Feature.t) sigi = match feat with | Language_extension Include_functor -> Some (Jsig_include_functor (Include_functor.of_sig_item sigi)) + | Language_extension Layouts -> + Some (Jsig_layout (Layouts.of_sig_item sigi)) | _ -> None let of_ast = Signature_item.make_of_ast ~of_ast_internal end module Structure_item = struct - type t = Jstr_include_functor of Include_functor.structure_item + type t = + | Jstr_include_functor of Include_functor.structure_item + | Jstr_layout of Layouts.structure_item let of_ast_internal (feat : Feature.t) stri = match feat with | Language_extension Include_functor -> Some (Jstr_include_functor (Include_functor.of_str_item stri)) + | Language_extension Layouts -> + Some (Jstr_layout (Layouts.of_str_item stri)) | _ -> None let of_ast = Structure_item.make_of_ast ~of_ast_internal diff --git a/vendor/parser-jane/for-parser-standard/jane_syntax.mli b/vendor/parser-jane/for-parser-standard/jane_syntax.mli index 4a421504d4..3480876585 100644 --- a/vendor/parser-jane/for-parser-standard/jane_syntax.mli +++ b/vendor/parser-jane/for-parser-standard/jane_syntax.mli @@ -100,6 +100,30 @@ module Immutable_arrays : sig val pat_of : loc:Location.t -> pattern -> Parsetree.pattern end +module Jkind : sig + module Const : sig + (** Constant jkind *) + + type raw = string + + (** Represent a user-written kind primitive/abbreviation, + containing a string and its location *) + type t = private raw Location.loc + + (** Constructs a jkind constant *) + val mk : string -> Location.t -> t + end + + type t = + | Default + | Primitive_layout_or_abbreviation of Const.t + | Mod of t * Parsetree.mode Location.loc list + | With of t * Parsetree.core_type + | Kind_of of Parsetree.core_type + + type annotation = t Location.loc +end + module N_ary_functions : sig (** These types use the [P] prefix to match how they are represented in the upstream compiler *) @@ -134,8 +158,7 @@ module N_ary_functions : sig Note: If [E0] is provided, only {{!Asttypes.arg_label.Optional}[Optional]} is allowed. *) - | Pparam_newtype of - string Asttypes.loc * Jane_asttypes.jkind_annotation option + | Pparam_newtype of string Asttypes.loc * Jkind.annotation option (** [Pparam_newtype (x, jkind)] represents the parameter [(type x)]. [x] carries the location of the identifier, whereas [pparam_loc] is the location of the [(type x)] as a whole. @@ -283,9 +306,7 @@ module Layouts : sig (* [fun (type a : immediate) -> ...] *) (* This is represented as an attribute wrapping a [Pexp_newtype] node. *) | Lexp_newtype of - string Location.loc - * Jane_asttypes.jkind_annotation - * Parsetree.expression + string Location.loc * Jkind.annotation * Parsetree.expression type nonrec pattern = (* examples: [ #2.0 ] or [ #42L ] *) @@ -298,7 +319,7 @@ module Layouts : sig a [Ptyp_var] node. *) | Ltyp_var of { name : string option; - jkind : Jane_asttypes.jkind_annotation + jkind : Jkind.annotation } (* [('a : immediate) 'b 'c ('d : value). 'a -> 'b -> 'c -> 'd] *) (* This is represented by an attribute wrapping a [Ptyp_poly] node. *) @@ -308,8 +329,7 @@ module Layouts : sig parsed representation and guarantees that we don't accidentally try to require the layouts extension. *) | Ltyp_poly of - { bound_vars : - (string Location.loc * Jane_asttypes.jkind_annotation option) list; + { bound_vars : (string Location.loc * Jkind.annotation option) list; inner_type : Parsetree.core_type } (* [ty as ('a : immediate)] *) @@ -319,7 +339,7 @@ module Layouts : sig | Ltyp_alias of { aliased_type : Parsetree.core_type; name : string option; - jkind : Jane_asttypes.jkind_annotation + jkind : Jkind.annotation } type nonrec extension_constructor = @@ -328,16 +348,15 @@ module Layouts : sig (* Like [Ltyp_poly], this is used only when there is at least one jkind annotation. Otherwise, we will have a [Pext_decl]. *) | Lext_decl of - (string Location.loc * Jane_asttypes.jkind_annotation option) list + (string Location.loc * Jkind.annotation option) list * Parsetree.constructor_arguments * Parsetree.core_type option - module Pprint : sig - val const_jkind : Format.formatter -> Jane_asttypes.const_jkind -> unit + type signature_item = + | Lsig_kind_abbrev of string Location.loc * Jkind.annotation - val jkind_annotation : - Format.formatter -> Jane_asttypes.jkind_annotation -> unit - end + type structure_item = + | Lstr_kind_abbrev of string Location.loc * Jkind.annotation val expr_of : loc:Location.t -> expression -> Parsetree.expression @@ -359,8 +378,7 @@ module Layouts : sig loc:Location.t -> attrs:Parsetree.attributes -> info:Docstrings.info -> - vars_jkinds: - (string Location.loc * Jane_asttypes.jkind_annotation option) list -> + vars_jkinds:(string Location.loc * Jkind.annotation option) list -> args:Parsetree.constructor_arguments -> res:Parsetree.core_type option -> string Location.loc -> @@ -372,7 +390,7 @@ module Layouts : sig the remaining pieces of the original [constructor_declaration]. *) val of_constructor_declaration : Parsetree.constructor_declaration -> - ((string Location.loc * Jane_asttypes.jkind_annotation option) list + ((string Location.loc * Jkind.annotation option) list * Parsetree.attributes) option @@ -389,10 +407,14 @@ module Layouts : sig kind:Parsetree.type_kind -> priv:Asttypes.private_flag -> manifest:Parsetree.core_type option -> - jkind:Jane_asttypes.jkind_annotation option -> + jkind:Jkind.annotation option -> string Location.loc -> Parsetree.type_declaration + val sig_item_of : loc:Location.t -> signature_item -> Parsetree.signature_item + + val str_item_of : loc:Location.t -> structure_item -> Parsetree.structure_item + (** Extract the jkind annotation from a [type_declaration]; returns leftover attributes. Similar to [of_constructor_declaration] in the sense that users of this function will have to process the remaining @@ -400,7 +422,7 @@ module Layouts : sig *) val of_type_declaration : Parsetree.type_declaration -> - (Jane_asttypes.jkind_annotation * Parsetree.attributes) option + (Jkind.annotation * Parsetree.attributes) option end (******************************************) @@ -554,14 +576,18 @@ end (** Novel syntax in signature items *) module Signature_item : sig - type t = Jsig_include_functor of Include_functor.signature_item + type t = + | Jsig_include_functor of Include_functor.signature_item + | Jsig_layout of Layouts.signature_item include AST with type t := t and type ast := Parsetree.signature_item end (** Novel syntax in structure items *) module Structure_item : sig - type t = Jstr_include_functor of Include_functor.structure_item + type t = + | Jstr_include_functor of Include_functor.structure_item + | Jstr_layout of Layouts.structure_item include AST with type t := t and type ast := Parsetree.structure_item end diff --git a/vendor/parser-jane/for-parser-standard/jane_syntax_parsing.mli b/vendor/parser-jane/for-parser-standard/jane_syntax_parsing.mli index d70486c2f9..e2869df666 100644 --- a/vendor/parser-jane/for-parser-standard/jane_syntax_parsing.mli +++ b/vendor/parser-jane/for-parser-standard/jane_syntax_parsing.mli @@ -103,6 +103,10 @@ module Feature : sig val extension_component : t -> string end +module Misnamed_embedding_error : sig + type t +end + (** An AST-style representation of the names used when generating extension nodes or attributes for modular syntax. We use this to abstract over the details of how they're encoded, so we have some flexibility in changing them @@ -137,6 +141,8 @@ module Embedded_name : sig infrastructure in this module, such as the dummy argument extension *) val to_string : t -> string + val of_string : string -> (t, Misnamed_embedding_error.t) result option + (** Print out the embedded form of a Jane-syntax name, in quotes; for use in error messages. *) val pp_quoted_name : Format.formatter -> t -> unit diff --git a/vendor/parser-jane/for-parser-standard/language_extension.ml b/vendor/parser-jane/for-parser-standard/language_extension.ml index 377941b0ea..5e8e3c95a7 100644 --- a/vendor/parser-jane/for-parser-standard/language_extension.ml +++ b/vendor/parser-jane/for-parser-standard/language_extension.ml @@ -79,7 +79,7 @@ module Exist_pair = struct | Pair (Layouts, m) -> m | Pair (SIMD, ()) -> Stable | Pair (Labeled_tuples, ()) -> Stable - | Pair (Small_numbers, ()) -> Alpha + | Pair (Small_numbers, ()) -> Beta let is_erasable : t -> bool = function Pair (ext, _) -> is_erasable ext diff --git a/vendor/parser-jane/for-parser-standard/parser.mly b/vendor/parser-jane/for-parser-standard/parser.mly index e4dca08c61..e2e5d00583 100644 --- a/vendor/parser-jane/for-parser-standard/parser.mly +++ b/vendor/parser-jane/for-parser-standard/parser.mly @@ -1749,8 +1749,9 @@ structure_item: | kind_abbreviation_decl { let name, jkind = $1 in - ignore (name, jkind); - Misc.fatal_error "jkind syntax not implemented" + Jane_syntax.Layouts.(str_item_of + ~loc:(make_loc $sloc) + (Lstr_kind_abbrev (name, jkind))) } ; @@ -2027,8 +2028,9 @@ signature_item: | kind_abbreviation_decl { let name, jkind = $1 in - ignore (name, jkind); - Misc.fatal_error "jkind syntax not implemented" + Jane_syntax.Layouts.(sig_item_of + ~loc:(make_loc $sloc) + (Lsig_kind_abbrev (name, jkind))) } (* A module declaration. *) @@ -2583,32 +2585,42 @@ labeled_simple_pattern: { (Labelled (fst $2), None, snd $2) } | LABEL simple_pattern { (Labelled $1, None, $2) } + | LABEL LPAREN modes0=optional_mode_expr_legacy x=let_pattern_required_modes RPAREN + { let pat, cty, modes = x in + (Labelled $1, None, + mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes:(modes0 @ modes)) + } | LABEL LPAREN modes=mode_expr_legacy pat=pattern RPAREN { (Labelled $1, None, mkpat_with_modes ~loc:$sloc ~pat ~cty:None ~modes) } | simple_pattern { (Nolabel, None, $1) } - | LPAREN modes0=mode_expr_legacy x=let_pattern RPAREN - { let pat, cty, modes = x in + | LPAREN modes=mode_expr_legacy x=let_pattern_no_modes RPAREN + { let pat, cty = x in (Nolabel, None, - mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes:(modes0 @ modes)) + mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes) } - | LABEL LPAREN x=poly_pattern RPAREN - { let pat, cty, modes = x in - (Labelled $1, None, - mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes) - } - | LABEL LPAREN modes0=mode_expr_legacy x=poly_pattern RPAREN + | LPAREN modes0=optional_mode_expr_legacy x=let_pattern_required_modes RPAREN { let pat, cty, modes = x in + (Nolabel, None, + mkpat_with_modes ~loc:$sloc ~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:$sloc ~pat ~cty ~modes:(modes0 @ modes)) + mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes:[]) } - | LPAREN x=poly_pattern RPAREN - { let pat, cty, modes = x in - (Nolabel, None, + | LABEL LPAREN modes=mode_expr_legacy x=poly_pattern_no_modes RPAREN + { let pat, cty = x in + (Labelled $1, None, mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes) } + | LPAREN x=poly_pattern_no_modes RPAREN + { let pat, cty = x in + (Nolabel, None, + mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes:[]) + } ; pattern_var: @@ -2646,23 +2658,45 @@ 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 } + 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 poly_pattern: +%inline let_pattern_awaiting_atat_modes: + pat=pattern COLON cty=core_type + { pat, Some cty } + | poly_pattern_no_modes + { $1 } +; + +%inline let_pattern_awaiting_at_modes: + pat=pattern { pat, None } +; + +%inline poly_pattern_no_modes: pat = pattern COLON cty = mktyp_jane_syntax_ltyp(bound_vars = typevar_list DOT inner_type = core_type { Jane_syntax.Layouts.Ltyp_poly { bound_vars; inner_type } }) - modes = optional_atat_mode_expr - { pat, Some cty, modes } + { pat, Some cty } ; %inline indexop_expr(dot, index, right): @@ -3596,10 +3630,24 @@ simple_pattern_not_ident: | extension { Ppat_extension $1 } ) { $1 } - | 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)) } + (* 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 ~loc:$sloc (Ppat_constraint($2, Some $4, [])) } + (* 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: @@ -3823,21 +3871,26 @@ type_parameters: jkind: jkind MOD mkrhs(LIDENT)+ { (* LIDENTs here are for modes *) - Misc.fatal_error "jkind syntax not implemented" + let modes = + List.map + (fun {txt; loc} -> {txt = Mode txt; loc}) + $3 + in + Jane_syntax.Jkind.Mod ($1, modes) } | jkind WITH core_type { - Misc.fatal_error "jkind syntax not implemented" + Jane_syntax.Jkind.With ($1, $3) } | mkrhs(ident) { - let { txt; _ } = $1 in - Jane_asttypes.jkind_of_string txt + let {txt; loc} = $1 in + Jane_syntax.Jkind.(Primitive_layout_or_abbreviation + (Const.mk txt loc)) } | KIND_OF ty=core_type { - ignore ty; - Misc.fatal_error "jkind syntax not implemented" + Jane_syntax.Jkind.Kind_of ty } | UNDERSCORE { - Misc.fatal_error "jkind syntax not implemented" + Jane_syntax.Jkind.Default } ; diff --git a/vendor/parser-jane/imported_commit.txt b/vendor/parser-jane/imported_commit.txt index d7639c0442..3ab01a913c 100644 --- a/vendor/parser-jane/imported_commit.txt +++ b/vendor/parser-jane/imported_commit.txt @@ -1 +1 @@ -7231329a2d22fd246bcfe77bf4861fca5a87a54b +5a5da4f670864f45952b8e6795923fc5fac224db diff --git a/vendor/parser-jane/update.sh b/vendor/parser-jane/update.sh index 35593c3cb4..03b40cf68c 100755 --- a/vendor/parser-jane/update.sh +++ b/vendor/parser-jane/update.sh @@ -18,8 +18,6 @@ cp "$parsing_dir"/asttypes.mli for-parser-standard/ cp "$parsing_dir"/ast_helper.ml for-parser-standard/ cp "$parsing_dir"/ast_mapper.ml for-parser-standard/ cp "$parsing_dir"/docstrings.ml for-parser-standard/ -cp "$parsing_dir"/jane_asttypes.ml for-parser-standard/ -cp "$parsing_dir"/jane_asttypes.mli for-parser-standard/ cp "$parsing_dir"/jane_syntax.ml for-parser-standard/ cp "$parsing_dir"/jane_syntax.mli for-parser-standard/ cp "$parsing_dir"/jane_syntax_parsing.ml for-parser-standard/ diff --git a/vendor/parser-standard/ast_mapper.ml b/vendor/parser-standard/ast_mapper.ml index 571d2538ed..2747cf0d2e 100644 --- a/vendor/parser-standard/ast_mapper.ml +++ b/vendor/parser-standard/ast_mapper.ml @@ -54,7 +54,7 @@ type mapper = { include_declaration: mapper -> include_declaration -> include_declaration; include_description: mapper -> include_description -> include_description; jkind_annotation: - mapper -> Jane_asttypes.const_jkind -> Jane_asttypes.const_jkind; + mapper -> Jane_syntax.Jkind.t -> Jane_syntax.Jkind.t; label_declaration: mapper -> label_declaration -> label_declaration; location: mapper -> Location.t -> Location.t; module_binding: mapper -> module_binding -> module_binding; @@ -418,11 +418,23 @@ module MT = struct | Ifsig_include_functor incl -> Ifsig_include_functor (sub.include_description sub incl) + module L = Jane_syntax.Layouts + + let map_sig_layout sub : L.signature_item -> L.signature_item = + function + | Lsig_kind_abbrev (name, jkind) -> + Lsig_kind_abbrev ( + map_loc sub name, + map_loc_txt sub sub.jkind_annotation jkind + ) + let map_signature_item_jst sub : Jane_syntax.Signature_item.t -> Jane_syntax.Signature_item.t = function | Jsig_include_functor ifincl -> Jsig_include_functor (map_sig_include_functor sub ifincl) + | Jsig_layout sigi -> + Jsig_layout (map_sig_layout sub sigi) let map_signature_item sub ({psig_desc = desc; psig_loc = loc} as sigi) = let open Sig in @@ -432,6 +444,8 @@ module MT = struct match sub.signature_item_jane_syntax sub jsigi with | Jsig_include_functor incl -> Jane_syntax.Include_functor.sig_item_of ~loc incl + | Jsig_layout sigi -> + Jane_syntax.Layouts.sig_item_of ~loc sigi end | None -> match desc with @@ -500,11 +514,23 @@ module M = struct | Ifstr_include_functor incl -> Ifstr_include_functor (sub.include_declaration sub incl) + module L = Jane_syntax.Layouts + + let map_str_layout sub : L.structure_item -> L.structure_item = + function + | Lstr_kind_abbrev (name, jkind) -> + Lstr_kind_abbrev ( + map_loc sub name, + map_loc_txt sub sub.jkind_annotation jkind + ) + let map_structure_item_jst sub : Jane_syntax.Structure_item.t -> Jane_syntax.Structure_item.t = function | Jstr_include_functor ifincl -> Jstr_include_functor (map_str_include_functor sub ifincl) + | Jstr_layout stri -> + Jstr_layout (map_str_layout sub stri) let map_structure_item sub ({pstr_loc = loc; pstr_desc = desc} as stri) = let open Str in @@ -514,6 +540,8 @@ module M = struct match sub.structure_item_jane_syntax sub jstri with | Jstr_include_functor incl -> Jane_syntax.Include_functor.str_item_of ~loc incl + | Jstr_layout stri -> + Jane_syntax.Layouts.str_item_of ~loc stri end | None -> match desc with @@ -1084,6 +1112,21 @@ let default_mapper = | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g) ); + jkind_annotation = (fun this -> + let open Jane_syntax in + function + | Default -> Default + | Primitive_layout_or_abbreviation s -> + let {txt; loc} = + map_loc this (s : Jkind.Const.t :> _ loc) + in + Primitive_layout_or_abbreviation (Jkind.Const.mk txt loc) + | Mod (t, mode_list) -> + Mod (this.jkind_annotation this t, this.modes this mode_list) + | With (t, ty) -> + With (this.jkind_annotation this t, this.typ this ty) + | Kind_of ty -> Kind_of (this.typ this ty)); + directive_argument = (fun this a -> { pdira_desc= a.pdira_desc @@ -1100,8 +1143,6 @@ let default_mapper = | Ptop_def s -> Ptop_def (this.structure this s) | Ptop_dir d -> Ptop_dir (this.toplevel_directive this d) ); - jkind_annotation = (fun _this l -> l); - expr_jane_syntax = E.map_jst; extension_constructor_jane_syntax = T.map_extension_constructor_jst; module_type_jane_syntax = MT.map_jane_syntax; diff --git a/vendor/parser-standard/jane_asttypes.ml b/vendor/parser-standard/jane_asttypes.ml deleted file mode 100644 index 3d6dfb1d35..0000000000 --- a/vendor/parser-standard/jane_asttypes.ml +++ /dev/null @@ -1,21 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Nick Roberts, Jane Street, New York *) -(* *) -(* Copyright 2023 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -type const_jkind = string - -let jkind_of_string x = x - -let jkind_to_string x = x - -type jkind_annotation = const_jkind Location.loc diff --git a/vendor/parser-standard/jane_asttypes.mli b/vendor/parser-standard/jane_asttypes.mli deleted file mode 100644 index 36a09d981d..0000000000 --- a/vendor/parser-standard/jane_asttypes.mli +++ /dev/null @@ -1,37 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Antal Spector-Zabusky, Jane Street, New York *) -(* *) -(* Copyright 2023 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Auxiliary Jane Street extensions to AST types used by parsetree and - typedtree. - - This file exists because [Asttypes] is considered part of the parse tree, - and we can't modify the parse tree. This also enables us to build other - files with the upstream compiler as long as [jane_asttypes.mli] is present; - see Note [Buildable with upstream] in jane_syntax.mli for details on that. - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -(** [const_jkind] is private to limit confusion with type variables, which - are also strings in the parser. -*) -type const_jkind - -val jkind_of_string : string -> const_jkind - -val jkind_to_string : const_jkind -> string - -type jkind_annotation = const_jkind Location.loc diff --git a/vendor/parser-standard/jane_syntax.ml b/vendor/parser-standard/jane_syntax.ml index 3bd961fef6..8998adbe94 100644 --- a/vendor/parser-standard/jane_syntax.ml +++ b/vendor/parser-standard/jane_syntax.ml @@ -1,5 +1,4 @@ open Asttypes -open Jane_asttypes open Parsetree open Jane_syntax_parsing @@ -184,6 +183,20 @@ module type Payload_protocol = sig end end +module type Structure_item_encodable = sig + type t + + val of_structure_item : structure_item -> t loc option + + val to_structure_item : t loc -> structure_item + + (** For error messages: a name that can be used to identify the + [t] being converted to and from string, and its indefinite + article (either "a" or "an"). + *) + val indefinite_article_and_name : string * string +end + module type Stringable = sig type t @@ -198,16 +211,30 @@ module type Stringable = sig val indefinite_article_and_name : string * string end -module Make_payload_protocol_of_stringable (Stringable : Stringable) : - Payload_protocol with type t := Stringable.t = struct - module Encode = struct - let as_expr t_loc = - let string = Stringable.to_string t_loc.txt in +module Make_structure_item_encodable_of_stringable (Stringable : Stringable) : + Structure_item_encodable with type t = Stringable.t = struct + include Stringable + + let to_structure_item t_loc = + let string = Stringable.to_string t_loc.txt in + let expr = Ast_helper.Exp.ident (Location.mkloc (Longident.Lident string) t_loc.loc) + in + { pstr_desc = Pstr_eval (expr, []); pstr_loc = Location.none } - let structure_item_of_expr expr = - { pstr_desc = Pstr_eval (expr, []); pstr_loc = Location.none } + let of_structure_item = function + | { pstr_desc = Pstr_eval ({ pexp_desc = Pexp_ident payload_lid; _ }, _) } + -> ( + match Stringable.of_string (Longident.last payload_lid.txt) with + | Some t -> Some (Location.mkloc t payload_lid.loc) + | None -> None) + | _ -> None +end +module Make_payload_protocol_of_structure_item_encodable + (Encodable : Structure_item_encodable) : + Payload_protocol with type t := Encodable.t = struct + module Encode = struct let structure_item_of_none = { pstr_desc = Pstr_attribute @@ -218,14 +245,10 @@ module Make_payload_protocol_of_stringable (Stringable : Stringable) : pstr_loc = Location.none } - let as_payload t_loc = - let expr = as_expr t_loc in - PStr [structure_item_of_expr expr] + let as_payload t_loc = PStr [Encodable.to_structure_item t_loc] let list_as_payload t_locs = - let items = - List.map (fun t_loc -> structure_item_of_expr (as_expr t_loc)) t_locs - in + let items = List.map Encodable.to_structure_item t_locs in PStr items let option_list_as_payload t_locs = @@ -233,7 +256,7 @@ module Make_payload_protocol_of_stringable (Stringable : Stringable) : List.map (function | None -> structure_item_of_none - | Some t_loc -> structure_item_of_expr (as_expr t_loc)) + | Some t_loc -> Encodable.to_structure_item t_loc) t_locs in PStr items @@ -244,7 +267,7 @@ module Make_payload_protocol_of_stringable (Stringable : Stringable) : let report_error ~loc = function | Unknown_payload payload -> - let indefinite_article, name = Stringable.indefinite_article_and_name in + let indefinite_article, name = Encodable.indefinite_article_and_name in Location.errorf ~loc "Attribute payload does not name %s %s:@;%a" indefinite_article name (Printast.payload 0) payload @@ -263,35 +286,25 @@ module Make_payload_protocol_of_stringable (Stringable : Stringable) : open struct exception Unexpected - let from_expr = function - | { pexp_desc = Pexp_ident payload_lid; _ } -> - let t = - match Stringable.of_string (Longident.last payload_lid.txt) with - | None -> raise Unexpected - | Some t -> t - in - Location.mkloc t payload_lid.loc - | _ -> raise Unexpected - - let expr_of_structure_item = function - | { pstr_desc = Pstr_eval (expr, _) } -> expr - | _ -> raise Unexpected - let is_none_structure_item = function | { pstr_desc = Pstr_attribute { attr_name = { txt = "jane.none" } } } -> true | _ -> false + let from_structure_item item = + match Encodable.of_structure_item item with + | Some t_loc -> t_loc + | None -> raise Unexpected + let from_payload payload = match payload with - | PStr [item] -> from_expr (expr_of_structure_item item) + | PStr [item] -> from_structure_item item | _ -> raise Unexpected let list_from_payload payload = match payload with - | PStr items -> - List.map (fun item -> from_expr (expr_of_structure_item item)) items + | PStr items -> List.map (fun item -> from_structure_item item) items | _ -> raise Unexpected let option_list_from_payload payload = @@ -301,7 +314,7 @@ module Make_payload_protocol_of_stringable (Stringable : Stringable) : (fun item -> if is_none_structure_item item then None - else Some (from_expr (expr_of_structure_item item))) + else Some (from_structure_item item)) items | _ -> raise Unexpected end @@ -320,27 +333,168 @@ module Make_payload_protocol_of_stringable (Stringable : Stringable) : end end -module Stringable_const_jkind = struct - type t = const_jkind +module Make_payload_protocol_of_stringable (Stringable : Stringable) : + Payload_protocol with type t := Stringable.t = + Make_payload_protocol_of_structure_item_encodable + (Make_structure_item_encodable_of_stringable (Stringable)) + +(* only used for [Jkind] below *) +module Mode = struct + module Protocol = Make_payload_protocol_of_stringable (struct + type t = mode + + let indefinite_article_and_name = "a", "mode" + + let to_string (Mode s) = s - let indefinite_article_and_name = "a", "layout" + let of_string' s = Mode s - let to_string = jkind_to_string + let of_string s = Some (of_string' s) + end) - let of_string t = Some (jkind_of_string t) + let list_as_payload = Protocol.Encode.list_as_payload + + let list_from_payload = Protocol.Decode.list_from_payload end -module Jkinds_pprint = struct - let const_jkind fmt cl = - Format.pp_print_string fmt (Stringable_const_jkind.to_string cl) +module Jkind = struct + module Const : sig + type raw = string + + type t = private raw loc + + val mk : string -> Location.t -> t - let jkind_annotation fmt ann = const_jkind fmt ann.txt + val of_structure_item : structure_item -> t option + + val to_structure_item : t -> structure_item + end = struct + type raw = string + + module Protocol = Make_structure_item_encodable_of_stringable (struct + type t = raw + + let indefinite_article_and_name = "a", "primitive kind" + + let to_string t = t + + let of_string t = Some t + end) + + type t = raw loc + + let mk txt loc : t = { txt; loc } + + let of_structure_item = Protocol.of_structure_item + + let to_structure_item = Protocol.to_structure_item + end + + type t = + | Default + | Primitive_layout_or_abbreviation of Const.t + | Mod of t * mode loc list + | With of t * core_type + | Kind_of of core_type + + type annotation = t loc + + let indefinite_article_and_name = "a", "kind" + + let prefix = "jane.erasable.layouts." + + let struct_item_of_attr attr = + { pstr_desc = Pstr_attribute attr; pstr_loc = Location.none } + + let struct_item_to_attr item = + match item with + | { pstr_desc = Pstr_attribute attr; _ } -> Some attr + | _ -> None + + let struct_item_of_type ty = + { pstr_desc = + Pstr_type + (Recursive, [Ast_helper.Type.mk ~manifest:ty (Location.mknoloc "t")]); + pstr_loc = Location.none + } + + let struct_item_to_type item = + match item with + | { pstr_desc = Pstr_type (Recursive, [decl]); _ } -> decl.ptype_manifest + | _ -> None + + let struct_item_of_list name list loc = + struct_item_of_attr + { attr_name = Location.mknoloc (prefix ^ name); + attr_payload = PStr list; + attr_loc = loc + } + + let struct_item_to_list item = + let strip_prefix s = + let prefix_len = String.length prefix in + String.sub s prefix_len (String.length s - prefix_len) + in + match item with + | { pstr_desc = + Pstr_attribute + { attr_name = name; attr_payload = PStr list; attr_loc = loc }; + _ + } + when String.starts_with ~prefix name.txt -> + Some (strip_prefix name.txt, list, loc) + | _ -> None + + let rec to_structure_item t_loc = + let to_structure_item t = to_structure_item (Location.mknoloc t) in + match t_loc.txt with + | Default -> struct_item_of_list "default" [] t_loc.loc + | Primitive_layout_or_abbreviation c -> + struct_item_of_list "prim" [Const.to_structure_item c] t_loc.loc + | Mod (t, modes) -> + let mode_list_item = + struct_item_of_attr + { attr_name = Location.mknoloc (prefix ^ "mod"); + attr_payload = Mode.list_as_payload modes; + attr_loc = Location.none + } + in + struct_item_of_list "mod" [to_structure_item t; mode_list_item] t_loc.loc + | With (t, ty) -> + struct_item_of_list "with" + [to_structure_item t; struct_item_of_type ty] + t_loc.loc + | Kind_of ty -> + struct_item_of_list "kind_of" [struct_item_of_type ty] t_loc.loc + + let rec of_structure_item item = + let bind = Option.bind in + let ret loc v = Some (Location.mkloc v loc) in + match struct_item_to_list item with + | Some ("default", [], loc) -> ret loc Default + | Some ("mod", [item_of_t; item_of_mode_expr], loc) -> + bind (of_structure_item item_of_t) (fun { txt = t } -> + bind (struct_item_to_attr item_of_mode_expr) (fun attr -> + let modes = + Mode.list_from_payload ~loc attr.attr_payload + in + ret loc (Mod (t, modes)))) + | Some ("with", [item_of_t; item_of_ty], loc) -> + bind (of_structure_item item_of_t) (fun { txt = t } -> + bind (struct_item_to_type item_of_ty) (fun ty -> + ret loc (With (t, ty)))) + | Some ("kind_of", [item_of_ty], loc) -> + bind (struct_item_to_type item_of_ty) (fun ty -> ret loc (Kind_of ty)) + | Some ("prim", [item], loc) -> + bind (Const.of_structure_item item) (fun c -> + ret loc (Primitive_layout_or_abbreviation c)) + | Some _ | None -> None end (** Jkind annotations' encoding as attribute payload, used in both n-ary functions and jkinds. *) module Jkind_annotation : sig - include Payload_protocol with type t := const_jkind + include Payload_protocol with type t := Jkind.t module Decode : sig include module type of Decode @@ -349,10 +503,10 @@ module Jkind_annotation : sig loc:Location.t -> string Location.loc list -> payload -> - (string Location.loc * jkind_annotation option) list + (string Location.loc * Jkind.annotation option) list end end = struct - module Protocol = Make_payload_protocol_of_stringable (Stringable_const_jkind) + module Protocol = Make_payload_protocol_of_structure_item_encodable (Jkind) (*******************************************************) (* Conversions with a payload *) @@ -364,20 +518,12 @@ end = struct module Desugaring_error = struct type error = - | Wrong_number_of_jkinds of int * jkind_annotation option list + | Wrong_number_of_jkinds of int * Jkind.annotation option list let report_error ~loc = function - | Wrong_number_of_jkinds (n, jkinds) -> + | Wrong_number_of_jkinds (n, _jkinds) -> Location.errorf ~loc - "Wrong number of layouts in an layout attribute;@;\ - expecting %i but got this list:@;\ - %a" - n - (Format.pp_print_list - (Format.pp_print_option - ~none:(fun ppf () -> Format.fprintf ppf "None") - Jkinds_pprint.jkind_annotation)) - jkinds + "Wrong number of kinds in an kind attribute;@;expecting %i." n exception Error of Location.t * error @@ -658,7 +804,7 @@ module N_ary_functions = struct type function_param_desc = | Pparam_val of arg_label * expression option * pattern - | Pparam_newtype of string loc * jkind_annotation option + | Pparam_newtype of string loc * Jkind.annotation option type function_param = { pparam_desc : function_param_desc; @@ -689,7 +835,7 @@ module N_ary_functions = struct type t = | Top_level | Fun_then of after_fun - | Jkind_annotation of const_jkind loc + | Jkind_annotation of Jkind.annotation (* We return an [of_suffix_result] from [of_suffix] rather than having [of_suffix] interpret the payload for two reasons: @@ -743,7 +889,7 @@ module N_ary_functions = struct | Expected_constraint_or_coerce | Expected_function_cases of Attribute_node.t | Expected_fun_or_newtype of Attribute_node.t - | Expected_newtype_with_jkind_annotation of jkind_annotation + | Expected_newtype_with_jkind_annotation of Jkind.annotation | Parameterless_function let report_error ~loc = function @@ -1187,6 +1333,13 @@ module Labeled_tuples = struct labeled_components, ptyp_attributes | _ -> Desugaring_error.raise typ.ptyp_loc Malformed + (* We wrap labeled tuple expressions in an additional extension node + so that tools that inspect the OCaml syntax tree are less likely + to treat a labeled tuple as a regular tuple. + *) + let labeled_tuple_extension_node_name = + Embedded_name.of_feature feature [] |> Embedded_name.to_string + let expr_of ~loc el = match check_for_any_label el with | No_labels el -> Ast_helper.Exp.tuple ~loc el @@ -1195,7 +1348,10 @@ module Labeled_tuples = struct Expression.make_entire_jane_syntax ~loc feature (fun () -> let names = List.map (fun (label, _) -> string_of_label label) el in Expression.make_jane_syntax feature names - @@ Ast_helper.Exp.tuple (List.map snd el)) + @@ Ast_helper.Exp.apply + (Ast_helper.Exp.extension + (Location.mknoloc labeled_tuple_extension_node_name, PStr [])) + [Nolabel, Ast_helper.Exp.tuple (List.map snd el)]) (* Returns remaining unconsumed attributes *) let of_expr expr = @@ -1203,7 +1359,10 @@ module Labeled_tuples = struct expand_labeled_tuple_extension expr.pexp_loc expr.pexp_attributes in match expr.pexp_desc with - | Pexp_tuple components -> + | Pexp_apply + ( { pexp_desc = Pexp_extension (name, PStr []) }, + [(Nolabel, { pexp_desc = Pexp_tuple components; _ })] ) + when String.equal name.txt labeled_tuple_extension_node_name -> if List.length labels <> List.length components then Desugaring_error.raise expr.pexp_loc Malformed; let labeled_components = @@ -1320,35 +1479,36 @@ module Layouts = struct type nonrec expression = | Lexp_constant of constant - | Lexp_newtype of string loc * jkind_annotation * expression + | Lexp_newtype of string loc * Jkind.annotation * expression type nonrec pattern = Lpat_constant of constant type nonrec core_type = | Ltyp_var of { name : string option; - jkind : jkind_annotation + jkind : Jkind.annotation } | Ltyp_poly of - { bound_vars : (string loc * jkind_annotation option) list; + { bound_vars : (string loc * Jkind.annotation option) list; inner_type : core_type } | Ltyp_alias of { aliased_type : core_type; name : string option; - jkind : jkind_annotation + jkind : Jkind.annotation } type nonrec extension_constructor = | Lext_decl of - (string Location.loc * jkind_annotation option) list + (string Location.loc * Jkind.annotation option) list * constructor_arguments * Parsetree.core_type option - (*******************************************************) - (* Pretty-printing *) + type signature_item = + | Lsig_kind_abbrev of string Location.loc * Jkind.annotation - module Pprint = Jkinds_pprint + type structure_item = + | Lstr_kind_abbrev of string Location.loc * Jkind.annotation (*******************************************************) (* Errors *) @@ -1696,6 +1856,56 @@ module Layouts = struct let of_type_declaration = Type_declaration.make_of_ast ~of_ast_internal:of_type_declaration_internal + + (*********************************************************) + (* Constructing a [signature_item] for kind_abbrev *) + + let attr_name_of { txt = name; loc } = + let embed = Embedded_name.of_feature feature ["kind_abbrev"; name] in + Location.mkloc (Embedded_name.to_string embed) loc + + let of_attr_name { txt = attr_name; loc } = + let name = + match Embedded_name.of_string attr_name with + | Some (Ok embed) -> ( + match Embedded_name.components embed with + | _ :: ["kind_abbrev"; name] -> name + | _ -> failwith "Malformed [kind_abbrev] attribute") + | None | Some (Error _) -> failwith "Malformed [kind_abbrev] attribute" + in + Location.mkloc name loc + + let sig_item_of ~loc = function + | Lsig_kind_abbrev (name, jkind) -> + (* See Note [Wrapping with make_entire_jane_syntax] *) + Signature_item.make_entire_jane_syntax ~loc feature (fun () -> + let payload = Encode.as_payload jkind in + Ast_helper.Sig.attribute + (Ast_helper.Attr.mk (attr_name_of name) payload)) + + let of_sig_item sigi = + match sigi.psig_desc with + | Psig_attribute { attr_name; attr_payload; _ } -> + Lsig_kind_abbrev + ( of_attr_name attr_name, + Decode.from_payload ~loc:sigi.psig_loc attr_payload ) + | _ -> failwith "Malformed [kind_abbrev] in signature" + + let str_item_of ~loc = function + | Lstr_kind_abbrev (name, jkind) -> + (* See Note [Wrapping with make_entire_jane_syntax] *) + Structure_item.make_entire_jane_syntax ~loc feature (fun () -> + let payload = Encode.as_payload jkind in + Ast_helper.Str.attribute + (Ast_helper.Attr.mk (attr_name_of name) payload)) + + let of_str_item stri = + match stri.pstr_desc with + | Pstr_attribute { attr_name; attr_payload; _ } -> + Lstr_kind_abbrev + ( of_attr_name attr_name, + Decode.from_payload ~loc:stri.pstr_loc attr_payload ) + | _ -> failwith "Malformed [kind_abbrev] in structure" end (******************************************************************************) @@ -1854,24 +2064,32 @@ module Module_type = struct end module Signature_item = struct - type t = Jsig_include_functor of Include_functor.signature_item + type t = + | Jsig_include_functor of Include_functor.signature_item + | Jsig_layout of Layouts.signature_item let of_ast_internal (feat : Feature.t) sigi = match feat with | Language_extension Include_functor -> Some (Jsig_include_functor (Include_functor.of_sig_item sigi)) + | Language_extension Layouts -> + Some (Jsig_layout (Layouts.of_sig_item sigi)) | _ -> None let of_ast = Signature_item.make_of_ast ~of_ast_internal end module Structure_item = struct - type t = Jstr_include_functor of Include_functor.structure_item + type t = + | Jstr_include_functor of Include_functor.structure_item + | Jstr_layout of Layouts.structure_item let of_ast_internal (feat : Feature.t) stri = match feat with | Language_extension Include_functor -> Some (Jstr_include_functor (Include_functor.of_str_item stri)) + | Language_extension Layouts -> + Some (Jstr_layout (Layouts.of_str_item stri)) | _ -> None let of_ast = Structure_item.make_of_ast ~of_ast_internal diff --git a/vendor/parser-standard/jane_syntax.mli b/vendor/parser-standard/jane_syntax.mli index 4a421504d4..3480876585 100644 --- a/vendor/parser-standard/jane_syntax.mli +++ b/vendor/parser-standard/jane_syntax.mli @@ -100,6 +100,30 @@ module Immutable_arrays : sig val pat_of : loc:Location.t -> pattern -> Parsetree.pattern end +module Jkind : sig + module Const : sig + (** Constant jkind *) + + type raw = string + + (** Represent a user-written kind primitive/abbreviation, + containing a string and its location *) + type t = private raw Location.loc + + (** Constructs a jkind constant *) + val mk : string -> Location.t -> t + end + + type t = + | Default + | Primitive_layout_or_abbreviation of Const.t + | Mod of t * Parsetree.mode Location.loc list + | With of t * Parsetree.core_type + | Kind_of of Parsetree.core_type + + type annotation = t Location.loc +end + module N_ary_functions : sig (** These types use the [P] prefix to match how they are represented in the upstream compiler *) @@ -134,8 +158,7 @@ module N_ary_functions : sig Note: If [E0] is provided, only {{!Asttypes.arg_label.Optional}[Optional]} is allowed. *) - | Pparam_newtype of - string Asttypes.loc * Jane_asttypes.jkind_annotation option + | Pparam_newtype of string Asttypes.loc * Jkind.annotation option (** [Pparam_newtype (x, jkind)] represents the parameter [(type x)]. [x] carries the location of the identifier, whereas [pparam_loc] is the location of the [(type x)] as a whole. @@ -283,9 +306,7 @@ module Layouts : sig (* [fun (type a : immediate) -> ...] *) (* This is represented as an attribute wrapping a [Pexp_newtype] node. *) | Lexp_newtype of - string Location.loc - * Jane_asttypes.jkind_annotation - * Parsetree.expression + string Location.loc * Jkind.annotation * Parsetree.expression type nonrec pattern = (* examples: [ #2.0 ] or [ #42L ] *) @@ -298,7 +319,7 @@ module Layouts : sig a [Ptyp_var] node. *) | Ltyp_var of { name : string option; - jkind : Jane_asttypes.jkind_annotation + jkind : Jkind.annotation } (* [('a : immediate) 'b 'c ('d : value). 'a -> 'b -> 'c -> 'd] *) (* This is represented by an attribute wrapping a [Ptyp_poly] node. *) @@ -308,8 +329,7 @@ module Layouts : sig parsed representation and guarantees that we don't accidentally try to require the layouts extension. *) | Ltyp_poly of - { bound_vars : - (string Location.loc * Jane_asttypes.jkind_annotation option) list; + { bound_vars : (string Location.loc * Jkind.annotation option) list; inner_type : Parsetree.core_type } (* [ty as ('a : immediate)] *) @@ -319,7 +339,7 @@ module Layouts : sig | Ltyp_alias of { aliased_type : Parsetree.core_type; name : string option; - jkind : Jane_asttypes.jkind_annotation + jkind : Jkind.annotation } type nonrec extension_constructor = @@ -328,16 +348,15 @@ module Layouts : sig (* Like [Ltyp_poly], this is used only when there is at least one jkind annotation. Otherwise, we will have a [Pext_decl]. *) | Lext_decl of - (string Location.loc * Jane_asttypes.jkind_annotation option) list + (string Location.loc * Jkind.annotation option) list * Parsetree.constructor_arguments * Parsetree.core_type option - module Pprint : sig - val const_jkind : Format.formatter -> Jane_asttypes.const_jkind -> unit + type signature_item = + | Lsig_kind_abbrev of string Location.loc * Jkind.annotation - val jkind_annotation : - Format.formatter -> Jane_asttypes.jkind_annotation -> unit - end + type structure_item = + | Lstr_kind_abbrev of string Location.loc * Jkind.annotation val expr_of : loc:Location.t -> expression -> Parsetree.expression @@ -359,8 +378,7 @@ module Layouts : sig loc:Location.t -> attrs:Parsetree.attributes -> info:Docstrings.info -> - vars_jkinds: - (string Location.loc * Jane_asttypes.jkind_annotation option) list -> + vars_jkinds:(string Location.loc * Jkind.annotation option) list -> args:Parsetree.constructor_arguments -> res:Parsetree.core_type option -> string Location.loc -> @@ -372,7 +390,7 @@ module Layouts : sig the remaining pieces of the original [constructor_declaration]. *) val of_constructor_declaration : Parsetree.constructor_declaration -> - ((string Location.loc * Jane_asttypes.jkind_annotation option) list + ((string Location.loc * Jkind.annotation option) list * Parsetree.attributes) option @@ -389,10 +407,14 @@ module Layouts : sig kind:Parsetree.type_kind -> priv:Asttypes.private_flag -> manifest:Parsetree.core_type option -> - jkind:Jane_asttypes.jkind_annotation option -> + jkind:Jkind.annotation option -> string Location.loc -> Parsetree.type_declaration + val sig_item_of : loc:Location.t -> signature_item -> Parsetree.signature_item + + val str_item_of : loc:Location.t -> structure_item -> Parsetree.structure_item + (** Extract the jkind annotation from a [type_declaration]; returns leftover attributes. Similar to [of_constructor_declaration] in the sense that users of this function will have to process the remaining @@ -400,7 +422,7 @@ module Layouts : sig *) val of_type_declaration : Parsetree.type_declaration -> - (Jane_asttypes.jkind_annotation * Parsetree.attributes) option + (Jkind.annotation * Parsetree.attributes) option end (******************************************) @@ -554,14 +576,18 @@ end (** Novel syntax in signature items *) module Signature_item : sig - type t = Jsig_include_functor of Include_functor.signature_item + type t = + | Jsig_include_functor of Include_functor.signature_item + | Jsig_layout of Layouts.signature_item include AST with type t := t and type ast := Parsetree.signature_item end (** Novel syntax in structure items *) module Structure_item : sig - type t = Jstr_include_functor of Include_functor.structure_item + type t = + | Jstr_include_functor of Include_functor.structure_item + | Jstr_layout of Layouts.structure_item include AST with type t := t and type ast := Parsetree.structure_item end diff --git a/vendor/parser-standard/jane_syntax_parsing.mli b/vendor/parser-standard/jane_syntax_parsing.mli index d70486c2f9..e2869df666 100644 --- a/vendor/parser-standard/jane_syntax_parsing.mli +++ b/vendor/parser-standard/jane_syntax_parsing.mli @@ -103,6 +103,10 @@ module Feature : sig val extension_component : t -> string end +module Misnamed_embedding_error : sig + type t +end + (** An AST-style representation of the names used when generating extension nodes or attributes for modular syntax. We use this to abstract over the details of how they're encoded, so we have some flexibility in changing them @@ -137,6 +141,8 @@ module Embedded_name : sig infrastructure in this module, such as the dummy argument extension *) val to_string : t -> string + val of_string : string -> (t, Misnamed_embedding_error.t) result option + (** Print out the embedded form of a Jane-syntax name, in quotes; for use in error messages. *) val pp_quoted_name : Format.formatter -> t -> unit diff --git a/vendor/parser-standard/language_extension.ml b/vendor/parser-standard/language_extension.ml index 377941b0ea..5e8e3c95a7 100644 --- a/vendor/parser-standard/language_extension.ml +++ b/vendor/parser-standard/language_extension.ml @@ -79,7 +79,7 @@ module Exist_pair = struct | Pair (Layouts, m) -> m | Pair (SIMD, ()) -> Stable | Pair (Labeled_tuples, ()) -> Stable - | Pair (Small_numbers, ()) -> Alpha + | Pair (Small_numbers, ()) -> Beta let is_erasable : t -> bool = function Pair (ext, _) -> is_erasable ext diff --git a/vendor/parser-standard/parser.mly b/vendor/parser-standard/parser.mly index 24d911c4cb..ae1fb7d5eb 100644 --- a/vendor/parser-standard/parser.mly +++ b/vendor/parser-standard/parser.mly @@ -1749,8 +1749,9 @@ structure_item: | kind_abbreviation_decl { let name, jkind = $1 in - ignore (name, jkind); - Misc.fatal_error "jkind syntax not implemented" + Jane_syntax.Layouts.(str_item_of + ~loc:(make_loc $sloc) + (Lstr_kind_abbrev (name, jkind))) } ; @@ -2027,8 +2028,9 @@ signature_item: | kind_abbreviation_decl { let name, jkind = $1 in - ignore (name, jkind); - Misc.fatal_error "jkind syntax not implemented" + Jane_syntax.Layouts.(sig_item_of + ~loc:(make_loc $sloc) + (Lsig_kind_abbrev (name, jkind))) } (* A module declaration. *) @@ -2583,32 +2585,42 @@ labeled_simple_pattern: { (Labelled (fst $2), None, snd $2) } | LABEL simple_pattern { (Labelled $1, None, $2) } + | LABEL LPAREN modes0=optional_mode_expr_legacy x=let_pattern_required_modes RPAREN + { let pat, cty, modes = x in + (Labelled $1, None, + mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes:(modes0 @ modes)) + } | LABEL LPAREN modes=mode_expr_legacy pat=pattern RPAREN { (Labelled $1, None, mkpat_with_modes ~loc:$sloc ~pat ~cty:None ~modes) } | simple_pattern { (Nolabel, None, $1) } - | LPAREN modes0=mode_expr_legacy x=let_pattern RPAREN - { let pat, cty, modes = x in + | LPAREN modes=mode_expr_legacy x=let_pattern_no_modes RPAREN + { let pat, cty = x in (Nolabel, None, - mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes:(modes0 @ modes)) + mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes) } - | LABEL LPAREN x=poly_pattern RPAREN - { let pat, cty, modes = x in - (Labelled $1, None, - mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes) - } - | LABEL LPAREN modes0=mode_expr_legacy x=poly_pattern RPAREN + | LPAREN modes0=optional_mode_expr_legacy x=let_pattern_required_modes RPAREN { let pat, cty, modes = x in + (Nolabel, None, + mkpat_with_modes ~loc:$sloc ~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:$sloc ~pat ~cty ~modes:(modes0 @ modes)) + mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes:[]) } - | LPAREN x=poly_pattern RPAREN - { let pat, cty, modes = x in - (Nolabel, None, + | LABEL LPAREN modes=mode_expr_legacy x=poly_pattern_no_modes RPAREN + { let pat, cty = x in + (Labelled $1, None, mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes) } + | LPAREN x=poly_pattern_no_modes RPAREN + { let pat, cty = x in + (Nolabel, None, + mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes:[]) + } ; pattern_var: @@ -2646,23 +2658,45 @@ 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 } + 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 poly_pattern: +%inline let_pattern_awaiting_atat_modes: + pat=pattern COLON cty=core_type + { pat, Some cty } + | poly_pattern_no_modes + { $1 } +; + +%inline let_pattern_awaiting_at_modes: + pat=pattern { pat, None } +; + +%inline poly_pattern_no_modes: pat = pattern COLON cty = mktyp_jane_syntax_ltyp(bound_vars = typevar_list DOT inner_type = core_type { Jane_syntax.Layouts.Ltyp_poly { bound_vars; inner_type } }) - modes = optional_atat_mode_expr - { pat, Some cty, modes } + { pat, Some cty } ; %inline indexop_expr(dot, index, right): @@ -3594,10 +3628,24 @@ simple_pattern_not_ident: | extension { Ppat_extension $1 } ) { $1 } - | 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)) } + (* 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 ~loc:$sloc (Ppat_constraint($2, Some $4, [])) } + (* 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: @@ -3821,21 +3869,26 @@ type_parameters: jkind: jkind MOD mkrhs(LIDENT)+ { (* LIDENTs here are for modes *) - Misc.fatal_error "jkind syntax not implemented" + let modes = + List.map + (fun {txt; loc} -> {txt = Mode txt; loc}) + $3 + in + Jane_syntax.Jkind.Mod ($1, modes) } | jkind WITH core_type { - Misc.fatal_error "jkind syntax not implemented" + Jane_syntax.Jkind.With ($1, $3) } | mkrhs(ident) { - let { txt; _ } = $1 in - Jane_asttypes.jkind_of_string txt + let {txt; loc} = $1 in + Jane_syntax.Jkind.(Primitive_layout_or_abbreviation + (Const.mk txt loc)) } | KIND_OF ty=core_type { - ignore ty; - Misc.fatal_error "jkind syntax not implemented" + Jane_syntax.Jkind.Kind_of ty } | UNDERSCORE { - Misc.fatal_error "jkind syntax not implemented" + Jane_syntax.Jkind.Default } ;