pax_global_header00006660000000000000000000000064125634245610014522gustar00rootroot0000000000000052 comment=40674a15f1e9cc14519e8a30abaaf27ebbff3df2 typerep-113.00.00/000077500000000000000000000000001256342456100135145ustar00rootroot00000000000000typerep-113.00.00/.gitignore000066400000000000000000000001021256342456100154750ustar00rootroot00000000000000_build/ /setup.data /setup.log /*.exe /*.docdir /*.native /*.byte typerep-113.00.00/CHANGES.md000066400000000000000000000005601256342456100151070ustar00rootroot00000000000000## 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-113.00.00/INRIA-DISCLAIMER.txt000066400000000000000000000013321256342456100165300ustar00rootroot00000000000000THIS SOFTWARE IS PROVIDED BY INRIA AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL INRIA OR ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. typerep-113.00.00/INSTALL.txt000066400000000000000000000016101256342456100153610ustar00rootroot00000000000000(* OASIS_START *) (* DO NOT EDIT (digest: 1ed2bc683576c6642c0b7e7e4639ca40) *) This is the INSTALL file for the typerep distribution. This package uses OASIS to generate its build system. See section OASIS for full information. Dependencies ============ In order to compile this package, you will need: * ocaml (>= 4.00.0) * findlib (>= 1.3.2) * type_conv for library typerep_syntax Installing ========== 1. Uncompress the source archive and go to the root of the package 2. Run 'ocaml setup.ml -configure' 3. Run 'ocaml setup.ml -build' 4. Run 'ocaml setup.ml -install' Uninstalling ============ 1. Go to the root of the package 2. Run 'ocaml setup.ml -uninstall' OASIS ===== OASIS is a program that generates a setup.ml file using a simple '_oasis' configuration file. The generated setup only depends on the standard OCaml installation: no additional library is required. (* OASIS_STOP *) typerep-113.00.00/LICENSE.txt000066400000000000000000000261361256342456100153470ustar00rootroot00000000000000 Apache License Version 2.0, January 2004 http://www.apache.org/licenses/ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 1. Definitions. "License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. "Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. "Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. "You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. "Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. "Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. "Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). "Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. "Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." "Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. 2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. 3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. 4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: (a) You must give any other recipients of the Work or Derivative Works a copy of this License; and (b) You must cause any modified files to carry prominent notices stating that You changed the files; and (c) You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and (d) If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. 5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. 6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. 7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. 8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. 9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. END OF TERMS AND CONDITIONS APPENDIX: How to apply the Apache License to your work. To apply the Apache License to your work, attach the following boilerplate notice, with the fields enclosed by brackets "[]" replaced with your own identifying information. (Don't include the brackets!) The text should be enclosed in the appropriate comment syntax for the file format. We also recommend that a file or class name and description of purpose be included on the same "printed page" as the copyright notice for easier identification within third-party archives. Copyright [yyyy] [name of copyright owner] Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. typerep-113.00.00/Makefile000066400000000000000000000025111256342456100151530ustar00rootroot00000000000000# Generic Makefile for oasis project # Set to setup.exe for the release SETUP := setup.exe # Default rule default: build # Setup for the development version setup-dev.exe: _oasis setup.ml sed '/^#/D' setup.ml > setup_dev.ml ocamlfind ocamlopt -o $@ -linkpkg -package ocamlbuild,oasis.dynrun setup_dev.ml || ocamlfind ocamlc -o $@ -linkpkg -package ocamlbuild,oasis.dynrun setup_dev.ml || true rm -f setup_dev.* # Setup for the release setup.exe: setup.ml ocamlopt.opt -o $@ $< || ocamlopt -o $@ $< || ocamlc -o $@ $< rm -f setup.cmx setup.cmi setup.o setup.obj setup.cmo build: $(SETUP) setup.data ./$(SETUP) -build $(BUILDFLAGS) doc: $(SETUP) setup.data build ./$(SETUP) -doc $(DOCFLAGS) test: $(SETUP) setup.data build ./$(SETUP) -test $(TESTFLAGS) all: $(SETUP) ./$(SETUP) -all $(ALLFLAGS) install: $(SETUP) setup.data ./$(SETUP) -install $(INSTALLFLAGS) uninstall: $(SETUP) setup.data ./$(SETUP) -uninstall $(UNINSTALLFLAGS) reinstall: $(SETUP) setup.data ./$(SETUP) -reinstall $(REINSTALLFLAGS) clean: $(SETUP) ./$(SETUP) -clean $(CLEANFLAGS) distclean: $(SETUP) ./$(SETUP) -distclean $(DISTCLEANFLAGS) configure: $(SETUP) ./$(SETUP) -configure $(CONFIGUREFLAGS) setup.data: $(SETUP) ./$(SETUP) -configure $(CONFIGUREFLAGS) .PHONY: default build doc test all install uninstall reinstall clean distclean configure typerep-113.00.00/THIRD-PARTY.txt000066400000000000000000000013601256342456100160240ustar00rootroot00000000000000The repository contains 3rd-party code in the following locations and under the following licenses: - type_conv, sexplib and bin_prot: based on Tywith, by Martin Sandin. License can be found in base/sexplib/LICENSE-Tywith.txt, base/type_conv/LICENSE-Tywith.txt, and base/bin_prot/LICENSE-Tywith.txt. - Core's implementation of union-find: based on an implementation by Henry Matthew Fluet, Suresh Jagannathan, and Stephen Weeks. License can be found in base/core/MLton-license. - Various Core libraries are based on INRIA's OCaml distribution. Relicensed under Apache 2.0, as permitted under the Caml License for Consortium members: http://caml.inria.fr/consortium/license.en.html See also the disclaimer INRIA-DISCLAIMER.txt. typerep-113.00.00/_oasis000066400000000000000000000032511256342456100147150ustar00rootroot00000000000000OASISFormat: 0.3 OCamlVersion: >= 4.00.0 FindlibVersion: >= 1.3.2 Name: typerep Version: 113.00.00 Synopsis: Runtime types for OCaml Authors: Jane Street Group, LLC Copyrights: (C) 2013 Jane Street Group LLC Maintainers: Jane Street Group, LLC License: Apache-2.0 LicenseFile: LICENSE.txt Homepage: https://github.com/janestreet/typerep_beta Plugins: StdFiles (0.3), DevFiles (0.3), META (0.3) XStdFilesAUTHORS: false XStdFilesREADME: false BuildTools: ocamlbuild, camlp4o Description: Library for creating runtime representation of OCaml types and computing functions from these. Library typerep_lib Path: lib Pack: true Modules: Make_typename, Named_intf, Std, Std_internal, Type_abstract, Type_equal, Type_generic_intf, Type_generic, Typename, Typerepable, Typerep_obj, Variant_and_record_intf Library typerep_syntax Path: syntax Modules: Pa_typerep_conv FindlibName: syntax FindlibParent: typerep_lib BuildDepends: camlp4.lib, camlp4.extend, camlp4.quotations, type_conv XMETAType: syntax XMETARequires: camlp4, type_conv XMETADescription: Syntax extension for the "typerep" converter typerep-113.00.00/_tags000066400000000000000000000026501256342456100145370ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 443b5dc74eb95bbb0466f9fba564a86a) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process true: annot, bin_annot <**/.svn>: -traverse <**/.svn>: not_hygienic ".bzr": -traverse ".bzr": not_hygienic ".hg": -traverse ".hg": not_hygienic ".git": -traverse ".git": not_hygienic "_darcs": -traverse "_darcs": not_hygienic # Library typerep_lib "lib/typerep_lib.cmxs": use_typerep_lib "lib/make_typename.cmx": for-pack(Typerep_lib) "lib/named_intf.cmx": for-pack(Typerep_lib) "lib/std.cmx": for-pack(Typerep_lib) "lib/std_internal.cmx": for-pack(Typerep_lib) "lib/type_abstract.cmx": for-pack(Typerep_lib) "lib/type_equal.cmx": for-pack(Typerep_lib) "lib/type_generic_intf.cmx": for-pack(Typerep_lib) "lib/type_generic.cmx": for-pack(Typerep_lib) "lib/typename.cmx": for-pack(Typerep_lib) "lib/typerepable.cmx": for-pack(Typerep_lib) "lib/typerep_obj.cmx": for-pack(Typerep_lib) "lib/variant_and_record_intf.cmx": for-pack(Typerep_lib) # Library typerep_syntax "syntax/typerep_syntax.cmxs": use_typerep_syntax : package(camlp4.extend) : package(camlp4.lib) : package(camlp4.quotations) : package(type_conv) # OASIS_STOP : syntax_camlp4o, locfix <{extended,generics}/**/*.ml{,i}>: syntax_camlp4o, pa_typerep typerep-113.00.00/configure000077500000000000000000000005531256342456100154260ustar00rootroot00000000000000#!/bin/sh # OASIS_START # DO NOT EDIT (digest: dc86c2ad450f91ca10c931b6045d0499) set -e FST=true for i in "$@"; do if $FST; then set -- FST=false fi case $i in --*=*) ARG=${i%%=*} VAL=${i##*=} set -- "$@" "$ARG" "$VAL" ;; *) set -- "$@" "$i" ;; esac done ocaml setup.ml -configure "$@" # OASIS_STOP typerep-113.00.00/experimental/000077500000000000000000000000001256342456100162115ustar00rootroot00000000000000typerep-113.00.00/experimental/example/000077500000000000000000000000001256342456100176445ustar00rootroot00000000000000typerep-113.00.00/experimental/example/with_typerep_pp/000077500000000000000000000000001256342456100230665ustar00rootroot00000000000000typerep-113.00.00/experimental/example/with_typerep_pp/combination.ml000066400000000000000000000213241256342456100257240ustar00rootroot00000000000000open Core.Std let _ = _squelch_unused_module_warning_ open Typerep_experimental.Std module Transaction_type = struct module V1 = struct type t = | Trade | Order module Typename_of_t = Make_typename.Make0(struct type non_rec = t type t = non_rec let name = "Combination.Transaction_type.V1.t" end) let typerep_of_t = let name_of_t = Typename_of_t.named in Typerep.Named (name_of_t, Some (lazy ( let tag0 = Typerep.Tag.internal_use_only { Typerep.Tag_internal. label = "Trade"; rep = typerep_of_tuple0; arity = 0; index = 0; ocaml_repr = 0; tyid = Typename.create (); create = Typerep.Tag_internal.Const Trade; } in let tag1 = Typerep.Tag.internal_use_only { Typerep.Tag_internal. label = "Order"; rep = typerep_of_tuple0; arity = 0; index = 1; ocaml_repr = 1; tyid = Typename.create (); create = Typerep.Tag_internal.Const Order; } in let typename = Typerep.Named.typename_of_t name_of_t in let polymorphic = false in let tags = [| Typerep.Variant_internal.Tag tag0; Typerep.Variant_internal.Tag tag1; |] in let value = function | Trade -> Typerep.Variant_internal.Value (tag0, value_tuple0) | Order -> Typerep.Variant_internal.Value (tag1, value_tuple0) in Typerep.Variant (Typerep.Variant.internal_use_only { Typerep.Variant_internal. typename; tags; polymorphic; value; }) ))) end module V2 = struct type t = | Trade | Order | Journal of string * string module Typename_of_t = Make_typename.Make0(struct type non_rec = t type t = non_rec let name = "Combination.Transaction_type.V2.t" end) let typerep_of_t = let name_of_t = Typename_of_t.named in Typerep.Named (name_of_t, Some (lazy ( let tag0 = Typerep.Tag.internal_use_only { Typerep.Tag_internal. label = "Trade"; rep = typerep_of_tuple0; arity = 0; index = 0; ocaml_repr = 0; tyid = Typename.create (); create = Typerep.Tag_internal.Const Trade; } in let tag1 = Typerep.Tag.internal_use_only { Typerep.Tag_internal. label = "Order"; rep = typerep_of_tuple0; arity = 0; index = 1; ocaml_repr = 1; tyid = Typename.create (); create = Typerep.Tag_internal.Const Order; } in let tag2 = Typerep.Tag.internal_use_only { Typerep.Tag_internal. label = "Journal"; rep = typerep_of_tuple2 typerep_of_string typerep_of_string; arity = 2; index = 1; ocaml_repr = 0; tyid = Typename.create (); create = Typerep.Tag_internal.Args (fun (v1, v2) -> Journal (v1, v2)); } in let typename = Typerep.Named.typename_of_t name_of_t in let polymorphic = false in let tags = [| Typerep.Variant_internal.Tag tag0; Typerep.Variant_internal.Tag tag1; Typerep.Variant_internal.Tag tag2; |] in let value = function | Trade -> Typerep.Variant_internal.Value (tag0, value_tuple0) | Order -> Typerep.Variant_internal.Value (tag1, value_tuple0) | Journal (v1, v2) -> Typerep.Variant_internal.Value (tag2, (v1, v2)) in Typerep.Variant (Typerep.Variant.internal_use_only { Typerep.Variant_internal. typename; tags; polymorphic; value; }) ))) end end module V1 = struct type t = { transaction_type : Transaction_type.V1.t; username : string; } module Typename_of_t = Make_typename.Make0(struct type non_rec = t type t = non_rec let name = "Combination.V1.t" end) let typerep_of_t = let name_of_t = Typename_of_t.named in Typerep.Named (name_of_t, Some(lazy( let field0 = Typerep.Field.internal_use_only { Typerep.Field_internal. label = "transaction_type"; index = 0; rep = Transaction_type.V1.typerep_of_t; tyid = Typename.create (); get = (fun t -> t.transaction_type); } in let field1 = Typerep.Field.internal_use_only { Typerep.Field_internal. label = "username"; index = 1; rep = typerep_of_string; tyid = Typename.create (); get = (fun t -> t.username); } in let typename = Typerep.Named.typename_of_t name_of_t in let has_double_array_tag = Typerep_obj.has_double_array_tag { transaction_type = Typerep_obj.double_array_value; username = Typerep_obj.double_array_value; } in let fields = [| Typerep.Record_internal.Field field0; Typerep.Record_internal.Field field1; |] in let create { Typerep.Record_internal.get } = let transaction_type = get field0 in let username = get field1 in { transaction_type ; username } in Typerep.Record (Typerep.Record.internal_use_only { Typerep.Record_internal. typename; has_double_array_tag; fields; create; }) ))) end module V2 = struct type t = { transaction_type : Transaction_type.V2.t; username : string; tags : (string * string) list; } module Typename_of_t = Make_typename.Make0(struct type non_rec = t type t = non_rec let name = "Combination.V2.t" end) let typerep_of_t = let name_of_t = Typename_of_t.named in Typerep.Named (name_of_t, Some(lazy( let field0 = Typerep.Field.internal_use_only { Typerep.Field_internal. label = "transaction_type"; index = 0; rep = Transaction_type.V2.typerep_of_t; tyid = Typename.create (); get = (fun t -> t.transaction_type); } in let field1 = Typerep.Field.internal_use_only { Typerep.Field_internal. label = "username"; index = 1; rep = typerep_of_string; tyid = Typename.create (); get = (fun t -> t.username); } in let field2 = Typerep.Field.internal_use_only { Typerep.Field_internal. label = "tags"; index = 2; rep = typerep_of_list (typerep_of_tuple2 typerep_of_string typerep_of_string); tyid = Typename.create (); get = (fun t -> t.tags); } in let typename = Typerep.Named.typename_of_t name_of_t in let has_double_array_tag = Typerep_obj.has_double_array_tag { transaction_type = Typerep_obj.double_array_value; username = Typerep_obj.double_array_value; tags = Typerep_obj.double_array_value; } in let fields = [| Typerep.Record_internal.Field field0; Typerep.Record_internal.Field field1; Typerep.Record_internal.Field field2; |] in let create { Typerep.Record_internal.get } = let transaction_type = get field0 in let username = get field1 in let tags = get field2 in { transaction_type ; username ; tags } in Typerep.Record (Typerep.Record.internal_use_only { Typerep.Record_internal. typename; has_double_array_tag; fields; create; }) ))) end type t = | V1 of V1.t | V2 of V2.t module Typename_of_t = Make_typename.Make0(struct type non_rec = t type t = non_rec let name = "Combination.t" end) let typerep_of_t : t Typerep.t = let name_of_t = Typename_of_t.named in Typerep.Named (name_of_t, Some (lazy ( let tag0 = Typerep.Tag.internal_use_only { Typerep.Tag_internal. label = "V1"; rep = V1.typerep_of_t; arity = 1; index = 0; ocaml_repr = 0; tyid = Typename.create (); create = Typerep.Tag_internal.Args (fun x -> V1 x); } in let tag1 = Typerep.Tag.internal_use_only { Typerep.Tag_internal. label = "V2"; rep = V2.typerep_of_t; arity = 1; index = 1; ocaml_repr = 1; tyid = Typename.create (); create = Typerep.Tag_internal.Args (fun x -> V2 x) } in let typename = Typerep.Named.typename_of_t name_of_t in let polymorphic = false in let tags = [| Typerep.Variant_internal.Tag tag0; Typerep.Variant_internal.Tag tag1; |] in let value = function | V1 x -> Typerep.Variant_internal.Value (tag0, x) | V2 x -> Typerep.Variant_internal.Value (tag1, x) in Typerep.Variant (Typerep.Variant.internal_use_only { Typerep.Variant_internal. typename; tags; polymorphic; value; }) ))) typerep-113.00.00/experimental/example/with_typerep_pp/combination.mli000066400000000000000000000012601256342456100260720ustar00rootroot00000000000000open Core.Std open Typerep_experimental.Std module Transaction_type : sig module V1 : sig type t = | Trade | Order val typerep_of_t : t Typerep.t end module V2 : sig type t = | Trade | Order | Journal of string * string val typerep_of_t : t Typerep.t end end module V1 : sig type t = { transaction_type : Transaction_type.V1.t; username : string; } val typerep_of_t : t Typerep.t end module V2 : sig type t = { transaction_type : Transaction_type.V2.t; username : string; tags : (string * string) list; } val typerep_of_t : t Typerep.t end type t = | V1 of V1.t | V2 of V2.t val typerep_of_t : t Typerep.t typerep-113.00.00/experimental/example/with_typerep_pp/records.ml000066400000000000000000000136061256342456100250670ustar00rootroot00000000000000open Typerep_experimental.Std module M1 = struct type t = { a : int; b : float; } module Typename_of_t = Make_typename.Make0(struct type nonrec t = t let name = "Records.M1.t" end) let typerep_of_t = let name_of_t = Typename_of_t.named in Typerep.Named (name_of_t, Some (lazy ( let field0 = Typerep.Field.internal_use_only { Typerep.Field_internal. label = "a"; index = 0; rep = typerep_of_int; tyid = Typename.create (); get = (fun t -> t.a); } in let field1 = Typerep.Field.internal_use_only { Typerep.Field_internal. label = "b"; index = 1; rep = typerep_of_float; tyid = Typename.create (); get = (fun t -> t.b); } in let typename = Typerep.Named.typename_of_t name_of_t in let has_double_array_tag = Typerep_obj.has_double_array_tag { a = Typerep_obj.double_array_value; b = Typerep_obj.double_array_value; } in let fields = [| Typerep.Record_internal.Field field0; Typerep.Record_internal.Field field1; |] in let create { Typerep.Record_internal.get } = let a = get field0 in let b = get field1 in { a ; b } in Typerep.Record (Typerep.Record.internal_use_only { Typerep.Record_internal. typename; has_double_array_tag; fields; create; }) ))) end module M2 = struct type t = { a : int * string; b : float; } module Typename_of_t = Make_typename.Make0(struct type non_rec = t type t = non_rec let name = "Records.M2.t" end) let typerep_of_t = let name_of_t = Typename_of_t.named in Typerep.Named (name_of_t, Some (lazy ( let field0 = Typerep.Field.internal_use_only { Typerep.Field_internal. label = "a"; index = 0; rep = typerep_of_tuple2 typerep_of_int typerep_of_string; tyid = Typename.create (); get = (fun t -> t.a); } in let field1 = Typerep.Field.internal_use_only { Typerep.Field_internal. label = "b"; index = 1; rep = typerep_of_float; tyid = Typename.create (); get = (fun t -> t.b); } in let typename = Typerep.Named.typename_of_t name_of_t in let has_double_array_tag = Typerep_obj.has_double_array_tag { a = Typerep_obj.double_array_value; b = Typerep_obj.double_array_value; } in let fields = [| Typerep.Record_internal.Field field0; Typerep.Record_internal.Field field1; |] in let create { Typerep.Record_internal.get } = let a = get field0 in let b = get field1 in { a ; b } in Typerep.Record (Typerep.Record.internal_use_only { Typerep.Record_internal. typename; has_double_array_tag; fields; create; }) ))) end module M3 = struct type t = { m1 : M1.t; m2 : M2.t; } module Typename_of_t = Make_typename.Make0(struct type non_rec = t type t = non_rec let name = "Records.M3.t" end) let typerep_of_t = let name_of_t = Typename_of_t.named in Typerep.Named (name_of_t, Some (lazy ( let field0 = Typerep.Field.internal_use_only { Typerep.Field_internal. label = "m1"; index = 0; rep = M1.typerep_of_t; tyid = Typename.create (); get = (fun t -> t.m1); } in let field1 = Typerep.Field.internal_use_only { Typerep.Field_internal. label = "m2"; index = 1; rep = M2.typerep_of_t; tyid = Typename.create (); get = (fun t -> t.m2); } in let typename = Typerep.Named.typename_of_t name_of_t in let has_double_array_tag = Typerep_obj.has_double_array_tag { m1 = Typerep_obj.double_array_value; m2 = Typerep_obj.double_array_value; } in let fields = [| Typerep.Record_internal.Field field0; Typerep.Record_internal.Field field1; |] in let create { Typerep.Record_internal.get } = let m1 = get field0 in let m2 = get field1 in { m1 ; m2 } in Typerep.Record (Typerep.Record.internal_use_only { Typerep.Record_internal. typename; has_double_array_tag; fields; create; }) ))) end (* parametric *) module P1 = struct type 'a t = { a : 'a; b : float; } module Typename_of_t = Make_typename.Make1(struct type 'a non_rec = 'a t type 'a t = 'a non_rec let name = "Records.P1.t" end) let typerep_of_t (type p1) (of_p1:p1 Typerep.t) = let name_of_t = Typename_of_t.named of_p1 in Typerep.Named (name_of_t, Some (lazy ( let field0 = Typerep.Field.internal_use_only { Typerep.Field_internal. label = "a"; index = 0; rep = of_p1; tyid = Typename.create (); get = (fun t -> t.a); } in let field1 = Typerep.Field.internal_use_only { Typerep.Field_internal. label = "b"; index = 1; rep = typerep_of_float; tyid = Typename.create (); get = (fun t -> t.b); } in let typename = Typerep.Named.typename_of_t name_of_t in let has_double_array_tag = Typerep_obj.has_double_array_tag { a = Typerep_obj.double_array_value; b = Typerep_obj.double_array_value; } in let fields = [| Typerep.Record_internal.Field field0; Typerep.Record_internal.Field field1; |] in let create { Typerep.Record_internal.get } = let a = get field0 in let b = get field1 in { a ; b } in Typerep.Record (Typerep.Record.internal_use_only { Typerep.Record_internal. typename; has_double_array_tag; fields; create; }) ))) end typerep-113.00.00/experimental/example/with_typerep_pp/records.mli000066400000000000000000000007301256342456100252320ustar00rootroot00000000000000open Core.Std open Typerep_experimental.Std module M1 : sig type t = { a : int; b : float; } val typerep_of_t : t Typerep.t end module M2 : sig type t = { a : int * string; b : float; } val typerep_of_t : t Typerep.t end module M3 : sig type t = { m1 : M1.t; m2 : M2.t; } val typerep_of_t : t Typerep.t end module P1 : sig type 'a t = { a : 'a; b : float; } val typerep_of_t : 'a Typerep.t -> 'a t Typerep.t end typerep-113.00.00/experimental/example/with_typerep_pp/recursives.ml000066400000000000000000000034511256342456100256150ustar00rootroot00000000000000open Core.Std let _ = _squelch_unused_module_warning_ open Typerep_experimental.Std module M1 = struct type 'a tree = | Leaf of 'a | Tree of 'a * 'a tree * 'a tree module Typename_of_tree = Make_typename.Make1(struct type 'a t = 'a tree let name = "Recursives.M1.t" end) let rec typerep_of_tree : 'a. 'a Typerep.t -> 'a tree Typerep.t = fun (type a) (of_a:a Typerep.t) -> let name_of_tree = Typename_of_tree.named of_a in Typerep.Named (name_of_tree, Some (lazy ( let tag0 = Typerep.Tag.internal_use_only { Typerep.Tag_internal. label = "Leaf"; rep = of_a; arity = 1; index = 0; ocaml_repr = 0; tyid = Typename.create (); create = Typerep.Tag_internal.Args (fun x -> Leaf x); } in let tag1 = Typerep.Tag.internal_use_only { Typerep.Tag_internal. label = "Tree"; rep = ( let v1 = of_a and v2 = typerep_of_tree of_a and v3 = typerep_of_tree of_a in typerep_of_tuple3 v1 v2 v3 ); arity = 3; index = 1; ocaml_repr = 1; tyid = Typename.create (); create = Typerep.Tag_internal.Args (fun (v1, v2, v3) -> Tree (v1, v2, v3)); } in let typename = Typerep.Named.typename_of_t name_of_tree in let polymorphic = false in let tags = [| Typerep.Variant_internal.Tag tag0; Typerep.Variant_internal.Tag tag1; |] in let value = function | Leaf x -> Typerep.Variant_internal.Value (tag0, x) | Tree (v1, v2, v3) -> Typerep.Variant_internal.Value (tag1, (v1, v2, v3)) in Typerep.Variant (Typerep.Variant.internal_use_only { Typerep.Variant_internal. typename; tags; polymorphic; value; }) ))) end typerep-113.00.00/experimental/example/with_typerep_pp/test.ml000066400000000000000000000714461256342456100244130ustar00rootroot00000000000000open Core.Std open Typerep_experimental.Std let hash_variant = Typerep_obj.hash_variant let print_rep name typerep = let sexp = Type_struct.sexp_of_typerep typerep in print_endline ("struct representation of "^name); print_endline (Sexp.to_string_hum sexp) (* manual examples *) let f () = print_rep "Records.M1.t" Records.M1.typerep_of_t; print_rep "Records.M2.t" Records.M2.typerep_of_t; print_rep "Records.M3.t" Records.M3.typerep_of_t; print_rep "Variants.M1.t" Variants.M1.typerep_of_t; print_rep "Variants.M2.t" Variants.M2.typerep_of_t; print_rep "Variants.M3.t" Variants.M3.typerep_of_t; print_rep "Tuples.M1.t" Tuples.M1.typerep_of_t; print_rep "Tuples.M2.t" Tuples.M2.typerep_of_t; print_rep "Tuples.M3.t" Tuples.M3.typerep_of_t; print_rep "Combination.t" Combination.typerep_of_t; print_rep "int Variants.P1.t" (Variants.P1.typerep_of_t typerep_of_int); print_rep "int Records.P1.t" (Records.P1.typerep_of_t typerep_of_int); print_rep "int Recursives.M1.t" (Recursives.M1.typerep_of_tree typerep_of_int); ;; let () = if Array.length Sys.argv > 1 && Sys.argv.(1) = "--print-rep" then f () let print_typestruct str = let sexp = Type_struct.sexp_of_t str in print_endline (Sexp.to_string_hum sexp) module S = Type_struct module V = S.Variant.Kind let vr index name array = let array = Farray.of_array array ~f:(fun _ x -> x) in { S.Variant. label=name ; ocaml_repr = hash_variant name ; index }, array let vu index ocaml_repr name array = let array = Farray.of_array array ~f:(fun _ x -> x) in { S.Variant. label=name ; index ; ocaml_repr }, array let fields t = Farray.of_array t ~f:(fun index (label, value) -> let field = { S.Field.index ; label } in field, value) let tags t = Farray.of_array t ~f:(fun _ x -> x) let stuple array = S.Tuple (Farray.of_array array ~f:(fun _ x -> x)) let simple_array = { S.Record_infos.has_double_array_tag = false } let double_array = { S.Record_infos.has_double_array_tag = true } let polymorphic = { S.Variant_infos.kind = V.Polymorphic } let usual = { S.Variant_infos.kind = V.Usual } (* General tests about code generation + structure building *) TEST_MODULE = struct let base_check name expected typestruct = (* polymorphic equality is ok for Type_struct.t *) if Type_struct.are_equivalent typestruct expected then true else begin print_endline ("testing "^name); print_endline "expected:"; print_typestruct expected; print_endline "built:"; print_typestruct typestruct; false end let check expected typerep = let result = ref true in let typestruct = Type_struct.of_typerep typerep in result := base_check "typestruct" expected typestruct && !result; let Typerep.T typerep_of_t = Type_struct.to_typerep typestruct in let typestruct2 : Type_struct.t = Type_struct.of_typerep typerep_of_t in result := base_check "typerep" expected typestruct2 && !result; let check_version vn = let versioned = try Some (Type_struct.Versioned.serialize ~version:vn typestruct) with | Type_struct.Versioned.Not_downgradable _ -> None in match versioned with | Some versioned -> let typestruct_of_t = Type_struct.Versioned.unserialize versioned in let name = Sexp.to_string (Type_struct.Versioned.Version.sexp_of_t vn) in result := base_check name expected typestruct_of_t && !result; | None -> () in List.iter ~f:check_version Type_struct.Versioned.Version.([ v1; v2; v3; v4; ]); !result (* simple cases *) TEST_UNIT = let module M : sig type t with typerep end = struct type t = int with typerep end in let exp = S.Int in assert (check exp M.typerep_of_t); assert (check exp <:typerep_of< int >>); ;; TEST_UNIT = let module M : sig type t with typerep end = struct type t = int32 with typerep end in let exp = S.Int32 in assert (check exp M.typerep_of_t); assert (check exp <:typerep_of< int32 >>); ;; TEST_UNIT = let module M : sig type t with typerep end = struct type t = int64 with typerep end in let exp = S.Int64 in assert (check exp M.typerep_of_t); assert (check exp <:typerep_of< int64 >>); ;; TEST_UNIT = let module M : sig type t with typerep end = struct type t = char with typerep end in let exp = S.Char in assert (check exp M.typerep_of_t); assert (check exp <:typerep_of< char >>); ;; TEST_UNIT = let module M : sig type t with typerep end = struct type t = float with typerep end in let exp = S.Float in assert (check exp M.typerep_of_t); assert (check exp <:typerep_of< float >>); ;; TEST_UNIT = let module M : sig type t with typerep end = struct type t = string with typerep end in let exp = S.String in assert (check exp M.typerep_of_t); assert (check exp <:typerep_of< string >>); ;; TEST_UNIT = let module M : sig type t with typerep end = struct type t = bool with typerep end in let exp = S.Bool in assert (check exp M.typerep_of_t); assert (check exp <:typerep_of< bool >>); ;; TEST_UNIT = let module M : sig type t with typerep end = struct type t = unit with typerep end in let exp = S.Unit in assert (check exp M.typerep_of_t); assert (check exp <:typerep_of< unit >>); ;; TEST_UNIT = let module M : sig type t with typerep end = struct type t = bool option with typerep end in let exp = S.Option S.Bool in assert (check exp M.typerep_of_t); assert (check exp <:typerep_of< bool option >>); ;; TEST_UNIT = let module M : sig type t with typerep end = struct type t = float option with typerep end in let exp = S.Option S.Float in assert (check exp M.typerep_of_t); assert (check exp <:typerep_of< float option >>); ;; TEST_UNIT = let module M : sig type t with typerep end = struct type t = bool list with typerep end in let exp = S.List S.Bool in assert (check exp M.typerep_of_t); assert (check exp <:typerep_of< bool list >>); ;; TEST_UNIT = let module M : sig type t with typerep end = struct type t = float list with typerep end in let exp = S.List S.Float in assert (check exp M.typerep_of_t); assert (check exp <:typerep_of< float list >>); ;; TEST_UNIT = let module M : sig type t with typerep end = struct type t = bool array with typerep end in let exp = S.Array S.Bool in assert (check exp M.typerep_of_t); assert (check exp <:typerep_of< bool array >>); ;; TEST_UNIT = let module M : sig type t with typerep end = struct type t = float array with typerep end in let exp = S.Array S.Float in assert (check exp M.typerep_of_t); assert (check exp <:typerep_of< float array >>); ;; TEST_UNIT = let module M : sig type t with typerep end = struct type t = bool lazy_t with typerep end in let exp = S.Lazy S.Bool in assert (check exp M.typerep_of_t); assert (check exp <:typerep_of< bool lazy_t >>); ;; TEST_UNIT = let module M : sig type t with typerep end = struct type t = float lazy_t with typerep end in let exp = S.Lazy S.Float in assert (check exp M.typerep_of_t); assert (check exp <:typerep_of< float lazy_t >>); ;; TEST_UNIT = let module M : sig type t with typerep end = struct type t = bool ref with typerep end in let exp = S.Ref S.Bool in assert (check exp M.typerep_of_t); assert (check exp <:typerep_of< bool ref >>); ;; TEST_UNIT = let module M : sig type t with typerep end = struct type t = float ref with typerep end in let exp = S.Ref S.Float in assert (check exp M.typerep_of_t); assert (check exp <:typerep_of< float ref >>); ;; TEST_UNIT = let module M : sig type t with typerep end = struct type t = float * string with typerep end in let exp = S.Tuple (Farray.of_list [ S.Float ; S.String ]) in assert (check exp M.typerep_of_t); assert (check exp <:typerep_of< float * string >>); ;; TEST_UNIT = let module M : sig type t with typerep end = struct type t = float * string * bool with typerep end in let exp = S.Tuple (Farray.of_list [ S.Float ; S.String ; S.Bool ]) in assert (check exp M.typerep_of_t); assert (check exp <:typerep_of< float * string * bool >>); ;; TEST_UNIT = let module M : sig type t with typerep end = struct type t = float * string * bool * unit with typerep end in let exp = S.Tuple (Farray.of_list [ S.Float ; S.String ; S.Bool ; S.Unit ]) in assert (check exp M.typerep_of_t); assert (check exp <:typerep_of< float * string * bool * unit >>); ;; TEST_UNIT = let module M : sig type t with typerep end = struct type t = float * string * bool * unit * int with typerep end in let exp = S.Tuple (Farray.of_list [ S.Float ; S.String ; S.Bool ; S.Unit ; S.Int ]) in assert (check exp M.typerep_of_t); assert (check exp <:typerep_of< float * string * bool * unit * int >>); ;; (* nested with previous types *) TEST_UNIT = let module A : sig type t with typerep end = struct type t = bool with typerep end in let module M : sig type t with typerep end = struct type t = A.t option with typerep end in let exp = S.Option S.Bool in assert (check exp M.typerep_of_t); assert (check exp <:typerep_of< A.t option >>); ;; TEST_UNIT = let module A : sig type t with typerep end = struct type t = bool with typerep end in let module M : sig type t with typerep end = struct type t = A.t list with typerep end in let exp = S.List S.Bool in assert (check exp M.typerep_of_t); assert (check exp <:typerep_of< M.t >>); ;; (* records *) TEST_UNIT = let module M : sig type t with typerep module A : sig type nonrec t = t with typerep end end = struct module T = struct type t = { float : float; string : string; bool : bool; unit : unit; int : int; } with typerep end module A = struct type t = T.t = { float : float; string : string; bool : bool; unit : unit; int : int; } with typerep end include T end in let exp = S.Record (simple_array, fields [| "float", S.Float; "string", S.String; "bool", S.Bool; "unit", S.Unit; "int", S.Int; |]) in assert (check exp M.typerep_of_t); assert (check exp <:typerep_of< M.t >>); assert (check exp M.A.typerep_of_t); assert (check exp <:typerep_of< M.A.t >>); ;; TEST_UNIT = let module M : sig type t with typerep end = struct type t = { f1 : float; f2 : float; } with typerep end in let exp = S.Record (double_array, fields [| "f1", S.Float; "f2", S.Float; |]) in assert (check exp M.typerep_of_t); assert (check exp <:typerep_of< M.t >>); ;; TEST_UNIT = let module M : sig type t with typerep end = struct type 'a poly = { f1 : float; f2 : 'a; } with typerep type t = float poly with typerep end in let exp = S.Record (simple_array, fields [| "f1", S.Float; "f2", S.Float; |]) in assert (check exp M.typerep_of_t); assert (check exp <:typerep_of< M.t >>); ;; (* variants arity 1 *) TEST_UNIT = let module M : sig type t with typerep end = struct type t = [ | `float of float | `string of string | `bool of bool | `unit of unit | `int of int ] with typerep end in let exp = S.Variant (polymorphic, tags [| vr 0 "float" [| S.Float |]; vr 1 "string" [| S.String |]; vr 2 "bool" [| S.Bool |]; vr 3 "unit" [| S.Unit |]; vr 4 "int" [| S.Int |]; |]) in assert (check exp M.typerep_of_t); assert (check exp <:typerep_of< M.t >>); ;; (* variants arity n *) TEST_UNIT = let module M : sig type t with typerep end = struct type t = [ | `zero | `one of unit | `two of bool * bool | `three of unit * unit * unit | `five of unit * unit * unit * unit * unit ] with typerep end in let exp = S.Variant (polymorphic, tags [| vr 0 "zero" [||]; vr 1 "one" [| S.Unit |]; vr 2 "two" [| S.Tuple (Farray.of_list [ S.Bool ; S.Bool ]) |]; vr 3 "three" [| S.Tuple (Farray.of_list [ S.Unit ; S.Unit ; S.Unit ]) |]; vr 4 "five" [| S.Tuple (Farray.init 5 ~f:(fun _ -> S.Unit)) |]; |]) in assert (check exp M.typerep_of_t); assert (check exp <:typerep_of< M.t >>); ;; (* sum arity 1 *) TEST_UNIT = let module M : sig type t with typerep end = struct type t = | Float of float | String of string | Bool of bool | Unit of unit | Int of int with typerep end in let exp = S.Variant (usual, tags [| vu 0 0 "Float" [| S.Float |]; vu 1 1 "String" [| S.String |]; vu 2 2 "Bool" [| S.Bool |]; vu 3 3 "Unit" [| S.Unit |]; vu 4 4 "Int" [| S.Int |]; |]) in assert (check exp M.typerep_of_t); assert (check exp <:typerep_of< M.t >>); ;; (* sum arity n *) TEST_UNIT = let module M : sig type t with typerep end = struct type t = | Zero | One of unit | Two of bool * bool | Two_tuple of (bool * bool) | Three of unit * unit * unit | Three_tuple of (unit * unit * unit) | Five of unit * unit * unit * unit * unit | Five_tuple of (unit * unit * unit * unit * unit) with typerep end in let exp = S.Variant (usual, tags [| vu 0 0 "Zero" [||]; vu 1 0 "One" [| S.Unit |]; vu 2 1 "Two" [| S.Bool ; S.Bool |]; vu 3 2 "Two_tuple" [| S.Tuple (Farray.of_list [ S.Bool ; S.Bool ]) |]; vu 4 3 "Three" [| S.Unit ; S.Unit ; S.Unit |]; vu 5 4 "Three_tuple" [| S.Tuple (Farray.of_list [ S.Unit ; S.Unit ; S.Unit ]) |]; vu 6 5 "Five" (Array.init 5 ~f:(fun _ -> S.Unit)); vu 7 6 "Five_tuple" [| S.Tuple (Farray.init 5 ~f:(fun _ -> S.Unit)) |]; |]) in assert (check exp M.typerep_of_t); assert (check exp <:typerep_of< M.t >>); ;; (* polymorphism *) (* records *) TEST_UNIT = let module A : sig type 'a t with typerep end = struct type 'a t = 'a * int with typerep end in let module M : sig type ('a, 'b, 'c) t with typerep end = struct type ('a, 'b, 'c) t = { a : 'a * 'a * 'a ; b : 'b; c : 'c; int : int; t_A : 'c A.t; } with typerep end in let module M1 : sig type t = (float, int A.t, int A.t A.t) M.t with typerep end = struct type t = (float, int A.t, int A.t A.t) M.t with typerep end in let exp = S.Record (simple_array, fields [| "a", S.Tuple (Farray.of_list [ S.Float; S.Float ; S.Float ]); "b", S.Tuple (Farray.of_list [ S.Int ; S.Int ]); "c", S.Tuple (Farray.of_list [ S.Tuple (Farray.of_list [ S.Int ; S.Int ]) ; S.Int ]); "int", S.Int; "t_A", S.Tuple (Farray.of_list [ S.Tuple (Farray.of_list [ S.Tuple (Farray.of_list [ S.Int ; S.Int ]) ; S.Int ]); S.Int ]); |]) in assert (check exp M1.typerep_of_t); assert (check exp <:typerep_of< (float, int A.t, int A.t A.t) M.t >>); ;; (* variants *) TEST_UNIT = let module A : sig type 'a t with typerep end = struct type 'a t = [ | `a of 'a | `int of int * string ] with typerep end in let module M : sig type ('a, 'b, 'c) t with typerep end = struct type ('a, 'b, 'c) t = [ | `a of 'a * 'a * 'a | `b of 'b | `c of 'c | `int of int | `t_A of 'a A.t | `no_arg ] with typerep end in let module M1 : sig type t = (float, int A.t, int A.t A.t) M.t with typerep end = struct type t = (float, int A.t, int A.t A.t) M.t with typerep end in let exp = S.Variant (polymorphic, tags [| vr 0 "a" [| stuple [| S.Float; S.Float ; S.Float |] |]; vr 1 "b" [| S.Variant (polymorphic, tags [| vr 0 "a" [| S.Int |] ; vr 1 "int" [| stuple [| S.Int ; S.String |] |] |]) |]; vr 2 "c" [| S.Variant (polymorphic, tags [| vr 0 "a" [| S.Variant (polymorphic, tags [| vr 0 "a" [| S.Int |] ; vr 1 "int" [| stuple [| S.Int ; S.String |] |] |]) |]; vr 1 "int" [| stuple [| S.Int ; S.String |] |] |]) |]; vr 3 "int" [| S.Int |]; vr 4 "t_A" [| S.Variant (polymorphic, tags [| vr 0 "a" [| S.Float |] ; vr 1 "int" [| stuple [| S.Int ; S.String |] |] |]) |]; vr 5 "no_arg" [||]; |]) in assert (check exp M1.typerep_of_t); assert (check exp <:typerep_of< (float, int A.t, int A.t A.t) M.t >>); ;; (* sums *) TEST_UNIT = let module A : sig type 'a t with typerep end = struct type 'a t = | A of 'a | Int of int * string with typerep end in let module M : sig type ('a, 'b, 'c) t with typerep end = struct type ('a, 'b, 'c) t = | A of ('a * 'a * 'a) | B of 'b | C of 'c | Int of int | T_A of 'a A.t | No_arg with typerep end in let module M1 : sig type t = (float, int A.t, int A.t A.t) M.t with typerep end = struct type t = (float, int A.t, int A.t A.t) M.t with typerep end in let exp = S.Variant (usual, tags [| vu 0 0 "A" [| stuple [| S.Float; S.Float ; S.Float |] |]; vu 1 1 "B" [| S.Variant (usual, tags [| vu 0 0 "A" [| S.Int |] ; vu 1 1 "Int" [| S.Int ; S.String |] |]) |]; vu 2 2 "C" [| S.Variant (usual, tags [| vu 0 0 "A" [| S.Variant (usual, tags [| vu 0 0 "A" [| S.Int |] ; vu 1 1 "Int" [| S.Int ; S.String |] |]) |]; vu 1 1 "Int" [| S.Int ; S.String |] |]) |]; vu 3 3 "Int" [| S.Int |]; vu 4 4 "T_A" [| S.Variant (usual, tags [| vu 0 0 "A" [| S.Float |] ; vu 1 1 "Int" [| S.Int ; S.String |] |]) |]; vu 5 0 "No_arg" [||]; |]) in assert (check exp M1.typerep_of_t); assert (check exp <:typerep_of< (float, int A.t, int A.t A.t) M.t >>); ;; (* phantom and mutability *) TEST_UNIT = let module A = struct type ('a,'b) t = { mutable foo: 'a } with typerep end in let module M = struct type t = (unit, int) A.t with typerep end in let exp = S.Record (simple_array, fields [| "foo", S.Unit; |]) in assert (check exp M.typerep_of_t); assert (check exp <:typerep_of< (unit, int) A.t >>); ;; (* sort of a real case *) TEST_UNIT = let module Transaction_type = struct module V1 = struct type t = | Trade | Order with typerep end module V2 = struct module Account : sig type t = private string with typerep end = struct type t = string with typerep end type t = | Trade | Order | Journal of Account.t * Account.t with typerep end end in let tt_v1 = S.Variant (usual, tags [| vu 0 0 "Trade" [||]; vu 1 1 "Order" [||]; |]) in assert (check tt_v1 Transaction_type.V1.typerep_of_t); let tt_v2 = S.Variant (usual, tags [| vu 0 0 "Trade" [||]; vu 1 1 "Order" [||]; vu 2 0 "Journal" [| S.String ; S.String |]; |]) in assert (check tt_v2 Transaction_type.V2.typerep_of_t); let module V1 = struct type t = { transaction_type : Transaction_type.V1.t; username : string; } with typerep end in let module V2 = struct type t = { transaction_type : Transaction_type.V2.t; username : string; tags : (string * string) list; } with typerep end in let module M_v1 = struct type t = | V1 of V1.t with typerep end in let module M_v2 = struct type t = | V1 of V1.t | V2 of V2.t with typerep end in let v1 = S.Record (simple_array, fields [| "transaction_type", tt_v1; "username", S.String ; |]) in let v2 = S.Record (simple_array, fields [| "transaction_type", tt_v2; "username", S.String ; "tags", S.List (stuple [| S.String ; S.String |]); |]) in let exp_v1 = S.Variant (usual, tags [| vu 0 0 "V1" [| v1 |] |]) in let exp_v2 = S.Variant (usual, tags [| vu 0 0 "V1" [| v1 |] ; vu 1 1 "V2" [| v2 |] ; |]) in assert (check exp_v1 M_v1.typerep_of_t); assert (check exp_v2 M_v2.typerep_of_t); (* recursive types *) (* sum *) TEST_UNIT = let module M = struct type t = | Zero | Succ of t with typerep end in let exp = S.Named (0, Some (S.Variant (usual, tags [| vu 0 0 "Zero" [||]; vu 1 0 "Succ" [| S.Named (0, None) |]; |]))) in let cyclic = S.Named (42, Some (S.Variant (usual, tags [| vu 0 0 "Zero" [||]; vu 1 0 "Succ" [| S.Named (42, None) |]; |]))) in assert (check cyclic M.typerep_of_t); assert (S.are_equivalent exp cyclic); assert (check exp M.typerep_of_t); ;; TEST_UNIT = let module M = struct type t = | Leaf | Node of t * t with typerep end in let exp = S.Named (0, Some (S.Variant (usual, tags [| vu 0 0 "Leaf" [||]; vu 1 0 "Node" [| S.Named (0, None) ; S.Named (0, None) |]; |]))) in assert (check exp M.typerep_of_t); ;; (* polymorphic *) TEST_UNIT = let module M = struct type t = [ | `Zero | `Succ of t ] with typerep end in let exp = S.Named (0, Some (S.Variant (polymorphic, tags [| vr 0 "Zero" [||]; vr 1 "Succ" [| S.Named (0, None) |]; |]))) in let cyclic = S.Named (42, Some (S.Variant (polymorphic, tags [| vr 0 "Zero" [||]; vr 1 "Succ" [| S.Named (42, None) |]; |]))) in assert (check cyclic M.typerep_of_t); assert (S.are_equivalent exp cyclic); assert (check exp M.typerep_of_t); ;; (* record *) TEST_UNIT = let module M = struct type t = { int : int; self : t; } with typerep end in let exp = S.Named (0, Some (S.Record (simple_array, fields [| "int", S.Int; "self", S.Named (0, None); |]))) in let cyclic = S.Named (0, Some (S.Record (simple_array, Farray.of_list [ { S.Field.label="int";index=0}, S.Int; { S.Field.label="self";index=1}, S.Named (0, None); ]))) in let exp2 = S.Record (simple_array, fields [| "int", S.Int; "self", S.Named (0, Some ( S.Record (simple_array, fields [| "int", S.Int; "self", S.Named (0, Some ( S.Record (simple_array, fields [| "int", S.Int; "self", S.Named (0, None); |]) ))|]))); |]) in assert (check exp M.typerep_of_t); assert (check cyclic M.typerep_of_t); assert (check exp2 M.typerep_of_t); ;; (* with parameters *) (* sum *) TEST_UNIT = let module M = struct type 'a tree = | Leaf of 'a | Tree of 'a * 'a tree * 'a tree with typerep end in let exp arg = S.Named (0, Some (S.Variant (usual, tags [| vu 0 0 "Leaf" [| arg |]; vu 1 1 "Tree" [| arg ; S.Named (0, None) ; S.Named (0, None) |]; |]))) in assert (check (exp S.Int) (M.typerep_of_tree typerep_of_int)); assert (check (exp S.Float) (M.typerep_of_tree typerep_of_float)); ;; TEST_UNIT = let module T = struct type ('a, 'b) t = | Empty | Node of ('b, 'a) t | A of 'a | B of 'b with typerep end in let module M = struct type t = (int, string) T.t with typerep end in let exp = S.Named (0, Some (S.Variant (usual, tags [| vu 0 0 "Empty" [||]; vu 1 0 "Node" [| S.Variant (usual, tags [| vu 0 0 "Empty" [||]; vu 1 0 "Node" [| S.Named (0, None) |]; vu 2 1 "A" [| S.String |]; vu 3 2 "B" [| S.Int |]; |])|]; vu 2 1 "A" [| S.Int |]; vu 3 2 "B" [| S.String |]; |]))) in assert (check exp M.typerep_of_t); ;; (* inlining not named polymorphic variant types *) TEST_UNIT = let module A = struct type t = A of [ `A ] with typerep let exp = S.Variant (usual, tags [| vu 0 0 "A" [| S.Variant (polymorphic, tags [| vr 0 "A" [||]; |]); |]; |]) end in assert (check A.exp A.typerep_of_t); ;; TEST_UNIT = let module A = struct type 'a t = [ `A of 'a | `B ] with typerep let exp arg = S.Variant (polymorphic, tags [| vr 0 "A" [| arg |]; vr 1 "B" [||]; |]) let param = S.Variant (polymorphic, tags [| vr 0 "A" [||]; |]) end in let module B = struct type ('a, 't, 'b) t = [ `A of 'a * 't | `B of 'b ] with typerep let exp a t b = S.Variant (polymorphic, tags [| vr 0 "A" [| S.Tuple (Farray.of_list [ a ; t ]) |]; vr 1 "B" [| b |]; |]) end in let module M = struct type 'a t = | Leaf of [ `A of 'a * 'a t | `B of [ `A of 'a | `B ] ] | Tree of 'a * 'a t * 'a t with typerep let exp arg = S.Named (0, Some (S.Variant (usual, tags [| vu 0 0 "Leaf" [| B.exp arg (S.Named (0, None)) (A.exp arg) |]; vu 1 1 "Tree" [| arg ; S.Named (0, None) ; S.Named (0, None) |]; |]))) end in assert (check (A.exp A.param) <:typerep_of< [ `A ] A.t >>); assert (check (A.exp S.Int) (A.typerep_of_t typerep_of_int)); assert (check (A.exp S.Int) <:typerep_of< [ `A of int | `B ] >>); assert (check (A.exp S.String) (A.typerep_of_t typerep_of_string)); assert (check (A.exp S.String) <:typerep_of< [ `A of string | `B ] >>); assert (check (B.exp S.Int S.String S.Float) (B.typerep_of_t typerep_of_int typerep_of_string typerep_of_float)); assert (check (B.exp S.String S.Float S.Int) (B.typerep_of_t typerep_of_string typerep_of_float typerep_of_int)); assert (check (M.exp S.Int) (M.typerep_of_t typerep_of_int)); assert (check (M.exp S.String) (M.typerep_of_t typerep_of_string)); ;; TEST_UNIT = let module A = struct type t = True of int | False with typerep end in (* the preprocessor for polymorphic variants should do the right thing, but camlp4 doesn't so the generated code doesn't even type (the type definition is that caml receives contains the constructor ` True (ie " True")) let module B = struct type t = [ `True | `False of int ] let _ = (`True : t) end in *) assert (check (S.Variant (usual, tags [| vu 1 0 "True" [| S.Int |]; vu 0 0 "False" [| |]; |])) A.typerep_of_t) end (* breaking the abstraction ? *) TEST_MODULE = struct module A : sig type 'a t include Typerepable.S1 with type 'a t := 'a t val create : 'a -> 'a t end = struct type 'a t = 'a option with typerep let create a = Some a end module B : sig type 'a t include Typerepable.S1 with type 'a t := 'a t val read : 'a t -> 'a end = struct type 'a t = 'a option with typerep let read = function | Some a -> a | None -> assert false end TEST_UNIT = let module M = struct type a = int A.t with typerep type b = int B.t with typerep end in let break (a : M.a) : int option = match Typename.same_witness (Typerep.typename_of_t M.typerep_of_a) (Typerep.typename_of_t M.typerep_of_b) with | Some proof -> let b = Type_equal.conv proof a in Some (B.read b) | None -> None in let a = A.create 42 in assert (break a = None) TEST_UNIT = let module M = struct type t = | Foo1 of int | Foo2 of int | Foo3 of int with typerep let get_int = match Typerep.head typerep_of_t with | Typerep.Variant variant -> (fun t -> let Typerep.Variant.Value (tag, arg) = Typerep.Variant.value variant t in let witness = Typerep.same_witness_exn (Typerep.Tag.traverse tag) typerep_of_int in Type_equal.conv witness arg ) | _ -> assert false end in assert (M.get_int (M.Foo1 1) = 1); assert (M.get_int (M.Foo2 2) = 2); end typerep-113.00.00/experimental/example/with_typerep_pp/tuples.ml000066400000000000000000000007421256342456100247370ustar00rootroot00000000000000open Core.Std let _ = _squelch_unused_module_warning_ open Typerep_experimental.Std module M1 = struct type t = int * string let typerep_of_t = typerep_of_tuple2 typerep_of_int typerep_of_string end module M2 = struct type t = int * string * float let typerep_of_t = typerep_of_tuple3 typerep_of_int typerep_of_string typerep_of_float end module M3 = struct type t = M1.t * M2.t let typerep_of_t = typerep_of_tuple2 M1.typerep_of_t M2.typerep_of_t end typerep-113.00.00/experimental/example/with_typerep_pp/tuples.mli000066400000000000000000000004351256342456100251070ustar00rootroot00000000000000open Core.Std open Typerep_experimental.Std module M1 : sig type t = int * string val typerep_of_t : t Typerep.t end module M2 : sig type t = int * string * float val typerep_of_t : t Typerep.t end module M3 : sig type t = M1.t * M2.t val typerep_of_t : t Typerep.t end typerep-113.00.00/experimental/example/with_typerep_pp/variants.ml000066400000000000000000000174171256342456100252610ustar00rootroot00000000000000open Core.Std let _ = _squelch_unused_module_warning_ open Typerep_experimental.Std module M1 = struct type t = | A of int | B of float module Typename_of_t = Make_typename.Make0(struct type non_rec = t type t = non_rec let name = "Variants.M1.t" end) let typerep_of_t : t Typerep.t = let name_of_t = Typename_of_t.named in Typerep.Named (name_of_t, Some (lazy ( let tag0 = Typerep.Tag.internal_use_only { Typerep.Tag_internal. label = "A"; rep = typerep_of_int; arity = 1; index = 0; ocaml_repr = 0; tyid = Typename.create (); create = Typerep.Tag_internal.Args (fun x -> A x); } in let tag1 = Typerep.Tag.internal_use_only { Typerep.Tag_internal. label = "B"; rep = typerep_of_float; arity = 1; index = 1; ocaml_repr = 1; tyid = Typename.create (); create = Typerep.Tag_internal.Args (fun x -> B x) } in let typename = Typerep.Named.typename_of_t name_of_t in let polymorphic = false in let tags = [| Typerep.Variant_internal.Tag tag0; Typerep.Variant_internal.Tag tag1; |] in let value = function | A x -> Typerep.Variant_internal.Value (tag0, x) | B x -> Typerep.Variant_internal.Value (tag1, x) in Typerep.Variant (Typerep.Variant.internal_use_only { Typerep.Variant_internal. typename; tags; polymorphic; value; }) ))) end module M2 = struct type t = [ | `A of int | `B of float ] module Typename_of_t = Make_typename.Make0(struct type non_rec = t type t = non_rec let name = "Variants.M2.t" end) let typerep_of_t : t Typerep.t = let name_of_t = Typename_of_t.named in Typerep.Named (name_of_t, Some (lazy ( let tag0 = Typerep.Tag.internal_use_only { Typerep.Tag_internal. label = "A"; rep = typerep_of_int; arity = 1; index = 0; ocaml_repr = Typerep_obj.repr_of_poly_variant `A; tyid = Typename.create (); create = Typerep.Tag_internal.Args (fun x -> `A x); } in let tag1 = Typerep.Tag.internal_use_only { Typerep.Tag_internal. label = "B"; rep = typerep_of_float; arity = 1; index = 1; ocaml_repr = Typerep_obj.repr_of_poly_variant `B; tyid = Typename.create (); create = Typerep.Tag_internal.Args (fun x -> `B x) } in let typename = Typerep.Named.typename_of_t name_of_t in let polymorphic = true in let tags = [| Typerep.Variant_internal.Tag tag0; Typerep.Variant_internal.Tag tag1; |] in let value = function | `A x -> Typerep.Variant_internal.Value (tag0, x) | `B x -> Typerep.Variant_internal.Value (tag1, x) in Typerep.Variant (Typerep.Variant.internal_use_only { Typerep.Variant_internal. typename; tags; polymorphic; value; }) ))) end module M3 = struct type t = | M1 of M1.t | M2 of M2.t module Typename_of_t = Make_typename.Make0(struct type non_rec = t type t = non_rec let name = "Variants.M3.t" end) let typerep_of_t : t Typerep.t = let name_of_t = Typename_of_t.named in Typerep.Named (name_of_t, Some (lazy ( let tag0 = Typerep.Tag.internal_use_only { Typerep.Tag_internal. label = "M1"; rep = M1.typerep_of_t; arity = 1; index = 0; ocaml_repr = 0; tyid = Typename.create (); create = Typerep.Tag_internal.Args (fun x -> M1 x); } in let tag1 = Typerep.Tag.internal_use_only { Typerep.Tag_internal. label = "M2"; rep = M2.typerep_of_t; arity = 1; index = 1; ocaml_repr = 1; tyid = Typename.create (); create = Typerep.Tag_internal.Args (fun x -> M2 x) } in let typename = Typerep.Named.typename_of_t name_of_t in let polymorphic = false in let tags = [| Typerep.Variant_internal.Tag tag0; Typerep.Variant_internal.Tag tag1; |] in let value = function | M1 x -> Typerep.Variant_internal.Value (tag0, x) | M2 x -> Typerep.Variant_internal.Value (tag1, x) in Typerep.Variant (Typerep.Variant.internal_use_only { Typerep.Variant_internal. typename; tags; polymorphic; value; }) ))) end module P1 = struct type 'a t = [ | `A of 'a | `B of float ] module Typename_of_t = Make_typename.Make1(struct type nonrec 'a t = 'a t let name = "Variants.P1.t" end) let typerep_of_t of_p1 = let name_of_t = Typename_of_t.named of_p1 in Typerep.Named (name_of_t, Some (lazy ( let tag0 = Typerep.Tag.internal_use_only { Typerep.Tag_internal. label = "A"; rep = of_p1; arity = 1; index = 0; ocaml_repr = Typerep_obj.repr_of_poly_variant `A; tyid = Typename.create (); create = Typerep.Tag_internal.Args (fun x -> `A x); } in let tag1 = Typerep.Tag.internal_use_only { Typerep.Tag_internal. label = "B"; rep = typerep_of_float; arity = 1; index = 1; ocaml_repr = Typerep_obj.repr_of_poly_variant `B; tyid = Typename.create (); create = Typerep.Tag_internal.Args (fun x -> `B x) } in let typename = Typerep.Named.typename_of_t name_of_t in let polymorphic = true in let tags = [| Typerep.Variant_internal.Tag tag0; Typerep.Variant_internal.Tag tag1; |] in let value = function | `A x -> Typerep.Variant_internal.Value (tag0, x) | `B x -> Typerep.Variant_internal.Value (tag1, x) in Typerep.Variant (Typerep.Variant.internal_use_only { Typerep.Variant_internal. typename; tags; polymorphic; value; }) ))) end module I1 = struct type t = A of [ `A ] module Typename_of_t = Make_typename.Make0 (struct type nonrec t = t let name = "test.ml.t" end) let typerep_of_t = let name_of_t = Typename_of_t.named in Typerep.Named (name_of_t, Some (lazy ( let tag0 = Typerep.Tag.internal_use_only { Typerep.Tag_internal. label = "A"; rep = (let tag0 = Typerep.Tag.internal_use_only { Typerep.Tag_internal. label = "A"; rep = typerep_of_tuple0; arity = 0; index = 0; ocaml_repr = Typerep_obj.repr_of_poly_variant `A; tyid = typename_of_tuple0; create = Typerep.Tag_internal.Const `A; } in let typename = Typename.create () in let tags = [| Typerep.Variant_internal.Tag tag0 |] in let polymorphic = true in let value = function | `A -> Typerep.Variant_internal.Value (tag0, value_tuple0) in Typerep.Variant (Typerep.Variant.internal_use_only { Typerep.Variant_internal. typename; tags; polymorphic; value; })); arity = 1; index = 0; ocaml_repr = 0; tyid = Typename.create (); create = Typerep.Tag_internal.Args (fun v0 -> A v0); } in let typename = Typerep.Named.typename_of_t name_of_t in let tags = [| Typerep.Variant_internal.Tag tag0 |] in let polymorphic = false in let value = function | A v0 -> Typerep.Variant_internal.Value (tag0, v0) in Typerep.Variant (Typerep.Variant.internal_use_only { Typerep.Variant_internal. typename; tags; polymorphic; value; }) ))) end typerep-113.00.00/experimental/example/with_typerep_pp/variants.mli000066400000000000000000000010241256342456100254150ustar00rootroot00000000000000open Core.Std open Typerep_experimental.Std module M1 : sig type t = | A of int | B of float val typerep_of_t : t Typerep.t end module M2 : sig type t = [ | `A of int | `B of float ] val typerep_of_t : t Typerep.t end module M3 : sig type t = | M1 of M1.t | M2 of M2.t val typerep_of_t : t Typerep.t end module P1 : sig type 'a t = [ | `A of 'a | `B of float ] val typerep_of_t : 'a Typerep.t -> 'a t Typerep.t end module I1 : sig type t = A of [ `A ] val typerep_of_t : t Typerep.t end typerep-113.00.00/experimental/lib/000077500000000000000000000000001256342456100167575ustar00rootroot00000000000000typerep-113.00.00/experimental/lib/customrep.ml000066400000000000000000000112101256342456100213250ustar00rootroot00000000000000open Typerep_extended.Std open Typerep_sexp.Std open Typerep_bin_io.Std let register0 m = let module M = (val m : Customrep_intf.S0) in let typerep_of_t = M.typerep_of_t in let typename_of_t = M.typename_of_t in let module Sexp_of = struct type t = M.t let typerep_of_t = typerep_of_t let typename_of_t = typename_of_t let compute = M.sexp_of_t end in let module Of_sexp = struct type t = M.t let typerep_of_t = typerep_of_t let typename_of_t = typename_of_t let compute = M.t_of_sexp end in let module Sizer = struct type t = M.t let typerep_of_t = typerep_of_t let typename_of_t = typename_of_t let compute = M.bin_size_t end in let module Writer = struct type t = M.t let typerep_of_t = typerep_of_t let typename_of_t = typename_of_t let compute = M.bin_writer_t end in let module Reader = struct type t = M.t let typerep_of_t = typerep_of_t let typename_of_t = typename_of_t let compute = M.bin_reader_t end in let module Struct = struct type t = M.t let typerep_of_t = typerep_of_t let typename_of_t = typename_of_t let compute = M.typestruct_of_t end in Type_struct.Generic.register0 (module Struct : Type_struct.Generic.S0); Sexprep.Sexp_of.register0 (module Sexp_of : Sexprep.Sexp_of.S0); Sexprep.Of_sexp.register0 (module Of_sexp : Sexprep.Of_sexp.S0); Binrep.Sizer.register0 (module Sizer : Binrep.Sizer.S0); Binrep.Writer.register0 (module Writer : Binrep.Writer.S0); Binrep.Reader.register0 (module Reader : Binrep.Reader.S0); ;; let register1 m = let module M = (val m : Customrep_intf.S1) in let typerep_of_t = M.typerep_of_t in let typename_of_t = M.typename_of_t in let module Sexp_of = struct type 'a t = 'a M.t let typerep_of_t = typerep_of_t let typename_of_t = typename_of_t let compute = M.sexp_of_t end in let module Of_sexp = struct type 'a t = 'a M.t let typerep_of_t = typerep_of_t let typename_of_t = typename_of_t let compute = M.t_of_sexp end in let module Sizer = struct type 'a t = 'a M.t let typerep_of_t = typerep_of_t let typename_of_t = typename_of_t let compute = M.bin_size_t end in let module Writer = struct type 'a t = 'a M.t let typerep_of_t = typerep_of_t let typename_of_t = typename_of_t let compute = M.bin_writer_t end in let module Reader = struct type 'a t = 'a M.t let typerep_of_t = typerep_of_t let typename_of_t = typename_of_t let compute = M.bin_reader_t end in let module Struct = struct type 'a t = 'a M.t let typerep_of_t = typerep_of_t let typename_of_t = typename_of_t let compute = M.typestruct_of_t end in Type_struct.Generic.register1 (module Struct : Type_struct.Generic.S1); Sexprep.Sexp_of.register1 (module Sexp_of : Sexprep.Sexp_of.S1); Sexprep.Of_sexp.register1 (module Of_sexp : Sexprep.Of_sexp.S1); Binrep.Sizer.register1 (module Sizer : Binrep.Sizer.S1); Binrep.Writer.register1 (module Writer : Binrep.Writer.S1); Binrep.Reader.register1 (module Reader : Binrep.Reader.S1); ;; let register2 m = let module M = (val m : Customrep_intf.S2) in let typerep_of_t = M.typerep_of_t in let typename_of_t = M.typename_of_t in let module Sexp_of = struct type ('a, 'b) t = ('a, 'b) M.t let typerep_of_t = typerep_of_t let typename_of_t = typename_of_t let compute = M.sexp_of_t end in let module Of_sexp = struct type ('a, 'b) t = ('a, 'b) M.t let typerep_of_t = typerep_of_t let typename_of_t = typename_of_t let compute = M.t_of_sexp end in let module Sizer = struct type ('a, 'b) t = ('a, 'b) M.t let typerep_of_t = typerep_of_t let typename_of_t = typename_of_t let compute = M.bin_size_t end in let module Writer = struct type ('a, 'b) t = ('a, 'b) M.t let typerep_of_t = typerep_of_t let typename_of_t = typename_of_t let compute = M.bin_writer_t end in let module Reader = struct type ('a, 'b) t = ('a, 'b) M.t let typerep_of_t = typerep_of_t let typename_of_t = typename_of_t let compute = M.bin_reader_t end in let module Struct = struct type ('a, 'b) t = ('a, 'b) M.t let typerep_of_t = typerep_of_t let typename_of_t = typename_of_t let compute = M.typestruct_of_t end in Type_struct.Generic.register2 (module Struct : Type_struct.Generic.S2); Sexprep.Sexp_of.register2 (module Sexp_of : Sexprep.Sexp_of.S2); Sexprep.Of_sexp.register2 (module Of_sexp : Sexprep.Of_sexp.S2); Binrep.Sizer.register2 (module Sizer : Binrep.Sizer.S2); Binrep.Writer.register2 (module Writer : Binrep.Writer.S2); Binrep.Reader.register2 (module Reader : Binrep.Reader.S2); ;; typerep-113.00.00/experimental/lib/customrep.mli000066400000000000000000000005171256342456100215060ustar00rootroot00000000000000(* This module is there to enforce that we register at the same time a customization of serialization. This takes care of registering the implementation in the right tables. *) val register0 : (module Customrep_intf.S0) -> unit val register1 : (module Customrep_intf.S1) -> unit val register2 : (module Customrep_intf.S2) -> unit typerep-113.00.00/experimental/lib/customrep_intf.ml000066400000000000000000000013571256342456100223600ustar00rootroot00000000000000open! Core_kernel.Std open Typerep_extended.Std module type S0 = sig type t include Typerepable.S0 with type t := t include Sexpable.S with type t := t include Binable.S with type t := t include Typestructable.S0 with type t := t end module type S1 = sig type 'a t include Typerepable.S1 with type 'a t := 'a t include Sexpable.S1 with type 'a t := 'a t include Binable.S1 with type 'a t := 'a t include Typestructable.S1 with type 'a t := 'a t end module type S2 = sig type ('a, 'b) t include Typerepable.S2 with type ('a, 'b) t := ('a, 'b) t include Sexpable.S2 with type ('a, 'b) t := ('a, 'b) t include Binable.S2 with type ('a, 'b) t := ('a, 'b) t include Typestructable.S2 with type ('a, 'b) t := ('a, 'b) t end typerep-113.00.00/experimental/lib/std.ml000066400000000000000000000022101256342456100200760ustar00rootroot00000000000000include Typerep_extended.Std include Typerep_sexp.Std include Typerep_bin_io.Std (*module Customrep_intf = Customrep_intf module Customrep = Customrep*) (* Mega-Hack because of applicative name comparison in ocaml first class module *) module Lib_customrep_intf = Customrep_intf let s0_to_s0 (module M : Lib_customrep_intf.S0) = (module M : Customrep_intf.S0) let s1_to_s1 (module M : Lib_customrep_intf.S1) = (module M : Customrep_intf.S1) let s2_to_s2 (module M : Lib_customrep_intf.S2) = (module M : Customrep_intf.S2) module Customrep_intf = Customrep_intf module Customrep : sig val register0 : (module Customrep_intf.S0) -> unit val register1 : (module Customrep_intf.S1) -> unit val register2 : (module Customrep_intf.S2) -> unit end = struct include Customrep let register0 (module M : Customrep_intf.S0) = Customrep.register0 (s0_to_s0 (module M : Lib_customrep_intf.S0)) let register1 (module M : Customrep_intf.S1) = Customrep.register1 (s1_to_s1 (module M : Lib_customrep_intf.S1)) let register2 (module M : Customrep_intf.S2) = Customrep.register2 (s2_to_s2 (module M : Lib_customrep_intf.S2)) end (* end of Mega-Hack *) typerep-113.00.00/experimental/test/000077500000000000000000000000001256342456100171705ustar00rootroot00000000000000typerep-113.00.00/experimental/test/test_diff.ml000066400000000000000000000071441256342456100214770ustar00rootroot00000000000000open Core.Std open Typerep_experimental.Std let print_str str = let sexp = Type_struct.sexp_of_t str in print_endline (Sexp.to_string_hum sexp) module S = Type_struct (* Tests about Type_struct diffing *) TEST_MODULE = struct let check exp rep1 rep2 = let s1 = S.of_typerep rep1 in let s2 = S.of_typerep rep2 in let diff = S.Diff.compute s1 s2 in let diff = S.Diff.sexp_of_t diff in let exp = try Sexp.of_string exp with _ -> Sexp.Atom exp in if diff = exp then true else begin print_endline "s1:"; print_str s1; print_endline "s2:"; print_str s2; print_endline "expected diff"; print_endline (Sexp.to_string_hum exp); print_endline "computed diff"; print_endline (Sexp.to_string_hum diff); false end TEST_UNIT = let module A = struct type t = int with typerep end in let module B = struct type t = float with typerep end in let exp = "((() (Update Int Float)))" in assert (check exp A.typerep_of_t B.typerep_of_t) TEST_UNIT = let module A = struct type t = { a : int; } with typerep end in let module B = struct type t = { a : int; b : float; } with typerep end in let exp = "((() (Add_field (((label b) (index 1)) Float))))" in assert (check exp A.typerep_of_t B.typerep_of_t); assert (not (S.Diff.is_bin_prot_subtype ~subtype:(S.of_typerep A.typerep_of_t) ~supertype:(S.of_typerep B.typerep_of_t))); let exp = "((() (Remove_field (((label b) (index 1)) Float))))" in assert (check exp B.typerep_of_t A.typerep_of_t); TEST_UNIT = let module A = struct type t = | V1 of int | V2 of int | V3 of int with typerep end in let module B = struct type t = | V1 of int | V2bis of float | V3 of int with typerep end in let exp = "((() (Update_variant (((label V2) (index 1) (ocaml_repr 1)) (Int)) (((label V2bis) (index 1) (ocaml_repr 1)) (Float)) )))" in assert (check exp A.typerep_of_t B.typerep_of_t); TEST_UNIT = let module A = struct type t = | V1 of int | V3 of int with typerep end in let module B = struct type t = | V1 of int | V2 of int * float | V3 of int with typerep end in let exp = "((() (Add_variant (Break ((label V2) (index 1) (ocaml_repr 1)) (Int Float)))))" in assert (check exp A.typerep_of_t B.typerep_of_t); let exp = "((() (Remove_variant (((label V2) (index 1) (ocaml_repr 1)) (Int Float)))))" in assert (check exp B.typerep_of_t A.typerep_of_t); assert (not ( (* order matters for non polymorphic variants *) S.Diff.is_bin_prot_subtype ~subtype:(S.of_typerep A.typerep_of_t) ~supertype:(S.of_typerep B.typerep_of_t))); TEST_UNIT = let module A = struct type t = [ | `V3 of int | `V1 of int ] with typerep end in let module B = struct type t = [ | `V1 of int | `V2 of int * float | `V3 of int ] with typerep end in let exp = "((()(Add_variant (Backward_compatible ((label V2) (index 1) (ocaml_repr 19228)) ((Tuple (Int Float)))))))" in assert (check exp A.typerep_of_t B.typerep_of_t); let exp = "((() (Remove_variant (((label V2) (index 1) (ocaml_repr 19228)) ((Tuple (Int Float)))))))" in assert (check exp B.typerep_of_t A.typerep_of_t); assert (S.Diff.is_bin_prot_subtype ~subtype:(S.of_typerep A.typerep_of_t) ~supertype:(S.of_typerep B.typerep_of_t)); end typerep-113.00.00/experimental/test/test_struct.ml000066400000000000000000000150251256342456100221100ustar00rootroot00000000000000open Core.Std open Typerep_experimental.Std let print_str str = let sexp = Type_struct.sexp_of_t str in print_endline (Sexp.to_string_hum sexp) module S = Type_struct let check s1 s2 = if Type_struct.are_equivalent s1 s2 then true else begin print_endline "s1:"; print_str s1; print_endline "s2:"; print_str s2; false end (* Tests about Type_struct rewriting *) TEST_MODULE = struct let str s = let versioned = Type_struct.Versioned.t_of_sexp (Sexp.of_string s) in Type_struct.Versioned.unserialize versioned let () = let t = Type_struct.incompatible in assert (not (Type_struct.are_equivalent (t()) (t()))) TEST_UNIT = let s1 = str "(V3 (Record ((has_double_array_tag false)) ((t1 (Named 10 ((Record \ ((has_double_array_tag false))((a Int)))))) (t2 (Named 10 ())))))" in let s2 = str "(V3 (Record ((has_double_array_tag false)) ((t1 (Named 42 ((Record \ ((has_double_array_tag false)) ((a Int)))))) (t2 (Named 42 ())))))" in assert (check s1 s2); assert (check (S.alpha_conversion s1) (S.alpha_conversion s2)) TEST_UNIT = let s1 = str "(V3 (Record ((has_double_array_tag false)) ((t1 (Record ((has_double_array_tag false))\ ((a Int)))) (t2 (Record ((has_double_array_tag false)) ((a Int)))))))" in let s2 = str "(V3 (Record ((has_double_array_tag false)) ((t1 (Named 0 \ ((Record ((has_double_array_tag false)) ((a Int)))))) (t2 (Named 0 ())))))" in assert (check s1 s2); assert (check (S.reduce s1) s2) TEST_UNIT = let module M1 = struct type t = | A | B with typerep end in let module M2 = struct type t = | B | A with typerep end in assert (not (S.are_equivalent (S.of_typerep M1.typerep_of_t) (S.of_typerep M2.typerep_of_t))) TEST_UNIT = let module M1 = struct type t = [ | `A | `B ] with typerep end in let module M2 = struct type t = [ | `B | `A ] with typerep end in assert (S.are_equivalent (S.of_typerep M1.typerep_of_t) (S.of_typerep M2.typerep_of_t)) end (* testing merge_unify *) TEST_MODULE = struct let print a str = print_endline ("str "^a^":"); print_str str let check name value = if not value then print_endline (name^": false"); value let merge should_match a b c = let a = S.of_typerep a in let b = S.of_typerep b in let c = S.of_typerep c in let result = try let ab = S.least_upper_bound_exn a b in let result = check "should match" should_match && check "a <= ab" (S.Diff.is_bin_prot_subtype ~subtype:a ~supertype:ab) && check "b <= ab" (S.Diff.is_bin_prot_subtype ~subtype:b ~supertype:ab) && check "a <= c" (S.Diff.is_bin_prot_subtype ~subtype:a ~supertype:c) && check "b <= c" (S.Diff.is_bin_prot_subtype ~subtype:b ~supertype:c) && check "ab === c" (S.are_equivalent ab c) in result || begin print "a" a; print "b" b; print "c" c; print "ab" ab; false end with | exn -> let result = check "should not match" (not should_match) in result || begin print_endline (Exn.to_string exn); print "a" a; print "b" b; print "c" c; false end in assert result module Const(X:sig type t with typerep end) = struct TEST_UNIT = merge true X.typerep_of_t X.typerep_of_t X.typerep_of_t end TEST_MODULE = Const(struct type t = int with typerep end) TEST_MODULE = Const(struct type t = int32 with typerep end) TEST_MODULE = Const(struct type t = int64 with typerep end) TEST_MODULE = Const(struct type t = char with typerep end) TEST_MODULE = Const(struct type t = float with typerep end) TEST_MODULE = Const(struct type t = string with typerep end) TEST_MODULE = Const(struct type t = bool with typerep end) TEST_MODULE = Const(struct type t = unit with typerep end) module V1 = struct type t = | V1 of int with typerep end module V2 = struct type t = | V1 of int | V2 of string with typerep end TEST_UNIT = merge true V1.typerep_of_t V2.typerep_of_t V2.typerep_of_t module A1 = struct type t = | V1 of V2.t with typerep end module A2 = struct type t = | V1 of V1.t | V2 of string with typerep end module A3 = struct type t = | V1 of V2.t | V2 of string with typerep end TEST_UNIT = merge true A1.typerep_of_t A2.typerep_of_t A3.typerep_of_t module B1 = struct type t = [ | `V1 of V2.t | `V3 of int | `R of t ] with typerep end module B2 = struct type t = [ | `V1 of V1.t | `V2 of string | `R of t ] with typerep end module B3 = struct type t = [ | `V1 of V2.t | `V2 of string | `V3 of int | `R of t ] with typerep end TEST_UNIT = merge true A1.typerep_of_t A2.typerep_of_t A3.typerep_of_t module Bind(X:sig type 'a t with typerep end) = struct TEST_UNIT = let module A = struct type t = A1.t X.t with typerep end in let module B = struct type t = A2.t X.t with typerep end in let module C = struct type t = A3.t X.t with typerep end in let module A' = struct type t = B1.t X.t with typerep end in let module B' = struct type t = B2.t X.t with typerep end in let module C' = struct type t = B3.t X.t with typerep end in merge true A.typerep_of_t B.typerep_of_t C.typerep_of_t; merge true A'.typerep_of_t B'.typerep_of_t C'.typerep_of_t; end TEST_MODULE = Bind(struct type 'a t = { a : 'a; b : 'a * 'a; c : int; } with typerep end) TEST_MODULE = Bind(struct type 'a t = | A of 'a * 'a | B of 'a | C of ('a * 'a) | D with typerep end) TEST_MODULE = Bind(struct type 'a t = [ | `A of 'a * 'a | `B | `C of 'a ] with typerep end) TEST_MODULE = Bind(struct type 'a t = ('a * 'a * ('a * 'a)) with typerep end) TEST_MODULE = Bind(struct type 'a t = 'a option with typerep end) TEST_MODULE = Bind(struct type 'a t = 'a list with typerep end) TEST_MODULE = Bind(struct type 'a t = 'a array with typerep end) TEST_MODULE = Bind(struct type 'a t = 'a lazy_t with typerep end) TEST_MODULE = Bind(struct type 'a t = 'a ref with typerep end) end typerep-113.00.00/experimental/test/test_untyped.ml000066400000000000000000000062271256342456100222600ustar00rootroot00000000000000open Core.Std open Typerep_experimental.Std TEST_MODULE = struct let inverts_composition_is_ident typerep value : bool = let `generic to_typed = Tagged.Typed_of.of_typerep typerep in let `generic of_typed = Tagged.Of_typed.of_typerep typerep in Polymorphic_compare.equal value (to_typed (of_typed value)) let check rep v = assert (inverts_composition_is_ident rep v) TEST_UNIT = let module M = struct type t = int with typerep end in check (M.typerep_of_t) 42 TEST_UNIT = let module M = struct type t = int32 with typerep end in check (M.typerep_of_t) (Int32.of_int_exn 1337) TEST_UNIT = let module M = struct type t = int64 with typerep end in check (M.typerep_of_t) (Int64.of_int_exn 1980) TEST_UNIT = let module M = struct type t = char with typerep end in check (M.typerep_of_t) 'a' TEST_UNIT = let module M = struct type t = float with typerep end in check (M.typerep_of_t) 3.1415 TEST_UNIT = let module M = struct type t = bool with typerep end in check (M.typerep_of_t) true; check (M.typerep_of_t) false TEST_UNIT = let module M = struct type t = string with typerep end in check (M.typerep_of_t) "foo" TEST_UNIT = let module M = struct type t = unit with typerep end in check (M.typerep_of_t) () TEST_UNIT = let module M = struct type t = int option with typerep end in check (M.typerep_of_t) (None) ; check (M.typerep_of_t) (Some 2012) TEST_UNIT = let module M = struct type t = string list with typerep end in check (M.typerep_of_t) [] ; check (M.typerep_of_t) ["foo"; "bar"; "baz"] TEST_UNIT = let module M = struct type t = bool array with typerep end in check (M.typerep_of_t) [||] ; check (M.typerep_of_t) [| true ; false ; true |] TEST_UNIT = let module M = struct type 'a t = 'a ref with typerep end in check (M.typerep_of_t typerep_of_int) (ref 0) TEST_UNIT = let module M = struct type ('a, 'b) t = { foo : 'a ; bar : 'b ; baz : unit } with typerep end in check (M.typerep_of_t typerep_of_int typerep_of_char) { M. foo=0 ; bar='a' ; baz=() } TEST_UNIT = let module M = struct type t = int * int with typerep end in check (M.typerep_of_t) (1,2) TEST_UNIT = let module M = struct type t = int * int * int with typerep end in check (M.typerep_of_t) (1,2,3) TEST_UNIT = let module M = struct type t = int * int * int * int with typerep end in check (M.typerep_of_t) (1,2,3,4) TEST_UNIT = let module M = struct type t = int * int * int * int * int with typerep end in check (M.typerep_of_t) (1,2,3,4,5) TEST_UNIT = let module M = struct type 'a t = Nil | Cons of 'a * 'a t with typerep end in M.(check (typerep_of_t typerep_of_int) (Cons (1, Cons (2, Cons (3, Nil))))) TEST_UNIT = let module M = struct type china = unit with typerep type t = [ `The | `Republic of china ] with typerep end in M.(check typerep_of_t `The) ; M.(check typerep_of_t (`Republic ())) end typerep-113.00.00/generics/000077500000000000000000000000001256342456100153135ustar00rootroot00000000000000typerep-113.00.00/generics/binrep/000077500000000000000000000000001256342456100165725ustar00rootroot00000000000000typerep-113.00.00/generics/binrep/benchmarks/000077500000000000000000000000001256342456100207075ustar00rootroot00000000000000typerep-113.00.00/generics/binrep/benchmarks/bench_binrep.ml000066400000000000000000000264471256342456100236740ustar00rootroot00000000000000open Core.Std open Typerep_experimental.Std module Bench = Core_extended.Deprecated_bench open Bin_prot module IntListList = struct type t = int list list with typerep, bin_io let generate_list size = let helper ~f = List.init size ~f in helper ~f:(fun _ -> helper ~f:ident) let get_bin_tools list_size = let values = generate_list list_size in let buf_size = bin_size_t values in let buf = Common.create_buf buf_size in (values, buf) end module Records = struct module Record = struct type 'a t = {foo:'a; bar:int} with typerep, bin_io let list_of_ts size = List.init size ~f:(fun i -> { foo = "hello" ; bar = i }) end type 'a t = 'a Record.t list list with typerep, bin_io let generate_list size = List.init ~f:(fun _ -> Record.list_of_ts size) size let get_bin_tools list_size = let values = generate_list list_size in let buf_size = bin_size_t bin_size_string values in let buf = Common.create_buf buf_size in (values, buf) end module Tree = struct type t = Leaf | Node of t * t with typerep, bin_io let rec generate_tree depth = if depth > 0 then Node (generate_tree (depth-1), generate_tree (depth-1)) else Leaf let get_bin_tools tree_depth = let values = generate_tree tree_depth in let buf_size = bin_size_t values in let buf = Common.create_buf buf_size in (values, buf) end let deserialize_int_list_command = Command.basic ~summary:"bin-rep benchmarks" Command.Spec.( empty +> flag "-size" (optional_with_default 2000 int) ~doc:"Size of list to deserialize (default 2000)" ) (fun size () -> let t_read = let `generic reader = Binrep.bin_reader_t IntListList.typerep_of_t in reader.Type_class.read in let t_obj_read = let `generic reader = let typerep = Type_struct.recreate_dynamically_typerep_for_test IntListList.typerep_of_t in Binrep.bin_reader_t typerep in reader.Type_class.read in let u_read = let str = Type_struct.of_typerep IntListList.typerep_of_t in let `generic reader = Binrep.Tagged.bin_reader_t str in reader.Type_class.read in let (values,buf) = IntListList.get_bin_tools size in ignore ( IntListList.bin_write_t buf ~pos:0 values ) ; Bench.bench ~verbosity:`Mid [ Bench.Test.create ~name:"with bin_io deserialize int list list" (fun () -> let pos_ref = ref 0 in let _value = IntListList.bin_read_t buf ~pos_ref in ()); Bench.Test.create ~name:"deserialize int list list" (fun () -> let pos_ref = ref 0 in let _value = t_read buf ~pos_ref in ()); Bench.Test.create ~name:"deserialize int list list (obj)" (fun () -> let pos_ref = ref 0 in let _value = t_obj_read buf ~pos_ref in ()); Bench.Test.create ~name:"deserialize int list list (untyped)" (fun () -> let pos_ref = ref 0 in let _value = u_read buf ~pos_ref in ()); ] ) let serialize_int_list_command = Command.basic ~summary:"bin-rep benchmarks" Command.Spec.( empty +> flag "-size" (optional_with_default 2000 int) ~doc:"Size of list to serialize (default 2000)" ) (fun size () -> let t_write = let `generic writer = Binrep.bin_writer_t IntListList.typerep_of_t in writer.Type_class.write in let t_obj_write = let `generic writer = let typerep = Type_struct.recreate_dynamically_typerep_for_test IntListList.typerep_of_t in Binrep.bin_writer_t typerep in writer.Type_class.write in let u_write = let str = Type_struct.of_typerep IntListList.typerep_of_t in let `generic writer = Binrep.Tagged.bin_writer_t str in writer.Type_class.write in let (values,buf) = IntListList.get_bin_tools size in let u_values = let `generic of_typed = Tagged.Of_typed.of_typerep IntListList.typerep_of_t in of_typed values in Bench.bench ~verbosity:`Mid [ Bench.Test.create ~name:"with bin_io serialize int list list" (fun () -> ignore ( IntListList.bin_write_t buf ~pos:0 values ) ); Bench.Test.create ~name:"serialize int list list" (fun () -> ignore ( t_write buf ~pos:0 values ) ); Bench.Test.create ~name:"serialize int list list (obj)" (fun () -> ignore ( t_obj_write buf ~pos:0 values ) ); Bench.Test.create ~name:"serialize int list list (untyped)" (fun () -> ignore ( u_write buf ~pos:0 u_values ) ); ] ) let deserialize_record_list_command = Command.basic ~summary:"bin-rep benchmarks" Command.Spec.( empty +> flag "-size" (optional_with_default 2000 int) ~doc:"Size of list to deserialize (default 2000)" ) (fun size () -> let typerep = Records.typerep_of_t typerep_of_string in let t_read = let `generic reader = Binrep.bin_reader_t typerep in reader.Type_class.read in let t_obj_read = let `generic reader = let typerep = Type_struct.recreate_dynamically_typerep_for_test typerep in Binrep.bin_reader_t typerep in reader.Type_class.read in let u_read = let str = Type_struct.of_typerep typerep in let `generic reader = Binrep.Tagged.bin_reader_t str in reader.Type_class.read in let (values, buf) = Records.get_bin_tools size in ignore ( Records.bin_write_t Write.bin_write_string buf ~pos:0 values ) ; Bench.bench ~verbosity:`Mid [ Bench.Test.create ~name:"with bin_io deserialize record list list" (fun () -> let pos_ref = ref 0 in ignore ( Records.bin_read_t Read.bin_read_string buf ~pos_ref ) ) ; Bench.Test.create ~name:"bin_read deserialize record list list" (fun () -> let pos_ref = ref 0 in ignore ( t_read buf ~pos_ref ) ) ; Bench.Test.create ~name:"bin_read deserialize record list list (obj)" (fun () -> let pos_ref = ref 0 in ignore ( t_obj_read buf ~pos_ref ) ) ; Bench.Test.create ~name:"bin_read deserialize record list list (untyped)" (fun () -> let pos_ref = ref 0 in ignore ( u_read buf ~pos_ref ) ) ; ] ) let serialize_record_list_command = Command.basic ~summary:"sexprep benchmarks" Command.Spec.( empty +> flag "-size" (optional_with_default 2000 int) ~doc:"Size of list to serialize (default 2000)" ) (fun size () -> let typerep = Records.typerep_of_t typerep_of_string in let t_write = let `generic writer = Binrep.bin_writer_t typerep in writer.Type_class.write in let t_obj_write = let `generic writer = let typerep = Type_struct.recreate_dynamically_typerep_for_test typerep in Binrep.bin_writer_t typerep in writer.Type_class.write in let u_write = let str = Type_struct.of_typerep typerep in let `generic writer = Binrep.Tagged.bin_writer_t str in writer.Type_class.write in let (values, buf) = Records.get_bin_tools size in let u_values = let `generic of_typed = Tagged.Of_typed.of_typerep typerep in of_typed values in Bench.bench ~verbosity:`Mid [ Bench.Test.create ~name:"with bin_io serialize record list list" (fun () -> ignore ( Records.bin_write_t Write.bin_write_string buf ~pos:0 values ) ); Bench.Test.create ~name:"serialize record list list" (fun () -> ignore ( t_write buf ~pos:0 values ) ); Bench.Test.create ~name:"serialize record list list (obj)" (fun () -> ignore ( t_obj_write buf ~pos:0 values ) ); Bench.Test.create ~name:"serialize record list list (untyped)" (fun () -> ignore ( u_write buf ~pos:0 u_values ) ); ] ) let serialize_tree_command = Command.basic ~summary:"sexprep benchmarks" Command.Spec.( empty +> flag "-depth" (optional_with_default 20 int) ~doc:"Depth of tree to serialize (default 20)" ) (fun d () -> let t_write = let `generic writer = Binrep.bin_writer_t Tree.typerep_of_t in writer.Type_class.write in let t_obj_write = let `generic writer = let typerep = Type_struct.recreate_dynamically_typerep_for_test Tree.typerep_of_t in Binrep.bin_writer_t typerep in writer.Type_class.write in let u_write = let str = Type_struct.of_typerep Tree.typerep_of_t in let `generic writer = Binrep.Tagged.bin_writer_t str in writer.Type_class.write in let (values,buf) = Tree.get_bin_tools d in let u_values = let `generic of_typed = Tagged.Of_typed.of_typerep Tree.typerep_of_t in of_typed values in Bench.bench ~verbosity:`Mid [ Bench.Test.create ~name:"with bin_io serialize tree" (fun () -> ignore ( Tree.bin_write_t buf ~pos:0 values ) ); Bench.Test.create ~name:"serialize tree" (fun () -> ignore ( t_write buf ~pos:0 values ) ); Bench.Test.create ~name:"serialize tree (obj)" (fun () -> ignore ( t_obj_write buf ~pos:0 values ) ); Bench.Test.create ~name:"serialize tree (untyped)" (fun () -> ignore ( u_write buf ~pos:0 u_values ) ); ] ) let deserialize_tree_command = Command.basic ~summary:"sexprep benchmarks" Command.Spec.( empty +> flag "-depth" (optional_with_default 20 int) ~doc:"Depth of tree to deserialize (default 20)" ) (fun d () -> let t_read = let `generic reader = Binrep.bin_reader_t Tree.typerep_of_t in reader.Type_class.read in let t_obj_read = let `generic reader = let typerep = Type_struct.recreate_dynamically_typerep_for_test Tree.typerep_of_t in Binrep.bin_reader_t typerep in reader.Type_class.read in let u_read = let str = Type_struct.of_typerep Tree.typerep_of_t in let `generic reader = Binrep.Tagged.bin_reader_t str in reader.Type_class.read in let (values,buf) = Tree.get_bin_tools d in ignore ( Tree.bin_write_t buf ~pos:0 values ) ; Bench.bench ~verbosity:`Mid [ Bench.Test.create ~name:"with bin_io deserialize tree" (fun () -> let pos_ref = ref 0 in ignore ( Tree.bin_read_t buf ~pos_ref ) ) ; Bench.Test.create ~name:"bin_read deserialize tree" (fun () -> let pos_ref = ref 0 in ignore ( t_read buf ~pos_ref ) ) ; Bench.Test.create ~name:"bin_read deserialize tree (obj)" (fun () -> let pos_ref = ref 0 in ignore ( t_obj_read buf ~pos_ref ) ) ; Bench.Test.create ~name:"bin_read deserialize tree (untyped)" (fun () -> let pos_ref = ref 0 in ignore ( u_read buf ~pos_ref ) ) ; ] ) let command = Command.group ~summary:"Benchmarks" [ "int-list-serial", serialize_int_list_command; "int-list-deserial", deserialize_int_list_command; "record-list-serial", serialize_record_list_command; "record-list-deserial", deserialize_record_list_command; "tree-serial", serialize_tree_command; "tree-deserial", deserialize_tree_command ] let () = Exn.handle_uncaught ~exit:true (fun () -> Command.run command) typerep-113.00.00/generics/binrep/benchmarks/results.txt000066400000000000000000000214761256342456100231630ustar00rootroot00000000000000deserialize int int list: - typed / bin_io : 1.19 - untyped / typed : 2.54 | - untyped / bin_io : 3.02 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocate | Promoted | Warnings | | | | | | d (minor | d (major | | | | | | | | ) | ) | | | |-----------+----------+----------+----------+----------+----------+----------+----------| | bin_io | 223838 u | 75931614 | 4200 us | 24036069 | 12062548 | 12062548 | McaA | | | s | 5 | | | | | | | | | | | | | | | | binrep | 266182 u | 90295788 | 21476 us | 24026081 | 12066691 | 12066691 | McaA | | | s | 8 | | | | | | | | | | | | | | | | untyped | 676319 u | 22942452 | 11652 us | 32040048 | 24008038 | 20004035 | McA | | | s | 24 | | | | | | |----------------------------------------------------------------------------------------| ========================================================================================== deserialize record list list: - typed / bin_io : 4.48 - untyped / typed : 1.46 | - untyped / bin_io : 6.69 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocate | Promoted | Warnings | | | | | | d (minor | d (major | | | | | | | | ) | ) | | | |-----------+----------+----------+----------+----------+----------+----------+----------| | bin_io | 690732 u | 23431347 | 28599 us | 64036109 | 32183181 | 32183181 | McaA | | | s | 92 | | | | | | | | | | | | | | | | binrep | 3166 ms | 10740055 | 108188 u | 10000283 | 37151182 | 37151176 | McaA | | | | 199 | s | 68 | | | | | | | | | | | | | | untyped | 4618 ms | 15666889 | 103212 u | 90004004 | 84008038 | 80004035 | McA | | | | 842 | s | 8 | | | | |----------------------------------------------------------------------------------------| ========================================================================================== deserialize tree (-depth 22): - typed / bin_io : 3.58 - untyped / typed : 1.79 | - untyped / bin_io : 6.41 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocate | Promoted | Warnings | | | | | | d (minor | d (major | | | | | | | | ) | ) | | | |-----------+----------+----------+----------+----------+----------+----------+----------| | bin_io | 231147 u | 78411018 | 2632 us | 12582954 | 11999798 | 11999798 | caA | | | s | 8 | | | | | | | | | | | | | | | | binrep | 827018 u | 28054544 | 22382 us | 44459715 | 12567236 | 12567236 | McaA | | | s | 75 | | 7 | | | | | | | | | | | | | | untyped | 1483 ms | 50336195 | 32207 us | 40265391 | 46063427 | 46063427 | McaA | | | | 81 | | 2 | | | | |----------------------------------------------------------------------------------------| ========================================================================================== ========================================================================================== serialize int list list: - typed / bin_io : 1.43 - untyped / typed : 1.39 | - untyped / bin_io : 2.00 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocate | Promoted | Warnings | | | | | | d (minor | d (major | | | | | | | | ) | ) | | | |-----------+----------+----------+----------+----------+----------+----------+----------| | bin_io | 39018 us | 13235928 | 478039 n | 32027 | 15 | 0 | MA | | | | 0 | s | | | | | | | | | | | | | | | binrep | 55974 us | 18987948 | 5396 us | 12038 | 31 | 0 | mMA | | | | 0 | | | | | | | | | | | | | | | | untyped | 78116 us | 26498961 | 4725 us | 12028058 | 40106 | 40106 | MaA | | | | 6 | | | | | | |----------------------------------------------------------------------------------------| ========================================================================================== serialize record list list: - typed / bin_io : 2.70 - untyped / typed : 1.71 | - untyped / bin_io : 4.63 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocate | Promoted | Warnings | | | | | | d (minor | d (major | | | | | | | | ) | ) | | | |-----------+----------+----------+----------+----------+----------+----------+----------| | bin_io | 116361 u | 39472809 | 7665 us | 40032053 | 367 | 367 | MA | | | s | 1 | | | | | | | | | | | | | | | | binrep | 314608 u | 10672296 | 38917 us | 11201213 | 1114 | 1114 | MaA | | | s | 62 | | 2 | | | | | | | | | | | | | | untyped | 539196 u | 18290870 | 11864 us | 18002841 | 552329 | 552329 | MaA | | | s | 89 | | 7 | | | | |----------------------------------------------------------------------------------------| ========================================================================================== serialize tree (-depth 25): - typed / bin_io : 7.64 - untyped / typed : 1.12 | - untyped / bin_io : 8.52 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocate | Promoted | Warnings | | | | | | d (minor | d (major | | | | | | | | ) | ) | | | |-----------+----------+----------+----------+----------+----------+----------+----------| | bin_io | 455909 u | 15465570 | 6478 us | 32 | 31 | 0 | MA | | | s | 52 | | | | | | | | | | | | | | | | binrep | 3483 ms | 11816311 | 91970 us | 27850239 | 16671 | 16671 | MaA | | | | 926 | | 49 | | | | | | | | | | | | | | untyped | 3886 ms | 13183614 | 13070 us | 17783876 | 3991 | 3991 | aA | | | | 251 | | 96 | | | | |----------------------------------------------------------------------------------------| typerep-113.00.00/generics/binrep/lib/000077500000000000000000000000001256342456100173405ustar00rootroot00000000000000typerep-113.00.00/generics/binrep/lib/binrep.ml000066400000000000000000000101671256342456100211560ustar00rootroot00000000000000open! Core_kernel.Std open Typerep_extended.Std type buf = Bin_prot.Common.buf type pos_ref = Bin_prot.Common.pos_ref module Type_class = Bin_prot.Type_class module Sizer = Binrep_sizer module Writer = Binrep_writer module Reader = Binrep_reader module Size_reader = Binrep_size_reader let bin_size_t = Sizer.of_typerep let bin_writer_t = Writer.of_typerep let bin_reader_t = Reader.of_typerep let bin_size_reader_t = Size_reader.of_typerep type 'a size_reader = buf -> pos_ref : pos_ref -> unit module Make_binable(X:sig type t val typerep_of_t : t Typerep.t end) = struct type t = X.t let bin_size_t = let `generic clos = bin_size_t X.typerep_of_t in clos let bin_writer_t = let `generic clos = bin_writer_t X.typerep_of_t in clos let bin_reader_t = let `generic clos = bin_reader_t X.typerep_of_t in clos let bin_write_t = bin_writer_t.Type_class.write let bin_read_t = bin_reader_t.Type_class.read let __bin_read_t__ = bin_reader_t.Type_class.vtag_read let bin_t = { Type_class. reader = bin_reader_t; writer = bin_writer_t; } end let make_binable (type a) (typerep_of_t : a Typerep.t) = let module M = Make_binable(struct type t = a let typerep_of_t = typerep_of_t end) in (module M : Binable.S with type t = a) module Tagged = struct let bin_size_t = let module Sizer = Tagged_generic.Make_output(struct type t = int end)(Sizer.Computation) in Sizer.of_typestruct let bin_size_reader_t = let module Size_reader = Tagged_generic.Make_reader(struct type 'a t = buf -> pos_ref:pos_ref -> unit let make _ fct = fct end)(Size_reader.Computation) in Size_reader.of_typestruct module Tagged_writer = struct module Computation = Writer.Computation module Builder = struct type 'a t = 'a Computation.t let make to_typed writer = { Type_class. size = (fun untyped -> writer.Type_class.size (to_typed untyped)); write = (fun buf ~pos untyped -> writer.Type_class.write buf ~pos (to_typed untyped)); } end include Tagged_generic.Make_writer(Builder)(Computation) end module Tagged_reader = struct module Computation = Reader.Computation module Builder = struct type 'a t = 'a Computation.t let make to_typed reader = { Type_class. read = (fun buf ~pos_ref -> to_typed (reader.Type_class.read buf ~pos_ref)); vtag_read = (fun buf ~pos_ref i -> to_typed (reader.Type_class.vtag_read buf ~pos_ref i)); } end include Tagged_generic.Make_reader(Builder)(Computation) end let bin_write_t str = let `generic writer = Tagged_writer.of_typestruct str in `generic writer.Type_class.write let bin_read_t str = let `generic reader = Tagged_reader.of_typestruct str in `generic reader.Type_class.read let __bin_read_t__ str = let `generic reader = Tagged_reader.of_typestruct str in `generic reader.Type_class.vtag_read let bin_writer_t str = Tagged_writer.of_typestruct str let bin_reader_t str = Tagged_reader.of_typestruct str let bin_t str = let `generic writer = Tagged_writer.of_typestruct str in let `generic reader = Tagged_reader.of_typestruct str in `generic { Type_class. reader ; writer } module Make_binable(X:sig val typestruct_of_t : Type_struct.t end) = struct type t = Tagged.t let bin_size_t = let `generic clos = bin_size_t X.typestruct_of_t in clos let bin_writer_t = let `generic clos = bin_writer_t X.typestruct_of_t in clos let bin_reader_t = let `generic clos = bin_reader_t X.typestruct_of_t in clos let bin_write_t = bin_writer_t.Type_class.write let bin_read_t = bin_reader_t.Type_class.read let __bin_read_t__ = bin_reader_t.Type_class.vtag_read let bin_t = { Type_class. reader = bin_reader_t; writer = bin_writer_t; } end let make_binable typestruct_of_t = let module M = Make_binable(struct let typestruct_of_t = typestruct_of_t end) in (module M : Bin_prot.Binable.S with type t = Tagged.t) end typerep-113.00.00/generics/binrep/lib/binrep.mli000066400000000000000000000041121256342456100213200ustar00rootroot00000000000000open! Core_kernel.Std open Typerep_extended.Std module Sizer : Type_generic.S with type 'a t = 'a Bin_prot.Size.sizer (* Writer needs to be registered before Reader *) module Writer : Type_generic.S with type 'a t = 'a Bin_prot.Type_class.writer module Reader : Type_generic.S with type 'a t = 'a Bin_prot.Type_class.reader type 'a size_reader = Bin_prot.Common.buf -> pos_ref : Bin_prot.Common.pos_ref -> unit module Size_reader : sig include Type_generic.S with type 'a t = 'a size_reader module Children : sig type 'a reader = Bin_prot.Common.buf -> pos_ref : Bin_prot.Common.pos_ref -> 'a val read_option : [ `some | `none ] reader val read_sequence : int reader val read_polymorphic_variant : int reader val read_usual_variant : int reader end end val bin_size_t : 'a Typerep.t -> [ `generic of 'a Bin_prot.Size.sizer ] val bin_writer_t : 'a Typerep.t -> [ `generic of 'a Bin_prot.Type_class.writer ] val bin_reader_t : 'a Typerep.t -> [ `generic of 'a Bin_prot.Type_class.reader ] val bin_size_reader_t : 'a Typerep.t -> [ `generic of 'a size_reader ] module Make_binable(X:Typerepable.S0) : Binable.S with type t := X.t val make_binable : 'a Typerep.t -> (module Binable.S with type t = 'a) module Tagged : sig open Bin_prot val bin_size_t : Type_struct.t -> [ `generic of Tagged.t Size.sizer ] val bin_write_t : Type_struct.t -> [ `generic of Tagged.t Write.writer ] val bin_read_t : Type_struct.t -> [ `generic of Tagged.t Read.reader ] val __bin_read_t__ : Type_struct.t -> [ `generic of (int->Tagged.t) Read.reader] val bin_writer_t : Type_struct.t -> [ `generic of Tagged.t Type_class.writer ] val bin_reader_t : Type_struct.t -> [ `generic of Tagged.t Type_class.reader ] val bin_t : Type_struct.t -> [ `generic of Tagged.t Type_class.t ] val bin_size_reader_t : Type_struct.t -> [ `generic of Tagged.t size_reader ] module Make_binable(X:sig val typestruct_of_t : Type_struct.t end) : Binable.S with type t := Tagged.t val make_binable : Type_struct.t -> (module Binable.S with type t = Tagged.t) end typerep-113.00.00/generics/binrep/lib/binrep_reader.ml000066400000000000000000000152261256342456100225010ustar00rootroot00000000000000open Bin_prot open Typerep_extended.Std let make_vtag_read_err () = let str_name = "Reader.unsafe_vtag_read" in fun _buf ~pos_ref:_ -> Bin_prot.Common.raise_variant_wrong_type str_name module Computation_impl = struct type 'a t = 'a Type_class.reader include Type_generic.Variant_and_record_intf.M(struct type nonrec 'a t = 'a t end) let int = Type_class.bin_reader_int let int32 = Type_class.bin_reader_int32 let int64 = Type_class.bin_reader_int64 let nativeint = Type_class.bin_reader_nativeint let char = Type_class.bin_reader_char let float = Type_class.bin_reader_float let string = Type_class.bin_reader_string let bool = Type_class.bin_reader_bool let unit = Type_class.bin_reader_unit let option = Type_class.bin_reader_option let list = Type_class.bin_reader_list let array = Type_class.bin_reader_array let lazy_t = Type_class.bin_reader_lazy let ref_ = Type_class.bin_reader_ref (* bin_io does *NOT* support serialization of functions *) let function_ _ = assert false let tuple2 ra rb = (* beware of (expr1, expr2) notation, expr1 has to be executed before expr2 thus, we use there let a = expr1 in let b = expr2 in a, b *) let read buf ~pos_ref = let a = ra.Type_class.read buf ~pos_ref in let b = rb.Type_class.read buf ~pos_ref in (a,b) in let vtag_read = make_vtag_read_err () in { Type_class. read ; vtag_read } let tuple3 ra rb rc = let read buf ~pos_ref = let a = ra.Type_class.read buf ~pos_ref in let b = rb.Type_class.read buf ~pos_ref in let c = rc.Type_class.read buf ~pos_ref in (a,b,c) in let vtag_read = make_vtag_read_err () in { Type_class. read ; vtag_read } let tuple4 ra rb rc rd = let read buf ~pos_ref = let a = ra.Type_class.read buf ~pos_ref in let b = rb.Type_class.read buf ~pos_ref in let c = rc.Type_class.read buf ~pos_ref in let d = rd.Type_class.read buf ~pos_ref in (a,b,c,d) in let vtag_read = make_vtag_read_err () in { Type_class. read ; vtag_read } let tuple5 ra rb rc rd re = let read buf ~pos_ref = let a = ra.Type_class.read buf ~pos_ref in let b = rb.Type_class.read buf ~pos_ref in let c = rc.Type_class.read buf ~pos_ref in let d = rd.Type_class.read buf ~pos_ref in let e = re.Type_class.read buf ~pos_ref in (a,b,c,d,e) in let vtag_read = make_vtag_read_err () in { Type_class. read ; vtag_read } let record record = let length = Record.length record in let read buf ~pos_ref = let current_field_index = ref 0 in let s = ref "" in let get field = let index = Field.index field in let label = Field.label field in s := !s ^ (Printf.sprintf "read %S index %d\n" label index); if index <> !current_field_index then ( s := !s^ (Printf.sprintf "current=%d\n" !current_field_index); raise (Failure !s) ); current_field_index := (succ index) mod length; (Field.traverse field).Type_class.read buf ~pos_ref in let t = Record.create record { Record.get } in if current_field_index.contents <> 0 then assert false; t in let vtag_read = make_vtag_read_err () in { Type_class. read ; vtag_read } let variant variant = let length = Variant.length variant in let is_polymorphic = Variant.is_polymorphic variant in let repr_reader = if is_polymorphic then Bin_prot.Read.bin_read_variant_int else if length < 256 then Bin_prot.Read.bin_read_int_8bit else Bin_prot.Read.bin_read_int_16bit in let read_with_repr = let extract_key = if is_polymorphic then Tag.ocaml_repr else Tag.index in let tags = Flat_map.Flat_int_map.init length ~f:(fun index -> match Variant.tag variant index with | (Variant.Tag tag) as data -> extract_key tag, data) in (fun buf ~pos_ref repr -> match Flat_map.Flat_int_map.find tags repr with | Some (Variant.Tag tag) -> begin match Tag.create tag with | Tag.Const const -> const | Tag.Args create -> let value = (Tag.traverse tag).Type_class.read buf ~pos_ref in create value end | None -> Bin_prot.Common.raise_read_error (Bin_prot.Common.ReadError.Sum_tag "Binrep.Reader.variant") !pos_ref) in let vtag_read buf ~pos_ref vint = if is_polymorphic then read_with_repr buf ~pos_ref vint else Bin_prot.Common.raise_variant_wrong_type "Binrep.Reader.variant" !pos_ref in let read buf ~pos_ref = let repr = repr_reader buf ~pos_ref in read_with_repr buf ~pos_ref repr in { Type_class. read ; vtag_read } module Named = struct module Reader_named = Type_generic.Make_named_for_closure(struct open Bin_prot.Common type 'a input = buf type 'a output = pos_ref:pos ref -> 'a type 'a t = 'a Read.reader end) module Vtag_reader_named = Type_generic.Make_named_for_closure(struct open Bin_prot.Common type 'a input = buf type 'a output = pos_ref:pos ref -> (int -> 'a) type 'a t = (int -> 'a) Read.reader end) module Context = struct type t = { reader_ctx : Reader_named.Context.t ; vtag_reader_cxt : Vtag_reader_named.Context.t ; } let create () = { reader_ctx = Reader_named.Context.create () ; vtag_reader_cxt = Vtag_reader_named.Context.create () ; } end type 'a t = { reader_named : 'a Reader_named.t; vtag_reader_named : 'a Vtag_reader_named.t; } let init ctx name = let open Context in { reader_named = Reader_named.init ctx.reader_ctx name; vtag_reader_named = Vtag_reader_named.init ctx.vtag_reader_cxt name; } let get_wip_computation t = { Type_class. read = Reader_named.get_wip_computation t.reader_named; vtag_read = Vtag_reader_named.get_wip_computation t.vtag_reader_named; } let set_final_computation t comp = { Type_class. read = Reader_named.set_final_computation t.reader_named comp.Type_class.read; vtag_read = Vtag_reader_named.set_final_computation t.vtag_reader_named comp.Type_class.vtag_read; } let share _ = true end end include Type_generic.Make(struct include Computation_impl let name = "bin_reader" let required = [ Type_struct.Generic.ident; Binrep_sizer.ident; Binrep_writer.ident; ] end) typerep-113.00.00/generics/binrep/lib/binrep_reader.mli000066400000000000000000000001331256342456100226410ustar00rootroot00000000000000open Typerep_lib.Std include Type_generic.S with type 'a t = 'a Bin_prot.Type_class.reader typerep-113.00.00/generics/binrep/lib/binrep_size_reader.ml000066400000000000000000000112251256342456100235260ustar00rootroot00000000000000open Bin_prot open Bin_prot.Common open Typerep_extended.Std module Computation_impl = struct type 'a t = buf -> pos_ref : pos_ref -> unit type 'a size_reader = 'a t include Type_generic.Variant_and_record_intf.M(struct type nonrec 'a t = 'a t end) let check_next = Common.check_next let static buf ~pos_ref i = let next = !pos_ref + i in check_next buf next; pos_ref := next; ;; let int buf ~pos_ref = let _ = Read.bin_read_int buf ~pos_ref in () let int32 buf ~pos_ref = let _ = Read.bin_read_int32 buf ~pos_ref in () let int64 buf ~pos_ref = let _ = Read.bin_read_int64 buf ~pos_ref in () let nativeint buf ~pos_ref = let _ = Read.bin_read_nativeint buf ~pos_ref in () let char buf ~pos_ref = static buf ~pos_ref 1 let float buf ~pos_ref = let _ = Read.bin_read_float buf ~pos_ref in () let string buf ~pos_ref = let start_pos = !pos_ref in let len = (Read.bin_read_nat0 buf ~pos_ref :> int) in if len > Sys.max_string_length then raise_read_error ReadError.String_too_long start_pos; let next = !pos_ref + len in check_next buf next; pos_ref := next; ;; let bool buf ~pos_ref = static buf ~pos_ref 1 let unit buf ~pos_ref = static buf ~pos_ref 1 let option read_el buf ~pos_ref = let pos = safe_get_pos buf pos_ref in match buf.{pos} with | '\000' -> pos_ref := pos + 1 | '\001' -> pos_ref := pos + 1; read_el buf ~pos_ref; | _ -> raise_read_error ReadError.Option_code pos let list read_el buf ~pos_ref = let len = (Read.bin_read_nat0 buf ~pos_ref :> int) in for _i = 1 to len do read_el buf ~pos_ref done let array = list let lazy_t read_el = read_el let ref_ read_el = read_el (* bin_io does *NOT* support serialization of functions *) let function_ _ = assert false let tuple2 read_a read_b = (fun buf ~pos_ref -> read_a buf ~pos_ref; read_b buf ~pos_ref; ) let tuple3 read_a read_b read_c = (fun buf ~pos_ref -> read_a buf ~pos_ref; read_b buf ~pos_ref; read_c buf ~pos_ref; ) let tuple4 read_a read_b read_c read_d = (fun buf ~pos_ref -> read_a buf ~pos_ref; read_b buf ~pos_ref; read_c buf ~pos_ref; read_d buf ~pos_ref; ) let tuple5 read_a read_b read_c read_d read_e = (fun buf ~pos_ref -> read_a buf ~pos_ref; read_b buf ~pos_ref; read_c buf ~pos_ref; read_d buf ~pos_ref; read_e buf ~pos_ref; ) let record record buf ~pos_ref = Record.fold record ~init:() ~f:(fun () -> function | Record.Field field -> Field.traverse field buf ~pos_ref ) let variant variant = let length = Variant.length variant in let is_polymorphic = Variant.is_polymorphic variant in let extract_key = if is_polymorphic then Tag.ocaml_repr else Tag.index in let tags = Flat_map.Flat_int_map.init length ~f:(fun index -> match Variant.tag variant index with | (Variant.Tag tag) as data -> extract_key tag, data ) in let repr_reader = if is_polymorphic then Read.bin_read_variant_int else if length < 256 then Read.bin_read_int_8bit else Read.bin_read_int_16bit in let bin_size_t buf ~pos_ref = let repr = repr_reader buf ~pos_ref in match Flat_map.Flat_int_map.find tags repr with | Some (Variant.Tag tag) -> let arity = Tag.arity tag in if arity <> 0 then Tag.traverse tag buf ~pos_ref | None -> Bin_prot.Common.raise_read_error (Bin_prot.Common.ReadError.Sum_tag "Bin_read_size.variant") !pos_ref in bin_size_t module Named = Type_generic.Make_named_for_closure(struct type 'a input = buf type 'a output = pos_ref: pos_ref -> unit type 'a t = 'a size_reader end) end include Type_generic.Make(struct include Computation_impl let name = "bin_size_reader" let required = [ Type_struct.Generic.ident; Binrep_sizer.ident; Binrep_reader.ident; Binrep_writer.ident; ] end) module Children = struct type 'a reader = buf -> pos_ref : pos_ref -> 'a let read_option buf ~pos_ref = let pos = safe_get_pos buf pos_ref in match buf.{pos} with | '\000' -> pos_ref := pos + 1; `none | '\001' -> pos_ref := pos + 1; `some | _ -> raise_read_error ReadError.Option_code pos let read_sequence buf ~pos_ref = let len = (Read.bin_read_nat0 buf ~pos_ref :> int) in len let read_usual_variant buf ~pos_ref = Read.bin_read_int_8bit buf ~pos_ref let read_polymorphic_variant buf ~pos_ref = Read.bin_read_variant_int buf ~pos_ref end typerep-113.00.00/generics/binrep/lib/binrep_size_reader.mli000066400000000000000000000006631256342456100237030ustar00rootroot00000000000000(** Compute size of values from the binary protocol (lazy) *) open Bin_prot.Common open Typerep_lib.Std type 'a t = buf -> pos_ref : pos_ref -> unit include Type_generic.S with type 'a t := 'a t module Children : sig type 'a reader = buf -> pos_ref : pos_ref -> 'a val read_option : [ `some | `none ] reader val read_sequence : int reader val read_polymorphic_variant : int reader val read_usual_variant : int reader end typerep-113.00.00/generics/binrep/lib/binrep_sizer.ml000066400000000000000000000043111256342456100223640ustar00rootroot00000000000000open Bin_prot open Typerep_extended.Std module Computation_impl = struct type 'a t = 'a Size.sizer include Type_generic.Variant_and_record_intf.M(struct type nonrec 'a t = 'a t end) let int = Size.bin_size_int let int32 = Size.bin_size_int32 let int64 = Size.bin_size_int64 let nativeint = Size.bin_size_nativeint let char = Size.bin_size_char let float = Size.bin_size_float let string = Size.bin_size_string let bool = Size.bin_size_bool let unit = Size.bin_size_unit let option = Size.bin_size_option let list = Size.bin_size_list let array = Size.bin_size_array let lazy_t = Size.bin_size_lazy let ref_ = Size.bin_size_ref (* bin_io does *NOT* support serialization of functions *) let function_ _ = assert false let tuple2 = fun sizer_fst sizer_snd -> fun (fst, snd) -> (sizer_fst fst) + (sizer_snd snd) let tuple3 = fun sizer_a sizer_b sizer_c -> fun (a,b,c) -> sizer_a a + sizer_b b + sizer_c c let tuple4 = fun sizer_a sizer_b sizer_c sizer_d -> fun (a,b,c,d) -> sizer_a a + sizer_b b + sizer_c c + sizer_d d let tuple5 = fun sizer_a sizer_b sizer_c sizer_d sizer_e -> fun (a,b,c,d,e) -> sizer_a a + sizer_b b + sizer_c c + sizer_d d + sizer_e e let record record value = let aggregate_fields_size acc = function | Record.Field field -> acc + Field.traverse field (Field.get field value) in Record.fold record ~init:0 ~f:aggregate_fields_size let variant variant = let tag_size = if Variant.is_polymorphic variant then 4 else let len = Variant.length variant in if len < 256 then 1 else 2 in let bin_size_t value = match Variant.value variant value with | Variant.Value (tag, args) -> let arity = Tag.arity tag in if arity = 0 then tag_size else tag_size + Tag.traverse tag args in bin_size_t module Named = Type_generic.Make_named_for_closure(struct type 'a input = 'a type 'a output = int type 'a t = 'a Size.sizer end) end include Type_generic.Make(struct include Computation_impl let name = "bin_sizer" let required = [ Type_struct.Generic.ident ] end) typerep-113.00.00/generics/binrep/lib/binrep_sizer.mli000066400000000000000000000001241256342456100225330ustar00rootroot00000000000000open Typerep_lib.Std include Type_generic.S with type 'a t = 'a Bin_prot.Size.sizer typerep-113.00.00/generics/binrep/lib/binrep_writer.ml000066400000000000000000000127321256342456100225520ustar00rootroot00000000000000open Bin_prot open Typerep_extended.Std module Computation_impl = struct type 'a t = 'a Type_class.writer include Type_generic.Variant_and_record_intf.M(struct type nonrec 'a t = 'a t end) let int = Type_class.bin_writer_int let int32 = Type_class.bin_writer_int32 let int64 = Type_class.bin_writer_int64 let nativeint = Type_class.bin_writer_nativeint let char = Type_class.bin_writer_char let float = Type_class.bin_writer_float let string = Type_class.bin_writer_string let bool = Type_class.bin_writer_bool let unit = Type_class.bin_writer_unit let option = Type_class.bin_writer_option let list = Type_class.bin_writer_list let array = Type_class.bin_writer_array let lazy_t = Type_class.bin_writer_lazy let ref_ = Type_class.bin_writer_ref (* bin_io does *NOT* support serialization of functions *) let function_ _ = assert false let tuple2 wa wb = let module TC = Type_class in let size (a,b) = wa.TC.size a + wb.TC.size b in let write buf ~pos (a,b) = let pos = wa.TC.write buf ~pos a in wb.TC.write buf ~pos b in { TC. size ; write } let tuple3 wa wb wc = let module TC = Type_class in let size (a,b,c) = wa.TC.size a + wb.TC.size b + wc.TC.size c in let write buf ~pos (a,b,c) = let pos = wa.TC.write buf ~pos a in let pos = wb.TC.write buf ~pos b in wc.TC.write buf ~pos c in { TC. size ; write } let tuple4 wa wb wc wd = let module TC = Type_class in let size (a,b,c,d) = wa.TC.size a + wb.TC.size b + wc.TC.size c + wd.TC.size d in let write buf ~pos (a,b,c,d) = let pos = wa.TC.write buf ~pos a in let pos = wb.TC.write buf ~pos b in let pos = wc.TC.write buf ~pos c in wd.TC.write buf ~pos d in { TC. size ; write } let tuple5 wa wb wc wd we = let module TC = Type_class in let size (a,b,c,d,e) = wa.TC.size a + wb.TC.size b + wc.TC.size c + wd.TC.size d + we.TC.size e in let write buf ~pos (a,b,c,d,e) = let pos = wa.TC.write buf ~pos a in let pos = wb.TC.write buf ~pos b in let pos = wc.TC.write buf ~pos c in let pos = wd.TC.write buf ~pos d in we.TC.write buf ~pos e in { TC. size ; write } let record record = let size value = let aggregate_fields_size acc = function | Record.Field field -> acc + (Field.traverse field).Type_class.size (Field.get field value) in Record.fold record ~init:0 ~f:aggregate_fields_size in let write buf ~pos value = let write_field pos = function | Record.Field field -> (Field.traverse field).Type_class.write buf ~pos (Field.get field value) in Record.fold record ~init:pos ~f:write_field in { Type_class. size ; write } let variant variant = let len = Variant.length variant in let tag_size = if Variant.is_polymorphic variant then 4 else if len < 256 then 1 else 2 in let size value = match Variant.value variant value with | Variant.Value (tag, args) -> let arity = Tag.arity tag in if arity = 0 then tag_size else tag_size + (Tag.traverse tag).Type_class.size args in let write buf ~pos value = match Variant.value variant value with | Variant.Value (tag, args) -> let pos = if Variant.is_polymorphic variant then let ocaml_repr = Tag.ocaml_repr tag in Bin_prot.Write.bin_write_variant_int buf ~pos ocaml_repr else let index = Tag.index tag in if len < 256 then Bin_prot.Write.bin_write_int_8bit buf ~pos index else Bin_prot.Write.bin_write_int_16bit buf ~pos index in if Tag.arity tag = 0 then pos else (Tag.traverse tag).Type_class.write buf ~pos args in { Type_class. size ; write } module Named = struct open Bin_prot module Writer_named = Type_generic.Make_named_for_closure(struct type 'a input = Common.buf type 'a output = pos:Common.pos -> 'a -> Common.pos type 'a t = 'a Write.writer end) module Context = struct type t = { sizer : Binrep_sizer.Computation.Named.Context.t ; writer : Writer_named.Context.t ; } let create () = { sizer = Binrep_sizer.Computation.Named.Context.create () ; writer = Writer_named.Context.create () ; } end type 'a t = { sizer_named : 'a Binrep_sizer.Computation.Named.t; writer_named : 'a Writer_named.t; } let init ctx name = let open Context in { sizer_named = Binrep_sizer.Computation.Named.init ctx.sizer name ; writer_named = Writer_named.init ctx.writer name; } let get_wip_computation { sizer_named ; writer_named } = { Type_class. size = Binrep_sizer.Computation.Named.get_wip_computation sizer_named ; write = Writer_named.get_wip_computation writer_named ; } let set_final_computation {sizer_named;writer_named} comp = let open Type_class in { size = Binrep_sizer.Computation.Named.set_final_computation sizer_named comp.size; write = Writer_named.set_final_computation writer_named comp.write; } let share _ = true end end include Type_generic.Make(struct include Computation_impl let name = "bin_writer" let required = [ Type_struct.Generic.ident; Binrep_sizer.ident; ] end) typerep-113.00.00/generics/binrep/lib/binrep_writer.mli000066400000000000000000000001331256342456100227130ustar00rootroot00000000000000open Typerep_lib.Std include Type_generic.S with type 'a t = 'a Bin_prot.Type_class.writer typerep-113.00.00/generics/binrep/lib/std.ml000066400000000000000000000000271256342456100204630ustar00rootroot00000000000000module Binrep = Binrep typerep-113.00.00/generics/binrep/test/000077500000000000000000000000001256342456100175515ustar00rootroot00000000000000typerep-113.00.00/generics/binrep/test/test_binrep.ml000066400000000000000000000314041256342456100224230ustar00rootroot00000000000000 open Core.Std open Typerep_experimental.Std (* NB: in this file only the "safe" versions (i.e. the ml ones) of the reader and writer * are manually checked. * This is OK because: * - the safe versions in reality call the unsafe ones (so the unsafe one are in fact * checked as well, although it's not obvious at first.) *) module TreeTest = struct type t = Leaf | Node of t * t with typerep,bin_io let rec producer n = if n > 0 then Node (producer (n-1), producer (n-1)) else Leaf ;; let value = producer 15 end let equal = Pervasives.(=) TEST_MODULE = struct open Bin_prot.Type_class let buf = let size = TreeTest.bin_size_t TreeTest.value in Bin_prot.Common.create_buf size ;; let compose_inverts_is_ident writer reader value : bool = ignore (writer.write buf ~pos:0 value) ; let value' = reader.read buf ~pos_ref:(ref 0) in equal value value' ;; (* ---------------------------------------------------------------------------------- *) let check value typerep = let `generic writer = Binrep.bin_writer_t typerep in let `generic reader = Binrep.bin_reader_t typerep in compose_inverts_is_ident writer reader value (* we lose the "diff" done in the sexp version, but printing a sexp is easy and useful, printing a binary buffer, not so much. *) ;; let check_untyped value typerep = let str = Type_struct.of_typerep typerep in let `generic writer = Binrep.Tagged.bin_writer_t str in let `generic reader = Binrep.Tagged.bin_reader_t str in let untyped_value = let `generic converter = Tagged.Of_typed.of_typerep typerep in converter value in assert ( compose_inverts_is_ident writer reader untyped_value ) ;; (* ---------------------------------------------------------------------------------- *) let check_reader buffer typerep trusted_reader = let `generic reader = Binrep.bin_reader_t typerep in equal (trusted_reader.read buffer ~pos_ref:(ref 0)) (reader.read buffer ~pos_ref:(ref 0)) ;; let check_untyped_reader buffer typerep trusted_reader = let `generic reader = Binrep.Tagged.bin_reader_t (Type_struct.of_typerep typerep) in let `generic to_typed = Tagged.Typed_of.of_typerep typerep in assert ( equal (trusted_reader.read buffer ~pos_ref:(ref 0)) (to_typed (reader.read buffer ~pos_ref:(ref 0))) ) ;; (* ---------------------------------------------------------------------------------- *) let check_writer value typerep trusted_reader = let `generic writer = Binrep.bin_writer_t typerep in ignore (writer.write buf ~pos:0 value) ; equal value (trusted_reader.read buf ~pos_ref:(ref 0)) ;; let check_untyped_writer value typerep trusted_reader = let `generic writer = Binrep.Tagged.bin_writer_t (Type_struct.of_typerep typerep) in let `generic of_typed = Tagged.Of_typed.of_typerep typerep in ignore (writer.write buf ~pos:0 (of_typed value)) ; assert ( equal value (trusted_reader.read buf ~pos_ref:(ref 0)) ) ;; (* ---------------------------------------------------------------------------------- *) let test_sequence_typed ~value ~typerep ~trusted_reader ~trusted_writer = assert (check value typerep) ; ignore (trusted_writer.write buf ~pos:0 value) ; assert (check_reader buf typerep trusted_reader) ; assert (check_writer value typerep trusted_reader); ;; let test_sequence_obj_typed ~value ~typerep ~trusted_reader ~trusted_writer = let typerep = Type_struct.recreate_dynamically_typerep_for_test typerep in test_sequence_typed ~value ~typerep ~trusted_reader ~trusted_writer ;; let test_sequence_untyped ~value ~typerep ~trusted_reader ~trusted_writer = check_untyped value typerep ; ignore (trusted_writer.write buf ~pos:0 value) ; check_untyped_reader buf typerep trusted_reader; check_untyped_writer value typerep trusted_reader ;; (* ---------------------------------------------------------------------------------- *) let full_cycle ~value ~typerep ~trusted_reader ~trusted_writer = let str = Type_struct.of_typerep typerep in let `generic t_writer = Binrep.bin_writer_t typerep in let `generic t_reader = Binrep.bin_reader_t typerep in let `generic u_writer = Binrep.Tagged.bin_writer_t str in let `generic u_reader = Binrep.Tagged.bin_reader_t str in begin ignore (trusted_writer.write buf ~pos:0 value) ; let read_value = t_reader.read buf ~pos_ref:(ref 0) in ignore (t_writer.write buf ~pos:0 read_value) ; let read_untyped = u_reader.read buf ~pos_ref:(ref 0) in ignore (u_writer.write buf ~pos:0 read_untyped) ; let final_read = trusted_reader.read buf ~pos_ref:(ref 0) in assert (equal final_read value) end (* ---------------------------------------------------------------------------------- *) let test_sequence ~value ~typerep ~trusted_reader ~trusted_writer = test_sequence_typed ~value ~typerep ~trusted_reader ~trusted_writer ; test_sequence_obj_typed ~value ~typerep ~trusted_reader ~trusted_writer ; test_sequence_untyped ~value ~typerep ~trusted_reader ~trusted_writer ; full_cycle ~value ~typerep ~trusted_reader ~trusted_writer; ;; TEST_UNIT = let module M = struct type t = int with typerep, bin_io end in test_sequence ~value:5 ~typerep:M.typerep_of_t ~trusted_reader:M.bin_reader_t ~trusted_writer:M.bin_writer_t ;; TEST_UNIT = let module M = struct type t = int32 with typerep, bin_io end in let value = Int32.of_int_exn 5 in test_sequence ~value ~typerep:M.typerep_of_t ~trusted_reader:M.bin_reader_t ~trusted_writer:M.bin_writer_t ;; TEST_UNIT = let module M = struct type t = int64 with typerep, bin_io end in let value = Int64.of_int_exn 5 in test_sequence ~value ~typerep:M.typerep_of_t ~trusted_reader:M.bin_reader_t ~trusted_writer:M.bin_writer_t ;; TEST_UNIT = let module M = struct type t = char with typerep, bin_io end in let value = 'c' in test_sequence ~value ~typerep:M.typerep_of_t ~trusted_reader:M.bin_reader_t ~trusted_writer:M.bin_writer_t ;; TEST_UNIT = let module M = struct type t = float with typerep, bin_io end in let value = 543.02 in test_sequence ~value ~typerep:M.typerep_of_t ~trusted_reader:M.bin_reader_t ~trusted_writer:M.bin_writer_t ;; TEST_UNIT = let module M = struct type t = string with typerep, bin_io end in let value = "Hello, world!" in test_sequence ~value ~typerep:M.typerep_of_t ~trusted_reader:M.bin_reader_t ~trusted_writer:M.bin_writer_t ;; TEST_UNIT = let module M = struct type t = bool with typerep, bin_io end in let test value = test_sequence ~value ~typerep:M.typerep_of_t ~trusted_reader:M.bin_reader_t ~trusted_writer:M.bin_writer_t in test true; test false ;; TEST_UNIT = let module M = struct type t = unit with typerep, bin_io end in test_sequence ~value:() ~typerep:M.typerep_of_t ~trusted_reader:M.bin_reader_t ~trusted_writer:M.bin_writer_t ;; TEST_UNIT = let module M = struct type 'a t = 'a option with typerep, bin_io end in let test value = let typerep = M.typerep_of_t typerep_of_int in let trusted_reader = M.bin_reader_t bin_reader_int in let trusted_writer = M.bin_writer_t bin_writer_int in test_sequence ~value ~typerep ~trusted_reader ~trusted_writer in test None; test (Some 5) ;; TEST_UNIT = let module M = struct type 'a t = 'a list with typerep, bin_io end in let test value = let typerep = M.typerep_of_t typerep_of_int in let trusted_reader = M.bin_reader_t bin_reader_int in let trusted_writer = M.bin_writer_t bin_writer_int in test_sequence ~value ~typerep ~trusted_reader ~trusted_writer in test [] ; test [1;2;6;5;4;3] ;; TEST_UNIT = let module M = struct type 'a t = 'a array with typerep, bin_io end in let test value = let typerep = M.typerep_of_t typerep_of_int in let trusted_reader = M.bin_reader_t bin_reader_int in let trusted_writer = M.bin_writer_t bin_writer_int in test_sequence ~value ~typerep ~trusted_reader ~trusted_writer in test [||] ; test [|1;2;6;5;4;3|] ;; TEST_UNIT = let module M = struct type 'a t = 'a ref with typerep, bin_io end in let value = ref 6 in let typerep = M.typerep_of_t typerep_of_int in let trusted_reader = M.bin_reader_t bin_reader_int in let trusted_writer = M.bin_writer_t bin_writer_int in test_sequence ~value ~typerep ~trusted_reader ~trusted_writer ;; TEST_UNIT = let module M = struct type 'a t = {foo:'a; bar:float} with typerep, bin_io end in let value = { M. foo = 5 ; bar = 43.25 } in let typerep = M.typerep_of_t typerep_of_int in let trusted_reader = M.bin_reader_t bin_reader_int in let trusted_writer = M.bin_writer_t bin_writer_int in test_sequence ~value ~typerep ~trusted_reader ~trusted_writer TEST_UNIT = let module M = struct type ('a, 'b) t = ('a * 'b) with typerep, bin_io end in let value = (5,45.67) in let typerep = M.typerep_of_t typerep_of_int typerep_of_float in let trusted_reader = M.bin_reader_t bin_reader_int bin_reader_float in let trusted_writer = M.bin_writer_t bin_writer_int bin_writer_float in test_sequence ~value ~typerep ~trusted_reader ~trusted_writer ;; TEST_UNIT = let module M = struct type ('a, 'b, 'c) t = ('a * 'b * 'c) with typerep, bin_io end in let value = (5,45,3.1415) in let typerep = M.typerep_of_t typerep_of_int typerep_of_int typerep_of_float in let trusted_reader = M.bin_reader_t bin_reader_int bin_reader_int bin_reader_float in let trusted_writer = M.bin_writer_t bin_writer_int bin_writer_int bin_writer_float in test_sequence ~value ~typerep ~trusted_reader ~trusted_writer ;; TEST_UNIT = let module M = struct type ('a, 'b, 'c, 'd) t = ('a * 'b * 'c * 'd) with typerep, bin_io end in let value = (5,45,3.14,42.25) in let typerep = M.typerep_of_t typerep_of_int typerep_of_int typerep_of_float typerep_of_float in let trusted_reader = M.bin_reader_t bin_reader_int bin_reader_int bin_reader_float bin_reader_float in let trusted_writer = M.bin_writer_t bin_writer_int bin_writer_int bin_writer_float bin_writer_float in test_sequence ~value ~typerep ~trusted_reader ~trusted_writer ;; TEST_UNIT = let module M = struct type ('a, 'b, 'c, 'd, 'e) t = ('a * 'b * 'c * 'd * 'e) with typerep, bin_io end in let value = (5,45,3.14,42.25,"hi") in let typerep = M.typerep_of_t typerep_of_int typerep_of_int typerep_of_float typerep_of_float typerep_of_string in let trusted_reader = M.bin_reader_t bin_reader_int bin_reader_int bin_reader_float bin_reader_float bin_reader_string in let trusted_writer = M.bin_writer_t bin_writer_int bin_writer_int bin_writer_float bin_writer_float bin_writer_string in test_sequence ~value ~typerep ~trusted_reader ~trusted_writer ;; TEST_UNIT = let module M = struct type t = | Foo | Bar of int | Baz of int * int | Bax of (int * int) with typerep, bin_io end in let test value = test_sequence ~value ~typerep:M.typerep_of_t ~trusted_reader:M.bin_reader_t ~trusted_writer:M.bin_writer_t in test M.Foo; test (M.Bar 651); test (M.Baz (651,54)); test (M.Bax (651,54)) ;; TEST_UNIT = test_sequence ~value:TreeTest.value ~typerep:TreeTest.typerep_of_t ~trusted_reader:TreeTest.bin_reader_t ~trusted_writer:TreeTest.bin_writer_t ;; TEST_UNIT = let module M = struct type t = [ `Foo | `Bar of int | `Other of string ] with typerep, bin_io end in let test value = test_sequence ~value ~typerep:M.typerep_of_t ~trusted_reader:M.bin_reader_t ~trusted_writer:M.bin_writer_t in test (`Foo); test (`Bar 13); test (`Other "FOOBAR"); ;; end typerep-113.00.00/generics/jsonrep/000077500000000000000000000000001256342456100167735ustar00rootroot00000000000000typerep-113.00.00/generics/jsonrep/benchmarks/000077500000000000000000000000001256342456100211105ustar00rootroot00000000000000typerep-113.00.00/generics/jsonrep/benchmarks/bench_jsonrep.ml000066400000000000000000000241271256342456100242670ustar00rootroot00000000000000open Core.Std open Json_typerep.Std open Typerep_experimental.Std module Bench = Core_extended.Deprecated_bench let int_list_command = Command.basic ~summary:"benchmark sexprep vs jsonrep on lists of ints" Command.Spec.( empty +> flag "-size" (optional_with_default 2000 int) ~doc:"Size of list to deserialize (default 2000)" +> flag "-serial" no_arg ~doc:"direction of test: serialization or deserialization (default deserial)" ) (fun size is_serial () -> let module M = struct type 'a t = 'a list list with typerep, sexp end in let list_of_int = List.init size ~f:ident in let values = List.init ~f:(fun _ -> list_of_int) size in let `generic x_of_sexp = Sexprep.t_of_sexp (M.typerep_of_t typerep_of_int) in let `generic sexp_of_x = Sexprep.sexp_of_t (M.typerep_of_t typerep_of_int) in let `generic x_of_json = Jsonrep.V2.t_of_json (M.typerep_of_t typerep_of_int) in let `generic json_of_x = Jsonrep.V2.json_of_t (M.typerep_of_t typerep_of_int) in let sexp = M.sexp_of_t sexp_of_int values in let json = json_of_x values in let tests = if is_serial then [ Bench.Test.create ~name:"sexprep" (fun () -> let _sexp = sexp_of_x values in ()) ; Bench.Test.create ~name:"jsonsexp" (fun () -> let _json = json_of_x values in ())] else [ Bench.Test.create ~name:"sexprep" (fun () -> let _values = x_of_sexp sexp in ()) ; Bench.Test.create ~name:"jsonsexp" (fun () -> let _values = x_of_json json in ())] in Bench.bench ~verbosity:`Mid tests ) let string_list_command = Command.basic ~summary:"benchmark sexprep vs jsonrep on lists of strings" Command.Spec.( empty +> flag "-size" (optional_with_default 2000 int) ~doc:"Size of list to deserialize (default 2000)" +> flag "-serial" no_arg ~doc:"direction of test: serialization or deserialization (default deserial)" ) (fun size is_serial () -> let module M = struct type 'a t = 'a list list with typerep, sexp end in let list_of_string = List.init size ~f:(fun n -> Int.to_string n) in let values = List.init ~f:(fun _ -> list_of_string) size in let `generic x_of_sexp = Sexprep.t_of_sexp (M.typerep_of_t typerep_of_string) in let `generic sexp_of_x = Sexprep.sexp_of_t (M.typerep_of_t typerep_of_string) in let `generic x_of_json = Jsonrep.V2.t_of_json (M.typerep_of_t typerep_of_string) in let `generic json_of_x = Jsonrep.V2.json_of_t (M.typerep_of_t typerep_of_string) in let sexp = M.sexp_of_t sexp_of_string values in let json = json_of_x values in let tests = if is_serial then [ Bench.Test.create ~name:"sexprep" (fun () -> let _sexp = sexp_of_x values in ()) ; Bench.Test.create ~name:"jsonsexp" (fun () -> let _json = json_of_x values in ())] else [ Bench.Test.create ~name:"sexprep" (fun () -> let _values = x_of_sexp sexp in ()) ; Bench.Test.create ~name:"jsonsexp" (fun () -> let _values = x_of_json json in ())] in Bench.bench ~verbosity:`Mid tests ) let record_list_command = Command.basic ~summary:"benchmark sexprep vs jsonrep on lists of large records" Command.Spec.( empty +> flag "-size" (optional_with_default 1000 int) ~doc:"Size of list to deserialize (default 1000)" +> flag "-reorder" no_arg ~doc:"Whether to reorder the sexps before deserialization" +> flag "-serial" no_arg ~doc:"direction of test: serialization or deserialization (default deserial)" ) (fun size reorder is_serial () -> let module M = struct type 'a r = { one:'a; two:int; three:'a; four:int; five:'a; six:int; seven:'a; eight:int; nine:'a; ten:int; eleven:'a; twelve:int; thirteen:'a; fourteen:int; fiveteen:'a; sixteen:int; seventeen:'a; eighteen:int; nineteen:'a; twenty:int; } with typerep, sexp type 'a t = 'a r list list with typerep, sexp end in let list_of_record = List.init size ~f:(fun n -> { M.one="hello"; two=n; three="hello"; four=n; five="hello"; six=n; seven="hello"; eight=n; nine="hello"; ten=n; eleven="hello"; twelve=n; thirteen="hello"; fourteen=n; fiveteen="hello"; sixteen=n; seventeen="hello"; eighteen=n; nineteen="hello"; twenty=n; }) in let values = List.init ~f:(fun _ -> list_of_record) size in let initial_sexp = M.sexp_of_t (sexp_of_string) values in let sexp = if reorder then match initial_sexp with | Sexp.List list_lists_of_recs -> Sexp.List (List.map list_lists_of_recs ~f:(function | Sexp.List list_recs -> Sexp.List (List.permute list_recs) | _ -> raise (Failure "failed before tests: unexpected sexp structure"))) | _ -> raise (Failure "failed before tests: unexpected sexp structure") else initial_sexp in let `generic sexp_of_x = Sexprep.sexp_of_t (M.typerep_of_t typerep_of_string) in let `generic x_of_sexp = Sexprep.t_of_sexp (M.typerep_of_t typerep_of_string) in let `generic x_of_json = Jsonrep.V2.t_of_json (M.typerep_of_t typerep_of_string) in let `generic json_of_x = Jsonrep.V2.json_of_t (M.typerep_of_t typerep_of_string) in let json = json_of_x values in let tests = if is_serial then [ Bench.Test.create ~name:"sexprep" (fun () -> let _sexp = sexp_of_x values in ()) ; Bench.Test.create ~name:"jsonsexp" (fun () -> let _json = json_of_x values in ())] else [ Bench.Test.create ~name:"sexprep" (fun () -> let _values = x_of_sexp sexp in ()) ; Bench.Test.create ~name:"jsonsexp" (fun () -> let _values = x_of_json json in ())] in Bench.bench ~verbosity:`Mid tests ) let variant_list_command = Command.basic ~summary:"benchmark sexprep vs jsonrep on lists of variants" Command.Spec.( empty +> flag "-size" (optional_with_default 2000 int) ~doc:"Size of list to (de)serialize (default 2000)" +> flag "-serial" no_arg ~doc:"direction of test: serialization or deserialization (default deserial)" ) (fun size is_serial () -> let module M = struct type v = | Foo | M22 | Bar of int | Baz of int * int | Other of string * int * v | Something | Another of int * int * string | Recur of v * v * v * v with typerep, sexp type t = v list list with typerep, sexp end in let values = List.init size ~f:(fun _ -> List.init size ~f:(fun n -> if Int.equal n 0 then M.Foo else if Int.equal (n % 2) 0 then M.Bar n else M.Baz (n,n-1))) in let `generic sexp_of_x = Sexprep.sexp_of_t M.typerep_of_t in let `generic x_of_sexp = Sexprep.t_of_sexp M.typerep_of_t in let `generic x_of_json = Jsonrep.V2.t_of_json M.typerep_of_t in let `generic json_of_x = Jsonrep.V2.json_of_t M.typerep_of_t in let sexp = M.sexp_of_t values in let json = json_of_x values in let tests = if is_serial then [ Bench.Test.create ~name:"sexprep" (fun () -> let _sexp = sexp_of_x values in ()) ; Bench.Test.create ~name:"jsonsexp" (fun () -> let _json = json_of_x values in ())] else [ Bench.Test.create ~name:"sexprep" (fun () -> let _values = x_of_sexp sexp in ()) ; Bench.Test.create ~name:"jsonsexp" (fun () -> let _values = x_of_json json in ())] in Bench.bench ~verbosity:`Mid tests ) let tree_command = Command.basic ~summary:"benchmark sexprep vs jsonrep on nested variant structures" Command.Spec.( empty +> flag "-depth" (optional_with_default 20 int) ~doc:"Depth of tree to serialize (default 20)" +> flag "-serial" no_arg ~doc:"direction of test: serialization or deserialization (default deserial)" ) (fun size is_serial () -> let module M = struct type t = | Leaf | Green_Node of t * t | Red_Node of t * t | Black_Node of t * t | Blue_Node of t * t | Node2 of t * t | Node_2 of t * t | Binary_Node of t * t | Foo | Bar | Baz | Bax with typerep, sexp end in let rec producer n = if n > 0 then M.Node2 (producer (n-1), producer (n-1)) else M.Leaf in let values = producer size in let sexp = M.sexp_of_t values in let `generic x_of_sexp = Sexprep.t_of_sexp M.typerep_of_t in let `generic sexp_of_x = Sexprep.sexp_of_t M.typerep_of_t in let `generic x_of_json = Jsonrep.V2.t_of_json M.typerep_of_t in let `generic json_of_x = Jsonrep.V2.json_of_t M.typerep_of_t in let json = json_of_x values in let tests = if is_serial then [ Bench.Test.create ~name:"sexprep" (fun () -> let _sexp = sexp_of_x values in ()) ; Bench.Test.create ~name:"jsonsexp" (fun () -> let _json = json_of_x values in ())] else [ Bench.Test.create ~name:"sexprep" (fun () -> let _values = x_of_sexp sexp in ()) ; Bench.Test.create ~name:"jsonsexp" (fun () -> let _values = x_of_json json in ())] in Bench.bench ~verbosity:`Mid tests ) let command = Command.group ~summary:"Benchmarks" [ "int-list", int_list_command; "string-list", string_list_command; "record-list", record_list_command; "variant-list", variant_list_command; "tree", tree_command; ] let () = Exn.handle_uncaught ~exit:true (fun () -> Command.run command) typerep-113.00.00/generics/jsonrep/benchmarks/results.txt000066400000000000000000000132671256342456100233630ustar00rootroot00000000000000 Deserialization Results for jsonrep vs sexprep ratios are run time, jsonrep/sexprep int-list -size 2200 ratio = 0.640 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocated | Promoted | Warnings | | | | | | d (minor | (major) | | | | | | | | ) | | | | |----------+----------+----------+----------+----------+-----------+----------+----------| | sexprep | 693369 u | 20748670 | 4839 us | 29064286 | 14593533 | 14593533 | aA | | | s | 96 | | | | | | | jsonsexp | 443818 u | 13281010 | 18147 us | 14526762 | 13999680 | 13999680 | mMaA | | | s | 53 | | | | | | |----------------------------------------------------------------------------------------| string-list -size 2000 ratio = 0.869 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocated | Promoted | Warnings | | | | | | d (minor | (major) | | | | | | | | ) | | | | |----------+----------+----------+----------+----------+-----------+----------+----------| | sexprep | 448852 u | 13431639 | 5102 us | 24022043 | 12070445 | 12070445 | aA | | | s | 95 | | | | | | | jsonsexp | 389965 u | 11669498 | 12089 us | 12006142 | 11999700 | 11999700 | mMaA | | | s | 81 | | | | | | |----------------------------------------------------------------------------------------| string-list -size 4000 ratio = 0.865 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocated | Promoted | Warnings | | | | | | d (minor | (major) | | | | | | | | ) | | | | |----------+----------+----------+----------+----------+-----------+----------+----------| | sexprep | 1824 ms | 54588990 | 35505 us | 96044099 | 48570240 | 48570240 | MaA | | | | 71 | | | | | | | jsonsexp | 1577 ms | 47201055 | 51981 us | 48012502 | 47999340 | 47999340 | mMaA | | | | 34 | | | | | | |----------------------------------------------------------------------------------------| record-list -size 500 ratio = 0.859 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocated | Promoted | Warnings | | | | | | d (minor | (major) | | | | | | | | ) | | | | |----------+----------+----------+----------+----------+-----------+----------+----------| | sexprep | 1311 ms | 39232505 | 52723 us | 20325631 | 6153990 | 6153990 | MaA | | | | 91 | | 5 | | | | | jsonsexp | 1126 ms | 33716165 | 50794 us | 20175203 | 5982467 | 5982467 | MaA | | | | 06 | | 2 | | | | |----------------------------------------------------------------------------------------| variant-list -size 2000 ratio = 0.744 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocated | Promoted | Warnings | | | | | | d (minor | (major) | | | | | | | | ) | | | | |----------+----------+----------+----------+----------+-----------+----------+----------| | sexprep | 1768 ms | 52934066 | 23018 us | 92004197 | 22280731 | 22280731 | MaA | | | | 59 | | | | | | | jsonsexp | 1315 ms | 39378209 | 20913 us | 63994165 | 21655849 | 21655849 | MaA | | | | 36 | | | | | | |----------------------------------------------------------------------------------------| tree -depth 20 ratio = 0.721 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocated | Allocated | Promoted | Warnings | | | | | | (minor) | (major) | | | |----------+----------+----------+---------+-----------+-----------+----------+----------| | sexprep | 437582 u | 13094413 | 6287 us | 26214439 | 3120001 | 3120001 | MA | | | s | 37 | | | | | | | jsonsexp | 315462 u | 94400255 | 6817 us | 20971546 | 3000028 | 3000028 | MaA | | | s | 7 | | | | | | |----------------------------------------------------------------------------------------| typerep-113.00.00/generics/jsonrep/lib/000077500000000000000000000000001256342456100175415ustar00rootroot00000000000000typerep-113.00.00/generics/jsonrep/lib/conv.ml000066400000000000000000000077251256342456100210530ustar00rootroot00000000000000open Core.Std module Jt = Json.Json_type exception Type_mismatch of string * Jt.t let int_of_json = function | Jt.Int n -> n | json -> raise (Type_mismatch ("Int", json)) let int32_of_json = fun json -> let fail () = raise (Type_mismatch ("Int32", json)) in match json with | Jt.Int n ->begin match Int32.of_int n with | Some x -> x | None -> fail () end | _ -> fail () let int64_of_json = function | Jt.Int n -> Int64.of_int n | json -> raise (Type_mismatch ("Int64", json)) let nativeint_of_json = function | Jt.Int n -> Nativeint.of_int n | json -> raise (Type_mismatch ("Nativeint", json)) let char_of_json = function | Jt.String c when Int.equal (String.length c) 1 -> String.get c 0 | json -> raise (Type_mismatch ("Char", json)) let float_of_json = function | Jt.Float n -> n | json -> raise (Type_mismatch ("Float", json)) let string_of_json = function | Jt.String s -> s | json -> raise (Type_mismatch ("String", json)) let bool_of_json = function | Jt.Bool b -> b | json -> raise (Type_mismatch ("Bool", json)) let unit_of_json = function | Jt.Array [] -> () | json -> raise (Type_mismatch ("Unit", json)) let option_of_json t_of_json = function | Jt.Null -> None | json -> Some (t_of_json json) let list_of_json t_of_json = function | Jt.Array jts -> List.map jts ~f:t_of_json | json -> raise (Type_mismatch ("List", json)) let array_of_json t_of_json = function | Jt.Array jts -> Array.of_list (List.map jts ~f:t_of_json) | json -> raise (Type_mismatch ("Array", json)) let lazy_t_of_json t_of_json = fun json -> Lazy.from_val (t_of_json json) let ref_of_json t_of_json = fun json -> ref (t_of_json json) let function_of_json _arg_of_json _ret_of_json = fun json -> raise (Type_mismatch ("Function",json)) let tuple2_of_json a_of_json b_of_json = function | Jt.Array [a;b] -> a_of_json a, b_of_json b | json -> raise (Type_mismatch ("Tuple2", json)) let tuple3_of_json a_of_json b_of_json c_of_json = function | Jt.Array [a;b;c] -> a_of_json a, b_of_json b, c_of_json c | json -> raise (Type_mismatch ("Tuple3", json)) let tuple4_of_json a_of_json b_of_json c_of_json d_of_json = function | Jt.Array [a;b;c;d] -> a_of_json a, b_of_json b, c_of_json c, d_of_json d | json -> raise (Type_mismatch ("Tuple4", json)) let tuple5_of_json a_of_json b_of_json c_of_json d_of_json e_of_json = function | Jt.Array [a;b;c;d;e] -> a_of_json a , b_of_json b , c_of_json c , d_of_json d , e_of_json e | json -> raise (Type_mismatch ("Tuple5", json)) let json_of_int = fun i -> Jt.Build.int i let json_of_int32 = fun i -> Jt.Build.int (Int32.to_int_exn i) let json_of_int64 = fun i -> Jt.Build.int (Int64.to_int_exn i) let json_of_nativeint = fun i -> Jt.Build.int (Nativeint.to_int_exn i) let json_of_char = fun c -> Jt.Build.string (Char.to_string c) let json_of_float = fun f -> Jt.Build.float f let json_of_string = fun s -> Jt.Build.string s let json_of_bool = fun b -> Jt.Build.bool b let json_of_unit = fun () -> Jt.Build.list ident [] let json_of_option json_of_t = function | None -> Jt.Build.null | Some t -> json_of_t t let json_of_list json_of_t = fun l -> Jt.Build.list (fun t -> json_of_t t) l let json_of_array json_of_t = fun arr -> Jt.Build.list (fun t -> json_of_t t) (Array.to_list arr) let json_of_lazy_t json_of_t = fun l -> json_of_t (Lazy.force l) let json_of_ref json_of_t = fun r -> json_of_t !r let json_of_function _json_of_arg _json_of_ref = fun _ -> Jt.Build.string "" let json_of_tuple2 json_of_a json_of_b = fun (a,b) -> Jt.Array [json_of_a a; json_of_b b] let json_of_tuple3 json_of_a json_of_b json_of_c = fun (a,b,c) -> Jt.Array [json_of_a a; json_of_b b; json_of_c c] let json_of_tuple4 json_of_a json_of_b json_of_c json_of_d = fun (a,b,c,d) -> Jt.Array [json_of_a a; json_of_b b; json_of_c c; json_of_d d] let json_of_tuple5 json_of_a json_of_b json_of_c json_of_d json_of_e = fun (a,b,c,d,e) -> Jt.Array [json_of_a a; json_of_b b; json_of_c c; json_of_d d; json_of_e e] typerep-113.00.00/generics/jsonrep/lib/conv.mli000066400000000000000000000062201256342456100212110ustar00rootroot00000000000000open Core.Std exception Type_mismatch of string * Json.Json_type.t val int_of_json : Json.Json_type.t -> int val int32_of_json : Json.Json_type.t -> int32 val int64_of_json : Json.Json_type.t -> int64 val nativeint_of_json : Json.Json_type.t -> nativeint val char_of_json : Json.Json_type.t -> char val float_of_json : Json.Json_type.t -> float val string_of_json : Json.Json_type.t -> string val bool_of_json : Json.Json_type.t -> bool val unit_of_json : Json.Json_type.t -> unit val option_of_json : (Json.Json_type.t -> 'a) -> Json.Json_type.t -> 'a option val list_of_json : (Json.Json_type.t -> 'a) -> Json.Json_type.t -> 'a list val array_of_json : (Json.Json_type.t -> 'a) -> Json.Json_type.t -> 'a array val lazy_t_of_json : (Json.Json_type.t -> 'a) -> Json.Json_type.t -> 'a lazy_t val function_of_json : (Json.Json_type.t -> 'a) -> (Json.Json_type.t -> 'b) -> Json.Json_type.t -> ('a -> 'b) val ref_of_json : (Json.Json_type.t -> 'a) -> Json.Json_type.t -> 'a ref val tuple2_of_json : (Json.Json_type.t -> 'a) -> (Json.Json_type.t -> 'b) -> Json.Json_type.t -> ('a * 'b) val tuple3_of_json : (Json.Json_type.t -> 'a) -> (Json.Json_type.t -> 'b) -> (Json.Json_type.t -> 'c) -> Json.Json_type.t -> ('a * 'b * 'c) val tuple4_of_json : (Json.Json_type.t -> 'a) -> (Json.Json_type.t -> 'b) -> (Json.Json_type.t -> 'c) -> (Json.Json_type.t -> 'd) -> Json.Json_type.t -> ('a * 'b * 'c * 'd) val tuple5_of_json : (Json.Json_type.t -> 'a) -> (Json.Json_type.t -> 'b) -> (Json.Json_type.t -> 'c) -> (Json.Json_type.t -> 'd) -> (Json.Json_type.t -> 'e) -> Json.Json_type.t -> ('a * 'b * 'c * 'd * 'e) val json_of_int : int -> Json.Json_type.t val json_of_int32 : int32 -> Json.Json_type.t val json_of_int64 : int64 -> Json.Json_type.t val json_of_nativeint : nativeint -> Json.Json_type.t val json_of_char : char -> Json.Json_type.t val json_of_float : float -> Json.Json_type.t val json_of_string : string -> Json.Json_type.t val json_of_bool : bool -> Json.Json_type.t val json_of_unit : unit -> Json.Json_type.t val json_of_option : ('a -> Json.Json_type.t) -> 'a option -> Json.Json_type.t val json_of_list : ('a -> Json.Json_type.t) -> 'a list -> Json.Json_type.t val json_of_array : ('a -> Json.Json_type.t) -> 'a array -> Json.Json_type.t val json_of_lazy_t : ('a -> Json.Json_type.t) -> 'a lazy_t -> Json.Json_type.t val json_of_ref : ('a -> Json.Json_type.t) -> 'a ref -> Json.Json_type.t val json_of_function : ('a -> Json.Json_type.t) -> ('b -> Json.Json_type.t) -> ('a -> 'b) -> Json.Json_type.t val json_of_tuple2 : ('a -> Json.Json_type.t) -> ('b -> Json.Json_type.t) -> ('a * 'b) -> Json.Json_type.t val json_of_tuple3 : ('a -> Json.Json_type.t) -> ('b -> Json.Json_type.t) -> ('c -> Json.Json_type.t) -> ('a * 'b * 'c) -> Json.Json_type.t val json_of_tuple4 : ('a -> Json.Json_type.t) -> ('b -> Json.Json_type.t) -> ('c -> Json.Json_type.t) -> ('d -> Json.Json_type.t) -> ('a * 'b * 'c * 'd) -> Json.Json_type.t val json_of_tuple5 : ('a -> Json.Json_type.t) -> ('b -> Json.Json_type.t) -> ('c -> Json.Json_type.t) -> ('d -> Json.Json_type.t) -> ('e -> Json.Json_type.t) -> ('a * 'b * 'c * 'd * 'e) -> Json.Json_type.t typerep-113.00.00/generics/jsonrep/lib/jsonrep.ml000066400000000000000000000235261256342456100215630ustar00rootroot00000000000000open Core.Std open Typerep_experimental.Std module type S = sig module Of_json : Type_generic.S with type 'a t = Json.Json_type.t -> 'a module Json_of : Type_generic.S with type 'a t = 'a -> Json.Json_type.t val t_of_json : 'a Typerep.t -> [`generic of Json.Json_type.t -> 'a] val json_of_t : 'a Typerep.t -> [`generic of 'a -> Json.Json_type.t] module Tagged : sig module Of_json : Tagged_generic.S with type 'a t = Json.Json_type.t -> 'a module Json_of : Tagged_generic.S with type 'a t = 'a -> Json.Json_type.t val t_of_json : Type_struct.t -> [ `generic of Json.Json_type.t -> Tagged.t ] val json_of_t : Type_struct.t -> [ `generic of Tagged.t -> Json.Json_type.t ] end end module C = Conv module Jt = struct (* we want [Json.Json_type.t] with sexp in order to get better error messages *) type json_type = Json.Json_type.json_type = | Object of (string * json_type) list | Array of json_type list | String of string | Int of int | Float of float | Bool of bool | Null with sexp type t = json_type with sexp include (Json.Json_type : (module type of Json.Json_type with type json_type := json_type and type t := t )) end exception Type_mismatch of string * Jt.t with sexp module Of_json_impl = struct type 'a t = Jt.t -> 'a include Type_generic.Variant_and_record_intf.M(struct type nonrec 'a t = 'a t end) let function_ arg_of_json ret_of_json = C.function_of_json arg_of_json ret_of_json let int = C.int_of_json let int32 = C.int32_of_json let int64 = C.int64_of_json let nativeint = C.nativeint_of_json let char = C.char_of_json let float = C.float_of_json let string = C.string_of_json let bool = C.bool_of_json let unit = C.unit_of_json let option = C.option_of_json let list = C.list_of_json let array = C.array_of_json let lazy_t = C.lazy_t_of_json let ref_ = C.ref_of_json let tuple2 = C.tuple2_of_json let tuple3 = C.tuple3_of_json let tuple4 = C.tuple4_of_json let tuple5 = C.tuple5_of_json ;; (* The following two functions are used by the various implementations of [record] *) let json_properties json = match json with | Jt.Object json_properties -> let seen = String.Hash_set.create () in let iter (name, _) = if Hash_set.mem seen name then raise (Type_mismatch("Record: json with duplicate key " ^ name, json)); Hash_set.add seen name; in List.iter ~f:iter json_properties; json_properties | Jt.Array values -> List.mapi values ~f:(fun index elt -> (* this automatic generation of fields name offers a way to load json types containing tuples with large arity, typically > 5 *) let field = Printf.sprintf "f%d" index in field, elt ) | _ -> raise (Type_mismatch("Record", json)) ;; let variant variant = let tag_by_label = let f index = match Variant.tag variant index with | (Variant.Tag tag) as data -> Tag.label tag, data in Flat_map.Flat_string_map.init (Variant.length variant) ~f in let t_of_json json = let fail () = raise (Type_mismatch ("Variant",json)) in match json with | Jt.String label -> begin match Flat_map.Flat_string_map.find tag_by_label label with | None -> fail () | Some (Variant.Tag tag) -> begin match Tag.create tag with | Tag.Const const -> const | Tag.Args _ -> fail () end end | Jt.Array ((Jt.String label)::jt_values) -> begin match Flat_map.Flat_string_map.find tag_by_label label with | None -> fail () | Some (Variant.Tag tag) -> begin match Tag.create tag with | Tag.Args create -> let arity = Tag.arity tag in let jt_value = if arity = 1 then match jt_values with | [jt_value] -> jt_value | _ -> fail () else Jt.Array jt_values in create (Tag.traverse tag jt_value) | Tag.Const _ -> fail () end end | _ -> fail () in t_of_json ;; module Named = Type_generic.Make_named_for_closure(struct type 'a input = Jt.t type 'a output = 'a type 'a t = Jt.t -> 'a end) end module Json_of_impl = struct type 'a t = 'a -> Jt.t include Type_generic.Variant_and_record_intf.M(struct type nonrec 'a t = 'a t end) let int = C.json_of_int let int32 = C.json_of_int32 let int64 = C.json_of_int64 let nativeint = C.json_of_nativeint let char = C.json_of_char let float = C.json_of_float let string = C.json_of_string let bool = C.json_of_bool let unit = C.json_of_unit let option = C.json_of_option let list = C.json_of_list let array = C.json_of_array let lazy_t = C.json_of_lazy_t let ref_ = C.json_of_ref let function_ = C.json_of_function let tuple2 = C.json_of_tuple2 let tuple3 = C.json_of_tuple3 let tuple4 = C.json_of_tuple4 let tuple5 = C.json_of_tuple5 let variant variant = (* preallocation of atoms *) let atoms = Array.init (Variant.length variant) ~f:(fun index -> match Variant.tag variant index with | Variant.Tag tag -> Jt.Build.string (Tag.label tag) ) in fun value -> match Variant.value variant value with | Variant.Value (tag, args) -> let index = Tag.index tag in let arity = Tag.arity tag in let atom = atoms.(index) in match arity with | 0 -> atom | 1 -> Jt.Array [atom ; Tag.traverse tag args] | _ -> match Tag.traverse tag args with | Jt.Array values -> Jt.Array (atom::values) | _ -> assert false module Named = Type_generic.Make_named_for_closure(struct type 'a input = 'a type 'a output = Jt.t type 'a t = 'a -> Jt.t end) end module type X_record = sig val version : int module Of_json : sig val record : 'a Of_json_impl.Record.t -> 'a Of_json_impl.t end module Json_of : sig val record : 'a Json_of_impl.Record.t -> 'a Json_of_impl.t end end module Make(X:X_record) = struct module Of_json = Type_generic.Make(struct include Of_json_impl include X.Of_json let name = sprintf "of_json_v%d" X.version let required = [] end) module Json_of = Type_generic.Make(struct include Json_of_impl include X.Json_of let name = sprintf "json_of_v%d" X.version let required = [] end) let t_of_json = Of_json.of_typerep let json_of_t = Json_of.of_typerep module Tagged = struct module Of_json = Tagged_generic.Make_input (Jt)(Of_json.Computation) module Json_of = Tagged_generic.Make_output(Jt)(Json_of.Computation) let t_of_json = Of_json.of_typestruct let json_of_t = Json_of.of_typestruct end end module V2 = Make(struct let version = 2 module Of_json = struct open Of_json_impl let record record = fun json -> let json_properties = json_properties json in let properties = lazy (Flat_map.Flat_string_map.of_alist json_properties) in let get field = let label = Field.label field in let index = Field.index field in let json_value = match List.nth json_properties index with | Some (json_name, json_value) when String.equal json_name label -> json_value | Some _ | None -> match Flat_map.Flat_string_map.find (Lazy.force properties) label with | Some x -> x | None -> Jt.Null in try Field.traverse field json_value with | exn -> failwiths "Exception while deserializing field" (label, json, exn) <:sexp_of< string * Jt.t * Exn.t>> in Record.create record { Record.get } ;; end module Json_of = struct open Json_of_impl let record record value = let rec aux acc index = if index < 0 then Jt.Build.objekt acc else let acc = match Record.field record index with | Record.Field field -> match Field.traverse field (Field.get field value) with | Jt.Null -> acc | json -> (Field.label field, json) :: acc in aux acc (pred index) in aux [] (pred (Record.length record)) ;; end end) module V1 = Make(struct let version = 1 module Of_json = struct open Of_json_impl let record record = fun json -> let json_properties = json_properties json in let properties = lazy (Flat_map.Flat_string_map.of_alist json_properties) in let get field = let label = Field.label field in let index = Field.index field in let json_value = match List.nth json_properties index with | Some (json_name, json_value) -> if String.equal json_name label then json_value else begin match Flat_map.Flat_string_map.find (Lazy.force properties) label with | Some x -> x | None -> failwithf "Field %s is present in the destination record but not in the \ source JSON." label () end | _ -> failwithf "Source JSON has %d fields, while destination record has more." (index + 1) () in Field.traverse field json_value in Record.create record { Record.get } end module Json_of = struct open Json_of_impl let record record value = let rec aux acc index = if index < 0 then Jt.Build.objekt acc else let field = match Record.field record index with | Record.Field field -> let label = Field.label field in label, Field.traverse field (Field.get field value) in aux (field::acc) (pred index) in aux [] (pred (Record.length record)) end end) typerep-113.00.00/generics/jsonrep/lib/jsonrep.mli000066400000000000000000000036401256342456100217270ustar00rootroot00000000000000open Core.Std open Typerep_experimental.Std module type S = sig module Of_json : Type_generic.S with type 'a t = Json.Json_type.t -> 'a module Json_of : Type_generic.S with type 'a t = 'a -> Json.Json_type.t val t_of_json : 'a Typerep.t -> [`generic of Json.Json_type.t -> 'a] val json_of_t : 'a Typerep.t -> [`generic of 'a -> Json.Json_type.t] module Tagged : sig module Of_json : Tagged_generic.S with type 'a t = Json.Json_type.t -> 'a module Json_of : Tagged_generic.S with type 'a t = 'a -> Json.Json_type.t val t_of_json : Type_struct.t -> [ `generic of Json.Json_type.t -> Tagged.t ] val json_of_t : Type_struct.t -> [ `generic of Tagged.t -> Json.Json_type.t ] end end (** The difference between both implementation is their behavior while {de}serializing optional fields in records. Optional fields meaning a field in a record of type [_ option]. v1 => will create the fields, putting Json.Null as the value. will expect also the field to be there with value Null during deserialization. v2 => the fields will not be present v1 was the original behavior, and is closer to a strictly typed kind of language, but it turns out it is actually a pain to use in practice. v2 is used by some serialization frameworks to indicate the absence of an object instead of Null. Note that the deserializer of V2 is backward compatible in that it can read json records serialized with V1. That is, V2 supports optional fields present with value Null. Example: {[ type t = { a : int option; } with typerep V1.json_of_t { a = None } ==> Jt.Object [ "a", Jt.Null ] V2.json_of_t { a = None } ==> Jt.Object [ ] V1.t_of_json (Jt.Object [ "a", Jt.Null ]) ==> { a = None } V2.t_of_json (Jt.Object [ "a", Jt.Null ]) ==> { a = None } V1.t_of_json (Jt.Object []) ==> FAIL V2.t_of_json (Jt.Object []) ==> { a = None } ]} *) module V1 : S module V2 : S typerep-113.00.00/generics/jsonrep/lib/std.ml000066400000000000000000000000541256342456100206640ustar00rootroot00000000000000module Jsonrep = Jsonrep module Conv = Conv typerep-113.00.00/generics/jsonrep/test/000077500000000000000000000000001256342456100177525ustar00rootroot00000000000000typerep-113.00.00/generics/jsonrep/test/test_jsonrep.ml000066400000000000000000000064361256342456100230340ustar00rootroot00000000000000open Core.Std open Typerep_experimental.Std open Json_typerep.Jsonrep module Jt = Json.Json_type TEST_MODULE = struct type x = | Foo | Bar of int | Baz of float * float with typerep type mrec = { foo: int; bar: float } with typerep type tree = Leaf | Node of tree * tree with typerep let test_json x typerep_of_x = let test t_of_json json_of_t = let `generic x_of_json = t_of_json typerep_of_x in let `generic json_of_x = json_of_t typerep_of_x in Polymorphic_compare.equal x (x_of_json (json_of_x x)) in test V1.t_of_json V1.json_of_t && test V2.t_of_json V2.json_of_t && test V2.t_of_json V1.json_of_t ;; TEST_UNIT = assert(test_json 5 typerep_of_int) TEST_UNIT = assert(test_json 'm' typerep_of_char) TEST_UNIT = assert(test_json 5.0 typerep_of_float) TEST_UNIT = assert(test_json "hello, world" typerep_of_string) TEST_UNIT = assert(test_json true typerep_of_bool) TEST_UNIT = assert(test_json false typerep_of_bool) TEST_UNIT = assert(test_json () typerep_of_unit) TEST_UNIT = assert(test_json None (typerep_of_option typerep_of_int)) TEST_UNIT = assert(test_json (Some 42) (typerep_of_option typerep_of_int)) TEST_UNIT = assert(test_json [1;2;3;4;5] (typerep_of_list typerep_of_int)) TEST_UNIT = assert(test_json [|6;7;8;9;19|] (typerep_of_array typerep_of_int)) TEST_UNIT = assert(test_json (52,78) (typerep_of_tuple2 typerep_of_int typerep_of_int)) TEST_UNIT = assert(test_json (52,78,89) (typerep_of_tuple3 typerep_of_int typerep_of_int typerep_of_int)) TEST_UNIT = assert(test_json (52,78,89, "hi") (typerep_of_tuple4 typerep_of_int typerep_of_int typerep_of_int typerep_of_string)) TEST_UNIT = assert(test_json (52,78,89, "hi",false) (typerep_of_tuple5 typerep_of_int typerep_of_int typerep_of_int typerep_of_string typerep_of_bool)) TEST_UNIT = assert(test_json Foo typerep_of_x) TEST_UNIT = assert(test_json (Bar 9) typerep_of_x) TEST_UNIT = assert(test_json (Baz (6.2, 7.566)) typerep_of_x) TEST_UNIT = assert(test_json {foo=5;bar=76.2} typerep_of_mrec) TEST_UNIT = assert(test_json (Node ((Node ((Node (Leaf, Leaf)), Leaf)), Leaf)) typerep_of_tree) end TEST_MODULE = struct module Jt = Json.Json_type type t = { a : int option; } with typerep let `generic t_of_json_v1 = V1.t_of_json typerep_of_t let `generic json_of_t_v1 = V1.json_of_t typerep_of_t let `generic t_of_json_v2 = V2.t_of_json typerep_of_t let `generic json_of_t_v2 = V2.json_of_t typerep_of_t module Ocaml = struct let some = { a = Some 42 } let none = { a = None } end module Json = struct let some = Jt.Object [ "a", Jt.Int 42 ] let none_with = Jt.Object [ "a", Jt.Null ] let none_sans = Jt.Object [] end TEST = json_of_t_v1 Ocaml.none = Json.none_with TEST = json_of_t_v2 Ocaml.none = Json.none_sans TEST = json_of_t_v1 Ocaml.some = Json.some TEST = json_of_t_v2 Ocaml.some = Json.some TEST = t_of_json_v2 Json.none_sans = Ocaml.none TEST = t_of_json_v1 Json.none_with = Ocaml.none TEST = t_of_json_v2 Json.none_with = Ocaml.none TEST = t_of_json_v1 Json.some = Ocaml.some TEST = t_of_json_v2 Json.some = Ocaml.some end typerep-113.00.00/generics/sexprep/000077500000000000000000000000001256342456100170015ustar00rootroot00000000000000typerep-113.00.00/generics/sexprep/benchmarks/000077500000000000000000000000001256342456100211165ustar00rootroot00000000000000typerep-113.00.00/generics/sexprep/benchmarks/bench_sexprep.ml000066400000000000000000000303541256342456100243020ustar00rootroot00000000000000open Core.Std module Bench = Core_extended.Deprecated_bench open Typerep_experimental.Std let int_list_command = Command.basic ~summary:"sexprep benchmarks" Command.Spec.( empty +> flag "-size" (optional_with_default 2000 int) ~doc:"Size of list to deserialize (default 2000)" +> flag "-serial" no_arg ~doc:"direction of test: serialization or deserialization (default deserial)" ) (fun size is_serial () -> let module M = struct type 'a t = 'a list list with typerep, sexp end in let list_of_int = List.init size ~f:ident in let values = List.init ~f:(fun _ -> list_of_int) size in let `generic x_of_sexp = Sexprep.t_of_sexp (M.typerep_of_t typerep_of_int) in let `generic sexp_of_x = Sexprep.sexp_of_t (M.typerep_of_t typerep_of_int) in let untyped_values = let `generic untyped_of_t = Tagged.Of_typed.of_typerep (M.typerep_of_t typerep_of_int) in untyped_of_t values in let `generic un_of_sexp = Sexprep.Tagged.Of_sexp.of_typestruct (Type_struct.of_typerep (M.typerep_of_t typerep_of_int)) in let `generic sexp_of_un = Sexprep.Tagged.Sexp_of.of_typestruct (Type_struct.of_typerep (M.typerep_of_t typerep_of_int)) in let sexp = M.sexp_of_t sexp_of_int values in let tests = if is_serial then [ Bench.Test.create ~name:"sexprep" (fun () -> let _sexp = sexp_of_x values in ()) ; Bench.Test.create ~name:"untyped" (fun () -> let _sexp = sexp_of_un untyped_values in ()) ; Bench.Test.create ~name:"withsexp" (fun () -> let _sexp = M.sexp_of_t sexp_of_int values in ())] else [ Bench.Test.create ~name:"sexprep" (fun () -> let _values = x_of_sexp sexp in ()) ; Bench.Test.create ~name:"untyped" (fun () -> let _values = un_of_sexp sexp in ()) ; Bench.Test.create ~name:"withsexp" (fun () -> let _values = M.t_of_sexp int_of_sexp sexp in ())] in Bench.bench ~verbosity:`Mid tests ) let record_list_command = Command.basic ~summary:"sexprep benchmarks" Command.Spec.( empty +> flag "-size" (optional_with_default 2000 int) ~doc:"Size of list to deserialize (default 2000)" +> flag "-reorder" no_arg ~doc:"Whether to reorder the sexps before deserialization" +> flag "-serial" no_arg ~doc:"direction of test: serialization or deserialization (default deserial)" ) (fun size reorder is_serial () -> let module M = struct type 'a r = { one:'a; two:int; three:'a; four:int; five:'a; six:int; seven:'a; eight:int; nine:'a; ten:int; eleven:'a; twelve:int; thirteen:'a; fourteen:int; fiveteen:'a; sixteen:int; seventeen:'a; eighteen:int; nineteen:'a; twenty:int; } with typerep, sexp type 'a t = 'a r list list with typerep, sexp end in let list_of_record = List.init size ~f:(fun n -> { M.one="hello"; two=n; three="hello"; four=n; five="hello"; six=n; seven="hello"; eight=n; nine="hello"; ten=n; eleven="hello"; twelve=n; thirteen="hello"; fourteen=n; fiveteen="hello"; sixteen=n; seventeen="hello"; eighteen=n; nineteen="hello"; twenty=n; }) in let values = List.init ~f:(fun _ -> list_of_record) size in let initial_sexp = M.sexp_of_t (sexp_of_string) values in let sexp = if reorder then match initial_sexp with | Sexp.List list_lists_of_recs -> Sexp.List (List.map list_lists_of_recs ~f:(function | Sexp.List list_recs -> Sexp.List (List.permute list_recs) | _ -> raise (Failure "failed before tests: unexpected sexp structure"))) | _ -> raise (Failure "failed before tests: unexpected sexp structure") else initial_sexp in let `generic sexp_of_x = Sexprep.sexp_of_t (M.typerep_of_t typerep_of_string) in let `generic x_of_sexp = Sexprep.t_of_sexp (M.typerep_of_t typerep_of_string) in let untyped_values = let `generic untyped_of_t = Tagged.Of_typed.of_typerep (M.typerep_of_t typerep_of_string) in untyped_of_t values in let `generic un_of_sexp = Sexprep.Tagged.Of_sexp.of_typestruct (Type_struct.of_typerep (M.typerep_of_t typerep_of_string)) in let `generic sexp_of_un = Sexprep.Tagged.Sexp_of.of_typestruct (Type_struct.of_typerep (M.typerep_of_t typerep_of_string)) in let tests = if is_serial then [ Bench.Test.create ~name:"sexprep" (fun () -> let _sexp = sexp_of_x values in ()) ; Bench.Test.create ~name:"untyped" (fun () -> let _sexp = sexp_of_un untyped_values in ()) ; Bench.Test.create ~name:"withsexp" (fun () -> let _sexp = M.sexp_of_t sexp_of_string values in ())] else [ Bench.Test.create ~name:"sexprep" (fun () -> let _values = x_of_sexp sexp in ()) ; Bench.Test.create ~name:"untyped" (fun () -> let _values = un_of_sexp sexp in ()) ; Bench.Test.create ~name:"withsexp" (fun () -> let _values = M.t_of_sexp string_of_sexp sexp in ())] in Bench.bench ~verbosity:`Mid tests ) let variant_list_command = Command.basic ~summary:"sexprep benchmarks" Command.Spec.( empty +> flag "-size" (optional_with_default 2000 int) ~doc:"Size of list to (de)serialize (default 2000)" +> flag "-serial" no_arg ~doc:"direction of test: serialization or deserialization (default deserial)" ) (fun size is_serial () -> let module M = struct type v = | Foo | Bar of int | Baz of int * int with typerep, sexp type t = v list list with typerep, sexp end in let values = List.init size ~f:(fun _ -> List.init size ~f:(fun n -> if Int.equal n 0 then M.Foo else if Int.equal (n % 2) 0 then M.Bar n else M.Baz (n,n-1))) in let `generic sexp_of_x = Sexprep.sexp_of_t M.typerep_of_t in let `generic x_of_sexp = Sexprep.t_of_sexp M.typerep_of_t in let untyped_values = let `generic untyped_of_t = Tagged.Of_typed.of_typerep M.typerep_of_t in untyped_of_t values in let `generic un_of_sexp = Sexprep.Tagged.Of_sexp.of_typestruct (Type_struct.of_typerep M.typerep_of_t) in let `generic sexp_of_un = Sexprep.Tagged.Sexp_of.of_typestruct (Type_struct.of_typerep M.typerep_of_t) in let sexp = M.sexp_of_t values in let tests = if is_serial then [ Bench.Test.create ~name:"sexprep" (fun () -> let _sexp = sexp_of_x values in ()) ; Bench.Test.create ~name:"untyped" (fun () -> let _sexp = sexp_of_un untyped_values in ()) ; Bench.Test.create ~name:"withsexp" (fun () -> let _sexp = M.sexp_of_t values in ()) ] else [ Bench.Test.create ~name:"sexprep" (fun () -> let _values = x_of_sexp sexp in ()) ; Bench.Test.create ~name:"untyped" (fun () -> let _values = un_of_sexp sexp in ()) ; Bench.Test.create ~name:"withsexp" (fun () -> let _values = M.t_of_sexp sexp in ())] in Bench.bench ~verbosity:`Mid tests ) let tree_command = Command.basic ~summary:"sexprep benchmarks" Command.Spec.( empty +> flag "-depth" (optional_with_default 20 int) ~doc:"Depth of tree to serialize (default 20)" +> flag "-serial" no_arg ~doc:"direction of test: serialization or deserialization (default deserial)" ) (fun size is_serial () -> let module M = struct type t = | Leaf | Green_Node of t * t | Red_Node of t * t | Black_Node of t * t | Blue_Node of t * t | Node2 of t * t | Node_2 of t * t | Binary_Node of t * t | Foo | Bar | Baz | Bax with typerep, sexp end in let rec producer n = if n > 0 then M.Node2 (producer (n-1), producer (n-1)) else M.Leaf in let values = producer size in let sexp = M.sexp_of_t values in let `generic x_of_sexp = Sexprep.t_of_sexp M.typerep_of_t in let `generic sexp_of_x = Sexprep.sexp_of_t M.typerep_of_t in let untyped_values = let `generic untyped_of_t = Tagged.Of_typed.of_typerep M.typerep_of_t in untyped_of_t values in let `generic un_of_sexp = Sexprep.Tagged.Of_sexp.of_typestruct (Type_struct.of_typerep M.typerep_of_t) in let `generic sexp_of_un = Sexprep.Tagged.Sexp_of.of_typestruct (Type_struct.of_typerep M.typerep_of_t) in let tests = if is_serial then [ Bench.Test.create ~name:"sexprep" (fun () -> let _sexp = sexp_of_x values in ()) ; Bench.Test.create ~name:"untyped" (fun () -> let _sexp = sexp_of_un untyped_values in ()) ; Bench.Test.create ~name:"withsexp" (fun () -> let _sexp = M.sexp_of_t values in ())] else [ Bench.Test.create ~name:"sexprep" (fun () -> let _values = x_of_sexp sexp in ()) ; Bench.Test.create ~name:"untyped" (fun () -> let _values = un_of_sexp sexp in ()) ; Bench.Test.create ~name:"withsexp" (fun () -> let _values = M.t_of_sexp sexp in ())] in Bench.bench ~verbosity:`Mid tests ) let allocate_small_maps = Command.basic ~summary:"sexprep benchmarks" Command.Spec.( empty +> flag "-size" (optional_with_default 1000 int) ~doc:"Number of times to repeat test (default 1000)" +> flag "-mapsize" (optional_with_default 10 int) ~doc:"Size of map to build (default 10)" ) (fun size small_map_size () -> let values = List.init small_map_size ~f:(fun n -> Int.to_string n, n) in let tries = List.init size ~f:ident in Bench.bench ~verbosity:`Mid [ Bench.Test.create ~name:"flat_map" (fun () -> let _map = List.map tries ~f:(fun _ -> Flat_map.Flat_string_map.of_alist values) in ()) ; Bench.Test.create ~name:"string map" (fun () -> let _value = List.map tries ~f:(fun _ -> String.Map.of_alist values) in ()); ] ) let look_up_maps = Command.basic ~summary:"sexprep benchmarks" Command.Spec.( empty +> flag "-size" (optional_with_default 1000 int) ~doc:"Number of times to repeat test (default 1000)" +> flag "-mapsize" (optional_with_default 10 int) ~doc:"Size of map to build (default 10)" ) (fun size small_map_size () -> let values = List.init small_map_size ~f:(fun n -> Int.to_string n, n) in let flat_map = Flat_map.Flat_string_map.of_alist values in let string_map = String.Map.of_alist_exn values in let goals = List.init size ~f:(fun _ -> List.map values ~f:(fun (key,_value) -> key)) in Bench.bench ~verbosity:`Mid [ Bench.Test.create ~name:"flat_map opt_to_exn" (fun () -> let _values = List.map goals ~f:(fun goal_list -> List.map goal_list ~f:(fun goal -> match Flat_map.Flat_string_map.find flat_map goal with | None -> raise (Failure "invalid sexp") | Some x -> x)) in ()) ; Bench.Test.create ~name:"string_map" (fun () -> let _valued = List.map goals ~f:(fun goal_list -> List.map goal_list ~f:(fun goal -> String.Map.find string_map goal)) in ()); ] ) let command = Command.group ~summary:"Benchmarks" [ "int-list", int_list_command; "record-list", record_list_command; "variant-list", variant_list_command; "tree", tree_command; "look-ups", look_up_maps; "small-maps", allocate_small_maps; ] let () = Exn.handle_uncaught ~exit:true (fun () -> Command.run command) typerep-113.00.00/generics/sexprep/benchmarks/results.txt000066400000000000000000001637211256342456100233720ustar00rootroot00000000000000 ./bench_sexprep.exe tree -serial ratio untyped to sexrep = 0.891 * old untyped is not included because it does not handle the Named case. |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocated | Promoted | Warnings | | | | | | d (minor | (major) | | | | | | | | ) | | | | |----------+----------+----------+----------+----------+-----------+----------+----------| | sexprep | 1161 ms | 34756695 | 22491 us | 15309242 | 13635467 | 13635467 | MaA | | | | 37 | | 1 | | | | | untyped | 1035 ms | 31000481 | 10369 us | 77594712 | 13535497 | 13535497 | aA | | | | 31 | | | | | | | withsexp | 313465 u | 93802670 | 6544 us | 11534367 | 10999799 | 10999799 | MaA | | | s | 6 | | | | | | |----------------------------------------------------------------------------------------| ./bench_sexprep.exe tree ratio untyped to sexrep = 1.233 * old untyped is not included because it does not handle the Named case. |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocated | Allocated | Promoted | Warnings | | | | | | (minor) | (major) | | | |----------+----------+----------+---------+-----------+-----------+----------+----------| | sexprep | 477334 u | 14283967 | 9020 us | 47185990 | 3133501 | 3133501 | MaA | | | s | 44 | | | | | | | untyped | 588492 u | 17610295 | 9045 us | 36700213 | 7199982 | 7199982 | aA | | | s | 43 | | | | | | | withsexp | 302620 u | 90557325 | 3654 us | 3145759 | 2999808 | 2999808 | aA | | | s | 8 | | | | | | |----------------------------------------------------------------------------------------| Benchmark Results 7/30/2012: Sexprep vs Sexprep.Untyped.t_of_sexp2/sexp_of_t2 ./bench_sexprep.exe variant-list -serial ratio untyped to sexrep = 0.918 ratio untyped to old untyped = 1.119 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocated | Promoted | Warnings | | | | | | d (minor | (major) | | | | | | | | ) | | | | |----------+----------+----------+----------+----------+-----------+----------+----------| | sexprep | 5123 ms | 15331679 | 337639 u | 34001922 | 83001501 | 83001501 | MaA | | | | 836 | s | 2 | | | | | untyped | 4703 ms | 14075900 | 99008 us | 22401838 | 83255128 | 83255128 | MA | | | | 629 | | 7 | | | | | old unty | 4201 ms | 12571393 | 143186 u | 13600423 | 82733393 | 82733393 | MaA | | ped | | 944 | s | 8 | | | | | withsexp | 3361 ms | 10058669 | 175148 u | 86002087 | 74246327 | 74246327 | MaA | | | | 787 | s | | | | | |----------------------------------------------------------------------------------------| ./bench_sexprep.exe record-list -serial -size 500 ratio untyped to sexrep = 1.076 ratio untyped to old untyped = 0.994 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocated | Promoted | Warnings | | | | | | d (minor | (major) | | | | | | | | ) | | | | |----------+----------+----------+----------+----------+-----------+----------+----------| | sexprep | 2769 ms | 82867811 | 35687 us | 94756676 | 80676625 | 80676625 | MaA | | | | 97 | | | | | | | untyped | 2979 ms | 89145484 | 35933 us | 99010674 | 81392341 | 81392341 | MaA | | | | 95 | | | | | | | old unty | 2998 ms | 89716358 | 122643 u | 90510777 | 80931931 | 80931931 | MaA | | ped | | 22 | s | | | | | | withsexp | 2768 ms | 82847769 | 84510 us | 72006921 | 71302599 | 71302599 | McaA | | | | 50 | | | | | | |----------------------------------------------------------------------------------------| ./bench_sexprep.exe int-list -serial ratio untyped to sexrep = 1.027 ratio untyped to old untyped = 1.006 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocated | Promoted | Warnings | | | | | | d (minor | (major) | | | | | | | | ) | | | | |----------+----------+----------+----------+----------+-----------+----------+----------| | sexprep | 1529 ms | 45778235 | 16717 us | 40026049 | 28115730 | 28115730 | MaA | | | | 86 | | | | | | | untyped | 1570 ms | 46998489 | 16342 us | 52042086 | 28235518 | 28235518 | MaA | | | | 38 | | | | | | | old unty | 1561 ms | 46715670 | 13895 us | 52042086 | 28235518 | 28235518 | MaA | | ped | | 19 | | | | | | | withsexp | 1661 ms | 49727241 | 7169 us | 40026058 | 28115718 | 28115718 | caA | | | | 97 | | | | | | |----------------------------------------------------------------------------------------| ./bench_sexprep.exe variant-list ratio untyped to sexrep = 1.361 ratio untyped to old untyped = 0.850 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocated | Promoted | Warnings | | | | | | d (minor | (major) | | | | | | | | ) | | | | |----------+----------+----------+----------+----------+-----------+----------+----------| | sexprep | 1778 ms | 53233153 | 11525 us | 13200425 | 22400353 | 22400353 | aA | | | | 03 | | 5 | | | | | untyped | 2419 ms | 72395329 | 32638 us | 13200621 | 42438999 | 38434996 | aA | | | | 38 | | 9 | | | | | old unty | 2846 ms | 85173584 | 59671 us | 50997069 | 54000073 | 49996070 | MA | | ped | | 70 | | 6 | | | | | withsexp | 1186 ms | 35497586 | 5029 us | 34018071 | 22099098 | 22099098 | aA | | | | 15 | | | | | | |----------------------------------------------------------------------------------------| ./bench_sexprep.exe record-list -size 1000 ratio untyped to sexrep = 1.389 ratio untyped to old untyped = 0.586 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocated | Promoted | Warnings | | | | | | d (minor | (major) | | | | | | | | ) | | | | |----------+----------+----------+----------+----------+-----------+----------+----------| | sexprep | 5088 ms | 15228289 | 41985 us | 81301361 | 25246681 | 25246681 | aA | | | | 391 | | 9 | | | | | untyped | 7067 ms | 21148906 | 86477 us | 46001804 | 127004034 | 12600203 | MA | | | | 384 | | 4 | | 1 | | | old unty | 12058 ms | 36083488 | 61687 us | 77803066 | 127004126 | 12600212 | A | | ped | | 194 | | 7 | | 3 | | | withsexp | 4099 ms | 12267042 | 21291 us | 13801728 | 24211549 | 24211549 | aA | | | | 659 | | 9 | | | | |----------------------------------------------------------------------------------------| ./bench_sexprep.exe int-list ratio untyped to sexrep = 1.719 ratio untyped to old untyped = 1.023 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocated | Promoted | Warnings | | | | | | d (minor | (major) | | | | | | | | ) | | | | |----------+----------+----------+----------+----------+-----------+----------+----------| | sexprep | 555664 u | 16627954 | 5988 us | 24022043 | 12070445 | 12070445 | aA | | | s | 37 | | | | | | | untyped | 955213 u | 28584185 | 52511 us | 32036044 | 24008034 | 20004031 | mMA | | | s | 96 | | | | | | | old unty | 934281 u | 27957805 | 27228 us | 56058379 | 24008043 | 20004040 | MA | | ped | s | 05 | | | | | | | withsexp | 586697 u | 17556564 | 4720 us | 24022049 | 12070444 | 12070444 | aA | | | s | 05 | | | | | | |----------------------------------------------------------------------------------------| Benchmark Results 7/30/2012: Exn vs Option for Flat_map ./bench_sexprep.exe look-ups -size 1000000 runtime ratio exn to opt = 0.981 minor mem ratio exn to opt = 0.667 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocate | Promoted | Warnings | | | | | | d (minor | d (major | | | | | | | | ) | ) | | | |-----------+----------+----------+----------+----------+----------+----------+----------| | flat_map_ | 2232 ms | 66806823 | 13500 us | 39985051 | 34985005 | 34985005 | aA | | exn try_w | | 30 | | | | | | | ith | | | | | | | | | flat_map | 2276 ms | 68121454 | 185822 u | 59985206 | 34985093 | 34985093 | MaA | | opt_to_ex | | 33 | s | | | | | | n | | | | | | | | | string_ma | 2677 ms | 80109444 | 47696 us | 59985206 | 54985093 | 54985093 | MaA | | p | | 82 | | | | | | |----------------------------------------------------------------------------------------| ./bench_sexprep.exe look-ups -size 100000 ratio exn to opt = 0.973 minor mem ratio exn to opt = 0.666 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocate | Promoted | Warnings | | | | | | d (minor | d (major | | | | | | | | ) | ) | | | |-----------+----------+----------+----------+----------+----------+----------+----------| | flat_map_ | 196729 u | 58870358 | 16711 us | 3985015 | 2673882 | 2673882 | mMaA | | exn try_w | s | 6 | | | | | | | ith | | | | | | | | | flat_map | 202118 u | 60482891 | 5874 us | 5985026 | 2888307 | 2888307 | MaA | | opt_to_ex | s | 1 | | | | | | | n | | | | | | | | | string_ma | 270271 u | 80877244 | 35319 us | 5985026 | 4647887 | 4647887 | mMaA | | p | s | 0 | | | | | | |----------------------------------------------------------------------------------------| Benchmark Results 7/27/2012: tree -serial -depth 20 ratio = 3.216 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocated | Promoted | Warnings | | | | | | d (minor | (major) | | | | | | | | ) | | | | |----------+----------+----------+----------+----------+-----------+----------+----------| | sexprep | 1007 ms | 30148428 | 32480 us | 13212088 | 15724802 | 15724802 | MaA | | | | 94 | | 4 | | | | | withsexp | 313123 u | 93700401 | 7130 us | 11534367 | 10999799 | 10999799 | MaA | | | s | 4 | | | | | | |----------------------------------------------------------------------------------------| variant-list -size 1000 -serial (variants of arity 12) ratio = 1.591 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocated | Promoted | Warnings | | | | | | d (minor | (major) | | | | | | | | ) | | | | |----------+----------+----------+----------+----------+-----------+----------+----------| | sexprep | 1226 ms | 36710638 | 25322 us | 79001188 | 20614603 | 20614603 | MaA | | | | 72 | | | | | | | withsexp | 770649 u | 23061220 | 11661 us | 21501120 | 18095199 | 18095199 | MA | | | s | 21 | | | | | | |----------------------------------------------------------------------------------------| variant-list -size 1000 -serial (variants of arity 3) ratio = 1.499 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocated | Promoted | Warnings | | | | | | d (minor | (major) | | | | | | | | ) | | | | |----------+----------+----------+----------+----------+-----------+----------+----------| | sexprep | 1145 ms | 34274917 | 12808 us | 79001188 | 20614603 | 20614603 | MaA | | | | 30 | | | | | | | withsexp | 763634 u | 22851311 | 10258 us | 21501120 | 18095199 | 18095199 | MA | | | s | 33 | | | | | | |----------------------------------------------------------------------------------------| variant-list -size 2000 ratio = 1.469 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocated | Allocated | Promoted | Warnings | | | | | | (minor) | (major) | | | |----------+----------+----------+---------+-----------+-----------+----------+----------| | sexprep | 1688 ms | 50539213 | 7358 us | 92004197 | 22280731 | 22280731 | aA | | | | 33 | | | | | | | withsexp | 1149 ms | 34412378 | 6060 us | 34018071 | 22099098 | 22099098 | aA | | | | 55 | | | | | | |----------------------------------------------------------------------------------------| record-list-deserial -size 1000 -reorder ratio = 1.252 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocate | Promoted | Warnings | | | | | | d (minor | d (major | | | | | | | | ) | ) | | | |-----------+----------+----------+----------+----------+----------+----------+----------| | with sexp | 4217 ms | 12619620 | 33682 us | 13801728 | 24211549 | 24211549 | aA | | deserial | | 421 | | 9 | | | | | ize recor | | | | | | | | | d list li | | | | | | | | | st | | | | | | | | | deseriali | 5281 ms | 15805386 | 214960 u | 81301361 | 25246681 | 25246681 | MaA | | ze2 recor | | 394 | s | 9 | | | | | d list li | | | | | | | | | st | | | | | | | | |----------------------------------------------------------------------------------------| Benchmark Results 7/26/2012: Serialization in Make2 int-list-serial -size 2000 ratio = 1.0 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocate | Promoted | Warnings | | | | | | d (minor | d (major | | | | | | | | ) | ) | | | |-----------+----------+----------+----------+----------+----------+----------+----------| | serialize | 1657 ms | 49586156 | 7719 us | 40026049 | 28115730 | 28115730 | caA | | int list | | 07 | | | | | | | list | | | | | | | | | with sexp | 1657 ms | 49606935 | 10535 us | 40026058 | 28115718 | 28115718 | caA | | serializ | | 27 | | | | | | | e int lis | | | | | | | | | t list | | | | | | | | |----------------------------------------------------------------------------------------| record-list-serial -size 500 ratio = 1.223 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocate | Promoted | Warnings | | | | | | d (minor | d (major | | | | | | | | ) | ) | | | |-----------+----------+----------+----------+----------+----------+----------+----------| | serialize | 3475 ms | 10399249 | 50105 us | 10125668 | 81128806 | 81128593 | McaA | | record l | | 547 | | 1 | | | | | ist list | | | | | | | | | with sexp | 2842 ms | 85053603 | 91908 us | 72006921 | 71302599 | 71302599 | McaA | | serializ | | 93 | | | | | | | e record | | | | | | | | | list list | | | | | | | | |----------------------------------------------------------------------------------------| tree-serial ratio = 3.221 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocate | Promoted | Warnings | | | | | | d (minor | d (major | | | | | | | | ) | ) | | | |-----------+----------+----------+----------+----------+----------+----------+----------| | serialize | 1018 ms | 30475372 | 21694 us | 13212088 | 15724802 | 15724802 | MaA | | tree | | 13 | | 4 | | | | | with sexp | 316006 u | 94563073 | 6871 us | 11534367 | 10999799 | 10999799 | MaA | | serializ | s | 5 | | | | | | | e tree | | | | | | | | |----------------------------------------------------------------------------------------| Benchmark Results 7/26/2012: Comparing Flat_map and String.Map for small maps Summary: (I don't understand these results; I ran the unsafe version twice to be sure.) -look-ups -size 1,000,000 -mapsize 10 Array.unsafe_get: ratio = 0.762 or 0.778 Array.get: ratio = 0.775 Flat_map using 1 Array of Tuples with Array.unsafe_get, Array.stable_sort look-ups -size 1,000,000 -mapsize 10 ratio = 0.762 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocated | Promoted | Warnings | | | | | | d (minor | (major) | | | | | | | | ) | | | | |----------+----------+----------+----------+----------+-----------+----------+----------| | flat_map | 2080 ms | 62255475 | 56404 us | 39985054 | 34985010 | 34985010 | McaA | | | | 01 | | | | | | | string_m | 2730 ms | 81696490 | 62820 us | 59985206 | 54985098 | 54985098 | McaA | | ap | | 77 | | | | | | |----------------------------------------------------------------------------------------| ratio = 0.778 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocated | Promoted | Warnings | | | | | | d (minor | (major) | | | | | | | | ) | | | | |----------+----------+----------+----------+----------+-----------+----------+----------| | flat_map | 2101 ms | 62883074 | 74907 us | 39985054 | 34985010 | 34985010 | McaA | | | | 11 | | | | | | | string_m | 2700 ms | 80819743 | 35941 us | 59985206 | 54985098 | 54985098 | McaA | | ap | | 67 | | | | | | |----------------------------------------------------------------------------------------| tree-deserial -depth 22 ratio = 1.723 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocate | Promoted | Warnings | | | | | | d (minor | d (major | | | | | | | | ) | ) | | | |-----------+----------+----------+----------+----------+----------+----------+----------| | with sexp | 809995 u | 24238646 | 9976 us | 12582952 | 11999799 | 11999799 | MaA | | deserial | s | 22 | | | | | | | ize tree | | | | | | | | | deseriali | 1396 ms | 41795549 | 50415 us | 10485775 | 12480067 | 12480067 | MaA | | ze2 tree | | 92 | | 2 | | | | |----------------------------------------------------------------------------------------| Flat_map using 1 Array of Tuples with Array.get,Array.stable_sort tree-deserial -depth 22 ratio = 1.693 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocate | Promoted | Warnings | | | | | | d (minor | d (major | | | | | | | | ) | ) | | | |-----------+----------+----------+----------+----------+----------+----------+----------| | with sexp | 803505 u | 24044428 | 3883 us | 12582952 | 11999799 | 11999799 | aA | | deserial | s | 98 | | | | | | | ize tree | | | | | | | | | deseriali | 1360 ms | 40725074 | 11971 us | 10485775 | 12480067 | 12480067 | aA | | ze2 tree | | 43 | | 2 | | | | |----------------------------------------------------------------------------------------| NOTE: the two record results below make sense. My record fields are always inorder, so the map is never actually created or used. I need to fix the benchmark. Record with String.Map record-list-deserial -size 1000 ratio = 1.291 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocate | Promoted | Warnings | | | | | | d (minor | d (major | | | | | | | | ) | ) | | | |-----------+----------+----------+----------+----------+----------+----------+----------| | with sexp | 4054 ms | 12133114 | 132820 u | 13801728 | 24211549 | 24211549 | MaA | | deserial | | 582 | s | 9 | | | | | ize recor | | | | | | | | | d list li | | | | | | | | | st | | | | | | | | | deseriali | 5233 ms | 15660187 | 180896 u | 81301361 | 25246681 | 25246681 | MaA | | ze2 recor | | 272 | s | 9 | | | | | d list li | | | | | | | | | st | | | | | | | | |----------------------------------------------------------------------------------------| Record with Flat_map record-list-deserial -size 1000 ratio = 1.307 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocate | Promoted | Warnings | | | | | | d (minor | d (major | | | | | | | | ) | ) | | | |-----------+----------+----------+----------+----------+----------+----------+----------| | with sexp | 4016 ms | 12019037 | 60770 us | 13801728 | 24211549 | 24211549 | MaA | | deserial | | 925 | | 9 | | | | | ize recor | | | | | | | | | d list li | | | | | | | | | st | | | | | | | | | deseriali | 5251 ms | 15713929 | 152151 u | 81301361 | 25246681 | 25246681 | MaA | | ze2 recor | | 457 | s | 9 | | | | | d list li | | | | | | | | | st | | | | | | | | |----------------------------------------------------------------------------------------| small-maps -size 1,000,000 -mapsize 10 ratio flat_map to string.map = 0.302 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocated | Promoted | Warnings | | | | | | d (minor | (major) | | | | | | | | ) | | | | |----------+----------+----------+----------+----------+-----------+----------+----------| | flat_map | 1521 ms | 45535582 | 10955 us | 81986344 | 15985428 | 15985428 | caA | | | | 21 | | | | | | | string m | 5039 ms | 15081613 | 28077 us | 27198577 | 55994785 | 55994785 | caA | | ap | | 595 | | 4 | | | | |----------------------------------------------------------------------------------------| small-maps -size 1,000,000 -mapsize 2 ratio flat_map to string.map = 0.469 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocated | Promoted | Warnings | | | | | | d (minor | (major) | | | | | | | | ) | | | | |----------+----------+----------+----------+----------+-----------+----------+----------| | flat_map | 404315 u | 12098909 | 12970 us | 41985059 | 7985194 | 7985194 | MaA | | | s | 23 | | | | | | | string m | 862775 u | 25818054 | 39375 us | 55985351 | 19985513 | 19985513 | McaA | | ap | s | 51 | | | | | | |----------------------------------------------------------------------------------------| look-ups -size 1,000,000 -mapsize 2 ratio flat_map to string.map = 0.655 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocated | Promoted | Warnings | | | | | | d (minor | (major) | | | | | | | | ) | | | | |----------+----------+----------+----------+----------+-----------+----------+----------| | flat_map | 357389 u | 10694681 | 13027 us | 15985032 | 10985010 | 10985010 | mMaA | | | s | 68 | | | | | | | string_m | 545317 u | 16318297 | 9272 us | 19985026 | 14985010 | 14985010 | McaA | | ap | s | 68 | | | | | | |----------------------------------------------------------------------------------------| Flat_map using 1 Array of Tuples with Array.get,Array.sort small-maps -size 1,000,000 -mapsize 10 ratio flat_map to string.map = 0.672 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocated | Promoted | Warnings | | | | | | d (minor | (major) | | | | | | | | ) | | | | |----------+----------+----------+----------+----------+-----------+----------+----------| | flat_map | 3440 ms | 10296054 | 41695 us | 15198664 | 15988469 | 15988469 | McaA | | | | 544 | | 7 | | | | | string m | 5116 ms | 15311165 | 171669 u | 27198577 | 55994785 | 55994785 | McaA | | ap | | 085 | s | 4 | | | | |----------------------------------------------------------------------------------------| look-ups -size 1,000,000 -mapsize 10 ratio flat_map to string.map = 0.775 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocated | Promoted | Warnings | | | | | | d (minor | (major) | | | | | | | | ) | | | | |----------+----------+----------+----------+----------+-----------+----------+----------| | flat_map | 2102 ms | 62927416 | 13299 us | 39985054 | 34985010 | 34985010 | caA | | | | 19 | | | | | | | string_m | 2714 ms | 81220494 | 17931 us | 59985206 | 54985098 | 54985098 | caA | | ap | | 30 | | | | | | |----------------------------------------------------------------------------------------| Benchmark Results 7/25/2012: Made Record and Variant tests bigger record-list-deserial -size 1000 ratio = 1.217 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocate | Promoted | Warnings | | | | | | d (minor | d (major | | | | | | | | ) | ) | | | |-----------+----------+----------+----------+----------+----------+----------+----------| | with sexp | 4215 ms | 12615888 | 24789 us | 13801728 | 24211549 | 24211549 | aA | | deserial | | 985 | | 9 | | | | | ize recor | | | | | | | | | d list li | | | | | | | | | st | | | | | | | | | deseriali | 5131 ms | 15356545 | 79327 us | 81301361 | 25246681 | 25246681 | MaA | | ze2 recor | | 046 | | 9 | | | | | d list li | | | | | | | | | st | | | | | | | | |----------------------------------------------------------------------------------------| tree-deserial -depth 22 ratio = 1.673 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocate | Promoted | Warnings | | | | | | d (minor | d (major | | | | | | | | ) | ) | | | |-----------+----------+----------+----------+----------+----------+----------+----------| | with sexp | 816326 u | 24428099 | 8331 us | 12582952 | 11999799 | 11999799 | MaA | | deserial | s | 54 | | | | | | | ize tree | | | | | | | | | deseriali | 1366 ms | 40878533 | 10964 us | 10485775 | 12480067 | 12480067 | aA | | ze2 tree | | 59 | | 2 | | | | |----------------------------------------------------------------------------------------| Benchmark Results 7/25/2012: After Changes to variant With flat_map_array with change to binary search: tree-deserial -depth 22 ratio = 1.427 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocate | Promoted | Warnings | | | | | | d (minor | d (major | | | | | | | | ) | ) | | | |-----------+----------+----------+----------+----------+----------+----------+----------| | with sexp | 831233 u | 24874165 | 48228 us | 12582952 | 11999799 | 11999799 | mMaA | | deserial | s | 16 | | | | | | | ize tree | | | | | | | | | deseriali | 1186 ms | 35514849 | 49212 us | 10485775 | 12480067 | 12480067 | MaA | | ze2 tree | | 01 | | 2 | | | | |----------------------------------------------------------------------------------------| With flat_map_original: tree-deserial -depth 22 ratio = 1.616 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocate | Promoted | Warnings | | | | | | d (minor | d (major | | | | | | | | ) | ) | | | |-----------+----------+----------+----------+----------+----------+----------+----------| | with sexp | 789635 u | 23629366 | 17999 us | 12582952 | 11999799 | 11999799 | MaA | | deserial | s | 87 | | | | | | | ize tree | | | | | | | | | deseriali | 2548 ms | 76267373 | 63520 us | 62075817 | 12621658 | 12621658 | MaA | | ze tree | | 03 | | 5 | | | | | deseriali | 1276 ms | 38185189 | 17788 us | 16357817 | 12538680 | 12538680 | aA | | ze2 tree | | 80 | | 0 | | | | |----------------------------------------------------------------------------------------| Benchmark Results 7/25/2012 With flat_map_original: tree-deserial -depth 22 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocate | Promoted | Warnings | | | | | | d (minor | d (major | | | | | | | | ) | ) | | | |-----------+----------+----------+----------+----------+----------+----------+----------| | with sexp | 785129 u | 23494537 | 4265 us | 12582952 | 11999799 | 11999799 | aA | | deserial | s | 08 | | | | | | | ize tree | | | | | | | | | deseriali | 2549 ms | 76299221 | 39561 us | 62075817 | 12621658 | 12621658 | aA | | ze tree | | 24 | | 5 | | | | | deseriali | 1459 ms | 43688733 | 20772 us | 17616106 | 12571655 | 12571655 | aA | | ze2 tree | | 63 | | 8 | | | | |----------------------------------------------------------------------------------------| record-list-deserial -size 500 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocate | Promoted | Warnings | | | | | | d (minor | d (major | | | | | | | | ) | ) | | | |------------+----------+----------+---------+----------+----------+----------+----------| | with sexp | 119536 u | 35770634 | 2450 us | 7505587 | 1406052 | 1406052 | aA | | deserializ | s | 1 | | | | | | | e record l | | | | | | | | | ist list | | | | | | | | | deserializ | 177203 u | 53027096 | 6146 us | 27013242 | 1516995 | 1516995 | MaA | | e record l | s | 4 | | | | | | | ist list | | | | | | | | | deserializ | 248745 u | 74435778 | 4977 us | 48005742 | 1538281 | 1538281 | MA | | e2 record | s | 0 | | | | | | | list list | | | | | | | | |----------------------------------------------------------------------------------------| With flat_map_not_as_slow: tree-deserial -depth 22 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocate | Promoted | Warnings | | | | | | d (minor | d (major | | | | | | | | ) | ) | | | |-----------+----------+----------+----------+----------+----------+----------+----------| | with sexp | 784905 u | 23487845 | 3501 us | 12582952 | 11999799 | 11999799 | aA | | deserial | s | 83 | | | | | | | ize tree | | | | | | | | | deseriali | 2557 ms | 76528747 | 90461 us | 62075817 | 12621658 | 12621658 | MaA | | ze tree | | 11 | | 5 | | | | | deseriali | 1403 ms | 41990087 | 37126 us | 17616106 | 12571655 | 12571655 | MaA | | ze2 tree | | 17 | | 8 | | | | |----------------------------------------------------------------------------------------| record-list-deserial -size 500 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocate | Promoted | Warnings | | | | | | d (minor | d (major | | | | | | | | ) | ) | | | |------------+----------+----------+---------+----------+----------+----------+----------| | with sexp | 117332 u | 35111312 | 4459 us | 7505587 | 1406052 | 1406052 | MaA | | deserializ | s | 5 | | | | | | | e record l | | | | | | | | | ist list | | | | | | | | | deserializ | 175483 u | 52512454 | 5375 us | 27013242 | 1516995 | 1516995 | MaA | | e record l | s | 6 | | | | | | | ist list | | | | | | | | | deserializ | 254308 u | 76100532 | 4965 us | 43755830 | 1510723 | 1510723 | MaA | | e2 record | s | 3 | | | | | | | list list | | | | | | | | |----------------------------------------------------------------------------------------| record-list-deserial -size 2000 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocate | Promoted | Warnings | | | | | | d (minor | d (major | | | | | | | | ) | ) | | | |-----------+----------+----------+----------+----------+----------+----------+----------| | with sexp | 1988 ms | 59504161 | 106837 u | 12002224 | 24378597 | 24378595 | MaA | | deserial | | 78 | s | 5 | | | | | ize recor | | | | | | | | | d list li | | | | | | | | | st | | | | | | | | | deseriali | 2904 ms | 86903520 | 151829 u | 43205266 | 25306952 | 25306952 | MaA | | ze record | | 72 | s | 0 | | | | | list lis | | | | | | | | | t | | | | | | | | | deseriali | 4156 ms | 12438148 | 54096 us | 70003466 | 26204818 | 26204818 | aA | | ze2 recor | | 506 | | 0 | | | | | d list li | | | | | | | | | st | | | | | | | | |----------------------------------------------------------------------------------------| with String.map for both variant and record: tree-deserial -depth 22 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocate | Promoted | Warnings | | | | | | d (minor | d (major | | | | | | | | ) | ) | | | |-----------+----------+----------+----------+----------+----------+----------+----------| | with sexp | 806247 u | 24126465 | 11355 us | 12582952 | 11999799 | 11999799 | MaA | | deserial | s | 78 | | | | | | | ize tree | | | | | | | | | deseriali | 2583 ms | 77299680 | 45014 us | 62075817 | 12621658 | 12621658 | MaA | | ze tree | | 91 | | 5 | | | | | deseriali | 1336 ms | 39982025 | 16787 us | 13421787 | 12562691 | 12562691 | aA | | ze2 tree | | 21 | | 9 | | | | |----------------------------------------------------------------------------------------| record-list-deserial -size 500 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocate | Promoted | Warnings | | | | | | d (minor | d (major | | | | | | | | ) | ) | | | |------------+----------+----------+---------+----------+----------+----------+----------| | with sexp | 116328 u | 34810653 | 2085 us | 7505587 | 1406052 | 1406052 | aA | | deserializ | s | 4 | | | | | | | e record l | | | | | | | | | ist list | | | | | | | | | deserializ | 173306 u | 51860979 | 5927 us | 27013242 | 1516995 | 1516995 | MaA | | e record l | s | 5 | | | | | | | ist list | | | | | | | | | deserializ | 186869 u | 55919601 | 9610 us | 30255580 | 1509629 | 1509629 | MaA | | e2 record | s | 3 | | | | | | | list list | | | | | | | | |----------------------------------------------------------------------------------------| record-list-deserial -size 2000 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocate | Promoted | Warnings | | | | | | d (minor | d (major | | | | | | | | ) | ) | | | |-----------+----------+----------+----------+----------+----------+----------+----------| | with sexp | 1964 ms | 58781665 | 19376 us | 12002224 | 24378597 | 24378595 | MaA | | deserial | | 93 | | 5 | | | | | ize recor | | | | | | | | | d list li | | | | | | | | | st | | | | | | | | | deseriali | 2848 ms | 85230478 | 41108 us | 43205266 | 25306952 | 25306952 | aA | | ze record | | 65 | | 0 | | | | | list lis | | | | | | | | | t | | | | | | | | | deseriali | 2982 ms | 89259269 | 61033 us | 48402279 | 25460569 | 25460569 | MaA | | ze2 recor | | 78 | | 5 | | | | | d list li | | | | | | | | | st | | | | | | | | |----------------------------------------------------------------------------------------| using lazy String.Map for record: record-list-deserial -size 500 ratio = 1.441 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocate | Promoted | Warnings | | | | | | d (minor | d (major | | | | | | | | ) | ) | | | |------------+----------+----------+---------+----------+----------+----------+----------| | with sexp | 116088 u | 34738882 | 1766 us | 7505587 | 1406052 | 1406052 | aA | | deserializ | s | 8 | | | | | | | e record l | | | | | | | | | ist list | | | | | | | | | deserializ | 178629 u | 53453786 | 7087 us | 27013242 | 1516995 | 1516995 | MaA | | e record l | s | 5 | | | | | | | ist list | | | | | | | | | deserializ | 167287 u | 50059884 | 4892 us | 27755685 | 1469446 | 1469446 | MaA | | e2 record | s | 6 | | | | | | | list list | | | | | | | | |----------------------------------------------------------------------------------------| record-list-deserial -size 2000 ratio = 1.404 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocate | Promoted | Warnings | | | | | | d (minor | d (major | | | | | | | | ) | ) | | | |-----------+----------+----------+----------+----------+----------+----------+----------| | with sexp | 1976 ms | 59146270 | 116539 u | 12002224 | 24378597 | 24378595 | MaA | | deserial | | 38 | s | 5 | | | | | ize recor | | | | | | | | | d list li | | | | | | | | | st | | | | | | | | | deseriali | 2852 ms | 85361080 | 49490 us | 43205266 | 25306952 | 25306952 | MaA | | ze record | | 80 | | 0 | | | | | list lis | | | | | | | | | t | | | | | | | | | deseriali | 2774 ms | 83023412 | 61446 us | 44402442 | 25327092 | 25327092 | MaA | | ze2 recor | | 71 | | 0 | | | | | d list li | | | | | | | | | st | | | | | | | | |----------------------------------------------------------------------------------------| using lazy Flat_map_not_so_slow for record: record-list-deserial -size 500 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocate | Promoted | Warnings | | | | | | d (minor | d (major | | | | | | | | ) | ) | | | |------------+----------+----------+---------+----------+----------+----------+----------| | with sexp | 115841 u | 34664966 | 2939 us | 7505587 | 1406052 | 1406052 | MaA | | deserializ | s | 8 | | | | | | | e record l | | | | | | | | | ist list | | | | | | | | | deserializ | 175132 u | 52407324 | 4445 us | 27013242 | 1516995 | 1516995 | MaA | | e record l | s | 7 | | | | | | | ist list | | | | | | | | | deserializ | 169741 u | 50794301 | 6542 us | 27755685 | 1469446 | 1469446 | MaA | | e2 record | s | 7 | | | | | | | list list | | | | | | | | |----------------------------------------------------------------------------------------| record-list-deserial -size 2000 |----------------------------------------------------------------------------------------| | Name | Run time | Cycles | Stdev | Allocate | Allocate | Promoted | Warnings | | | | | | d (minor | d (major | | | | | | | | ) | ) | | | |-----------+----------+----------+----------+----------+----------+----------+----------| | with sexp | 2078 ms | 62187036 | 151522 u | 12002224 | 24378597 | 24378595 | MaA | | deserial | | 84 | s | 5 | | | | | ize recor | | | | | | | | | d list li | | | | | | | | | st | | | | | | | | | deseriali | 2905 ms | 86950292 | 92321 us | 43205266 | 25306952 | 25306952 | MaA | | ze record | | 58 | | 0 | | | | | list lis | | | | | | | | | t | | | | | | | | | deseriali | 2924 ms | 87501286 | 253195 u | 44402442 | 25327092 | 25327092 | mMaA | | ze2 recor | | 87 | s | 0 | | | | | d list li | | | | | | | | | st | | | | | | | | |----------------------------------------------------------------------------------------| typerep-113.00.00/generics/sexprep/lib/000077500000000000000000000000001256342456100175475ustar00rootroot00000000000000typerep-113.00.00/generics/sexprep/lib/sexprep.ml000066400000000000000000000225741256342456100216010ustar00rootroot00000000000000open! Core_kernel.Std open Typerep_extended.Std module SC = struct include Sexplib.Conv let of_sexp_error what sexp = raise (Of_sexp_error (Failure what, sexp)) let quadruple_of_sexp a_of_sexp b_of_sexp c_of_sexp d_of_sexp = function | Sexp.List [a;b;c;d] -> a_of_sexp a , b_of_sexp b , c_of_sexp c , d_of_sexp d | (Sexp.List _) as sexp -> of_sexp_error "quadruple_of_sexp: list must contain exactly four elements only" sexp | (Sexp.Atom _) as sexp -> of_sexp_error "quadruple_of_sexp: list needed" sexp let quintuple_of_sexp a_of_sexp b_of_sexp c_of_sexp d_of_sexp e_of_sexp = function | Sexp.List [a;b;c;d;e] -> a_of_sexp a , b_of_sexp b , c_of_sexp c , d_of_sexp d , e_of_sexp e | (Sexp.List _) as sexp -> of_sexp_error "quintuple_of_sexp: list must contain exactly five elements only" sexp | (Sexp.Atom _) as sexp -> of_sexp_error "quintuple_of_sexp: list needed" sexp let sexp_of_quadruple sexp_of_a sexp_of_b sexp_of_c sexp_of_d (a,b,c,d) = let sexp_a = sexp_of_a a in let sexp_b = sexp_of_b b in let sexp_c = sexp_of_c c in let sexp_d = sexp_of_d d in Sexp.List [sexp_a; sexp_b; sexp_c; sexp_d] let sexp_of_quintuple sexp_of_a sexp_of_b sexp_of_c sexp_of_d sexp_of_e (a,b,c,d,e) = let sexp_a = sexp_of_a a in let sexp_b = sexp_of_b b in let sexp_c = sexp_of_c c in let sexp_d = sexp_of_d d in let sexp_e = sexp_of_e e in Sexp.List [sexp_a; sexp_b; sexp_c; sexp_d; sexp_e] end module Of_sexp = struct exception Type_mismatch of string * Sexp.t module Computation_impl = struct type 'a t = Sexp.t -> 'a include Type_generic.Variant_and_record_intf.M(struct type nonrec 'a t = 'a t end) let int = SC.int_of_sexp let int32 = SC.int32_of_sexp let int64 = SC.int64_of_sexp let nativeint = SC.nativeint_of_sexp let char = SC.char_of_sexp let float = SC.float_of_sexp let string = SC.string_of_sexp let bool = SC.bool_of_sexp let unit = SC.unit_of_sexp let option contents_of_sexp = SC.option_of_sexp contents_of_sexp let list contents_of_sexp = SC.list_of_sexp contents_of_sexp let array contents_of_sexp = SC.array_of_sexp contents_of_sexp let lazy_t contents_of_sexp = SC.lazy_t_of_sexp contents_of_sexp let ref_ contents_of_sexp = SC.ref_of_sexp contents_of_sexp let function_ _arg_of_sexp _return_of_sexp = SC.fun_of_sexp let tuple2 = SC.pair_of_sexp let tuple3 = SC.triple_of_sexp let tuple4 = SC.quadruple_of_sexp let tuple5 = SC.quintuple_of_sexp let record record = fun sexp -> let fail () = raise (Type_mismatch ("Record", sexp)) in match sexp with | Sexp.List sexp_properties -> begin let properties = lazy ( let seen = String.Hash_set.create () in Flat_map.Flat_string_map.of_alist ( List.rev_map sexp_properties ~f:(function | Sexp.List [Sexp.Atom name; sexp_value] -> if Hash_set.mem seen name then fail (); Hash_set.add seen name; (name, sexp_value) | _ -> fail () ) )) in let get field = let label = Field.label field in let index = Field.index field in let sexp_value = match List.nth sexp_properties index with | Some (Sexp.List [Sexp.Atom sexp_name; sexp_value]) -> if String.equal sexp_name label then sexp_value else begin match Flat_map.Flat_string_map.find (Lazy.force properties) label with | Some x -> x | None -> fail () end | _ -> fail () in Field.traverse field sexp_value in Record.create record { Record.get } end | _ -> fail () let variant variant = let tag_by_label = let f index = match Variant.tag variant index with | (Variant.Tag tag) as data -> Tag.label tag, data in Flat_map.Flat_string_map.init (Variant.length variant) ~f in let t_of_sexp sexp = let fail () = raise (Type_mismatch ("Variant", sexp)) in match sexp with | Sexp.Atom label -> begin match Flat_map.Flat_string_map.find tag_by_label label with | Some (Variant.Tag tag) -> begin match Tag.create tag with | Tag.Const const -> const | Tag.Args _ -> fail () end | _ -> fail () end | Sexp.List ((Sexp.Atom label)::sexps) -> begin match Flat_map.Flat_string_map.find tag_by_label label with | Some (Variant.Tag tag) -> begin match Tag.create tag with | Tag.Args create -> let arity = Tag.arity tag in let sexp_value = if arity = 1 then match sexps with | [sexp] -> sexp | _ -> fail () else Sexp.List sexps in create (Tag.traverse tag sexp_value) | Tag.Const _ -> fail () end | _ -> fail () end | _ -> fail () in t_of_sexp module Named = Type_generic.Make_named_for_closure(struct type 'a input = Sexp.t type 'a output = 'a type 'a t = Sexp.t -> 'a end) end include Type_generic.Make(struct include Computation_impl let name = "of_sexp" let required = [ Type_struct.Generic.ident ] end) end module Sexp_of = struct module Computation_impl = struct type 'a t = 'a -> Sexp.t include Type_generic.Variant_and_record_intf.M(struct type nonrec 'a t = 'a t end) let int = SC.sexp_of_int let int32 = SC.sexp_of_int32 let int64 = SC.sexp_of_int64 let nativeint = SC.sexp_of_nativeint let char = SC.sexp_of_char let float = SC.sexp_of_float let string = SC.sexp_of_string let bool = SC.sexp_of_bool let function_ _sexp_of_arg _sexp_of_ret = SC.sexp_of_fun let unit = SC.sexp_of_unit let option = SC.sexp_of_option let ref_ = SC.sexp_of_ref let lazy_t = SC.sexp_of_lazy_t let list = SC.sexp_of_list let array = SC.sexp_of_array let tuple2 = SC.sexp_of_pair let tuple3 = SC.sexp_of_triple let tuple4 = SC.sexp_of_quadruple let tuple5 = SC.sexp_of_quintuple let record record = (* preallocation of atoms *) let atoms = Array.init (Record.length record) ~f:(fun index -> match Record.field record index with | Record.Field field -> Sexp.Atom (Field.label field) ) in fun value -> let rec aux acc index = if index < 0 then Sexp.List acc else let field = match Record.field record index with | Record.Field field -> let field_value = Field.traverse field (Field.get field value) in let index = Field.index field in Sexp.List [ atoms.(index) ; field_value ] in aux (field::acc) (pred index) in aux [] (pred (Record.length record)) let variant variant = (* preallocation of atoms *) let atoms = Array.init (Variant.length variant) ~f:(fun index -> match Variant.tag variant index with | Variant.Tag tag -> Sexp.Atom (Tag.label tag) ) in fun value -> match Variant.value variant value with | Variant.Value (tag, args) -> let index = Tag.index tag in let arity = Tag.arity tag in let atom = atoms.(index) in match arity with | 0 -> atom | 1 -> Sexp.List [ atom ; Tag.traverse tag args ] | _ -> (* this might be a cause of this being slower because of this [Sexp.List sexps] temporary cons/decons I'm not sure how to get rid of it though *) match Tag.traverse tag args with | Sexp.List sexps -> Sexp.List (atom::sexps) | _ -> assert false module Named = Type_generic.Make_named_for_closure(struct type 'a input = 'a type 'a output = Sexp.t type 'a t = 'a -> Sexp.t end) end include Type_generic.Make(struct include Computation_impl let name = "sexp_of" let required = [ Type_struct.Generic.ident ] end) end let t_of_sexp = Of_sexp.of_typerep let sexp_of_t = Sexp_of.of_typerep module Make_sexpable(X:Typerepable.S0) = struct type t = X.t let `generic sexp_of_t = sexp_of_t X.typerep_of_t let `generic t_of_sexp = t_of_sexp X.typerep_of_t end let make_sexpable (type a) (typerep_of_t : a Typerep.t) = let module M = Make_sexpable(struct type t = a let typerep_of_t = typerep_of_t let typename_of_t = Typerep.typename_of_t typerep_of_t end) in (module M : Sexpable.S with type t = a) module Tagged = struct module Of_sexp = Tagged_generic.Make_input(Sexp)(Of_sexp.Computation) module Sexp_of = Tagged_generic.Make_output(Sexp)(Sexp_of.Computation) let t_of_sexp = Of_sexp.of_typestruct let sexp_of_t = Sexp_of.of_typestruct module Make_sexpable(X:sig val typestruct_of_t : Type_struct.t end) = struct type t = Tagged.t let `generic sexp_of_t = sexp_of_t X.typestruct_of_t let `generic t_of_sexp = t_of_sexp X.typestruct_of_t end let make_sexpable typestruct_of_t = let module M = Make_sexpable(struct let typestruct_of_t = typestruct_of_t end) in (module M : Sexpable.S with type t = Tagged.t) end typerep-113.00.00/generics/sexprep/lib/sexprep.mli000066400000000000000000000017421256342456100217440ustar00rootroot00000000000000open! Core_kernel.Std open Typerep_extended.Std module Of_sexp : sig exception Type_mismatch of string * Sexp.t include Type_generic.S with type 'a t = Sexp.t -> 'a end module Sexp_of : Type_generic.S with type 'a t = 'a -> Sexp.t val t_of_sexp : 'a Typerep.t -> [`generic of Sexp.t -> 'a] val sexp_of_t : 'a Typerep.t -> [`generic of 'a -> Sexp.t] module Make_sexpable(X:Typerepable.S0) : Sexpable.S with type t := X.t val make_sexpable : 'a Typerep.t -> (module Sexpable.S with type t = 'a) module Tagged : sig module Of_sexp : Tagged_generic.S with type 'a t = Sexp.t -> 'a module Sexp_of : Tagged_generic.S with type 'a t = 'a -> Sexp.t val t_of_sexp : Type_struct.t -> [ `generic of Sexp.t -> Tagged.t ] val sexp_of_t : Type_struct.t -> [ `generic of Tagged.t -> Sexp.t ] module Make_sexpable(X:sig val typestruct_of_t : Type_struct.t end) : Sexpable.S with type t := Tagged.t val make_sexpable : Type_struct.t -> (module Sexpable.S with type t = Tagged.t) end typerep-113.00.00/generics/sexprep/lib/std.ml000066400000000000000000000000311256342456100206650ustar00rootroot00000000000000module Sexprep = Sexprep typerep-113.00.00/generics/sexprep/test/000077500000000000000000000000001256342456100177605ustar00rootroot00000000000000typerep-113.00.00/generics/sexprep/test/test_sexprep.ml000066400000000000000000000436341256342456100230510ustar00rootroot00000000000000open Core.Std open Typerep_experimental.Std module S = Sexprep (* Tests to make sure we can deserialize values we serialized *) (* Tests to make sure we can deserialize values serialized by with sexp *) (* Tests to make sure with sexp can deserialize values serialized by us *) TEST_MODULE = struct let t_of_sexp_of_sexp_of_t typerep value = let `generic t_of_sexp = S.t_of_sexp typerep in let `generic sexp_of_t = S.sexp_of_t typerep in t_of_sexp (sexp_of_t value) let check_untyped value typerep = let `generic t_of_sexp = S.t_of_sexp typerep in let `generic sexp_of_t = S.sexp_of_t typerep in let `generic sexp_of_un = Sexprep.Tagged.Sexp_of.of_typestruct (Type_struct.of_typerep typerep) in let `generic un_of_sexp = Sexprep.Tagged.Of_sexp.of_typestruct (Type_struct.of_typerep typerep) in let new_value = t_of_sexp (sexp_of_un (un_of_sexp (sexp_of_t value))) in Polymorphic_compare.equal new_value value let check_typerep value typerep = let str = t_of_sexp_of_sexp_of_t typerep value in Polymorphic_compare.equal value str let check_obj_typerep (type a) (value:a) (typerep:a Typerep.t) = let `generic sexp_of_t = S.sexp_of_t typerep in let sexp = sexp_of_t value in let typestruct = Type_struct.of_typerep typerep in let typerep_of_t = Type_struct.recreate_dynamically_typerep_for_test typerep in let objstruct = Type_struct.of_typerep typerep_of_t in let fail = ref false in let () = let `generic t_of_sexp = S.t_of_sexp typerep_of_t in let obj_value = t_of_sexp sexp in if not (Polymorphic_compare.equal obj_value value) then begin fail := true; Printf.printf "typestruct: %s\n" (Sexp.to_string_hum (Type_struct.sexp_of_t typestruct)); Printf.printf "objstruct: %s\n" (Sexp.to_string_hum (Type_struct.sexp_of_t objstruct)); Printf.printf "polymorphic equality failed obj_value: %S\n%!" (Sexp.to_string_hum sexp) end in let () = let `generic sexp_of_t = S.sexp_of_t typerep_of_t in let obj_sexp = sexp_of_t value in let obj_str = Sexp.to_string_hum obj_sexp in let value_str = Sexp.to_string_hum sexp in if not (String.equal obj_str value_str) then begin fail := true; Printf.printf "typestruct: %s\n" (Sexp.to_string_hum (Type_struct.sexp_of_t typestruct)); Printf.printf "objstruct: %s\n" (Sexp.to_string_hum (Type_struct.sexp_of_t objstruct)); Printf.printf "sexp equality failed obj_value:\nvalue sexp:\n%s\nobj sexp\n%s\n%!" value_str obj_str end in not !fail let check value typerep = if (check_typerep value typerep) && (check_untyped value typerep) && (check_obj_typerep value typerep) then true else begin let `generic sexp_of_t = S.sexp_of_t typerep in let `generic t_of_sexp = S.t_of_sexp typerep in let sexp = sexp_of_t value in let second_sexp = sexp_of_t (t_of_sexp sexp) in print_endline "sexp:"; print_endline (Sexp.to_string_hum sexp); print_endline "sexp of (t of (sexp of t)):"; print_endline (Sexp.to_string_hum second_sexp); false end let check_of_sexp value typerep sexp_of_t = let `generic t_of_sexp = S.t_of_sexp typerep in Polymorphic_compare.equal value (t_of_sexp (sexp_of_t value)) let check_of_t value typerep t_of_sexp = let `generic sexp_of_t = S.sexp_of_t typerep in Polymorphic_compare.equal value (t_of_sexp (sexp_of_t value)) TEST_UNIT = let module M = struct type t = int with typerep, sexp end in let value = 5 in assert(check value M.typerep_of_t); assert(check_of_sexp value M.typerep_of_t M.sexp_of_t); assert(check_of_t value M.typerep_of_t M.t_of_sexp) TEST_UNIT = let module M = struct type t = int32 with typerep, sexp end in let value = Int32.of_int_exn 5 in assert(check value M.typerep_of_t); assert(check_of_sexp value M.typerep_of_t M.sexp_of_t); assert(check_of_t value M.typerep_of_t M.t_of_sexp) TEST_UNIT = let module M = struct type t = int64 with typerep, sexp end in let value = Int64.of_int_exn 5 in assert(check value M.typerep_of_t); assert(check_of_sexp value M.typerep_of_t M.sexp_of_t); assert(check_of_t value M.typerep_of_t M.t_of_sexp) TEST_UNIT = let module M = struct type t = char with typerep, sexp end in let value = 'c' in assert(check value M.typerep_of_t); assert(check_of_sexp value M.typerep_of_t M.sexp_of_t); assert(check_of_t value M.typerep_of_t M.t_of_sexp) TEST_UNIT = let module M = struct type t = float with typerep, sexp end in let value = 543.02 in assert(check value M.typerep_of_t); assert(check_of_sexp value M.typerep_of_t M.sexp_of_t); assert(check_of_t value M.typerep_of_t M.t_of_sexp) TEST_UNIT = let module M = struct type t = string with typerep, sexp end in let value = "Hello, world!" in assert(check value M.typerep_of_t); assert(check_of_sexp value M.typerep_of_t M.sexp_of_t); assert(check_of_t value M.typerep_of_t M.t_of_sexp) TEST_UNIT = let module M = struct type t = bool with typerep, sexp end in assert(check true M.typerep_of_t); assert(check false M.typerep_of_t); assert(check_of_sexp true M.typerep_of_t M.sexp_of_t); assert(check_of_sexp false M.typerep_of_t M.sexp_of_t); assert(check_of_t true M.typerep_of_t M.t_of_sexp); assert(check_of_t false M.typerep_of_t M.t_of_sexp) TEST_UNIT = let module M = struct type t = unit with typerep, sexp end in assert(check () M.typerep_of_t); assert(check_of_sexp () M.typerep_of_t M.sexp_of_t); assert(check_of_t () M.typerep_of_t M.t_of_sexp) TEST_UNIT = let module M = struct type 'a t = 'a option with typerep, sexp end in assert(check None (M.typerep_of_t typerep_of_int)); assert(check (Some 5) (M.typerep_of_t typerep_of_int)); assert(check_of_sexp None (M.typerep_of_t typerep_of_int) (M.sexp_of_t sexp_of_int)); assert(check_of_sexp (Some 5) (M.typerep_of_t typerep_of_int) (M.sexp_of_t sexp_of_int)); assert(check_of_t None (M.typerep_of_t typerep_of_int) (M.t_of_sexp int_of_sexp)); assert(check_of_t (Some 5) (M.typerep_of_t typerep_of_int) (M.t_of_sexp int_of_sexp)) TEST_UNIT = let module M = struct type 'a t = 'a list with typerep, sexp end in assert(check [] (M.typerep_of_t typerep_of_int)); assert(check [1;2;6;5;4;3] (M.typerep_of_t typerep_of_int)); assert(check_of_sexp [] (M.typerep_of_t typerep_of_int) (M.sexp_of_t sexp_of_int)); assert(check_of_sexp [1;2;6;5;4;3] (M.typerep_of_t typerep_of_int) (M.sexp_of_t sexp_of_int)); assert(check_of_t [] (M.typerep_of_t typerep_of_int) (M.t_of_sexp int_of_sexp)); assert(check_of_t [1;2;6;5;4;3] (M.typerep_of_t typerep_of_int) (M.t_of_sexp int_of_sexp)) TEST_UNIT = let module M = struct type 'a t = 'a array with typerep, sexp end in assert(check [||] (M.typerep_of_t typerep_of_int)); assert(check [|1;2;6;5;4;3|] (M.typerep_of_t typerep_of_int)); assert(check_of_sexp [||] (M.typerep_of_t typerep_of_int) (M.sexp_of_t sexp_of_int)); assert(check_of_sexp [|1;2;6;5;4;3|] (M.typerep_of_t typerep_of_int) (M.sexp_of_t sexp_of_int)); assert(check_of_t [||] (M.typerep_of_t typerep_of_int) (M.t_of_sexp int_of_sexp)); assert(check_of_t [|1;2;6;5;4;3|] (M.typerep_of_t typerep_of_int) (M.t_of_sexp int_of_sexp)) TEST_UNIT = let module M = struct type 'a t = 'a ref with typerep, sexp end in assert(check (ref 6) (M.typerep_of_t typerep_of_int)); assert(check_of_sexp (ref 6) (M.typerep_of_t typerep_of_int) (M.sexp_of_t sexp_of_int)); assert(check_of_t (ref 6) (M.typerep_of_t typerep_of_int) (M.t_of_sexp int_of_sexp)) TEST_UNIT = let module M = struct type 'a t = 'a lazy_t with typerep, sexp end in let value = lazy 42 in let typerep = M.typerep_of_t typerep_of_int in let sexp_of_t = M.sexp_of_t sexp_of_int in let t_of_sexp = M.t_of_sexp int_of_sexp in let `generic sexp_of_x = S.sexp_of_t typerep in let `generic x_of_sexp = S.t_of_sexp typerep in assert (Int.equal (Lazy.force value) (Lazy.force (x_of_sexp (sexp_of_x value)))); assert (Int.equal (Lazy.force value) (Lazy.force (x_of_sexp (sexp_of_t value)))); assert (Int.equal (Lazy.force value) (Lazy.force (t_of_sexp (sexp_of_x value)))); ;; TEST_UNIT = let module M = struct type 'a t = {foo:'a; bar:float} with typerep, sexp end in assert(check {M.foo=5;bar=43.25} (M.typerep_of_t typerep_of_int)); assert(check_of_sexp {M.foo=5;bar=43.25} (M.typerep_of_t typerep_of_int) (M.sexp_of_t sexp_of_int)); assert( check_of_t {M.foo=5;bar=43.25} (M.typerep_of_t typerep_of_int) (M.t_of_sexp int_of_sexp)) TEST_UNIT = let module M = struct type ('a, 'b) t = ('a * 'b) with typerep, sexp end in assert(check (5,45.67) (M.typerep_of_t typerep_of_int typerep_of_float)); assert(check_of_sexp (5,45.67) (M.typerep_of_t typerep_of_int typerep_of_float) (M.sexp_of_t sexp_of_int sexp_of_float)); assert(check_of_t (5,45.67) (M.typerep_of_t typerep_of_int typerep_of_float) (M.t_of_sexp int_of_sexp float_of_sexp)) TEST_UNIT = let module M = struct type ('a, 'b, 'c) t = ('a * 'b * 'c) with typerep, sexp end in assert(check (5,45,3.14159) (M.typerep_of_t typerep_of_int typerep_of_int typerep_of_float)); assert(check_of_sexp (5,45,3.14159) (M.typerep_of_t typerep_of_int typerep_of_int typerep_of_float) (M.sexp_of_t sexp_of_int sexp_of_int sexp_of_float)); assert(check_of_t (5,45,3.14159) (M.typerep_of_t typerep_of_int typerep_of_int typerep_of_float) (M.t_of_sexp int_of_sexp int_of_sexp float_of_sexp)) TEST_UNIT = let module M = struct type ('a, 'b, 'c, 'd) t = ('a * 'b * 'c * 'd) with typerep, sexp end in assert(check (5,45,3.14159,1.14159) (M.typerep_of_t typerep_of_int typerep_of_int typerep_of_float typerep_of_float)); assert(check_of_sexp (5,45,3.14159,1.14159) (M.typerep_of_t typerep_of_int typerep_of_int typerep_of_float typerep_of_float) (M.sexp_of_t sexp_of_int sexp_of_int sexp_of_float sexp_of_float)); assert(check_of_t (5,45,3.14159,1.14159) (M.typerep_of_t typerep_of_int typerep_of_int typerep_of_float typerep_of_float) (M.t_of_sexp int_of_sexp int_of_sexp float_of_sexp float_of_sexp)) TEST_UNIT = let module M = struct type ('a, 'b, 'c, 'd, 'e) t = ('a * 'b * 'c * 'd * 'e) with typerep, sexp end in assert(check (5,45,3.14159,1.14159,"hi") (M.typerep_of_t typerep_of_int typerep_of_int typerep_of_float typerep_of_float typerep_of_string)); assert(check_of_sexp (5,45,3.14159,1.14159,"hi") (M.typerep_of_t typerep_of_int typerep_of_int typerep_of_float typerep_of_float typerep_of_string) (M.sexp_of_t sexp_of_int sexp_of_int sexp_of_float sexp_of_float sexp_of_string)); assert(check_of_t (5,45,3.14159,1.14159,"hi") (M.typerep_of_t typerep_of_int typerep_of_int typerep_of_float typerep_of_float typerep_of_string) (M.t_of_sexp int_of_sexp int_of_sexp float_of_sexp float_of_sexp string_of_sexp)) TEST_UNIT = let module M = struct type 'a t = | Foo | Bar of 'a | Baz of int * int | Bee | Bax of (int * int) | Baa of 'a * 'a | Bab of ('a * 'a) with typerep, sexp end in (* sexprep serialize and deserialize *) assert(check M.Foo (M.typerep_of_t typerep_of_int)); assert(check (M.Bar 651) (M.typerep_of_t typerep_of_int)); assert(check (M.Bar "651") (M.typerep_of_t typerep_of_string)); assert(check M.Bee (M.typerep_of_t typerep_of_bool)); assert(check (M.Baz (651,54)) (M.typerep_of_t typerep_of_int)); assert(check (M.Bax (651,54)) (M.typerep_of_t typerep_of_int)); assert(check (M.Baa (651,54)) (M.typerep_of_t typerep_of_int)); assert(check (M.Bab (651,54)) (M.typerep_of_t typerep_of_int)); (* sexplib serialize; sexprep deserialize *) assert(check_of_sexp M.Foo (M.typerep_of_t typerep_of_int) (M.sexp_of_t sexp_of_int)); assert(check_of_sexp (M.Bar 651) (M.typerep_of_t typerep_of_int) (M.sexp_of_t sexp_of_int)); assert(check_of_sexp (M.Baz (651,54)) (M.typerep_of_t typerep_of_int) (M.sexp_of_t sexp_of_int)); assert(check_of_sexp (M.Bax (651,54)) (M.typerep_of_t typerep_of_int) (M.sexp_of_t sexp_of_int)); assert(check_of_sexp (M.Baa (651,54)) (M.typerep_of_t typerep_of_int) (M.sexp_of_t sexp_of_int)); assert(check_of_sexp (M.Bab (651,54)) (M.typerep_of_t typerep_of_int) (M.sexp_of_t sexp_of_int)); (* sexprep serialize; sexplib deserialize *) assert(check_of_t M.Foo (M.typerep_of_t typerep_of_int) (M.t_of_sexp int_of_sexp)); assert(check_of_t (M.Bar 651) (M.typerep_of_t typerep_of_int) (M.t_of_sexp int_of_sexp)); assert(check_of_t (M.Baz (651,54)) (M.typerep_of_t typerep_of_int) (M.t_of_sexp int_of_sexp)); assert(check_of_t (M.Bax (651,54)) (M.typerep_of_t typerep_of_int) (M.t_of_sexp int_of_sexp)); assert(check_of_t (M.Baa (651,54)) (M.typerep_of_t typerep_of_int) (M.t_of_sexp int_of_sexp)); assert(check_of_t (M.Bab (651,54)) (M.typerep_of_t typerep_of_int) (M.t_of_sexp int_of_sexp)) TEST_UNIT = let module M = struct type t = | Foo | Bar of int | Baz of int * int | Bax of (int * int) with typerep, sexp end in (* sexprep serialize and deserialize *) assert(check M.Foo M.typerep_of_t); assert(check (M.Bar 651) M.typerep_of_t); assert(check (M.Baz (651,54)) M.typerep_of_t); assert(check (M.Bax (651,54)) M.typerep_of_t); (* sexplib serialize; sexprep deserialize *) assert(check_of_sexp M.Foo M.typerep_of_t M.sexp_of_t); assert(check_of_sexp (M.Bar 651) M.typerep_of_t M.sexp_of_t); assert(check_of_sexp (M.Baz (651,54)) M.typerep_of_t M.sexp_of_t); assert(check_of_sexp (M.Bax (651,54)) M.typerep_of_t M.sexp_of_t); (* sexprep serialize; sexplib deserialize *) assert(check_of_t M.Foo M.typerep_of_t M.t_of_sexp); assert(check_of_t (M.Bar 651) M.typerep_of_t M.t_of_sexp); assert(check_of_t (M.Baz (651,54)) M.typerep_of_t M.t_of_sexp); assert(check_of_t (M.Bax (651,54)) M.typerep_of_t M.t_of_sexp) TEST_UNIT = let module M = struct type t = Leaf | Node of t * t with typerep,sexp end in let rec producer n = if n > 0 then M.Node (producer (n-1), producer (n-1)) else M.Leaf in let value = producer 15 in assert(check value M.typerep_of_t); assert(check_of_sexp value M.typerep_of_t M.sexp_of_t); assert(check_of_t value M.typerep_of_t M.t_of_sexp); TEST_UNIT = let module M = struct type 'a t = [ `Foo | `Bar of 'a ] with typerep end in let typerep = M.typerep_of_t typerep_of_unit in assert(check `Foo typerep) ; assert(check (`Bar ()) typerep) module Rev_option : sig type 'a t with typerep val of_option : 'a option -> 'a t val register : unit -> unit end = struct module T = struct type 'a t = 'a option with typerep(abstract) end include T let of_option t = t let t_of_sexp a_of_sexp sexp = match sexp with | Sexp.Atom ("enon" | "enoN") -> None | Sexp.List [el] | Sexp.List [el ; Sexp.Atom ("emos" | "emoS")] -> Some (a_of_sexp el) | _ -> assert false let sexp_of_t sexp_of_a a = match a with | None -> Sexp.Atom "enoN" | Some a -> Sexp.List [sexp_of_a a ; Sexp.Atom "emoS"] let register () = Type_struct.Generic.register1 (module struct include T let compute = fun t -> Type_struct.Option t end : Type_struct.Generic.S1); S.Of_sexp.register1 (module struct include T let compute = t_of_sexp end : S.Of_sexp.S1); S.Sexp_of.register1 (module struct include T let compute = sexp_of_t end : S.Sexp_of.S1) end TEST_UNIT = let module A = struct type t = int Rev_option.t with typerep end in assert ( try ignore (check (Rev_option.of_option None) A.typerep_of_t); false with S.Of_sexp.Not_implemented _ -> true); Rev_option.register (); assert (check_typerep (Rev_option.of_option None) A.typerep_of_t); assert (check_typerep (Rev_option.of_option (Some 0)) A.typerep_of_t); assert (check_typerep (Rev_option.of_option (Some 42)) A.typerep_of_t); ;; TEST_UNIT = let module Rev_int : sig type t = int with typerep val register : unit -> unit end = struct module T = struct type t = int with typerep end include T exception Parse_error of Sexp.t with sexp let t_of_sexp = function | Sexp.Atom str -> let str' = String.copy str in let len = String.length str in let rec aux index index' = if index >= len then () else begin str'.[index] <- str.[index']; aux (succ index) (pred index') end in aux 0 (pred len); int_of_string str' | Sexp.List _ as sexp -> raise (Parse_error sexp) let register () = Type_struct.Generic.register0 (module struct include T let compute = Type_struct.Int end : Type_struct.Generic.S0); S.Of_sexp.register typerep_of_t t_of_sexp end in assert (check 421 Rev_int.typerep_of_t); Rev_int.register(); let `generic t_of_sexp = S.t_of_sexp Rev_int.typerep_of_t in let `generic sexp_of_t = S.sexp_of_t Rev_int.typerep_of_t in assert (Int.equal 421 (t_of_sexp (sexp_of_t 124))); ;; end typerep-113.00.00/lib/000077500000000000000000000000001256342456100142625ustar00rootroot00000000000000typerep-113.00.00/lib/META000066400000000000000000000013511256342456100147330ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: f8d2190c7fcda90d14aa1959da0c683f) version = "113.00.00" description = "Runtime types for OCaml" archive(byte) = "typerep_lib.cma" archive(byte, plugin) = "typerep_lib.cma" archive(native) = "typerep_lib.cmxa" archive(native, plugin) = "typerep_lib.cmxs" exists_if = "typerep_lib.cma" package "syntax" ( version = "113.00.00" description = "Syntax extension for the \"typerep\" converter" requires = "camlp4 type_conv" archive(syntax, preprocessor) = "typerep_syntax.cma" archive(syntax, toploop) = "typerep_syntax.cma" archive(syntax, preprocessor, native) = "typerep_syntax.cmxa" archive(syntax, preprocessor, native, plugin) = "typerep_syntax.cmxs" exists_if = "typerep_syntax.cma" ) # OASIS_STOP typerep-113.00.00/lib/make_typename.ml000066400000000000000000000101771256342456100174410ustar00rootroot00000000000000open 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-113.00.00/lib/make_typename.mli000066400000000000000000000026461256342456100176140ustar00rootroot00000000000000open 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-113.00.00/lib/named_intf.ml000066400000000000000000000006101256342456100167150ustar00rootroot00000000000000module 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-113.00.00/lib/std.ml000066400000000000000000000004751256342456100154140ustar00rootroot00000000000000module 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-113.00.00/lib/std_internal.ml000066400000000000000000000472241256342456100173130ustar00rootroot00000000000000module 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_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 | 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 | 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 | 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 | 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 | 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_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 = () typerep-113.00.00/lib/std_internal.mli000066400000000000000000000207321256342456100174570ustar00rootroot00000000000000(** 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 | 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; } with typerep end module M2 = struct type t = { a : int; b : float; } with typerep end TEST = not (same M1.typerep_of_t M2.typerep_of_t) type a = int with typerep type b = int with typerep TEST = same typerep_of_a typerep_of_b |} This is meant to recover type equality hidden by existential constructors. For a deeper introspection of the structure, [see Type_struct]. 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_char : char Typerep.t val typerep_of_float : float Typerep.t val typerep_of_string : string 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_char : char Typename.t val typename_of_float : float Typename.t val typename_of_string : string 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-113.00.00/lib/type_abstract.ml000066400000000000000000000031101256342456100174530ustar00rootroot00000000000000open Std_internal module Make0 (X : Named_intf.S0) : Typerepable.S0 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-113.00.00/lib/type_abstract.mli000066400000000000000000000020651256342456100176340ustar00rootroot00000000000000(** 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.S0 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-113.00.00/lib/type_equal.ml000066400000000000000000000003761256342456100167720ustar00rootroot00000000000000type (_, _) 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-113.00.00/lib/type_equal.mli000066400000000000000000000007171256342456100171420ustar00rootroot00000000000000(** runtime witnes of type equality this is a reduced version of [Core.Std.Type_equal]. *) type ('a, 'b) 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-113.00.00/lib/type_generic.ml000066400000000000000000000571571256342456100173100ustar00rootroot00000000000000open 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 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; 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 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; 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 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 Pervasives.(==) 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 S0 = sig type t include Typerepable.S0 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 S0) -> 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.lazy_is_val table then let table = Lazy.force table in try Some (find table key) with 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.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 S0 = (val rep : S0) in let witness = Typename.same_witness_exn S0.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) S0.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 S0 = (val compute : S0) in let uid = Typename.uid S0.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 S0 = 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 S0 : S0) (* 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.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-113.00.00/lib/type_generic.mli000066400000000000000000000174671256342456100174610ustar00rootroot00000000000000open 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 type type_struct = Type_struct.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 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_struct.t] ['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 S0) -> 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-113.00.00/lib/type_generic_intf.ml000066400000000000000000000025531256342456100203160ustar00rootroot00000000000000module M (X : sig type 'a t end) = struct module type S0 = sig type t include Typerepable.S0 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-113.00.00/lib/typename.ml000066400000000000000000000146641256342456100164510ustar00rootroot00000000000000(* 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 = Pervasives.compare (a.code : int) b.code let equal a b = Pervasives.(=) (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 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-113.00.00/lib/typename.mli000066400000000000000000000062621256342456100166150ustar00rootroot00000000000000(** 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-113.00.00/lib/typerep_lib.mldylib000066400000000000000000000001401256342456100201510ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 279f1c0ba96f69a9cca8d15c480e40d7) Typerep_lib # OASIS_STOP typerep-113.00.00/lib/typerep_lib.mllib000066400000000000000000000001401256342456100176140ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 279f1c0ba96f69a9cca8d15c480e40d7) Typerep_lib # OASIS_STOP typerep-113.00.00/lib/typerep_lib.mlpack000066400000000000000000000003571256342456100177760ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 084bba238b41bf99434345b4c07fe7f5) Make_typename Named_intf Std Std_internal Type_abstract Type_equal Type_generic_intf Type_generic Typename Typerepable Typerep_obj Variant_and_record_intf # OASIS_STOP typerep-113.00.00/lib/typerep_obj.ml000066400000000000000000000025151256342456100171410ustar00rootroot00000000000000(* 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 = Pervasives.(=) 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-113.00.00/lib/typerep_obj.mli000066400000000000000000000004631256342456100173120ustar00rootroot00000000000000(** 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-113.00.00/lib/typerepable.ml000066400000000000000000000025441256342456100171350ustar00rootroot00000000000000open Std_internal module type S0 = 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-113.00.00/lib/variant_and_record_intf.ml000066400000000000000000000332471256342456100214710ustar00rootroot00000000000000(** 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; 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 this type has two 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 *) 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: | A of int "A" | `a of int "a" | `A of int "A" 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: 0: | A | 'A 1: | A of int | `A of int | A of (int * int) | `A of (int * int) | `A of int * int 2: | A of int * float etc. *) val arity : (_, _) t -> int (** 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 *) *) 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 *) *) 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 [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] *) 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 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 *\) *) } 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 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 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-113.00.00/myocamlbuild.ml000066400000000000000000000430741256342456100165370ustar00rootroot00000000000000(* OASIS_START *) (* DO NOT EDIT (digest: 512e06a1737a85e12aaded74533abdb9) *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) let ns_ str = str let s_ str = str let f_ (str: ('a, 'b, 'c, 'd) format4) = str let fn_ fmt1 fmt2 n = if n = 1 then fmt1^^"" else fmt2^^"" let init = [] end module OASISExpr = struct (* # 22 "src/oasis/OASISExpr.ml" *) open OASISGettext type test = string type flag = string type t = | EBool of bool | ENot of t | EAnd of t * t | EOr of t * t | EFlag of flag | ETest of test * string type 'a choices = (t * 'a) list let eval var_get t = let rec eval' = function | EBool b -> b | ENot e -> not (eval' e) | EAnd (e1, e2) -> (eval' e1) && (eval' e2) | EOr (e1, e2) -> (eval' e1) || (eval' e2) | EFlag nm -> let v = var_get nm in assert(v = "true" || v = "false"); (v = "true") | ETest (nm, vl) -> let v = var_get nm in (v = vl) in eval' t let choose ?printer ?name var_get lst = let rec choose_aux = function | (cond, vl) :: tl -> if eval var_get cond then vl else choose_aux tl | [] -> let str_lst = if lst = [] then s_ "" else String.concat (s_ ", ") (List.map (fun (cond, vl) -> match printer with | Some p -> p vl | None -> s_ "") lst) in match name with | Some nm -> failwith (Printf.sprintf (f_ "No result for the choice list '%s': %s") nm str_lst) | None -> failwith (Printf.sprintf (f_ "No result for a choice list: %s") str_lst) in choose_aux (List.rev lst) end # 132 "myocamlbuild.ml" module BaseEnvLight = struct (* # 22 "src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) type t = string MapString.t let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" let load ?(allow_empty=false) ?(filename=default_filename) () = if Sys.file_exists filename then begin let chn = open_in_bin filename in let st = Stream.of_channel chn in let line = ref 1 in let st_line = Stream.from (fun _ -> try match Stream.next st with | '\n' -> incr line; Some '\n' | c -> Some c with Stream.Failure -> None) in let lexer = Genlex.make_lexer ["="] st_line in let rec read_file mp = match Stream.npeek 3 lexer with | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> Stream.junk lexer; Stream.junk lexer; Stream.junk lexer; read_file (MapString.add nm value mp) | [] -> mp | _ -> failwith (Printf.sprintf "Malformed data file '%s' line %d" filename !line) in let mp = read_file MapString.empty in close_in chn; mp end else if allow_empty then begin MapString.empty end else begin failwith (Printf.sprintf "Unable to load environment, the file '%s' doesn't exist." filename) end let rec var_expand str env = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try var_expand (MapString.find var env) env with Not_found -> failwith (Printf.sprintf "No variable %s defined when trying to expand %S." var str)) str; Buffer.contents buff let var_get name env = var_expand (MapString.find name env) env let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst end # 237 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) (** OCamlbuild extension, copied from * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild * by N. Pouillard and others * * Updated on 2009/02/28 * * Modified by Sylvain Le Gall *) open Ocamlbuild_plugin type conf = { no_automatic_syntax: bool; } (* these functions are not really officially exported *) let run_and_read = Ocamlbuild_pack.My_unix.run_and_read let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings let exec_from_conf exec = let exec = let env_filename = Pathname.basename BaseEnvLight.default_filename in let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in try BaseEnvLight.var_get exec env with Not_found -> Printf.eprintf "W: Cannot get variable %s\n" exec; exec in let fix_win32 str = if Sys.os_type = "Win32" then begin let buff = Buffer.create (String.length str) in (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. *) String.iter (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) str; Buffer.contents buff end else begin str end in fix_win32 exec let split s ch = let buf = Buffer.create 13 in let x = ref [] in let flush () = x := (Buffer.contents buf) :: !x; Buffer.clear buf in String.iter (fun c -> if c = ch then flush () else Buffer.add_char buf c) s; flush (); List.rev !x let split_nl s = split s '\n' let before_space s = try String.before s (String.index s ' ') with Not_found -> s (* ocamlfind command *) let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x] (* This lists all supported packages. *) let find_packages () = List.map before_space (split_nl & run_and_read (exec_from_conf "ocamlfind" ^ " list")) (* Mock to list available syntaxes. *) let find_syntaxes () = ["camlp4o"; "camlp4r"] let well_known_syntax = [ "camlp4.quotations.o"; "camlp4.quotations.r"; "camlp4.exceptiontracer"; "camlp4.extend"; "camlp4.foldgenerator"; "camlp4.listcomprehension"; "camlp4.locationstripper"; "camlp4.macro"; "camlp4.mapgenerator"; "camlp4.metagenerator"; "camlp4.profiler"; "camlp4.tracer" ] let dispatch conf = function | After_options -> (* By using Before_options one let command line options have an higher * priority on the contrary using After_options will guarantee to have * the higher priority override default commands by ocamlfind ones *) Options.ocamlc := ocamlfind & A"ocamlc"; Options.ocamlopt := ocamlfind & A"ocamlopt"; Options.ocamldep := ocamlfind & A"ocamldep"; Options.ocamldoc := ocamlfind & A"ocamldoc"; Options.ocamlmktop := ocamlfind & A"ocamlmktop"; Options.ocamlmklib := ocamlfind & A"ocamlmklib" | After_rules -> (* When one link an OCaml library/binary/package, one should use * -linkpkg *) flag ["ocaml"; "link"; "program"] & A"-linkpkg"; if not (conf.no_automatic_syntax) then begin (* For each ocamlfind package one inject the -package option when * compiling, computing dependencies, generating documentation and * linking. *) List.iter begin fun pkg -> let base_args = [A"-package"; A pkg] in (* TODO: consider how to really choose camlp4o or camlp4r. *) let syn_args = [A"-syntax"; A "camlp4o"] in let (args, pargs) = (* Heuristic to identify syntax extensions: whether they end in ".syntax"; some might not. *) if Filename.check_suffix pkg "syntax" || List.mem pkg well_known_syntax then (syn_args @ base_args, syn_args) else (base_args, []) in flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; (* TODO: Check if this is allowed for OCaml < 3.12.1 *) flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs; flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs; flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs; flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs; end (find_packages ()); end; (* Like -package but for extensions syntax. Morover -syntax is useless * when linking. *) List.iter begin fun syntax -> flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; end (find_syntaxes ()); (* The default "thread" tag is not compatible with ocamlfind. * Indeed, the default rules add the "threads.cma" or "threads.cmxa" * options when using this tag. When using the "-linkpkg" option with * ocamlfind, this module will then be added twice on the command line. * * To solve this, one approach is to add the "-thread" option when using * the "threads" package using the previous plugin. *) flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]); flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]); flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]); flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]); flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]); | _ -> () end module MyOCamlbuildBase = struct (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) (** Base functions for writing myocamlbuild.ml @author Sylvain Le Gall *) open Ocamlbuild_plugin module OC = Ocamlbuild_pack.Ocaml_compiler type dir = string type file = string type name = string type tag = string (* # 62 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) type t = { lib_ocaml: (name * dir list * string list) list; lib_c: (name * dir * file list) list; flags: (tag list * (spec OASISExpr.choices)) list; (* Replace the 'dir: include' from _tags by a precise interdepends in * directory. *) includes: (dir * dir list) list; } let env_filename = Pathname.basename BaseEnvLight.default_filename let dispatch_combine lst = fun e -> List.iter (fun dispatch -> dispatch e) lst let tag_libstubs nm = "use_lib"^nm^"_stubs" let nm_libstubs nm = nm^"_stubs" let dispatch t e = let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in match e with | Before_options -> let no_trailing_dot s = if String.length s >= 1 && s.[0] = '.' then String.sub s 1 ((String.length s) - 1) else s in List.iter (fun (opt, var) -> try opt := no_trailing_dot (BaseEnvLight.var_get var env) with Not_found -> Printf.eprintf "W: Cannot get variable %s\n" var) [ Options.ext_obj, "ext_obj"; Options.ext_lib, "ext_lib"; Options.ext_dll, "ext_dll"; ] | After_rules -> (* Declare OCaml libraries *) List.iter (function | nm, [], intf_modules -> ocaml_lib nm; let cmis = List.map (fun m -> (String.uncapitalize m) ^ ".cmi") intf_modules in dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis | nm, dir :: tl, intf_modules -> ocaml_lib ~dir:dir (dir^"/"^nm); List.iter (fun dir -> List.iter (fun str -> flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) ["compile"; "infer_interface"; "doc"]) tl; let cmis = List.map (fun m -> dir^"/"^(String.uncapitalize m)^".cmi") intf_modules in dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"] cmis) t.lib_ocaml; (* Declare directories dependencies, replace "include" in _tags. *) List.iter (fun (dir, include_dirs) -> Pathname.define_context dir include_dirs) t.includes; (* Declare C libraries *) List.iter (fun (lib, dir, headers) -> (* Handle C part of library *) flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; A("-l"^(nm_libstubs lib))]); flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); (* When ocaml link something that use the C library, then one need that file to be up to date. This holds both for programs and for libraries. *) dep ["link"; "ocaml"; tag_libstubs lib] [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; dep ["compile"; "ocaml"; tag_libstubs lib] [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; (* TODO: be more specific about what depends on headers *) (* Depends on .h files *) dep ["compile"; "c"] headers; (* Setup search path for lib *) flag ["link"; "ocaml"; "use_"^lib] (S[A"-I"; P(dir)]); ) t.lib_c; (* Add flags *) List.iter (fun (tags, cond_specs) -> let spec = BaseEnvLight.var_choose cond_specs env in let rec eval_specs = function | S lst -> S (List.map eval_specs lst) | A str -> A (BaseEnvLight.var_expand str env) | spec -> spec in flag tags & (eval_specs spec)) t.flags | _ -> () let dispatch_default conf t = dispatch_combine [ dispatch t; MyOCamlbuildFindlib.dispatch conf; ] end # 606 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { MyOCamlbuildBase.lib_ocaml = [("typerep_lib", ["lib"], []); ("typerep_syntax", ["syntax"], [])]; lib_c = []; flags = []; includes = [] } ;; let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; # 623 "myocamlbuild.ml" (* OASIS_STOP *) let dispatch = function | Before_options -> Options.make_links := false | After_rules -> let tag = "pa_typerep" and file = "syntax/pa_typerep_conv.cmo" in flag ["ocaml"; "compile"; tag] & S[A"-ppopt"; A file]; flag ["ocaml"; "ocamldep"; tag] & S[A"-ppopt"; A file]; flag ["ocaml"; "doc"; tag] & S[A"-ppopt"; A file]; flag ["ocaml"; "compile"; "locfix"] & S[A"-ppopt"; A "-locloc"]; flag ["ocaml"; "ocamldep"; "locfix"] & S[A"-ppopt"; A "-locloc"]; flag ["ocaml"; "doc"; "locfix"] & S[A"-ppopt"; A "-locloc"]; dep ["ocaml"; "ocamldep"; tag] [file] | _ -> () let () = Ocamlbuild_plugin.dispatch (fun hook -> dispatch hook; dispatch_default hook) typerep-113.00.00/setup.ml000066400000000000000000005313101256342456100152110ustar00rootroot00000000000000(* OASIS_START *) (* DO NOT EDIT (digest: 5d679bcb3d1f0ca8657a02d9d3878bd6) *) (* Regenerated by OASIS v0.4.5 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) let ns_ str = str let s_ str = str let f_ (str: ('a, 'b, 'c, 'd) format4) = str let fn_ fmt1 fmt2 n = if n = 1 then fmt1^^"" else fmt2^^"" let init = [] end module OASISContext = struct (* # 22 "src/oasis/OASISContext.ml" *) open OASISGettext type level = [ `Debug | `Info | `Warning | `Error] type t = { (* TODO: replace this by a proplist. *) quiet: bool; info: bool; debug: bool; ignore_plugins: bool; ignore_unknown_fields: bool; printf: level -> string -> unit; } let printf lvl str = let beg = match lvl with | `Error -> s_ "E: " | `Warning -> s_ "W: " | `Info -> s_ "I: " | `Debug -> s_ "D: " in prerr_endline (beg^str) let default = ref { quiet = false; info = false; debug = false; ignore_plugins = false; ignore_unknown_fields = false; printf = printf; } let quiet = {!default with quiet = true} let fspecs () = (* TODO: don't act on default. *) let ignore_plugins = ref false in ["-quiet", Arg.Unit (fun () -> default := {!default with quiet = true}), s_ " Run quietly"; "-info", Arg.Unit (fun () -> default := {!default with info = true}), s_ " Display information message"; "-debug", Arg.Unit (fun () -> default := {!default with debug = true}), s_ " Output debug message"; "-ignore-plugins", Arg.Set ignore_plugins, s_ " Ignore plugin's field."; "-C", (* TODO: remove this chdir. *) Arg.String (fun str -> Sys.chdir str), s_ "dir Change directory before running."], fun () -> {!default with ignore_plugins = !ignore_plugins} end module OASISString = struct (* # 22 "src/oasis/OASISString.ml" *) (** Various string utilities. Mostly inspired by extlib and batteries ExtString and BatString libraries. @author Sylvain Le Gall *) let nsplitf str f = if str = "" then [] else let buf = Buffer.create 13 in let lst = ref [] in let push () = lst := Buffer.contents buf :: !lst; Buffer.clear buf in let str_len = String.length str in for i = 0 to str_len - 1 do if f str.[i] then push () else Buffer.add_char buf str.[i] done; push (); List.rev !lst (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the separator. *) let nsplit str c = nsplitf str ((=) c) let find ~what ?(offset=0) str = let what_idx = ref 0 in let str_idx = ref offset in while !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx else what_idx := 0; incr str_idx done; if !what_idx <> String.length what then raise Not_found else !str_idx - !what_idx let sub_start str len = let str_len = String.length str in if len >= str_len then "" else String.sub str len (str_len - len) let sub_end ?(offset=0) str len = let str_len = String.length str in if len >= str_len then "" else String.sub str 0 (str_len - len) let starts_with ~what ?(offset=0) str = let what_idx = ref 0 in let str_idx = ref offset in let ok = ref true in while !ok && !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx else ok := false; incr str_idx done; if !what_idx = String.length what then true else false let strip_starts_with ~what str = if starts_with ~what str then sub_start str (String.length what) else raise Not_found let ends_with ~what ?(offset=0) str = let what_idx = ref ((String.length what) - 1) in let str_idx = ref ((String.length str) - 1) in let ok = ref true in while !ok && offset <= !str_idx && 0 <= !what_idx do if str.[!str_idx] = what.[!what_idx] then decr what_idx else ok := false; decr str_idx done; if !what_idx = -1 then true else false let strip_ends_with ~what str = if ends_with ~what str then sub_end str (String.length what) else raise Not_found let replace_chars f s = let buf = Buffer.create (String.length s) in String.iter (fun c -> Buffer.add_char buf (f c)) s; Buffer.contents buf end module OASISUtils = struct (* # 22 "src/oasis/OASISUtils.ml" *) open OASISGettext module MapExt = struct module type S = sig include Map.S val add_list: 'a t -> (key * 'a) list -> 'a t val of_list: (key * 'a) list -> 'a t val to_list: 'a t -> (key * 'a) list end module Make (Ord: Map.OrderedType) = struct include Map.Make(Ord) let rec add_list t = function | (k, v) :: tl -> add_list (add k v t) tl | [] -> t let of_list lst = add_list empty lst let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] end end module MapString = MapExt.Make(String) module SetExt = struct module type S = sig include Set.S val add_list: t -> elt list -> t val of_list: elt list -> t val to_list: t -> elt list end module Make (Ord: Set.OrderedType) = struct include Set.Make(Ord) let rec add_list t = function | e :: tl -> add_list (add e t) tl | [] -> t let of_list lst = add_list empty lst let to_list = elements end end module SetString = SetExt.Make(String) let compare_csl s1 s2 = String.compare (String.lowercase s1) (String.lowercase s2) module HashStringCsl = Hashtbl.Make (struct type t = string let equal s1 s2 = (String.lowercase s1) = (String.lowercase s2) let hash s = Hashtbl.hash (String.lowercase s) end) module SetStringCsl = SetExt.Make (struct type t = string let compare = compare_csl end) let varname_of_string ?(hyphen='_') s = if String.length s = 0 then begin invalid_arg "varname_of_string" end else begin let buf = OASISString.replace_chars (fun c -> if ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') || ('0' <= c && c <= '9') then c else hyphen) s; in let buf = (* Start with a _ if digit *) if '0' <= s.[0] && s.[0] <= '9' then "_"^buf else buf in String.lowercase buf end let varname_concat ?(hyphen='_') p s = let what = String.make 1 hyphen in let p = try OASISString.strip_ends_with ~what p with Not_found -> p in let s = try OASISString.strip_starts_with ~what s with Not_found -> s in p^what^s let is_varname str = str = varname_of_string str let failwithf fmt = Printf.ksprintf failwith fmt end module PropList = struct (* # 22 "src/oasis/PropList.ml" *) open OASISGettext type name = string exception Not_set of name * string option exception No_printer of name exception Unknown_field of name * name let () = Printexc.register_printer (function | Not_set (nm, Some rsn) -> Some (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn) | Not_set (nm, None) -> Some (Printf.sprintf (f_ "Field '%s' is not set") nm) | No_printer nm -> Some (Printf.sprintf (f_ "No default printer for value %s") nm) | Unknown_field (nm, schm) -> Some (Printf.sprintf (f_ "Field %s is not defined in schema %s") nm schm) | _ -> None) module Data = struct type t = (name, unit -> unit) Hashtbl.t let create () = Hashtbl.create 13 let clear t = Hashtbl.clear t (* # 78 "src/oasis/PropList.ml" *) end module Schema = struct type ('ctxt, 'extra) value = { get: Data.t -> string; set: Data.t -> ?context:'ctxt -> string -> unit; help: (unit -> string) option; extra: 'extra; } type ('ctxt, 'extra) t = { name: name; fields: (name, ('ctxt, 'extra) value) Hashtbl.t; order: name Queue.t; name_norm: string -> string; } let create ?(case_insensitive=false) nm = { name = nm; fields = Hashtbl.create 13; order = Queue.create (); name_norm = (if case_insensitive then String.lowercase else fun s -> s); } let add t nm set get extra help = let key = t.name_norm nm in if Hashtbl.mem t.fields key then failwith (Printf.sprintf (f_ "Field '%s' is already defined in schema '%s'") nm t.name); Hashtbl.add t.fields key { set = set; get = get; help = help; extra = extra; }; Queue.add nm t.order let mem t nm = Hashtbl.mem t.fields nm let find t nm = try Hashtbl.find t.fields (t.name_norm nm) with Not_found -> raise (Unknown_field (nm, t.name)) let get t data nm = (find t nm).get data let set t data nm ?context x = (find t nm).set data ?context x let fold f acc t = Queue.fold (fun acc k -> let v = find t k in f acc k v.extra v.help) acc t.order let iter f t = fold (fun () -> f) () t let name t = t.name end module Field = struct type ('ctxt, 'value, 'extra) t = { set: Data.t -> ?context:'ctxt -> 'value -> unit; get: Data.t -> 'value; sets: Data.t -> ?context:'ctxt -> string -> unit; gets: Data.t -> string; help: (unit -> string) option; extra: 'extra; } let new_id = let last_id = ref 0 in fun () -> incr last_id; !last_id let create ?schema ?name ?parse ?print ?default ?update ?help extra = (* Default value container *) let v = ref None in (* If name is not given, create unique one *) let nm = match name with | Some s -> s | None -> Printf.sprintf "_anon_%d" (new_id ()) in (* Last chance to get a value: the default *) let default () = match default with | Some d -> d | None -> raise (Not_set (nm, Some (s_ "no default value"))) in (* Get data *) let get data = (* Get value *) try (Hashtbl.find data nm) (); match !v with | Some x -> x | None -> default () with Not_found -> default () in (* Set data *) let set data ?context x = let x = match update with | Some f -> begin try f ?context (get data) x with Not_set _ -> x end | None -> x in Hashtbl.replace data nm (fun () -> v := Some x) in (* Parse string value, if possible *) let parse = match parse with | Some f -> f | None -> fun ?context s -> failwith (Printf.sprintf (f_ "Cannot parse field '%s' when setting value %S") nm s) in (* Set data, from string *) let sets data ?context s = set ?context data (parse ?context s) in (* Output value as string, if possible *) let print = match print with | Some f -> f | None -> fun _ -> raise (No_printer nm) in (* Get data, as a string *) let gets data = print (get data) in begin match schema with | Some t -> Schema.add t nm sets gets extra help | None -> () end; { set = set; get = get; sets = sets; gets = gets; help = help; extra = extra; } let fset data t ?context x = t.set data ?context x let fget data t = t.get data let fsets data t ?context s = t.sets data ?context s let fgets data t = t.gets data end module FieldRO = struct let create ?schema ?name ?parse ?print ?default ?update ?help extra = let fld = Field.create ?schema ?name ?parse ?print ?default ?update ?help extra in fun data -> Field.fget data fld end end module OASISMessage = struct (* # 22 "src/oasis/OASISMessage.ml" *) open OASISGettext open OASISContext let generic_message ~ctxt lvl fmt = let cond = if ctxt.quiet then false else match lvl with | `Debug -> ctxt.debug | `Info -> ctxt.info | _ -> true in Printf.ksprintf (fun str -> if cond then begin ctxt.printf lvl str end) fmt let debug ~ctxt fmt = generic_message ~ctxt `Debug fmt let info ~ctxt fmt = generic_message ~ctxt `Info fmt let warning ~ctxt fmt = generic_message ~ctxt `Warning fmt let error ~ctxt fmt = generic_message ~ctxt `Error fmt end module OASISVersion = struct (* # 22 "src/oasis/OASISVersion.ml" *) open OASISGettext type s = string type t = string type comparator = | VGreater of t | VGreaterEqual of t | VEqual of t | VLesser of t | VLesserEqual of t | VOr of comparator * comparator | VAnd of comparator * comparator (* Range of allowed characters *) let is_digit c = '0' <= c && c <= '9' let is_alpha c = ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') let is_special = function | '.' | '+' | '-' | '~' -> true | _ -> false let rec version_compare v1 v2 = if v1 <> "" || v2 <> "" then begin (* Compare ascii string, using special meaning for version * related char *) let val_ascii c = if c = '~' then -1 else if is_digit c then 0 else if c = '\000' then 0 else if is_alpha c then Char.code c else (Char.code c) + 256 in let len1 = String.length v1 in let len2 = String.length v2 in let p = ref 0 in (** Compare ascii part *) let compare_vascii () = let cmp = ref 0 in while !cmp = 0 && !p < len1 && !p < len2 && not (is_digit v1.[!p] && is_digit v2.[!p]) do cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]); incr p done; if !cmp = 0 && !p < len1 && !p = len2 then val_ascii v1.[!p] else if !cmp = 0 && !p = len1 && !p < len2 then - (val_ascii v2.[!p]) else !cmp in (** Compare digit part *) let compare_digit () = let extract_int v p = let start_p = !p in while !p < String.length v && is_digit v.[!p] do incr p done; let substr = String.sub v !p ((String.length v) - !p) in let res = match String.sub v start_p (!p - start_p) with | "" -> 0 | s -> int_of_string s in res, substr in let i1, tl1 = extract_int v1 (ref !p) in let i2, tl2 = extract_int v2 (ref !p) in i1 - i2, tl1, tl2 in match compare_vascii () with | 0 -> begin match compare_digit () with | 0, tl1, tl2 -> if tl1 <> "" && is_digit tl1.[0] then 1 else if tl2 <> "" && is_digit tl2.[0] then -1 else version_compare tl1 tl2 | n, _, _ -> n end | n -> n end else begin 0 end let version_of_string str = str let string_of_version t = t let version_compare_string s1 s2 = version_compare (version_of_string s1) (version_of_string s2) let chop t = try let pos = String.rindex t '.' in String.sub t 0 pos with Not_found -> t let rec comparator_apply v op = match op with | VGreater cv -> (version_compare v cv) > 0 | VGreaterEqual cv -> (version_compare v cv) >= 0 | VLesser cv -> (version_compare v cv) < 0 | VLesserEqual cv -> (version_compare v cv) <= 0 | VEqual cv -> (version_compare v cv) = 0 | VOr (op1, op2) -> (comparator_apply v op1) || (comparator_apply v op2) | VAnd (op1, op2) -> (comparator_apply v op1) && (comparator_apply v op2) let rec string_of_comparator = function | VGreater v -> "> "^(string_of_version v) | VEqual v -> "= "^(string_of_version v) | VLesser v -> "< "^(string_of_version v) | VGreaterEqual v -> ">= "^(string_of_version v) | VLesserEqual v -> "<= "^(string_of_version v) | VOr (c1, c2) -> (string_of_comparator c1)^" || "^(string_of_comparator c2) | VAnd (c1, c2) -> (string_of_comparator c1)^" && "^(string_of_comparator c2) let rec varname_of_comparator = let concat p v = OASISUtils.varname_concat p (OASISUtils.varname_of_string (string_of_version v)) in function | VGreater v -> concat "gt" v | VLesser v -> concat "lt" v | VEqual v -> concat "eq" v | VGreaterEqual v -> concat "ge" v | VLesserEqual v -> concat "le" v | VOr (c1, c2) -> (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2) | VAnd (c1, c2) -> (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) let rec comparator_ge v' = let cmp v = version_compare v v' >= 0 in function | VEqual v | VGreaterEqual v | VGreater v -> cmp v | VLesserEqual _ | VLesser _ -> false | VOr (c1, c2) -> comparator_ge v' c1 || comparator_ge v' c2 | VAnd (c1, c2) -> comparator_ge v' c1 && comparator_ge v' c2 end module OASISLicense = struct (* # 22 "src/oasis/OASISLicense.ml" *) (** License for _oasis fields @author Sylvain Le Gall *) type license = string type license_exception = string type license_version = | Version of OASISVersion.t | VersionOrLater of OASISVersion.t | NoVersion type license_dep_5_unit = { license: license; excption: license_exception option; version: license_version; } type license_dep_5 = | DEP5Unit of license_dep_5_unit | DEP5Or of license_dep_5 list | DEP5And of license_dep_5 list type t = | DEP5License of license_dep_5 | OtherLicense of string (* URL *) end module OASISExpr = struct (* # 22 "src/oasis/OASISExpr.ml" *) open OASISGettext type test = string type flag = string type t = | EBool of bool | ENot of t | EAnd of t * t | EOr of t * t | EFlag of flag | ETest of test * string type 'a choices = (t * 'a) list let eval var_get t = let rec eval' = function | EBool b -> b | ENot e -> not (eval' e) | EAnd (e1, e2) -> (eval' e1) && (eval' e2) | EOr (e1, e2) -> (eval' e1) || (eval' e2) | EFlag nm -> let v = var_get nm in assert(v = "true" || v = "false"); (v = "true") | ETest (nm, vl) -> let v = var_get nm in (v = vl) in eval' t let choose ?printer ?name var_get lst = let rec choose_aux = function | (cond, vl) :: tl -> if eval var_get cond then vl else choose_aux tl | [] -> let str_lst = if lst = [] then s_ "" else String.concat (s_ ", ") (List.map (fun (cond, vl) -> match printer with | Some p -> p vl | None -> s_ "") lst) in match name with | Some nm -> failwith (Printf.sprintf (f_ "No result for the choice list '%s': %s") nm str_lst) | None -> failwith (Printf.sprintf (f_ "No result for a choice list: %s") str_lst) in choose_aux (List.rev lst) end module OASISText = struct (* # 22 "src/oasis/OASISText.ml" *) type elt = | Para of string | Verbatim of string | BlankLine type t = elt list end module OASISTypes = struct (* # 22 "src/oasis/OASISTypes.ml" *) type name = string type package_name = string type url = string type unix_dirname = string type unix_filename = string type host_dirname = string type host_filename = string type prog = string type arg = string type args = string list type command_line = (prog * arg list) type findlib_name = string type findlib_full = string type compiled_object = | Byte | Native | Best type dependency = | FindlibPackage of findlib_full * OASISVersion.comparator option | InternalLibrary of name type tool = | ExternalTool of name | InternalExecutable of name type vcs = | Darcs | Git | Svn | Cvs | Hg | Bzr | Arch | Monotone | OtherVCS of url type plugin_kind = [ `Configure | `Build | `Doc | `Test | `Install | `Extra ] type plugin_data_purpose = [ `Configure | `Build | `Install | `Clean | `Distclean | `Install | `Uninstall | `Test | `Doc | `Extra | `Other of string ] type 'a plugin = 'a * name * OASISVersion.t option type all_plugin = plugin_kind plugin type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list (* # 115 "src/oasis/OASISTypes.ml" *) type 'a conditional = 'a OASISExpr.choices type custom = { pre_command: (command_line option) conditional; post_command: (command_line option) conditional; } type common_section = { cs_name: name; cs_data: PropList.Data.t; cs_plugin_data: plugin_data; } type build_section = { bs_build: bool conditional; bs_install: bool conditional; bs_path: unix_dirname; bs_compiled_object: compiled_object; bs_build_depends: dependency list; bs_build_tools: tool list; bs_c_sources: unix_filename list; bs_data_files: (unix_filename * unix_filename option) list; bs_ccopt: args conditional; bs_cclib: args conditional; bs_dlllib: args conditional; bs_dllpath: args conditional; bs_byteopt: args conditional; bs_nativeopt: args conditional; } type library = { lib_modules: string list; lib_pack: bool; lib_internal_modules: string list; lib_findlib_parent: findlib_name option; lib_findlib_name: findlib_name option; lib_findlib_containers: findlib_name list; } type object_ = { obj_modules: string list; obj_findlib_fullname: findlib_name list option; } type executable = { exec_custom: bool; exec_main_is: unix_filename; } type flag = { flag_description: string option; flag_default: bool conditional; } type source_repository = { src_repo_type: vcs; src_repo_location: url; src_repo_browser: url option; src_repo_module: string option; src_repo_branch: string option; src_repo_tag: string option; src_repo_subdir: unix_filename option; } type test = { test_type: [`Test] plugin; test_command: command_line conditional; test_custom: custom; test_working_directory: unix_filename option; test_run: bool conditional; test_tools: tool list; } type doc_format = | HTML of unix_filename | DocText | PDF | PostScript | Info of unix_filename | DVI | OtherDoc type doc = { doc_type: [`Doc] plugin; doc_custom: custom; doc_build: bool conditional; doc_install: bool conditional; doc_install_dir: unix_filename; doc_title: string; doc_authors: string list; doc_abstract: string option; doc_format: doc_format; doc_data_files: (unix_filename * unix_filename option) list; doc_build_tools: tool list; } type section = | Library of common_section * build_section * library | Object of common_section * build_section * object_ | Executable of common_section * build_section * executable | Flag of common_section * flag | SrcRepo of common_section * source_repository | Test of common_section * test | Doc of common_section * doc type section_kind = [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ] type package = { oasis_version: OASISVersion.t; ocaml_version: OASISVersion.comparator option; findlib_version: OASISVersion.comparator option; alpha_features: string list; beta_features: string list; name: package_name; version: OASISVersion.t; license: OASISLicense.t; license_file: unix_filename option; copyrights: string list; maintainers: string list; authors: string list; homepage: url option; synopsis: string; description: OASISText.t option; categories: url list; conf_type: [`Configure] plugin; conf_custom: custom; build_type: [`Build] plugin; build_custom: custom; install_type: [`Install] plugin; install_custom: custom; uninstall_custom: custom; clean_custom: custom; distclean_custom: custom; files_ab: unix_filename list; sections: section list; plugins: [`Extra] plugin list; disable_oasis_section: unix_filename list; schema_data: PropList.Data.t; plugin_data: plugin_data; } end module OASISFeatures = struct (* # 22 "src/oasis/OASISFeatures.ml" *) open OASISTypes open OASISUtils open OASISGettext open OASISVersion module MapPlugin = Map.Make (struct type t = plugin_kind * name let compare = Pervasives.compare end) module Data = struct type t = { oasis_version: OASISVersion.t; plugin_versions: OASISVersion.t option MapPlugin.t; alpha_features: string list; beta_features: string list; } let create oasis_version alpha_features beta_features = { oasis_version = oasis_version; plugin_versions = MapPlugin.empty; alpha_features = alpha_features; beta_features = beta_features } let of_package pkg = create pkg.OASISTypes.oasis_version pkg.OASISTypes.alpha_features pkg.OASISTypes.beta_features let add_plugin (plugin_kind, plugin_name, plugin_version) t = {t with plugin_versions = MapPlugin.add (plugin_kind, plugin_name) plugin_version t.plugin_versions} let plugin_version plugin_kind plugin_name t = MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions let to_string t = Printf.sprintf "oasis_version: %s; alpha_features: %s; beta_features: %s; \ plugins_version: %s" (OASISVersion.string_of_version t.oasis_version) (String.concat ", " t.alpha_features) (String.concat ", " t.beta_features) (String.concat ", " (MapPlugin.fold (fun (_, plg) ver_opt acc -> (plg^ (match ver_opt with | Some v -> " "^(OASISVersion.string_of_version v) | None -> "")) :: acc) t.plugin_versions [])) end type origin = | Field of string * string | Section of string | NoOrigin type stage = Alpha | Beta let string_of_stage = function | Alpha -> "alpha" | Beta -> "beta" let field_of_stage = function | Alpha -> "AlphaFeatures" | Beta -> "BetaFeatures" type publication = InDev of stage | SinceVersion of OASISVersion.t type t = { name: string; plugin: all_plugin option; publication: publication; description: unit -> string; } (* TODO: mutex protect this. *) let all_features = Hashtbl.create 13 let since_version ver_str = SinceVersion (version_of_string ver_str) let alpha = InDev Alpha let beta = InDev Beta let to_string t = Printf.sprintf "feature: %s; plugin: %s; publication: %s" t.name (match t.plugin with | None -> "" | Some (_, nm, _) -> nm) (match t.publication with | InDev stage -> string_of_stage stage | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver)) let data_check t data origin = let no_message = "no message" in let check_feature features stage = let has_feature = List.mem t.name features in if not has_feature then match origin with | Field (fld, where) -> Some (Printf.sprintf (f_ "Field %s in %s is only available when feature %s \ is in field %s.") fld where t.name (field_of_stage stage)) | Section sct -> Some (Printf.sprintf (f_ "Section %s is only available when features %s \ is in field %s.") sct t.name (field_of_stage stage)) | NoOrigin -> Some no_message else None in let version_is_good ~min_version version fmt = let version_is_good = OASISVersion.comparator_apply version (OASISVersion.VGreaterEqual min_version) in Printf.ksprintf (fun str -> if version_is_good then None else Some str) fmt in match origin, t.plugin, t.publication with | _, _, InDev Alpha -> check_feature data.Data.alpha_features Alpha | _, _, InDev Beta -> check_feature data.Data.beta_features Beta | Field(fld, where), None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version (f_ "Field %s in %s is only valid since OASIS v%s, update \ OASISFormat field from '%s' to '%s' after checking \ OASIS changelog.") fld where (string_of_version min_version) (string_of_version data.Data.oasis_version) (string_of_version min_version) | Field(fld, where), Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = try match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> failwithf (f_ "Field %s in %s is only valid for the OASIS \ plugin %s since v%s, but no plugin version is \ defined in the _oasis file, change '%s' to \ '%s (%s)' in your _oasis file.") fld where plugin_name (string_of_version min_version) plugin_name plugin_name (string_of_version min_version) with Not_found -> failwithf (f_ "Field %s in %s is only valid when the OASIS plugin %s \ is defined.") fld where plugin_name in version_is_good ~min_version plugin_version_current (f_ "Field %s in %s is only valid for the OASIS plugin %s \ since v%s, update your plugin from '%s (%s)' to \ '%s (%s)' after checking the plugin's changelog.") fld where plugin_name (string_of_version min_version) plugin_name (string_of_version plugin_version_current) plugin_name (string_of_version min_version) with Failure msg -> Some msg end | Section sct, None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version (f_ "Section %s is only valid for since OASIS v%s, update \ OASISFormat field from '%s' to '%s' after checking OASIS \ changelog.") sct (string_of_version min_version) (string_of_version data.Data.oasis_version) (string_of_version min_version) | Section sct, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = try match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> failwithf (f_ "Section %s is only valid for the OASIS \ plugin %s since v%s, but no plugin version is \ defined in the _oasis file, change '%s' to \ '%s (%s)' in your _oasis file.") sct plugin_name (string_of_version min_version) plugin_name plugin_name (string_of_version min_version) with Not_found -> failwithf (f_ "Section %s is only valid when the OASIS plugin %s \ is defined.") sct plugin_name in version_is_good ~min_version plugin_version_current (f_ "Section %s is only valid for the OASIS plugin %s \ since v%s, update your plugin from '%s (%s)' to \ '%s (%s)' after checking the plugin's changelog.") sct plugin_name (string_of_version min_version) plugin_name (string_of_version plugin_version_current) plugin_name (string_of_version min_version) with Failure msg -> Some msg end | NoOrigin, None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version "%s" no_message | NoOrigin, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> raise Not_found in version_is_good ~min_version plugin_version_current "%s" no_message with Not_found -> Some no_message end let data_assert t data origin = match data_check t data origin with | None -> () | Some str -> failwith str let data_test t data = match data_check t data NoOrigin with | None -> true | Some str -> false let package_test t pkg = data_test t (Data.of_package pkg) let create ?plugin name publication description = let () = if Hashtbl.mem all_features name then failwithf "Feature '%s' is already declared." name in let t = { name = name; plugin = plugin; publication = publication; description = description; } in Hashtbl.add all_features name t; t let get_stage name = try (Hashtbl.find all_features name).publication with Not_found -> failwithf (f_ "Feature %s doesn't exist.") name let list () = Hashtbl.fold (fun _ v acc -> v :: acc) all_features [] (* * Real flags. *) let features = create "features_fields" (since_version "0.4") (fun () -> s_ "Enable to experiment not yet official features.") let flag_docs = create "flag_docs" (since_version "0.3") (fun () -> s_ "Building docs require '-docs' flag at configure.") let flag_tests = create "flag_tests" (since_version "0.3") (fun () -> s_ "Running tests require '-tests' flag at configure.") let pack = create "pack" (since_version "0.3") (fun () -> s_ "Allow to create packed library.") let section_object = create "section_object" beta (fun () -> s_ "Implement an object section.") let dynrun_for_release = create "dynrun_for_release" alpha (fun () -> s_ "Make '-setup-update dynamic' suitable for releasing project.") let compiled_setup_ml = create "compiled_setup_ml" alpha (fun () -> s_ "It compiles the setup.ml and speed-up actions done with it.") let disable_oasis_section = create "disable_oasis_section" alpha (fun () -> s_ "Allows the OASIS section comments and digest to be omitted in \ generated files.") let no_automatic_syntax = create "no_automatic_syntax" alpha (fun () -> s_ "Disable the automatic inclusion of -syntax camlp4o for packages \ that matches the internal heuristic (if a dependency ends with \ a .syntax or is a well known syntax).") end module OASISUnixPath = struct (* # 22 "src/oasis/OASISUnixPath.ml" *) type unix_filename = string type unix_dirname = string type host_filename = string type host_dirname = string let current_dir_name = "." let parent_dir_name = ".." let is_current_dir fn = fn = current_dir_name || fn = "" let concat f1 f2 = if is_current_dir f1 then f2 else let f1' = try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1 in f1'^"/"^f2 let make = function | hd :: tl -> List.fold_left (fun f p -> concat f p) hd tl | [] -> invalid_arg "OASISUnixPath.make" let dirname f = try String.sub f 0 (String.rindex f '/') with Not_found -> current_dir_name let basename f = try let pos_start = (String.rindex f '/') + 1 in String.sub f pos_start ((String.length f) - pos_start) with Not_found -> f let chop_extension f = try let last_dot = String.rindex f '.' in let sub = String.sub f 0 last_dot in try let last_slash = String.rindex f '/' in if last_slash < last_dot then sub else f with Not_found -> sub with Not_found -> f let capitalize_file f = let dir = dirname f in let base = basename f in concat dir (String.capitalize base) let uncapitalize_file f = let dir = dirname f in let base = basename f in concat dir (String.uncapitalize base) end module OASISHostPath = struct (* # 22 "src/oasis/OASISHostPath.ml" *) open Filename module Unix = OASISUnixPath let make = function | [] -> invalid_arg "OASISHostPath.make" | hd :: tl -> List.fold_left Filename.concat hd tl let of_unix ufn = if Sys.os_type = "Unix" then ufn else make (List.map (fun p -> if p = Unix.current_dir_name then current_dir_name else if p = Unix.parent_dir_name then parent_dir_name else p) (OASISString.nsplit ufn '/')) end module OASISSection = struct (* # 22 "src/oasis/OASISSection.ml" *) open OASISTypes let section_kind_common = function | Library (cs, _, _) -> `Library, cs | Object (cs, _, _) -> `Object, cs | Executable (cs, _, _) -> `Executable, cs | Flag (cs, _) -> `Flag, cs | SrcRepo (cs, _) -> `SrcRepo, cs | Test (cs, _) -> `Test, cs | Doc (cs, _) -> `Doc, cs let section_common sct = snd (section_kind_common sct) let section_common_set cs = function | Library (_, bs, lib) -> Library (cs, bs, lib) | Object (_, bs, obj) -> Object (cs, bs, obj) | Executable (_, bs, exec) -> Executable (cs, bs, exec) | Flag (_, flg) -> Flag (cs, flg) | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) | Test (_, tst) -> Test (cs, tst) | Doc (_, doc) -> Doc (cs, doc) (** Key used to identify section *) let section_id sct = let k, cs = section_kind_common sct in k, cs.cs_name let string_of_section sct = let k, nm = section_id sct in (match k with | `Library -> "library" | `Object -> "object" | `Executable -> "executable" | `Flag -> "flag" | `SrcRepo -> "src repository" | `Test -> "test" | `Doc -> "doc") ^" "^nm let section_find id scts = List.find (fun sct -> id = section_id sct) scts module CSection = struct type t = section let id = section_id let compare t1 t2 = compare (id t1) (id t2) let equal t1 t2 = (id t1) = (id t2) let hash t = Hashtbl.hash (id t) end module MapSection = Map.Make(CSection) module SetSection = Set.Make(CSection) end module OASISBuildSection = struct (* # 22 "src/oasis/OASISBuildSection.ml" *) end module OASISExecutable = struct (* # 22 "src/oasis/OASISExecutable.ml" *) open OASISTypes let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = let dir = OASISUnixPath.concat bs.bs_path (OASISUnixPath.dirname exec.exec_main_is) in let is_native_exec = match bs.bs_compiled_object with | Native -> true | Best -> is_native () | Byte -> false in OASISUnixPath.concat dir (cs.cs_name^(suffix_program ())), if not is_native_exec && not exec.exec_custom && bs.bs_c_sources <> [] then Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ())) else None end module OASISLibrary = struct (* # 22 "src/oasis/OASISLibrary.ml" *) open OASISTypes open OASISUtils open OASISGettext open OASISSection (* Look for a module file, considering capitalization or not. *) let find_module source_file_exists bs modul = let possible_base_fn = List.map (OASISUnixPath.concat bs.bs_path) [modul; OASISUnixPath.uncapitalize_file modul; OASISUnixPath.capitalize_file modul] in (* TODO: we should be able to be able to determine the source for every * files. Hence we should introduce a Module(source: fn) for the fields * Modules and InternalModules *) List.fold_left (fun acc base_fn -> match acc with | `No_sources _ -> begin let file_found = List.fold_left (fun acc ext -> if source_file_exists (base_fn^ext) then (base_fn^ext) :: acc else acc) [] [".ml"; ".mli"; ".mll"; ".mly"] in match file_found with | [] -> acc | lst -> `Sources (base_fn, lst) end | `Sources _ -> acc) (`No_sources possible_base_fn) possible_base_fn let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = List.fold_left (fun acc modul -> match find_module source_file_exists bs modul with | `Sources (base_fn, lst) -> (base_fn, lst) :: acc | `No_sources _ -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in library %s") modul cs.cs_name; acc) [] (lib.lib_modules @ lib.lib_internal_modules) let generated_unix_files ~ctxt ~is_native ~has_native_dynlink ~ext_lib ~ext_dll ~source_file_exists (cs, bs, lib) = let find_modules lst ext = let find_module modul = match find_module source_file_exists bs modul with | `Sources (base_fn, [fn]) when ext <> "cmi" && Filename.check_suffix fn ".mli" -> None (* No implementation files for pure interface. *) | `Sources (base_fn, _) -> Some [base_fn] | `No_sources lst -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in library %s") modul cs.cs_name; Some lst in List.fold_left (fun acc nm -> match find_module nm with | None -> acc | Some base_fns -> List.map (fun base_fn -> base_fn ^"."^ext) base_fns :: acc) [] lst in (* The .cmx that be compiled along *) let cmxs = let should_be_built = match bs.bs_compiled_object with | Native -> true | Best -> is_native | Byte -> false in if should_be_built then if lib.lib_pack then find_modules [cs.cs_name] "cmx" else find_modules (lib.lib_modules @ lib.lib_internal_modules) "cmx" else [] in let acc_nopath = [] in (* The headers and annot/cmt files that should be compiled along *) let headers = let sufx = if lib.lib_pack then [".cmti"; ".cmt"; ".annot"] else [".cmi"; ".cmti"; ".cmt"; ".annot"] in List.map begin List.fold_left begin fun accu s -> let dot = String.rindex s '.' in let base = String.sub s 0 dot in List.map ((^) base) sufx @ accu end [] end (find_modules lib.lib_modules "cmi") in (* Compute what libraries should be built *) let acc_nopath = (* Add the packed header file if required *) let add_pack_header acc = if lib.lib_pack then [cs.cs_name^".cmi"; cs.cs_name^".cmti"; cs.cs_name^".cmt"] :: acc else acc in let byte acc = add_pack_header ([cs.cs_name^".cma"] :: acc) in let native acc = let acc = add_pack_header (if has_native_dynlink then [cs.cs_name^".cmxs"] :: acc else acc) in [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc in match bs.bs_compiled_object with | Native -> byte (native acc_nopath) | Best when is_native -> byte (native acc_nopath) | Byte | Best -> byte acc_nopath in (* Add C library to be built *) let acc_nopath = if bs.bs_c_sources <> [] then begin ["lib"^cs.cs_name^"_stubs"^ext_lib] :: ["dll"^cs.cs_name^"_stubs"^ext_dll] :: acc_nopath end else acc_nopath in (* All the files generated *) List.rev_append (List.rev_map (List.rev_map (OASISUnixPath.concat bs.bs_path)) acc_nopath) (headers @ cmxs) end module OASISObject = struct (* # 22 "src/oasis/OASISObject.ml" *) open OASISTypes open OASISGettext let source_unix_files ~ctxt (cs, bs, obj) source_file_exists = List.fold_left (fun acc modul -> match OASISLibrary.find_module source_file_exists bs modul with | `Sources (base_fn, lst) -> (base_fn, lst) :: acc | `No_sources _ -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in object %s") modul cs.cs_name; acc) [] obj.obj_modules let generated_unix_files ~ctxt ~is_native ~source_file_exists (cs, bs, obj) = let find_module ext modul = match OASISLibrary.find_module source_file_exists bs modul with | `Sources (base_fn, _) -> [base_fn ^ ext] | `No_sources lst -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in object %s") modul cs.cs_name ; lst in let header, byte, native, c_object, f = match obj.obj_modules with | [ m ] -> (find_module ".cmi" m, find_module ".cmo" m, find_module ".cmx" m, find_module ".o" m, fun x -> x) | _ -> ([cs.cs_name ^ ".cmi"], [cs.cs_name ^ ".cmo"], [cs.cs_name ^ ".cmx"], [cs.cs_name ^ ".o"], OASISUnixPath.concat bs.bs_path) in List.map (List.map f) ( match bs.bs_compiled_object with | Native -> native :: c_object :: byte :: header :: [] | Best when is_native -> native :: c_object :: byte :: header :: [] | Byte | Best -> byte :: header :: []) end module OASISFindlib = struct (* # 22 "src/oasis/OASISFindlib.ml" *) open OASISTypes open OASISUtils open OASISGettext open OASISSection type library_name = name type findlib_part_name = name type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t exception InternalLibraryNotFound of library_name exception FindlibPackageNotFound of findlib_name type group_t = | Container of findlib_name * group_t list | Package of (findlib_name * common_section * build_section * [`Library of library | `Object of object_] * group_t list) type data = common_section * build_section * [`Library of library | `Object of object_] type tree = | Node of (data option) * (tree MapString.t) | Leaf of data let findlib_mapping pkg = (* Map from library name to either full findlib name or parts + parent. *) let fndlb_parts_of_lib_name = let fndlb_parts cs lib = let name = match lib.lib_findlib_name with | Some nm -> nm | None -> cs.cs_name in let name = String.concat "." (lib.lib_findlib_containers @ [name]) in name in List.fold_left (fun mp -> function | Library (cs, _, lib) -> begin let lib_name = cs.cs_name in let fndlb_parts = fndlb_parts cs lib in if MapString.mem lib_name mp then failwithf (f_ "The library name '%s' is used more than once.") lib_name; match lib.lib_findlib_parent with | Some lib_name_parent -> MapString.add lib_name (`Unsolved (lib_name_parent, fndlb_parts)) mp | None -> MapString.add lib_name (`Solved fndlb_parts) mp end | Object (cs, _, obj) -> begin let obj_name = cs.cs_name in if MapString.mem obj_name mp then failwithf (f_ "The object name '%s' is used more than once.") obj_name; let findlib_full_name = match obj.obj_findlib_fullname with | Some ns -> String.concat "." ns | None -> obj_name in MapString.add obj_name (`Solved findlib_full_name) mp end | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> mp) MapString.empty pkg.sections in (* Solve the above graph to be only library name to full findlib name. *) let fndlb_name_of_lib_name = let rec solve visited mp lib_name lib_name_child = if SetString.mem lib_name visited then failwithf (f_ "Library '%s' is involved in a cycle \ with regard to findlib naming.") lib_name; let visited = SetString.add lib_name visited in try match MapString.find lib_name mp with | `Solved fndlb_nm -> fndlb_nm, mp | `Unsolved (lib_nm_parent, post_fndlb_nm) -> let pre_fndlb_nm, mp = solve visited mp lib_nm_parent lib_name in let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp with Not_found -> failwithf (f_ "Library '%s', which is defined as the findlib parent of \ library '%s', doesn't exist.") lib_name lib_name_child in let mp = MapString.fold (fun lib_name status mp -> match status with | `Solved _ -> (* Solved initialy, no need to go further *) mp | `Unsolved _ -> let _, mp = solve SetString.empty mp lib_name "" in mp) fndlb_parts_of_lib_name fndlb_parts_of_lib_name in MapString.map (function | `Solved fndlb_nm -> fndlb_nm | `Unsolved _ -> assert false) mp in (* Convert an internal library name to a findlib name. *) let findlib_name_of_library_name lib_nm = try MapString.find lib_nm fndlb_name_of_lib_name with Not_found -> raise (InternalLibraryNotFound lib_nm) in (* Add a library to the tree. *) let add sct mp = let fndlb_fullname = let cs, _, _ = sct in let lib_name = cs.cs_name in findlib_name_of_library_name lib_name in let rec add_children nm_lst (children: tree MapString.t) = match nm_lst with | (hd :: tl) -> begin let node = try add_node tl (MapString.find hd children) with Not_found -> (* New node *) new_node tl in MapString.add hd node children end | [] -> (* Should not have a nameless library. *) assert false and add_node tl node = if tl = [] then begin match node with | Node (None, children) -> Node (Some sct, children) | Leaf (cs', _, _) | Node (Some (cs', _, _), _) -> (* TODO: allow to merge Package, i.e. * archive(byte) = "foo.cma foo_init.cmo" *) let cs, _, _ = sct in failwithf (f_ "Library '%s' and '%s' have the same findlib name '%s'") cs.cs_name cs'.cs_name fndlb_fullname end else begin match node with | Leaf data -> Node (Some data, add_children tl MapString.empty) | Node (data_opt, children) -> Node (data_opt, add_children tl children) end and new_node = function | [] -> Leaf sct | hd :: tl -> Node (None, MapString.add hd (new_node tl) MapString.empty) in add_children (OASISString.nsplit fndlb_fullname '.') mp in let rec group_of_tree mp = MapString.fold (fun nm node acc -> let cur = match node with | Node (Some (cs, bs, lib), children) -> Package (nm, cs, bs, lib, group_of_tree children) | Node (None, children) -> Container (nm, group_of_tree children) | Leaf (cs, bs, lib) -> Package (nm, cs, bs, lib, []) in cur :: acc) mp [] in let group_mp = List.fold_left (fun mp -> function | Library (cs, bs, lib) -> add (cs, bs, `Library lib) mp | Object (cs, bs, obj) -> add (cs, bs, `Object obj) mp | _ -> mp) MapString.empty pkg.sections in let groups = group_of_tree group_mp in let library_name_of_findlib_name = lazy begin (* Revert findlib_name_of_library_name. *) MapString.fold (fun k v mp -> MapString.add v k mp) fndlb_name_of_lib_name MapString.empty end in let library_name_of_findlib_name fndlb_nm = try MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name) with Not_found -> raise (FindlibPackageNotFound fndlb_nm) in groups, findlib_name_of_library_name, library_name_of_findlib_name let findlib_of_group = function | Container (fndlb_nm, _) | Package (fndlb_nm, _, _, _, _) -> fndlb_nm let root_of_group grp = let rec root_lib_aux = (* We do a DFS in the group. *) function | Container (_, children) -> List.fold_left (fun res grp -> if res = None then root_lib_aux grp else res) None children | Package (_, cs, bs, lib, _) -> Some (cs, bs, lib) in match root_lib_aux grp with | Some res -> res | None -> failwithf (f_ "Unable to determine root library of findlib library '%s'") (findlib_of_group grp) end module OASISFlag = struct (* # 22 "src/oasis/OASISFlag.ml" *) end module OASISPackage = struct (* # 22 "src/oasis/OASISPackage.ml" *) end module OASISSourceRepository = struct (* # 22 "src/oasis/OASISSourceRepository.ml" *) end module OASISTest = struct (* # 22 "src/oasis/OASISTest.ml" *) end module OASISDocument = struct (* # 22 "src/oasis/OASISDocument.ml" *) end module OASISExec = struct (* # 22 "src/oasis/OASISExec.ml" *) open OASISGettext open OASISUtils open OASISMessage (* TODO: I don't like this quote, it is there because $(rm) foo expands to * 'rm -f' foo... *) let run ~ctxt ?f_exit_code ?(quote=true) cmd args = let cmd = if quote then if Sys.os_type = "Win32" then if String.contains cmd ' ' then (* Double the 1st double quote... win32... sigh *) "\""^(Filename.quote cmd) else cmd else Filename.quote cmd else cmd in let cmdline = String.concat " " (cmd :: args) in info ~ctxt (f_ "Running command '%s'") cmdline; match f_exit_code, Sys.command cmdline with | None, 0 -> () | None, i -> failwithf (f_ "Command '%s' terminated with error code %d") cmdline i | Some f, i -> f i let run_read_output ~ctxt ?f_exit_code cmd args = let fn = Filename.temp_file "oasis-" ".txt" in try begin let () = run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn]) in let chn = open_in fn in let routput = ref [] in begin try while true do routput := (input_line chn) :: !routput done with End_of_file -> () end; close_in chn; Sys.remove fn; List.rev !routput end with e -> (try Sys.remove fn with _ -> ()); raise e let run_read_one_line ~ctxt ?f_exit_code cmd args = match run_read_output ~ctxt ?f_exit_code cmd args with | [fst] -> fst | lst -> failwithf (f_ "Command return unexpected output %S") (String.concat "\n" lst) end module OASISFileUtil = struct (* # 22 "src/oasis/OASISFileUtil.ml" *) open OASISGettext let file_exists_case fn = let dirname = Filename.dirname fn in let basename = Filename.basename fn in if Sys.file_exists dirname then if basename = Filename.current_dir_name then true else List.mem basename (Array.to_list (Sys.readdir dirname)) else false let find_file ?(case_sensitive=true) paths exts = (* Cardinal product of two list *) let ( * ) lst1 lst2 = List.flatten (List.map (fun a -> List.map (fun b -> a, b) lst2) lst1) in let rec combined_paths lst = match lst with | p1 :: p2 :: tl -> let acc = (List.map (fun (a, b) -> Filename.concat a b) (p1 * p2)) in combined_paths (acc :: tl) | [e] -> e | [] -> [] in let alternatives = List.map (fun (p, e) -> if String.length e > 0 && e.[0] <> '.' then p ^ "." ^ e else p ^ e) ((combined_paths paths) * exts) in List.find (fun file -> (if case_sensitive then file_exists_case file else Sys.file_exists file) && not (Sys.is_directory file) ) alternatives let which ~ctxt prg = let path_sep = match Sys.os_type with | "Win32" -> ';' | _ -> ':' in let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in let exec_ext = match Sys.os_type with | "Win32" -> "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep) | _ -> [""] in find_file ~case_sensitive:false [path_lst; [prg]] exec_ext (**/**) let rec fix_dir dn = (* Windows hack because Sys.file_exists "src\\" = false when * Sys.file_exists "src" = true *) let ln = String.length dn in if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then fix_dir (String.sub dn 0 (ln - 1)) else dn let q = Filename.quote (**/**) let cp ~ctxt ?(recurse=false) src tgt = if recurse then match Sys.os_type with | "Win32" -> OASISExec.run ~ctxt "xcopy" [q src; q tgt; "/E"] | _ -> OASISExec.run ~ctxt "cp" ["-r"; q src; q tgt] else OASISExec.run ~ctxt (match Sys.os_type with | "Win32" -> "copy" | _ -> "cp") [q src; q tgt] let mkdir ~ctxt tgt = OASISExec.run ~ctxt (match Sys.os_type with | "Win32" -> "md" | _ -> "mkdir") [q tgt] let rec mkdir_parent ~ctxt f tgt = let tgt = fix_dir tgt in if Sys.file_exists tgt then begin if not (Sys.is_directory tgt) then OASISUtils.failwithf (f_ "Cannot create directory '%s', a file of the same name already \ exists") tgt end else begin mkdir_parent ~ctxt f (Filename.dirname tgt); if not (Sys.file_exists tgt) then begin f tgt; mkdir ~ctxt tgt end end let rmdir ~ctxt tgt = if Sys.readdir tgt = [||] then begin match Sys.os_type with | "Win32" -> OASISExec.run ~ctxt "rd" [q tgt] | _ -> OASISExec.run ~ctxt "rm" ["-r"; q tgt] end else begin OASISMessage.error ~ctxt (f_ "Cannot remove directory '%s': not empty.") tgt end let glob ~ctxt fn = let basename = Filename.basename fn in if String.length basename >= 2 && basename.[0] = '*' && basename.[1] = '.' then begin let ext_len = (String.length basename) - 2 in let ext = String.sub basename 2 ext_len in let dirname = Filename.dirname fn in Array.fold_left (fun acc fn -> try let fn_ext = String.sub fn ((String.length fn) - ext_len) ext_len in if fn_ext = ext then (Filename.concat dirname fn) :: acc else acc with Invalid_argument _ -> acc) [] (Sys.readdir dirname) end else begin if file_exists_case fn then [fn] else [] end end # 2893 "setup.ml" module BaseEnvLight = struct (* # 22 "src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) type t = string MapString.t let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" let load ?(allow_empty=false) ?(filename=default_filename) () = if Sys.file_exists filename then begin let chn = open_in_bin filename in let st = Stream.of_channel chn in let line = ref 1 in let st_line = Stream.from (fun _ -> try match Stream.next st with | '\n' -> incr line; Some '\n' | c -> Some c with Stream.Failure -> None) in let lexer = Genlex.make_lexer ["="] st_line in let rec read_file mp = match Stream.npeek 3 lexer with | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> Stream.junk lexer; Stream.junk lexer; Stream.junk lexer; read_file (MapString.add nm value mp) | [] -> mp | _ -> failwith (Printf.sprintf "Malformed data file '%s' line %d" filename !line) in let mp = read_file MapString.empty in close_in chn; mp end else if allow_empty then begin MapString.empty end else begin failwith (Printf.sprintf "Unable to load environment, the file '%s' doesn't exist." filename) end let rec var_expand str env = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try var_expand (MapString.find var env) env with Not_found -> failwith (Printf.sprintf "No variable %s defined when trying to expand %S." var str)) str; Buffer.contents buff let var_get name env = var_expand (MapString.find name env) env let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst end # 2998 "setup.ml" module BaseContext = struct (* # 22 "src/base/BaseContext.ml" *) (* TODO: get rid of this module. *) open OASISContext let args () = fst (fspecs ()) let default = default end module BaseMessage = struct (* # 22 "src/base/BaseMessage.ml" *) (** Message to user, overrid for Base @author Sylvain Le Gall *) open OASISMessage open BaseContext let debug fmt = debug ~ctxt:!default fmt let info fmt = info ~ctxt:!default fmt let warning fmt = warning ~ctxt:!default fmt let error fmt = error ~ctxt:!default fmt end module BaseEnv = struct (* # 22 "src/base/BaseEnv.ml" *) open OASISGettext open OASISUtils open PropList module MapString = BaseEnvLight.MapString type origin_t = | ODefault | OGetEnv | OFileLoad | OCommandLine type cli_handle_t = | CLINone | CLIAuto | CLIWith | CLIEnable | CLIUser of (Arg.key * Arg.spec * Arg.doc) list type definition_t = { hide: bool; dump: bool; cli: cli_handle_t; arg_help: string option; group: string option; } let schema = Schema.create "environment" (* Environment data *) let env = Data.create () (* Environment data from file *) let env_from_file = ref MapString.empty (* Lexer for var *) let var_lxr = Genlex.make_lexer [] let rec var_expand str = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try (* TODO: this is a quick hack to allow calling Test.Command * without defining executable name really. I.e. if there is * an exec Executable toto, then $(toto) should be replace * by its real name. It is however useful to have this function * for other variable that depend on the host and should be * written better than that. *) let st = var_lxr (Stream.of_string var) in match Stream.npeek 3 st with | [Genlex.Ident "utoh"; Genlex.Ident nm] -> OASISHostPath.of_unix (var_get nm) | [Genlex.Ident "utoh"; Genlex.String s] -> OASISHostPath.of_unix s | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> String.escaped (var_get nm) | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> String.escaped s | [Genlex.Ident nm] -> var_get nm | _ -> failwithf (f_ "Unknown expression '%s' in variable expansion of %s.") var str with | Unknown_field (_, _) -> failwithf (f_ "No variable %s defined when trying to expand %S.") var str | Stream.Error e -> failwithf (f_ "Syntax error when parsing '%s' when trying to \ expand %S: %s") var str e) str; Buffer.contents buff and var_get name = let vl = try Schema.get schema env name with Unknown_field _ as e -> begin try MapString.find name !env_from_file with Not_found -> raise e end in var_expand vl let var_choose ?printer ?name lst = OASISExpr.choose ?printer ?name var_get lst let var_protect vl = let buff = Buffer.create (String.length vl) in String.iter (function | '$' -> Buffer.add_string buff "\\$" | c -> Buffer.add_char buff c) vl; Buffer.contents buff let var_define ?(hide=false) ?(dump=true) ?short_desc ?(cli=CLINone) ?arg_help ?group name (* TODO: type constraint on the fact that name must be a valid OCaml id *) dflt = let default = [ OFileLoad, (fun () -> MapString.find name !env_from_file); ODefault, dflt; OGetEnv, (fun () -> Sys.getenv name); ] in let extra = { hide = hide; dump = dump; cli = cli; arg_help = arg_help; group = group; } in (* Try to find a value that can be defined *) let var_get_low lst = let errors, res = List.fold_left (fun (errors, res) (o, v) -> if res = None then begin try errors, Some (v ()) with | Not_found -> errors, res | Failure rsn -> (rsn :: errors), res | e -> (Printexc.to_string e) :: errors, res end else errors, res) ([], None) (List.sort (fun (o1, _) (o2, _) -> Pervasives.compare o2 o1) lst) in match res, errors with | Some v, _ -> v | None, [] -> raise (Not_set (name, None)) | None, lst -> raise (Not_set (name, Some (String.concat (s_ ", ") lst))) in let help = match short_desc with | Some fs -> Some fs | None -> None in let var_get_lst = FieldRO.create ~schema ~name ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s]) ~print:var_get_low ~default ~update:(fun ?context x old_x -> x @ old_x) ?help extra in fun () -> var_expand (var_get_low (var_get_lst env)) let var_redefine ?hide ?dump ?short_desc ?cli ?arg_help ?group name dflt = if Schema.mem schema name then begin (* TODO: look suspsicious, we want to memorize dflt not dflt () *) Schema.set schema env ~context:ODefault name (dflt ()); fun () -> var_get name end else begin var_define ?hide ?dump ?short_desc ?cli ?arg_help ?group name dflt end let var_ignore (e: unit -> string) = () let print_hidden = var_define ~hide:true ~dump:false ~cli:CLIAuto ~arg_help:"Print even non-printable variable. (debug)" "print_hidden" (fun () -> "false") let var_all () = List.rev (Schema.fold (fun acc nm def _ -> if not def.hide || bool_of_string (print_hidden ()) then nm :: acc else acc) [] schema) let default_filename = BaseEnvLight.default_filename let load ?allow_empty ?filename () = env_from_file := BaseEnvLight.load ?allow_empty ?filename () let unload () = env_from_file := MapString.empty; Data.clear env let dump ?(filename=default_filename) () = let chn = open_out_bin filename in let output nm value = Printf.fprintf chn "%s=%S\n" nm value in let mp_todo = (* Dump data from schema *) Schema.fold (fun mp_todo nm def _ -> if def.dump then begin try let value = Schema.get schema env nm in output nm value with Not_set _ -> () end; MapString.remove nm mp_todo) !env_from_file schema in (* Dump data defined outside of schema *) MapString.iter output mp_todo; (* End of the dump *) close_out chn let print () = let printable_vars = Schema.fold (fun acc nm def short_descr_opt -> if not def.hide || bool_of_string (print_hidden ()) then begin try let value = Schema.get schema env nm in let txt = match short_descr_opt with | Some s -> s () | None -> nm in (txt, value) :: acc with Not_set _ -> acc end else acc) [] schema in let max_length = List.fold_left max 0 (List.rev_map String.length (List.rev_map fst printable_vars)) in let dot_pad str = String.make ((max_length - (String.length str)) + 3) '.' in Printf.printf "\nConfiguration: \n"; List.iter (fun (name, value) -> Printf.printf "%s: %s %s\n" name (dot_pad name) value) (List.rev printable_vars); Printf.printf "\n%!" let args () = let arg_concat = OASISUtils.varname_concat ~hyphen:'-' in [ "--override", Arg.Tuple ( let rvr = ref "" in let rvl = ref "" in [ Arg.Set_string rvr; Arg.Set_string rvl; Arg.Unit (fun () -> Schema.set schema env ~context:OCommandLine !rvr !rvl) ] ), "var+val Override any configuration variable."; ] @ List.flatten (Schema.fold (fun acc name def short_descr_opt -> let var_set s = Schema.set schema env ~context:OCommandLine name s in let arg_name = OASISUtils.varname_of_string ~hyphen:'-' name in let hlp = match short_descr_opt with | Some txt -> txt () | None -> "" in let arg_hlp = match def.arg_help with | Some s -> s | None -> "str" in let default_value = try Printf.sprintf (f_ " [%s]") (Schema.get schema env name) with Not_set _ -> "" in let args = match def.cli with | CLINone -> [] | CLIAuto -> [ arg_concat "--" arg_name, Arg.String var_set, Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value ] | CLIWith -> [ arg_concat "--with-" arg_name, Arg.String var_set, Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value ] | CLIEnable -> let dflt = if default_value = " [true]" then s_ " [default: enabled]" else s_ " [default: disabled]" in [ arg_concat "--enable-" arg_name, Arg.Unit (fun () -> var_set "true"), Printf.sprintf (f_ " %s%s") hlp dflt; arg_concat "--disable-" arg_name, Arg.Unit (fun () -> var_set "false"), Printf.sprintf (f_ " %s%s") hlp dflt ] | CLIUser lst -> lst in args :: acc) [] schema) end module BaseArgExt = struct (* # 22 "src/base/BaseArgExt.ml" *) open OASISUtils open OASISGettext let parse argv args = (* Simulate command line for Arg *) let current = ref 0 in try Arg.parse_argv ~current:current (Array.concat [[|"none"|]; argv]) (Arg.align args) (failwithf (f_ "Don't know what to do with arguments: '%s'")) (s_ "configure options:") with | Arg.Help txt -> print_endline txt; exit 0 | Arg.Bad txt -> prerr_endline txt; exit 1 end module BaseCheck = struct (* # 22 "src/base/BaseCheck.ml" *) open BaseEnv open BaseMessage open OASISUtils open OASISGettext let prog_best prg prg_lst = var_redefine prg (fun () -> let alternate = List.fold_left (fun res e -> match res with | Some _ -> res | None -> try Some (OASISFileUtil.which ~ctxt:!BaseContext.default e) with Not_found -> None) None prg_lst in match alternate with | Some prg -> prg | None -> raise Not_found) let prog prg = prog_best prg [prg] let prog_opt prg = prog_best prg [prg^".opt"; prg] let ocamlfind = prog "ocamlfind" let version var_prefix cmp fversion () = (* Really compare version provided *) let var = var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp) in var_redefine ~hide:true var (fun () -> let version_str = match fversion () with | "[Distributed with OCaml]" -> begin try (var_get "ocaml_version") with Not_found -> warning (f_ "Variable ocaml_version not defined, fallback \ to default"); Sys.ocaml_version end | res -> res in let version = OASISVersion.version_of_string version_str in if OASISVersion.comparator_apply version cmp then version_str else failwithf (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") var_prefix (OASISVersion.string_of_comparator cmp) version_str) () let package_version pkg = OASISExec.run_read_one_line ~ctxt:!BaseContext.default (ocamlfind ()) ["query"; "-format"; "%v"; pkg] let package ?version_comparator pkg () = let var = OASISUtils.varname_concat "pkg_" (OASISUtils.varname_of_string pkg) in let findlib_dir pkg = let dir = OASISExec.run_read_one_line ~ctxt:!BaseContext.default (ocamlfind ()) ["query"; "-format"; "%d"; pkg] in if Sys.file_exists dir && Sys.is_directory dir then dir else failwithf (f_ "When looking for findlib package %s, \ directory %s return doesn't exist") pkg dir in let vl = var_redefine var (fun () -> findlib_dir pkg) () in ( match version_comparator with | Some ver_cmp -> ignore (version var ver_cmp (fun _ -> package_version pkg) ()) | None -> () ); vl end module BaseOCamlcConfig = struct (* # 22 "src/base/BaseOCamlcConfig.ml" *) open BaseEnv open OASISUtils open OASISGettext module SMap = Map.Make(String) let ocamlc = BaseCheck.prog_opt "ocamlc" let ocamlc_config_map = (* Map name to value for ocamlc -config output (name ^": "^value) *) let rec split_field mp lst = match lst with | line :: tl -> let mp = try let pos_semicolon = String.index line ':' in if pos_semicolon > 1 then ( let name = String.sub line 0 pos_semicolon in let linelen = String.length line in let value = if linelen > pos_semicolon + 2 then String.sub line (pos_semicolon + 2) (linelen - pos_semicolon - 2) else "" in SMap.add name value mp ) else ( mp ) with Not_found -> ( mp ) in split_field mp tl | [] -> mp in let cache = lazy (var_protect (Marshal.to_string (split_field SMap.empty (OASISExec.run_read_output ~ctxt:!BaseContext.default (ocamlc ()) ["-config"])) [])) in var_redefine "ocamlc_config_map" ~hide:true ~dump:false (fun () -> (* TODO: update if ocamlc change !!! *) Lazy.force cache) let var_define nm = (* Extract data from ocamlc -config *) let avlbl_config_get () = Marshal.from_string (ocamlc_config_map ()) 0 in let chop_version_suffix s = try String.sub s 0 (String.index s '+') with _ -> s in let nm_config, value_config = match nm with | "ocaml_version" -> "version", chop_version_suffix | _ -> nm, (fun x -> x) in var_redefine nm (fun () -> try let map = avlbl_config_get () in let value = SMap.find nm_config map in value_config value with Not_found -> failwithf (f_ "Cannot find field '%s' in '%s -config' output") nm (ocamlc ())) end module BaseStandardVar = struct (* # 22 "src/base/BaseStandardVar.ml" *) open OASISGettext open OASISTypes open OASISExpr open BaseCheck open BaseEnv let ocamlfind = BaseCheck.ocamlfind let ocamlc = BaseOCamlcConfig.ocamlc let ocamlopt = prog_opt "ocamlopt" let ocamlbuild = prog "ocamlbuild" (**/**) let rpkg = ref None let pkg_get () = match !rpkg with | Some pkg -> pkg | None -> failwith (s_ "OASIS Package is not set") let var_cond = ref [] let var_define_cond ~since_version f dflt = let holder = ref (fun () -> dflt) in let since_version = OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version) in var_cond := (fun ver -> if OASISVersion.comparator_apply ver since_version then holder := f ()) :: !var_cond; fun () -> !holder () (**/**) let pkg_name = var_define ~short_desc:(fun () -> s_ "Package name") "pkg_name" (fun () -> (pkg_get ()).name) let pkg_version = var_define ~short_desc:(fun () -> s_ "Package version") "pkg_version" (fun () -> (OASISVersion.string_of_version (pkg_get ()).version)) let c = BaseOCamlcConfig.var_define let os_type = c "os_type" let system = c "system" let architecture = c "architecture" let ccomp_type = c "ccomp_type" let ocaml_version = c "ocaml_version" (* TODO: Check standard variable presence at runtime *) let standard_library_default = c "standard_library_default" let standard_library = c "standard_library" let standard_runtime = c "standard_runtime" let bytecomp_c_compiler = c "bytecomp_c_compiler" let native_c_compiler = c "native_c_compiler" let model = c "model" let ext_obj = c "ext_obj" let ext_asm = c "ext_asm" let ext_lib = c "ext_lib" let ext_dll = c "ext_dll" let default_executable_name = c "default_executable_name" let systhread_supported = c "systhread_supported" let flexlink = BaseCheck.prog "flexlink" let flexdll_version = var_define ~short_desc:(fun () -> "FlexDLL version (Win32)") "flexdll_version" (fun () -> let lst = OASISExec.run_read_output ~ctxt:!BaseContext.default (flexlink ()) ["-help"] in match lst with | line :: _ -> Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) | [] -> raise Not_found) (**/**) let p name hlp dflt = var_define ~short_desc:hlp ~cli:CLIAuto ~arg_help:"dir" name dflt let (/) a b = if os_type () = Sys.os_type then Filename.concat a b else if os_type () = "Unix" then OASISUnixPath.concat a b else OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat") (os_type ()) (**/**) let prefix = p "prefix" (fun () -> s_ "Install architecture-independent files dir") (fun () -> match os_type () with | "Win32" -> let program_files = Sys.getenv "PROGRAMFILES" in program_files/(pkg_name ()) | _ -> "/usr/local") let exec_prefix = p "exec_prefix" (fun () -> s_ "Install architecture-dependent files in dir") (fun () -> "$prefix") let bindir = p "bindir" (fun () -> s_ "User executables") (fun () -> "$exec_prefix"/"bin") let sbindir = p "sbindir" (fun () -> s_ "System admin executables") (fun () -> "$exec_prefix"/"sbin") let libexecdir = p "libexecdir" (fun () -> s_ "Program executables") (fun () -> "$exec_prefix"/"libexec") let sysconfdir = p "sysconfdir" (fun () -> s_ "Read-only single-machine data") (fun () -> "$prefix"/"etc") let sharedstatedir = p "sharedstatedir" (fun () -> s_ "Modifiable architecture-independent data") (fun () -> "$prefix"/"com") let localstatedir = p "localstatedir" (fun () -> s_ "Modifiable single-machine data") (fun () -> "$prefix"/"var") let libdir = p "libdir" (fun () -> s_ "Object code libraries") (fun () -> "$exec_prefix"/"lib") let datarootdir = p "datarootdir" (fun () -> s_ "Read-only arch-independent data root") (fun () -> "$prefix"/"share") let datadir = p "datadir" (fun () -> s_ "Read-only architecture-independent data") (fun () -> "$datarootdir") let infodir = p "infodir" (fun () -> s_ "Info documentation") (fun () -> "$datarootdir"/"info") let localedir = p "localedir" (fun () -> s_ "Locale-dependent data") (fun () -> "$datarootdir"/"locale") let mandir = p "mandir" (fun () -> s_ "Man documentation") (fun () -> "$datarootdir"/"man") let docdir = p "docdir" (fun () -> s_ "Documentation root") (fun () -> "$datarootdir"/"doc"/"$pkg_name") let htmldir = p "htmldir" (fun () -> s_ "HTML documentation") (fun () -> "$docdir") let dvidir = p "dvidir" (fun () -> s_ "DVI documentation") (fun () -> "$docdir") let pdfdir = p "pdfdir" (fun () -> s_ "PDF documentation") (fun () -> "$docdir") let psdir = p "psdir" (fun () -> s_ "PS documentation") (fun () -> "$docdir") let destdir = p "destdir" (fun () -> s_ "Prepend a path when installing package") (fun () -> raise (PropList.Not_set ("destdir", Some (s_ "undefined by construct")))) let findlib_version = var_define "findlib_version" (fun () -> BaseCheck.package_version "findlib") let is_native = var_define "is_native" (fun () -> try let _s: string = ocamlopt () in "true" with PropList.Not_set _ -> let _s: string = ocamlc () in "false") let ext_program = var_define "suffix_program" (fun () -> match os_type () with | "Win32" | "Cygwin" -> ".exe" | _ -> "") let rm = var_define ~short_desc:(fun () -> s_ "Remove a file.") "rm" (fun () -> match os_type () with | "Win32" -> "del" | _ -> "rm -f") let rmdir = var_define ~short_desc:(fun () -> s_ "Remove a directory.") "rmdir" (fun () -> match os_type () with | "Win32" -> "rd" | _ -> "rm -rf") let debug = var_define ~short_desc:(fun () -> s_ "Turn ocaml debug flag on") ~cli:CLIEnable "debug" (fun () -> "true") let profile = var_define ~short_desc:(fun () -> s_ "Turn ocaml profile flag on") ~cli:CLIEnable "profile" (fun () -> "false") let tests = var_define_cond ~since_version:"0.3" (fun () -> var_define ~short_desc:(fun () -> s_ "Compile tests executable and library and run them") ~cli:CLIEnable "tests" (fun () -> "false")) "true" let docs = var_define_cond ~since_version:"0.3" (fun () -> var_define ~short_desc:(fun () -> s_ "Create documentations") ~cli:CLIEnable "docs" (fun () -> "true")) "true" let native_dynlink = var_define ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") ~cli:CLINone "native_dynlink" (fun () -> let res = let ocaml_lt_312 () = OASISVersion.comparator_apply (OASISVersion.version_of_string (ocaml_version ())) (OASISVersion.VLesser (OASISVersion.version_of_string "3.12.0")) in let flexdll_lt_030 () = OASISVersion.comparator_apply (OASISVersion.version_of_string (flexdll_version ())) (OASISVersion.VLesser (OASISVersion.version_of_string "0.30")) in let has_native_dynlink = let ocamlfind = ocamlfind () in try let fn = OASISExec.run_read_one_line ~ctxt:!BaseContext.default ocamlfind ["query"; "-predicates"; "native"; "dynlink"; "-format"; "%d/%a"] in Sys.file_exists fn with _ -> false in if not has_native_dynlink then false else if ocaml_lt_312 () then false else if (os_type () = "Win32" || os_type () = "Cygwin") && flexdll_lt_030 () then begin BaseMessage.warning (f_ ".cmxs generation disabled because FlexDLL needs to be \ at least 0.30. Please upgrade FlexDLL from %s to 0.30.") (flexdll_version ()); false end else true in string_of_bool res) let init pkg = rpkg := Some pkg; List.iter (fun f -> f pkg.oasis_version) !var_cond end module BaseFileAB = struct (* # 22 "src/base/BaseFileAB.ml" *) open BaseEnv open OASISGettext open BaseMessage let to_filename fn = let fn = OASISHostPath.of_unix fn in if not (Filename.check_suffix fn ".ab") then warning (f_ "File '%s' doesn't have '.ab' extension") fn; Filename.chop_extension fn let replace fn_lst = let buff = Buffer.create 13 in List.iter (fun fn -> let fn = OASISHostPath.of_unix fn in let chn_in = open_in fn in let chn_out = open_out (to_filename fn) in ( try while true do Buffer.add_string buff (var_expand (input_line chn_in)); Buffer.add_char buff '\n' done with End_of_file -> () ); Buffer.output_buffer chn_out buff; Buffer.clear buff; close_in chn_in; close_out chn_out) fn_lst end module BaseLog = struct (* # 22 "src/base/BaseLog.ml" *) open OASISUtils let default_filename = Filename.concat (Filename.dirname BaseEnv.default_filename) "setup.log" module SetTupleString = Set.Make (struct type t = string * string let compare (s11, s12) (s21, s22) = match String.compare s11 s21 with | 0 -> String.compare s12 s22 | n -> n end) let load () = if Sys.file_exists default_filename then begin let chn = open_in default_filename in let scbuf = Scanf.Scanning.from_file default_filename in let rec read_aux (st, lst) = if not (Scanf.Scanning.end_of_input scbuf) then begin let acc = try Scanf.bscanf scbuf "%S %S\n" (fun e d -> let t = e, d in if SetTupleString.mem t st then st, lst else SetTupleString.add t st, t :: lst) with Scanf.Scan_failure _ -> failwith (Scanf.bscanf scbuf "%l" (fun line -> Printf.sprintf "Malformed log file '%s' at line %d" default_filename line)) in read_aux acc end else begin close_in chn; List.rev lst end in read_aux (SetTupleString.empty, []) end else begin [] end let register event data = let chn_out = open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename in Printf.fprintf chn_out "%S %S\n" event data; close_out chn_out let unregister event data = if Sys.file_exists default_filename then begin let lst = load () in let chn_out = open_out default_filename in let write_something = ref false in List.iter (fun (e, d) -> if e <> event || d <> data then begin write_something := true; Printf.fprintf chn_out "%S %S\n" e d end) lst; close_out chn_out; if not !write_something then Sys.remove default_filename end let filter events = let st_events = List.fold_left (fun st e -> SetString.add e st) SetString.empty events in List.filter (fun (e, _) -> SetString.mem e st_events) (load ()) let exists event data = List.exists (fun v -> (event, data) = v) (load ()) end module BaseBuilt = struct (* # 22 "src/base/BaseBuilt.ml" *) open OASISTypes open OASISGettext open BaseStandardVar open BaseMessage type t = | BExec (* Executable *) | BExecLib (* Library coming with executable *) | BLib (* Library *) | BObj (* Library *) | BDoc (* Document *) let to_log_event_file t nm = "built_"^ (match t with | BExec -> "exec" | BExecLib -> "exec_lib" | BLib -> "lib" | BObj -> "obj" | BDoc -> "doc")^ "_"^nm let to_log_event_done t nm = "is_"^(to_log_event_file t nm) let register t nm lst = BaseLog.register (to_log_event_done t nm) "true"; List.iter (fun alt -> let registered = List.fold_left (fun registered fn -> if OASISFileUtil.file_exists_case fn then begin BaseLog.register (to_log_event_file t nm) (if Filename.is_relative fn then Filename.concat (Sys.getcwd ()) fn else fn); true end else registered) false alt in if not registered then warning (f_ "Cannot find an existing alternative files among: %s") (String.concat (s_ ", ") alt)) lst let unregister t nm = List.iter (fun (e, d) -> BaseLog.unregister e d) (BaseLog.filter [to_log_event_file t nm; to_log_event_done t nm]) let fold t nm f acc = List.fold_left (fun acc (_, fn) -> if OASISFileUtil.file_exists_case fn then begin f acc fn end else begin warning (f_ "File '%s' has been marked as built \ for %s but doesn't exist") fn (Printf.sprintf (match t with | BExec | BExecLib -> (f_ "executable %s") | BLib -> (f_ "library %s") | BObj -> (f_ "object %s") | BDoc -> (f_ "documentation %s")) nm); acc end) acc (BaseLog.filter [to_log_event_file t nm]) let is_built t nm = List.fold_left (fun is_built (_, d) -> (try bool_of_string d with _ -> false)) false (BaseLog.filter [to_log_event_done t nm]) let of_executable ffn (cs, bs, exec) = let unix_exec_is, unix_dll_opt = OASISExecutable.unix_exec_is (cs, bs, exec) (fun () -> bool_of_string (is_native ())) ext_dll ext_program in let evs = (BExec, cs.cs_name, [[ffn unix_exec_is]]) :: (match unix_dll_opt with | Some fn -> [BExecLib, cs.cs_name, [[ffn fn]]] | None -> []) in evs, unix_exec_is, unix_dll_opt let of_library ffn (cs, bs, lib) = let unix_lst = OASISLibrary.generated_unix_files ~ctxt:!BaseContext.default ~source_file_exists:(fun fn -> OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) ~is_native:(bool_of_string (is_native ())) ~has_native_dynlink:(bool_of_string (native_dynlink ())) ~ext_lib:(ext_lib ()) ~ext_dll:(ext_dll ()) (cs, bs, lib) in let evs = [BLib, cs.cs_name, List.map (List.map ffn) unix_lst] in evs, unix_lst let of_object ffn (cs, bs, obj) = let unix_lst = OASISObject.generated_unix_files ~ctxt:!BaseContext.default ~source_file_exists:(fun fn -> OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) ~is_native:(bool_of_string (is_native ())) (cs, bs, obj) in let evs = [BObj, cs.cs_name, List.map (List.map ffn) unix_lst] in evs, unix_lst end module BaseCustom = struct (* # 22 "src/base/BaseCustom.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISGettext let run cmd args extra_args = OASISExec.run ~ctxt:!BaseContext.default ~quote:false (var_expand cmd) (List.map var_expand (args @ (Array.to_list extra_args))) let hook ?(failsafe=false) cstm f e = let optional_command lst = let printer = function | Some (cmd, args) -> String.concat " " (cmd :: args) | None -> s_ "No command" in match var_choose ~name:(s_ "Pre/Post Command") ~printer lst with | Some (cmd, args) -> begin try run cmd args [||] with e when failsafe -> warning (f_ "Command '%s' fail with error: %s") (String.concat " " (cmd :: args)) (match e with | Failure msg -> msg | e -> Printexc.to_string e) end | None -> () in let res = optional_command cstm.pre_command; f e in optional_command cstm.post_command; res end module BaseDynVar = struct (* # 22 "src/base/BaseDynVar.ml" *) open OASISTypes open OASISGettext open BaseEnv open BaseBuilt let init pkg = (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) (* TODO: provide compile option for library libary_byte_args_VARNAME... *) List.iter (function | Executable (cs, bs, exec) -> if var_choose bs.bs_build then var_ignore (var_redefine (* We don't save this variable *) ~dump:false ~short_desc:(fun () -> Printf.sprintf (f_ "Filename of executable '%s'") cs.cs_name) (OASISUtils.varname_of_string cs.cs_name) (fun () -> let fn_opt = fold BExec cs.cs_name (fun _ fn -> Some fn) None in match fn_opt with | Some fn -> fn | None -> raise (PropList.Not_set (cs.cs_name, Some (Printf.sprintf (f_ "Executable '%s' not yet built.") cs.cs_name))))) | Library _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> ()) pkg.sections end module BaseTest = struct (* # 22 "src/base/BaseTest.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISExpr open OASISGettext let test lst pkg extra_args = let one_test (failure, n) (test_plugin, cs, test) = if var_choose ~name:(Printf.sprintf (f_ "test %s run") cs.cs_name) ~printer:string_of_bool test.test_run then begin let () = info (f_ "Running test '%s'") cs.cs_name in let back_cwd = match test.test_working_directory with | Some dir -> let cwd = Sys.getcwd () in let chdir d = info (f_ "Changing directory to '%s'") d; Sys.chdir d in chdir dir; fun () -> chdir cwd | None -> fun () -> () in try let failure_percent = BaseCustom.hook test.test_custom (test_plugin pkg (cs, test)) extra_args in back_cwd (); (failure_percent +. failure, n + 1) with e -> begin back_cwd (); raise e end end else begin info (f_ "Skipping test '%s'") cs.cs_name; (failure, n) end in let failed, n = List.fold_left one_test (0.0, 0) lst in let failure_percent = if n = 0 then 0.0 else failed /. (float_of_int n) in let msg = Printf.sprintf (f_ "Tests had a %.2f%% failure rate") (100. *. failure_percent) in if failure_percent > 0.0 then failwith msg else info "%s" msg; (* Possible explanation why the tests where not run. *) if OASISFeatures.package_test OASISFeatures.flag_tests pkg && not (bool_of_string (BaseStandardVar.tests ())) && lst <> [] then BaseMessage.warning "Tests are turned off, consider enabling with \ 'ocaml setup.ml -configure --enable-tests'" end module BaseDoc = struct (* # 22 "src/base/BaseDoc.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISGettext let doc lst pkg extra_args = let one_doc (doc_plugin, cs, doc) = if var_choose ~name:(Printf.sprintf (f_ "documentation %s build") cs.cs_name) ~printer:string_of_bool doc.doc_build then begin info (f_ "Building documentation '%s'") cs.cs_name; BaseCustom.hook doc.doc_custom (doc_plugin pkg (cs, doc)) extra_args end in List.iter one_doc lst; if OASISFeatures.package_test OASISFeatures.flag_docs pkg && not (bool_of_string (BaseStandardVar.docs ())) && lst <> [] then BaseMessage.warning "Docs are turned off, consider enabling with \ 'ocaml setup.ml -configure --enable-docs'" end module BaseSetup = struct (* # 22 "src/base/BaseSetup.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISSection open OASISGettext open OASISUtils type std_args_fun = package -> string array -> unit type ('a, 'b) section_args_fun = name * (package -> (common_section * 'a) -> string array -> 'b) type t = { configure: std_args_fun; build: std_args_fun; doc: ((doc, unit) section_args_fun) list; test: ((test, float) section_args_fun) list; install: std_args_fun; uninstall: std_args_fun; clean: std_args_fun list; clean_doc: (doc, unit) section_args_fun list; clean_test: (test, unit) section_args_fun list; distclean: std_args_fun list; distclean_doc: (doc, unit) section_args_fun list; distclean_test: (test, unit) section_args_fun list; package: package; oasis_fn: string option; oasis_version: string; oasis_digest: Digest.t option; oasis_exec: string option; oasis_setup_args: string list; setup_update: bool; } (* Associate a plugin function with data from package *) let join_plugin_sections filter_map lst = List.rev (List.fold_left (fun acc sct -> match filter_map sct with | Some e -> e :: acc | None -> acc) [] lst) (* Search for plugin data associated with a section name *) let lookup_plugin_section plugin action nm lst = try List.assoc nm lst with Not_found -> failwithf (f_ "Cannot find plugin %s matching section %s for %s action") plugin nm action let configure t args = (* Run configure *) BaseCustom.hook t.package.conf_custom (fun () -> (* Reload if preconf has changed it *) begin try unload (); load (); with _ -> () end; (* Run plugin's configure *) t.configure t.package args; (* Dump to allow postconf to change it *) dump ()) (); (* Reload environment *) unload (); load (); (* Save environment *) print (); (* Replace data in file *) BaseFileAB.replace t.package.files_ab let build t args = BaseCustom.hook t.package.build_custom (t.build t.package) args let doc t args = BaseDoc.doc (join_plugin_sections (function | Doc (cs, e) -> Some (lookup_plugin_section "documentation" (s_ "build") cs.cs_name t.doc, cs, e) | _ -> None) t.package.sections) t.package args let test t args = BaseTest.test (join_plugin_sections (function | Test (cs, e) -> Some (lookup_plugin_section "test" (s_ "run") cs.cs_name t.test, cs, e) | _ -> None) t.package.sections) t.package args let all t args = let rno_doc = ref false in let rno_test = ref false in let arg_rest = ref [] in Arg.parse_argv ~current:(ref 0) (Array.of_list ((Sys.executable_name^" all") :: (Array.to_list args))) [ "-no-doc", Arg.Set rno_doc, s_ "Don't run doc target"; "-no-test", Arg.Set rno_test, s_ "Don't run test target"; "--", Arg.Rest (fun arg -> arg_rest := arg :: !arg_rest), s_ "All arguments for configure."; ] (failwithf (f_ "Don't know what to do with '%s'")) ""; info "Running configure step"; configure t (Array.of_list (List.rev !arg_rest)); info "Running build step"; build t [||]; (* Load setup.log dynamic variables *) BaseDynVar.init t.package; if not !rno_doc then begin info "Running doc step"; doc t [||]; end else begin info "Skipping doc step" end; if not !rno_test then begin info "Running test step"; test t [||] end else begin info "Skipping test step" end let install t args = BaseCustom.hook t.package.install_custom (t.install t.package) args let uninstall t args = BaseCustom.hook t.package.uninstall_custom (t.uninstall t.package) args let reinstall t args = uninstall t args; install t args let clean, distclean = let failsafe f a = try f a with e -> warning (f_ "Action fail with error: %s") (match e with | Failure msg -> msg | e -> Printexc.to_string e) in let generic_clean t cstm mains docs tests args = BaseCustom.hook ~failsafe:true cstm (fun () -> (* Clean section *) List.iter (function | Test (cs, test) -> let f = try List.assoc cs.cs_name tests with Not_found -> fun _ _ _ -> () in failsafe (f t.package (cs, test)) args | Doc (cs, doc) -> let f = try List.assoc cs.cs_name docs with Not_found -> fun _ _ _ -> () in failsafe (f t.package (cs, doc)) args | Library _ | Object _ | Executable _ | Flag _ | SrcRepo _ -> ()) t.package.sections; (* Clean whole package *) List.iter (fun f -> failsafe (f t.package) args) mains) () in let clean t args = generic_clean t t.package.clean_custom t.clean t.clean_doc t.clean_test args in let distclean t args = (* Call clean *) clean t args; (* Call distclean code *) generic_clean t t.package.distclean_custom t.distclean t.distclean_doc t.distclean_test args; (* Remove generated file *) List.iter (fun fn -> if Sys.file_exists fn then begin info (f_ "Remove '%s'") fn; Sys.remove fn end) (BaseEnv.default_filename :: BaseLog.default_filename :: (List.rev_map BaseFileAB.to_filename t.package.files_ab)) in clean, distclean let version t _ = print_endline t.oasis_version let update_setup_ml, no_update_setup_ml_cli = let b = ref true in b, ("-no-update-setup-ml", Arg.Clear b, s_ " Don't try to update setup.ml, even if _oasis has changed.") let default_oasis_fn = "_oasis" let update_setup_ml t = let oasis_fn = match t.oasis_fn with | Some fn -> fn | None -> default_oasis_fn in let oasis_exec = match t.oasis_exec with | Some fn -> fn | None -> "oasis" in let ocaml = Sys.executable_name in let setup_ml, args = match Array.to_list Sys.argv with | setup_ml :: args -> setup_ml, args | [] -> failwith (s_ "Expecting non-empty command line arguments.") in let ocaml, setup_ml = if Sys.executable_name = Sys.argv.(0) then (* We are not running in standard mode, probably the script * is precompiled. *) "ocaml", "setup.ml" else ocaml, setup_ml in let no_update_setup_ml_cli, _, _ = no_update_setup_ml_cli in let do_update () = let oasis_exec_version = OASISExec.run_read_one_line ~ctxt:!BaseContext.default ~f_exit_code: (function | 0 -> () | 1 -> failwithf (f_ "Executable '%s' is probably an old version \ of oasis (< 0.3.0), please update to version \ v%s.") oasis_exec t.oasis_version | 127 -> failwithf (f_ "Cannot find executable '%s', please install \ oasis v%s.") oasis_exec t.oasis_version | n -> failwithf (f_ "Command '%s version' exited with code %d.") oasis_exec n) oasis_exec ["version"] in if OASISVersion.comparator_apply (OASISVersion.version_of_string oasis_exec_version) (OASISVersion.VGreaterEqual (OASISVersion.version_of_string t.oasis_version)) then begin (* We have a version >= for the executable oasis, proceed with * update. *) (* TODO: delegate this check to 'oasis setup'. *) if Sys.os_type = "Win32" then failwithf (f_ "It is not possible to update the running script \ setup.ml on Windows. Please update setup.ml by \ running '%s'.") (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args)) else begin OASISExec.run ~ctxt:!BaseContext.default ~f_exit_code: (function | 0 -> () | n -> failwithf (f_ "Unable to update setup.ml using '%s', \ please fix the problem and retry.") oasis_exec) oasis_exec ("setup" :: t.oasis_setup_args); OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args) end end else failwithf (f_ "The version of '%s' (v%s) doesn't match the version of \ oasis used to generate the %s file. Please install at \ least oasis v%s.") oasis_exec oasis_exec_version setup_ml t.oasis_version in if !update_setup_ml then begin try match t.oasis_digest with | Some dgst -> if Sys.file_exists oasis_fn && dgst <> Digest.file default_oasis_fn then begin do_update (); true end else false | None -> false with e -> error (f_ "Error when updating setup.ml. If you want to avoid this error, \ you can bypass the update of %s by running '%s %s %s %s'") setup_ml ocaml setup_ml no_update_setup_ml_cli (String.concat " " args); raise e end else false let setup t = let catch_exn = ref true in try let act_ref = ref (fun _ -> failwithf (f_ "No action defined, run '%s %s -help'") Sys.executable_name Sys.argv.(0)) in let extra_args_ref = ref [] in let allow_empty_env_ref = ref false in let arg_handle ?(allow_empty_env=false) act = Arg.Tuple [ Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); Arg.Unit (fun () -> allow_empty_env_ref := allow_empty_env; act_ref := act); ] in Arg.parse (Arg.align ([ "-configure", arg_handle ~allow_empty_env:true configure, s_ "[options*] Configure the whole build process."; "-build", arg_handle build, s_ "[options*] Build executables and libraries."; "-doc", arg_handle doc, s_ "[options*] Build documents."; "-test", arg_handle test, s_ "[options*] Run tests."; "-all", arg_handle ~allow_empty_env:true all, s_ "[options*] Run configure, build, doc and test targets."; "-install", arg_handle install, s_ "[options*] Install libraries, data, executables \ and documents."; "-uninstall", arg_handle uninstall, s_ "[options*] Uninstall libraries, data, executables \ and documents."; "-reinstall", arg_handle reinstall, s_ "[options*] Uninstall and install libraries, data, \ executables and documents."; "-clean", arg_handle ~allow_empty_env:true clean, s_ "[options*] Clean files generated by a build."; "-distclean", arg_handle ~allow_empty_env:true distclean, s_ "[options*] Clean files generated by a build and configure."; "-version", arg_handle ~allow_empty_env:true version, s_ " Display version of OASIS used to generate this setup.ml."; "-no-catch-exn", Arg.Clear catch_exn, s_ " Don't catch exception, useful for debugging."; ] @ (if t.setup_update then [no_update_setup_ml_cli] else []) @ (BaseContext.args ()))) (failwithf (f_ "Don't know what to do with '%s'")) (s_ "Setup and run build process current package\n"); (* Build initial environment *) load ~allow_empty:!allow_empty_env_ref (); (** Initialize flags *) List.iter (function | Flag (cs, {flag_description = hlp; flag_default = choices}) -> begin let apply ?short_desc () = var_ignore (var_define ~cli:CLIEnable ?short_desc (OASISUtils.varname_of_string cs.cs_name) (fun () -> string_of_bool (var_choose ~name:(Printf.sprintf (f_ "default value of flag %s") cs.cs_name) ~printer:string_of_bool choices))) in match hlp with | Some hlp -> apply ~short_desc:(fun () -> hlp) () | None -> apply () end | _ -> ()) t.package.sections; BaseStandardVar.init t.package; BaseDynVar.init t.package; if t.setup_update && update_setup_ml t then () else !act_ref t (Array.of_list (List.rev !extra_args_ref)) with e when !catch_exn -> error "%s" (Printexc.to_string e); exit 1 end # 5409 "setup.ml" module InternalConfigurePlugin = struct (* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) (** Configure using internal scheme @author Sylvain Le Gall *) open BaseEnv open OASISTypes open OASISUtils open OASISGettext open BaseMessage (** Configure build using provided series of check to be done * and then output corresponding file. *) let configure pkg argv = let var_ignore_eval var = let _s: string = var () in () in let errors = ref SetString.empty in let buff = Buffer.create 13 in let add_errors fmt = Printf.kbprintf (fun b -> errors := SetString.add (Buffer.contents b) !errors; Buffer.clear b) buff fmt in let warn_exception e = warning "%s" (Printexc.to_string e) in (* Check tools *) let check_tools lst = List.iter (function | ExternalTool tool -> begin try var_ignore_eval (BaseCheck.prog tool) with e -> warn_exception e; add_errors (f_ "Cannot find external tool '%s'") tool end | InternalExecutable nm1 -> (* Check that matching tool is built *) List.iter (function | Executable ({cs_name = nm2}, {bs_build = build}, _) when nm1 = nm2 -> if not (var_choose build) then add_errors (f_ "Cannot find buildable internal executable \ '%s' when checking build depends") nm1 | _ -> ()) pkg.sections) lst in let build_checks sct bs = if var_choose bs.bs_build then begin if bs.bs_compiled_object = Native then begin try var_ignore_eval BaseStandardVar.ocamlopt with e -> warn_exception e; add_errors (f_ "Section %s requires native compilation") (OASISSection.string_of_section sct) end; (* Check tools *) check_tools bs.bs_build_tools; (* Check depends *) List.iter (function | FindlibPackage (findlib_pkg, version_comparator) -> begin try var_ignore_eval (BaseCheck.package ?version_comparator findlib_pkg) with e -> warn_exception e; match version_comparator with | None -> add_errors (f_ "Cannot find findlib package %s") findlib_pkg | Some ver_cmp -> add_errors (f_ "Cannot find findlib package %s (%s)") findlib_pkg (OASISVersion.string_of_comparator ver_cmp) end | InternalLibrary nm1 -> (* Check that matching library is built *) List.iter (function | Library ({cs_name = nm2}, {bs_build = build}, _) when nm1 = nm2 -> if not (var_choose build) then add_errors (f_ "Cannot find buildable internal library \ '%s' when checking build depends") nm1 | _ -> ()) pkg.sections) bs.bs_build_depends end in (* Parse command line *) BaseArgExt.parse argv (BaseEnv.args ()); (* OCaml version *) begin match pkg.ocaml_version with | Some ver_cmp -> begin try var_ignore_eval (BaseCheck.version "ocaml" ver_cmp BaseStandardVar.ocaml_version) with e -> warn_exception e; add_errors (f_ "OCaml version %s doesn't match version constraint %s") (BaseStandardVar.ocaml_version ()) (OASISVersion.string_of_comparator ver_cmp) end | None -> () end; (* Findlib version *) begin match pkg.findlib_version with | Some ver_cmp -> begin try var_ignore_eval (BaseCheck.version "findlib" ver_cmp BaseStandardVar.findlib_version) with e -> warn_exception e; add_errors (f_ "Findlib version %s doesn't match version constraint %s") (BaseStandardVar.findlib_version ()) (OASISVersion.string_of_comparator ver_cmp) end | None -> () end; (* Make sure the findlib version is fine for the OCaml compiler. *) begin let ocaml_ge4 = OASISVersion.version_compare (OASISVersion.version_of_string (BaseStandardVar.ocaml_version())) (OASISVersion.version_of_string "4.0.0") >= 0 in if ocaml_ge4 then let findlib_lt132 = OASISVersion.version_compare (OASISVersion.version_of_string (BaseStandardVar.findlib_version())) (OASISVersion.version_of_string "1.3.2") < 0 in if findlib_lt132 then add_errors "OCaml >= 4.0.0 requires Findlib version >= 1.3.2" end; (* FlexDLL *) if BaseStandardVar.os_type () = "Win32" || BaseStandardVar.os_type () = "Cygwin" then begin try var_ignore_eval BaseStandardVar.flexlink with e -> warn_exception e; add_errors (f_ "Cannot find 'flexlink'") end; (* Check build depends *) List.iter (function | Executable (_, bs, _) | Library (_, bs, _) as sct -> build_checks sct bs | Doc (_, doc) -> if var_choose doc.doc_build then check_tools doc.doc_build_tools | Test (_, test) -> if var_choose test.test_run then check_tools test.test_tools | _ -> ()) pkg.sections; (* Check if we need native dynlink (presence of libraries that compile to * native) *) begin let has_cmxa = List.exists (function | Library (_, bs, _) -> var_choose bs.bs_build && (bs.bs_compiled_object = Native || (bs.bs_compiled_object = Best && bool_of_string (BaseStandardVar.is_native ()))) | _ -> false) pkg.sections in if has_cmxa then var_ignore_eval BaseStandardVar.native_dynlink end; (* Check errors *) if SetString.empty != !errors then begin List.iter (fun e -> error "%s" e) (SetString.elements !errors); failwithf (fn_ "%d configuration error" "%d configuration errors" (SetString.cardinal !errors)) (SetString.cardinal !errors) end end module InternalInstallPlugin = struct (* # 22 "src/plugins/internal/InternalInstallPlugin.ml" *) (** Install using internal scheme @author Sylvain Le Gall *) open BaseEnv open BaseStandardVar open BaseMessage open OASISTypes open OASISFindlib open OASISGettext open OASISUtils let exec_hook = ref (fun (cs, bs, exec) -> cs, bs, exec) let lib_hook = ref (fun (cs, bs, lib) -> cs, bs, lib, []) let obj_hook = ref (fun (cs, bs, obj) -> cs, bs, obj, []) let doc_hook = ref (fun (cs, doc) -> cs, doc) let install_file_ev = "install-file" let install_dir_ev = "install-dir" let install_findlib_ev = "install-findlib" let win32_max_command_line_length = 8000 let split_install_command ocamlfind findlib_name meta files = if Sys.os_type = "Win32" then (* Arguments for the first command: *) let first_args = ["install"; findlib_name; meta] in (* Arguments for remaining commands: *) let other_args = ["install"; findlib_name; "-add"] in (* Extract as much files as possible from [files], [len] is the current command line length: *) let rec get_files len acc files = match files with | [] -> (List.rev acc, []) | file :: rest -> let len = len + 1 + String.length file in if len > win32_max_command_line_length then (List.rev acc, files) else get_files len (file :: acc) rest in (* Split the command into several commands. *) let rec split args files = match files with | [] -> [] | _ -> (* Length of "ocamlfind install [META|-add]" *) let len = List.fold_left (fun len arg -> len + 1 (* for the space *) + String.length arg) (String.length ocamlfind) args in match get_files len [] files with | ([], _) -> failwith (s_ "Command line too long.") | (firsts, others) -> let cmd = args @ firsts in (* Use -add for remaining commands: *) let () = let findlib_ge_132 = OASISVersion.comparator_apply (OASISVersion.version_of_string (BaseStandardVar.findlib_version ())) (OASISVersion.VGreaterEqual (OASISVersion.version_of_string "1.3.2")) in if not findlib_ge_132 then failwithf (f_ "Installing the library %s require to use the \ flag '-add' of ocamlfind because the command \ line is too long. This flag is only available \ for findlib 1.3.2. Please upgrade findlib from \ %s to 1.3.2") findlib_name (BaseStandardVar.findlib_version ()) in let cmds = split other_args others in cmd :: cmds in (* The first command does not use -add: *) split first_args files else ["install" :: findlib_name :: meta :: files] let install pkg argv = let in_destdir = try let destdir = destdir () in (* Practically speaking destdir is prepended * at the beginning of the target filename *) fun fn -> destdir^fn with PropList.Not_set _ -> fun fn -> fn in let install_file ?tgt_fn src_file envdir = let tgt_dir = in_destdir (envdir ()) in let tgt_file = Filename.concat tgt_dir (match tgt_fn with | Some fn -> fn | None -> Filename.basename src_file) in (* Create target directory if needed *) OASISFileUtil.mkdir_parent ~ctxt:!BaseContext.default (fun dn -> info (f_ "Creating directory '%s'") dn; BaseLog.register install_dir_ev dn) tgt_dir; (* Really install files *) info (f_ "Copying file '%s' to '%s'") src_file tgt_file; OASISFileUtil.cp ~ctxt:!BaseContext.default src_file tgt_file; BaseLog.register install_file_ev tgt_file in (* Install data into defined directory *) let install_data srcdir lst tgtdir = let tgtdir = OASISHostPath.of_unix (var_expand tgtdir) in List.iter (fun (src, tgt_opt) -> let real_srcs = OASISFileUtil.glob ~ctxt:!BaseContext.default (Filename.concat srcdir src) in if real_srcs = [] then failwithf (f_ "Wildcard '%s' doesn't match any files") src; List.iter (fun fn -> install_file fn (fun () -> match tgt_opt with | Some s -> OASISHostPath.of_unix (var_expand s) | None -> tgtdir)) real_srcs) lst in let make_fnames modul sufx = List.fold_right begin fun sufx accu -> (String.capitalize modul ^ sufx) :: (String.uncapitalize modul ^ sufx) :: accu end sufx [] in (** Install all libraries *) let install_libs pkg = let files_of_library (f_data, acc) data_lib = let cs, bs, lib, lib_extra = !lib_hook data_lib in if var_choose bs.bs_install && BaseBuilt.is_built BaseBuilt.BLib cs.cs_name then begin let acc = (* Start with acc + lib_extra *) List.rev_append lib_extra acc in let acc = (* Add uncompiled header from the source tree *) let path = OASISHostPath.of_unix bs.bs_path in List.fold_left begin fun acc modul -> begin try [List.find OASISFileUtil.file_exists_case (List.map (Filename.concat path) (make_fnames modul [".mli"; ".ml"]))] with Not_found -> warning (f_ "Cannot find source header for module %s \ in library %s") modul cs.cs_name; [] end @ List.filter OASISFileUtil.file_exists_case (List.map (Filename.concat path) (make_fnames modul [".annot";".cmti";".cmt"])) @ acc end acc lib.lib_modules in let acc = (* Get generated files *) BaseBuilt.fold BaseBuilt.BLib cs.cs_name (fun acc fn -> fn :: acc) acc in let f_data () = (* Install data associated with the library *) install_data bs.bs_path bs.bs_data_files (Filename.concat (datarootdir ()) pkg.name); f_data () in (f_data, acc) end else begin (f_data, acc) end and files_of_object (f_data, acc) data_obj = let cs, bs, obj, obj_extra = !obj_hook data_obj in if var_choose bs.bs_install && BaseBuilt.is_built BaseBuilt.BObj cs.cs_name then begin let acc = (* Start with acc + obj_extra *) List.rev_append obj_extra acc in let acc = (* Add uncompiled header from the source tree *) let path = OASISHostPath.of_unix bs.bs_path in List.fold_left begin fun acc modul -> begin try [List.find OASISFileUtil.file_exists_case (List.map (Filename.concat path) (make_fnames modul [".mli"; ".ml"]))] with Not_found -> warning (f_ "Cannot find source header for module %s \ in object %s") modul cs.cs_name; [] end @ List.filter OASISFileUtil.file_exists_case (List.map (Filename.concat path) (make_fnames modul [".annot";".cmti";".cmt"])) @ acc end acc obj.obj_modules in let acc = (* Get generated files *) BaseBuilt.fold BaseBuilt.BObj cs.cs_name (fun acc fn -> fn :: acc) acc in let f_data () = (* Install data associated with the object *) install_data bs.bs_path bs.bs_data_files (Filename.concat (datarootdir ()) pkg.name); f_data () in (f_data, acc) end else begin (f_data, acc) end in (* Install one group of library *) let install_group_lib grp = (* Iterate through all group nodes *) let rec install_group_lib_aux data_and_files grp = let data_and_files, children = match grp with | Container (_, children) -> data_and_files, children | Package (_, cs, bs, `Library lib, children) -> files_of_library data_and_files (cs, bs, lib), children | Package (_, cs, bs, `Object obj, children) -> files_of_object data_and_files (cs, bs, obj), children in List.fold_left install_group_lib_aux data_and_files children in (* Findlib name of the root library *) let findlib_name = findlib_of_group grp in (* Determine root library *) let root_lib = root_of_group grp in (* All files to install for this library *) let f_data, files = install_group_lib_aux (ignore, []) grp in (* Really install, if there is something to install *) if files = [] then begin warning (f_ "Nothing to install for findlib library '%s'") findlib_name end else begin let meta = (* Search META file *) let _, bs, _ = root_lib in let res = Filename.concat bs.bs_path "META" in if not (OASISFileUtil.file_exists_case res) then failwithf (f_ "Cannot find file '%s' for findlib library %s") res findlib_name; res in let files = (* Make filename shorter to avoid hitting command max line length * too early, esp. on Windows. *) let remove_prefix p n = let plen = String.length p in let nlen = String.length n in if plen <= nlen && String.sub n 0 plen = p then begin let fn_sep = if Sys.os_type = "Win32" then '\\' else '/' in let cutpoint = plen + (if plen < nlen && n.[plen] = fn_sep then 1 else 0) in String.sub n cutpoint (nlen - cutpoint) end else n in List.map (remove_prefix (Sys.getcwd ())) files in info (f_ "Installing findlib library '%s'") findlib_name; let ocamlfind = ocamlfind () in let commands = split_install_command ocamlfind findlib_name meta files in List.iter (OASISExec.run ~ctxt:!BaseContext.default ocamlfind) commands; BaseLog.register install_findlib_ev findlib_name end; (* Install data files *) f_data (); in let group_libs, _, _ = findlib_mapping pkg in (* We install libraries in groups *) List.iter install_group_lib group_libs in let install_execs pkg = let install_exec data_exec = let cs, bs, exec = !exec_hook data_exec in if var_choose bs.bs_install && BaseBuilt.is_built BaseBuilt.BExec cs.cs_name then begin let exec_libdir () = Filename.concat (libdir ()) pkg.name in BaseBuilt.fold BaseBuilt.BExec cs.cs_name (fun () fn -> install_file ~tgt_fn:(cs.cs_name ^ ext_program ()) fn bindir) (); BaseBuilt.fold BaseBuilt.BExecLib cs.cs_name (fun () fn -> install_file fn exec_libdir) (); install_data bs.bs_path bs.bs_data_files (Filename.concat (datarootdir ()) pkg.name) end in List.iter (function | Executable (cs, bs, exec)-> install_exec (cs, bs, exec) | _ -> ()) pkg.sections in let install_docs pkg = let install_doc data = let cs, doc = !doc_hook data in if var_choose doc.doc_install && BaseBuilt.is_built BaseBuilt.BDoc cs.cs_name then begin let tgt_dir = OASISHostPath.of_unix (var_expand doc.doc_install_dir) in BaseBuilt.fold BaseBuilt.BDoc cs.cs_name (fun () fn -> install_file fn (fun () -> tgt_dir)) (); install_data Filename.current_dir_name doc.doc_data_files doc.doc_install_dir end in List.iter (function | Doc (cs, doc) -> install_doc (cs, doc) | _ -> ()) pkg.sections in install_libs pkg; install_execs pkg; install_docs pkg (* Uninstall already installed data *) let uninstall _ argv = List.iter (fun (ev, data) -> if ev = install_file_ev then begin if OASISFileUtil.file_exists_case data then begin info (f_ "Removing file '%s'") data; Sys.remove data end else begin warning (f_ "File '%s' doesn't exist anymore") data end end else if ev = install_dir_ev then begin if Sys.file_exists data && Sys.is_directory data then begin if Sys.readdir data = [||] then begin info (f_ "Removing directory '%s'") data; OASISFileUtil.rmdir ~ctxt:!BaseContext.default data end else begin warning (f_ "Directory '%s' is not empty (%s)") data (String.concat ", " (Array.to_list (Sys.readdir data))) end end else begin warning (f_ "Directory '%s' doesn't exist anymore") data end end else if ev = install_findlib_ev then begin info (f_ "Removing findlib library '%s'") data; OASISExec.run ~ctxt:!BaseContext.default (ocamlfind ()) ["remove"; data] end else failwithf (f_ "Unknown log event '%s'") ev; BaseLog.unregister ev data) (* We process event in reverse order *) (List.rev (BaseLog.filter [install_file_ev; install_dir_ev; install_findlib_ev])) end # 6273 "setup.ml" module OCamlbuildCommon = struct (* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) (** Functions common to OCamlbuild build and doc plugin *) open OASISGettext open BaseEnv open BaseStandardVar open OASISTypes type extra_args = string list let ocamlbuild_clean_ev = "ocamlbuild-clean" let ocamlbuildflags = var_define ~short_desc:(fun () -> "OCamlbuild additional flags") "ocamlbuildflags" (fun () -> "") (** Fix special arguments depending on environment *) let fix_args args extra_argv = List.flatten [ if (os_type ()) = "Win32" then [ "-classic-display"; "-no-log"; "-no-links"; "-install-lib-dir"; (Filename.concat (standard_library ()) "ocamlbuild") ] else []; if not (bool_of_string (is_native ())) || (os_type ()) = "Win32" then [ "-byte-plugin" ] else []; args; if bool_of_string (debug ()) then ["-tag"; "debug"] else []; if bool_of_string (tests ()) then ["-tag"; "tests"] else []; if bool_of_string (profile ()) then ["-tag"; "profile"] else []; OASISString.nsplit (ocamlbuildflags ()) ' '; Array.to_list extra_argv; ] (** Run 'ocamlbuild -clean' if not already done *) let run_clean extra_argv = let extra_cli = String.concat " " (Array.to_list extra_argv) in (* Run if never called with these args *) if not (BaseLog.exists ocamlbuild_clean_ev extra_cli) then begin OASISExec.run ~ctxt:!BaseContext.default (ocamlbuild ()) (fix_args ["-clean"] extra_argv); BaseLog.register ocamlbuild_clean_ev extra_cli; at_exit (fun () -> try BaseLog.unregister ocamlbuild_clean_ev extra_cli with _ -> ()) end (** Run ocamlbuild, unregister all clean events *) let run_ocamlbuild args extra_argv = (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html *) OASISExec.run ~ctxt:!BaseContext.default (ocamlbuild ()) (fix_args args extra_argv); (* Remove any clean event, we must run it again *) List.iter (fun (e, d) -> BaseLog.unregister e d) (BaseLog.filter [ocamlbuild_clean_ev]) (** Determine real build directory *) let build_dir extra_argv = let rec search_args dir = function | "-build-dir" :: dir :: tl -> search_args dir tl | _ :: tl -> search_args dir tl | [] -> dir in search_args "_build" (fix_args [] extra_argv) end module OCamlbuildPlugin = struct (* # 22 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) (** Build using ocamlbuild @author Sylvain Le Gall *) open OASISTypes open OASISGettext open OASISUtils open OASISString open BaseEnv open OCamlbuildCommon open BaseStandardVar open BaseMessage let cond_targets_hook = ref (fun lst -> lst) let build extra_args pkg argv = (* Return the filename in build directory *) let in_build_dir fn = Filename.concat (build_dir argv) fn in (* Return the unix filename in host build directory *) let in_build_dir_of_unix fn = in_build_dir (OASISHostPath.of_unix fn) in let cond_targets = List.fold_left (fun acc -> function | Library (cs, bs, lib) when var_choose bs.bs_build -> begin let evs, unix_files = BaseBuilt.of_library in_build_dir_of_unix (cs, bs, lib) in let tgts = List.flatten (List.filter (fun l -> l <> []) (List.map (List.filter (fun fn -> ends_with ~what:".cma" fn || ends_with ~what:".cmxs" fn || ends_with ~what:".cmxa" fn || ends_with ~what:(ext_lib ()) fn || ends_with ~what:(ext_dll ()) fn)) unix_files)) in match tgts with | _ :: _ -> (evs, tgts) :: acc | [] -> failwithf (f_ "No possible ocamlbuild targets for library %s") cs.cs_name end | Object (cs, bs, obj) when var_choose bs.bs_build -> begin let evs, unix_files = BaseBuilt.of_object in_build_dir_of_unix (cs, bs, obj) in let tgts = List.flatten (List.filter (fun l -> l <> []) (List.map (List.filter (fun fn -> ends_with ".cmo" fn || ends_with ".cmx" fn)) unix_files)) in match tgts with | _ :: _ -> (evs, tgts) :: acc | [] -> failwithf (f_ "No possible ocamlbuild targets for object %s") cs.cs_name end | Executable (cs, bs, exec) when var_choose bs.bs_build -> begin let evs, unix_exec_is, unix_dll_opt = BaseBuilt.of_executable in_build_dir_of_unix (cs, bs, exec) in let target ext = let unix_tgt = (OASISUnixPath.concat bs.bs_path (OASISUnixPath.chop_extension exec.exec_main_is))^ext in let evs = (* Fix evs, we want to use the unix_tgt, without copying *) List.map (function | BaseBuilt.BExec, nm, lst when nm = cs.cs_name -> BaseBuilt.BExec, nm, [[in_build_dir_of_unix unix_tgt]] | ev -> ev) evs in evs, [unix_tgt] in (* Add executable *) let acc = match bs.bs_compiled_object with | Native -> (target ".native") :: acc | Best when bool_of_string (is_native ()) -> (target ".native") :: acc | Byte | Best -> (target ".byte") :: acc in acc end | Library _ | Object _ | Executable _ | Test _ | SrcRepo _ | Flag _ | Doc _ -> acc) [] (* Keep the pkg.sections ordered *) (List.rev pkg.sections); in (* Check and register built files *) let check_and_register (bt, bnm, lst) = List.iter (fun fns -> if not (List.exists OASISFileUtil.file_exists_case fns) then failwithf (fn_ "Expected built file %s doesn't exist." "None of expected built files %s exists." (List.length fns)) (String.concat (s_ " or ") (List.map (Printf.sprintf "'%s'") fns))) lst; (BaseBuilt.register bt bnm lst) in (* Run the hook *) let cond_targets = !cond_targets_hook cond_targets in (* Run a list of target... *) run_ocamlbuild (List.flatten (List.map snd cond_targets) @ extra_args) argv; (* ... and register events *) List.iter check_and_register (List.flatten (List.map fst cond_targets)) let clean pkg extra_args = run_clean extra_args; List.iter (function | Library (cs, _, _) -> BaseBuilt.unregister BaseBuilt.BLib cs.cs_name | Executable (cs, _, _) -> BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name | _ -> ()) pkg.sections end module OCamlbuildDocPlugin = struct (* # 22 "src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall *) open OASISTypes open OASISGettext open OASISMessage open OCamlbuildCommon open BaseStandardVar type run_t = { extra_args: string list; run_path: unix_filename; } let doc_build run pkg (cs, doc) argv = let index_html = OASISUnixPath.make [ run.run_path; cs.cs_name^".docdir"; "index.html"; ] in let tgt_dir = OASISHostPath.make [ build_dir argv; OASISHostPath.of_unix run.run_path; cs.cs_name^".docdir"; ] in run_ocamlbuild (index_html :: run.extra_args) argv; List.iter (fun glb -> BaseBuilt.register BaseBuilt.BDoc cs.cs_name [OASISFileUtil.glob ~ctxt:!BaseContext.default (Filename.concat tgt_dir glb)]) ["*.html"; "*.css"] let doc_clean run pkg (cs, doc) argv = run_clean argv; BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name end # 6651 "setup.ml" open OASISTypes;; let setup_t = { BaseSetup.configure = InternalConfigurePlugin.configure; build = OCamlbuildPlugin.build ["-use-ocamlfind"]; test = []; doc = []; install = InternalInstallPlugin.install; uninstall = InternalInstallPlugin.uninstall; clean = [OCamlbuildPlugin.clean]; clean_test = []; clean_doc = []; distclean = []; distclean_test = []; distclean_doc = []; package = { oasis_version = "0.3"; ocaml_version = Some (OASISVersion.VGreaterEqual "4.00.0"); findlib_version = Some (OASISVersion.VGreaterEqual "1.3.2"); alpha_features = []; beta_features = []; name = "typerep"; version = "113.00.00"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit { OASISLicense.license = "Apache"; excption = None; version = OASISLicense.Version "2.0" }); license_file = Some "LICENSE.txt"; copyrights = ["(C) 2013 Jane Street Group LLC "]; maintainers = ["Jane Street Group"; "LLC "]; authors = ["Jane Street Group"; "LLC "]; homepage = Some "https://github.com/janestreet/typerep_beta"; synopsis = "Runtime types for OCaml"; description = Some [ OASISText.Para "Library for creating runtime representation of OCaml types and computing functions from these." ]; categories = []; conf_type = (`Configure, "internal", Some "0.4"); conf_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; build_type = (`Build, "ocamlbuild", Some "0.4"); build_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; install_type = (`Install, "internal", Some "0.4"); install_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; uninstall_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; clean_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; distclean_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; files_ab = []; sections = [ Library ({ cs_name = "typerep_lib"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "lib"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "ocamlbuild"; ExternalTool "camlp4o"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = [ "Make_typename"; "Named_intf"; "Std"; "Std_internal"; "Type_abstract"; "Type_equal"; "Type_generic_intf"; "Type_generic"; "Typename"; "Typerepable"; "Typerep_obj"; "Variant_and_record_intf" ]; lib_pack = true; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = [] }); Library ({ cs_name = "typerep_syntax"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "syntax"; bs_compiled_object = Best; bs_build_depends = [ FindlibPackage ("camlp4.lib", None); FindlibPackage ("camlp4.extend", None); FindlibPackage ("camlp4.quotations", None); FindlibPackage ("type_conv", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"; ExternalTool "camlp4o"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = ["Pa_typerep_conv"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "typerep_lib"; lib_findlib_name = Some "syntax"; lib_findlib_containers = [] }) ]; plugins = [ (`Extra, "StdFiles", Some "0.3"); (`Extra, "DevFiles", Some "0.3"); (`Extra, "META", Some "0.3") ]; disable_oasis_section = []; schema_data = PropList.Data.create (); plugin_data = [] }; oasis_fn = Some "_oasis"; oasis_version = "0.4.5"; oasis_digest = Some "\223)(T\252\249-\014\210X\219[_\184\nM"; oasis_exec = None; oasis_setup_args = []; setup_update = false };; let setup () = BaseSetup.setup setup_t;; # 6840 "setup.ml" (* OASIS_STOP *) let () = setup () typerep-113.00.00/syntax/000077500000000000000000000000001256342456100150425ustar00rootroot00000000000000typerep-113.00.00/syntax/pa_typerep_conv.ml000066400000000000000000000632171256342456100206020ustar00rootroot00000000000000open StdLabels open Camlp4 open PreCast module Rewrite_tds = Pa_type_conv.Rewrite_tds module Gen = struct include Pa_type_conv.Gen let idp loc id = <:patt< $lid:id$ >> let ide loc id = <:expr< $lid:id$ >> let let_in loc list_lid_expr body = List.fold_right list_lid_expr ~init:body ~f:(fun (lid, expr) body -> <:expr< let $lid:lid$ = $expr$ in $body$ >>) end module List = struct include List let init ~f n = let rec aux acc index = if index < 0 then acc else let acc = f index :: acc in aux acc (pred index) in aux [] (pred n) let fold_righti list ~f ~init = let length = length list in let (acc, _) = fold_right ~f:(fun el (acc, index) -> let acc = f index el acc in (acc, pred index)) ~init:(init, pred length) list in acc let mapi ~f list = let rev, _ = fold_left ~f:(fun (acc, index) el -> f index el :: acc, succ index) ~init:([], 0) list in List.rev rev end (* camlp4 is very confusing with its tuple representation *) module Tuple : sig val expr : Ast.loc -> Ast.expr list -> Ast.expr val patt : Ast.loc -> Ast.patt list -> Ast.patt val ctyp : Ast.loc -> Ast.ctyp list -> Ast.ctyp end = struct let make fct = function | [] -> assert false | [ hd ] -> hd | (_ :: _) as list -> fct list let expr loc = make (fun list -> <:expr< ($tup:Ast.exCom_of_list list$) >>) let patt loc = make (fun list -> <:patt< ($tup:Ast.paCom_of_list list$) >>) let ctyp loc = make (fun list -> <:ctyp< ($tup:Ast.tyCom_of_list list$) >>) end module Field_case = struct type t = { label : string; ctyp : Ast.ctyp; index : int; } end module Variant_case = struct type t = { label : string; ctyp : Ast.ctyp option; poly : bool; arity : int; index : int; arity_index : int; } let patt ~loc t = let label = t.label in if t.poly then <:patt< `$label$ >> else <:patt< $uid:label$ >> let expr ~loc t = let label = t.label in if t.poly then <:expr< `$label$ >> else <:expr< $uid:label$ >> let ocaml_repr ~loc { label ; poly ; arity_index ; _ } = if poly then <:expr< Typerep_lib.Std.Typerep_obj.repr_of_poly_variant `$label$ >> else <:expr< $`int:arity_index$ >> end module Branches = struct let fields fields = let fields = Ast.list_of_ctyp fields [] in let mapi index = function | <:ctyp< $lid:label$ : mutable $ctyp$ >> | <:ctyp< $lid:label$ : $ctyp$ >> -> { Field_case.label ; ctyp ; index } | ctyp -> Gen.unknown_type ctyp "Util.branches(record)" in List.mapi fields ~f:mapi let variants alts = (* duplicates like [ `A | `B | `A ] cause warnings in the generated code (duplicated patterns), so we don't have to deal with them. *) let rec extract = function | <:ctyp< [ $row_fields$ ] >> | <:ctyp< [< $row_fields$ ] >> | <:ctyp< [> $row_fields$ ] >> | <:ctyp< [= $row_fields$ ] >> -> extract row_fields | <:ctyp< $tp1$ | $tp2$ >> -> extract tp1 @ extract tp2 | ctyp -> [ctyp] in let cases = extract alts in let no_arg = let r = ref (-1) in fun () -> incr r; !r in let with_arg = let r = ref (-1) in fun () -> incr r; !r in let mapi index = function | <:ctyp< `$label$ >> -> { Variant_case. label; ctyp = None; poly = true; arity = 0; index; arity_index = no_arg (); } | <:ctyp< `$label$ of $ctyp$ >> -> { Variant_case. label; ctyp = Some ctyp; poly = true; arity = 1; index; arity_index = with_arg (); } | <:ctyp< $uid:label$ >> -> { Variant_case. label; ctyp = None; poly = false; arity = 0; index; arity_index = no_arg (); } | <:ctyp@loc< $uid:label$ of $ctyp$ >> -> let args = Ast.list_of_ctyp ctyp [] in let arity = List.length args in let ctyp = Tuple.ctyp loc args in { Variant_case. label; ctyp = Some ctyp; poly = false; arity; index; arity_index = with_arg (); } | ctyp -> Gen.unknown_type ctyp "Util.branches(variant)" in List.mapi cases ~f:mapi end module Typerep_signature = struct let sig_of_type_definitions ~sig_of_one_def ~ctyp = let rec aux = function | Ast.TyDcl (loc, type_name, params, rhs, cl) -> sig_of_one_def ~loc ~type_name ~params ~rhs ~cl | Ast.TyAnd (loc, tp1, tp2) -> <:sig_item< $aux tp1$; $aux tp2$ >> | _ -> assert false in aux ctyp let sig_of_of_t make_ty ~loc ~type_name ~params = let t_with_params = let fold acc param = <:ctyp< $acc$ $param$ >> in List.fold_left ~f:fold ~init:<:ctyp< $lid:type_name$ >> params in let returned = <:ctyp< $make_ty t_with_params$ >> in let fold param acc = let param = Gen.drop_variance_annotations param in let loc = Ast.loc_of_ctyp param in <:ctyp< $make_ty param$ -> $acc$ >> in List.fold_right ~f:fold ~init:returned params let sig_of_typerep_of_t ~loc = let make_ty params = <:ctyp< Typerep_lib.Std.Typerep.t $params$ >> in sig_of_of_t make_ty ~loc let sig_of_typename_of_t ~loc = let make_ty params = <:ctyp< Typerep_lib.Std.Typename.t $params$ >> in sig_of_of_t make_ty ~loc let sig_of_one_def ~loc ~type_name ~params ~rhs:_ ~cl:_ = let typerep_of = sig_of_typerep_of_t ~loc ~type_name ~params in let typename_of = sig_of_typename_of_t ~loc ~type_name ~params in <:sig_item< value $lid: "typerep_of_" ^ type_name$ : $typerep_of$; value $lid: "typename_of_" ^ type_name$ : $typename_of$; >> let sig_generator _rec ctyp = sig_of_type_definitions ~sig_of_one_def ~ctyp let () = Pa_type_conv.add_sig_generator "typerep" sig_generator end module Typerep_implementation = struct module Util : sig val typename_field : loc:Ast.loc -> type_name:string option -> Ast.expr val arg_of_param : string -> string val params_names : params:Ast.ctyp list -> string list val params_patts : loc:Ast.loc -> params_names:string list -> Ast.patt list val type_name_module_definition : loc:Ast.loc -> type_name:string -> params_names:string list -> Ast.str_item val with_named : loc:Ast.loc -> type_name:string -> params_names:string list -> Ast.expr -> Ast.expr val typerep_of_t_coerce : loc:Ast.loc -> type_name:string -> params_names:string list -> Ast.ctyp option val typerep_abstract : loc:Ast.loc -> type_name:string -> params_names:string list -> Ast.str_item module Record : sig val field_n_ident : fields:(Field_case.t list) -> int -> string val fields : loc:Ast.loc -> typerep_of_type:(Ast.ctyp -> Ast.expr) -> fields:Field_case.t list -> (int * string * Ast.expr) list val create : loc:Ast.loc -> fields:Field_case.t list -> Ast.expr val has_double_array_tag : loc:Ast.loc -> fields:Field_case.t list -> Ast.expr end module Variant : sig val tag_n_ident : variants:(Variant_case.t list) -> int -> string val tags : loc:Ast.loc -> typerep_of_type:(Ast.ctyp -> Ast.expr) -> variants:Variant_case.t list -> (int * Ast.expr) list val value : loc:Ast.loc -> variants:Variant_case.t list -> Ast.expr val polymorphic : loc:Ast.loc -> variants:Variant_case.t list -> Ast.expr end end = struct let str_item_type_and_name loc ~params_names ~type_name = let params = List.map params_names ~f:(fun name -> <:ctyp< '$lid:name$ >>) in let prototype = let fold acc name = <:ctyp< $acc$ '$lid:name$ >> in let init = <:ctyp< $lid:type_name$ >> in List.fold_left ~f:fold ~init params_names in let tds = Ast.TyDcl (loc, "t", params, prototype, []) in let type_t = Rewrite_tds.str_ loc false tds in let name_def = let full_type_name = Printf.sprintf "%s.%s" (Pa_type_conv.get_conv_path ()) type_name in <:str_item< value name = $str:full_type_name$ >> in <:module_expr< struct $type_t$; $name_def$; end >> let arg_of_param name = "_of_" ^ name let name_of_t ~type_name = "name_of_" ^ type_name let typename_field ~loc ~type_name = match type_name with | None -> <:expr< Typerep_lib.Std.Typename.create () >> | Some type_name -> <:expr< Typerep_lib.Std.Typerep.Named.typename_of_t $lid:name_of_t ~type_name$ >> let params_names ~params = List.map params ~f:(fun ty -> Gen.get_tparam_id ty) let params_patts ~loc ~params_names = List.map params_names ~f:(fun s -> Gen.idp loc (arg_of_param s)) let type_name_module_name ~type_name = "Typename_of_" ^ type_name let with_named ~loc ~type_name ~params_names expr = let name_t = let init = <:expr< $uid:type_name_module_name ~type_name$.named >> in List.fold_left params_names ~init ~f:(fun acc name -> let arg = arg_of_param name in <:expr< $acc$ $lid:arg$>> ) in let name_of_t = name_of_t ~type_name in let args = <:expr< ( $lid:name_of_t$, Some (lazy $expr$) ) >> in <:expr< let $lid:name_of_t$ = $name_t$ in Typerep_lib.Std.Typerep.Named $args$ >> let typerep_of_t_coerce ~loc ~type_name ~params_names = match params_names with | [] -> None | hd :: tl -> let returned = let fold acc name = <:ctyp< $acc$ '$lid:name$ >> in let init = <:ctyp< $lid:type_name$ >> in let t = List.fold_left ~f:fold ~init params_names in <:ctyp< Typerep_lib.Std.Typerep.t $t$ >> in let coerce = let fold name acc = let arg = <:ctyp< Typerep_lib.Std.Typerep.t '$lid:name$ >> in <:ctyp< $arg$ -> $acc$ >> in List.fold_right ~init:returned ~f:fold params_names in let f name = <:ctyp< '$name$ >> in let typevars = List.fold_left ~f:(fun a b -> <:ctyp< $a$ $f b$>>) ~init:(f hd) tl in Some <:ctyp< ! $typevars$ . $coerce$ >> (* forall *) let type_name_module_definition ~loc ~type_name ~params_names = let name = type_name_module_name ~type_name in let type_arity = List.length params_names in let make = <:module_expr< Typerep_lib.Std.Make_typename.$uid:"Make" ^ (string_of_int type_arity)$ >> in let type_name_struct = str_item_type_and_name loc ~params_names ~type_name in let type_name_module = <:module_expr< $make$ $type_name_struct$ >> in let module_def = <:str_item< module $uid:name$ = $type_name_module$ >> in let typename_of_t = let lid = "typename_of_" ^ type_name in <:str_item< value $lid:lid$ = $uid:name$.typename_of_t >> in <:str_item< $module_def$; $typename_of_t$; >> let typerep_abstract ~loc ~type_name ~params_names = let type_name_struct = str_item_type_and_name loc ~params_names ~type_name in let type_arity = List.length params_names in let make = <:module_expr< Typerep_lib.Std.Type_abstract.$uid:"Make" ^ (string_of_int type_arity)$ >> in <:str_item< include $make$ $type_name_struct$ >> let field_or_tag_n_ident prefix ~list n = if n < 0 || n > List.length list then assert false; prefix ^ string_of_int n module Record = struct let field_n_ident ~fields:list = field_or_tag_n_ident "field" ~list let fields ~loc ~typerep_of_type ~fields = let map { Field_case.ctyp ; label ; index } = let rep = typerep_of_type ctyp in index, label, <:expr< Typerep_lib.Std.Typerep.Field.internal_use_only { Typerep_lib.Std.Typerep.Field_internal. label = $str:label$; index = $`int:index$; rep = $rep$; tyid = Typerep_lib.Std.Typename.create (); get = (fun t -> t.$lid:label$); } >> in List.map ~f:map fields let has_double_array_tag ~loc ~fields = let fields_binding = let map { Field_case.label ; _ } = (* The value must be a float else this segfaults. This is tested by the unit tests in case this property changes. *) <:rec_binding< $lid:label$ = Typerep_lib.Std.Typerep_obj.double_array_value >> in List.map ~f:map fields in <:expr< Typerep_lib.Std.Typerep_obj.has_double_array_tag { $list:fields_binding$ } >> let create ~loc ~fields = let record = (* Calling [get] on the fields from left to right matters, so that iteration goes left to right too. *) let fields_binding = let map { Field_case.label ; _ } = <:rec_binding< $lid:label$ >> in List.map ~f:map fields in let record = <:expr< { $list:fields_binding$ } >> in let foldi index' { Field_case.label ; index; _ } acc = if index <> index' then assert false; let rhs = <:expr< get $lid:field_n_ident ~fields index$ >> in <:expr< let $lid:label$ = $rhs$ in $acc$ >> in List.fold_righti fields ~f:foldi ~init:record in <:expr< fun { Typerep_lib.Std.Typerep.Record_internal.get = get } -> $record$ >> end module Variant = struct (* tag_0, tag_1, etc. *) let tag_n_ident ~variants:list = field_or_tag_n_ident "tag" ~list let polymorphic ~loc ~variants = let polymorphic = match variants with | [] -> true | hd :: _ -> hd.Variant_case.poly in <:expr< $`bool:polymorphic$ >> let tags ~loc ~typerep_of_type ~variants = let create ({ Variant_case.arity ; _ } as variant) = let constructor = Variant_case.expr ~loc variant in if arity = 0 then <:expr< Typerep_lib.Std.Typerep.Tag_internal.Const $constructor$ >> else let arg_tuple i = "v" ^ string_of_int i in let patt, expr = let patt = let f i = <:patt< $lid:arg_tuple i$ >> in Tuple.patt loc (List.init arity ~f) in let expr = let f i = <:expr< $lid:arg_tuple i$ >> in let args = Tuple.expr loc (List.init arity ~f) in <:expr< $constructor$ $args$ >> in patt, expr in <:expr< Typerep_lib.Std.Typerep.Tag_internal.Args (fun $patt$ -> $expr$) >> in let mapi index' ({ Variant_case.ctyp ; label ; arity ; index ; _ } as variant) = if index <> index' then assert false; let rep, tyid = match ctyp with | Some ctyp -> typerep_of_type ctyp, <:expr< Typerep_lib.Std.Typename.create () >> | None -> <:expr< typerep_of_tuple0 >>, <:expr< typename_of_tuple0 >> in let label_string = Pa_type_conv.Gen.regular_constr_of_revised_constr label in index, <:expr< Typerep_lib.Std.Typerep.Tag.internal_use_only { Typerep_lib.Std.Typerep.Tag_internal. label = $str:label_string$; rep = $rep$; arity = $`int:arity$; index = $`int:index$; ocaml_repr = $Variant_case.ocaml_repr ~loc variant$; tyid = $tyid$; create = $create variant$; } >> in List.mapi ~f:mapi variants let value ~loc ~variants = let match_cases = let arg_tuple i = "v" ^ string_of_int i in let mapi index' ({ Variant_case.arity ; index ; _ } as variant) = if index <> index' then assert false; let constructor = Variant_case.patt ~loc variant in let patt, value = if arity = 0 then constructor, <:expr< value_tuple0 >> else let patt = let f i = <:patt< $lid:arg_tuple i$ >> in let args = Tuple.patt loc (List.init arity ~f) in <:patt< $constructor$ $args$ >> in let expr = let f i = <:expr< $lid:arg_tuple i$ >> in Tuple.expr loc (List.init arity ~f) in patt, expr in let tag = <:expr< $lid:tag_n_ident ~variants index$ >> in let prod = <:expr< Typerep_lib.Std.Typerep.Variant_internal.Value ($tag$, $value$) >> in <:match_case< $patt$ -> $prod$ >> in List.mapi ~f:mapi variants in <:expr< fun [ $list:match_cases$ ] >> end end let mk_abst_call loc tn rev_path = <:expr< $id:Gen.ident_of_rev_path loc (("typerep_of_" ^ tn) :: rev_path)$ >> (* Conversion of type paths *) let typerep_of_path_fun loc id = match Gen.get_rev_id_path id [] with | tn :: rev_path -> mk_abst_call loc tn rev_path | [] -> assert false let rec typerep_of_type = function | <:ctyp@loc< $ty$ $param$ >> -> typerep_of_type_app loc ~ty ~param | <:ctyp@loc< '$parm$ >> -> Gen.ide loc (Util.arg_of_param parm) | <:ctyp@loc< $id:id$ >> -> typerep_of_path_fun loc id | <:ctyp< [< $row_fields$ ] >> | <:ctyp< [> $row_fields$ ] >> | <:ctyp< [= $row_fields$ ] >> -> typerep_of_variant ~type_name:None row_fields | <:ctyp< ( $tup:tuple$ ) >> -> typerep_of_tuple tuple | ctyp -> Gen.unknown_type ctyp "typerep_of_type" and typerep_of_type_app loc ~ty ~param = let typerep_of_ty = typerep_of_type ty in let typerep_of_param = typerep_of_type param in <:expr< $typerep_of_ty$ $typerep_of_param$ >> and typerep_of_tuple tuple = let loc = Ast.loc_of_ctyp tuple in let typereps = List.map (Ast.list_of_ctyp tuple []) ~f:typerep_of_type in let typerep_of_tuple = let len = List.length typereps in if len < 2 || len > 5 then Gen.error tuple ~fn:"typerep impl_gen" ~msg:(Printf.sprintf "unsupported tuple arity %d. must be in {2,3,4,5}" len) else Gen.ide loc ("typerep_of_tuple" ^ string_of_int len) in Gen.apply loc typerep_of_tuple typereps and typerep_of_record ~type_name ctyp = let loc = Ast.loc_of_ctyp ctyp in let fields = Branches.fields ctyp in let field_ident i = Util.Record.field_n_ident ~fields i in let indexed_fields = Util.Record.fields ~loc ~typerep_of_type ~fields in let fields_array = let fields = List.map ~f:(fun (index,_,_) -> <:expr< Typerep_lib.Std.Typerep.Record_internal.Field $lid:field_ident index$ >> ) indexed_fields in <:expr< [| $list:fields$ |] >> in let bindings = [ "typename", Util.typename_field ~loc ~type_name:(Some type_name); "has_double_array_tag", Util.Record.has_double_array_tag ~loc ~fields; "fields", fields_array; "create", Util.Record.create ~loc ~fields; ] in let fields_binding = let map (name, _) = <:rec_binding< Typerep_lib.Std.Typerep.Record_internal.$lid:name$ >> in List.map ~f:map bindings in let record = let fields = <:expr< Typerep_lib.Std.Typerep.Record.internal_use_only { $list:fields_binding$ } >> in <:expr< Typerep_lib.Std.Typerep.Record $fields$ >> in let record = Gen.let_in loc bindings record in let record = List.fold_right indexed_fields ~f:(fun (index, _, expr) acc -> <:expr< let $lid:field_ident index$ = $expr$ in $acc$ >> ) ~init:record in record and typerep_of_variant ~type_name ctyp = let loc = Ast.loc_of_ctyp ctyp in let variants = Branches.variants ctyp in let tags = Util.Variant.tags ~loc ~typerep_of_type ~variants in let tag_ident i = Util.Variant.tag_n_ident ~variants i in let tags_array = let tags = List.map ~f:(fun (index,_) -> <:expr< Typerep_lib.Std.Typerep.Variant_internal.Tag $lid:tag_ident index$ >> ) tags in <:expr< [| $list:tags$ |] >> in let bindings = [ "typename", Util.typename_field ~loc ~type_name; "tags", tags_array; "polymorphic", Util.Variant.polymorphic ~loc ~variants; "value", Util.Variant.value ~loc ~variants; ] in let tags_binding = let map (name, _) = <:rec_binding< Typerep_lib.Std.Typerep.Variant_internal. $lid:name$ = $lid:name$ >> in List.map ~f:map bindings in let variant = let tags = <:expr< Typerep_lib.Std.Typerep.Variant.internal_use_only { $list:tags_binding$ } >> in <:expr< Typerep_lib.Std.Typerep.Variant $tags$ >> in let variant = Gen.let_in loc bindings variant in let variant = List.fold_right tags ~f:(fun (index, expr) acc -> <:expr< let $lid:tag_ident index$ = $expr$ in $acc$ >> ) ~init:variant in variant let impl_of_one_def ~loc ~type_name ~params ~rhs:ctyp = let rec body ctyp = Gen.switch_tp_def ctyp ~alias:(fun (_:Loc.t) ctyp -> typerep_of_type ctyp) ~sum:(fun (_:Loc.t) -> typerep_of_variant ~type_name:(Some type_name)) ~record:(fun (_:Loc.t) -> typerep_of_record ~type_name) ~variants:(fun (_:Loc.t) -> typerep_of_variant ~type_name:(Some type_name)) ~mani:(fun (_:Loc.t) _tp1 ctyp -> body ctyp) ~nil:(fun loc -> Loc.raise loc (Failure "typerep cannot be applied on abstract types, except \ like 'type t with typerep(abstract)'") ) in let body = body ctyp in let params_names = Util.params_names ~params in let params_patts = Util.params_patts ~loc ~params_names in let body = Util.with_named ~loc ~type_name ~params_names body in let arguments = List.map2 params_names params_patts ~f:(fun name patt -> (* Add type annotations to parameters, at least to avoid the unused type warning. *) let loc = Ast.loc_of_patt patt in <:patt< ($patt$ : Typerep_lib.Std.Typerep.t $lid:name$) >>) in let body = Gen.abstract loc arguments body in let body = List.fold_right params_names ~init:body ~f:(fun name acc -> <:expr< fun (type $name$) -> $acc$ >> ) in let body = match Util.typerep_of_t_coerce ~loc ~type_name ~params_names with | Some coerce -> <:expr< ($body$ : $coerce$) >> | None -> body in let bnd = Gen.idp loc ("typerep_of_" ^ type_name) in let binding = <:binding< $bnd$ = $body$ >> in Util.type_name_module_definition ~loc ~type_name ~params_names, binding let rec with_typerep_aux = function | Ast.TyDcl (loc, type_name, params, rhs, _cl) -> [impl_of_one_def ~loc ~type_name ~params ~rhs] | <:ctyp< $ctyp1$ and $ctyp2$ >> -> with_typerep_aux ctyp1 @ with_typerep_aux ctyp2 | _ -> assert false let with_typerep rec_ ctyp = let loc, rec_ = match ctyp with | Ast.TyDcl (loc, type_name, _, rhs, _) -> loc, rec_ && Gen.type_is_recursive type_name rhs | <:ctyp@loc< $_$ and $_$ >> -> loc, rec_ | _ -> assert false in let rec_flag = match rec_ with | true -> <:rec_flag< rec >> | false -> <:rec_flag< >> in let prelude, bindings = List.split (with_typerep_aux ctyp) in <:str_item< $list:prelude$; value $rec:rec_flag$ $list:bindings$; >> let rec with_typerep_abstract rec_ ctyp = match ctyp with | Ast.TyDcl (loc, type_name, params, _ctyp, _cl) -> ignore rec_; let params_names = Util.params_names ~params in Util.typerep_abstract ~loc ~type_name ~params_names | <:ctyp@loc< $ctyp1$ and $ctyp2$ >> -> <:str_item< $with_typerep_abstract rec_ ctyp1$; $with_typerep_abstract rec_ ctyp2$; >> | _ -> Gen.error ctyp ~fn:"typerep impl_gen" ~msg:"unsupported type def" module Config = struct type t = { abstract : bool; warn_23_field : unit; } let default = { abstract = false; warn_23_field = (); } let gram_entry : t Gram.Entry.t = Gram.Entry.mk "typerep_arguments" EXTEND Gram GLOBAL: gram_entry; typerep_arg: [[ LIDENT "abstract" -> (fun acc -> { acc with abstract = true }) | id = LIDENT -> Loc.raise loc (Failure (Printf.sprintf "Unknown typerep argument %S" id)); ]]; gram_entry: [[ v = LIST0 typerep_arg SEP "," ; `EOI -> ignore loc; (* don't know how to ignore it otherwise *) List.fold_left v ~f:(fun acc f -> f acc) ~init:default ]]; END end let () = Pa_type_conv.add_generator_with_arg "typerep" Config.gram_entry (fun conf rec_ ctyp -> let config = match conf with None -> Config.default | Some conf -> conf in if config.Config.abstract then with_typerep_abstract rec_ ctyp else with_typerep rec_ ctyp ) let typerep_of_quote (loc : Ast.loc) (_loc_name_opt : string option) (cnt_str : string) = Pa_type_conv.set_conv_path_if_not_set loc; let ctyp = Gram.parse_string Syntax.ctyp_quot loc cnt_str in typerep_of_type ctyp let () = Quotation.add "typerep_of" Quotation.DynAst.expr_tag typerep_of_quote end typerep-113.00.00/syntax/pa_typerep_conv.mli000066400000000000000000000015331256342456100207440ustar00rootroot00000000000000(** Pa_type_rep: Preprocessing Module for automatic type representation *) open Camlp4 open PreCast module Tuple : sig val expr : Ast.loc -> Ast.expr list -> Ast.expr val patt : Ast.loc -> Ast.patt list -> Ast.patt val ctyp : Ast.loc -> Ast.ctyp list -> Ast.ctyp end module Field_case : sig type t = { label : string; ctyp : Ast.ctyp; index : int; } end module Variant_case : sig type t = { label : string; ctyp : Ast.ctyp option; poly : bool; arity : int; index : int; arity_index : int; } (** expr and patt for the constructor *) val expr : loc:Ast.loc -> t -> Ast.expr val patt : loc:Ast.loc -> t -> Ast.patt val ocaml_repr : loc:Ast.loc -> t -> Ast.expr end module Branches : sig val fields : Ast.ctyp -> Field_case.t list val variants : Ast.ctyp -> Variant_case.t list end typerep-113.00.00/syntax/typerep_syntax.mldylib000066400000000000000000000001441256342456100215150ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: f436e54f4577b31addedd8eeae83512c) Pa_typerep_conv # OASIS_STOP typerep-113.00.00/syntax/typerep_syntax.mllib000066400000000000000000000001441256342456100211600ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: f436e54f4577b31addedd8eeae83512c) Pa_typerep_conv # OASIS_STOP