├── .gitignore ├── .ocamlformat ├── LICENSE ├── Makefile ├── README.md ├── bench ├── .gitignore ├── dune ├── json_roundtrip_bench.ml ├── variant_roundtrip_bench.ml ├── variant_roundtrip_gen.ml └── variant_roundtrip_type.ml ├── dune ├── dune-project ├── lib ├── check.ml ├── check.mli ├── dune ├── ext.ml ├── json.ml ├── json.mli ├── lrt.ml ├── lrt_ppx_runtime.ml ├── matcher.ml ├── matcher_index.ml ├── path.ml ├── path.mli ├── print.ml ├── print.mli ├── std.ml ├── std.mli ├── stype.ml ├── stype.mli ├── ttype.ml ├── ttype.mli ├── typEq.ml ├── typEq.mli ├── unify.ml ├── unify.mli ├── utf8.ml ├── utf8.mli ├── variant.ml ├── variant.mli ├── variant_lexer.mli ├── variant_lexer.mll ├── xtype.ml └── xtype.mli ├── lrt.opam ├── ppx ├── deriving │ ├── dune │ └── lrt_deriving.ml ├── path │ ├── dune │ └── lrt_path.ml └── standalone │ ├── dune │ └── standalone.ml └── test ├── dune ├── fuzzing.expected ├── fuzzing.ml ├── matcher.ml ├── open_std_only.ml ├── path.ml ├── ppx.ml └── variantizer.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _* 2 | *.install 3 | .merlin 4 | dune-workspace 5 | docs 6 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile = conventional 2 | disambiguate-non-breaking-match = false 3 | indicate-multiline-delimiters = closing-on-separate-line 4 | exp-grouping = preserve 5 | dock-collection-brackets = true 6 | field-space=tight-decl 7 | leading-nested-match-parens=true 8 | ocp-indent-compat=true 9 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020 by LexiFi. 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: build test fmt docs 2 | 3 | build: 4 | dune build 5 | 6 | test: 7 | dune runtest 8 | 9 | fmt: test 10 | dune build @fmt --auto-promote 11 | 12 | docs: 13 | dune build @doc 14 | rm -r docs || true 15 | cp -r _build/default/_doc/_html docs 16 | 17 | deploy-docs: 18 | test -d _site || git worktree add _site gh-pages 19 | cd _site && git rm -rf * 20 | cp -r _build/default/_doc/_html/* _site 21 | cd _site && git add --all 22 | cd _site && git commit -m "Deploy updates" 23 | git push origin gh-pages 24 | git worktree remove _site 25 | 26 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | LexiFi runtime types 2 | ==================== 3 | 4 | [//]: # (Remember to keep this pitch in sync with lib/lrt.ml and lrt.opam) 5 | 6 | It is often useful to get access to types at runtime in order to implement 7 | generic type-driven operations. A typical example is a generic 8 | pretty-printer. Unfortunately, the OCaml compiler does not keep type 9 | information at runtime. At LexiFi, we have extended OCaml to support runtime 10 | types. This extension has been in use for years and is now a key element in 11 | many of our interesting components, such as our automatic GUI framework 12 | (which derives GUIs from type definitions) or our high-level database layer 13 | (which derives SQL schema from type definitions, and exposes a well-typed 14 | interface for queries). This extension is tightly integrated with the OCaml 15 | typechecker, which allows the compiler to synthesize the runtime type 16 | representations with minimal input from the programmer. 17 | 18 | This package makes the features of our extension available to other OCaml 19 | users without relying on a modified compiler. Instead, it only relies on a 20 | PPX syntax extension that synthesizes the runtime representation of types 21 | from their syntactic definition with a deriving-like approach. 22 | 23 | Based on this new implementation we are able to open-source the 24 | infrastructure we have developed around the machinery of runtime types as 25 | well as libraries built upon them. 26 | 27 | ## Getting started 28 | 29 | This package has not been made available on the OPAM repository. You can 30 | still use OPAM to install its current version: 31 | 32 | ```sh 33 | opam pin add lrt git://github.com/lexifi/lrt.git 34 | ``` 35 | 36 | Then, in order to generate runtime representations of your OCaml 37 | types, you have to enable the lrt ppx. Your dune file might look like 38 | the following. 39 | 40 | ```dune 41 | (executable 42 | (name foo) 43 | (libraries bar lrt) 44 | (preprocess (pps lrt.deriving))) 45 | ``` 46 | 47 | Now you can use runtime types in your programs: 48 | 49 | ```ocaml 50 | open Lrt 51 | 52 | type nat = 53 | | Z 54 | | S of nat 55 | [@@deriving t] 56 | 57 | let () = 58 | Print.show ~t:nat_t (S (S (S Z))) 59 | ``` 60 | 61 | Having the basic things set up, you are ready to explore the 62 | [documentation][docs] of the `Lrt` module. 63 | 64 | ## About 65 | 66 | This must be considered a **preliminary, potentially unstable release**. 67 | 68 | The package is is licensed by LexiFi under the terms of the MIT license. 69 | 70 | [docs]: https://lexifi.github.io/lrt/lrt/Lrt/index.html 71 | [lexifi]: https://lexifi.github.io/ 72 | 73 | ## Maintaining 74 | 75 | There are four main directories: 76 | 77 | * `lib` contains the runtime type representations and useful modules built atop. 78 | * `ppx` contains the syntax extension. 79 | * `bench` contains the json/variant roundtrip benchmark code. 80 | * `tests` contains the separate tests. Some more tests are placed 81 | directly in the corresponding modules. 82 | 83 | Some things remain open: 84 | 85 | * Except of `Json` no module uses the latest features of `Xtype` and 86 | `Matcher`. 87 | * `Unify` was written before `Matcher` and uses a different definition 88 | of equality. 89 | * `git grep TODO` 90 | 91 | Useful commands: 92 | 93 | * View the generated code using 94 | `dune exec ppx/standalone.exe test/ppx.ml`. 95 | * Run tests using `dune runtest`. 96 | * Format the code using `dune build @fmt --auto-promote` or 97 | `make fmt`. 98 | * Generate documentation for github pages using `make docs`, then commit 99 | and push to master. 100 | -------------------------------------------------------------------------------- /bench/.gitignore: -------------------------------------------------------------------------------- 1 | variant_roundtrip_data.txt 2 | -------------------------------------------------------------------------------- /bench/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (libraries lrt landmarks) 3 | (names variant_roundtrip_gen variant_roundtrip_bench json_roundtrip_bench) 4 | (preprocess 5 | (pps ppx_expect lrt.deriving landmarks.ppx))) 6 | -------------------------------------------------------------------------------- /bench/json_roundtrip_bench.ml: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | open Lrt 9 | 10 | type t = Variant_roundtrip_type.t list [@@deriving t] 11 | 12 | let filename = 13 | if Array.length Sys.argv > 1 then Sys.argv.(1) 14 | else ( 15 | Printf.eprintf "Please provide filename of data as first argument"; 16 | exit 1 17 | ) 18 | 19 | let value = Variant.value_of_variant_in_file ~t filename 20 | 21 | let[@landmark "iteration"] run () = 22 | let[@landmark "prepare"] Json.{ of_json; to_json } = Json.conv t in 23 | let[@landmark "to_json"] json = to_json value in 24 | let[@landmark "of_json"] value' = of_json json in 25 | ignore value' 26 | 27 | let _ = List.init 10 (fun _ -> run ()) 28 | -------------------------------------------------------------------------------- /bench/variant_roundtrip_bench.ml: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | open Lrt 9 | 10 | type t = Variant_roundtrip_type.t list [@@deriving t] 11 | 12 | let filename = 13 | if Array.length Sys.argv > 1 then Sys.argv.(1) 14 | else ( 15 | Printf.eprintf "Please provide filename of data as first argument"; 16 | exit 1 17 | ) 18 | 19 | let x = Variant.value_of_variant_in_file ~t filename 20 | 21 | let[@landmark "test"] run () = 22 | let[@landmark "to_variant"] v = Variant.to_variant ~t x in 23 | let[@landmark "of_variant"] x' = Variant.of_variant ~t v in 24 | ignore x' 25 | 26 | let _ = List.init 10 (fun _ -> run ()) 27 | -------------------------------------------------------------------------------- /bench/variant_roundtrip_gen.ml: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | open Lrt 9 | open Check 10 | open Variant_roundtrip_type 11 | 12 | let _ = 13 | let seed = 42 and size = 100 and n = 100_000 in 14 | print_endline "["; 15 | let _ = 16 | test n ~seed ~generator:(of_type_gen ~size [] ~t) (fun x -> 17 | Format.printf "%a;\n" Variant.print_variant (Variant.to_variant ~t x); 18 | true) 19 | in 20 | print_endline "]" 21 | -------------------------------------------------------------------------------- /bench/variant_roundtrip_type.ml: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | open Lrt 9 | 10 | type currency = 11 | | USD (** US Dollar*) 12 | | JPY (** Japanese Yen*) 13 | | EUR (** Euro*) 14 | | GBP (** Pound Sterling*) 15 | | CHF (** Swiss Franc*) 16 | | HKD (** Hong Kong Dollar*) 17 | | CAD (** Canadian Dollar*) 18 | | AUD (** Australian Dollar*) 19 | | DKK (** Danish Krone*) 20 | | NOK (** Norvegian Krone*) 21 | | SEK (** Swedish Krona*) 22 | | CZK (** Czech Koruna*) 23 | | IEP (** Irish Pound*) 24 | | MYR (** Malayasian Ringgit*) 25 | | NZD (** New Zealand Dollar*) 26 | | SGD (** Singapore Dollar*) 27 | | THB (** Thai Baht*) 28 | | ZAR (** South African Rand*) 29 | | FIM (** Markka*) 30 | | PTE (** Portuguese Escudo*) 31 | | IDR (** Indonesian Rupiah*) 32 | | TWD (** New Taiwan Dollar*) 33 | | EEK (** Estonian Kroon*) 34 | | HUF (** Hungarian Forint*) 35 | | ARS (** Argentine peso*) 36 | | BRL (** Brazilian Real*) 37 | | CLP (** Chiliean Peso*) 38 | | FRF 39 | | DEM 40 | | ITL 41 | | ESP 42 | | BEF 43 | | ATS 44 | | NLG 45 | | LUF 46 | | GRD (** Euroland*) 47 | | ILS (** Israeli Shekel*) 48 | | KRW (** Korean Won*) 49 | | LBP (** Libanese Pound*) 50 | | MXP (** Mexican Peso*) 51 | | PHP (** Philippine peso*) 52 | | PLZ (** Polish Zloty*) 53 | | RUB (** Russian Ruble*) 54 | | SAR (** Saudi Arabian Riyal *) 55 | | SKK (** Slovak Koruna*) 56 | | TRL (** Turkish Lira*) 57 | | CNY (** Chinese Yuan Renminbi*) 58 | | INR (** Indian Rupee*) 59 | | MXN 60 | | TRY 61 | | PLN 62 | | IRR 63 | | AED 64 | | VEF 65 | | COP 66 | | EGP 67 | | NGN 68 | | PKR 69 | | RON 70 | | DZD 71 | | PEN 72 | | KZT 73 | | UAH 74 | | KWD 75 | | QAR 76 | | BDT 77 | | VND 78 | | MAD 79 | | XAU 80 | | XAG 81 | | XPT 82 | | XPD 83 | | GBX (** Pence Sterling (100 GBX = 1 GBP) *) 84 | | LKR (** Sri Lankan rupee *) 85 | | CNH (** Huan Offshore *) 86 | | AFN 87 | | ALL 88 | | AOA 89 | | AZN 90 | | BAM 91 | | BGN 92 | | BHD 93 | | BOB 94 | | BWP 95 | | BYR 96 | | CDF 97 | | CRC 98 | | CUC 99 | | CUP 100 | | DOP 101 | | ETB 102 | | GHS 103 | | GTQ 104 | | HNL 105 | | HRK 106 | | IQD 107 | | JOD 108 | | KES 109 | | KHR 110 | | MMK 111 | | MZN 112 | | NPR 113 | | OMR 114 | | PAB 115 | | PYG 116 | | RSD 117 | | SDG 118 | | SVC 119 | | SYP 120 | | TMT 121 | | TND 122 | | TZS 123 | | UGX 124 | | UYU 125 | | UZS 126 | | YER 127 | | XCD (** East Caribbean Dollar *) 128 | | AMD (** Armenia Dram *) 129 | | ANG (** Netherlands Antilles Guilder *) 130 | | AWG (** Aruba Guilder *) 131 | | BBD (** Barbados Dollar *) 132 | | BIF (** Burundi Franc *) 133 | | BMD (** Bermuda Dollar *) 134 | | BND (** Brunei Darussalam Dollar *) 135 | | BSD (** Bahamas Dollar *) 136 | | BZD (** Belize Dollar *) 137 | | CVE (** Cape Verde Escudo *) 138 | | DJF (** Djibouti Franc *) 139 | | ERN (** Eritrea Nakfa *) 140 | | FJD (** Fiji Dollar *) 141 | | FKP (** Falkland Islands (Malvinas) Pound *) 142 | | GEL (** Georgia Lari *) 143 | | GIP (** Gibraltar Pound *) 144 | | GMD (** Gambia Dalasi *) 145 | | GNF (** Guinea Franc *) 146 | | GYD (** Guyana Dollar *) 147 | | ISK (** Iceland Krona *) 148 | | JMD (** Jamaica Dollar *) 149 | | KGS (** Kyrgyzstan Som *) 150 | | KMF (** Comoros Franc *) 151 | | KPW (** Korea (North) Won *) 152 | | KYD (** Cayman Islands Dollar *) 153 | | LAK (** Laos Kip *) 154 | | LRD (** Liberia Dollar *) 155 | | LYD (** Libya Dinar *) 156 | | MDL (** Moldova Leu *) 157 | | MGA (** Madagascar Ariary *) 158 | | MKD (** Macedonia Denar *) 159 | | MNT (** Mongolia Tughrik *) 160 | | MOP (** Macau Pataca *) 161 | | MRO (** Mauritania Ouguiya *) 162 | | MUR (** Mauritius Rupee *) 163 | | MVR (** Maldives (Maldive Islands) Rufiyaa *) 164 | | MWK (** Malawi Kwacha *) 165 | | NIO (** Nicaragua Cordoba *) 166 | | PGK (** Papua New Guinea Kina *) 167 | | RWF (** Rwanda Franc *) 168 | | SBD (** Solomon Islands Dollar *) 169 | | SCR (** Seychelles Rupee *) 170 | | SHP (** Saint Helena Pound *) 171 | | SLL (** Sierra Leone Leone *) 172 | | SOS (** Somalia Shilling *) 173 | | SRD (** Suriname Dollar *) 174 | | SSP (** South Sudanese pound *) 175 | | STD (** São Tomé and Príncipe Dobra *) 176 | | SZL (** Swaziland Lilangeni *) 177 | | TJS (** Tajikistan Somoni *) 178 | | TOP (** Tonga Pa'anga *) 179 | | TTD (** Trinidad and Tobago Dollar *) 180 | | VUV (** Vanuatu Vatu *) 181 | | WST (** Samoa Tala *) 182 | | XAF (** Communauté Financière Africaine (BEAC) CFA Franc BEAC *) 183 | | XOF (** Communauté Financière Africaine (BCEAO) Franc *) 184 | | XPF (** Comptoirs Français du Pacifique (CFP) Franc *) 185 | | ZMW (** Zambia Kwacha *) 186 | | ZWL (** Zimbabwean dollar *) 187 | | CLF (** Chile Unidad de Fomento *) 188 | | LTL (** Lithuanian Litas (now Euroland) *) 189 | | Asset of string (** Another asset, considered as a currency. *) 190 | [@@deriving t] 191 | 192 | type rec1 = { 193 | rec1_f1: string; 194 | rec1_f2: int; 195 | rec1_f3: int * string; 196 | rec1_f4: bool; 197 | rec1_f5: float list; 198 | } 199 | 200 | and rec2 = { rec2_f1: float; rec2_f2: float; rec2_i1: int } 201 | 202 | and variant = 203 | | R1 of rec1 204 | | R2 of rec2 205 | | V1 of bool option array 206 | | V2 of currency list 207 | | E1 208 | 209 | and t = variant * variant [@@deriving t] 210 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LexiFi/lrt/038ff963bd066c9d94cffb9896b04b6b8696f136/dune -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.0) 2 | (name lrt) 3 | (version "~dev") 4 | -------------------------------------------------------------------------------- /lib/check.mli: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | (** A quickcheck-like library for OCaml. *) 9 | 10 | (** {3 Generators} *) 11 | 12 | type 'a gen 13 | (** Generators of ['a] values. *) 14 | 15 | val return : 'a -> 'a gen 16 | (** Create a generator that always generates the given value. *) 17 | 18 | val join : 'a gen gen -> 'a gen 19 | 20 | val map : ('a -> 'b) -> 'a gen -> 'b gen 21 | (** Map a function over a generator. *) 22 | 23 | val map2 : ('a -> 'b -> 'c) -> 'a gen -> 'b gen -> 'c gen 24 | 25 | val ( <$> ) : ('a -> 'b) -> 'a gen -> 'b gen 26 | (** Infix for [map]. *) 27 | 28 | val ( <*> ) : ('a -> 'b) gen -> 'a gen -> 'b gen 29 | (** Sequential applicaton. 30 | 31 | Can be used together with [<$>] to allow programming in an applicative 32 | style while remaining in the world of generators. E.g: 33 | 34 | If [f] has type ['a -> 'b -> 'c -> 'd] then [f <$> g1 <*> g2 <*> g3] 35 | generates three values using the generators [g1], [g2] and [g3], and then 36 | applies [f] to them, yielding a new generator of type ['d gen]. 37 | *) 38 | 39 | val ( >>= ) : 'a gen -> ('a -> 'b gen) -> 'b gen 40 | (** Sequentially compose two generators, passing the value produced by the 41 | first as an argument to the second. *) 42 | 43 | val sized : (int -> 'a gen) -> 'a gen 44 | 45 | val try_with : 'a gen -> (exn -> 'a gen) -> 'a gen 46 | 47 | val list_sequence : 'a gen list -> 'a list gen 48 | (** Use the given generators in sequence to produce a list of values. *) 49 | 50 | val choose_int : int * int -> int gen 51 | (** Generate a random integer in the given inclusive range. *) 52 | 53 | val choose_float : int -> int * int -> float gen 54 | (** Generate a random float with given number of digits and exponent in the 55 | given inclusive range. *) 56 | 57 | val choose_char : int * int -> char gen 58 | (** Generate a random char in the given inclusive range. *) 59 | 60 | val oneof : 'a gen list -> 'a gen 61 | (** Randomly use one of the given generators. The input list must be non-empty. *) 62 | 63 | val oneof_freq : (int * 'a gen) list -> 'a gen 64 | (** Choose one of the given generators, with a weighted random distribution. 65 | The input list must be non-empty. *) 66 | 67 | val oneof_freq_lazy : (int * 'a gen Lazy.t) list -> 'a gen 68 | (** Like [oneof_freq] but takes lazy generators, which can be used to avoid 69 | infinite loops when writing recursive generators. *) 70 | 71 | val oneof_lazy : 'a gen Lazy.t list -> 'a gen 72 | 73 | val elements_sized : 'a list -> int -> 'a gen 74 | 75 | val elements : 'a list -> 'a gen 76 | (** Generate one of the given values. The input list must be non-empty. *) 77 | 78 | val elements_freq : (int * 'a) list -> 'a gen 79 | 80 | val elements_freq_lazy : (int * 'a Lazy.t) list -> 'a gen 81 | 82 | val until : ('a -> bool) -> 'a gen -> 'a gen 83 | (** Generate values until the given condition is satisfied. *) 84 | 85 | (** {3 Generators of basic types} *) 86 | 87 | val unit : unit gen 88 | (** Generate [unit]. *) 89 | 90 | val bool : bool gen 91 | (** Generate a random [bool]. *) 92 | 93 | val int : int gen 94 | (** Generate a random [int]. *) 95 | 96 | val float : float gen 97 | (** Generate a random [float]. *) 98 | 99 | val char : char gen 100 | (** Generate a random [char]. *) 101 | 102 | val lowercase_letter : char gen 103 | (** Generate a lowercase letter [char]. *) 104 | 105 | val uppercase_letter : char gen 106 | (** Generate an uppercase letter [char]. *) 107 | 108 | val digit : char gen 109 | (** Generate a digit [char]. *) 110 | 111 | val string : string gen 112 | (** Generate a random [string]. *) 113 | 114 | val string_of_size : int -> char gen -> string gen 115 | (** Generate a random [string] of at most a given size using given [char] generator. *) 116 | 117 | val option : 'a gen -> 'a option gen 118 | (** Generate a random [option]. *) 119 | 120 | val tuple : 'a gen -> 'b gen -> ('a * 'b) gen 121 | (** Generate a tuple using the two given generators. *) 122 | 123 | val tuple3 : 'a gen -> 'b gen -> 'c gen -> ('a * 'b * 'c) gen 124 | (** Generate a triple using the three given generators. *) 125 | 126 | val list : 'a gen -> 'a list gen 127 | (** Generate a list where each element is generated using the given generator. *) 128 | 129 | val list_copy : int -> 'a gen -> 'a list gen 130 | (** Generate a list of a given size, where each element is generated 131 | using the given generator. *) 132 | 133 | val list_of_size : int -> 'a gen -> 'a list gen 134 | (** Generate a list of at most a given size, where each element is 135 | generated using the given generator. *) 136 | 137 | val array : 'a gen -> 'a array gen 138 | (** Generate an array where each element is generated using the given generator. *) 139 | 140 | val array_copy : int -> 'a gen -> 'a array gen 141 | (** Generate an array of a given size, where each element is generated 142 | using the given generator. *) 143 | 144 | val array_of_size : int -> 'a gen -> 'a array gen 145 | (** Generate an array of at most a given size, where each element is 146 | generated using the given generator. *) 147 | 148 | (** {3 Mlfi-specific generators} *) 149 | 150 | val lident : string gen 151 | (** Generate a lowercase identifier, usable as a record field name (not an MLFi keyword) *) 152 | 153 | val uident : string gen 154 | (** Generate an uppercase identifier, usable as a constructor name *) 155 | 156 | module UGen : sig 157 | type t 158 | 159 | val create : t:'a Ttype.t -> (int -> 'a gen) -> t 160 | end 161 | 162 | val of_type_gen : ?size:int -> UGen.t list -> t:'a Ttype.t -> 'a gen 163 | (** Generate a random value of type ['a]. 164 | 165 | Useful for automatically creating generators for simple types, but may loop 166 | on recursive types or be too random for your use case. 167 | 168 | Can be customized with a list of custom generators. And an interger 169 | determining the size of the drawn base values. 170 | *) 171 | 172 | val stype : Stype.t gen 173 | (** Generate a random [stype]. *) 174 | 175 | val dynamic : ?size:int -> UGen.t list -> Ttype.dynamic gen 176 | (** Generate a random [Dyn ('a ttype, 'a)]. Arguments correspond to 177 | * the ones of [of_type_gen]. *) 178 | 179 | (** {3 Combinators to make writing properties easier} *) 180 | 181 | val ( => ) : bool -> bool -> bool 182 | 183 | val ( ==> ) : bool -> (unit -> bool) -> bool 184 | 185 | (* Like [(=>)] but with a lazy second argument. *) 186 | 187 | (** {3 Shrinking} *) 188 | 189 | type 'a shrink = 'a -> 'a list 190 | 191 | module Shrink : sig 192 | (* Basic types. *) 193 | 194 | val bool : bool shrink 195 | 196 | val char : char shrink 197 | 198 | val int : int shrink 199 | 200 | val float : float shrink 201 | 202 | val string : string shrink 203 | 204 | val option : 'a shrink -> 'a option shrink 205 | 206 | val tuple : 'a shrink -> 'b shrink -> ('a * 'b) shrink 207 | 208 | val tuple3 : 'a shrink -> 'b shrink -> 'c shrink -> ('a * 'b * 'c) shrink 209 | 210 | val tuple4 211 | : 'a shrink -> 212 | 'b shrink -> 213 | 'c shrink -> 214 | 'd shrink -> 215 | ('a * 'b * 'c * 'd) shrink 216 | 217 | val tuple5 218 | : 'a shrink -> 219 | 'b shrink -> 220 | 'c shrink -> 221 | 'd shrink -> 222 | 'e shrink -> 223 | ('a * 'b * 'c * 'd * 'e) shrink 224 | 225 | val tuple6 226 | : 'a shrink -> 227 | 'b shrink -> 228 | 'c shrink -> 229 | 'd shrink -> 230 | 'e shrink -> 231 | 'f shrink -> 232 | ('a * 'b * 'c * 'd * 'e * 'f) shrink 233 | 234 | val tuple7 235 | : 'a shrink -> 236 | 'b shrink -> 237 | 'c shrink -> 238 | 'd shrink -> 239 | 'e shrink -> 240 | 'f shrink -> 241 | 'g shrink -> 242 | ('a * 'b * 'c * 'd * 'e * 'f * 'g) shrink 243 | 244 | val list : 'a shrink -> 'a list shrink 245 | 246 | val list2 : 'a shrink -> 'a list shrink 247 | 248 | val array : 'a shrink -> 'a array shrink 249 | 250 | (* val of_type: t:'a ttype -> 'a shrink *) 251 | end 252 | 253 | (** {3 Running the generators} *) 254 | 255 | type 'a test_result = 256 | | Succeed of { name: string option; test_run: int } 257 | | Fail of { 258 | name: string option; 259 | test_run: int; 260 | seed: int; 261 | test_case: 'a; 262 | shrink_count: int option; 263 | } 264 | | Throw of { 265 | name: string option; 266 | test_run: int; 267 | seed: int; 268 | test_case: 'a; 269 | shrink_count: int option; 270 | backtrace: string; 271 | } 272 | 273 | val test 274 | : int -> 275 | seed:int -> 276 | ?name:string -> 277 | generator:'a gen -> 278 | ?depthmax:int -> 279 | ?shrink:'a shrink -> 280 | ('a -> bool) -> 281 | 'a test_result 282 | (** [test n ~generator prop] checks the property [prop] [n] times by feeding 283 | it input from [generator]. If [seed] is specified, it is used to initialize the 284 | random number generator, otherwise it is left uninitialized and the behaviour 285 | is undeterministic. If [shrink] is specified, it should produce a (possibly 286 | empty) list of immediate "shrinks" of the given value. It is used to 287 | successively shrink values that falsifies the property until a "minimal" value 288 | that falsfies the property is found. We don't yet provide exact definitions of 289 | "shrinks" and "minimal". The function returns structured data to be used in external test runners. 290 | *) 291 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name lrt) 3 | (synopsis "LexiFi runtime types") 4 | (inline_tests) 5 | (libraries stdlib-shims landmarks) 6 | (preprocess 7 | (pps ppx_expect lrt.deriving landmarks.ppx))) 8 | 9 | (rule 10 | (targets variant_lexer.ml) 11 | (deps variant_lexer.mll) 12 | (action 13 | (chdir 14 | %{workspace_root} 15 | (run %{bin:ocamllex} -ml -q -o %{targets} %{deps})))) 16 | -------------------------------------------------------------------------------- /lib/ext.ml: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | module Int = struct 9 | module Map = Map.Make (struct 10 | type t = int 11 | 12 | let compare = compare 13 | end) 14 | end 15 | 16 | module List_ = struct 17 | let pp_list sep pp ppf = function 18 | | [] -> () 19 | | [ e ] -> pp ppf e 20 | | e :: es -> 21 | pp ppf e; 22 | (* Must be efficient, code specialization. *) 23 | ( match sep with 24 | | "" -> 25 | List.iter 26 | (fun e -> 27 | Format.pp_print_space ppf (); 28 | pp ppf e) 29 | es 30 | | "," -> 31 | List.iter 32 | (fun e -> 33 | Format.pp_print_char ppf ','; 34 | Format.pp_print_space ppf (); 35 | pp ppf e) 36 | es 37 | | ";" -> 38 | List.iter 39 | (fun e -> 40 | Format.pp_print_char ppf ';'; 41 | Format.pp_print_space ppf (); 42 | pp ppf e) 43 | es 44 | | _ -> 45 | List.iter 46 | (fun e -> 47 | Format.pp_print_string ppf sep; 48 | Format.pp_print_space ppf (); 49 | pp ppf e) 50 | es 51 | ) 52 | 53 | let to_string sep f = function 54 | | [] -> "" 55 | | hd :: tl -> 56 | let seplen = String.length sep in 57 | let rec aux len = function 58 | | [] -> Bytes.create len 59 | | hd :: tl -> 60 | let s = f hd in 61 | let slen = String.length s in 62 | let buf = aux (len + seplen + slen) tl in 63 | Bytes.blit_string sep 0 buf len seplen; 64 | Bytes.blit_string s 0 buf (len + seplen) slen; 65 | buf 66 | in 67 | let s = f hd in 68 | let slen = String.length s in 69 | let buf = aux slen tl in 70 | Bytes.blit_string s 0 buf 0 slen; 71 | Bytes.to_string buf 72 | 73 | let rec fst_n acc n = function 74 | | [] -> (List.rev acc, []) 75 | | l when n = 0 -> (List.rev acc, l) 76 | | x :: l -> fst_n (x :: acc) (n - 1) l 77 | 78 | let fst_n n l = fst_n [] n l 79 | 80 | let copy n x = 81 | let rec aux accu n = if n = 0 then accu else aux (x :: accu) (n - 1) in 82 | aux [] n 83 | 84 | let rev_choose f l = 85 | let rec aux accu = function 86 | | [] -> accu 87 | | x :: xs -> 88 | (match f x with None -> aux accu xs | Some y -> aux (y :: accu) xs) 89 | in 90 | aux [] l 91 | 92 | let choose f l = List.rev (rev_choose f l) 93 | 94 | let range n m = 95 | let rec range acc m = 96 | if n >= m then acc 97 | else 98 | let m = pred m in 99 | range (m :: acc) m 100 | in 101 | range [] m 102 | 103 | let findi prop lst = 104 | let i = ref 0 in 105 | let rec f = function 106 | | [] -> raise Not_found 107 | | hd :: tl -> 108 | if prop hd then !i 109 | else ( 110 | incr i; 111 | f tl 112 | ) 113 | in 114 | f lst 115 | 116 | let rev_flatten_map f l = 117 | List.fold_left (fun acc e -> List.rev_append (f e) acc) [] l 118 | 119 | let rev_flatten l = rev_flatten_map (fun x -> x) l 120 | 121 | let flatten_map f l = List.rev (rev_flatten_map f l) 122 | end 123 | 124 | module Array_ = struct 125 | let pp_array sep pp ppf es = 126 | let open Format in 127 | let n = Array.length es in 128 | if n > 0 then ( 129 | let e = Array.unsafe_get es 0 in 130 | pp ppf e; 131 | for i = 1 to n - 1 do 132 | let e = Array.unsafe_get es i in 133 | pp_print_char ppf sep; 134 | pp_print_space ppf (); 135 | pp ppf e 136 | done 137 | ) 138 | 139 | let map_to_list f t = Array.fold_right (fun el acc -> f el :: acc) t [] 140 | 141 | let of_list_rev = function 142 | | [] -> [||] 143 | | hd :: _ as l -> 144 | let i = ref (List.length l) in 145 | let t = Array.make !i hd in 146 | List.iter 147 | (fun e -> 148 | decr i; 149 | t.(!i) <- e) 150 | l; 151 | t 152 | 153 | let of_list_map f = function 154 | | [] -> [||] 155 | | x :: xs -> 156 | let n = List.length xs in 157 | let a = Array.make (n + 1) (f x) in 158 | let rec aux i = function 159 | | [] -> a 160 | | x :: xs -> 161 | Array.unsafe_set a i (f x); 162 | aux (i + 1) xs 163 | in 164 | aux 1 xs 165 | 166 | let of_list_mapi f = function 167 | | [] -> [||] 168 | | x :: xs -> 169 | let n = List.length xs in 170 | let a = Array.make (n + 1) (f 0 x) in 171 | let rec aux i = function 172 | | [] -> a 173 | | x :: xs -> 174 | Array.unsafe_set a i (f i x); 175 | aux (i + 1) xs 176 | in 177 | aux 1 xs 178 | end 179 | 180 | module Float = struct 181 | (* TODO: speed up float printing. *) 182 | 183 | (* from ocaml/stdlib/stdlib.ml *) 184 | let valid_float_lexem s = 185 | let l = String.length s in 186 | let rec loop i = 187 | if i >= l then s ^ "." 188 | else match s.[i] with '0' .. '9' | '-' -> loop (i + 1) | _ -> s 189 | in 190 | loop 0 191 | 192 | (* from ocaml/typing/oprint.ml *) 193 | let repres f = 194 | match classify_float f with 195 | | FP_nan -> "nan" 196 | | FP_infinite -> if f < 0.0 then "neg_infinity" else "infinity" 197 | | _ -> 198 | let float_val = 199 | let s1 = Printf.sprintf "%.12g" f in 200 | if f = float_of_string s1 then s1 201 | else 202 | let s2 = Printf.sprintf "%.15g" f in 203 | if f = float_of_string s2 then s2 else Printf.sprintf "%.18g" f 204 | in 205 | valid_float_lexem float_val 206 | 207 | let pp_repres ppf f = Format.pp_print_string ppf (repres f) 208 | end 209 | 210 | module String = struct 211 | let cut_start i s = 212 | let l = String.length s in 213 | if l <= i then "" else String.sub s i (l - i) 214 | 215 | let cut_end i s = 216 | let l = String.length s in 217 | if l <= i then "" else String.sub s 0 (l - i) 218 | 219 | let rec sub_equal_aux_case_sensitive pat i s j n = 220 | n = 0 221 | || String.unsafe_get pat i = String.unsafe_get s j 222 | && sub_equal_aux_case_sensitive pat (i + 1) s (j + 1) (n - 1) 223 | 224 | let rec sub_equal_aux_case_insensitive pat i s j n = 225 | n = 0 226 | || Char.uppercase_ascii (String.unsafe_get pat i) 227 | = Char.uppercase_ascii (String.unsafe_get s j) 228 | && sub_equal_aux_case_insensitive pat (i + 1) s (j + 1) (n - 1) 229 | 230 | let sub_equal_aux ?(case_insensitive = false) pat i s j n = 231 | if case_insensitive then sub_equal_aux_case_insensitive pat i s j n 232 | else sub_equal_aux_case_sensitive pat i s j n 233 | 234 | let sub_equal ?case_insensitive ~pattern s i = 235 | 0 <= i 236 | && i + String.length pattern <= String.length s 237 | && sub_equal_aux ?case_insensitive pattern 0 s i (String.length pattern) 238 | 239 | let string_start ?case_insensitive ~pattern s = 240 | sub_equal ?case_insensitive ~pattern s 0 241 | 242 | let string_end ?case_insensitive ~pattern s = 243 | sub_equal ?case_insensitive ~pattern s 244 | (String.length s - String.length pattern) 245 | 246 | let buffer_add_unicode_escape = 247 | let conv = "0123456789abcdef" in 248 | fun b c -> 249 | Buffer.add_char b '\\'; 250 | Buffer.add_char b 'u'; 251 | Buffer.add_char b conv.[(c lsr 12) land 0xf]; 252 | Buffer.add_char b conv.[(c lsr 8) land 0xf]; 253 | Buffer.add_char b conv.[(c lsr 4) land 0xf]; 254 | Buffer.add_char b conv.[c land 0xf] 255 | 256 | (* Code taken from js_of_ocaml. *) 257 | let js_string_escaping ?(utf8 = false) s = 258 | let l = String.length s in 259 | let b = Buffer.create (4 * l) in 260 | let i = ref 0 in 261 | while !i < l do 262 | let c = s.[!i] in 263 | ( match c with 264 | (* '\000' when i = l - 1 || s.[i + 1] < '0' || s.[i + 1] > '9' -> 265 | Buffer.add_string b "\\0" *) 266 | | '\b' -> Buffer.add_string b "\\b" 267 | | '\t' -> Buffer.add_string b "\\t" 268 | | '\n' -> Buffer.add_string b "\\n" 269 | (* This escape sequence is not supported by IE < 9 270 | | '\011' -> 271 | Buffer.add_string b "\\v" 272 | *) 273 | | '\012' -> Buffer.add_string b "\\f" 274 | | '\r' -> Buffer.add_string b "\\r" 275 | | '\"' -> Buffer.add_string b "\\\"" 276 | | '\\' -> Buffer.add_string b "\\\\" 277 | | '\000' .. '\031' | '\'' | '\127' .. '\255' -> 278 | let c = 279 | if utf8 then ( 280 | let cp = Utf8.next s i in 281 | decr i; 282 | Uchar.to_int cp 283 | ) 284 | else Char.code c 285 | in 286 | if c <= 0xFFFF then buffer_add_unicode_escape b c 287 | else 288 | let c = c - 0x1_0000 in 289 | let high_surrogate = ((c lsr 10) land 0b11_1111_1111) + 0xD800 in 290 | let low_surrogate = (c land 0b11_1111_1111) + 0xDC00 in 291 | buffer_add_unicode_escape b high_surrogate; 292 | buffer_add_unicode_escape b low_surrogate 293 | | _ -> Buffer.add_char b c 294 | ); 295 | incr i 296 | done; 297 | Buffer.contents b 298 | 299 | let hex_digit = function 300 | | '0' .. '9' as c -> Char.code c - Char.code '0' 301 | | 'a' .. 'f' as c -> 10 + (Char.code c - Char.code 'a') 302 | | 'A' .. 'F' as c -> 10 + (Char.code c - Char.code 'A') 303 | | _ -> raise (Invalid_argument "of_hex") 304 | 305 | let char_to_hex_const = 306 | [| 307 | "00"; 308 | "01"; 309 | "02"; 310 | "03"; 311 | "04"; 312 | "05"; 313 | "06"; 314 | "07"; 315 | "08"; 316 | "09"; 317 | "0a"; 318 | "0b"; 319 | "0c"; 320 | "0d"; 321 | "0e"; 322 | "0f"; 323 | "10"; 324 | "11"; 325 | "12"; 326 | "13"; 327 | "14"; 328 | "15"; 329 | "16"; 330 | "17"; 331 | "18"; 332 | "19"; 333 | "1a"; 334 | "1b"; 335 | "1c"; 336 | "1d"; 337 | "1e"; 338 | "1f"; 339 | "20"; 340 | "21"; 341 | "22"; 342 | "23"; 343 | "24"; 344 | "25"; 345 | "26"; 346 | "27"; 347 | "28"; 348 | "29"; 349 | "2a"; 350 | "2b"; 351 | "2c"; 352 | "2d"; 353 | "2e"; 354 | "2f"; 355 | "30"; 356 | "31"; 357 | "32"; 358 | "33"; 359 | "34"; 360 | "35"; 361 | "36"; 362 | "37"; 363 | "38"; 364 | "39"; 365 | "3a"; 366 | "3b"; 367 | "3c"; 368 | "3d"; 369 | "3e"; 370 | "3f"; 371 | "40"; 372 | "41"; 373 | "42"; 374 | "43"; 375 | "44"; 376 | "45"; 377 | "46"; 378 | "47"; 379 | "48"; 380 | "49"; 381 | "4a"; 382 | "4b"; 383 | "4c"; 384 | "4d"; 385 | "4e"; 386 | "4f"; 387 | "50"; 388 | "51"; 389 | "52"; 390 | "53"; 391 | "54"; 392 | "55"; 393 | "56"; 394 | "57"; 395 | "58"; 396 | "59"; 397 | "5a"; 398 | "5b"; 399 | "5c"; 400 | "5d"; 401 | "5e"; 402 | "5f"; 403 | "60"; 404 | "61"; 405 | "62"; 406 | "63"; 407 | "64"; 408 | "65"; 409 | "66"; 410 | "67"; 411 | "68"; 412 | "69"; 413 | "6a"; 414 | "6b"; 415 | "6c"; 416 | "6d"; 417 | "6e"; 418 | "6f"; 419 | "70"; 420 | "71"; 421 | "72"; 422 | "73"; 423 | "74"; 424 | "75"; 425 | "76"; 426 | "77"; 427 | "78"; 428 | "79"; 429 | "7a"; 430 | "7b"; 431 | "7c"; 432 | "7d"; 433 | "7e"; 434 | "7f"; 435 | "80"; 436 | "81"; 437 | "82"; 438 | "83"; 439 | "84"; 440 | "85"; 441 | "86"; 442 | "87"; 443 | "88"; 444 | "89"; 445 | "8a"; 446 | "8b"; 447 | "8c"; 448 | "8d"; 449 | "8e"; 450 | "8f"; 451 | "90"; 452 | "91"; 453 | "92"; 454 | "93"; 455 | "94"; 456 | "95"; 457 | "96"; 458 | "97"; 459 | "98"; 460 | "99"; 461 | "9a"; 462 | "9b"; 463 | "9c"; 464 | "9d"; 465 | "9e"; 466 | "9f"; 467 | "a0"; 468 | "a1"; 469 | "a2"; 470 | "a3"; 471 | "a4"; 472 | "a5"; 473 | "a6"; 474 | "a7"; 475 | "a8"; 476 | "a9"; 477 | "aa"; 478 | "ab"; 479 | "ac"; 480 | "ad"; 481 | "ae"; 482 | "af"; 483 | "b0"; 484 | "b1"; 485 | "b2"; 486 | "b3"; 487 | "b4"; 488 | "b5"; 489 | "b6"; 490 | "b7"; 491 | "b8"; 492 | "b9"; 493 | "ba"; 494 | "bb"; 495 | "bc"; 496 | "bd"; 497 | "be"; 498 | "bf"; 499 | "c0"; 500 | "c1"; 501 | "c2"; 502 | "c3"; 503 | "c4"; 504 | "c5"; 505 | "c6"; 506 | "c7"; 507 | "c8"; 508 | "c9"; 509 | "ca"; 510 | "cb"; 511 | "cc"; 512 | "cd"; 513 | "ce"; 514 | "cf"; 515 | "d0"; 516 | "d1"; 517 | "d2"; 518 | "d3"; 519 | "d4"; 520 | "d5"; 521 | "d6"; 522 | "d7"; 523 | "d8"; 524 | "d9"; 525 | "da"; 526 | "db"; 527 | "dc"; 528 | "dd"; 529 | "de"; 530 | "df"; 531 | "e0"; 532 | "e1"; 533 | "e2"; 534 | "e3"; 535 | "e4"; 536 | "e5"; 537 | "e6"; 538 | "e7"; 539 | "e8"; 540 | "e9"; 541 | "ea"; 542 | "eb"; 543 | "ec"; 544 | "ed"; 545 | "ee"; 546 | "ef"; 547 | "f0"; 548 | "f1"; 549 | "f2"; 550 | "f3"; 551 | "f4"; 552 | "f5"; 553 | "f6"; 554 | "f7"; 555 | "f8"; 556 | "f9"; 557 | "fa"; 558 | "fb"; 559 | "fc"; 560 | "fd"; 561 | "fe"; 562 | "ff"; 563 | |] 564 | 565 | let char_to_hex c = Array.unsafe_get char_to_hex_const (Char.code c) 566 | 567 | let to_hex s = 568 | let len = String.length s in 569 | let res = Bytes.create (len * 2) in 570 | for i = 0 to len - 1 do 571 | Bytes.blit_string (char_to_hex s.[i]) 0 res (2 * i) 2 572 | done; 573 | Bytes.unsafe_to_string res 574 | 575 | let hex_in_string s i = 576 | Char.chr ((hex_digit s.[i] lsl 4) + hex_digit s.[i + 1]) 577 | 578 | let of_hex s = 579 | let len = String.length s in 580 | if len mod 2 = 1 then raise (Invalid_argument "of_hex"); 581 | let len = len / 2 in 582 | let res = Bytes.create len in 583 | for i = 0 to len - 1 do 584 | Bytes.set res i (hex_in_string s (2 * i)) 585 | done; 586 | Bytes.unsafe_to_string res 587 | 588 | let url_encode ?(is_uri_component = false) s = 589 | let n = String.length s in 590 | let b = Buffer.create (n * 2) in 591 | for i = 0 to n - 1 do 592 | match s.[i] with 593 | | ( 'A' .. 'Z' 594 | | 'a' .. 'z' 595 | | '0' .. '9' 596 | | '-' | '_' | '.' | '~' (* url_special_chars *) | '!' | '*' | '\'' | '(' 597 | | ')' ) as c 598 | (* url_reserved_chars allowed in uri components*) -> 599 | Buffer.add_char b c 600 | | ( '$' | '&' | '+' | ',' | '/' | ':' | ';' | '=' | '?' | '@' | '#' | '[' 601 | | ']' ) as c 602 | (* url_reserved_chars encoded in uri_components*) 603 | when not is_uri_component -> 604 | Buffer.add_char b c 605 | | c -> Buffer.add_string b (String.uppercase_ascii ("%" ^ char_to_hex c)) 606 | done; 607 | Buffer.contents b 608 | 609 | let url_decode ?(is_query_string_value = false) s = 610 | let n = String.length s in 611 | let rec simple_string i = 612 | if i < n then 613 | match s.[i] with 614 | | '%' | '+' -> 615 | let buf = Buffer.create n in 616 | Buffer.add_substring buf s 0 i; 617 | decode_string buf i 618 | | _ -> simple_string (i + 1) 619 | else s 620 | and decode_string buf i = 621 | if i < n then ( 622 | match s.[i] with 623 | | '+' when is_query_string_value -> 624 | Buffer.add_char buf ' '; 625 | decode_string buf (i + 1) 626 | | '%' when i + 2 < n -> 627 | ( match hex_in_string s (i + 1) with 628 | | s -> 629 | Buffer.add_char buf s; 630 | decode_string buf (i + 3) 631 | | exception Invalid_argument _ -> 632 | Buffer.add_char buf s.[i]; 633 | decode_string buf (i + 1) 634 | ) 635 | | c -> 636 | Buffer.add_char buf c; 637 | decode_string buf (i + 1) 638 | ) 639 | else Buffer.contents buf 640 | in 641 | simple_string 0 642 | 643 | module Tbl = struct 644 | (* TODO: heuristic to delay building the dispatch table until N lookups occured 645 | (use simple list search before)? *) 646 | 647 | (* A slightly faster, but much less readable, implementation is in public/tests/strtbl.mf. *) 648 | 649 | type tree = 650 | | Node of { pos: int; first: int; sub: tree array } 651 | | Leaf of int * string 652 | | Fail 653 | 654 | (* Decision tree (pos is the index to look up). *) 655 | 656 | type t = tree array 657 | 658 | (* dispatch on the string's length *) 659 | 660 | (* Dispatching *) 661 | 662 | let rec eval_tree s = function 663 | | Fail -> -1 664 | | Leaf (i, s2) -> if s = s2 then i else -1 665 | | Node { pos; first; sub } -> 666 | let c = Char.code (String.unsafe_get s pos) in 667 | if c < first then -1 668 | else 669 | let i = c - first in 670 | if i >= Array.length sub then -1 671 | else eval_tree s (Array.unsafe_get sub i) 672 | 673 | let lookup trees s = 674 | let len = String.length s in 675 | if len >= Array.length trees then -1 676 | else eval_tree s (Array.unsafe_get trees len) 677 | 678 | (* Preparation *) 679 | 680 | let split_at strings i = 681 | let buckets = Array.make 256 [] in 682 | let min_char = ref 256 in 683 | let max_char = ref (-1) in 684 | let rec loop = function 685 | | ((_, s) as x) :: tl -> 686 | let c = Char.code s.[i] in 687 | if c > !max_char then max_char := c; 688 | if c < !min_char then min_char := c; 689 | buckets.(c) <- x :: buckets.(c); 690 | loop tl 691 | | [] -> () 692 | in 693 | loop strings; 694 | (!min_char, !max_char, buckets) 695 | 696 | let score (min_char, max_char, buckets) = 697 | let max_len = ref 0 in 698 | for i = min_char to max_char do 699 | let l = List.length buckets.(i) in 700 | if l > !max_len then max_len := l 701 | done; 702 | !max_len 703 | 704 | let rec split idxs = function 705 | | [ (i, s) ] -> Leaf (i, s) 706 | | [] -> Fail 707 | | strings -> 708 | let best_score = ref max_int in 709 | let best_idx = ref (-1) in 710 | let best_split = ref (0, 0, [||]) in 711 | let rec loop = function 712 | | i :: rest -> 713 | let res = split_at strings i in 714 | let score = score res in 715 | if score < !best_score then ( 716 | best_score := score; 717 | best_idx := i; 718 | best_split := res 719 | ); 720 | loop rest 721 | | [] -> () 722 | in 723 | loop idxs; 724 | let pos = !best_idx in 725 | let first, last, buckets = !best_split in 726 | let idxs = List.filter (( != ) pos) idxs in 727 | (* optim *) 728 | Node 729 | { 730 | pos; 731 | first; 732 | sub = 733 | Array.init 734 | (last - first + 1) 735 | (fun i -> split idxs buckets.(i + first)); 736 | } 737 | 738 | let prepare strings : t = 739 | let rec max_len acc = function 740 | | [] -> acc 741 | | hd :: tl -> max_len (max acc (String.length hd)) tl 742 | in 743 | let max_len = max_len 0 strings in 744 | let buckets = Array.make (max_len + 1) [] in 745 | let rec dispatch i = function 746 | | [] -> () 747 | | hd :: tl -> 748 | let len = String.length hd in 749 | buckets.(len) <- (i, hd) :: buckets.(len); 750 | dispatch (i + 1) tl 751 | in 752 | dispatch 0 strings; 753 | Array.mapi 754 | (fun len strings -> 755 | let idxs = List_.range 0 len in 756 | split idxs strings) 757 | buckets 758 | end 759 | end 760 | 761 | module Option_ = struct 762 | let bind f = function None -> None | Some x -> f x 763 | 764 | let map f = function None -> None | Some x -> Some (f x) 765 | 766 | let value_exn = function 767 | | None -> raise (Invalid_argument "Expected Some, got None") 768 | | Some x -> x 769 | end 770 | 771 | module List = List_ 772 | module Array = Array_ 773 | module Option = Option_ 774 | -------------------------------------------------------------------------------- /lib/json.mli: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | (** Json compatible representation of values. *) 9 | 10 | (** {3 Representation of JSON trees} *) 11 | 12 | type number = I of int | F of float 13 | 14 | type value = 15 | | Null 16 | | Bool of bool 17 | | Number of number 18 | | String of string 19 | | Array of value list 20 | | Object of (string * value) list 21 | [@@deriving t] 22 | 23 | (** Notes: 24 | - The [String] payload is either Latin1-encoded or utf8-encoded, depending 25 | on the [utf8] flag passed to [encode/decode]. When not in utf8 mode, a 26 | code point outside the range of that character set will be encoded in a 27 | special (undocumented) way. 28 | *) 29 | 30 | (** {3 Conversion between JSON trees and OCaml values} *) 31 | 32 | type 'a conv = { to_json: 'a -> value; of_json: value -> 'a } 33 | 34 | (** 35 | An ['a conv] contains mapping from OCaml values of type ['a] to JSON and vice 36 | versa. Such a conv pair can be derived from a type at runtime using 37 | {!val:conv}. 38 | 39 | The default mapping is defined below. If [to_json x] succeeds, the property 40 | [of_json (to_json x) = x] is expected to hold (assuming that custom 41 | converters behave properly). 42 | 43 | Basic types: 44 | {[ 45 | - 1 ---> 1 46 | - 1. ---> 1. 47 | - () ---> {} 48 | - true/false ---> true/false 49 | - "abc" ---> "abc" 50 | - 2001-01-01 ---> "2001-01-01" 51 | ]} 52 | 53 | List/array/tuple types: 54 | {[ 55 | - [x; y] ---> [x', y'] 56 | - [|x; y|] ---> [x', y'] 57 | - (x, y) ---> [x', y'] 58 | ]} 59 | 60 | Record types: 61 | {[ 62 | - {l1 = x; l2 = y} ---> {"l1": x', "l2": y'} 63 | - {l1 = x; l2 = None} ---> {"l1": x'} 64 | ]} 65 | 66 | Sum types: 67 | {[ 68 | - A ---> {"type": "A"} 69 | - B x ---> {"type": "B", "val": [x'] } 70 | - C (x, y) ---> {"type": "C", "val": [x', y'] } 71 | - D {l1 = x; l2 = y} ---> {"type": "D", "l1": x', "l2": y'} 72 | ]} 73 | 74 | Option types: 75 | {[ 76 | - Some x ---> x' 77 | - None ---> null (when not in record) 78 | ]} 79 | 80 | Nested option types! 81 | {[ 82 | - Some (Some x) ---> {"type": "Some", "val": x'} 83 | - Some None ---> {"type": "Some"} 84 | - None ---> {"type": "None"} 85 | ]} 86 | 87 | Lazy types: 88 | {[ 89 | - lazy x ---> x' 90 | (x is forced upon jsonification; de-jsonification is lazy) 91 | ]} 92 | 93 | String Maps ('a Mlfi_sets_maps.StringMap.t) 94 | are mapped to objects, e.g. 95 | {[ 96 | - {"a" -> 1; "b" -> 2} ---> {"a": 1, "b": 2} 97 | - {"foo" -> "hello"; "bar" -> "world"} ---> {"foo": "hello", "bar": "world"} 98 | ]} 99 | 100 | Special cases: 101 | {[ 102 | - (x : Variant.t) ----> textual representation of x, in OCaml syntax 103 | - (x : Json.value) ----> x 104 | ]} 105 | 106 | Notes: 107 | 108 | - Function types and object types are not supported by default. Custom 109 | handlers can be specified in {!matcher}. 110 | 111 | - Upon parsing, extra fields in objects are accepted and ignored 112 | (including when parsing a sum type or unit). 113 | *) 114 | 115 | (* 116 | - TODO?: special case when all constructors are empty (mapped to strings). 117 | 118 | - TODO: support some type properties (default value, etc). 119 | 120 | *) 121 | 122 | (** {3 Custom mapping for specific types} 123 | 124 | Custom conv pairs can be globally registered using the {!add} function and 125 | its variations. By default, [conv t] uses the globally registered 126 | converters where possible. The default can be overwritten, by providing 127 | a custom matcher locally (via {!ctx}). 128 | 129 | Note: 130 | - It is not allowed to use [null] in the JSON representation of values, at 131 | least if the type is used under the option type constructor ([null] is 132 | reserved for representing the [None] case). 133 | *) 134 | 135 | module Matcher : Matcher.S with type 'a return := 'a conv 136 | 137 | val add : t:'a Ttype.t -> 'a conv -> unit 138 | (** See {!Matcher.add}. Modifies the global registry. *) 139 | 140 | val add0 : (module Matcher.C0) -> unit 141 | (** See {!Matcher.add0}. Modifies the global registry. *) 142 | 143 | val add1 : (module Matcher.C1) -> unit 144 | (** See {!Matcher.add1}. Modifies the global registry. *) 145 | 146 | val add2 : (module Matcher.C2) -> unit 147 | (** See {!Matcher.add2}. Modifies the global registry. *) 148 | 149 | val matcher : unit -> Matcher.t 150 | (** Fetch the current global registry of converters. *) 151 | 152 | type ctx 153 | 154 | val ctx : ?to_json_field:(string -> string) -> ?matcher:Matcher.t -> unit -> ctx 155 | (** The default mapping can be manipulated by providing a context to the 156 | {!val:conv} function. The following variations are currently possible. 157 | 158 | - to_json_field: how to translate a record field name to a JSON field name. 159 | - matcher: instead of the global registry of custom converters, use modified 160 | one. Allows to overwrite global converters locally. 161 | *) 162 | 163 | val conv : ?ctx:ctx -> 'a Ttype.t -> 'a conv 164 | (** Generates a conv pair from the provided type. *) 165 | 166 | (** {3 Mapping between JSON trees and their textual representation.} *) 167 | 168 | val encode : ?utf8:bool -> value -> string 169 | (** Encode JSON tree into a compact JSON text (single line, etc). *) 170 | 171 | val decode : ?utf8:bool -> ?filename:string -> string -> value 172 | (** Parse a JSON text into JSON tree. Report parse errors using 173 | the [Failure] exception. The optional [filename] argument 174 | is used to report locations in error messages. *) 175 | 176 | val to_pretty_string : value -> string 177 | (** Prints a JSON tree into human-friendly text (multi-line, indentation). 178 | The output is NOT a parsable json string. 179 | *) 180 | 181 | (**/**) 182 | 183 | (* TODO: move somewhere else *) 184 | val of_get_params : ?utf8:bool -> (string * string) list -> value 185 | 186 | val to_get_params : ?utf8:bool -> value -> (string * string) list 187 | 188 | (**/**) 189 | 190 | (** {3 Miscellaneous} *) 191 | 192 | (** Access values in JSON trees. *) 193 | module Access : sig 194 | val is_null : value -> bool 195 | 196 | val to_string : value -> string 197 | 198 | val to_int : value -> int 199 | 200 | val to_float : value -> float 201 | 202 | val to_list : value -> value list 203 | 204 | val get_field : string -> value -> value 205 | 206 | val string_field : string -> value -> string 207 | 208 | val int_field : string -> value -> int 209 | 210 | val float_field : string -> value -> float 211 | 212 | val list_field : string -> value -> value list 213 | 214 | val object_field : string -> value -> value 215 | end 216 | -------------------------------------------------------------------------------- /lib/lrt.ml: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | (** LexiFi runtime types. *) 9 | 10 | (* REMEMBER TO KEEP THE FOLLOWING PITCH IN SYNC WITH THE README AND OPAM FILE. *) 11 | 12 | (** {3 Introduction} 13 | 14 | It is often useful to get access to types at runtime in order to implement 15 | generic type-driven operations. A typical example is a generic 16 | pretty-printer. Unfortunately, the OCaml compiler does not keep type 17 | information at runtime. At LexiFi, we have extended OCaml to support runtime 18 | types. This extension has been in use for years and is now a key element in 19 | many of our interesting components, such as our automatic GUI framework 20 | (which derives GUIs from type definitions) or our high-level database layer 21 | (which derives SQL schema from type definitions, and exposes a well-typed 22 | interface for queries). This extension is tightly integrated with the OCaml 23 | typechecker, which allows the compiler to synthesize the runtime type 24 | representations with minimal input from the programmer. 25 | 26 | This package makes the features of our extension available to other OCaml 27 | users without relying on a modified compiler. Instead, it only relies on a 28 | PPX syntax extension that synthesizes the runtime representation of types 29 | from their syntactic definition with a deriving-like approach. 30 | 31 | Based on this new implementation we are able to open-source the 32 | infrastructure we have developed around the machinery of runtime types as 33 | well as libraries built upon them. 34 | *) 35 | 36 | (** {3 Build runtime types} 37 | 38 | Runtime representations of OCaml types are built using the [lrt.deriving] 39 | PPX syntax extension. In the simplest case, you only have to attach a 40 | [ [@@deriving t] ] attribute to the type declaration. 41 | 42 | {[ 43 | # #require "lrt.deriving";; 44 | # open Lrt.Std;; 45 | # type foo = { bar: string } [@@deriving t] ;; 46 | type foo = { bar: string } 47 | val foo_t : foo ttype 48 | # type t = foo * int [@@deriving t] ;; 49 | val t : t ttype 50 | ]} 51 | 52 | Runtime representations of the basic OCaml types can be found in the {!Std} 53 | module. These definitions are generally required, when you use the 54 | [[@@deriving t]] syntax extension. 55 | *) 56 | 57 | module Std = struct 58 | include Std 59 | 60 | (**/**) 61 | 62 | module Lrt_ppx_runtime = Lrt_ppx_runtime 63 | 64 | (**/**) 65 | end 66 | 67 | (** {4 Free variable handling} 68 | 69 | Types with free variables are represented as closures with one 70 | {!ttype} argument per free variable. Most APIs, like {!Print} for dynamic 71 | printing, consume closed types. 72 | 73 | {[ 74 | # type 'a tree = 75 | + | Leave of 'a 76 | + | Node of 'a tree list 77 | + [@@deriving t];; 78 | val tree_t : 'a ttype -> 'a tree ttype 79 | # let () = Print.show ~t:(tree_t int_t) (Node [Leave 0; Leave 1]);; 80 | Node [Leave 0; Leave 1] 81 | ]} 82 | 83 | Stating the types in function application style might be a bit unintuitive. 84 | Thus there is an extension point that translates types to applications. 85 | Instead of the previous example, you can also write the following. 86 | 87 | {[ 88 | # let () = Print.show ~t:[%t: int tree] (Node [Leave 0; Leave 1]);; 89 | Node [Leave 0; Leave 1] 90 | ]} 91 | *) 92 | 93 | (** {4 Abstract types} 94 | 95 | We attempt to support abstract types. Whenever you want to hide the actual 96 | type definition from the derived ttype, you have to annotate the type 97 | declarations with [ [@@abstract] ]. 98 | 99 | {[ 100 | # module M : sig 101 | + type t [@@deriving t] 102 | + end = struct 103 | + type t = int array [@@deriving t] 104 | + end;; 105 | module M : sig type t val t : t ttype end 106 | # Format.printf "%a\n" Ttype.print M.t;; 107 | int array 108 | # module N : sig 109 | + type t [@@deriving t] 110 | + end = struct 111 | + type t = int array [@@abstract] [@@deriving t] 112 | + end;; 113 | module N : sig type t val t : t ttype end 114 | # Format.printf "%a\n" Ttype.print M.t;; 115 | //toplevel//.N.t 116 | ]} 117 | 118 | It is worth to note that abstract types are represented by a string. You can 119 | trick the naming mechanism into producing indistinguishable abstract runtime 120 | types for distinct OCaml types. You can bypass the name generation by 121 | providing a string argument to the abstract annotation. 122 | 123 | {[ 124 | # type abstract = int [@@abstract "uid"] [@@deriving t];; 125 | val abstract_t : abstract ttype 126 | # Format.printf "%a\n" Ttype.print abstract_t;; 127 | uid 128 | ]} 129 | 130 | In case you want to expose an abstract ttype, but use a non-abstract version 131 | within the module, we recommend to define two types - one non-abstract for 132 | internal use and one abstract for satisfying the interface - as outlined 133 | below. 134 | 135 | {[ 136 | # module M : sig 137 | + type hidden [@@deriving t] 138 | + end = struct 139 | + type visible = string list 140 | + and hidden = visible [@@abstract] [@@deriving t];; 141 | + (* [visible] represents a string list here. *) 142 | + end;; 143 | ]} 144 | *) 145 | 146 | (** {4 Patching} 147 | 148 | It happens frequently, that ttypes are not available under the expected 149 | name. For such cases, we provide the [@patch] annotation. 150 | 151 | {[ 152 | # lazy_t;; 153 | - : 'a ttype -> 'a lazy_t ttype = 154 | # type 'a lazy_pair = ('a * 'a) Lazy.t [@patch lazy_t] [@@deriving t];; 155 | type 'a lazy_pair = ('a * 'a) lazy_t 156 | val lazy_pair_t : 'a ttype -> 'a lazy_pair ttype = 157 | ]} 158 | 159 | When using an external type that has no corresponding ttype we recommend to 160 | introduce an abstract alias and use it as replacement. 161 | 162 | {[ 163 | type external = External.t [@@abstract] [@@deriving t] 164 | type local = (External.t [@patch external_t]) list [@@deriving t] 165 | ]} 166 | *) 167 | 168 | (** {4 Properties} 169 | 170 | Our runtime types support attachments of properties. The behaviour of some 171 | APIs can be tweaked by providing certain properties. Properties can be added 172 | to core types, record fields and constructors. Keep in mind the binding 173 | precedence of annotations. 174 | 175 | {[ 176 | type sum = 177 | | A of int [@prop {key1= "binds to constructor A"}] 178 | | B of (int [@prop {key2= "binds to type int"}]) 179 | and record = 180 | { c : int [@prop {key3= "binds to field c"}] 181 | ; d : (int [@prop {key4= "binds"; key5="to int"}]) 182 | } 183 | [@@deriving t] 184 | ]} 185 | *) 186 | 187 | (** {3 Use runtime types} 188 | 189 | We provide some example modules that consume runtime types. The best entry 190 | point for further exploring the features of Lrt is probably the 191 | implementation of {!Json.conv}. 192 | 193 | {!Print} is used as generic dynamic printer. It is able to print arbitrary 194 | values based on their runtime type. Values of abstract types can be printed 195 | by registering abstract printers. 196 | 197 | {!Variant} may be used to serialize values in an OCaml compatible syntax. 198 | Provided a runtime type, the module is able to serialize and deserialize 199 | arbitrary values of non-abstract type. Custom (de)variantizers for abstract 200 | types can be registered globally. 201 | 202 | {!Json} provides serialization like {!Variant} but targets JSON as 203 | intermediate format. Additionally, it uses the latest features provided by 204 | {!Matcher} to allow the registration of custom converters for any type. 205 | 206 | {!Check} is a Quickcheck implementation that derives value generators from 207 | runtime types. Additionally, it is able to generate random runtime types and 208 | thereby values of random type. This is useful for testing functions that are 209 | meant to handle any type. 210 | *) 211 | 212 | module Print = Print 213 | module Variant = Variant 214 | module Json = Json 215 | module Check = Check 216 | 217 | (** {4 Type representation} 218 | 219 | Lrt comes with different representations of runtime types. Depending on the 220 | application, one might use one or another. 221 | 222 | {!Stype.t} or {!stype} in short are an untyped runtime representation of 223 | OCaml types. Stypes are easy to construct, serializable and allow to write 224 | unsafe but powerful code. Most users want to avoid this interface. 225 | 226 | {!Ttype.t} or {!ttype} in short extend the untyped {!stype} with an OCaml 227 | type. Ttypes can be built using the [[@@deriving t]] syntax extension 228 | and can be used to safely consume APIs that make use of runtime types. 229 | 230 | {!Xtype.t} enable safe inspection of runtime types. Xtypes are used to 231 | implement APIs that make use of runtime types. 232 | *) 233 | 234 | module Stype = Stype 235 | module Ttype = Ttype 236 | module Xtype = Xtype 237 | 238 | (** {4 Unification} 239 | 240 | The {!Unify} module holds functors that allow to unify an unclosed runtime 241 | type with a closed one. This was particularly interesting for implementing 242 | the abstract type handling of {!Print} and {!Variant}. It may be that 243 | {!Matcher} is strictly more powerful and {!Unify} can be dropped. 244 | *) 245 | 246 | module Unify = Unify 247 | 248 | (** {4 Pattern matching} 249 | 250 | {!Matcher} provides a mechanism for storing data indexed by type 251 | using as discrimination tree. The runtime type provided as key during 252 | insertion may contain free variables. Data can be retrieved from the store 253 | by providing a closed type. During retrieval, the key type is unified with 254 | the type used for insertion. 255 | 256 | This provides a mechanism similar to OCaml pattern matching but for runtime 257 | types. 258 | *) 259 | 260 | module Matcher = Matcher 261 | 262 | (** {4 Type equality} 263 | 264 | Some of the other modules are able to check for type equality of dynamically 265 | crafted types. Such type equalities are inherently out of reach for the 266 | OCaml type system. They are "transported back" with help of the {!TypEq} 267 | module. 268 | 269 | A value of type [('a, 'b) TypEq.t] can be interpreted as equality proof for 270 | ['a] and ['b]. OCaml's type system accepts this proof when you open the 271 | GADT constructor {!TypEq.Eq}. An unwrap may look like the following. 272 | 273 | {[ 274 | let plus: type a. int -> a -> (a, int) TypEq.t -> int = 275 | fun a b eq -> 276 | let TypEq.Eq = eq in 277 | a + b 278 | ]} 279 | *) 280 | 281 | module TypEq = TypEq 282 | 283 | (** {3 Paths} 284 | 285 | We include an implementation of lenses and list of lenses: {!Path} enables 286 | access to values in nested tuples, records and constructors. Additionally, 287 | paths can be used to access nested types (see {!Xtype.project_path}). 288 | 289 | Paths can be built using the [lrt.path] syntax extension. 290 | 291 | {[ 292 | # #require "lrt.path";; 293 | # type t = A of {b: int array list * string} 294 | + let p1 : (t, string) Path.t = [%path? [ A b; (_, []) ]] 295 | + let p2 : (t, int) Path.t = [%path? [ A b; ([], _); [0]; [|1|] ]] 296 | + let Path.{get; set} = Path.lens p2 297 | + let () = 298 | if get (A {b= ([ [|0; 42|]; [||] ], "clutter")}) = Some 42 299 | then print_endline "success" ;; 300 | success 301 | ]} 302 | 303 | Further instructions can be found within the {!Path} module. 304 | *) 305 | 306 | module Path = Path 307 | 308 | (** {3 open Lrt} 309 | 310 | We recommend to place [open Lrt] at the toplevel of your modules to have 311 | the runtime representation of basic OCaml types and all the lrt tools 312 | available when you need them. If you do not want to have the [Lrt.*] 313 | modules cluttering your namespace use [open Lrt.Std]. 314 | *) 315 | 316 | type stype = Stype.t 317 | 318 | type 'a ttype = 'a Ttype.t 319 | 320 | type dynamic = Ttype.dynamic = Dyn : 'a ttype * 'a -> dynamic 321 | 322 | include Std 323 | -------------------------------------------------------------------------------- /lib/lrt_ppx_runtime.ml: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | (** Runtime components of [\[@@deriving t\]] and [\[%path? .\]]. *) 9 | 10 | (**/**) 11 | 12 | module Types = struct 13 | (** Runtime for building types *) 14 | 15 | module Ttype = Ttype 16 | open Stype.Internal 17 | 18 | type 'a lazy_t = 'a Lazy.t 19 | 20 | type nonrec node = Stype.node 21 | 22 | let ttype_of_stype (type a) (s : Stype.t) : a Ttype.t = Obj.magic s 23 | 24 | let substitute = substitute 25 | 26 | let stype_of_ttype = Ttype.to_stype 27 | 28 | let create_node = create_node 29 | 30 | let set_node_record = set_node_record 31 | 32 | let set_node_variant = set_node_variant 33 | 34 | let rev_map2 = List.rev_map2 35 | 36 | let force = Lazy.force 37 | 38 | let record_representation (l : Stype.t list) : Stype.record_repr = 39 | let p = Stype.equality_modulo_props (stype_of_ttype Std.float_t) in 40 | if List.for_all p l then Record_float else Record_regular 41 | 42 | module Set = Set.Make (String) 43 | 44 | let abstract_names = ref Set.empty 45 | 46 | exception Non_unique_abstract_name of string 47 | 48 | let register_abstract_name s = 49 | if Set.mem s !abstract_names then raise (Non_unique_abstract_name s); 50 | abstract_names := Set.add s !abstract_names 51 | end 52 | 53 | module Path = struct 54 | (** Runtime for building paths *) 55 | 56 | (* Make sure that nobody masks the things we use *) 57 | module Array = Array 58 | module List = List 59 | 60 | type nonrec 'a option = 'a option = None | Some of 'a 61 | 62 | (* Set nth element in a list *) 63 | let set_nth l nth x = 64 | let rec f acc l nth = 65 | match (nth, l) with 66 | | 0, _hd :: tl -> List.rev_append acc (x :: tl) 67 | | _i, [] -> raise (Failure "nth") 68 | | i, hd :: tl -> f (hd :: acc) tl (i - 1) 69 | in 70 | if nth < 0 then raise (Invalid_argument "List.nth") else f [] l nth 71 | 72 | let set_nth_opt l nth x = 73 | match set_nth l nth x with x -> Some x | exception _ -> None 74 | 75 | include Path 76 | include Internal [@@ocaml.warning "-3"] 77 | end 78 | -------------------------------------------------------------------------------- /lib/matcher.ml: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | (** Pattern matching on runtime types. *) 9 | 10 | (** In order to gain some intuition about how this module can be used, consult 11 | the below {!example} or the implementation of {!Json.conv}. *) 12 | 13 | (** A matcher with a given return type. *) 14 | module type S = sig 15 | type t 16 | (** A matcher. Cases can be added using {!add} and it can be applied using 17 | {!apply}. *) 18 | 19 | type 'a return 20 | (** The return type of the matcher. Patterns are registered together with a 21 | value of this type. On a successful match the registered value is 22 | returned. 23 | *) 24 | 25 | val empty : modulo_props:bool -> t 26 | (** The empty matcher without any registered pattern. The parameter 27 | [modulo_props] controls whether properties are ignored or interpreted as 28 | distinguishing features of runtime types. 29 | 30 | {4 Properties} 31 | 32 | The handling of properties during matching requires special attention. 33 | 34 | When [modulo_props:false] (default), properties are distinguishing 35 | features of runtime types. Two types that only differ in their outermost 36 | properties (e.g. one without and one with) will not unify and thus not 37 | match. The same is true if the properties are the same but their order is 38 | different. We attempt to provide associativity in the sense of 39 | {!Ttype.consume_outer_props}. A property is uniquely identified by its 40 | key, values are ignored during matching. 41 | 42 | When [modulo_props:true], properties are ignored for unification. 43 | Nevertheless, properties are preserved within the substituted runtime 44 | types. 45 | 46 | TODO: 47 | - Think about moving the [modulo_props] argument to {!apply}. 48 | - Think about automatic property handling: first check for pattern with 49 | property, if not registered, strip first property and retry. 50 | *) 51 | 52 | (** {3 Pattern candidates} *) 53 | 54 | val add : t:'a Ttype.t -> 'a return -> t -> t 55 | (** [add ~t return m] adds pattern [t] with right hand side [return] to 56 | the matcher [m]. *) 57 | 58 | module type C0 = sig 59 | include Unify.T0 60 | 61 | val return : t return 62 | (** Is returned when {!t} is given to {!apply}. *) 63 | end 64 | 65 | val add0 : (module C0) -> t -> t 66 | (** Add a case to the matcher. Equivalent to {!add}. *) 67 | 68 | module type C1 = sig 69 | include Unify.T1 70 | 71 | val return : 'a Ttype.t -> 'a t return 72 | (** Used to obtain {!M1.return} on a match. *) 73 | end 74 | 75 | val add1 : (module C1) -> t -> t 76 | (** Adds a case to a matcher. One free variable.*) 77 | 78 | module type C2 = sig 79 | include Unify.T2 80 | 81 | val return : 'a Ttype.t -> 'b Ttype.t -> ('a, 'b) t return 82 | (** Used to obtain {!M2.return} on a match. *) 83 | end 84 | 85 | val add2 : (module C2) -> t -> t 86 | (** Adds a case to a matcher. Two free variables. *) 87 | 88 | (** {3 Matching results} *) 89 | 90 | (** A matching result without substituted variables. *) 91 | module type M0 = sig 92 | include Unify.T0 93 | 94 | type matched 95 | (** The type given to {!apply}. *) 96 | 97 | val eq : (t, matched) TypEq.t 98 | (** Proofs the equality of the {!add}ed type and the matched type 99 | to the type checker. *) 100 | 101 | val return : t return 102 | (** The result of the match. Corresponds to 103 | the right hand side of [->] in usual OCaml pattern matching. *) 104 | end 105 | 106 | (** A matching result with one substituted variable. *) 107 | module type M1 = sig 108 | include Unify.T1 109 | 110 | type a 111 | (** First type variable. *) 112 | 113 | type matched 114 | (** The type given to {!apply}. *) 115 | 116 | val eq : (a t, matched) TypEq.t 117 | (** Proofs the equality of the {!add}ed type and the matched type 118 | to the type checker. *) 119 | 120 | val return : a t return 121 | (** The result of the match with substituted type variable. Corresponds to 122 | the right hand side of [->] in usual OCaml pattern matching. *) 123 | end 124 | 125 | (** A matching result with two substituted variables. *) 126 | module type M2 = sig 127 | include Unify.T2 128 | 129 | type a 130 | (** First type variable. *) 131 | 132 | type b 133 | (** Second type variable. *) 134 | 135 | type matched 136 | (** The type given to {!apply}. *) 137 | 138 | val eq : ((a, b) t, matched) TypEq.t 139 | (** Proofs the equality of the {!add}ed type and the matched type 140 | to the type checker. *) 141 | 142 | val return : (a, b) t return 143 | (** The result of the match with substituted type variables. Corresponds to 144 | the right hand side of [->] in usual OCaml pattern matching. *) 145 | end 146 | 147 | type 'a matched = 148 | | M0 of (module M0 with type matched = 'a) 149 | | M1 of (module M1 with type matched = 'a) 150 | | M2 of (module M2 with type matched = 'a) 151 | 152 | (** {3 Application} *) 153 | 154 | val apply : t -> t:'a Ttype.t -> 'a matched option 155 | (** [apply matcher ~t] matches runtime type [t] against previously registered 156 | patterns in [matcher]. *) 157 | 158 | val apply_exn : t -> t:'a Ttype.t -> 'a matched 159 | (** See {!apply}. Raises {!Not_found} if no matching pattern is available. *) 160 | end 161 | 162 | (** Instantiate a matcher with a result type. *) 163 | module Make (Return : sig 164 | type 'a t 165 | end) : S with type 'a return = 'a Return.t = struct 166 | module Index = Matcher_index.Tree 167 | module IntMap = Ext.Int.Map 168 | 169 | (* TODO: How can I avoid this duplication of signatures? *) 170 | type 'a return = 'a Return.t 171 | 172 | module type C0 = sig 173 | include Unify.T0 174 | 175 | val return : t return 176 | end 177 | 178 | module type C1 = sig 179 | include Unify.T1 180 | 181 | val return : 'a Ttype.t -> 'a t return 182 | end 183 | 184 | module type C2 = sig 185 | include Unify.T2 186 | 187 | val return : 'a Ttype.t -> 'b Ttype.t -> ('a, 'b) t return 188 | end 189 | 190 | module type M0 = sig 191 | include Unify.T0 192 | 193 | type matched 194 | 195 | val eq : (t, matched) TypEq.t 196 | 197 | val return : t return 198 | end 199 | 200 | module type M1 = sig 201 | include Unify.T1 202 | 203 | type matched 204 | 205 | type a 206 | 207 | val eq : (a t, matched) TypEq.t 208 | 209 | val return : a t return 210 | end 211 | 212 | module type M2 = sig 213 | include C2 214 | 215 | type matched 216 | 217 | type a 218 | 219 | type b 220 | 221 | val eq : ((a, b) t, matched) TypEq.t 222 | 223 | val return : (a, b) t return 224 | end 225 | 226 | type 'a matched = 227 | | M0 of (module M0 with type matched = 'a) 228 | | M1 of (module M1 with type matched = 'a) 229 | | M2 of (module M2 with type matched = 'a) 230 | 231 | type candidate = C0 of (module C0) | C1 of (module C1) | C2 of (module C2) 232 | 233 | type t = candidate Index.t 234 | 235 | let empty ~modulo_props : t = Index.empty ~modulo_props 236 | 237 | let add (type a) ~(t : a Ttype.t) (return : a return) = 238 | let c = 239 | C0 240 | ( module struct 241 | type t = a 242 | 243 | let t = t 244 | 245 | let return = return 246 | end 247 | ) 248 | in 249 | Index.add (Ttype.to_stype t) c 250 | 251 | let add0 (module C : C0) = Index.add (Ttype.to_stype C.t) (C0 (module C)) 252 | 253 | type var 254 | 255 | let var i : var Ttype.t = Obj.magic (Stype.DT_var i) 256 | 257 | let v0 = var 0 258 | 259 | let v1 = var 1 260 | 261 | let add1 (module C : C1) = Index.add (Ttype.to_stype (C.t v0)) (C1 (module C)) 262 | 263 | let add2 (module C : C2) = 264 | Index.add (Ttype.to_stype (C.t v0 v1)) (C2 (module C)) 265 | 266 | let ttype : type a. int -> Index.substitution -> a Ttype.t = 267 | fun i map -> 268 | match IntMap.find_opt i map with 269 | | None -> Obj.magic Std.unit_t 270 | (* Unification succeeded, but type variable 271 | was not used. *) 272 | | Some s -> Obj.magic s 273 | 274 | (* Unification succeeded by instantiating type 275 | variable with stype s. *) 276 | 277 | let apply : type a. t -> t:a Ttype.t -> a matched option = 278 | fun tree ~t -> 279 | let stype = Ttype.to_stype t in 280 | match Index.get tree stype with 281 | | None -> None 282 | | Some (C0 (module C : C0), map) -> 283 | assert (IntMap.cardinal map = 0); 284 | let module M : M0 with type matched = a = struct 285 | include C 286 | 287 | type matched = a 288 | 289 | let eq = Obj.magic TypEq.refl 290 | end 291 | in 292 | Some (M0 (module M)) 293 | | Some (C1 (module C : C1), map) -> 294 | assert (IntMap.cardinal map < 2); 295 | let module M : M1 with type matched = a = struct 296 | include C 297 | 298 | type matched = a 299 | 300 | type a 301 | 302 | let eq = Obj.magic TypEq.refl 303 | 304 | let return = return (ttype 0 map) 305 | end 306 | in 307 | Some (M1 (module M)) 308 | | Some (C2 (module C : C2), map) -> 309 | assert (IntMap.cardinal map < 3); 310 | let module M : M2 with type matched = a = struct 311 | include C 312 | 313 | type matched = a 314 | 315 | type a 316 | 317 | type b 318 | 319 | let eq = Obj.magic TypEq.refl 320 | 321 | let return = return (ttype 0 map) (ttype 1 map) 322 | end 323 | in 324 | Some (M2 (module M)) 325 | 326 | let apply_exn tree ~t = 327 | match apply tree ~t with None -> raise Not_found | Some m -> m 328 | end 329 | 330 | (** {3 Example} 331 | 332 | We will match on these example types. 333 | 334 | {[ 335 | type t0 = string list 336 | 337 | and 'a t1 = 'a array 338 | 339 | and ('a, 'b) t2 = ('a * 'b) option [@@deriving t] 340 | ]} 341 | 342 | The example pattern match should print the type. An appropriate result type 343 | is [unit -> unit]. 344 | 345 | {[ 346 | module Matcher = Matcher.Make (struct type 'a t = unit -> unit end) 347 | ]} 348 | 349 | The different cases are registered one by one. Free variables will be 350 | substituted in the returned result. 351 | 352 | {[ 353 | let m = 354 | let open Matcher in 355 | let pp_ty = Ttype.print 356 | empty ~modulo_props:true 357 | |> add ~t:[%t: string list] (fun () -> 358 | Format.printf "t0 = %a\n%!" pp_ty t0_t ) 359 | |> add1 360 | ( module struct 361 | type 'a t = 'a t1 [@@deriving t] 362 | 363 | let return a_t () = 364 | Format.printf "%a t1 = %a\n%!" pp_ty a_t pp_ty (t1_t a_t) 365 | end ) 366 | |> add2 367 | ( module struct 368 | type ('a, 'b) t = ('a, 'b) t2 [@@deriving t] 369 | 370 | let return a_t b_t () = 371 | Format.printf "(%a, %a) t2 = %a\n%!" pp_ty a_t pp_ty b_t pp_ty 372 | (t2_t a_t b_t) 373 | end ) 374 | ]} 375 | 376 | The handling of matcher results needs some boilerplate code. 377 | 378 | {[ 379 | 380 | let apply : type a. Matcher.t -> t:a Ttype.t -> unit = 381 | fun matcher ~t -> 382 | let open Matcher in 383 | match apply matcher ~t with 384 | | None -> print_endline "Not found" 385 | | Some (M0 (module M : M0 with type matched = a)) -> M.return () 386 | | Some (M1 (module M : M1 with type matched = a)) -> M.return () 387 | | Some (M2 (module M : M2 with type matched = a)) -> M.return () 388 | 389 | ]} 390 | 391 | Now everything is set up and the matcher is ready for application. 392 | 393 | {[ 394 | 395 | let () = 396 | apply m ~t:[%t: t0] ; 397 | apply m ~t:[%t: int t1] ; 398 | apply m ~t:[%t: bool t1] ; 399 | apply m ~t:[%t: float option] ; 400 | apply m ~t:[%t: (float, string) t2] ; 401 | apply m ~t:[%t: (unit, string) t2] 402 | ]} 403 | 404 | The above example program produces the following output. 405 | 406 | {[ 407 | t0 = string list 408 | int t1 = int array 409 | bool t1 = bool array 410 | Not found 411 | (float, string) t2 = (float * string) option 412 | (unit, string) t2 = (unit * string) option 413 | ]} 414 | *) 415 | -------------------------------------------------------------------------------- /lib/matcher_index.ml: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | module Id : sig 9 | (** Map stype to an identifying integer. 10 | 11 | TODO: Extend stype with an integer symbol identifier to avoid all 12 | overhead. 13 | 14 | TODO: can property names and rec_name/abstract names collide? 15 | *) 16 | 17 | type registry 18 | 19 | val empty : registry 20 | 21 | val range : registry -> int * int 22 | (** The inclusive range of used ids. *) 23 | 24 | type maybe_free = 25 | | Symbol of int * Stype.t list (** symbol, arguments *) 26 | | Var of int (** DT_var *) 27 | 28 | val register_stype 29 | : registry -> 30 | modulo_props:bool -> 31 | Stype.t -> 32 | maybe_free * registry 33 | (** Identify stype. Generates new id for unkown stypes and adds it to the 34 | registry. *) 35 | 36 | val identify_stype 37 | : registry -> 38 | modulo_props:bool -> 39 | Stype.t -> 40 | maybe_free option 41 | (** See {!register_stype}. Returns [None] if stype is unknown. *) 42 | end = struct 43 | (* Strings are mapped to non-negative integers using a string table. During 44 | registration, we use map data structure. For lookup, we compile a string 45 | table. 46 | 47 | It is crucial to preserve the ids when going from map to table. 48 | *) 49 | 50 | module StrMap = Map.Make (String) 51 | module Tbl = Ext.String.Tbl 52 | 53 | type registry = { 54 | map: int StrMap.t; 55 | rev_strings: string list; 56 | table: Tbl.t Lazy.t; 57 | min_id: int; 58 | max_id: int; 59 | } 60 | 61 | let add_name r name = 62 | let rev_strings = name :: r.rev_strings in 63 | let max_id = r.max_id + 1 in 64 | ( max_id, 65 | { 66 | rev_strings; 67 | max_id; 68 | map = StrMap.add name max_id r.map; 69 | table = lazy (Tbl.prepare (List.rev rev_strings)); 70 | min_id = r.min_id; 71 | } ) 72 | 73 | let register_name r name = 74 | match StrMap.find_opt name r.map with 75 | | Some i -> (i, r) 76 | | None -> add_name r name 77 | 78 | let lookup_name r name = 79 | let i = Tbl.lookup (Lazy.force r.table) name in 80 | if i >= 0 then Some i else None 81 | 82 | (* Non-strings are mapped to the negative integers. *) 83 | 84 | let last = ref 0 85 | 86 | let next () = 87 | decr last; 88 | !last 89 | 90 | let int = next () 91 | 92 | let float = next () 93 | 94 | let string = next () 95 | 96 | let array = next () 97 | 98 | let list = next () 99 | 100 | let option = next () 101 | 102 | let arrow = next () 103 | 104 | let tuple0 = next () 105 | 106 | (* Disable next (), since it interferes with tuple ids. *) 107 | type false_ 108 | 109 | let next (x : false_) = x 110 | 111 | let _ = next 112 | 113 | let identify_tuple r arity = 114 | let id = tuple0 - arity in 115 | if id < r.min_id then None else Some id 116 | 117 | let register_tuple r arity = 118 | let min_id = tuple0 - arity in 119 | (min_id, { r with min_id }) 120 | 121 | let empty = 122 | { 123 | max_id = -1; 124 | min_id = tuple0; 125 | map = StrMap.empty; 126 | rev_strings = []; 127 | table = lazy (Tbl.prepare []); 128 | } 129 | 130 | let range r = (r.min_id, r.max_id) 131 | 132 | type maybe_free = Symbol of int * Stype.t list | Var of int (** DT_var *) 133 | 134 | (* Associativity by enforcing single prop DT_prop *) 135 | let rec normalize_props t = function 136 | | [] -> t 137 | | hd :: tl -> normalize_props (Stype.DT_prop ([ hd ], t)) tl 138 | 139 | let rec identify_stype 140 | : registry -> modulo_props:bool -> Stype.t -> maybe_free option 141 | = 142 | fun r ~modulo_props -> function 143 | | DT_int -> Some (Symbol (int, [])) 144 | | DT_float -> Some (Symbol (float, [])) 145 | | DT_string -> Some (Symbol (string, [])) 146 | | DT_list a -> Some (Symbol (list, [ a ])) 147 | | DT_array a -> Some (Symbol (array, [ a ])) 148 | | DT_option a -> Some (Symbol (option, [ a ])) 149 | | DT_arrow (_, a, b) -> Some (Symbol (arrow, [ a; b ])) 150 | | DT_prop (_, s) when modulo_props -> identify_stype r ~modulo_props s 151 | | DT_prop ([], s) -> identify_stype r ~modulo_props s 152 | | DT_prop ([ (key, _) ], s) -> 153 | ( match lookup_name r key with 154 | | None -> None 155 | | Some i -> Some (Symbol (i, [ s ])) 156 | ) 157 | | DT_prop (l, s) -> identify_stype r ~modulo_props (normalize_props s l) 158 | | DT_tuple l -> 159 | ( match identify_tuple r (List.length l) with 160 | | Some id -> Some (Symbol (id, l)) 161 | | None -> None 162 | ) 163 | | DT_abstract (rec_name, rec_args) | DT_node { rec_name; rec_args; _ } -> 164 | ( match lookup_name r rec_name with 165 | | None -> None 166 | | Some i -> Some (Symbol (i, rec_args)) 167 | ) 168 | | DT_object _ -> failwith "object not supported" 169 | | DT_var i -> Some (Var i) 170 | 171 | let rec register_stype 172 | : registry -> modulo_props:bool -> Stype.t -> maybe_free * registry 173 | = 174 | fun r ~modulo_props -> function 175 | | DT_int -> (Symbol (int, []), r) 176 | | DT_float -> (Symbol (float, []), r) 177 | | DT_string -> (Symbol (string, []), r) 178 | | DT_list a -> (Symbol (list, [ a ]), r) 179 | | DT_array a -> (Symbol (array, [ a ]), r) 180 | | DT_option a -> (Symbol (option, [ a ]), r) 181 | | DT_arrow (_, a, b) -> (Symbol (arrow, [ a; b ]), r) 182 | | DT_prop (_, s) when modulo_props -> register_stype r ~modulo_props s 183 | | DT_prop ([], s) -> register_stype r ~modulo_props s 184 | | DT_prop ([ (key, _) ], s) -> 185 | let id, r = register_name r key in 186 | (Symbol (id, [ s ]), r) 187 | | DT_prop (l, s) -> register_stype r ~modulo_props (normalize_props s l) 188 | | DT_tuple l -> 189 | let id, r = register_tuple r (List.length l) in 190 | (Symbol (id, l), r) 191 | | DT_abstract (rec_name, rec_args) | DT_node { rec_name; rec_args; _ } -> 192 | let id, r = register_name r rec_name in 193 | (Symbol (id, rec_args), r) 194 | | DT_object _ -> failwith "object not supported" 195 | | DT_var i -> (Var i, r) 196 | 197 | (* TODO: Runner fails with: Trying to run an expect test from the wrong file 198 | 199 | let%expect_test _ = 200 | let open Stype in 201 | let print = function 202 | | Var i -> Printf.printf "Var %i\n%!" i 203 | | Symbol (i, _) -> Printf.printf "Symbol %i\n%!" i 204 | and modulo_props = true in 205 | let print' = function 206 | | None -> Printf.printf "not registered\n%!" 207 | | Some x -> print x 208 | in 209 | let r = create () in 210 | let r' = create () in 211 | print (of_stype_register r ~modulo_props DT_int) ; 212 | print (of_stype_register r ~modulo_props (DT_array DT_int)) ; 213 | print (of_stype_register r ~modulo_props (DT_abstract ("a", []))) ; 214 | print (of_stype_register r ~modulo_props (DT_abstract ("c", []))) ; 215 | print (of_stype_register r ~modulo_props (DT_abstract ("d", []))) ; 216 | print' (of_stype r ~modulo_props DT_int) ; 217 | print' (of_stype r ~modulo_props (DT_tuple [DT_int; DT_int])) ; 218 | print' (of_stype r ~modulo_props (DT_tuple [])) ; 219 | print' (of_stype r ~modulo_props (DT_abstract ("a", []))) ; 220 | print' (of_stype r ~modulo_props (DT_abstract ("b", []))) ; 221 | print' (of_stype r ~modulo_props (DT_abstract ("c", []))) ; 222 | print' (of_stype r ~modulo_props (DT_abstract ("d", []))) ; 223 | print (of_stype_register r ~modulo_props (DT_abstract ("b", []))) ; 224 | print' (of_stype r ~modulo_props (DT_abstract ("b", []))) ; 225 | let print = function 226 | | Var i -> Printf.printf "Var %i\n%!" i 227 | | Symbol (i, _) -> Printf.printf "Symbol %i\n%!" i 228 | and modulo_props = true in 229 | let print' = function 230 | | None -> Printf.printf "not registered\n%!" 231 | | Some x -> print x 232 | in 233 | print' (of_stype r' ~modulo_props (DT_abstract ("b", []))) ; 234 | [%expect 235 | {| 236 | Symbol -1 237 | Symbol -4 238 | Symbol 0 239 | Symbol 1 240 | Symbol 2 241 | Symbol -1 242 | Symbol -10 243 | Symbol -8 244 | Symbol 0 245 | not registered 246 | Symbol 1 247 | Symbol 2 248 | Symbol 3 249 | Symbol 3 250 | not registered |}] 251 | *) 252 | end 253 | 254 | module IntMap = Ext.Int.Map 255 | 256 | module Tree : sig 257 | type 'a t 258 | 259 | type key = Stype.t 260 | 261 | type substitution = Stype.t IntMap.t 262 | 263 | val empty : modulo_props:bool -> 'a t 264 | 265 | val add : key -> 'a -> 'a t -> 'a t 266 | 267 | val get : 'a t -> key -> ('a * substitution) option 268 | end = struct 269 | (* On each level of the discrimination tree, we discriminate on the 270 | on the first symbol on the stack. Arguments returned by [Id.of_stype] 271 | are pushed back to the stack. 272 | 273 | The set of paths from root to leaves in the resulting tree is homomorphic 274 | to the set of stypes (modulo Id.of_stype). Each path in the tree 275 | corresponds to one stype and vice versa. 276 | 277 | There are two different types of variables. On type corresponds to 278 | DT_vars in stypes , the other to free spots in a path. The variables 279 | in a path are enumerated starting from zero and constitute a normalized 280 | renaming of the DT_vars. We do that, such that ('a * 'b) and ('b * 'a) 281 | give the same path of features. During traversal of the tree, we maintain 282 | a mapping between the two. 283 | 284 | I use Id.range to make the upper level of the tree an array instead of 285 | a table. Reasoning: In most cases, we do not match complex patterns, but 286 | only the outermost structure of an stype. E.g. we implement a new type and 287 | register a dynamic printer for it. In these easy cases, the overhead of a 288 | Hashtbl can be completely avoided. 289 | *) 290 | 291 | type key = Stype.t 292 | 293 | type substitution = Stype.t IntMap.t 294 | 295 | type 'a steps = { 296 | map: 'a IntMap.t; 297 | (* used during insertion *) 298 | ids: Id.registry; 299 | (* stypes to int mapping specific to node*) 300 | arr: 'a option array Lazy.t; 301 | (* flattened map *) 302 | shift: int; (* diff between ids in map and array indexes *) 303 | } 304 | 305 | type 'a tree = 306 | | Leave of { value: 'a; free_vars: (int * int) list } 307 | (* free_vars maps DT_var in stype to free vars in path *) 308 | | Inner of { steps: 'a tree steps; free: 'a tree IntMap.t } 309 | 310 | type 'a t = { modulo_props: bool; tree: 'a tree } 311 | 312 | let steps : type a. Id.registry -> a IntMap.t -> a steps = 313 | fun ids map -> 314 | let min, max = Id.range ids in 315 | let arr = 316 | lazy 317 | (let arr = Array.make (max - min + 1) None in 318 | IntMap.iter (fun i tree -> arr.(i - min) <- Some tree) map; 319 | arr) 320 | in 321 | { map; ids; arr; shift = -min } 322 | 323 | let empty ~modulo_props : 'a t = 324 | { 325 | modulo_props; 326 | tree = Inner { steps = steps Id.empty IntMap.empty; free = IntMap.empty }; 327 | } 328 | 329 | let get t stype = 330 | let modulo_props = t.modulo_props in 331 | let equal = 332 | if modulo_props then Stype.equality_modulo_props else Stype.equality 333 | and get_step ids s = 334 | match Id.identify_stype ids ~modulo_props s with 335 | | Some (Id.Symbol (s, l)) -> Some (s, l) 336 | | None -> None 337 | | _ -> failwith "free variable in query" 338 | in 339 | let rec traverse stack subst tree = 340 | match (stack, tree) with 341 | | [], Leave { value; free_vars } -> 342 | (* undo the variable name normalization *) 343 | let subst = 344 | List.fold_left 345 | (fun map (dt_var, free_id) -> 346 | IntMap.add dt_var (List.assoc free_id subst) map) 347 | IntMap.empty free_vars 348 | in 349 | Some (value, subst) 350 | | hd :: tl, Inner node -> 351 | let ordinary = 352 | match get_step node.steps.ids hd with 353 | | None -> None 354 | | Some (symbol, children) -> 355 | ( match 356 | (Lazy.force node.steps.arr).(symbol + node.steps.shift) 357 | with 358 | | Some x -> traverse (children @ tl) subst x 359 | | None -> None 360 | ) 361 | in 362 | ( match ordinary with 363 | | Some x -> Some x 364 | | None -> 365 | (* Ordinary lookup using the outermost feature of the stype hd failed. 366 | Now try to unify with the free vars, starting with the smallest. 367 | By doing this, we guarantee that ('a * 'a) is preferred 368 | over ('a * 'b). 369 | Rationale: the smallest id was bound further up in the path and thus 370 | is the most restricting choice. 371 | *) 372 | let rec loop = function 373 | | [] -> None 374 | | (free_id, tree) :: rest -> 375 | ( match List.assoc_opt free_id subst with 376 | | None -> traverse tl ((free_id, hd) :: subst) tree 377 | | Some stype -> 378 | if equal stype hd then traverse tl subst tree 379 | else loop rest 380 | ) 381 | in 382 | loop (IntMap.bindings node.free) 383 | ) 384 | | [], _ | _ :: _, Leave _ -> failwith "inconsistent matcher index" 385 | (* This should be impossible. [Id.identify] should uniquely identify the 386 | number of children on each step. *) 387 | in 388 | traverse [ stype ] [] t.tree 389 | 390 | let add : type a. key -> a -> a t -> a t = 391 | fun stype value t -> 392 | let empty_tree : a tree = 393 | Inner { steps = steps Id.empty IntMap.empty; free = IntMap.empty } 394 | in 395 | let get_step = 396 | let modulo_props = t.modulo_props in 397 | Id.register_stype ~modulo_props 398 | in 399 | let rec traverse stack free_vars tree = 400 | match (tree, stack) with 401 | | Leave _, [] -> 402 | raise (Invalid_argument "(congruent) type already registered") 403 | | Inner node, hd :: tl -> 404 | ( match get_step node.steps.ids hd with 405 | | Symbol (symbol, children), ids' -> 406 | let stack' = children @ tl in 407 | ( match IntMap.find_opt symbol node.steps.map with 408 | | None -> 409 | ( match stack' with 410 | | [] -> 411 | let map' = 412 | IntMap.add symbol 413 | (Leave { value; free_vars }) 414 | node.steps.map 415 | in 416 | Inner { node with steps = steps ids' map' } 417 | | _ -> 418 | let tree' = traverse stack' free_vars empty_tree in 419 | let map' = IntMap.add symbol tree' node.steps.map in 420 | Inner { node with steps = steps ids' map' } 421 | ) 422 | | Some tree -> 423 | let tree' = traverse stack' free_vars tree in 424 | let map' = IntMap.add symbol tree' node.steps.map in 425 | Inner { node with steps = steps ids' map' } 426 | ) 427 | | Var dt_var, _ids' -> 428 | let free_id, free_vars = 429 | (* Was this dt_var already observed further up in the path? 430 | If so, reuse free_id, else bump free_id. *) 431 | match List.assoc_opt dt_var free_vars with 432 | | Some free_id -> (free_id, free_vars) 433 | | None -> 434 | ( match free_vars with 435 | | [] -> (0, [ (dt_var, 0) ]) 436 | | (_, last) :: _ as l -> (last + 1, (dt_var, last + 1) :: l) 437 | ) 438 | in 439 | ( match IntMap.find_opt free_id node.free with 440 | | Some tree -> 441 | let tree' = traverse tl free_vars tree in 442 | let free' = IntMap.add free_id tree' node.free in 443 | Inner { node with free = free' } 444 | | None -> 445 | ( match tl with 446 | | [] -> 447 | let free' = 448 | IntMap.add free_id 449 | (Leave { value; free_vars }) 450 | node.free 451 | in 452 | Inner { node with free = free' } 453 | | _ -> 454 | let tree' = traverse tl free_vars empty_tree in 455 | let free' = IntMap.add free_id tree' node.free in 456 | Inner { node with free = free' } 457 | ) 458 | ) 459 | ) 460 | | _, _ -> failwith "inconsistent tree" 461 | in 462 | { t with tree = traverse [ stype ] [] t.tree } 463 | 464 | let%test _ = 465 | let open Stype in 466 | let print_substitution fmt map = 467 | IntMap.iter 468 | (fun i stype -> 469 | Format.fprintf fmt " DT_var %i -> %a;" i Stype.print stype) 470 | map 471 | in 472 | let print fmt = function 473 | | None -> Format.fprintf fmt "None" 474 | | Some (i, s) -> Format.fprintf fmt "Some (%i, %a)" i print_substitution s 475 | in 476 | let tadd typ = add (Ttype.to_stype typ) in 477 | let open Std in 478 | let tree = 479 | empty ~modulo_props:true 480 | |> tadd (list_t int_t) 1 481 | |> tadd (option_t string_t) 2 482 | |> tadd int_t 3 |> add (DT_var 0) 42 |> add (DT_list (DT_var 0)) 4 483 | |> add (DT_tuple [ DT_var 0; DT_var 0 ]) 5 484 | |> add (DT_tuple [ DT_var 1; DT_var 0 ]) 6 485 | (* this fails as expected *) 486 | (* |> add (DT_var 1) 42 *) 487 | in 488 | let s = Ttype.to_stype in 489 | List.for_all 490 | (fun (stype, expected) -> 491 | let got = get tree stype in 492 | if got = expected then true 493 | else 494 | let () = 495 | Format.printf "expected: %a\ngot: %a\n%!" print expected print got 496 | in 497 | false) 498 | [ 499 | (s int_t, Some (3, IntMap.empty)); 500 | (s (list_t string_t), Some (4, IntMap.singleton 0 DT_string)); 501 | (s (list_t int_t), Some (1, IntMap.empty)); 502 | (s (option_t string_t), Some (2, IntMap.empty)); 503 | ( s (list_t (array_t int_t)), 504 | Some (4, IntMap.singleton 0 (DT_array DT_int)) ); 505 | (s [%t: int * int], Some (5, IntMap.singleton 0 DT_int)); 506 | ( s [%t: int * bool], 507 | Some (6, IntMap.(singleton 0 (s bool_t) |> add 1 (s int_t))) ); 508 | (s [%t: int option], Some (42, IntMap.singleton 0 (DT_option DT_int))); 509 | ] 510 | end 511 | -------------------------------------------------------------------------------- /lib/path.ml: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | let print_list ppf ~opn ~cls ~sep print_el l = 9 | let rec f = function 10 | | [] -> () 11 | | [ hd ] -> Format.fprintf ppf "%a" print_el hd 12 | | hd :: tl -> 13 | Format.fprintf ppf "%a" print_el hd; 14 | Format.fprintf ppf "%s" sep; 15 | f tl 16 | in 17 | Format.fprintf ppf "%s" opn; 18 | f l; 19 | Format.fprintf ppf "%s" cls 20 | 21 | type (_, _) t = 22 | | ( :: ) : ('a, 'b) step * ('b, 'c) t -> ('a, 'c) t 23 | | [] : ('a, 'a) t 24 | 25 | and ('a, 'b) step = ('a, 'b) lens * meta 26 | 27 | and ('a, 'b) lens = { get: 'a -> 'b option; set: 'a -> 'b -> 'a option } 28 | 29 | and meta = 30 | (* private *) 31 | | Field of { field_name: string } 32 | | Constructor of { name: string; arg: argument } 33 | | Tuple of { nth: int; arity: int } 34 | | List of { nth: int } 35 | | Array of { nth: int } 36 | 37 | and argument = 38 | | Regular of { nth: int; arity: int } 39 | | Inline of { field_name: string } 40 | 41 | let rec print_step ppf = function 42 | | Field { field_name } -> Format.fprintf ppf "%s" field_name 43 | | Constructor { name; arg = Regular { nth; arity } } -> 44 | Format.fprintf ppf "%s %a" name print_step (Tuple { nth; arity }) 45 | | Constructor { name; arg = Inline { field_name } } -> 46 | Format.fprintf ppf "%s %a" name print_step (Field { field_name }) 47 | | Tuple { nth; arity } -> 48 | let a = Array.make arity "_" in 49 | a.(nth) <- "[]"; 50 | if arity > 1 then Format.fprintf ppf "("; 51 | print_list ppf ~opn:"" ~cls:"" ~sep:"," 52 | (fun ppf s -> Format.fprintf ppf "%s" s) 53 | (Array.to_list a); 54 | if arity > 1 then Format.fprintf ppf ")" 55 | | List { nth } -> Format.fprintf ppf "[%i]" nth 56 | | Array { nth } -> Format.fprintf ppf "[|%i|]" nth 57 | 58 | let meta t = 59 | let rec fold : type a b. meta list -> (a, b) t -> meta list = 60 | fun acc -> function 61 | | [] -> List.rev acc 62 | | (_, hd) :: tl -> fold (hd :: acc) tl 63 | in 64 | fold [] t 65 | 66 | let print ppf t = 67 | print_list ppf ~opn:"[%path? [" ~cls:"]]" ~sep:"; " print_step (meta t) 68 | 69 | let ( >>= ) x f = match x with None -> None | Some x -> f x 70 | 71 | let root_lens : ('a, 'a) lens = 72 | let set _a b = Some b and get a = Some a in 73 | { set; get } 74 | 75 | let lens (t : ('a, 'b) t) : ('a, 'b) lens = 76 | let focus acc hd = 77 | let get a = acc.get a >>= hd.get 78 | and set a c = acc.get a >>= fun b -> hd.set b c >>= acc.set a in 79 | { get; set } 80 | in 81 | let rec fold : type a b c. (a, b) lens -> (b, c) t -> (a, c) lens = 82 | fun acc -> function [] -> acc | (hd, _) :: tl -> fold (focus acc hd) tl 83 | in 84 | fold root_lens t 85 | 86 | let rec ( @ ) : type a b c. (a, b) t -> (b, c) t -> (a, c) t = 87 | fun p1 p2 -> match p1 with hd :: tl -> hd :: (tl @ p2) | [] -> p2 88 | 89 | module Unsafe = struct 90 | let is_prefix : type a b c. (a, b) t -> (a, c) t -> (b, c) t option = 91 | fun prefix t -> 92 | let pmeta, tmeta = (meta prefix, meta t) in 93 | let rec check (l : meta list) (r : meta list) (p : (_, _) t) = 94 | match (l, r, p) with 95 | | [], _, p -> Some p 96 | | hl :: tl, hr :: tr, _ :: tp when hl = hr -> check tl tr (Obj.magic tp) 97 | | _, _ :: _, [] | _, [], _ :: _ -> assert false 98 | | _ -> None 99 | in 100 | (* TODO: We are comparing the path based on the untyped meta information. 101 | Can we do better? *) 102 | Obj.magic (check pmeta tmeta (Obj.magic t)) 103 | 104 | let is_equal a b = match is_prefix a b with Some [] -> true | _ -> false 105 | end 106 | 107 | module Internal = struct 108 | let list ~nth = List { nth } 109 | 110 | let array ~nth = Array { nth } 111 | 112 | let field ~field_name = Field { field_name } 113 | 114 | let tuple ~nth ~arity = Tuple { nth; arity } 115 | 116 | let constructor_regular ~name ~nth ~arity = 117 | Constructor { name; arg = Regular { nth; arity } } 118 | 119 | let constructor_inline ~name ~field_name = 120 | Constructor { name; arg = Inline { field_name } } 121 | end 122 | -------------------------------------------------------------------------------- /lib/path.mli: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | (** Access deeply nested types and values. 9 | 10 | This module introduces paths within types and values. 11 | 12 | Paths are constructed using the syntax extension [\[%path? P\]]. 13 | The payload [P] is a list of steps, each following this syntax: 14 | 15 | - [ ([],_,_) ] to access the first element of a triple. 16 | - [ fld ] to access the record field [fld]. 17 | - [ Cst (_,[]) ] to access the second argument to constructor [Cst]. 18 | - [ Cst fld ] to access inline record field [fld] of constructor [Cst]. 19 | - [ [7] ] to access the seventh element of a list. 20 | - [ [|5|] ] to access the fifth element of an array. 21 | 22 | The empty path can be written [\[%path? []\]] or [Path.\[\]]. 23 | 24 | Examples: 25 | 26 | - [\[%path? \[fld; (\[\],_)\]\]] corresponds to [fun x -> fst x.fld] 27 | - [\[%path? \[Cst fld; \[|1|\]\]\]] corresponds to 28 | [fun (Cst x) -> Array.get x.fld 1] 29 | *) 30 | 31 | type (_, _) t = 32 | | ( :: ) : ('a, 'b) step * ('b, 'c) t -> ('a, 'c) t 33 | | [] : ('a, 'a) t 34 | 35 | and ('a, 'b) step = ('a, 'b) lens * meta 36 | 37 | and ('a, 'b) lens = { get: 'a -> 'b option; set: 'a -> 'b -> 'a option } 38 | 39 | and meta = private 40 | | Field of { field_name: string } 41 | | Constructor of { name: string; arg: argument } 42 | | Tuple of { nth: int; arity: int } 43 | | List of { nth: int } 44 | | Array of { nth: int } 45 | 46 | and argument = 47 | | Regular of { nth: int; arity: int } 48 | | Inline of { field_name: string } 49 | 50 | val ( @ ) : ('a, 'b) t -> ('b, 'c) t -> ('a, 'c) t 51 | (** [a @ b] composes the paths [a] and [b]. *) 52 | 53 | val lens : ('a, 'b) t -> ('a, 'b) lens 54 | (** Condense a path to a single lens. *) 55 | 56 | val meta : ('a, 'b) t -> meta list 57 | (** Reads the unsafe representation of steps from a path. *) 58 | 59 | val print : Format.formatter -> ('a, 'b) t -> unit 60 | (** Print a path in the syntax expected by the syntax extension. *) 61 | 62 | (** Operations based on the untyped meta information. *) 63 | module Unsafe : sig 64 | (** The following functions compare paths based on the untyped meta 65 | information. This meta information is derived from an untyped 66 | representation of your program using a PPX. You might be able to construct 67 | distinct paths with the same meta information. This module will interpret 68 | such paths as equal and potentially produce unexpected results. *) 69 | 70 | val is_equal : ('a, 'b) t -> ('a, 'b) t -> bool 71 | (** [is_equal path1 path2] checks if [path1] and [path2] consist of the same 72 | steps. *) 73 | 74 | val is_prefix : ('a, 'b) t -> ('a, 'c) t -> ('b, 'c) t option 75 | (** [is_prefix path1 path2] checks if [path2] starts with [path1]. 76 | When this is the case, the function returns the remaining path. *) 77 | end 78 | 79 | (**/**) 80 | 81 | module Internal : sig 82 | (** Constructors for the private type [meta]. This should not be used directly 83 | because other parts of the module assume consistency between the lens and 84 | meta information. *) 85 | 86 | val field : field_name:string -> meta 87 | 88 | val tuple : nth:int -> arity:int -> meta 89 | 90 | val constructor_regular : name:string -> nth:int -> arity:int -> meta 91 | 92 | val constructor_inline : name:string -> field_name:string -> meta 93 | 94 | val list : nth:int -> meta 95 | 96 | val array : nth:int -> meta 97 | end 98 | [@@ocaml.deprecated "do not use this module directly"] 99 | -------------------------------------------------------------------------------- /lib/print.ml: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | open Std 9 | 10 | type 'a printer = Format.formatter -> 'a -> unit 11 | 12 | module type PRINTABLE_0 = sig 13 | include Unify.T0 14 | 15 | val printer : t printer 16 | end 17 | 18 | module type PRINTABLE_1 = sig 19 | include Unify.T1 20 | 21 | val printer : 'a printer -> 'a t printer 22 | end 23 | 24 | module type PRINTABLE_2 = sig 25 | include Unify.T2 26 | 27 | val printer : 'a printer -> 'b printer -> ('a, 'b) t printer 28 | end 29 | 30 | type printable = 31 | | T0 of (module PRINTABLE_0) 32 | | T1 of (module PRINTABLE_1) 33 | | T2 of (module PRINTABLE_2) 34 | 35 | let abstract_printers : (string, printable) Hashtbl.t = Hashtbl.create 17 36 | 37 | let add_abstract_0 (module P : PRINTABLE_0) = 38 | match Ttype.abstract_name P.t with 39 | | Some name -> Hashtbl.add abstract_printers name (T0 (module P)) 40 | | _ -> raise (Invalid_argument "add_abstract: received non abstract type") 41 | 42 | let add_abstract_1 (module P : PRINTABLE_1) = 43 | match Ttype.abstract_name (P.t unit_t) with 44 | | Some name -> Hashtbl.add abstract_printers name (T1 (module P)) 45 | | _ -> raise (Invalid_argument "add_abstract: received non abstract type") 46 | 47 | let add_abstract_2 (module P : PRINTABLE_2) = 48 | match Ttype.abstract_name (P.t unit_t unit_t) with 49 | | Some name -> Hashtbl.add abstract_printers name (T2 (module P)) 50 | | _ -> raise (Invalid_argument "add_abstract: received non abstract type") 51 | 52 | module type UNSAFE_ABSTRACT_PRINTABLE_1 = sig 53 | type 'a t 54 | 55 | val name : string 56 | 57 | val printer : 'a printer -> 'a t printer 58 | end 59 | 60 | module type UNSAFE_ABSTRACT_PRINTABLE_2 = sig 61 | type ('a, 'b) t 62 | 63 | val name : string 64 | 65 | val printer : 'a printer -> 'b printer -> ('a, 'b) t printer 66 | end 67 | 68 | let add_unsafe_abstract_0 ~name (printer : Format.formatter -> 'a printer) = 69 | add_abstract_0 70 | ( module struct 71 | type t = Obj.t 72 | 73 | let t : t Ttype.t = Obj.magic (Stype.DT_abstract (name, [])) 74 | 75 | let printer = Obj.magic printer 76 | end 77 | ) 78 | 79 | let add_unsafe_abstract_1 (module P : UNSAFE_ABSTRACT_PRINTABLE_1) = 80 | add_abstract_1 81 | ( module struct 82 | type 'a t = Obj.t 83 | 84 | let t (a : 'a Ttype.t) : 'a t Ttype.t = 85 | Obj.magic (Stype.DT_abstract (P.name, [ Ttype.to_stype a ])) 86 | 87 | let printer = Obj.magic P.printer 88 | end 89 | ) 90 | 91 | let add_unsafe_abstract_2 (module P : UNSAFE_ABSTRACT_PRINTABLE_2) = 92 | add_abstract_2 93 | ( module struct 94 | type ('a, 'b) t = Obj.t 95 | 96 | let t (a : 'a Ttype.t) (b : 'b Ttype.t) : ('a, 'b) t Ttype.t = 97 | Obj.magic 98 | (Stype.DT_abstract (P.name, [ Ttype.to_stype a; Ttype.to_stype b ])) 99 | 100 | let printer = Obj.magic P.printer 101 | end 102 | ) 103 | 104 | let pp_may_left_paren ppf parens = 105 | Format.pp_open_box ppf 1; 106 | if parens then Format.pp_print_char ppf '(' 107 | 108 | let pp_may_right_paren ppf parens = 109 | if parens then Format.pp_print_char ppf ')'; 110 | Format.pp_close_box ppf () 111 | 112 | let pp_par_when_neg ppf parens abs print x = 113 | if abs x <> x then ( 114 | pp_may_left_paren ppf parens; 115 | print ppf x; 116 | pp_may_right_paren ppf parens 117 | ) 118 | else print ppf x 119 | 120 | let pp_print_int32 ppf x = Format.pp_print_string ppf (Int32.to_string x) 121 | 122 | let pp_print_int64 ppf x = Format.pp_print_string ppf (Int64.to_string x) 123 | 124 | let pp_print_nativeint ppf x = 125 | Format.pp_print_string ppf (Nativeint.to_string x) 126 | 127 | let print_dynamic fmt (t, x) = 128 | let open Format in 129 | let open Xtype in 130 | let rec print_list 131 | : type a. pre:_ -> pst:_ -> sep:_ -> (a -> unit) -> a list -> unit 132 | = 133 | fun ~pre ~pst ~sep print_el lst -> 134 | let rec f = function 135 | | [] -> () 136 | | [ e ] -> print_el e 137 | | e :: rest -> 138 | print_el e; 139 | pp_print_string fmt sep; 140 | pp_print_space fmt (); 141 | f rest 142 | in 143 | pp_print_string fmt pre; 144 | f lst; 145 | pp_print_string fmt pst 146 | and print_dynamic : type t. t Ttype.t -> bool -> t -> unit = 147 | fun t parens x -> 148 | match xtype_of_ttype t with 149 | | Unit -> pp_print_string fmt "()" 150 | | Bool -> pp_print_bool fmt x 151 | | Char -> pp_print_char fmt x 152 | | Int -> pp_par_when_neg fmt parens abs pp_print_int x 153 | | Int32 -> pp_par_when_neg fmt parens Int32.abs pp_print_int32 x 154 | | Int64 -> pp_par_when_neg fmt parens Int64.abs pp_print_int64 x 155 | | Float -> pp_par_when_neg fmt parens abs_float Ext.Float.pp_repres x 156 | | Nativeint -> pp_par_when_neg fmt parens Nativeint.abs pp_print_nativeint x 157 | | String -> 158 | pp_print_char fmt '\"'; 159 | pp_print_string fmt (String.escaped x); 160 | pp_print_char fmt '\"' 161 | | Option { t; _ } -> 162 | ( match x with 163 | | None -> pp_print_string fmt "None" 164 | | Some next_x -> 165 | pp_may_left_paren fmt parens; 166 | pp_print_string fmt "Some"; 167 | pp_print_space fmt (); 168 | print_dynamic t true next_x; 169 | pp_may_right_paren fmt parens 170 | ) 171 | | List _ when x = [] -> pp_print_string fmt "[]" 172 | | List { t; _ } -> 173 | pp_open_box fmt 2; 174 | print_list ~pre:"[" ~sep:";" ~pst:"]" (print_dynamic t false) x; 175 | pp_close_box fmt () 176 | | Array { t; _ } -> 177 | pp_open_box fmt 2; 178 | pp_print_string fmt "[|"; 179 | for i = 0 to Array.length x - 1 do 180 | if i > 0 then ( 181 | pp_print_char fmt ';'; 182 | pp_print_space fmt () 183 | ); 184 | print_dynamic t false x.(i) 185 | done; 186 | pp_print_string fmt "|]"; 187 | pp_close_box fmt () 188 | | Tuple tup -> 189 | let print_el (Field e) = 190 | print_dynamic e.typ.t false (Read.tuple tup e x) 191 | in 192 | pp_open_box fmt 1; 193 | print_list ~pre:"(" ~sep:"," ~pst:")" print_el tup.t_flds; 194 | pp_close_box fmt () 195 | | Record r -> 196 | let print_el ((name, _), Field e) = 197 | pp_open_box fmt 1; 198 | pp_print_string fmt name; 199 | pp_print_string fmt " ="; 200 | pp_print_space fmt (); 201 | print_dynamic e.typ.t false (Read.record r e x); 202 | pp_close_box fmt () 203 | in 204 | pp_open_hvbox fmt 1; 205 | print_list ~pre:"{" ~sep:";" ~pst:"}" print_el r.r_flds; 206 | pp_close_box fmt () 207 | | Sum s -> 208 | pp_may_left_paren fmt parens; 209 | ( match s.s_cstr_by_value x with 210 | | Constant c -> pp_print_string fmt (fst c.cc_label) 211 | | Regular ({ rc_flds = [ Field e ]; _ } as c) -> 212 | pp_open_box fmt 1; 213 | pp_print_string fmt (fst c.rc_label); 214 | pp_print_space fmt (); 215 | print_dynamic e.typ.t true 216 | (Read.regular_constructor c e x |> Ext.Option.value_exn); 217 | pp_close_box fmt () 218 | | Regular c -> 219 | let print_el (Field e) = 220 | pp_open_box fmt 1; 221 | print_dynamic e.typ.t false 222 | (Read.regular_constructor c e x |> Ext.Option.value_exn); 223 | pp_close_box fmt () 224 | in 225 | pp_open_box fmt 1; 226 | pp_print_string fmt (fst c.rc_label); 227 | pp_print_space fmt (); 228 | print_list ~pre:"(" ~sep:"," ~pst:")" print_el c.rc_flds; 229 | pp_close_box fmt () 230 | | Inlined c -> 231 | let print_el ((name, _), Field e) = 232 | pp_open_box fmt 1; 233 | pp_print_string fmt name; 234 | pp_print_string fmt " ="; 235 | pp_print_space fmt (); 236 | print_dynamic e.typ.t false 237 | (Read.inlined_constructor c e x |> Ext.Option.value_exn); 238 | pp_close_box fmt () 239 | in 240 | pp_open_hvbox fmt 1; 241 | pp_print_string fmt (fst c.ic_label); 242 | pp_print_space fmt (); 243 | print_list ~pre:"{" ~sep:";" ~pst:"}" print_el c.ic_flds; 244 | pp_close_box fmt () 245 | ); 246 | pp_may_right_paren fmt parens 247 | | Lazy { t; _ } -> 248 | pp_may_left_paren fmt parens; 249 | pp_print_string fmt "lazy "; 250 | ( match Lazy.force x with 251 | | exception exn -> 252 | pp_print_string fmt "(raise "; 253 | pp_print_string fmt (Printexc.to_string exn); 254 | pp_print_char fmt ')' 255 | | x -> print_dynamic t true x 256 | ); 257 | pp_may_right_paren fmt parens 258 | | Function _ -> pp_print_string fmt "" 259 | | Object _ -> pp_print_string fmt "" 260 | | Prop (_, { t; _ }) -> print_dynamic t parens x 261 | | Abstract (name, _) -> 262 | let (module B) = Unify.t0 t 263 | and (module P) = Unify.init ~modulo_props:false in 264 | let rec use_first = function 265 | | [] -> 266 | pp_print_string fmt "" 269 | | hd :: tl -> 270 | ( match hd with 271 | | T0 (module A : PRINTABLE_0) -> 272 | ( try 273 | let module U = Unify.U0 (P) (A) (B) in 274 | let TypEq.Eq = U.eq in 275 | A.printer fmt x 276 | with Unify.Not_unifiable -> use_first tl 277 | ) 278 | | T1 (module A : PRINTABLE_1) -> 279 | ( try 280 | let module U = Unify.U1 (P) (A) (B) in 281 | let TypEq.Eq = U.eq in 282 | let pr _fmt x = print_dynamic U.a_t false x in 283 | A.printer pr fmt x 284 | with Unify.Not_unifiable -> use_first tl 285 | ) 286 | | T2 (module A : PRINTABLE_2) -> 287 | ( try 288 | let module U = Unify.U2 (P) (A) (B) in 289 | let TypEq.Eq = U.eq in 290 | let pr1 _fmt x = print_dynamic U.a_t false x in 291 | let pr2 _fmt x = print_dynamic U.b_t false x in 292 | A.printer pr1 pr2 fmt x 293 | with Unify.Not_unifiable -> use_first tl 294 | ) 295 | ) 296 | in 297 | pp_open_box fmt 0; 298 | use_first (Hashtbl.find_all abstract_printers name); 299 | pp_close_box fmt () 300 | in 301 | print_dynamic t false x 302 | 303 | let print ~t ppf x = print_dynamic ppf (t, x) 304 | 305 | let show ~t x = Format.printf "%a\n%!" print_dynamic (t, x) 306 | 307 | module Hashtbl_printer = struct 308 | open Format 309 | 310 | type ('a, 'b) t = ('a, 'b) Hashtbl.t 311 | 312 | let t (type a b) (a : a Ttype.t) (b : b Ttype.t) = hashtbl_t a b 313 | 314 | let printer (print1 : 'a printer) (print2 : 'b printer) ppf 315 | (h : ('a, 'b) Hashtbl.t) 316 | = 317 | let first = ref true in 318 | let print_el key value = 319 | if !first then first := false 320 | else ( 321 | pp_print_char ppf ';'; 322 | pp_print_space ppf () 323 | ); 324 | pp_open_box ppf 1; 325 | pp_print_char ppf '('; 326 | print1 ppf key; 327 | pp_print_char ppf ','; 328 | pp_print_space ppf (); 329 | print2 ppf value; 330 | pp_print_char ppf ')'; 331 | pp_close_box ppf () 332 | in 333 | if Hashtbl.length h = 0 then pp_print_string ppf "[]" 334 | else ( 335 | pp_open_box ppf 1; 336 | pp_print_char ppf '['; 337 | Hashtbl.iter print_el h; 338 | pp_print_char ppf ']'; 339 | pp_close_box ppf () 340 | ) 341 | end 342 | 343 | let () = add_abstract_2 (module Hashtbl_printer) 344 | 345 | let () = 346 | add_abstract_0 347 | ( module struct 348 | type t = unit 349 | 350 | let t = unit_t 351 | 352 | let printer ppf () = Format.pp_print_string ppf "()" 353 | end 354 | ); 355 | add_abstract_1 356 | ( module struct 357 | type 'a t = 'a Ttype.t 358 | 359 | let t (type a) (a : a Ttype.t) = Ttype.t a 360 | 361 | let printer _pp_a ppf t = Stype.print ppf (Ttype.to_stype t) 362 | end 363 | ) 364 | 365 | module Test = struct 366 | [@@@warning "-37"] 367 | 368 | let show t x = show ~t x 369 | 370 | let ht = Hashtbl.create 5 371 | 372 | let () = 373 | Hashtbl.add ht "a" 5; 374 | Hashtbl.add ht "b" 7; 375 | Hashtbl.add ht "c" 13 376 | 377 | type sum = Tpl of int * int | Atm of int [@@deriving t] 378 | 379 | let%expect_test _ = 380 | show [%t: unit] (); 381 | show [%t: int] (-2); 382 | show [%t: int] 40; 383 | show int64_t (Int64.of_int 41); 384 | show string_t "a string"; 385 | show [%t: int -> int] (fun x -> x + 1); 386 | show [%t: int list] [ 1; 2; 3 ]; 387 | show [%t: string array] [| "a"; "b"; "c" |]; 388 | show (hashtbl_t string_t int_t) ht; 389 | show [%t: sum * sum] (Tpl (0, 0), Atm 0); 390 | show int32_t (Int32.of_int 42); 391 | show nativeint_t (Nativeint.of_int 43); 392 | [%expect 393 | {| 394 | () 395 | -2 396 | 40 397 | 41 398 | "a string" 399 | 400 | [1; 2; 3] 401 | [|"a"; "b"; "c"|] 402 | [("a", 5); ("b", 7); ("c", 13)] 403 | (Tpl (0, 0), Atm 0) 404 | 42 405 | 43 |}] 406 | 407 | type tt = 408 | | Inl of { x: int; y: bool; z: string } 409 | | Empty 410 | | Tupl of int * bool * string 411 | [@@deriving t] 412 | 413 | let%expect_test _ = 414 | print_endline "ttype:"; 415 | show (Ttype.t tt_t) tt_t; 416 | [%expect 417 | {| 418 | ttype: 419 | (lrt#lib/print.ml.Test.tt = 420 | | Inl of 421 | (tt.Inl = 422 | { 423 | x: int; 424 | y: bool; 425 | z: string; 426 | }) 427 | | Empty 428 | | Tupl of (int * bool * string)) |}] 429 | end 430 | -------------------------------------------------------------------------------- /lib/print.mli: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | (** Dynamic printing. *) 9 | 10 | val print : t:'a Ttype.t -> Format.formatter -> 'a -> unit 11 | (** Print a value to the given formatter. *) 12 | 13 | val show : t:'a Ttype.t -> 'a -> unit 14 | (** Print a value to stdout. *) 15 | 16 | (** {3 Handling abstract types} *) 17 | 18 | type 'a printer = Format.formatter -> 'a -> unit 19 | 20 | module type PRINTABLE_0 = sig 21 | include Unify.T0 22 | 23 | val printer : t printer 24 | end 25 | 26 | module type PRINTABLE_1 = sig 27 | include Unify.T1 28 | 29 | val printer : 'a printer -> 'a t printer 30 | end 31 | 32 | module type PRINTABLE_2 = sig 33 | include Unify.T2 34 | 35 | val printer : 'a printer -> 'b printer -> ('a, 'b) t printer 36 | end 37 | 38 | (** The following raise [Failure] on non-abstract types. *) 39 | 40 | val add_abstract_0 : (module PRINTABLE_0) -> unit 41 | 42 | val add_abstract_1 : (module PRINTABLE_1) -> unit 43 | 44 | val add_abstract_2 : (module PRINTABLE_2) -> unit 45 | 46 | (** {3 Unsafe printing for abstract types} 47 | 48 | The abstract types are matched by name only. 49 | *) 50 | 51 | module type UNSAFE_ABSTRACT_PRINTABLE_1 = sig 52 | type 'a t 53 | 54 | val name : string 55 | 56 | val printer : 'a printer -> 'a t printer 57 | end 58 | 59 | module type UNSAFE_ABSTRACT_PRINTABLE_2 = sig 60 | type ('a, 'b) t 61 | 62 | val name : string 63 | 64 | val printer : 'a printer -> 'b printer -> ('a, 'b) t printer 65 | end 66 | 67 | val add_unsafe_abstract_0 68 | : name:string -> 69 | (Format.formatter -> 'a printer) -> 70 | unit 71 | 72 | val add_unsafe_abstract_1 : (module UNSAFE_ABSTRACT_PRINTABLE_1) -> unit 73 | 74 | val add_unsafe_abstract_2 : (module UNSAFE_ABSTRACT_PRINTABLE_2) -> unit 75 | -------------------------------------------------------------------------------- /lib/std.ml: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | open Stype 9 | 10 | (* CAUTION: This must be consistent with xtype_of_ttype *) 11 | let unit_t = DT_abstract ("unit", []) |> Obj.magic 12 | 13 | let bool_t = DT_abstract ("bool", []) |> Obj.magic 14 | 15 | let char_t = DT_abstract ("char", []) |> Obj.magic 16 | 17 | let int32_t = DT_abstract ("int32", []) |> Obj.magic 18 | 19 | let int64_t = DT_abstract ("int64", []) |> Obj.magic 20 | 21 | let nativeint_t = DT_abstract ("nativeint", []) |> Obj.magic 22 | 23 | let int_t = DT_int |> Obj.magic 24 | 25 | let string_t = DT_string |> Obj.magic 26 | 27 | let float_t = DT_float |> Obj.magic 28 | 29 | let option_t a = 30 | let t = Ttype.to_stype a in 31 | DT_option t |> Obj.magic 32 | 33 | let list_t a = 34 | let t = Ttype.to_stype a in 35 | DT_list t |> Obj.magic 36 | 37 | let array_t a = 38 | let t = Ttype.to_stype a in 39 | DT_array t |> Obj.magic 40 | 41 | let lazy_t a = 42 | let t = Ttype.to_stype a in 43 | DT_abstract ("Lazy.t", [ t ]) |> Obj.magic 44 | 45 | let hashtbl_t a b = 46 | let a = Ttype.to_stype a in 47 | let b = Ttype.to_stype b in 48 | DT_abstract ("Hashtbl.t", [ a; b ]) |> Obj.magic 49 | -------------------------------------------------------------------------------- /lib/std.mli: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | (** Dynamic type representations for standard ocaml types. *) 9 | 10 | (** {3 Pervasives } *) 11 | 12 | val unit_t : unit Ttype.t 13 | 14 | val bool_t : bool Ttype.t 15 | 16 | val int_t : int Ttype.t 17 | 18 | val string_t : string Ttype.t 19 | 20 | val float_t : float Ttype.t 21 | 22 | val char_t : char Ttype.t 23 | 24 | val nativeint_t : nativeint Ttype.t 25 | 26 | val int32_t : int32 Ttype.t 27 | 28 | val int64_t : int64 Ttype.t 29 | 30 | val option_t : 'a Ttype.t -> 'a option Ttype.t 31 | 32 | val list_t : 'a Ttype.t -> 'a list Ttype.t 33 | 34 | val array_t : 'a Ttype.t -> 'a array Ttype.t 35 | 36 | (** {3 Stdlib } *) 37 | 38 | val lazy_t : 'a Ttype.t -> 'a Lazy.t Ttype.t 39 | 40 | val hashtbl_t : 'a Ttype.t -> 'b Ttype.t -> ('a, 'b) Hashtbl.t Ttype.t 41 | -------------------------------------------------------------------------------- /lib/stype.mli: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | (** Untyped representation of types. *) 9 | 10 | type t = node gtype 11 | 12 | and 'node gtype = 13 | | DT_node of 'node 14 | | DT_int 15 | | DT_float 16 | | DT_string 17 | | DT_tuple of 'node gtype list 18 | | DT_list of 'node gtype 19 | | DT_array of 'node gtype 20 | | DT_option of 'node gtype 21 | | DT_abstract of string * 'node gtype list 22 | | DT_arrow of string * 'node gtype * 'node gtype 23 | | DT_object of (string * 'node gtype) list 24 | | DT_prop of properties * 'node gtype 25 | | DT_var of int 26 | 27 | and node = private { 28 | mutable rec_descr: node_descr; (** Structure. *) 29 | rec_uid: int; (** Corresponds to physical equality of nodes. *) 30 | rec_name: string; (** Fully qualified name. *) 31 | rec_args: t list; (** Arguments. *) 32 | mutable rec_has_var: bool option; (** Internal use only. *) 33 | mutable rec_hash: int; (** Internal use only. *) 34 | mutable rec_memoized: memoized_type_prop array; 35 | } 36 | 37 | and properties = (string * string) list 38 | 39 | and memoized_type_prop = .. 40 | 41 | and node_descr = DT_variant of variant_descr | DT_record of record_descr 42 | 43 | and record_descr = { 44 | record_fields: (string * properties * t) list; 45 | record_repr: record_repr; 46 | } 47 | 48 | and record_repr = 49 | | Record_regular 50 | | Record_float 51 | | Record_unboxed 52 | | Record_inline of int 53 | 54 | and variant_descr = { 55 | variant_constrs: (string * properties * t variant_args) list; 56 | variant_repr: variant_repr; 57 | } 58 | 59 | and 'stype variant_args = C_tuple of 'stype list | C_inline of 'stype 60 | 61 | and variant_repr = Variant_regular | Variant_unboxed 62 | 63 | val print_ref : (Format.formatter -> t -> unit) ref 64 | (** Pretty-printer hook. This can be changed dynamically. *) 65 | 66 | val print : Format.formatter -> t -> unit 67 | (** Pretty-printer for [Stype.t]. Calls {!print_ref}. *) 68 | 69 | val print_hide_enumerations : Format.formatter -> t -> unit 70 | 71 | val strict_equality : t -> t -> bool 72 | 73 | val equality : t -> t -> bool 74 | 75 | val equality_modulo_props : t -> t -> bool 76 | 77 | val remove_outer_props : t -> t 78 | (** Remove properties from a stype. If properties are nested, all are removed.*) 79 | 80 | val consume_outer_props : t -> properties * t 81 | (** Read the properties from a stype and returns a stype that is not a property 82 | node. If properties are nested, the innermost properties are at the 83 | beginning of the return list. 84 | 85 | In the sense of this function the following types [s] and [t] carry the same 86 | list of properties. 87 | {[ 88 | type s' = int [@prop {a = "b"; b = "c"}] [@@deriving t] 89 | type s = s' [@prop {c = "d"; d = "e"}] [@@deriving t] 90 | type t = int [@prop {a = "b"; b = "c"; c = "d"; d = "e"}] [@@deriving t] 91 | let t = Ttype.to_stype t 92 | and s = Ttype.to_stype s_t in 93 | assert (fst (consume_outer_props s) = fst (consume_outer_props t)) 94 | ]} 95 | *) 96 | 97 | val uninline : 'a variant_args -> 'a list 98 | 99 | val is_cst_args : 'a variant_args -> bool 100 | 101 | (**/**) 102 | 103 | module Internal : sig 104 | (** Internally used helper functions *) 105 | 106 | val create_variant_type 107 | : string -> 108 | t list -> 109 | (t -> (string * properties * t variant_args) list * variant_repr) -> 110 | t 111 | 112 | val create_record_type 113 | : string -> 114 | t list -> 115 | (t -> (string * properties * t) list * record_repr) -> 116 | t 117 | 118 | val create_node : string -> t list -> node 119 | 120 | val set_node_variant 121 | : node -> 122 | (string * properties * t variant_args) list * variant_repr -> 123 | unit 124 | 125 | val set_node_record 126 | : node -> 127 | (string * properties * t) list * record_repr -> 128 | unit 129 | 130 | val hash0 : t -> int 131 | (** This hash function ignores paths and properties. It remembers only the 132 | * ordered list of constructors names (with arity) and field labels. It 133 | * memoized the hash value of nodes. *) 134 | 135 | val hash0_node : node -> int 136 | 137 | val hash : ignore_props:bool -> ignore_path:bool -> t -> int 138 | 139 | val equal : ignore_props:bool -> ignore_path:bool -> t -> t -> bool 140 | (** The function returned (after passing the two named arguments) is memoized. 141 | * *) 142 | 143 | val has_var : t -> bool 144 | 145 | val substitute : t array -> t -> t 146 | (** Substitute all the DT_var nodes in the second arguments with elements of 147 | the array. *) 148 | 149 | val normalize : ignore_props:bool -> ignore_path:bool -> t -> t 150 | (** The function returned (after passing the two named arguments) is memoized. 151 | * *) 152 | 153 | val remove_props : t -> t 154 | (** This function is memoized. *) 155 | 156 | val set_memoized : node -> memoized_type_prop array -> unit 157 | end 158 | 159 | (**/**) 160 | 161 | module Textual : sig 162 | type stype = t 163 | (** This module defines a tree representation isomorphic to the internal 164 | graphs. This form is useful for printing and storing stypes. *) 165 | 166 | type t = int gtype 167 | 168 | type node = 169 | | Variant of 170 | string 171 | * t list 172 | * (string * properties * t variant_args) list 173 | * variant_repr 174 | | Record of string * t list * (string * properties * t) list * record_repr 175 | 176 | type textual = { nodes: node array; t: t } 177 | 178 | val export : stype -> textual 179 | 180 | val export_with_digests : stype -> textual * string array 181 | 182 | val import : textual -> stype 183 | 184 | val import_table : textual -> string array -> stype array 185 | end 186 | -------------------------------------------------------------------------------- /lib/ttype.ml: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | type 'a t = Stype.t 9 | 10 | type dynamic = Dyn : 'a t * 'a -> dynamic 11 | 12 | let to_stype : _ t -> Stype.t = fun a -> a 13 | 14 | let print fmt t = Format.fprintf fmt "%a" Stype.print (to_stype t) 15 | 16 | let remove_outer_props = Stype.remove_outer_props 17 | 18 | let consume_outer_props = Stype.consume_outer_props 19 | 20 | let add_props props t = Stype.DT_prop (props, t) 21 | 22 | let split_arrow t = 23 | match remove_outer_props t with 24 | | DT_arrow (_, t1, t2) -> (t1, t2) 25 | | _ -> assert false 26 | 27 | let build_arrow t1 t2 = Stype.DT_arrow ("", t1, t2) 28 | 29 | let fst = function Stype.DT_tuple [ t; _ ] -> t | _ -> assert false 30 | 31 | let snd = function Stype.DT_tuple [ _; t ] -> t | _ -> assert false 32 | 33 | let abstract_name t = 34 | match Stype.remove_outer_props t with 35 | | DT_abstract (name, _) -> Some name 36 | | _ -> None 37 | 38 | let equality t1 t2 = 39 | if Stype.equality t1 t2 then Some (Obj.magic TypEq.refl) else None 40 | 41 | let equality_modulo_props t1 t2 = 42 | if Stype.equality_modulo_props t1 t2 then Some (Obj.magic TypEq.refl) 43 | else None 44 | 45 | type is_t = Ttype : 'a t -> is_t 46 | 47 | let of_stype s = Ttype (Obj.magic s) 48 | 49 | let t a = 50 | let t = to_stype a in 51 | Stype.DT_abstract ("Lrt.Ttype.t", [ t ]) |> Obj.magic 52 | -------------------------------------------------------------------------------- /lib/ttype.mli: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | (** Typed representation of types. *) 9 | 10 | type 'a t 11 | 12 | val t : 'a t -> 'a t t 13 | 14 | val print : Format.formatter -> 'a t -> unit 15 | 16 | (** A dynamically typed value. *) 17 | type dynamic = Dyn : 'a t * 'a -> dynamic 18 | 19 | val equality : 'a t -> 'b t -> ('a, 'b) TypEq.t option 20 | 21 | val equality_modulo_props : 'a t -> 'b t -> ('a, 'b) TypEq.t option 22 | 23 | (** {3 Access information in types} *) 24 | 25 | val split_arrow : ('a -> 'b) t -> 'a t * 'b t 26 | 27 | val build_arrow : 'a t -> 'b t -> ('a -> 'b) t 28 | 29 | val fst : ('a * 'b) t -> 'a t 30 | 31 | val snd : ('a * 'b) t -> 'b t 32 | 33 | val abstract_name : 'a t -> string option 34 | 35 | (** {3 Porperties } *) 36 | 37 | val remove_outer_props : 'a t -> 'a t 38 | (** Remove properties from a ttype. If properties are nested, all are removed.*) 39 | 40 | val consume_outer_props : 'a t -> Stype.properties * 'a t 41 | (** Read the properties from a ttype and returns a ttype that is not a property 42 | node. If properties are nested, the innermost properties are at the 43 | beginning of the return list. 44 | 45 | In the sense of this function the following types [s] and [t] carry the same 46 | list of properties. 47 | {[ 48 | type s' = int [@prop {a = "b"; b = "c"}] [@@deriving t] 49 | type s = s' [@prop {c = "d"; d = "e"}] [@@deriving t] 50 | type t = int [@prop {a = "b"; b = "c"; c = "d"; d = "e"}] [@@deriving t] 51 | assert (fst (consume_outer_props s_t) = fst (consume_outer_props t)) 52 | ]} 53 | *) 54 | 55 | val add_props : Stype.properties -> 'a t -> 'a t 56 | 57 | (** {3 Conversion to/from stype} *) 58 | 59 | type is_t = Ttype : 'a t -> is_t 60 | 61 | val of_stype : Stype.t -> is_t 62 | 63 | val to_stype : _ t -> Stype.t 64 | -------------------------------------------------------------------------------- /lib/typEq.ml: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | type (_, _) t = Eq : ('a, 'a) t 9 | 10 | let refl = Eq 11 | 12 | let trans (type a b c) (Eq : (a, b) t) (Eq : (b, c) t) : (a, c) t = Eq 13 | 14 | let sym (type a b) (Eq : (a, b) t) : (b, a) t = Eq 15 | 16 | let app (type a b) (Eq : (a, b) t) (x : a) : b = x 17 | 18 | module Lift (T : sig 19 | type 'a c 20 | end) = 21 | struct 22 | let eq (type a b) (Eq : (a, b) t) : (a T.c, b T.c) t = Eq 23 | end 24 | -------------------------------------------------------------------------------- /lib/typEq.mli: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | (** Type equalities. *) 9 | 10 | (** A value of type [('a, 'b) t] is a witness that the two types ['a] and ['b] 11 | are equal. *) 12 | type (_, _) t = Eq : ('a, 'a) t 13 | 14 | val refl : ('a, 'a) t 15 | 16 | val trans : ('a, 'b) t -> ('b, 'c) t -> ('a, 'c) t 17 | 18 | val sym : ('a, 'b) t -> ('b, 'a) t 19 | 20 | val app : ('a, 'b) t -> 'a -> 'b 21 | 22 | module Lift (T : sig 23 | type 'a c 24 | end) : sig 25 | val eq : ('a, 'b) t -> ('a T.c, 'b T.c) t 26 | end 27 | -------------------------------------------------------------------------------- /lib/unify.ml: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | module type T0 = sig 9 | type t 10 | 11 | val t : t Ttype.t 12 | end 13 | 14 | let t0 (type t) (t : t Ttype.t) = 15 | (module struct 16 | type nonrec t = t [@@deriving t] 17 | end : T0 18 | with type t = t 19 | ) 20 | 21 | module type T1 = sig 22 | type 'a t 23 | 24 | val t : 'a Ttype.t -> 'a t Ttype.t 25 | end 26 | 27 | module type T2 = sig 28 | type ('a, 'b) t 29 | 30 | val t : 'a Ttype.t -> 'b Ttype.t -> ('a, 'b) t Ttype.t 31 | end 32 | 33 | module type PARAM = sig 34 | val modulo_props : bool 35 | end 36 | 37 | let init ~modulo_props = 38 | (module struct 39 | let modulo_props = modulo_props 40 | end : PARAM 41 | ) 42 | 43 | (* unification of stypes *) 44 | 45 | exception Not_unifiable 46 | 47 | let rec unify_list_iter2 f l1 l2 = 48 | match (l1, l2) with 49 | | [], [] -> () 50 | | [], _ | _, [] -> raise Not_unifiable 51 | | h1 :: t1, h2 :: t2 -> 52 | f h1 h2; 53 | unify_list_iter2 f t1 t2 54 | 55 | let variant_constrs_iter2 (f : Stype.t -> Stype.t -> unit) 56 | (name1, props1, vargs1) (name2, props2, vargs2) 57 | = 58 | if name1 <> name2 then raise Not_unifiable; 59 | if props1 <> props2 then raise Not_unifiable; 60 | match (vargs1, vargs2) with 61 | | Stype.C_inline s1, Stype.C_inline s2 -> f s1 s2 62 | | C_tuple l1, C_tuple l2 -> unify_list_iter2 f l1 l2 63 | | C_inline _, _ | C_tuple _, _ -> raise Not_unifiable 64 | 65 | (* iterate over all stypes in a node *) 66 | (* TODO: This is a much stricter compare than the one in Matcher. 67 | Perhaps, one might relax this a bit and document the assumptions. *) 68 | let node_iter2 (f : Stype.t -> Stype.t -> unit) 69 | ({ rec_descr = descr1; rec_name = name1; rec_args = args1; _ } : Stype.node) 70 | ({ rec_descr = descr2; rec_name = name2; rec_args = args2; _ } : Stype.node) 71 | = 72 | if name1 <> name2 then raise Not_unifiable; 73 | unify_list_iter2 f args1 args2; 74 | match (descr1, descr2) with 75 | | ( DT_variant { variant_constrs = c1; variant_repr = r1 }, 76 | DT_variant { variant_constrs = c2; variant_repr = r2 } ) 77 | when r1 = r2 -> 78 | unify_list_iter2 (variant_constrs_iter2 f) c1 c2 79 | | ( DT_record { record_fields = l1; record_repr = r1 }, 80 | DT_record { record_fields = l2; record_repr = r2 } ) 81 | when r1 = r2 -> 82 | unify_list_iter2 83 | (fun (name1, props1, s1) (name2, props2, s2) -> 84 | if name1 <> name2 then raise Not_unifiable; 85 | if props1 <> props2 then raise Not_unifiable; 86 | f s1 s2) 87 | l1 l2 88 | | DT_record _, _ | DT_variant _, _ -> raise Not_unifiable 89 | 90 | let unify ~modulo_props nfree t1 t2 = 91 | let subs = Array.make nfree None 92 | and equal = 93 | if modulo_props then 94 | (* TODO: It would be ideal if this equality raised on DT_var *) 95 | Stype.equality_modulo_props 96 | else Stype.equality 97 | and s1 = Ttype.to_stype t1 98 | and s2 = Ttype.to_stype t2 in 99 | let rec unify s1 s2 = 100 | let set v s = 101 | match subs.(v) with 102 | | None -> subs.(v) <- Some s 103 | | Some s' -> if not (equal s s') then raise Not_unifiable 104 | in 105 | match ((s1, s2) : Stype.t * Stype.t) with 106 | | _, DT_var _ -> raise (Invalid_argument "unify: free variable in ttype") 107 | | DT_var k, s2 -> set k s2 108 | | DT_int, DT_int | DT_float, DT_float | DT_string, DT_string -> () 109 | | DT_option s1, DT_option s2 110 | | DT_list s1, DT_list s2 111 | | DT_array s1, DT_array s2 -> 112 | unify s1 s2 113 | | DT_tuple l1, DT_tuple l2 -> unify_list_iter2 unify l1 l2 114 | | DT_node n1, DT_node n2 -> node_iter2 unify n1 n2 115 | | DT_arrow (n1, s1, s1'), DT_arrow (n2, s2, s2') -> 116 | if n1 <> n2 then raise Not_unifiable; 117 | unify s1 s2; 118 | unify s1' s2' 119 | | DT_object l1, DT_object l2 -> 120 | unify_list_iter2 121 | (fun (n1, s1) (n2, s2) -> 122 | if n1 <> n2 then raise Not_unifiable; 123 | unify s1 s2) 124 | l1 l2 125 | | DT_abstract (n1, l1), DT_abstract (n2, l2) -> 126 | if n1 <> n2 then raise Not_unifiable; 127 | unify_list_iter2 unify l1 l2 128 | | DT_prop (_, t1), t2 when modulo_props -> unify t1 t2 129 | | t1, DT_prop (_, t2) when modulo_props -> unify t1 t2 130 | | DT_prop (p1, t1), DT_prop (p2, t2) when p1 = p2 -> unify t1 t2 131 | | DT_prop _, _ 132 | | DT_int, _ 133 | | DT_float, _ 134 | | DT_string, _ 135 | | DT_option _, _ 136 | | DT_list _, _ 137 | | DT_array _, _ 138 | | DT_tuple _, _ 139 | | DT_node _, _ 140 | | DT_arrow _, _ 141 | | DT_object _, _ 142 | | DT_abstract _, _ -> 143 | raise Not_unifiable 144 | in 145 | unify s1 s2; 146 | subs 147 | 148 | (* Use stype unification & magic to satisfy interface *) 149 | 150 | let ttype : type a. Stype.t option -> a Ttype.t = function 151 | | None -> Obj.magic Std.unit_t 152 | (* Unification succeeded, but type variable was 153 | not used. *) 154 | | Some s -> Obj.magic s 155 | 156 | (* Unification succeeded by instantiating type 157 | variable with stype s. *) 158 | 159 | module U0 (P : PARAM) (A : T0) (B : T0) = struct 160 | include A 161 | include P 162 | 163 | type t' = B.t 164 | 165 | let eq : (t, t') TypEq.t = 166 | match unify ~modulo_props 0 t B.t with 167 | | [||] -> Obj.magic TypEq.refl 168 | | _ -> assert false 169 | end 170 | 171 | type var 172 | 173 | let var i : var Ttype.t = Obj.magic (Stype.DT_var i) 174 | 175 | let v0 = var 0 176 | 177 | let v1 = var 1 178 | 179 | module U1 (P : PARAM) (A : T1) (B : T0) = struct 180 | include A 181 | include P 182 | 183 | type t' = B.t 184 | 185 | type a 186 | 187 | let (a_t : a Ttype.t), (eq : (a t, t') TypEq.t) = 188 | match unify ~modulo_props 1 (t v0) B.t with 189 | | [| a |] -> (ttype a, Obj.magic TypEq.refl) 190 | | _ -> assert false 191 | end 192 | 193 | module U2 (P : PARAM) (A : T2) (B : T0) = struct 194 | include A 195 | include P 196 | 197 | type t' = B.t 198 | 199 | type a 200 | 201 | type b 202 | 203 | let (a_t : a Ttype.t), (b_t : b Ttype.t), (eq : ((a, b) t, t') TypEq.t) = 204 | match unify ~modulo_props 2 (t v0 v1) B.t with 205 | | [| a; b |] -> (ttype a, ttype b, Obj.magic TypEq.refl) 206 | | _ -> assert false 207 | end 208 | -------------------------------------------------------------------------------- /lib/unify.mli: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | (** Unification of runtime types. *) 9 | 10 | (** {3 Types with free variables} *) 11 | 12 | module type T0 = sig 13 | type t [@@deriving t] 14 | end 15 | 16 | val t0 : 'a Ttype.t -> (module T0 with type t = 'a) 17 | 18 | module type T1 = sig 19 | type 'a t [@@deriving t] 20 | end 21 | 22 | module type T2 = sig 23 | type ('a, 'b) t [@@deriving t] 24 | end 25 | 26 | (** {3 Unification} *) 27 | 28 | module type PARAM = sig 29 | val modulo_props : bool 30 | end 31 | 32 | (* TODO: might be part of the second argument (B: T0) *) 33 | 34 | val init : modulo_props:bool -> (module PARAM) 35 | (** The unification algorithm can be parametrized. Currently, the only parameter 36 | is [modulo_props]. It allows the user to specify whether properties are 37 | ignored or interpreted as distinguishing feature of the types. *) 38 | 39 | exception Not_unifiable 40 | (** Is raised by the following functors whenever unification is not possible. *) 41 | 42 | module U0 (P : PARAM) (A : T0) (B : T0) : sig 43 | include T0 with type t = A.t 44 | 45 | type t' = B.t 46 | 47 | val eq : (t, t') TypEq.t 48 | end 49 | 50 | module U1 (P : PARAM) (A : T1) (B : T0) : sig 51 | include T1 with type 'a t = 'a A.t 52 | 53 | type t' = B.t 54 | 55 | type a [@@deriving t] 56 | 57 | (** When [P.modulo_props] is true, we cannot guarantee that [a_t] carries the 58 | expected properties. *) 59 | 60 | val eq : (a t, t') TypEq.t 61 | end 62 | 63 | module U2 (P : PARAM) (A : T2) (B : T0) : sig 64 | include T2 with type ('a, 'b) t = ('a, 'b) A.t 65 | 66 | type t' = B.t 67 | 68 | type a [@@deriving t] 69 | 70 | type b [@@deriving t] 71 | 72 | (** When [P.modulo_props] is true, we cannot guarantee that [a_t] and [b_t] 73 | carry the expected properties. *) 74 | 75 | val eq : ((a, b) t, t') TypEq.t 76 | end 77 | -------------------------------------------------------------------------------- /lib/utf8.ml: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | (* 9 | This file is a simplified version of the UTF8 module found in CDUCE: 10 | http://www.cduce.org/cgi-bin/viewcvs.cgi/cduce/trunk/misc/encodings.ml?revision=1956&view=markup 11 | *) 12 | 13 | let store b p = 14 | (* Adapted from Netstring's netconversion.ml/write_utf8 *) 15 | if p <= 127 then Buffer.add_char b (Char.chr p) 16 | else if p <= 0x7ff then ( 17 | Buffer.add_char b (Char.chr (0xc0 lor (p lsr 6))); 18 | Buffer.add_char b (Char.chr (0x80 lor (p land 0x3f))) 19 | ) 20 | else if p <= 0xffff then ( 21 | (* Refuse writing surrogate pairs, and fffe, ffff *) 22 | if (p >= 0xd800 && p < 0xe000) || p >= 0xfffe then 23 | failwith "Encodings.Utf8.store"; 24 | Buffer.add_char b (Char.chr (0xe0 lor (p lsr 12))); 25 | Buffer.add_char b (Char.chr (0x80 lor ((p lsr 6) land 0x3f))); 26 | Buffer.add_char b (Char.chr (0x80 lor (p land 0x3f))) 27 | ) 28 | else if p <= 0x10ffff then ( 29 | Buffer.add_char b (Char.chr (0xf0 lor (p lsr 18))); 30 | Buffer.add_char b (Char.chr (0x80 lor ((p lsr 12) land 0x3f))); 31 | Buffer.add_char b (Char.chr (0x80 lor ((p lsr 6) land 0x3f))); 32 | Buffer.add_char b (Char.chr (0x80 lor (p land 0x3f))) 33 | ) 34 | else 35 | (* Higher code points are not possible in XML: *) 36 | failwith "Encodings.Utf8.store" 37 | 38 | let rec mk_latin1_aux buf s i n = 39 | if i = n then () 40 | else ( 41 | store buf (Char.code s.[i]); 42 | mk_latin1_aux buf s (succ i) n 43 | ) 44 | 45 | let of_latin1 s = 46 | let b = Buffer.create (String.length s) in 47 | mk_latin1_aux b s 0 (String.length s); 48 | Buffer.contents b 49 | 50 | let next s i = 51 | let fail () = failwith "Malformed UTF-8 buffer" in 52 | let check i = 53 | let n = Char.code s.[i] in 54 | if n lsr 6 <> 0b10 then fail () else n 55 | in 56 | try 57 | match s.[!i] with 58 | | '\000' .. '\127' as c -> 59 | let n = Char.code c in 60 | i := !i + 1; 61 | Uchar.of_int n 62 | | '\192' .. '\223' as c -> 63 | let n1 = Char.code c in 64 | let n2 = check (!i + 1) in 65 | let n = ((n1 land 0b11111) lsl 6) lor (n2 land 0b111111) in 66 | i := !i + 2; 67 | Uchar.of_int n 68 | | '\224' .. '\239' as c -> 69 | let n1 = Char.code c in 70 | let n2 = check (!i + 1) in 71 | let n3 = check (!i + 2) in 72 | let n = 73 | ((n1 land 0b1111) lsl 12) 74 | lor ((n2 land 0b111111) lsl 6) 75 | lor (n3 land 0b111111) 76 | in 77 | i := !i + 3; 78 | Uchar.of_int n 79 | | '\240' .. '\247' as c -> 80 | let n1 = Char.code c in 81 | let n2 = check (!i + 1) in 82 | let n3 = check (!i + 2) in 83 | let n4 = check (!i + 3) in 84 | let n = 85 | ((n1 land 0b111) lsl 18) 86 | lor ((n2 land 0b111111) lsl 12) 87 | lor ((n3 land 0b111111) lsl 6) 88 | lor (n4 land 0b111111) 89 | in 90 | i := !i + 4; 91 | Uchar.of_int n 92 | | _ -> fail () 93 | with Invalid_argument _ -> fail () 94 | 95 | let to_string_aux buf s i n = 96 | let i = ref i in 97 | while !i <> n do 98 | let c = Uchar.to_int (next s i) in 99 | if c <= 255 then Buffer.add_char buf (Char.chr c) 100 | else Printf.bprintf buf "\\%i;" c 101 | (* or fail? *) 102 | done 103 | 104 | let to_latin1 s = 105 | let l = String.length s in 106 | let b = Buffer.create l in 107 | to_string_aux b s 0 l; 108 | Buffer.contents b 109 | 110 | let is_valid s = 111 | let off = ref 0 in 112 | try 113 | while !off < String.length s do 114 | ignore (next s off) 115 | done; 116 | true 117 | with Failure _ -> false 118 | -------------------------------------------------------------------------------- /lib/utf8.mli: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | val of_latin1 : string -> string 9 | (** Converts a latin1 string to utf-8. *) 10 | 11 | val to_latin1 : string -> string 12 | (** Converts a utf-8 string to latin1. Characters which cannot be represented 13 | in latin1 are escaped in a special way. *) 14 | 15 | val next : string -> int ref -> Uchar.t 16 | (** [next s i] tries to decode a utf8 code point at position [i] in [s]. If 17 | successful, return the value of code point and updates [i] with the position 18 | of the next code point. Otherwise, raise [Failure _]. *) 19 | 20 | val is_valid : string -> bool 21 | (** [is_valid s] returns whether [s] is a valid UTF-8 string. *) 22 | -------------------------------------------------------------------------------- /lib/variant.mli: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | (** Ocaml syntax compatible representation of values. 9 | 10 | Values can be converted to and from variants using {!to_variant} and 11 | {!of_variant}. *) 12 | 13 | type t = Variant_lexer.t = 14 | | Unit 15 | | Bool of bool 16 | | Int of int 17 | | Float of float 18 | | String of string 19 | | Tuple of t list 20 | | List of t list 21 | | Array of t array 22 | | Option of t option 23 | | Record of (string * t) list 24 | | Constructor of string * t option 25 | | Variant of t 26 | | Lazy of t Lazy.t 27 | [@@deriving t] 28 | 29 | val to_variant : t:'a Ttype.t -> 'a -> t 30 | (** 31 | Transform a typed value into a variant. 32 | 33 | One may write, for instance, [variant (45, "hello")], in place of 34 | [V_tuple[V_int 45; V_string "hello"]]. 35 | 36 | Note: variantizing constructors named "None" or "Some" (but not part 37 | of the "option" type) can result in unexpected behavior if the variant 38 | go through a roundtrip with textual syntax. 39 | 40 | May raise the [Failure] exception if the value cannot be 41 | variantized. 42 | *) 43 | 44 | exception Bad_type_for_variant of Stype.t * t * string 45 | 46 | val of_variant : t:'a Ttype.t -> t -> 'a 47 | (** Rebuild a typed value from a variant. May raise [Bad_type_for_variant] 48 | if [t] does not match the type of the variant or [Failure] if e.g. a value 49 | of an abstract type needs to be rebuilt but there is no registered 50 | de-variantizer. 51 | *) 52 | 53 | (** {3 (De)Serialization} *) 54 | 55 | val print_variant : Format.formatter -> t -> unit 56 | (** Print a variant with the syntax of MLFi constants. *) 57 | 58 | val strings_of_variant : t -> string list 59 | (** Return a list of "string"-like components found inside the variant; useful 60 | to implement generic textual search. *) 61 | 62 | val string_one_line_of_variant : t -> string 63 | (** Return a textual representation of a variant, with the syntax 64 | of MLFi constants, on one line. Same behavior with respect 65 | to exceptions than [compact_string_of_variant]. *) 66 | 67 | val compact_string_of_variant 68 | : ?dont_compress_records:unit -> 69 | ?with_more_spaces:unit -> 70 | t -> 71 | string 72 | (** Similar to {!string_one_line_of_variant}, but use a more compact 73 | form, with fewer whitespaces, and a special syntax for lists and arrays of 74 | records (unless the [dont_compress_records] flag is used). The result is 75 | guaranteed to not contain any newline characters. If the variant 76 | contains a lazy which raises an exception, the function fails and raises 77 | that exception. 78 | *) 79 | 80 | val output_compact_string_of_variant 81 | : ?dont_compress_records:unit -> 82 | ?with_more_spaces:unit -> 83 | out_channel -> 84 | t -> 85 | unit 86 | (** Same as compact_string_of_variant, but write the result into a file. *) 87 | 88 | val variant_to_file : ?eol_lf:unit -> string -> t -> unit 89 | (** Write a variant to a text file. *) 90 | 91 | val value_to_variant_in_file 92 | : t:'a Ttype.t -> 93 | ?eol_lf:unit -> 94 | string -> 95 | 'a -> 96 | unit 97 | (** Write a value as a variant to a text file. *) 98 | 99 | exception Variant_parser of { msg: string; text: string; loc: string } 100 | (** Raised when an exception is raised by the variant parser. 101 | [msg] contains the error message; [text] is the fragment 102 | of source showing the error; [loc] is a description of the 103 | error location *) 104 | 105 | val variant_of_string : string -> t 106 | (** Parse a textual representation of a variant (produced e.g. by 107 | {!string_one_line_of_variant} from a string. *) 108 | 109 | val variant_of_file : string -> t 110 | (** Parse a textual representation of a variant (produced e.g. by 111 | {!string_one_line_of_variant} from a text file. *) 112 | 113 | val value_of_variant_in_file : t:'a Ttype.t -> string -> 'a 114 | (** Read a value as a variant from a text file. *) 115 | 116 | (** {3 Variant mapper} *) 117 | 118 | (** Lexifi has documentation on how to use mappers and the other properties. 119 | This should go here *) 120 | 121 | val of_variant_custom 122 | : ?name:string -> 123 | t:'a Ttype.t -> 124 | (t -> 'a option) -> 125 | 'a Ttype.t 126 | (** [of_variant_custom ~t custom] returns a modified [t] such that 127 | [of_variant ~t v] uses [custom v] as fallback when the normal 128 | devariantization fails with [Bad_type_for_variant]. 129 | 130 | Multiple custom devariantizers can be registered. They will be applied in 131 | order of registration. 132 | 133 | Exception {!Bad_type_for_variant} raised by [custom] are caught and 134 | interpreted as failed attempt to apply the custom devariantizer. If other 135 | custom devariantizers are registered, they will be tried next. Otherwise, 136 | the original {!Bad_type_for_variant} exception is raised. 137 | 138 | All other exceptions raised by [custom] are transformed into a string, 139 | prefixed with the optional [name] argument and re-raised as [Failure]. 140 | 141 | The following example shows how to handle the transition from [type t = int] 142 | to [type t = int * string]: 143 | {[ 144 | type t = int * string [@@deriving t] 145 | let t = of_variant_custom ~name:"int to (int * string)" ~t (function 146 | | Int i -> Some (i, string_of_int i) 147 | | _ -> None 148 | )]} 149 | *) 150 | 151 | val of_variant_mapper 152 | : ?name:string -> 153 | t:'a Ttype.t -> 154 | (t -> t option) -> 155 | 'a Ttype.t 156 | (** [of_variant_mapper ~t mapper] returns a modified [t] such that 157 | [of_variant ~t] uses [mapper] as fallback mechanism when the normal 158 | conversion fails. 159 | 160 | This is a wrapper for {!of_variant_custom}: 161 | {[ 162 | let of_variant_mapper ?name ~t mapper = 163 | let custom v = 164 | match mapper v with 165 | | None -> None 166 | | Some v' -> Some (of_variant ~t v') 167 | in of_variant_custom ?name ~t custom 168 | ]} 169 | *) 170 | 171 | val of_variant_default 172 | : ?name:string -> 173 | t:'a Ttype.t -> 174 | (unit -> 'a) -> 175 | 'a Ttype.t 176 | (** [of_variant_default ~t init] returns a modified [t] such that 177 | [of_variant ~t] uses [init ()] as default value when the normal conversion 178 | fails. 179 | 180 | This is a wrapper for {!of_variant_custom}: 181 | {[ 182 | let of_variant_default ?name ~t init = 183 | let custom _v = Some (init ()) in 184 | of_variant_custom ?name ~t custom 185 | ]} 186 | *) 187 | 188 | (** {3 Handle abstract types} *) 189 | 190 | type 'a to_variant = 'a -> t 191 | 192 | type 'a of_variant = t -> 'a 193 | 194 | type failwith = { failwith: 'a. string -> 'a } [@@unboxed] 195 | (** [failwith s] raises {!Bad_type_for_variant} with the corresponding stype 196 | and variant inserted. *) 197 | 198 | module type VARIANTIZABLE_0 = sig 199 | include Unify.T0 200 | 201 | val to_variant : t to_variant 202 | 203 | val of_variant : failwith -> t of_variant 204 | end 205 | 206 | module type VARIANTIZABLE_1 = sig 207 | include Unify.T1 208 | 209 | val to_variant : 'a to_variant -> 'a t to_variant 210 | 211 | val of_variant : failwith -> 'a of_variant -> 'a t of_variant 212 | end 213 | 214 | module type VARIANTIZABLE_2 = sig 215 | include Unify.T2 216 | 217 | val to_variant : 'a to_variant -> 'b to_variant -> ('a, 'b) t to_variant 218 | 219 | val of_variant 220 | : failwith -> 221 | 'a of_variant -> 222 | 'b of_variant -> 223 | ('a, 'b) t of_variant 224 | end 225 | 226 | (** The following raise [Failure] on non-abstract types. *) 227 | 228 | val add_abstract_0 : (module VARIANTIZABLE_0) -> unit 229 | 230 | val add_abstract_1 : (module VARIANTIZABLE_1) -> unit 231 | 232 | val add_abstract_2 : (module VARIANTIZABLE_2) -> unit 233 | -------------------------------------------------------------------------------- /lib/variant_lexer.mli: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | (** Variant parsing *) 9 | 10 | type t = 11 | | Unit 12 | | Bool of bool 13 | | Int of int 14 | | Float of float 15 | | String of string 16 | | Tuple of t list 17 | | List of t list 18 | | Array of t array 19 | | Option of t option 20 | | Record of (string * t) list 21 | | Constructor of string * t option 22 | | Variant of t 23 | | Lazy of t Lazy.t 24 | 25 | type error = 26 | | Unterminated_string 27 | | Unterminated_string_in_comment 28 | | Unterminated_comment 29 | | Illegal_escape of string 30 | | Literal_overflow of string 31 | | Illegal_date_value 32 | | Illegal_character of char 33 | | Syntax_error (** Errors reported during variant lexing *) 34 | 35 | exception Error of { msg: string; text: string; loc: string } 36 | (** Raised when an exception is raised by the variant parser. 37 | [msg] contains the error message; [text] is the fragment 38 | of source showing the error; [loc] is a description of the 39 | error location *) 40 | 41 | val variant_of_string : string -> t 42 | (** Parse a textual representation of a variant (produced e.g. by 43 | {!Mlfi_isdatypes.string_one_line_of_variant} from a string. *) 44 | 45 | val variant_of_file : string -> t 46 | (** Parse a textual representation of a variant (produced e.g. by 47 | {!Mlfi_isdatypes.string_one_line_of_variant} from a text file. *) 48 | -------------------------------------------------------------------------------- /lib/xtype.mli: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | (** Visitable representation of types. *) 9 | 10 | type record_repr = Regular | Float | Unboxed 11 | 12 | type constr_repr = Tag of int | Unboxed 13 | 14 | type 'a t = private { t: 'a Ttype.t; xt: 'a xtype Lazy.t } 15 | 16 | and 'a xtype = private 17 | | Unit : unit xtype 18 | | Bool : bool xtype 19 | | Int : int xtype 20 | | Float : float xtype 21 | | String : string xtype 22 | | Char : char xtype 23 | | Int32 : int32 xtype 24 | | Int64 : int64 xtype 25 | | Nativeint : nativeint xtype 26 | | List : 'b t -> 'b list xtype 27 | | Option : 'b t -> 'b option xtype 28 | | Array : 'b t -> 'b array xtype 29 | | Lazy : 'b t -> 'b Lazy.t xtype 30 | | Tuple : 'a tuple -> 'a xtype 31 | | Record : 'a record -> 'a xtype 32 | | Sum : 'a sum -> 'a xtype 33 | | Function : ('b, 'c) arrow -> ('b -> 'c) xtype 34 | | Object : 'a object_ -> 'a xtype 35 | | Prop : (Stype.properties * 'a t) -> 'a xtype 36 | | Abstract : (string * Stype.t list) -> 'a xtype 37 | 38 | and ('s, 't) element = private { typ: 't t; nth: int } 39 | 40 | and 's field = private Field : ('s, 't) element -> 's field 41 | 42 | and 's tuple = private { t_flds: 's field list; t_len: int } 43 | 44 | and label = string * Stype.properties 45 | 46 | and 's record_field = label * 's field 47 | 48 | and 's record = private { 49 | r_flds: 's record_field list; 50 | r_len: int; 51 | r_repr: record_repr; 52 | r_lookup: string -> 's record_field option; 53 | } 54 | 55 | and 's constant_constructor = private { cc_label: label; cc_nr: int } 56 | 57 | and ('s, 't) regular_constructor = private { 58 | rc_label: label; 59 | rc_flds: 't field list; 60 | rc_len: int; 61 | rc_repr: constr_repr; 62 | } 63 | 64 | and ('s, 't) inlined_constructor = private { 65 | ic_label: label; 66 | ic_flds: 't record_field list; 67 | ic_len: int; 68 | ic_repr: constr_repr; 69 | ic_lookup: string -> 't record_field option; 70 | } 71 | 72 | and 's constructor = private 73 | | Constant : 's constant_constructor -> 's constructor 74 | | Regular : ('s, 't) regular_constructor -> 's constructor 75 | | Inlined : ('s, 't) inlined_constructor -> 's constructor 76 | 77 | and 's sum = private { 78 | s_cstrs: 's constructor list; 79 | s_lookup: string -> 's constructor option; 80 | s_cstr_by_value: 's -> 's constructor; 81 | } 82 | 83 | and ('s, 't) arrow = private { 84 | arg_label: string option; 85 | arg_t: 's t; 86 | res_t: 't t; 87 | } 88 | 89 | and 's method_ = private Method : string * ('s, 't) element -> 's method_ 90 | 91 | and 's object_ = private { 92 | o_methods: 's method_ list; 93 | o_lookup: string -> 's method_ option; 94 | } 95 | 96 | (** {3 Initialization and transformation} *) 97 | 98 | val of_ttype : 'a Ttype.t -> 'a t 99 | (** Produce a representation of a runtime type, that is safer to inspect than 100 | the {!Stype.t} one. *) 101 | 102 | val xtype_of_ttype : 'a Ttype.t -> 'a xtype 103 | (** See {!of_ttype}. This produces the {!xtype} without wrapping it in {!t}. *) 104 | 105 | (* There is intentionally no [ttype_of_xtype] function. It would encourage 106 | bad style, i.e. forcing an {!xtype} too early and then going back to 107 | {!ttype}. *) 108 | 109 | val remove_outer_props : 'a t -> 'a t 110 | (** Strip the outer properties from the type. The result is guaranteed to be 111 | different from {!constructor:Prop}. *) 112 | 113 | val consume_outer_props : 'a t -> Stype.properties * 'a t 114 | (** See {!remove_outer_props}. This function additionally returns an 115 | accumulated list of the removed properties. The accumulation is 116 | associative, i.e. [ Prop ([a], Prop ([b, c], _)) ] yields the same list 117 | as [ Prop ([a, b], Prop ([c], _)) ]. *) 118 | 119 | (** {3 Destruction and construction of values} *) 120 | 121 | (** Read values from tuples, records and constructors. *) 122 | module Read : sig 123 | val tuple : 'a tuple -> ('a, 'b) element -> 'a -> 'b 124 | 125 | val record : 'a record -> ('a, 'b) element -> 'a -> 'b 126 | 127 | val regular_constructor 128 | : ('a, 'b) regular_constructor -> 129 | ('b, 'c) element -> 130 | 'a -> 131 | 'c option 132 | 133 | val inlined_constructor 134 | : ('a, 'b) inlined_constructor -> 135 | ('b, 'c) element -> 136 | 'a -> 137 | 'c option 138 | 139 | val call_method : 'a object_ -> ('a, 'b) element -> 'a -> 'b 140 | 141 | (** The following functions allow to map the values stored in a tuple, record, 142 | or constructor to a list. This supports partial application, i.e. 143 | [map_tuple tup f] results in a closure that can processes many values while 144 | calling [f] only once on the first value. 145 | *) 146 | 147 | type 'b mapf = { f: 'a. 'a t -> 'a -> 'b } [@@unboxed] 148 | (** TODO: Instead of the Xtype.t, [f] could also consume a {!field}. *) 149 | 150 | val map_tuple : 'a tuple -> 'b mapf -> 'a -> 'b list 151 | (** Map the values in a tuple to list. *) 152 | 153 | type 'b mapf' = { f: 'a. name:string -> 'a t -> 'a -> 'b } [@@unboxed] 154 | (** TODO: Instead of the name and type, [f] may as well consume a 155 | {!record_field}. *) 156 | 157 | val map_record : 'a record -> 'b mapf' -> 'a -> 'b list 158 | (** Map the values in a record to a list. *) 159 | 160 | (** The constructor's name and its mapped arguments. *) 161 | type ('a, 'b) mapped_sum = 162 | | Regular of string * 'a list 163 | | Inlined of string * 'b list 164 | | Constant of string 165 | 166 | val map_sum : 'a sum -> 'b mapf -> 'c mapf' -> 'a -> ('b, 'c) mapped_sum 167 | (** Map the values in a constructor to a list. *) 168 | end 169 | 170 | (** Building tuples, records and constructors. *) 171 | module Builder : sig 172 | (** The builder function [mk] is called for each field in the order of the 173 | fields list, i.e. in same order as they appear in the corresponding type 174 | definition. 175 | *) 176 | 177 | type 's t = { mk: 't. ('s, 't) element -> 't } [@@unboxed] 178 | 179 | type 's t' = { mk: 't. label -> ('s, 't) element -> 't } [@@unboxed] 180 | 181 | val tuple : 'a tuple -> 'a t -> 'a 182 | 183 | val record : 'a record -> 'a t' -> 'a 184 | 185 | val constant_constructor : 'a constant_constructor -> 'a 186 | 187 | val regular_constructor : ('a, 'b) regular_constructor -> 'b t -> 'a 188 | 189 | val inlined_constructor : ('a, 'b) inlined_constructor -> 'b t' -> 'a 190 | 191 | type generic = { mk: 's 't. ('s, 't) element -> 't } [@@unboxed] 192 | 193 | val constructor : 'a constructor -> generic -> 'a 194 | end 195 | 196 | (** Similar to {!Builder} but with active interface. *) 197 | module Make : sig 198 | (** Instead of providing a function to the builder, that is then called for 199 | each field of the block, this module lets the user actively set each 200 | field. 201 | *) 202 | 203 | exception Missing_field of string 204 | (** Raised if not all fields where set via {!set}. *) 205 | 206 | type 'a t 207 | (** An intermediate representation of a block. *) 208 | 209 | val set : 'a t -> ('a, 'b) element -> 'b -> unit 210 | (** Set a single field of a block. *) 211 | 212 | val tuple : 'a tuple -> ('a t -> unit) -> 'a 213 | 214 | val record : 'a record -> ('a t -> unit) -> 'a 215 | 216 | val regular_constructor : ('a, 'b) regular_constructor -> ('b t -> unit) -> 'a 217 | 218 | val inlined_constructor : ('a, 'b) inlined_constructor -> ('b t -> unit) -> 'a 219 | end 220 | 221 | (** More restrictive interface to {!Builder} that allows to build closures. *) 222 | module Assembler : sig 223 | (** The functions {!tuple}, {!record}, and {!sum} can be partially applied 224 | with the first two arguments. This results in efficient closures that 225 | call the function in {!asm} only once per field definition instead of once 226 | per processed value. 227 | *) 228 | 229 | type 'a asm = { f: 'b. 'b t -> 'a -> 'b } [@@unboxed] 230 | 231 | val tuple : 'a tuple -> 'b asm -> 'b list -> 'a 232 | (** The assembler consumes the provided list in order of the tuple elements.*) 233 | 234 | val record : 'a record -> 'b asm -> (string * 'b) list -> 'a 235 | (** The assembler is efficient, when the provided alist is in the correct 236 | order. If not, it falls back to {!List.assoc}. TODO: improve the fallback 237 | to use a table. *) 238 | 239 | type ('a, 'b) cstr = 240 | | Constant : 'a constant_constructor -> ('a, 'b) cstr 241 | | Regular : ('a, 'c) regular_constructor * 'b list -> ('a, 'b) cstr 242 | | Inlined : 243 | ('a, 'c) inlined_constructor * (string * 'b) list 244 | -> ('a, 'b) cstr 245 | 246 | val sum : 'a sum -> 'b asm -> ('a, 'b) cstr -> 'a 247 | (** The assembler uses the same mechanism as {!tuple} and {!sum}. *) 248 | end 249 | 250 | (** {3 Paths} 251 | 252 | Interop between runtime types and {!Path}. 253 | *) 254 | 255 | (** Build steps from elements. *) 256 | module Step : sig 257 | val tuple : 'a tuple -> ('a, 'b) element -> ('a, 'b) Path.step 258 | 259 | val record : 'a record -> ('a, 'b) element -> ('a, 'b) Path.step 260 | 261 | val regular_constructor 262 | : ('a, 'b) regular_constructor -> 263 | ('b, 'c) element -> 264 | ('a, 'c) Path.step 265 | 266 | val inlined_constructor 267 | : ('a, 'b) inlined_constructor -> 268 | ('b, 'c) element -> 269 | ('a, 'c) Path.step 270 | end 271 | 272 | val all_paths : 'a Ttype.t -> 'b Ttype.t -> ('a, 'b) Path.t list 273 | (** Returns all the paths leading to a value of type ['a] inside 274 | a value of type ['b]. Does not traverse list, array, lazy and objects. 275 | {e Will loop on recursive types.} *) 276 | 277 | val project_path : 'a Ttype.t -> ('a, 'b) Path.t -> 'b Ttype.t 278 | (** Extraction of sub-type pointed to by a path. *) 279 | -------------------------------------------------------------------------------- /lrt.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "lrt" 3 | version: "dev" 4 | synopsis: "LexiFi Runtime Types" 5 | description: """ 6 | It is often useful to get access to types at runtime in order to implement 7 | generic type-driven operations. A typical example is a generic 8 | pretty-printer. Unfortunately, the OCaml compiler does not keep type 9 | information at runtime. At LexiFi, we have extended OCaml to support runtime 10 | types. This extension has been in use for years and is now a key element in 11 | many of our interesting components, such as our automatic GUI framework 12 | (which derives GUIs from type definitions) or our high-level database layer 13 | (which derives SQL schema from type definitions, and exposes a well-typed 14 | interface for queries). This extension is tightly integrated with the OCaml 15 | typechecker, which allows the compiler to synthesize the runtime type 16 | representations with minimal input from the programmer. 17 | 18 | This package makes the features of our extension available to other OCaml 19 | users without relying on a modified compiler. Instead, it only relies on a 20 | PPX syntax extension that synthesizes the runtime representation of types 21 | from their syntactic definition with a deriving-like approach. 22 | 23 | Based on this new implementation we are able to open-source the 24 | infrastructure we have developed around the machinery of runtime types as 25 | well as libraries built upon them. 26 | """ 27 | maintainer: "LexiFi" 28 | authors: ["Patrik Keller , LexiFi"] 29 | homepage: "https://github.com/LexiFi/lrt/" 30 | bug-reports: "https://github.com/LexiFi/lrt/issues" 31 | dev-repo: "git+https://github.com/LexiFi/lrt.git" 32 | doc: "https://lexifi.github.io/dynt/dynt/lrt/index.html" 33 | license: "MIT" 34 | depends: [ 35 | "ocaml" { >= "4.06.1" } 36 | "ppx_expect" { build | with-test } 37 | "dune" { build } 38 | "landmarks" { build } 39 | "ppxlib" { build } 40 | ] 41 | build: [ 42 | ["dune" "runtest" "-p" name] { with-test } 43 | ["dune" "build" "@doc" "-p" name] { with-doc } 44 | ["dune" "build" "-p" name "-j" jobs] 45 | ] 46 | run-test: ["dune" "runtest" "-p" name] 47 | -------------------------------------------------------------------------------- /ppx/deriving/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name lrt_deriving) 3 | (public_name lrt.deriving) 4 | (synopsis "lrt [@@deriving t] syntax extension") 5 | (libraries ppxlib) 6 | (preprocess 7 | (pps ppxlib.metaquot)) 8 | (kind ppx_rewriter)) 9 | -------------------------------------------------------------------------------- /ppx/deriving/lrt_deriving.ml: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | (** The [\[@@deriving t\]] syntax extension. See {!Lrt}. *) 9 | 10 | (**/**) 11 | 12 | open Ppxlib 13 | open Ast_builder.Default 14 | 15 | (* Who are we? *) 16 | type ppx = { pp: string; id: string } 17 | 18 | let ppx = { pp = "[@@deriving t]"; id = "t" } 19 | 20 | let raise_errorf ~loc = 21 | Format.ksprintf (Location.raise_errorf ~loc "%s: %s" ppx.pp) 22 | 23 | (* Data stored between invocations of the ppx driver *) 24 | type cookies = { mutable libname: string option } 25 | 26 | let cookies = { libname = None } 27 | 28 | let () = 29 | Driver.Cookies.add_simple_handler "library-name" 30 | Ast_pattern.(estring __) 31 | ~f:(function x -> cookies.libname <- x) 32 | 33 | let qualifying_name ~path name = 34 | match cookies.libname with 35 | | None -> Format.sprintf "%s.%s" path name 36 | | Some lib -> Format.sprintf "%s#%s.%s" lib path name 37 | 38 | (* Declare attributes on type declarations, core types, 39 | record field labels and variant constructors *) 40 | 41 | let attr_prop ctx = 42 | let prop a b = 43 | pexp_tuple ~loc:a.loc [ estring ~loc:a.loc a.txt; estring ~loc:b.loc b.txt ] 44 | in 45 | Attribute.declare (ppx.id ^ ".prop") ctx 46 | Ast_pattern.( 47 | pair (lident __' |> loc) (estring __') 48 | |> map2 ~f:prop |> many 49 | |> (fun l -> pexp_record l none) 50 | ||| (pexp_apply (estring __') (no_label (estring __') ^:: nil) 51 | |> map2 ~f:prop |> elist 52 | ) 53 | ||| (pexp_apply (estring __') (no_label (estring __') ^:: nil) 54 | |> map2 ~f:prop 55 | |> map1 ~f:(fun x -> [ x ]) 56 | ) 57 | |> single_expr_payload) 58 | (fun l -> l) 59 | 60 | let attr_ct_prop = attr_prop Attribute.Context.core_type 61 | 62 | let attr_rf_prop = attr_prop Attribute.Context.label_declaration 63 | 64 | let attr_vc_prop = attr_prop Attribute.Context.constructor_declaration 65 | 66 | let attr_td_prop = attr_prop Attribute.Context.type_declaration 67 | 68 | let props_of_attr attr x = 69 | match Attribute.get attr x with None -> [] | Some l -> l 70 | 71 | let props_of_ct = props_of_attr attr_ct_prop 72 | 73 | let props_of_rf = props_of_attr attr_rf_prop 74 | 75 | let props_of_vc = props_of_attr attr_vc_prop 76 | 77 | let props_of_td = props_of_attr attr_td_prop 78 | 79 | type abstract = No | Auto | Name of label loc 80 | 81 | let attr_td_abstract = 82 | Attribute.declare (ppx.id ^ ".abstract") Attribute.Context.type_declaration 83 | Ast_pattern.( 84 | estring __' |> single_expr_payload 85 | |> map1 ~f:(fun s -> Name s) 86 | ||| (pstr nil |> map0 ~f:Auto)) 87 | (fun x -> x) 88 | 89 | let abstract_of_td td = 90 | match Attribute.get attr_td_abstract td with Some x -> x | None -> No 91 | 92 | let attr_ct_patch = 93 | Attribute.declare (ppx.id ^ ".patch") Attribute.Context.core_type 94 | Ast_pattern.(single_expr_payload __') 95 | (fun x -> x) 96 | 97 | let patch_of_ct ct = 98 | match Attribute.consume attr_ct_patch ct with 99 | | None -> (ct, None) 100 | | Some (ct, patch) -> (ct, Some patch) 101 | 102 | let attr_td_unboxed = 103 | Attribute.declare 104 | (ppx.id ^ ".ocaml.unboxed") 105 | Attribute.Context.type_declaration 106 | Ast_pattern.(pstr nil |> map0 ~f:()) 107 | (fun x -> x) 108 | 109 | let unboxed_of_td td = 110 | match Attribute.get attr_td_unboxed td with Some () -> true | None -> false 111 | 112 | (* generate regularly used AST fragments *) 113 | 114 | let ignore ~loc expr : expression -> expression = 115 | let pat = ppat_any ~loc in 116 | pexp_let ~loc Nonrecursive [ value_binding ~loc ~expr ~pat ] 117 | 118 | let lazy_value_binding ~loc txt typ expr = 119 | let (module M) = Ast_builder.make loc in 120 | let open M in 121 | let pat = 122 | ppat_constraint (ppat_var { loc; txt }) [%type: [%t typ] Ttype.t lazy_t] 123 | in 124 | let expr = ignore ~loc (evar txt) [%expr lazy [%e expr]] in 125 | value_binding ~pat ~expr 126 | 127 | let force_lazy ~loc var = [%expr force [%e var]] 128 | 129 | let stypes_of_free ~loc free = 130 | let (module M) = Ast_builder.make loc in 131 | let open M in 132 | List.mapi (fun i _v -> [%expr DT_var [%e eint i]]) free |> elist 133 | 134 | let lid_runtime = Longident.parse "Lrt_ppx_runtime.Types" 135 | 136 | let lid_ttype = Longident.parse "Lrt_ppx_runtime.Types.Ttype.t" 137 | 138 | let wrap_runtime ~loc = 139 | let expr = pmod_ident ~loc { txt = lid_runtime; loc } in 140 | pexp_open ~loc (open_infos ~loc ~expr ~override:Override) 141 | 142 | let wrap_props ~loc props t = 143 | match props with 144 | | [] -> t 145 | | l -> 146 | [%expr 147 | ttype_of_stype (DT_prop ([%e elist ~loc l], stype_of_ttype [%e t]))] 148 | 149 | (* check whether ttype is of a certain type and make it an stype *) 150 | let stype_of_ttype ({ ptyp_loc = loc; _ } as ct) expr = 151 | (* strip patch attribute *) 152 | let ct, _ = patch_of_ct ct and txt = lid_ttype in 153 | [%expr stype_of_ttype ([%e expr] : [%t ptyp_constr ~loc { loc; txt } [ ct ]])] 154 | 155 | (* mangle names *) 156 | 157 | let mangle_label = function 158 | | "t" -> ppx.id 159 | | s -> Format.sprintf "%s_%s" s ppx.id 160 | 161 | let mangle_lid = function 162 | | Lident s -> Lident (mangle_label s) 163 | | Ldot (t, s) -> Ldot (t, mangle_label s) 164 | | Lapply _ -> raise_errorf ~loc:Location.none "Internal error in mangle_lid" 165 | 166 | let mangle_label_loc t = { t with txt = mangle_label t.txt } 167 | 168 | let mangle_lid_loc t = { t with txt = mangle_lid t.txt } 169 | 170 | (* Read information from AST fragments *) 171 | 172 | type names = { qualifying: string; typ: string; ttyp: string; node: string } 173 | 174 | let free_vars_of_type_decl td = 175 | List.map 176 | (fun (ct, _variance) -> 177 | match ct.ptyp_desc with 178 | | Ptyp_var s -> s 179 | | _ -> raise_errorf ~loc:ct.ptyp_loc "This should be a type variable") 180 | td.ptype_params 181 | 182 | let names_of_type_decl ~path td = 183 | let typ = td.ptype_name.txt in 184 | let qualifying = qualifying_name ~path typ in 185 | { typ; qualifying; ttyp = mangle_label typ; node = typ ^ "_node" } 186 | 187 | let ttype_ct_of_ct ~loc ct = ptyp_constr ~loc { txt = lid_ttype; loc } [ ct ] 188 | 189 | let type_of_type_decl ~loc td : core_type = 190 | let (module M) = Ast_builder.make loc in 191 | let open M in 192 | ptyp_constr 193 | { txt = Lident td.ptype_name.txt; loc } 194 | (List.map (fun (ct, _variance) -> ct) td.ptype_params) 195 | 196 | let ttype_of_type_decl ~loc td : core_type = 197 | let (module M) = Ast_builder.make loc in 198 | let open M in 199 | let ct = type_of_type_decl ~loc td in 200 | ptyp_constr { txt = lid_ttype; loc } [ ct ] 201 | 202 | let close_ttype ~loc ~free ttype = 203 | List.fold_left 204 | (fun acc name -> [%type: [%t ptyp_var ~loc name] Ttype.t -> [%t acc]]) 205 | ttype (List.rev free) 206 | 207 | (* general helpers *) 208 | 209 | let find_index_opt (l : 'a list) (el : 'a) : int option = 210 | let i = ref 0 in 211 | let rec f = function 212 | | [] -> None 213 | | hd :: _ when hd = el -> Some !i 214 | | _ :: tl -> 215 | incr i; 216 | f tl 217 | in 218 | f l 219 | 220 | (* the actual mappers *) 221 | 222 | (* We use this to store information about recursive types. Which identifiers 223 | are used recursively? Is the recursion regular? 224 | Rec: alist mapping recursive identifiers to their type args 225 | Nonrec: list of identifiers 226 | Inline defined types do not have an identifier *) 227 | type rec_ = Inline | Nonrec of label list | Rec of (label * label list) list 228 | 229 | let rec core_type ~rec_ ~free ({ ptyp_loc = loc; _ } as ct) : expression = 230 | let ct, patch = patch_of_ct ct in 231 | let rc = core_type ~rec_ ~free in 232 | let rcs ({ ptyp_loc = loc; _ } as ct) = 233 | (* TODO: When we do a full PPX extension, we could fix this hole by 234 | moving the type check before the type declaration that redefines the 235 | type *) 236 | match (rec_, ct.ptyp_desc) with 237 | | Nonrec l, Ptyp_constr ({ txt = Lident name; _ }, _) when List.mem name l 238 | -> 239 | stype_of_ttype (ptyp_any ~loc) (rc ct) 240 | | _ -> stype_of_ttype ct (rc ct) 241 | in 242 | let constr = 243 | match (patch, rec_) with 244 | (* patched ct? nonrec td? *) 245 | | Some { txt; loc }, _ -> 246 | fun _ args -> 247 | let typ = 248 | List.fold_right 249 | (fun e acc -> ptyp_arrow Nolabel ~loc (ttype_ct_of_ct ~loc e) acc) 250 | args (ttype_ct_of_ct ~loc ct) 251 | in 252 | let exp = pexp_constraint ~loc txt typ in 253 | pexp_apply ~loc exp (List.map (fun x -> (Nolabel, rc x)) args) 254 | | None, Nonrec _ | None, Inline -> 255 | fun id args -> 256 | let id' = mangle_lid_loc id in 257 | pexp_apply ~loc (pexp_ident ~loc id') 258 | (List.map (fun x -> (Nolabel, rc x)) args) 259 | | None, Rec l -> 260 | fun id args -> 261 | let id' = mangle_lid_loc id in 262 | (* recursive identifier? *) 263 | ( match List.assoc_opt (Longident.name id.txt) l with 264 | | Some l -> 265 | (* regular recursion? *) 266 | let is = List.rev_map (fun x -> x.ptyp_desc) args 267 | and should = List.rev_map (fun a -> Ptyp_var a) l in 268 | if is = should then pexp_ident ~loc id' |> force_lazy ~loc 269 | else raise_errorf ~loc "non-regular type recursion not supported" 270 | | None -> 271 | pexp_apply ~loc (pexp_ident ~loc id') 272 | (List.map (fun x -> (Nolabel, rc x)) args) 273 | ) 274 | in 275 | let t = 276 | match ct.ptyp_desc with 277 | | Ptyp_tuple l -> 278 | let args = List.map rcs l in 279 | [%expr ttype_of_stype (DT_tuple [%e elist ~loc args])] 280 | | Ptyp_constr (id, args) -> constr id args 281 | | Ptyp_var vname -> 282 | ( match find_index_opt free vname with 283 | | None -> raise_errorf ~loc "please provide closed type" 284 | | Some i -> [%expr ttype_of_stype (DT_var [%e eint ~loc i])] 285 | ) 286 | | Ptyp_arrow (label, l, r) -> 287 | let lab = 288 | match label with 289 | | Nolabel -> "" 290 | | Labelled s -> s 291 | | Optional s -> "?" ^ s 292 | in 293 | [%expr 294 | ttype_of_stype 295 | (DT_arrow ([%e estring ~loc lab], [%e rcs l], [%e rcs r]))] 296 | | Ptyp_object (l, _closed_flag) -> 297 | let fields = 298 | List.map 299 | (function 300 | (* TODO: properties could be read for object fields. 301 | But where should they be placed? 302 | DT_prop (ct)? *) 303 | | { pof_desc = Otag ({ txt; loc }, ct); _ } -> 304 | pexp_tuple ~loc [ estring ~loc txt; rcs ct ] 305 | | { pof_desc = Oinherit _; _ } -> 306 | raise_errorf "inheritance not yet supported" ~loc) 307 | l 308 | in 309 | [%expr ttype_of_stype (DT_object [%e elist ~loc fields])] 310 | | Ptyp_alias (ct, _label) -> rc ct 311 | | _ -> raise_errorf ~loc "type not yet supported" 312 | in 313 | wrap_props ~loc (props_of_ct ct) t 314 | 315 | let fields_of_record_labels ~rec_ ~free l = 316 | List.fold_left 317 | (fun (meta, args) ({ pld_loc = loc; _ } as x) -> 318 | let props = props_of_rf x and ct = core_type ~rec_ ~free x.pld_type in 319 | ( pexp_tuple ~loc [ estring ~loc x.pld_name.txt; elist ~loc props ] :: meta, 320 | stype_of_ttype x.pld_type ct :: args )) 321 | ([], []) l 322 | 323 | let record_labels ~loc ~me ~free ~rec_ ~unboxed l = 324 | let meta, args = fields_of_record_labels ~free ~rec_ l in 325 | let createnode = 326 | let pat = pvar ~loc me.node 327 | and expr = 328 | [%expr 329 | create_node [%e estring ~loc me.qualifying] 330 | [%e stypes_of_free ~loc free]] 331 | in 332 | pexp_let ~loc Nonrecursive [ value_binding ~loc ~pat ~expr ] 333 | and ttype = [%expr ttype_of_stype (DT_node [%e evar ~loc me.node])] 334 | and setnode = 335 | let pat = punit ~loc 336 | and expr = 337 | let repr = 338 | if unboxed then [%expr Record_unboxed] 339 | else [%expr record_representation args] 340 | in 341 | [%expr 342 | let meta = [%e elist ~loc meta] in 343 | let args = [%e elist ~loc args] in 344 | set_node_record [%e evar ~loc me.node] 345 | (rev_map2 (fun (n, p) a -> (n, p, a)) meta args, [%e repr])] 346 | in 347 | pexp_let ~loc Nonrecursive [ value_binding ~loc ~pat ~expr ] 348 | in 349 | (createnode, ttype, setnode) 350 | 351 | let record_labels_inline ~loc ~free ~rec_ ~name ~unboxed i l = 352 | let meta, args = fields_of_record_labels ~free ~rec_ l in 353 | let repr = 354 | if unboxed then [%expr Record_unboxed] 355 | else [%expr Record_inline [%e eint ~loc i]] 356 | in 357 | [%expr 358 | let ([%p pvar ~loc "inline_node"] : node) = 359 | create_node [%e estring ~loc name] [%e stypes_of_free ~loc free] 360 | in 361 | let meta = [%e elist ~loc meta] in 362 | let args = [%e elist ~loc args] in 363 | set_node_record inline_node 364 | (rev_map2 (fun (n, p) a -> (n, p, a)) meta args, [%e repr]); 365 | DT_node [%e evar ~loc "inline_node"]] 366 | 367 | let variant_constructors ~loc ~me ~free ~rec_ ~unboxed l = 368 | let nconst_tag = ref 0 in 369 | let constructors = 370 | List.map 371 | (fun ({ pcd_loc = loc; _ } as x) -> 372 | let props = props_of_vc x in 373 | match x.pcd_args with 374 | | Pcstr_tuple ctl -> 375 | if ctl <> [] then incr nconst_tag; 376 | let l = 377 | List.map 378 | (fun ct -> 379 | core_type ~rec_ ~free ct |> fun e -> stype_of_ttype ct e) 380 | ctl 381 | in 382 | [%expr 383 | [%e estring ~loc x.pcd_name.txt], 384 | [%e elist ~loc props], 385 | C_tuple [%e elist ~loc l]] 386 | | Pcstr_record lbl -> 387 | let name = Format.sprintf "%s.%s" me.typ x.pcd_name.txt in 388 | let r = 389 | record_labels_inline ~rec_ ~free ~loc ~unboxed ~name !nconst_tag 390 | lbl 391 | in 392 | incr nconst_tag; 393 | [%expr 394 | [%e estring ~loc x.pcd_name.txt], 395 | [%e elist ~loc props], 396 | C_inline [%e r]]) 397 | l 398 | in 399 | let createnode = 400 | let pat = pvar ~loc me.node 401 | and expr = 402 | [%expr 403 | create_node [%e estring ~loc me.qualifying] 404 | [%e stypes_of_free ~loc free]] 405 | in 406 | pexp_let ~loc Nonrecursive [ value_binding ~loc ~pat ~expr ] 407 | and ttype = [%expr ttype_of_stype (DT_node [%e evar ~loc me.node])] 408 | and setnode = 409 | let pat = punit ~loc 410 | and expr = 411 | let repr = 412 | if unboxed then [%expr Variant_unboxed] else [%expr Variant_regular] 413 | in 414 | [%expr 415 | set_node_variant [%e evar ~loc me.node] 416 | ([%e elist ~loc constructors], [%e repr])] 417 | in 418 | pexp_let ~loc Nonrecursive [ value_binding ~loc ~pat ~expr ] 419 | in 420 | (createnode, ttype, setnode) 421 | 422 | let substitution_of_free_vars ~loc ~me ttype free = 423 | let typ = close_ttype ~loc ~free ttype in 424 | let expr = 425 | let arr = 426 | List.map (fun v -> [%expr stype_of_ttype [%e evar ~loc v]]) free 427 | in 428 | List.fold_left 429 | (fun acc v -> pexp_fun ~loc Nolabel None (pvar ~loc v) acc) 430 | [%expr 431 | ttype_of_stype 432 | (substitute [%e pexp_array ~loc arr] 433 | (stype_of_ttype [%e evar ~loc me.ttyp]))] 434 | (List.rev free) 435 | |> wrap_runtime ~loc 436 | and pat = ppat_constraint ~loc (pvar ~loc me.ttyp) typ in 437 | value_binding ~loc ~expr ~pat 438 | 439 | let open_abstract ~loc ~free name = 440 | let f = stypes_of_free ~loc free in 441 | let name = estring ~loc name in 442 | [%expr 443 | let () = register_abstract_name [%e name] in 444 | ttype_of_stype (DT_abstract ([%e name], [%e f]))] 445 | 446 | let str_type_decl ~loc ~path (recflag, tds) = 447 | let _ = path in 448 | let extend_let new_ was expr = new_ (was expr) in 449 | let rec_ = 450 | match recflag with 451 | | Nonrecursive -> Nonrec (List.map (fun td -> td.ptype_name.txt) tds) 452 | | Recursive -> 453 | Rec 454 | (List.map 455 | (fun td -> (td.ptype_name.txt, free_vars_of_type_decl td)) 456 | tds) 457 | in 458 | (* We create one value binding from tpl, cn, ls, sn and fl: 459 | let tpl[0], tpl[1] = 460 | let () = createnodes (cn) in 461 | let rec = lazy .. and lazy .. (lr) in 462 | let () = setnodes (sn) in 463 | force .. , force .. (fl) 464 | the other value bindings (bnd) are appended *) 465 | let parse (tpl, cn, lr, sn, fl, bnd) ({ ptype_loc = loc; _ } as td) = 466 | let me = names_of_type_decl ~path td in 467 | let typ = type_of_type_decl ~loc td in 468 | let ttyp = ttype_of_type_decl ~loc td in 469 | let free = free_vars_of_type_decl td in 470 | let tpl = ppat_constraint ~loc (pvar ~loc me.ttyp) ttyp :: tpl in 471 | let cn, ttype, sn = 472 | match abstract_of_td td with 473 | | Name { txt = name; loc } -> (cn, open_abstract ~free ~loc name, sn) 474 | | Auto -> (cn, open_abstract ~free ~loc me.qualifying, sn) 475 | | No -> 476 | ( match td.ptype_kind with 477 | | Ptype_abstract -> 478 | ( match td.ptype_manifest with 479 | | None -> raise_errorf ~loc "no manifest found" 480 | | Some ct -> 481 | let t = core_type ~rec_ ~free ct in 482 | (cn, t, sn) 483 | ) 484 | | Ptype_record l -> 485 | let unboxed = unboxed_of_td td in 486 | let c, t, s = record_labels ~me ~unboxed ~free ~loc ~rec_ l in 487 | (extend_let c cn, t, extend_let s sn) 488 | | Ptype_variant l -> 489 | let unboxed = unboxed_of_td td in 490 | let c, t, s = 491 | variant_constructors ~me ~unboxed ~free ~loc ~rec_ l 492 | in 493 | (extend_let c cn, t, extend_let s sn) 494 | | Ptype_open -> raise_errorf ~loc "type kind not yet supported" 495 | ) 496 | in 497 | let ttype = wrap_props ~loc (props_of_td td) ttype in 498 | let lr = lazy_value_binding ~loc me.ttyp typ ttype :: lr in 499 | let fl = force_lazy ~loc (evar ~loc me.ttyp) :: fl in 500 | let bnd = 501 | if free = [] then bnd 502 | else substitution_of_free_vars ~loc ~me ttyp free :: bnd 503 | in 504 | (tpl, cn, lr, sn, fl, bnd) 505 | in 506 | let tpl, createnode, lazyrec, setnode, forcelazy, bindings = 507 | let id x = x in 508 | List.fold_left parse ([], id, [], id, [], []) tds 509 | in 510 | let prepare = 511 | let pat, force = 512 | match tpl with 513 | | [] -> raise_errorf ~loc "internal error (type_decl_str)" 514 | | [ hd ] -> (hd, List.hd forcelazy) 515 | | _ -> (ppat_tuple ~loc tpl, pexp_tuple ~loc forcelazy) 516 | in 517 | let expr = 518 | let recflag = 519 | match rec_ with Nonrec _ -> Nonrecursive | _ -> Recursive 520 | in 521 | wrap_runtime ~loc 522 | (createnode @@ pexp_let ~loc recflag lazyrec @@ setnode @@ force) 523 | in 524 | value_binding ~loc ~pat ~expr 525 | in 526 | List.map (fun x -> pstr_value ~loc Nonrecursive [ x ]) (prepare :: bindings) 527 | 528 | (* Type declarations in signature. Generates 529 | val _t : ttype *) 530 | let sig_of_type_decl ({ ptype_loc = loc; _ } as td) = 531 | match td.ptype_kind with 532 | | Ptype_abstract | Ptype_record _ | Ptype_variant _ -> 533 | let type_ = 534 | let free = free_vars_of_type_decl td in 535 | close_ttype ~loc ~free (ttype_of_type_decl ~loc td) 536 | and name = mangle_label_loc td.ptype_name 537 | and prim = [] in 538 | value_description ~loc ~type_ ~name ~prim 539 | | _ -> raise_errorf ~loc "cannot handle this type in signatures yet" 540 | 541 | let sig_type_decl ~loc ~path (_recflag, tds) = 542 | let _ = path in 543 | List.map sig_of_type_decl tds |> List.map (psig_value ~loc) 544 | 545 | (* inline types *) 546 | let extension ~loc ~path ct = 547 | let _ = path in 548 | let t = core_type ~rec_:Inline ~free:[] ct in 549 | (* prepend ignore statement to produce nicer error message *) 550 | wrap_runtime ~loc 551 | [%expr 552 | let _ = fun (_ : [%t ct]) -> () in 553 | [%e t]] 554 | 555 | (* Register the generator functions *) 556 | let () = 557 | let open Deriving in 558 | let str_type_decl = Generator.make_noarg str_type_decl in 559 | let sig_type_decl = Generator.make_noarg sig_type_decl in 560 | add ~str_type_decl ~sig_type_decl ~extension ppx.id |> ignore 561 | -------------------------------------------------------------------------------- /ppx/path/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name lrt_path) 3 | (public_name lrt.path) 4 | (synopsis "lrt [%path? .] syntax extension") 5 | (libraries ppxlib) 6 | (preprocess 7 | (pps ppxlib.metaquot)) 8 | (kind ppx_rewriter)) 9 | -------------------------------------------------------------------------------- /ppx/path/lrt_path.ml: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | (** The [\[%path? .\]] syntax extension. See {!Lrt.Path}.*) 9 | 10 | (**/**) 11 | 12 | open Ppxlib 13 | open Ast_builder.Default 14 | 15 | let raise_errorf ~loc = 16 | Format.ksprintf (Location.raise_errorf ~loc "%s %s" "[%path .]") 17 | 18 | class tyvar = 19 | object 20 | val mutable i = 0 21 | 22 | method pair loc = 23 | i <- i + 1; 24 | ( Printf.sprintf "t%d" (i - 1) |> ptyp_var ~loc, 25 | Printf.sprintf "t%d" i |> ptyp_var ~loc ) 26 | end 27 | 28 | type step = 29 | | Constructor of label loc * int * int 30 | | ConstructorInline of label loc * label loc 31 | | Field of label loc 32 | | Tuple of int * int 33 | | List of int 34 | | Array of int 35 | 36 | type lst = Cons of pattern * pattern | Nil 37 | 38 | module Pat = struct 39 | open Ast_pattern 40 | 41 | exception Invalid_tuple of string loc 42 | 43 | let nth_and_arity ~loc lst = 44 | match 45 | List.fold_left 46 | (fun (i, nth) e -> 47 | match (e, nth) with 48 | | true, None -> (i + 1, Some i) 49 | | true, _ -> raise (Invalid_tuple { txt = "Too much []"; loc }) 50 | | false, x -> (i + 1, x)) 51 | (0, None) lst 52 | with 53 | | arity, Some nth -> (nth, arity) 54 | | _ -> raise (Invalid_tuple { txt = "No []"; loc }) 55 | 56 | let tuple = 57 | ppat_tuple 58 | (many 59 | (ppat_any |> map0 ~f:false 60 | ||| (ppat_construct (lident (string "[]")) none |> map0 ~f:true) 61 | )) 62 | |> map1' ~f:(fun loc -> nth_and_arity ~loc) 63 | 64 | let step = 65 | ppat_var __' 66 | |> map1 ~f:(fun x -> Field x) 67 | ||| (ppat_array (pint __ ^:: nil) |> map1 ~f:(fun x -> Array x)) 68 | ||| (ppat_construct 69 | (lident (string "::")) 70 | (some 71 | (ppat_tuple 72 | (pint __ ^:: ppat_construct (lident (string "[]")) none ^:: nil))) 73 | |> map1 ~f:(fun x -> List x) 74 | ) 75 | ||| (ppat_construct (lident __') (some tuple) 76 | |> map2 ~f:(fun s (nth, arity) -> Constructor (s, nth, arity)) 77 | ) 78 | ||| (ppat_construct (lident __') (some (ppat_var __')) 79 | |> map2 ~f:(fun name field -> ConstructorInline (name, field)) 80 | ) 81 | ||| (ppat_construct (lident __') none 82 | |> map1 ~f:(fun s -> Constructor (s, 0, 1)) 83 | ) 84 | ||| (tuple |> map1 ~f:(fun (nth, arity) -> Tuple (nth, arity))) 85 | 86 | let lst = 87 | ppat_construct 88 | (lident (string "::")) 89 | (some (ppat_tuple (__ ^:: __ ^:: nil))) 90 | |> map2 ~f:(fun a b -> Cons (a, b)) 91 | ||| (ppat_construct (lident (string "[]")) none |> map0 ~f:Nil) 92 | end 93 | 94 | let lid_loc_of_label_loc = Loc.map ~f:(fun x -> Lident x) 95 | 96 | let tuple_pat ~loc nth arity = 97 | let arr = Array.init arity (fun i -> pvar ~loc ("_v" ^ string_of_int i)) in 98 | let () = arr.(nth) <- pvar ~loc "x" in 99 | ppat_tuple ~loc (Array.to_list arr) 100 | 101 | let tuple_patch ~loc nth arity = 102 | let arr = Array.init arity (fun i -> evar ~loc ("_v" ^ string_of_int i)) in 103 | let () = arr.(nth) <- evar ~loc "y" in 104 | pexp_tuple ~loc (Array.to_list arr) 105 | 106 | let rec expand_step ~loc x = 107 | match Ast_pattern.parse Pat.step loc x (fun x -> x) with 108 | | Constructor (label, nth, arity) -> 109 | let p = Some (tuple_pat ~loc nth arity) in 110 | let lloc = lid_loc_of_label_loc label in 111 | let c = ppat_construct ~loc lloc p in 112 | let patched = 113 | pexp_construct ~loc lloc (Some (tuple_patch ~loc nth arity)) 114 | in 115 | [%expr 116 | let get x = 117 | match[@ocaml.warning "-11"] x with [%p c] -> Some x | _ -> None 118 | and set x y = 119 | match[@ocaml.warning "-11"] x with 120 | | [%p c] -> Some [%e patched] 121 | | _ -> None 122 | in 123 | ( { get; set }, 124 | constructor_regular 125 | ~name:[%e estring ~loc:label.loc label.txt] 126 | ~nth:[%e eint ~loc nth] ~arity:[%e eint ~loc arity] )] 127 | | ConstructorInline (name, field) -> 128 | let nlloc = lid_loc_of_label_loc name in 129 | let flloc = lid_loc_of_label_loc field in 130 | let c = ppat_construct ~loc nlloc (Some (pvar ~loc "x")) in 131 | let get = pexp_field ~loc (evar ~loc "x") flloc 132 | and set = 133 | pexp_construct ~loc nlloc 134 | (Some 135 | (pexp_record ~loc 136 | [ (flloc, evar ~loc "y") ] 137 | (Some (evar ~loc "x")))) 138 | in 139 | [%expr 140 | let get x = 141 | match[@ocaml.warning "-11"] x with 142 | | [%p c] -> Some [%e get] 143 | | _ -> None 144 | and set x y = 145 | match[@ocaml.warning "-11"] [@ocaml.warning "-23"] x with 146 | | [%p c] -> Some [%e set] 147 | | _ -> None 148 | in 149 | ( { get; set }, 150 | constructor_inline 151 | ~name:[%e estring ~loc:name.loc name.txt] 152 | ~field_name:[%e estring ~loc:field.loc field.txt] )] 153 | | Field label -> 154 | let liloc = lid_loc_of_label_loc label in 155 | let get = pexp_field ~loc (evar ~loc "x") liloc 156 | and set = 157 | pexp_record ~loc [ (liloc, evar ~loc "y") ] (Some (evar ~loc "x")) 158 | in 159 | [%expr 160 | let get x = Some [%e get] 161 | and set x y = (Some [%e set] [@ocaml.warning "-23"]) in 162 | ({ get; set }, field ~field_name:[%e estring ~loc:label.loc label.txt])] 163 | | Tuple (nth, arity) -> 164 | let p = tuple_pat ~loc nth arity in 165 | let patched = tuple_patch ~loc nth arity in 166 | [%expr 167 | let get [%p p] = Some x and set [%p p] y = Some [%e patched] in 168 | ({ get; set }, tuple ~nth:[%e eint ~loc nth] ~arity:[%e eint ~loc arity])] 169 | | List nth -> 170 | let () = if nth < 0 then raise_errorf ~loc "Invalid list index" in 171 | [%expr 172 | let get l = List.nth_opt l [%e eint ~loc nth] 173 | and set l y = set_nth_opt l [%e eint ~loc nth] y in 174 | ({ get; set }, list ~nth:[%e eint ~loc nth])] 175 | | Array nth -> 176 | let () = if nth < 0 then raise_errorf ~loc "Invalid array index" in 177 | [%expr 178 | let get a = 179 | if [%e eint ~loc nth] < Array.length a then 180 | Some a.([%e eint ~loc nth]) 181 | else None 182 | and set a y = 183 | if [%e eint ~loc nth] < Array.length a then ( 184 | let a' = Array.copy a in 185 | a'.([%e eint ~loc nth]) <- y; 186 | Some a' 187 | ) 188 | else None 189 | in 190 | ({ get; set }, array ~nth:[%e eint ~loc nth])] 191 | | exception Pat.Invalid_tuple { txt; loc } -> raise_errorf ~loc "%s" txt 192 | 193 | and expand acc ({ ppat_loc = loc; _ } as x) = 194 | match Ast_pattern.parse Pat.lst loc x (fun x -> x) with 195 | | Cons (hd, tl) -> expand (expand_step ~loc hd :: acc) tl 196 | | Nil -> acc 197 | 198 | let expand ~loc ~path x = 199 | ignore path; 200 | [%expr 201 | let open! Lrt_ppx_runtime.Path in 202 | [%e elist ~loc (expand [] x |> List.rev)]] 203 | 204 | (* Register the expander *) 205 | let () = 206 | let extensions = 207 | [ 208 | Extension.( 209 | declare "path" Context.expression Ast_pattern.(ppat __ none) expand); 210 | ] 211 | in 212 | Driver.register_transformation "lrt_path" ~extensions 213 | -------------------------------------------------------------------------------- /ppx/standalone/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name standalone) 3 | (libraries lrt_path lrt_deriving ppxlib)) 4 | -------------------------------------------------------------------------------- /ppx/standalone/standalone.ml: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | (** Standalone PPX rewriter 9 | 10 | Use [dune exec ppx/standalone.exe source.ml] to see the ppx generated output 11 | of [source.ml] 12 | *) 13 | 14 | open Ppxlib 15 | 16 | let () = Driver.standalone () 17 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name lrt_test) 3 | (libraries lrt) 4 | (inline_tests) 5 | (modules path ppx variantizer matcher open_std_only) 6 | (preprocess 7 | (pps ppx_expect lrt.path lrt.deriving))) 8 | 9 | (tests 10 | (names fuzzing) 11 | (libraries lrt) 12 | (modules fuzzing) 13 | (preprocess 14 | (pps ppx_expect lrt.path lrt.deriving))) 15 | -------------------------------------------------------------------------------- /test/fuzzing.ml: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | open Lrt 9 | open Check 10 | 11 | (* Generate random ttypes with random witnesses and use them for basic tests *) 12 | 13 | let n = 14 | if Array.length Sys.argv > 1 then 15 | match int_of_string_opt Sys.argv.(1) with Some i -> i | None -> 111 16 | else 111 17 | 18 | let seed = 19 | if Array.length Sys.argv > 2 then 20 | match int_of_string_opt Sys.argv.(2) with Some i -> i | None -> 42 21 | else 42 22 | 23 | (* printing *) 24 | 25 | let f : Ttype.dynamic -> bool = function 26 | | Ttype.Dyn (t, x) -> 27 | let () = 28 | Format.printf "Type: %a\n%!" Ttype.print t; 29 | Format.printf "Value: %a\n%!" (Print.print ~t) x 30 | in 31 | true 32 | 33 | let () = ignore (test n ~seed ~generator:(dynamic ~size:10 []) f) 34 | 35 | (* variant *) 36 | 37 | let f : Ttype.dynamic -> bool = function 38 | | Ttype.Dyn (t, x) -> 39 | let v = Variant.to_variant ~t x in 40 | let () = 41 | Format.printf "Value: %a\n%!" (Print.print ~t) x; 42 | Format.printf "Variant: %a\n%!" Variant.print_variant v 43 | in 44 | let x' = Variant.of_variant ~t v in 45 | let s = Format.asprintf "%a%!" Variant.print_variant v in 46 | let v' = 47 | try Variant.variant_of_string s 48 | with r -> 49 | Printf.eprintf "Could not parse string:\n%s\n%!" s; 50 | raise r 51 | in 52 | let x'' = Variant.of_variant ~t v' in 53 | let r = compare x x' = 0 && compare x' x'' = 0 && compare v v' = 0 in 54 | if not r then 55 | Format.printf "Screwed:\nv': %a\nx'': %a\n%!" Variant.print_variant v' 56 | (Print.print ~t) x''; 57 | r 58 | 59 | let () = 60 | let seed = 2 * seed in 61 | match test n ~seed ~generator:(dynamic ~size:22 []) f with 62 | | Succeed _ -> () 63 | | Throw { backtrace; _ } -> failwith backtrace 64 | | Fail _ -> print_endline "test failed" 65 | 66 | (* json *) 67 | 68 | let f : Ttype.dynamic -> bool = function 69 | | Ttype.Dyn (t, x) -> 70 | let Json.{ to_json; of_json } = Json.conv t in 71 | let j = to_json x in 72 | let () = 73 | Format.printf "Value: %a\n%!" (Print.print ~t) x; 74 | Format.printf "Json: %s\n%!" (Json.to_pretty_string j) 75 | in 76 | let x' = of_json j in 77 | let s = Json.encode j in 78 | let j' = 79 | try Json.decode s 80 | with r -> 81 | Printf.eprintf "Json.decode:\n%s\n%!" s; 82 | raise r 83 | in 84 | let x'' = of_json j' in 85 | let r = compare x x' = 0 && compare x' x'' = 0 && compare j j' = 0 in 86 | if not r then 87 | Format.printf "Screwed:\nv': %s\nx'': %a\n%!" (Json.to_pretty_string j') 88 | (Print.print ~t) x''; 89 | r 90 | 91 | let () = 92 | let seed = 3 * seed in 93 | match test n ~seed ~generator:(dynamic ~size:22 []) f with 94 | | Succeed _ -> () 95 | | Throw { backtrace; _ } -> failwith backtrace 96 | | Fail _ -> print_endline "test failed" 97 | -------------------------------------------------------------------------------- /test/matcher.ml: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | open Lrt 9 | 10 | module T = struct 11 | (* stripped down version for documentation *) 12 | 13 | type t0 = string list 14 | 15 | and 'a t1 = 'a array 16 | 17 | and ('a, 'b) t2 = ('a * 'b) option [@@deriving t] 18 | 19 | module Matcher = Matcher.Make (struct 20 | type 'a t = unit -> unit 21 | end) 22 | 23 | let pp_ty = Ttype.print 24 | 25 | let m = 26 | let open Matcher in 27 | empty ~modulo_props:true 28 | |> add ~t:[%t: string list] (fun () -> 29 | Format.printf "t0 = %a\n%!" pp_ty t0_t) 30 | |> add1 31 | ( module struct 32 | type 'a t = 'a t1 [@@deriving t] 33 | 34 | let return a_t () = 35 | Format.printf "%a t1 = %a\n%!" pp_ty a_t pp_ty (t1_t a_t) 36 | end 37 | ) 38 | |> add2 39 | ( module struct 40 | type ('a, 'b) t = ('a, 'b) t2 [@@deriving t] 41 | 42 | let return a_t b_t () = 43 | Format.printf "(%a, %a) t2 = %a\n%!" pp_ty a_t pp_ty b_t pp_ty 44 | (t2_t a_t b_t) 45 | end 46 | ) 47 | 48 | let apply : type a. Matcher.t -> t:a Ttype.t -> unit = 49 | fun matcher ~t -> 50 | let open Matcher in 51 | match apply matcher ~t with 52 | | None -> print_endline "Not found" 53 | | Some (M0 (module M : M0 with type matched = a)) -> M.return () 54 | | Some (M1 (module M : M1 with type matched = a)) -> M.return () 55 | | Some (M2 (module M : M2 with type matched = a)) -> M.return () 56 | 57 | let%expect_test _ = 58 | apply m ~t:[%t: t0]; 59 | apply m ~t:[%t: int t1]; 60 | apply m ~t:[%t: bool t1]; 61 | apply m ~t:[%t: float option]; 62 | apply m ~t:[%t: (float, string) t2]; 63 | apply m ~t:[%t: (unit, string) t2]; 64 | [%expect 65 | {| 66 | t0 = string list 67 | int t1 = int array 68 | bool t1 = bool array 69 | Not found 70 | (float, string) t2 = (float * string) option 71 | (unit, string) t2 = (unit * string) option |}] 72 | end 73 | 74 | type a = int * int 75 | 76 | and b = int option 77 | 78 | and c = string list 79 | 80 | and d = int * (int * string) 81 | 82 | and 'a e = 'a list 83 | 84 | and ('a, 'b) f = (('a, 'b) Hashtbl.t[@patch hashtbl_t]) [@@deriving t] 85 | 86 | module Matcher = Matcher.Make (struct 87 | type 'a t = unit -> unit 88 | end) 89 | 90 | let pp_ty = Ttype.print 91 | 92 | let matcher = 93 | let open Matcher in 94 | empty ~modulo_props:true 95 | |> add ~t:a_t (fun () -> Format.printf "a = %a\n%!" pp_ty a_t) 96 | |> add ~t:b_t (fun () -> Format.printf "b = %a\n%!" pp_ty b_t) 97 | |> add ~t:c_t (fun () -> Format.printf "c = %a\n%!" pp_ty c_t) 98 | |> add0 99 | ( module struct 100 | type t = d [@@deriving t] 101 | 102 | let return () = Format.printf "d = %a\n%!" pp_ty d_t 103 | end 104 | ) 105 | |> add1 106 | ( module struct 107 | type 'a t = 'a e [@@deriving t] 108 | 109 | let return a_t () = 110 | Format.printf "%a e = %a\n%!" pp_ty a_t pp_ty (e_t a_t) 111 | end 112 | ) 113 | |> add2 114 | ( module struct 115 | type ('a, 'b) t = ('a, 'b) f [@@deriving t] 116 | 117 | let return a_t b_t () = 118 | Format.printf "(%a, %a) f = %a\n%!" pp_ty a_t pp_ty b_t pp_ty 119 | (t a_t b_t) 120 | end 121 | ) 122 | 123 | let apply : type a. Matcher.t -> t:a Ttype.t -> unit = 124 | fun matcher ~t -> 125 | let open Matcher in 126 | match apply matcher ~t with 127 | | None -> print_endline "Not found" 128 | | Some (M0 (module M : M0 with type matched = a)) -> M.return () 129 | | Some (M1 (module M : M1 with type matched = a)) -> M.return () 130 | | Some (M2 (module M : M2 with type matched = a)) -> M.return () 131 | 132 | let%expect_test _ = 133 | apply matcher ~t:a_t; 134 | apply matcher ~t:b_t; 135 | apply matcher ~t:c_t; 136 | apply matcher ~t:d_t; 137 | apply matcher ~t:(e_t float_t); 138 | apply matcher ~t:(f_t int_t float_t); 139 | [%expect 140 | {| 141 | a = (int * int) 142 | b = int option 143 | c = string list 144 | d = (int * (int * string)) 145 | float e = float list 146 | (int, float) f = (int, float) Hashtbl.t |}] 147 | -------------------------------------------------------------------------------- /test/open_std_only.ml: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | open Lrt.Std 9 | 10 | type t = int [@@abstract] [@@deriving t] 11 | 12 | let p : (int array list, int) Lrt.Path.t = [%path? [ [ 101 ]; [| 42 |] ]] 13 | 14 | let _ = p 15 | -------------------------------------------------------------------------------- /test/path.ml: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | open Lrt 9 | 10 | (* 11 | type id = int -> int [@@deriving t] 12 | let fn :id = fun x -> x 13 | let _ = 14 | Format.printf "%a\n%!" Stype.print_stype (Ttype.stype_of_ttype id_t); 15 | Print.show ~t:Variant.t (Variant.variant ~t:id_t fn) *) 16 | 17 | let pprint p = Format.(printf "%a\n%!" Path.print p) 18 | 19 | let tprint x = Format.printf "%a\n%!" Ttype.print x 20 | 21 | let vprint t v = Format.(printf "%a\n%!" (Print.print ~t) v) 22 | 23 | let dprint dyn = 24 | let open Ttype in 25 | let (Dyn (t, v)) = dyn in 26 | vprint t v 27 | 28 | type t = A of { b: int array list * string } [@@deriving t] 29 | 30 | let value = A { b = ([ [| 0; 1 |]; [| 0; 1; 2 |]; [| 0 |] ], "string") } 31 | 32 | let assert_some = function Some x -> x | None -> assert false 33 | 34 | let%expect_test _ = 35 | let f p = 36 | let Path.{ get; _ } = Path.lens p in 37 | let t = Xtype.project_path t p in 38 | pprint p; 39 | tprint t; 40 | get value |> assert_some |> vprint t; 41 | print_endline "----------------" 42 | in 43 | f Path.[]; 44 | f [%path? [ A b ]]; 45 | f [%path? [ A b; ([], _) ]]; 46 | f [%path? [ A b; (_, []) ]]; 47 | f [%path? [ A b; ([], _); [ 1 ] ]]; 48 | f [%path? [ A b; ([], _); [ 1 ]; [| 2 |] ]]; 49 | [%expect 50 | {| 51 | [%path? []] 52 | (lrt_test#test/path.ml.t = 53 | | A of 54 | (t.A = 55 | { 56 | b: (int array list * string); 57 | })) 58 | A {b = ([[|0; 1|]; [|0; 1; 2|]; [|0|]], "string")} 59 | ---------------- 60 | [%path? [A b]] 61 | (int array list * string) 62 | ([[|0; 1|]; [|0; 1; 2|]; [|0|]], "string") 63 | ---------------- 64 | [%path? [A b; ([],_)]] 65 | int array list 66 | [[|0; 1|]; [|0; 1; 2|]; [|0|]] 67 | ---------------- 68 | [%path? [A b; (_,[])]] 69 | string 70 | "string" 71 | ---------------- 72 | [%path? [A b; ([],_); [1]]] 73 | int array 74 | [|0; 1; 2|] 75 | ---------------- 76 | [%path? [A b; ([],_); [1]; [|2|]]] 77 | int 78 | 2 79 | ---------------- |}] 80 | 81 | type y = Int of int | Bool of bool | Pair of int * string 82 | 83 | type z = Y of { y1: y; y2: y; y3: y } 84 | 85 | type x = { x1: z; x2: z } 86 | 87 | type r = x * y 88 | 89 | type s = r list 90 | 91 | type f = s array 92 | 93 | type e = { e: f } 94 | 95 | let p = [%path? [ e; [| 50 |]; [ 1 ]; ([], _); x1; Y y2; Pair (_, []) ]] 96 | 97 | let%expect_test _ = 98 | pprint p; 99 | [%expect {| [%path? [e; [|50|]; [1]; ([],_); x1; Y y2; Pair (_,[])]] |}] 100 | 101 | let value = [| [ "hey"; "hi" ] |] 102 | 103 | let p2 = [%path? [ [| 0 |]; [ 1 ] ]] 104 | 105 | let l2 = Lrt.Path.lens p2 106 | 107 | let%expect_test _ = 108 | print_endline (l2.get value |> assert_some); 109 | print_endline (l2.set value "salut" |> assert_some |> l2.get |> assert_some); 110 | [%expect {| 111 | hi 112 | salut |}] 113 | -------------------------------------------------------------------------------- /test/variantizer.ml: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (C) 2020 by LexiFi. *) 3 | (* *) 4 | (* This source file is released under the terms of the MIT license as part *) 5 | (* of the lrt package. Details can be found in the attached LICENSE file. *) 6 | (******************************************************************************) 7 | 8 | open Lrt 9 | open Variant 10 | 11 | let variant_round t value = to_variant ~t value |> of_variant ~t 12 | 13 | let string_round t value = 14 | to_variant ~t value 15 | |> Format.asprintf "%a" print_variant 16 | |> variant_of_string |> of_variant ~t 17 | 18 | let round cmp t v = 19 | cmp v (variant_round t v) = 0 && cmp v (string_round t v) = 0 20 | 21 | let lazy_compare a b = compare (Lazy.force a) (Lazy.force b) 22 | 23 | let lazy_round t v = round lazy_compare t v 24 | 25 | let round t v = round compare t v 26 | 27 | let shows t v = Format.printf "%a\n%!" print_variant (to_variant ~t v) 28 | 29 | let showv t v = 30 | Format.printf "%a\n%!" (Print.print ~t:Variant.t) (to_variant ~t v) 31 | 32 | type a = int * int [@@deriving t] 33 | 34 | let%test _ = round a_t (-1, 3) 35 | 36 | let%test _ = round a_t (max_int, min_int) 37 | 38 | type b = float list [@@deriving t] 39 | 40 | let%test _ = 41 | round b_t 42 | [ 0.; neg_infinity; infinity; max_float; min_float; 1.17e99; 1.17e-99; nan ] 43 | 44 | let%test _ = round unit_t () 45 | 46 | type c = (bool Lazy.t[@patch lazy_t]) [@@deriving t] 47 | 48 | let%test _ = 49 | lazy_round c_t 50 | ( lazy 51 | ( Random.self_init (); 52 | Random.bool () 53 | ) 54 | ) 55 | 56 | type d = { 57 | d1: int; [@prop { of_variant_old_name = "d" }] 58 | d2: float; [@prop { of_variant_default = "1e-4" }] 59 | } 60 | [@@deriving t] 61 | 62 | let ht = Hashtbl.create 3 63 | 64 | let () = 65 | Hashtbl.add ht "a" (Some { d1 = 1; d2 = nan }); 66 | Hashtbl.add ht "b" (Some { d1 = max_int; d2 = 1e42 }); 67 | Hashtbl.add ht "c" None 68 | 69 | let ht_t = hashtbl_t string_t (option_t d_t) 70 | 71 | let%test _ = round ht_t ht 72 | 73 | let%expect_test _ = 74 | shows ht_t ht; 75 | [%expect 76 | {| 77 | [("c", None); ("b", Some{d1 = 4611686018427387903; d2 = 1e+42}); 78 | ("a", Some{d1 = 1; d2 = nan})] |}] 79 | 80 | (* Test whether record fields can be reordered *) 81 | let%test _ = 82 | of_variant ~t:d_t (Record [ ("d1", Int 0); ("d2", Float 0.) ]) 83 | = { d2 = 0.; d1 = 0 } 84 | 85 | let%test _ = 86 | of_variant ~t:d_t (Record [ ("d2", Float 0.); ("d1", Int 0) ]) 87 | = { d2 = 0.; d1 = 0 } 88 | 89 | (* of_variant_old_name, of_variant_default *) 90 | let%test _ = of_variant ~t:d_t (Record [ ("d", Int 0) ]) = { d2 = 1e-4; d1 = 0 } 91 | 92 | type e = 93 | | A of string [@prop { of_variant_old_name = "E1" }] 94 | | B of char * char [@prop { of_variant_old_name = "E2" }] 95 | | C of { i: nativeint [@prop { of_variant_old_name = "native" }] } 96 | [@prop { of_variant_old_name = "E3" }] 97 | [@@deriving t] 98 | 99 | let%test _ = round e_t (A "a") 100 | 101 | let%test _ = round e_t (B ('b', 'b')) 102 | 103 | let%test _ = round e_t (C { i = Nativeint.max_int }) 104 | 105 | let%expect_test _ = 106 | showv e_t (A "a"); 107 | showv e_t (B ('b', 'b')); 108 | showv e_t (C { i = Nativeint.zero }); 109 | [%expect 110 | {| 111 | Constructor ("A", Some (String "a")) 112 | Constructor ("B", Some (Tuple [String "b"; String "b"])) 113 | Constructor ("C", Some (Record [("i", String "0")])) |}] 114 | 115 | let%test _ = 116 | of_variant ~t:e_t (Constructor ("A", Some (Tuple [ String "a" ]))) = A "a" 117 | 118 | let%test _ = of_variant ~t:e_t (Constructor ("A", Some (String "a"))) = A "a" 119 | 120 | let%test _ = of_variant ~t:e_t (Constructor ("E1", Some (String "a"))) = A "a" 121 | 122 | let%test _ = 123 | of_variant ~t:e_t 124 | (Constructor ("E3", Some (Record [ ("native", String "0") ]))) 125 | = C { i = Nativeint.zero } 126 | 127 | type f = int * string [@@deriving t] 128 | 129 | let f_flip = function 130 | | Tuple [ String s; Int i ] -> Some (Tuple [ Int i; String s ]) 131 | | _ -> None 132 | 133 | let f_custom = function Int i -> Some (i, string_of_int i) | _ -> None 134 | 135 | let f_i = ref 0 136 | 137 | let f_default () = 138 | f_i := succ !f_i; 139 | (!f_i, "0") 140 | 141 | let f_t = of_variant_mapper ~name:"Variantizer.f_flip" ~t:f_t f_flip 142 | 143 | let f_t = of_variant_custom ~name:"Variantizer.f_custom" ~t:f_t f_custom 144 | 145 | let f_t = of_variant_default ~name:"Variantizer.f_default" ~t:f_t f_default 146 | 147 | let%expect_test _ = 148 | Format.printf "%a\n%!" Ttype.print [%t: f]; 149 | [%expect 150 | {| (int * string) [@prop {of_variant_custom_uid = "0"; of_variant_custom_uid = "1"; of_variant_custom_uid = "2"}] |}] 151 | 152 | let of_variant_string ~t s = variant_of_string s |> of_variant ~t 153 | 154 | let%test "mapper0" = of_variant_string ~t:f_t "(1, \"1\")" = (1, "1") 155 | 156 | let%test "mapper1" = of_variant_string ~t:f_t "(\"1\", 1)" = (1, "1") 157 | 158 | let%test "custom" = of_variant_string ~t:f_t "42" = (42, "42") 159 | 160 | let%test "default0" = of_variant_string ~t:f_t "Invalid" = (1, "0") 161 | 162 | let%test "default1" = of_variant_string ~t:f_t "Invalid" = (2, "0") 163 | 164 | let%test "default2" = of_variant_string ~t:f_t "Invalid" = (3, "0") 165 | --------------------------------------------------------------------------------