pax_global_header00006660000000000000000000000064136631505570014525gustar00rootroot0000000000000052 comment=8df563706fb3a2f1872040abb73fcb191b18361c typerep-0.14.0/000077500000000000000000000000001366315055700132775ustar00rootroot00000000000000typerep-0.14.0/.gitignore000066400000000000000000000000411366315055700152620ustar00rootroot00000000000000_build *.install *.merlin _opam typerep-0.14.0/CHANGES.md000066400000000000000000000014051366315055700146710ustar00rootroot00000000000000## 113.43.00 - Change `typerep_lib` to use the type `lazy_t` rather than `Lazy.t`. The ocaml_plugin library's `Ocaml_compiler` compiles modules in an environment where the compiler cannot determine that `Lazy.t` and `lazy_t` are the same - thus with the current version of typerep_lib plugins effectively cannot use `@@deriving typerep`. ## 113.24.00 - Add whether record fields are mutable. ## 112.24.00 - Remove unused "bin_proj" rewriter. ## 112.17.00 - Split out typerep_extended which is now using core_kernel ## 111.06.00 - Renamed `Typerep` libraries for more consistency with the rest of the framework. ```ocaml Typerep_kernel --> Typerep_lib Typerep_core --> Typerep_extended Typereplib --> Typerep_experimental ``` typerep-0.14.0/CONTRIBUTING.md000066400000000000000000000044101366315055700155270ustar00rootroot00000000000000This repository contains open source software that is developed and maintained by [Jane Street][js]. Contributions to this project are welcome and should be submitted via GitHub pull requests. Signing contributions --------------------- We require that you sign your contributions. Your signature certifies that you wrote the patch or otherwise have the right to pass it on as an open-source patch. The rules are pretty simple: if you can certify the below (from [developercertificate.org][dco]): ``` Developer Certificate of Origin Version 1.1 Copyright (C) 2004, 2006 The Linux Foundation and its contributors. 1 Letterman Drive Suite D4700 San Francisco, CA, 94129 Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Developer's Certificate of Origin 1.1 By making a contribution to this project, I certify that: (a) The contribution was created in whole or in part by me and I have the right to submit it under the open source license indicated in the file; or (b) The contribution is based upon previous work that, to the best of my knowledge, is covered under an appropriate open source license and I have the right under that license to submit that work with modifications, whether created in whole or in part by me, under the same open source license (unless I am permitted to submit under a different license), as indicated in the file; or (c) The contribution was provided directly to me by some other person who certified (a), (b) or (c) and I have not modified it. (d) I understand and agree that this project and the contribution are public and that a record of the contribution (including all personal information I submit with it, including my sign-off) is maintained indefinitely and may be redistributed consistent with this project or the open source license(s) involved. ``` Then you just add a line to every git commit message: ``` Signed-off-by: Joe Smith ``` Use your real name (sorry, no pseudonyms or anonymous contributions.) If you set your `user.name` and `user.email` git configs, you can sign your commit automatically with git commit -s. [dco]: http://developercertificate.org/ [js]: https://opensource.janestreet.com/ typerep-0.14.0/LICENSE.md000066400000000000000000000021351366315055700147040ustar00rootroot00000000000000The MIT License Copyright (c) 2013--2020 Jane Street Group, LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. typerep-0.14.0/Makefile000066400000000000000000000004031366315055700147340ustar00rootroot00000000000000INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) default: dune build install: dune install $(INSTALL_ARGS) uninstall: dune uninstall $(INSTALL_ARGS) reinstall: uninstall install clean: dune clean .PHONY: default install uninstall reinstall clean typerep-0.14.0/dune-project000066400000000000000000000000201366315055700156110ustar00rootroot00000000000000(lang dune 1.10)typerep-0.14.0/lib/000077500000000000000000000000001366315055700140455ustar00rootroot00000000000000typerep-0.14.0/lib/dune000066400000000000000000000001421366315055700147200ustar00rootroot00000000000000(library (name typerep_lib) (public_name typerep) (preprocess no_preprocessing) (libraries base))typerep-0.14.0/lib/make_typename.ml000066400000000000000000000101771366315055700172240ustar00rootroot00000000000000open Std_internal module Make0 (X : Named_intf.S0) = struct module Name_of_x = Typename.Make0 (X) let typename_of_t = Name_of_x.typename_of_t let named = Typerep.Named.T0 (module struct type named = X.t type t = X.t let typename_of_named = Name_of_x.typename_of_t let typename_of_t = typename_of_t let witness = Type_equal.refl end : Typerep.Named.T0 with type t = X.t) end module Make1 (X : Named_intf.S1) = struct module Name_of_x = Typename.Make1 (X) let typename_of_t = Name_of_x.typename_of_t let named (type p1) of_p1 = let typename_of_t = Name_of_x.typename_of_t (Typerep.typename_of_t of_p1) in Typerep.Named.T1 (module struct type 'a named = 'a X.t type a = p1 let a = of_p1 type t = p1 X.t let typename_of_named = Name_of_x.typename_of_t let typename_of_t = typename_of_t let witness = Type_equal.refl end : Typerep.Named.T1 with type t = p1 X.t) end module Make2 (X : Named_intf.S2) = struct module Name_of_x = Typename.Make2 (X) let typename_of_t = Name_of_x.typename_of_t let named (type p1) (type p2) of_p1 of_p2 = let typename_of_t = Name_of_x.typename_of_t (Typerep.typename_of_t of_p1) (Typerep.typename_of_t of_p2) in Typerep.Named.T2 (module struct type ('a, 'b) named = ('a, 'b) X.t type a = p1 let a = of_p1 type b = p2 let b = of_p2 type t = (p1, p2) X.t let typename_of_named = Name_of_x.typename_of_t let typename_of_t = typename_of_t let witness = Type_equal.refl end : Typerep.Named.T2 with type t = (p1, p2) X.t) end module Make3 (X : Named_intf.S3) = struct module Name_of_x = Typename.Make3 (X) let typename_of_t = Name_of_x.typename_of_t let named (type p1) (type p2) (type p3) of_p1 of_p2 of_p3 = let typename_of_t = Name_of_x.typename_of_t (Typerep.typename_of_t of_p1) (Typerep.typename_of_t of_p2) (Typerep.typename_of_t of_p3) in Typerep.Named.T3 (module struct type ('a, 'b, 'c) named = ('a, 'b, 'c) X.t type a = p1 let a = of_p1 type b = p2 let b = of_p2 type c = p3 let c = of_p3 type t = (p1, p2, p3) X.t let typename_of_named = Name_of_x.typename_of_t let typename_of_t = typename_of_t let witness = Type_equal.refl end : Typerep.Named.T3 with type t = (p1, p2, p3) X.t) end module Make4 (X : Named_intf.S4) = struct module Name_of_x = Typename.Make4 (X) let typename_of_t = Name_of_x.typename_of_t let named (type p1) (type p2) (type p3) (type p4) of_p1 of_p2 of_p3 of_p4 = let typename_of_t = Name_of_x.typename_of_t (Typerep.typename_of_t of_p1) (Typerep.typename_of_t of_p2) (Typerep.typename_of_t of_p3) (Typerep.typename_of_t of_p4) in Typerep.Named.T4 (module struct type ('a, 'b, 'c, 'd) named = ('a, 'b, 'c, 'd) X.t type a = p1 let a = of_p1 type b = p2 let b = of_p2 type c = p3 let c = of_p3 type d = p4 let d = of_p4 type t = (p1, p2, p3, p4) X.t let typename_of_named = Name_of_x.typename_of_t let typename_of_t = typename_of_t let witness = Type_equal.refl end : Typerep.Named.T4 with type t = (p1, p2, p3, p4) X.t) end module Make5 (X : Named_intf.S5) = struct module Name_of_x = Typename.Make5 (X) let typename_of_t = Name_of_x.typename_of_t let named (type p1) (type p2) (type p3) (type p4) (type p5) of_p1 of_p2 of_p3 of_p4 of_p5 = let typename_of_t = Name_of_x.typename_of_t (Typerep.typename_of_t of_p1) (Typerep.typename_of_t of_p2) (Typerep.typename_of_t of_p3) (Typerep.typename_of_t of_p4) (Typerep.typename_of_t of_p5) in Typerep.Named.T5 (module struct type ('a, 'b, 'c, 'd, 'e) named = ('a, 'b, 'c, 'd, 'e) X.t type a = p1 let a = of_p1 type b = p2 let b = of_p2 type c = p3 let c = of_p3 type d = p4 let d = of_p4 type e = p5 let e = of_p5 type t = (p1, p2, p3, p4, p5) X.t let typename_of_named = Name_of_x.typename_of_t let typename_of_t = typename_of_t let witness = Type_equal.refl end : Typerep.Named.T5 with type t = (p1, p2, p3, p4, p5) X.t) end typerep-0.14.0/lib/make_typename.mli000066400000000000000000000026461366315055700173770ustar00rootroot00000000000000open Std_internal (* Typerep.Named generation helpers *) module Make0 (X : Named_intf.S0) : sig val named : X.t Typerep.Named.t val typename_of_t : X.t Typename.t end module Make1 (X : Named_intf.S1) : sig val named : 'a Typerep.t -> 'a X.t Typerep.Named.t val typename_of_t : 'a Typename.t -> 'a X.t Typename.t end module Make2 (X : Named_intf.S2) : sig val named : 'a Typerep.t -> 'b Typerep.t -> ('a, 'b) X.t Typerep.Named.t val typename_of_t : 'a Typename.t -> 'b Typename.t -> ('a, 'b) X.t Typename.t end module Make3 (X : Named_intf.S3) : sig val named : 'a Typerep.t -> 'b Typerep.t -> 'c Typerep.t -> ('a, 'b, 'c) X.t Typerep.Named.t val typename_of_t : 'a Typename.t -> 'b Typename.t -> 'c Typename.t -> ('a, 'b, 'c) X.t Typename.t end module Make4 (X : Named_intf.S4) : sig val named : 'a Typerep.t -> 'b Typerep.t -> 'c Typerep.t -> 'd Typerep.t -> ('a, 'b, 'c, 'd) X.t Typerep.Named.t val typename_of_t : 'a Typename.t -> 'b Typename.t -> 'c Typename.t -> 'd Typename.t -> ('a, 'b, 'c, 'd) X.t Typename.t end module Make5 (X : Named_intf.S5) : sig val named : 'a Typerep.t -> 'b Typerep.t -> 'c Typerep.t -> 'd Typerep.t -> 'e Typerep.t -> ('a, 'b, 'c, 'd, 'e) X.t Typerep.Named.t val typename_of_t : 'a Typename.t -> 'b Typename.t -> 'c Typename.t -> 'd Typename.t -> 'e Typename.t -> ('a, 'b, 'c, 'd, 'e) X.t Typename.t end typerep-0.14.0/lib/named_intf.ml000066400000000000000000000006101366315055700165000ustar00rootroot00000000000000module type S0 = sig type t val name : string end module type S1 = sig type 'a t val name : string end module type S2 = sig type ('a, 'b) t val name : string end module type S3 = sig type ('a, 'b, 'c) t val name : string end module type S4 = sig type ('a, 'b, 'c, 'd) t val name : string end module type S5 = sig type ('a, 'b, 'c, 'd, 'e) t val name : string end typerep-0.14.0/lib/std.ml000066400000000000000000000004751366315055700151770ustar00rootroot00000000000000module Type_abstract = Type_abstract module Type_equal = Type_equal module Type_generic = Type_generic module Typename = Typename module Make_typename = Make_typename module Type_named_intf = Named_intf module Typerepable = Typerepable module Typerep_obj = Typerep_obj include Std_internal typerep-0.14.0/lib/std_internal.ml000066400000000000000000000505561366315055700171000ustar00rootroot00000000000000module Name_of = struct let typename_of_int = let module M = Typename.Make0(struct type t = int let name = "int" end) in M.typename_of_t let typename_of_int32 = let module M = Typename.Make0(struct type t = int32 let name = "int32" end) in M.typename_of_t let typename_of_int64 = let module M = Typename.Make0(struct type t = int64 let name = "int64" end) in M.typename_of_t let typename_of_nativeint = let module M = Typename.Make0(struct type t = nativeint let name = "nativeint" end) in M.typename_of_t let typename_of_char = let module M = Typename.Make0(struct type t = char let name = "char" end) in M.typename_of_t let typename_of_float = let module M = Typename.Make0(struct type t = float let name = "float" end) in M.typename_of_t let typename_of_string = let module M = Typename.Make0(struct type t = string let name = "string" end) in M.typename_of_t let typename_of_bytes = let module M = Typename.Make0(struct type t = bytes let name = "bytes" end) in M.typename_of_t let typename_of_bool = let module M = Typename.Make0(struct type t = bool let name = "bool" end) in M.typename_of_t let typename_of_unit = let module M = Typename.Make0(struct type t = unit let name = "unit" end) in M.typename_of_t module M_option = Typename.Make1(struct type 'a t = 'a option let name = "option" end) let typename_of_option = M_option.typename_of_t module M_list = Typename.Make1(struct type 'a t = 'a list let name = "list" end) let typename_of_list = M_list.typename_of_t module M_array = Typename.Make1(struct type 'a t = 'a array let name = "array" end) let typename_of_array = M_array.typename_of_t module M_lazy_t = Typename.Make1(struct type 'a t = 'a lazy_t let name = "lazy_t" end) let typename_of_lazy_t = M_lazy_t.typename_of_t module M_ref = Typename.Make1(struct type 'a t = 'a ref let name = "ref" end) let typename_of_ref = M_ref.typename_of_t module M_function = Typename.Make2(struct type ('a, 'b) t = 'a -> 'b let name = "function" end) let typename_of_function = M_function.typename_of_t type tuple0 = unit module M_tuple0 = Typename.Make0(struct type t = tuple0 let name = "tuple0" end) let typename_of_tuple0 = M_tuple0.typename_of_t module M_tuple2 = Typename.Make2(struct type ('a, 'b) t = 'a * 'b let name = "tuple2" end) let typename_of_tuple2 = M_tuple2.typename_of_t module M_tuple3 = Typename.Make3(struct type ('a, 'b, 'c) t = 'a * 'b * 'c let name = "tuple3" end) let typename_of_tuple3 = M_tuple3.typename_of_t module M_tuple4 = Typename.Make4(struct type ('a, 'b, 'c, 'd) t = 'a * 'b * 'c * 'd let name = "tuple4" end) let typename_of_tuple4 = M_tuple4.typename_of_t module M_tuple5 = Typename.Make5(struct type ('a, 'b, 'c, 'd, 'e) t = 'a * 'b * 'c *'d * 'e let name = "tuple5" end) let typename_of_tuple5 = M_tuple5.typename_of_t end module rec Typerep : sig type _ t = | Int : int t | Int32 : int32 t | Int64 : int64 t | Nativeint : nativeint t | Char : char t | Float : float t | String : string t | Bytes : bytes t | Bool : bool t | Unit : unit t | Option : 'a t -> 'a option t | List : 'a t -> 'a list t | Array : 'a t -> 'a array t | Lazy : 'a t -> 'a lazy_t t | Ref : 'a t -> 'a ref t | Function : ('dom t * 'rng t) -> ('dom -> 'rng) t | Tuple : 'a Typerep.Tuple.t -> 'a t | Record : 'a Typerep.Record.t -> 'a t | Variant : 'a Typerep.Variant.t -> 'a t | Named : ('a Typerep.Named.t * 'a t lazy_t option) -> 'a t type packed = T : 'a t -> packed module Named : sig module type T0 = sig type named type t val typename_of_named : named Typename.t val typename_of_t : t Typename.t val witness : (t, named) Type_equal.t end module type T1 = sig type 'a named type a val a : a Typerep.t type t val typename_of_named : 'a Typename.t -> 'a named Typename.t val typename_of_t : t Typename.t val witness : (t, a named) Type_equal.t end module type T2 = sig type ('a, 'b) named type a val a : a Typerep.t type b val b : b Typerep.t type t val typename_of_named : 'a Typename.t -> 'b Typename.t -> ('a, 'b) named Typename.t val typename_of_t : t Typename.t val witness : (t, (a, b) named) Type_equal.t end module type T3 = sig type ('a, 'b, 'c) named type a val a : a Typerep.t type b val b : b Typerep.t type c val c : c Typerep.t type t val typename_of_named : 'a Typename.t -> 'b Typename.t -> 'c Typename.t -> ('a, 'b, 'c) named Typename.t val typename_of_t : t Typename.t val witness : (t, (a, b, c) named) Type_equal.t end module type T4 = sig type ('a, 'b, 'c, 'd) named type a val a : a Typerep.t type b val b : b Typerep.t type c val c : c Typerep.t type d val d : d Typerep.t type t val typename_of_named : 'a Typename.t -> 'b Typename.t -> 'c Typename.t -> 'd Typename.t -> ('a, 'b, 'c, 'd) named Typename.t val typename_of_t : t Typename.t val witness : (t, (a, b, c, d) named) Type_equal.t end module type T5 = sig type ('a, 'b, 'c, 'd, 'e) named type a val a : a Typerep.t type b val b : b Typerep.t type c val c : c Typerep.t type d val d : d Typerep.t type e val e : e Typerep.t type t val typename_of_named : 'a Typename.t -> 'b Typename.t -> 'c Typename.t -> 'd Typename.t -> 'e Typename.t -> ('a, 'b, 'c, 'd, 'e) named Typename.t val typename_of_t : t Typename.t val witness : (t, (a, b, c, d, e) named) Type_equal.t end (* there the module is necessary because we need to deal with a type [t] with parameters whose kind is not representable as a type variable: ['a 't], even with a gadt. *) type 'a t = | T0 of (module T0 with type t = 'a) | T1 of (module T1 with type t = 'a) | T2 of (module T2 with type t = 'a) | T3 of (module T3 with type t = 'a) | T4 of (module T4 with type t = 'a) | T5 of (module T5 with type t = 'a) val arity : _ t -> int val typename_of_t : 'a t -> 'a Typename.t val name : _ t -> string end module Tuple : sig (* these constructors could be plunged at toplevel of Typerep.t, however it is less verbose that way *) type _ t = | T2 : ('a Typerep.t * 'b Typerep.t) -> ('a * 'b) t | T3 : ('a Typerep.t * 'b Typerep.t * 'c Typerep.t) -> ('a * 'b * 'c) t | T4 : ('a Typerep.t * 'b Typerep.t * 'c Typerep.t * 'd Typerep.t) -> ('a * 'b * 'c * 'd) t | T5 : ('a Typerep.t * 'b Typerep.t * 'c Typerep.t * 'd Typerep.t * 'e Typerep.t) -> ('a * 'b * 'c * 'd * 'e) t val arity : _ t -> int val typename_of_t : 'a t -> 'a Typename.t end include Variant_and_record_intf.S with type 'a t := 'a Typerep.t val same : _ t -> _ t -> bool val same_witness : 'a t -> 'b t -> ('a, 'b) Type_equal.t option val same_witness_exn : 'a t -> 'b t -> ('a, 'b) Type_equal.t val typename_of_t : 'a t -> 'a Typename.t val head : 'a t -> 'a t end = struct type _ t = | Int : int t | Int32 : int32 t | Int64 : int64 t | Nativeint : nativeint t | Char : char t | Float : float t | String : string t | Bytes : bytes t | Bool : bool t | Unit : unit t | Option : 'a t -> 'a option t | List : 'a t -> 'a list t | Array : 'a t -> 'a array t | Lazy : 'a t -> 'a lazy_t t | Ref : 'a t -> 'a ref t | Function : ('dom t * 'rng t) -> ('dom -> 'rng) t | Tuple : 'a Typerep.Tuple.t -> 'a t | Record : 'a Typerep.Record.t -> 'a t | Variant : 'a Typerep.Variant.t -> 'a t | Named : ('a Typerep.Named.t * 'a t lazy_t option) -> 'a t type packed = T : 'a t -> packed module Named = struct module type T0 = sig type named type t val typename_of_named : named Typename.t val typename_of_t : t Typename.t val witness : (t, named) Type_equal.t end module type T1 = sig type 'a named type a val a : a Typerep.t type t val typename_of_named : 'a Typename.t -> 'a named Typename.t val typename_of_t : t Typename.t val witness : (t, a named) Type_equal.t end module type T2 = sig type ('a, 'b) named type a val a : a Typerep.t type b val b : b Typerep.t type t val typename_of_named : 'a Typename.t -> 'b Typename.t -> ('a, 'b) named Typename.t val typename_of_t : t Typename.t val witness : (t, (a, b) named) Type_equal.t end module type T3 = sig type ('a, 'b, 'c) named type a val a : a Typerep.t type b val b : b Typerep.t type c val c : c Typerep.t type t val typename_of_named : 'a Typename.t -> 'b Typename.t -> 'c Typename.t -> ('a, 'b, 'c) named Typename.t val typename_of_t : t Typename.t val witness : (t, (a, b, c) named) Type_equal.t end module type T4 = sig type ('a, 'b, 'c, 'd) named type a val a : a Typerep.t type b val b : b Typerep.t type c val c : c Typerep.t type d val d : d Typerep.t type t val typename_of_named : 'a Typename.t -> 'b Typename.t -> 'c Typename.t -> 'd Typename.t -> ('a, 'b, 'c, 'd) named Typename.t val typename_of_t : t Typename.t val witness : (t, (a, b, c, d) named) Type_equal.t end module type T5 = sig type ('a, 'b, 'c, 'd, 'e) named type a val a : a Typerep.t type b val b : b Typerep.t type c val c : c Typerep.t type d val d : d Typerep.t type e val e : e Typerep.t type t val typename_of_named : 'a Typename.t -> 'b Typename.t -> 'c Typename.t -> 'd Typename.t -> 'e Typename.t -> ('a, 'b, 'c, 'd, 'e) named Typename.t val typename_of_t : t Typename.t val witness : (t, (a, b, c, d, e) named) Type_equal.t end (* there the module is necessary because we need to deal with a type [t] with parameters whose kind is not representable as a type variable: ['a 't], even with a gadt. *) type 'a t = | T0 of (module T0 with type t = 'a) | T1 of (module T1 with type t = 'a) | T2 of (module T2 with type t = 'a) | T3 of (module T3 with type t = 'a) | T4 of (module T4 with type t = 'a) | T5 of (module T5 with type t = 'a) let arity = function | T0 _ -> 0 | T1 _ -> 1 | T2 _ -> 2 | T3 _ -> 3 | T4 _ -> 4 | T5 _ -> 5 let typename_of_t (type a) = function | T0 rep -> let module T = (val rep : T0 with type t = a) in T.typename_of_t | T1 rep -> let module T = (val rep : T1 with type t = a) in T.typename_of_t | T2 rep -> let module T = (val rep : T2 with type t = a) in T.typename_of_t | T3 rep -> let module T = (val rep : T3 with type t = a) in T.typename_of_t | T4 rep -> let module T = (val rep : T4 with type t = a) in T.typename_of_t | T5 rep -> let module T = (val rep : T5 with type t = a) in T.typename_of_t let name rep = Typename.Uid.name (Typename.uid (typename_of_t rep)) end module Tuple = struct (* these constructors could be plunged at toplevel of Typerep.t, however it is less verbose this way *) type _ t = | T2 : ('a Typerep.t * 'b Typerep.t) -> ('a * 'b) t | T3 : ('a Typerep.t * 'b Typerep.t * 'c Typerep.t) -> ('a * 'b * 'c) t | T4 : ('a Typerep.t * 'b Typerep.t * 'c Typerep.t * 'd Typerep.t) -> ('a * 'b * 'c * 'd) t | T5 : ('a Typerep.t * 'b Typerep.t * 'c Typerep.t * 'd Typerep.t * 'e Typerep.t) -> ('a * 'b * 'c * 'd * 'e) t let arity : type a. a t -> int = function | Typerep.Tuple.T2 _ -> 2 | Typerep.Tuple.T3 _ -> 3 | Typerep.Tuple.T4 _ -> 4 | Typerep.Tuple.T5 _ -> 5 let typename_of_t : type a. a t -> a Typename.t = function | T2 (a, b) -> Name_of.typename_of_tuple2 (Typerep.typename_of_t a) (Typerep.typename_of_t b) | T3 (a, b, c) -> Name_of.typename_of_tuple3 (Typerep.typename_of_t a) (Typerep.typename_of_t b) (Typerep.typename_of_t c) | T4 (a, b, c, d) -> Name_of.typename_of_tuple4 (Typerep.typename_of_t a) (Typerep.typename_of_t b) (Typerep.typename_of_t c) (Typerep.typename_of_t d) | T5 (a, b, c, d, e) -> Name_of.typename_of_tuple5 (Typerep.typename_of_t a) (Typerep.typename_of_t b) (Typerep.typename_of_t c) (Typerep.typename_of_t d) (Typerep.typename_of_t e) end include Variant_and_record_intf.M (struct type 'a rep = 'a t type 'a t = 'a rep end) let rec typename_of_t : type a. a t -> a Typename.t = function | Int -> Name_of.typename_of_int | Int32 -> Name_of.typename_of_int32 | Int64 -> Name_of.typename_of_int64 | Nativeint -> Name_of.typename_of_nativeint | Char -> Name_of.typename_of_char | Float -> Name_of.typename_of_float | String -> Name_of.typename_of_string | Bytes -> Name_of.typename_of_bytes | Bool -> Name_of.typename_of_bool | Unit -> Name_of.typename_of_unit | Option rep -> Name_of.typename_of_option (typename_of_t rep) | List rep -> Name_of.typename_of_list (typename_of_t rep) | Array rep -> Name_of.typename_of_array (typename_of_t rep) | Lazy rep -> Name_of.typename_of_lazy_t (typename_of_t rep) | Ref rep -> Name_of.typename_of_ref (typename_of_t rep) | Function (dom, rng) -> Name_of.typename_of_function (typename_of_t dom) (typename_of_t rng) | Tuple rep -> Typerep.Tuple.typename_of_t rep | Record rep -> Typerep.Record.typename_of_t rep | Variant rep -> Typerep.Variant.typename_of_t rep | Named (name, _) -> Named.typename_of_t name ;; let rec same_witness : type a b. a t -> b t -> (a, b) Type_equal.t option = fun t1 t2 -> let module E = Type_equal in match t1, t2 with | Named (name1, r1), Named (name2, r2) -> begin match Typename.same_witness (Named.typename_of_t name1) (Named.typename_of_t name2) with | Some E.T as x -> x | None -> match r1, r2 with | Some (lazy t1), Some (lazy t2) -> same_witness t1 t2 | Some (lazy t1), None -> same_witness t1 t2 | None, Some (lazy t2) -> same_witness t1 t2 | None, None -> None end | Named (_, r1), t2 -> begin match r1 with | Some (lazy t1) -> same_witness t1 t2 | None -> None end | t1, Named (_, r2) -> begin match r2 with | Some (lazy t2) -> same_witness t1 t2 | None -> None end | Int , Int -> Some E.T | Int32 , Int32 -> Some E.T | Int64 , Int64 -> Some E.T | Nativeint , Nativeint -> Some E.T | Char , Char -> Some E.T | Float , Float -> Some E.T | String , String -> Some E.T | Bytes , Bytes -> Some E.T | Bool , Bool -> Some E.T | Unit , Unit -> Some E.T | Option r1, Option r2 -> begin match same_witness r1 r2 with | None as x -> x | Some E.T as x -> x end | List r1, List r2 -> begin match same_witness r1 r2 with | None as x -> x | Some E.T as x -> x end | Array r1, Array r2 -> begin match same_witness r1 r2 with | None as x -> x | Some E.T as x -> x end | Lazy r1, Lazy r2 -> begin match same_witness r1 r2 with | None as x -> x | Some E.T as x -> x end | Ref r1, Ref r2 -> begin match same_witness r1 r2 with | None as x -> x | Some E.T as x -> x end | Function (dom1, rng1), Function (dom2, rng2) -> begin match same_witness dom1 dom2, same_witness rng1 rng2 with | Some E.T, Some E.T -> Some E.T | None, _ | _, None -> None end | Tuple t1, Tuple t2 -> begin let module T = Typerep.Tuple in match t1, t2 with | T.T2 (a1, b1), T.T2 (a2, b2) -> begin match same_witness a1 a2, same_witness b1 b2 with | Some E.T, Some E.T -> Some E.T | None, _ | _, None -> None end | T.T3 (a1, b1, c1), T.T3 (a2, b2, c2) -> begin match same_witness a1 a2, same_witness b1 b2, same_witness c1 c2 with | Some E.T, Some E.T, Some E.T -> Some E.T | None, _, _ | _, None, _ | _, _, None -> None end | T.T4 (a1, b1, c1, d1), T.T4 (a2, b2, c2, d2) -> begin match same_witness a1 a2, same_witness b1 b2, same_witness c1 c2, same_witness d1 d2 with | Some E.T, Some E.T, Some E.T, Some E.T -> Some E.T | None, _, _, _ | _, None, _, _ | _, _, None, _ | _, _, _, None -> None end | T.T5 (a1, b1, c1, d1, e1), T.T5 (a2, b2, c2, d2, e2) -> begin match same_witness a1 a2, same_witness b1 b2, same_witness c1 c2, same_witness d1 d2, same_witness e1 e2 with | Some E.T, Some E.T, Some E.T, Some E.T, Some E.T -> Some E.T | None, _, _, _, _ | _, None, _, _, _ | _, _, None, _, _ | _, _, _, None, _ | _, _, _, _, None -> None end | T.T2 _, _ -> None | T.T3 _, _ -> None | T.T4 _, _ -> None | T.T5 _, _ -> None end | Record r1, Record r2 -> Typename.same_witness (Typerep.Record.typename_of_t r1) (Typerep.Record.typename_of_t r2) | Variant r1, Variant r2 -> Typename.same_witness (Typerep.Variant.typename_of_t r1) (Typerep.Variant.typename_of_t r2) | Int, _ -> None | Int32, _ -> None | Int64, _ -> None | Nativeint, _ -> None | Char, _ -> None | Float, _ -> None | String, _ -> None | Bytes, _ -> None | Bool, _ -> None | Unit, _ -> None | Option _, _ -> None | List _, _ -> None | Array _, _ -> None | Lazy _, _ -> None | Ref _, _ -> None | Function _, _ -> None | Tuple _, _ -> None | Record _, _ -> None | Variant _, _ -> None ;; let same a b = same_witness a b <> None let same_witness_exn a b = match same_witness a b with | Some proof -> proof | None -> assert false let rec head = function | Typerep.Named (_, Some (lazy t)) -> head t | t -> t end let typerep_of_int = Typerep.Int let typerep_of_int32 = Typerep.Int32 let typerep_of_int64 = Typerep.Int64 let typerep_of_nativeint = Typerep.Nativeint let typerep_of_char = Typerep.Char let typerep_of_float = Typerep.Float let typerep_of_string = Typerep.String let typerep_of_bytes = Typerep.Bytes let typerep_of_bool = Typerep.Bool let typerep_of_unit = Typerep.Unit let typerep_of_option rep = Typerep.Option rep let typerep_of_list rep = Typerep.List rep let typerep_of_array rep = Typerep.Array rep let typerep_of_lazy_t rep = Typerep.Lazy rep let typerep_of_ref rep = Typerep.Ref rep let typerep_of_function dom rng = Typerep.Function (dom, rng) let typerep_of_tuple0 = Typerep.Unit let typerep_of_tuple2 a b = Typerep.Tuple (Typerep.Tuple.T2 (a, b)) let typerep_of_tuple3 a b c = Typerep.Tuple (Typerep.Tuple.T3 (a, b, c)) let typerep_of_tuple4 a b c d = Typerep.Tuple (Typerep.Tuple.T4 (a, b, c, d)) let typerep_of_tuple5 a b c d e = Typerep.Tuple (Typerep.Tuple.T5 (a, b, c, d, e)) include Name_of let value_tuple0 = () let typerep_of_int63, typename_of_int63 = let typerep_and_typename_of_int63_repr : type a b . (a, b) Base.Int63.Private.Repr.t -> a Typerep.t * a Typename.t = function | Base.Int63.Private.Repr.Int -> typerep_of_int, typename_of_int | Base.Int63.Private.Repr.Int64 -> typerep_of_int64, typename_of_int64 in typerep_and_typename_of_int63_repr Base.Int63.Private.repr typerep-0.14.0/lib/std_internal.mli000066400000000000000000000213411366315055700172370ustar00rootroot00000000000000(** type-safe runtime type introspection *) (** runtime type representations *) module rec Typerep : sig type _ t = | Int : int t | Int32 : int32 t | Int64 : int64 t | Nativeint : nativeint t | Char : char t | Float : float t | String : string t | Bytes : bytes t | Bool : bool t | Unit : unit t | Option : 'a t -> 'a option t | List : 'a t -> 'a list t | Array : 'a t -> 'a array t | Lazy : 'a t -> 'a lazy_t t | Ref : 'a t -> 'a ref t | Function : ('dom t * 'rng t) -> ('dom -> 'rng) t | Tuple : 'a Typerep.Tuple.t -> 'a t | Record : 'a Typerep.Record.t -> 'a t | Variant : 'a Typerep.Variant.t -> 'a t (** The [Named] constructor both allows for custom implementations of generics based on name and provides a way to represent recursive types, the lazy part dealing with cycles *) | Named : ('a Typerep.Named.t * 'a t lazy_t option) -> 'a t type packed = T : 'a t -> packed module Named : sig module type T0 = sig type named type t val typename_of_named : named Typename.t val typename_of_t : t Typename.t val witness : (t, named) Type_equal.t end module type T1 = sig type 'a named type a val a : a Typerep.t type t val typename_of_named : 'a Typename.t -> 'a named Typename.t val typename_of_t : t Typename.t val witness : (t, a named) Type_equal.t end module type T2 = sig type ('a, 'b) named type a val a : a Typerep.t type b val b : b Typerep.t type t val typename_of_named : 'a Typename.t -> 'b Typename.t -> ('a, 'b) named Typename.t val typename_of_t : t Typename.t val witness : (t, (a, b) named) Type_equal.t end module type T3 = sig type ('a, 'b, 'c) named type a val a : a Typerep.t type b val b : b Typerep.t type c val c : c Typerep.t type t val typename_of_named : 'a Typename.t -> 'b Typename.t -> 'c Typename.t -> ('a, 'b, 'c) named Typename.t val typename_of_t : t Typename.t val witness : (t, (a, b, c) named) Type_equal.t end module type T4 = sig type ('a, 'b, 'c, 'd) named type a val a : a Typerep.t type b val b : b Typerep.t type c val c : c Typerep.t type d val d : d Typerep.t type t val typename_of_named : 'a Typename.t -> 'b Typename.t -> 'c Typename.t -> 'd Typename.t -> ('a, 'b, 'c, 'd) named Typename.t val typename_of_t : t Typename.t val witness : (t, (a, b, c, d) named) Type_equal.t end module type T5 = sig type ('a, 'b, 'c, 'd, 'e) named type a val a : a Typerep.t type b val b : b Typerep.t type c val c : c Typerep.t type d val d : d Typerep.t type e val e : e Typerep.t type t val typename_of_named : 'a Typename.t -> 'b Typename.t -> 'c Typename.t -> 'd Typename.t -> 'e Typename.t -> ('a, 'b, 'c, 'd, 'e) named Typename.t val typename_of_t : t Typename.t val witness : (t, (a, b, c, d, e) named) Type_equal.t end type 'a t = | T0 of (module T0 with type t = 'a) | T1 of (module T1 with type t = 'a) | T2 of (module T2 with type t = 'a) | T3 of (module T3 with type t = 'a) | T4 of (module T4 with type t = 'a) | T5 of (module T5 with type t = 'a) val arity : _ t -> int val typename_of_t : 'a t -> 'a Typename.t val name : _ t -> string end module Tuple : sig type _ t = | T2 : ('a Typerep.t * 'b Typerep.t) -> ('a * 'b) t | T3 : ('a Typerep.t * 'b Typerep.t * 'c Typerep.t) -> ('a * 'b * 'c) t | T4 : ('a Typerep.t * 'b Typerep.t * 'c Typerep.t * 'd Typerep.t) -> ('a * 'b * 'c * 'd) t | T5 : ('a Typerep.t * 'b Typerep.t * 'c Typerep.t * 'd Typerep.t * 'e Typerep.t) -> ('a * 'b * 'c * 'd * 'e) t val arity : _ t -> int val typename_of_t : 'a t -> 'a Typename.t end include Variant_and_record_intf.S with type 'a t := 'a t (** [same t t'] will return a proof a equality if [t] and [t'] are the same type. One can think of two types being the [same] as two types whose values could be for example put in a list together. It is worth noting that this function *does not* operate compatiblity diffs between two different types with the same structure. Example: {[ module M1 = struct type t = { a : int; b : float; } [@@deriving typerep] end module M2 = struct type t = { a : int; b : float; } [@@deriving typerep] end [%test_result:bool] ~expect:false (same M1.typerep_of_t M2.typerep_of_t) type a = int with typerep type b = int with typerep [%test_result:bool] ~expect:true (same typerep_of_a typerep_of_b) ]} This is meant to recover type equality hidden by existential constructors. Basically this function does structural equality for everything except variant types, record types, and named types with no lazy definition exposed. This last case is about types that are defined [with typerep(abstract)] *) val same : _ t -> _ t -> bool val same_witness : 'a t -> 'b t -> ('a, 'b) Type_equal.t option val same_witness_exn : 'a t -> 'b t -> ('a, 'b) Type_equal.t val typename_of_t : 'a t -> 'a Typename.t (** [head ty] is used to traverse the [Named] constructor. It might be used when one care to pattern match directly on the representation in a low level way rather than going through a full generic. [head t] is [t] if [t] is not of the form [Named _] *) val head : 'a t -> 'a t end (* basic *) val typerep_of_int : int Typerep.t val typerep_of_int32 : int32 Typerep.t val typerep_of_int64 : int64 Typerep.t val typerep_of_nativeint : nativeint Typerep.t val typerep_of_int63 : Base.Int63.t Typerep.t val typerep_of_char : char Typerep.t val typerep_of_float : float Typerep.t val typerep_of_string : string Typerep.t val typerep_of_bytes : bytes Typerep.t val typerep_of_bool : bool Typerep.t val typerep_of_unit : unit Typerep.t (* variant with no argument *) type tuple0 val value_tuple0 : tuple0 (* nested *) val typerep_of_option : 'a Typerep.t -> 'a option Typerep.t val typerep_of_list : 'a Typerep.t -> 'a list Typerep.t val typerep_of_array : 'a Typerep.t -> 'a array Typerep.t val typerep_of_lazy_t : 'a Typerep.t -> 'a lazy_t Typerep.t val typerep_of_ref : 'a Typerep.t -> 'a ref Typerep.t val typerep_of_function : 'a Typerep.t -> 'b Typerep.t -> ('a -> 'b) Typerep.t val typerep_of_tuple0 : tuple0 Typerep.t val typerep_of_tuple2 : 'a Typerep.t -> 'b Typerep.t -> ('a * 'b) Typerep.t val typerep_of_tuple3 : 'a Typerep.t -> 'b Typerep.t -> 'c Typerep.t -> ('a * 'b * 'c) Typerep.t val typerep_of_tuple4 : 'a Typerep.t -> 'b Typerep.t -> 'c Typerep.t -> 'd Typerep.t -> ('a * 'b * 'c * 'd) Typerep.t val typerep_of_tuple5 : 'a Typerep.t -> 'b Typerep.t -> 'c Typerep.t -> 'd Typerep.t -> 'e Typerep.t -> ('a * 'b * 'c * 'd * 'e) Typerep.t val typename_of_int : int Typename.t val typename_of_int32 : int32 Typename.t val typename_of_int64 : int64 Typename.t val typename_of_nativeint : nativeint Typename.t val typename_of_int63 : Base.Int63.t Typename.t val typename_of_char : char Typename.t val typename_of_float : float Typename.t val typename_of_string : string Typename.t val typename_of_bytes : bytes Typename.t val typename_of_bool : bool Typename.t val typename_of_unit : unit Typename.t val typename_of_option : 'a Typename.t -> 'a option Typename.t val typename_of_list : 'a Typename.t -> 'a list Typename.t val typename_of_array : 'a Typename.t -> 'a array Typename.t val typename_of_lazy_t : 'a Typename.t -> 'a lazy_t Typename.t val typename_of_ref : 'a Typename.t -> 'a ref Typename.t val typename_of_function : 'a Typename.t -> 'b Typename.t -> ('a -> 'b) Typename.t val typename_of_tuple0 : tuple0 Typename.t val typename_of_tuple2 : 'a Typename.t -> 'b Typename.t -> ('a * 'b) Typename.t val typename_of_tuple3 : 'a Typename.t -> 'b Typename.t -> 'c Typename.t -> ('a * 'b * 'c) Typename.t val typename_of_tuple4 : 'a Typename.t -> 'b Typename.t -> 'c Typename.t -> 'd Typename.t -> ('a * 'b * 'c * 'd) Typename.t val typename_of_tuple5 : 'a Typename.t -> 'b Typename.t -> 'c Typename.t -> 'd Typename.t -> 'e Typename.t -> ('a * 'b * 'c * 'd * 'e) Typename.t typerep-0.14.0/lib/type_abstract.ml000066400000000000000000000031071366315055700172440ustar00rootroot00000000000000open Std_internal module Make0 (X : Named_intf.S0) : Typerepable.S with type t := X.t = struct module M = Make_typename.Make0(X) let typerep_of_t = Typerep.Named (M.named, None) let typename_of_t = M.typename_of_t end module Make1 (X : Named_intf.S1) : Typerepable.S1 with type 'a t := 'a X.t = struct module M = Make_typename.Make1(X) let typerep_of_t of_p1 = Typerep.Named (M.named of_p1, None) let typename_of_t = M.typename_of_t end module Make2 (X : Named_intf.S2) : Typerepable.S2 with type ('a, 'b) t := ('a, 'b) X.t = struct module M = Make_typename.Make2(X) let typerep_of_t of_p1 of_p2 = Typerep.Named (M.named of_p1 of_p2, None) let typename_of_t = M.typename_of_t end module Make3 (X : Named_intf.S3) : Typerepable.S3 with type ('a, 'b, 'c) t := ('a, 'b, 'c) X.t = struct module M = Make_typename.Make3(X) let typerep_of_t of_p1 of_p2 of_p3 = Typerep.Named (M.named of_p1 of_p2 of_p3, None) let typename_of_t = M.typename_of_t end module Make4 (X : Named_intf.S4) : Typerepable.S4 with type ('a, 'b, 'c, 'd) t := ('a, 'b, 'c, 'd) X.t = struct module M = Make_typename.Make4(X) let typerep_of_t of_p1 of_p2 of_p3 of_p4 = Typerep.Named (M.named of_p1 of_p2 of_p3 of_p4, None) let typename_of_t = M.typename_of_t end module Make5 (X : Named_intf.S5) : Typerepable.S5 with type ('a, 'b, 'c, 'd, 'e) t := ('a, 'b, 'c, 'd, 'e) X.t = struct module M = Make_typename.Make5(X) let typerep_of_t of_p1 of_p2 of_p3 of_p4 of_p5 = Typerep.Named (M.named of_p1 of_p2 of_p3 of_p4 of_p5, None) let typename_of_t = M.typename_of_t end typerep-0.14.0/lib/type_abstract.mli000066400000000000000000000020641366315055700174160ustar00rootroot00000000000000(** Abstract types helpers. An abstract type in the sense of the typerep library is a type whose representation is unknown. Such a type has only a name that can be used to provide and register custom implementation of generics. This is typically a type obtained with the following syntax extension: {[ type t with typerep(abstract) ]} The following functors are meant to be used by the code generator, however they could also be useful while writing low level typerep code manually. *) module Make0 (X : Named_intf.S0) : Typerepable.S with type t := X.t module Make1 (X : Named_intf.S1) : Typerepable.S1 with type 'a t := 'a X.t module Make2 (X : Named_intf.S2) : Typerepable.S2 with type ('a, 'b) t := ('a, 'b) X.t module Make3 (X : Named_intf.S3) : Typerepable.S3 with type ('a, 'b, 'c) t := ('a, 'b, 'c) X.t module Make4 (X : Named_intf.S4) : Typerepable.S4 with type ('a, 'b, 'c, 'd) t := ('a, 'b, 'c, 'd) X.t module Make5 (X : Named_intf.S5) : Typerepable.S5 with type ('a, 'b, 'c, 'd, 'e) t := ('a, 'b, 'c, 'd, 'e) X.t typerep-0.14.0/lib/type_equal.ml000066400000000000000000000004341366315055700165500ustar00rootroot00000000000000type ('a, 'b) t = ('a,'b) Base.Type_equal.t = T : ('a, 'a) t type ('a, 'b) equal = ('a, 'b) t let refl = T let conv : type a b. (a, b) t -> a -> b = fun T x -> x module Lift (X: sig type 'a t end) = struct let lift (type a) (type b) (T : (a, b) t) = (T : (a X.t, b X.t) t) end typerep-0.14.0/lib/type_equal.mli000066400000000000000000000007471366315055700167300ustar00rootroot00000000000000(** runtime witnes of type equality this is a reduced version of [Core.Type_equal]. *) type ('a, 'b) t = ('a,'b) Base.Type_equal.t = T : ('a, 'a) t type ('a, 'b) equal = ('a, 'b) t (** type-safe conversion between equal types *) val conv : ('a, 'b) t -> 'a -> 'b (** type equality is reflexive *) val refl : ('a, 'a) t (** needed in some cases even though t is exported and is a gadt *) module Lift (X: sig type 'a t end) : sig val lift : ('a, 'b) t -> ('a X.t, 'b X.t) t end typerep-0.14.0/lib/type_generic.ml000066400000000000000000000574601366315055700170700ustar00rootroot00000000000000open Std_internal module Variant_and_record_intf = Variant_and_record_intf module Helper (A : Variant_and_record_intf.S) (B : Variant_and_record_intf.S) = struct type map = { map : 'a. 'a A.t -> 'a B.t } let map_variant (type variant) { map } (variant : variant A.Variant.t) = let map_create = function | A.Tag.Args fct -> B.Tag_internal.Args fct | A.Tag.Const k -> B.Tag_internal.Const k in let map_tag tag = match tag with | A.Variant.Tag tag -> let label = A.Tag.label tag in let rep = map (A.Tag.traverse tag) in let arity = A.Tag.arity tag in let args_labels = A.Tag.args_labels tag in let index = A.Tag.index tag in let ocaml_repr = A.Tag.ocaml_repr tag in let tyid = A.Tag.tyid tag in let create = map_create (A.Tag.create tag) in B.Variant_internal.Tag (B.Tag.internal_use_only { B.Tag_internal.label; rep; arity; args_labels; index; ocaml_repr; tyid; create; }) in let typename = A.Variant.typename_of_t variant in let polymorphic = A.Variant.is_polymorphic variant in let tags = Array.init (A.Variant.length variant) (fun index -> map_tag (A.Variant.tag variant index)) in let value (a : variant) = match A.Variant.value variant a with | A.Variant.Value (atag, a) -> (fun (type args) (atag : (variant, args) A.Tag.t) (a : args) -> let (B.Variant_internal.Tag btag) = tags.(A.Tag.index atag) in (fun (type ex) (btag : (variant, ex) B.Tag.t) -> let Type_equal.T = Typename.same_witness_exn (A.Tag.tyid atag) (B.Tag.tyid btag) in let btag = (btag : (variant, args) B.Tag.t) in B.Variant_internal.Value (btag, a) ) btag ) atag a in B.Variant.internal_use_only { B.Variant_internal.typename; tags; polymorphic; value; } let map_record (type record) { map } (record : record A.Record.t) = let map_field field = match field with | A.Record.Field field -> let label = A.Field.label field in let rep = map (A.Field.traverse field) in let index = A.Field.index field in let is_mutable = A.Field.is_mutable field in let tyid = A.Field.tyid field in let get = A.Field.get field in B.Record_internal.Field (B.Field.internal_use_only { B.Field_internal.label; rep; index; is_mutable; tyid; get; }) in let typename = A.Record.typename_of_t record in let has_double_array_tag = A.Record.has_double_array_tag record in let fields = Array.init (A.Record.length record) (fun index -> map_field (A.Record.field record index)) in let create { B.Record_internal.get } = let get (type a) (afield : (_, a) A.Field.t) = match fields.(A.Field.index afield) with | B.Record_internal.Field bfield -> (fun (type ex) (bfield : (record, ex) B.Field.t) -> let Type_equal.T = Typename.same_witness_exn (A.Field.tyid afield) (B.Field.tyid bfield) in let bfield = (bfield : (record, a) B.Field.t) in get bfield ) bfield in A.Record.create record { A.Record.get } in B.Record.internal_use_only { B.Record_internal.typename; fields; has_double_array_tag; create; } end module type Named = sig type 'a computation module Context : sig type t val create : unit -> t end type 'a t val init : Context.t -> 'a Typename.t -> 'a t val get_wip_computation : 'a t -> 'a computation val set_final_computation : 'a t -> 'a computation -> 'a computation val share : _ Typerep.t -> bool end module type Computation = sig type 'a t include Variant_and_record_intf.S with type 'a t := 'a t val int : int t val int32 : int32 t val int64 : int64 t val nativeint : nativeint t val char : char t val float : float t val string : string t val bytes : bytes t val bool : bool t val unit : unit t val option : 'a t -> 'a option t val list : 'a t -> 'a list t val array : 'a t -> 'a array t val lazy_t : 'a t -> 'a lazy_t t val ref_ : 'a t -> 'a ref t val function_ : 'a t -> 'b t -> ('a -> 'b) t val tuple2 : 'a t -> 'b t -> ('a * 'b) t val tuple3 : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t val tuple4 : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t val tuple5 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> ('a * 'b * 'c * 'd * 'e) t val record : 'a Record.t -> 'a t val variant : 'a Variant.t -> 'a t module Named : Named with type 'a computation := 'a t end (* special functor application for computation as closure of the form [a -> b] *) module Make_named_for_closure (X : sig type 'a input type 'a output type 'a t = 'a input -> 'a output end) = struct module Context = struct type t = unit let create = ignore end type 'a t = { runtime_dereference : 'a X.t; runtime_reference : 'a X.t ref; compiletime_dereference : 'a X.t option ref; } exception Undefined of string let init () name = let path = Typename.Uid.name (Typename.uid name) in let r = ref (fun _ -> raise (Undefined path)) in { runtime_dereference = (fun input -> !r input); runtime_reference = r; compiletime_dereference = ref None; } let get_wip_computation shared = match shared.compiletime_dereference.contents with | Some clos -> clos | None -> shared.runtime_dereference let set_final_computation shared computation = let compiletime_dereference = shared.compiletime_dereference in match compiletime_dereference.contents with | Some _ -> assert false | None -> if Base.phys_equal shared.runtime_dereference computation then assert false; compiletime_dereference := Some computation; shared.runtime_reference := computation; computation let share _ = true end module Ident = struct type t = { name : string; implements : Typename.Uid.t -> bool; } exception Broken_dependency of string let check_dependencies name required = match required with | [] -> (fun _ -> ()) | _ -> (fun uid -> List.iter (fun { name = name'; implements } -> if not (implements uid) then begin (* something is wrong with the set up, this is an error during the initialization of the program, we rather fail with a human readable output *) let message = Printf.sprintf "Type_generic %S requires %S for uid %S\n" name name' (Typename.Uid.name uid) in prerr_endline message; raise (Broken_dependency message) end ) required) end (* Extending an existing generic *) module type Extending = sig type 'a t type 'a computation = 'a t val ident : Ident.t (* generic_ident * typename or info *) exception Not_implemented of string * string module type S = sig type t include Typerepable.S with type t := t val compute : t computation end module type S1 = sig type 'a t include Typerepable.S1 with type 'a t := 'a t val compute : 'a computation -> 'a t computation end module type S2 = sig type ('a, 'b) t include Typerepable.S2 with type ('a, 'b) t := ('a, 'b) t val compute : 'a computation -> 'b computation -> ('a, 'b) t computation end module type S3 = sig type ('a, 'b, 'c) t include Typerepable.S3 with type ('a, 'b, 'c) t := ('a, 'b, 'c) t val compute : 'a computation -> 'b computation -> 'c computation -> ('a, 'b, 'c) t computation end module type S4 = sig type ('a, 'b, 'c, 'd) t include Typerepable.S4 with type ('a, 'b, 'c, 'd) t := ('a, 'b, 'c, 'd) t val compute : 'a computation -> 'b computation -> 'c computation -> 'd computation -> ('a, 'b, 'c, 'd) t computation end module type S5 = sig type ('a, 'b, 'c, 'd, 'e) t include Typerepable.S5 with type ('a, 'b, 'c, 'd, 'e) t := ('a, 'b, 'c, 'd, 'e) t val compute : 'a computation -> 'b computation -> 'c computation -> 'd computation -> 'e computation -> ('a, 'b, 'c, 'd, 'e) t computation end val register0 : (module S) -> unit val register1 : (module S1) -> unit val register2 : (module S2) -> unit val register3 : (module S3) -> unit val register4 : (module S4) -> unit val register5 : (module S5) -> unit (* special less scary type when the type has no parameters *) val register : 'a Typerep.t -> 'a computation -> unit (* Essentially because we cannot talk about a variable of kind * -> k val register1 : 'a 't Typerep.t -> ('a computation -> 'a 't computation) -> unit ... *) end (* Implementing a new generic *) module type S_implementation = sig include Extending (* raise using the current ident *) val raise_not_implemented : string -> 'a type implementation = { generic : 'a. 'a Typerep.t -> 'a computation; } (* Standard case, find a extended_implementation, or look in the content *) val _using_extended_implementation : implementation -> 'a Typerep.Named.t -> 'a Typerep.t lazy_t option -> 'a computation (* This function allows you more control on what you want to do *) val find_extended_implementation : implementation -> 'a Typerep.Named.t -> 'a computation option end module type S = sig include Extending val of_typerep : 'a Typerep.t -> [ `generic of 'a computation ] module Computation : Computation with type 'a t = 'a t end module Make_S_implementation(X : sig type 'a t val name : string val required : Ident.t list end) : S_implementation with type 'a t = 'a X.t = struct type 'a t = 'a X.t type 'a computation = 'a t include Type_generic_intf.M(struct type 'a t = 'a computation end) (* we do not use core since we are earlier in the dependencies graph *) module Uid_table = struct include Hashtbl.Make(Typename.Uid) let find table key = if Lazy.is_val table then let table = Lazy.force table in try Some (find table key) with Base.Not_found_s _ | Caml.Not_found -> None else None let check_dependencies = Ident.check_dependencies X.name X.required let replace table key value = check_dependencies key; replace (Lazy.force table) key value let mem table key = if Lazy.is_val table then let table = Lazy.force table in mem table key else false end let size = 256 let table0 = lazy (Uid_table.create size) let table1 = lazy (Uid_table.create size) let table2 = lazy (Uid_table.create size) let table3 = lazy (Uid_table.create size) let table4 = lazy (Uid_table.create size) let table5 = lazy (Uid_table.create size) let is_registered uid = Uid_table.mem table0 uid || Uid_table.mem table1 uid || Uid_table.mem table2 uid || Uid_table.mem table3 uid || Uid_table.mem table4 uid || Uid_table.mem table5 uid let ident = { Ident. name = X.name; implements = is_registered; } module Find0(T : Typerep.Named.T0) : sig val compute : unit -> T.named computation option end = struct let compute () = match Uid_table.find table0 (Typename.uid T.typename_of_t) with | None -> None | Some rep -> let module S = (val rep : S) in let witness = Typename.same_witness_exn S.typename_of_t T.typename_of_named in let module L = Type_equal.Lift(struct type 'a t = 'a computation end) in Some (Type_equal.conv (L.lift witness) S.compute) end module Find1(T : Typerep.Named.T1) : sig val compute : unit -> (T.a computation -> T.a T.named computation) option end = struct let compute () = match Uid_table.find table1 (Typename.uid T.typename_of_t) with | None -> None | Some rep -> let module S1 = (val rep : S1) in let module Conv = Typename.Same_witness_exn_1(S1)(struct type 'a t = 'a T.named let typename_of_t = T.typename_of_named end) in let module L = Type_equal.Lift(struct type 'a t = T.a computation -> 'a computation end) in Some (Type_equal.conv (L.lift Conv.(witness.eq)) S1.compute) end module Find2(T : Typerep.Named.T2) : sig val compute : unit -> (T.a computation -> T.b computation -> (T.a, T.b) T.named computation) option end = struct let compute () = match Uid_table.find table2 (Typename.uid T.typename_of_t) with | None -> None | Some rep -> let module S2 = (val rep : S2) in let module Conv = Typename.Same_witness_exn_2(S2)(struct type ('a, 'b) t = ('a, 'b) T.named let typename_of_t = T.typename_of_named end) in let module L = Type_equal.Lift(struct type 'a t = T.a computation -> T.b computation -> 'a computation end) in Some (Type_equal.conv (L.lift Conv.(witness.eq)) S2.compute) end module Find3(T : Typerep.Named.T3) : sig val compute : unit -> (T.a computation -> T.b computation -> T.c computation -> (T.a, T.b, T.c) T.named computation) option end = struct let compute () = match Uid_table.find table3 (Typename.uid T.typename_of_t) with | None -> None | Some rep -> let module S3 = (val rep : S3) in let module Conv = Typename.Same_witness_exn_3(S3)(struct type ('a, 'b, 'c) t = ('a, 'b, 'c) T.named let typename_of_t = T.typename_of_named end) in let module L = Type_equal.Lift(struct type 'a t = T.a computation -> T.b computation -> T.c computation -> 'a computation end) in Some (Type_equal.conv (L.lift Conv.(witness.eq)) S3.compute) end module Find4(T : Typerep.Named.T4) : sig val compute : unit -> (T.a computation -> T.b computation -> T.c computation -> T.d computation -> (T.a, T.b, T.c, T.d) T.named computation) option end = struct let compute () = match Uid_table.find table4 (Typename.uid T.typename_of_t) with | None -> None | Some rep -> let module S4 = (val rep : S4) in let module Conv = Typename.Same_witness_exn_4(S4)(struct type ('a, 'b, 'c, 'd) t = ('a, 'b, 'c, 'd) T.named let typename_of_t = T.typename_of_named end) in let module L = Type_equal.Lift(struct type 'a t = T.a computation -> T.b computation -> T.c computation -> T.d computation -> 'a computation end) in Some (Type_equal.conv (L.lift Conv.(witness.eq)) S4.compute) end module Find5(T : Typerep.Named.T5) : sig val compute : unit -> (T.a computation -> T.b computation -> T.c computation -> T.d computation -> T.e computation -> (T.a, T.b, T.c, T.d, T.e) T.named computation) option end = struct let compute () = match Uid_table.find table5 (Typename.uid T.typename_of_t) with | None -> None | Some rep -> let module S5 = (val rep : S5) in let module Conv = Typename.Same_witness_exn_5(S5)(struct type ('a, 'b, 'c, 'd, 'e) t = ('a, 'b, 'c, 'd, 'e) T.named let typename_of_t = T.typename_of_named end) in let module L = Type_equal.Lift(struct type 'a t = T.a computation -> T.b computation -> T.c computation -> T.d computation -> T.e computation -> 'a computation end) in Some (Type_equal.conv (L.lift Conv.(witness.eq)) S5.compute) end let unit = Typename.static let register0 compute = let module S = (val compute : S) in let uid = Typename.uid S.typename_of_t in Uid_table.replace table0 uid compute let register1 compute = let module S1 = (val compute : S1) in let uid = Typename.uid (S1.typename_of_t unit) in Uid_table.replace table1 uid compute let register2 compute = let module S2 = (val compute : S2) in let uid = Typename.uid (S2.typename_of_t unit unit) in Uid_table.replace table2 uid compute let register3 compute = let module S3 = (val compute : S3) in let uid = Typename.uid (S3.typename_of_t unit unit unit) in Uid_table.replace table3 uid compute let register4 compute = let module S4 = (val compute : S4) in let uid = Typename.uid (S4.typename_of_t unit unit unit unit) in Uid_table.replace table4 uid compute let register5 compute = let module S5 = (val compute : S5) in let uid = Typename.uid (S5.typename_of_t unit unit unit unit unit) in Uid_table.replace table5 uid compute let register (type a) typerep_of_a compute = let module S = struct type t = a let typename_of_t = Typerep.typename_of_t typerep_of_a let typerep_of_t = typerep_of_a let compute = compute end in register0 (module S : S) (* IMPLEMENTATION *) type implementation = { generic : 'a. 'a Typerep.t -> 'a computation; } let find_extended_implementation (type a) aux = function | Typerep.Named.T0 rep -> begin let module T = (val rep : Typerep.Named.T0 with type t = a) in let module Custom = Find0(T) in match Custom.compute () with | Some custom -> let Type_equal.T = T.witness in Some (custom : a computation) | None -> None end | Typerep.Named.T1 rep -> begin let module T = (val rep : Typerep.Named.T1 with type t = a) in let module Custom = Find1(T) in match Custom.compute () with | Some custom -> let custom = (custom (aux.generic T.a) : T.a T.named computation) in let Type_equal.T = T.witness in Some (custom : a computation) | None -> None end | Typerep.Named.T2 rep -> begin let module T = (val rep : Typerep.Named.T2 with type t = a) in let module Custom = Find2(T) in match Custom.compute () with | Some custom -> let custom = (custom (aux.generic T.a) (aux.generic T.b) : (T.a, T.b) T.named computation) in let Type_equal.T = T.witness in Some (custom : a computation) | None -> None end | Typerep.Named.T3 rep -> begin let module T = (val rep : Typerep.Named.T3 with type t = a) in let module Custom = Find3(T) in match Custom.compute () with | Some custom -> let custom = (custom (aux.generic T.a) (aux.generic T.b) (aux.generic T.c) : (T.a, T.b, T.c) T.named computation) in let Type_equal.T = T.witness in Some (custom : a computation) | None -> None end | Typerep.Named.T4 rep -> begin let module T = (val rep : Typerep.Named.T4 with type t = a) in let module Custom = Find4(T) in match Custom.compute () with | Some custom -> let custom = (custom (aux.generic T.a) (aux.generic T.b) (aux.generic T.c) (aux.generic T.d) : (T.a, T.b, T.c, T.d) T.named computation) in let Type_equal.T = T.witness in Some (custom : a computation) | None -> None end | Typerep.Named.T5 rep -> begin let module T = (val rep : Typerep.Named.T5 with type t = a) in let module Custom = Find5(T) in match Custom.compute () with | Some custom -> let custom = (custom (aux.generic T.a) (aux.generic T.b) (aux.generic T.c) (aux.generic T.d) (aux.generic T.e) : (T.a, T.b, T.c, T.d, T.e) T.named computation) in let Type_equal.T = T.witness in Some (custom : a computation) | None -> None end exception Not_implemented of string * string let raise_not_implemented string = raise (Not_implemented (X.name, string)) let _using_extended_implementation aux rep content = match find_extended_implementation aux rep with | Some computation -> computation | None -> begin match content with | Some (lazy content) -> aux.generic content | None -> let typename = Typerep.Named.typename_of_t rep in let name = Typename.Uid.name (Typename.uid typename) in raise_not_implemented name end end module Key_table = Hashtbl.Make(Typename.Key) module Make(X : sig type 'a t val name : string val required : Ident.t list include Computation with type 'a t := 'a t end) = struct module Computation = X include Make_S_implementation(X) module Memo = Typename.Table(struct type 'a t = 'a X.Named.t end) module Helper = Helper(Typerep)(Computation) let of_typerep rep = let context = X.Named.Context.create () in let memo_table = Memo.create 32 in let rec of_typerep : type a. a Typerep.t -> a t = function | Typerep.Int -> X.int | Typerep.Int32 -> X.int32 | Typerep.Int64 -> X.int64 | Typerep.Nativeint -> X.nativeint | Typerep.Char -> X.char | Typerep.Float -> X.float | Typerep.String -> X.string | Typerep.Bytes -> X.bytes | Typerep.Bool -> X.bool | Typerep.Unit -> X.unit | Typerep.Option rep -> X.option (of_typerep rep) | Typerep.List rep -> X.list (of_typerep rep) | Typerep.Array rep -> X.array (of_typerep rep) | Typerep.Lazy rep -> X.lazy_t (of_typerep rep) | Typerep.Ref rep -> X.ref_ (of_typerep rep) | Typerep.Function (dom, rng) -> X.function_ (of_typerep dom) (of_typerep rng) | Typerep.Tuple tuple -> begin (* do NOT write [X.tuple2 (of_typerep a) (of_typerep b)] because of_typerep can contain a side effect and [a] should be executed before [b] *) match tuple with | Typerep.Tuple.T2 (a, b) -> let ra = of_typerep a in let rb = of_typerep b in X.tuple2 ra rb | Typerep.Tuple.T3 (a, b, c) -> let ra = of_typerep a in let rb = of_typerep b in let rc = of_typerep c in X.tuple3 ra rb rc | Typerep.Tuple.T4 (a, b, c, d) -> let ra = of_typerep a in let rb = of_typerep b in let rc = of_typerep c in let rd = of_typerep d in X.tuple4 ra rb rc rd | Typerep.Tuple.T5 (a, b, c, d, e) -> let ra = of_typerep a in let rb = of_typerep b in let rc = of_typerep c in let rd = of_typerep d in let re = of_typerep e in X.tuple5 ra rb rc rd re end | Typerep.Record record -> X.record (Helper.map_record { Helper.map = of_typerep } record) | Typerep.Variant variant -> X.variant (Helper.map_variant { Helper.map = of_typerep } variant) | Typerep.Named (named, content) -> begin let typename = Typerep.Named.typename_of_t named in match Memo.find memo_table typename with | Some shared -> X.Named.get_wip_computation shared | None -> begin match find_extended_implementation { generic = of_typerep } named with | Some computation -> computation | None -> begin match content with | None -> let name = Typename.Uid.name (Typename.uid typename) in raise_not_implemented name | Some (lazy content) -> if X.Named.share content then let shared = X.Named.init context typename in Memo.set memo_table typename shared; let computation = of_typerep content in X.Named.set_final_computation shared computation else of_typerep content end end end in let computation = of_typerep rep in `generic computation end typerep-0.14.0/lib/type_generic.mli000066400000000000000000000173661366315055700172420ustar00rootroot00000000000000open Std_internal (** A computation is the type of an operation that can be applied to various different kind of types. It is expressed as a type with one parameter: type 'a computation Examples of computation: type sexp_of_t = ('a -> Sexp.t) computation The term [generic] is used to refer to a specific implementation of a computation whose concrete implementation is programmed using the type representation of values. For example, when one uses [with sexp] as a way to implement the [sexp_of_t] computation, the technique used is code generation at compile time. Another approach is to define a generic function [sexp_of_t] that inspects the representation of the type at runtime. This module offers an abstraction over type rep in order to implement generics in a efficient way. Provided from a user enough pieces of implementation regarding a particular computation, this module returns essentially the following function: (** main function : get the computation from the typerep *) val of_typerep : 'a Typerep.t -> [ `generic of 'a computation ] that allows one to get the generic computation operating on a given type ['a]. *) module Variant_and_record_intf : (module type of Variant_and_record_intf) module Helper (A : Variant_and_record_intf.S) (B : Variant_and_record_intf.S) : sig type map = { map : 'a. 'a A.t -> 'a B.t } val map_variant : map -> 'a A.Variant.t -> 'a B.Variant.t val map_record : map -> 'a A.Record.t -> 'a B.Record.t end module type Named = sig type 'a computation module Context : sig (** Mutable context used to memorize some info during the traversal of a typerep. A new context is created before starting to enter the toplevel of a typerep. Then it is passed to all [init] calls that happen during the traversal of it. The user of the generic functor is free to stuff there whatever context needs to be available while creating a new value of type ['a Named.t] *) type t val create : unit -> t end (** Work in progress representation of a computation. This is mostly used to handle recursive types. While building a computation on a recursive type, one needs to have some computation available for the location where the type appears recursively. [init] will be called once on each new type_name met during the traversal of a type. Each time the same type is encountered again, [get_wip_computation] will be called. At the end of the traversal of that particular type, [set_final_computation] will be called, offering as a way to "close" the wip representation. ['a t] can be mutable (and is likely to be in practice). After a [set_final_computation] is performed and return a final computation C for a type_name, C will be memoized and returned for each further occurrences of the same type_name inside the typerep, going further on. *) type 'a t val init : Context.t -> 'a Typename.t -> 'a t val get_wip_computation : 'a t -> 'a computation val set_final_computation : 'a t -> 'a computation -> 'a computation (** It might be interesting to inline some computation for a few typerep if they appear several times within a typerep. This parameters will allow one to tweak the sharing between multiple occurences of the same typename. [share = true] means no inlining. Note that not sharing recursive types will lead the [of_typerep] function to loop forever. Be careful when setting this. An example where it is not suitable to share everything for example is typestruct. The typestruct of an int is a simple constructor called [Int], naming it once and using the name to refere to it later within the typestruct does not lead to a shorter typestruct, and is in fact less readable. The benefit of the sharing depends on the computation, its memory and building costs. *) val share : _ Typerep.t -> bool end module type Computation = sig type 'a t include Variant_and_record_intf.S with type 'a t := 'a t val int : int t val int32 : int32 t val int64 : int64 t val nativeint : nativeint t val char : char t val float : float t val string : string t val bytes : bytes t val bool : bool t val unit : unit t val option : 'a t -> 'a option t val list : 'a t -> 'a list t val array : 'a t -> 'a array t val lazy_t : 'a t -> 'a lazy_t t val ref_ : 'a t -> 'a ref t val function_ : 'a t -> 'b t -> ('a -> 'b) t val tuple2 : 'a t -> 'b t -> ('a * 'b) t val tuple3 : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t val tuple4 : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t val tuple5 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> ('a * 'b * 'c * 'd * 'e) t val record : 'a Record.t -> 'a t val variant : 'a Variant.t -> 'a t module Named : Named with type 'a computation := 'a t end (** Not all computations are arrow types. For example: ['a computation = Type_hash.t] However, arrow types computation such as [of_sexp], [sexp_of], [json_of], etc. are such a standard case that is seems reasonable to share this extra layer of functor for it to build the [Named] module. *) module Make_named_for_closure (X : sig type 'a input type 'a output type 'a t = 'a input -> 'a output end) : Named with type 'a computation := 'a X.t module Ident : sig (** Runtime identifier for a generic computation. This is essentially a string whose purpose is to give reasonable error messages in case the dependency requirements for a generic are not met at runtime. The field called [required] is needed in order to build a generic computation module. It is used to establish a set up that would explicitly list all the computation that are required by an other computation to work. Generic computations are a way to build dynamically some operations on types. It is possible to build computation on top of each other. This ident type will be the key to talk about other computations at the point of setting up the dependencies. *) type t end module type S = sig type 'a t type 'a computation = 'a t val ident : Ident.t (** generic_ident * typename or info *) exception Not_implemented of string * string (** register mechanism to customize the behavior of this generic *) include Type_generic_intf.S with type 'a t := 'a t (** Extending an existing generic for a particular type name The use of first class modules there is essentially because we cannot talk about a variable of kind * -> k val register1 : 'a 't Typerep.t -> ('a computation -> 'a 't computation) -> unit ... *) val register0 : (module S) -> unit val register1 : (module S1) -> unit val register2 : (module S2) -> unit val register3 : (module S3) -> unit val register4 : (module S4) -> unit val register5 : (module S5) -> unit (** special less scary type when the type has no parameters. this is equivalent as using register0 *) val register : 'a Typerep.t -> 'a computation -> unit (** main function : compute the generic computation from the typerep *) val of_typerep : 'a Typerep.t -> [ `generic of 'a computation ] (** exported to build a computation on top of a previous one *) module Computation : Computation with type 'a t = 'a t end (** The [name] is used for debug information only in case of Broken_dependency. The [required] is to handle dependencies between generics at runtime. Example: if [X] is the module given to build a generic computation [G] that depends on three other computation [A,B,C] then X.required shall be [ A.ident ; B.ident ; C.ident ] *) module Make (X : sig type 'a t val name : string val required : Ident.t list include Computation with type 'a t := 'a t end) : S with type 'a t = 'a X.t typerep-0.14.0/lib/type_generic_intf.ml000066400000000000000000000025511366315055700200770ustar00rootroot00000000000000module M (X : sig type 'a t end) = struct module type S = sig type t include Typerepable.S with type t := t val compute : t X.t end module type S1 = sig type 'a t include Typerepable.S1 with type 'a t := 'a t val compute : 'a X.t -> 'a t X.t end module type S2 = sig type ('a, 'b) t include Typerepable.S2 with type ('a, 'b) t := ('a, 'b) t val compute : 'a X.t -> 'b X.t -> ('a, 'b) t X.t end module type S3 = sig type ('a, 'b, 'c) t include Typerepable.S3 with type ('a, 'b, 'c) t := ('a, 'b, 'c) t val compute : 'a X.t -> 'b X.t -> 'c X.t -> ('a, 'b, 'c) t X.t end module type S4 = sig type ('a, 'b, 'c, 'd) t include Typerepable.S4 with type ('a, 'b, 'c, 'd) t := ('a, 'b, 'c, 'd) t val compute : 'a X.t -> 'b X.t -> 'c X.t -> 'd X.t -> ('a, 'b, 'c, 'd) t X.t end module type S5 = sig type ('a, 'b, 'c, 'd, 'e) t include Typerepable.S5 with type ('a, 'b, 'c, 'd, 'e) t := ('a, 'b, 'c, 'd, 'e) t val compute : 'a X.t -> 'b X.t -> 'c X.t -> 'd X.t -> 'e X.t -> ('a, 'b, 'c, 'd, 'e) t X.t end end module type S = sig type 'a t include (module type of M (struct type 'a computation = 'a t type 'a t = 'a computation end) ) end typerep-0.14.0/lib/typename.ml000066400000000000000000000146661366315055700162360ustar00rootroot00000000000000(* this lib should not depend on core *) module List = struct include List let compare cmp a b = let rec loop a b = match a, b with | [], [] -> 0 | [], _ -> -1 | _ , [] -> 1 | x :: xs, y :: ys -> let n = cmp x y in if n = 0 then loop xs ys else n in loop a b end module Uid : sig type t val compare : t -> t -> int val equal : t -> t -> bool val next : string -> t val hash : t -> int val name : t -> string val static : t end = struct type t = { code : int; name : string; } let compare a b = compare (a.code : int) b.code let equal a b = (a.code : int) = b.code let uid = ref 0 let next name = let code = !uid in incr uid; {code; name} let hash a = Hashtbl.hash a.code let name a = a.name let static = next "static" end module Key = struct type t = { uid : Uid.t; params : t list; } let rec compare k1 k2 = if k1 == k2 then 0 else let cmp = Uid.compare k1.uid k2.uid in if cmp <> 0 then cmp else List.compare compare k1.params k2.params let equal a b = compare a b = 0 let hash = (Hashtbl.hash : t -> int) let static = { uid = Uid.static ; params = [] } end type 'a t = Key.t type 'a typename = 'a t let key t = t let uid t = t.Key.uid let name t = Uid.name t.Key.uid let static = Key.static let create ?(name="Typename.create") () = { Key.uid = Uid.next name ; params = [] } include struct (* The argument for Obj.magic here is the same as the one in core/type_equal *) let same (type a) (type b) (nm1 : a t) (nm2 : b t) = Key.compare nm1 nm2 = 0 let same_witness (type a) (type b) (nm1 : a t) (nm2 : b t) = if Key.compare nm1 nm2 = 0 then Some (Obj.magic Type_equal.refl : (a, b) Type_equal.t) else None let same_witness_exn (type a) (type b) (nm1 : a t) (nm2 : b t) = if Key.compare nm1 nm2 = 0 then (Obj.magic Type_equal.refl : (a, b) Type_equal.t) else failwith "Typename.same_witness_exn" end module type S0 = sig type t val typename_of_t : t typename end module type S1 = sig type 'a t val typename_of_t : 'a typename -> 'a t typename end module type S2 = sig type ('a, 'b) t val typename_of_t : 'a typename -> 'b typename -> ('a, 'b) t typename end module type S3 = sig type ('a, 'b, 'c) t val typename_of_t : 'a typename -> 'b typename -> 'c typename -> ('a, 'b, 'c) t typename end module type S4 = sig type ('a, 'b, 'c, 'd) t val typename_of_t : 'a typename -> 'b typename -> 'c typename -> 'd typename -> ('a, 'b, 'c, 'd) t typename end module type S5 = sig type ('a, 'b, 'c, 'd, 'e) t val typename_of_t : 'a typename -> 'b typename -> 'c typename -> 'd typename -> 'e typename -> ('a, 'b, 'c, 'd, 'e) t typename end module Make0 (X : Named_intf.S0) = struct let uid = Uid.next X.name let typename_of_t = { Key.uid ; params = [] } end module Make1 (X : Named_intf.S1) = struct let uid = Uid.next X.name let typename_of_t a = { Key.uid ; params = [ a ] } end module Make2 (X : Named_intf.S2) = struct let uid = Uid.next X.name let typename_of_t a b = { Key.uid ; params = [ a ; b ] } end module Make3 (X : Named_intf.S3) = struct let uid = Uid.next X.name let typename_of_t a b c = { Key.uid ; params = [ a ; b ; c ] } end module Make4 (X : Named_intf.S4) = struct let uid = Uid.next X.name let typename_of_t a b c d = { Key.uid ; params = [ a ; b ; c ; d ] } end module Make5 (X : Named_intf.S5) = struct let uid = Uid.next X.name let typename_of_t a b c d e = { Key.uid ; params = [ a ; b ; c ; d ; e ] } end module Key_table = Hashtbl.Make (Key) module Table (X : sig type 'a t end) = struct type data = Data : 'a t * 'a X.t -> data type t = data Key_table.t let create int = Key_table.create int let mem table name = Key_table.mem table (key name) let set table name data = Key_table.replace table (key name) (Data (name, data)) let find (type a) table (name : a typename) = let data = try Some (Key_table.find table (key name)) with Base.Not_found_s _ | Caml.Not_found -> None in match data with | None -> None | Some (Data (name', data)) -> (fun (type b) (name' : b typename) (data : b X.t) -> let Type_equal.T = (same_witness_exn name' name : (b, a) Type_equal.t) in Some (data : a X.t) ) name' data end let fail uid_a uid_b = let msg = Printf.sprintf "Typename.Same_witness_exn %S %S" (Uid.name uid_a) (Uid.name uid_b) in failwith msg module Same_witness_exn_1 (A : S1) (B : S1) = struct type t = { eq : 'a. ('a A.t, 'a B.t) Type_equal.t } let witness = let uid_a = uid (A.typename_of_t static) in let uid_b = uid (B.typename_of_t static) in if Uid.equal uid_a uid_b then { eq = Obj.magic Type_equal.refl } else fail uid_a uid_b end module Same_witness_exn_2 (A : S2) (B : S2) = struct type t = { eq : 'a 'b. ( ('a, 'b) A.t, ('a, 'b) B.t ) Type_equal.t } let witness = let uid_a = uid (A.typename_of_t static static) in let uid_b = uid (B.typename_of_t static static) in if Uid.equal uid_a uid_b then { eq = Obj.magic Type_equal.refl } else fail uid_a uid_b end module Same_witness_exn_3 (A : S3) (B : S3) = struct type t = { eq : 'a 'b 'c. ( ('a, 'b, 'c) A.t, ('a, 'b, 'c) B.t ) Type_equal.t } let witness = let uid_a = uid (A.typename_of_t static static static) in let uid_b = uid (B.typename_of_t static static static) in if Uid.equal uid_a uid_b then { eq = Obj.magic Type_equal.refl } else fail uid_a uid_b end module Same_witness_exn_4 (A : S4) (B : S4) = struct type t = { eq : 'a 'b 'c 'd. ( ('a, 'b, 'c, 'd) A.t, ('a, 'b, 'c, 'd) B.t ) Type_equal.t } let witness = let uid_a = uid (A.typename_of_t static static static static) in let uid_b = uid (B.typename_of_t static static static static) in if Uid.equal uid_a uid_b then { eq = Obj.magic Type_equal.refl } else fail uid_a uid_b end module Same_witness_exn_5 (A : S5) (B : S5) = struct type t = { eq : 'a 'b 'c 'd 'e. ( ('a, 'b, 'c, 'd, 'e) A.t, ('a, 'b, 'c, 'd, 'e) B.t ) Type_equal.t } let witness = let uid_a = uid (A.typename_of_t static static static static static) in let uid_b = uid (B.typename_of_t static static static static static) in if Uid.equal uid_a uid_b then { eq = Obj.magic Type_equal.refl } else fail uid_a uid_b end typerep-0.14.0/lib/typename.mli000066400000000000000000000062621366315055700164000ustar00rootroot00000000000000(** runtime representation of the name of type ['a]. Useful for representing types with a nominal notion of equality *) type 'a t type 'a typename = 'a t val create : ?name:string -> unit -> 'a t val static : unit t (** nominal type equality test *) val same : _ t -> _ t -> bool val same_witness : 'a t -> 'b t -> ('a, 'b) Type_equal.t option val same_witness_exn : 'a t -> 'b t -> ('a, 'b) Type_equal.t (** a runtime representation of fully applied type ['a] *) module Key : sig type t val compare : t -> t -> int val equal : t -> t -> bool val hash : t -> int end val key : 'a t -> Key.t (** an untyped runtime representation of non applied type *) module Uid : sig type t val compare : t -> t -> int val equal : t -> t -> bool val hash : t -> int val name : t -> string end val uid : 'a t -> Uid.t val name : 'a t -> string module type S0 = sig type t val typename_of_t : t typename end module type S1 = sig type 'a t val typename_of_t : 'a typename -> 'a t typename end module type S2 = sig type ('a, 'b) t val typename_of_t : 'a typename -> 'b typename -> ('a, 'b) t typename end module type S3 = sig type ('a, 'b, 'c) t val typename_of_t : 'a typename -> 'b typename -> 'c typename -> ('a, 'b, 'c) t typename end module type S4 = sig type ('a, 'b, 'c, 'd) t val typename_of_t : 'a typename -> 'b typename -> 'c typename -> 'd typename -> ('a, 'b, 'c, 'd) t typename end module type S5 = sig type ('a, 'b, 'c, 'd, 'e) t val typename_of_t : 'a typename -> 'b typename -> 'c typename -> 'd typename -> 'e typename -> ('a, 'b, 'c, 'd, 'e) t typename end module Make0(X : Named_intf.S0) : S0 with type t := X.t module Make1(X : Named_intf.S1) : S1 with type 'a t := 'a X.t module Make2(X : Named_intf.S2) : S2 with type ('a, 'b) t := ('a, 'b) X.t module Make3(X : Named_intf.S3) : S3 with type ('a, 'b, 'c) t := ('a, 'b, 'c) X.t module Make4(X : Named_intf.S4) : S4 with type ('a, 'b, 'c, 'd) t := ('a, 'b, 'c, 'd) X.t module Make5(X : Named_intf.S5) : S5 with type ('a, 'b, 'c, 'd, 'e) t := ('a, 'b, 'c, 'd, 'e) X.t module Table(X : sig type 'a t end) : sig type t val create : int -> t val mem : t -> 'a typename -> bool val set : t -> 'a typename -> 'a X.t -> unit val find : t -> 'a typename -> 'a X.t option end (* witness of equality between non applied types *) module Same_witness_exn_1 (A : S1) (B : S1) : sig type t = { eq : 'a. ( 'a A.t, 'a B.t ) Type_equal.t } val witness : t end module Same_witness_exn_2 (A : S2) (B : S2) : sig type t = { eq : 'a 'b. ( ('a, 'b) A.t, ('a, 'b) B.t ) Type_equal.t } val witness : t end module Same_witness_exn_3 (A : S3) (B : S3) : sig type t = { eq : 'a 'b 'c. ( ('a, 'b, 'c) A.t, ('a, 'b, 'c) B.t ) Type_equal.t } val witness : t end module Same_witness_exn_4 (A : S4) (B : S4) : sig type t = { eq : 'a 'b 'c 'd. ( ('a, 'b, 'c, 'd) A.t, ('a, 'b, 'c, 'd) B.t ) Type_equal.t } val witness : t end module Same_witness_exn_5 (A : S5) (B : S5) : sig type t = { eq : 'a 'b 'c 'd 'e. ( ('a, 'b, 'c, 'd, 'e) A.t, ('a, 'b, 'c, 'd, 'e) B.t ) Type_equal.t } val witness : t end typerep-0.14.0/lib/typerep_obj.ml000066400000000000000000000025001366315055700167160ustar00rootroot00000000000000(* using the hash_variant of pa_type_conv at compile time *) let repr_of_poly_variant : [> ] -> int = fun variant -> let obj = Obj.repr variant in if Obj.is_int obj then Obj.obj obj else let size = Obj.size obj in assert (size = 2); let repr = Obj.field obj 0 in (assert (Obj.is_int repr)); Obj.obj repr let hash_variant s = let accu = ref 0 in for i = 0 to String.length s - 1 do accu := 223 * !accu + Char.code s.[i] done; (* reduce to 31 bits *) accu := !accu land (1 lsl 31 - 1); (* make it signed for 64 bits architectures *) if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu (* a few unit tests of cases that have triggered diffs in the past of this lib *) let () = assert (repr_of_poly_variant `Latency_stats = hash_variant "Latency_stats") let () = assert (repr_of_poly_variant `zero = hash_variant "zero") let double_array_value = Obj.magic 0. let has_double_array_tag a = Obj.double_array_tag = (Obj.tag (Obj.repr a)) let () = let module M = struct type double = { a : float ; b : float } type simple = { c : float ; d : int } let double = { a = double_array_value; b = double_array_value; } let simple = { c = double_array_value; d = double_array_value; } end in assert (has_double_array_tag M.double); assert (not (has_double_array_tag M.simple)); ;; typerep-0.14.0/lib/typerep_obj.mli000066400000000000000000000004631366315055700170750ustar00rootroot00000000000000(** some utils related to the runtime of ocaml, used both at compile time (camlp4) and runtime. to be considered the same way than [Obj] (internal, unsafe, etc.) *) val repr_of_poly_variant : [> ] -> int val hash_variant : string -> int val double_array_value : 'a val has_double_array_tag : 'a -> bool typerep-0.14.0/lib/typerepable.ml000066400000000000000000000025431366315055700167170ustar00rootroot00000000000000open Std_internal module type S = sig type t val typerep_of_t : t Typerep.t val typename_of_t : t Typename.t end module type S1 = sig type 'a t val typerep_of_t : 'a Typerep.t -> 'a t Typerep.t val typename_of_t : 'a Typename.t -> 'a t Typename.t end module type S2 = sig type ('a, 'b) t val typerep_of_t : 'a Typerep.t -> 'b Typerep.t -> ('a, 'b) t Typerep.t val typename_of_t : 'a Typename.t -> 'b Typename.t -> ('a, 'b) t Typename.t end module type S3 = sig type ('a, 'b, 'c) t val typerep_of_t : 'a Typerep.t -> 'b Typerep.t -> 'c Typerep.t -> ('a, 'b, 'c) t Typerep.t val typename_of_t : 'a Typename.t -> 'b Typename.t -> 'c Typename.t -> ('a, 'b, 'c) t Typename.t end module type S4 = sig type ('a, 'b, 'c, 'd) t val typerep_of_t : 'a Typerep.t -> 'b Typerep.t -> 'c Typerep.t -> 'd Typerep.t -> ('a, 'b, 'c, 'd) t Typerep.t val typename_of_t : 'a Typename.t -> 'b Typename.t -> 'c Typename.t -> 'd Typename.t -> ('a, 'b, 'c, 'd) t Typename.t end module type S5 = sig type ('a, 'b, 'c, 'd, 'e) t val typerep_of_t : 'a Typerep.t -> 'b Typerep.t -> 'c Typerep.t -> 'd Typerep.t -> 'e Typerep.t -> ('a, 'b, 'c, 'd, 'e) t Typerep.t val typename_of_t : 'a Typename.t -> 'b Typename.t -> 'c Typename.t -> 'd Typename.t -> 'e Typename.t -> ('a, 'b, 'c, 'd, 'e) t Typename.t end typerep-0.14.0/lib/variant_and_record_intf.ml000066400000000000000000000371651366315055700212570ustar00rootroot00000000000000(** Place holder for common Variants and Fields interface *) module M (X : sig (** This functor is essentially there because we use this same interface in different contexts, with different types for ['a t]. 1) One use case for it is where ['a X.t = 'a Typerep.t]. These interfaces are then part of the type witness built for a type containing a record or a variant in its structure. [traverse] will give a way of accessing the type representation for the arguments of a variant or record type. 2) Another use case is for building "staged generic computations". In that case, the type ['a X.t] is the type of the computation that is being built. [traverse] returns the computation built for the argument. The interface no longer exports the typerep of the arguments in hopes of enforcing that no typerep traversal happens at runtime if the computation happen to be a function. *) type 'a t end) = struct (* The functions prefixed by [internal] as well as the module suffixed by [_internal] are used by the code generated by the camlp4 extension [with typerep] as well as some internals of the typerep library. Do not consider using these somewhere else. They should ideally not be exported outside the typerep library, but the generated code needs somehow to access this, even outside. *) module Tag_internal = struct type ('variant, 'args) create = Args of ('args -> 'variant) | Const of 'variant type ('variant, 'args) t = { label : string ; rep : 'args X.t ; arity : int ; args_labels: string list ; index : int ; ocaml_repr : int ; tyid : 'args Typename.t ; create : ('variant, 'args) create } end (** Witness of a tag, that is an item in a variant type, also called an "applied variant Constructor" The first parameter is the variant type, the second is the type of the tag parameters. Example: {[ type t = | A of (int * string) | B of string | C of { x : int; y : string } ]} this type has three constructors. For each of them we'll have a corresponding [Tag.t]: {[ val tag_A : (t, (int * string)) Tag.t val tag_B : (t, string ) Tag.t val tag_C : (t, (int * string)) Tag.t ]} Note, inline record in variant are typed as if their definition was using tuples, without the parenthesis. This is consistent with their runtime representation. But the distinction is carried and available for introspection as part of the [Tag.t]. See [args_labels]. *) module Tag : sig type ('variant, 'args) create = Args of ('args -> 'variant) | Const of 'variant type ('variant, 'args) t (** The name of the constructor as it is given in the concrete syntax Examples: {v Constructor | label ------------------------- | A of int | "A" | `a of int | "a" | `A of int | "A" | A of { x : int } | "A" v} for standard variant, the ocaml syntax implies that this label will always starts with a capital letter. For polymorphic variants, this might be a lowercase char. For polymorphic variant, this label does not include the [`] character. *) val label : (_, _) t -> string (** The size of the ocaml heap block containing the arguments Examples: {v 0: | A | 'A 1: | A of int | `A of int | A of (int * int) | `A of (int * int) | `A of int * int | A of { x : int} 2: | A of int * float | A of { x : int; y : string } etc. v} *) val arity : (_, _) t -> int (** The label of the fields for inline records. For other forms of tags, this is the empty list. When this returns a non empty list, the length of the returned list is equal to the arity. Example: {v (1) Empty: | A | 'A | A of int | `A of int | A of (int * int) | `A of (int * int) | `A of int * int | A of int * float (2) Non empty: | A of { x : int } -> [ "x" ] | A of { x : int; y : string } -> [ "x" ; "y" ] v} *) val args_labels : (_, _) t -> string list (** The index of the constructor in the list of all the variant type's constructors Examples: {[ type t = | A of int (* 0 *) | B (* 1 *) | C of int (* 2 *) | D of char (* 3 *) | E of { x : int } (* 4 *) ]} *) val index : (_, _) t -> int (** ocaml_repr is related to the runtime of objects. this is essentially a way of giving one the ability to rebuild dynamically an [Obj.t] representing a tag. Polymorphic variants: --------------------- [ocaml_repr] is the hash of the label, as done by the compiler. Example: print_int (Obj.magic `bar) (* 4895187 *) print_int (Obj.magic 'foo) (* 5097222 *) Standards variants: ------------------- [ocaml_repr] is the tag corresponding to the constructor within the type. the way it works in the ocaml runtime is by partitioning the constructors regarding if they have some arguments or not, preserving the order, then assign increasing index withing each partition. Example: {[ type t = (* no arg *) (* args *) | A (* 0 *) | B of int (* 0 *) | C (* 1 *) | D of (float * string) (* 1 *) | E (* 2 *) | F (* 3 *) | G of string (* 2 *) | H of { x : int } (* 3 *) ]} *) val ocaml_repr : (_, _) t -> int (** Give back a way of constructing a value of that constructor from its arguments. Examples: {[ type t = | A of (int * string) | B of int * float | C | D of { x : int; y : string } ]} [create] will return something equivalent to: tag_A : [Args (fun (d : (int * string) -> A d)] tag_B : [Args (fun (i, f) -> B (i, f))] tag_C : [Const C] tag_D : [Args (fun (x, y) -> D { x; y })] *) val create : ('variant, 'args) t -> ('variant, 'args) create (** return the type_name of the arguments. might be used to perform some lookup based on it while building a computation for example *) val tyid : (_, 'args) t -> 'args Typename.t (** get the representation/computation of the arguments *) val traverse : (_, 'args) t -> 'args X.t (* used by the camlp4 extension to build type witnesses, or by some internal parts of typerep. you should feel bad if you need to use it in some user code *) val internal_use_only : ('a, 'b) Tag_internal.t -> ('a, 'b) t end = struct include Tag_internal let label t = t.label let arity t = t.arity let args_labels t = t.args_labels let index t = t.index let ocaml_repr t = t.ocaml_repr let create t = t.create let tyid t = t.tyid let traverse t = t.rep let internal_use_only t = t end module Variant_internal = struct type _ tag = Tag : ('variant, 'a) Tag.t -> 'variant tag type _ value = Value : ('variant, 'a) Tag.t * 'a -> 'variant value type 'a t = { typename : 'a Typename.t; tags : 'a tag array; polymorphic : bool; value : 'a -> 'a value; } end module Variant : sig (** An existential type used to gather all the tags constituing a variant type. the ['variant] parameter is the variant type, it is the same for all the constructors of that variant type. The type of the parameters might be different for each constructor and is thus existential *) type _ tag = Tag : ('variant, 'args) Tag.t -> 'variant tag (** A similar existential constructor to [_ tag] but this one holds a value whose type is the arguments of the tag constructor. A value of type ['a value] is a pair of (1) a value of variant type ['a] along with (2) some information about the constructor within the type ['a] *) type _ value = Value : ('variant, 'args) Tag.t * 'args -> 'variant value (** Witness of a variant type. The parameter is the type of the variant type witnessed. *) type 'a t val typename_of_t : 'a t -> 'a Typename.t (** Returns the number of tags of this variant type definition. *) val length : 'a t -> int (** Get the nth tag of this variant type, indexed from 0. *) val tag : 'a t -> int -> 'a tag (** Distinguish polymorphic variants and standard variants. Typically, polymorphic variants tags starts with the [`] character. Example polymorphic variant: type t = [ `A | `B ] standard variant: type t = A | B *) val is_polymorphic : _ t -> bool (** Pattern matching on a value of this variant type. *) val value : 'a t -> 'a -> 'a value (** folding along the tags of the variant type *) val fold : 'a t -> init:'acc -> f:('acc -> 'a tag -> 'acc) -> 'acc (* used by the camlp4 extension to build type witnesses, or by some internal parts of typerep. you should feel bad if you need to use it in some user code *) val internal_use_only : 'a Variant_internal.t -> 'a t end = struct include Variant_internal let typename_of_t t = t.typename let length t = Array.length t.tags let tag t index = t.tags.(index) let is_polymorphic t = t.polymorphic let value t = t.value let fold t ~init ~f = Array.fold_left f init t.tags let internal_use_only t = t end module Field_internal = struct type ('record, 'field) t = { label : string; rep : 'field X.t; index : int; tyid : 'field Typename.t; get : ('record -> 'field); (* set : ('record -> 'field -> unit) option; (\* mutable field *\) *) is_mutable : bool; } end (** Witness of a field, that is an item in a record type. The first parameter is the record type, the second is the type of the field. Example: {[ type t = { x : int ; y : string } ]} This type has two fields. for each of them we'll have a corresponding [Field.t] val field_x : (t, int) Field.t val field_y : (t, string) Field.t *) module Field : sig type ('record, 'field) t (** The name of the field as it is given in the concrete syntax Examples: {[ { x : int; (* "x" *) foo : string; (* "foo" *) bar : float; (* "bar" *) } ]} *) val label : (_, _) t -> string (** The 0-based index of the field in the list of all fields for this record type. Example: {[ type t = { x : int; (* 0 *) foo : string; (* 1 *) bar : string; (* 2 *) } ]} *) val index : (_, _) t -> int (** Field accessors. This corresponds to the dot operation. [Field.get bar_field t] returns the field [bar] of the record value [t], just the same as [t.bar] *) val get : ('record, 'field) t -> 'record -> 'field (** return whether the field is mutable, i.e. whether its declaration is prefixed with the keyword [mutable] *) val is_mutable : (_, _) t -> bool (** return the type_name of the arguments. Might be used to perform some lookup based on it *) val tyid : (_, 'field) t -> 'field Typename.t (** get the computation of the arguments *) val traverse : (_, 'field) t -> 'field X.t (* used by the camlp4 extension to build type witnesses, or by some internal parts of typerep. you should feel bad if you need to use it in some user code *) val internal_use_only : ('a, 'b) Field_internal.t -> ('a, 'b) t end = struct include Field_internal let label t = t.label let index t = t.index let get t = t.get let is_mutable t = t.is_mutable let tyid t = t.tyid let traverse t = t.rep let internal_use_only t = t end module Record_internal = struct type _ field = Field : ('record, 'a) Field.t -> 'record field type 'record fields = { get : 'field. ('record, 'field) Field.t -> 'field } type 'a t = { typename : 'a Typename.t; fields : 'a field array; has_double_array_tag : bool; create : 'a fields -> 'a; } end module Record : sig (** An existential type used to gather all the fields constituing a record type. the ['record] parameter is the record type, it is the same for all the field of that record type. The type of the fields might be different for each field and is thus existential. *) type _ field = Field : ('record, 'a) Field.t -> 'record field (** ['record fields] is a type isomorphic to ['record]. This gives a way to get the field value for each field of the record. The advantage of this representation is that it is convenient for writing generic computations. *) type 'record fields = { get : 'field. ('record, 'field) Field.t -> 'field } (** Witness of a record type. The parameter is the type of the record type witnessed. *) type 'a t val typename_of_t : 'a t -> 'a Typename.t (** Returns the number of fields of this record type definition. *) val length : 'a t -> int (** Get the nth field of this record type, indexed from 0. *) val field : 'a t -> int -> 'a field (** This is a low level metadata regarding the way the ocaml compiler represent the array underneath that is the runtime value of a record of type ['a] given a witness of type ['a t]. [has_double_array_tag w] returns [true] if the array that represents runtime values of this type is an optimized ocaml float array. Typically, this will be true for record where all fields are statically known as to be [floats]. Note that you can't get this information dynamically by inspecting the typerep once it is applied, because there is at this point no way to tell whether one of the field is polymorphic in the type definition. *) val has_double_array_tag : _ t -> bool (** Expose one direction of the isomorphism between a value of type ['a] and a value of type ['a fields]. Basically, given an encoding way of accessing the value of all the fields of a record, create that record and return it. *) val create : 'a t -> 'a fields -> 'a (** folding along the tags of the variant type *) val fold : 'a t -> init:'acc -> f:('acc -> 'a field -> 'acc) -> 'acc (* used by the camlp4 extension to build type witnesses, or by some internal parts of typerep. you should feel bad if you need to use it in some user code *) val internal_use_only : 'a Record_internal.t -> 'a t end = struct include Record_internal let typename_of_t t = t.typename let length t = Array.length t.fields let field t index = t.fields.(index) let has_double_array_tag t = t.has_double_array_tag let create t = t.create let fold t ~init ~f = Array.fold_left f init t.fields let internal_use_only t = t end end module type S = sig type 'a t include (module type of M (struct type 'a rep = 'a t type 'a t = 'a rep end)) end typerep-0.14.0/typerep.opam000066400000000000000000000011501366315055700156420ustar00rootroot00000000000000opam-version: "2.0" version: "v0.14.0" maintainer: "opensource@janestreet.com" authors: ["Jane Street Group, LLC "] homepage: "https://github.com/janestreet/typerep" bug-reports: "https://github.com/janestreet/typerep/issues" dev-repo: "git+https://github.com/janestreet/typerep.git" doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/typerep/index.html" license: "MIT" build: [ ["dune" "build" "-p" name "-j" jobs] ] depends: [ "ocaml" {>= "4.04.2"} "base" {>= "v0.14" & < "v0.15"} "dune" {>= "2.0.0"} ] synopsis: "Typerep is a library for runtime types" description: " "