diff --git a/analysis/reanalyze/src/annotation.ml b/analysis/reanalyze/src/annotation.ml index 9e11949b09e..81b496fa287 100644 --- a/analysis/reanalyze/src/annotation.ml +++ b/analysis/reanalyze/src/annotation.ml @@ -83,10 +83,7 @@ let has_attribute check_text (attributes : Typedtree.attributes) = get_attribute_payload check_text attributes <> None let is_ocaml_suppress_dead_warning attributes = - match - attributes - |> get_attribute_payload (fun x -> x = "ocaml.warning" || x = "warning") - with + match attributes |> get_attribute_payload (fun x -> x = "warning") with | Some (StringPayload s) -> let numeric = match Str.search_forward (Str.regexp (Str.quote "-32")) s 0 with diff --git a/analysis/reanalyze/src/arnold.ml b/analysis/reanalyze/src/arnold.ml index 93d7e412d51..6b078c99c0c 100644 --- a/analysis/reanalyze/src/arnold.ml +++ b/analysis/reanalyze/src/arnold.ml @@ -1033,12 +1033,8 @@ module Compile = struct | Texp_pack _ -> not_implemented "Texp_pack"; assert false - | Texp_extension_constructor _ when true -> - not_implemented "Texp_extension_constructor"; - assert false - | _ -> - (* ocaml 4.08: Texp_letop(_) | Texp_open(_) *) - not_implemented "Texp_letop(_) | Texp_open(_)"; + | Texp_break | Texp_continue -> + not_implemented "Texp_break | Texp_continue"; assert false and expression_opt ~ctx e_opt = diff --git a/analysis/reanalyze/src/side_effects.ml b/analysis/reanalyze/src/side_effects.ml index 24ed895bee1..45b38e3f1ac 100644 --- a/analysis/reanalyze/src/side_effects.ml +++ b/analysis/reanalyze/src/side_effects.ml @@ -78,8 +78,6 @@ let rec expr_no_side_effects (expr : Typedtree.expression) = | Texp_object_set _ -> false | Texp_letexception (_ec, e) -> e |> expr_no_side_effects | Texp_pack _ -> false - | Texp_extension_constructor _ when true -> true - | _ -> (* on ocaml 4.08: Texp_letop | Texp_open *) true and expr_opt_no_side_effects eo = match eo with diff --git a/analysis/src/process_attributes.ml b/analysis/src/process_attributes.ml index 4c64684c4d0..3c025dec4c4 100644 --- a/analysis/src/process_attributes.ml +++ b/analysis/src/process_attributes.ml @@ -4,8 +4,7 @@ open Shared_types let rec find_doc_attribute attributes = match attributes with | [] -> None - | ({Asttypes.txt = "ocaml.doc" | "ocaml.text" | "ns.doc" | "res.doc"}, payload) - :: rest -> ( + | ({Asttypes.txt = "ocaml.doc" | "ns.doc" | "res.doc"}, payload) :: rest -> ( match Ast_payload.semantic_string_of_payload payload with | Some doc -> Some doc | None -> find_doc_attribute rest) diff --git a/changes/remove-ocaml-attribute-aliases.breaking.md b/changes/remove-ocaml-attribute-aliases.breaking.md new file mode 100644 index 00000000000..8ef10011cce --- /dev/null +++ b/changes/remove-ocaml-attribute-aliases.breaking.md @@ -0,0 +1 @@ +- Remove the OCaml attribute spellings `@ocaml.deprecated`, `@ocaml.unboxed`, `@ocaml.immediate`, `@ocaml.warnerror`, `@ocaml.warning`, `@ocaml.ppwarning`, `@ocaml.boxed`, `@ocaml.deprecated_mutable`, `@ocaml.text` and `%ocaml.error`, and the `%extension_constructor` extension. `@boxed` and `@deprecated_mutable` are no longer interpreted and are ignored. PPX output keeps working: the PPX bridge renames `ocaml.warning`, `ocaml.ppwarning` and `ocaml.error` to the bare names. diff --git a/compiler/core/cmd_ppx_apply.ml b/compiler/core/cmd_ppx_apply.ml index be91fe50d66..3cba3b43d42 100644 --- a/compiler/core/cmd_ppx_apply.ml +++ b/compiler/core/cmd_ppx_apply.ml @@ -108,6 +108,7 @@ let apply_rewriters_str ~tool_name ast = Ml_binary.ast0_roundtrip Ml_binary.Ml ast else ast | ppxs -> + Bs_ast_invariant.check_removed_ocaml_spellings_on_structure ast; ast |> Ast_mapper.add_ppx_context_str ~tool_name |> rewrite Ml ppxs |> Ml_binary.ast0_to_structure @@ -120,6 +121,7 @@ let apply_rewriters_sig ~tool_name ast = Ml_binary.ast0_roundtrip Ml_binary.Mli ast else ast | ppxs -> + Bs_ast_invariant.check_removed_ocaml_spellings_on_signature ast; ast |> Ast_mapper.add_ppx_context_sig ~tool_name |> rewrite Mli ppxs |> Ml_binary.ast0_to_signature diff --git a/compiler/ext/config.ml b/compiler/ext/config.ml index 86d5a2dcca3..3febba61945 100644 --- a/compiler/ext/config.ml +++ b/compiler/ext/config.ml @@ -1,4 +1,4 @@ -let cmi_magic_number = "Caml1999I038" +let cmi_magic_number = "Caml1999I039" (* Magic numbers for marshaled values of the *current* parsetree, whose layout changes across compiler versions. *) @@ -13,7 +13,7 @@ and ast0_impl_magic_number = "Caml1999M022" and ast0_intf_magic_number = "Caml1999N022" -and cmt_magic_number = "Caml1999T046" +and cmt_magic_number = "Caml1999T047" let get_load_path () = (Compiler_request_state.current ()).load_path let set_load_path path = (Compiler_request_state.current ()).load_path <- path diff --git a/compiler/frontend/bs_ast_invariant.ml b/compiler/frontend/bs_ast_invariant.ml index 89cec0e9a3c..d7a9e709051 100644 --- a/compiler/frontend/bs_ast_invariant.ml +++ b/compiler/frontend/bs_ast_invariant.ml @@ -33,7 +33,34 @@ let is_checked_attribute txt = true | _ -> false -let warn_unused_attribute ((({txt; loc} as sloc), _) : Parsetree.attribute) = +(* OCaml spellings of builtin attributes the compiler used to accept. *) +let removed_ocaml_attribute txt = + match txt with + | "ocaml.deprecated" -> Some "use `@deprecated` instead." + | "ocaml.unboxed" -> Some "use `@unboxed` instead." + | "ocaml.immediate" -> Some "use `@immediate` instead." + | "ocaml.warnerror" -> Some "use `@warnerror` instead." + | "ocaml.boxed" -> Some "remove it: types are boxed unless marked `@unboxed`." + | "ocaml.deprecated_mutable" -> Some "remove it." + | "ocaml.text" -> Some "use a doc comment instead." + | "ocaml.warning" -> Some "use `@warning` instead." + | "ocaml.ppwarning" -> Some "use `@ppwarning` instead." + | _ -> None + +let check_removed_ocaml_attribute (({txt; loc}, _) : Parsetree.attribute) = + match removed_ocaml_attribute txt with + | Some hint -> + Location.raise_errorf ~loc "`@%s` is no longer supported, %s" txt hint + | None -> () + +let check_removed_ocaml_extension (({txt; loc}, _) : Parsetree.extension) = + if txt = "ocaml.error" then + Location.raise_errorf ~loc + "`%%ocaml.error` is no longer supported, use `%%error` instead." + +let warn_unused_attribute + ((({txt; loc} as sloc), _) as attr : Parsetree.attribute) = + check_removed_ocaml_attribute attr; if is_checked_attribute txt && (not loc.loc_ghost) && not (Used_attributes.is_used_attribute sloc) @@ -71,6 +98,10 @@ let emit_external_warnings : iterator = "built-in type `%s` can not be redefined " txt; super.type_declaration self ptyp); attribute = (fun _ attr -> warn_unused_attribute attr); + extension = + (fun self ext -> + check_removed_ocaml_extension ext; + super.extension self ext); structure_item = (fun self str_item -> match str_item.pstr_desc with @@ -85,7 +116,9 @@ let emit_external_warnings : iterator = expr = (fun self ({pexp_loc = loc} as a) -> match a.pexp_desc with - | Pexp_constant const -> check_constant loc const + | Pexp_constant const -> + check_constant loc const; + self.attributes self a.pexp_attributes | _ -> super.expr self a); label_declaration = (fun self lbl -> @@ -136,7 +169,9 @@ let emit_external_warnings : iterator = pat = (fun self (pat : Parsetree.pattern) -> match pat.ppat_desc with - | Ppat_constant constant -> check_constant pat.ppat_loc constant + | Ppat_constant constant -> + check_constant pat.ppat_loc constant; + self.attributes self pat.ppat_attributes | _ -> super.pat self pat); } @@ -165,3 +200,25 @@ let emit_external_warnings_on_structure (stru : Parsetree.structure) = let emit_external_warnings_on_signature (sigi : Parsetree.signature) = emit_external_warnings.signature emit_external_warnings sigi + +(* The PPX bridge renames the [ocaml.]-prefixed builtins a PPX emits to their + bare names, so source written with them is checked before it reaches the + bridge. *) +let removed_ocaml_spellings : iterator = + { + super with + attribute = + (fun self attr -> + check_removed_ocaml_attribute attr; + super.attribute self attr); + extension = + (fun self ext -> + check_removed_ocaml_extension ext; + super.extension self ext); + } + +let check_removed_ocaml_spellings_on_structure (stru : Parsetree.structure) = + removed_ocaml_spellings.structure removed_ocaml_spellings stru + +let check_removed_ocaml_spellings_on_signature (sigi : Parsetree.signature) = + removed_ocaml_spellings.signature removed_ocaml_spellings sigi diff --git a/compiler/frontend/bs_ast_invariant.mli b/compiler/frontend/bs_ast_invariant.mli index b3b580ebfa5..25e97fbdcb3 100644 --- a/compiler/frontend/bs_ast_invariant.mli +++ b/compiler/frontend/bs_ast_invariant.mli @@ -37,3 +37,9 @@ val iter_warnings_on_sigi : Parsetree.signature -> unit val emit_external_warnings_on_structure : Parsetree.structure -> unit val emit_external_warnings_on_signature : Parsetree.signature -> unit + +val check_removed_ocaml_spellings_on_structure : Parsetree.structure -> unit +(** Reject the [ocaml.]-prefixed builtin attributes and extensions that are no + longer supported. Run on source before external PPXs see it. *) + +val check_removed_ocaml_spellings_on_signature : Parsetree.signature -> unit diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index d08c3ff6a8f..619047539f5 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -640,7 +640,7 @@ let default_mapper = } let rec extension_of_error {loc; msg; if_highlight; sub} = - ( {loc; txt = "ocaml.error"}, + ( {loc; txt = "error"}, PStr ([ Str.eval (Exp.constant (Const.string msg)); diff --git a/compiler/ml/ast_mapper.mli b/compiler/ml/ast_mapper.mli index d16efadec55..6e749a0f824 100644 --- a/compiler/ml/ast_mapper.mli +++ b/compiler/ml/ast_mapper.mli @@ -99,7 +99,7 @@ val default_mapper : mapper (** {1 Convenience functions to write mappers} *) val extension_of_error : Location.error -> extension -(** Encode an error into an 'ocaml.error' extension node which can be +(** Encode an error into an 'error' extension node which can be inserted in a generated Parsetree. The compiler will be responsible for reporting the error. *) diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index 4fc85334ac8..ca5d1021fc4 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -226,6 +226,16 @@ let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} let record_rest_attr_name = "_res.record_rest" let constructor_args_attr_name = "_res.constructor_args" +(* PPXs built on OCaml tooling spell builtin attributes and extensions with an + [ocaml.] prefix: ppxlib reports errors as [%ocaml.error] and lint warnings + as [@@@ocaml.ppwarning]. The compiler reads only the bare names. *) +let bare_builtin_name (name : string Location.loc) = + match name.txt with + | "ocaml.error" -> {name with txt = "error"} + | "ocaml.warning" -> {name with txt = "warning"} + | "ocaml.ppwarning" -> {name with txt = "ppwarning"} + | _ -> name + let has_explicit_arity_attr (attrs : Pt.attributes) = List.exists (function @@ -1669,8 +1679,10 @@ let default_mapper = | None -> this.payload this payload else this.payload this payload in - (map_loc this s, payload)); - attribute = (fun this (s, e) -> (map_loc this s, this.payload this e)); + (map_loc this (bare_builtin_name s), payload)); + attribute = + (fun this (s, e) -> + (map_loc this (bare_builtin_name s), this.payload this e)); attributes = (fun this l -> List.map (this.attribute this) l); payload = (fun this -> function diff --git a/compiler/ml/builtin_attributes.ml b/compiler/ml/builtin_attributes.ml index 6c4c06b28a6..7e81ff3cbe2 100644 --- a/compiler/ml/builtin_attributes.ml +++ b/compiler/ml/builtin_attributes.ml @@ -25,7 +25,7 @@ let string_of_opt_payload p = let rec error_of_extension ext = match ext with - | {txt = ("ocaml.error" | "error") as txt; loc}, p -> ( + | {txt = "error" as txt; loc}, p -> ( let rec sub_from inner = match inner with | {pstr_desc = Pstr_extension (ext, _)} :: rest -> @@ -59,8 +59,7 @@ let cat s1 s2 = let rec deprecated_of_attrs = function | [] -> None - | ({txt = "ocaml.deprecated" | "deprecated"; _}, p) :: _ -> - Some (string_of_opt_payload p) + | ({txt = "deprecated"; _}, p) :: _ -> Some (string_of_opt_payload p) | _ :: tl -> deprecated_of_attrs tl let rec deprecated_of_attrs_with_migrate = function @@ -102,8 +101,6 @@ let rec deprecated_of_attrs_with_migrate = function Some (reason, migration_template, migration_in_pipe_chain_template) | None -> None) | _ -> Some (string_of_opt_payload payload, None, None)) - | ({txt = "ocaml.deprecated"; _}, p) :: _ -> - Some (string_of_opt_payload p, None, None) | _ :: tl -> deprecated_of_attrs_with_migrate tl let check_deprecated ?deprecated_context loc attrs s = @@ -124,27 +121,6 @@ let check_deprecated_inclusion ~def ~use loc attrs1 attrs2 s = | None, _ | Some _, Some _ -> () | Some txt, None -> Location.deprecated ~def ~use loc (cat s txt) -let rec deprecated_mutable_of_attrs = function - | [] -> None - | ({txt = "ocaml.deprecated_mutable" | "deprecated_mutable"; _}, p) :: _ -> - Some (string_of_opt_payload p) - | _ :: tl -> deprecated_mutable_of_attrs tl - -let check_deprecated_mutable loc attrs s = - match deprecated_mutable_of_attrs attrs with - | None -> () - | Some txt -> - Location.deprecated loc (Printf.sprintf "mutating field %s" (cat s txt)) - -let check_deprecated_mutable_inclusion ~def ~use loc attrs1 attrs2 s = - match - (deprecated_mutable_of_attrs attrs1, deprecated_mutable_of_attrs attrs2) - with - | None, _ | Some _, Some _ -> () - | Some txt, None -> - Location.deprecated ~def ~use loc - (Printf.sprintf "mutating field %s" (cat s txt)) - let rec deprecated_of_sig = function | {psig_desc = Psig_attribute a} :: tl -> ( match deprecated_of_attrs [a] with @@ -172,12 +148,9 @@ let warning_attribute ?(ppwarning = true) = (Warnings.Attribute_payload (txt, "A single string literal is expected")) in function - | {txt = ("ocaml.warning" | "warning") as txt; loc}, payload -> - process loc txt false payload - | {txt = ("ocaml.warnerror" | "warnerror") as txt; loc}, payload -> - process loc txt true payload - | {txt = "ocaml.ppwarning" | "ppwarning"}, (PStr [{pstr_loc; _}] as payload) - when ppwarning -> ( + | {txt = "warning" as txt; loc}, payload -> process loc txt false payload + | {txt = "warnerror" as txt; loc}, payload -> process loc txt true payload + | {txt = "ppwarning"}, (PStr [{pstr_loc; _}] as payload) when ppwarning -> ( match string_of_payload payload with | Some s -> Location.prerr_warning pstr_loc (Warnings.Preprocessor s) | None -> ()) @@ -196,25 +169,15 @@ let warning_scope ?ppwarning attrs f = let warn_on_literal_pattern = List.exists (function - | {txt = "ocaml.warn_on_literal_pattern" | "warn_on_literal_pattern"; _}, _ - -> - true + | {txt = "warn_on_literal_pattern"; _}, _ -> true | _ -> false) let immediate = List.exists (function - | {txt = "ocaml.immediate" | "immediate"; _}, _ -> true + | {txt = "immediate"; _}, _ -> true | _ -> false) -(* The "ocaml.boxed (default)" and "ocaml.unboxed (default)" - attributes cannot be input by the user, they are added by the - compiler when applying the default setting. This is done to record - in the .cmi the default used by the compiler when compiling the - source file because the default can change between compiler - invocations. *) - -let check l (x, _) = List.mem x.txt l - -let has_unboxed attr = List.exists (check ["ocaml.unboxed"; "unboxed"]) attr - -let has_boxed attr = List.exists (check ["ocaml.boxed"; "boxed"]) attr +let has_unboxed = + List.exists (function + | {txt = "unboxed"; _}, _ -> true + | _ -> false) diff --git a/compiler/ml/builtin_attributes.mli b/compiler/ml/builtin_attributes.mli index 24b3fd2d436..5c9d8637dd3 100644 --- a/compiler/ml/builtin_attributes.mli +++ b/compiler/ml/builtin_attributes.mli @@ -15,15 +15,14 @@ (* Support for some of the builtin attributes: - ocaml.deprecated - ocaml.error - ocaml.ppwarning - ocaml.warning - ocaml.warnerror - ocaml.warn_on_literal_pattern - ocaml.deprecated_mutable - ocaml.immediate - ocaml.boxed / ocaml.unboxed + deprecated + error + ppwarning + warning + warnerror + warn_on_literal_pattern + immediate + unboxed *) val check_deprecated : @@ -44,26 +43,14 @@ val deprecated_of_attrs : Parsetree.attributes -> string option val deprecated_of_sig : Parsetree.signature -> string option val deprecated_of_str : Parsetree.structure -> string option -val check_deprecated_mutable : - Location.t -> Parsetree.attributes -> string -> unit -val check_deprecated_mutable_inclusion : - def:Location.t -> - use:Location.t -> - Location.t -> - Parsetree.attributes -> - Parsetree.attributes -> - string -> - unit - val error_of_extension : Parsetree.extension -> Location.error val warning_attribute : ?ppwarning:bool -> Parsetree.attribute -> unit (** Apply warning settings from the specified attribute. - "ocaml.warning"/"ocaml.warnerror" (and variants without the prefix) - are processed and other attributes are ignored. + "warning" and "warnerror" are processed and other attributes are + ignored. - Also implement ocaml.ppwarning (unless ~ppwarning:false is - passed). + Also implement ppwarning (unless ~ppwarning:false is passed). *) val warning_scope : @@ -83,4 +70,3 @@ val warn_on_literal_pattern : Parsetree.attributes -> bool val immediate : Parsetree.attributes -> bool val has_unboxed : Parsetree.attributes -> bool -val has_boxed : Parsetree.attributes -> bool diff --git a/compiler/ml/depend.ml b/compiler/ml/depend.ml index 82960f38b3b..63930784866 100644 --- a/compiler/ml/depend.ml +++ b/compiler/ml/depend.ml @@ -90,7 +90,7 @@ let addmodule bv lid = add_path bv lid.txt let handle_extension ext = match (fst ext).txt with - | "error" | "ocaml.error" -> + | "error" -> raise (Location.Error (Builtin_attributes.error_of_extension ext)) | _ -> () @@ -313,12 +313,6 @@ let rec add_expr bv exp = | Pexp_open (_ovf, m, e) -> let bv = open_module bv m.txt in add_expr bv e - | Pexp_extension - (( {txt = "ocaml.extension_constructor" | "extension_constructor"; _}, - PStr [item] ) as e) -> ( - match item.pstr_desc with - | Pstr_eval ({pexp_desc = Pexp_construct (c, {txt = []})}, _) -> add bv c - | _ -> handle_extension e) | Pexp_extension e -> handle_extension e | Pexp_raw _ -> () | Pexp_await e -> add_expr bv e diff --git a/compiler/ml/includecore.ml b/compiler/ml/includecore.ml index 026858e5657..712958ff8ba 100644 --- a/compiler/ml/includecore.ml +++ b/compiler/ml/includecore.ml @@ -223,7 +223,7 @@ let report_type_mismatch first second decl ppf = else Format.fprintf ppf "@ %a." (report_type_mismatch0 first second decl) err) -let rec compare_constructor_arguments ~loc env cstr params1 params2 arg1 arg2 = +let rec compare_constructor_arguments env cstr params1 params2 arg1 arg2 = match (arg1, arg2) with | Types.Cstr_tuple arg1, Types.Cstr_tuple arg2 -> if List.length arg1 <> List.length arg2 then [Field_arity cstr] @@ -233,7 +233,7 @@ let rec compare_constructor_arguments ~loc env cstr params1 params2 arg1 arg2 = then [] else [Field_type cstr] | Types.Cstr_record l1, Types.Cstr_record l2 -> - compare_records env ~loc params1 params2 0 l1 l2 + compare_records env params1 params2 0 l1 l2 | _ -> [Field_type cstr] and compare_variants ~loc env params1 params2 ~layout1 ~layout2 n @@ -254,12 +254,12 @@ and compare_variants ~loc env params1 params2 ~layout1 ~layout2 n match (cd1.cd_res, cd2.cd_res) with | Some r1, Some r2 -> if Ctype.equal env true [r1] [r2] then - compare_constructor_arguments ~loc env cd1.cd_id [r1] [r2] - cd1.cd_args cd2.cd_args + compare_constructor_arguments env cd1.cd_id [r1] [r2] cd1.cd_args + cd2.cd_args else [Field_type cd1.cd_id] | Some _, None | None, Some _ -> [Field_type cd1.cd_id] | _ -> - compare_constructor_arguments ~loc env cd1.cd_id params1 params2 + compare_constructor_arguments env cd1.cd_id params1 params2 cd1.cd_args cd2.cd_args in let r = @@ -278,7 +278,7 @@ and compare_variants ~loc env params1 params2 ~layout1 ~layout2 n compare_variants ~loc env params1 params2 ~layout1 ~layout2 (n + 1) rem1 rem2) -and compare_records ~loc env params1_ params2_ n_ +and compare_records env params1_ params2_ n_ (labels1_ : Types.label_declaration list) (labels2_ : Types.label_declaration list) = (* First try a fast path that checks if all the fields at once are consistent. @@ -292,15 +292,12 @@ and compare_records ~loc env params1_ params2_ n_ else [] | [], l :: _ -> [Field_missing (true, l.Types.ld_id)] | l :: _, [] -> [Field_missing (false, l.Types.ld_id)] - | ld1 :: rem1, ld2 :: rem2 -> + | ld1 :: rem1, ld2 :: rem2 -> ( if Ident.name ld1.ld_id <> Ident.name ld2.ld_id then [Field_names (n, ld1.ld_id.name, ld2.ld_id.name)] else if ld1.ld_mutable <> ld2.ld_mutable then [Field_mutable ld1.ld_id] else if ld1.ld_optional <> ld2.ld_optional then [Field_optional ld1.ld_id] - else ( - Builtin_attributes.check_deprecated_mutable_inclusion ~def:ld1.ld_loc - ~use:ld2.ld_loc loc ld1.ld_attributes ld2.ld_attributes - (Ident.name ld1.ld_id); + else let name1 = Record_runtime.declaration_name ld1 in let name2 = Record_runtime.declaration_name ld2 in match name1 <> name2 with @@ -411,7 +408,7 @@ let type_declarations ?(equality = false) ~loc env name decl1 id decl2 = cstrs1 cstrs2 | Type_record (labels1, rep1), Type_record (labels2, rep2) -> let err = - compare_records ~loc env decl1.type_params decl2.type_params 1 + compare_records env decl1.type_params decl2.type_params 1 labels1 labels2 in if err <> [] || rep1 = rep2 then err @@ -466,7 +463,7 @@ let type_declarations ?(equality = false) ~loc env name decl1 id decl2 = (* Inclusion between extension constructors *) -let extension_constructors ~loc env id ext1 ext2 = +let extension_constructors env id ext1 ext2 = let usage = if ext1.ext_private = Private || ext2.ext_private = Public then Env.Positive else Env.Privatize @@ -486,8 +483,8 @@ let extension_constructors ~loc env id ext1 ext2 = (ty2 :: ext2.ext_type_params) then if - compare_constructor_arguments ~loc env (Ident.create "") - ext1.ext_type_params ext2.ext_type_params ext1.ext_args ext2.ext_args + compare_constructor_arguments env (Ident.create "") ext1.ext_type_params + ext2.ext_type_params ext1.ext_args ext2.ext_args = [] then if diff --git a/compiler/ml/includecore.mli b/compiler/ml/includecore.mli index 565de90075d..ab6aebf6c06 100644 --- a/compiler/ml/includecore.mli +++ b/compiler/ml/includecore.mli @@ -58,12 +58,7 @@ val type_declarations : type_mismatch list val extension_constructors : - loc:Location.t -> - Env.t -> - Ident.t -> - extension_constructor -> - extension_constructor -> - bool + Env.t -> Ident.t -> extension_constructor -> extension_constructor -> bool val report_type_mismatch : string -> string -> string -> Format.formatter -> type_mismatch list -> unit diff --git a/compiler/ml/includemod.ml b/compiler/ml/includemod.ml index 97ccfdc7d91..890c6c97ded 100644 --- a/compiler/ml/includemod.ml +++ b/compiler/ml/includemod.ml @@ -73,9 +73,9 @@ let type_declarations ~loc env ?(old_env = env) cxt subst id decl1 decl2 = (* Inclusion between extension constructors *) -let extension_constructors ~loc env cxt subst id ext1 ext2 = +let extension_constructors env cxt subst id ext1 ext2 = let ext2 = Subst.extension_constructor subst ext2 in - if Includecore.extension_constructors ~loc env id ext1 ext2 then () + if Includecore.extension_constructors env id ext1 ext2 then () else raise (Error [(cxt, env, Extension_constructors (id, ext1, ext2))]) (* Expand a module type identifier when possible *) @@ -381,7 +381,7 @@ and signature_components ~loc old_env env cxt subst paired = type_declarations ~loc ~old_env env cxt subst id1 tydecl1 tydecl2; comps_rec rem | (Sig_typext (id1, ext1, _), Sig_typext (_id2, ext2, _), pos) :: rem -> - extension_constructors ~loc env cxt subst id1 ext1 ext2; + extension_constructors env cxt subst id1 ext1 ext2; (pos, Tcoerce_none) :: comps_rec rem | (Sig_module (id1, mty1, _), Sig_module (_id2, mty2, _), pos) :: rem -> let cc = module_declarations ~loc env cxt subst id1 mty1 mty2 in diff --git a/compiler/ml/predef.ml b/compiler/ml/predef.ml index 4ca95022843..aca107a5591 100644 --- a/compiler/ml/predef.ml +++ b/compiler/ml/predef.ml @@ -59,8 +59,6 @@ and ident_bigint = ident_create "bigint" and ident_string = ident_create "string" -and ident_extension_constructor = ident_create "extension_constructor" - and ident_unknown = ident_create "unknown" and ident_promise = ident_create "promise" @@ -110,8 +108,6 @@ and path_string = Pident ident_string and path_unkonwn = Pident ident_unknown -and path_extension_constructor = Pident ident_extension_constructor - and path_promise = Pident ident_promise and path_tagged_template = Pident ident_tagged_template @@ -153,10 +149,6 @@ let type_string () = Domain.DLS.get type_string_key let type_unknown_key = predefined_type path_unkonwn let type_unknown () = Domain.DLS.get type_unknown_key -let type_extension_constructor_key = predefined_type path_extension_constructor -let type_extension_constructor () = - Domain.DLS.get type_extension_constructor_key - let predefined_types = [ (type_int_key, path_int); @@ -168,7 +160,6 @@ let predefined_types = (type_bigint_key, path_bigint); (type_string_key, path_string); (type_unknown_key, path_unkonwn); - (type_extension_constructor_key, path_extension_constructor); ] let reset_for_request () = @@ -391,10 +382,7 @@ let common_initial_env add_type add_extension empty_env = ext_loc = Location.none; ext_attributes = [ - ( { - Asttypes.txt = "ocaml.warn_on_literal_pattern"; - loc = Location.none; - }, + ( {Asttypes.txt = "warn_on_literal_pattern"; loc = Location.none}, Parsetree.PStr [] ); ]; ext_is_exception = true; @@ -407,7 +395,6 @@ let common_initial_env add_type add_extension empty_env = |> add_type ident_bigint decl_abstr |> add_type ident_string decl_abstr |> add_type ident_unit decl_unit - |> add_type ident_extension_constructor decl_abstr |> add_type ident_exn decl_exn |> add_type ident_option decl_option |> add_type ident_result decl_result diff --git a/compiler/ml/predef.mli b/compiler/ml/predef.mli index 626443418fe..31c3d3aba46 100644 --- a/compiler/ml/predef.mli +++ b/compiler/ml/predef.mli @@ -28,7 +28,6 @@ val type_array : type_expr -> type_expr val type_iterable : type_expr -> type_expr val type_async_iterable : type_expr -> type_expr val type_bigint : unit -> type_expr -val type_extension_constructor : unit -> type_expr val reset_for_request : unit -> unit val with_fresh : (unit -> 'a) -> 'a diff --git a/compiler/ml/printtyped.ml b/compiler/ml/printtyped.ml index e329c40bfa3..7e59096a454 100644 --- a/compiler/ml/printtyped.ml +++ b/compiler/ml/printtyped.ml @@ -410,8 +410,6 @@ and expression i ppf x = | Texp_pack me -> line i ppf "Texp_pack"; module_expr i ppf me - | Texp_extension_constructor (li, _) -> - line i ppf "Texp_extension_constructor %a" fmt_longident li and value_description i ppf x = line i ppf "value_description %a %a\n" fmt_ident x.val_id fmt_location diff --git a/compiler/ml/rec_check.ml b/compiler/ml/rec_check.ml index 228f0dfb1ed..421ca6195d4 100644 --- a/compiler/ml/rec_check.ml +++ b/compiler/ml/rec_check.ml @@ -206,8 +206,7 @@ let rec classify_expression : Typedtree.expression -> sd = | Texp_ident _ | Texp_for _ | Texp_for_of _ | Texp_for_await_of _ | Texp_constant _ | Texp_tuple _ | Texp_array _ | Texp_construct _ | Texp_variant _ | Texp_record _ | Texp_object_literal _ | Texp_setfield _ - | Texp_while _ | Texp_pack _ | Texp_function _ | Texp_extension_constructor _ - | Texp_break | Texp_continue -> + | Texp_while _ | Texp_pack _ | Texp_function _ | Texp_break | Texp_continue -> Static | Texp_apply {funct = {exp_desc = Texp_ident (_, _, vd)}} when is_ref vd -> Static @@ -337,7 +336,6 @@ let rec expression : Env.env -> Typedtree.expression -> Use.t = env params in Use.delay (expression env body) - | Texp_extension_constructor _ -> Use.empty and option : 'a. (Env.env -> 'a -> Use.t) -> Env.env -> 'a option -> Use.t = fun f env -> value_default (f env) ~default:Use.empty diff --git a/compiler/ml/tast_iterator.ml b/compiler/ml/tast_iterator.ml index 0768ca4f0e0..80caa9b8520 100644 --- a/compiler/ml/tast_iterator.ml +++ b/compiler/ml/tast_iterator.ml @@ -223,7 +223,6 @@ let expr sub {exp_extra; exp_desc; exp_env; _} = sub.expr sub exp | Texp_assert exp -> sub.expr sub exp | Texp_pack mexpr -> sub.module_expr sub mexpr - | Texp_extension_constructor _ -> () let package_type sub {pack_fields; _} = List.iter (fun (_, p) -> sub.typ sub p) pack_fields diff --git a/compiler/ml/tast_mapper.ml b/compiler/ml/tast_mapper.ml index dbbda981a85..a6606fe8f17 100644 --- a/compiler/ml/tast_mapper.ml +++ b/compiler/ml/tast_mapper.ml @@ -286,7 +286,6 @@ let expr sub x = Texp_letexception (sub.extension_constructor sub cd, sub.expr sub exp) | Texp_assert exp -> Texp_assert (sub.expr sub exp) | Texp_pack mexpr -> Texp_pack (sub.module_expr sub mexpr) - | Texp_extension_constructor _ as e -> e in {x with exp_extra; exp_desc; exp_env} diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index c3fc9386252..3bd8184ad1b 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -1402,8 +1402,6 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.t = prim ~primitive:(Pmakeblock Blk_extension) ~args:(Transl_path.transl_extension_path e.exp_env path :: ll) e.exp_loc) - | Texp_extension_constructor (_, path) -> - Transl_path.transl_extension_path e.exp_env path | Texp_variant (l, arg) -> ( match arg with | None -> const (const_polyvar l) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index a44a71133bc..637fd6532e4 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -77,8 +77,6 @@ type error = | Exception_pattern_below_toplevel | Inlined_record_escape | Inlined_record_expected - | Invalid_extension_constructor_payload - | Not_an_extension_constructor | Break_outside_loop | Continue_outside_loop | Literal_overflow of string @@ -3130,8 +3128,6 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp if label.lbl_private = Private && is_private_record_field env label then Location.prerr_warning lid.loc (Warnings.Bs_private_record_mutation (Longident.last lid.txt)); - Builtin_attributes.check_deprecated_mutable lid.loc label.lbl_attributes - (Longident.last lid.txt); rue { exp_desc = Texp_setfield (record, label_loc, label, newval); @@ -3694,32 +3690,6 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp (Texp_open (ovf, path, lid, newenv), loc, sexp.pexp_attributes) :: exp.exp_extra; } - | Pexp_extension - ( {txt = "ocaml.extension_constructor" | "extension_constructor"; _}, - payload ) -> ( - match payload with - | PStr - [ - { - pstr_desc = - Pstr_eval ({pexp_desc = Pexp_construct (lid, {txt = []}); _}, _); - }; - ] -> - let path = - match (Typetexp.find_constructor env lid.loc lid.txt).cstr_kind with - | Extension_constructor path -> path - | _ -> raise (Error (lid.loc, env, Not_an_extension_constructor)) - in - rue - { - exp_desc = Texp_extension_constructor (lid, path); - exp_loc = loc; - exp_extra = []; - exp_type = instance_def (Predef.type_extension_constructor ()); - exp_attributes = sexp.pexp_attributes; - exp_env = env; - } - | _ -> raise (Error (loc, env, Invalid_extension_constructor_payload))) | Pexp_extension ext -> raise (Error_forward (Builtin_attributes.error_of_extension ext)) | Pexp_raw {kind; name_loc} -> @@ -5405,11 +5375,6 @@ let report_error env loc ppf error = destructuring it first" | Inlined_record_expected -> fprintf ppf "@[This constructor expects an inlined record argument.@]" - | Invalid_extension_constructor_payload -> - fprintf ppf - "Invalid [%%extension_constructor] payload, a constructor is expected." - | Not_an_extension_constructor -> - fprintf ppf "This constructor is not an extension constructor." | Break_outside_loop -> fprintf ppf "`break` can only be used directly inside a loop body." | Continue_outside_loop -> diff --git a/compiler/ml/typecore.mli b/compiler/ml/typecore.mli index bf0b76aa192..330b0b93ecf 100644 --- a/compiler/ml/typecore.mli +++ b/compiler/ml/typecore.mli @@ -93,8 +93,6 @@ type error = | Exception_pattern_below_toplevel | Inlined_record_escape | Inlined_record_expected - | Invalid_extension_constructor_payload - | Not_an_extension_constructor | Break_outside_loop | Continue_outside_loop | Literal_overflow of string diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index 2ad0b295f35..82a86327294 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -51,7 +51,6 @@ type error = | Invalid_attribute of string | Bad_immediate_attribute | Bad_unboxed_attribute of string - | Boxed_and_unboxed | Nonrec_gadt | Variant_runtime_representation_mismatch of Variant_coercion.variant_error | Variant_spread_fail of Variant_type_spread.variant_type_spread_error @@ -61,12 +60,8 @@ open Typedtree exception Error of Location.t * error let get_representation_from_attributes sdecl = - let unboxed = Builtin_attributes.has_unboxed sdecl.ptype_attributes in - let boxed = Builtin_attributes.has_boxed sdecl.ptype_attributes in - match (boxed, unboxed) with - | true, true -> raise (Error (sdecl.ptype_loc, Boxed_and_unboxed)) - | true, false | false, false -> Boxed - | false, true -> Unboxed + if Builtin_attributes.has_unboxed sdecl.ptype_attributes then Unboxed + else Boxed (* Enter all declared types in the environment as abstract types *) @@ -2289,8 +2284,6 @@ let report_error ppf = function "non-pointer types like int or bool" | Bad_unboxed_attribute msg -> fprintf ppf "@[This type cannot be unboxed because@ %s.@]" msg - | Boxed_and_unboxed -> - fprintf ppf "@[A type cannot be boxed and unboxed at the same time.@]" | Nonrec_gadt -> fprintf ppf "@[GADT case syntax cannot be used in a 'nonrec' block.@]" | Variant_runtime_representation_mismatch diff --git a/compiler/ml/typedtree.ml b/compiler/ml/typedtree.ml index 1de2e848189..688dc72836b 100644 --- a/compiler/ml/typedtree.ml +++ b/compiler/ml/typedtree.ml @@ -142,7 +142,6 @@ and expression_desc = | Texp_letexception of extension_constructor * expression | Texp_assert of expression | Texp_pack of module_expr - | Texp_extension_constructor of Longident.t loc * Path.t (* Keep new expression constructors at the end. CMT files are marshalled by runtime constructor tag, so inserting constructors before existing ones breaks analysis when it reads CMTs produced by older compiler versions. *) diff --git a/compiler/ml/typedtree.mli b/compiler/ml/typedtree.mli index 03022eec122..98b5295ebea 100644 --- a/compiler/ml/typedtree.mli +++ b/compiler/ml/typedtree.mli @@ -258,7 +258,6 @@ and expression_desc = | Texp_letexception of extension_constructor * expression | Texp_assert of expression | Texp_pack of module_expr - | Texp_extension_constructor of Longident.t loc * Path.t (* Keep new expression constructors at the end. CMT files are marshalled by runtime constructor tag, so inserting constructors before existing ones breaks analysis when it reads CMTs produced by older compiler versions. *) diff --git a/compiler/ml/typedtree_iter.ml b/compiler/ml/typedtree_iter.ml index 3cb6db8c6ad..a748bff361d 100644 --- a/compiler/ml/typedtree_iter.ml +++ b/compiler/ml/typedtree_iter.ml @@ -309,8 +309,7 @@ end = struct iter_extension_constructor cd; iter_expression exp | Texp_assert exp -> iter_expression exp - | Texp_pack mexpr -> iter_module_expr mexpr - | Texp_extension_constructor _ -> ()); + | Texp_pack mexpr -> iter_module_expr mexpr); Iter.leave_expression exp and iter_package_type pack = diff --git a/tests/analysis_tests/tests-reanalyze/deadcode/src/OcamlWarningSuppressToplevel.res b/tests/analysis_tests/tests-reanalyze/deadcode/src/OcamlWarningSuppressToplevel.res index 21ed8a5e7c9..18cdbe5f10c 100644 --- a/tests/analysis_tests/tests-reanalyze/deadcode/src/OcamlWarningSuppressToplevel.res +++ b/tests/analysis_tests/tests-reanalyze/deadcode/src/OcamlWarningSuppressToplevel.res @@ -1,4 +1,4 @@ -@@ocaml.warning("-32") +@@warning("-32") let suppressed1 = 1 let suppressed2 = 2 diff --git a/tests/analysis_tests/tests-reanalyze/deadcode/src/Unboxed.res b/tests/analysis_tests/tests-reanalyze/deadcode/src/Unboxed.res index 208a6456d31..6d3261fcd0d 100644 --- a/tests/analysis_tests/tests-reanalyze/deadcode/src/Unboxed.res +++ b/tests/analysis_tests/tests-reanalyze/deadcode/src/Unboxed.res @@ -1,4 +1,4 @@ -@genType @ocaml.unboxed +@genType @unboxed type v1 = A(int) @genType @unboxed @@ -10,7 +10,7 @@ let testV1 = (x: v1) => x @genType @unboxed type r1 = {x: int} -@genType @ocaml.unboxed +@genType @unboxed type r2 = B({g: string}) @genType diff --git a/tests/build_tests/super_errors/expected/boxed_and_unboxed.res.expected b/tests/build_tests/super_errors/expected/boxed_and_unboxed.res.expected deleted file mode 100644 index 96719069efd..00000000000 --- a/tests/build_tests/super_errors/expected/boxed_and_unboxed.res.expected +++ /dev/null @@ -1,9 +0,0 @@ - - We've found a bug for you! - /.../fixtures/boxed_and_unboxed.res:2:1-17 - - 1 │ @unboxed @boxed - 2 │ type t = One(int) - 3 │ - - A type cannot be boxed and unboxed at the same time. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/invalid_extension_constructor_payload.res.expected b/tests/build_tests/super_errors/expected/invalid_extension_constructor_payload.res.expected deleted file mode 100644 index 73f16cf7ae9..00000000000 --- a/tests/build_tests/super_errors/expected/invalid_extension_constructor_payload.res.expected +++ /dev/null @@ -1,8 +0,0 @@ - - We've found a bug for you! - /.../fixtures/invalid_extension_constructor_payload.res:1:9-37 - - 1 │ let _ = %extension_constructor(1 + 1) - 2 │ - - Invalid [%extension_constructor] payload, a constructor is expected. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/not_an_extension_constructor.res.expected b/tests/build_tests/super_errors/expected/not_an_extension_constructor.res.expected deleted file mode 100644 index e9e410d2a5b..00000000000 --- a/tests/build_tests/super_errors/expected/not_an_extension_constructor.res.expected +++ /dev/null @@ -1,10 +0,0 @@ - - We've found a bug for you! - /.../fixtures/not_an_extension_constructor.res:3:32 - - 1 │ type t = A - 2 │ - 3 │ let _ = %extension_constructor(A) - 4 │ - - This constructor is not an extension constructor. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/removed_extension_constructor.res.expected b/tests/build_tests/super_errors/expected/removed_extension_constructor.res.expected new file mode 100644 index 00000000000..4ffec733152 --- /dev/null +++ b/tests/build_tests/super_errors/expected/removed_extension_constructor.res.expected @@ -0,0 +1,10 @@ + + We've found a bug for you! + /.../fixtures/removed_extension_constructor.res:3:9-30 + + 1 │ exception A + 2 │ + 3 │ let _ = %extension_constructor(A) + 4 │ + + Uninterpreted extension 'extension_constructor'. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/removed_ocaml_error.res.expected b/tests/build_tests/super_errors/expected/removed_ocaml_error.res.expected new file mode 100644 index 00000000000..2ad12fae926 --- /dev/null +++ b/tests/build_tests/super_errors/expected/removed_ocaml_error.res.expected @@ -0,0 +1,8 @@ + + We've found a bug for you! + /.../fixtures/removed_ocaml_error.res:1:9-20 + + 1 │ let x = %ocaml.error("boom") + 2 │ + + `%ocaml.error` is no longer supported, use `%error` instead. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/removed_ocaml_unboxed.res.expected b/tests/build_tests/super_errors/expected/removed_ocaml_unboxed.res.expected new file mode 100644 index 00000000000..076f68cbd03 --- /dev/null +++ b/tests/build_tests/super_errors/expected/removed_ocaml_unboxed.res.expected @@ -0,0 +1,9 @@ + + We've found a bug for you! + /.../fixtures/removed_ocaml_unboxed.res:1:1-14 + + 1 │ @ocaml.unboxed + 2 │ type t = Name(string) + 3 │ + + `@ocaml.unboxed` is no longer supported, use `@unboxed` instead. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/boxed_and_unboxed.res b/tests/build_tests/super_errors/fixtures/boxed_and_unboxed.res deleted file mode 100644 index 803c980c006..00000000000 --- a/tests/build_tests/super_errors/fixtures/boxed_and_unboxed.res +++ /dev/null @@ -1,2 +0,0 @@ -@unboxed @boxed -type t = One(int) diff --git a/tests/build_tests/super_errors/fixtures/invalid_extension_constructor_payload.res b/tests/build_tests/super_errors/fixtures/invalid_extension_constructor_payload.res deleted file mode 100644 index a8cd8bf06e4..00000000000 --- a/tests/build_tests/super_errors/fixtures/invalid_extension_constructor_payload.res +++ /dev/null @@ -1 +0,0 @@ -let _ = %extension_constructor(1 + 1) diff --git a/tests/build_tests/super_errors/fixtures/not_an_extension_constructor.res b/tests/build_tests/super_errors/fixtures/removed_extension_constructor.res similarity index 74% rename from tests/build_tests/super_errors/fixtures/not_an_extension_constructor.res rename to tests/build_tests/super_errors/fixtures/removed_extension_constructor.res index 3cffdf20afa..7e197abd1b1 100644 --- a/tests/build_tests/super_errors/fixtures/not_an_extension_constructor.res +++ b/tests/build_tests/super_errors/fixtures/removed_extension_constructor.res @@ -1,3 +1,3 @@ -type t = A +exception A let _ = %extension_constructor(A) diff --git a/tests/build_tests/super_errors/fixtures/removed_ocaml_error.res b/tests/build_tests/super_errors/fixtures/removed_ocaml_error.res new file mode 100644 index 00000000000..88f259df054 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/removed_ocaml_error.res @@ -0,0 +1 @@ +let x = %ocaml.error("boom") diff --git a/tests/build_tests/super_errors/fixtures/removed_ocaml_unboxed.res b/tests/build_tests/super_errors/fixtures/removed_ocaml_unboxed.res new file mode 100644 index 00000000000..5998996b381 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/removed_ocaml_unboxed.res @@ -0,0 +1,2 @@ +@ocaml.unboxed +type t = Name(string) diff --git a/tests/gentype_tests/typescript-react-example/src/Unboxed.res b/tests/gentype_tests/typescript-react-example/src/Unboxed.res index d2f305c4ee7..a3fad07498f 100644 --- a/tests/gentype_tests/typescript-react-example/src/Unboxed.res +++ b/tests/gentype_tests/typescript-react-example/src/Unboxed.res @@ -1,4 +1,4 @@ -@genType @ocaml.unboxed +@genType @unboxed type v1 = A(int) @genType @unboxed @@ -9,7 +9,7 @@ type v2 = A(int) @genType @unboxed type r1 = {x: int} -@genType @ocaml.unboxed +@genType @unboxed type r2 = B({g: string}) @genType let r2Test = (x: r2) => x diff --git a/tests/ounit_tests/ounit_ast_mapper0_tests.ml b/tests/ounit_tests/ounit_ast_mapper0_tests.ml index 956f4e8a90f..8c758807af1 100644 --- a/tests/ounit_tests/ounit_ast_mapper0_tests.ml +++ b/tests/ounit_tests/ounit_ast_mapper0_tests.ml @@ -2547,6 +2547,77 @@ let test_error_extension_backquoted_strings _ = OUnit.assert_equal ~printer:(Printf.sprintf "%S") "highlighted\nmessage" error.if_highlight +(* Attribute and extension names a mapped tree carries, payloads included. *) +let builtin_names_of iterate = + let names = ref [] in + let iterator = + { + Ast_iterator.default_iterator with + attribute = + (fun self ((name, _) as attr) -> + names := name.Location.txt :: !names; + Ast_iterator.default_iterator.attribute self attr); + extension = + (fun self ((name, _) as ext) -> + names := name.Location.txt :: !names; + Ast_iterator.default_iterator.extension self ext); + } + in + iterate iterator; + List.sort_uniq compare !names + +let test_ocaml_prefixed_builtins_arrive_bare _ = + let string0 s = + Parsetree0.PStr + [ + Ast_helper0.Str.eval ~loc + (Ast_helper0.Exp.constant ~loc (Parsetree0.Pconst_string (s, None))); + ] + in + let error0 = (Location.mknoloc "ocaml.error", string0 "ppx error") in + let warning0 = attr "ocaml.warning" (string0 "-32") in + let structure0 = + [ + Ast_helper0.Str.attribute ~loc + (attr "ocaml.ppwarning" (string0 "lint warning")); + Ast_helper0.Str.extension ~loc error0; + Ast_helper0.Str.type_ ~loc Asttypes.Recursive + [Ast_helper0.Type.mk ~loc ~attrs:[warning0] (Location.mknoloc "t")]; + Ast_helper0.Str.eval ~loc ~attrs:[warning0] + (Ast_helper0.Exp.extension ~loc + ~attrs: + [ + attr "nested" + (Parsetree0.PStr [Ast_helper0.Str.extension ~loc error0]); + ] + error0); + ] + in + let signature0 = + [ + Ast_helper0.Sig.attribute ~loc warning0; + Ast_helper0.Sig.extension ~loc error0; + ] + in + let structure = + Ast_mapper_from0.default_mapper.structure Ast_mapper_from0.default_mapper + structure0 + in + let signature = + Ast_mapper_from0.default_mapper.signature Ast_mapper_from0.default_mapper + signature0 + in + let show names = String.concat ", " names in + OUnit.assert_equal ~printer:show + ["error"; "nested"; "ppwarning"; "warning"] + (builtin_names_of (fun it -> it.structure it structure)); + OUnit.assert_equal ~printer:show ["error"; "warning"] + (builtin_names_of (fun it -> it.signature it signature)) + +let test_extension_of_error_is_bare _ = + let name, _ = Ast_mapper.extension_of_error (Location.error ~loc "boom") in + OUnit.assert_equal ~printer:Fun.id "error" name.txt + let suites = __FILE__ >::: [ @@ -2665,6 +2736,9 @@ let suites = "jsx_component_on_value_descriptions_through_ast0" >:: test_jsx_component_on_value_descriptions_through_ast0; "ppx_context_on_the_wire" >:: test_ppx_context_on_the_wire; + "ocaml_prefixed_builtins_arrive_bare" + >:: test_ocaml_prefixed_builtins_arrive_bare; + "extension_of_error_is_bare" >:: test_extension_of_error_is_bare; "raw_nodes_roundtrip_through_ast0" >:: test_raw_nodes_roundtrip_through_ast0; "raw_structure_item_roundtrips_through_ast0" diff --git a/tests/ounit_tests/ounit_compiler_request_tests.ml b/tests/ounit_tests/ounit_compiler_request_tests.ml index eb7a8156892..131e5aa1840 100644 --- a/tests/ounit_tests/ounit_compiler_request_tests.ml +++ b/tests/ounit_tests/ounit_compiler_request_tests.ml @@ -1077,6 +1077,58 @@ let ppx_recovery_tests _context = (contains_text repaired.stderr "+ rewatch-test-ppx") "direct verbose output is returned through the request boundary") +(* The PPX bridge renames a PPX's [ocaml.warning] to [warning], so source + spelled that way must be rejected before an external PPX sees it. *) +let ppx_removed_ocaml_spelling_tests _context = + with_temp_dir "rewatch-driver-ppx-ocaml-" (fun root -> + let identity_ppx command = + let quote = if String.contains command '\'' then '\'' else '"' in + match String.split_on_char quote command with + | _program :: input :: _separator :: output :: _ -> + copy_existing_file input output; + (0, "", "") + | _ -> (2, "", "could not decode test PPX command") + in + let run input = + Rescript_compiler_driver.run_request ~cwd:root + ~argv: + [ + "-nostdlib"; + "-nopervasives"; + "-bs-project-root"; + root; + "-bs-package-name"; + "driver-test"; + "-bs-package-output"; + "commonjs:.:.js"; + "-ppx"; + "identity-ppx"; + ] + ~input ~run_external:(Some identity_ppx) + in + write root "Impl.res" "@@ocaml.warning(\"-32\")\nlet value = 1\n"; + let impl = run "Impl.res" in + expect_code 2 impl; + check + (contains_text impl.stderr + "`@ocaml.warning` is no longer supported, use `@warning` instead.") + "@@ocaml.warning in an implementation is rejected before the PPX"; + write root "Intf.resi" + "let value: int\n@ocaml.ppwarning(\"x\")\nlet other: int\n"; + let intf = run "Intf.resi" in + expect_code 2 intf; + check + (contains_text intf.stderr "`@ocaml.ppwarning` is no longer supported") + "@ocaml.ppwarning in an interface is rejected before the PPX"; + write root "Error.res" "let value = %ocaml.error(\"boom\")\n"; + let error = run "Error.res" in + expect_code 2 error; + check + (contains_text error.stderr "`%ocaml.error` is no longer supported") + "%ocaml.error is rejected before the PPX"; + write root "Bare.res" "@@warning(\"-32\")\nlet value = 1\n"; + expect_code 0 (run "Bare.res")) + let control_flow_and_output_tests _context = with_temp_dir "rewatch-driver-control-" (fun root -> let process_cwd = Sys.getcwd () in @@ -1589,6 +1641,7 @@ let suites = "eval_relative_temp_dir" >:: eval_relative_temp_dir_tests; "recovery" >:: recovery_tests; "ppx_recovery" >:: ppx_recovery_tests; + "ppx_removed_ocaml_spelling" >:: ppx_removed_ocaml_spelling_tests; "control_flow_and_output" >:: control_flow_and_output_tests; "state_boundary" >:: state_boundary_tests; "package_and_load_path_isolation"