pax_global_header00006660000000000000000000000064146164733610014525gustar00rootroot0000000000000052 comment=079acc99a277513ac5de2306e4be6577ca6f1f19 ppx_globalize-0.17.0/000077500000000000000000000000001461647336100144515ustar00rootroot00000000000000ppx_globalize-0.17.0/.gitignore000066400000000000000000000000411461647336100164340ustar00rootroot00000000000000_build *.install *.merlin _opam ppx_globalize-0.17.0/.ocamlformat000066400000000000000000000000231461647336100167510ustar00rootroot00000000000000profile=janestreet ppx_globalize-0.17.0/CHANGES.md000066400000000000000000000000011461647336100160320ustar00rootroot00000000000000 ppx_globalize-0.17.0/CONTRIBUTING.md000066400000000000000000000044101461647336100167010ustar00rootroot00000000000000This repository contains open source software that is developed and maintained by [Jane Street][js]. Contributions to this project are welcome and should be submitted via GitHub pull requests. Signing contributions --------------------- We require that you sign your contributions. Your signature certifies that you wrote the patch or otherwise have the right to pass it on as an open-source patch. The rules are pretty simple: if you can certify the below (from [developercertificate.org][dco]): ``` Developer Certificate of Origin Version 1.1 Copyright (C) 2004, 2006 The Linux Foundation and its contributors. 1 Letterman Drive Suite D4700 San Francisco, CA, 94129 Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Developer's Certificate of Origin 1.1 By making a contribution to this project, I certify that: (a) The contribution was created in whole or in part by me and I have the right to submit it under the open source license indicated in the file; or (b) The contribution is based upon previous work that, to the best of my knowledge, is covered under an appropriate open source license and I have the right under that license to submit that work with modifications, whether created in whole or in part by me, under the same open source license (unless I am permitted to submit under a different license), as indicated in the file; or (c) The contribution was provided directly to me by some other person who certified (a), (b) or (c) and I have not modified it. (d) I understand and agree that this project and the contribution are public and that a record of the contribution (including all personal information I submit with it, including my sign-off) is maintained indefinitely and may be redistributed consistent with this project or the open source license(s) involved. ``` Then you just add a line to every git commit message: ``` Signed-off-by: Joe Smith ``` Use your real name (sorry, no pseudonyms or anonymous contributions.) If you set your `user.name` and `user.email` git configs, you can sign your commit automatically with git commit -s. [dco]: http://developercertificate.org/ [js]: https://opensource.janestreet.com/ ppx_globalize-0.17.0/LICENSE.md000066400000000000000000000021461461647336100160600ustar00rootroot00000000000000The MIT License Copyright (c) 2022--2024 Jane Street Group, LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ppx_globalize-0.17.0/Makefile000066400000000000000000000004031461647336100161060ustar00rootroot00000000000000INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) default: dune build install: dune install $(INSTALL_ARGS) uninstall: dune uninstall $(INSTALL_ARGS) reinstall: uninstall install clean: dune clean .PHONY: default install uninstall reinstall clean ppx_globalize-0.17.0/dune000066400000000000000000000003121461647336100153230ustar00rootroot00000000000000(library (name ppx_globalize) (public_name ppx_globalize) (kind ppx_deriver) (ppx_runtime_libraries) (preprocess (pps ppxlib.metaquot)) (libraries compiler-libs.common base ppxlib ppxlib_jane)) ppx_globalize-0.17.0/dune-project000066400000000000000000000000211461647336100167640ustar00rootroot00000000000000(lang dune 3.11) ppx_globalize-0.17.0/ppx_globalize.ml000066400000000000000000000613651461647336100176550ustar00rootroot00000000000000open! Base open Ppxlib (* Copies source syntax to be used in generated code. Strips attributes and ensures all locations are marked as "ghost". *) let copy = object inherit Ast_traverse.map method! location loc = { loc with loc_ghost = true } method! attributes _ = [] end ;; let error ~loc fmt = Location.raise_errorf ~loc (Stdlib.( ^^ ) "ppx_globalize: " fmt) let is_global_field ld = match ld.pld_mutable with | Mutable -> true | Immutable -> (match Ppxlib_jane.Ast_builder.Default.get_label_declaration_modality ld with | Some Global, _ -> true | None, _ -> false) ;; (* Check if types are really recursive ignoring global and mutable fields *) class is_recursive rec_flag decls = object inherit type_is_recursive rec_flag decls as super method! label_declaration ld = if is_global_field ld then () else super#label_declaration ld end let really_recursive rec_flag decls = (new is_recursive rec_flag decls)#go () (* The name of the globalize function for a given type name as a string *) let globalize_name type_name = if String.equal type_name "t" then "globalize" else "globalize_" ^ type_name ;; (* The name of the globalize function for a given type name as a longident *) let globalize_lid = function | Lident name -> Lident (globalize_name name) | Ldot (p, name) -> Ldot (p, globalize_name name) | Lapply _ -> assert false ;; module Env : sig (* A mapping from type variables to globalize functions *) type t (* An empty mapping *) val empty : t type var = | Universal | Globalize of expression (* Lookup a globalize function *) val lookup : t -> string -> var option (* Create a mapping for the type parameters of a type declaration. Returns both the mapping and a list of names that should be bound to the globalize functions of the parameters of the type *) val of_type_decl : (module Ast_builder.S) -> type_declaration -> t * string list (* Update a mapping for the body of a variant constructor. In the non-GADT case the mapping is unchanged. In the GADT case we need to build the mapping by looking at the result type of the constructor. *) val enter_constructor_declaration : (module Ast_builder.S) -> t -> constructor_declaration -> t (* Update a mapping for the body of a polytype. *) val enter_poly : (module Ast_builder.S) -> t -> string loc list -> t end = struct type var = | Universal | Globalize of expression type t = { vars : var Map.M(String).t ; params : string list } let empty = { vars = Map.empty (module String); params = [] } let lookup t name = Map.find t.vars name let of_type_decl builder decl = let open (val builder : Ast_builder.S) in let vars = Map.empty (module String) in let params = [] in let t = List.fold_right decl.ptype_params ~init:{ vars; params } ~f:(fun (typ, _) { vars; params } -> let vars, sym = match typ.ptyp_desc with | Ptyp_var name -> let prefix = "_globalize_" ^ name in let sym = gen_symbol ~prefix () in let vars = Map.add_exn vars ~key:name ~data:(Globalize (evar sym)) in vars, sym | _ -> let prefix = "_globalize_param" in let sym = gen_symbol ~prefix () in vars, sym in let params = sym :: params in { vars; params }) in t, t.params ;; (* This is for GADTs; it finds the indices (as opposed to the parameters) of the type and makes them their own globalize parameters. Given a definition like: {[ type ('a, 'b) t = | Foo : ... -> ('c, 'd) t ]} we are making a mapping from ['c] and ['d] to the globalize functions of the first and second parameters. [params] has the list of globalize functions so we just fold2 along that list and the list of arguments to [t] in the result type adding mappings for it. This completely replaces the outer mapping, which would have mapped ['a] and ['b] to those parameters. If the index is not a variable, or if the variable has already appeared for another index, then we don't add a mapping. *) let enter_constructor_declaration builder { vars; params } cd = let open (val builder : Ast_builder.S) in let vars = match cd.pcd_res with | None -> vars | Some ty -> let vars = Map.empty (module String) in (match ty.ptyp_desc with | Ptyp_constr (_, args) when List.length params = List.length args -> List.fold2_exn params args ~init:vars ~f:(fun vars param arg -> match arg.ptyp_desc with | Ptyp_var name | Ptyp_alias (_, name) -> (match Map.add vars ~key:name ~data:(Globalize (evar param)) with | `Duplicate -> vars | `Ok vars -> vars) | _ -> vars) | _ -> vars) in { vars; params } ;; let enter_poly _builder { vars; params } names = let vars = List.fold ~init:vars names ~f:(fun vars name -> Map.set vars ~key:name.txt ~data:Universal) in { vars; params } ;; end let globalize_arrow ~loc ty = [%type: [%t ty] -> [%t ty]] (* Generate the type for a copier function for a given list of type parameters and type name *) let generate_typ builder params type_name = let open (val builder : Ast_builder.S) in let globalize_arrow = globalize_arrow ~loc in let type_lid = Located.lident type_name in let type_ = ptyp_constr type_lid params in List.fold_right params ~init:(globalize_arrow type_) ~f:(fun param acc -> ptyp_arrow Nolabel (globalize_arrow param) acc) ;; (* Is an object field a polymorphic method? *) let is_polymorphic_method field = match field.pof_desc with | Otag (_, ct) -> (match ct.ptyp_desc with | Ptyp_poly _ -> true | _ -> false) | Oinherit _ -> false ;; (* Strip a type to just its head for use in a coercion. This avoids needing to worry about the scope of type variables. *) let rec type_head builder typ = let open (val builder : Ast_builder.S) in match Ppxlib_jane.Jane_syntax.Core_type.of_ast typ with | Some (Jtyp_tuple args, _) -> let args = List.map ~f:(fun (lbl, _) -> lbl, ptyp_any) args in Ppxlib_jane.Jane_syntax.Core_type.core_type_of ~loc ~attrs:[] (Jtyp_tuple args) | Some (Jtyp_layout _, _) | None -> (match typ.ptyp_desc with | Ptyp_any | Ptyp_var _ | Ptyp_extension _ -> ptyp_any | Ptyp_tuple args -> let args = List.map ~f:(fun _ -> ptyp_any) args in ptyp_tuple args | Ptyp_constr (lid, []) -> ptyp_constr (Located.mk lid.txt) [] | Ptyp_constr (lid, _ :: _) -> ptyp_constr (Located.mk lid.txt) [ ptyp_any ] | Ptyp_variant (fields, closed, labels) -> let fields = List.map fields ~f:(fun field -> match field.prf_desc with | Rtag (label, const, args) -> rtag label const (List.map ~f:(fun _ -> ptyp_any) args) | Rinherit typ -> rinherit (type_head builder typ)) in ptyp_variant fields closed labels | Ptyp_alias (typ, _) -> type_head builder typ | Ptyp_arrow (lbl, _, _) -> ptyp_arrow lbl ptyp_any ptyp_any | Ptyp_package (mty, constrs) -> let constrs = List.map ~f:(fun (lid, _) -> lid, ptyp_any) constrs in ptyp_package (mty, constrs) | Ptyp_object (fields, closed) -> if List.exists fields ~f:is_polymorphic_method then ptyp_any else ( let fields = List.map fields ~f:(fun field -> match field.pof_desc with | Otag (lbl, _) -> otag lbl ptyp_any | Oinherit typ -> oinherit (type_head builder typ)) in ptyp_object fields closed) | Ptyp_class (lid, args) -> let args = List.map ~f:(fun _ -> ptyp_any) args in ptyp_class (Located.mk lid.txt) args | Ptyp_poly _ -> assert false) ;; let mode_crossing_attr_name = "globalized" let mode_crossing_attr_core_type = Attribute.declare mode_crossing_attr_name Attribute.Context.core_type Ast_pattern.(pstr nil) () ;; let mode_crossing_attr_label_declaration = Attribute.declare mode_crossing_attr_name Attribute.Context.label_declaration Ast_pattern.(pstr nil) () ;; (* We generate a beta-redex to give a better error message if the type does not cross modes. *) let globalized_mode_crossing exp typ loc = let loc = { loc with loc_ghost = true } in let builder = Ast_builder.make loc in let open (val builder : Ast_builder.S) in pexp_apply (pexp_constraint (pexp_fun Nolabel None (ppat_var { txt = "x"; loc }) (pexp_ident { txt = Lident "x"; loc })) [%type: [%t typ] -> [%t copy#core_type typ]]) [ Nolabel, exp ] ;; (* Generate code to create a globalized copy of the value produced by the expression [exp] of type [typ]. *) let rec generate_globalized_for_typ builder env exp name_opt typ = let open (val builder : Ast_builder.S) in let typ_loc = typ.ptyp_loc in match Attribute.consume mode_crossing_attr_core_type typ with | Some (typ, ()) -> globalized_mode_crossing exp typ typ_loc | None -> (match Ppxlib_jane.Jane_syntax.Core_type.of_ast typ with | Some (Jtyp_tuple args, _attrs) -> let tpat, texp = generate_globalized_for_tuple_args builder env args in pexp_let Nonrecursive [ value_binding ~pat:tpat ~expr:exp ] texp | Some (Jtyp_layout _, _) | None -> (match typ.ptyp_desc with | Ptyp_var name -> (match Env.lookup env name with | Some (Globalize fn) -> eapply fn [ exp ] | Some Universal -> error ~loc:typ.ptyp_loc "Cannot generate globalize function for universal type variable '%s" name | None -> error ~loc:typ.ptyp_loc "Cannot generate globalize function for unbound type variable '%s" name) | Ptyp_tuple args -> let tpat, texp = generate_globalized_for_tuple_args builder env (List.map ~f:(fun arg -> None, arg) args) in pexp_let Nonrecursive [ value_binding ~pat:tpat ~expr:exp ] texp | Ptyp_constr (lid, args) -> let args = List.map ~f:(generate_globalized_for_typ_as_function builder env None) args in let lid = globalize_lid lid.txt in eapply (pexp_ident (Located.mk lid)) (args @ [ exp ]) | Ptyp_variant (fields, Closed, None) -> let inherits, constants, nonconstants = List.fold_right fields ~init:([], [], []) ~f:(fun field (inherits, consts, nonconsts) -> match field.prf_desc with | Rtag (name, false, [ arg ]) -> inherits, consts, (name.txt, arg) :: nonconsts | Rtag (name, true, []) -> inherits, name.txt :: consts, nonconsts | Rtag (_, _, _) -> error ~loc:typ.ptyp_loc "Cannot generate globalize function for partial variant type" | Rinherit typ -> (match typ.ptyp_desc with | Ptyp_constr (lid, _) -> (lid.txt, typ) :: inherits, consts, nonconsts | _ -> error ~loc:typ.ptyp_loc "Cannot generate globalize function for unnamed inherited variant \ constructors")) in let inherit_cases = List.map inherits ~f:(fun (lid, inher) -> let v = gen_symbol ~prefix:"x" () in let lid = Located.mk lid in let lhs = ppat_alias (ppat_type lid) (Located.mk v) in let typ = match name_opt with | None -> typ | Some typ -> typ in let rhs = pexp_coerce (generate_globalized_for_typ builder env (evar v) None inher) (Some (type_head builder inher)) (type_head builder typ) in case ~lhs ~rhs ~guard:None) in let constants_case = match constants with | [] -> None | first :: rest -> let v = gen_symbol ~prefix:"x" () in let first_pat = ppat_variant first None in let lhs = ppat_alias (List.fold ~init:first_pat rest ~f:(fun acc name -> ppat_or acc (ppat_variant name None))) (Located.mk v) in let rhs = evar v in Some (case ~lhs ~rhs ~guard:None) in let nonconstants_cases = List.map nonconstants ~f:(fun (name, arg) -> let v = gen_symbol ~prefix:"arg" () in let lhs = ppat_variant name (Some (pvar v)) in let arg = generate_globalized_for_typ builder env (evar v) None arg in let rhs = pexp_variant name (Some arg) in case ~lhs ~rhs ~guard:None) in let cases = inherit_cases @ Option.to_list constants_case @ nonconstants_cases in pexp_match exp cases | Ptyp_variant (_, Open, _) -> error ~loc:typ.ptyp_loc "Cannot generate globalize function for open variant type" | Ptyp_variant (_, Closed, Some _) -> error ~loc:typ.ptyp_loc "Cannot generate globalize function for partial variant type" | Ptyp_alias (typ, name) -> (match Env.lookup env name with | Some (Globalize fn) -> eapply fn [ exp ] | Some Universal | None -> generate_globalized_for_typ builder env exp name_opt typ) | Ptyp_poly (names, typ) -> let env = Env.enter_poly builder env names in generate_globalized_for_typ builder env exp None typ | Ptyp_any -> error ~loc:typ.ptyp_loc "Cannot generate globalize function for unknown type" | Ptyp_arrow (_, _, _) -> error ~loc:typ.ptyp_loc "Cannot generate globalize function for function type" | Ptyp_object (_, _) -> error ~loc:typ.ptyp_loc "Cannot generate globalize function for object type" | Ptyp_class (_, _) -> error ~loc:typ.ptyp_loc "Cannot generate globalize function for class type" | Ptyp_package _ -> error ~loc:typ.ptyp_loc "Cannot generate globalize function for first-class module type" | Ptyp_extension _ -> error ~loc:typ.ptyp_loc "Cannot generate globalize function for unknown extension")) (* Generate code for a function to globalize values of type [type]. *) and generate_globalized_for_typ_as_function builder env name_opt typ = let open (val builder : Ast_builder.S) in let v = gen_symbol ~prefix:"x" () in let lhs = pvar v in let rhs = generate_globalized_for_typ builder env (evar v) name_opt typ in eta_reduce_if_possible (pexp_fun Nolabel None lhs rhs) (* Generate code to create a globalized copy of the arguments of a tuple with types [args]. Returns a pattern to match the tuple, an expression to produce the copy, and some value bindings for intermediate values. *) and generate_globalized_for_tuple_args builder env args = let open (val builder : Ast_builder.S) in let pats, exps = List.fold_right ~init:([], []) ~f:(fun (lbl, arg) (pats, exps) -> let vin = gen_symbol ~prefix:"arg" () in let pat = pvar vin in let local_exp = evar vin in let exp = match Ppxlib_jane.Ast_builder.Default.get_tuple_field_modality arg with | Some Global, _ -> local_exp | None, _ -> generate_globalized_for_typ builder env local_exp None arg in (lbl, pat) :: pats, (lbl, exp) :: exps) args in let pat = match pats with | [] | [ (Some _, _) ] -> assert false | [ (None, pat) ] -> pat | _ :: _ -> Ppxlib_jane.Jane_syntax.Pattern.pat_of ~loc ~attrs:[] (Jpat_tuple (pats, Closed)) in let exp = match exps with | [] | [ (Some _, _) ] -> assert false | [ (None, exp) ] -> exp | _ :: _ -> Ppxlib_jane.Jane_syntax.Expression.expr_of ~loc ~attrs:[] (Jexp_tuple exps) in pat, exp ;; (* Generate code to create a globalized copy of the arguments of a record with labels [lds]. Returns a pattern to match the record, an expression to produce the copy, and some value bindings for intermediate values. *) let generate_globalized_for_record_args builder env lds = let open (val builder : Ast_builder.S) in let pats, exps = List.fold_right ~init:([], []) ~f:(fun ld (pats, exps) -> let name = ld.pld_name.txt in let lid = Located.mk (Lident name) in let vin = gen_symbol ~prefix:name () in let pat = lid, pvar vin in let local_exp = evar vin in let ld_loc = ld.pld_loc in let exp = match Attribute.consume mode_crossing_attr_label_declaration ld with | Some (ld, ()) -> globalized_mode_crossing local_exp ld.pld_type ld_loc | None -> if is_global_field ld then local_exp else generate_globalized_for_typ builder env local_exp None ld.pld_type in pat :: pats, (lid, exp) :: exps) lds in ppat_record pats Closed, pexp_record exps None ;; (* Generate code to create a globalized copy of the value produced by the expression [exp] of a type with record labels [lds]. *) let generate_globalized_for_record builder env exp lds = let open (val builder : Ast_builder.S) in let rpat, rexp = generate_globalized_for_record_args builder env lds in pexp_let Nonrecursive [ value_binding ~pat:rpat ~expr:exp ] rexp ;; (* Generate code to create a globalized copy of the value produced by the expression [exp] of a type with variant constructors [cds]. *) let generate_globalized_for_variant builder env exp cds = let open (val builder : Ast_builder.S) in let constants, nonconstants = List.fold_right cds ~init:([], []) ~f:(fun (cd : constructor_declaration) (consts, nonconsts) -> (* We differentiate between constant cases for GADTs vs normal variants because currently, the type checker does not allow the use of as-pattern to rename an or-pattern of GADTs when it does allow us to do so for normal variants. This is fixed in an upstream PR: https://github.com/ocaml/ocaml/pull/11799 When this is merged we can collapse the constants case back into a singular branch. *) match cd.pcd_res, cd.pcd_args with | None, Pcstr_tuple [] -> let name = cd.pcd_name.txt in let consts = name :: consts in consts, nonconsts | None, ((Pcstr_tuple _ | Pcstr_record _) as args) | Some _, ((Pcstr_tuple _ | Pcstr_record _) as args) -> let name = cd.pcd_name.txt in let env = Env.enter_constructor_declaration builder env cd in let nonconsts = (name, args, env) :: nonconsts in consts, nonconsts) in let constants_case = match constants with | [] -> None | first :: rest -> let v = gen_symbol ~prefix:"x" () in let first_lid = Located.mk (Lident first) in let first_pat = ppat_construct first_lid None in let lhs = ppat_alias (List.fold ~init:first_pat rest ~f:(fun acc name -> let lid = Located.mk (Lident name) in ppat_or acc (ppat_construct lid None))) (Located.mk v) in let rhs = evar v in Some (case ~lhs ~rhs ~guard:None) in let nonconstants_cases = List.map nonconstants ~f:(fun (name, args, env) -> let pat, exp = match args with | Pcstr_tuple [] -> None, None | Pcstr_tuple args -> let pat, exp = generate_globalized_for_tuple_args builder env (List.map ~f:(fun arg -> None, arg) args) in Some pat, Some exp | Pcstr_record lds -> let pat, exp = generate_globalized_for_record_args builder env lds in Some pat, Some exp in let lid = Located.mk (Lident name) in let lhs = ppat_construct lid pat in let rhs = pexp_construct lid exp in case ~lhs ~rhs ~guard:None) in let cases = Option.to_list constants_case @ nonconstants_cases in pexp_match exp cases ;; (* Generate code to create a globalized copy of the value produced by the expression [exp] of a type with declaration [decl]. *) let generate_globalized_for_decl builder env exp name decl = let open (val builder : Ast_builder.S) in match decl.ptype_kind with | Ptype_abstract -> (match decl.ptype_manifest with | Some typ -> let name = let args = match decl.ptype_params with | [] -> [] | _ :: _ -> [ ptyp_any ] in ptyp_constr (Located.lident name) args in generate_globalized_for_typ builder env exp (Some name) typ | None -> error ~loc "Cannot generate globalize function for abstract type") | Ptype_record lds -> generate_globalized_for_record builder env exp lds | Ptype_variant cds -> generate_globalized_for_variant builder env exp cds | Ptype_open -> error ~loc "Cannot generate globalize function for extensible variants" ;; (* Generate code for a function to globalize values of a type with declaration [decl]. *) let generate_globalized_for_decl_as_function builder env name decl = let open (val builder : Ast_builder.S) in let v = gen_symbol ~prefix:"x" () in let lhs = pvar v in let rhs = generate_globalized_for_decl builder env (evar v) name decl in pexp_fun Nolabel None lhs rhs ;; (* Generate a value binding for a function to globalize values of a type with declaration [decl]. *) let generate_vb rec_flag decl = let loc = { decl.ptype_loc with loc_ghost = true } in let builder = Ast_builder.make loc in let open (val builder : Ast_builder.S) in let type_name = decl.ptype_name.txt in let name = globalize_name type_name in let pat = pvar name in let param_names = List.mapi decl.ptype_params ~f:(fun i (param, _) -> match param.ptyp_desc with | Ptyp_var name -> name | _ -> "param" ^ Int.to_string i) in let external_params = List.map param_names ~f:(fun name -> ptyp_var name) in let external_param_bindings = List.map param_names ~f:(fun name -> Located.mk name) in let external_type = ptyp_poly external_param_bindings (generate_typ builder external_params type_name) in let pat = ppat_constraint pat external_type in let internal_param_names = List.map param_names ~f:(fun name -> gen_symbol ~prefix:name ()) in let internal_params = List.map internal_param_names ~f:(fun name -> ptyp_constr (Located.lident name) []) in let internal_type = generate_typ builder internal_params type_name in let env, params = Env.of_type_decl builder decl in let fn = generate_globalized_for_decl_as_function builder env type_name decl in let fn = eabstract (List.map ~f:pvar params) fn in let fn = eta_reduce_if_possible_and_nonrec ~rec_flag fn in let expr = pexp_constraint fn internal_type in let expr = List.fold_right ~init:expr ~f:(fun name acc -> pexp_newtype (Located.mk name) acc) internal_param_names in value_binding ~pat ~expr ;; (* Generate a value declaration for a function to globalize values of a type with declaration [decl]. *) let generate_val decl = let loc = { decl.ptype_loc with loc_ghost = true } in let builder = Ast_builder.make loc in let open (val builder : Ast_builder.S) in let type_name = decl.ptype_name.txt in let name = Located.mk (globalize_name type_name) in let params = List.map decl.ptype_params ~f:(fun (param, _) -> param) in let type_ = generate_typ builder params type_name in let vd = value_description ~name ~type_ ~prim:[] in psig_value vd ;; (* The deriver for types in structures *) let generate_str ~ctxt:_ (rec_flag, decls) = let rec_flag = really_recursive rec_flag decls in let vbs = List.map ~f:(generate_vb rec_flag) decls in [ Ast_builder.Default.pstr_value ~loc:Location.none rec_flag vbs ] ;; (* The deriver for types in signatures *) let generate_sig ~ctxt:_ (_rec_flag, decls) = List.map ~f:generate_val decls (* The implementation of `[%globalize: ...]` *) let extension ~loc:_ ~path:_ typ = let loc = { typ.ptyp_loc with loc_ghost = true } in let builder = Ast_builder.make loc in generate_globalized_for_typ_as_function builder Env.empty None typ ;; let extension_name = "globalize" let globalize = let str_type_decl = Deriving.Generator.V2.make_noarg generate_str in let sig_type_decl = Deriving.Generator.V2.make_noarg generate_sig in Deriving.add extension_name ~str_type_decl ~sig_type_decl ~extension ;; ppx_globalize-0.17.0/ppx_globalize.mli000066400000000000000000000000501461647336100200060ustar00rootroot00000000000000open Ppxlib val globalize : Deriving.t ppx_globalize-0.17.0/ppx_globalize.opam000066400000000000000000000015051461647336100201670ustar00rootroot00000000000000opam-version: "2.0" version: "v0.17.0" maintainer: "Jane Street developers" authors: ["Jane Street Group, LLC"] homepage: "https://github.com/janestreet/ppx_globalize" bug-reports: "https://github.com/janestreet/ppx_globalize/issues" dev-repo: "git+https://github.com/janestreet/ppx_globalize.git" doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/ppx_globalize/index.html" license: "MIT" build: [ ["dune" "build" "-p" name "-j" jobs] ] depends: [ "ocaml" {>= "5.1.0"} "base" {>= "v0.17" & < "v0.18"} "ppxlib_jane" {>= "v0.17" & < "v0.18"} "dune" {>= "3.11.0"} "ppxlib" {>= "0.28.0"} ] available: arch != "arm32" & arch != "x86_32" synopsis: "A ppx rewriter that generates functions to copy local values to the global heap" description: " Part of the Jane Street's PPX rewriters collection. "