diff --git a/flake.lock b/flake.lock index f6e13b266..e3d589031 100644 --- a/flake.lock +++ b/flake.lock @@ -28,11 +28,11 @@ ] }, "locked": { - "lastModified": 1732487857, - "narHash": "sha256-F3SyJmoSCAIceSMtcZWG1H26sL+OFIXC6FkGyRvpNBs=", + "lastModified": 1732515780, + "narHash": "sha256-YcK9fsQLh5Hb91bguy4ATXO4IomuqUGpYF1uzpeeD4I=", "owner": "melange-re", "repo": "melange-compiler-libs", - "rev": "fb77eb71e0560dd9dd598e2ceaa10baa59a97e28", + "rev": "7eda8e25f2ee27bd048226e6d09c85c5eb1c3b4a", "type": "github" }, "original": { @@ -64,11 +64,11 @@ "nixpkgs": "nixpkgs_2" }, "locked": { - "lastModified": 1732486064, - "narHash": "sha256-wLayHqqtp0g0xaee52vX22D3ylvOBLYumv1KKSSDxYo=", + "lastModified": 1732494935, + "narHash": "sha256-NCXDJAt1ya1Tdfklf3aOWHr8DOkB6QcwwSzW5/XBisQ=", "owner": "nix-ocaml", "repo": "nix-overlays", - "rev": "6375a7d39aafe1153a91c9c5a82c25dcd67e9a2b", + "rev": "9421b52a0d0fdd73fd478ab3ef2433058a7dd0a5", "type": "github" }, "original": { diff --git a/jscomp/common/dune b/jscomp/common/dune index 7d92349dc..435fb74db 100644 --- a/jscomp/common/dune +++ b/jscomp/common/dune @@ -3,12 +3,6 @@ (package melange) (libraries melstd melange_compiler_libs js_parser)) -(rule - (target oprint_mel_primitive_name.ml) - (deps oprint_mel_primitive_name.dev.ml oprint_mel_primitive_name.release.ml) - (action - (copy# oprint_mel_primitive_name.%{profile}.ml %{target}))) - (rule (targets utf8_string.ml) (deps utf8_string.cppo.ml) diff --git a/jscomp/common/external_ffi_attributes.ml b/jscomp/common/external_ffi_attributes.ml index f56128494..1572991d6 100644 --- a/jscomp/common/external_ffi_attributes.ml +++ b/jscomp/common/external_ffi_attributes.ml @@ -45,8 +45,9 @@ let external_attrs = let has_mel_attributes attrs = List.exists ~f:(fun txt -> - String.starts_with txt ~prefix:"mel." - || Array.exists ~f:(fun (x : string) -> txt = x) external_attrs) + match String.starts_with txt ~prefix:"mel." with + | true -> not (String.starts_with txt ~prefix:"mel.internal") + | false -> Array.exists ~f:(fun (x : string) -> txt = x) external_attrs) attrs let is_mel_attribute txt = diff --git a/jscomp/common/external_ffi_types.ml b/jscomp/common/external_ffi_types.ml index e290a25a1..b33378a36 100644 --- a/jscomp/common/external_ffi_types.ml +++ b/jscomp/common/external_ffi_types.ml @@ -23,7 +23,6 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) open Import -open External_ffi_types0 module Literals = struct let setter_suffix = "#=" @@ -196,17 +195,26 @@ let check_ffi ~loc ffi : bool = let to_string (t : t) = Marshal.to_string t [] -let () = - Oprint.map_primitive_name := Oprint_mel_primitive_name.map_primitive_name - external from_bytes_unsafe : bytes -> int -> 'a = "caml_input_value_from_bytes" (* TODO: better error message when version mismatch *) -let from_string s : t = - if is_mel_primitive s then from_bytes_unsafe (Bytes.unsafe_of_string s) 0 - else Ffi_normal +let from_string = + (* \132\149\166\190 + 0x84 95 A6 BE Intext_magic_small intext.h + https://github.com/ocaml/merlin/commit/b094c937c3a360eb61054f7652081b88e4f3612f +*) + let is_mel_primitive s = + (* TODO(anmonteiro): check this, header_size changed to 16 in 5.1 *) + String.length s >= 20 + (* Marshal.header_size*) && String.unsafe_get s 0 = '\132' + && String.unsafe_get s 1 = '\149' + in + fun s : t -> + match is_mel_primitive s with + | true -> from_bytes_unsafe (Bytes.unsafe_of_string s) 0 + | false -> Ffi_normal -let inline_string_primitive (s : string) (op : string option) : string list = +let inline_string_primitive ?op s = let lam : Lam_constant.t = let unicode = match op with @@ -215,7 +223,7 @@ let inline_string_primitive (s : string) (op : string option) : string list = in Const_string { s; unicode } in - [ ""; to_string (Ffi_inline_const lam) ] + Ffi_inline_const lam (* Let's only do it for string ATM for boolean, and ints, a good optimizer should @@ -223,21 +231,18 @@ let inline_string_primitive (s : string) (op : string option) : string list = But it may not work after layers of indirection e.g, submodule *) -let inline_bool_primitive b : string list = - let lam : Lam_constant.t = - if b then Lam_constant.Const_js_true else Lam_constant.Const_js_false - in - [ ""; to_string (Ffi_inline_const lam) ] - -(* FIXME: check overflow ?*) -let inline_int_primitive (i : int32) : string list = - [ ""; to_string (Ffi_inline_const (Const_int { i; comment = None })) ] +let inline_bool_primitive b = + Ffi_inline_const + (match b with + | true -> Lam_constant.Const_js_true + | false -> Lam_constant.Const_js_false) -let inline_int64_primitive (i : int64) : string list = - [ ""; to_string (Ffi_inline_const (Const_int64 i)) ] +let inline_int_primitive i = + (* FIXME: check overflow? *) + Ffi_inline_const (Const_int { i; comment = None }) -let inline_float_primitive (i : string) : string list = - [ ""; to_string (Ffi_inline_const (Const_float i)) ] +let inline_int64_primitive i = Ffi_inline_const (Const_int64 i) +let inline_float_primitive i = Ffi_inline_const (Const_float i) let ffi_mel = let rec ffi_mel_aux acc @@ -256,8 +261,4 @@ let ffi_mel = if n < 0 then Ffi_mel (Params params, return, attr) else Ffi_mel (Param_number n, return, attr) -let ffi_mel_as_prims params return attr = - [ ""; to_string (ffi_mel params return attr) ] - let ffi_obj_create obj_params = Ffi_obj_create obj_params -let ffi_obj_as_prims obj_params = [ ""; to_string (Ffi_obj_create obj_params) ] diff --git a/jscomp/common/external_ffi_types.mli b/jscomp/common/external_ffi_types.mli index 83c347648..8a96b9bc2 100644 --- a/jscomp/common/external_ffi_types.mli +++ b/jscomp/common/external_ffi_types.mli @@ -98,15 +98,15 @@ type t = private val check_ffi : loc:Location.t -> external_spec -> bool val to_string : t -> string - val from_string : string -> t + (** Note *) -val inline_string_primitive : string -> string option -> string list -val inline_bool_primitive : bool -> string list -val inline_int_primitive : int32 -> string list -val inline_int64_primitive : int64 -> string list -val inline_float_primitive : string -> string list +val inline_string_primitive : ?op:string -> string -> t +val inline_bool_primitive : bool -> t +val inline_int_primitive : int32 -> t +val inline_int64_primitive : int64 -> t +val inline_float_primitive : string -> t val ffi_mel : External_arg_spec.Arg_label.t External_arg_spec.param list -> @@ -114,14 +114,5 @@ val ffi_mel : external_spec -> t -val ffi_mel_as_prims : - External_arg_spec.Arg_label.t External_arg_spec.param list -> - return_wrapper -> - external_spec -> - string list - val ffi_obj_create : External_arg_spec.Obj_label.t External_arg_spec.param list -> t - -val ffi_obj_as_prims : - External_arg_spec.Obj_label.t External_arg_spec.param list -> string list diff --git a/jscomp/common/external_ffi_types0.ml b/jscomp/common/external_ffi_types0.ml deleted file mode 100644 index 7f9a7cced..000000000 --- a/jscomp/common/external_ffi_types0.ml +++ /dev/null @@ -1,33 +0,0 @@ -(* Copyright (C) 2023- Authors of Melange - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* \132\149\166\190 - 0x84 95 A6 BE Intext_magic_small intext.h - https://github.com/ocaml/merlin/commit/b094c937c3a360eb61054f7652081b88e4f3612f -*) -let is_mel_primitive s = - (* TODO(anmonteiro): check this, header_size changed to 16 in 5.1 *) - String.length s >= 20 - (* Marshal.header_size*) && String.unsafe_get s 0 = '\132' - && String.unsafe_get s 1 = '\149' diff --git a/jscomp/common/oprint_mel_primitive_name.dev.ml b/jscomp/common/oprint_mel_primitive_name.dev.ml deleted file mode 100644 index d8bbc017c..000000000 --- a/jscomp/common/oprint_mel_primitive_name.dev.ml +++ /dev/null @@ -1,25 +0,0 @@ -(* Copyright (C) 2023- Authors of Melange - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let map_primitive_name s = String.escaped s (* For debugging*) diff --git a/jscomp/common/oprint_mel_primitive_name.release.ml b/jscomp/common/oprint_mel_primitive_name.release.ml deleted file mode 100644 index 7471fa357..000000000 --- a/jscomp/common/oprint_mel_primitive_name.release.ml +++ /dev/null @@ -1,26 +0,0 @@ -(* Copyright (C) 2023- Authors of Melange - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let map_primitive_name s = - if External_ffi_types0.is_mel_primitive s then "MEL:external" else s diff --git a/jscomp/core/lam_convert.cppo.ml b/jscomp/core/lam_convert.cppo.ml index 1bb642247..ad8307328 100644 --- a/jscomp/core/lam_convert.cppo.ml +++ b/jscomp/core/lam_convert.cppo.ml @@ -541,16 +541,56 @@ let convert (exports : Ident.Set.t) (lam : Lambda.lambda) : let alias_tbl = Ident.Hash.create 64 in let exit_map = Hash_int.create 0 in let may_depends = Lam_module_ident.Hash_set.create 0 in - + let partition_by_mel_ffi_attribute attrs = + let st = ref None in + let _ffi, rest = + List.partition attrs ~f:(function + | { + Parsetree.attr_name = { txt = "mel.internal.ffi"; loc }; + attr_payload; + _; + } -> ( + match !st with + | Some _ -> + Location.raise_errorf ~loc + "Duplicate `[@mel.internal.ffi \"..\"]' annotation" + | None -> ( + match attr_payload with + | PStr + [ + { + pstr_desc = + Pstr_eval ({ pexp_desc = Pexp_constant const; _ }, _); + _; + }; + ] -> ( + match + #if OCAML_VERSION >= (5, 3, 0) + const.pconst_desc + #else + const + #endif + with + | Pconst_string (s, _, _) -> + st := Some s; + true + | _ -> false) + | _ -> + Location.raise_errorf ~loc + "`[@mel.internal.ffi \"..\"]' annotation must be a string")) + | _ -> false) + in + !st, rest + in let rec convert_ccall (a_prim : Primitive.description) (args : Lambda.lambda list) loc ~dynamic_import : Lam.t = let prim_name = a_prim.prim_name in - let prim_name_len = String.length prim_name in - match - Melange_ffi.External_ffi_types.from_string a_prim.prim_native_name - with + let ffi, _ = + partition_by_mel_ffi_attribute a_prim.prim_attrs + in + match Melange_ffi.External_ffi_types.from_string (Option.value ~default:"" ffi) with | Ffi_normal -> - if prim_name_len > 0 && String.unsafe_get prim_name 0 = '#' then + if String.length prim_name > 0 && String.unsafe_get prim_name 0 = '#' then convert_js_primitive a_prim args loc else let args = List.map ~f:convert_aux args in diff --git a/jscomp/core/mel_ast_invariant.cppo.ml b/jscomp/core/mel_ast_invariant.cppo.ml index 9a88d4cb8..b87966a45 100644 --- a/jscomp/core/mel_ast_invariant.cppo.ml +++ b/jscomp/core/mel_ast_invariant.cppo.ml @@ -69,7 +69,7 @@ end let emit_external_warnings : Ast_iterator.iterator = let has_mel_attributes attrs = Melange_ffi.External_ffi_attributes.has_mel_attributes - (List.map ~f:(fun { Parsetree.attr_name = { txt; _ }; _ } -> txt) attrs) + (List.map ~f:(fun (attr: Parsetree.attribute) -> attr.attr_name.txt) attrs) in let print_unprocessed_alert ~loc = Location.prerr_alert loc diff --git a/ppx/ast_attributes.ml b/ppx/ast_attributes.ml index 50886c42b..180e39294 100644 --- a/ppx/ast_attributes.ml +++ b/ppx/ast_attributes.ml @@ -361,6 +361,41 @@ let prims_to_be_encoded (attrs : string list) = | _ :: x :: _ when first_marshal_char x -> false | _ -> true +let partition_by_mel_ffi_attribute attrs = + let st = ref None in + let _ffi, rest = + List.partition attrs ~f:(function + | { + Parsetree.attr_name = { txt = "mel.internal.ffi"; loc }; + attr_payload; + _; + } -> ( + match !st with + | Some _ -> + Location.raise_errorf ~loc + "Duplicate `[@mel.internal.ffi \"..\"]' annotation" + | None -> ( + match attr_payload with + | PStr + [ + { + pstr_desc = + Pstr_eval ({ pexp_desc = Pexp_constant const; _ }, _); + _; + }; + ] -> ( + match const with + | Pconst_string (s, _, _) -> + st := Some s; + true + | _ -> false) + | _ -> + Location.raise_errorf ~loc + "`[@mel.internal.ffi \"..\"]' annotation must be a string")) + | _ -> false) + in + (!st, rest) + (** [@@inline] @@ -371,18 +406,22 @@ let prims_to_be_encoded (attrs : string list) = They are not considered externals, they are part of the language *) - let rs_externals attrs pval_prim = - match (attrs, pval_prim) with - | _, [] -> false - (* This is val *) - | [], _ -> - (* No attributes found *) - prims_to_be_encoded pval_prim - | _, _ -> - Melange_ffi.External_ffi_attributes.has_mel_attributes - (List.map ~f:(fun { attr_name = { txt; _ }; _ } -> txt) attrs) - || prims_to_be_encoded pval_prim + match pval_prim with + | [] -> + (* This is val *) + false + | _ :: _ -> ( + let mel_ffi, attrs = partition_by_mel_ffi_attribute attrs in + match mel_ffi with + | Some _ -> false + | None -> ( + match attrs with + | [] -> prims_to_be_encoded pval_prim + | _ :: _ -> + Melange_ffi.External_ffi_attributes.has_mel_attributes + (List.map ~f:(fun { attr_name = { txt; _ }; _ } -> txt) attrs) + || prims_to_be_encoded pval_prim)) let iter_process_mel_int_as attrs = let st = ref None in @@ -458,3 +497,18 @@ let ocaml_warning w = runtime *) let unboxable_type_in_prim_decl = ocaml_warning "-unboxable-type-in-prim-decl" let ignored_extra_argument = ocaml_warning "-ignored-extra-argument" + +let mel_ffi = + fun (t : Melange_ffi.External_ffi_types.t) -> + { + Parsetree.attr_name = { txt = "mel.internal.ffi"; loc = Location.none }; + attr_loc = Location.none; + attr_payload = + PStr + [ + Ast_helper.( + Str.eval + (Exp.constant + (Const.string (Melange_ffi.External_ffi_types.to_string t)))); + ]; + } diff --git a/ppx/ast_attributes.mli b/ppx/ast_attributes.mli index 7cf77680a..c6398bf0d 100644 --- a/ppx/ast_attributes.mli +++ b/ppx/ast_attributes.mli @@ -69,3 +69,7 @@ val unboxable_type_in_prim_decl : attribute val ignored_extra_argument : attribute val is_mel_as : attribute -> bool val has_mel_as_payload : attribute list -> attribute list * attribute option + +val mel_ffi : Melange_ffi.External_ffi_types.t -> attribute + +val partition_by_mel_ffi_attribute: attribute list -> string option * attribute list diff --git a/ppx/ast_derive/ast_derive_abstract.ml b/ppx/ast_derive/ast_derive_abstract.ml index cde966591..5377c67f7 100644 --- a/ppx/ast_derive/ast_derive_abstract.ml +++ b/ppx/ast_derive/ast_derive_abstract.ml @@ -25,25 +25,26 @@ open Import open Ast_helper -let deprecated_abstract = - let loc = Location.none in - { - attr_name = { txt = "alert"; loc }; - attr_payload = - PStr - [ - [%stri - deprecated - "`@@deriving abstract' deprecated. Use `@@deriving jsProperties, \ - getSet' instead."]; - ]; - attr_loc = loc; - } - -let with_deprecation ~is_deprecated attrs = - match is_deprecated with - | false -> attrs - | true -> deprecated_abstract :: attrs +let with_deprecation = + let deprecated_abstract = + let loc = Location.none in + { + attr_name = { txt = "alert"; loc }; + attr_payload = + PStr + [ + [%stri + deprecated + "`@@deriving abstract' deprecated. Use `@@deriving \ + jsProperties, getSet' instead."]; + ]; + attr_loc = loc; + } + in + fun ~is_deprecated attrs -> + match is_deprecated with + | false -> attrs + | true -> deprecated_abstract :: attrs let get_pld_type pld_type ~attrs = let is_optional = Ast_attributes.has_mel_optional attrs in @@ -56,30 +57,26 @@ let get_pld_type pld_type ~attrs = else pld_type let derive_js_constructor = - let pval_prim_of_option_labels (labels : (bool * string Asttypes.loc) list) - (ends_with_unit : bool) = - let arg_kinds = - List.fold_right - ~f:(fun (is_option, p) arg_kinds -> - let label_name = Melange_ffi.Lam_methname.translate p.txt in - let obj_arg_label = - if is_option then - Melange_ffi.External_arg_spec.Obj_label.optional - ~for_sure_no_nested_option:false label_name - else Melange_ffi.External_arg_spec.Obj_label.obj label_name - in - { - Melange_ffi.External_arg_spec.arg_type = Nothing; - arg_label = obj_arg_label; - } - :: arg_kinds) - labels - ~init: - (if ends_with_unit then - [ Melange_ffi.External_arg_spec.empty_kind Extern_unit ] - else []) - in - Melange_ffi.External_ffi_types.ffi_obj_as_prims arg_kinds + let ffi_of_option_labels labels ~ends_with_unit = + Melange_ffi.External_ffi_types.ffi_obj_create + (List.fold_right labels + ~init: + (if ends_with_unit then + [ Melange_ffi.External_arg_spec.empty_kind Extern_unit ] + else []) + ~f:(fun ((is_option, p) : bool * string Asttypes.loc) arg_kinds -> + let obj_arg_label = + let label_name = Melange_ffi.Lam_methname.translate p.txt in + if is_option then + Melange_ffi.External_arg_spec.Obj_label.optional + ~for_sure_no_nested_option:false label_name + else Melange_ffi.External_arg_spec.Obj_label.obj label_name + in + { + Melange_ffi.External_arg_spec.arg_type = Nothing; + arg_label = obj_arg_label; + } + :: arg_kinds)) in fun ?(is_deprecated = false) tdcl -> match tdcl.ptype_kind with @@ -132,16 +129,18 @@ let derive_js_constructor = match tdcl.ptype_private with | Private -> [] | Public -> - let myPrims = - pval_prim_of_option_labels labels has_optional_field - in [ Val.mk ~loc { loc; txt = tdcl.ptype_name.txt } ~attrs: (with_deprecation ~is_deprecated - [ Ast_attributes.unboxable_type_in_prim_decl ]) - ~prim:myPrims makeType; + [ + Ast_attributes.mel_ffi + (ffi_of_option_labels labels + ~ends_with_unit:has_optional_field); + Ast_attributes.unboxable_type_in_prim_decl; + ]) + ~prim:Ast_external.pval_prim_default makeType; ]) | Ptype_abstract | Ptype_variant _ | Ptype_open -> (* Looks obvious that it does not make sense to warn *) @@ -194,14 +193,20 @@ let derive_getters_setters = Val.mk ~loc:pld_loc (if light then pld_name else { pld_name with txt = pld_name.txt ^ "Get" }) - ~attrs:(with_deprecation ~is_deprecated get_attrs) - ~prim: - ((* Not needed actually*) - Melange_ffi.External_ffi_types.ffi_mel_as_prims - [ Melange_ffi.External_arg_spec.dummy ] - Return_identity - (Js_get - { js_get_name = prim_as_name; js_get_scopes = [] })) + ~attrs: + (with_deprecation ~is_deprecated + (Ast_attributes.mel_ffi + (* Not needed actually*) + (Melange_ffi.External_ffi_types.ffi_mel + [ Melange_ffi.External_arg_spec.dummy ] + Return_identity + (Js_get + { + js_get_name = prim_as_name; + js_get_scopes = []; + })) + :: get_attrs)) + ~prim:Ast_external.pval_prim_default [%type: [%t core_type] -> [%t pld_type]] :: acc in diff --git a/ppx/ast_external.ml b/ppx/ast_external.ml index 505f85a37..db70d59ca 100644 --- a/ppx/ast_external.ml +++ b/ppx/ast_external.ml @@ -24,6 +24,8 @@ open Import +let pval_prim_default = [ ""; "" ] + let single_string_payload_error ~loc = Ast_helper.Exp.constant (Pconst_string diff --git a/ppx/ast_external.mli b/ppx/ast_external.mli index 5d92d24c4..c5bb5a01f 100644 --- a/ppx/ast_external.mli +++ b/ppx/ast_external.mli @@ -24,6 +24,8 @@ open Import +val pval_prim_default : string list + val handleExternalInSig : Ast_traverse.map -> value_description -> signature_item -> signature_item diff --git a/ppx/ast_external_process.ml b/ppx/ast_external_process.ml index de52a2393..a2887bc6c 100644 --- a/ppx/ast_external_process.ml +++ b/ppx/ast_external_process.ml @@ -1184,13 +1184,14 @@ let handle_attributes_as_string (pval_loc : Location.t) (typ : core_type) } = From_attributes.parse ~loc:pval_loc fn_type attrs ~pval_name ~prim_name in + { pval_type = Ast_helper.Typ.constr { txt = Ldot (Ast_literal.js_fn, arity); loc } [ pval_type ]; - pval_prim = [ prim_name; External_ffi_types.to_string ffi ]; - pval_attributes; + pval_prim = [ prim_name; prim_name ]; + pval_attributes = Ast_attributes.mel_ffi ffi :: pval_attributes; dont_inline_cross_module; } | _ -> @@ -1204,7 +1205,7 @@ let handle_attributes_as_string (pval_loc : Location.t) (typ : core_type) in { pval_type; - pval_prim = [ prim_name; External_ffi_types.to_string ffi ]; - pval_attributes; + pval_prim = [ prim_name; prim_name ]; + pval_attributes = Ast_attributes.mel_ffi ffi :: pval_attributes; dont_inline_cross_module; } diff --git a/ppx/ast_object.ml b/ppx/ast_object.ml index b8aee0e30..8e047ec4e 100644 --- a/ppx/ast_object.ml +++ b/ppx/ast_object.ml @@ -25,27 +25,21 @@ open Import open Ast_helper -let pval_prim_of_labels (labels : string Asttypes.loc list) = - let arg_kinds = - List.fold_right - ~f:(fun p arg_kinds -> - let obj_arg_label = - Melange_ffi.External_arg_spec.Obj_label.obj - (Melange_ffi.Lam_methname.translate p.txt) - in - { - Melange_ffi.External_arg_spec.arg_type = Nothing; - arg_label = obj_arg_label; - } - :: arg_kinds) - labels ~init:[] - in - Melange_ffi.External_ffi_types.ffi_obj_as_prims arg_kinds +let ffi_of_labels labels = + Melange_ffi.External_ffi_types.ffi_obj_create + (List.fold_right labels ~init:[] ~f:(fun (p : string with_loc) arg_kinds -> + { + Melange_ffi.External_arg_spec.arg_type = Nothing; + arg_label = + Melange_ffi.External_arg_spec.Obj_label.obj + (Melange_ffi.Lam_methname.translate p.txt); + } + :: arg_kinds)) let ocaml_object_as_js_object = - let local_extern_cont_to_obj loc ?(pval_attributes = []) ~pval_prim ~pval_type - ?(local_module_name = "J") ?(local_fun_name = "unsafe_expr") - (cb : expression -> 'a) : expression_desc = + let local_extern_cont_to_obj loc ~ffi ~pval_type ?(local_module_name = "J") + ?(local_fun_name = "unsafe_expr") (cb : expression -> 'a) : + expression_desc = Pexp_letmodule ( { txt = Some local_module_name; loc }, { @@ -59,8 +53,8 @@ let ocaml_object_as_js_object = pval_name = { txt = local_fun_name; loc }; pval_type; pval_loc = loc; - pval_prim; - pval_attributes; + pval_prim = Ast_external.pval_prim_default; + pval_attributes = [ Ast_attributes.mel_ffi ffi ]; }; pstr_loc = loc; }; @@ -244,17 +238,15 @@ let ocaml_object_as_js_object = label_type acc) labels label_types ~init:public_obj_type in - local_extern_cont_to_obj loc - ~pval_prim:(pval_prim_of_labels labels) + local_extern_cont_to_obj loc ~ffi:(ffi_of_labels labels) (fun e -> Exp.apply ~loc e (List.map2 ~f:(fun l expr -> (Labelled l.txt, expr)) labels exprs)) ~pval_type let record_as_js_object = - let local_external_obj loc ?(pval_attributes = []) ~pval_prim ~pval_type - ?(local_module_name = "J") ?(local_fun_name = "unsafe_expr") args : - expression_desc = + let local_external_obj loc ~ffi ~pval_type ?(local_module_name = "J") + ?(local_fun_name = "unsafe_expr") args : expression_desc = Pexp_letmodule ( { txt = Some local_module_name; loc }, { @@ -268,8 +260,8 @@ let record_as_js_object = pval_name = { txt = local_fun_name; loc }; pval_type; pval_loc = loc; - pval_prim; - pval_attributes; + pval_prim = [ ""; "" ]; + pval_attributes = [ Ast_attributes.mel_ffi ffi ]; }; pstr_loc = loc; }; @@ -331,7 +323,6 @@ let record_as_js_object = "`%%mel.obj' literals only support simple labels") label_exprs ~init:([], [], 0) in - local_external_obj loc - ~pval_prim:(pval_prim_of_labels labels) + local_external_obj loc ~ffi:(ffi_of_labels labels) ~pval_type:(from_labels ~loc arity labels) args diff --git a/ppx/mel_ast_invariant.ml b/ppx/mel_ast_invariant.ml index 32c5043d4..2b608361d 100644 --- a/ppx/mel_ast_invariant.ml +++ b/ppx/mel_ast_invariant.ml @@ -74,6 +74,9 @@ let mark_used_mel_attribute ({ attr_name = x; _ } : attribute) = let warn_unused_attribute ({ attr_name = { txt; loc } as sloc; _ } : attribute) : unit = if + (* XXX(anmonteiro): the `not loc.loc_ghost` expression is holding together + e.g. the fact that we don't emit unused attribute warnings for + `mel.internal.ffi` *) Melange_ffi.External_ffi_attributes.is_mel_attribute txt && (not loc.loc_ghost) && not (Polyvariant.Hash_set.mem used_attributes sloc) diff --git a/ppx/melange_ppx.cppo.ml b/ppx/melange_ppx.cppo.ml index ede8301ca..93b23ec0a 100644 --- a/ppx/melange_ppx.cppo.ml +++ b/ppx/melange_ppx.cppo.ml @@ -342,6 +342,15 @@ end module Mapper = struct let mapper = + let pval_ffi ~pval_name ~pval_type ~pval_loc ffi = + { + pval_name; + pval_type; + pval_loc; + pval_prim = Ast_external.pval_prim_default; + pval_attributes = [ Ast_attributes.mel_ffi ffi ]; + }; + in let succeed attr attrs = match attrs with | [ _ ] -> () @@ -606,15 +615,11 @@ module Mapper = struct str with pstr_desc = Pstr_primitive - { - pval_name; - pval_type = [%type: string]; - pval_loc = loc; - pval_attributes = []; - pval_prim = - Melange_ffi.External_ffi_types.inline_string_primitive - s None; - }; + (pval_ffi + ~pval_name + ~pval_type:[%type: string] + ~pval_loc:loc + (Melange_ffi.External_ffi_types.inline_string_primitive s)); } | Some attr, Pexp_constant (Pconst_string (s, loc, Some dec)) -> ( match @@ -645,15 +650,12 @@ module Mapper = struct str with pstr_desc = Pstr_primitive - { - pval_name; - pval_type = [%type: string]; - pval_loc = pvb_loc; - pval_attributes = []; - pval_prim = - Melange_ffi.External_ffi_types - .inline_string_primitive s dec; - }; + (pval_ffi + ~pval_name + ~pval_type:[%type: string] + ~pval_loc:pvb_loc + (Melange_ffi.External_ffi_types.inline_string_primitive s ?op:dec) + ); } | _ -> str) | Some attr, Pexp_constant (Pconst_integer (s, None)) -> @@ -664,14 +666,11 @@ module Mapper = struct str with pstr_desc = Pstr_primitive - { - pval_name; - pval_type = [%type: int]; - pval_loc = loc; - pval_attributes = []; - pval_prim = - Melange_ffi.External_ffi_types.inline_int_primitive s; - }; + (pval_ffi + ~pval_name + ~pval_type:[%type: int] + ~pval_loc:loc + (Melange_ffi.External_ffi_types.inline_int_primitive s)) } | Some attr, Pexp_constant (Pconst_integer (s, Some 'L')) -> let s = Int64.of_string s in @@ -681,15 +680,11 @@ module Mapper = struct str with pstr_desc = Pstr_primitive - { - pval_name; - pval_type = [%type: int64]; - pval_loc = loc; - pval_attributes = []; - pval_prim = - Melange_ffi.External_ffi_types.inline_int64_primitive - s; - }; + (pval_ffi + ~pval_name + ~pval_type:[%type: int64] + ~pval_loc:loc + (Melange_ffi.External_ffi_types.inline_int64_primitive s)) } | Some attr, Pexp_constant (Pconst_float (s, None)) -> succeed attr pvb_attributes; @@ -698,15 +693,11 @@ module Mapper = struct str with pstr_desc = Pstr_primitive - { - pval_name; - pval_type = [%type: float]; - pval_loc = loc; - pval_attributes = []; - pval_prim = - Melange_ffi.External_ffi_types.inline_float_primitive - s; - }; + (pval_ffi + ~pval_name + ~pval_type:[%type: float] + ~pval_loc:loc + (Melange_ffi.External_ffi_types.inline_float_primitive s)); } | ( Some attr, Pexp_construct @@ -717,15 +708,11 @@ module Mapper = struct str with pstr_desc = Pstr_primitive - { - pval_name; - pval_type = [%type: bool]; - pval_loc = loc; - pval_attributes = []; - pval_prim = - Melange_ffi.External_ffi_types.inline_bool_primitive - (bool = "true"); - }; + (pval_ffi + ~pval_name + ~pval_type:[%type: bool] + ~pval_loc:loc + (Melange_ffi.External_ffi_types.inline_bool_primitive (bool = "true"))); } | _ -> { @@ -869,10 +856,11 @@ module Mapper = struct Psig_value { value_desc with - pval_prim = - Melange_ffi.External_ffi_types - .inline_string_primitive s None; - pval_attributes = []; + pval_prim = Ast_external.pval_prim_default; + pval_attributes = [ + Ast_attributes.mel_ffi + (Melange_ffi.External_ffi_types.inline_string_primitive s); + ] }; } | Pexp_constant (Pconst_string (s, loc, Some dec)) -> ( @@ -907,10 +895,11 @@ module Mapper = struct Psig_value { value_desc with - pval_prim = - Melange_ffi.External_ffi_types - .inline_string_primitive s dec; - pval_attributes = []; + pval_attributes = [ + Ast_attributes.mel_ffi + (Melange_ffi.External_ffi_types.inline_string_primitive s ?op:dec) + ]; + pval_prim = Ast_external.pval_prim_default; }; } | _ -> sigi) @@ -923,10 +912,11 @@ module Mapper = struct Psig_value { value_desc with - pval_prim = - Melange_ffi.External_ffi_types - .inline_int_primitive s; - pval_attributes = []; + pval_attributes = [ + Ast_attributes.mel_ffi + (Melange_ffi.External_ffi_types.inline_int_primitive s) + ]; + pval_prim = Ast_external.pval_prim_default; }; } | Pexp_constant (Pconst_integer (s, Some 'L')) -> @@ -938,10 +928,11 @@ module Mapper = struct Psig_value { value_desc with - pval_prim = - Melange_ffi.External_ffi_types - .inline_int64_primitive s; - pval_attributes = []; + pval_attributes = [ + Ast_attributes.mel_ffi + (Melange_ffi.External_ffi_types.inline_int64_primitive s) + ]; + pval_prim = Ast_external.pval_prim_default; }; } | Pexp_constant (Pconst_float (s, None)) -> @@ -952,10 +943,11 @@ module Mapper = struct Psig_value { value_desc with - pval_prim = - Melange_ffi.External_ffi_types - .inline_float_primitive s; - pval_attributes = []; + pval_attributes = [ + Ast_attributes.mel_ffi + (Melange_ffi.External_ffi_types.inline_float_primitive s) + ]; + pval_prim = Ast_external.pval_prim_default; }; } | Pexp_construct @@ -967,10 +959,11 @@ module Mapper = struct Psig_value { value_desc with - pval_prim = - Melange_ffi.External_ffi_types - .inline_bool_primitive (txt = "true"); - pval_attributes = []; + pval_attributes = [ + Ast_attributes.mel_ffi + (Melange_ffi.External_ffi_types.inline_bool_primitive + (txt = "true"))]; + pval_prim = Ast_external.pval_prim_default; }; } | _ -> diff --git a/test/blackbox-tests/deriving-separate.t b/test/blackbox-tests/deriving-separate.t index 664de3135..df9e68bc1 100644 --- a/test/blackbox-tests/deriving-separate.t +++ b/test/blackbox-tests/deriving-separate.t @@ -20,10 +20,11 @@ Tests for deriving `jsProperties, getSet` struct let _ = fun (_ : chartDataItemType) -> () external chartDataItemType : - height:int -> foo:string -> chartDataItemType = "" - "\132\149\166\190\000\000\000\023\000\000\000\t\000\000\000\024\000\000\000\022\145\160\160A\144&height\160\160A\144%width@" - [@@ocaml.warning "-unboxable-type-in-prim-decl"][@@ocaml.warning - "-unboxable-type-in-prim-decl"] + height:int -> foo:string -> chartDataItemType = "" ""[@@ocaml.warning + "-unboxable-type-in-prim-decl"] + [@@mel.internal.ffi + "\132\149\166\190\000\000\000\023\000\000\000\t\000\000\000\024\000\000\000\022\145\160\160A\144&height\160\160A\144%width@"] + [@@ocaml.warning "-unboxable-type-in-prim-decl"] end[@@ocaml.doc "@inline"][@@merlin.hide ] let t = chartDataItemType ~height:2 ~foo:"bar" // Generated by Melange @@ -54,16 +55,16 @@ Tests for deriving `jsProperties, getSet` include struct let _ = fun (_ : chartDataItemType) -> () - external heightGet : - chartDataItemType -> int = "" - "\132\149\166\190\000\000\000\r\000\000\000\004\000\000\000\012\000\000\000\011\176\145AA\168&height@" - [@@ocaml.warning "-unboxable-type-in-prim-decl"][@@internal.arity 1] - [@@ocaml.warning "-unboxable-type-in-prim-decl"] - external fooGet : - chartDataItemType -> string = "" - "\132\149\166\190\000\000\000\012\000\000\000\004\000\000\000\012\000\000\000\011\176\145AA\168%width@" - [@@ocaml.warning "-unboxable-type-in-prim-decl"][@@internal.arity 1] - [@@ocaml.warning "-unboxable-type-in-prim-decl"] + external heightGet : chartDataItemType -> int = "" ""[@@ocaml.warning + "-unboxable-type-in-prim-decl"] + [@@mel.internal.ffi + "\132\149\166\190\000\000\000\r\000\000\000\004\000\000\000\012\000\000\000\011\176\145AA\168&height@"] + [@@internal.arity 1][@@ocaml.warning "-unboxable-type-in-prim-decl"] + external fooGet : chartDataItemType -> string = "" ""[@@ocaml.warning + "-unboxable-type-in-prim-decl"] + [@@mel.internal.ffi + "\132\149\166\190\000\000\000\012\000\000\000\004\000\000\000\012\000\000\000\011\176\145AA\168%width@"] + [@@internal.arity 1][@@ocaml.warning "-unboxable-type-in-prim-decl"] end[@@ocaml.doc "@inline"][@@merlin.hide ] // Generated by Melange /* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ @@ -85,20 +86,21 @@ Tests for deriving `jsProperties, getSet` struct let _ = fun (_ : chartDataItemType) -> () external chartDataItemType : - height:int -> foo:string -> chartDataItemType = "" - "\132\149\166\190\000\000\000\023\000\000\000\t\000\000\000\024\000\000\000\022\145\160\160A\144&height\160\160A\144%width@" - [@@ocaml.warning "-unboxable-type-in-prim-decl"][@@ocaml.warning - "-unboxable-type-in-prim-decl"] - external heightGet : - chartDataItemType -> int = "" - "\132\149\166\190\000\000\000\r\000\000\000\004\000\000\000\012\000\000\000\011\176\145AA\168&height@" - [@@ocaml.warning "-unboxable-type-in-prim-decl"][@@internal.arity 1] - [@@ocaml.warning "-unboxable-type-in-prim-decl"] - external fooGet : - chartDataItemType -> string = "" - "\132\149\166\190\000\000\000\012\000\000\000\004\000\000\000\012\000\000\000\011\176\145AA\168%width@" - [@@ocaml.warning "-unboxable-type-in-prim-decl"][@@internal.arity 1] + height:int -> foo:string -> chartDataItemType = "" ""[@@ocaml.warning + "-unboxable-type-in-prim-decl"] + [@@mel.internal.ffi + "\132\149\166\190\000\000\000\023\000\000\000\t\000\000\000\024\000\000\000\022\145\160\160A\144&height\160\160A\144%width@"] [@@ocaml.warning "-unboxable-type-in-prim-decl"] + external heightGet : chartDataItemType -> int = "" ""[@@ocaml.warning + "-unboxable-type-in-prim-decl"] + [@@mel.internal.ffi + "\132\149\166\190\000\000\000\r\000\000\000\004\000\000\000\012\000\000\000\011\176\145AA\168&height@"] + [@@internal.arity 1][@@ocaml.warning "-unboxable-type-in-prim-decl"] + external fooGet : chartDataItemType -> string = "" ""[@@ocaml.warning + "-unboxable-type-in-prim-decl"] + [@@mel.internal.ffi + "\132\149\166\190\000\000\000\012\000\000\000\004\000\000\000\012\000\000\000\011\176\145AA\168%width@"] + [@@internal.arity 1][@@ocaml.warning "-unboxable-type-in-prim-decl"] end[@@ocaml.doc "@inline"][@@merlin.hide ] // Generated by Melange /* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/vendor/melange-compiler-libs b/vendor/melange-compiler-libs index 5612cd791..7eda8e25f 160000 --- a/vendor/melange-compiler-libs +++ b/vendor/melange-compiler-libs @@ -1 +1 @@ -Subproject commit 5612cd791f386f47665f64add5bc69991e15ec2f +Subproject commit 7eda8e25f2ee27bd048226e6d09c85c5eb1c3b4a