diff --git a/src/dune-project b/src/dune-project index e385e317699..7ecace1391f 100644 --- a/src/dune-project +++ b/src/dune-project @@ -153,6 +153,7 @@ (package (name ppx_to_enum)) (package (name ppx_util)) (package (name ppx_version)) +(package (name ppx_version.runtime)) (package (name precomputed_values)) (package (name promise)) (package (name proof_carrying_data)) diff --git a/src/lib/ppx_version/README.md b/src/lib/ppx_version/README.md new file mode 100644 index 00000000000..3d3972c039c --- /dev/null +++ b/src/lib/ppx_version/README.md @@ -0,0 +1,178 @@ +ppx_version +=========== + +The `ppx_version` preprocessor comprises a type deriver, an annotation +for modules, and a syntax linter. + +Type deriver +------------ + +This deriver is meant to be added automatically when using the +%%versioned annotation for `Stable` modules (see below). That code is in +versioned_module.ml + +*** You should not need to add this deriver to the `deriving` list explicitly *** + +The deriver accomplishes these goals: + + 1) check that a versioned type is always in valid module hierarchy + 2) versioned types depend only on other versioned types or OCaml built-in types + +The usage in type declarations is: + + [@@deriving version] + + or + + [@@deriving version { option }] + +where the option is one of "rpc" or "binable" (mutally +exclusively). For types within signatures, no options are used. + +Within structures, the deriver generates two definitions: + + let version = n + let __versioned__ = () + +where `n` is taken from the surrounding module Vn. + +Within signatures, the deriver generates the definition: + + val __versioned__ : unit + +The purpose of `__versioned__` is to make sure that types referred to +in versioned type definitions are themselves versioned. + +Without options (the common case), the type must be named "t", and its +definition occurs in the module hierarchy "Stable.Vn" or +"Stable.Vn.T", where n is a positive integer. + +The "binable" option asserts that the type is versioned, to allow +compilation to proceed. The types referred to in the type are not +checked for versioning with this option. It assumes that the type will +be serialized using a "Binable.Of_..." or "Make_binable" functors, +which relies on the serialization of some other type. + +If "rpc" is true, again, the type must be named "query", "response", +or "msg", and the type definition occurs in the hierarchy "Vn.T". + +Versioned modules +----------------- + +Modules in structures with versioned types are annotated: + + [%%versioned + module Stable = struct + module Vn = struct + type t = ... + let to_latest = ... + end + ... + end] + +Within a `Stable` module, there can be arbitrarily many versioned type +modules, which must be listed in descending numeric order (most recent +version first). A versioned module must define `to_latest`, which +takes instances of the type `t` to instances of the most recent type +version. + +Modules in signatures are annotated similarly (note the colon): + + [%%versioned: + module Stable : sig + module Vn : sig + type t = ... + end + ... + end] + +The annotation generates a deriver list for the type that includes +`bin_io` and `version`, which are added to any other deriver items +already listed. + +Just past the most recent Vn, a definition is generated: + + module Latest = Vn + +A type definition is generated just past the `Stable` module: + + type t = Stable.Latest.t + +Sometimes that causes compilation issues, which can be avoided by +adding the annotation `[@@@no_toplevel_latest_type]` at the start of +the `Stable` module, in either structures or signatures. + +For compatibility with older code, there is the annotation: + + [@@@with_all_version_tags] + +Given at the start of a `Vn` module, generates a module +Vn.With_all_version_tags`, where the `Bin_prot` functions add the +version number as an integer at the start of the serialization of this +type, and similarly for all versioned types referred to by this type +(which means those referred-to types must also have that +annotation). That mimics the way all types were serialized in the +original Mina mainnet. The representation of some values, like public +keys, rely on the `Bin_prot` serialization, so this annotation is +required in order to maintain that representation. + +A related annotation is: + + [@@@with_top_version_tag] + +Given at the start of a `Stable` module, generates for each contained +module `Vn`, another module `Vn.With_top_version_tag`, where the +`Bin_prot` serialization adds the version number at the start of the +type serialization, but does not change the serialization of +referred-to types. That's useful to know which version the remainder +of the serialization is for. For example, a transaction id is the +Base64 encoding of the `Bin_prot` serialization of a command. +Therefore, the transaction id contains the information about the +transaction type version used to create it. + +or JSON serialization: + + [@@@with_versioned_json] + +When given at the start of a `Stable` module, for each module `Vn`, if +the `yojson` deriver is used in `Vn.t`, then `Vn.to_yojson` generates: + + `Assoc [("version",`Int n); ("data",)] + +For example, use this version-tagged JSON for precomputed and +extensional blocks to know which version of the code produced them. + +Using %%versioned on a `Stable` module generates code that registers a +shape, that is, an instance of `Bin_prot.Shape.t`, for each versioned +type defined in that module. That supports the CLI command +`mina internal dump-type-shapes`, which prints shapes for all versioned +types. + +Syntax linter +------------- + +The linter finds invalid syntax related to type versioning. + +The lint rules: + +- "deriving bin_io" and "deriving version" never appear in types + defined inside functor bodies, except for the `Make_str` functors + used for wire types. + +- otherwise, "bin_io" may appear in a "deriving" attribute only if + "version" also appears in that extension + +- versioned types only appear in versioned type definitions + +- versioned type definitions appear only in %%versioned... extensions + +- packaged modules, like "(module Foo)", may not be stable-versioned + (but allowed inside %%versioned for legitimate uses) + +- the constructs "include Stable.Latest" and "include Stable.Vn" are prohibited + + - uses of Binable.Of... and Bin_prot.Utils.Make_binable functors are + always in stable-versioned modules, and always as an argument to + "include" + +- these restrictions are not enforced in inline tests and inline test modules diff --git a/src/lib/ppx_version/lint_version_syntax.ml b/src/lib/ppx_version/lint_version_syntax.ml index f5c3c789ad9..7800e26e837 100644 --- a/src/lib/ppx_version/lint_version_syntax.ml +++ b/src/lib/ppx_version/lint_version_syntax.ml @@ -1,16 +1,4 @@ -(* lint_version_syntax.ml -- static enforcement of syntactic items relating to proper versioning - - - "deriving bin_io" and "deriving version" never appear in types defined inside functor bodies - - otherwise, "bin_io" may appear in a "deriving" attribute only if "version" also appears in that extension - - versioned types only appear in versioned type definitions - - versioned type definitions appear only in %%versioned... extensions - - packaged modules, like "(module Foo)", may not be stable-versioned (but allowed inside %%versioned for - legitimate uses) - - the constructs "include Stable.Latest" and "include Stable.Vn" are prohibited - - uses of Binable.Of... and Bin_prot.Utils.Make_binable functors are always in stable-versioned modules, - and always as an argument to "include" - - restrictions are not enforced in inline tests and inline test modules -*) +(* lint_version_syntax.ml -- static enforcement of syntactic items relating to proper versioning *) open Core_kernel open Ppxlib diff --git a/src/lib/ppx_version/test/Makefile b/src/lib/ppx_version/test/Makefile index 34022911e85..43d2df4c4ee 100644 --- a/src/lib/ppx_version/test/Makefile +++ b/src/lib/ppx_version/test/Makefile @@ -11,14 +11,13 @@ endif .PHONY: positive-tests negative-tests -# all : positive-tests negative-tests -all : negative-tests +all : positive-tests negative-tests positive-tests : # version syntax @ echo -n "Version syntax, should succeed..." - dune build good_version_syntax.cma ${REDIRECT} - echo "OK" + @ dune build good_version_syntax.cma ${REDIRECT} + @ echo "OK" # versioning @ echo -n "Versioned types, should succeed..." @ dune build versioned_good.cma ${REDIRECT} diff --git a/src/lib/ppx_version/test/README.md b/src/lib/ppx_version/test/README.md new file mode 100644 index 00000000000..09da230b3b1 --- /dev/null +++ b/src/lib/ppx_version/test/README.md @@ -0,0 +1,33 @@ +ppx_version tests +================= + +These are tests for the basic features of ppx_version. + +There are "positive" tests, where the syntax should be accepted, and +"negative" tests, where the syntax should be rejected. + +Disabling vendoring +------------------- + +*** IMPORTANT *** + +Before running these tests, *temporarily* comment out the +`vendored_dirs` clause in the dune file in the directory above this +one: + + ; (vendored_dirs test) + +That clause prevents the ppx_version linter warnings from +taking effect in the negative tests, so that those tests fail. + +Running the tests +----------------- + +Run `make` to run all tests. There are also separate targets +"positive-tests" and "negative-tests". + +The negative tests succeed if the dune build fails, but the failures +may occur for reasons other than the expected reasons. Ordinarily, +the test output is suppressed. By setting the VERBOSE environment +variable, the output is shown, in order to make sure the failures +are as expected. diff --git a/src/lib/ppx_version/test/dune b/src/lib/ppx_version/test/dune index 7475aa2bd9c..50762eacc8d 100644 --- a/src/lib/ppx_version/test/dune +++ b/src/lib/ppx_version/test/dune @@ -1,5 +1,6 @@ -;;; each library below has an identical preprocess clause, because of this -;;; dune bug: https://github.com/ocaml/dune/issues/1946 +(env + (_ + (flags (:standard -warn-error @22)))) ;;; should succeed @@ -7,27 +8,27 @@ (library (name good_version_syntax) (preprocess (pps ppx_jane ppx_version ppx_deriving_yojson)) - (libraries base.caml core_kernel bin_prot.shape) + (libraries base.caml core_kernel bin_prot.shape ppx_version.runtime) (modules good_version_syntax)) ;; versioning (library (name versioned_good) (preprocess (pps ppx_jane ppx_deriving_yojson ppx_version)) - (libraries base.caml core_kernel bin_prot.shape sexplib0) + (libraries base.caml core_kernel bin_prot.shape sexplib0 ppx_version.runtime) (modules versioned_good)) ;; module versioning (executable (name versioned_module_good) (preprocess (pps ppx_jane ppx_deriving_yojson ppx_version)) - (libraries base.caml core_kernel bin_prot.shape sexplib0) + (libraries base.caml core_kernel bin_prot.shape sexplib0 ppx_version.runtime) (modules versioned_module_good)) (executable (name versioned_sig_good) (preprocess (pps ppx_jane ppx_deriving_yojson ppx_version)) - (libraries base.caml core_kernel bin_prot.shape sexplib0) + (libraries base.caml core_kernel bin_prot.shape sexplib0 ppx_version.runtime) (modules versioned_sig_good)) ;;; should fail @@ -37,25 +38,25 @@ (library (name bad_version_syntax_missing_versioned) (preprocess (pps ppx_jane ppx_deriving_yojson ppx_version)) - (libraries base.caml core_kernel bin_prot.shape sexplib0) + (libraries base.caml core_kernel bin_prot.shape sexplib0 ppx_version.runtime) (modules bad_version_syntax_missing_versioned)) (library (name bad_versioned_in_functor) (preprocess (pps ppx_jane ppx_deriving_yojson ppx_version)) - (libraries base.caml core_kernel bin_prot.shape sexplib0) + (libraries base.caml core_kernel bin_prot.shape sexplib0 ppx_version.runtime) (modules bad_versioned_in_functor)) (library (name bad_versioned_in_nested_functor) (preprocess (pps ppx_jane ppx_deriving_yojson ppx_version)) - (libraries base.caml core_kernel bin_prot.shape sexplib0) + (libraries base.caml core_kernel bin_prot.shape sexplib0 ppx_version.runtime) (modules bad_versioned_in_nested_functor)) (library (name bad_version_syntax_multiple_errors) (preprocess (pps ppx_jane ppx_deriving_yojson ppx_version)) - (libraries base.caml core_kernel bin_prot.shape sexplib0) + (libraries base.caml core_kernel bin_prot.shape sexplib0 ppx_version.runtime) (modules bad_version_syntax_multiple_errors)) ;; versioning @@ -63,66 +64,66 @@ (library (name versioned_bad_module_name) (preprocess (pps ppx_jane ppx_deriving_yojson ppx_version)) - (libraries base.caml core_kernel bin_prot.shape sexplib0) + (libraries base.caml core_kernel bin_prot.shape sexplib0 ppx_version.runtime) (modules versioned_bad_module_name)) (library (name versioned_bad_version_name) (preprocess (pps ppx_jane ppx_deriving_yojson ppx_version)) - (libraries base.caml core_kernel bin_prot.shape sexplib0) + (libraries base.caml core_kernel bin_prot.shape sexplib0 ppx_version.runtime) (modules versioned_bad_version_name)) (library (name versioned_bad_type_name) (preprocess (pps ppx_jane ppx_deriving_yojson ppx_version)) - (libraries base.caml core_kernel bin_prot.shape sexplib0) + (libraries base.caml core_kernel bin_prot.shape sexplib0 ppx_version.runtime) (modules versioned_bad_type_name)) (library (name versioned_bad_option) (preprocess (pps ppx_jane ppx_deriving_yojson ppx_version)) - (libraries base.caml core_kernel bin_prot.shape sexplib0) + (libraries base.caml core_kernel bin_prot.shape sexplib0 ppx_version.runtime) (modules versioned_bad_option)) (library (name versioned_bad_contained_types) (preprocess (pps ppx_jane ppx_deriving_yojson ppx_version)) - (libraries base.caml core_kernel bin_prot.shape sexplib0) + (libraries base.caml core_kernel bin_prot.shape sexplib0 ppx_version.runtime) (modules versioned_bad_contained_types)) (library (name versioned_bad_arrow_type) (preprocess (pps ppx_jane ppx_deriving_yojson ppx_version)) - (libraries base.caml core_kernel bin_prot.shape sexplib0) + (libraries base.caml core_kernel bin_prot.shape sexplib0 ppx_version.runtime) (modules versioned_bad_arrow_type)) ;; module versioning (library (name versioned_module_bad_stable_name) (preprocess (pps ppx_jane ppx_deriving_yojson ppx_version)) - (libraries base.caml core_kernel bin_prot.shape sexplib0) + (libraries base.caml core_kernel bin_prot.shape sexplib0 ppx_version.runtime) (modules versioned_module_bad_stable_name)) (library (name versioned_module_bad_version_name) (preprocess (pps ppx_jane ppx_deriving_yojson ppx_version)) - (libraries base.caml core_kernel bin_prot.shape sexplib0) + (libraries base.caml core_kernel bin_prot.shape sexplib0 ppx_version.runtime) (modules versioned_module_bad_version_name)) (library (name versioned_module_bad_missing_type) (preprocess (pps ppx_jane ppx_deriving_yojson ppx_version)) - (libraries base.caml core_kernel bin_prot.shape sexplib0) + (libraries base.caml core_kernel bin_prot.shape sexplib0 ppx_version.runtime) (modules versioned_module_bad_missing_type)) (library (name versioned_module_bad_version_order) (preprocess (pps ppx_jane ppx_deriving_yojson ppx_version)) - (libraries base.caml core_kernel bin_prot.shape sexplib0) + (libraries base.caml core_kernel bin_prot.shape sexplib0 ppx_version.runtime) (modules versioned_module_bad_version_order)) (library (name versioned_module_bad_missing_to_latest) (preprocess (pps ppx_jane ppx_deriving_yojson ppx_version)) - (libraries base.caml core_kernel bin_prot.shape sexplib0) + (libraries base.caml core_kernel bin_prot.shape sexplib0 ppx_version.runtime) (modules versioned_module_bad_missing_to_latest)) diff --git a/src/lib/ppx_version/versioned_module.ml b/src/lib/ppx_version/versioned_module.ml index 62a7763f45f..e63e0fecd19 100644 --- a/src/lib/ppx_version/versioned_module.ml +++ b/src/lib/ppx_version/versioned_module.ml @@ -1,3 +1,5 @@ +(* versioned_module.ml -- modules with versioned types *) + open Core_kernel open Ppxlib open Versioned_util diff --git a/src/lib/ppx_version/versioned_type.ml b/src/lib/ppx_version/versioned_type.ml index b817967fd51..3808c43d30c 100644 --- a/src/lib/ppx_version/versioned_type.ml +++ b/src/lib/ppx_version/versioned_type.ml @@ -1,51 +1,4 @@ -(* versioned_types.ml -- static enforcement of versioned types via ppx *) - -(* If the dune profile defines "print_versioned_types" to be true, this deriver - prints a representation of each versioned type to stdout. The driver "print_versioned_types" - can be used to print the types from a particular OCaml source file. This facility is - meant to be used in CI to detect changes to versioned types. - - Otherwise, we use this deriver as follows: - - 1) check that versioned type always in valid module hierarchy - 2) versioned types depend only on other versioned types or OCaml built-in types - - to use, add coda_ppx to the dune pps list, and annotate a type declaration with - either - - [@@deriving version] - - or - - [@@deriving version { option }] - - where option is one of "rpc" or "binable". - - Without options (the common case), the type must be named "t", and its definition - occurs in the module hierarchy "Stable.Vn" or "Stable.Vn.T", where n is a positive integer. - - The "binable" option asserts that the type is versioned, to allow compilation - to proceed. The types referred to in the type are not checked for versioning - with this option. It assumes that the type will be serialized using a - "Binable.Of_..." or "Make_binable" functors, which relies on the serialization of - some other type. - - If "rpc" is true, again, the type must be named "query", "response", or "msg", - and the type definition occurs in the hierarchy "Vn.T". - - All these options are available for types within structures. - - Within signatures, the declaration - - val __versioned__ : unit - - is generated. If the "numbered" option is given, then - - val version : int - - is also generated. This option should be needed only by the internal versioning - machinery, and not in ordinary code. No other options are available within signatures. -*) +(* versioned_types.ml -- deriver for versioned types *) open Core_kernel open Ppxlib @@ -53,535 +6,399 @@ open Versioned_util let deriver = "version" -let printing_ref = ref false - -let set_printing () = printing_ref := true - -let unset_printing () = printing_ref := false - (* path is filename.ml.M1.M2.... *) let module_path_list path = List.drop (String.split path ~on:'.') 2 -(* print versioned types *) -module Printing = struct - let contains_deriving_bin_io (attrs : attributes) = - let derivers = - Ast_pattern.( - attribute ~name:(string "deriving") ~payload:(single_expr_payload __)) - in - match - List.find_map attrs ~f:(fun attr -> - parse_opt derivers Location.none attr (fun l -> Some l) ) - with - | Some derivers -> - let derivers = - match derivers.pexp_desc with - | Pexp_tuple derivers -> - derivers - | _ -> - [ derivers ] - in - let bin_io_pattern = - Ast_pattern.(pexp_ident (lident (string "bin_io"))) - in - List.exists derivers ~f:(fun deriver -> - Option.is_some - @@ parse_opt bin_io_pattern Location.none deriver (Some ()) ) - | None -> - false - - (* singleton attribute *) - let just_bin_io = - let module E = Ppxlib.Ast_builder.Make (struct - let loc = Location.none - end) in - let open E in - { attr_name = { txt = "deriving"; loc } - ; attr_payload = PStr [%str bin_io] - ; attr_loc = Location.none - } - - (* remove internal attributes, on core type in manifest and in records or variants in kind *) - let type_decl_remove_internal_attributes type_decl = - let removed_in_kind = - match type_decl.ptype_kind with - | Ptype_variant ctors -> - Ptype_variant - (List.map ctors ~f:(fun ctor -> { ctor with pcd_attributes = [] })) - | Ptype_record labels -> - Ptype_record - (List.map labels ~f:(fun label -> - { label with pld_attributes = [] } ) ) - | kind -> - kind - in - let removed_in_manifest = - Option.map type_decl.ptype_manifest ~f:(fun core_type -> - { core_type with ptyp_attributes = [] } ) - in - { type_decl with - ptype_manifest = removed_in_manifest - ; ptype_kind = removed_in_kind - } - - (* filter attributes from types, except for bin_io, don't care about changes to others *) - let filter_type_decls_attrs type_decl = - (* retain only `deriving bin_io` in deriving list *) - let ptype_attributes = - if contains_deriving_bin_io type_decl.ptype_attributes then - [ just_bin_io ] - else [] - in - let type_decl_no_attrs = type_decl_remove_internal_attributes type_decl in - { type_decl_no_attrs with ptype_attributes } - - (* remove manifests from non-abstract types, so these print the same: - type t = Quux.t = Foo | Bar - type t = Foo | Bar - *) - let filter_type_manifests type_decl = - match type_decl.ptype_kind with - | Ptype_abstract | Ptype_open -> - type_decl - | Ptype_variant _ | Ptype_record _ -> - { type_decl with ptype_manifest = None } - - (* convert type_decls to structure item so we can print it *) - let type_decls_to_stri type_decls = - (* type derivers only work with recursive types *) - { pstr_desc = Pstr_type (Ast.Recursive, type_decls) - ; pstr_loc = Location.none - } - - (* prints path_to_type:type_definition *) - let print_type ~loc:_ ~path (_rec_flag, type_decls) _rpc _binable = - let module_path = module_path_list path in - let path_len = List.length module_path in - List.iteri module_path ~f:(fun i s -> - printf "%s" s ; - if i < path_len - 1 then printf "." ) ; - printf ".%s" (List.hd_exn type_decls).ptype_name.txt ; - printf ":%!" ; - let type_decls_filtered_attrs = - List.map type_decls ~f:filter_type_decls_attrs - in - let type_decls_filtered_manifests = - List.map type_decls_filtered_attrs ~f:filter_type_manifests - in - let stri = type_decls_to_stri type_decls_filtered_manifests in - let formatter = Versioned_util.diff_formatter Format.std_formatter in - Pprintast.structure_item formatter stri ; - Format.pp_print_flush formatter () ; - printf "\n%!" ; - [] +type generation_kind = Plain | Rpc - (* we're worried about changes to the serialization of types, which can occur via changes to implementations, - so nothing to do for signatures - *) - let gen_empty_sig ~loc:_ ~path:_ (_rec_flag, _type_decls) = [] -end - -(* real derivers *) -module Deriving = struct - type generation_kind = Plain | Rpc - - let validate_rpc_type_decl inner3_modules type_decl = - match List.take inner3_modules 2 with - | [ "T"; module_version ] -> - validate_module_version module_version type_decl.ptype_loc - | _ -> - Location.raise_errorf ~loc:type_decl.ptype_loc - "Versioned RPC type must be contained in module path Vn.T, for some \ - number n" - - let validate_plain_type_decl inner3_modules type_decl = - match inner3_modules with - | [ "T"; module_version; "Stable" ] | module_version :: "Stable" :: _ -> - validate_module_version module_version type_decl.ptype_loc - | _ -> - Location.raise_errorf ~loc:type_decl.ptype_loc - "Versioned type must be contained in module path Stable.Vn or \ - Stable.Vn.T, for some number n" +let validate_rpc_type_decl inner3_modules type_decl = + match List.take inner3_modules 2 with + | [ "T"; module_version ] -> + validate_module_version module_version type_decl.ptype_loc + | _ -> + Location.raise_errorf ~loc:type_decl.ptype_loc + "Versioned RPC type must be contained in module path Vn.T, for some \ + number n" + +let validate_plain_type_decl inner3_modules type_decl = + match inner3_modules with + | [ "T"; module_version; "Stable" ] | module_version :: "Stable" :: _ -> + validate_module_version module_version type_decl.ptype_loc + | _ -> + Location.raise_errorf ~loc:type_decl.ptype_loc + "Versioned type must be contained in module path Stable.Vn or \ + Stable.Vn.T, for some number n" - (* check that a versioned type occurs in valid module hierarchy and is named "t" - (for RPC types, the name can be "query", "response", or "msg") - *) - let validate_type_decl inner3_modules generation_kind type_decl = - let name = type_decl.ptype_name.txt in - let loc = type_decl.ptype_name.loc in +(* check that a versioned type occurs in valid module hierarchy and is named "t" + (for RPC types, the name can be "query", "response", or "msg") +*) +let validate_type_decl inner3_modules generation_kind type_decl = + let name = type_decl.ptype_name.txt in + let loc = type_decl.ptype_name.loc in + match generation_kind with + | Rpc -> + let rpc_valid_names = [ "query"; "response"; "msg" ] in + if + List.find rpc_valid_names ~f:(fun ty -> String.equal ty name) + |> Option.is_none + then + Location.raise_errorf ~loc + "RPC versioned type must be named one of \"%s\", got: \"%s\"" + (String.concat ~sep:"," rpc_valid_names) + name ; + validate_rpc_type_decl inner3_modules type_decl + | Plain -> + let valid_name = "t" in + if not (String.equal name valid_name) then + Location.raise_errorf ~loc + "Versioned type must be named \"%s\", got: \"%s\"" valid_name name ; + validate_plain_type_decl inner3_modules type_decl + +(* module structure in this case validated by linter *) + +let module_name_from_plain_path inner3_modules = + match inner3_modules with + | [ "T"; module_version; "Stable" ] | module_version :: "Stable" :: _ -> + module_version + | _ -> + failwith "module_name_from_plain_path: unexpected module path" + +let module_name_from_rpc_path inner3_modules = + match List.take inner3_modules 2 with + | [ "T"; module_version ] -> + module_version + | _ -> + failwith "module_name_from_rpc_path: unexpected module path" + +(* generate "let version = n", when version module is Vn *) +let generate_version_number_decl inner3_modules loc generation_kind = + (* invariant: we've checked module name already *) + let module E = Ppxlib.Ast_builder.Make (struct + let loc = loc + end) in + let open E in + let module_name = match generation_kind with - | Rpc -> - let rpc_valid_names = [ "query"; "response"; "msg" ] in - if - List.find rpc_valid_names ~f:(fun ty -> String.equal ty name) - |> Option.is_none - then - Location.raise_errorf ~loc - "RPC versioned type must be named one of \"%s\", got: \"%s\"" - (String.concat ~sep:"," rpc_valid_names) - name ; - validate_rpc_type_decl inner3_modules type_decl | Plain -> - let valid_name = "t" in - if not (String.equal name valid_name) then - Location.raise_errorf ~loc - "Versioned type must be named \"%s\", got: \"%s\"" valid_name name ; - validate_plain_type_decl inner3_modules type_decl - - (* module structure in this case validated by linter *) - - let module_name_from_plain_path inner3_modules = - match inner3_modules with - | [ "T"; module_version; "Stable" ] | module_version :: "Stable" :: _ -> - module_version - | _ -> - failwith "module_name_from_plain_path: unexpected module path" - - let module_name_from_rpc_path inner3_modules = - match List.take inner3_modules 2 with - | [ "T"; module_version ] -> - module_version + module_name_from_plain_path inner3_modules + | Rpc -> + module_name_from_rpc_path inner3_modules + in + let version = version_of_versioned_module_name module_name in + [%str + let version = [%e eint version] + + (* to prevent unused value warnings *) + let (_ : _) = version] + +let ocaml_builtin_types = + [ "bytes" + ; "int" + ; "int32" + ; "int64" + ; "float" + ; "char" + ; "string" + ; "bool" + ; "unit" + ] + +let ocaml_builtin_type_constructors = [ "list"; "array"; "option"; "ref" ] + +(* true iff module_path is of form M. ... .Stable.Vn, where M is Core or Core_kernel, and n is integer *) +let is_jane_street_stable_module module_path = + let hd_elt = List.hd_exn module_path in + List.mem jane_street_modules hd_elt ~equal:String.equal + && + match List.rev module_path with + | vn :: "Stable" :: _ -> + Versioned_util.is_version_module vn + | vn :: label :: "Stable" :: "Time" :: _ + when List.mem [ "Span"; "With_utc_sexp" ] label ~equal:String.equal -> + (* special cases, maybe improper module structure *) + is_version_module vn + | _ -> + false + +let trustlisted_prefix prefix ~loc = + match prefix with + | Lident id -> + String.equal id "Bitstring" + | Ldot _ -> + let module_path = Longident.flatten_exn prefix in + is_jane_street_stable_module module_path + | Lapply _ -> + Location.raise_errorf ~loc "Type name contains unexpected application" + +(* disallow Stable.Latest types in versioned types *) + +let is_stable_latest = + let is_longident_with_id id = function + | Lident s when String.equal id s -> + true + | Ldot (_lident, s) when String.equal id s -> + true | _ -> - failwith "module_name_from_rpc_path: unexpected module path" - - (* generate "let version = n", when version module is Vn *) - let generate_version_number_decl inner3_modules loc generation_kind = - (* invariant: we've checked module name already *) - let module E = Ppxlib.Ast_builder.Make (struct - let loc = loc - end) in - let open E in - let module_name = - match generation_kind with - | Plain -> - module_name_from_plain_path inner3_modules - | Rpc -> - module_name_from_rpc_path inner3_modules - in - let version = version_of_versioned_module_name module_name in - [%str - let version = [%e eint version] - - (* to prevent unused value warnings *) - let (_ : _) = version] - - let ocaml_builtin_types = - [ "bytes" - ; "int" - ; "int32" - ; "int64" - ; "float" - ; "char" - ; "string" - ; "bool" - ; "unit" - ] - - let ocaml_builtin_type_constructors = [ "list"; "array"; "option"; "ref" ] - - (* true iff module_path is of form M. ... .Stable.Vn, where M is Core or Core_kernel, and n is integer *) - let is_jane_street_stable_module module_path = - let hd_elt = List.hd_exn module_path in - List.mem jane_street_modules hd_elt ~equal:String.equal + false + in + let is_stable = is_longident_with_id "Stable" in + let is_latest = is_longident_with_id "Latest" in + fun prefix -> + is_latest prefix && - match List.rev module_path with - | vn :: "Stable" :: _ -> - Versioned_util.is_version_module vn - | vn :: label :: "Stable" :: "Time" :: _ - when List.mem [ "Span"; "With_utc_sexp" ] label ~equal:String.equal -> - (* special cases, maybe improper module structure *) - is_version_module vn + match prefix with + | Ldot (lident, _) when is_stable lident -> + true | _ -> false - let trustlisted_prefix prefix ~loc = - match prefix with - | Lident id -> - String.equal id "Bitstring" - | Ldot _ -> - let module_path = Longident.flatten_exn prefix in - is_jane_street_stable_module module_path - | Lapply _ -> - Location.raise_errorf ~loc "Type name contains unexpected application" - - (* disallow Stable.Latest types in versioned types *) - - let is_stable_latest = - let is_longident_with_id id = function - | Lident s when String.equal id s -> - true - | Ldot (_lident, s) when String.equal id s -> - true - | _ -> - false - in - let is_stable = is_longident_with_id "Stable" in - let is_latest = is_longident_with_id "Latest" in - fun prefix -> - is_latest prefix - && - match prefix with - | Ldot (lident, _) when is_stable lident -> - true - | _ -> - false - - let rec generate_core_type_version_decls type_name core_type = - let version_asserted_str = "version_asserted" in - match core_type.ptyp_desc with - | Ptyp_constr ({ txt; _ }, core_types) -> ( - match txt with - | Lident id -> - (* type t = id *) - if String.equal id type_name (* recursion *) then [] - else if - List.is_empty core_types - && List.mem ocaml_builtin_types id ~equal:String.equal - then (* no versioning to worry about *) - [] - else if - List.mem ocaml_builtin_type_constructors id ~equal:String.equal - then - match core_types with - | [ _ ] -> - generate_version_lets_for_core_types type_name core_types +let rec generate_core_type_version_decls type_name core_type = + let version_asserted_str = "version_asserted" in + match core_type.ptyp_desc with + | Ptyp_constr ({ txt; _ }, core_types) -> ( + match txt with + | Lident id -> + (* type t = id *) + if String.equal id type_name (* recursion *) then [] + else if + List.is_empty core_types + && List.mem ocaml_builtin_types id ~equal:String.equal + then (* no versioning to worry about *) + [] + else if + List.mem ocaml_builtin_type_constructors id ~equal:String.equal + then + match core_types with + | [ _ ] -> + generate_version_lets_for_core_types type_name core_types + | _ -> + Location.raise_errorf ~loc:core_type.ptyp_loc + "Type constructor \"%s\" expects one type argument, got %d" id + (List.length core_types) + else + Location.raise_errorf ~loc:core_type.ptyp_loc + "\"%s\" is neither an OCaml type constructor nor a versioned type" + id + | Ldot (prefix, "t") -> + (* type t = A.B.t + if prefix not trustlisted, generate: let _ = A.B.__versioned__ + disallow Stable.Latest.t + *) + if is_stable_latest prefix then + Location.raise_errorf ~loc:core_type.ptyp_loc + "Cannot use type of the form Stable.Latest.t within a versioned \ + type" ; + let core_type_decls = + generate_version_lets_for_core_types type_name core_types + in + (* type t = M.t [@version_asserted] *) + let version_asserted = + List.find core_type.ptyp_attributes ~f:(fun attr -> + String.equal attr.attr_name.txt version_asserted_str ) + |> Option.is_some + in + if + version_asserted + || trustlisted_prefix prefix ~loc:core_type.ptyp_loc + then core_type_decls + else + let loc = core_type.ptyp_loc in + let pexp_loc = loc in + let new_prefix = + (* allow types within stable-versioned modules generated + by Hashable.Make_binable, like M.Stable.Vn.Table.t; + generate "let _ = M.Stable.Vn.__versioned__" + *) + match prefix with + | Ldot ((Ldot (_, vn) as longident), label) + when is_version_module vn + && List.mem + [ "Table"; "Hash_set"; "Hash_queue" ] + label ~equal:String.equal -> + longident | _ -> - Location.raise_errorf ~loc:core_type.ptyp_loc - "Type constructor \"%s\" expects one type argument, got %d" - id (List.length core_types) - else - Location.raise_errorf ~loc:core_type.ptyp_loc - "\"%s\" is neither an OCaml type constructor nor a versioned \ - type" - id - | Ldot (prefix, "t") -> - (* type t = A.B.t - if prefix not trustlisted, generate: let _ = A.B.__versioned__ - disallow Stable.Latest.t - *) - if is_stable_latest prefix then - Location.raise_errorf ~loc:core_type.ptyp_loc - "Cannot use type of the form Stable.Latest.t within a \ - versioned type" ; - let core_type_decls = - generate_version_lets_for_core_types type_name core_types + prefix in - (* type t = M.t [@version_asserted] *) - let version_asserted = - List.find core_type.ptyp_attributes ~f:(fun attr -> - String.equal attr.attr_name.txt version_asserted_str ) - |> Option.is_some + let versioned_ident = + { pexp_desc = + Pexp_ident { txt = Ldot (new_prefix, "__versioned__"); loc } + ; pexp_loc + ; pexp_loc_stack = [] + ; pexp_attributes = [] + } in - if - version_asserted - || trustlisted_prefix prefix ~loc:core_type.ptyp_loc - then core_type_decls - else - let loc = core_type.ptyp_loc in - let pexp_loc = loc in - let new_prefix = - (* allow types within stable-versioned modules generated - by Hashable.Make_binable, like M.Stable.Vn.Table.t; - generate "let _ = M.Stable.Vn.__versioned__" - *) - match prefix with - | Ldot ((Ldot (_, vn) as longident), label) - when is_version_module vn - && List.mem - [ "Table"; "Hash_set"; "Hash_queue" ] - label ~equal:String.equal -> - longident - | _ -> - prefix - in - let versioned_ident = - { pexp_desc = - Pexp_ident { txt = Ldot (new_prefix, "__versioned__"); loc } - ; pexp_loc - ; pexp_loc_stack = [] - ; pexp_attributes = [] - } - in - [%str let (_ : _) = [%e versioned_ident]] @ core_type_decls - | _ -> - Location.raise_errorf ~loc:core_type.ptyp_loc - "Unrecognized type constructor for versioned type" ) - | Ptyp_tuple core_types -> - (* type t = t1 * t2 * t3 *) - generate_version_lets_for_core_types type_name core_types - | Ptyp_variant _ -> - (* type t = [ `A | `B ] *) - [] - | Ptyp_var _ -> - (* type variable *) - [] - | Ptyp_any -> - (* underscore *) - [] - | _ -> - Location.raise_errorf ~loc:core_type.ptyp_loc - "Can't determine versioning for contained type" - - and generate_version_lets_for_core_types type_name core_types = - List.fold_right core_types ~init:[] ~f:(fun core_type accum -> - generate_core_type_version_decls type_name core_type @ accum ) - - let generate_version_lets_for_label_decls type_name label_decls = - generate_version_lets_for_core_types type_name - (List.map label_decls ~f:(fun lab_decl -> lab_decl.pld_type)) - - let generate_constructor_decl_decls type_name ctor_decl = - let result_lets = - match ctor_decl.pcd_res with - | None -> - [] - | Some res -> - (* for GADTs, check versioned-ness of parameters to result type *) - let ty_params = - match res.ptyp_desc with - | Ptyp_constr (_, params) -> - params - | _ -> - failwith - "generate_constructor_decl_decls: expected type parameter \ - list" - in - generate_version_lets_for_core_types type_name ty_params - in - match ctor_decl.pcd_args with - | Pcstr_tuple core_types -> - (* C of T1 * ... * Tn, or GADT C : T1 -> T2 *) - let arg_lets = - generate_version_lets_for_core_types type_name core_types - in - arg_lets @ result_lets - | Pcstr_record label_decls -> - (* C of { ... }, or GADT C : { ... } -> T *) - let arg_lets = - generate_version_lets_for_label_decls type_name label_decls - in - arg_lets @ result_lets + [%str let (_ : _) = [%e versioned_ident]] @ core_type_decls + | _ -> + Location.raise_errorf ~loc:core_type.ptyp_loc + "Unrecognized type constructor for versioned type" ) + | Ptyp_tuple core_types -> + (* type t = t1 * t2 * t3 *) + generate_version_lets_for_core_types type_name core_types + | Ptyp_variant _ -> + (* type t = [ `A | `B ] *) + [] + | Ptyp_var _ -> + (* type variable *) + [] + | Ptyp_any -> + (* underscore *) + [] + | _ -> + Location.raise_errorf ~loc:core_type.ptyp_loc + "Can't determine versioning for contained type" - let generate_constraint_type_decls type_name cstrs = - let gen_for_constraint (ty1, ty2, _loc) = - List.concat_map [ ty1; ty2 ] - ~f:(generate_core_type_version_decls type_name) - in - List.concat_map cstrs ~f:gen_for_constraint +and generate_version_lets_for_core_types type_name core_types = + List.fold_right core_types ~init:[] ~f:(fun core_type accum -> + generate_core_type_version_decls type_name core_type @ accum ) - let generate_contained_type_version_decls type_decl = - let type_name = type_decl.ptype_name.txt in - let constraint_type_version_decls = - generate_constraint_type_decls type_decl.ptype_name.txt - type_decl.ptype_cstrs - in - let main_type_version_decls = - match type_decl.ptype_kind with - | Ptype_abstract -> ( - match type_decl.ptype_manifest with - | Some manifest -> - generate_core_type_version_decls type_name manifest - | None -> - Location.raise_errorf ~loc:type_decl.ptype_loc - "Versioned type, not a label or variant, must have manifest \ - (right-hand side)" ) - | Ptype_variant ctor_decls -> - List.fold ctor_decls ~init:[] ~f:(fun accum ctor_decl -> - generate_constructor_decl_decls type_name ctor_decl @ accum ) - | Ptype_record label_decls -> - generate_version_lets_for_label_decls type_name label_decls - | Ptype_open -> - Location.raise_errorf ~loc:type_decl.ptype_loc - "Versioned type may not be open" - in - constraint_type_version_decls @ main_type_version_decls - - let generate_versioned_decls ~binable generation_kind type_decl = - let module E = Ppxlib.Ast_builder.Make (struct - let loc = type_decl.ptype_loc - end) in - let open E in - let versioned_current = [%stri let __versioned__ = ()] in - if binable then [ versioned_current ] - else - match generation_kind with - | Rpc -> - (* check whether contained types are versioned, - but don't assert versioned-ness of this type *) - generate_contained_type_version_decls type_decl - | Plain -> - (* check contained types, assert this type is versioned *) - versioned_current :: generate_contained_type_version_decls type_decl - - let get_type_decl_representative type_decls = - match type_decls with - | [ type_decl1 ] -> - type_decl1 - | type_decl1 :: type_decls -> - let type_decl2 = List.hd_exn (List.rev type_decls) in - let loc = - { loc_start = type_decl1.ptype_loc.loc_start - ; loc_end = type_decl2.ptype_loc.loc_end - ; loc_ghost = true - } +let generate_version_lets_for_label_decls type_name label_decls = + generate_version_lets_for_core_types type_name + (List.map label_decls ~f:(fun lab_decl -> lab_decl.pld_type)) + +let generate_constructor_decl_decls type_name ctor_decl = + let result_lets = + match ctor_decl.pcd_res with + | None -> + [] + | Some res -> + (* for GADTs, check versioned-ness of parameters to result type *) + let ty_params = + match res.ptyp_desc with + | Ptyp_constr (_, params) -> + params + | _ -> + failwith + "generate_constructor_decl_decls: expected type parameter list" in - Location.raise_errorf ~loc - "Versioned type must be just one type \"t\", not a sequence of types" - | [] -> - assert false - (* assumed to not be possible *) - - let generate_let_bindings_for_type_decl_str ~loc ~path (_rec_flag, type_decls) - rpc binable = - let type_decl = get_type_decl_representative type_decls in - if binable && rpc then - Location.raise_errorf ~loc:type_decl.ptype_loc - "Options \"binable\" and \"rpc\" cannot be combined" ; - let generation_kind = if rpc then Rpc else Plain in - let module_path = module_path_list path in - let inner3_modules = List.take (List.rev module_path) 3 in - (* TODO: when Module_version.Registration goes away, remove - the empty list special case - *) - if List.is_empty inner3_modules then - (* module path doesn't seem to be tracked inside test module *) - [] - else ( - validate_type_decl inner3_modules generation_kind type_decl ; - let versioned_decls = - generate_versioned_decls ~binable generation_kind type_decl + generate_version_lets_for_core_types type_name ty_params + in + match ctor_decl.pcd_args with + | Pcstr_tuple core_types -> + (* C of T1 * ... * Tn, or GADT C : T1 -> T2 *) + let arg_lets = + generate_version_lets_for_core_types type_name core_types in - let type_name = type_decl.ptype_name.txt in - (* generate version number for Rpc response, but not for query, so we - don't get an unused value - *) - match generation_kind with - | Rpc when String.equal type_name "query" -> - versioned_decls - | _ -> - generate_version_number_decl inner3_modules loc generation_kind - @ versioned_decls ) + arg_lets @ result_lets + | Pcstr_record label_decls -> + (* C of { ... }, or GADT C : { ... } -> T *) + let arg_lets = + generate_version_lets_for_label_decls type_name label_decls + in + arg_lets @ result_lets + +let generate_constraint_type_decls type_name cstrs = + let gen_for_constraint (ty1, ty2, _loc) = + List.concat_map [ ty1; ty2 ] ~f:(generate_core_type_version_decls type_name) + in + List.concat_map cstrs ~f:gen_for_constraint - let generate_val_decls_for_type_decl ~loc type_decl = +let generate_contained_type_version_decls type_decl = + let type_name = type_decl.ptype_name.txt in + let constraint_type_version_decls = + generate_constraint_type_decls type_decl.ptype_name.txt + type_decl.ptype_cstrs + in + let main_type_version_decls = match type_decl.ptype_kind with - (* the structure of the type doesn't affect what we generate for signatures *) - | Ptype_abstract | Ptype_variant _ | Ptype_record _ -> - [ [%sigi: val __versioned__ : unit] ] + | Ptype_abstract -> ( + match type_decl.ptype_manifest with + | Some manifest -> + generate_core_type_version_decls type_name manifest + | None -> + Location.raise_errorf ~loc:type_decl.ptype_loc + "Versioned type, not a label or variant, must have manifest \ + (right-hand side)" ) + | Ptype_variant ctor_decls -> + List.fold ctor_decls ~init:[] ~f:(fun accum ctor_decl -> + generate_constructor_decl_decls type_name ctor_decl @ accum ) + | Ptype_record label_decls -> + generate_version_lets_for_label_decls type_name label_decls | Ptype_open -> - (* but the type can't be open, else it might vary over time *) - Location.raise_errorf ~loc - "Versioned type in a signature must not be open" - - let generate_val_decls_for_type_decl_sig ~loc ~path:_ (_rec_flag, type_decls) - = - (* in a signature, the module path may vary *) - let type_decl = get_type_decl_representative type_decls in - generate_val_decls_for_type_decl ~loc type_decl -end - -(* at preprocessing time, choose between printing, deriving derivers *) -let choose_deriver ~printing ~deriving = - if !printing_ref then printing else deriving + Location.raise_errorf ~loc:type_decl.ptype_loc + "Versioned type may not be open" + in + constraint_type_version_decls @ main_type_version_decls + +let generate_versioned_decls ~binable generation_kind type_decl = + let module E = Ppxlib.Ast_builder.Make (struct + let loc = type_decl.ptype_loc + end) in + let open E in + let versioned_current = [%stri let __versioned__ = ()] in + if binable then [ versioned_current ] + else + match generation_kind with + | Rpc -> + (* check whether contained types are versioned, + but don't assert versioned-ness of this type *) + generate_contained_type_version_decls type_decl + | Plain -> + (* check contained types, assert this type is versioned *) + versioned_current :: generate_contained_type_version_decls type_decl + +let get_type_decl_representative type_decls = + match type_decls with + | [ type_decl1 ] -> + type_decl1 + | type_decl1 :: type_decls -> + let type_decl2 = List.hd_exn (List.rev type_decls) in + let loc = + { loc_start = type_decl1.ptype_loc.loc_start + ; loc_end = type_decl2.ptype_loc.loc_end + ; loc_ghost = true + } + in + Location.raise_errorf ~loc + "Versioned type must be just one type \"t\", not a sequence of types" + | [] -> + (* assumed not possible *) + assert false + +let generate_let_bindings_for_type_decl_str ~loc ~path (_rec_flag, type_decls) + rpc binable = + let type_decl = get_type_decl_representative type_decls in + if binable && rpc then + Location.raise_errorf ~loc:type_decl.ptype_loc + "Options \"binable\" and \"rpc\" cannot be combined" ; + let generation_kind = if rpc then Rpc else Plain in + let module_path = module_path_list path in + let inner3_modules = List.take (List.rev module_path) 3 in + (* TODO: when Module_version.Registration goes away, remove + the empty list special case + *) + if List.is_empty inner3_modules then + (* module path doesn't seem to be tracked inside test module *) + [] + else ( + validate_type_decl inner3_modules generation_kind type_decl ; + let versioned_decls = + generate_versioned_decls ~binable generation_kind type_decl + in + let type_name = type_decl.ptype_name.txt in + (* generate version number for Rpc response, but not for query, so we + don't get an unused value + *) + match generation_kind with + | Rpc when String.equal type_name "query" -> + versioned_decls + | _ -> + generate_version_number_decl inner3_modules loc generation_kind + @ versioned_decls ) + +let generate_val_decls_for_type_decl ~loc type_decl = + match type_decl.ptype_kind with + (* the structure of the type doesn't affect what we generate for signatures *) + | Ptype_abstract | Ptype_variant _ | Ptype_record _ -> + [ [%sigi: val __versioned__ : unit] ] + | Ptype_open -> + (* but the type can't be open, else it might vary over time *) + Location.raise_errorf ~loc + "Versioned type in a signature must not be open" + +let generate_val_decls_for_type_decl_sig ~loc ~path:_ (_rec_flag, type_decls) = + (* in a signature, the module path may vary *) + let type_decl = get_type_decl_representative type_decls in + generate_val_decls_for_type_decl ~loc type_decl let str_type_decl : (structure, rec_flag * type_declaration list) Ppxlib.Deriving.Generator.t = @@ -590,18 +407,15 @@ let str_type_decl : empty +> flag "rpc" +> flag "binable" in let deriver ~loc ~path (rec_flag, type_decls) rpc binable = - (choose_deriver ~printing:Printing.print_type - ~deriving:Deriving.generate_let_bindings_for_type_decl_str ) - ~loc ~path (rec_flag, type_decls) rpc binable + generate_let_bindings_for_type_decl_str ~loc ~path (rec_flag, type_decls) + rpc binable in Ppxlib.Deriving.Generator.make args deriver let sig_type_decl : (signature, rec_flag * type_declaration list) Ppxlib.Deriving.Generator.t = let deriver ~loc ~path (rec_flag, type_decls) = - (choose_deriver ~printing:Printing.gen_empty_sig - ~deriving:Deriving.generate_val_decls_for_type_decl_sig ) - ~loc ~path (rec_flag, type_decls) + generate_val_decls_for_type_decl_sig ~loc ~path (rec_flag, type_decls) in Ppxlib.Deriving.Generator.make_noarg deriver