├── dune-project ├── .ocamlformat ├── src ├── syntax.mli ├── type_kind.mli ├── nothing_generator.mli ├── product_kind.mli ├── typed_deriver.mli ├── product_kind.ml ├── variant_generator.mli ├── variant_kind_generator.mli ├── tuple_generator.mli ├── tuple_kind_generator.mli ├── unit_kind_generator.mli ├── record_generator.mli ├── record_kind_generator.mli ├── names.mli ├── syntax.ml ├── names.ml ├── dune ├── syntax_intf.ml ├── subset_of.mli ├── ppx_typed_variants.mli ├── typed_deriver_fields.mli ├── singleton_generator.mli ├── ppx_typed_fields.mli ├── generic_generator.mli ├── variant_kind_generator.ml ├── product_kind_intf.ml ├── unit_kind_generator.ml ├── typed_deriver_intf.ml ├── record_generator.ml ├── typed_deriver_variants.mli ├── generic_generator.ml ├── tuple_generator.ml ├── nothing_generator.ml ├── subset_of.ml ├── tuple_kind_generator.ml ├── record_kind_generator.ml ├── type_kind.ml ├── typed_deriver.ml ├── product_kind_generator.mli ├── singleton_generator.ml ├── type_kind_intf.ml ├── variant_kind_generator_intf.ml └── typed_deriver_fields.ml ├── .gitignore ├── typed_field_map ├── the_map.mli ├── typed_field_map.ml ├── typed_field_map.mli ├── dune ├── sexp_serializers.mli ├── nested.mli ├── nested.ml ├── sexp_serializers.ml ├── the_map_intf.ml └── the_map.ml ├── typed_variants_lib ├── typed_variants_lib.mli ├── dune ├── typed_variants_lib_intf.ml └── typed_variants_lib.ml ├── typed_fields_lib ├── typed_fields_lib.mli ├── dune ├── typed_fields_lib_intf.ml └── typed_common_lib_intf.ml ├── CHANGES.md ├── Makefile ├── ppx_typed_fields.opam ├── LICENSE.md └── CONTRIBUTING.md /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.17) 2 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile=janestreet 2 | -------------------------------------------------------------------------------- /src/syntax.mli: -------------------------------------------------------------------------------- 1 | include Syntax_intf.Syntax 2 | -------------------------------------------------------------------------------- /src/type_kind.mli: -------------------------------------------------------------------------------- 1 | include Type_kind_intf.Type_kind 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *.install 3 | *.merlin 4 | _opam 5 | 6 | -------------------------------------------------------------------------------- /src/nothing_generator.mli: -------------------------------------------------------------------------------- 1 | include Variant_kind_generator.S 2 | -------------------------------------------------------------------------------- /src/product_kind.mli: -------------------------------------------------------------------------------- 1 | include Product_kind_intf.Product_kind 2 | -------------------------------------------------------------------------------- /src/typed_deriver.mli: -------------------------------------------------------------------------------- 1 | include Typed_deriver_intf.Typed_deriver 2 | -------------------------------------------------------------------------------- /src/product_kind.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | include Product_kind_intf.Definitions 3 | -------------------------------------------------------------------------------- /src/variant_generator.mli: -------------------------------------------------------------------------------- 1 | open! Base 2 | include Variant_kind_generator.S 3 | -------------------------------------------------------------------------------- /typed_field_map/the_map.mli: -------------------------------------------------------------------------------- 1 | open! Base 2 | include The_map_intf.The_map 3 | -------------------------------------------------------------------------------- /src/variant_kind_generator.mli: -------------------------------------------------------------------------------- 1 | include Variant_kind_generator_intf.Variant_kind_generator 2 | -------------------------------------------------------------------------------- /typed_variants_lib/typed_variants_lib.mli: -------------------------------------------------------------------------------- 1 | include Typed_variants_lib_intf.Typed_variants_lib 2 | -------------------------------------------------------------------------------- /typed_fields_lib/typed_fields_lib.mli: -------------------------------------------------------------------------------- 1 | include Typed_fields_lib_intf.Typed_fields_lib (** @inline *) 2 | -------------------------------------------------------------------------------- /src/tuple_generator.mli: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Ppxlib 3 | include Product_kind.S with type t = core_type 4 | -------------------------------------------------------------------------------- /src/tuple_kind_generator.mli: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Ppxlib 3 | include Type_kind.S with type t = core_type 4 | -------------------------------------------------------------------------------- /src/unit_kind_generator.mli: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Ppxlib 3 | include Type_kind.S with type t = core_type 4 | -------------------------------------------------------------------------------- /src/record_generator.mli: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Ppxlib 3 | include Product_kind.S with type t = label_declaration 4 | -------------------------------------------------------------------------------- /src/record_kind_generator.mli: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Ppxlib 3 | include Type_kind.S with type t = label_declaration 4 | -------------------------------------------------------------------------------- /typed_field_map/typed_field_map.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | include The_map 3 | module Nested = Nested 4 | module Sexp_serializers = Sexp_serializers 5 | -------------------------------------------------------------------------------- /typed_field_map/typed_field_map.mli: -------------------------------------------------------------------------------- 1 | open! Base 2 | include The_map_intf.The_map 3 | module Nested = Nested 4 | module Sexp_serializers = Sexp_serializers 5 | -------------------------------------------------------------------------------- /src/names.mli: -------------------------------------------------------------------------------- 1 | open! Base 2 | 3 | val derived_on_name : string 4 | val localize : string -> local:bool -> string 5 | val stackify : string -> stack:bool -> string 6 | -------------------------------------------------------------------------------- /typed_field_map/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name typed_field_map) 3 | (public_name ppx_typed_fields.typed_field_map) 4 | (libraries base sexplib typed_fields_lib univ_map) 5 | (preprocess 6 | (pps ppx_base ppx_pipebang ppx_sexp_message))) 7 | -------------------------------------------------------------------------------- /src/syntax.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | include Syntax_intf.Definitions 3 | 4 | let builder loc : (module S) = 5 | (module struct 6 | include (val Ppxlib.Ast_builder.make loc) 7 | include (val Ppxlib_jane.Ast_builder.make loc) 8 | end) 9 | ;; 10 | -------------------------------------------------------------------------------- /typed_variants_lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name typed_variants_lib) 3 | (public_name ppx_typed_fields.typed_variants_lib) 4 | (libraries base sexplib0 typed_fields_lib) 5 | (preprocess 6 | (pps ppx_sexp_conv ppx_enumerate ppx_compare ppx_template))) 7 | -------------------------------------------------------------------------------- /typed_fields_lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name typed_fields_lib) 3 | (public_name ppx_typed_fields.typed_fields_lib) 4 | (libraries base sexplib0) 5 | (preprocess 6 | (pps ppx_compare ppx_enumerate ppx_globalize ppx_hash ppx_sexp_conv 7 | ppx_template))) 8 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## Release v0.16.0 2 | 3 | - Extend `Typed_fields_lib` and `Typed_variants_lib` with new functors for converting 4 | between a module that operates on a record or variant with type variables into one with 5 | concrete types for those variables: S_of_S1, S_of_S2, S_of_S3, S_of_S4, S_of_S5 6 | -------------------------------------------------------------------------------- /src/names.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | 3 | let derived_on_name = "derived_on" 4 | 5 | let localize name ~local = 6 | match local with 7 | | false -> name 8 | | true -> name ^ "__local" 9 | ;; 10 | 11 | let stackify name ~stack = 12 | match stack with 13 | | false -> name 14 | | true -> name ^ "__stack" 15 | ;; 16 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) 2 | 3 | default: 4 | dune build 5 | 6 | install: 7 | dune install $(INSTALL_ARGS) 8 | 9 | uninstall: 10 | dune uninstall $(INSTALL_ARGS) 11 | 12 | reinstall: uninstall install 13 | 14 | clean: 15 | dune clean 16 | 17 | .PHONY: default install uninstall reinstall clean 18 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_typed_fields) 3 | (public_name ppx_typed_fields) 4 | (kind ppx_deriver) 5 | (ppx_runtime_libraries base ppx_typed_fields.typed_fields_lib 6 | ppx_typed_fields.typed_variants_lib sexplib) 7 | (libraries base ppxlib ppxlib_jane) 8 | (preprocess 9 | (pps ppxlib.metaquot ppx_base -require-template-extension ppx_pipebang 10 | ppx_string))) 11 | -------------------------------------------------------------------------------- /src/syntax_intf.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | 3 | module Definitions = struct 4 | module type S = sig 5 | include Ppxlib.Ast_builder.S 6 | include Ppxlib_jane.Ast_builder.S_with_implicit_loc 7 | end 8 | end 9 | 10 | module type Syntax = sig 11 | include module type of struct 12 | include Definitions 13 | end 14 | 15 | val builder : Ppxlib.Location.t -> (module S) 16 | end 17 | -------------------------------------------------------------------------------- /src/subset_of.mli: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Ppxlib 3 | 4 | val generate_str 5 | : loc:location 6 | -> typ_name:label 7 | -> fields:(label_declaration * Type_kind.granularity) list 8 | -> params:(core_type * (variance * injectivity)) list 9 | -> super:longident 10 | -> structure_item 11 | 12 | val generate_sig 13 | : loc:location 14 | -> typ_name:label 15 | -> params:(core_type * (variance * injectivity)) list 16 | -> super:longident 17 | -> signature_item 18 | -------------------------------------------------------------------------------- /src/ppx_typed_variants.mli: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Ppxlib 3 | 4 | val variants : Deriving.t 5 | 6 | module For_testing : sig 7 | val expand_struct 8 | : loc:location 9 | -> rec_flag * type_declaration list 10 | -> structure_item list 11 | 12 | val expand_sig : loc:location -> rec_flag * type_declaration list -> signature_item list 13 | 14 | val expand_anonymous_struct 15 | : loc:location 16 | -> rec_flag 17 | -> type_declaration list 18 | -> module_expr 19 | end 20 | -------------------------------------------------------------------------------- /typed_field_map/sexp_serializers.mli: -------------------------------------------------------------------------------- 1 | open! Base 2 | 3 | (* Creates sexper functions for a typed_field_map. *) 4 | module Make (Map : The_map_intf.S_plain) : sig 5 | type to_sexper = { f : 'a. 'a Map.Key.t -> 'a Map.Data.t -> Sexp.t } 6 | type of_sexper = { f : 'a. 'a Map.Key.t -> Sexp.t -> 'a Map.Data.t } 7 | type defaulter = { f : 'a. 'a Map.Key.t -> 'a Map.Data.t option } 8 | 9 | val sexp_of_t : to_sexper -> Map.t -> Sexp.t 10 | val t_of_sexp : ?default:defaulter -> of_sexper -> Sexp.t -> Map.t 11 | end 12 | -------------------------------------------------------------------------------- /src/typed_deriver_fields.mli: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Ppxlib 3 | 4 | (* Generate a Typed_fields(_t | of_x) structure item given a specific implementation 5 | module for how to handle the specific conversions like how the names for the 6 | typed_fields constructors are determined and how setter/getter functions work.*) 7 | val gen_str 8 | : (module Type_kind.S with type t = 'a) 9 | -> original_type:core_type option 10 | -> original_kind:type_kind 11 | -> loc:location 12 | -> elements_to_convert:('a * Type_kind.granularity) list 13 | -> params:(core_type * (variance * injectivity)) list 14 | -> structure_item list 15 | 16 | include Typed_deriver.S 17 | -------------------------------------------------------------------------------- /src/singleton_generator.mli: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Ppxlib 3 | 4 | type common_items = 5 | { upper : structure_item 6 | ; upper_rename : structure_item 7 | ; t_type_declaration : structure_item 8 | ; internal_gadt_declaration : structure_item 9 | ; names : structure_item 10 | ; name : structure_item 11 | ; path : structure_item 12 | ; ord : structure_item 13 | ; globalize0 : structure_item 14 | ; globalize : structure_item 15 | ; type_ids : structure_item 16 | ; packed : structure_item 17 | } 18 | 19 | (*Creates the common top level items between typed variants and types fields. *) 20 | val common 21 | : loc:location 22 | -> minimum_needed_parameters:(core_type * (variance * injectivity)) list 23 | -> core_type_params:core_type list 24 | -> ctype:core_type 25 | -> unique_id:label 26 | -> common_items 27 | -------------------------------------------------------------------------------- /typed_field_map/nested.mli: -------------------------------------------------------------------------------- 1 | open! Base 2 | 3 | module Make (Leaf_data : T1) : sig 4 | module rec Tree : sig 5 | type 'a t = private 6 | | Leaf : 'a Leaf_data.t -> 'a t 7 | | Branch : (module Branch.S with type Typed_field.derived_on = 'a) -> 'a t 8 | end 9 | 10 | and Branch : sig 11 | module type S = sig 12 | module Typed_field : Typed_fields_lib.S 13 | 14 | module Map : 15 | The_map.S with module Key := Typed_field and type 'a Data.t := 'a Tree.t 16 | 17 | val map : Map.t 18 | end 19 | end 20 | 21 | module type S = sig 22 | module Typed_field : Typed_fields_lib.S 23 | 24 | val children : 'a Typed_field.t -> 'a Tree.t 25 | end 26 | 27 | type 'a t = 'a Tree.t 28 | 29 | val leaf : 'a Leaf_data.t -> 'a t 30 | val branch : (module S with type Typed_field.derived_on = 'a) -> 'a t 31 | end 32 | -------------------------------------------------------------------------------- /src/ppx_typed_fields.mli: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Ppxlib 3 | 4 | val fields : Deriving.t 5 | 6 | module For_testing : sig 7 | val expand_struct 8 | : ?super:expression 9 | -> loc:location 10 | -> rec_flag * type_declaration list 11 | -> structure_item list 12 | 13 | val expand_sig 14 | : ?super:expression 15 | -> loc:location 16 | -> rec_flag * type_declaration list 17 | -> signature_item list 18 | 19 | val expand_anonymous_struct 20 | : loc:location 21 | -> rec_flag 22 | -> type_declaration list 23 | -> module_expr 24 | 25 | val expand_variant_struct 26 | : loc:location 27 | -> rec_flag * type_declaration list 28 | -> structure_item list 29 | 30 | val expand_variant_sig 31 | : loc:location 32 | -> rec_flag * type_declaration list 33 | -> signature_item list 34 | 35 | val expand_variant_anonymous_struct 36 | : loc:location 37 | -> rec_flag 38 | -> type_declaration list 39 | -> module_expr 40 | end 41 | -------------------------------------------------------------------------------- /ppx_typed_fields.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Jane Street developers" 3 | authors: ["Jane Street Group, LLC"] 4 | homepage: "https://github.com/janestreet/ppx_typed_fields" 5 | bug-reports: "https://github.com/janestreet/ppx_typed_fields/issues" 6 | dev-repo: "git+https://github.com/janestreet/ppx_typed_fields.git" 7 | doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/ppx_typed_fields/index.html" 8 | license: "MIT" 9 | build: [ 10 | ["dune" "build" "-p" name "-j" jobs] 11 | ] 12 | depends: [ 13 | "ocaml" {>= "5.1.0"} 14 | "base" 15 | "ppx_base" 16 | "ppx_compare" 17 | "ppx_enumerate" 18 | "ppx_globalize" 19 | "ppx_hash" 20 | "ppx_pipebang" 21 | "ppx_sexp_conv" 22 | "ppx_sexp_message" 23 | "ppx_string" 24 | "ppx_template" 25 | "ppxlib_jane" 26 | "sexplib" 27 | "sexplib0" 28 | "univ_map" 29 | "dune" {>= "3.17.0"} 30 | "ppxlib" {>= "0.33.0" & < "0.36.0"} 31 | ] 32 | available: arch != "arm32" & arch != "x86_32" 33 | synopsis: "GADT-based field accessors and utilities" 34 | description: " 35 | Part of the Jane Street's PPX rewriters collection. 36 | " 37 | -------------------------------------------------------------------------------- /typed_field_map/nested.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | 3 | module Make (Leaf_data : T1) = struct 4 | module rec Tree : sig 5 | type 'a t = 6 | | Leaf : 'a Leaf_data.t -> 'a t 7 | | Branch : (module Branch.S with type Typed_field.derived_on = 'a) -> 'a t 8 | end = 9 | Tree 10 | 11 | and Branch : sig 12 | module type S = sig 13 | module Typed_field : Typed_fields_lib.S 14 | 15 | module Map : 16 | The_map.S with module Key := Typed_field and type 'a Data.t := 'a Tree.t 17 | 18 | val map : Map.t 19 | end 20 | end = 21 | Branch 22 | 23 | type 'a t = 'a Tree.t 24 | 25 | let leaf kind = Tree.Leaf kind 26 | 27 | module type S = sig 28 | module Typed_field : Typed_fields_lib.S 29 | 30 | val children : 'a Typed_field.t -> 'a Tree.t 31 | end 32 | 33 | let branch (type a) (module N : S with type Typed_field.derived_on = a) = 34 | let module M = struct 35 | module Typed_field = N.Typed_field 36 | module Map = The_map.Make (Typed_field) (Tree) 37 | 38 | let map = Map.create { f = N.children } 39 | end 40 | in 41 | Tree.Branch (module M) 42 | ;; 43 | end 44 | -------------------------------------------------------------------------------- /src/generic_generator.mli: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Ppxlib 3 | 4 | (* Generates top level type definitions 5 | `type record = t` and 6 | `type _ t = A : a | B : b ...` *) 7 | val gen_t 8 | : loc:location 9 | -> original_type:core_type option 10 | -> original_kind:type_kind 11 | -> elements_to_convert:('a * Type_kind.granularity) list 12 | -> generate_constructors: 13 | (loc:location 14 | -> elements_to_convert:('a * Type_kind.granularity) list 15 | -> core_type_params:core_type list 16 | -> (('a * Type_kind.granularity) * constructor_declaration) list) 17 | -> params:(core_type * (variance * injectivity)) list 18 | -> upper_name:label 19 | -> 'a Type_kind.gen_t_result 20 | 21 | (* Generates a signature for an opaque type. (e.g. type ('a, 'b, 'c) inner_weird) 22 | The parameter name is the name of the type (e.g. inner weird), and the 23 | params are the type parameters of the type (e.g. ('a, 'b, 'c)) 24 | *) 25 | val opaque_signature 26 | : (module Typed_deriver.S) 27 | -> loc:location 28 | -> manifest_type:core_type option 29 | -> original_kind:type_kind 30 | -> params:(core_type * (variance * injectivity)) list 31 | -> module_type 32 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The MIT License 2 | 3 | Copyright (c) 2020--2025 Jane Street Group, LLC 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /src/variant_kind_generator.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | include Variant_kind_generator_intf.Definitions 3 | 4 | let append_functor_parameter original_name = original_name ^ "_subvariant" 5 | 6 | let supported_constructor_name = function 7 | | Anonymous_record_constructor { constructor_name; _ } 8 | | No_values_constructor { constructor_name; _ } 9 | | Single_value_constructor { constructor_name; _ } 10 | | Tuple_values_constructor { constructor_name; _ } -> constructor_name 11 | ;; 12 | 13 | let supported_constructor_type = function 14 | | Anonymous_record_constructor { return_value_type; _ } 15 | | Tuple_values_constructor { return_value_type; _ } 16 | | No_values_constructor { return_value_type; _ } 17 | | Single_value_constructor { return_value_type; _ } -> return_value_type 18 | ;; 19 | 20 | let strip_depth_from_supported_declaration declaration = 21 | match declaration with 22 | | Anonymous_record_constructor _ | No_values_constructor _ | Tuple_values_constructor _ 23 | -> declaration 24 | | Single_value_constructor contents -> 25 | Single_value_constructor { contents with granularity = Shallow } 26 | ;; 27 | 28 | let strip_depth_from_td_case td_case = 29 | match td_case with 30 | | Nothing _ | Opaque _ | Unknown -> td_case 31 | | Variant (declarations, params) -> 32 | Variant (List.map declarations ~f:strip_depth_from_supported_declaration, params) 33 | ;; 34 | 35 | let at_least_one_subvariant constructor_declarations = 36 | List.exists constructor_declarations ~f:(fun cd -> 37 | match cd with 38 | | Single_value_constructor { granularity = Constr_deep _; _ } 39 | | Single_value_constructor { granularity = Polymorphic_deep; _ } -> true 40 | | _ -> false) 41 | ;; 42 | -------------------------------------------------------------------------------- /src/product_kind_intf.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Ppxlib 3 | 4 | module Definitions = struct 5 | module type S = sig 6 | type t 7 | 8 | (* Generates the name with which an individual element is identified. This name is 9 | used to generate the constructor for each element. *) 10 | val name : int -> t -> label 11 | 12 | (* Retrieves the type of an element. This is the type that defines the type of 13 | each constructor in the t GADT.*) 14 | val to_type : t -> core_type 15 | 16 | (* Generates the expression which sets an element in the original tuple/record. 17 | 18 | The element to be changed is identified by the index which is position based in the 19 | order that the fields/elements where defined. *) 20 | val set_rhs_expression 21 | : loc:location 22 | -> index:int 23 | -> element:t 24 | -> number_of_elements:int 25 | -> expression_to_set:expression 26 | -> expression 27 | 28 | (* Generates the expression which gets an element from the original tuple/record. 29 | 30 | The element to be retrieved is identified by the index which is position based in 31 | the order that the fields/elements where defined. *) 32 | val get_rhs_expression 33 | : loc:location 34 | -> index:int 35 | -> element:t 36 | -> number_of_elements:int 37 | -> expression 38 | 39 | (* Generates an expression that creates a tuple/record from a creator function. *) 40 | val create_expression 41 | : loc:location 42 | -> constructor_declarations: 43 | ((t * Type_kind.granularity) * constructor_declaration) list 44 | -> local:bool 45 | -> expression 46 | end 47 | end 48 | 49 | module type Product_kind = sig 50 | include module type of struct 51 | include Definitions 52 | end 53 | end 54 | -------------------------------------------------------------------------------- /src/unit_kind_generator.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Ppxlib 3 | 4 | type t = core_type 5 | 6 | (* The structure items will be inserted after the type type 7 | definitions and before any other items.*) 8 | let extra_structure_items_to_insert loc = 9 | [ [%stri 10 | let unreachable_code = function 11 | | (_ : _ typed__t) -> . 12 | ;;] 13 | ] 14 | ;; 15 | 16 | let constructor_declarations ~loc:_ ~elements_to_convert:_ ~core_type_params:_ = [] 17 | let names_list ~loc ~elements_to_convert:_ = [%expr []] 18 | let name_function_body ~loc = [%expr unreachable_code] 19 | let path_function_body ~loc ~elements_to_convert:_ = [%expr unreachable_code] 20 | let ord_function_body ~loc ~elements_to_convert:_ = [%expr unreachable_code] 21 | let get_function_body ~loc ~elements_to_convert:_ = [%expr unreachable_code] 22 | 23 | let set_function_body ~loc ~elements_to_convert:_ = 24 | [%expr fun t _ _ -> unreachable_code t] 25 | ;; 26 | 27 | let create_function_body ~loc ~constructor_declarations:_ ~local:_ = [%expr ()] 28 | let type_ids ~loc:_ ~elements_to_convert:_ ~core_type_params:_ = [] 29 | let subproduct_type_id_modules ~loc:_ ~elements_to_convert:_ ~core_type_params:_ = [] 30 | let type_id_function_body ~loc ~elements_to_convert:_ = [%expr unreachable_code] 31 | let globalize0_function_body ~loc ~elements_to_convert:_ = [%expr unreachable_code] 32 | 33 | let sexp_of_t_body ~loc ~elements_to_convert:_ ~stack:_ = 34 | [%expr 35 | match packed with 36 | | (_ : t) -> .] 37 | ;; 38 | 39 | let all_body ~loc ~constructor_declarations:_ = [%expr []] 40 | let pack_body ~loc ~elements_to_convert:_ ~local:_ = [%expr unreachable_code] 41 | 42 | let globalize_packed_function_body ~loc ~elements_to_convert:_ = 43 | [%expr 44 | function 45 | | (_ : t) -> .] 46 | ;; 47 | 48 | let t_of_sexp_body ~loc ~elements_to_convert:_ = 49 | [%expr 50 | Base.raise_s 51 | (Sexplib.Sexp.List 52 | [ Sexplib.Sexp.Atom "Unit has no fields, so cannot convert to field."; sexp ])] 53 | ;; 54 | 55 | let deep_functor_structure ~loc:_ ~elements_to_convert:_ ~module_expression = 56 | module_expression 57 | ;; 58 | 59 | let full_depth_module ~loc ~elements_to_convert:_ = [ [%stri include Shallow] ] 60 | let singleton_modules_structures ~loc:_ ~elements_to_convert:_ = [] 61 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | This repository contains open source software that is developed and 2 | maintained by [Jane Street][js]. 3 | 4 | Contributions to this project are welcome and should be submitted via 5 | GitHub pull requests. 6 | 7 | Signing contributions 8 | --------------------- 9 | 10 | We require that you sign your contributions. Your signature certifies 11 | that you wrote the patch or otherwise have the right to pass it on as 12 | an open-source patch. The rules are pretty simple: if you can certify 13 | the below (from [developercertificate.org][dco]): 14 | 15 | ``` 16 | Developer Certificate of Origin 17 | Version 1.1 18 | 19 | Copyright (C) 2004, 2006 The Linux Foundation and its contributors. 20 | 1 Letterman Drive 21 | Suite D4700 22 | San Francisco, CA, 94129 23 | 24 | Everyone is permitted to copy and distribute verbatim copies of this 25 | license document, but changing it is not allowed. 26 | 27 | 28 | Developer's Certificate of Origin 1.1 29 | 30 | By making a contribution to this project, I certify that: 31 | 32 | (a) The contribution was created in whole or in part by me and I 33 | have the right to submit it under the open source license 34 | indicated in the file; or 35 | 36 | (b) The contribution is based upon previous work that, to the best 37 | of my knowledge, is covered under an appropriate open source 38 | license and I have the right under that license to submit that 39 | work with modifications, whether created in whole or in part 40 | by me, under the same open source license (unless I am 41 | permitted to submit under a different license), as indicated 42 | in the file; or 43 | 44 | (c) The contribution was provided directly to me by some other 45 | person who certified (a), (b) or (c) and I have not modified 46 | it. 47 | 48 | (d) I understand and agree that this project and the contribution 49 | are public and that a record of the contribution (including all 50 | personal information I submit with it, including my sign-off) is 51 | maintained indefinitely and may be redistributed consistent with 52 | this project or the open source license(s) involved. 53 | ``` 54 | 55 | Then you just add a line to every git commit message: 56 | 57 | ``` 58 | Signed-off-by: Joe Smith 59 | ``` 60 | 61 | Use your real name (sorry, no pseudonyms or anonymous contributions.) 62 | 63 | If you set your `user.name` and `user.email` git configs, you can sign 64 | your commit automatically with git commit -s. 65 | 66 | [dco]: http://developercertificate.org/ 67 | [js]: https://opensource.janestreet.com/ 68 | -------------------------------------------------------------------------------- /src/typed_deriver_intf.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Ppxlib 3 | 4 | module Definitions = struct 5 | module type S = sig 6 | (** Either generates either [include Typed_fields_lib.SN with type record := record] 7 | or the fully generated partial signature if the number of parameter is above 5. *) 8 | val generate_include_signature_for_opaque 9 | : loc:location 10 | -> params:(core_type * (variance * injectivity)) list 11 | -> signature_item list 12 | 13 | (** Either generates either 14 | [include Typed_fields_lib.SN with type record := record and type t := t] or the 15 | fully generated partial signature if the number of parameter is above 5. *) 16 | val generate_include_signature 17 | : loc:location 18 | -> params:(core_type * (variance * injectivity)) list 19 | -> signature_item list 20 | end 21 | end 22 | 23 | module type Typed_deriver = sig 24 | include module type of struct 25 | include Definitions 26 | end 27 | 28 | val generate_packed_field_type_declaration 29 | : loc:Location.t 30 | -> params:(core_type * (variance * injectivity)) list 31 | -> unique_parameter_id:string 32 | -> t_type_constr:core_type 33 | -> type_declaration 34 | 35 | val generate_packed_t_prime_type_declaration 36 | : loc:Location.t 37 | -> params:(core_type * (variance * injectivity)) list 38 | -> core_type_params:core_type list 39 | -> field_type:core_type 40 | -> type_declaration 41 | 42 | val generate_packed_t_type_declaration 43 | : loc:Location.t 44 | -> core_type_params:core_type list 45 | -> type_declaration 46 | 47 | val disable_warning_37 : loc:Location.t -> attribute 48 | 49 | (** Generates 50 | 51 | {[ 52 | let : 53 | type . t 54 | -> = 55 | ]} 56 | 57 | e.g. 58 | 59 | {[ 60 | let name : type a_. ('a, a_) t -> string = fun x -> match x with ... 61 | ]} *) 62 | val generate_new_typed_function 63 | : loc:Location.t 64 | -> function_name:string 65 | -> core_type_params:core_type list 66 | -> unique_parameter_id:string 67 | -> ?arg_modes:Ppxlib_jane.Shim.Modes.t 68 | -> ?result_modes:Ppxlib_jane.Shim.Modes.t 69 | -> var_arrow_type:core_type 70 | -> constr_arrow_type:core_type 71 | -> function_body:expression 72 | -> name_of_first_parameter:Longident.t 73 | -> unit 74 | -> structure_item 75 | 76 | val at_least_one_subproduct : ('a * Type_kind.granularity) list -> bool 77 | end 78 | -------------------------------------------------------------------------------- /src/record_generator.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Ppxlib 3 | 4 | type t = label_declaration 5 | 6 | let name _ field = field.pld_name.txt 7 | let to_type field = field.pld_type 8 | 9 | let get_rhs_expression ~loc ~index:_ ~element:{ pld_name; _ } ~number_of_elements:_ = 10 | let open (val Syntax.builder loc) in 11 | pexp_field [%expr record] (Located.mk (Lident pld_name.txt)) 12 | ;; 13 | 14 | let disable_warning_23 ~loc = 15 | let open (val Syntax.builder loc) in 16 | attribute 17 | ~name:(Located.mk "ocaml.warning") 18 | ~payload:(PStr [ pstr_eval (estring "-23") [] ]) 19 | ;; 20 | 21 | let set_rhs_expression 22 | ~loc 23 | ~index:_ 24 | ~element:{ pld_name; _ } 25 | ~number_of_elements:_ 26 | ~expression_to_set 27 | = 28 | let open (val Syntax.builder loc) in 29 | let rhs = 30 | pexp_record 31 | [ Located.mk (Lident pld_name.txt), expression_to_set ] 32 | (Some [%expr record]) 33 | in 34 | { rhs with pexp_attributes = [ disable_warning_23 ~loc ] } 35 | ;; 36 | 37 | let create_expression ~loc ~constructor_declarations ~local = 38 | let open (val Syntax.builder loc) in 39 | let create_record = 40 | pexp_record 41 | (List.map constructor_declarations ~f:(fun (({ pld_name; _ }, _), _) -> 42 | Located.mk (Lident pld_name.txt), [%expr [%e evar pld_name.txt]])) 43 | None 44 | in 45 | (* create fields and then create record *) 46 | List.fold 47 | (List.rev constructor_declarations) 48 | ~init:create_record 49 | ~f:(fun acc (({ pld_name; _ }, granularity), constructor) -> 50 | let expr = 51 | match granularity with 52 | | Type_kind.Shallow -> 53 | [%expr __ppx_typed_fields_creator_f [%e econstruct constructor None]] 54 | | Type_kind.Deep _ -> 55 | let constructor_expression = 56 | pexp_construct 57 | (Lident (pld_name.txt |> String.capitalize) |> Located.mk) 58 | (Some (pexp_ident (Lident "x" |> Located.mk))) 59 | in 60 | let subproduct_function = 61 | let subproduct_module_name = 62 | pld_name.txt |> String.capitalize |> Type_kind.append_functor_parameter 63 | in 64 | match local with 65 | | false -> 66 | pexp_ident (Ldot (Lident subproduct_module_name, "create") |> Located.mk) 67 | | true -> 68 | pexp_ident 69 | (Ldot (Lident subproduct_module_name, "create_local") |> Located.mk) 70 | in 71 | [%expr 72 | [%e subproduct_function] 73 | { f = 74 | (fun x -> 75 | __ppx_typed_fields_creator_f [%e constructor_expression] [@nontail]) 76 | }] 77 | in 78 | pexp_let 79 | Immutable 80 | Nonrecursive 81 | [ value_binding ~pat:(pvar pld_name.txt) ~expr ~modes:[] ] 82 | acc) 83 | ;; 84 | -------------------------------------------------------------------------------- /typed_field_map/sexp_serializers.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | 3 | module Make (Map : The_map_intf.S_plain) = struct 4 | module Typed_field = Map.Key 5 | 6 | type to_sexper = { f : 'a. 'a Typed_field.t -> 'a Map.Data.t -> Sexp.t } 7 | type of_sexper = { f : 'a. 'a Map.Key.t -> Sexp.t -> 'a Map.Data.t } 8 | type defaulter = { f : 'a. 'a Map.Key.t -> 'a Map.Data.t option } 9 | 10 | let default_defaulter = { f = (fun _ -> None) } 11 | 12 | let sexp_of_t (to_sexper : to_sexper) (t : Map.t) : Sexp.t = 13 | let module P = Typed_field.Packed in 14 | let sexp_of_field { P.f = T key } = 15 | let key_sexp = P.sexp_of_t { f = T key } in 16 | let data_sexp = to_sexper.f key (Map.find t key) in 17 | Sexp.List [ key_sexp; data_sexp ] 18 | in 19 | List (List.map Typed_field.Packed.all ~f:sexp_of_field) 20 | ;; 21 | 22 | module Optional_map = struct 23 | module T = struct 24 | type 'a t = 'a Map.Data.t option 25 | end 26 | 27 | include The_map.Make (Map.Key) (T) 28 | 29 | let empty = create { f = (fun _ -> None) } 30 | end 31 | 32 | let raise_invalid_sexp sexp = 33 | raise_s 34 | [%message 35 | "Cannot deserialize typed_field_map. Reason: Unrecognized sexp:" 36 | ~_:(sexp : Sexp.t)] 37 | ;; 38 | 39 | let t_of_sexp ?(default = default_defaulter) (of_sexper : of_sexper) (sexp : Sexp.t) 40 | : Map.t 41 | = 42 | match sexp with 43 | | Sexp.Atom _ -> raise_invalid_sexp sexp 44 | | List l -> 45 | let map_with_parsed_results = 46 | List.fold l ~init:Optional_map.empty ~f:(fun acc -> function 47 | | List [ key_sexp; data_sexp ] -> 48 | let { f = T key } = Typed_field.Packed.t_of_sexp key_sexp in 49 | let data = of_sexper.f key data_sexp in 50 | (match Optional_map.find acc key with 51 | | None -> Optional_map.set acc ~key ~data:(Some data) 52 | | Some _ -> 53 | let duplicate_field = Typed_field.name key in 54 | raise_s 55 | [%message 56 | "Cannot deserialize typed_field_map. Reason: duplicate field:" 57 | (duplicate_field : string)]) 58 | | _ -> raise_invalid_sexp sexp) 59 | in 60 | Map.create 61 | { Map.f = 62 | (fun f -> 63 | match 64 | Optional_map.find map_with_parsed_results (Typed_field.globalize0 f) 65 | with 66 | | None -> 67 | (match default.f f with 68 | | Some data -> data 69 | | None -> 70 | let missing_field = Typed_field.name f in 71 | raise_s 72 | [%message 73 | "Cannot deserialize typed_field_map. Reason: missing field:" 74 | (missing_field : string)]) 75 | | Some data -> data) 76 | } 77 | ;; 78 | end 79 | -------------------------------------------------------------------------------- /src/typed_deriver_variants.mli: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Ppxlib 3 | 4 | (** Generates the anonymous records and gives them a concrete name. e.g. (Also attaches 5 | [@@deriving typed_fields] if needed.) 6 | 7 | {[ 8 | type rgb = 9 | { r : int 10 | ; g : int 11 | ; b : int 12 | } 13 | 14 | type 'x rgbx = 15 | { r : int 16 | ; g : int 17 | ; b : int 18 | ; x : 'x 19 | } 20 | [@@deriving typed_fields] 21 | ]} *) 22 | val generate_anonymous_records_sig 23 | : loc:location 24 | -> elements_to_convert:Variant_kind_generator.supported_constructor_declaration list 25 | -> signature_item list 26 | 27 | (** Generates the anonymous records and gives them a concrete name. e.g. (Also attaches 28 | [@@deriving typed_fields] if needed.) 29 | 30 | {[ 31 | type rgb = 32 | { r : int 33 | ; g : int 34 | ; b : int 35 | } 36 | 37 | type 'x rgbx = 38 | { r : int 39 | ; g : int 40 | ; b : int 41 | ; x : 'x 42 | } 43 | ]} *) 44 | val generate_anonymous_records_str 45 | : loc:location 46 | -> elements_to_convert:Variant_kind_generator.supported_constructor_declaration list 47 | -> structure_item list 48 | 49 | (** Generates the tuples module and gives them a concrete name. e.g. (Also attaches 50 | [@@deriving typed_fields] if needed.) 51 | 52 | {[ 53 | type rgb = int * int * string 54 | type 'x rgbx = 'x * float * 'x [@@deriving typed_fields] 55 | ]} *) 56 | val generate_tuples_sig 57 | : loc:location 58 | -> elements_to_convert:Variant_kind_generator.supported_constructor_declaration list 59 | -> signature_item list 60 | 61 | (** Generates the tuples module and gives them a concrete name. e.g. (Also attaches 62 | [@@deriving typed_fields] if needed.) 63 | 64 | {[ 65 | type rgb = int * int * string 66 | type 'x rgbx = 'x * float * 'x [@@deriving typed_fields] 67 | ]} *) 68 | val generate_tuples_str 69 | : loc:location 70 | -> elements_to_convert:Variant_kind_generator.supported_constructor_declaration list 71 | -> structure_item list 72 | 73 | (* Generate a Typed_fields(_t | of_x) structure item given a specific implementation 74 | module for how to handle the specific conversions like how the names for the 75 | typed_fields constructors are determined and how setter/getter functions work.*) 76 | val gen_str 77 | : (module Variant_kind_generator.S) 78 | -> original_type:core_type option 79 | -> original_kind:type_kind 80 | -> loc:location 81 | -> elements_to_convert:Variant_kind_generator.supported_constructor_declaration list 82 | -> expand_typed_variants: 83 | (loc:location -> rec_flag -> type_declaration list -> module_expr) 84 | -> params:(core_type * (variance * injectivity)) list 85 | -> td_case:Variant_kind_generator.type_case 86 | -> structure_item list 87 | 88 | (* Generates packed with value type, e.g. 89 | 90 | type ('a, 'b, 'c, 'd) packed_with_value = 91 | | T : ('a, 'b, 'c, 'd, 'r) t * 'r -> ('a, 'b, 'c, 'd) packed_with_value 92 | *) 93 | val generate_packed_with_value_type 94 | : loc:location 95 | -> params:(core_type * (variance * injectivity)) list 96 | -> core_type_params:core_type list 97 | -> unique_parameter_id:label 98 | -> type_declaration 99 | 100 | include Typed_deriver.S 101 | -------------------------------------------------------------------------------- /src/generic_generator.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Ppxlib 3 | open Ppxlib_jane 4 | 5 | (* Generates `type _ t = A : a | B : b ...` type *) 6 | let gen_t 7 | (type a) 8 | ~loc 9 | ~original_type 10 | ~original_kind 11 | ~(elements_to_convert : (a * Type_kind.granularity) list) 12 | ~generate_constructors 13 | ~params 14 | ~upper_name 15 | = 16 | let open (val Syntax.builder loc) in 17 | let core_type_params = List.map params ~f:(fun (core_type_, _) -> core_type_) in 18 | let upper = 19 | Type_kind.upper 20 | ~loc 21 | ~manifest_type:original_type 22 | ~original_kind 23 | ~params 24 | ~name:upper_name 25 | in 26 | let constructor_declarations = 27 | generate_constructors ~loc ~elements_to_convert ~core_type_params 28 | in 29 | let t = 30 | let is_immediate = 31 | List.for_all constructor_declarations ~f:(fun (_, decl) -> 32 | match decl.pcd_args with 33 | | Pcstr_tuple [] -> true 34 | | _ -> false) 35 | in 36 | let jkind_annotation, attributes = 37 | if is_immediate 38 | then None, [] 39 | else 40 | ( Some 41 | { pjkind_loc = loc 42 | ; pjkind_desc = 43 | Pjk_mod 44 | ( { pjkind_loc = loc; pjkind_desc = Pjk_abbreviation "value" } 45 | , [ Loc.make ~loc (Mode "contended") 46 | ; Loc.make ~loc (Mode "non_float") 47 | ; Loc.make ~loc (Mode "portable") 48 | ] ) 49 | } 50 | , [ attribute 51 | ~name:{ loc; txt = "unsafe_allow_any_mode_crossing" } 52 | ~payload:(PStr []) 53 | ] ) 54 | in 55 | type_declaration 56 | ~private_:Public 57 | ~manifest:None 58 | ~name:(Located.mk Type_kind.internal_gadt_name) 59 | ~params:(params @ [ ptyp_any, (NoVariance, Injective) ]) 60 | ~cstrs:[] 61 | ~kind:(Ptype_variant (List.map constructor_declarations ~f:snd)) 62 | ?jkind_annotation 63 | ~attrs:attributes 64 | () 65 | in 66 | let internal_gadt_rename = 67 | let unique_id = 68 | Type_kind.generate_unique_id (Type_kind.generate_core_type_params params) 69 | in 70 | let t_params = params @ [ ptyp_var unique_id, (NoVariance, NoInjectivity) ] in 71 | let core_type_params = List.map t_params ~f:(fun (x, _) -> x) in 72 | type_declaration 73 | ~name:(Located.mk "t") 74 | ~params:t_params 75 | ~cstrs:[] 76 | ~private_:Public 77 | ~kind:Ptype_abstract 78 | ~manifest: 79 | (Some 80 | (ptyp_constr 81 | (Lident Type_kind.internal_gadt_name |> Located.mk) 82 | core_type_params)) 83 | () 84 | in 85 | let internal_gadt_rename = 86 | { internal_gadt_rename with 87 | ptype_attributes = 88 | [ attribute 89 | ~name:(Located.mk "ocaml.warning") 90 | ~payload:(PStr [ pstr_eval (estring "-34") [] ]) 91 | ] 92 | } 93 | in 94 | let result : 'a Type_kind.gen_t_result = 95 | { gadt_t = t; upper; constructor_declarations; internal_gadt_rename } 96 | in 97 | result 98 | ;; 99 | 100 | let opaque_signature 101 | (module Specific_deriver : Typed_deriver.S) 102 | ~loc 103 | ~manifest_type 104 | ~original_kind 105 | ~params 106 | = 107 | let open (val Syntax.builder loc) in 108 | let upper = 109 | Type_kind.upper ~loc ~manifest_type ~original_kind ~params ~name:Names.derived_on_name 110 | in 111 | pmty_signature 112 | (signature 113 | ([ psig_type Nonrecursive [ upper ] ] 114 | @ Specific_deriver.generate_include_signature_for_opaque ~loc ~params)) 115 | ;; 116 | -------------------------------------------------------------------------------- /src/tuple_generator.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Ppxlib 3 | 4 | type t = core_type 5 | 6 | let name index _ = [%string "t_%{(index + 1)#Int}"] 7 | let to_type = Fn.id 8 | 9 | let get_rhs_expression ~loc ~index ~element:_ ~number_of_elements = 10 | let open (val Syntax.builder loc) in 11 | let pattern = 12 | ppat_tuple 13 | (List.init number_of_elements ~f:(fun i -> 14 | None, if i = index then ppat_var (Located.mk "x") else ppat_any)) 15 | Closed 16 | in 17 | pexp_let 18 | Immutable 19 | Nonrecursive 20 | [ value_binding ~pat:pattern ~expr:[%expr record] ~modes:[] ] 21 | [%expr x] 22 | ;; 23 | 24 | let set_rhs_expression ~loc ~index ~element:_ ~number_of_elements ~expression_to_set = 25 | let open (val Syntax.builder loc) in 26 | let generate_temp_idenfier i = [%string "x%{i#Int}"] in 27 | let pattern = 28 | ppat_tuple 29 | (List.init number_of_elements ~f:(fun i -> 30 | ( None 31 | , if i = index 32 | then ppat_any 33 | else generate_temp_idenfier i |> Located.mk |> ppat_var ))) 34 | Closed 35 | in 36 | let tuple_building_expression = 37 | pexp_tuple 38 | (List.init number_of_elements ~f:(fun i -> 39 | ( None 40 | , if i = index 41 | then expression_to_set 42 | else Lident (generate_temp_idenfier i) |> Located.mk |> pexp_ident ))) 43 | in 44 | pexp_let 45 | Immutable 46 | Nonrecursive 47 | [ value_binding ~pat:pattern ~expr:[%expr record] ~modes:[] ] 48 | tuple_building_expression 49 | ;; 50 | 51 | let create_expression ~loc ~constructor_declarations ~local = 52 | let open (val Syntax.builder loc) in 53 | let number_of_declarations = List.length constructor_declarations in 54 | let generate_temp_idenfier i = [%string "x%{i#Int}"] in 55 | let create_tuple = 56 | pexp_tuple 57 | (List.init number_of_declarations ~f:(fun i -> 58 | None, Lident (generate_temp_idenfier i) |> Located.mk |> pexp_ident)) 59 | in 60 | (* create fields and then creates a tuple. *) 61 | List.foldi 62 | (List.rev constructor_declarations) 63 | ~init:create_tuple 64 | ~f:(fun index acc ((element, granularity), constructor) -> 65 | let unreversed_index = number_of_declarations - index - 1 in 66 | let expr = 67 | match granularity with 68 | | Type_kind.Shallow -> 69 | [%expr __ppx_typed_fields_creator_f [%e econstruct constructor None]] 70 | | Type_kind.Deep _ -> 71 | let constructor_expression = 72 | pexp_construct 73 | (Lident (name unreversed_index element |> String.capitalize) |> Located.mk) 74 | (Some (pexp_ident (Lident "x" |> Located.mk))) 75 | in 76 | let subproduct_function = 77 | let subproduct_module_name = 78 | name unreversed_index element 79 | |> String.capitalize 80 | |> Type_kind.append_functor_parameter 81 | in 82 | match local with 83 | | false -> 84 | pexp_ident (Ldot (Lident subproduct_module_name, "create") |> Located.mk) 85 | | true -> 86 | pexp_ident 87 | (Ldot (Lident subproduct_module_name, "create_local") |> Located.mk) 88 | in 89 | [%expr 90 | [%e subproduct_function] 91 | { f = 92 | (fun x -> 93 | __ppx_typed_fields_creator_f [%e constructor_expression] [@nontail]) 94 | }] 95 | in 96 | pexp_let 97 | Immutable 98 | Nonrecursive 99 | [ value_binding 100 | ~pat:(pvar (generate_temp_idenfier unreversed_index)) 101 | ~expr 102 | ~modes:[] 103 | ] 104 | acc) 105 | ;; 106 | -------------------------------------------------------------------------------- /src/nothing_generator.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Ppxlib 3 | 4 | (* The structure items will be inserted after the type type 5 | definitions and before any other items.*) 6 | let extra_structure_items_to_insert loc = 7 | [ [%stri 8 | let unreachable_code = function 9 | | (_ : _ typed__t) -> . 10 | ;;] 11 | ] 12 | ;; 13 | 14 | let generate_constructor_declarations ~loc:_ ~elements_to_convert:_ ~core_type_params:_ = 15 | [] 16 | ;; 17 | 18 | let names_list ~loc ~elements_to_convert:_ = [%expr []] 19 | let name_function_body ~loc ~elements_to_convert:_ = [%expr unreachable_code] 20 | let path_function_body ~loc ~elements_to_convert:_ = [%expr unreachable_code] 21 | let ord_function_body ~loc ~elements_to_convert:_ = [%expr unreachable_code] 22 | let get_function_body ~loc ~elements_to_convert:_ = [%expr unreachable_code] 23 | 24 | let create_function_body ~loc ~constructor_declarations:_ ~local:_ = 25 | [%expr unreachable_code] 26 | ;; 27 | 28 | let type_ids ~loc:_ ~elements_to_convert:_ ~core_type_params:_ = [] 29 | let type_id_function_body ~loc ~elements_to_convert:_ = [%expr unreachable_code] 30 | let globalize0_function_body ~loc ~elements_to_convert:_ = [%expr unreachable_code] 31 | 32 | let sexp_of_t_body ~loc ~elements_to_convert:_ ~stack:_ = 33 | [%expr 34 | match packed with 35 | | (_ : t) -> .] 36 | ;; 37 | 38 | let all_body ~loc ~constructor_declarations:_ = [%expr []] 39 | let pack_body ~loc ~elements_to_convert:_ ~local:_ = [%expr unreachable_code] 40 | 41 | let globalize_packed_function_body ~loc ~elements_to_convert:_ = 42 | [%expr 43 | function 44 | | (_ : t) -> .] 45 | ;; 46 | 47 | let t_of_sexp_body ~loc ~elements_to_convert:_ = 48 | [%expr 49 | Base.raise_s 50 | (Sexplib.Sexp.List 51 | [ Sexplib.Sexp.Atom "Nothing has no constructors, so cannot convert to variant." 52 | ; sexp 53 | ])] 54 | ;; 55 | 56 | let which_function_body ~loc ~elements_to_convert:_ ~number_of_params = 57 | match number_of_params with 58 | | 0 -> 59 | [%expr 60 | function 61 | | (_ : derived_on) -> .] 62 | | _ -> 63 | [%expr 64 | function 65 | | (_ : _ derived_on) -> .] 66 | ;; 67 | 68 | let deep_functor_signature ~loc ~elements_to_convert:_ ~base_module_type = 69 | let open (val Syntax.builder loc) in 70 | psig_module (module_declaration (Some "Deep" |> Located.mk) base_module_type) 71 | ;; 72 | 73 | let deep_functor_structure ~loc ~elements_to_convert:_ ~module_expression = 74 | let open (val Syntax.builder loc) in 75 | pstr_module (module_binding ~name:(Some "Deep" |> Located.mk) ~expr:module_expression) 76 | ;; 77 | 78 | (** Generates the full depth module of a structure, e.g. 79 | [ module Constr1_subproduct = [%typed_field ...]; module Name_subproduct = [%typed_field ...]; ...; include Deep (Constr1_subproduct) (Name_subproduct) ] *) 80 | let full_depth_module ~loc ~elements_to_convert:_ ~expand_typed_variants:_ = 81 | [ [%stri include Deep] ] 82 | ;; 83 | 84 | (** Generates the full_depth module's signature. e.g. 85 | 86 | [ module Constr1_subproduct : module type of [%typed_field ...]; module Name_subproduct : module type of [%typed_field ...]; ...; include module type of Deep (Constr1_subproduct) (Name_subproduct) ] *) 87 | let full_depth_signature ~loc ~elements_to_convert:_ ~expand_typed_variants:_ = 88 | [ [%sigi: include module type of Deep] ] 89 | ;; 90 | 91 | (* Generates the signature for the singleton modules sent to Shallow 92 | 93 | [ 94 | module Singleton_for_t_1 : sig ... end; 95 | module Singleton_for_t_2 : sig ... end; 96 | ... 97 | 98 | ] 99 | *) 100 | let singleton_modules_signatures ~loc:_ ~elements_to_convert:_ = [] 101 | 102 | (* Generates the structure for the sigleton modules sent to Shallow 103 | 104 | [ 105 | module Singleton_for_t_1 = struct ... end; 106 | module Singleton_for_t_2 = struct ... end; 107 | ... 108 | 109 | ] 110 | *) 111 | let singleton_modules_structures ~loc:_ ~elements_to_convert:_ = [] 112 | -------------------------------------------------------------------------------- /typed_field_map/the_map_intf.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | 3 | module type Data = T1 4 | 5 | (** The reason that S_plain exists is because the To_other_map functor needs to take one 6 | as an argument, so they need to be split. 7 | 8 | One of these maps is isomorphic to the record that they are built out of. When 9 | creating the map via the creator function, you provide all possible keys and values. 10 | 11 | This means that [find] will always succeed. *) 12 | module type S_plain = sig 13 | type t [@@deriving sexp_of] 14 | 15 | module Key : Typed_fields_lib.Common.S 16 | module Data : Data 17 | 18 | type sexper = 19 | { individual : 'a. 'a Key.t -> 'a -> Sexp.t 20 | ; container : 'a. ('a -> Sexp.t) -> 'a Data.t -> Sexp.t 21 | } 22 | 23 | type creator = { f : 'a. 'a Key.t -> 'a Data.t } 24 | 25 | val create : ?sexper:sexper -> creator -> t 26 | val set : t -> key:'a Key.t -> data:'a Data.t -> t 27 | 28 | (** Find will always succeed *) 29 | val find : t -> 'a Key.t -> 'a Data.t 30 | 31 | val change : t -> 'a Key.t -> f:('a Data.t -> 'a Data.t) -> t 32 | 33 | module As_applicative : sig 34 | module type S = sig 35 | type 'a t = 'a Data.t 36 | 37 | val map : 'a t -> f:('a -> 'b) -> 'b t 38 | val all : 'a t list -> 'a list t 39 | end 40 | 41 | type creator = { f : 'a. 'a Key.t -> 'a } 42 | 43 | val transpose : (module S) -> t -> create:(creator -> 'a) -> 'a Data.t 44 | end 45 | end 46 | 47 | module type S = sig 48 | include S_plain 49 | 50 | module As_applicative : sig 51 | include module type of As_applicative 52 | 53 | module type S_for_other_map = sig 54 | (** This module is basically "Applicative", but with an additional type that can be 55 | used to translate to the applicative type. 56 | 57 | Typically these types will be something like 58 | 59 | {[ 60 | type 'a t = 'a Value.t 61 | type 'a s = 'a Form.t 62 | 63 | val translate : 'a Form.t Value.t -> 'a Form.t Value.t 64 | ]} 65 | 66 | [translate] probably doesn't need to do any work. It just exists to expose a 67 | type equality between ['a Data.t] and ['a s t]. *) 68 | 69 | type 'a t 70 | 71 | val map : 'a t -> f:('a -> 'b) -> 'b t 72 | val all : 'a t list -> 'a list t 73 | 74 | type 'a s 75 | 76 | val translate : 'a Data.t -> 'a s t 77 | end 78 | 79 | module To_other_map 80 | (A : S_for_other_map) 81 | (M : S_plain with type 'a Key.t = 'a Key.t and type 'a Data.t = 'a A.s) : sig 82 | val run : t -> M.t A.t 83 | end 84 | end 85 | end 86 | 87 | module For_records = struct 88 | (** This module type just extends [S] with a more ergonomic way to call 89 | [transpose_applicative] that works for records. 90 | 91 | It goes from: 92 | {[ 93 | let module Map = Typed_field_map.Make (Typed_field) (Deferred) in 94 | let map = Map.create { f } in 95 | Map.As_applicative.transpose (module Deferred) map ~create:(fun { f } -> 96 | Typed_field.create { f }) 97 | ]} 98 | 99 | To: 100 | {[ 101 | let module Map = Typed_field_map.Make_for_records (M.Typed_field) (Deferred) in 102 | Map.transpose_applicative { f } (module Deferred) 103 | ]} *) 104 | module type S = sig 105 | module Key : Typed_fields_lib.S 106 | include S with module Key := Key 107 | 108 | val transpose_applicative 109 | : creator 110 | -> (module As_applicative.S) 111 | -> Key.derived_on Data.t 112 | end 113 | end 114 | 115 | module type The_map = sig 116 | module type Data = Data 117 | module type S = S 118 | module type S_plain = S_plain 119 | 120 | module Make (Key : Typed_fields_lib.Common.S) (Data : Data) : 121 | S with module Key = Key and module Data = Data 122 | 123 | module Make_for_records (Key : Typed_fields_lib.S) (Data : Data) : 124 | For_records.S with module Key = Key and module Data = Data 125 | end 126 | -------------------------------------------------------------------------------- /src/subset_of.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Ppxlib 3 | 4 | let generate_str ~loc ~typ_name ~fields ~params ~super = 5 | let open (val Syntax.builder loc) in 6 | let of_suffix = if String.equal typ_name "t" then "" else [%string "_of_%{typ_name}"] in 7 | let function_name = [%string "superset_field%{of_suffix}"] in 8 | let core_type_params = Type_kind.generate_core_type_params params in 9 | let unique_parameter_id = Type_kind.generate_unique_id core_type_params in 10 | let parameters_as_constrs = 11 | List.map core_type_params ~f:(fun type_ -> 12 | match Ppxlib_jane.Shim.Core_type_desc.of_parsetree type_.ptyp_desc with 13 | | Ptyp_var (name, _) -> ptyp_constr (Lident name |> Located.mk) [] 14 | | _ -> type_) 15 | in 16 | let var_arrow_type = 17 | ptyp_constr 18 | (Ldot (super, "t") |> Located.mk) 19 | (core_type_params @ [ ptyp_var unique_parameter_id ]) 20 | in 21 | let constr_arrow_type = 22 | ptyp_constr 23 | (Ldot (super, "t") |> Located.mk) 24 | (parameters_as_constrs 25 | @ [ ptyp_constr (Located.mk (Lident unique_parameter_id)) [] ]) 26 | in 27 | let function_body = 28 | pexp_function 29 | (List.map fields ~f:(fun (label, param) -> 30 | let constr = label.pld_name.txt |> String.capitalize |> Lident |> Located.mk in 31 | let pat_payload = 32 | match (param : Type_kind.granularity) with 33 | | Deep _ -> Some (ppat_var (Located.mk "subproduct")) 34 | | Shallow -> None 35 | in 36 | let expr_payload = 37 | match param with 38 | | Deep _ -> Some (pexp_ident (Located.mk (Lident "subproduct"))) 39 | | Shallow -> None 40 | in 41 | case 42 | ~lhs:(ppat_construct constr pat_payload) 43 | ~rhs:[%expr [%e pexp_construct constr expr_payload]] 44 | ~guard:None)) 45 | in 46 | Typed_deriver.generate_new_typed_function 47 | ~loc 48 | ~function_name 49 | ~core_type_params 50 | ~unique_parameter_id 51 | ~arg_modes:(Ppxlib_jane.Shim.Modes.local ~loc) 52 | ~result_modes:(Ppxlib_jane.Shim.Modes.local ~loc) 53 | ~var_arrow_type 54 | ~constr_arrow_type 55 | ~name_of_first_parameter:(Ldot (Lident [%string "Typed_field%{of_suffix}"], "t")) 56 | ~function_body 57 | () 58 | ;; 59 | 60 | let generate_sig ~loc ~typ_name ~params ~super = 61 | let open (val Syntax.builder loc) in 62 | let of_suffix = if String.equal typ_name "t" then "" else [%string "_of_%{typ_name}"] in 63 | let function_name = [%string "superset_field%{of_suffix}"] in 64 | let typed_fields = Ldot (Lident [%string "Typed_field%{of_suffix}"], "t") in 65 | let core_type_params = Type_kind.generate_core_type_params params in 66 | let unique_parameter_id = Type_kind.generate_unique_id core_type_params in 67 | let parameter_names = 68 | List.filter_map core_type_params ~f:(fun { ptyp_desc; _ } -> 69 | match Ppxlib_jane.Shim.Core_type_desc.of_parsetree ptyp_desc with 70 | | Ptyp_var (name, _) -> Some (Located.mk name, None) 71 | | _ -> None) 72 | in 73 | let t_type_parameters = parameter_names @ [ Located.mk unique_parameter_id, None ] in 74 | let var_arrow_type = 75 | ptyp_constr 76 | (Ldot (super, "t") |> Located.mk) 77 | (core_type_params @ [ ptyp_var unique_parameter_id ]) 78 | in 79 | let function_type = 80 | ptyp_poly 81 | t_type_parameters 82 | (ptyp_arrow 83 | { arg_label = Nolabel 84 | ; arg_type = 85 | ptyp_constr 86 | (Located.mk typed_fields) 87 | (core_type_params @ [ ptyp_var unique_parameter_id ]) 88 | ; arg_modes = Ppxlib_jane.Shim.Modes.local ~loc 89 | } 90 | { result_type = var_arrow_type 91 | ; result_modes = Ppxlib_jane.Shim.Modes.local ~loc 92 | }) 93 | in 94 | psig_value 95 | (Ppxlib_jane.Shim.Value_description.create 96 | ~name:(Located.mk function_name) 97 | ~type_:function_type 98 | ~modalities:[] 99 | ~prim:[] 100 | ~loc) 101 | ;; 102 | -------------------------------------------------------------------------------- /src/tuple_kind_generator.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Ppxlib 3 | 4 | type t = core_type 5 | 6 | (* The structure items will be inserted after the type type 7 | definitions and before any other items.*) 8 | let extra_structure_items_to_insert _ = [] 9 | 10 | let constructor_declarations ~loc ~elements_to_convert ~core_type_params = 11 | Product_kind_generator.constructor_declarations 12 | (module Tuple_generator) 13 | ~loc 14 | ~elements_to_convert 15 | ~core_type_params 16 | ;; 17 | 18 | let names_list ~loc ~elements_to_convert = 19 | Product_kind_generator.names_list (module Tuple_generator) ~loc ~elements_to_convert 20 | ;; 21 | 22 | let name_function_body ~loc = Product_kind_generator.name_function_body ~loc 23 | 24 | let path_function_body ~loc ~elements_to_convert = 25 | Product_kind_generator.path_function_body 26 | (module Tuple_generator) 27 | ~loc 28 | ~elements_to_convert 29 | ;; 30 | 31 | let ord_function_body ~loc ~elements_to_convert = 32 | Product_kind_generator.ord_function_body 33 | (module Tuple_generator) 34 | ~loc 35 | ~elements_to_convert 36 | ;; 37 | 38 | let get_function_body ~loc ~elements_to_convert = 39 | Product_kind_generator.get_function_body 40 | (module Tuple_generator) 41 | ~loc 42 | ~elements_to_convert 43 | ;; 44 | 45 | let set_function_body ~loc ~elements_to_convert = 46 | Product_kind_generator.set_function_body 47 | (module Tuple_generator) 48 | ~loc 49 | ~elements_to_convert 50 | ;; 51 | 52 | let create_function_body ~loc ~constructor_declarations ~local = 53 | Product_kind_generator.create_function_body 54 | (module Tuple_generator) 55 | ~loc 56 | ~constructor_declarations 57 | ~local 58 | ;; 59 | 60 | let type_ids ~loc ~elements_to_convert ~core_type_params = 61 | Product_kind_generator.type_ids 62 | (module Tuple_generator) 63 | ~loc 64 | ~elements_to_convert 65 | ~core_type_params 66 | ;; 67 | 68 | let subproduct_type_id_modules ~loc ~elements_to_convert ~core_type_params = 69 | Product_kind_generator.subproduct_type_id_modules 70 | (module Tuple_generator) 71 | ~loc 72 | ~elements_to_convert 73 | ~core_type_params 74 | ;; 75 | 76 | let type_id_function_body ~loc ~elements_to_convert = 77 | Product_kind_generator.type_id_function_body 78 | (module Tuple_generator) 79 | ~loc 80 | ~elements_to_convert 81 | ;; 82 | 83 | let globalize0_function_body ~loc ~elements_to_convert = 84 | Product_kind_generator.globalize0_function_body 85 | (module Tuple_generator) 86 | ~loc 87 | ~elements_to_convert 88 | ;; 89 | 90 | let globalize_packed_function_body ~loc ~elements_to_convert = 91 | Product_kind_generator.globalize_packed_function_body 92 | (module Tuple_generator) 93 | ~loc 94 | ~elements_to_convert 95 | ;; 96 | 97 | let all_body ~loc ~constructor_declarations = 98 | Product_kind_generator.all_body (module Tuple_generator) ~loc ~constructor_declarations 99 | ;; 100 | 101 | let pack_body ~loc ~elements_to_convert = 102 | Product_kind_generator.pack_body (module Tuple_generator) ~loc ~elements_to_convert 103 | ;; 104 | 105 | let sexp_of_t_body ~loc ~elements_to_convert = 106 | Product_kind_generator.sexp_of_t_body (module Tuple_generator) ~loc ~elements_to_convert 107 | ;; 108 | 109 | let t_of_sexp_body ~loc ~elements_to_convert = 110 | Product_kind_generator.t_of_sexp_body (module Tuple_generator) ~loc ~elements_to_convert 111 | ;; 112 | 113 | let deep_functor_structure ~loc ~elements_to_convert ~module_expression = 114 | Product_kind_generator.deep_functor_structure 115 | (module Tuple_generator) 116 | ~loc 117 | ~elements_to_convert 118 | ~module_expression 119 | ;; 120 | 121 | let full_depth_module ~loc ~elements_to_convert = 122 | Product_kind_generator.full_depth_module 123 | (module Tuple_generator) 124 | ~loc 125 | ~elements_to_convert 126 | ;; 127 | 128 | let singleton_modules_structures ~loc ~elements_to_convert = 129 | Product_kind_generator.singleton_modules_structures 130 | (module Tuple_generator) 131 | ~loc 132 | ~elements_to_convert 133 | ;; 134 | -------------------------------------------------------------------------------- /src/record_kind_generator.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Ppxlib 3 | 4 | type t = label_declaration 5 | 6 | (* The structure items will be inserted after the type type 7 | definitions and before any other items.*) 8 | let extra_structure_items_to_insert _ = [] 9 | 10 | let constructor_declarations ~loc ~elements_to_convert ~core_type_params = 11 | Product_kind_generator.constructor_declarations 12 | (module Record_generator) 13 | ~loc 14 | ~elements_to_convert 15 | ~core_type_params 16 | ;; 17 | 18 | let names_list ~loc ~elements_to_convert = 19 | Product_kind_generator.names_list (module Record_generator) ~loc ~elements_to_convert 20 | ;; 21 | 22 | let name_function_body ~loc = Product_kind_generator.name_function_body ~loc 23 | 24 | let path_function_body ~loc ~elements_to_convert = 25 | Product_kind_generator.path_function_body 26 | (module Record_generator) 27 | ~loc 28 | ~elements_to_convert 29 | ;; 30 | 31 | let ord_function_body ~loc ~elements_to_convert = 32 | Product_kind_generator.ord_function_body 33 | (module Record_generator) 34 | ~loc 35 | ~elements_to_convert 36 | ;; 37 | 38 | let get_function_body ~loc ~elements_to_convert = 39 | Product_kind_generator.get_function_body 40 | (module Record_generator) 41 | ~loc 42 | ~elements_to_convert 43 | ;; 44 | 45 | let set_function_body ~loc ~elements_to_convert = 46 | Product_kind_generator.set_function_body 47 | (module Record_generator) 48 | ~loc 49 | ~elements_to_convert 50 | ;; 51 | 52 | let create_function_body ~loc ~constructor_declarations = 53 | Product_kind_generator.create_function_body 54 | (module Record_generator) 55 | ~loc 56 | ~constructor_declarations 57 | ;; 58 | 59 | let subproduct_type_id_modules ~loc ~elements_to_convert = 60 | Product_kind_generator.subproduct_type_id_modules 61 | (module Record_generator) 62 | ~loc 63 | ~elements_to_convert 64 | ;; 65 | 66 | let type_ids ~loc ~elements_to_convert ~core_type_params = 67 | Product_kind_generator.type_ids 68 | (module Record_generator) 69 | ~loc 70 | ~elements_to_convert 71 | ~core_type_params 72 | ;; 73 | 74 | let type_id_function_body ~loc ~elements_to_convert = 75 | Product_kind_generator.type_id_function_body 76 | (module Record_generator) 77 | ~loc 78 | ~elements_to_convert 79 | ;; 80 | 81 | let globalize0_function_body ~loc ~elements_to_convert = 82 | Product_kind_generator.globalize0_function_body 83 | (module Record_generator) 84 | ~loc 85 | ~elements_to_convert 86 | ;; 87 | 88 | let globalize_packed_function_body ~loc ~elements_to_convert = 89 | Product_kind_generator.globalize_packed_function_body 90 | (module Record_generator) 91 | ~loc 92 | ~elements_to_convert 93 | ;; 94 | 95 | let all_body ~loc ~constructor_declarations = 96 | Product_kind_generator.all_body (module Record_generator) ~loc ~constructor_declarations 97 | ;; 98 | 99 | let pack_body ~loc ~elements_to_convert ~local = 100 | Product_kind_generator.pack_body 101 | (module Record_generator) 102 | ~loc 103 | ~elements_to_convert 104 | ~local 105 | ;; 106 | 107 | let sexp_of_t_body ~loc ~elements_to_convert ~stack = 108 | Product_kind_generator.sexp_of_t_body 109 | (module Record_generator) 110 | ~loc 111 | ~elements_to_convert 112 | ~stack 113 | ;; 114 | 115 | let t_of_sexp_body ~loc ~elements_to_convert = 116 | Product_kind_generator.t_of_sexp_body 117 | (module Record_generator) 118 | ~loc 119 | ~elements_to_convert 120 | ;; 121 | 122 | let deep_functor_structure ~loc ~elements_to_convert ~module_expression = 123 | Product_kind_generator.deep_functor_structure 124 | (module Record_generator) 125 | ~loc 126 | ~elements_to_convert 127 | ~module_expression 128 | ;; 129 | 130 | let full_depth_module ~loc ~elements_to_convert = 131 | Product_kind_generator.full_depth_module 132 | (module Record_generator) 133 | ~loc 134 | ~elements_to_convert 135 | ;; 136 | 137 | let singleton_modules_structures ~loc ~elements_to_convert = 138 | Product_kind_generator.singleton_modules_structures 139 | (module Record_generator) 140 | ~loc 141 | ~elements_to_convert 142 | ;; 143 | -------------------------------------------------------------------------------- /typed_field_map/the_map.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | include The_map_intf 3 | 4 | module Make_plain (Key : Typed_fields_lib.Common.S) (Data : Data) = struct 5 | module Key_mod = struct 6 | include Key 7 | 8 | let type_id = Type_ids.type_id 9 | let sexp_of_t _ t = Packed.sexp_of_t { f = T t } 10 | end 11 | 12 | include 13 | Univ_map.Make 14 | (Key_mod) 15 | (struct 16 | include Data 17 | 18 | let sexp_of_t _ = Sexplib.Conv.sexp_of_opaque 19 | end) 20 | 21 | module Key = Key_mod 22 | 23 | let find t key = find_exn t (Key.globalize0 key) 24 | let change t key ~f = change_exn t (Key.globalize0 key) ~f 25 | let set t ~key ~data = set t ~key:(Key.globalize0 key) ~data 26 | 27 | type creator = { f : 'a. 'a Key.t -> 'a Data.t } 28 | 29 | let create creator = 30 | List.fold Key.Packed.all ~init:empty ~f:(fun acc { f = Key.Packed.T t } -> 31 | add_exn acc ~key:t ~data:(creator.f t)) 32 | ;; 33 | end 34 | 35 | module Make (Key : Typed_fields_lib.Common.S) (Data : Data) = struct 36 | module Key = Key 37 | module Data = Data 38 | module Base = Make_plain (Key) (Data) 39 | 40 | type creator = Base.creator = { f : 'a. 'a Key.t -> 'a Data.t } 41 | 42 | type sexper = 43 | { individual : 'a. 'a Key.t -> 'a -> Sexp.t 44 | ; container : 'a. ('a -> Sexp.t) -> 'a Data.t -> Sexp.t 45 | } 46 | 47 | type t = 48 | { base : Base.t 49 | ; sexper : sexper option 50 | } 51 | 52 | let create ?sexper creator = { base = Base.create creator; sexper } 53 | let set t ~key ~data = { t with base = Base.set t.base ~key ~data } 54 | let change t key ~f = { t with base = Base.change t.base key ~f } 55 | let find t key = Base.find t.base key 56 | 57 | module As_applicative = struct 58 | module type S = sig 59 | type 'a t = 'a Data.t 60 | 61 | val map : 'a t -> f:('a -> 'b) -> 'b t 62 | val all : 'a t list -> 'a list t 63 | end 64 | 65 | module type S_for_other_map = sig 66 | type 'a t 67 | 68 | val map : 'a t -> f:('a -> 'b) -> 'b t 69 | val all : 'a t list -> 'a list t 70 | 71 | type 'a s 72 | 73 | val translate : 'a Data.t -> 'a s t 74 | end 75 | 76 | module Id = struct 77 | type 'a t = 'a 78 | end 79 | 80 | module Id_map = Make_plain (Key) (Id) 81 | 82 | type creator = { f : 'a. 'a Key.t -> 'a } 83 | 84 | let transpose (module A : S) t ~create = 85 | t.base 86 | |> Base.to_alist 87 | |> List.map ~f:(function T (key, a) -> 88 | A.map a ~f:(fun a -> Id_map.Packed.T (key, a))) 89 | |> A.all 90 | |> A.map ~f:(fun all -> 91 | let map = Id_map.of_alist_exn all in 92 | create { f = (fun k -> Id_map.find map (Key.globalize0 k)) }) 93 | ;; 94 | 95 | module To_other_map 96 | (A : S_for_other_map) 97 | (M : S_plain with type 'a Key.t = 'a Key.t and type 'a Data.t = 'a A.s) = 98 | struct 99 | module Inner = 100 | Make_plain 101 | (Key) 102 | (struct 103 | type 'a t = 'a A.s 104 | end) 105 | 106 | let run t = 107 | t.base 108 | |> Base.to_alist 109 | |> List.map ~f:(function T (key, a) -> 110 | A.map (A.translate a) ~f:(fun a -> Inner.Packed.T (key, a))) 111 | |> A.all 112 | |> A.map ~f:(fun alist -> 113 | let m = Inner.of_alist_exn alist in 114 | M.create { f = (fun k -> Inner.find m (Key.globalize0 k)) }) 115 | ;; 116 | end 117 | end 118 | 119 | let sexp_of_t t = 120 | match t.sexper with 121 | | None -> Base.sexp_of_t t.base 122 | | Some sexpers -> 123 | t.base 124 | |> Base.to_alist 125 | |> List.map ~f:(function T (k, v) -> 126 | let sexp_of_a = sexpers.container [%eta1 sexpers.individual k] v in 127 | Sexp.List [ Key.Packed.sexp_of_t { f = T k }; sexp_of_a ]) 128 | |> Sexp.List 129 | ;; 130 | end 131 | 132 | module Make_for_records (Key : Typed_fields_lib.S) (Data : Data) = struct 133 | let create_derived_on = Key.create 134 | 135 | module Original_key = Key 136 | include Make (Key) (Data) 137 | 138 | let transpose_applicative { f } (module A : As_applicative.S) = 139 | let t = create { f } in 140 | As_applicative.transpose (module A) t ~create:(fun { f } -> create_derived_on { f }) 141 | ;; 142 | 143 | (* Re-export Key as Typed_fields_lib.S *) 144 | module Key = Original_key 145 | end 146 | -------------------------------------------------------------------------------- /src/type_kind.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Ppxlib 3 | include Type_kind_intf.Definitions 4 | 5 | let internal_gadt_name = "typed__t" 6 | 7 | let generate_core_type_params params = 8 | List.map params ~f:(fun (core_type, _) -> core_type) 9 | ;; 10 | 11 | let generate_unique_name ~start ~identifiers_to_avoid = 12 | let rec loop curr = 13 | if Set.mem identifiers_to_avoid curr then loop (curr ^ "_") else curr 14 | in 15 | loop start 16 | ;; 17 | 18 | let generate_local_type_name td = 19 | let finder_of_type_names_in_use = 20 | object 21 | inherit [(string, String.comparator_witness) Set.t] Ast_traverse.fold as super 22 | 23 | method! core_type ctype acc = 24 | let acc = 25 | match ctype.ptyp_desc with 26 | | Ptyp_constr ({ txt = Lident name; _ }, _) -> Set.add acc name 27 | | _ -> acc 28 | in 29 | super#core_type ctype acc 30 | end 31 | in 32 | let identifiers_to_avoid = 33 | finder_of_type_names_in_use#type_declaration td (Set.empty (module String)) 34 | in 35 | generate_unique_name ~start:"local_type" ~identifiers_to_avoid 36 | ;; 37 | 38 | let generate_manifest_type_constr ~loc ~name ~params = 39 | let open (val Syntax.builder loc) in 40 | let core_type_params = List.map params ~f:(fun (core_type, _) -> core_type) in 41 | ptyp_constr (Located.mk (Lident name)) core_type_params 42 | ;; 43 | 44 | let disable_warning_32 ~loc = 45 | let open (val Syntax.builder loc) in 46 | attribute 47 | ~name:(Located.mk "ocaml.warning") 48 | ~payload:(PStr [ pstr_eval (estring "-32") [] ]) 49 | ;; 50 | 51 | let generate_creator_type_declaration 52 | ~loc 53 | ~unique_parameter_id 54 | ~core_type_params 55 | ~params 56 | ~t_name 57 | = 58 | let open (val Syntax.builder loc) in 59 | let creator_function_type = 60 | ptyp_poly 61 | [ Located.mk unique_parameter_id, None ] 62 | (ptyp_arrow 63 | { arg_label = Nolabel 64 | ; arg_type = 65 | ptyp_constr 66 | (Located.mk (Lident t_name)) 67 | (core_type_params @ [ ptyp_var unique_parameter_id ]) 68 | ; arg_modes = Ppxlib_jane.Shim.Modes.local ~loc 69 | } 70 | { result_type = ptyp_var unique_parameter_id; result_modes = [] }) 71 | in 72 | type_declaration 73 | ~name:(Located.mk "creator") 74 | ~params 75 | ~cstrs:[] 76 | ~private_:Public 77 | ~manifest:None 78 | ~kind: 79 | (Ptype_record 80 | [ label_declaration 81 | ~name:(Located.mk "f") 82 | ~mutable_:Immutable 83 | ~type_:creator_function_type 84 | ~modalities:[] 85 | ]) 86 | () 87 | ;; 88 | 89 | let attribute_remover = 90 | object 91 | inherit Ast_traverse.map as super 92 | 93 | method! core_type ctype = 94 | let ctype = { ctype with ptyp_attributes = [] } in 95 | super#core_type ctype 96 | 97 | method! label_declaration ld = 98 | let ld = { ld with pld_attributes = [] } in 99 | super#label_declaration ld 100 | 101 | method! row_field rf = 102 | let rf = { rf with prf_attributes = [] } in 103 | super#row_field rf 104 | 105 | method! constructor_declaration cd = 106 | let cd = { cd with pcd_attributes = [] } in 107 | super#constructor_declaration cd 108 | end 109 | ;; 110 | 111 | let upper ~loc ~manifest_type ~original_kind ~params ~name = 112 | let open (val Syntax.builder loc) in 113 | type_declaration 114 | ~name:(Located.mk name) 115 | ~params 116 | ~cstrs:[] 117 | ~kind:original_kind 118 | ~private_:Public 119 | ~manifest:manifest_type 120 | () 121 | ;; 122 | 123 | let append_functor_parameter prefix = [%string "%{prefix}_subproduct"] 124 | 125 | let generate_param_name_to_index ~core_type_params = 126 | List.foldi 127 | core_type_params 128 | ~init:(Map.empty (module String)) 129 | ~f:(fun index acc { ptyp_desc; _ } -> 130 | match Ppxlib_jane.Shim.Core_type_desc.of_parsetree ptyp_desc with 131 | | Ptyp_var (name, _) -> Map.set acc ~key:name ~data:index 132 | | _ -> acc) 133 | ;; 134 | 135 | let original_param_to_functor_param original_name param_name_to_index = 136 | match Map.find param_name_to_index original_name with 137 | | Some index -> Ldot (Lident [%string "T%{(index + 1)#Int}"], "t") 138 | | None -> Ldot (Lident "T", "t") 139 | ;; 140 | 141 | let create_mapper ~loc param_name_to_index = 142 | let open (val Syntax.builder loc) in 143 | object 144 | inherit Ast_traverse.map as super 145 | 146 | method! core_type type_ = 147 | match Ppxlib_jane.Shim.Core_type_desc.of_parsetree type_.ptyp_desc with 148 | | Ptyp_var (name, _) -> 149 | ptyp_constr 150 | (original_param_to_functor_param name param_name_to_index |> Located.mk) 151 | [] 152 | | _ -> super#core_type type_ 153 | end 154 | ;; 155 | 156 | let generate_unique_id params = 157 | let existing = 158 | List.filter_map params ~f:(fun core_type -> 159 | match Ppxlib_jane.Shim.Core_type_desc.of_parsetree core_type.ptyp_desc with 160 | | Ptyp_var (id, _) -> Some id 161 | | _ -> None) 162 | |> Set.of_list (module String) 163 | in 164 | let rec loop curr = if Set.mem existing curr then loop (curr ^ "_") else curr in 165 | loop "result" 166 | ;; 167 | 168 | let or_patterns (patterns : pattern list) ~(loc : Location.t) = 169 | let open (val Syntax.builder loc) in 170 | List.reduce_exn patterns ~f:ppat_or 171 | ;; 172 | 173 | let exclave_if_local exp ~loc ~local = 174 | match local with 175 | | false -> exp 176 | | true -> [%expr [%e exp]] 177 | ;; 178 | 179 | let exclave_if_stack exp ~loc ~stack = 180 | match stack with 181 | | false -> exp 182 | | true -> [%expr [%e exp]] 183 | ;; 184 | -------------------------------------------------------------------------------- /src/typed_deriver.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Ppxlib 3 | open Ppxlib_jane 4 | include Typed_deriver_intf.Definitions 5 | 6 | let generate_packed_field_type_declaration 7 | ~loc 8 | ~params 9 | ~unique_parameter_id 10 | ~t_type_constr 11 | = 12 | let open (val Syntax.builder loc) in 13 | let field_params = 14 | params @ [ ptyp_var unique_parameter_id, (NoVariance, NoInjectivity) ] 15 | in 16 | type_declaration 17 | ~name:(Located.mk "field") 18 | ~params:field_params 19 | ~cstrs:[] 20 | ~kind:Ptype_abstract 21 | ~private_:Public 22 | ~manifest:(Some t_type_constr) 23 | () 24 | ;; 25 | 26 | let generate_packed_t_prime_type_declaration ~loc ~params ~core_type_params ~field_type = 27 | let open (val Syntax.builder loc) in 28 | type_declaration 29 | ~name:(Located.mk "t'") 30 | ~params 31 | ~cstrs:[] 32 | ~private_:Public 33 | ~manifest:None 34 | ~kind: 35 | (Ptype_variant 36 | [ constructor_declaration 37 | ~name:(Located.mk "T") 38 | ~args: 39 | (Pcstr_tuple 40 | [ field_type |> Ppxlib_jane.Shim.Pcstr_tuple_arg.of_core_type ]) 41 | ~res:(Some (ptyp_constr (Lident "t'" |> Located.mk) core_type_params)) 42 | ]) 43 | ~jkind_annotation: 44 | { pjkind_loc = loc 45 | ; pjkind_desc = 46 | Pjk_mod 47 | ( { pjkind_loc = loc; pjkind_desc = Pjk_abbreviation "value" } 48 | , [ Loc.make ~loc (Mode "contended") 49 | ; Loc.make ~loc (Mode "non_float") 50 | ; Loc.make ~loc (Mode "portable") 51 | ] ) 52 | } 53 | ~attrs: 54 | [ attribute 55 | ~name:(Loc.make ~loc "unsafe_allow_any_mode_crossing") 56 | ~payload:(PStr []) 57 | ] 58 | () 59 | ;; 60 | 61 | let generate_packed_t_type_declaration ~loc ~core_type_params = 62 | let open (val Syntax.builder loc) in 63 | let ty = 64 | type_declaration 65 | ~name:(Located.mk "t") 66 | ~cstrs:[] 67 | ~private_:Public 68 | ~manifest:None 69 | ~params:[] 70 | ~kind: 71 | (Ptype_record 72 | [ label_declaration 73 | ~name:(Located.mk "f") 74 | ~mutable_:Immutable 75 | ~type_: 76 | (ptyp_poly 77 | (List.filter_map core_type_params ~f:(fun param -> 78 | match 79 | Ppxlib_jane.Shim.Core_type_desc.of_parsetree param.ptyp_desc 80 | with 81 | | Ptyp_var (name, _) -> Some (Located.mk name, None) 82 | | _ -> None)) 83 | (ptyp_constr (Lident "t'" |> Located.mk) core_type_params)) 84 | ~modalities:[] 85 | ]) 86 | () 87 | in 88 | let attribute = attribute ~name:(Located.mk "unboxed") ~payload:(PStr []) in 89 | { ty with ptype_attributes = [ attribute ] } 90 | ;; 91 | 92 | let disable_warning_37 ~loc = 93 | let open (val Syntax.builder loc) in 94 | attribute 95 | ~name:(Located.mk "ocaml.warning") 96 | ~payload:(PStr [ pstr_eval (estring "-37") [] ]) 97 | ;; 98 | 99 | let generate_new_typed_function 100 | ~loc 101 | ~function_name 102 | ~core_type_params 103 | ~unique_parameter_id 104 | ?(arg_modes = []) 105 | ?(result_modes = []) 106 | ~var_arrow_type 107 | ~constr_arrow_type 108 | ~function_body 109 | ~name_of_first_parameter 110 | () 111 | = 112 | let open (val Syntax.builder loc) in 113 | let parameter_names = 114 | List.filter_map core_type_params ~f:(fun { ptyp_desc; _ } -> 115 | match Ppxlib_jane.Shim.Core_type_desc.of_parsetree ptyp_desc with 116 | | Ptyp_var (name, _) -> Some (Located.mk name, None) 117 | | _ -> None) 118 | in 119 | let t_type_parameters = parameter_names @ [ Located.mk unique_parameter_id, None ] in 120 | let function_type = 121 | ptyp_poly 122 | t_type_parameters 123 | (ptyp_arrow 124 | { arg_label = Nolabel 125 | ; arg_type = 126 | ptyp_constr 127 | (Located.mk name_of_first_parameter) 128 | (core_type_params @ [ ptyp_var unique_parameter_id ]) 129 | ; arg_modes 130 | } 131 | { result_type = var_arrow_type; result_modes }) 132 | in 133 | let function_expression = 134 | let parameters_as_constrs = 135 | List.map core_type_params ~f:(fun type_ -> 136 | match Ppxlib_jane.Shim.Core_type_desc.of_parsetree type_.ptyp_desc with 137 | | Ptyp_var (name, _) -> ptyp_constr (Lident name |> Located.mk) [] 138 | | _ -> type_) 139 | in 140 | let inner_new_type = 141 | pexp_newtype 142 | (Located.mk unique_parameter_id) 143 | None 144 | (pexp_constraint 145 | function_body 146 | (Some 147 | (ptyp_arrow 148 | { arg_label = Nolabel 149 | ; arg_type = 150 | ptyp_constr 151 | (Located.mk name_of_first_parameter) 152 | (parameters_as_constrs 153 | @ [ ptyp_constr (Located.mk (Lident unique_parameter_id)) [] ]) 154 | ; arg_modes 155 | } 156 | { result_type = constr_arrow_type; result_modes })) 157 | []) 158 | in 159 | List.fold_right parameter_names ~init:inner_new_type ~f:(fun (name, kind) acc -> 160 | pexp_newtype name kind acc) 161 | in 162 | pstr_value 163 | Nonrecursive 164 | [ value_binding 165 | ~pat: 166 | (ppat_constraint (ppat_var (Located.mk function_name)) (Some function_type) []) 167 | ~expr:function_expression 168 | ~modes:[] 169 | ] 170 | ;; 171 | 172 | let at_least_one_subproduct elements_to_convert = 173 | List.exists elements_to_convert ~f:(fun (_, granularity) -> 174 | match granularity with 175 | | Type_kind.Shallow -> false 176 | | Type_kind.Deep _ -> true) 177 | ;; 178 | -------------------------------------------------------------------------------- /typed_variants_lib/typed_variants_lib_intf.ml: -------------------------------------------------------------------------------- 1 | (** [@@deriving typed_variants] will derive a module that satisfies module type . 2 | 3 | For example, this 4 | {[ 5 | type t = 6 | | Rgb of (int * int * int) 7 | | Rgba of 8 | { r : int 9 | ; g : int 10 | ; b : int 11 | ; a : int 12 | } 13 | [@@deriving typed_variants] 14 | ]} 15 | 16 | will generate a sub-module that looks something like this 17 | {[ 18 | module Typed_variants : sig 19 | type nonrec derived_on = t 20 | 21 | module Typed_variant_anonymous_records : sig 22 | type rgba_record = { 23 | r: int; 24 | g: int; 25 | b: int; 26 | a: int; 27 | } 28 | end 29 | 30 | type _ t = 31 | | Rgb: (int * int * int) t 32 | | Rgba: Typed_variant_anonymous_records.rgba_record t 33 | 34 | include Typed_variants.S with type 'a t := 'a t and type derived_on := derived_on 35 | end 36 | ]} 37 | 38 | Exposing this as a module type allows one to write functors over the derived 39 | `Typed_variants` module. *) 40 | 41 | (*$ 42 | open Base 43 | open Stdio 44 | open Typed_fields_lib_cinaps 45 | $*) 46 | 47 | open Base 48 | 49 | (*$ 50 | for n = 0 to 5 do 51 | [%string 52 | {| 53 | 54 | module type %{this n "S"} = sig @@ portable 55 | include Typed_fields_lib.Common.%{this n "S"} 56 | 57 | val get : (%{each n "'t%i,"} 'a) t @ local -> %{params n "'t%i"} derived_on -> 'a option 58 | val create : (%{each n "'t%i,"} 'a) t @ local -> 'a -> %{params n "'t%i"} derived_on 59 | val which : %{params n "'t%i"} derived_on -> Packed.t 60 | end 61 | 62 | |}] 63 | |> print_endline 64 | done 65 | *) 66 | 67 | module type S = sig 68 | include Typed_fields_lib.Common.S 69 | 70 | val get : 'a t -> derived_on -> 'a option 71 | val create : 'a t -> 'a -> derived_on 72 | val which : derived_on -> Packed.t 73 | end 74 | 75 | module type S1 = sig 76 | include Typed_fields_lib.Common.S1 77 | 78 | val get : ('t1, 'a) t -> 't1 derived_on -> 'a option 79 | val create : ('t1, 'a) t -> 'a -> 't1 derived_on 80 | val which : 't1 derived_on -> Packed.t 81 | end 82 | 83 | module type S2 = sig 84 | include Typed_fields_lib.Common.S2 85 | 86 | val get : ('t1, 't2, 'a) t -> ('t1, 't2) derived_on -> 'a option 87 | val create : ('t1, 't2, 'a) t -> 'a -> ('t1, 't2) derived_on 88 | val which : ('t1, 't2) derived_on -> Packed.t 89 | end 90 | 91 | module type S3 = sig 92 | include Typed_fields_lib.Common.S3 93 | 94 | val get : ('t1, 't2, 't3, 'a) t -> ('t1, 't2, 't3) derived_on -> 'a option 95 | val create : ('t1, 't2, 't3, 'a) t -> 'a -> ('t1, 't2, 't3) derived_on 96 | val which : ('t1, 't2, 't3) derived_on -> Packed.t 97 | end 98 | 99 | module type S4 = sig 100 | include Typed_fields_lib.Common.S4 101 | 102 | val get : ('t1, 't2, 't3, 't4, 'a) t -> ('t1, 't2, 't3, 't4) derived_on -> 'a option 103 | val create : ('t1, 't2, 't3, 't4, 'a) t -> 'a -> ('t1, 't2, 't3, 't4) derived_on 104 | val which : ('t1, 't2, 't3, 't4) derived_on -> Packed.t 105 | end 106 | 107 | module type S5 = sig 108 | include Typed_fields_lib.Common.S5 109 | 110 | val get 111 | : ('t1, 't2, 't3, 't4, 't5, 'a) t 112 | -> ('t1, 't2, 't3, 't4, 't5) derived_on 113 | -> 'a option 114 | 115 | val create 116 | : ('t1, 't2, 't3, 't4, 't5, 'a) t 117 | -> 'a 118 | -> ('t1, 't2, 't3, 't4, 't5) derived_on 119 | 120 | val which : ('t1, 't2, 't3, 't4, 't5) derived_on -> Packed.t 121 | end 122 | 123 | (*$*) 124 | 125 | module type Typed_variants_lib = sig 126 | module type S = S 127 | module type S1 = S1 128 | module type S2 = S2 129 | module type S3 = S3 130 | module type S4 = S4 131 | module type S5 = S5 132 | 133 | (*$ 134 | for n = 1 to 5 do 135 | [%string 136 | {| 137 | 138 | module %{this n "S_of_S"} (M : %{this n "S"}) %{each n "(T%i : T)"} : S 139 | with type 'a t = (%{each n "T%i.t,"} 'a) M.t 140 | and type derived_on = %{params n "T%i.t"} M.derived_on 141 | 142 | |}] 143 | |> print_endline 144 | done 145 | *) 146 | 147 | module S_of_S1 (M : S1) (T1 : T) : 148 | S with type 'a t = (T1.t, 'a) M.t and type derived_on = T1.t M.derived_on 149 | 150 | module S_of_S2 (M : S2) (T1 : T) (T2 : T) : 151 | S 152 | with type 'a t = (T1.t, T2.t, 'a) M.t 153 | and type derived_on = (T1.t, T2.t) M.derived_on 154 | 155 | module S_of_S3 (M : S3) (T1 : T) (T2 : T) (T3 : T) : 156 | S 157 | with type 'a t = (T1.t, T2.t, T3.t, 'a) M.t 158 | and type derived_on = (T1.t, T2.t, T3.t) M.derived_on 159 | 160 | module S_of_S4 (M : S4) (T1 : T) (T2 : T) (T3 : T) (T4 : T) : 161 | S 162 | with type 'a t = (T1.t, T2.t, T3.t, T4.t, 'a) M.t 163 | and type derived_on = (T1.t, T2.t, T3.t, T4.t) M.derived_on 164 | 165 | module S_of_S5 (M : S5) (T1 : T) (T2 : T) (T3 : T) (T4 : T) (T5 : T) : 166 | S 167 | with type 'a t = (T1.t, T2.t, T3.t, T4.t, T5.t, 'a) M.t 168 | and type derived_on = (T1.t, T2.t, T3.t, T4.t, T5.t) M.derived_on 169 | 170 | (*$ 171 | for n = 0 to 5 do 172 | [%string 173 | {| 174 | 175 | module %{this n "Singleton"} (%{this n "T"} : sig 176 | type %{params n "'t%i"} t 177 | end) : 178 | sig 179 | type (%{each n "'t%i,"} 'r) t = 180 | | T : (%{each n "'t%i,"} %{params n "'t%i"} %{this n "T"}.t) t 181 | 182 | include %{this n "S"} 183 | with type %{params n "'t%i"} derived_on = %{params n "'t%i"} %{this n "T"}.t 184 | and type (%{each n "'t%i,"} 'r) t := (%{each n "'t%i,"} 'r) t 185 | end 186 | 187 | |}] 188 | |> print_endline 189 | done 190 | *) 191 | 192 | module Singleton (T : sig 193 | type t 194 | end) : sig 195 | type 'r t = T : T.t t 196 | 197 | include S with type derived_on = T.t and type 'r t := 'r t 198 | end 199 | 200 | module Singleton1 (T1 : sig 201 | type 't1 t 202 | end) : sig 203 | type ('t1, 'r) t = T : ('t1, 't1 T1.t) t 204 | 205 | include S1 with type 't1 derived_on = 't1 T1.t and type ('t1, 'r) t := ('t1, 'r) t 206 | end 207 | 208 | module Singleton2 (T2 : sig 209 | type ('t1, 't2) t 210 | end) : sig 211 | type ('t1, 't2, 'r) t = T : ('t1, 't2, ('t1, 't2) T2.t) t 212 | 213 | include 214 | S2 215 | with type ('t1, 't2) derived_on = ('t1, 't2) T2.t 216 | and type ('t1, 't2, 'r) t := ('t1, 't2, 'r) t 217 | end 218 | 219 | module Singleton3 (T3 : sig 220 | type ('t1, 't2, 't3) t 221 | end) : sig 222 | type ('t1, 't2, 't3, 'r) t = T : ('t1, 't2, 't3, ('t1, 't2, 't3) T3.t) t 223 | 224 | include 225 | S3 226 | with type ('t1, 't2, 't3) derived_on = ('t1, 't2, 't3) T3.t 227 | and type ('t1, 't2, 't3, 'r) t := ('t1, 't2, 't3, 'r) t 228 | end 229 | 230 | module Singleton4 (T4 : sig 231 | type ('t1, 't2, 't3, 't4) t 232 | end) : sig 233 | type ('t1, 't2, 't3, 't4, 'r) t = 234 | | T : ('t1, 't2, 't3, 't4, ('t1, 't2, 't3, 't4) T4.t) t 235 | 236 | include 237 | S4 238 | with type ('t1, 't2, 't3, 't4) derived_on = ('t1, 't2, 't3, 't4) T4.t 239 | and type ('t1, 't2, 't3, 't4, 'r) t := ('t1, 't2, 't3, 't4, 'r) t 240 | end 241 | 242 | module Singleton5 (T5 : sig 243 | type ('t1, 't2, 't3, 't4, 't5) t 244 | end) : sig 245 | type ('t1, 't2, 't3, 't4, 't5, 'r) t = 246 | | T : ('t1, 't2, 't3, 't4, 't5, ('t1, 't2, 't3, 't4, 't5) T5.t) t 247 | 248 | include 249 | S5 250 | with type ('t1, 't2, 't3, 't4, 't5) derived_on = ('t1, 't2, 't3, 't4, 't5) T5.t 251 | and type ('t1, 't2, 't3, 't4, 't5, 'r) t := ('t1, 't2, 't3, 't4, 't5, 'r) t 252 | end 253 | 254 | (*$*) 255 | 256 | module Nothing : sig 257 | type derived_on = | 258 | type 'a t = | 259 | 260 | include S with type derived_on := derived_on and type 'a t := 'a t 261 | end 262 | end 263 | -------------------------------------------------------------------------------- /src/product_kind_generator.mli: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Ppxlib 3 | 4 | type t 5 | 6 | (** Generates the GADT constructors used in the type t. *) 7 | val constructor_declarations 8 | : (module Product_kind.S with type t = 'a) 9 | -> loc:location 10 | -> elements_to_convert:('a * Type_kind.granularity) list 11 | -> core_type_params:core_type list 12 | -> (('a * Type_kind.granularity) * constructor_declaration) list 13 | 14 | (** Generates an expression containing the names of the names of the fields, e.g. 15 | ["name1"; "name2"] *) 16 | val names_list 17 | : (module Product_kind.S with type t = 'a) 18 | -> loc:location 19 | -> elements_to_convert:('a * Type_kind.granularity) list 20 | -> expression 21 | 22 | (** {v 23 | Generates an expression containing the names of the 24 | names of the fields, e.g. 25 | 26 | match t with 27 | | Constr1 -> "constr1" 28 | | Name -> "name" 29 | v} *) 30 | val name_function_body : loc:location -> expression 31 | 32 | (** {v 33 | Generates an expression containing the path of the 34 | names of the fields, e.g. 35 | 36 | match t with 37 | | Constr1 -> ["constr1"] 38 | | Name subproduct -> "name" :: Name_subproduct.path subproduct 39 | v} *) 40 | val path_function_body 41 | : (module Product_kind.S with type t = 'a) 42 | -> loc:location 43 | -> elements_to_convert:('a * Type_kind.granularity) list 44 | -> expression 45 | 46 | (** {v 47 | Generates an expression containing the order of the 48 | names of the fields, e.g. 49 | 50 | match t with 51 | | Constr1 -> [0] 52 | | Name subproduct -> 1:: Name_subproduct.__ord subproduct 53 | v} *) 54 | val ord_function_body 55 | : (module Product_kind.S with type t = 'a) 56 | -> loc:location 57 | -> elements_to_convert:('a * Type_kind.granularity) list 58 | -> expression 59 | 60 | (** {v 61 | Generates the body of the get function. 62 | 63 | match t with 64 | | Constr1 -> record.constr1 65 | | Name -> record.name 66 | v} *) 67 | val get_function_body 68 | : (module Product_kind.S with type t = 'a) 69 | -> loc:location 70 | -> elements_to_convert:('a * Type_kind.granularity) list 71 | -> expression 72 | 73 | (** {v 74 | Generates the body of the set function. 75 | 76 | match t with 77 | | Constr1 -> {record with constr1 = value} 78 | | Name -> {record with name = value} 79 | v} *) 80 | val set_function_body 81 | : (module Product_kind.S with type t = 'a) 82 | -> loc:location 83 | -> elements_to_convert:('a * Type_kind.granularity) list 84 | -> expression 85 | 86 | (** Generates create function body. For example: 87 | 88 | let constr1 = f Constr1 in let name = f Name in [{constr1 ; name}] *) 89 | val create_function_body 90 | : (module Product_kind.S with type t = 'a) 91 | -> loc:location 92 | -> constructor_declarations: 93 | (('a * Type_kind.granularity) * constructor_declaration) list 94 | -> local:bool 95 | -> expression 96 | 97 | (** Generates a list of modules that are used as the parameters. 98 | 99 | e.g. 100 | 101 | [ module Name_subproduct = [%typed_fields type t = int * int] ; ... ] *) 102 | val subproduct_type_id_modules 103 | : (module Product_kind.S with type t = 'a) 104 | -> loc:location 105 | -> elements_to_convert:('a * Type_kind.granularity) list 106 | -> core_type_params:core_type list 107 | -> structure_item list 108 | 109 | (** Generates a list of type ids definitions. 110 | 111 | e.g. 112 | 113 | [ let (constr1 : () Type_equal.Id.t) = Type_equal.Id.create ~name:"constr1" Sexplib.Conv.opaque ; ... ] *) 114 | val type_ids 115 | : (module Product_kind.S with type t = 'a) 116 | -> loc:location 117 | -> elements_to_convert:('a * Type_kind.granularity) list 118 | -> core_type_params:core_type list 119 | -> structure_item list 120 | 121 | (** {v 122 | Generates body for the [type_id] function 123 | For example: 124 | 125 | match t with 126 | | Constr1 -> constr1 127 | | Name -> name 128 | v} *) 129 | val type_id_function_body 130 | : (module Product_kind.S with type t = 'a) 131 | -> loc:location 132 | -> elements_to_convert:('a * Type_kind.granularity) list 133 | -> expression 134 | 135 | val globalize0_function_body 136 | : (module Product_kind.S with type t = 'a) 137 | -> loc:location 138 | -> elements_to_convert:('a * Type_kind.granularity) list 139 | -> expression 140 | 141 | val globalize_packed_function_body 142 | : (module Product_kind.S with type t = 'a) 143 | -> loc:location 144 | -> elements_to_convert:('a * Type_kind.granularity) list 145 | -> expression 146 | 147 | (** Generates the body for the all function inside of packed. 148 | 149 | [T Constr1 ; T Name] *) 150 | val all_body 151 | : (module Product_kind.S with type t = 'a) 152 | -> loc:location 153 | -> constructor_declarations: 154 | (('a * Type_kind.granularity) * constructor_declaration) list 155 | -> expression 156 | 157 | (** {v 158 | Generates the pack function body. (e.g.): 159 | 160 | match t with 161 | | Name -> {f = T Name} 162 | v} *) 163 | val pack_body 164 | : (module Product_kind.S with type t = 'a) 165 | -> loc:location 166 | -> elements_to_convert:('a * Type_kind.granularity) list 167 | -> local:bool 168 | -> expression 169 | 170 | (** {v 171 | Generates the body for the sexp_of_t function inside of packed. 172 | 173 | match t with 174 | | Constr1 -> Sexplib.Sexp.Atom "Constr1" 175 | | ... 176 | v} *) 177 | val sexp_of_t_body 178 | : (module Product_kind.S with type t = 'a) 179 | -> loc:location 180 | -> elements_to_convert:('a * Type_kind.granularity) list 181 | -> stack:bool 182 | -> expression 183 | 184 | (** {v 185 | Generates the body for the t_of_sexp function inside of packed. 186 | 187 | match t with 188 | | Sexplib.Sexp.Atom "Constr1" -> Constr1 189 | | ... 190 | v} *) 191 | val t_of_sexp_body 192 | : (module Product_kind.S with type t = 'a) 193 | -> loc:location 194 | -> elements_to_convert:('a * Type_kind.granularity) list 195 | -> expression 196 | 197 | (** Generates the deep functor signature. e.g. 198 | 199 | module Deep (Name_subproduct : ) (Constr1: ) = *) 201 | val deep_functor_signature 202 | : (module Product_kind.S with type t = 'a) 203 | -> loc:location 204 | -> elements_to_convert:('a * Type_kind.granularity) list 205 | -> base_module_type:module_type 206 | -> signature_item 207 | 208 | (** Generates the deep functor structure. e.g. 209 | 210 | module Deep (Name_subproduct : ) (Constr1: ) = *) 212 | val deep_functor_structure 213 | : (module Product_kind.S with type t = 'a) 214 | -> loc:location 215 | -> elements_to_convert:('a * Type_kind.granularity) list 216 | -> module_expression:module_expr 217 | -> module_expr 218 | 219 | (** Generates the full_depth module. e.g. 220 | 221 | [ module Constr1_subproduct = [%typed_field ...]; module Name_subproduct = [%typed_field ...]; ...; include Deep (Constr1_subproduct) (Name_subproduct) ] *) 222 | val full_depth_module 223 | : (module Product_kind.S with type t = 'a) 224 | -> loc:location 225 | -> elements_to_convert:('a * Type_kind.granularity) list 226 | -> structure_item list 227 | 228 | (** Generates the full_depth module's signature. e.g. 229 | 230 | [ module Constr1_subproduct : module type of [%typed_field ...]; module Name_subproduct : module type of [%typed_field ...]; ...; include module type of Deep (Constr1_subproduct) (Name_subproduct) ] *) 231 | val full_depth_signature 232 | : (module Product_kind.S with type t = 'a) 233 | -> loc:location 234 | -> elements_to_convert:('a * Type_kind.granularity) list 235 | -> signature_item list 236 | 237 | (* Generates the signature for the sigleton modules sent to Shallow 238 | 239 | [ 240 | module Singleton_for_t_1 : sig ... end; 241 | module Singleton_for_t_2 : sig ... end; 242 | ... 243 | 244 | ] 245 | *) 246 | val singleton_modules_signatures 247 | : (module Product_kind.S with type t = 'a) 248 | -> loc:location 249 | -> elements_to_convert:('a * Type_kind.granularity) list 250 | -> (signature_item * label) list 251 | 252 | (* Generates the structure for the sigleton modules sent to Shallow 253 | 254 | [ 255 | module Singleton_for_t_1 = struct ... end; 256 | module Singleton_for_t_2 = struct ... end; 257 | ... 258 | 259 | ] 260 | *) 261 | val singleton_modules_structures 262 | : (module Product_kind.S with type t = 'a) 263 | -> loc:location 264 | -> elements_to_convert:('a * Type_kind.granularity) list 265 | -> (structure_item * label) list 266 | -------------------------------------------------------------------------------- /typed_fields_lib/typed_fields_lib_intf.ml: -------------------------------------------------------------------------------- 1 | (** [@@deriving typed_fields] will derive a module that satisfies module type S. 2 | 3 | For example, this 4 | {[ 5 | type t = 6 | { name : string 7 | ; age : int 8 | } 9 | [@@deriving typed_fields] 10 | ]} 11 | 12 | will generate a sub-module that looks something like this 13 | {[ 14 | module Typed_fields : sig 15 | type nonrec derived_on = t 16 | 17 | type _ t = 18 | | Name: string t 19 | | Age: int t 20 | 21 | include Typed_fields.S with type 'a t := 'a t and type derived_on := derived_on 22 | end 23 | ]} 24 | 25 | Exposing this as a module type allows one to write functors over the derived 26 | `Typed_fields` module. *) 27 | 28 | (*$ 29 | open Base 30 | open Stdio 31 | open Typed_fields_lib_cinaps 32 | $*) 33 | 34 | open Base 35 | 36 | (*$ 37 | for n = 0 to 5 do 38 | [%string 39 | {| 40 | 41 | module type %{this n "S"} = sig @@ portable 42 | include Typed_common_lib_intf.%{this n "S"} 43 | 44 | type %{params n "'t%i"} creator = { f : 'a. (%{each n "'t%i,"} 'a) t @ local -> 'a } 45 | 46 | val get : (%{each n "'t%i,"} 'a) t @ local -> %{params n "'t%i"} derived_on -> 'a 47 | 48 | val set 49 | : (%{each n "'t%i,"} 'a) t @ local 50 | -> %{params n "'t%i"} derived_on 51 | -> 'a 52 | -> %{params n "'t%i"} derived_on 53 | 54 | val create : local_ %{params n "'t%i"} creator -> %{params n "'t%i"} derived_on 55 | 56 | val create_local 57 | : local_ %{params n "'t%i"} creator 58 | -> local_ %{params n "'t%i"} derived_on 59 | end 60 | 61 | |}] 62 | |> print_endline 63 | done 64 | *) 65 | 66 | module type S = sig 67 | include Typed_common_lib_intf.S 68 | 69 | type creator = { f : 'a. 'a t -> 'a } 70 | 71 | val get : 'a t -> derived_on -> 'a 72 | val set : 'a t -> derived_on -> 'a -> derived_on 73 | val create : creator -> derived_on 74 | val create_local : creator -> derived_on 75 | end 76 | 77 | module type S1 = sig 78 | include Typed_common_lib_intf.S1 79 | 80 | type 't1 creator = { f : 'a. ('t1, 'a) t -> 'a } 81 | 82 | val get : ('t1, 'a) t -> 't1 derived_on -> 'a 83 | val set : ('t1, 'a) t -> 't1 derived_on -> 'a -> 't1 derived_on 84 | val create : 't1 creator -> 't1 derived_on 85 | val create_local : 't1 creator -> 't1 derived_on 86 | end 87 | 88 | module type S2 = sig 89 | include Typed_common_lib_intf.S2 90 | 91 | type ('t1, 't2) creator = { f : 'a. ('t1, 't2, 'a) t -> 'a } 92 | 93 | val get : ('t1, 't2, 'a) t -> ('t1, 't2) derived_on -> 'a 94 | val set : ('t1, 't2, 'a) t -> ('t1, 't2) derived_on -> 'a -> ('t1, 't2) derived_on 95 | val create : ('t1, 't2) creator -> ('t1, 't2) derived_on 96 | val create_local : ('t1, 't2) creator -> ('t1, 't2) derived_on 97 | end 98 | 99 | module type S3 = sig 100 | include Typed_common_lib_intf.S3 101 | 102 | type ('t1, 't2, 't3) creator = { f : 'a. ('t1, 't2, 't3, 'a) t -> 'a } 103 | 104 | val get : ('t1, 't2, 't3, 'a) t -> ('t1, 't2, 't3) derived_on -> 'a 105 | 106 | val set 107 | : ('t1, 't2, 't3, 'a) t 108 | -> ('t1, 't2, 't3) derived_on 109 | -> 'a 110 | -> ('t1, 't2, 't3) derived_on 111 | 112 | val create : ('t1, 't2, 't3) creator -> ('t1, 't2, 't3) derived_on 113 | val create_local : ('t1, 't2, 't3) creator -> ('t1, 't2, 't3) derived_on 114 | end 115 | 116 | module type S4 = sig 117 | include Typed_common_lib_intf.S4 118 | 119 | type ('t1, 't2, 't3, 't4) creator = { f : 'a. ('t1, 't2, 't3, 't4, 'a) t -> 'a } 120 | 121 | val get : ('t1, 't2, 't3, 't4, 'a) t -> ('t1, 't2, 't3, 't4) derived_on -> 'a 122 | 123 | val set 124 | : ('t1, 't2, 't3, 't4, 'a) t 125 | -> ('t1, 't2, 't3, 't4) derived_on 126 | -> 'a 127 | -> ('t1, 't2, 't3, 't4) derived_on 128 | 129 | val create : ('t1, 't2, 't3, 't4) creator -> ('t1, 't2, 't3, 't4) derived_on 130 | val create_local : ('t1, 't2, 't3, 't4) creator -> ('t1, 't2, 't3, 't4) derived_on 131 | end 132 | 133 | module type S5 = sig 134 | include Typed_common_lib_intf.S5 135 | 136 | type ('t1, 't2, 't3, 't4, 't5) creator = 137 | { f : 'a. ('t1, 't2, 't3, 't4, 't5, 'a) t -> 'a } 138 | 139 | val get : ('t1, 't2, 't3, 't4, 't5, 'a) t -> ('t1, 't2, 't3, 't4, 't5) derived_on -> 'a 140 | 141 | val set 142 | : ('t1, 't2, 't3, 't4, 't5, 'a) t 143 | -> ('t1, 't2, 't3, 't4, 't5) derived_on 144 | -> 'a 145 | -> ('t1, 't2, 't3, 't4, 't5) derived_on 146 | 147 | val create : ('t1, 't2, 't3, 't4, 't5) creator -> ('t1, 't2, 't3, 't4, 't5) derived_on 148 | 149 | val create_local 150 | : ('t1, 't2, 't3, 't4, 't5) creator 151 | -> ('t1, 't2, 't3, 't4, 't5) derived_on 152 | end 153 | 154 | (*$*) 155 | 156 | module type Typed_fields_lib = sig 157 | module type S = S 158 | module type S1 = S1 159 | module type S2 = S2 160 | module type S3 = S3 161 | module type S4 = S4 162 | module type S5 = S5 163 | 164 | (*$ 165 | for n = 1 to 5 do 166 | [%string 167 | {| 168 | 169 | module %{this n "S_of_S"} (M : %{this n "S"}) %{each n "(T%i : T)"} : S 170 | with type 'a t = (%{each n "T%i.t,"} 'a) M.t 171 | and type derived_on = %{params n "T%i.t"} M.derived_on 172 | 173 | |}] 174 | |> print_endline 175 | done 176 | *) 177 | 178 | module S_of_S1 (M : S1) (T1 : T) : 179 | S with type 'a t = (T1.t, 'a) M.t and type derived_on = T1.t M.derived_on 180 | 181 | module S_of_S2 (M : S2) (T1 : T) (T2 : T) : 182 | S 183 | with type 'a t = (T1.t, T2.t, 'a) M.t 184 | and type derived_on = (T1.t, T2.t) M.derived_on 185 | 186 | module S_of_S3 (M : S3) (T1 : T) (T2 : T) (T3 : T) : 187 | S 188 | with type 'a t = (T1.t, T2.t, T3.t, 'a) M.t 189 | and type derived_on = (T1.t, T2.t, T3.t) M.derived_on 190 | 191 | module S_of_S4 (M : S4) (T1 : T) (T2 : T) (T3 : T) (T4 : T) : 192 | S 193 | with type 'a t = (T1.t, T2.t, T3.t, T4.t, 'a) M.t 194 | and type derived_on = (T1.t, T2.t, T3.t, T4.t) M.derived_on 195 | 196 | module S_of_S5 (M : S5) (T1 : T) (T2 : T) (T3 : T) (T4 : T) (T5 : T) : 197 | S 198 | with type 'a t = (T1.t, T2.t, T3.t, T4.t, T5.t, 'a) M.t 199 | and type derived_on = (T1.t, T2.t, T3.t, T4.t, T5.t) M.derived_on 200 | 201 | (*$ 202 | for n = 0 to 5 do 203 | [%string 204 | {| 205 | 206 | module %{this n "Singleton"} (%{this n "T"} : sig 207 | type %{params n "'t%i"} t 208 | end) : 209 | sig 210 | type (%{each n "'t%i,"} 'r) t = 211 | | T : (%{each n "'t%i,"} %{params n "'t%i"} %{this n "T"}.t) t 212 | 213 | include %{this n "S"} 214 | with type %{params n "'t%i"} derived_on = %{params n "'t%i"} %{this n "T"}.t 215 | and type (%{each n "'t%i,"} 'r) t := (%{each n "'t%i,"} 'r) t 216 | end 217 | 218 | |}] 219 | |> print_endline 220 | done 221 | *) 222 | 223 | module Singleton (T : sig 224 | type t 225 | end) : sig 226 | type 'r t = T : T.t t 227 | 228 | include S with type derived_on = T.t and type 'r t := 'r t 229 | end 230 | 231 | module Singleton1 (T1 : sig 232 | type 't1 t 233 | end) : sig 234 | type ('t1, 'r) t = T : ('t1, 't1 T1.t) t 235 | 236 | include S1 with type 't1 derived_on = 't1 T1.t and type ('t1, 'r) t := ('t1, 'r) t 237 | end 238 | 239 | module Singleton2 (T2 : sig 240 | type ('t1, 't2) t 241 | end) : sig 242 | type ('t1, 't2, 'r) t = T : ('t1, 't2, ('t1, 't2) T2.t) t 243 | 244 | include 245 | S2 246 | with type ('t1, 't2) derived_on = ('t1, 't2) T2.t 247 | and type ('t1, 't2, 'r) t := ('t1, 't2, 'r) t 248 | end 249 | 250 | module Singleton3 (T3 : sig 251 | type ('t1, 't2, 't3) t 252 | end) : sig 253 | type ('t1, 't2, 't3, 'r) t = T : ('t1, 't2, 't3, ('t1, 't2, 't3) T3.t) t 254 | 255 | include 256 | S3 257 | with type ('t1, 't2, 't3) derived_on = ('t1, 't2, 't3) T3.t 258 | and type ('t1, 't2, 't3, 'r) t := ('t1, 't2, 't3, 'r) t 259 | end 260 | 261 | module Singleton4 (T4 : sig 262 | type ('t1, 't2, 't3, 't4) t 263 | end) : sig 264 | type ('t1, 't2, 't3, 't4, 'r) t = 265 | | T : ('t1, 't2, 't3, 't4, ('t1, 't2, 't3, 't4) T4.t) t 266 | 267 | include 268 | S4 269 | with type ('t1, 't2, 't3, 't4) derived_on = ('t1, 't2, 't3, 't4) T4.t 270 | and type ('t1, 't2, 't3, 't4, 'r) t := ('t1, 't2, 't3, 't4, 'r) t 271 | end 272 | 273 | module Singleton5 (T5 : sig 274 | type ('t1, 't2, 't3, 't4, 't5) t 275 | end) : sig 276 | type ('t1, 't2, 't3, 't4, 't5, 'r) t = 277 | | T : ('t1, 't2, 't3, 't4, 't5, ('t1, 't2, 't3, 't4, 't5) T5.t) t 278 | 279 | include 280 | S5 281 | with type ('t1, 't2, 't3, 't4, 't5) derived_on = ('t1, 't2, 't3, 't4, 't5) T5.t 282 | and type ('t1, 't2, 't3, 't4, 't5, 'r) t := ('t1, 't2, 't3, 't4, 't5, 'r) t 283 | end 284 | 285 | (*$*) 286 | 287 | (** This is a convenient module for deriving typed_fields on unit, which you can 288 | conceptually think of as a record with no fields. OCaml does not support actual 289 | record types with no fields. *) 290 | module Unit : sig 291 | (* unit has no fields *) 292 | type 'a t = | 293 | 294 | include S with type derived_on = unit and type 'a t := 'a t 295 | end 296 | 297 | module Common : sig 298 | module type S = Typed_common_lib_intf.S 299 | module type S1 = Typed_common_lib_intf.S1 300 | module type S2 = Typed_common_lib_intf.S2 301 | module type S3 = Typed_common_lib_intf.S3 302 | module type S4 = Typed_common_lib_intf.S4 303 | module type S5 = Typed_common_lib_intf.S5 304 | end 305 | 306 | module Private : sig 307 | val list_to_sexp : Sexp.t list -> Sexp.t 308 | end 309 | end 310 | -------------------------------------------------------------------------------- /src/singleton_generator.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Ppxlib 3 | 4 | type common_items = 5 | { upper : structure_item 6 | ; upper_rename : structure_item 7 | ; t_type_declaration : structure_item 8 | ; internal_gadt_declaration : structure_item 9 | ; names : structure_item 10 | ; name : structure_item 11 | ; path : structure_item 12 | ; ord : structure_item 13 | ; globalize0 : structure_item 14 | ; globalize : structure_item 15 | ; type_ids : structure_item 16 | ; packed : structure_item 17 | } 18 | 19 | let type_ids ~loc ~number_of_parameters ~unique_id = 20 | let open (val Syntax.builder loc) in 21 | let functor_param_names = 22 | List.init number_of_parameters ~f:(fun i -> [%string "Typed_id_T%{(i + 1)#Int}"]) 23 | in 24 | let functor_param_constrs = 25 | List.map functor_param_names ~f:(fun name -> 26 | ptyp_constr (Ldot (Lident name, "t") |> Located.mk) []) 27 | in 28 | let type_equal_type = 29 | ptyp_constr 30 | (Ldot (Ldot (Ldot (Lident "Base", "Type_equal"), "Id"), "t") |> Located.mk) 31 | [ ptyp_constr (Lident Names.derived_on_name |> Located.mk) functor_param_constrs ] 32 | in 33 | let type_id = 34 | let pattern = ppat_var (Located.mk "type_id") in 35 | let expression = 36 | let expression = 37 | let pattern = 38 | ppat_constraint 39 | (ppat_construct (Lident "T" |> Located.mk) None) 40 | (Some 41 | (ptyp_constr 42 | (Lident "t" |> Located.mk) 43 | (functor_param_constrs 44 | @ [ ptyp_constr (Lident unique_id |> Located.mk) [] ]))) 45 | [] 46 | in 47 | let expression = 48 | pexp_constraint 49 | (pexp_ident (Lident "type_id" |> Located.mk)) 50 | (Some 51 | (ptyp_constr 52 | (Ldot (Ldot (Ldot (Lident "Base", "Type_equal"), "Id"), "t") 53 | |> Located.mk) 54 | [ ptyp_constr (Lident unique_id |> Located.mk) [] ])) 55 | [] 56 | in 57 | pexp_fun Nolabel None pattern expression 58 | in 59 | pexp_newtype (Located.mk unique_id) None expression 60 | in 61 | let vb = value_binding ~pat:pattern ~expr:expression ~modes:[] in 62 | pstr_value Nonrecursive [ vb ] 63 | in 64 | let initial_expr = 65 | pmod_structure 66 | [ [%stri 67 | let type_id : [%t type_equal_type] = 68 | Base.Type_equal.Id.create__portable ~name:"this" (fun _ -> 69 | Sexplib.Sexp.Atom "") 70 | ;;] 71 | ; type_id 72 | ] 73 | in 74 | let expr = 75 | List.fold_right functor_param_names ~init:initial_expr ~f:(fun name acc -> 76 | pmod_functor 77 | (Named 78 | ( Some name |> Located.mk 79 | , pmty_ident (Ldot (Lident "Base", "T") |> Located.mk) 80 | , [] ) 81 | |> Ppxlib_jane.Shim.Functor_parameter.to_parsetree) 82 | acc) 83 | in 84 | pstr_module (module_binding ~name:(Some "Type_ids" |> Located.mk) ~expr) 85 | ;; 86 | 87 | let packed ~loc ~core_type_params ~unique_id ~minimum_needed_parameters = 88 | let open (val Syntax.builder loc) in 89 | let t_params = core_type_params @ [ ptyp_var unique_id ] in 90 | let t_type_constr = ptyp_constr (Lident "t" |> Located.mk) t_params in 91 | let field_type = ptyp_constr (Lident "field" |> Located.mk) t_params in 92 | let packed_field = 93 | let td = 94 | Typed_deriver.generate_packed_field_type_declaration 95 | ~loc 96 | ~params:minimum_needed_parameters 97 | ~unique_parameter_id:unique_id 98 | ~t_type_constr 99 | in 100 | pstr_type Recursive [ td ] 101 | in 102 | let t_prime_type_declaration = 103 | let td = 104 | Typed_deriver.generate_packed_t_prime_type_declaration 105 | ~loc 106 | ~params:minimum_needed_parameters 107 | ~core_type_params 108 | ~field_type 109 | in 110 | let td = 111 | { td with 112 | ptype_attributes = Typed_deriver.disable_warning_37 ~loc :: td.ptype_attributes 113 | } 114 | in 115 | pstr_type Recursive [ td ] 116 | in 117 | let t_type_declaration = 118 | let td = Typed_deriver.generate_packed_t_type_declaration ~loc ~core_type_params in 119 | pstr_type Recursive [ td ] 120 | in 121 | let compare = [%stri let compare _ _ = 0] in 122 | let compare__local = [%stri let compare__local _ _ = 0] in 123 | let equal = [%stri let equal _ _ = true] in 124 | let equal__local = [%stri let equal__local _ _ = true] in 125 | let hash_fold_t = [%stri let hash_fold_t state _ = Base.Int.hash_fold_t state 0] in 126 | let hash = [%stri let hash t = Base.Hash.of_fold hash_fold_t t] in 127 | let all = [%stri let all = [ { f = T T } ]] in 128 | let globalize = [%stri let globalize _ = { f = T T }] in 129 | let sexp_of_t = [%stri let sexp_of_t _ = Sexplib.Sexp.Atom "this"] in 130 | let sexp_of_t__stack = [%stri let sexp_of_t__stack _ = Sexplib.Sexp.Atom "this"] in 131 | let t_of_sexp = [%stri let t_of_sexp _ = { f = T T }] in 132 | let pack = [%stri let pack _ = { f = T T }] in 133 | let pack__local = [%stri let pack__local _ = { f = T T }] in 134 | pstr_module 135 | (module_binding 136 | ~name:(Some "Packed" |> Located.mk) 137 | ~expr: 138 | (pmod_structure 139 | [ packed_field 140 | ; t_prime_type_declaration 141 | ; t_type_declaration 142 | ; compare 143 | ; compare__local 144 | ; equal 145 | ; equal__local 146 | ; hash_fold_t 147 | ; hash 148 | ; all 149 | ; globalize 150 | ; sexp_of_t 151 | ; sexp_of_t__stack 152 | ; t_of_sexp 153 | ; pack 154 | ; pack__local 155 | ])) 156 | ;; 157 | 158 | let common ~loc ~minimum_needed_parameters ~core_type_params ~ctype ~unique_id = 159 | let open (val Syntax.builder loc) in 160 | let upper = 161 | let td = 162 | type_declaration 163 | ~name:(Located.mk "typed_common_original") 164 | ~params:minimum_needed_parameters 165 | ~cstrs:[] 166 | ~kind:Ptype_abstract 167 | ~private_:Public 168 | ~manifest:(Some ctype) 169 | () 170 | in 171 | pstr_type Recursive [ td ] 172 | in 173 | let constructor = 174 | constructor_declaration 175 | ~name:(Located.mk "T") 176 | ~args:(Pcstr_tuple []) 177 | ~res:(Some (ptyp_constr (Lident "t" |> Located.mk) (core_type_params @ [ ctype ]))) 178 | in 179 | let t_params = 180 | minimum_needed_parameters @ [ ptyp_var unique_id, (NoVariance, NoInjectivity) ] 181 | in 182 | let t_type_declaration = 183 | let td = 184 | type_declaration 185 | ~name:("t" |> Located.mk) 186 | ~params:t_params 187 | ~cstrs:[] 188 | ~kind:(Ptype_variant [ constructor ]) 189 | ~private_:Public 190 | ~manifest:None 191 | () 192 | in 193 | pstr_type Recursive [ td ] 194 | in 195 | let internal_gadt_declaration = 196 | let core_type_params = List.map t_params ~f:fst in 197 | let type_ = ptyp_constr (Lident "t" |> Located.mk) core_type_params in 198 | let td = 199 | type_declaration 200 | ~name:(Type_kind.internal_gadt_name |> Located.mk) 201 | ~params:t_params 202 | ~cstrs:[] 203 | ~kind:Ptype_abstract 204 | ~private_:Public 205 | ~manifest:(Some type_) 206 | () 207 | in 208 | pstr_type Recursive [ td ] 209 | in 210 | let upper_rename = 211 | let td = 212 | type_declaration 213 | ~name:(Located.mk Names.derived_on_name) 214 | ~params:minimum_needed_parameters 215 | ~cstrs:[] 216 | ~private_:Public 217 | ~kind:Ptype_abstract 218 | ~manifest: 219 | (Some 220 | (ptyp_constr (Lident "typed_common_original" |> Located.mk) core_type_params)) 221 | () 222 | in 223 | pstr_type Recursive [ td ] 224 | in 225 | let names = [%stri let names = [ "this" ]] in 226 | let name = [%stri let name _ = "this"] in 227 | let path = [%stri let path _ = []] in 228 | let ord = [%stri let __ord _ = [ 0 ]] in 229 | let globalize0 = 230 | let unique_parameter_id = Type_kind.generate_unique_id core_type_params in 231 | let var_arrow_type = 232 | ptyp_constr 233 | (Located.mk (Lident Type_kind.internal_gadt_name)) 234 | (core_type_params @ [ ptyp_var unique_parameter_id ]) 235 | in 236 | let constr_arrow_type = 237 | ptyp_constr 238 | (Located.mk (Lident Type_kind.internal_gadt_name)) 239 | (List.map 240 | (core_type_params @ [ ptyp_var unique_parameter_id ]) 241 | ~f:(fun core_type -> 242 | match Ppxlib_jane.Shim.Core_type_desc.of_parsetree core_type.ptyp_desc with 243 | | Ptyp_var (name, _) -> ptyp_constr (Located.mk (Lident name)) [] 244 | | _ -> core_type)) 245 | in 246 | Typed_deriver.generate_new_typed_function 247 | ~loc 248 | ~function_name:"globalize0" 249 | ~core_type_params 250 | ~unique_parameter_id 251 | ~arg_modes:(Ppxlib_jane.Shim.Modes.local ~loc) 252 | ~result_modes:[] 253 | ~var_arrow_type 254 | ~constr_arrow_type 255 | ~function_body: 256 | [%expr 257 | function 258 | | T -> T] 259 | ~name_of_first_parameter:(Lident "t") 260 | () 261 | in 262 | let globalize = 263 | let body = 264 | eabstract (List.map t_params ~f:(fun _ -> ppat_any)) [%expr fun t -> globalize0 t] 265 | in 266 | [%stri let globalize = [%e body]] 267 | in 268 | let type_ids = 269 | type_ids ~loc ~number_of_parameters:(List.length minimum_needed_parameters) ~unique_id 270 | in 271 | let packed = packed ~loc ~core_type_params ~unique_id ~minimum_needed_parameters in 272 | { upper 273 | ; t_type_declaration 274 | ; internal_gadt_declaration 275 | ; upper_rename 276 | ; name 277 | ; path 278 | ; ord 279 | ; globalize0 280 | ; globalize 281 | ; type_ids 282 | ; packed 283 | ; names 284 | } 285 | ;; 286 | -------------------------------------------------------------------------------- /src/type_kind_intf.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Ppxlib 3 | 4 | module Definitions = struct 5 | type granularity = 6 | | Shallow 7 | | Deep of 8 | { minimum_needed_parameters : (core_type * (variance * injectivity)) list 9 | ; minimum_needed_parameter_ids : int list 10 | ; original_type_with_attributes : core_type 11 | } 12 | 13 | (** Attaches a number of type parameters to a type case. *) 14 | type 'a with_parameters = 'a * (core_type * (variance * injectivity)) list 15 | 16 | (** Type is used in order to represent the results of gen_t and its helper function. 17 | 18 | This is defined in this module to avoid circular dependencies between the generic 19 | and the more specific module which both need access to it. *) 20 | type 'a gen_t_result = 21 | { gadt_t : type_declaration 22 | ; upper : type_declaration 23 | ; constructor_declarations : (('a * granularity) * constructor_declaration) list 24 | ; internal_gadt_rename : type_declaration 25 | } 26 | 27 | module type S = sig 28 | type t 29 | 30 | (** The structure items will be inserted after the type type definitions and before 31 | any other items. *) 32 | val extra_structure_items_to_insert : location -> structure_item list 33 | 34 | (** Generates the GADT constructors used in the type t. *) 35 | val constructor_declarations 36 | : loc:location 37 | -> elements_to_convert:(t * granularity) list 38 | -> core_type_params:core_type list 39 | -> ((t * granularity) * constructor_declaration) list 40 | 41 | (** Generates an expression containing the names of the names of the fields, e.g. 42 | ["name1"; "name2"] *) 43 | val names_list 44 | : loc:location 45 | -> elements_to_convert:(t * granularity) list 46 | -> expression 47 | 48 | (** Generates an expression containing the names of the names of the fields, e.g. 49 | 50 | {[ 51 | match t with 52 | | Constr1 -> "constr1" 53 | | Name -> "name" 54 | ]} *) 55 | val name_function_body : loc:location -> expression 56 | 57 | (** Generates an expression containing the path of the names of the fields, e.g. 58 | 59 | {[ 60 | match t with 61 | | Constr1 -> [ "constr1" ] 62 | | Name subproduct -> "name" :: Name_subproduct.path subproduct 63 | ]} *) 64 | val path_function_body 65 | : loc:location 66 | -> elements_to_convert:(t * granularity) list 67 | -> expression 68 | 69 | (** Generates an expression containing the path of the names of the fields, e.g. 70 | 71 | {[ 72 | match t with 73 | | Constr1 -> [ 0 ] 74 | | Name subproduct -> 1 :: Name_subproduct.__ord subproduct 75 | ]} *) 76 | val ord_function_body 77 | : loc:location 78 | -> elements_to_convert:(t * granularity) list 79 | -> expression 80 | 81 | (** Generates the body of the get function. 82 | 83 | {[ 84 | match t with 85 | | Constr1 -> record.constr1 86 | | Name -> record.name 87 | ]} *) 88 | val get_function_body 89 | : loc:location 90 | -> elements_to_convert:(t * granularity) list 91 | -> expression 92 | 93 | (** Generates the body of the set function. 94 | 95 | {[ 96 | match t with 97 | | Constr1 -> { record with constr1 = value } 98 | | Name -> { record with name = value } 99 | ]} *) 100 | val set_function_body 101 | : loc:location 102 | -> elements_to_convert:(t * granularity) list 103 | -> expression 104 | 105 | (** Generates create function body. For example: 106 | 107 | {[ 108 | let constr1 = f Constr1 in 109 | let name = f Name in 110 | { constr1; name } 111 | ]} *) 112 | val create_function_body 113 | : loc:location 114 | -> constructor_declarations:((t * granularity) * constructor_declaration) list 115 | -> local:bool 116 | -> expression 117 | 118 | (** Generates a list of type ids definitions. 119 | 120 | e.g. 121 | 122 | {[ 123 | let (constr1 : () Type_equal.Id.t) = 124 | Type_equal.Id.create ~name:"constr1" Sexplib.Conv.opaque 125 | ;; 126 | 127 | ... 128 | ]} *) 129 | val type_ids 130 | : loc:location 131 | -> elements_to_convert:(t * granularity) list 132 | -> core_type_params:core_type list 133 | -> structure_item list 134 | 135 | (** Generates a list of modules that are used as the parameters. 136 | 137 | e.g. 138 | 139 | {[ 140 | module Name_subproduct = [%typed_fields type t = int * int] 141 | ... 142 | ]} *) 143 | val subproduct_type_id_modules 144 | : loc:location 145 | -> elements_to_convert:(t * granularity) list 146 | -> core_type_params:core_type list 147 | -> structure_item list 148 | 149 | (** Generates body for the [type_id] function For example: 150 | 151 | {[ 152 | match t with 153 | | Constr1 -> constr1 154 | | Name -> name 155 | ]} *) 156 | val type_id_function_body 157 | : loc:location 158 | -> elements_to_convert:(t * granularity) list 159 | -> expression 160 | 161 | val globalize0_function_body 162 | : loc:location 163 | -> elements_to_convert:(t * granularity) list 164 | -> expression 165 | 166 | val globalize_packed_function_body 167 | : loc:location 168 | -> elements_to_convert:(t * granularity) list 169 | -> expression 170 | 171 | (** Generates the body for the all function inside of packed. 172 | 173 | [T Constr1 ; T Name] *) 174 | val all_body 175 | : loc:location 176 | -> constructor_declarations:((t * granularity) * constructor_declaration) list 177 | -> expression 178 | 179 | val pack_body 180 | : loc:location 181 | -> elements_to_convert:(t * granularity) list 182 | -> local:bool 183 | -> expression 184 | 185 | (** Generates the body for the sexp_of_t function inside of packed. 186 | 187 | {[ 188 | match t with 189 | | Constr1 -> Sexplib.Sexp.Atom "Constr1" 190 | | ... 191 | ]} *) 192 | val sexp_of_t_body 193 | : loc:location 194 | -> elements_to_convert:(t * granularity) list 195 | -> stack:bool 196 | -> expression 197 | 198 | (** Generates the body for the t_of_sexp function inside of packed. 199 | 200 | {[ 201 | match t with 202 | | Sexplib.Sexp.Atom "Constr1" -> Constr1 203 | | ... 204 | ]} *) 205 | val t_of_sexp_body 206 | : loc:location 207 | -> elements_to_convert:(t * granularity) list 208 | -> expression 209 | 210 | (** Generates the deep functor structure. e.g. 211 | 212 | {[ 213 | module Deep 214 | (Name_subproduct : ) 215 | (Constr1: ) = 216 | ]} *) 217 | val deep_functor_structure 218 | : loc:location 219 | -> elements_to_convert:(t * granularity) list 220 | -> module_expression:module_expr 221 | -> module_expr 222 | 223 | (** Generates the full_depth module. e.g. 224 | 225 | {[ 226 | module Constr1_subproduct = [%typed_field ...] 227 | module Name_subproduct = [%typed_field ...] 228 | ... 229 | include Deep (Constr1_subproduct) (Name_subproduct) 230 | ]} *) 231 | val full_depth_module 232 | : loc:location 233 | -> elements_to_convert:(t * granularity) list 234 | -> structure_item list 235 | 236 | (** Generates the structure for the sigleton modules sent to Shallow 237 | 238 | {[ 239 | module Singleton_for_t_1 = struct ... end; 240 | module Singleton_for_t_2 = struct ... end; 241 | ... 242 | ]} *) 243 | val singleton_modules_structures 244 | : loc:location 245 | -> elements_to_convert:(t * granularity) list 246 | -> (structure_item * label) list 247 | end 248 | end 249 | 250 | module type Type_kind = sig 251 | include module type of struct 252 | include Definitions 253 | end 254 | 255 | val internal_gadt_name : string 256 | 257 | val generate_core_type_params 258 | : (core_type * (variance * injectivity)) list 259 | -> core_type list 260 | 261 | (** Repeatedly appends '_' to start until it is not inside of 'identifiers_to_avoid'. *) 262 | val generate_unique_name 263 | : start:string 264 | -> identifiers_to_avoid:Set.M(String).t 265 | -> string 266 | 267 | (** Needs to be an identifier that does not collide with any other types from the 268 | Typed_fields_lib.S signature. *) 269 | val generate_local_type_name : type_declaration -> string 270 | 271 | val generate_manifest_type_constr 272 | : loc:Location.t 273 | -> name:string 274 | -> params:(core_type * (variance * injectivity)) list 275 | -> core_type 276 | 277 | (** Disables unused value warning. *) 278 | val disable_warning_32 : loc:Location.t -> attribute 279 | 280 | val generate_creator_type_declaration 281 | : loc:Location.t 282 | -> unique_parameter_id:string 283 | -> core_type_params:core_type list 284 | -> params:(core_type * (variance * injectivity)) list 285 | -> t_name:string 286 | -> type_declaration 287 | 288 | (** Attributes need to be manually removed so that they do not reappear in the output of 289 | the ppx. *) 290 | val attribute_remover : Ast_traverse.map 291 | 292 | val upper 293 | : loc:Location.t 294 | -> manifest_type:core_type option 295 | -> original_kind:type_kind 296 | -> params:(core_type * (variance * injectivity)) list 297 | -> name:string 298 | -> type_declaration 299 | 300 | val append_functor_parameter : string -> string 301 | 302 | val generate_param_name_to_index 303 | : core_type_params:core_type list 304 | -> int Map.M(String).t 305 | 306 | val original_param_to_functor_param : string -> int Map.M(String).t -> Longident.t 307 | 308 | (** Replaces the original type parameters to the types that will be used by the functor. 309 | 310 | e.g. ('a * 'b) list * 'c -> (T1.t * T2.t) * list * T3.t *) 311 | val create_mapper : loc:Location.t -> int Map.M(String).t -> Ast_traverse.map 312 | 313 | (** Generates a unique id by repeatedly appending "_" to "result", e.g. "result_". *) 314 | val generate_unique_id : core_type list -> string 315 | 316 | val or_patterns : pattern list -> loc:Location.t -> pattern 317 | val exclave_if_local : expression -> loc:Location.t -> local:bool -> expression 318 | val exclave_if_stack : expression -> loc:Location.t -> stack:bool -> expression 319 | end 320 | -------------------------------------------------------------------------------- /typed_fields_lib/typed_common_lib_intf.ml: -------------------------------------------------------------------------------- 1 | (** [@@deriving typed_fields] and [@@deriving typed_variants] will derive a module that 2 | satisfies Typed_fields_lib.S (or S1, S2, etc) or Typed_variants_lib.S (or S1, S2, etc) 3 | respectively. 4 | 5 | Each of them have many signature fields in common. In order to facilitate operations 6 | on both of them generically, this file contains the signature with the intersections 7 | of typed fields and typed variants. *) 8 | 9 | (*$ 10 | open Base 11 | open Stdio 12 | open Typed_fields_lib_cinaps 13 | $*) 14 | 15 | open Base 16 | 17 | (*$ 18 | for n = 0 to 5 do 19 | [%string 20 | {| 21 | 22 | module type %{this n "S"} = sig @@ portable 23 | type (%{each n "'t%i,"} 'a) t : value mod contended portable [@@deriving globalize] 24 | type %{params n "'t%i"} derived_on 25 | 26 | val names : string list 27 | 28 | (** The name of the field, e.g. "rgb" from the example above. *) 29 | val name : _ t @ local -> string 30 | 31 | (** The path of a field, e.g. ["rgb"] from the example above. 32 | The list will have multiple elements if the field is a subproduct. *) 33 | val path : _ t @ local -> string list 34 | 35 | (** Globalize without extra parameters. *) 36 | val globalize0 : (%{each n "'t%i,"} 'a) t @ local -> (%{each n "'t%i,"} 'a) t 37 | 38 | val __ord : _ t @ local -> int list 39 | 40 | module Type_ids %{each n "(T%i : T)"} : sig @@ portable 41 | val type_id : (%{each n "T%i.t,"} 'a) t @ local -> 'a Type_equal.Id.t 42 | end 43 | 44 | (** Packed is useful for making collections of 'a t's with different 'a's. *) 45 | module Packed : sig 46 | type (%{each n "'t%i,"} 'a) field := (%{each n "'t%i,"} 'a) t 47 | type %{params n "'t%i"} t' : value mod contended portable = 48 | T : (%{each n "'t%i,"} 'a) field -> %{params n "'t%i"} t' 49 | [@@unsafe_allow_any_mode_crossing 50 | ] 51 | 52 | type t = { f : %{poly n "'t%i"} %{params n "'t%i"} t' } 53 | [@@deriving compare ~localize, enumerate, equal ~localize, globalize, hash, sexp ~stackify] 54 | [@@unboxed] 55 | 56 | include Comparator.S with type t := t 57 | 58 | val%template pack : (%{each n "'t%i,"} 'a) field @ m -> t @ m 59 | [@@mode m = (local, global)] 60 | end 61 | end 62 | 63 | |}] 64 | |> print_endline 65 | done 66 | *) 67 | 68 | module type S = sig 69 | type 'a t [@@deriving globalize] 70 | type derived_on 71 | 72 | val names : string list 73 | 74 | (** The name of the field, e.g. "rgb" from the example above. *) 75 | val name : _ t -> string 76 | 77 | (** The path of a field, e.g. ["rgb"] from the example above. The list will have 78 | multiple elements if the field is a subproduct. *) 79 | val path : _ t -> string list 80 | 81 | (** Globalize without extra parameters. *) 82 | val globalize0 : 'a t -> 'a t 83 | 84 | val __ord : _ t -> int list 85 | 86 | module Type_ids : sig 87 | val type_id : 'a t -> 'a Type_equal.Id.t 88 | end 89 | 90 | (** Packed is useful for making collections of 'a t's with different 'a's. *) 91 | module Packed : sig 92 | type 'a field := 'a t 93 | type t' = T : 'a field -> t' [@@unsafe_allow_any_mode_crossing] 94 | 95 | type t = { f : t' } 96 | [@@deriving 97 | compare ~localize, enumerate, equal ~localize, globalize, hash, sexp ~stackify] 98 | [@@unboxed] 99 | 100 | include Comparator.S with type t := t 101 | 102 | val%template pack : 'a field -> t [@@mode m = (local, global)] 103 | end 104 | end 105 | 106 | module type S1 = sig 107 | type ('t1, 'a) t [@@deriving globalize] 108 | type 't1 derived_on 109 | 110 | val names : string list 111 | 112 | (** The name of the field, e.g. "rgb" from the example above. *) 113 | val name : _ t -> string 114 | 115 | (** The path of a field, e.g. ["rgb"] from the example above. The list will have 116 | multiple elements if the field is a subproduct. *) 117 | val path : _ t -> string list 118 | 119 | (** Globalize without extra parameters. *) 120 | val globalize0 : ('t1, 'a) t -> ('t1, 'a) t 121 | 122 | val __ord : _ t -> int list 123 | 124 | module Type_ids (T1 : T) : sig 125 | val type_id : (T1.t, 'a) t -> 'a Type_equal.Id.t 126 | end 127 | 128 | (** Packed is useful for making collections of 'a t's with different 'a's. *) 129 | module Packed : sig 130 | type ('t1, 'a) field := ('t1, 'a) t 131 | type 't1 t' = T : ('t1, 'a) field -> 't1 t' [@@unsafe_allow_any_mode_crossing] 132 | 133 | type t = { f : 't1. 't1 t' } 134 | [@@deriving 135 | compare ~localize, enumerate, equal ~localize, globalize, hash, sexp ~stackify] 136 | [@@unboxed] 137 | 138 | include Comparator.S with type t := t 139 | 140 | val%template pack : ('t1, 'a) field -> t [@@mode m = (local, global)] 141 | end 142 | end 143 | 144 | module type S2 = sig 145 | type ('t1, 't2, 'a) t [@@deriving globalize] 146 | type ('t1, 't2) derived_on 147 | 148 | val names : string list 149 | 150 | (** The name of the field, e.g. "rgb" from the example above. *) 151 | val name : _ t -> string 152 | 153 | (** The path of a field, e.g. ["rgb"] from the example above. The list will have 154 | multiple elements if the field is a subproduct. *) 155 | val path : _ t -> string list 156 | 157 | (** Globalize without extra parameters. *) 158 | val globalize0 : ('t1, 't2, 'a) t -> ('t1, 't2, 'a) t 159 | 160 | val __ord : _ t -> int list 161 | 162 | module Type_ids (T1 : T) (T2 : T) : sig 163 | val type_id : (T1.t, T2.t, 'a) t -> 'a Type_equal.Id.t 164 | end 165 | 166 | (** Packed is useful for making collections of 'a t's with different 'a's. *) 167 | module Packed : sig 168 | type ('t1, 't2, 'a) field := ('t1, 't2, 'a) t 169 | 170 | type ('t1, 't2) t' = T : ('t1, 't2, 'a) field -> ('t1, 't2) t' 171 | [@@unsafe_allow_any_mode_crossing] 172 | 173 | type t = { f : 't1 't2. ('t1, 't2) t' } 174 | [@@deriving 175 | compare ~localize, enumerate, equal ~localize, globalize, hash, sexp ~stackify] 176 | [@@unboxed] 177 | 178 | include Comparator.S with type t := t 179 | 180 | val%template pack : ('t1, 't2, 'a) field -> t [@@mode m = (local, global)] 181 | end 182 | end 183 | 184 | module type S3 = sig 185 | type ('t1, 't2, 't3, 'a) t [@@deriving globalize] 186 | type ('t1, 't2, 't3) derived_on 187 | 188 | val names : string list 189 | 190 | (** The name of the field, e.g. "rgb" from the example above. *) 191 | val name : _ t -> string 192 | 193 | (** The path of a field, e.g. ["rgb"] from the example above. The list will have 194 | multiple elements if the field is a subproduct. *) 195 | val path : _ t -> string list 196 | 197 | (** Globalize without extra parameters. *) 198 | val globalize0 : ('t1, 't2, 't3, 'a) t -> ('t1, 't2, 't3, 'a) t 199 | 200 | val __ord : _ t -> int list 201 | 202 | module Type_ids (T1 : T) (T2 : T) (T3 : T) : sig 203 | val type_id : (T1.t, T2.t, T3.t, 'a) t -> 'a Type_equal.Id.t 204 | end 205 | 206 | (** Packed is useful for making collections of 'a t's with different 'a's. *) 207 | module Packed : sig 208 | type ('t1, 't2, 't3, 'a) field := ('t1, 't2, 't3, 'a) t 209 | 210 | type ('t1, 't2, 't3) t' = T : ('t1, 't2, 't3, 'a) field -> ('t1, 't2, 't3) t' 211 | [@@unsafe_allow_any_mode_crossing] 212 | 213 | type t = { f : 't1 't2 't3. ('t1, 't2, 't3) t' } 214 | [@@deriving 215 | compare ~localize, enumerate, equal ~localize, globalize, hash, sexp ~stackify] 216 | [@@unboxed] 217 | 218 | include Comparator.S with type t := t 219 | 220 | val%template pack : ('t1, 't2, 't3, 'a) field -> t [@@mode m = (local, global)] 221 | end 222 | end 223 | 224 | module type S4 = sig 225 | type ('t1, 't2, 't3, 't4, 'a) t [@@deriving globalize] 226 | type ('t1, 't2, 't3, 't4) derived_on 227 | 228 | val names : string list 229 | 230 | (** The name of the field, e.g. "rgb" from the example above. *) 231 | val name : _ t -> string 232 | 233 | (** The path of a field, e.g. ["rgb"] from the example above. The list will have 234 | multiple elements if the field is a subproduct. *) 235 | val path : _ t -> string list 236 | 237 | (** Globalize without extra parameters. *) 238 | val globalize0 : ('t1, 't2, 't3, 't4, 'a) t -> ('t1, 't2, 't3, 't4, 'a) t 239 | 240 | val __ord : _ t -> int list 241 | 242 | module Type_ids (T1 : T) (T2 : T) (T3 : T) (T4 : T) : sig 243 | val type_id : (T1.t, T2.t, T3.t, T4.t, 'a) t -> 'a Type_equal.Id.t 244 | end 245 | 246 | (** Packed is useful for making collections of 'a t's with different 'a's. *) 247 | module Packed : sig 248 | type ('t1, 't2, 't3, 't4, 'a) field := ('t1, 't2, 't3, 't4, 'a) t 249 | 250 | type ('t1, 't2, 't3, 't4) t' = 251 | | T : ('t1, 't2, 't3, 't4, 'a) field -> ('t1, 't2, 't3, 't4) t' 252 | [@@unsafe_allow_any_mode_crossing] 253 | 254 | type t = { f : 't1 't2 't3 't4. ('t1, 't2, 't3, 't4) t' } 255 | [@@deriving 256 | compare ~localize, enumerate, equal ~localize, globalize, hash, sexp ~stackify] 257 | [@@unboxed] 258 | 259 | include Comparator.S with type t := t 260 | 261 | val%template pack : ('t1, 't2, 't3, 't4, 'a) field -> t [@@mode m = (local, global)] 262 | end 263 | end 264 | 265 | module type S5 = sig 266 | type ('t1, 't2, 't3, 't4, 't5, 'a) t [@@deriving globalize] 267 | type ('t1, 't2, 't3, 't4, 't5) derived_on 268 | 269 | val names : string list 270 | 271 | (** The name of the field, e.g. "rgb" from the example above. *) 272 | val name : _ t -> string 273 | 274 | (** The path of a field, e.g. ["rgb"] from the example above. The list will have 275 | multiple elements if the field is a subproduct. *) 276 | val path : _ t -> string list 277 | 278 | (** Globalize without extra parameters. *) 279 | val globalize0 : ('t1, 't2, 't3, 't4, 't5, 'a) t -> ('t1, 't2, 't3, 't4, 't5, 'a) t 280 | 281 | val __ord : _ t -> int list 282 | 283 | module Type_ids (T1 : T) (T2 : T) (T3 : T) (T4 : T) (T5 : T) : sig 284 | val type_id : (T1.t, T2.t, T3.t, T4.t, T5.t, 'a) t -> 'a Type_equal.Id.t 285 | end 286 | 287 | (** Packed is useful for making collections of 'a t's with different 'a's. *) 288 | module Packed : sig 289 | type ('t1, 't2, 't3, 't4, 't5, 'a) field := ('t1, 't2, 't3, 't4, 't5, 'a) t 290 | 291 | type ('t1, 't2, 't3, 't4, 't5) t' = 292 | | T : ('t1, 't2, 't3, 't4, 't5, 'a) field -> ('t1, 't2, 't3, 't4, 't5) t' 293 | [@@unsafe_allow_any_mode_crossing] 294 | 295 | type t = { f : 't1 't2 't3 't4 't5. ('t1, 't2, 't3, 't4, 't5) t' } 296 | [@@deriving 297 | compare ~localize, enumerate, equal ~localize, globalize, hash, sexp ~stackify] 298 | [@@unboxed] 299 | 300 | include Comparator.S with type t := t 301 | 302 | val%template pack : ('t1, 't2, 't3, 't4, 't5, 'a) field -> t 303 | [@@mode m = (local, global)] 304 | end 305 | end 306 | 307 | (*$*) 308 | 309 | module type Typed_variants_lib = sig 310 | module type S = S 311 | module type S1 = S1 312 | module type S2 = S2 313 | module type S3 = S3 314 | module type S4 = S4 315 | module type S5 = S5 316 | end 317 | -------------------------------------------------------------------------------- /src/variant_kind_generator_intf.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Ppxlib 3 | 4 | module Definitions = struct 5 | type variant_granularity = 6 | | Shallow (** When the subvariant is another type that derives typed variants. *) 7 | | Constr_deep of 8 | { ident : longident_loc 9 | ; params : core_type list 10 | } 11 | | Polymorphic_deep 12 | 13 | type supported_constructor_declaration = 14 | (* | C of {a : int} *) 15 | | Anonymous_record_constructor of 16 | { constructor_name : string 17 | ; return_value_type : core_type 18 | ; return_value_type_with_original_attributes : core_type 19 | ; minimum_needed_parameters : (core_type * (variance * injectivity)) list 20 | ; label_declarations : label_declaration list 21 | ; typed_fields : bool 22 | } 23 | (* | C of (int * int * int) *) 24 | | Single_value_constructor of 25 | { constructor_name : string 26 | ; return_value_type : core_type 27 | ; return_value_type_with_original_attributes : core_type 28 | ; minimum_needed_parameters : (core_type * (variance * injectivity)) list 29 | ; minimum_needed_parameter_ids : int list 30 | ; granularity : variant_granularity 31 | ; typed_fields : bool 32 | ; is_polymorphic : bool 33 | } 34 | (* | C of int * int * int *) 35 | | Tuple_values_constructor of 36 | { constructor_name : string 37 | ; return_value_type : core_type 38 | ; return_value_type_with_original_attributes : core_type 39 | ; minimum_needed_parameters : (core_type * (variance * injectivity)) list 40 | ; tuple_types : core_type list 41 | ; typed_fields : bool 42 | } 43 | (* | C *) 44 | | No_values_constructor of 45 | { constructor_name : string 46 | ; return_value_type : core_type 47 | ; is_polymorphic : bool 48 | } 49 | 50 | type type_case = 51 | | Variant of supported_constructor_declaration list Type_kind.with_parameters 52 | | Nothing of unit Type_kind.with_parameters 53 | | Opaque of bool Type_kind.with_parameters 54 | | Unknown 55 | 56 | module type S = sig 57 | (** The structure items will be inserted after the type type definitions and before 58 | any other items. *) 59 | val extra_structure_items_to_insert : location -> structure_item list 60 | 61 | (** Generates an expression containing the names of the names of the fields, e.g. 62 | ["name1"; "name2"] *) 63 | val names_list 64 | : loc:location 65 | -> elements_to_convert: 66 | (supported_constructor_declaration * Type_kind.granularity) list 67 | -> expression 68 | 69 | (** Generates an expression containing the names of the names of the fields, e.g. 70 | 71 | {[ 72 | match t with 73 | | Constr1 -> "constr1" 74 | | Name -> "name" 75 | ]} *) 76 | val name_function_body 77 | : loc:location 78 | -> elements_to_convert: 79 | (supported_constructor_declaration * Type_kind.granularity) list 80 | -> expression 81 | 82 | (** Generates an expression containing the path of the names of the fields, e.g. 83 | 84 | {[ 85 | match t with 86 | | Constr1 -> [ "constr1" ] 87 | | Name subproduct -> "name" :: Name_subproduct.path subproduct 88 | ]} *) 89 | val path_function_body 90 | : loc:location 91 | -> elements_to_convert: 92 | (supported_constructor_declaration * Type_kind.granularity) list 93 | -> expression 94 | 95 | (** Generates an expression containing the path of the names of the fields, e.g. 96 | 97 | {[ 98 | match t with 99 | | Constr1 -> [ 0 ] 100 | | Name subproduct -> 1 :: Name_subproduct.__ord subproduct 101 | ]} *) 102 | val ord_function_body 103 | : loc:location 104 | -> elements_to_convert: 105 | (supported_constructor_declaration * Type_kind.granularity) list 106 | -> expression 107 | 108 | (** Generates the body of the get function. 109 | 110 | {[ 111 | match t with 112 | | Constr1 -> record.constr1 113 | | Name -> record.name 114 | ]} *) 115 | val get_function_body 116 | : loc:location 117 | -> elements_to_convert: 118 | (supported_constructor_declaration * Type_kind.granularity) list 119 | -> expression 120 | 121 | (** Generates create function body. For example: 122 | 123 | {[ 124 | let constr1 = f Constr1 in 125 | let name = f Name in 126 | { constr1; name } 127 | ]} *) 128 | val create_function_body 129 | : loc:location 130 | -> constructor_declarations: 131 | ((supported_constructor_declaration * Type_kind.granularity) 132 | * constructor_declaration) 133 | list 134 | -> local:bool 135 | -> expression 136 | 137 | (** Generates a list of type ids definitions. 138 | 139 | e.g. 140 | 141 | {[ 142 | let (constr1 : () Type_equal.Id.t) = 143 | Type_equal.Id.create ~name:"constr1" Sexplib.Conv.opaque 144 | ;; 145 | ... 146 | ]} *) 147 | val type_ids 148 | : loc:location 149 | -> elements_to_convert: 150 | (supported_constructor_declaration * Type_kind.granularity) list 151 | -> core_type_params:core_type list 152 | -> structure_item list 153 | 154 | (** Generates body for the [type_id] function For example: 155 | 156 | {[ 157 | match t with 158 | | Constr1 -> constr1 159 | | Name -> name 160 | ]} *) 161 | val type_id_function_body 162 | : loc:location 163 | -> elements_to_convert: 164 | (supported_constructor_declaration * Type_kind.granularity) list 165 | -> expression 166 | 167 | val globalize0_function_body 168 | : loc:location 169 | -> elements_to_convert: 170 | (supported_constructor_declaration * Type_kind.granularity) list 171 | -> expression 172 | 173 | val globalize_packed_function_body 174 | : loc:location 175 | -> elements_to_convert: 176 | (supported_constructor_declaration * Type_kind.granularity) list 177 | -> expression 178 | 179 | (** Generates the body for the all function inside of packed. 180 | 181 | [T Constr1 ; T Name] *) 182 | val all_body 183 | : loc:location 184 | -> constructor_declarations: 185 | ((supported_constructor_declaration * Type_kind.granularity) 186 | * constructor_declaration) 187 | list 188 | -> expression 189 | 190 | val pack_body 191 | : loc:location 192 | -> elements_to_convert: 193 | (supported_constructor_declaration * Type_kind.granularity) list 194 | -> local:bool 195 | -> expression 196 | 197 | (** Generates the body for the sexp_of_t function inside of packed. 198 | 199 | {[ 200 | match t with 201 | | Constr1 -> Sexplib.Sexp.Atom "Constr1" 202 | | ... 203 | ]} *) 204 | val sexp_of_t_body 205 | : loc:location 206 | -> elements_to_convert: 207 | (supported_constructor_declaration * Type_kind.granularity) list 208 | -> stack:bool 209 | -> expression 210 | 211 | (** Generates the body for the t_of_sexp function inside of packed. 212 | 213 | {[ 214 | match t with 215 | | Sexplib.Sexp.Atom "Constr1" -> Constr1 216 | | ... 217 | ]} *) 218 | val t_of_sexp_body 219 | : loc:location 220 | -> elements_to_convert: 221 | (supported_constructor_declaration * Type_kind.granularity) list 222 | -> expression 223 | 224 | (** Generates the body of the get function. 225 | 226 | {[ 227 | match t with 228 | | Constr1 -> { f = T Constr1 } 229 | | Name -> { f = T Name } 230 | ]} *) 231 | val which_function_body 232 | : loc:location 233 | -> elements_to_convert: 234 | (supported_constructor_declaration * Type_kind.granularity) list 235 | -> number_of_params:int 236 | -> expression 237 | 238 | (** Generates top level type definitions [type record = t] and 239 | [type _ t = A : a | B : b ...] *) 240 | val generate_constructor_declarations 241 | : loc:location 242 | -> elements_to_convert: 243 | (supported_constructor_declaration * Type_kind.granularity) list 244 | -> core_type_params:core_type list 245 | -> ((supported_constructor_declaration * Type_kind.granularity) 246 | * constructor_declaration) 247 | list 248 | 249 | (** Generates the deep functor structure. e.g. 250 | 251 | {[ 252 | module Deep 253 | (Name_subproduct : ) 254 | (Constr1: ) 255 | = 256 | ]} *) 257 | val deep_functor_structure 258 | : loc:location 259 | -> elements_to_convert:supported_constructor_declaration list 260 | -> module_expression:module_expr 261 | -> structure_item 262 | 263 | (** Generates the deep functor structure. e.g. 264 | 265 | {[ 266 | module Deep 267 | (Name_subproduct : ) 268 | (Constr1: ) 269 | = 270 | ]} *) 271 | val deep_functor_signature 272 | : loc:location 273 | -> elements_to_convert:supported_constructor_declaration list 274 | -> base_module_type:module_type 275 | -> signature_item 276 | 277 | (** Generates the full_depth module. e.g. 278 | 279 | {[ 280 | module Constr1_subproduct = [%typed_field ...] 281 | module Name_subproduct = [%typed_field ...] 282 | ... 283 | include Deep (Constr1_subproduct) (Name_subproduct) 284 | ]} *) 285 | val full_depth_module 286 | : loc:location 287 | -> elements_to_convert:supported_constructor_declaration list 288 | -> expand_typed_variants: 289 | (loc:location -> rec_flag -> type_declaration list -> module_expr) 290 | -> structure_item list 291 | 292 | (** Generates the full_depth module's signature. e.g. 293 | 294 | {[ 295 | module Constr1_subproduct : module type of [%typed_field ...] 296 | module Name_subproduct : module type of [%typed_field ...] 297 | ... 298 | include module type of Deep (Constr1_subproduct) (Name_subproduct) 299 | ]} *) 300 | val full_depth_signature 301 | : loc:location 302 | -> elements_to_convert:supported_constructor_declaration list 303 | -> expand_typed_variants: 304 | (loc:location -> rec_flag -> type_declaration list -> module_expr) 305 | -> signature_item list 306 | 307 | (** Generates the signature for the singleton modules sent to Shallow 308 | 309 | {[ 310 | module Singleton_for_t_1 : sig ... end; 311 | module Singleton_for_t_2 : sig ... end; 312 | ... 313 | ]} *) 314 | val singleton_modules_signatures 315 | : loc:location 316 | -> elements_to_convert:supported_constructor_declaration list 317 | -> signature_item list 318 | 319 | (** Generates the structure for the sigleton modules sent to Shallow 320 | 321 | {[ 322 | module Singleton_for_t_1 = struct ... end; 323 | module Singleton_for_t_2 = struct ... end; 324 | ... 325 | ]} *) 326 | val singleton_modules_structures 327 | : loc:location 328 | -> elements_to_convert:supported_constructor_declaration list 329 | -> structure_item list 330 | end 331 | end 332 | 333 | module type Variant_kind_generator = sig 334 | include module type of struct 335 | include Definitions 336 | end 337 | 338 | val append_functor_parameter : string -> string 339 | val supported_constructor_name : supported_constructor_declaration -> string 340 | val supported_constructor_type : supported_constructor_declaration -> core_type 341 | 342 | val strip_depth_from_supported_declaration 343 | : supported_constructor_declaration 344 | -> supported_constructor_declaration 345 | 346 | val strip_depth_from_td_case : type_case -> type_case 347 | val at_least_one_subvariant : supported_constructor_declaration list -> bool 348 | end 349 | -------------------------------------------------------------------------------- /typed_variants_lib/typed_variants_lib.ml: -------------------------------------------------------------------------------- 1 | (*$ 2 | open Base 3 | open Stdio 4 | open Typed_fields_lib_cinaps 5 | $*) 6 | 7 | open Base 8 | include Typed_variants_lib_intf 9 | 10 | module Nothing = struct 11 | type nonrec derived_on = | 12 | type _ t = | 13 | 14 | let unreachable_code = function 15 | | (_ : _ t) -> . 16 | ;; 17 | 18 | let names = [] 19 | let name : type a. a t -> string = unreachable_code 20 | let path : type a. a t -> string list = unreachable_code 21 | let __ord : type a. a t -> int list = unreachable_code 22 | let get : type a. a t -> derived_on -> a option = unreachable_code 23 | let create : type a. a t -> a -> derived_on = unreachable_code 24 | let globalize0 = unreachable_code 25 | let globalize _ t = globalize0 t 26 | 27 | module Type_ids = struct 28 | let type_id : type a. a t -> a Type_equal.Id.t = unreachable_code 29 | end 30 | 31 | module Packed = struct 32 | type 'a field = 'a t 33 | type t' = T : 'a field -> t' [@@unsafe_allow_any_mode_crossing] 34 | type t = { f : t' } [@@unboxed] 35 | 36 | let all = [] 37 | let pack : type a. a field -> t = unreachable_code 38 | let pack__local : type a. a field -> t = unreachable_code 39 | let globalize { f = T field } = { f = T (globalize0 field) } 40 | let compare { f = T x1 } { f = T x2 } = List.compare Int.compare (__ord x1) (__ord x2) 41 | 42 | let compare__local { f = T x1 } { f = T x2 } = 43 | List.compare__local Int.compare__local (__ord x1) (__ord x2) 44 | ;; 45 | 46 | let equal t1 t2 = compare t1 t2 = 0 47 | let equal__local t1 t2 = compare__local t1 t2 = 0 48 | 49 | let hash_fold_t _ packed = 50 | match packed with 51 | | (_ : t) -> . 52 | ;; 53 | 54 | let hash packed = 55 | match packed with 56 | | (_ : t) -> . 57 | ;; 58 | 59 | let sexp_of_t__stack packed = 60 | match packed with 61 | | (_ : t) -> . 62 | ;; 63 | 64 | let sexp_of_t packed = 65 | match packed with 66 | | (_ : t) -> . 67 | ;; 68 | 69 | let t_of_sexp sexp = 70 | raise_s 71 | (Sexp.List 72 | [ Sexp.Atom "Nothing has no constructors, so cannot convert to variant." 73 | ; sexp 74 | ]) 75 | ;; 76 | 77 | include%template Comparator.Make [@mode portable] (struct 78 | type nonrec t = t 79 | 80 | let compare = compare 81 | let sexp_of_t = sexp_of_t 82 | end) 83 | end 84 | 85 | let which : derived_on -> Packed.t = function 86 | | (_ : derived_on) -> . 87 | ;; 88 | end 89 | 90 | (*$ 91 | for n = 0 to 5 do 92 | [%string 93 | {| 94 | 95 | module %{this n "Singleton"} (%{this n "T"} : sig 96 | type %{params n "'t%i"} t 97 | end) = 98 | struct 99 | include Typed_fields_lib.%{this n "Singleton"} (%{this n "T"}) 100 | 101 | let get 102 | (type %{each n "t%i "} r) 103 | (T : (%{each n "t%i,"} r) t @ local) 104 | (t : %{params n "t%i"} derived_on) 105 | : r option 106 | = Some t 107 | ;; 108 | 109 | let create 110 | (type %{each n "t%i "} r) 111 | (T : (%{each n "t%i,"} r) t @ local) 112 | (t : r) 113 | : %{params n "t%i"} derived_on 114 | = t 115 | ;; 116 | 117 | let which _ = { Packed.f = Packed.T T } 118 | end 119 | 120 | |}] 121 | |> print_endline 122 | done 123 | *) 124 | 125 | module Singleton (T : sig 126 | type t 127 | end) = 128 | struct 129 | include Typed_fields_lib.Singleton (T) 130 | 131 | let get (type r) (T : r t) (t : derived_on) : r option = Some t 132 | let create (type r) (T : r t) (t : r) : derived_on = t 133 | let which _ = { Packed.f = Packed.T T } 134 | end 135 | 136 | module Singleton1 (T1 : sig 137 | type 't1 t 138 | end) = 139 | struct 140 | include Typed_fields_lib.Singleton1 (T1) 141 | 142 | let get (type t1 r) (T : (t1, r) t) (t : t1 derived_on) : r option = Some t 143 | let create (type t1 r) (T : (t1, r) t) (t : r) : t1 derived_on = t 144 | let which _ = { Packed.f = Packed.T T } 145 | end 146 | 147 | module Singleton2 (T2 : sig 148 | type ('t1, 't2) t 149 | end) = 150 | struct 151 | include Typed_fields_lib.Singleton2 (T2) 152 | 153 | let get (type t1 t2 r) (T : (t1, t2, r) t) (t : (t1, t2) derived_on) : r option = Some t 154 | let create (type t1 t2 r) (T : (t1, t2, r) t) (t : r) : (t1, t2) derived_on = t 155 | let which _ = { Packed.f = Packed.T T } 156 | end 157 | 158 | module Singleton3 (T3 : sig 159 | type ('t1, 't2, 't3) t 160 | end) = 161 | struct 162 | include Typed_fields_lib.Singleton3 (T3) 163 | 164 | let get (type t1 t2 t3 r) (T : (t1, t2, t3, r) t) (t : (t1, t2, t3) derived_on) 165 | : r option 166 | = 167 | Some t 168 | ;; 169 | 170 | let create (type t1 t2 t3 r) (T : (t1, t2, t3, r) t) (t : r) : (t1, t2, t3) derived_on = 171 | t 172 | ;; 173 | 174 | let which _ = { Packed.f = Packed.T T } 175 | end 176 | 177 | module Singleton4 (T4 : sig 178 | type ('t1, 't2, 't3, 't4) t 179 | end) = 180 | struct 181 | include Typed_fields_lib.Singleton4 (T4) 182 | 183 | let get 184 | (type t1 t2 t3 t4 r) 185 | (T : (t1, t2, t3, t4, r) t) 186 | (t : (t1, t2, t3, t4) derived_on) 187 | : r option 188 | = 189 | Some t 190 | ;; 191 | 192 | let create (type t1 t2 t3 t4 r) (T : (t1, t2, t3, t4, r) t) (t : r) 193 | : (t1, t2, t3, t4) derived_on 194 | = 195 | t 196 | ;; 197 | 198 | let which _ = { Packed.f = Packed.T T } 199 | end 200 | 201 | module Singleton5 (T5 : sig 202 | type ('t1, 't2, 't3, 't4, 't5) t 203 | end) = 204 | struct 205 | include Typed_fields_lib.Singleton5 (T5) 206 | 207 | let get 208 | (type t1 t2 t3 t4 t5 r) 209 | (T : (t1, t2, t3, t4, t5, r) t) 210 | (t : (t1, t2, t3, t4, t5) derived_on) 211 | : r option 212 | = 213 | Some t 214 | ;; 215 | 216 | let create (type t1 t2 t3 t4 t5 r) (T : (t1, t2, t3, t4, t5, r) t) (t : r) 217 | : (t1, t2, t3, t4, t5) derived_on 218 | = 219 | t 220 | ;; 221 | 222 | let which _ = { Packed.f = Packed.T T } 223 | end 224 | 225 | (*$ 226 | for n = 1 to 5 do 227 | [%string 228 | {| 229 | 230 | module %{this n "S_of_S"} (M : %{this n "S"}) %{each n "(T%i : T)"} : S 231 | with type 'a t = (%{each n "T%i.t,"} 'a) M.t 232 | and type derived_on = %{params n "T%i.t"} M.derived_on = 233 | struct 234 | include M 235 | 236 | type 'a t = (%{each n "T%i.t,"} 'a) M.t 237 | type derived_on = %{params n "T%i.t"} M.derived_on 238 | 239 | let globalize _ t = globalize0 t 240 | 241 | module Type_ids = Type_ids %{each n "(T%i)"} 242 | 243 | module Packed = struct 244 | type 'a field = 'a t 245 | type t' : value mod contended portable = T : 'a field -> t' 246 | [@@unsafe_allow_any_mode_crossing 247 | ] 248 | type t = { f : t' } [@@unboxed] 249 | 250 | let m_of_packed { f = T field } = M.Packed.pack field 251 | let m_of_packed__local { f = T field } = exclave_ M.Packed.pack__local field 252 | let packed_of_m { M.Packed.f = T field } = { f = T field } 253 | let compare a b = M.Packed.compare (m_of_packed a) (m_of_packed b) 254 | 255 | let compare__local a b = 256 | M.Packed.compare__local (m_of_packed__local a) (m_of_packed__local b) [@nontail] 257 | ;; 258 | 259 | let equal a b = M.Packed.equal (m_of_packed a) (m_of_packed b) 260 | 261 | let equal__local a b = 262 | M.Packed.equal__local (m_of_packed__local a) (m_of_packed__local b) [@nontail] 263 | ;; 264 | 265 | let hash_fold_t state t = M.Packed.hash_fold_t state (m_of_packed t) 266 | let hash t = Hash.of_fold hash_fold_t t 267 | let all = List.map M.Packed.all ~f:packed_of_m 268 | let sexp_of_t t = M.Packed.sexp_of_t (m_of_packed t) 269 | let sexp_of_t__stack t = exclave_ M.Packed.sexp_of_t__stack (m_of_packed__local t) 270 | let t_of_sexp sexp = packed_of_m (M.Packed.t_of_sexp sexp) 271 | let globalize { f = T field } = { f = T (globalize0 field) } 272 | let pack field = { f = T field } 273 | let pack__local field = exclave_ { f = T field } 274 | 275 | include%template Comparator.Make [@mode portable] (struct 276 | type nonrec t = t 277 | let compare = compare 278 | let sexp_of_t = sexp_of_t 279 | end) 280 | end 281 | 282 | let which t = Packed.packed_of_m (M.which t) 283 | end 284 | 285 | |}] 286 | |> print_endline 287 | done 288 | *) 289 | 290 | module S_of_S1 (M : S1) (T1 : T) : 291 | S with type 'a t = (T1.t, 'a) M.t and type derived_on = T1.t M.derived_on = struct 292 | include M 293 | 294 | type 'a t = (T1.t, 'a) M.t 295 | type derived_on = T1.t M.derived_on 296 | 297 | let globalize _ t = globalize0 t 298 | 299 | module Type_ids = Type_ids (T1) 300 | 301 | module Packed = struct 302 | type 'a field = 'a t 303 | type t' = T : 'a field -> t' [@@unsafe_allow_any_mode_crossing] 304 | type t = { f : t' } [@@unboxed] 305 | 306 | let m_of_packed { f = T field } = M.Packed.pack field 307 | let m_of_packed__local { f = T field } = M.Packed.pack__local field 308 | let packed_of_m { M.Packed.f = T field } = { f = T field } 309 | let compare a b = M.Packed.compare (m_of_packed a) (m_of_packed b) 310 | 311 | let compare__local a b = 312 | M.Packed.compare__local (m_of_packed__local a) (m_of_packed__local b) [@nontail] 313 | ;; 314 | 315 | let equal a b = M.Packed.equal (m_of_packed a) (m_of_packed b) 316 | 317 | let equal__local a b = 318 | M.Packed.equal__local (m_of_packed__local a) (m_of_packed__local b) [@nontail] 319 | ;; 320 | 321 | let hash_fold_t state t = M.Packed.hash_fold_t state (m_of_packed t) 322 | let hash t = Hash.of_fold hash_fold_t t 323 | let all = List.map M.Packed.all ~f:packed_of_m 324 | let sexp_of_t t = M.Packed.sexp_of_t (m_of_packed t) 325 | let sexp_of_t__stack t = M.Packed.sexp_of_t__stack (m_of_packed__local t) 326 | let t_of_sexp sexp = packed_of_m (M.Packed.t_of_sexp sexp) 327 | let globalize { f = T field } = { f = T (globalize0 field) } 328 | let pack field = { f = T field } 329 | let pack__local field = { f = T field } 330 | 331 | include%template Comparator.Make [@mode portable] (struct 332 | type nonrec t = t 333 | 334 | let compare = compare 335 | let sexp_of_t = sexp_of_t 336 | end) 337 | end 338 | 339 | let which t = Packed.packed_of_m (M.which t) 340 | end 341 | 342 | module S_of_S2 (M : S2) (T1 : T) (T2 : T) : 343 | S with type 'a t = (T1.t, T2.t, 'a) M.t and type derived_on = (T1.t, T2.t) M.derived_on = 344 | struct 345 | include M 346 | 347 | type 'a t = (T1.t, T2.t, 'a) M.t 348 | type derived_on = (T1.t, T2.t) M.derived_on 349 | 350 | let globalize _ t = globalize0 t 351 | 352 | module Type_ids = Type_ids (T1) (T2) 353 | 354 | module Packed = struct 355 | type 'a field = 'a t 356 | type t' = T : 'a field -> t' [@@unsafe_allow_any_mode_crossing] 357 | type t = { f : t' } [@@unboxed] 358 | 359 | let m_of_packed { f = T field } = M.Packed.pack field 360 | let m_of_packed__local { f = T field } = M.Packed.pack__local field 361 | let packed_of_m { M.Packed.f = T field } = { f = T field } 362 | let compare a b = M.Packed.compare (m_of_packed a) (m_of_packed b) 363 | 364 | let compare__local a b = 365 | M.Packed.compare__local (m_of_packed__local a) (m_of_packed__local b) [@nontail] 366 | ;; 367 | 368 | let equal a b = M.Packed.equal (m_of_packed a) (m_of_packed b) 369 | 370 | let equal__local a b = 371 | M.Packed.equal__local (m_of_packed__local a) (m_of_packed__local b) [@nontail] 372 | ;; 373 | 374 | let hash_fold_t state t = M.Packed.hash_fold_t state (m_of_packed t) 375 | let hash t = Hash.of_fold hash_fold_t t 376 | let all = List.map M.Packed.all ~f:packed_of_m 377 | let sexp_of_t t = M.Packed.sexp_of_t (m_of_packed t) 378 | let sexp_of_t__stack t = M.Packed.sexp_of_t__stack (m_of_packed__local t) 379 | let t_of_sexp sexp = packed_of_m (M.Packed.t_of_sexp sexp) 380 | let globalize { f = T field } = { f = T (globalize0 field) } 381 | let pack field = { f = T field } 382 | let pack__local field = { f = T field } 383 | 384 | include%template Comparator.Make [@mode portable] (struct 385 | type nonrec t = t 386 | 387 | let compare = compare 388 | let sexp_of_t = sexp_of_t 389 | end) 390 | end 391 | 392 | let which t = Packed.packed_of_m (M.which t) 393 | end 394 | 395 | module S_of_S3 (M : S3) (T1 : T) (T2 : T) (T3 : T) : 396 | S 397 | with type 'a t = (T1.t, T2.t, T3.t, 'a) M.t 398 | and type derived_on = (T1.t, T2.t, T3.t) M.derived_on = struct 399 | include M 400 | 401 | type 'a t = (T1.t, T2.t, T3.t, 'a) M.t 402 | type derived_on = (T1.t, T2.t, T3.t) M.derived_on 403 | 404 | let globalize _ t = globalize0 t 405 | 406 | module Type_ids = Type_ids (T1) (T2) (T3) 407 | 408 | module Packed = struct 409 | type 'a field = 'a t 410 | type t' = T : 'a field -> t' [@@unsafe_allow_any_mode_crossing] 411 | type t = { f : t' } [@@unboxed] 412 | 413 | let m_of_packed { f = T field } = M.Packed.pack field 414 | let m_of_packed__local { f = T field } = M.Packed.pack__local field 415 | let packed_of_m { M.Packed.f = T field } = { f = T field } 416 | let compare a b = M.Packed.compare (m_of_packed a) (m_of_packed b) 417 | 418 | let compare__local a b = 419 | M.Packed.compare__local (m_of_packed__local a) (m_of_packed__local b) [@nontail] 420 | ;; 421 | 422 | let equal a b = M.Packed.equal (m_of_packed a) (m_of_packed b) 423 | 424 | let equal__local a b = 425 | M.Packed.equal__local (m_of_packed__local a) (m_of_packed__local b) [@nontail] 426 | ;; 427 | 428 | let hash_fold_t state t = M.Packed.hash_fold_t state (m_of_packed t) 429 | let hash t = Hash.of_fold hash_fold_t t 430 | let all = List.map M.Packed.all ~f:packed_of_m 431 | let sexp_of_t t = M.Packed.sexp_of_t (m_of_packed t) 432 | let sexp_of_t__stack t = M.Packed.sexp_of_t__stack (m_of_packed__local t) 433 | let t_of_sexp sexp = packed_of_m (M.Packed.t_of_sexp sexp) 434 | let globalize { f = T field } = { f = T (globalize0 field) } 435 | let pack field = { f = T field } 436 | let pack__local field = { f = T field } 437 | 438 | include%template Comparator.Make [@mode portable] (struct 439 | type nonrec t = t 440 | 441 | let compare = compare 442 | let sexp_of_t = sexp_of_t 443 | end) 444 | end 445 | 446 | let which t = Packed.packed_of_m (M.which t) 447 | end 448 | 449 | module S_of_S4 (M : S4) (T1 : T) (T2 : T) (T3 : T) (T4 : T) : 450 | S 451 | with type 'a t = (T1.t, T2.t, T3.t, T4.t, 'a) M.t 452 | and type derived_on = (T1.t, T2.t, T3.t, T4.t) M.derived_on = struct 453 | include M 454 | 455 | type 'a t = (T1.t, T2.t, T3.t, T4.t, 'a) M.t 456 | type derived_on = (T1.t, T2.t, T3.t, T4.t) M.derived_on 457 | 458 | let globalize _ t = globalize0 t 459 | 460 | module Type_ids = Type_ids (T1) (T2) (T3) (T4) 461 | 462 | module Packed = struct 463 | type 'a field = 'a t 464 | type t' = T : 'a field -> t' [@@unsafe_allow_any_mode_crossing] 465 | type t = { f : t' } [@@unboxed] 466 | 467 | let m_of_packed { f = T field } = M.Packed.pack field 468 | let m_of_packed__local { f = T field } = M.Packed.pack__local field 469 | let packed_of_m { M.Packed.f = T field } = { f = T field } 470 | let compare a b = M.Packed.compare (m_of_packed a) (m_of_packed b) 471 | 472 | let compare__local a b = 473 | M.Packed.compare__local (m_of_packed__local a) (m_of_packed__local b) [@nontail] 474 | ;; 475 | 476 | let equal a b = M.Packed.equal (m_of_packed a) (m_of_packed b) 477 | 478 | let equal__local a b = 479 | M.Packed.equal__local (m_of_packed__local a) (m_of_packed__local b) [@nontail] 480 | ;; 481 | 482 | let hash_fold_t state t = M.Packed.hash_fold_t state (m_of_packed t) 483 | let hash t = Hash.of_fold hash_fold_t t 484 | let all = List.map M.Packed.all ~f:packed_of_m 485 | let sexp_of_t t = M.Packed.sexp_of_t (m_of_packed t) 486 | let sexp_of_t__stack t = M.Packed.sexp_of_t__stack (m_of_packed__local t) 487 | let t_of_sexp sexp = packed_of_m (M.Packed.t_of_sexp sexp) 488 | let globalize { f = T field } = { f = T (globalize0 field) } 489 | let pack field = { f = T field } 490 | let pack__local field = { f = T field } 491 | 492 | include%template Comparator.Make [@mode portable] (struct 493 | type nonrec t = t 494 | 495 | let compare = compare 496 | let sexp_of_t = sexp_of_t 497 | end) 498 | end 499 | 500 | let which t = Packed.packed_of_m (M.which t) 501 | end 502 | 503 | module S_of_S5 (M : S5) (T1 : T) (T2 : T) (T3 : T) (T4 : T) (T5 : T) : 504 | S 505 | with type 'a t = (T1.t, T2.t, T3.t, T4.t, T5.t, 'a) M.t 506 | and type derived_on = (T1.t, T2.t, T3.t, T4.t, T5.t) M.derived_on = struct 507 | include M 508 | 509 | type 'a t = (T1.t, T2.t, T3.t, T4.t, T5.t, 'a) M.t 510 | type derived_on = (T1.t, T2.t, T3.t, T4.t, T5.t) M.derived_on 511 | 512 | let globalize _ t = globalize0 t 513 | 514 | module Type_ids = Type_ids (T1) (T2) (T3) (T4) (T5) 515 | 516 | module Packed = struct 517 | type 'a field = 'a t 518 | type t' = T : 'a field -> t' [@@unsafe_allow_any_mode_crossing] 519 | type t = { f : t' } [@@unboxed] 520 | 521 | let m_of_packed { f = T field } = M.Packed.pack field 522 | let m_of_packed__local { f = T field } = M.Packed.pack__local field 523 | let packed_of_m { M.Packed.f = T field } = { f = T field } 524 | let compare a b = M.Packed.compare (m_of_packed a) (m_of_packed b) 525 | 526 | let compare__local a b = 527 | M.Packed.compare__local (m_of_packed__local a) (m_of_packed__local b) [@nontail] 528 | ;; 529 | 530 | let equal a b = M.Packed.equal (m_of_packed a) (m_of_packed b) 531 | 532 | let equal__local a b = 533 | M.Packed.equal__local (m_of_packed__local a) (m_of_packed__local b) [@nontail] 534 | ;; 535 | 536 | let hash_fold_t state t = M.Packed.hash_fold_t state (m_of_packed t) 537 | let hash t = Hash.of_fold hash_fold_t t 538 | let all = List.map M.Packed.all ~f:packed_of_m 539 | let sexp_of_t t = M.Packed.sexp_of_t (m_of_packed t) 540 | let sexp_of_t__stack t = M.Packed.sexp_of_t__stack (m_of_packed__local t) 541 | let t_of_sexp sexp = packed_of_m (M.Packed.t_of_sexp sexp) 542 | let globalize { f = T field } = { f = T (globalize0 field) } 543 | let pack field = { f = T field } 544 | let pack__local field = { f = T field } 545 | 546 | include%template Comparator.Make [@mode portable] (struct 547 | type nonrec t = t 548 | 549 | let compare = compare 550 | let sexp_of_t = sexp_of_t 551 | end) 552 | end 553 | 554 | let which t = Packed.packed_of_m (M.which t) 555 | end 556 | 557 | (*$*) 558 | -------------------------------------------------------------------------------- /src/typed_deriver_fields.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Ppxlib 3 | 4 | let gen_sig_t ~loc ~params = 5 | let open (val Syntax.builder loc) in 6 | let unique_id = 7 | Type_kind.generate_unique_id (Type_kind.generate_core_type_params params) 8 | in 9 | let t_params = params @ [ ptyp_var unique_id, (NoVariance, NoInjectivity) ] in 10 | let t = 11 | psig_type 12 | Nonrecursive 13 | [ type_declaration 14 | ~name:(Located.mk "t") 15 | ~params:t_params 16 | ~cstrs:[] 17 | ~kind:Ptype_abstract 18 | ~private_:Public 19 | ~manifest:None 20 | () 21 | ] 22 | in 23 | [ t ] 24 | ;; 25 | 26 | let deriving_compare_equals_attribute ~loc = 27 | let open (val Syntax.builder loc) in 28 | attribute 29 | ~name:(Located.mk "deriving") 30 | ~payload: 31 | (PStr 32 | [ pstr_eval 33 | (pexp_tuple 34 | [ None, [%expr compare ~localize]; None, [%expr equal ~localize] ]) 35 | [] 36 | ]) 37 | ;; 38 | 39 | (** Generates a partial signature without the upper level t and without the upper level 40 | record. *) 41 | let gen_partial_sig ~loc ~params ~t_name = 42 | let open (val Syntax.builder loc) in 43 | let unique_parameter_id = 44 | Type_kind.generate_unique_id (Type_kind.generate_core_type_params params) 45 | in 46 | let core_type_params = Type_kind.generate_core_type_params params in 47 | let t_params = core_type_params @ [ ptyp_var unique_parameter_id ] in 48 | let t_type_constr = ptyp_constr (Lident "t" |> Located.mk) t_params in 49 | let record_type_constr = 50 | ptyp_constr (Lident Names.derived_on_name |> Located.mk) core_type_params 51 | in 52 | let unique_parameter_type_var = ptyp_var unique_parameter_id in 53 | let creator = 54 | psig_type 55 | Recursive 56 | [ Type_kind.generate_creator_type_declaration 57 | ~loc 58 | ~unique_parameter_id 59 | ~core_type_params 60 | ~params 61 | ~t_name 62 | ] 63 | in 64 | let names = [%sigi: val names : string list] in 65 | let name = [%sigi: val name : [%t t_type_constr] -> string] in 66 | let path = [%sigi: val path : [%t t_type_constr] -> string list] in 67 | let ord = [%sigi: val __ord : [%t t_type_constr] -> int list] in 68 | let get = 69 | [%sigi: 70 | val get 71 | : [%t t_type_constr] 72 | -> [%t record_type_constr] 73 | -> [%t unique_parameter_type_var]] 74 | in 75 | let set = 76 | [%sigi: 77 | val set 78 | : [%t t_type_constr] 79 | -> [%t record_type_constr] 80 | -> [%t unique_parameter_type_var] 81 | -> [%t record_type_constr]] 82 | in 83 | let globalize0 = [%sigi: val globalize0 : [%t t_type_constr] -> [%t t_type_constr]] in 84 | let creator_type_constr = 85 | ptyp_constr (Lident "creator" |> Located.mk) core_type_params 86 | in 87 | let create = 88 | [%sigi: val create : [%t creator_type_constr] -> [%t record_type_constr]] 89 | in 90 | let create_local = 91 | [%sigi: val create_local : [%t creator_type_constr] -> [%t record_type_constr]] 92 | in 93 | let type_ids = 94 | let signature = 95 | let t_type = 96 | ptyp_constr 97 | (Lident "t" |> Located.mk) 98 | (List.mapi core_type_params ~f:(fun index _ -> 99 | ptyp_constr 100 | (Ldot (Lident [%string "T%{(index + 1)#Int}"], "t") |> Located.mk) 101 | []) 102 | @ [ unique_parameter_type_var ]) 103 | in 104 | pmty_signature 105 | (signature 106 | [ [%sigi: 107 | val type_id 108 | : [%t t_type] 109 | -> [%t unique_parameter_type_var] Base.Type_equal.Id.t] 110 | ]) 111 | in 112 | let number_of_parameters = List.length core_type_params in 113 | let signature_with_functors = 114 | List.foldi core_type_params ~init:signature ~f:(fun index acc _ -> 115 | pmty_functor 116 | (Named 117 | ( Some [%string "T%{(number_of_parameters - index)#Int}"] |> Located.mk 118 | , pmty_ident (Ldot (Lident "Base", "T") |> Located.mk) 119 | , [] ) 120 | |> Ppxlib_jane.Shim.Functor_parameter.to_parsetree) 121 | acc) 122 | in 123 | psig_module 124 | (module_declaration (Some "Type_ids" |> Located.mk) signature_with_functors) 125 | in 126 | let packed = 127 | let signature = 128 | let field_type_declaration = 129 | let td = 130 | Typed_deriver.generate_packed_field_type_declaration 131 | ~loc 132 | ~params 133 | ~unique_parameter_id 134 | ~t_type_constr 135 | in 136 | psig_type Recursive [ td ] 137 | in 138 | let field_type = ptyp_constr (Lident "field" |> Located.mk) t_params in 139 | let t_prime_type_declaration = 140 | let td = 141 | Typed_deriver.generate_packed_t_prime_type_declaration 142 | ~loc 143 | ~params 144 | ~core_type_params 145 | ~field_type 146 | in 147 | let td = 148 | { td with 149 | ptype_attributes = 150 | Typed_deriver.disable_warning_37 ~loc :: td.ptype_attributes 151 | } 152 | in 153 | psig_type Recursive [ td ] 154 | in 155 | let t_type_declaration = 156 | let td = 157 | Typed_deriver.generate_packed_t_type_declaration ~loc ~core_type_params 158 | in 159 | let td = 160 | { td with 161 | ptype_attributes = 162 | deriving_compare_equals_attribute ~loc :: td.ptype_attributes 163 | } 164 | in 165 | psig_type Recursive [ td ] 166 | in 167 | let sexp_of_t = [%sigi: val sexp_of_t : t -> Sexplib.Sexp.t] in 168 | let sexp_of_t__stack = [%sigi: val sexp_of_t__stack : t -> Sexplib.Sexp.t] in 169 | let t_of_sexp = [%sigi: val t_of_sexp : Sexplib.Sexp.t -> t] in 170 | let all = [%sigi: val all : t list] in 171 | let pack = 172 | let field_type_constr = ptyp_constr (Lident "field" |> Located.mk) t_params in 173 | [%sigi: val pack : [%t field_type_constr] -> t] 174 | in 175 | let pack__local = 176 | let field_type_constr = ptyp_constr (Lident "field" |> Located.mk) t_params in 177 | [%sigi: val pack__local : [%t field_type_constr] -> t] 178 | in 179 | pmty_signature 180 | (signature 181 | [ field_type_declaration 182 | ; t_prime_type_declaration 183 | ; t_type_declaration 184 | ; pack 185 | ; pack__local 186 | ; sexp_of_t 187 | ; sexp_of_t__stack 188 | ; t_of_sexp 189 | ; all 190 | ]) 191 | in 192 | psig_module (module_declaration (Some "Packed" |> Located.mk) signature) 193 | in 194 | [ [%sigi: 195 | include 196 | [%m 197 | pmty_signature 198 | (signature 199 | [ creator 200 | ; name 201 | ; path 202 | ; ord 203 | ; get 204 | ; set 205 | ; create 206 | ; create_local 207 | ; type_ids 208 | ; globalize0 209 | ; packed 210 | ; names 211 | ])]] 212 | ] 213 | ;; 214 | 215 | (** Either generates either `include Typed_fields_lib.SN with type original := original` 216 | or the fully generated partial signature if the number of parameter is above 5. *) 217 | let generate_include_signature_for_opaque ~loc ~params = 218 | match List.length params with 219 | | 0 -> [ [%sigi: include Typed_fields_lib.S with type derived_on := derived_on] ] 220 | | 1 -> 221 | [ [%sigi: include Typed_fields_lib.S1 with type 't1 derived_on := 't1 derived_on] ] 222 | | 2 -> 223 | [ [%sigi: 224 | include 225 | Typed_fields_lib.S2 with type ('t1, 't2) derived_on := ('t1, 't2) derived_on] 226 | ] 227 | | 3 -> 228 | [ [%sigi: 229 | include 230 | Typed_fields_lib.S3 231 | with type ('t1, 't2, 't3) derived_on := ('t1, 't2, 't3) derived_on] 232 | ] 233 | | 4 -> 234 | [ [%sigi: 235 | include 236 | Typed_fields_lib.S4 237 | with type ('t1, 't2, 't3, 't4) derived_on := ('t1, 't2, 't3, 't4) derived_on] 238 | ] 239 | | 5 -> 240 | [ [%sigi: 241 | include 242 | Typed_fields_lib.S5 243 | with type ('t1, 't2, 't3, 't4, 't5) derived_on := 244 | ('t1, 't2, 't3, 't4, 't5) derived_on] 245 | ] 246 | | _ -> gen_sig_t ~loc ~params @ gen_partial_sig ~loc ~params ~t_name:"t" 247 | ;; 248 | 249 | let generate_include_signature ~loc ~params = 250 | match List.length params with 251 | | 0 -> 252 | [ [%sigi: 253 | include 254 | Typed_fields_lib.S with type 'a t := 'a t and type derived_on := derived_on] 255 | ] 256 | | 1 -> 257 | [ [%sigi: 258 | include 259 | Typed_fields_lib.S1 260 | with type ('t1, 'a) t := ('t1, 'a) t 261 | and type 't1 derived_on := 't1 derived_on] 262 | ] 263 | | 2 -> 264 | [ [%sigi: 265 | include 266 | Typed_fields_lib.S2 267 | with type ('t1, 't2, 'a) t := ('t1, 't2, 'a) t 268 | and type ('t1, 't2) derived_on := ('t1, 't2) derived_on] 269 | ] 270 | | 3 -> 271 | [ [%sigi: 272 | include 273 | Typed_fields_lib.S3 274 | with type ('t1, 't2, 't3, 'a) t := ('t1, 't2, 't3, 'a) t 275 | and type ('t1, 't2, 't3) derived_on := ('t1, 't2, 't3) derived_on] 276 | ] 277 | | 4 -> 278 | [ [%sigi: 279 | include 280 | Typed_fields_lib.S4 281 | with type ('t1, 't2, 't3, 't4, 'a) t := ('t1, 't2, 't3, 't4, 'a) t 282 | and type ('t1, 't2, 't3, 't4) derived_on := ('t1, 't2, 't3, 't4) derived_on] 283 | ] 284 | | 5 -> 285 | [ [%sigi: 286 | include 287 | Typed_fields_lib.S5 288 | with type ('t1, 't2, 't3, 't4, 't5, 'a) t := ('t1, 't2, 't3, 't4, 't5, 'a) t 289 | and type ('t1, 't2, 't3, 't4, 't5) derived_on := 290 | ('t1, 't2, 't3, 't4, 't5) derived_on] 291 | ] 292 | | _ -> gen_partial_sig ~loc ~params ~t_name:"t" 293 | ;; 294 | 295 | let generate_str_body 296 | (type a) 297 | (module Specific_generator : Type_kind.S with type t = a) 298 | ~original_type 299 | ~original_kind 300 | ~loc 301 | ~(elements_to_convert : (a * Type_kind.granularity) list) 302 | ~params 303 | = 304 | let open (val Syntax.builder loc) in 305 | let ({ gadt_t = t; upper; constructor_declarations; internal_gadt_rename } 306 | : a Type_kind.gen_t_result) 307 | = 308 | Generic_generator.gen_t 309 | ~loc 310 | ~generate_constructors:Specific_generator.constructor_declarations 311 | ~original_type 312 | ~original_kind 313 | ~elements_to_convert 314 | ~params 315 | ~upper_name:"typed_common_original" 316 | in 317 | let upper = pstr_type Nonrecursive [ upper ] in 318 | let t = pstr_type Recursive [ t ] in 319 | let internal_gadt_rename = pstr_type Recursive [ internal_gadt_rename ] in 320 | let core_type_params = Type_kind.generate_core_type_params params in 321 | let unique_parameter_id = Type_kind.generate_unique_id core_type_params in 322 | let creator_type = 323 | pstr_type 324 | Recursive 325 | [ Type_kind.generate_creator_type_declaration 326 | ~loc 327 | ~unique_parameter_id 328 | ~core_type_params 329 | ~params 330 | ~t_name:Type_kind.internal_gadt_name 331 | ] 332 | in 333 | let names = 334 | let names = Specific_generator.names_list ~loc ~elements_to_convert in 335 | [%stri let names = [%e names]] 336 | in 337 | let name = 338 | let function_body = Specific_generator.name_function_body ~loc in 339 | let arrow_type = ptyp_constr (Lident "string" |> Located.mk) [] in 340 | Typed_deriver.generate_new_typed_function 341 | ~loc 342 | ~function_name:"name" 343 | ~core_type_params 344 | ~unique_parameter_id 345 | ~arg_modes:(Ppxlib_jane.Shim.Modes.local ~loc) 346 | ~constr_arrow_type:arrow_type 347 | ~var_arrow_type:arrow_type 348 | ~function_body 349 | ~name_of_first_parameter:(Lident Type_kind.internal_gadt_name) 350 | () 351 | in 352 | let path = 353 | let function_body = Specific_generator.path_function_body ~loc ~elements_to_convert in 354 | let arrow_type = 355 | ptyp_constr 356 | (Lident "list" |> Located.mk) 357 | [ ptyp_constr (Lident "string" |> Located.mk) [] ] 358 | in 359 | Typed_deriver.generate_new_typed_function 360 | ~loc 361 | ~function_name:"path" 362 | ~core_type_params 363 | ~unique_parameter_id 364 | ~arg_modes:(Ppxlib_jane.Shim.Modes.local ~loc) 365 | ~constr_arrow_type:arrow_type 366 | ~var_arrow_type:arrow_type 367 | ~function_body 368 | ~name_of_first_parameter:(Lident Type_kind.internal_gadt_name) 369 | () 370 | in 371 | let ord = 372 | let function_body = Specific_generator.ord_function_body ~loc ~elements_to_convert in 373 | let arrow_type = 374 | ptyp_constr 375 | (Lident "list" |> Located.mk) 376 | [ ptyp_constr (Lident "int" |> Located.mk) [] ] 377 | in 378 | Typed_deriver.generate_new_typed_function 379 | ~loc 380 | ~function_name:"__ord" 381 | ~core_type_params 382 | ~unique_parameter_id 383 | ~arg_modes:(Ppxlib_jane.Shim.Modes.local ~loc) 384 | ~constr_arrow_type:arrow_type 385 | ~var_arrow_type:arrow_type 386 | ~function_body 387 | ~name_of_first_parameter:(Lident Type_kind.internal_gadt_name) 388 | () 389 | in 390 | let constr_record_type = 391 | ptyp_constr 392 | (Lident Names.derived_on_name |> Located.mk) 393 | (List.filter_map core_type_params ~f:(fun { ptyp_desc; _ } -> 394 | match Ppxlib_jane.Shim.Core_type_desc.of_parsetree ptyp_desc with 395 | | Ptyp_var (name, _) -> Some (ptyp_constr (Lident name |> Located.mk) []) 396 | | _ -> None)) 397 | in 398 | let var_record_type = 399 | ptyp_constr (Lident Names.derived_on_name |> Located.mk) core_type_params 400 | in 401 | let get = 402 | let function_body = Specific_generator.get_function_body ~loc ~elements_to_convert in 403 | Typed_deriver.generate_new_typed_function 404 | ~loc 405 | ~function_name:"get" 406 | ~core_type_params 407 | ~unique_parameter_id 408 | ~arg_modes:(Ppxlib_jane.Shim.Modes.local ~loc) 409 | ~constr_arrow_type: 410 | (ptyp_arrow 411 | { arg_label = Nolabel; arg_type = constr_record_type; arg_modes = [] } 412 | { result_type = ptyp_constr (Lident unique_parameter_id |> Located.mk) [] 413 | ; result_modes = [] 414 | }) 415 | ~var_arrow_type: 416 | (ptyp_arrow 417 | { arg_label = Nolabel; arg_type = var_record_type; arg_modes = [] } 418 | { result_type = ptyp_var unique_parameter_id; result_modes = [] }) 419 | ~function_body 420 | ~name_of_first_parameter:(Lident Type_kind.internal_gadt_name) 421 | () 422 | in 423 | let set = 424 | let function_body = Specific_generator.set_function_body ~loc ~elements_to_convert in 425 | Typed_deriver.generate_new_typed_function 426 | ~loc 427 | ~function_name:"set" 428 | ~core_type_params 429 | ~unique_parameter_id 430 | ~arg_modes:(Ppxlib_jane.Shim.Modes.local ~loc) 431 | ~constr_arrow_type: 432 | (ptyp_arrow 433 | { arg_label = Nolabel; arg_type = constr_record_type; arg_modes = [] } 434 | { result_type = 435 | ptyp_arrow 436 | { arg_label = Nolabel 437 | ; arg_type = ptyp_constr (Lident unique_parameter_id |> Located.mk) [] 438 | ; arg_modes = [] 439 | } 440 | { result_type = constr_record_type; result_modes = [] } 441 | ; result_modes = [] 442 | }) 443 | ~var_arrow_type: 444 | (ptyp_arrow 445 | { arg_label = Nolabel; arg_type = var_record_type; arg_modes = [] } 446 | { result_type = 447 | ptyp_arrow 448 | { arg_label = Nolabel 449 | ; arg_type = ptyp_var unique_parameter_id 450 | ; arg_modes = [] 451 | } 452 | { result_type = var_record_type; result_modes = [] } 453 | ; result_modes = [] 454 | }) 455 | ~function_body 456 | ~name_of_first_parameter:(Lident Type_kind.internal_gadt_name) 457 | () 458 | in 459 | let create = 460 | let body = 461 | Specific_generator.create_function_body ~loc ~constructor_declarations ~local:false 462 | in 463 | let creator_constr_type = 464 | ptyp_constr (Lident "creator" |> Located.mk) core_type_params 465 | in 466 | match constructor_declarations with 467 | | [] -> 468 | [%stri 469 | let create ({ f = _ } : [%t creator_constr_type]) : [%t var_record_type] = 470 | [%e body] 471 | ;;] 472 | | _ :: _ -> 473 | [%stri 474 | let create ({ f = __ppx_typed_fields_creator_f } : [%t creator_constr_type]) 475 | : [%t var_record_type] 476 | = 477 | [%e body] 478 | ;;] 479 | in 480 | let create_local = 481 | let body = 482 | Specific_generator.create_function_body ~loc ~constructor_declarations ~local:true 483 | in 484 | let creator_constr_type = 485 | ptyp_constr (Lident "creator" |> Located.mk) core_type_params 486 | in 487 | match constructor_declarations with 488 | | [] -> 489 | [%stri 490 | let create_local ({ f = _ } : [%t creator_constr_type]) : [%t var_record_type] = 491 | [%e body] 492 | ;;] 493 | | _ :: _ -> 494 | [%stri 495 | let create_local ({ f = __ppx_typed_fields_creator_f } : [%t creator_constr_type]) 496 | : [%t var_record_type] 497 | = 498 | [%e body] 499 | ;;] 500 | in 501 | let type_ids = 502 | let type_ids = 503 | Specific_generator.type_ids ~loc ~elements_to_convert ~core_type_params 504 | in 505 | let subproduct_type_id_modules = 506 | Specific_generator.subproduct_type_id_modules 507 | ~loc 508 | ~elements_to_convert 509 | ~core_type_params 510 | in 511 | let type_id = 512 | let function_body = 513 | Specific_generator.type_id_function_body ~loc ~elements_to_convert 514 | in 515 | let type_equal_t = 516 | List.fold 517 | [ "Type_equal"; "Id"; "t" ] 518 | ~init:(Lident "Base") 519 | ~f:(fun acc new_label -> Ldot (acc, new_label)) 520 | |> Located.mk 521 | in 522 | Typed_deriver.generate_new_typed_function 523 | ~loc 524 | ~function_name:"type_id" 525 | ~core_type_params: 526 | (List.init (List.length core_type_params) ~f:(fun index -> 527 | ptyp_constr 528 | (Ldot (Lident [%string "T%{(index + 1)#Int}"], "t") |> Located.mk) 529 | [])) 530 | ~unique_parameter_id 531 | ~function_body 532 | ~arg_modes:(Ppxlib_jane.Shim.Modes.local ~loc) 533 | ~constr_arrow_type: 534 | (ptyp_constr 535 | type_equal_t 536 | [ ptyp_constr (Lident unique_parameter_id |> Located.mk) [] ]) 537 | ~var_arrow_type:(ptyp_constr type_equal_t [ ptyp_var unique_parameter_id ]) 538 | ~name_of_first_parameter:(Lident Type_kind.internal_gadt_name) 539 | () 540 | in 541 | let number_of_parameters = List.length core_type_params in 542 | let functor_expression = 543 | List.foldi 544 | core_type_params 545 | ~init:(pmod_structure (type_ids @ subproduct_type_id_modules @ [ type_id ])) 546 | ~f:(fun index acc _ -> 547 | pmod_functor 548 | (Named 549 | ( Some [%string "T%{(number_of_parameters - index)#Int}"] |> Located.mk 550 | , pmty_ident (Ldot (Lident "Base", "T") |> Located.mk) 551 | , [] ) 552 | |> Ppxlib_jane.Shim.Functor_parameter.to_parsetree) 553 | acc) 554 | in 555 | [%stri module Type_ids = [%m functor_expression]] 556 | in 557 | let t_params = core_type_params @ [ ptyp_var unique_parameter_id ] in 558 | let t_type_constr = 559 | ptyp_constr (Lident Type_kind.internal_gadt_name |> Located.mk) t_params 560 | in 561 | let field_type = ptyp_constr (Lident "field" |> Located.mk) t_params in 562 | let globalize0 = 563 | let var_arrow_type = t_type_constr in 564 | let constr_arrow_type = 565 | ptyp_constr 566 | (Lident Type_kind.internal_gadt_name |> Located.mk) 567 | (List.map t_params ~f:(fun core_type -> 568 | match Ppxlib_jane.Shim.Core_type_desc.of_parsetree core_type.ptyp_desc with 569 | | Ptyp_var (name, _) -> 570 | { core_type with ptyp_desc = Ptyp_constr (Located.mk (Lident name), []) } 571 | | _ -> core_type)) 572 | in 573 | Typed_deriver.generate_new_typed_function 574 | ~loc 575 | ~function_name:"globalize0" 576 | ~core_type_params 577 | ~unique_parameter_id 578 | ~arg_modes:(Ppxlib_jane.Shim.Modes.local ~loc) 579 | ~result_modes:[] 580 | ~var_arrow_type 581 | ~constr_arrow_type 582 | ~function_body: 583 | (Specific_generator.globalize0_function_body ~loc ~elements_to_convert) 584 | ~name_of_first_parameter:(Lident Type_kind.internal_gadt_name) 585 | () 586 | in 587 | let globalize = 588 | let body = 589 | eabstract (List.map t_params ~f:(fun _ -> ppat_any)) [%expr fun t -> globalize0 t] 590 | in 591 | [%stri let globalize = [%e body]] 592 | in 593 | let packed = 594 | let packed_field = 595 | let td = 596 | Typed_deriver.generate_packed_field_type_declaration 597 | ~loc 598 | ~params 599 | ~unique_parameter_id 600 | ~t_type_constr 601 | in 602 | pstr_type Recursive [ td ] 603 | in 604 | let t_prime_type_declaration = 605 | let td = 606 | Typed_deriver.generate_packed_t_prime_type_declaration 607 | ~loc 608 | ~params 609 | ~core_type_params 610 | ~field_type 611 | in 612 | let td = 613 | { td with 614 | ptype_attributes = Typed_deriver.disable_warning_37 ~loc :: td.ptype_attributes 615 | } 616 | in 617 | pstr_type Recursive [ td ] 618 | in 619 | let t_type_declaration = 620 | let td = Typed_deriver.generate_packed_t_type_declaration ~loc ~core_type_params in 621 | pstr_type Recursive [ td ] 622 | in 623 | let all = 624 | let all_list_expression = 625 | Specific_generator.all_body ~loc ~constructor_declarations 626 | in 627 | [%stri let all = [%e all_list_expression]] 628 | in 629 | let compare = 630 | [%stri 631 | let compare { f = T x1 } { f = T x2 } = 632 | Base.List.compare Base.Int.compare (__ord x1) (__ord x2) 633 | ;;] 634 | in 635 | let compare__local = 636 | [%stri 637 | let compare__local { f = T x1 } { f = T x2 } = 638 | Base.List.compare__local Base.Int.compare__local (__ord x1) (__ord x2) 639 | ;;] 640 | in 641 | let equal = 642 | [%stri let equal packed_1 packed_2 = Base.Int.equal 0 (compare packed_1 packed_2)] 643 | in 644 | let equal__local = 645 | [%stri 646 | let equal__local packed_1 packed_2 = 647 | Base.Int.equal 0 (compare__local packed_1 packed_2) 648 | ;;] 649 | in 650 | let hash_fold_t = 651 | [%stri 652 | let hash_fold_t state { f = T x } = 653 | Base.List.hash_fold_t Base.Int.hash_fold_t state (__ord x) 654 | ;;] 655 | in 656 | let hash = [%stri let hash t = Base.Hash.of_fold hash_fold_t t] in 657 | let pack ~local = 658 | let function_body = Specific_generator.pack_body ~loc ~elements_to_convert ~local in 659 | let arrow_type = ptyp_constr (Lident "t" |> Located.mk) [] in 660 | let modes = if local then Ppxlib_jane.Shim.Modes.local ~loc else [] in 661 | Typed_deriver.generate_new_typed_function 662 | ~loc 663 | ~function_name:(Names.localize "pack" ~local) 664 | ~core_type_params 665 | ~unique_parameter_id 666 | ~arg_modes:modes 667 | ~result_modes:modes 668 | ~constr_arrow_type:arrow_type 669 | ~var_arrow_type:arrow_type 670 | ~function_body 671 | ~name_of_first_parameter:(Lident "field") 672 | () 673 | in 674 | let globalize_packed = 675 | [%stri 676 | let globalize : t -> t = 677 | [%e Specific_generator.globalize_packed_function_body ~loc ~elements_to_convert] 678 | ;;] 679 | in 680 | let sexp_of_packed ~stack = 681 | let function_body = 682 | Specific_generator.sexp_of_t_body ~loc ~elements_to_convert ~stack 683 | in 684 | let name = Names.stackify "sexp_of_t" ~stack in 685 | let pat = 686 | match stack with 687 | | false -> [%pat? packed] 688 | | true -> ppat_constraint [%pat? packed] None (Ppxlib_jane.Shim.Modes.local ~loc) 689 | in 690 | [%stri let [%p pvar name] = fun [%p pat] -> [%e function_body]] 691 | in 692 | let packed_of_sexp = 693 | let function_body = Specific_generator.t_of_sexp_body ~loc ~elements_to_convert in 694 | [%stri let t_of_sexp sexp = [%e function_body]] 695 | in 696 | let comparator = 697 | [%stri 698 | include Base.Comparator.Make__portable (struct 699 | type nonrec t = t 700 | 701 | let compare = compare 702 | let sexp_of_t = sexp_of_t 703 | end)] 704 | in 705 | pstr_module 706 | (module_binding 707 | ~name:(Some "Packed" |> Located.mk) 708 | ~expr: 709 | (pmod_structure 710 | [ packed_field 711 | ; t_prime_type_declaration 712 | ; t_type_declaration 713 | ; all 714 | ; compare 715 | ; compare__local 716 | ; equal 717 | ; equal__local 718 | ; hash_fold_t 719 | ; hash 720 | ; pack ~local:false 721 | ; pack ~local:true 722 | ; globalize_packed 723 | ; sexp_of_packed ~stack:false 724 | ; sexp_of_packed ~stack:true 725 | ; packed_of_sexp 726 | ; comparator 727 | ])) 728 | in 729 | let upper_rename = 730 | let td = 731 | type_declaration 732 | ~name:(Located.mk Names.derived_on_name) 733 | ~params 734 | ~cstrs:[] 735 | ~private_:Public 736 | ~kind:Ptype_abstract 737 | ~manifest: 738 | (Some 739 | (ptyp_constr (Lident "typed_common_original" |> Located.mk) core_type_params)) 740 | () 741 | in 742 | pstr_type Recursive [ td ] 743 | in 744 | [ upper; t; upper_rename ] 745 | @ Specific_generator.extra_structure_items_to_insert loc 746 | @ [ creator_type 747 | ; path 748 | ; name 749 | ; ord 750 | ; get 751 | ; set 752 | ; create 753 | ; create_local 754 | ; type_ids 755 | ; globalize0 756 | ; globalize 757 | ; packed 758 | ; names 759 | ; internal_gadt_rename 760 | ] 761 | ;; 762 | 763 | (** Generates a structure with the two submodules, Shallow, Deep and exposes the full 764 | depth version of Deep. *) 765 | let gen_str 766 | (type a) 767 | (module Specific_generator : Type_kind.S with type t = a) 768 | ~original_type 769 | ~original_kind 770 | ~loc 771 | ~(elements_to_convert : (a * Type_kind.granularity) list) 772 | ~params 773 | = 774 | let open (val Syntax.builder loc) in 775 | let shallow_module = 776 | let singleton_modules = 777 | Specific_generator.singleton_modules_structures ~loc ~elements_to_convert 778 | in 779 | let deep_application_expr = 780 | List.fold 781 | singleton_modules 782 | ~init:(pmod_ident (Lident "Deep" |> Located.mk)) 783 | ~f:(fun acc (_, ident) -> 784 | pmod_apply acc (pmod_ident (Lident ident |> Located.mk))) 785 | in 786 | List.map singleton_modules ~f:(fun (f, _) -> f) 787 | @ [ pstr_module 788 | (module_binding 789 | ~name:(Some "Shallow" |> Located.mk) 790 | ~expr:deep_application_expr) 791 | ] 792 | in 793 | let deep_module = 794 | let module_expr = 795 | let deep_contents = 796 | pmod_structure 797 | (generate_str_body 798 | (module Specific_generator) 799 | ~original_type 800 | ~original_kind 801 | ~loc 802 | ~elements_to_convert 803 | ~params) 804 | in 805 | Specific_generator.deep_functor_structure 806 | ~loc 807 | ~elements_to_convert 808 | ~module_expression:deep_contents 809 | in 810 | pstr_module (module_binding ~name:(Some "Deep" |> Located.mk) ~expr:module_expr) 811 | in 812 | let full_depth = Specific_generator.full_depth_module ~loc ~elements_to_convert in 813 | (deep_module :: shallow_module) @ full_depth 814 | ;; 815 | --------------------------------------------------------------------------------