pax_global_header00006660000000000000000000000064146164733610014525gustar00rootroot0000000000000052 comment=d9cdce4e1ff97145acfd4e7a734e033d307b71aa ppx_stable_witness-0.17.0/000077500000000000000000000000001461647336100155275ustar00rootroot00000000000000ppx_stable_witness-0.17.0/.gitignore000066400000000000000000000000411461647336100175120ustar00rootroot00000000000000_build *.install *.merlin _opam ppx_stable_witness-0.17.0/.ocamlformat000066400000000000000000000000231461647336100200270ustar00rootroot00000000000000profile=janestreet ppx_stable_witness-0.17.0/CONTRIBUTING.md000066400000000000000000000044101461647336100177570ustar00rootroot00000000000000This 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_stable_witness-0.17.0/LICENSE.md000066400000000000000000000021461461647336100171360ustar00rootroot00000000000000The 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_stable_witness-0.17.0/Makefile000066400000000000000000000004031461647336100171640ustar00rootroot00000000000000INSTALL_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_stable_witness-0.17.0/dune-project000066400000000000000000000000211461647336100200420ustar00rootroot00000000000000(lang dune 3.11) ppx_stable_witness-0.17.0/ppx_stable_witness.opam000066400000000000000000000017061461647336100223260ustar00rootroot00000000000000opam-version: "2.0" version: "v0.17.0" maintainer: "Jane Street developers" authors: ["Jane Street Group, LLC"] homepage: "https://github.com/janestreet/ppx_stable_witness" bug-reports: "https://github.com/janestreet/ppx_stable_witness/issues" dev-repo: "git+https://github.com/janestreet/ppx_stable_witness.git" doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/ppx_stable_witness/index.html" license: "MIT" build: [ ["dune" "build" "-p" name "-j" jobs] ] depends: [ "ocaml" {>= "5.1.0"} "base" {>= "v0.17" & < "v0.18"} "dune" {>= "3.11.0"} "ppxlib" {>= "0.28.0"} ] available: arch != "arm32" & arch != "x86_32" synopsis: "Ppx extension for deriving a witness that a type is intended to be stable. In this\n context, stable means that the serialization format will never change. This allows\n programs running at different versions of the code to safely communicate." description: " Part of the Jane Street's PPX rewriters collection. " ppx_stable_witness-0.17.0/src/000077500000000000000000000000001461647336100163165ustar00rootroot00000000000000ppx_stable_witness-0.17.0/src/runtime/000077500000000000000000000000001461647336100200015ustar00rootroot00000000000000ppx_stable_witness-0.17.0/src/runtime/dune000066400000000000000000000002221461647336100206530ustar00rootroot00000000000000(library (name ppx_stable_witness_runtime) (public_name ppx_stable_witness.runtime) (libraries stable_witness) (preprocess no_preprocessing)) ppx_stable_witness-0.17.0/src/runtime/ppx_stable_witness_runtime.ml000066400000000000000000000002631461647336100260140ustar00rootroot00000000000000(** This library exists solely to re-export [Stable_witness] via a fully-qualified module path that is unlikely to ever be shadowed. *) module Stable_witness = Stable_witness ppx_stable_witness-0.17.0/src/src/000077500000000000000000000000001461647336100171055ustar00rootroot00000000000000ppx_stable_witness-0.17.0/src/src/dune000066400000000000000000000003161461647336100177630ustar00rootroot00000000000000(library (name ppx_stable_witness) (public_name ppx_stable_witness) (kind ppx_deriver) (ppx_runtime_libraries ppx_stable_witness.runtime) (libraries base ppxlib) (preprocess (pps ppxlib.metaquot))) ppx_stable_witness-0.17.0/src/src/ppx_stable_witness.ml000066400000000000000000000237571461647336100233720ustar00rootroot00000000000000open! Base open Ppxlib open Ast_builder.Default let ghost loc = { loc with loc_ghost = true } let strip_locs = (* Replace locations with a dummy so that syntax can be compared for equality. *) object inherit Ast_traverse.map method! location _ = Location.none end ;; let copy = (* Strip off attributes and mark all locations as ghost so that a copy of syntax (usually a type) can be included in generated code. *) object inherit Ast_traverse.map method! attributes _ = [] method! location = ghost end ;; let custom_attr = Attribute.declare "stable_witness.custom" Core_type Ast_pattern.(pstr (pstr_eval __ nil ^:: nil)) Fn.id ;; let stable_witness_name = function | "t" -> "stable_witness" | type_name -> "stable_witness_" ^ type_name ;; let stable_witness_type ~loc core_type = [%type: [%t copy#core_type core_type] Ppx_stable_witness_runtime.Stable_witness.t] ;; let stable_witness_variable var = "__'" ^ var ^ "_stable_witness" module Value_binding = struct let compare a b = Comparable.lift Poly.compare ~f:strip_locs#value_binding a b end module Signature = struct let expand_type_declaration td = let td = name_type_params_in_td td in let loc = ghost td.ptype_loc in value_description ~loc ~name:(Loc.map ~f:stable_witness_name td.ptype_name) ~type_:(combinator_type_of_type_declaration td ~f:stable_witness_type) ~prim:[] |> psig_value ~loc ;; let expand ~loc:_ ~path:_ (_, tds) : signature = List.map tds ~f:expand_type_declaration end module Structure = struct (* We generate [let] clauses to check types of stable witnesses that the current one depends on. *) let check ~loc witness_expr witness_type = value_binding ~loc ~pat:[%pat? (_ : [%t witness_type])] ~expr:witness_expr ;; let unsupported ~loc description = (* Rather than raise at expansion time, we generate a [%error] node that can complain during compile time. This is more merlin-friendly, among other benefits. *) let message = Printf.sprintf "ppx_stable_witness: %s not supported" description in check ~loc [%expr [%ocaml.error [%e estring ~loc message]]] [%type: _] ;; let check_type_constructor ~loc id params = let witness_expr = unapplied_type_constr_conv ~loc id ~f:stable_witness_name in let witness_type = List.fold_right params ~init:(stable_witness_type ~loc (ptyp_constr ~loc id params)) ~f:(fun param core_type -> let loc = ghost param.ptyp_loc in ptyp_arrow ~loc Nolabel (stable_witness_type ~loc param) core_type) in check ~loc witness_expr witness_type ;; let check_type_variable ~loc var = let witness_expr = evar ~loc (stable_witness_variable var) in let witness_type = stable_witness_type ~loc (ptyp_var ~loc var) in check ~loc witness_expr witness_type ;; let rec check_core_type core_type = let loc = ghost core_type.ptyp_loc in match Attribute.get custom_attr core_type with | Some expr -> [ check ~loc expr (stable_witness_type ~loc core_type) ] | None -> (match core_type.ptyp_desc with | Ptyp_any -> [ unsupported ~loc "wildcard type" ] | Ptyp_var var -> [ check_type_variable ~loc var ] | Ptyp_arrow _ -> [ unsupported ~loc "arrow type" ] | Ptyp_tuple tuple -> List.concat_map tuple ~f:check_core_type | Ptyp_constr (id, params) -> check_type_constructor ~loc id params :: List.concat_map params ~f:check_core_type | Ptyp_object _ -> [ unsupported ~loc "object type" ] | Ptyp_class _ -> [ unsupported ~loc "class type" ] | Ptyp_alias (core_type, _) -> check_core_type core_type | Ptyp_variant (rows, _, _) -> List.concat_map rows ~f:check_row_field | Ptyp_poly (_, _) -> [ unsupported ~loc "polymorphic type" ] | Ptyp_package _ -> [ unsupported ~loc "first-class module type" ] | Ptyp_extension _ -> [ unsupported ~loc "ppx extension" ]) and check_row_field row = match row.prf_desc with | Rtag (_, _, core_types) -> List.concat_map ~f:check_core_type core_types | Rinherit core_type -> check_core_type core_type ;; let check_label_declaration ld = check_core_type ld.pld_type let check_constructor_declaration cd = match cd.pcd_res with | Some _ -> [ unsupported ~loc:cd.pcd_loc "GADT" ] | None -> (match cd.pcd_args with | Pcstr_tuple tuple -> List.concat_map ~f:check_core_type tuple | Pcstr_record record -> List.concat_map ~f:check_label_declaration record) ;; let param_patterns td = List.map td.ptype_params ~f:(fun param -> let core_type = fst param in let loc = ghost core_type.ptyp_loc in ppat_constraint ~loc (pvar ~loc (stable_witness_variable (get_type_param_name param).txt)) (stable_witness_type ~loc core_type)) ;; (* Generate all the witness type checks for a type declaration. *) let check_type_declaration td = let loc = ghost td.ptype_loc in let pat = pvar ~loc ("__stable_witness_checks_for_" ^ td.ptype_name.txt ^ "__") in let checks = match td.ptype_kind with | Ptype_open -> [ unsupported ~loc "open type" ] | Ptype_record fields -> List.concat_map fields ~f:check_label_declaration | Ptype_variant clauses -> List.concat_map clauses ~f:check_constructor_declaration | Ptype_abstract -> (match td.ptype_manifest with | None -> [] | Some core_type -> check_core_type core_type) in let checks = (* Don't bother generating obviously redundant checks. *) List.stable_dedup ~compare:Value_binding.compare checks in match List.is_empty checks with | true -> [] | false -> (* If there are any witnesses to check, we generate a function parameterized by any arguments to the current witness and a unit argument. Since this is always a lambda, it is safe inside [let rec]. *) let expr = eunit ~loc |> pexp_let ~loc Nonrecursive checks |> eabstract ~loc (param_patterns td @ [ punit ~loc ]) in [ value_binding ~loc ~pat ~expr ] ;; (* Create a stable witness for a type we trust to be stable. Evalutes to a variable reference so that it is safe inside [let rec]. *) let assert_witness_for core_type = let loc = ghost core_type.ptyp_loc in pexp_constraint ~loc [%expr Ppx_stable_witness_runtime.Stable_witness.assert_stable] (stable_witness_type ~loc core_type) ;; (* Generate the actual stable witness definition for a type declaration. *) let expand_type_declaration td = let loc = ghost td.ptype_loc in let expr = List.map td.ptype_params ~f:fst |> ptyp_constr ~loc (Located.map_lident td.ptype_name) |> assert_witness_for |> eabstract ~loc (param_patterns td) in let pat = pvar ~loc:td.ptype_name.loc (stable_witness_name td.ptype_name.txt) in value_binding ~loc ~pat ~expr ;; let shadows_self_without_redefining td = match td.ptype_manifest with | Some { ptyp_desc = Ptyp_constr ({ txt = Lident name; _ }, params); _ } when String.equal name td.ptype_name.txt -> (match List.for_all2 params td.ptype_params ~f:(fun actual (formal, _) -> match actual.ptyp_desc, formal.ptyp_desc with | Ptyp_var a, Ptyp_var b -> String.equal a b | _ -> false) with | Ok bool -> bool | Unequal_lengths -> false) | _ -> false ;; class refers_to_redefined_type tds = object (* We pass [Recursive] here, even though this is only actually called on non-recursive definitions. What we really want to check for is whether a type refers to its own name, not whether it's recursive. This is equivalent to [type_is_recursive Recursive], so we use that even though it reads wrong. *) inherit type_is_recursive Recursive tds val! type_names = List.filter_map tds ~f:(fun td -> match shadows_self_without_redefining td with | true -> (* No need to check for references to types that redefine a name to precisely what it was before. *) None | false -> (* Anything else, we need to look for. *) Some td.ptype_name.txt) end let refers_to_redefined_type tds = let obj = new refers_to_redefined_type tds in match obj#go () with | Nonrecursive -> false | Recursive -> true ;; (* Define both the stable witness, and all the checks, for a type declaration. Define them both in the same [let] with a shared [rec_flag] so that the checks have the same scope as the stable witness itself. *) let expand ~loc ~path:_ (rec_flag, tds) = let tds = List.map tds ~f:name_type_params_in_td in match rec_flag with | Nonrecursive when refers_to_redefined_type tds -> let message = Printf.sprintf "ppx_stable_witness: This definition shadows a type that it also refers to. \ Expanded code needs to refer to the shadowed name.\n\n\ Perhaps you can define an alias for the shadowed type, then use the alias in \ this definition." in [%str [%%ocaml.error [%e estring ~loc message]]] | _ -> let rec_flag = really_recursive rec_flag tds in List.concat [ List.map tds ~f:expand_type_declaration ; List.concat_map tds ~f:check_type_declaration ] |> pstr_value_list ~loc rec_flag ;; (* Expand a single type to an expression containing its checks and a stable witness. *) let extension ~loc ~path:_ core_type = let checks = check_core_type core_type in let body = assert_witness_for core_type in match List.is_empty checks with | true -> body | false -> pexp_let ~loc Nonrecursive checks body ;; end let extension = Structure.extension let sig_type_decl = Deriving.Generator.make_noarg Signature.expand let str_type_decl = Deriving.Generator.make_noarg Structure.expand let () = Deriving.add "stable_witness" ~sig_type_decl ~str_type_decl ~extension |> Deriving.ignore ;; ppx_stable_witness-0.17.0/src/src/ppx_stable_witness.mli000066400000000000000000000000551461647336100235250ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_stable_witness-0.17.0/stable_witness/000077500000000000000000000000001461647336100205555ustar00rootroot00000000000000ppx_stable_witness-0.17.0/stable_witness/src/000077500000000000000000000000001461647336100213445ustar00rootroot00000000000000ppx_stable_witness-0.17.0/stable_witness/src/dune000066400000000000000000000001761461647336100222260ustar00rootroot00000000000000(library (name stable_witness) (public_name ppx_stable_witness.stable_witness) (libraries) (preprocess no_preprocessing)) ppx_stable_witness-0.17.0/stable_witness/src/stable_witness.ml000066400000000000000000000017601461647336100247300ustar00rootroot00000000000000include Stable_witness_intf (* The runtime representation of stable witnesses does not matter. *) type _ t = unit module Export = struct let stable_witness_array () = () let stable_witness_bool = () let stable_witness_bytes = () let stable_witness_char = () let stable_witness_exn = () let stable_witness_float = () let stable_witness_int = () let stable_witness_int32 = () let stable_witness_int64 = () let stable_witness_lazy_t () = () let stable_witness_list () = () let stable_witness_nativeint = () let stable_witness_option () = () let stable_witness_ref () = () let stable_witness_string = () let stable_witness_unit = () end let of_serializable () _ _ = () module Of_serializable1 (_ : T1) (_ : T1) = struct let of_serializable _ _ _ () = () end module Of_serializable2 (_ : T2) (_ : T2) = struct let of_serializable _ _ _ () () = () end module Of_serializable3 (_ : T3) (_ : T3) = struct let of_serializable _ _ _ _ () () = () end let assert_stable = () ppx_stable_witness-0.17.0/stable_witness/src/stable_witness.mli000066400000000000000000000000531461647336100250730ustar00rootroot00000000000000include Stable_witness_intf.Stable_witness ppx_stable_witness-0.17.0/stable_witness/src/stable_witness_intf.ml000066400000000000000000000076431461647336100257560ustar00rootroot00000000000000module type T1 = sig type _ t end module type T2 = sig type (_, _) t end module type T3 = sig type (_, _, _) t end module type Stable_witness = sig type 'a t module Export : sig (** Stable witnesses for primitive types exported by [Core.Core_stable]. Code using [ppx_stable_witness] is expected to start with [open Stable_witness.Export]. *) val stable_witness_array : 'a t -> 'a array t val stable_witness_bool : bool t val stable_witness_bytes : bytes t val stable_witness_char : char t val stable_witness_exn : exn t val stable_witness_float : float t val stable_witness_int : int t val stable_witness_int32 : int32 t val stable_witness_int64 : int64 t val stable_witness_lazy_t : 'a t -> 'a lazy_t t val stable_witness_list : 'a t -> 'a list t val stable_witness_nativeint : nativeint t val stable_witness_option : 'a t -> 'a option t val stable_witness_ref : 'a t -> 'a ref t val stable_witness_string : string t val stable_witness_unit : unit t end (** This is useful to provide a stable witness on a type that uses another type for serialization. *) val of_serializable : 'a t -> ('a -> 'b) -> ('b -> 'a) -> 'b t module type T1 = T1 module Of_serializable1 (Stable_format : T1) (M : T1) : sig (** This is the analogue of [of_serializable] for types with 1 type parameter, e.g. ['a M.t]. An example usage would look something like this: {[ let stable_witness (type a) : a Stable_witness.t -> a M.t Stable_witness.t = fun witness -> let module Stable_witness = Stable_witness.Of_serializable1 (Stable_format) (M) in Stable_witness.of_serializable Stable_format.stable_witness M.of_stable_format M.to_stable_format witness ;; ]} *) val of_serializable : ('a t -> 'a Stable_format.t t) (** witness for stable format *) -> ('a Stable_format.t -> 'a M.t) (** conversion from stable format *) -> ('a M.t -> 'a Stable_format.t) (** conversion to stable format *) -> 'a t -> 'a M.t t end module type T2 = T2 module Of_serializable2 (Stable_format : T2) (M : T2) : sig (** This is the analogue of [of_serializable] for types with 2 type parameters. *) val of_serializable : ('a1 t -> 'a2 t -> ('a1, 'a2) Stable_format.t t) (** witness for stable format *) -> (('a1, 'a2) Stable_format.t -> ('a1, 'a2) M.t) (** from stable format *) -> (('a1, 'a2) M.t -> ('a1, 'a2) Stable_format.t) (** to stable format *) -> 'a1 t -> 'a2 t -> ('a1, 'a2) M.t t end module Of_serializable3 (Stable_format : T3) (M : T3) : sig (** This is the analogue of [of_serializable] for types with 3 type parameters. *) val of_serializable : ('a1 t -> 'a2 t -> 'a3 t -> ('a1, 'a2, 'a3) Stable_format.t t) (** witness for stable format *) -> (('a1, 'a2, 'a3) Stable_format.t -> ('a1, 'a2, 'a3) M.t) (** from stable format *) -> (('a1, 'a2, 'a3) M.t -> ('a1, 'a2, 'a3) Stable_format.t) (** to stable format *) -> 'a1 t -> 'a2 t -> 'a3 t -> ('a1, 'a2, 'a3) M.t t end (** This is an escape hatch. Don't use it unless you have to. There are two use cases for this: 1. It allows you to assert that a type that you're writing has stable serialization functions, even if the type itself depends on unstable types. 2. It allows you to assert that a type from some other module is stable (and generate a stable witness for it) even if the type doesn't provide one for itself. It is almost always better to get the upstream code to provide a stability guarantee. At the very least, consult with the upstream maintainer to make sure their serializations are stable over time, and document the discussion. *) val assert_stable : _ t end