├── .github └── workflows │ └── changelog-check.yml ├── .gitignore ├── .ocamlformat ├── CHANGES.md ├── LICENSE.md ├── Makefile ├── README.md ├── README_PPX.md ├── bench ├── dune ├── main.ml ├── main.mli ├── output.ml ├── output.mli └── process │ └── main.py ├── dune-project ├── fuzz ├── dune ├── input │ └── 000 ├── main.ml └── rewriter │ ├── dune │ ├── main.ml │ └── main.mli ├── ppx_repr.opam ├── repr-bench.opam ├── repr-fuzz.opam ├── repr.opam ├── src ├── ppx_repr │ ├── bin │ │ ├── dune │ │ ├── ppx_repr.ml │ │ └── ppx_repr.mli │ └── lib │ │ ├── algebraic.ml │ │ ├── algebraic.mli │ │ ├── algebraic_intf.ml │ │ ├── attributes.ml │ │ ├── attributes.mli │ │ ├── attributes_intf.ml │ │ ├── dsl.ml │ │ ├── dune │ │ ├── engine.ml │ │ ├── engine.mli │ │ ├── engine_intf.ml │ │ ├── meta_deriving.ml │ │ ├── meta_deriving.mli │ │ ├── monad.ml │ │ ├── monad.mli │ │ ├── monad_intf.ml │ │ ├── plugins.ml │ │ ├── plugins.mli │ │ ├── ppx_repr_lib.ml │ │ ├── raise.ml │ │ ├── raise.mli │ │ └── utils.ml └── repr │ ├── attribute.ml │ ├── attribute.mli │ ├── attribute_intf.ml │ ├── binary.ml │ ├── binary.mli │ ├── binary_intf.ml │ ├── dune │ ├── higher.ml │ ├── repr.ml │ ├── size.ml │ ├── staging.ml │ ├── staging.mli │ ├── type.ml │ ├── type.mli │ ├── type_binary.ml │ ├── type_binary.mli │ ├── type_core.ml │ ├── type_core.mli │ ├── type_core_intf.ml │ ├── type_intf.ml │ ├── type_json.ml │ ├── type_json.mli │ ├── type_ordered.ml │ ├── type_ordered.mli │ ├── type_pp.ml │ ├── type_pp.mli │ ├── type_random.ml │ ├── type_random.mli │ ├── type_size.ml │ ├── type_size.mli │ ├── utils.ml │ ├── utils.mli │ ├── witness.ml │ └── witness.mli └── test ├── ppx_repr └── deriver │ ├── dune │ ├── errors │ ├── dune │ ├── dune.inc │ ├── lib_invalid.expected │ ├── lib_invalid.ml │ ├── nobuiltin_nonempty.expected │ ├── nobuiltin_nonempty.ml │ ├── pp.ml │ ├── recursion_more_than_two.expected │ ├── recursion_more_than_two.ml │ ├── recursion_with_type_parameters.expected │ ├── recursion_with_type_parameters.ml │ ├── unsupported_polyvar_inherit_case.expected │ ├── unsupported_polyvar_inherit_case.ml │ ├── unsupported_tuple_size.expected │ ├── unsupported_tuple_size.ml │ ├── unsupported_type_arrow.expected │ ├── unsupported_type_arrow.ml │ ├── unsupported_type_extension.expected │ ├── unsupported_type_extension.ml │ ├── unsupported_type_open.expected │ ├── unsupported_type_open.ml │ ├── unsupported_type_open_polyvariant.expected │ ├── unsupported_type_open_polyvariant.ml │ ├── unsupported_type_package.expected │ ├── unsupported_type_package.ml │ ├── unsupported_type_poly.expected │ └── unsupported_type_poly.ml │ ├── gen_dune_rules.ml │ └── passing │ ├── alias.expected │ ├── alias.ml │ ├── arguments.expected │ ├── arguments.ml │ ├── as_alias.expected │ ├── as_alias.ml │ ├── basic.expected │ ├── basic.ml │ ├── composite.expected │ ├── composite.ml │ ├── dune │ ├── dune.inc │ ├── extension.expected │ ├── extension.ml │ ├── json_module.expected │ ├── json_module.ml │ ├── lib_relocated.expected │ ├── lib_relocated.ml │ ├── meta_deriving.expected │ ├── meta_deriving.ml │ ├── module.expected │ ├── module.ml │ ├── nobuiltin.expected │ ├── nobuiltin.ml │ ├── nonrec.expected │ ├── nonrec.ml │ ├── polyvariant.expected │ ├── polyvariant.ml │ ├── pp.ml │ ├── record.expected │ ├── record.ml │ ├── recursive.expected │ ├── recursive.ml │ ├── signature.expected │ ├── signature.ml │ ├── tuple_deep.expected │ ├── tuple_deep.ml │ ├── type_params.expected │ ├── type_params.ml │ ├── variant.expected │ └── variant.ml └── repr ├── dune ├── import.ml ├── main.ml ├── main.mli ├── test_pre_hash.ml ├── test_pre_hash.mli ├── test_size_of.ml └── test_size_of.mli /.github/workflows/changelog-check.yml: -------------------------------------------------------------------------------- 1 | name: Changelog check 2 | 3 | on: 4 | pull_request: 5 | branches: [ main ] 6 | types: [ opened, synchronize, reopened, labeled, unlabeled ] 7 | 8 | jobs: 9 | build: 10 | runs-on: ubuntu-latest 11 | 12 | steps: 13 | - uses: actions/checkout@v1 14 | 15 | - name: git diff 16 | if: ${{ !contains(github.event.pull_request.labels.*.name, 'no-changelog-needed') }} 17 | env: 18 | BASE_REF: ${{ github.event.pull_request.base.ref }} 19 | run: | 20 | ! git diff --exit-code origin/$BASE_REF -- CHANGES.md 21 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /_build 2 | /_opam 3 | *~ 4 | *.install 5 | *.merlin 6 | .envrc 7 | \#* 8 | .#* 9 | .*.swp 10 | **/.DS_Store 11 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version = 0.20.0 2 | profile = conventional 3 | 4 | ocaml-version = 4.08.0 5 | parse-docstrings 6 | break-infix = fit-or-vertical 7 | indicate-multiline-delimiters = no 8 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ### 0.7.0 (2023-08-02) 2 | 3 | - Add quadruples as another type combinator (#104, @patricoferris) 4 | 5 | - Expose the underlying `Jsonm.decoder` for custom JSON serialisation in 6 | functions like `Repr.like`. (#103, @patricoferris) 7 | 8 | ### 0.6.0 (2022-01-04) 9 | 10 | - Change the type of `Repr.decode_bin` to take a mutable buffer offset rather 11 | than threading an immutable position. (#81, @CraigFe) 12 | 13 | - Expose a `Repr.Binary` module providing direct access to functions for 14 | interacting with Repr's binary serialisation format. (#88, @CraigFe) 15 | 16 | ### 0.5.0 (2021-10-12) 17 | 18 | - Add `Repr.int63`, a representation of the `Optint.Int63.t` type (provided by 19 | the `optint` library). (#80, @CraigFe) 20 | 21 | - Change `Repr.{like,map,partially_abstract}` functions to not require `_ 22 | staged` wrappers around any (monomorphic) overrides. (#77, @CraigFe) 23 | 24 | - Fix a bug causing custom `Repr.{random,random_state}` implementations to be 25 | ignored. (#79, @CraigFe) 26 | 27 | - Fix `Repr.pre_hash` to rely on itself recursively. This ensures that custom 28 | `pre_hash` functions attached to components of larger types are not ignored. 29 | (#71, @CraigFe) 30 | 31 | ### 0.4.0 (2021-06-16) 32 | 33 | - Add `Repr.{random,random_state}`, a pair of generic functions for sampling 34 | random instances of representable types. (#58, @CraigFe) 35 | 36 | - Add `Repr.Size`, which provides sizing functions for binary codecs that are 37 | more informative than the existing `Repr.size_of`. Types built using `Repr.v` 38 | and `Repr.like` must now pass a sizer built using `Repr.Size.custom_*`. (#69, 39 | @CraigFe) 40 | 41 | ### 0.3.0 (2021-04-30) 42 | 43 | - `Repr.v` is now called `Repr.abstract`. (#52, @CraigFe) 44 | 45 | - Added `Repr.partially_abstract`, a helper combinator for constructing type 46 | representations with overridden operations. (#52, @CraigFe) 47 | 48 | - Add combinators for standard library container types: `ref`, `Lazy.t`, 49 | `Seq.t`, `Queue.t`, `Stack.t`, `Hashtbl.t`, `Set.t` and `Map.t`. 50 | (#43, @CraigFe) 51 | 52 | - Improve PPX `Repr.t` generation for types in the standard library. References 53 | to e.g. `Bool.t` or `Stdlib.Int32.t` will be resolved to the corresponding 54 | combinators. (#43, @CraigFe) 55 | 56 | - Add support for deriving mutually-recursive pairs of type representations 57 | with `ppx_repr`. (#42, @CraigFe) 58 | 59 | - Add a JSON object combinator: `Json.assoc` (#53, @Ngoguey42) 60 | 61 | - Drop the payload of NaN floating point values during JSON encoding. `-nan` 62 | strings are not emitted any more. (#55, @Ngoguey42) 63 | 64 | ### 0.2.1 (2021-01-18) 65 | 66 | - Support Ppxlib versions >= 0.18.0. (#35, @CraigFe) 67 | - Add missing dependency on `ppx_deriving`. (#36, @CraigFe) 68 | - Add a representation of the `Either.t` type. (#33, @CraigFe) 69 | 70 | ### 0.2.0 (2020-12-18) 71 | 72 | - Improve performance of variable-size integers encoding and decoding. 73 | (#24, #30, @samoht) 74 | - Require `short_hash` operations to be explicitly unstaged. 75 | (#15, @CraigFe) 76 | - Require `equal` and `compare` operations to be explicitly unstaged. 77 | (#16, @samoht) 78 | 79 | ### 0.1.0 (2020-10-16) 80 | 81 | Initial release. 82 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | ## ISC License 2 | 3 | Copyright (c) 2013-2020 Thomas Gazagnaire 4 | Copyright (c) 2019-2020 Craig Ferguson 5 | 6 | Permission to use, copy, modify, and distribute this software for any 7 | purpose with or without fee is hereby granted, provided that the above 8 | copyright notice and this permission notice appear in all copies. 9 | 10 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: bench 2 | 3 | bench: 4 | @dune exec -- bench/main.exe 5 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## Repr — run-time representations of OCaml types 2 | 3 | [![OCaml-CI Build Status](https://img.shields.io/endpoint?url=https%3A%2F%2Fci.ocamllabs.io%2Fbadge%2Fmirage%2Frepr%2Fmain&logo=ocaml)](https://ci.ocamllabs.io/github/mirage/repr) 4 | [![Documentation](https://img.shields.io/badge/doc-online-blue.svg)][docs] 5 | 6 | `Repr` is a library of type combinators for defining runtime representations of 7 | OCaml types and operations that are generic over those representations (`pp`, 8 | `to_string`, `compare` etc.) 9 | 10 | This library is currently experimental and provides no stability guarantee. The 11 | documentation is available [online][docs]. 12 | 13 | [docs]: https://mirage.github.io/repr/repr/index.html 14 | 15 | ### Installation 16 | 17 | `Repr` can be installed with `opam`: 18 | 19 | ``` 20 | opam install repr 21 | ``` 22 | -------------------------------------------------------------------------------- /README_PPX.md: -------------------------------------------------------------------------------- 1 | ## ppx_repr 2 | 3 | PPX extension for automatically generating type representations. 4 | 5 | ### Overview 6 | 7 | `ppx_repr` automatically generates type representations (values of type 8 | `_ Repr.t`) corresponding to type declarations in your code. For example: 9 | 10 | ```ocaml 11 | type 'a tree = 12 | | Branch of tree * bool option * tree 13 | | Leaf of 'a [@@deriving repr] 14 | ``` 15 | 16 | will be expanded to: 17 | 18 | ```ocaml 19 | type 'a tree = (* as above *) 20 | 21 | let tree_t leaf_t = 22 | let open Repr in 23 | mu (fun tree_t -> 24 | variant "tree" (fun branch leaf -> function 25 | | Branch (x1, x2, x3) -> branch (x1, x2, x3) 26 | | Leaf (x1, x2) -> leaf (x1, x2)) 27 | |~ case1 "Branch" (triple tree_t (option bool) tree_t) (fun (x1, x2, x3) -> Branch (x1, x2, x3)) 28 | |~ case1 "Leaf" leaf_t (fun x1 -> Leaf x1) 29 | |> sealv) 30 | ``` 31 | 32 | Type representations can also be derived inline using the `[%typ: ]` 33 | extension point. 34 | 35 | ### Installation and usage 36 | 37 | `ppx_repr` may be installed via [opam](https://opam.ocaml.org/): 38 | 39 | ``` 40 | opam install ppx_repr 41 | ``` 42 | 43 | If you're using the [dune](https://github.com/ocaml/dune) build system, add the 44 | following field to your `library`, `executable` or `test` stanza: 45 | 46 | ``` 47 | (preprocess (pps ppx_repr)) 48 | ``` 49 | 50 | You can now use `[@@deriving repr]` after a type declaration in your code to 51 | automatically derive a type representation with the same name. 52 | 53 | ### Specifics 54 | 55 | `ppx_repr` supports all of the type combinators exposed in the 56 | [Repr](https://docs.mirage.io/repr/Repr/index.html) module (basic 57 | types, records, variants (plain and closed polymorphic), recursive types etc.). 58 | Types with parameters will result in parameterised representations (i.e. type 59 | `'a t` is generated a representation of type `'a Type.t -> 'a t Type.t`). 60 | 61 | To supply base representations from a module other than `Repr` (such as 62 | when `Repr` is aliased to a different module path), the `lib` argument 63 | can be passed to `@@deriving repr`: 64 | 65 | ```ocaml 66 | type foo = unit [@@deriving repr { lib = Some "Mylib.Types" }] 67 | 68 | (* generates the value *) 69 | val foo_t = Mylib.Types.unit 70 | ``` 71 | 72 | This argument can also be passed as a command-line option (i.e. `--lib 73 | Mylib.Types`, with `--lib ''` interpreted as the current module). 74 | 75 | #### Naming scheme 76 | 77 | The generated type representation will be called `_t`, unless the 78 | type-name is `t`, in which case the representation is simply `t`. This 79 | behaviour can be overridden using the `name` argument, as in: 80 | 81 | ```ocaml 82 | type foo = string list * int32 [@@deriving repr { name = "foo_repr" }] 83 | 84 | (* generates the value *) 85 | val foo_repr = Repr.(pair (list string) int32) 86 | ``` 87 | 88 | If the type contains an abstract type, `ppx_repr` will expect to find a 89 | corresponding type representation using its own naming rules. This can be 90 | overridden using the `[@repr ...]` attribute, as in: 91 | 92 | ```ocaml 93 | type bar = (foo [@repr foo_repr], string) result [@@deriving repr] 94 | 95 | (* generates the value *) 96 | val bar_t = Repr.(result foo_repr string) 97 | ``` 98 | 99 | Built-in abstract types such as `unit` are assumed to be represented in 100 | `Repr`. This behaviour can be overridden with the `[@nobuiltin]` 101 | attribute: 102 | 103 | ```ocaml 104 | type t = unit [@nobuiltin] [@@deriving repr] 105 | 106 | (* generates the value *) 107 | let t = unit_t (* not [Repr.unit] *) 108 | ``` 109 | 110 | #### Signature type definitions 111 | 112 | The `ppx_repr` deriver can also be used in signatures to expose the 113 | auto-generated value: 114 | 115 | ```ocaml 116 | module Contents : sig 117 | type t = int32 [@@deriving repr] 118 | 119 | (* exposes repr in signature *) 120 | val t : t Repr.t 121 | 122 | end = struct 123 | type t = int32 [@@deriving repr] 124 | 125 | (* generates repr value *) 126 | val t = Repr.int32 127 | end 128 | ``` 129 | -------------------------------------------------------------------------------- /bench/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name repr-bench) 4 | (package repr-bench) 5 | (libraries repr bechamel fpath yojson unix) 6 | (preprocess 7 | (pps ppx_repr))) 8 | 9 | (rule 10 | (alias bench) 11 | (package repr-bench) 12 | (deps main.exe) 13 | (action (progn))) 14 | 15 | ;; Require [main.ml] to compile during tests 16 | 17 | (rule 18 | (alias runtest) 19 | (package repr-bench) 20 | (deps main.exe) 21 | (action progn)) 22 | -------------------------------------------------------------------------------- /bench/main.mli: -------------------------------------------------------------------------------- 1 | (* Intentionally empty *) 2 | -------------------------------------------------------------------------------- /bench/output.ml: -------------------------------------------------------------------------------- 1 | (** Reporter for the benchmarking format described in 2 | {:https://github.com/gs0510/index-benchmarks#benchmarks-format}. *) 3 | 4 | let ( >> ) f g x = g (f x) 5 | 6 | let unit_of_metric_name = function 7 | | "major-allocated" -> Some "words" 8 | | "minor-allocated" -> Some "words" 9 | | "monotonic-clock" -> Some "ns" 10 | | _ -> None 11 | 12 | type metric = { metric_name : string; unit : string option } 13 | 14 | let metric_to_string { metric_name; unit } = 15 | metric_name ^ Option.fold ~none:"" ~some:(Fmt.str " (%s)") unit 16 | 17 | type measurements = (metric * float) list 18 | 19 | let measurements_to_yojson ms = 20 | `Assoc (ms |> List.map (fun (m, v) -> (metric_to_string m, `Float v))) 21 | 22 | type bench_result = { 23 | bench_name : string; [@key "name"] 24 | measurements : measurements; [@key "metrics"] 25 | } 26 | 27 | type output = { results : bench_result list } 28 | 29 | let bench_result_to_yojson { bench_name; measurements } = 30 | `Assoc 31 | [ 32 | ("name", `String bench_name); 33 | ("metrics", measurements_to_yojson measurements); 34 | ] 35 | 36 | let output_to_yojson { results } = 37 | `Assoc [ ("results", `List (List.map bench_result_to_yojson results)) ] 38 | 39 | (** Lift a binary function to operate over a larger type using an inner 40 | projection. *) 41 | let under2 : type a b c. (a -> b) -> (b -> b -> c) -> a -> a -> c = 42 | fun f g a b -> g (f a) (f b) 43 | 44 | let sort_results = 45 | let sort_measurements = 46 | List.sort 47 | (under2 (fun ({ metric_name; _ }, _) -> metric_name) String.compare) 48 | in 49 | List.map (fun { bench_name; measurements } -> 50 | { bench_name; measurements = sort_measurements measurements }) 51 | >> List.sort (under2 (fun { bench_name; _ } -> bench_name) String.compare) 52 | 53 | let replace2 : type k v. (k, (k, v) Hashtbl.t) Hashtbl.t -> k -> k -> v -> unit 54 | = 55 | fun h k1 k2 v -> 56 | match Hashtbl.find_opt h k1 with 57 | | Some h_inner -> Hashtbl.replace h_inner k2 v 58 | | None -> 59 | let h_inner = Hashtbl.create 0 in 60 | Hashtbl.replace h_inner k2 v; 61 | Hashtbl.replace h k1 h_inner 62 | 63 | let hashtbl_transpose : type a b. ((a, (a, b) Hashtbl.t) Hashtbl.t as 'h) -> 'h 64 | = 65 | fun h -> 66 | let new_h = Hashtbl.create 0 in 67 | Hashtbl.iter 68 | (fun a_outer -> 69 | Hashtbl.iter (fun a_inner b -> replace2 new_h a_inner a_outer b)) 70 | h; 71 | new_h 72 | 73 | let add_measurement : 74 | string -> Bechamel.Analyze.OLS.t -> ((metric * float) list as 'acc) -> 'acc 75 | = 76 | fun metric_name analysis -> 77 | let metric = { metric_name; unit = unit_of_metric_name metric_name } in 78 | let value = 79 | let open Bechamel.Analyze.OLS in 80 | match (estimates analysis, predictors analysis) with 81 | | Some [ value ], [ "run" ] -> value 82 | | estimates, predictors -> 83 | Fmt.failwith "Unexpected results: { estimates = %a; predictors = %a }" 84 | Fmt.(Dump.option (Dump.list float)) 85 | estimates 86 | Fmt.(Dump.list string) 87 | predictors 88 | in 89 | List.cons (metric, value) 90 | 91 | let pp_results = 92 | Fmt.using 93 | ((* Bechamel reports results indexed by [metric] then by [bench_name], but 94 | the output format indexes in the reverse order. *) 95 | hashtbl_transpose 96 | >> (fun h -> 97 | Hashtbl.fold 98 | (fun bench_name measurements -> 99 | let measurements = Hashtbl.fold add_measurement measurements [] in 100 | List.cons { bench_name; measurements }) 101 | h []) 102 | >> sort_results 103 | >> (fun results -> { results }) 104 | >> output_to_yojson) 105 | Yojson.Safe.pretty_print 106 | -------------------------------------------------------------------------------- /bench/output.mli: -------------------------------------------------------------------------------- 1 | val ( >> ) : ('a -> 'b) -> ('b -> 'c) -> 'a -> 'c 2 | 3 | val pp_results : 4 | (string, (string, Bechamel.Analyze.OLS.t) Hashtbl.t) Hashtbl.t Fmt.t 5 | -------------------------------------------------------------------------------- /bench/process/main.py: -------------------------------------------------------------------------------- 1 | import json 2 | import pandas as pd 3 | 4 | data_fd = open('_build/default/bench/irmin/data/latest.json', 'r') 5 | data = json.load(data_fd)['results'] 6 | data_fd.close() 7 | 8 | df = pd.json_normalize(data) 9 | print(df) 10 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.7) 2 | (generate_opam_files true) 3 | (allow_approximate_merlin) 4 | 5 | (name repr) 6 | (source (github mirage/repr)) 7 | (license ISC) 8 | (authors "Thomas Gazagnaire" "Craig Ferguson") 9 | (maintainers "thomas@gazagnaire.org") 10 | 11 | (package 12 | (name repr) 13 | (documentation "https://mirage.github.io/repr") 14 | (depends 15 | (ocaml (>= 4.08.0)) 16 | (fmt (>= 0.8.7)) 17 | uutf 18 | either 19 | (jsonm (>= 1.0.0)) 20 | (base64 (>= 3.0.0)) 21 | (optint (>= 0.1.0))) 22 | (synopsis "Dynamic type representations. Provides no stability guarantee") 23 | (description "\ 24 | This package defines a library of combinators for building dynamic type 25 | representations and a set of generic operations over representable types, used 26 | in the implementation of Irmin and related packages. 27 | 28 | It is not yet intended for public consumption and provides no stability 29 | guarantee. 30 | ")) 31 | 32 | (package 33 | (name ppx_repr) 34 | (documentation "https://mirage.github.io/repr") 35 | (depends 36 | (repr (= :version)) 37 | (ppxlib (>= 0.12.0)) 38 | ppx_deriving 39 | fmt 40 | ; Test dependencies inherited from [repr] (see [test/repr/dune]) 41 | (hex :with-test) 42 | (optint (and (>= 0.1.0) :with-test)) 43 | (alcotest (and (>= 1.4.0) :with-test))) 44 | ;; See https://github.com/mirage/repr/issues/48 45 | ;; Can be removed once using Ppxlib >= 0.16.0 46 | (conflicts (ocaml-migrate-parsetree (= 1.7.1))) 47 | (synopsis "PPX deriver for type representations") 48 | (description "PPX deriver for type representations")) 49 | 50 | (package 51 | (name repr-bench) 52 | (documentation "https://mirage.github.io/repr") 53 | (depends 54 | (repr (= :version)) 55 | (ppx_repr (= :version)) 56 | bechamel 57 | yojson 58 | fpath) 59 | (synopsis "Benchmarks for the `repr` package") 60 | (description "Benchmarks for the `repr` package")) 61 | 62 | (package 63 | (name repr-fuzz) 64 | (documentation "https://mirage.github.io/repr") 65 | (depends 66 | (repr (= :version)) 67 | (crowbar (= 0.2)) 68 | (ppxlib (and (>= 0.12.0)))) 69 | (synopsis "Fuzz tests for the `repr` package") 70 | (description "Fuzz tests for the `repr` package")) 71 | -------------------------------------------------------------------------------- /fuzz/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name repr-fuzz) 4 | (package repr-fuzz) 5 | (libraries crowbar repr) 6 | (preprocess 7 | (pps repr-fuzz.rewriter))) 8 | 9 | ;; Start fuzzing when calling `dune build @fuzz`. 10 | 11 | (rule 12 | (alias fuzz) 13 | (deps 14 | (source_tree ./input)) 15 | (action 16 | (run afl-fuzz -i ./input -o output %{exe:fuzz_types.exe} @@))) 17 | 18 | (rule 19 | (alias runtest) 20 | (package repr-fuzz) 21 | (deps main.exe) 22 | (action progn)) 23 | -------------------------------------------------------------------------------- /fuzz/input/000: -------------------------------------------------------------------------------- 1 | qwerty -------------------------------------------------------------------------------- /fuzz/rewriter/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name main) 3 | (public_name repr-fuzz.rewriter) 4 | (kind ppx_rewriter) 5 | (libraries ppxlib) 6 | (preprocess 7 | (pps ppxlib.metaquot))) 8 | -------------------------------------------------------------------------------- /fuzz/rewriter/main.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | 3 | (* 4 | * - [%impl_record n] becomes becomes a function which builds record representations with 1 up to [n] fields. 5 | * - [%impl_variant n] becomes a function which builds variant representations with 1 up to [n] cases. 6 | *) 7 | 8 | module type S = sig 9 | val impl_record : int -> expression 10 | val impl_variant : int -> expression 11 | end 12 | 13 | let ( >>| ) x f = List.map f x 14 | let ( >>= ) x f = List.map f x |> List.flatten 15 | 16 | module Located (A : Ast_builder.S) : S = struct 17 | open A 18 | 19 | let ev n i = evar (n ^ string_of_int i) 20 | let pv n i = pvar (n ^ string_of_int i) 21 | 22 | let plist : pattern list -> pattern = 23 | fun ps -> 24 | List.fold_right (fun hd tl -> [%pat? [%p hd] :: [%p tl]]) ps [%pat? []] 25 | 26 | let elist : expression list -> expression = 27 | fun es -> 28 | List.fold_right (fun hd tl -> [%expr [%e hd] :: [%e tl]]) es [%expr []] 29 | 30 | let efun ~(params : pattern list) : expression -> expression = 31 | List.fold_right 32 | (fun param body -> [%expr fun [%p param] -> [%e body]]) 33 | params 34 | 35 | let error_case ~msg : case = 36 | case ~lhs:ppat_any ~guard:None ~rhs:[%expr failwith [%e estring msg]] 37 | 38 | (** Generates the code for the [%impl_record n] extension point. *) 39 | let impl_record n = 40 | let generate_case indices = 41 | let lhs = 42 | plist (indices >>| fun i -> [%pat? [%p pv "n" i], AT [%p pv "t" i]]) 43 | in 44 | let wrap_params = efun ~params:(indices >>| pv "v") in 45 | let rhs = 46 | let apply_fields body = 47 | indices 48 | >>| (fun i body -> 49 | [%expr 50 | [%e body] 51 | |+ T.field [%e ev "n" i] 52 | (t_to_repr [%e ev "t" i]) 53 | (new_dyn_record_getter record_name [%e ev "n" i] 54 | [%e ev "t" i])]) 55 | |> List.fold_left ( |> ) body 56 | in 57 | let values = 58 | indices >>| fun i -> 59 | [%expr [%e ev "n" i], wrap [%e ev "t" i] [%e ev "v" i]] 60 | in 61 | [%expr 62 | [%e 63 | apply_fields 64 | [%expr 65 | T.record record_name 66 | [%e 67 | wrap_params 68 | [%expr new_dyn_record record_name [%e elist values]]]]] 69 | |> T.sealr] 70 | in 71 | case ~lhs ~guard:None ~rhs 72 | in 73 | let cases = 74 | List.init n succ >>| (fun l -> List.init l succ) >>| generate_case 75 | in 76 | let error_case = 77 | error_case 78 | ~msg: 79 | (Format.sprintf 80 | "The given TRecord has a number of fields outside of [|1; %d|]" n) 81 | in 82 | [%expr 83 | fun record_name fs -> [%e pexp_match [%expr fs] (cases @ [ error_case ])]] 84 | 85 | let generate_case indices = 86 | let pattern : pattern = 87 | plist 88 | ( indices >>| fun (i, typ) -> 89 | match typ with 90 | | `Case0 -> [%pat? [%p pv "n" i], ACT Case0] 91 | | `Case1 -> [%pat? [%p pv "n" i], ACT (Case1 [%p pv "t" i])] ) 92 | in 93 | let wrap_params : expression -> expression = 94 | indices 95 | >>| (fun (i, _) -> pv "c" i) 96 | |> List.fold_right (fun param body -> [%expr fun [%p param] -> [%e body]]) 97 | in 98 | let inits : case list = 99 | let guard i = Some [%expr r = [%e ev "n" i]] in 100 | indices >>| function 101 | | i, `Case0 -> case ~lhs:[%pat? _, r, _] ~guard:(guard i) ~rhs:(ev "c" i) 102 | | i, `Case1 -> 103 | case 104 | ~lhs:[%pat? _, r, v] 105 | ~guard:(guard i) 106 | ~rhs:[%expr [%e ev "c" i] (unwrap [%e ev "t" i] v)] 107 | in 108 | let cases (body : expression) : expression = 109 | let case = function 110 | | i, `Case0 -> 111 | fun e -> 112 | [%expr 113 | [%e e] 114 | |~ T.case0 [%e ev "n" i] (variant_name, [%e ev "n" i], VUnit ())] 115 | | i, `Case1 -> 116 | fun e -> 117 | [%expr 118 | [%e e] 119 | |~ T.case1 [%e ev "n" i] 120 | (t_to_repr [%e ev "t" i]) 121 | (fun v -> 122 | (variant_name, [%e ev "n" i], wrap [%e ev "t" i] v))] 123 | in 124 | indices >>| case |> List.fold_left ( |> ) body 125 | in 126 | let rhs = 127 | let destructor = 128 | [ 129 | case 130 | ~lhs:[%pat? vn, _, _] 131 | ~guard:(Some [%expr not (variant_name = vn)]) 132 | ~rhs:[%expr variant_error vn]; 133 | ] 134 | @ inits 135 | @ [ 136 | case 137 | ~lhs:[%pat? _, unmatched_case_name, _] 138 | ~guard:None 139 | ~rhs:[%expr case_error unmatched_case_name]; 140 | ] 141 | in 142 | [%expr 143 | [%e 144 | cases 145 | [%expr 146 | T.variant variant_name [%e wrap_params (pexp_function destructor)]]] 147 | |> T.sealv] 148 | in 149 | case ~lhs:pattern ~guard:None ~rhs 150 | 151 | (** Generates the code for the [%impl_variant n] extension point. *) 152 | let impl_variant n = 153 | let error_case = 154 | error_case 155 | ~msg: 156 | (Format.sprintf 157 | "The given TVariant has a number of fields outside of [|1; %d|]." n) 158 | in 159 | (* Generate the i-th cartesian power l^i. *) 160 | let rec cart l = function 161 | | 0 -> [ [] ] 162 | | i -> 163 | cart l (i - 1) >>= fun p -> 164 | l >>| fun e -> e :: p 165 | in 166 | let cases = 167 | List.init n succ 168 | >>= cart [ `Case0; `Case1 ] 169 | >>| List.mapi (fun i t -> (succ i, t)) 170 | >>| generate_case 171 | in 172 | [%expr 173 | fun variant_name cs -> 174 | let variant_error = 175 | Fmt.failwith "Trying to access the wrong variant: wanted %s, got %s" 176 | variant_name 177 | in 178 | let case_error = 179 | Fmt.failwith "Trying to use an unknown case name: %s" 180 | in 181 | [%e pexp_match [%expr cs] (cases @ [ error_case ])]] 182 | end 183 | 184 | let () = 185 | let extension f name = 186 | Extension.declare name Extension.Context.Expression 187 | Ast_pattern.(pstr (pstr_eval (eint __) nil ^:: nil)) 188 | (fun ~loc ~path:_ -> 189 | let (module A) = Ast_builder.make loc in 190 | f (module Located (A) : S)) 191 | |> Context_free.Rule.extension 192 | in 193 | Driver.register_transformation 194 | ~rules: 195 | [ 196 | extension (fun (module L) -> L.impl_record) "impl_record"; 197 | extension (fun (module L) -> L.impl_variant) "impl_variant"; 198 | ] 199 | "alcotest.test" 200 | -------------------------------------------------------------------------------- /fuzz/rewriter/main.mli: -------------------------------------------------------------------------------- 1 | (* Intentionally empty *) 2 | -------------------------------------------------------------------------------- /ppx_repr.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "PPX deriver for type representations" 4 | description: "PPX deriver for type representations" 5 | maintainer: ["thomas@gazagnaire.org"] 6 | authors: ["Thomas Gazagnaire" "Craig Ferguson"] 7 | license: "ISC" 8 | homepage: "https://github.com/mirage/repr" 9 | doc: "https://mirage.github.io/repr" 10 | bug-reports: "https://github.com/mirage/repr/issues" 11 | depends: [ 12 | "dune" {>= "2.7"} 13 | "repr" {= version} 14 | "ppxlib" {>= "0.12.0"} 15 | "ppx_deriving" 16 | "fmt" 17 | "hex" {with-test} 18 | "optint" {>= "0.1.0" & with-test} 19 | "alcotest" {>= "1.4.0" & with-test} 20 | "odoc" {with-doc} 21 | ] 22 | conflicts: [ 23 | "ocaml-migrate-parsetree" {= "1.7.1"} 24 | ] 25 | build: [ 26 | ["dune" "subst"] {dev} 27 | [ 28 | "dune" 29 | "build" 30 | "-p" 31 | name 32 | "-j" 33 | jobs 34 | "@install" 35 | "@runtest" {with-test} 36 | "@doc" {with-doc} 37 | ] 38 | ] 39 | dev-repo: "git+https://github.com/mirage/repr.git" 40 | -------------------------------------------------------------------------------- /repr-bench.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Benchmarks for the `repr` package" 4 | description: "Benchmarks for the `repr` package" 5 | maintainer: ["thomas@gazagnaire.org"] 6 | authors: ["Thomas Gazagnaire" "Craig Ferguson"] 7 | license: "ISC" 8 | homepage: "https://github.com/mirage/repr" 9 | doc: "https://mirage.github.io/repr" 10 | bug-reports: "https://github.com/mirage/repr/issues" 11 | depends: [ 12 | "dune" {>= "2.7"} 13 | "repr" {= version} 14 | "ppx_repr" {= version} 15 | "bechamel" 16 | "yojson" 17 | "fpath" 18 | "odoc" {with-doc} 19 | ] 20 | build: [ 21 | ["dune" "subst"] {dev} 22 | [ 23 | "dune" 24 | "build" 25 | "-p" 26 | name 27 | "-j" 28 | jobs 29 | "@install" 30 | "@runtest" {with-test} 31 | "@doc" {with-doc} 32 | ] 33 | ] 34 | dev-repo: "git+https://github.com/mirage/repr.git" 35 | -------------------------------------------------------------------------------- /repr-fuzz.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Fuzz tests for the `repr` package" 4 | description: "Fuzz tests for the `repr` package" 5 | maintainer: ["thomas@gazagnaire.org"] 6 | authors: ["Thomas Gazagnaire" "Craig Ferguson"] 7 | license: "ISC" 8 | homepage: "https://github.com/mirage/repr" 9 | doc: "https://mirage.github.io/repr" 10 | bug-reports: "https://github.com/mirage/repr/issues" 11 | depends: [ 12 | "dune" {>= "2.7"} 13 | "repr" {= version} 14 | "crowbar" {= "0.2"} 15 | "ppxlib" {>= "0.12.0"} 16 | "odoc" {with-doc} 17 | ] 18 | build: [ 19 | ["dune" "subst"] {dev} 20 | [ 21 | "dune" 22 | "build" 23 | "-p" 24 | name 25 | "-j" 26 | jobs 27 | "@install" 28 | "@runtest" {with-test} 29 | "@doc" {with-doc} 30 | ] 31 | ] 32 | dev-repo: "git+https://github.com/mirage/repr.git" 33 | -------------------------------------------------------------------------------- /repr.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Dynamic type representations. Provides no stability guarantee" 4 | description: """ 5 | This package defines a library of combinators for building dynamic type 6 | representations and a set of generic operations over representable types, used 7 | in the implementation of Irmin and related packages. 8 | 9 | It is not yet intended for public consumption and provides no stability 10 | guarantee. 11 | """ 12 | maintainer: ["thomas@gazagnaire.org"] 13 | authors: ["Thomas Gazagnaire" "Craig Ferguson"] 14 | license: "ISC" 15 | homepage: "https://github.com/mirage/repr" 16 | doc: "https://mirage.github.io/repr" 17 | bug-reports: "https://github.com/mirage/repr/issues" 18 | depends: [ 19 | "dune" {>= "2.7"} 20 | "ocaml" {>= "4.08.0"} 21 | "fmt" {>= "0.8.7"} 22 | "uutf" 23 | "either" 24 | "jsonm" {>= "1.0.0"} 25 | "base64" {>= "3.0.0"} 26 | "optint" {>= "0.1.0"} 27 | "odoc" {with-doc} 28 | ] 29 | build: [ 30 | ["dune" "subst"] {dev} 31 | [ 32 | "dune" 33 | "build" 34 | "-p" 35 | name 36 | "-j" 37 | jobs 38 | "@install" 39 | "@runtest" {with-test} 40 | "@doc" {with-doc} 41 | ] 42 | ] 43 | dev-repo: "git+https://github.com/mirage/repr.git" 44 | -------------------------------------------------------------------------------- /src/ppx_repr/bin/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name ppx_repr) 3 | (kind ppx_deriver) 4 | (ppx_runtime_libraries repr) 5 | (libraries ppx_repr_lib ppxlib)) 6 | -------------------------------------------------------------------------------- /src/ppx_repr/bin/ppx_repr.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2019-2020 Craig Ferguson 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | module Plugins = Ppx_repr_lib.Plugins.Make (struct 18 | let default_library = "Repr" 19 | let namespace = "repr" 20 | end) 21 | 22 | let () = 23 | Plugins.register_deriver (); 24 | Plugins.register_extension () 25 | -------------------------------------------------------------------------------- /src/ppx_repr/bin/ppx_repr.mli: -------------------------------------------------------------------------------- 1 | (* Intentionally empty *) 2 | -------------------------------------------------------------------------------- /src/ppx_repr/lib/algebraic.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2019-2020 Craig Ferguson 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | include Algebraic_intf 18 | open Typ 19 | open Ppxlib 20 | 21 | module Located (A : Ast_builder.S) (M : Monad.S) : S with module M = M = struct 22 | module M = M 23 | open Utils 24 | open Utils.Make (A) 25 | open A 26 | 27 | let generate_identifiers n = 28 | List.init n (fun i -> Printf.sprintf "x%d" (i + 1)) 29 | 30 | let dsl ~lib = 31 | (function 32 | | `field -> "field" 33 | | `case1 -> "case1" 34 | | `case0 -> "case0" 35 | | `add_case -> "|~" 36 | | `add_field -> "|+" 37 | | `sealr -> "sealr" 38 | | `sealv -> "sealv" 39 | | `record -> "record" 40 | | `variant -> "variant") 41 | >> (match lib with Some l -> ( ^ ) (l ^ ".") | None -> fun x -> x) 42 | >> evar 43 | 44 | (** {1 Helper functions for various subfragments} *) 45 | 46 | let construct ~polymorphic ?body name = 47 | if polymorphic then pexp_variant name body 48 | else pexp_construct (Located.lident name) body 49 | 50 | (** {[ |~ case0 "cons_name" (`)Cons_name ]} *) 51 | let variant_case0 ~lib ~polymorphic ~cons_name e = 52 | [%expr 53 | [%e dsl ~lib `add_case] 54 | [%e e] 55 | ([%e dsl ~lib `case0] 56 | [%e estring cons_name] 57 | [%e construct ~polymorphic cons_name])] 58 | 59 | (** {[ 60 | |~ case1 "cons_name" component_type (fun (x1, ..., xN) -> (`)Cons_name (x1, ..., xN)) 61 | ]} *) 62 | let variant_case1 ~lib ~polymorphic ~cons_name ~component_type ~idents e = 63 | let tuple_pat = idents >|= pvar |> ppat_tuple in 64 | let tuple_exp = idents >|= evar |> pexp_tuple in 65 | [%expr 66 | [%e dsl ~lib `add_case] 67 | [%e e] 68 | ([%e dsl ~lib `case1] [%e estring cons_name] [%e component_type] 69 | (fun [%p tuple_pat] -> 70 | [%e construct ~polymorphic ~body:tuple_exp cons_name]))] 71 | 72 | (** Wrapper for {!variant_case0} and {!variant_case1} *) 73 | let variant_case ~polymorphic { case_name; case_cons } = 74 | match case_cons with 75 | | None -> variant_case0 ~polymorphic ~cons_name:case_name 76 | | Some (component_type, n) -> 77 | let idents = generate_identifiers n in 78 | variant_case1 ~polymorphic ~cons_name:case_name ~component_type ~idents 79 | 80 | (** [|+ field "field_name" (field_type) (fun t -> t.field_name)] *) 81 | let record_field ~lib { field_name; field_repr } e = 82 | [%expr 83 | [%e dsl ~lib `add_field] 84 | [%e e] 85 | ([%e dsl ~lib `field] [%e estring field_name] [%e field_repr] (fun t -> 86 | [%e pexp_field (evar "t") (Located.lident field_name)]))] 87 | 88 | (** Record composites are encoded as a constructor function 89 | 90 | {[ fun field1 field2 ... fieldN -> { field1; field2; ...; fieldN }) ]} *) 91 | let record_composite fields = 92 | let fields = fields >|= fun l -> l.pld_name.txt in 93 | let record = 94 | let rfields = fields >|= fun s -> (Located.lident s, evar s) in 95 | pexp_record rfields None 96 | in 97 | lambda fields record 98 | 99 | (** {[ | Cons_name (x1, x2, x3) -> cons_name x1 x2 x3 ] ]} *) 100 | let variant_pattern cons_name pattern n = 101 | let fparam_of_name name = String.lowercase_ascii name in 102 | match n with 103 | | 0 -> 104 | let lhs = pattern None in 105 | let rhs = evar (fparam_of_name cons_name) in 106 | case ~lhs ~guard:None ~rhs 107 | | n -> 108 | let idents = generate_identifiers n in 109 | let lhs = idents >|= pvar |> ppat_tuple |> fun x -> pattern (Some x) in 110 | let rhs = 111 | idents >|= evar |> pexp_tuple |> fun x -> 112 | [%expr [%e evar (fparam_of_name cons_name)] [%e x]] 113 | in 114 | case ~lhs ~guard:None ~rhs 115 | 116 | (** Variant composites are encoded as a destructor function: 117 | 118 | {[ 119 | fun case1 case2 ... caseN -> function 120 | | Case1 x -> case1 c 121 | | Case2 (x1, x2) -> case2 x1 x2 122 | ... 123 | | CaseN -> casen 124 | ]} *) 125 | let variant_composite cs = 126 | let fparam_of_cdecl c = c.pcd_name.txt |> String.lowercase_ascii in 127 | let pattern_of_cdecl c = 128 | let pattern = ppat_construct (Located.map_lident c.pcd_name) in 129 | let n = 130 | match c.pcd_args with 131 | | Pcstr_tuple args -> List.length args 132 | | Pcstr_record _ -> invalid_arg "Inline record types unsupported" 133 | in 134 | variant_pattern c.pcd_name.txt pattern n 135 | in 136 | cs >|= pattern_of_cdecl |> pexp_function |> lambda (cs >|= fparam_of_cdecl) 137 | 138 | (** Analogous to {!variant_composite} but using AST fragments for polymorphic 139 | variants. *) 140 | let polyvariant_composite fs = 141 | let fparam_of_rowfield f = 142 | match f.prf_desc with 143 | | Rtag (label, _, _) -> String.lowercase_ascii label.txt 144 | | Rinherit _ -> assert false 145 | in 146 | let pattern_case_of_rowfield f = 147 | match f.prf_desc with 148 | | Rtag ({ txt; _ }, _, typs) -> 149 | let pattern = ppat_variant txt in 150 | let n = List.length typs in 151 | variant_pattern txt pattern n 152 | | Rinherit _ -> assert false 153 | in 154 | fs 155 | >|= pattern_case_of_rowfield 156 | |> pexp_function 157 | |> lambda (fs >|= fparam_of_rowfield) 158 | 159 | (** {1 Functional encodings of composite types} 160 | 161 | The functional encodings have a standard form: 162 | 163 | {[ 164 | 165 | |> 166 | |> 167 | |> 168 | |> 169 | ]} 170 | 171 | That is, they initially construct an 'open' representation of the 172 | composite, then add each of the subcomponents to the open representation 173 | using an 'augmenter', and finally 'seal' the representation. 174 | 175 | The following function extracts the necessary terms for each algebraic 176 | type. *) 177 | 178 | type ('a, 'b) dsl_terms = { 179 | combinator : expression; 180 | composite : 'a list -> expression; 181 | augment : 'b -> expression -> expression; 182 | sealer : expression; 183 | } 184 | 185 | let terms_of_typ : 186 | type a b. lib:string option -> (a, b) Typ.t -> (a, b) dsl_terms = 187 | fun ~lib typ -> 188 | let dsl = dsl ~lib in 189 | let combinator = 190 | dsl 191 | (match typ with 192 | | Record -> `record 193 | | Variant -> `variant 194 | | Polyvariant -> `variant) 195 | and composite : a list -> expression = 196 | match typ with 197 | | Record -> record_composite 198 | | Variant -> variant_composite 199 | | Polyvariant -> polyvariant_composite 200 | and augment : b -> expression -> expression = 201 | match typ with 202 | | Record -> record_field ~lib 203 | | Variant -> variant_case ~lib ~polymorphic:false 204 | | Polyvariant -> variant_case ~lib ~polymorphic:true 205 | and sealer = 206 | dsl 207 | (match typ with 208 | | Record -> `sealr 209 | | Variant -> `sealv 210 | | Polyvariant -> `sealv) 211 | in 212 | { combinator; composite; augment; sealer } 213 | 214 | let encode : 215 | type a b e. 216 | (a, b) Typ.t -> 217 | subderive:(a -> (b, e) M.t) -> 218 | lib:string option -> 219 | type_name:string -> 220 | a list -> 221 | (expression, e) M.t = 222 | fun typ ~subderive ~lib ~type_name ts -> 223 | let open M.Syntax in 224 | let dsl = terms_of_typ ~lib typ in 225 | let composite = dsl.composite ts in 226 | let+ apply_augments = 227 | ts 228 | >|= (subderive >> M.map dsl.augment) 229 | |> M.sequence 230 | |> M.map (List.rev >> compose_all) 231 | in 232 | let open_repr = 233 | [%expr [%e dsl.combinator] [%e estring type_name] [%e composite]] 234 | |> apply_augments 235 | in 236 | [%expr [%e dsl.sealer] [%e open_repr]] 237 | end 238 | -------------------------------------------------------------------------------- /src/ppx_repr/lib/algebraic.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2019-2020 Craig Ferguson 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (** Helper functions for deriving encodings of algebraic data types. *) 18 | 19 | include Algebraic_intf.Algebraic 20 | (** @inline *) 21 | -------------------------------------------------------------------------------- /src/ppx_repr/lib/algebraic_intf.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2019-2020 Craig Ferguson 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Ppxlib 18 | 19 | module Typ = struct 20 | type nonrec record_field_repr = { 21 | field_name : string; 22 | field_repr : expression; 23 | } 24 | 25 | and variant_case_repr = { 26 | case_name : string; 27 | case_cons : (expression * int) option; 28 | } 29 | 30 | (** The algebraic datatypes supported by this module, parameterised by: 31 | 32 | - ['a]: the subcomponent type of the algebraic type 33 | - ['b]: a generic representation of the subcomponent type necessary to 34 | derive the {i composite} type representation *) 35 | type (_, _) t = 36 | | Record : (label_declaration, record_field_repr) t 37 | | Variant : (constructor_declaration, variant_case_repr) t 38 | | Polyvariant : (row_field, variant_case_repr) t 39 | end 40 | 41 | module type S = sig 42 | module M : Monad.S 43 | 44 | val encode : 45 | ('a, 'b) Typ.t -> 46 | subderive:('a -> ('b, 'e) M.t) -> 47 | lib:string option -> 48 | type_name:string -> 49 | 'a list -> 50 | (expression, 'e) M.t 51 | (** Build the functional encoding of a composite type. Combine the various 52 | elements necessary for a functional encoding of a composite type 53 | [('a, 'b) {!typ}], in terms its components of type ['a list] and the name 54 | of the composite type [type_name]. 55 | 56 | This requires a function [subderive] for deriving the type representation 57 | of the subcomponents, which may run in a monadic context [M.t]. *) 58 | end 59 | 60 | module type Algebraic = sig 61 | module Typ = Typ 62 | 63 | module type S = S 64 | 65 | module Located (S : Ast_builder.S) (M : Monad.S) : S with module M = M 66 | end 67 | -------------------------------------------------------------------------------- /src/ppx_repr/lib/attributes.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2019-2020 Craig Ferguson 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | include Attributes_intf 18 | open Ppxlib 19 | 20 | module Make (T : sig 21 | val namespace : string 22 | end) = 23 | struct 24 | let repr = 25 | Attribute.declare 26 | (String.concat "." [ T.namespace; "repr" ]) 27 | Attribute.Context.Core_type 28 | Ast_pattern.(single_expr_payload __) 29 | (fun e -> e) 30 | 31 | let nobuiltin = 32 | Attribute.declare 33 | (String.concat "." [ T.namespace; "nobuiltin" ]) 34 | Attribute.Context.Core_type 35 | Ast_pattern.(pstr __') 36 | (fun s -> 37 | match s with 38 | | { txt = _ :: _; loc } -> 39 | Location.raise_errorf ~loc "`nobuiltin` payload must be empty" 40 | | { txt = []; _ } -> ()) 41 | 42 | let all = Attribute.[ T repr; T nobuiltin ] 43 | end 44 | -------------------------------------------------------------------------------- /src/ppx_repr/lib/attributes.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2019-2020 Craig Ferguson 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | include Attributes_intf.Attributes 18 | (** @inline *) 19 | -------------------------------------------------------------------------------- /src/ppx_repr/lib/attributes_intf.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | 3 | module type S = sig 4 | val repr : (core_type, expression) Attribute.t 5 | val nobuiltin : (core_type, unit) Attribute.t 6 | end 7 | 8 | module type Attributes = sig 9 | module type S = S 10 | 11 | module Make (T : sig 12 | val namespace : string 13 | end) : sig 14 | include S 15 | 16 | val all : Attribute.packed list 17 | (** Boxed list of all of the attributes required by [ppx_repr]. *) 18 | end 19 | end 20 | -------------------------------------------------------------------------------- /src/ppx_repr/lib/dsl.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2019-2020 Craig Ferguson 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Ppxlib 18 | 19 | (** This module defines the expected combinators exposed by Repr, and their 20 | correspondences to the types in the standard library. *) 21 | 22 | let rec drop_stdlib_prefix = function 23 | | (Lident _ | Lapply _) as l -> l 24 | | Ldot (Lident "Stdlib", suffix) -> Lident suffix 25 | | Ldot (l, suffix) -> Ldot (drop_stdlib_prefix l, suffix) 26 | 27 | let basic = 28 | [ 29 | "unit"; 30 | "bool"; 31 | "char"; 32 | "int"; 33 | "int32"; 34 | "int63"; 35 | "int64"; 36 | "float"; 37 | "string"; 38 | "bytes"; 39 | "list"; 40 | "array"; 41 | "option"; 42 | "result"; 43 | ] 44 | 45 | let containers = [ "either"; "hashtbl"; "queue"; "seq"; "stack" ] 46 | let type_in_default_scope name = (Lident name, name) 47 | 48 | let type_in_separate_module name = 49 | (Ldot (Lident (String.capitalize_ascii name), "t"), name) 50 | 51 | let type_to_combinator_name : longident -> string option = 52 | let correspondences = 53 | let assoc = 54 | (* Abstract types with equivalent combinator names: *) 55 | List.map type_in_default_scope basic 56 | (* Types named [t] within their own modules: *) 57 | @ List.map type_in_separate_module (basic @ containers) 58 | (* Technically [lazy_t] is not for direct use, but derive anyway: *) 59 | @ [ (Lident "lazy_t", "lazy_t"); (Ldot (Lident "Lazy", "t"), "lazy_t") ] 60 | (* [Int63.t] may be namespaced under [Optint.Int63.t]: *) 61 | @ [ (Ldot (Ldot (Lident "Optint", "Int63"), "t"), "int63") ] 62 | in 63 | List.to_seq assoc |> Hashtbl.of_seq 64 | in 65 | fun lident -> Hashtbl.find_opt correspondences (drop_stdlib_prefix lident) 66 | -------------------------------------------------------------------------------- /src/ppx_repr/lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_repr_lib) 3 | (public_name ppx_repr.lib) 4 | (libraries ppxlib fmt) 5 | (preprocess 6 | (pps ppxlib.metaquot))) 7 | -------------------------------------------------------------------------------- /src/ppx_repr/lib/engine.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2019-2020 Craig Ferguson 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | include Engine_intf.Engine 18 | (** @inline *) 19 | -------------------------------------------------------------------------------- /src/ppx_repr/lib/engine_intf.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2019-2020 Craig Ferguson 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Ppxlib 18 | 19 | module type S = sig 20 | val parse_lib : expression -> string option 21 | (** [parse_lib e] is [Some "foo"] or [None] if [e] is a [string option], and 22 | raises a located exception otherwise. Intended to be used for parsing the 23 | [lib] argument to the derivers. *) 24 | 25 | val expand_typ : ?lib:string -> core_type -> expression 26 | 27 | val derive_str : 28 | plugins:Meta_deriving.Plugin.t list -> 29 | name:string option -> 30 | lib:string option -> 31 | rec_flag * type_declaration list -> 32 | structure_item list 33 | (** Deriver for Irmin type representations. 34 | 35 | - [?name]: overrides the default name of the generated type 36 | representation; 37 | 38 | - [?lib]: overrides the default location for the primitive Irmin typereps. 39 | [~lib:None] will assume that the typereps are available in the same 40 | namespace. *) 41 | 42 | val derive_sig : 43 | plugins:Meta_deriving.Plugin.t list -> 44 | name:string option -> 45 | lib:string option -> 46 | rec_flag * type_declaration list -> 47 | signature_item list 48 | (** Deriver for Irmin type representation signatures. 49 | 50 | Optional arguments have the same meaning as in {!derive_str}. *) 51 | end 52 | 53 | module type Engine = sig 54 | module type S = S 55 | 56 | module Located (_ : Attributes.S) (_ : Ast_builder.S) : S 57 | end 58 | -------------------------------------------------------------------------------- /src/ppx_repr/lib/meta_deriving.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | 3 | module Plugin = struct 4 | type t = { 5 | name : string; 6 | type_name : [ `before | `after ]; 7 | impl : location -> expression -> expression; 8 | intf : location -> core_type -> core_type; 9 | } 10 | 11 | let create ?(type_name = `after) ~impl ~intf name = 12 | { name; type_name; impl; intf } 13 | 14 | let op_name_of_type_name t n = 15 | match (n, t.type_name) with 16 | | "t", _ -> t.name 17 | | x, `before -> Printf.sprintf "%s_%s" x t.name 18 | | x, `after -> Printf.sprintf "%s_%s" t.name x 19 | 20 | let derive_str t ~loc ~type_name ~params ~expr:repr = 21 | let (module Ast_builder) = Ast_builder.make loc in 22 | let open Ast_builder in 23 | let name = op_name_of_type_name t type_name in 24 | let expr = 25 | let body = t.impl loc repr in 26 | ListLabels.fold_right params ~init:body ~f:(fun p acc -> 27 | pexp_fun Nolabel None (pvar p) acc) 28 | in 29 | pstr_value Nonrecursive 30 | [ value_binding ~pat:(ppat_var (Located.mk name)) ~expr ] 31 | 32 | let derive_sig t ~loc ~type_name ~params ~ctyp:repr = 33 | let (module Ast_builder) = Ast_builder.make loc in 34 | let open Ast_builder in 35 | let name = op_name_of_type_name t type_name in 36 | let type_ = 37 | let return_type = t.intf loc repr in 38 | ListLabels.fold_right params ~init:return_type ~f:(ptyp_arrow Nolabel) 39 | in 40 | psig_value (value_description ~name:(Located.mk name) ~type_ ~prim:[]) 41 | 42 | let defaults = 43 | [ 44 | create "equal" 45 | ~impl:(fun loc t -> [%expr Repr.unstage (Repr.equal [%e t])]) 46 | ~intf:(fun loc t -> [%type: [%t t] -> [%t t] -> bool]); 47 | create "compare" 48 | ~impl:(fun loc t -> [%expr Repr.unstage (Repr.compare [%e t])]) 49 | ~intf:(fun loc t -> [%type: [%t t] -> [%t t] -> int]); 50 | create "size_of" 51 | ~impl:(fun loc t -> [%expr Repr.unstage (Repr.size_of [%e t])]) 52 | ~intf:(fun loc t -> [%type: [%t t] -> int option]); 53 | create "pp" 54 | ~impl:(fun loc t -> [%expr Repr.pp [%e t]]) 55 | ~intf:(fun loc t -> [%type: Stdlib.Format.formatter -> [%t t] -> unit]); 56 | create "pp_dump" 57 | ~impl:(fun loc t -> [%expr Repr.pp_dump [%e t]]) 58 | ~intf:(fun loc t -> [%type: Stdlib.Format.formatter -> [%t t] -> unit]); 59 | create "random" 60 | ~impl:(fun loc t -> [%expr Repr.unstage (Repr.random [%e t])]) 61 | ~intf:(fun loc t -> [%type: unit -> [%t t]]); 62 | create "to_bin_string" ~type_name:`before 63 | ~impl:(fun loc t -> [%expr Repr.unstage (Repr.to_bin_string [%e t])]) 64 | ~intf:(fun loc t -> [%type: [%t t] -> string]); 65 | create "of_bin_string" ~type_name:`before 66 | ~impl:(fun loc t -> [%expr Repr.unstage (Repr.of_bin_string [%e t])]) 67 | ~intf:(fun loc t -> 68 | [%type: string -> ([%t t], [ `Msg of string ]) Stdlib.result]); 69 | create "encode_bin" 70 | ~impl:(fun loc t -> [%expr Repr.unstage (Repr.encode_bin [%e t])]) 71 | ~intf:(fun loc t -> [%type: [%t t] -> (string -> unit) -> unit]); 72 | create "decode_bin" 73 | ~impl:(fun loc t -> [%expr Repr.unstage (Repr.decode_bin [%e t])]) 74 | ~intf:(fun loc t -> [%type: string -> int ref -> [%t t]]); 75 | create "short_hash" 76 | ~impl:(fun loc t -> [%expr Repr.unstage (Repr.short_hash [%e t])]) 77 | ~intf:(fun loc t -> [%type: ?seed:int -> [%t t] -> unit]); 78 | create "pre_hash" 79 | ~impl:(fun loc t -> [%expr Repr.unstage (Repr.pre_hash [%e t])]) 80 | ~intf:(fun loc t -> [%type: [%t t] -> (string -> unit) -> unit]); 81 | ] 82 | end 83 | 84 | (** [Deriving.Args.t] is a heterogeneous list that supports only [revcons] but 85 | we need [cons] below. As a workaround, we use our own argument list type for 86 | the intermediate representation. *) 87 | module Args = struct 88 | module Plain = Deriving.Args 89 | 90 | type (_, _) t = 91 | | [] : ('a, 'a) t 92 | | ( :: ) : 'a Plain.param * ('b, 'c) t -> ('a -> 'b, 'c) t 93 | 94 | let to_plain : type a b. (a, b) t -> (a, b) Plain.t = 95 | let rec aux : type a b c. (a, b) Plain.t -> (b, c) t -> (a, c) Plain.t = 96 | fun acc -> function [] -> acc | x :: xs -> aux Plain.(acc +> x) xs 97 | in 98 | fun t -> aux Deriving.Args.empty t 99 | 100 | let rec append : type a b c. (a, b) t -> (b, c) t -> (a, c) t = 101 | fun a b -> match a with [] -> b | x :: xs -> x :: append xs b 102 | end 103 | 104 | (** Each plugin gets a flag in the main deriver corresponding to whether it's 105 | activated or not. For instance, [\[@@deriving repr ~equal\]] indicates that 106 | the "equal" plugin should be run on this type definition. 107 | 108 | Given the list of plugins [ p1; p2; ... pn ], we need to build: 109 | 110 | - the [Deriving.Args] list of flags to pass to [Ppxlib]; 111 | - a corresponding function over booleans [fun b1 b2 ... bn -> ...] for 112 | Ppxlib to call indicating which of the plugins have been activated. 113 | 114 | For each derivation, we pass the list of activated plugins to the deriver. *) 115 | module Arg_collector = struct 116 | type _ t = 117 | | E : { 118 | args : ('f, 'output) Args.t; 119 | consumer : (Plugin.t list -> 'output) -> 'f; 120 | } 121 | -> 'output t 122 | 123 | let empty = E { args = Args.[]; consumer = (fun k -> k []) } 124 | 125 | let add (plugin : Plugin.t) (E { args; consumer }) = 126 | let args = Args.(Deriving.Args.flag plugin.name :: args) in 127 | let consumer k flag_passed = 128 | (* If this plugin has been selected, then add it to the list and pass it 129 | along, otherwise skip. *) 130 | consumer (fun ps -> if flag_passed then k (plugin :: ps) else k ps) 131 | in 132 | E { args; consumer } 133 | 134 | let for_plugins ps = ListLabels.fold_right ps ~f:add ~init:empty 135 | end 136 | 137 | let make_generator ?attributes ?deps ~args:extra_args ~supported_plugins f = 138 | let (E { args; consumer }) = Arg_collector.for_plugins supported_plugins in 139 | Deriving.Generator.make ?attributes ?deps 140 | Args.(to_plain (append args extra_args)) 141 | (fun ~loc ~path input -> 142 | consumer (fun plugins -> f ~loc ~path plugins input)) 143 | -------------------------------------------------------------------------------- /src/ppx_repr/lib/meta_deriving.mli: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | 3 | (** A [Plugin.t] is a pair of functions that extend a representable type with 4 | specialised generic operations: one to supply the implementation of the 5 | specialistion, and one to supply its type. 6 | 7 | For instance, the generic operation [equal : 'a Repr.t -> 'a -> 'a -> equal] 8 | could be packaged as the following plugin: 9 | 10 | {[ 11 | create 12 | ~intf:(fun loc t -> [%type: [%t t] -> [%t t] -> bool]) 13 | ~impl:(fun loc t -> [%expr Repr.unstage (Repr.equal [%e t])]) 14 | ]} 15 | 16 | That is: 17 | 18 | - given some type [t], its equality function has type [t -> t -> bool], 19 | - given a runtime representation of [t], we can derive an equality function 20 | via [Repr.equal]. *) 21 | module Plugin : sig 22 | type t 23 | 24 | val create : 25 | ?type_name:[ `before | `after ] 26 | (** Position of the type name relative to the operation name in the 27 | derived value (i.e. [`before] ↦ [val date_random], and [`after] ↦ 28 | [val random_date]). *) -> 29 | impl:(location -> expression -> expression) -> 30 | intf:(location -> core_type -> core_type) -> 31 | string -> 32 | t 33 | 34 | val derive_str : 35 | t -> 36 | loc:location -> 37 | type_name:string -> 38 | params:string list -> 39 | expr:expression -> 40 | structure_item 41 | 42 | val derive_sig : 43 | t -> 44 | loc:location -> 45 | type_name:string -> 46 | params:core_type list -> 47 | ctyp:core_type -> 48 | signature_item 49 | 50 | val defaults : t list 51 | (** Default set of plugins, using the generic operations provided by {!Repr}. *) 52 | end 53 | 54 | module Args : sig 55 | type (_, _) t = 56 | | [] : ('a, 'a) t 57 | | ( :: ) : 'a Deriving.Args.param * ('b, 'c) t -> ('a -> 'b, 'c) t 58 | end 59 | 60 | val make_generator : 61 | ?attributes:Ppxlib.Attribute.packed list -> 62 | ?deps:Ppxlib.Deriving.t list -> 63 | args:('a, 'b) Args.t -> 64 | supported_plugins:Plugin.t list -> 65 | (loc:location -> path:string -> Plugin.t list -> 'c -> 'a) -> 66 | ('b, 'c) Ppxlib.Deriving.Generator.t 67 | (** An extension of {!Ppxlib.Deriving.make_generator} that supports a set of 68 | meta-deriving plugins. *) 69 | -------------------------------------------------------------------------------- /src/ppx_repr/lib/monad.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2019-2020 Craig Ferguson 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | include Monad_intf 18 | 19 | module Reader = struct 20 | type ('a, 'e) t = Reader of ('e -> 'a) 21 | 22 | let run (Reader r) = r 23 | let map f m = Reader (fun env -> f (run m env)) 24 | let bind f m = Reader (fun env -> run (f (run m env)) env) 25 | let return x = Reader (fun _ -> x) 26 | 27 | let sequence (type a e) ms = 28 | List.fold_right 29 | (fun (aM : (a, e) t) (bM : (a list, e) t) -> 30 | bind (fun a -> map (fun b -> a :: b) bM) aM) 31 | ms (return []) 32 | 33 | let asks f = Reader (fun env -> f env) 34 | let ask = Reader (fun env -> env) 35 | let local f m = Reader (fun env -> run m (f env)) 36 | 37 | module Syntax = struct 38 | let ( let+ ) x f = map f x 39 | let ( let* ) x f = bind f x 40 | end 41 | end 42 | -------------------------------------------------------------------------------- /src/ppx_repr/lib/monad.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2019-2020 Craig Ferguson 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | include Monad_intf.Monad 18 | (** @inline *) 19 | -------------------------------------------------------------------------------- /src/ppx_repr/lib/monad_intf.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2019-2020 Craig Ferguson 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | module type S = sig 18 | type ('a, 'p) t 19 | 20 | val return : 'a -> ('a, 'p) t 21 | val map : ('a -> 'b) -> ('a, 'p) t -> ('b, 'p) t 22 | val bind : ('a -> ('b, 'p) t) -> ('a, 'p) t -> ('b, 'p) t 23 | val sequence : ('a, 'p) t list -> ('a list, 'p) t 24 | 25 | module Syntax : sig 26 | val ( let+ ) : ('a, 'p) t -> ('a -> 'b) -> ('b, 'p) t 27 | val ( let* ) : ('a, 'p) t -> ('a -> ('b, 'p) t) -> ('b, 'p) t 28 | end 29 | end 30 | 31 | module type Monad = sig 32 | module type S = S 33 | 34 | module Reader : sig 35 | (** Computations that read values from a shared environment. *) 36 | 37 | include S 38 | (** @inline *) 39 | 40 | val run : ('a, 'e) t -> 'e -> 'a 41 | (** Runs a {!('a, 'e) t} and extracts the final value ['a] from it. *) 42 | 43 | val ask : ('e, 'e) t 44 | (** Retrieves the monad environment. *) 45 | 46 | val asks : ('e -> 'a) -> ('a, 'e) t 47 | (** Retrieves a projection of the current monad environment. *) 48 | 49 | val local : ('e -> 'e) -> ('a, 'e) t -> ('a, 'e) t 50 | (** [local f m] executes a computation in [m] in an environment modified by 51 | [f]. *) 52 | end 53 | end 54 | -------------------------------------------------------------------------------- /src/ppx_repr/lib/plugins.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2019-2020 Craig Ferguson 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Ppxlib 18 | 19 | module Make (T : sig 20 | val namespace : string 21 | val default_library : string 22 | end) = 23 | struct 24 | module Attributes = Attributes.Make (T) 25 | 26 | let with_engine f ~loc ~path:_ = 27 | let (module S) = Ast_builder.make loc in 28 | f (module Engine.Located (Attributes) (S) : Engine.S) 29 | 30 | let args () = 31 | let open Deriving.Args in 32 | Meta_deriving.Args.[ arg "name" (estring __); arg "lib" __ ] 33 | 34 | let library = 35 | lazy 36 | (let library = ref (Some T.default_library) in 37 | let doc = 38 | Format.sprintf 39 | " Set the module path containing the combinators to \ 40 | use (defaults to %s). An empty string is interpreted as the \ 41 | current module." 42 | T.default_library 43 | in 44 | Ppxlib.Driver.add_arg "--lib" 45 | (Arg.String (function "" -> library := None | s -> library := Some s)) 46 | ~doc; 47 | library) 48 | 49 | let register_deriver 50 | ?plugins:(supported_plugins = Meta_deriving.Plugin.defaults) () = 51 | let library = Lazy.force library in 52 | let str_type_decl = 53 | let attributes = Attributes.all in 54 | Meta_deriving.make_generator ~attributes ~supported_plugins 55 | ~args:(args ()) 56 | ( with_engine @@ fun (module L) plugins input_ast name lib -> 57 | let lib = Option.fold lib ~some:L.parse_lib ~none:!library in 58 | L.derive_str ~plugins ~name ~lib input_ast ) 59 | in 60 | let sig_type_decl = 61 | Meta_deriving.make_generator ~supported_plugins ~args:(args ()) 62 | ( with_engine @@ fun (module L) plugins input_ast name lib -> 63 | let lib = Option.fold lib ~some:L.parse_lib ~none:!library in 64 | L.derive_sig ~plugins ~name ~lib input_ast ) 65 | in 66 | Deriving.add ~str_type_decl ~sig_type_decl T.namespace |> Deriving.ignore 67 | 68 | let register_extension ?no_reserve_namespace () = 69 | let library = Lazy.force library in 70 | let extension = 71 | Extension.declare (T.namespace ^ ".typ") Extension.Context.expression 72 | Ast_pattern.(ptyp __) 73 | (with_engine @@ fun (module L) -> L.expand_typ ?lib:!library) 74 | in 75 | (match no_reserve_namespace with 76 | | Some () -> () 77 | | None -> Reserved_namespaces.reserve T.namespace); 78 | Driver.register_transformation ~extensions:[ extension ] T.namespace 79 | end 80 | -------------------------------------------------------------------------------- /src/ppx_repr/lib/plugins.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2019-2020 Craig Ferguson 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | module Make (T : sig 18 | val namespace : string 19 | val default_library : string 20 | end) : sig 21 | val register_deriver : ?plugins:Meta_deriving.Plugin.t list -> unit -> unit 22 | val register_extension : ?no_reserve_namespace:unit -> unit -> unit 23 | end 24 | -------------------------------------------------------------------------------- /src/ppx_repr/lib/ppx_repr_lib.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2019-2020 Craig Ferguson 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | module Engine = Engine 18 | (** Derivers and expanders for [ppx_repr]. *) 19 | 20 | module Plugins = Plugins 21 | (** Functions for defining PPXes that use the implementation defined in 22 | {!Engine}. *) 23 | 24 | module Meta_deriving = Meta_deriving 25 | (** A meta-deriver is a deriver defined in terms of specialisations of Repr's 26 | generic operations (i.e. with plugins that consume type representations 27 | rather than type ASTs). *) 28 | -------------------------------------------------------------------------------- /src/ppx_repr/lib/raise.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2019-2020 Craig Ferguson 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Ppxlib 18 | 19 | let name = "ppx_repr" 20 | 21 | module Unsupported = struct 22 | let tuple_size ~loc count = 23 | Location.raise_errorf ~loc 24 | "%s: tuple types must have 2, 3 or 4 components. Found %d." name count 25 | 26 | let type_arrow ~loc ctyp = 27 | Location.raise_errorf ~loc 28 | "%s: function type encountered: %a. Functions are not Irmin-serialisable." 29 | name Pprintast.core_type ctyp 30 | 31 | let type_open ~loc = 32 | Location.raise_errorf ~loc 33 | "%s: extensible variant types are not Irmin-serialisable." name 34 | 35 | let type_poly ~loc ctyp = 36 | Location.raise_errorf ~loc 37 | "%s: universally-quantified type %a encountered. Irmin types must be \ 38 | grounded." 39 | name Pprintast.core_type ctyp 40 | 41 | let type_open_polyvar ~loc ctyp = 42 | Location.raise_errorf ~loc 43 | "%s: open polymorphic variant %a encountered. Polymorphic variants must \ 44 | be closed." 45 | name Pprintast.core_type ctyp 46 | 47 | let polyvar_inherit_case ~loc ctyp = 48 | Location.raise_errorf ~loc 49 | "%s: inherited variant cases encountered in %a. This is unsupported by \ 50 | ppx_repr." 51 | name Pprintast.core_type ctyp 52 | 53 | let type_package ~loc ctyp = 54 | Location.raise_errorf ~loc 55 | "%s: package type %a encountered. Package types are not \ 56 | Irmin-serialisable." 57 | name Pprintast.core_type ctyp 58 | 59 | let type_extension ~loc ctyp = 60 | Location.raise_errorf ~loc "%s: unprocessed extension %a encountered." name 61 | Pprintast.core_type ctyp 62 | 63 | let type_alias ~loc ctyp = 64 | Location.raise_errorf ~loc 65 | "%s: alias type %a encountered. Alias types are not supported." name 66 | Pprintast.core_type ctyp 67 | 68 | let type_any ~loc = 69 | Location.raise_errorf ~loc "%s: anonymous type variable unsupported." name 70 | 71 | let plugin ~loc ~supported found = 72 | Location.raise_errorf ~loc 73 | "%s: unsupported deriver plugin %s. Registered plugins: %a" name found 74 | Fmt.(Dump.list string) 75 | supported 76 | 77 | let recursive_groups ~loc tys = 78 | Location.raise_errorf ~loc 79 | "%s: mutually-recursive groups of size > 2 are not supported. Here we \ 80 | have %d types: %a)" 81 | name (List.length tys) 82 | Fmt.(list ~sep:(any ", ") string) 83 | tys 84 | 85 | let recursive_type_with_type_paramets ~loc ty = 86 | Location.raise_errorf ~loc 87 | "%s: Can't support mutually-recursive types with type parameters in type \ 88 | %s" 89 | name ty 90 | end 91 | -------------------------------------------------------------------------------- /src/ppx_repr/lib/raise.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2019-2020 Craig Ferguson 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Ppxlib 18 | 19 | module Unsupported : sig 20 | val tuple_size : loc:location -> int -> _ 21 | val type_arrow : loc:location -> core_type -> _ 22 | val type_open : loc:location -> _ 23 | val type_poly : loc:location -> core_type -> _ 24 | val type_open_polyvar : loc:location -> core_type -> _ 25 | val polyvar_inherit_case : loc:location -> core_type -> _ 26 | val type_package : loc:location -> core_type -> _ 27 | val type_extension : loc:location -> core_type -> _ 28 | val type_alias : loc:location -> core_type -> _ 29 | val type_any : loc:location -> _ 30 | val plugin : loc:location -> supported:string list -> string -> _ 31 | val recursive_groups : loc:location -> string list -> _ 32 | val recursive_type_with_type_paramets : loc:location -> string -> _ 33 | end 34 | -------------------------------------------------------------------------------- /src/ppx_repr/lib/utils.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | 3 | let ( >> ) f g x = g (f x) 4 | let ( >|= ) x f = List.map f x 5 | 6 | module Option = struct 7 | include Option 8 | 9 | let to_bool : unit option -> bool = function Some () -> true | None -> false 10 | end 11 | 12 | module List = struct 13 | include List 14 | 15 | (* TODO(4.10): remove *) 16 | let concat_map = 17 | let rec aux f acc = function 18 | | [] -> rev acc 19 | | x :: l -> 20 | let xs = f x in 21 | aux f (List.rev_append xs acc) l 22 | in 23 | fun ~f l -> aux f [] l 24 | 25 | let reduce ~f = function 26 | | [] -> None 27 | | [ x ] -> Some x 28 | | _ :: _ :: _ as l -> 29 | let rec aux = function 30 | | [] -> assert false 31 | | [ a; b ] -> f a b 32 | | x :: xs -> f x (aux xs) 33 | in 34 | Some (aux l) 35 | 36 | let reduce_exn ~f l = 37 | match reduce ~f l with 38 | | Some x -> x 39 | | None -> failwith "Cannot reduce empty list" 40 | end 41 | 42 | module Make (A : Ast_builder.S) : sig 43 | val compose_all : ('a -> 'a) list -> 'a -> 'a 44 | (** Left-to-right composition of a list of functions. *) 45 | 46 | val lambda : string list -> expression -> expression 47 | (** [lambda \[ "x_1"; ...; "x_n" \] e] is [fun x1 ... x_n -> e] *) 48 | 49 | val arrow : core_type list -> core_type -> core_type 50 | (** [arrow \[ "t_1"; ...; "t_n" \] u] is [t_1 -> ... -> t_n -> u] *) 51 | end = struct 52 | open A 53 | 54 | let compose_all l x = List.fold_left ( |> ) x (List.rev l) 55 | let lambda = List.map (pvar >> pexp_fun Nolabel None) >> compose_all 56 | let arrow = List.map (ptyp_arrow Nolabel) >> compose_all 57 | end 58 | 59 | (* Extracted from [Ppxlib.0.24.0] to avoid depending on the particular naming 60 | scheme used (which is exposed in our snapshot tests). This scheme was 61 | changed in https://github.com/ocaml-ppx/ppxlib/pull/285. *) 62 | let name_type_params_in_td = 63 | let gen_symbol = 64 | let cnt = ref 0 in 65 | fun ~prefix () -> 66 | cnt := !cnt + 1; 67 | Printf.sprintf "%s__%03i_" prefix !cnt 68 | in 69 | fun (td : type_declaration) : type_declaration -> 70 | let prefix_string i = 71 | (* a, b, ..., y, z, aa, bb, ... *) 72 | String.make ((i / 26) + 1) (Char.chr (Char.code 'a' + (i mod 26))) 73 | in 74 | let name_param i (tp, variance) = 75 | let ptyp_desc = 76 | match tp.ptyp_desc with 77 | | Ptyp_any -> Ptyp_var (gen_symbol ~prefix:(prefix_string i) ()) 78 | | Ptyp_var _ as v -> v 79 | | _ -> Location.raise_errorf ~loc:tp.ptyp_loc "not a type parameter" 80 | in 81 | ({ tp with ptyp_desc }, variance) 82 | in 83 | { td with ptype_params = List.mapi name_param td.ptype_params } 84 | -------------------------------------------------------------------------------- /src/repr/attribute.ml: -------------------------------------------------------------------------------- 1 | include Attribute_intf 2 | open Higher 3 | 4 | module Key = struct 5 | type 'f t = { uid : int; name : string; wit : 'f Witness.t } 6 | 7 | let uid = 8 | let counter = ref (-1) in 9 | fun () -> 10 | incr counter; 11 | !counter 12 | 13 | let create ~name = 14 | let uid = uid () in 15 | let wit = Witness.make () in 16 | { uid; name; wit } 17 | 18 | let name t = t.name 19 | 20 | type 'a ty = 'a t 21 | 22 | module Boxed = struct 23 | type t = E : _ ty -> t [@@ocaml.unboxed] 24 | 25 | let compare (E k1) (E k2) = Int.compare k1.uid k2.uid 26 | end 27 | end 28 | 29 | module Map = struct 30 | open Map.Make (Key.Boxed) 31 | 32 | type ('a, 'f) data = ('a, 'f) app 33 | type 'a binding = B : 'f Key.t * ('a, 'f) data -> 'a binding 34 | type nonrec 'a t = 'a binding t 35 | 36 | let empty = empty 37 | let is_empty = is_empty 38 | let mem t k = mem (E k) t 39 | let add t ~key ~data = add (E key) (B (key, data)) t 40 | 41 | let update : 42 | type a f. 43 | a t -> f Key.t -> ((a, f) data option -> (a, f) data option) -> a t = 44 | fun t k f -> 45 | update (E k) 46 | (fun b -> 47 | let v = 48 | f 49 | (match b with 50 | | None -> None 51 | | Some (B (k', v)) -> ( 52 | match Witness.eq k.wit k'.wit with 53 | | None -> None 54 | | Some Refl -> Some v)) 55 | in 56 | match v with None -> None | Some v -> Some (B (k, v))) 57 | t 58 | 59 | let singleton k v = singleton (E k) (B (k, v)) 60 | let iter t ~f = iter (fun _ b -> f b) t 61 | let for_all t ~f = for_all (fun _ b -> f b) t 62 | let exists t ~f = exists (fun _ b -> f b) t 63 | let cardinal t = cardinal t 64 | let bindings t = bindings t |> List.map snd 65 | 66 | let find : type a f. a t -> f Key.t -> (a, f) data option = 67 | fun t k -> 68 | match find_opt (E k) t with 69 | | None -> None 70 | | Some (B (k', v)) -> ( 71 | match Witness.eq k.wit k'.wit with None -> None | Some Refl -> Some v) 72 | end 73 | 74 | module Make1 (T : sig 75 | type 'a t 76 | 77 | val name : string 78 | end) = 79 | struct 80 | include T 81 | include Branded.Make (T) 82 | 83 | let key : br Key.t = Key.create ~name 84 | 85 | let find map = 86 | match Map.find map key with None -> None | Some x -> Some (prj x) 87 | 88 | let add data map = Map.add map ~key ~data:(inj data) 89 | end 90 | 91 | include Key 92 | 93 | module type S1 = S1 with type 'a attr := 'a t and type 'a map := 'a Map.t 94 | -------------------------------------------------------------------------------- /src/repr/attribute.mli: -------------------------------------------------------------------------------- 1 | include Attribute_intf.Attribute 2 | (** @inline *) 3 | -------------------------------------------------------------------------------- /src/repr/attribute_intf.ml: -------------------------------------------------------------------------------- 1 | open Higher 2 | 3 | (** An attribute key is a value that can be used to attach polymorphic data to a 4 | heterogeneous attribute map. *) 5 | module type S1 = sig 6 | type 'a attr 7 | type 'a map 8 | 9 | type 'a t 10 | (** The type of data associated with the {!attr} attribute key. *) 11 | 12 | val add : 'a t -> 'a map -> 'a map 13 | (** Attach data for {!attr} to a given map. *) 14 | 15 | val find : 'a map -> 'a t option 16 | (** Search for data corresponding to the key {!attr} in the given map. *) 17 | 18 | include Branded.S with type 'a t := 'a t 19 | 20 | val key : br attr 21 | end 22 | 23 | module type Attribute = sig 24 | type 'f t 25 | (** An ['f t] is an attribute key that can be used to pack polymorphic data 26 | into a heterogeneous {!Map} (and then recover it again). 27 | 28 | The type parameter ['f] is the brand of a type operator [f : * ⇒ *] which, 29 | when applied to the type parameter ['a] of a {!Map.t}, gives the type 30 | ['a f] of the associated data. This allows a single attribute key to store 31 | {i polymorphic} data. *) 32 | 33 | val create : name:string -> _ t 34 | (** [create ~name] is a fresh attribute key with the given string name. *) 35 | 36 | val name : _ t -> string 37 | (** Get the string name of an attribute key. *) 38 | 39 | module Map : sig 40 | type 'f key := 'f t 41 | 42 | type 'a t 43 | (** The type of polymorphic, heterogeneous maps. *) 44 | 45 | type ('a, 'f) data := ('a, 'f) app 46 | (** Given an ['a t] map and an ['f key] attribute key, the type of the 47 | corresponding data is [('a, 'f) Higher.app]. *) 48 | 49 | val empty : _ t 50 | val is_empty : _ t -> bool 51 | val mem : 'a t -> 'f key -> bool 52 | val add : 'a t -> key:'f key -> data:('a, 'f) data -> 'a t 53 | 54 | val update : 55 | 'a t -> 'f key -> (('a, 'f) data option -> ('a, 'f) data option) -> 'a t 56 | 57 | val singleton : 'f key -> ('a, 'f) data -> 'a t 58 | 59 | type 'a binding = B : 'f key * ('a, 'f) data -> 'a binding 60 | 61 | val iter : 'a t -> f:('a binding -> unit) -> unit 62 | val for_all : 'a t -> f:('a binding -> bool) -> bool 63 | val exists : 'a t -> f:('a binding -> bool) -> bool 64 | val cardinal : 'a t -> int 65 | val find : 'a t -> 'f key -> ('a, 'f) data option 66 | val bindings : 'a t -> 'a binding list 67 | end 68 | 69 | module type S1 = S1 with type 'a attr := 'a t and type 'a map := 'a Map.t 70 | 71 | module Make1 (T : sig 72 | type 'a t 73 | 74 | val name : string 75 | end) : S1 with type 'a t = 'a T.t 76 | end 77 | -------------------------------------------------------------------------------- /src/repr/binary.mli: -------------------------------------------------------------------------------- 1 | (** This module provides functions for interacting with Repr's binary 2 | serialisation format directly (without first constructing a representation 3 | of the type being encoded). These can be useful for performance-critical 4 | applications, where the runtime overhead of the dynamic specialisation is 5 | too large, or when the actual codec being used is too complex to be 6 | expressed via a type representation. *) 7 | 8 | include Binary_intf.Intf 9 | (** @inline *) 10 | -------------------------------------------------------------------------------- /src/repr/binary_intf.ml: -------------------------------------------------------------------------------- 1 | open Type_core 2 | open Staging 3 | 4 | module Types = struct 5 | type 'a encoder = 'a -> (string -> unit) -> unit 6 | type 'a decoder = string -> int ref -> 'a 7 | type 'a sizer = 'a Size.Sizer.t 8 | end 9 | 10 | open Types 11 | 12 | module type S = sig 13 | type t 14 | 15 | val encode : t encoder 16 | val decode : t decoder 17 | val sizer : t sizer 18 | end 19 | 20 | module type S_with_length = sig 21 | type t 22 | 23 | val encode : len -> t encoder staged 24 | val decode : len -> t decoder staged 25 | val sizer : len -> t sizer 26 | end 27 | 28 | module type S1 = sig 29 | type 'a t 30 | 31 | val encode : 'a encoder -> 'a t encoder 32 | val decode : 'a decoder -> 'a t decoder 33 | val sizer : 'a sizer -> 'a t sizer 34 | end 35 | 36 | module type S1_with_length = sig 37 | type 'a t 38 | 39 | val encode : len -> 'a encoder -> 'a t encoder staged 40 | val decode : len -> 'a decoder -> 'a t decoder staged 41 | val sizer : len -> 'a sizer -> 'a t sizer 42 | end 43 | 44 | module type S2 = sig 45 | type ('a, 'b) t 46 | 47 | val encode : 'a encoder -> 'b encoder -> ('a, 'b) t encoder 48 | val decode : 'a decoder -> 'b decoder -> ('a, 'b) t decoder 49 | val sizer : 'a sizer -> 'b sizer -> ('a, 'b) t sizer 50 | end 51 | 52 | module type S3 = sig 53 | type ('a, 'b, 'c) t 54 | 55 | val encode : 'a encoder -> 'b encoder -> 'c encoder -> ('a, 'b, 'c) t encoder 56 | val decode : 'a decoder -> 'b decoder -> 'c decoder -> ('a, 'b, 'c) t decoder 57 | val sizer : 'a sizer -> 'b sizer -> 'c sizer -> ('a, 'b, 'c) t sizer 58 | end 59 | 60 | module type S4 = sig 61 | type ('a, 'b, 'c, 'd) t 62 | 63 | val encode : 64 | 'a encoder -> 65 | 'b encoder -> 66 | 'c encoder -> 67 | 'd encoder -> 68 | ('a, 'b, 'c, 'd) t encoder 69 | 70 | val decode : 71 | 'a decoder -> 72 | 'b decoder -> 73 | 'c decoder -> 74 | 'd decoder -> 75 | ('a, 'b, 'c, 'd) t decoder 76 | 77 | val sizer : 78 | 'a sizer -> 'b sizer -> 'c sizer -> 'd sizer -> ('a, 'b, 'c, 'd) t sizer 79 | end 80 | 81 | module type Intf = sig 82 | include module type of Types 83 | 84 | module type S = S 85 | module type S1 = S1 86 | module type S2 = S2 87 | module type S3 = S3 88 | module type S4 = S4 89 | 90 | module Unit : S with type t := unit 91 | module Bool : S with type t := bool 92 | module Char : S with type t := char 93 | module Varint : S with type t := int 94 | module Varint_int63 : S with type t := Optint.Int63.t 95 | module Int16 : S with type t := int 96 | module Int32 : S with type t := int32 97 | module Int64 : S with type t := int64 98 | module Float : S with type t := float 99 | module String : S_with_length with type t := string 100 | module String_unboxed : S_with_length with type t := string 101 | module Bytes : S_with_length with type t := bytes 102 | module Bytes_unboxed : S_with_length with type t := bytes 103 | module List : S1_with_length with type 'a t := 'a list 104 | module Array : S1_with_length with type 'a t := 'a array 105 | module Option : S1 with type 'a t := 'a option 106 | module Pair : S2 with type ('a, 'b) t := 'a * 'b 107 | module Triple : S3 with type ('a, 'b, 'c) t := 'a * 'b * 'c 108 | module Quad : S4 with type ('a, 'b, 'c, 'd) t := 'a * 'b * 'c * 'd 109 | end 110 | -------------------------------------------------------------------------------- /src/repr/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name repr) 3 | (public_name repr) 4 | (libraries 5 | base64 6 | fmt 7 | jsonm 8 | uutf 9 | either 10 | (re_export optint))) 11 | -------------------------------------------------------------------------------- /src/repr/higher.ml: -------------------------------------------------------------------------------- 1 | (** Defunctionalised higher-kinded types. See "Lightweight Higher-Kinded 2 | Polymorphism" (Yallop and White, 2014) for more details. *) 3 | 4 | type ('a, 'f) app 5 | 6 | module Branded = struct 7 | module type S = sig 8 | type 'a t 9 | type br 10 | 11 | external inj : 'a t -> ('a, br) app = "%identity" 12 | external prj : ('a, br) app -> 'a t = "%identity" 13 | end 14 | 15 | module Make (T : sig 16 | type 'a t 17 | end) : S with type 'a t := 'a T.t = struct 18 | type 'a t = 'a T.t 19 | type br 20 | 21 | external inj : 'a t -> ('a, br) app = "%identity" 22 | external prj : ('a, br) app -> 'a t = "%identity" 23 | end 24 | end 25 | -------------------------------------------------------------------------------- /src/repr/repr.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016-2017 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | include Type 18 | (** @inline *) 19 | 20 | (** {1 Miscellaneous modules} *) 21 | 22 | module Binary = Binary 23 | module Staging = Staging 24 | module Witness = Witness 25 | -------------------------------------------------------------------------------- /src/repr/size.ml: -------------------------------------------------------------------------------- 1 | type 'a t = Static of int | Dynamic of 'a | Unknown 2 | type 'a size = 'a t 3 | 4 | let map : type a b. (a -> b) -> a t -> b t = 5 | fun f -> function 6 | | Unknown -> Unknown 7 | | Static n -> Static n 8 | | Dynamic a -> Dynamic (f a) 9 | 10 | module Syntax = struct 11 | let ( let+ ) x f = map f x 12 | end 13 | 14 | (** A type wrapper for positional offsets into buffers (as opposed to e.g. 15 | lengths of values in those buffers). *) 16 | type offset = Offset of int [@@unboxed] 17 | 18 | module Offset = struct 19 | type t = offset 20 | 21 | let ( +> ) : t -> int -> t = fun (Offset n) m -> Offset (n + m) 22 | let ( <+ ) : int -> t -> t = fun n (Offset m) -> Offset (n + m) 23 | end 24 | 25 | module Sizer = struct 26 | type 'a t = { 27 | of_value : ('a -> int) size; 28 | of_encoding : (string -> Offset.t -> Offset.t) size; 29 | } 30 | (** An ['a t] is a value that represents the size information known about a 31 | particular codec for type ['a]. 32 | 33 | - [of_value]: given a value to encode, return the size of its encoding. 34 | 35 | - [of_encoding]: given a buffer [buf] and an offset [off], return the 36 | _offset_ immediately _after_ the encoding starting at [buf.\[off\]] 37 | NOTE: not the length of the encoding itself, to enable chains of such 38 | sizers to call each other in tail-position. 39 | 40 | Invariant: [∀ n. (of_value = Static n) ⟺ (of_encoding = Static n)]. *) 41 | 42 | let ( <+> ) : type a. a t -> a t -> a t = 43 | let add_of_value (a : _ size) (b : _ size) : _ size = 44 | match (a, b) with 45 | | Unknown, _ | _, Unknown -> Unknown 46 | | Static a, Static b -> Static (a + b) 47 | | Static 0, other | other, Static 0 -> other 48 | | Static n, Dynamic f | Dynamic f, Static n -> Dynamic (fun a -> n + f a) 49 | | Dynamic f, Dynamic g -> Dynamic (fun a -> f a + g a) 50 | in 51 | let add_of_encoding (a : _ size) (b : _ size) : _ size = 52 | match (a, b) with 53 | | Unknown, _ | _, Unknown -> Unknown 54 | | Static a, Static b -> Static (a + b) 55 | | Static 0, other | other, Static 0 -> other 56 | | Dynamic f, Dynamic g -> Dynamic (fun buf off -> g buf (f buf off)) 57 | (* NOTE: in these cases we could be slightly more efficient by storing a 58 | vector of sizing functions inside [Dynamic], which would allow constant 59 | folding for static segments of dynamically-sized types. *) 60 | | Static n, Dynamic f -> Dynamic (fun buf off -> f buf Offset.(off +> n)) 61 | | Dynamic f, Static n -> Dynamic (fun buf off -> Offset.(f buf off +> n)) 62 | in 63 | fun a b -> 64 | { 65 | of_value = add_of_value a.of_value b.of_value; 66 | of_encoding = add_of_encoding a.of_encoding b.of_encoding; 67 | } 68 | 69 | let static n = { of_value = Static n; of_encoding = Static n } 70 | 71 | let dynamic ~of_value ~of_encoding = 72 | { of_value = Dynamic of_value; of_encoding = Dynamic of_encoding } 73 | 74 | let using f t = 75 | let of_value = map (fun size_of x -> size_of (f x)) t.of_value in 76 | { t with of_value } 77 | 78 | let unknown = { of_value = Unknown; of_encoding = Unknown } 79 | end 80 | -------------------------------------------------------------------------------- /src/repr/staging.ml: -------------------------------------------------------------------------------- 1 | type +'a staged = 'a 2 | 3 | let stage x = x 4 | let unstage x = x 5 | -------------------------------------------------------------------------------- /src/repr/staging.mli: -------------------------------------------------------------------------------- 1 | (** This module is intended to be globally opened. *) 2 | 3 | type +'a staged 4 | 5 | val stage : 'a -> 'a staged 6 | val unstage : 'a staged -> 'a 7 | -------------------------------------------------------------------------------- /src/repr/type.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016-2017 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (** Yet-another type combinator library 18 | 19 | [Repr] provides type combinators to define runtime representation for OCaml 20 | types and {{!generics} generic operations} to manipulate values with a 21 | runtime type representation. 22 | 23 | The type combinators supports all the usual {{!primitives} type primitives} 24 | but also compact definitions of {{!records} records} and {{!variants} 25 | variants}. It also allows the definition of run-time representations of 26 | {{!recursive} recursive types}. *) 27 | 28 | include Type_intf.Type 29 | (** @inline *) 30 | -------------------------------------------------------------------------------- /src/repr/type_binary.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016-2017 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Type_core 18 | open Staging 19 | 20 | val pre_hash : 'a t -> 'a encode_bin staged 21 | val encode_bin : 'a t -> 'a encode_bin staged 22 | val decode_bin : 'a t -> 'a decode_bin staged 23 | 24 | module Unboxed : sig 25 | val encode_bin : 'a t -> 'a encode_bin staged 26 | val decode_bin : 'a t -> 'a decode_bin staged 27 | end 28 | 29 | val to_bin_string : 'a t -> 'a to_string staged 30 | val of_bin_string : 'a t -> 'a of_string staged 31 | -------------------------------------------------------------------------------- /src/repr/type_core.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016-2017 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | include Type_core_intf 18 | include Type_core_intf.Types 19 | open Staging 20 | 21 | module Json = struct 22 | type decoder = json_decoder 23 | 24 | let decoder ?encoding src = { lexemes = []; d = Jsonm.decoder ?encoding src } 25 | let decoder_of_lexemes lexemes = { lexemes; d = Jsonm.decoder (`String "") } 26 | let rewind e l = e.lexemes <- l :: e.lexemes 27 | 28 | let decode e = 29 | match e.lexemes with 30 | | h :: t -> 31 | e.lexemes <- t; 32 | `Lexeme h 33 | | [] -> Jsonm.decode e.d 34 | 35 | let decoder_and_lexemes t = (t.d, t.lexemes) 36 | end 37 | 38 | module Encode_json = Attribute.Make1 (struct 39 | type 'a t = Jsonm.encoder -> 'a -> unit 40 | 41 | let name = "encode_json" 42 | end) 43 | 44 | module Decode_json = Attribute.Make1 (struct 45 | type 'a t = json_decoder -> ('a, [ `Msg of string ]) result 46 | 47 | let name = "decode_json" 48 | end) 49 | 50 | let annotate t ~add ~data = 51 | match t with 52 | | Attributes t -> Attributes { t with attrs = add data t.attrs } 53 | | t -> Attributes { attrs = add data Attribute.Map.empty; attr_type = t } 54 | 55 | let unimplemented_size_of = 56 | let f _ = failwith "`size_of` not implemented" in 57 | Size.Sizer.{ of_value = Dynamic f; of_encoding = Dynamic f } 58 | 59 | let partial ?(pp = fun _ -> failwith "`pp` not implemented") 60 | ?(of_string = fun _ -> failwith "`of_string` not implemented") 61 | ?(encode_json = fun _ -> failwith "`encode_json` not implemented") 62 | ?(decode_json = fun _ -> failwith "`decode_json` not implemented") 63 | ?(short_hash = fun ?seed:_ _ -> failwith "`short_hash` not implemented") 64 | ?(pre_hash = fun _ -> failwith "`pre_hash` not implemented") 65 | ?(compare = fun _ -> failwith "`compare` not implemented") 66 | ?(equal = fun _ -> failwith "`equal` not implemented") 67 | ?(encode_bin = fun _ -> failwith "`encode_bin` not implemented") 68 | ?(decode_bin = fun _ -> failwith "`decode_bin` not implemented") 69 | ?(size_of = unimplemented_size_of) 70 | ?(unboxed_encode_bin = 71 | fun _ -> failwith "`unboxed_encode_bin` not implemented") 72 | ?(unboxed_decode_bin = 73 | fun _ -> failwith "`unboxed_decode_bin` not implemented") 74 | ?(unboxed_size_of = unimplemented_size_of) () = 75 | Custom 76 | { 77 | cwit = `Witness (Witness.make ()); 78 | pp; 79 | of_string; 80 | short_hash; 81 | pre_hash; 82 | compare; 83 | equal; 84 | encode_bin; 85 | decode_bin; 86 | size_of; 87 | unboxed_encode_bin; 88 | unboxed_decode_bin; 89 | unboxed_size_of; 90 | } 91 | |> annotate ~add:Encode_json.add ~data:encode_json 92 | |> annotate ~add:Decode_json.add ~data:decode_json 93 | 94 | let rec fields_aux : type a b. (a, b) fields -> a a_field list = function 95 | | F0 -> [] 96 | | F1 (h, t) -> Field h :: fields_aux t 97 | 98 | let fields r = match r.rfields with Fields (f, _) -> fields_aux f 99 | 100 | module Dispatch = struct 101 | type 'a t = 102 | | Base : 'a staged -> 'a t 103 | | Arrow : { arg_wit : 'b Witness.t; f : ('b -> 'a) staged } -> 'a t 104 | end 105 | 106 | module Fields_folder (Acc : sig 107 | type ('a, 'b) t 108 | end) = 109 | struct 110 | type 'a t = { 111 | nil : ('a, 'a) Acc.t; 112 | cons : 'b 'c. ('a, 'b) field -> ('a, 'c) Acc.t -> ('a, 'b -> 'c) Acc.t; 113 | } 114 | 115 | let rec fold : type a c. a t -> (a, c) fields -> (a, c) Acc.t = 116 | fun folder -> function 117 | | F0 -> folder.nil 118 | | F1 (f, fs) -> folder.cons f (fold folder fs) 119 | end 120 | 121 | let fold_variant : 122 | type a f. (a, f) Case_folder.t -> a variant -> (a -> f) staged = 123 | fun folder v_typ -> 124 | let cases = 125 | Array.map 126 | (function 127 | | C0 c0 -> Dispatch.Base (folder.c0 c0) 128 | | C1 c1 -> Dispatch.Arrow { arg_wit = c1.cwit1; f = folder.c1 c1 }) 129 | v_typ.vcases 130 | in 131 | stage (fun v -> 132 | match v_typ.vget v with 133 | | CV0 { ctag0; _ } -> ( 134 | match cases.(ctag0) with 135 | | Dispatch.Base x -> unstage x 136 | | _ -> assert false) 137 | | CV1 ({ ctag1; cwit1; _ }, v) -> ( 138 | match cases.(ctag1) with 139 | | Dispatch.Arrow { f; arg_wit } -> 140 | let v = Witness.cast_exn cwit1 arg_wit v in 141 | unstage f v 142 | | _ -> assert false)) 143 | -------------------------------------------------------------------------------- /src/repr/type_core.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016-2017 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | include Type_core_intf.Type_core 18 | (** @inline *) 19 | -------------------------------------------------------------------------------- /src/repr/type_core_intf.ml: -------------------------------------------------------------------------------- 1 | open Staging 2 | 3 | module Types = struct 4 | type len = [ `Int | `Int8 | `Int16 | `Int32 | `Int64 | `Fixed of int ] 5 | type 'a pp = 'a Fmt.t 6 | type 'a of_string = string -> ('a, [ `Msg of string ]) result 7 | type 'a to_string = 'a -> string 8 | type 'a encode_json = Jsonm.encoder -> 'a -> unit 9 | type json_decoder = { mutable lexemes : Jsonm.lexeme list; d : Jsonm.decoder } 10 | type 'a decode_json = json_decoder -> ('a, [ `Msg of string ]) result 11 | type 'a bin_seq = 'a -> (string -> unit) -> unit 12 | type 'a pre_hash = 'a bin_seq 13 | type 'a encode_bin = 'a bin_seq 14 | type 'a decode_bin = string -> int ref -> 'a 15 | type 'a size_of = 'a Size.Sizer.t 16 | type 'a compare = 'a -> 'a -> int 17 | type 'a equal = 'a -> 'a -> bool 18 | type 'a short_hash = ?seed:int -> 'a -> int 19 | 20 | type 'a t = 21 | | Var : string -> 'a t 22 | | Self : 'a self -> 'a t 23 | | Attributes : 'a attributes -> 'a t 24 | | Custom : 'a custom -> 'a t 25 | | Map : ('a, 'b) map -> 'b t 26 | | Prim : 'a prim -> 'a t 27 | | List : 'a len_v -> 'a list t 28 | | Array : 'a len_v -> 'a array t 29 | | Tuple : 'a tuple -> 'a t 30 | | Option : 'a t -> 'a option t 31 | | Record : 'a record -> 'a t 32 | | Variant : 'a variant -> 'a t 33 | | Boxed : 'a t -> 'a t 34 | 35 | and 'a len_v = { len : len; v : 'a t } 36 | and 'a attributes = { attrs : 'a Attribute.Map.t; attr_type : 'a t } 37 | 38 | and 'a custom = { 39 | cwit : [ `Type of 'a t | `Witness of 'a Witness.t ]; 40 | pp : 'a pp; 41 | of_string : 'a of_string; 42 | short_hash : 'a short_hash; 43 | pre_hash : 'a encode_bin; 44 | compare : 'a compare; 45 | equal : 'a equal; 46 | (* boxed binary encoding *) 47 | encode_bin : 'a encode_bin; 48 | decode_bin : 'a decode_bin; 49 | size_of : 'a size_of; 50 | (* unboxed binary encoding *) 51 | unboxed_encode_bin : 'a encode_bin; 52 | unboxed_decode_bin : 'a decode_bin; 53 | unboxed_size_of : 'a size_of; 54 | } 55 | 56 | and ('a, 'b) map = { 57 | x : 'a t; 58 | f : 'a -> 'b; 59 | g : 'b -> 'a; 60 | mwit : 'b Witness.t; 61 | } 62 | 63 | and 'a self = { self_unroll : 'a t -> 'a t; mutable self_fix : 'a t } 64 | 65 | and 'a prim = 66 | | Unit : unit prim 67 | | Bool : bool prim 68 | | Char : char prim 69 | | Int : int prim 70 | | Int32 : int32 prim 71 | | Int64 : int64 prim 72 | | Float : float prim 73 | | String : len -> string prim 74 | | Bytes : len -> bytes prim 75 | 76 | and 'a tuple = 77 | | Pair : 'a t * 'b t -> ('a * 'b) tuple 78 | | Triple : 'a t * 'b t * 'c t -> ('a * 'b * 'c) tuple 79 | | Quad : 'a t * 'b t * 'c t * 'd t -> ('a * 'b * 'c * 'd) tuple 80 | 81 | and 'a record = { 82 | rwit : 'a Witness.t; 83 | rname : string; 84 | rfields : 'a fields_and_constr; 85 | } 86 | 87 | and 'a fields_and_constr = 88 | | Fields : ('a, 'b) fields * 'b -> 'a fields_and_constr 89 | 90 | and ('a, 'b) fields = 91 | | F0 : ('a, 'a) fields 92 | | F1 : ('a, 'b) field * ('a, 'c) fields -> ('a, 'b -> 'c) fields 93 | 94 | and ('a, 'b) field = { fname : string; ftype : 'b t; fget : 'a -> 'b } 95 | 96 | and 'a variant = { 97 | vwit : 'a Witness.t; 98 | vname : string; 99 | vcases : 'a a_case array; 100 | vget : 'a -> 'a case_v; 101 | } 102 | 103 | and 'a a_case = 104 | | C0 : 'a case0 -> 'a a_case 105 | | C1 : ('a, 'b) case1 -> 'a a_case 106 | 107 | and 'a case_v = 108 | | CV0 : 'a case0 -> 'a case_v 109 | | CV1 : ('a, 'b) case1 * 'b -> 'a case_v 110 | 111 | and 'a case0 = { ctag0 : int; cname0 : string; c0 : 'a } 112 | 113 | and ('a, 'b) case1 = { 114 | ctag1 : int; 115 | cname1 : string; 116 | ctype1 : 'b t; 117 | cwit1 : 'b Witness.t; 118 | c1 : 'b -> 'a; 119 | } 120 | 121 | type 'a ty = 'a t 122 | 123 | exception Unbound_type_variable of string 124 | 125 | type _ a_field = Field : ('a, 'b) field -> 'a a_field 126 | 127 | module Case_folder = struct 128 | type ('a, 'f) t = { 129 | c0 : 'a case0 -> 'f staged; 130 | c1 : 'b. ('a, 'b) case1 -> ('b -> 'f) staged; 131 | } 132 | end 133 | end 134 | 135 | module type Type_core = sig 136 | include module type of Types 137 | (** @inline *) 138 | 139 | val unimplemented_size_of : 'a size_of 140 | val fields : 'a record -> 'a a_field list 141 | 142 | module Fields_folder (Acc : sig 143 | type ('a, 'b) t 144 | end) : sig 145 | type 'a t = { 146 | nil : ('a, 'a) Acc.t; 147 | cons : 'b 'c. ('a, 'b) field -> ('a, 'c) Acc.t -> ('a, 'b -> 'c) Acc.t; 148 | } 149 | 150 | val fold : 'a t -> ('a, 'c) fields -> ('a, 'c) Acc.t 151 | end 152 | 153 | module Encode_json : Attribute.S1 with type 'a t = 'a encode_json 154 | module Decode_json : Attribute.S1 with type 'a t = 'a decode_json 155 | 156 | val annotate : 157 | 'a t -> 158 | add:('data -> 'a Attribute.Map.t -> 'a Attribute.Map.t) -> 159 | data:'data -> 160 | 'a t 161 | 162 | val fold_variant : ('a, 'b) Case_folder.t -> 'a variant -> ('a -> 'b) staged 163 | 164 | val partial : 165 | ?pp:'a pp -> 166 | ?of_string:'a of_string -> 167 | ?encode_json:'a Encode_json.t -> 168 | ?decode_json:'a Decode_json.t -> 169 | ?short_hash:'a short_hash -> 170 | ?pre_hash:'a pre_hash -> 171 | ?compare:'a compare -> 172 | ?equal:'a equal -> 173 | ?encode_bin:'a encode_bin -> 174 | ?decode_bin:'a decode_bin -> 175 | ?size_of:'a size_of -> 176 | ?unboxed_encode_bin:'a encode_bin -> 177 | ?unboxed_decode_bin:'a decode_bin -> 178 | ?unboxed_size_of:'a size_of -> 179 | unit -> 180 | 'a t 181 | 182 | module Json : sig 183 | type decoder = json_decoder 184 | 185 | val decoder : 186 | ?encoding:[< Jsonm.encoding ] -> [< Jsonm.src ] -> json_decoder 187 | 188 | val decoder_of_lexemes : Jsonm.lexeme list -> json_decoder 189 | val rewind : json_decoder -> Jsonm.lexeme -> unit 190 | 191 | val decode : 192 | json_decoder -> 193 | [> `Await | `End | `Error of Jsonm.error | `Lexeme of Jsonm.lexeme ] 194 | 195 | val decoder_and_lexemes : decoder -> Jsonm.decoder * Jsonm.lexeme list 196 | end 197 | end 198 | -------------------------------------------------------------------------------- /src/repr/type_json.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016-2017 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Type_core 18 | 19 | val pp : ?minify:bool -> 'a t -> 'a Fmt.t 20 | val to_string : ?minify:bool -> 'a t -> 'a to_string 21 | val of_string : 'a t -> 'a of_string 22 | val encode : 'a t -> 'a Encode_json.t 23 | val decode : 'a t -> 'a Decode_json.t 24 | val decode_jsonm : 'a t -> Jsonm.decoder -> ('a, [ `Msg of string ]) result 25 | 26 | val decode_lexemes : 27 | 'a t -> Jsonm.lexeme list -> ('a, [ `Msg of string ]) result 28 | 29 | val encode_assoc : 'a t -> (string * 'a) list Encode_json.t 30 | val decode_assoc : 'a t -> (string * 'a) list Decode_json.t 31 | -------------------------------------------------------------------------------- /src/repr/type_ordered.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016-2017 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Type_core 18 | open Staging 19 | 20 | val equal : 'a t -> 'a equal staged 21 | val compare : 'a t -> 'a compare staged 22 | -------------------------------------------------------------------------------- /src/repr/type_pp.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016-2017 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Type_core 18 | module Attr : Attribute.S1 with type 'a t = 'a Fmt.t 19 | 20 | val t : 'a t -> 'a Fmt.t 21 | val dump : 'a t -> 'a Fmt.t 22 | val ty : 'a t Fmt.t 23 | val to_string : 'a t -> 'a to_string 24 | val of_string : 'a t -> 'a of_string 25 | -------------------------------------------------------------------------------- /src/repr/type_random.ml: -------------------------------------------------------------------------------- 1 | open Type_core 2 | open Staging 3 | module R = Random.State 4 | 5 | module Attr = Attribute.Make1 (struct 6 | type 'a t = R.t -> 'a 7 | 8 | let name = "random" 9 | end) 10 | 11 | type 'a random = (R.t -> 'a) staged 12 | 13 | let ( let+ ) x f = 14 | let x = unstage x in 15 | stage (f x) 16 | 17 | let ( and+ ) a b = stage (unstage a, unstage b) 18 | let return x = stage (fun _ -> x) 19 | 20 | (* Sample lengths according to a geometric distribution by inverse 21 | transform sampling an exponential one (characterised by [mean_length = λ⁻¹]) 22 | and rounding to integer values. *) 23 | let pick_len : mean:int -> len -> R.t -> int = 24 | let bound len x = 25 | match len with 26 | | `Int | `Int64 -> x 27 | | `Int8 -> min x ((1 lsl 8) - 1) 28 | | `Int16 -> min x ((1 lsl 16) - 1) 29 | | `Int32 -> min x ((0x7fff lsl 16) lor 0xffff) 30 | in 31 | fun ~mean l s -> 32 | match l with 33 | | (`Int | `Int8 | `Int16 | `Int32 | `Int64) as l -> 34 | bound l (Float.to_int (-.Float.log (R.float s 1.) *. Float.of_int mean)) 35 | | `Fixed i -> i 36 | 37 | let indexable : 38 | type a b. 39 | mean_len:int -> len -> (int -> (int -> a) -> b) -> a random -> b random = 40 | fun ~mean_len len init elt -> 41 | let+ elt = elt in 42 | fun s -> init (pick_len ~mean:mean_len len s) (fun _ -> elt s) 43 | 44 | module Record_deriver = Fields_folder (struct 45 | type ('a, 'b) t = R.t -> 'b -> 'a 46 | end) 47 | 48 | let int32 = 49 | let open Int32 in 50 | let bits s = of_int (R.bits s) in 51 | fun s -> logxor (bits s) (shift_left (bits s) 30) 52 | 53 | let int64 = 54 | let open Int64 in 55 | let bits s = of_int (R.bits s) in 56 | fun s -> 57 | logxor (bits s) (logxor (shift_left (bits s) 30) (shift_left (bits s) 60)) 58 | 59 | let int = 60 | match Sys.word_size with 61 | | 64 -> fun s -> Int64.to_int (int64 s) 62 | | 32 -> fun s -> Int32.to_int (int32 s) 63 | | _ -> assert false 64 | 65 | let float s = 66 | R.float s (if R.bool s then Float.max_float else -.Float.max_float) 67 | 68 | let rec t : type a. a t -> a random = function 69 | | Map x -> map x 70 | | Prim x -> prim x 71 | | Tuple x -> tuple x 72 | | List { len; v } -> indexable ~mean_len:4 len List.init (t v) 73 | | Array { len; v } -> indexable ~mean_len:4 len Array.init (t v) 74 | | Option x -> option x 75 | | Record x -> record x 76 | | Variant x -> variant x 77 | | Attributes { attrs; attr_type } -> ( 78 | match Attr.find attrs with Some f -> stage f | None -> t attr_type) 79 | | Boxed x -> t x 80 | | Self x -> stage (fun s -> (* improperly staged *) unstage (t x.self_fix) s) 81 | | Custom _ -> failwith "Cannot generate random instance of Custom type" 82 | | Var v -> raise (Unbound_type_variable v) 83 | 84 | and char : char random = stage (fun s -> Char.unsafe_chr (R.int s 256)) 85 | 86 | and prim : type a. a prim -> a random = function 87 | | Unit -> return () 88 | | Bool -> stage R.bool 89 | | Char -> char 90 | | Int -> stage int 91 | | Int32 -> stage int32 92 | | Int64 -> stage int64 93 | | Float -> stage float 94 | | String len -> indexable ~mean_len:8 len String.init char 95 | | Bytes len -> indexable ~mean_len:8 len Bytes.init char 96 | 97 | and tuple : type a. a tuple -> a random = function 98 | | Pair (a, b) -> 99 | let+ a = t a and+ b = t b in 100 | fun s -> (a s, b s) 101 | | Triple (a, b, c) -> 102 | let+ a = t a and+ b = t b and+ c = t c in 103 | fun s -> (a s, b s, c s) 104 | | Quad (a, b, c, d) -> 105 | let+ a = t a and+ b = t b and+ c = t c and+ d = t d in 106 | fun s -> (a s, b s, c s, d s) 107 | 108 | and option : type a. a t -> a option random = 109 | fun elt -> 110 | let+ elt = t elt in 111 | fun s -> match R.bool s with true -> None | false -> Some (elt s) 112 | 113 | and record : type a. a record -> a random = 114 | fun { rfields = Fields (fs, constr); _ } -> 115 | let nil _ v = v in 116 | let cons { ftype; _ } random_remaining = 117 | let f_random = unstage (t ftype) in 118 | fun s constr -> 119 | let f = f_random s in 120 | random_remaining s (constr f) 121 | in 122 | let f = Record_deriver.fold { nil; cons } fs in 123 | stage (fun s -> f s constr) 124 | 125 | and variant : type a. a variant -> a random = 126 | fun v -> 127 | let random_case = 128 | let cases = Array.length v.vcases in 129 | fun s -> R.int s cases 130 | in 131 | let generators = 132 | ArrayLabels.map v.vcases ~f:(function 133 | | C0 { c0; _ } -> fun _ -> c0 134 | | C1 { c1; ctype1; _ } -> 135 | let inner = unstage (t ctype1) in 136 | fun s -> c1 (inner s)) 137 | in 138 | stage (fun s -> generators.(random_case s) s) 139 | 140 | and map : type a b. (a, b) map -> b random = 141 | fun m -> 142 | let+ inner = t m.x in 143 | fun s -> m.f (inner s) 144 | 145 | let of_state = t 146 | 147 | let of_global ty = 148 | let+ random = of_state ty in 149 | fun () -> random (Random.get_state ()) 150 | -------------------------------------------------------------------------------- /src/repr/type_random.mli: -------------------------------------------------------------------------------- 1 | open Type_core 2 | open Staging 3 | module Attr : Attribute.S1 with type 'a t = Random.State.t -> 'a 4 | 5 | val of_state : 'a t -> (Random.State.t -> 'a) staged 6 | val of_global : 'a t -> (unit -> 'a) staged 7 | -------------------------------------------------------------------------------- /src/repr/type_size.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016-2017 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Type_core 18 | module Sizer = Size.Sizer 19 | module Bin = Binary 20 | 21 | let rec t : type a. a t -> a Sizer.t = function 22 | | Self s -> fst (self s) 23 | | Custom c -> c.size_of 24 | | Map b -> map ~boxed:true b 25 | | Prim t -> prim ~boxed:true t 26 | | Attributes { attr_type; _ } -> t attr_type 27 | | Boxed b -> t b 28 | | List l -> Bin.List.sizer l.len (t l.v) 29 | | Array a -> Bin.Array.sizer a.len (t a.v) 30 | | Tuple t -> tuple t 31 | | Option x -> Bin.Option.sizer (t x) 32 | | Record r -> record r 33 | | Variant v -> variant v 34 | | Var v -> raise (Unbound_type_variable v) 35 | 36 | and unboxed : type a. a t -> a Sizer.t = function 37 | | Self s -> snd (self s) 38 | | Custom c -> c.unboxed_size_of 39 | | Map b -> map ~boxed:false b 40 | | Prim t -> prim ~boxed:false t 41 | | Attributes { attr_type = t; _ } -> unboxed t 42 | | Boxed b -> t b 43 | | List l -> Bin.List.sizer l.len (t l.v) 44 | | Array a -> Bin.Array.sizer a.len (t a.v) 45 | | Tuple t -> tuple t 46 | | Option x -> Bin.Option.sizer (t x) 47 | | Record r -> record r 48 | | Variant v -> variant v 49 | | Var v -> raise (Unbound_type_variable v) 50 | 51 | and self : type a. a self -> a Sizer.t * a Sizer.t = 52 | (* The resulting sizer may be any of [Unknown], [Static] or [Dynamic]. In the 53 | latter case, we must be able to recurse back to this definition at size 54 | computation time. 55 | 56 | We unroll with 'stub' dynamic values that initially [assert false] but will 57 | be backpatched with the parent derivation (iff it does actually turn out to 58 | be dynamic). *) 59 | let stub _ = assert false in 60 | let backpatch stubref = function 61 | | Size.Dynamic f -> stubref := f 62 | | Size.Static _ -> () 63 | | Size.Unknown -> () 64 | in 65 | fun { self_unroll; _ } -> 66 | let of_value = ref stub 67 | and of_encoding = ref stub 68 | and unboxed_of_value = ref stub 69 | and unboxed_of_encoding = ref stub in 70 | let unrolled = 71 | let size_of = 72 | Sizer.dynamic 73 | ~of_value:(fun a -> !of_value a) 74 | ~of_encoding:(fun buf off -> !of_encoding buf off) 75 | in 76 | let unboxed_size_of = 77 | Sizer.dynamic 78 | ~of_value:(fun a -> !unboxed_of_value a) 79 | ~of_encoding:(fun buf off -> !unboxed_of_encoding buf off) 80 | in 81 | self_unroll (partial ~size_of ~unboxed_size_of ()) 82 | in 83 | let t = t unrolled and unboxed = unboxed unrolled in 84 | backpatch of_value t.of_value; 85 | backpatch of_encoding t.of_encoding; 86 | backpatch unboxed_of_value unboxed.of_value; 87 | backpatch unboxed_of_encoding unboxed.of_encoding; 88 | (t, unboxed) 89 | 90 | and tuple : type a. a tuple -> a Sizer.t = function 91 | | Pair (x, y) -> Bin.Pair.sizer (t x) (t y) 92 | | Triple (x, y, z) -> Bin.Triple.sizer (t x) (t y) (t z) 93 | | Quad (w, x, y, z) -> Bin.Quad.sizer (t w) (t x) (t y) (t z) 94 | 95 | and map : type a b. boxed:bool -> (a, b) map -> b Sizer.t = 96 | fun ~boxed { x; g; _ } -> Sizer.using g (if boxed then t x else unboxed x) 97 | 98 | and prim : type a. boxed:bool -> a prim -> a Sizer.t = 99 | fun ~boxed -> function 100 | | Unit -> Bin.Unit.sizer 101 | | Bool -> Bin.Bool.sizer 102 | | Char -> Bin.Char.sizer 103 | | Int -> Bin.Varint.sizer 104 | | Int32 -> Bin.Int32.sizer 105 | | Int64 -> Bin.Int64.sizer 106 | | Float -> Bin.Float.sizer 107 | | String n -> (if boxed then Bin.String.sizer else Bin.String_unboxed.sizer) n 108 | | Bytes n -> (if boxed then Bin.Bytes.sizer else Bin.Bytes_unboxed.sizer) n 109 | 110 | and record : type a. a record -> a Sizer.t = 111 | fun r -> 112 | fields r 113 | |> List.map (fun (Field f) -> Sizer.using f.fget (t f.ftype)) 114 | |> ListLabels.fold_left ~init:(Sizer.static 0) ~f:Sizer.( <+> ) 115 | 116 | and variant : type a. a variant -> a Sizer.t = 117 | fun v -> 118 | let static_varint_size n = 119 | match Bin.Varint.sizer.of_value with 120 | | Unknown | Static _ -> assert false 121 | | Dynamic f -> f n 122 | in 123 | let case_lengths : (int * a Sizer.t) array = 124 | ArrayLabels.map v.vcases ~f:(function 125 | | C0 { ctag0; _ } -> (static_varint_size ctag0, Sizer.static 0) 126 | | C1 { ctag1; ctype1; cwit1 = expected; _ } -> 127 | let tag_length = static_varint_size ctag1 in 128 | let arg_length = 129 | match t ctype1 with 130 | | ({ of_value = Static _; _ } | { of_value = Unknown; _ }) as t -> t 131 | | { of_value = Dynamic of_value; of_encoding } -> 132 | let of_value a = 133 | match v.vget a with 134 | | CV0 _ -> assert false 135 | | CV1 ({ cwit1 = received; _ }, args) -> ( 136 | match Witness.cast received expected args with 137 | | Some v -> of_value v 138 | | None -> assert false) 139 | in 140 | { of_value = Dynamic of_value; of_encoding } 141 | in 142 | (tag_length, arg_length)) 143 | in 144 | (* If all cases have [size = Static n], then so does the variant. 145 | If any case has [size = Unknown], then so does the variant. *) 146 | let non_dynamic_length = 147 | let rec aux static_so_far = function 148 | | -1 -> Option.map (fun n -> Sizer.static n) static_so_far 149 | | i -> ( 150 | match case_lengths.(i) with 151 | | _, { of_value = Unknown; _ } -> Some Sizer.unknown 152 | | _, { of_value = Dynamic _; _ } -> None 153 | | tag_len, { of_value = Static arg_len; _ } -> ( 154 | let len = tag_len + arg_len in 155 | match static_so_far with 156 | | None -> aux (Some len) (i - 1) 157 | | Some len' when len = len' -> aux static_so_far (i - 1) 158 | | Some _ -> None)) 159 | in 160 | aux None (Array.length case_lengths - 1) 161 | in 162 | match non_dynamic_length with 163 | | Some x -> x 164 | | None -> 165 | (* Otherwise, the variant size is [Dynamic] over the tag *) 166 | let of_value a = 167 | let tag = 168 | match v.vget a with 169 | | CV0 { ctag0; _ } -> ctag0 170 | | CV1 ({ ctag1; _ }, _) -> ctag1 171 | in 172 | let tag_length, arg_length = case_lengths.(tag) in 173 | let arg_length = 174 | match arg_length.of_value with 175 | | Dynamic f -> f a 176 | | Static n -> n 177 | | Unknown -> 178 | (* [Unknown] arg lengths discounted above *) 179 | assert false 180 | in 181 | tag_length + arg_length 182 | in 183 | let of_encoding buf (Size.Offset off) = 184 | let off = ref off in 185 | let tag = Bin.Varint.decode buf off in 186 | match case_lengths.(tag) with 187 | | _, { of_encoding = Static n; _ } -> Size.Offset (!off + n) 188 | | _, { of_encoding = Dynamic f; _ } -> f buf (Size.Offset !off) 189 | | _, { of_encoding = _; _ } -> assert false 190 | in 191 | Sizer.dynamic ~of_value ~of_encoding 192 | -------------------------------------------------------------------------------- /src/repr/type_size.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016-2017 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Type_core 18 | 19 | val t : 'a t -> 'a Size.Sizer.t 20 | val unboxed : 'a t -> 'a Size.Sizer.t 21 | -------------------------------------------------------------------------------- /src/repr/utils.ml: -------------------------------------------------------------------------------- 1 | open Staging 2 | 3 | let check_valid_utf8 str = 4 | Uutf.String.fold_utf_8 5 | (fun _ _ -> function 6 | | `Malformed _ -> invalid_arg "Malformed UTF-8" 7 | | _ -> ()) 8 | () str 9 | 10 | let is_valid_utf8 str = 11 | try 12 | check_valid_utf8 str; 13 | true 14 | with Invalid_argument _ -> false 15 | 16 | let fix_staged : 17 | type a b. ((a -> b) staged -> (a -> b) staged) -> (a -> b) staged = 18 | fun unroll -> 19 | let rec here = lazy (unroll (stage backptr)) 20 | and backptr e = unstage (Lazy.force here) e in 21 | Lazy.force here 22 | 23 | let fix_staged2 : 24 | type a b c d. 25 | (((a -> b) staged as 'f1) -> ((c -> d) staged as 'f2) -> 'f1 * 'f2) -> 26 | 'f1 * 'f2 = 27 | fun unroll -> 28 | let rec here = lazy (unroll (stage backptr1) (stage backptr2)) 29 | and backptr1 e = unstage (Lazy.force here |> fst) e 30 | and backptr2 e = unstage (Lazy.force here |> snd) e in 31 | Lazy.force here 32 | -------------------------------------------------------------------------------- /src/repr/utils.mli: -------------------------------------------------------------------------------- 1 | open Staging 2 | 3 | val check_valid_utf8 : string -> unit 4 | val is_valid_utf8 : string -> bool 5 | 6 | val fix_staged : ('f -> 'f) -> ((_ -> _) staged as 'f) 7 | (** Fixpoint combinator that unrolls exactly once via lazy, recursively-defined 8 | values. Useful when unrolling has a non-negligible performance cost, e.g. 9 | incurs many heap allocations. *) 10 | 11 | val fix_staged2 : 12 | ('f1 -> 'f2 -> 'f1 * 'f2) -> 13 | ((_ -> _) staged as 'f1) * ((_ -> _) staged as 'f2) 14 | (** Generalises {!fix_staged} to handle mutually recursive definitions. *) 15 | -------------------------------------------------------------------------------- /src/repr/witness.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016-2017 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | type (_, _) eq = Refl : ('a, 'a) eq 18 | type _ equality = .. 19 | 20 | module type Inst = sig 21 | type t 22 | type _ equality += Eq : t equality 23 | end 24 | 25 | type 'a t = (module Inst with type t = 'a) 26 | 27 | let make : type a. unit -> a t = 28 | fun () -> 29 | let module Inst = struct 30 | type t = a 31 | type _ equality += Eq : t equality 32 | end in 33 | (module Inst) 34 | 35 | let eq : type a b. a t -> b t -> (a, b) eq option = 36 | fun (module A) (module B) -> match A.Eq with B.Eq -> Some Refl | _ -> None 37 | 38 | let eq_exn : type a b. a t -> b t -> (a, b) eq = 39 | fun (module A) (module B) -> 40 | match A.Eq with 41 | | B.Eq -> Refl 42 | | _ -> failwith "Repr.internal_error: unexpected runtime type inequality" 43 | 44 | let cast : type a b. a t -> b t -> a -> b option = 45 | fun awit bwit a -> match eq awit bwit with Some Refl -> Some a | None -> None 46 | 47 | let cast_exn : type a b. a t -> b t -> a -> b = 48 | fun awit bwit a -> 49 | let Refl = eq_exn awit bwit in 50 | a 51 | -------------------------------------------------------------------------------- /src/repr/witness.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016-2017 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | type (_, _) eq = Refl : ('a, 'a) eq 18 | type 'a t 19 | 20 | val make : unit -> 'a t 21 | val eq : 'a t -> 'b t -> ('a, 'b) eq option 22 | val eq_exn : 'a t -> 'b t -> ('a, 'b) eq 23 | val cast : 'a t -> 'b t -> 'a -> 'b option 24 | val cast_exn : 'a t -> 'b t -> 'a -> 'b 25 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name gen_dune_rules) 3 | (modules gen_dune_rules)) 4 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/errors/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name pp) 3 | (modules pp) 4 | (libraries ppx_repr ppxlib)) 5 | 6 | (include dune.inc) 7 | 8 | (rule 9 | (targets dune.inc.gen) 10 | (deps 11 | (source_tree .)) 12 | (action 13 | (with-stdout-to 14 | %{targets} 15 | (run ../gen_dune_rules.exe --expect-failure)))) 16 | 17 | (rule 18 | (alias runtest) 19 | (package ppx_repr) 20 | (action 21 | (diff dune.inc dune.inc.gen))) 22 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/errors/dune.inc: -------------------------------------------------------------------------------- 1 | (env 2 | (_ 3 | (env-vars 4 | (OCAML_ERROR_STYLE "short") 5 | (OCAML_COLOR "never")))) 6 | 7 | ; -------- Test: `lib_invalid.ml` -------- 8 | 9 | 10 | 11 | ; Run the PPX on the `.ml` file 12 | (rule 13 | (targets lib_invalid.actual) 14 | (deps 15 | (:pp pp.exe) 16 | (:input lib_invalid.ml)) 17 | (action 18 | ; expect the process to fail, capturing stderr 19 | (with-stderr-to 20 | %{targets} 21 | (bash "! ./%{pp} -no-color --impl %{input}")))) 22 | 23 | ; Compare the post-processed output to the .expected file 24 | (rule 25 | (alias runtest) 26 | (package ppx_repr) 27 | (action 28 | (diff lib_invalid.expected lib_invalid.actual))) 29 | 30 | ; -------- Test: `nobuiltin_nonempty.ml` -------- 31 | 32 | 33 | 34 | ; Run the PPX on the `.ml` file 35 | (rule 36 | (targets nobuiltin_nonempty.actual) 37 | (deps 38 | (:pp pp.exe) 39 | (:input nobuiltin_nonempty.ml)) 40 | (action 41 | ; expect the process to fail, capturing stderr 42 | (with-stderr-to 43 | %{targets} 44 | (bash "! ./%{pp} -no-color --impl %{input}")))) 45 | 46 | ; Compare the post-processed output to the .expected file 47 | (rule 48 | (alias runtest) 49 | (package ppx_repr) 50 | (action 51 | (diff nobuiltin_nonempty.expected nobuiltin_nonempty.actual))) 52 | 53 | ; -------- Test: `recursion_more_than_two.ml` -------- 54 | 55 | 56 | 57 | ; Run the PPX on the `.ml` file 58 | (rule 59 | (targets recursion_more_than_two.actual) 60 | (deps 61 | (:pp pp.exe) 62 | (:input recursion_more_than_two.ml)) 63 | (action 64 | ; expect the process to fail, capturing stderr 65 | (with-stderr-to 66 | %{targets} 67 | (bash "! ./%{pp} -no-color --impl %{input}")))) 68 | 69 | ; Compare the post-processed output to the .expected file 70 | (rule 71 | (alias runtest) 72 | (enabled_if (>= %{ocaml_version} 4.09)) 73 | (package ppx_repr) 74 | (action 75 | (diff recursion_more_than_two.expected recursion_more_than_two.actual))) 76 | 77 | ; -------- Test: `recursion_with_type_parameters.ml` -------- 78 | 79 | 80 | 81 | ; Run the PPX on the `.ml` file 82 | (rule 83 | (targets recursion_with_type_parameters.actual) 84 | (deps 85 | (:pp pp.exe) 86 | (:input recursion_with_type_parameters.ml)) 87 | (action 88 | ; expect the process to fail, capturing stderr 89 | (with-stderr-to 90 | %{targets} 91 | (bash "! ./%{pp} -no-color --impl %{input}")))) 92 | 93 | ; Compare the post-processed output to the .expected file 94 | (rule 95 | (alias runtest) 96 | (enabled_if (>= %{ocaml_version} 4.09)) 97 | (package ppx_repr) 98 | (action 99 | (diff recursion_with_type_parameters.expected 100 | recursion_with_type_parameters.actual))) 101 | 102 | ; -------- Test: `unsupported_polyvar_inherit_case.ml` -------- 103 | 104 | 105 | 106 | ; Run the PPX on the `.ml` file 107 | (rule 108 | (targets unsupported_polyvar_inherit_case.actual) 109 | (deps 110 | (:pp pp.exe) 111 | (:input unsupported_polyvar_inherit_case.ml)) 112 | (action 113 | ; expect the process to fail, capturing stderr 114 | (with-stderr-to 115 | %{targets} 116 | (bash "! ./%{pp} -no-color --impl %{input}")))) 117 | 118 | ; Compare the post-processed output to the .expected file 119 | (rule 120 | (alias runtest) 121 | (package ppx_repr) 122 | (action 123 | (diff unsupported_polyvar_inherit_case.expected 124 | unsupported_polyvar_inherit_case.actual))) 125 | 126 | ; -------- Test: `unsupported_tuple_size.ml` -------- 127 | 128 | 129 | 130 | ; Run the PPX on the `.ml` file 131 | (rule 132 | (targets unsupported_tuple_size.actual) 133 | (deps 134 | (:pp pp.exe) 135 | (:input unsupported_tuple_size.ml)) 136 | (action 137 | ; expect the process to fail, capturing stderr 138 | (with-stderr-to 139 | %{targets} 140 | (bash "! ./%{pp} -no-color --impl %{input}")))) 141 | 142 | ; Compare the post-processed output to the .expected file 143 | (rule 144 | (alias runtest) 145 | (package ppx_repr) 146 | (action 147 | (diff unsupported_tuple_size.expected unsupported_tuple_size.actual))) 148 | 149 | ; -------- Test: `unsupported_type_arrow.ml` -------- 150 | 151 | 152 | 153 | ; Run the PPX on the `.ml` file 154 | (rule 155 | (targets unsupported_type_arrow.actual) 156 | (deps 157 | (:pp pp.exe) 158 | (:input unsupported_type_arrow.ml)) 159 | (action 160 | ; expect the process to fail, capturing stderr 161 | (with-stderr-to 162 | %{targets} 163 | (bash "! ./%{pp} -no-color --impl %{input}")))) 164 | 165 | ; Compare the post-processed output to the .expected file 166 | (rule 167 | (alias runtest) 168 | (package ppx_repr) 169 | (action 170 | (diff unsupported_type_arrow.expected unsupported_type_arrow.actual))) 171 | 172 | ; -------- Test: `unsupported_type_extension.ml` -------- 173 | 174 | 175 | 176 | ; Run the PPX on the `.ml` file 177 | (rule 178 | (targets unsupported_type_extension.actual) 179 | (deps 180 | (:pp pp.exe) 181 | (:input unsupported_type_extension.ml)) 182 | (action 183 | ; expect the process to fail, capturing stderr 184 | (with-stderr-to 185 | %{targets} 186 | (bash "! ./%{pp} -no-color --impl %{input}")))) 187 | 188 | ; Compare the post-processed output to the .expected file 189 | (rule 190 | (alias runtest) 191 | (package ppx_repr) 192 | (action 193 | (diff unsupported_type_extension.expected unsupported_type_extension.actual))) 194 | 195 | ; -------- Test: `unsupported_type_open.ml` -------- 196 | 197 | 198 | 199 | ; Run the PPX on the `.ml` file 200 | (rule 201 | (targets unsupported_type_open.actual) 202 | (deps 203 | (:pp pp.exe) 204 | (:input unsupported_type_open.ml)) 205 | (action 206 | ; expect the process to fail, capturing stderr 207 | (with-stderr-to 208 | %{targets} 209 | (bash "! ./%{pp} -no-color --impl %{input}")))) 210 | 211 | ; Compare the post-processed output to the .expected file 212 | (rule 213 | (alias runtest) 214 | (package ppx_repr) 215 | (action 216 | (diff unsupported_type_open.expected unsupported_type_open.actual))) 217 | 218 | ; -------- Test: `unsupported_type_open_polyvariant.ml` -------- 219 | 220 | 221 | 222 | ; Run the PPX on the `.ml` file 223 | (rule 224 | (targets unsupported_type_open_polyvariant.actual) 225 | (deps 226 | (:pp pp.exe) 227 | (:input unsupported_type_open_polyvariant.ml)) 228 | (action 229 | ; expect the process to fail, capturing stderr 230 | (with-stderr-to 231 | %{targets} 232 | (bash "! ./%{pp} -no-color --impl %{input}")))) 233 | 234 | ; Compare the post-processed output to the .expected file 235 | (rule 236 | (alias runtest) 237 | (package ppx_repr) 238 | (action 239 | (diff unsupported_type_open_polyvariant.expected 240 | unsupported_type_open_polyvariant.actual))) 241 | 242 | ; -------- Test: `unsupported_type_package.ml` -------- 243 | 244 | 245 | 246 | ; Run the PPX on the `.ml` file 247 | (rule 248 | (targets unsupported_type_package.actual) 249 | (deps 250 | (:pp pp.exe) 251 | (:input unsupported_type_package.ml)) 252 | (action 253 | ; expect the process to fail, capturing stderr 254 | (with-stderr-to 255 | %{targets} 256 | (bash "! ./%{pp} -no-color --impl %{input}")))) 257 | 258 | ; Compare the post-processed output to the .expected file 259 | (rule 260 | (alias runtest) 261 | (package ppx_repr) 262 | (action 263 | (diff unsupported_type_package.expected unsupported_type_package.actual))) 264 | 265 | ; -------- Test: `unsupported_type_poly.ml` -------- 266 | 267 | 268 | 269 | ; Run the PPX on the `.ml` file 270 | (rule 271 | (targets unsupported_type_poly.actual) 272 | (deps 273 | (:pp pp.exe) 274 | (:input unsupported_type_poly.ml)) 275 | (action 276 | ; expect the process to fail, capturing stderr 277 | (with-stderr-to 278 | %{targets} 279 | (bash "! ./%{pp} -no-color --impl %{input}")))) 280 | 281 | ; Compare the post-processed output to the .expected file 282 | (rule 283 | (alias runtest) 284 | (package ppx_repr) 285 | (action 286 | (diff unsupported_type_poly.expected unsupported_type_poly.actual))) 287 | 288 | 289 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/errors/lib_invalid.expected: -------------------------------------------------------------------------------- 1 | File "lib_invalid.ml", line 1, characters 39-44: 2 | Error: Could not process `lib' argument: must be either `Some "Lib"' or `None' 3 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/errors/lib_invalid.ml: -------------------------------------------------------------------------------- 1 | type t = unit [@@deriving repr { lib = "foo" }] (* should be [Some "foo"] *) 2 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/errors/nobuiltin_nonempty.expected: -------------------------------------------------------------------------------- 1 | File "nobuiltin_nonempty.ml", line 1, characters 26-28: 2 | Error: `nobuiltin` payload must be empty 3 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/errors/nobuiltin_nonempty.ml: -------------------------------------------------------------------------------- 1 | type x = (unit[@nobuiltin ()]) [@@deriving repr] 2 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/errors/pp.ml: -------------------------------------------------------------------------------- 1 | Ppxlib.Driver.standalone () 2 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/errors/recursion_more_than_two.expected: -------------------------------------------------------------------------------- 1 | File "recursion_more_than_two.ml", lines 1-3, characters 0-36: 2 | Error: ppx_repr: mutually-recursive groups of size > 2 are not supported. Here we have 3 types: t1, t2, t3) 3 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/errors/recursion_more_than_two.ml: -------------------------------------------------------------------------------- 1 | type t1 = t2 option 2 | and t2 = t3 option 3 | and t3 = t1 option [@@deriving repr] 4 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/errors/recursion_with_type_parameters.expected: -------------------------------------------------------------------------------- 1 | File "recursion_with_type_parameters.ml", lines 1-2, characters 0-47: 2 | Error: ppx_repr: Can't support mutually-recursive types with type parameters in type t1 3 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/errors/recursion_with_type_parameters.ml: -------------------------------------------------------------------------------- 1 | type 'a t1 = 'a * t2 option 2 | and t2 = int * unit t1 option [@@deriving repr] 3 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/errors/unsupported_polyvar_inherit_case.expected: -------------------------------------------------------------------------------- 1 | File "unsupported_polyvar_inherit_case.ml", line 2, characters 9-19: 2 | Error: ppx_repr: inherited variant cases encountered in [ | s | `T ]. This is unsupported by ppx_repr. 3 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/errors/unsupported_polyvar_inherit_case.ml: -------------------------------------------------------------------------------- 1 | type s = [ `S ] [@@deriving repr] 2 | type t = [ s | `T ] [@@deriving repr] 3 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/errors/unsupported_tuple_size.expected: -------------------------------------------------------------------------------- 1 | File "unsupported_tuple_size.ml", line 1, characters 0-59: 2 | Error: ppx_repr: tuple types must have 2, 3 or 4 components. Found 5. 3 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/errors/unsupported_tuple_size.ml: -------------------------------------------------------------------------------- 1 | type t = unit * unit * unit * unit * unit [@@deriving repr] 2 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/errors/unsupported_type_arrow.expected: -------------------------------------------------------------------------------- 1 | File "unsupported_type_arrow.ml", line 1, characters 9-20: 2 | Error: ppx_repr: function type encountered: unit -> int. Functions are not Irmin-serialisable. 3 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/errors/unsupported_type_arrow.ml: -------------------------------------------------------------------------------- 1 | type t = unit -> int [@@deriving repr] 2 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/errors/unsupported_type_extension.expected: -------------------------------------------------------------------------------- 1 | File "unsupported_type_extension.ml", line 1, characters 9-15: 2 | Error: ppx_repr: unprocessed extension [%typ ] encountered. 3 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/errors/unsupported_type_extension.ml: -------------------------------------------------------------------------------- 1 | type t = [%typ] [@@deriving repr] 2 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/errors/unsupported_type_open.expected: -------------------------------------------------------------------------------- 1 | File "unsupported_type_open.ml", line 1, characters 0-29: 2 | Error: ppx_repr: extensible variant types are not Irmin-serialisable. 3 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/errors/unsupported_type_open.ml: -------------------------------------------------------------------------------- 1 | type t = .. [@@deriving repr] 2 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/errors/unsupported_type_open_polyvariant.expected: -------------------------------------------------------------------------------- 1 | File "unsupported_type_open_polyvariant.ml", line 1, characters 9-24: 2 | Error: ppx_repr: open polymorphic variant [> `On | `Off ] encountered. Polymorphic variants must be closed. 3 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/errors/unsupported_type_open_polyvariant.ml: -------------------------------------------------------------------------------- 1 | type t = [> `On | `Off ] [@@deriving repr] 2 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/errors/unsupported_type_package.expected: -------------------------------------------------------------------------------- 1 | File "unsupported_type_package.ml", line 5, characters 9-19: 2 | Error: ppx_repr: package type (module S) encountered. Package types are not Irmin-serialisable. 3 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/errors/unsupported_type_package.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | val x : unit 3 | end 4 | 5 | type t = (module S) [@@deriving repr] 6 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/errors/unsupported_type_poly.expected: -------------------------------------------------------------------------------- 1 | File "unsupported_type_poly.ml", line 1, characters 15-21: 2 | Error: ppx_repr: universally-quantified type 'a . 'a encountered. Irmin types must be grounded. 3 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/errors/unsupported_type_poly.ml: -------------------------------------------------------------------------------- 1 | type t = { v : 'a. 'a } [@@deriving repr] 2 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/gen_dune_rules.ml: -------------------------------------------------------------------------------- 1 | (* Global configuration for tests in which the PPX fails (for consistency with 2 | various compiler versions / platforms). *) 3 | let ppx_fail_global_stanzas () = 4 | Format.printf 5 | {|(env 6 | (_ 7 | (env-vars 8 | (OCAML_ERROR_STYLE "short") 9 | (OCAML_COLOR "never")))) 10 | 11 | |} 12 | 13 | let ocaml_version = function 14 | | "recursion_with_type_parameters" | "recursion_more_than_two" -> Some "4.09" 15 | | _ -> None 16 | 17 | let output_stanzas ~expect_failure filename = 18 | let base = Filename.remove_extension filename in 19 | let pp_library ppf base = 20 | (* If the PPX will fail, we don't need to declare the file as executable *) 21 | if not expect_failure then 22 | Format.fprintf ppf 23 | "; The PPX-dependent executable under test@,\ 24 | @[(executable@ (name %s)@ (modules %s)@ (preprocess (pps \ 25 | ppx_repr))@ (libraries repr))@]" 26 | base base 27 | else () 28 | in 29 | let pp_rule ppf base = 30 | let pp_action ppf expect_failure = 31 | Format.fprintf ppf 32 | (if expect_failure then 33 | "; expect the process to fail, capturing stderr@,\ 34 | @[(with-stderr-to@,\ 35 | %%{targets}@,\ 36 | (bash \"! ./%%{pp} -no-color --impl %%{input}\"))@]" 37 | else 38 | "(run ./%%{pp} -deriving-keep-w32 both --impl %%{input} -o \ 39 | %%{targets})") 40 | in 41 | Format.fprintf ppf 42 | "; Run the PPX on the `.ml` file@,\ 43 | @[(rule@,\ 44 | (targets %s.actual)@,\ 45 | @[(deps@,\ 46 | (:pp pp.exe)@,\ 47 | (:input %s.ml))@]@,\ 48 | @[(action@,\ 49 | %a))@]@]" 50 | base base pp_action expect_failure 51 | in 52 | let pp_enabled_if ppf = function 53 | | None -> () 54 | | Some v -> Format.fprintf ppf "(enabled_if (>= %%{ocaml_version} %s))@," v 55 | in 56 | let pp_diff_alias ppf base = 57 | Format.fprintf ppf 58 | "; Compare the post-processed output to the .expected file@,\ 59 | @[(rule@,\ 60 | (alias runtest)@,\ 61 | %a(package ppx_repr)@,\ 62 | @[(action@,\ 63 | @[(diff@ %s.expected@ %s.actual)@])@])@]" pp_enabled_if 64 | (ocaml_version base) base base 65 | in 66 | let pp_run_alias ppf base = 67 | (* If we expect the derivation to succeed, then we should be able to compile 68 | the output. *) 69 | if not expect_failure then 70 | Format.fprintf ppf 71 | "@,\ 72 | @,\ 73 | ; Ensure that the post-processed executable runs correctly@,\ 74 | @[(rule@,\ 75 | (alias runtest)@,\ 76 | (package ppx_repr)@,\ 77 | @[(action@,\ 78 | @[(run@ ./%s.exe)@])@])@]" base 79 | else () 80 | in 81 | Format.set_margin 80; 82 | Format.printf 83 | "@[; -------- Test: `%s.ml` --------@,@,%a@,@,%a@,@,%a%a@,@]@." base 84 | pp_library base pp_rule base pp_diff_alias base pp_run_alias base 85 | 86 | let is_error_test = function 87 | | "pp.ml" -> false 88 | | "gen_dune_rules.ml" -> false 89 | | filename -> 90 | Filename.check_suffix filename ".ml" 91 | (* Avoid capturing post-PPX files *) 92 | && not (Filename.check_suffix filename ".pp.ml") 93 | 94 | let () = 95 | let expect_failure = 96 | match Array.to_list Sys.argv with 97 | | [ _; "--expect-failure" ] -> true 98 | | [ _ ] -> false 99 | | _ -> failwith "Unsupported option passed" 100 | in 101 | if expect_failure then ppx_fail_global_stanzas (); 102 | Sys.readdir "." 103 | |> Array.to_list 104 | |> List.sort String.compare 105 | |> List.filter is_error_test 106 | |> List.iter (output_stanzas ~expect_failure); 107 | Format.printf "\n%!" 108 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/alias.expected: -------------------------------------------------------------------------------- 1 | type test_result = (int, string) result[@@deriving repr] 2 | include struct let test_result_t = Repr.result Repr.int Repr.string end 3 | [@@ocaml.doc "@inline"][@@merlin.hide ] 4 | type t_alias = test_result[@@deriving repr] 5 | include struct let t_alias_t = test_result_t end[@@ocaml.doc "@inline"] 6 | [@@merlin.hide ] 7 | type t = t_alias[@@deriving repr] 8 | include struct let t = t_alias_t end[@@ocaml.doc "@inline"][@@merlin.hide ] 9 | let (_ : test_result Repr.t) = test_result_t 10 | let (_ : t_alias Repr.t) = t_alias_t 11 | let (_ : t Repr.t) = t 12 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/alias.ml: -------------------------------------------------------------------------------- 1 | (* Tests of type aliases *) 2 | type test_result = (int, string) result [@@deriving repr] 3 | type t_alias = test_result [@@deriving repr] 4 | type t = t_alias [@@deriving repr] 5 | 6 | let (_ : test_result Repr.t) = test_result_t 7 | let (_ : t_alias Repr.t) = t_alias_t 8 | let (_ : t Repr.t) = t 9 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/arguments.expected: -------------------------------------------------------------------------------- 1 | type c = string[@@deriving repr { name = "c_wit" }] 2 | include struct let c_wit = Repr.string end[@@ocaml.doc "@inline"][@@merlin.hide 3 | ] 4 | let (_ : c Repr.t) = c_wit 5 | type d = int[@@deriving repr { name = "repr_for_d" }] 6 | include struct let repr_for_d = Repr.int end[@@ocaml.doc "@inline"][@@merlin.hide 7 | ] 8 | let (_ : d Repr.t) = repr_for_d 9 | type point_elsewhere1 = ((c)[@repr c_wit])[@@deriving repr] 10 | include struct let point_elsewhere1_t = c_wit end[@@ocaml.doc "@inline"] 11 | [@@merlin.hide ] 12 | type point_elsewhere2 = (int * ((c)[@repr c_wit]))[@@deriving repr] 13 | include struct let point_elsewhere2_t = Repr.pair Repr.int c_wit end[@@ocaml.doc 14 | "@inline"] 15 | [@@merlin.hide ] 16 | type point_elsewhere3 = 17 | | A of int * ((c)[@repr c_wit]) 18 | | B of ((c)[@repr c_wit]) [@@deriving repr] 19 | include 20 | struct 21 | let point_elsewhere3_t = 22 | Repr.sealv 23 | (Repr.(|~) 24 | (Repr.(|~) 25 | (Repr.variant "point_elsewhere3" 26 | (fun a -> 27 | fun b -> 28 | function | A (x1, x2) -> a (x1, x2) | B x1 -> b x1)) 29 | (Repr.case1 "A" (Repr.pair Repr.int c_wit) 30 | (fun (x1, x2) -> A (x1, x2)))) 31 | (Repr.case1 "B" c_wit (fun x1 -> B x1))) 32 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 33 | type point_elsewhere4 = 34 | { 35 | lorem: string ; 36 | ipsum: ((c)[@repr c_wit]) ; 37 | dolor: int ; 38 | sit: ((d)[@repr repr_for_d]) }[@@deriving repr] 39 | include 40 | struct 41 | let point_elsewhere4_t = 42 | Repr.sealr 43 | (Repr.(|+) 44 | (Repr.(|+) 45 | (Repr.(|+) 46 | (Repr.(|+) 47 | (Repr.record "point_elsewhere4" 48 | (fun lorem -> 49 | fun ipsum -> 50 | fun dolor -> 51 | fun sit -> { lorem; ipsum; dolor; sit })) 52 | (Repr.field "lorem" Repr.string (fun t -> t.lorem))) 53 | (Repr.field "ipsum" c_wit (fun t -> t.ipsum))) 54 | (Repr.field "dolor" Repr.int (fun t -> t.dolor))) 55 | (Repr.field "sit" repr_for_d (fun t -> t.sit))) 56 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 57 | let (_ : point_elsewhere1 Repr.t) = point_elsewhere1_t 58 | let (_ : point_elsewhere2 Repr.t) = point_elsewhere2_t 59 | let (_ : point_elsewhere3 Repr.t) = point_elsewhere3_t 60 | let (_ : point_elsewhere4 Repr.t) = point_elsewhere4_t 61 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/arguments.ml: -------------------------------------------------------------------------------- 1 | (* Tests of the arguments/attributes *) 2 | type c = string [@@deriving repr { name = "c_wit" }] 3 | 4 | let (_ : c Repr.t) = c_wit 5 | 6 | type d = int [@@deriving repr { name = "repr_for_d" }] 7 | 8 | let (_ : d Repr.t) = repr_for_d 9 | 10 | type point_elsewhere1 = (c[@repr c_wit]) [@@deriving repr] 11 | type point_elsewhere2 = int * (c[@repr c_wit]) [@@deriving repr] 12 | 13 | type point_elsewhere3 = A of int * (c[@repr c_wit]) | B of (c[@repr c_wit]) 14 | [@@deriving repr] 15 | 16 | type point_elsewhere4 = { 17 | lorem : string; 18 | ipsum : (c[@repr c_wit]); 19 | dolor : int; 20 | sit : (d[@repr repr_for_d]); 21 | } 22 | [@@deriving repr] 23 | 24 | let (_ : point_elsewhere1 Repr.t) = point_elsewhere1_t 25 | let (_ : point_elsewhere2 Repr.t) = point_elsewhere2_t 26 | let (_ : point_elsewhere3 Repr.t) = point_elsewhere3_t 27 | let (_ : point_elsewhere4 Repr.t) = point_elsewhere4_t 28 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/as_alias.expected: -------------------------------------------------------------------------------- 1 | type 'a typ = 'a Repr.t 2 | module Trivial : 3 | sig 4 | type t[@@deriving repr] 5 | include sig val t : t Repr.t end[@@ocaml.doc "@inline"][@@merlin.hide ] 6 | end = 7 | struct 8 | type t = int as 'a[@@deriving repr] 9 | include struct let t = Repr.int end[@@ocaml.doc "@inline"][@@merlin.hide 10 | ] 11 | end 12 | module Recursive : 13 | sig 14 | type 'a tree[@@deriving repr] 15 | include sig val tree_t : 'a Repr.t -> 'a tree Repr.t end[@@ocaml.doc 16 | "@inline"] 17 | [@@merlin.hide ] 18 | end = 19 | struct 20 | type 'a tree = 21 | [ `Branch of ('tree * int * 'tree) | `Leaf of 'a ] as 'tree[@@deriving 22 | repr] 23 | include 24 | struct 25 | let tree_t a = 26 | Repr.mu 27 | (fun tree -> 28 | Repr.sealv 29 | (Repr.(|~) 30 | (Repr.(|~) 31 | (Repr.variant "tree" 32 | (fun branch -> 33 | fun leaf -> 34 | function 35 | | `Branch x1 -> branch x1 36 | | `Leaf x1 -> leaf x1)) 37 | (Repr.case1 "Branch" (Repr.triple tree Repr.int tree) 38 | (fun x1 -> `Branch x1))) 39 | (Repr.case1 "Leaf" a (fun x1 -> `Leaf x1)))) 40 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 41 | end 42 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/as_alias.ml: -------------------------------------------------------------------------------- 1 | type 'a typ = 'a Repr.t 2 | 3 | module Trivial : sig 4 | type t [@@deriving repr] 5 | end = struct 6 | type t = int as 'a [@@deriving repr] 7 | end 8 | 9 | module Recursive : sig 10 | type 'a tree [@@deriving repr] 11 | end = struct 12 | type 'a tree = [ `Branch of 'tree * int * 'tree | `Leaf of 'a ] as 'tree 13 | [@@deriving repr] 14 | end 15 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/basic.ml: -------------------------------------------------------------------------------- 1 | type int63 = Optint.Int63.t 2 | 3 | module type BASIC = sig 4 | val test_unit_t : unit Repr.t 5 | val test_bool_t : bool Repr.t 6 | val test_char_t : char Repr.t 7 | val test_int_t : int Repr.t 8 | val test_int32_t : int32 Repr.t 9 | val test_int63_t : int63 Repr.t 10 | val test_int64_t : int64 Repr.t 11 | val test_float_t : float Repr.t 12 | val test_string_t : string Repr.t 13 | val test_bytes_t : bytes Repr.t 14 | end 15 | 16 | module Basic : BASIC = struct 17 | type test_unit = unit [@@deriving repr] 18 | type test_bool = bool [@@deriving repr] 19 | type test_char = char [@@deriving repr] 20 | type test_int = int [@@deriving repr] 21 | type test_int32 = int32 [@@deriving repr] 22 | type test_int63 = int63 [@@deriving repr] 23 | type test_int64 = int64 [@@deriving repr] 24 | type test_float = float [@@deriving repr] 25 | type test_string = string [@@deriving repr] 26 | type test_bytes = bytes [@@deriving repr] 27 | end 28 | 29 | module Composite : sig end = struct 30 | type test_list1 = string list [@@deriving repr] 31 | type test_list2 = int32 list list list [@@deriving repr] 32 | type test_array = bool array [@@deriving repr] 33 | type test_option = unit option [@@deriving repr] 34 | type test_pair = string * int32 [@@deriving repr] 35 | type test_triple = string * int32 * bool [@@deriving repr] 36 | type test_quad = string * int32 * bool * float [@@deriving repr] 37 | type test_result = (int32 lazy_t, string) result [@@deriving repr] 38 | 39 | let (_ : test_list1 Repr.t) = test_list1_t 40 | let (_ : test_list2 Repr.t) = test_list2_t 41 | let (_ : test_array Repr.t) = test_array_t 42 | let (_ : test_option Repr.t) = test_option_t 43 | let (_ : test_pair Repr.t) = test_pair_t 44 | let (_ : test_triple Repr.t) = test_triple_t 45 | let (_ : test_quad Repr.t) = test_quad_t 46 | let (_ : test_result Repr.t) = test_result_t 47 | end 48 | 49 | module Inside_modules : sig 50 | include BASIC 51 | 52 | (* Aliases of composite types *) 53 | val test_list_t : 'a Repr.t -> 'a List.t Repr.t 54 | val test_array_t : 'a Repr.t -> 'a Array.t Repr.t 55 | val test_option_t : 'a Repr.t -> 'a Option.t Repr.t 56 | val test_lazy_t : 'a Repr.t -> 'a Lazy.t Repr.t 57 | val test_result_t : 'a Repr.t -> 'b Repr.t -> ('a, 'b) Result.t Repr.t 58 | 59 | (* Other container types *) 60 | val test_seq_t : 'a Repr.t -> 'a Seq.t Repr.t 61 | val test_hashtbl_t : 'a Repr.t -> 'b Repr.t -> ('a, 'b) Hashtbl.t Repr.t 62 | val test_stack_t : 'a Repr.t -> 'a Stack.t Repr.t 63 | val test_queue_t : 'a Repr.t -> 'a Queue.t Repr.t 64 | val test_either_t : 'a Repr.t -> 'b Repr.t -> ('a, 'b) Either.t Repr.t 65 | end = struct 66 | type test_unit = Unit.t [@@deriving repr] 67 | type test_bool = Bool.t [@@deriving repr] 68 | type test_char = Char.t [@@deriving repr] 69 | type test_int = Int.t [@@deriving repr] 70 | type test_int32 = Int32.t [@@deriving repr] 71 | type test_int63 = Optint.Int63.t [@@deriving repr] 72 | type test_int64 = Int64.t [@@deriving repr] 73 | type test_float = Float.t [@@deriving repr] 74 | type test_string = String.t [@@deriving repr] 75 | type test_bytes = Bytes.t [@@deriving repr] 76 | type 'a test_list = 'a List.t [@@deriving repr] 77 | type 'a test_array = 'a Array.t [@@deriving repr] 78 | type 'a test_option = 'a Option.t [@@deriving repr] 79 | type 'a test_lazy = 'a Lazy.t [@@deriving repr] 80 | type ('a, 'b) test_result = ('a, 'b) Result.t [@@deriving repr] 81 | type 'a test_seq = 'a Seq.t [@@deriving repr] 82 | type ('a, 'b) test_hashtbl = ('a, 'b) Hashtbl.t [@@deriving repr] 83 | type 'a test_stack = 'a Stack.t [@@deriving repr] 84 | type 'a test_queue = 'a Queue.t [@@deriving repr] 85 | type ('a, 'b) test_either = ('a, 'b) Either.t [@@deriving repr] 86 | end 87 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/composite.expected: -------------------------------------------------------------------------------- 1 | type test_list1 = string list[@@deriving repr] 2 | include struct let test_list1_t = Repr.list Repr.string end[@@ocaml.doc 3 | "@inline"] 4 | [@@merlin.hide ] 5 | type test_list2 = int32 list list list[@@deriving repr] 6 | include 7 | struct let test_list2_t = Repr.list (Repr.list (Repr.list Repr.int32)) end 8 | [@@ocaml.doc "@inline"][@@merlin.hide ] 9 | type test_array = bool array[@@deriving repr] 10 | include struct let test_array_t = Repr.array Repr.bool end[@@ocaml.doc 11 | "@inline"] 12 | [@@merlin.hide ] 13 | type test_option = unit option[@@deriving repr] 14 | include struct let test_option_t = Repr.option Repr.unit end[@@ocaml.doc 15 | "@inline"] 16 | [@@merlin.hide ] 17 | type test_pair = (string * int32)[@@deriving repr] 18 | include struct let test_pair_t = Repr.pair Repr.string Repr.int32 end 19 | [@@ocaml.doc "@inline"][@@merlin.hide ] 20 | type test_triple = (string * int32 * bool)[@@deriving repr] 21 | include 22 | struct let test_triple_t = Repr.triple Repr.string Repr.int32 Repr.bool end 23 | [@@ocaml.doc "@inline"][@@merlin.hide ] 24 | type test_result = (int32, string) result[@@deriving repr] 25 | include struct let test_result_t = Repr.result Repr.int32 Repr.string end 26 | [@@ocaml.doc "@inline"][@@merlin.hide ] 27 | let (_ : test_list1 Repr.t) = test_list1_t 28 | let (_ : test_list2 Repr.t) = test_list2_t 29 | let (_ : test_array Repr.t) = test_array_t 30 | let (_ : test_option Repr.t) = test_option_t 31 | let (_ : test_pair Repr.t) = test_pair_t 32 | let (_ : test_triple Repr.t) = test_triple_t 33 | let (_ : test_result Repr.t) = test_result_t 34 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/composite.ml: -------------------------------------------------------------------------------- 1 | (* Tests of the composite type combinators *) 2 | type test_list1 = string list [@@deriving repr] 3 | type test_list2 = int32 list list list [@@deriving repr] 4 | type test_array = bool array [@@deriving repr] 5 | type test_option = unit option [@@deriving repr] 6 | type test_pair = string * int32 [@@deriving repr] 7 | type test_triple = string * int32 * bool [@@deriving repr] 8 | type test_result = (int32, string) result [@@deriving repr] 9 | 10 | let (_ : test_list1 Repr.t) = test_list1_t 11 | let (_ : test_list2 Repr.t) = test_list2_t 12 | let (_ : test_array Repr.t) = test_array_t 13 | let (_ : test_option Repr.t) = test_option_t 14 | let (_ : test_pair Repr.t) = test_pair_t 15 | let (_ : test_triple Repr.t) = test_triple_t 16 | let (_ : test_result Repr.t) = test_result_t 17 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name pp) 3 | (modules pp) 4 | (libraries ppx_repr ppxlib)) 5 | 6 | (include dune.inc) 7 | 8 | (rule 9 | (targets dune.inc.gen) 10 | (deps 11 | (source_tree .)) 12 | (action 13 | (with-stdout-to 14 | %{targets} 15 | (run ../gen_dune_rules.exe)))) 16 | 17 | (rule 18 | (alias runtest) 19 | (package ppx_repr) 20 | (action 21 | (diff dune.inc dune.inc.gen))) 22 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/extension.expected: -------------------------------------------------------------------------------- 1 | type 'a typ = 'a Repr.t 2 | module Simple = 3 | struct 4 | let (_ : (int * string) list typ) = 5 | Repr.list (Repr.pair Repr.int Repr.string) 6 | end 7 | module Alias = 8 | struct type t = unit 9 | let t = Repr.unit 10 | let (_ : unit typ) = t end 11 | module Sum = 12 | struct 13 | let (_ : [ `Foo | `Bar of string ] typ) = 14 | Repr.sealv 15 | (Repr.(|~) 16 | (Repr.(|~) 17 | (Repr.variant "t" 18 | (fun foo -> 19 | fun bar -> function | `Foo -> foo | `Bar x1 -> bar x1)) 20 | (Repr.case0 "Foo" `Foo)) 21 | (Repr.case1 "Bar" Repr.string (fun x1 -> `Bar x1))) 22 | end 23 | module Params = 24 | struct 25 | let __ : type a. a typ -> a list typ = fun a -> Repr.list a 26 | let __ : type a b. a typ -> b typ -> (a * b * a) typ = 27 | fun a -> fun _x__001_ -> Repr.triple a _x__001_ a 28 | let __ : type a b. a typ -> b typ -> (a, b) result typ = 29 | fun _x__002_ -> fun _x__003_ -> Repr.result _x__002_ _x__003_ 30 | end 31 | module Namespace = struct let (_ : string typ) = Repr.string end 32 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/extension.ml: -------------------------------------------------------------------------------- 1 | type 'a typ = 'a Repr.t 2 | 3 | module Simple = struct 4 | let (_ : (int * string) list typ) = [%typ: (int * string) list] 5 | end 6 | 7 | module Alias = struct 8 | type t = unit 9 | 10 | let t = Repr.unit 11 | let (_ : unit typ) = [%typ: t] 12 | end 13 | 14 | module Sum = struct 15 | let (_ : [ `Foo | `Bar of string ] typ) = [%typ: [ `Foo | `Bar of string ]] 16 | end 17 | 18 | module Params = struct 19 | let __ : type a. a typ -> a list typ = [%typ: 'a list] 20 | let __ : type a b. a typ -> b typ -> (a * b * a) typ = [%typ: 'a * _ * 'a] 21 | let __ : type a b. a typ -> b typ -> (a, b) result typ = [%typ: (_, _) result] 22 | end 23 | 24 | module Namespace = struct 25 | let (_ : string typ) = [%repr.typ: string] 26 | end 27 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/json_module.expected: -------------------------------------------------------------------------------- 1 | module Json = struct type t = string 2 | let t = Repr.string end 3 | type foo = { 4 | contents: Json.t }[@@deriving repr] 5 | include 6 | struct 7 | let foo_t = 8 | Repr.sealr 9 | (Repr.(|+) (Repr.record "foo" (fun contents -> { contents })) 10 | (Repr.field "contents" Json.t (fun t -> t.contents))) 11 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 12 | let (_ : foo Repr.t) = foo_t 13 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/json_module.ml: -------------------------------------------------------------------------------- 1 | (* Ensure that the [Json] module in [Repr] doesn't shadow references to 2 | types contained in a different [Json] module. 3 | 4 | Regression test for https://github.com/mirage/irmin/issues/923. *) 5 | 6 | module Json = struct 7 | type t = string 8 | 9 | let t = Repr.string 10 | end 11 | 12 | type foo = { contents : Json.t } [@@deriving repr] 13 | 14 | let (_ : foo Repr.t) = foo_t 15 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/lib_relocated.expected: -------------------------------------------------------------------------------- 1 | module Elsewhere : 2 | sig 3 | module Foo : module type of Repr 4 | type t[@@deriving repr { lib = (Some "Foo") }] 5 | include sig val t : t Foo.t end[@@ocaml.doc "@inline"][@@merlin.hide ] 6 | end = 7 | struct 8 | module Foo = Repr 9 | module Irmin = struct end 10 | type t = (unit * unit)[@@deriving repr { lib = (Some "Foo") }] 11 | include struct let t = Foo.pair Foo.unit Foo.unit end[@@ocaml.doc 12 | "@inline"] 13 | [@@merlin.hide ] 14 | end 15 | module Locally_avaliable : 16 | sig 17 | type 'a ty 18 | type t[@@deriving repr { lib = None }] 19 | include sig val t : t ty end[@@ocaml.doc "@inline"][@@merlin.hide ] 20 | end = 21 | struct 22 | let (pair, unit) = let open Repr in (pair, unit) 23 | type 'a ty = 'a Repr.ty 24 | module Irmin = struct end 25 | type t = (unit * unit)[@@deriving repr { lib = None }] 26 | include struct let t = pair unit unit end[@@ocaml.doc "@inline"][@@merlin.hide 27 | ] 28 | end 29 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/lib_relocated.ml: -------------------------------------------------------------------------------- 1 | module Elsewhere : sig 2 | module Foo : module type of Repr 3 | 4 | type t [@@deriving repr { lib = Some "Foo" }] 5 | end = struct 6 | module Foo = Repr 7 | module Irmin = struct end 8 | 9 | type t = unit * unit [@@deriving repr { lib = Some "Foo" }] 10 | end 11 | 12 | module Locally_avaliable : sig 13 | type 'a ty 14 | type t [@@deriving repr { lib = None }] 15 | end = struct 16 | let pair, unit = Repr.(pair, unit) 17 | 18 | type 'a ty = 'a Repr.ty 19 | 20 | module Irmin = struct end 21 | 22 | type t = unit * unit [@@deriving repr { lib = None }] 23 | end 24 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/meta_deriving.expected: -------------------------------------------------------------------------------- 1 | module T0 : 2 | sig 3 | type nonrec t = int 4 | and other = string[@@deriving 5 | repr ~equal ~compare ~pp ~pp_dump ~size_of 6 | ~to_bin_string ~of_bin_string ~encode_bin 7 | ~decode_bin] 8 | include 9 | sig 10 | val t : t Repr.t 11 | val equal : t -> t -> bool 12 | val compare : t -> t -> int 13 | val size_of : t -> int option 14 | val pp : Stdlib.Format.formatter -> t -> unit 15 | val pp_dump : Stdlib.Format.formatter -> t -> unit 16 | val to_bin_string : t -> string 17 | val of_bin_string : string -> (t, [ `Msg of string ]) Stdlib.result 18 | val encode_bin : t -> (string -> unit) -> unit 19 | val decode_bin : string -> int ref -> t 20 | val other_t : other Repr.t 21 | val equal_other : other -> other -> bool 22 | val compare_other : other -> other -> int 23 | val size_of_other : other -> int option 24 | val pp_other : Stdlib.Format.formatter -> other -> unit 25 | val pp_dump_other : Stdlib.Format.formatter -> other -> unit 26 | val other_to_bin_string : other -> string 27 | val other_of_bin_string : 28 | string -> (other, [ `Msg of string ]) Stdlib.result 29 | val encode_bin_other : other -> (string -> unit) -> unit 30 | val decode_bin_other : string -> int ref -> other 31 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 32 | end = 33 | struct 34 | type nonrec t = int 35 | and other = string[@@deriving 36 | repr ~equal ~compare ~pp ~pp_dump ~size_of 37 | ~to_bin_string ~of_bin_string ~encode_bin 38 | ~decode_bin] 39 | include 40 | struct 41 | let (t, other_t) = (Repr.int, Repr.string) 42 | let equal = Repr.unstage (Repr.equal Repr.int) 43 | let compare = Repr.unstage (Repr.compare Repr.int) 44 | let size_of = Repr.unstage (Repr.size_of Repr.int) 45 | let pp = Repr.pp Repr.int 46 | let pp_dump = Repr.pp_dump Repr.int 47 | let to_bin_string = Repr.unstage (Repr.to_bin_string Repr.int) 48 | let of_bin_string = Repr.unstage (Repr.of_bin_string Repr.int) 49 | let encode_bin = Repr.unstage (Repr.encode_bin Repr.int) 50 | let decode_bin = Repr.unstage (Repr.decode_bin Repr.int) 51 | let equal_other = Repr.unstage (Repr.equal Repr.string) 52 | let compare_other = Repr.unstage (Repr.compare Repr.string) 53 | let size_of_other = Repr.unstage (Repr.size_of Repr.string) 54 | let pp_other = Repr.pp Repr.string 55 | let pp_dump_other = Repr.pp_dump Repr.string 56 | let other_to_bin_string = 57 | Repr.unstage (Repr.to_bin_string Repr.string) 58 | let other_of_bin_string = 59 | Repr.unstage (Repr.of_bin_string Repr.string) 60 | let encode_bin_other = Repr.unstage (Repr.encode_bin Repr.string) 61 | let decode_bin_other = Repr.unstage (Repr.decode_bin Repr.string) 62 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 63 | end 64 | module T1 : 65 | sig 66 | type 'a t = 'a list[@@deriving repr ~equal] 67 | include 68 | sig 69 | val t : 'a Repr.t -> 'a t Repr.t 70 | val equal : 'a Repr.t -> 'a t -> 'a t -> bool 71 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 72 | end = 73 | struct 74 | type 'a t = 'a list[@@deriving repr ~equal] 75 | include 76 | struct 77 | let t a = Repr.list a 78 | let equal a = Repr.unstage (Repr.equal (Repr.list a)) 79 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 80 | end 81 | module T2 : 82 | sig 83 | type ('a, 'b) t = ('a * 'b) list[@@deriving repr ~equal] 84 | include 85 | sig 86 | val t : 'a Repr.t -> 'b Repr.t -> ('a, 'b) t Repr.t 87 | val equal : 88 | 'a Repr.t -> 'b Repr.t -> ('a, 'b) t -> ('a, 'b) t -> bool 89 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 90 | end = 91 | struct 92 | type ('a, 'b) t = ('a * 'b) list[@@deriving repr ~equal] 93 | include 94 | struct 95 | let t a b = Repr.list (Repr.pair a b) 96 | let equal a b = Repr.unstage (Repr.equal (Repr.list (Repr.pair a b))) 97 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 98 | end 99 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/meta_deriving.ml: -------------------------------------------------------------------------------- 1 | module T0 : sig 2 | type nonrec t = int 3 | 4 | and other = string 5 | [@@deriving 6 | repr ~equal ~compare ~pp ~pp_dump ~size_of ~to_bin_string ~of_bin_string 7 | ~encode_bin ~decode_bin] 8 | end = struct 9 | type nonrec t = int 10 | 11 | and other = string 12 | [@@deriving 13 | repr ~equal ~compare ~pp ~pp_dump ~size_of ~to_bin_string ~of_bin_string 14 | ~encode_bin ~decode_bin] 15 | end 16 | 17 | module T1 : sig 18 | type 'a t = 'a list [@@deriving repr ~equal] 19 | end = struct 20 | type 'a t = 'a list [@@deriving repr ~equal] 21 | end 22 | 23 | module T2 : sig 24 | type ('a, 'b) t = ('a * 'b) list [@@deriving repr ~equal] 25 | end = struct 26 | type ('a, 'b) t = ('a * 'b) list [@@deriving repr ~equal] 27 | end 28 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/module.expected: -------------------------------------------------------------------------------- 1 | module ModuleQualifiedTypes = 2 | struct 3 | module X = 4 | struct 5 | type t = int[@@deriving repr] 6 | include struct let t = Repr.int end[@@ocaml.doc "@inline"][@@merlin.hide 7 | ] 8 | end 9 | module Y = 10 | struct 11 | type foo = X.t list[@@deriving repr] 12 | include struct let foo_t = Repr.list X.t end[@@ocaml.doc "@inline"] 13 | [@@merlin.hide ] 14 | end 15 | type t = X.t[@@deriving repr] 16 | include struct let t = X.t end[@@ocaml.doc "@inline"][@@merlin.hide ] 17 | type t_result = (X.t, unit) result[@@deriving repr] 18 | include struct let t_result_t = Repr.result X.t Repr.unit end[@@ocaml.doc 19 | "@inline"] 20 | [@@merlin.hide ] 21 | type foo = Y.foo[@@deriving repr] 22 | include struct let foo_t = Y.foo_t end[@@ocaml.doc "@inline"][@@merlin.hide 23 | ] 24 | type foo_list = Y.foo list[@@deriving repr] 25 | include struct let foo_list_t = Repr.list Y.foo_t end[@@ocaml.doc 26 | "@inline"] 27 | [@@merlin.hide ] 28 | end 29 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/module.ml: -------------------------------------------------------------------------------- 1 | (* Types within modules *) 2 | module ModuleQualifiedTypes = struct 3 | module X = struct 4 | type t = int [@@deriving repr] 5 | end 6 | 7 | module Y = struct 8 | type foo = X.t list [@@deriving repr] 9 | end 10 | 11 | type t = X.t [@@deriving repr] 12 | type t_result = (X.t, unit) result [@@deriving repr] 13 | type foo = Y.foo [@@deriving repr] 14 | type foo_list = Y.foo list [@@deriving repr] 15 | end 16 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/nobuiltin.expected: -------------------------------------------------------------------------------- 1 | type unit = string[@@deriving repr] 2 | include struct let unit_t = Repr.string end[@@ocaml.doc "@inline"][@@merlin.hide 3 | ] 4 | module Nobuiltin_t = 5 | struct 6 | type t = ((unit)[@nobuiltin ])[@@deriving repr] 7 | include struct let t = unit_t end[@@ocaml.doc "@inline"][@@merlin.hide ] 8 | let (_ : string Repr.t) = t 9 | end 10 | module Nobuiltin_foo = 11 | struct 12 | type foo = ((unit)[@repr.nobuiltin ])[@@deriving repr] 13 | include struct let foo_t = unit_t end[@@ocaml.doc "@inline"][@@merlin.hide 14 | ] 15 | let (_ : string Repr.t) = foo_t 16 | end 17 | module Nobuiltin_operator = 18 | struct 19 | let result_t a b = Repr.pair a b 20 | let int32_t = Repr.int 21 | let int64_t = Repr.bool 22 | type u = (((((int32)[@nobuiltin ]), int64) result)[@nobuiltin ])[@@deriving 23 | repr] 24 | include struct let u_t = result_t int32_t Repr.int64 end[@@ocaml.doc 25 | "@inline"] 26 | [@@merlin.hide ] 27 | let (_ : (int * int64) Repr.t) = u_t 28 | end 29 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/nobuiltin.ml: -------------------------------------------------------------------------------- 1 | (* When a type is annotated with the [nobuiltin] annotation, it should be 2 | considered as an abstract type (i.e. don't pull representations from 3 | [Repr]). *) 4 | 5 | type unit = string [@@deriving repr] 6 | 7 | (* Shadow [Stdlib.unit] *) 8 | module Nobuiltin_t = struct 9 | type t = (unit[@nobuiltin]) [@@deriving repr] 10 | 11 | (* [t]'s repr should be for strings. *) 12 | let (_ : string Repr.t) = t 13 | end 14 | 15 | module Nobuiltin_foo = struct 16 | type foo = (unit[@repr.nobuiltin]) [@@deriving repr] 17 | 18 | (* [foo]'s repr should be for strings too. *) 19 | let (_ : string Repr.t) = foo_t 20 | end 21 | 22 | module Nobuiltin_operator = struct 23 | (* Define our own representation of [result]. *) 24 | let result_t a b = Repr.pair a b 25 | let int32_t = Repr.int 26 | let int64_t = Repr.bool 27 | 28 | type u = (((int32[@nobuiltin]), int64) result[@nobuiltin]) [@@deriving repr] 29 | 30 | let (_ : (int * int64) Repr.t) = u_t 31 | end 32 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/nonrec.expected: -------------------------------------------------------------------------------- 1 | type t = unit[@@deriving repr] 2 | include struct let t = Repr.unit end[@@ocaml.doc "@inline"][@@merlin.hide ] 3 | type t_alias = unit[@@deriving repr] 4 | include struct let t_alias_t = Repr.unit end[@@ocaml.doc "@inline"][@@merlin.hide 5 | ] 6 | module S1 : 7 | sig 8 | type nonrec t = t list[@@deriving repr] 9 | include sig val t : t Repr.t end[@@ocaml.doc "@inline"][@@merlin.hide ] 10 | type nonrec t_alias = t_alias list[@@deriving repr] 11 | include sig val t_alias_t : t_alias Repr.t end[@@ocaml.doc "@inline"] 12 | [@@merlin.hide ] 13 | end = 14 | struct 15 | type nonrec t = t list[@@deriving repr] 16 | include struct let t = Repr.list t end[@@ocaml.doc "@inline"][@@merlin.hide 17 | ] 18 | type nonrec t_alias = t_alias list[@@deriving repr] 19 | include struct let t_alias_t = Repr.list t_alias_t end[@@ocaml.doc 20 | "@inline"] 21 | [@@merlin.hide ] 22 | end 23 | module S2 : 24 | sig 25 | type nonrec t = t list[@@deriving repr { name = "t_repr" }] 26 | include sig val t_repr : t Repr.t end[@@ocaml.doc "@inline"][@@merlin.hide 27 | ] 28 | type nonrec t_alias = t_alias list[@@deriving repr { name = "t_repr" }] 29 | include sig val t_repr : t_alias Repr.t end[@@ocaml.doc "@inline"] 30 | [@@merlin.hide ] 31 | end = 32 | struct 33 | type nonrec t = t list[@@deriving repr { name = "t_repr" }] 34 | include struct let t_repr = Repr.list t end[@@ocaml.doc "@inline"] 35 | [@@merlin.hide ] 36 | type nonrec t_alias = t_alias list[@@deriving repr { name = "t_repr" }] 37 | include struct let t_repr = Repr.list t_alias_t end[@@ocaml.doc 38 | "@inline"][@@merlin.hide 39 | ] 40 | end 41 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/nonrec.ml: -------------------------------------------------------------------------------- 1 | type t = unit [@@deriving repr] 2 | type t_alias = unit [@@deriving repr] 3 | 4 | (* Ensure that 'nonrec' assertions are respected *) 5 | module S1 : sig 6 | type nonrec t = t list [@@deriving repr] 7 | type nonrec t_alias = t_alias list [@@deriving repr] 8 | end = struct 9 | type nonrec t = t list [@@deriving repr] 10 | type nonrec t_alias = t_alias list [@@deriving repr] 11 | end 12 | 13 | (* Now test the interaction of 'nonrec' with custom naming *) 14 | module S2 : sig 15 | type nonrec t = t list [@@deriving repr { name = "t_repr" }] 16 | type nonrec t_alias = t_alias list [@@deriving repr { name = "t_repr" }] 17 | end = struct 18 | type nonrec t = t list [@@deriving repr { name = "t_repr" }] 19 | type nonrec t_alias = t_alias list [@@deriving repr { name = "t_repr" }] 20 | end 21 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/polyvariant.expected: -------------------------------------------------------------------------------- 1 | type test_polyvar1 = [ `On of int | `Off ][@@deriving repr] 2 | include 3 | struct 4 | let test_polyvar1_t = 5 | Repr.sealv 6 | (Repr.(|~) 7 | (Repr.(|~) 8 | (Repr.variant "test_polyvar1" 9 | (fun on -> 10 | fun off -> function | `On x1 -> on x1 | `Off -> off)) 11 | (Repr.case1 "On" Repr.int (fun x1 -> `On x1))) 12 | (Repr.case0 "Off" `Off)) 13 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 14 | type test_polyvar2 = 15 | [ `Outer_a of [ `Inner_a | `Inner_b ] | `Outer_b of [ `Inner_a ] 16 | | `Outer_c of [ `Inner_a of string | `Inner_c of int ] ][@@deriving repr] 17 | include 18 | struct 19 | let test_polyvar2_t = 20 | Repr.sealv 21 | (Repr.(|~) 22 | (Repr.(|~) 23 | (Repr.(|~) 24 | (Repr.variant "test_polyvar2" 25 | (fun outer_a -> 26 | fun outer_b -> 27 | fun outer_c -> 28 | function 29 | | `Outer_a x1 -> outer_a x1 30 | | `Outer_b x1 -> outer_b x1 31 | | `Outer_c x1 -> outer_c x1)) 32 | (Repr.case1 "Outer_a" 33 | (Repr.sealv 34 | (Repr.(|~) 35 | (Repr.(|~) 36 | (Repr.variant "test_polyvar2" 37 | (fun inner_a -> 38 | fun inner_b -> 39 | function 40 | | `Inner_a -> inner_a 41 | | `Inner_b -> inner_b)) 42 | (Repr.case0 "Inner_a" `Inner_a)) 43 | (Repr.case0 "Inner_b" `Inner_b))) 44 | (fun x1 -> `Outer_a x1))) 45 | (Repr.case1 "Outer_b" 46 | (Repr.sealv 47 | (Repr.(|~) 48 | (Repr.variant "test_polyvar2" 49 | (fun inner_a -> function | `Inner_a -> inner_a)) 50 | (Repr.case0 "Inner_a" `Inner_a))) 51 | (fun x1 -> `Outer_b x1))) 52 | (Repr.case1 "Outer_c" 53 | (Repr.sealv 54 | (Repr.(|~) 55 | (Repr.(|~) 56 | (Repr.variant "test_polyvar2" 57 | (fun inner_a -> 58 | fun inner_c -> 59 | function 60 | | `Inner_a x1 -> inner_a x1 61 | | `Inner_c x1 -> inner_c x1)) 62 | (Repr.case1 "Inner_a" Repr.string 63 | (fun x1 -> `Inner_a x1))) 64 | (Repr.case1 "Inner_c" Repr.int (fun x1 -> `Inner_c x1)))) 65 | (fun x1 -> `Outer_c x1))) 66 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 67 | type test_polyvar3 = 68 | [ `Branch of (test_polyvar3 * test_polyvar3) | `Leaf of string ][@@deriving 69 | repr] 70 | include 71 | struct 72 | let test_polyvar3_t = 73 | Repr.mu 74 | (fun test_polyvar3_t -> 75 | Repr.sealv 76 | (Repr.(|~) 77 | (Repr.(|~) 78 | (Repr.variant "test_polyvar3" 79 | (fun branch -> 80 | fun leaf -> 81 | function 82 | | `Branch x1 -> branch x1 83 | | `Leaf x1 -> leaf x1)) 84 | (Repr.case1 "Branch" 85 | (Repr.pair test_polyvar3_t test_polyvar3_t) 86 | (fun x1 -> `Branch x1))) 87 | (Repr.case1 "Leaf" Repr.string (fun x1 -> `Leaf x1)))) 88 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 89 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/polyvariant.ml: -------------------------------------------------------------------------------- 1 | (* Polymorphic variants *) 2 | type test_polyvar1 = [ `On of int | `Off ] [@@deriving repr] 3 | 4 | type test_polyvar2 = 5 | [ `Outer_a of [ `Inner_a | `Inner_b ] 6 | | `Outer_b of [ `Inner_a ] 7 | | `Outer_c of [ `Inner_a of string | `Inner_c of int ] ] 8 | [@@deriving repr] 9 | 10 | type test_polyvar3 = 11 | [ `Branch of test_polyvar3 * test_polyvar3 | `Leaf of string ] 12 | [@@deriving repr] 13 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/pp.ml: -------------------------------------------------------------------------------- 1 | let () = Ppxlib.Driver.standalone () 2 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/record.expected: -------------------------------------------------------------------------------- 1 | type test_record1 = { 2 | alpha: string ; 3 | beta: int64 list ; 4 | gamma: unit }[@@deriving repr] 5 | include 6 | struct 7 | let test_record1_t = 8 | Repr.sealr 9 | (Repr.(|+) 10 | (Repr.(|+) 11 | (Repr.(|+) 12 | (Repr.record "test_record1" 13 | (fun alpha -> 14 | fun beta -> fun gamma -> { alpha; beta; gamma })) 15 | (Repr.field "alpha" Repr.string (fun t -> t.alpha))) 16 | (Repr.field "beta" (Repr.list Repr.int64) (fun t -> t.beta))) 17 | (Repr.field "gamma" Repr.unit (fun t -> t.gamma))) 18 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 19 | type test_record2 = 20 | { 21 | the_FIRST_identifier: test_record1 option ; 22 | the_SECOND_identifier: (string, int32) result list }[@@deriving repr] 23 | include 24 | struct 25 | let test_record2_t = 26 | Repr.sealr 27 | (Repr.(|+) 28 | (Repr.(|+) 29 | (Repr.record "test_record2" 30 | (fun the_FIRST_identifier -> 31 | fun the_SECOND_identifier -> 32 | { the_FIRST_identifier; the_SECOND_identifier })) 33 | (Repr.field "the_FIRST_identifier" (Repr.option test_record1_t) 34 | (fun t -> t.the_FIRST_identifier))) 35 | (Repr.field "the_SECOND_identifier" 36 | (Repr.list (Repr.result Repr.string Repr.int32)) 37 | (fun t -> t.the_SECOND_identifier))) 38 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 39 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/record.ml: -------------------------------------------------------------------------------- 1 | (* Records *) 2 | type test_record1 = { alpha : string; beta : int64 list; gamma : unit } 3 | [@@deriving repr] 4 | 5 | type test_record2 = { 6 | the_FIRST_identifier : test_record1 option; 7 | the_SECOND_identifier : (string, int32) result list; 8 | } 9 | [@@deriving repr] 10 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/recursive.expected: -------------------------------------------------------------------------------- 1 | module Non_recursive_group : 2 | sig 3 | type nonrec t0 4 | and t1 5 | and t2[@@deriving repr] 6 | include 7 | sig val t0_t : t0 Repr.t val t1_t : t1 Repr.t val t2_t : t2 Repr.t end 8 | [@@ocaml.doc "@inline"][@@merlin.hide ] 9 | end = 10 | struct 11 | type nonrec t0 = unit 12 | and t1 = unit 13 | and t2 = unit[@@deriving repr] 14 | include 15 | struct 16 | let (t0_t, (t1_t, t2_t)) = (Repr.unit, (Repr.unit, Repr.unit)) 17 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 18 | end 19 | module Recursive_group : 20 | sig 21 | type even 22 | and odd[@@deriving repr] 23 | include sig val even_t : even Repr.t val odd_t : odd Repr.t end[@@ocaml.doc 24 | "@inline"] 25 | [@@merlin.hide ] 26 | end = 27 | struct 28 | type odd = 29 | | Odd of even option 30 | and even = 31 | | Even of odd option [@@deriving repr] 32 | include 33 | struct 34 | let (odd_t, even_t) = 35 | Repr.mu2 36 | (fun odd_t -> 37 | fun even_t -> 38 | ((Repr.sealv 39 | (Repr.(|~) 40 | (Repr.variant "odd" 41 | (fun odd -> function | Odd x1 -> odd x1)) 42 | (Repr.case1 "Odd" (Repr.option even_t) 43 | (fun x1 -> Odd x1)))), 44 | (Repr.sealv 45 | (Repr.(|~) 46 | (Repr.variant "even" 47 | (fun even -> function | Even x1 -> even x1)) 48 | (Repr.case1 "Even" (Repr.option odd_t) 49 | (fun x1 -> Even x1)))))) 50 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 51 | end 52 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/recursive.ml: -------------------------------------------------------------------------------- 1 | (* Non-recursive group of type declarations: *) 2 | 3 | module Non_recursive_group : sig 4 | type nonrec t0 5 | and t1 6 | and t2 [@@deriving repr] 7 | end = struct 8 | type nonrec t0 = unit 9 | and t1 = unit 10 | and t2 = unit [@@deriving repr] 11 | end 12 | 13 | module Recursive_group : sig 14 | type even 15 | and odd [@@deriving repr] 16 | end = struct 17 | type odd = Odd of even option 18 | and even = Even of odd option [@@deriving repr] 19 | end 20 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/signature.expected: -------------------------------------------------------------------------------- 1 | module SigTests : 2 | sig 3 | type t = string[@@deriving repr] 4 | include sig val t : t Repr.t end[@@ocaml.doc "@inline"][@@merlin.hide ] 5 | type foo = unit[@@deriving repr { name = "foo_repr" }] 6 | include sig val foo_repr : foo Repr.t end[@@ocaml.doc "@inline"][@@merlin.hide 7 | ] 8 | type my_int = (int32 * t)[@@deriving repr] 9 | include sig val my_int_t : my_int Repr.t end[@@ocaml.doc "@inline"] 10 | [@@merlin.hide ] 11 | type my_variant = 12 | | A of (my_int, int) result 13 | | B of unit 14 | | C of string * int32 [@@deriving repr] 15 | include sig val my_variant_t : my_variant Repr.t end[@@ocaml.doc 16 | "@inline"][@@merlin.hide 17 | ] 18 | end = 19 | struct 20 | type t = string[@@deriving repr] 21 | include struct let t = Repr.string end[@@ocaml.doc "@inline"][@@merlin.hide 22 | ] 23 | type foo = unit[@@deriving repr { name = "foo_repr" }] 24 | include struct let foo_repr = Repr.unit end[@@ocaml.doc "@inline"] 25 | [@@merlin.hide ] 26 | type my_int = (int32 * t)[@@deriving repr] 27 | include struct let my_int_t = Repr.pair Repr.int32 t end[@@ocaml.doc 28 | "@inline"] 29 | [@@merlin.hide ] 30 | type my_variant = 31 | | A of (my_int, int) result 32 | | B of unit 33 | | C of string * int32 [@@deriving repr] 34 | include 35 | struct 36 | let my_variant_t = 37 | Repr.sealv 38 | (Repr.(|~) 39 | (Repr.(|~) 40 | (Repr.(|~) 41 | (Repr.variant "my_variant" 42 | (fun a -> 43 | fun b -> 44 | fun c -> 45 | function 46 | | A x1 -> a x1 47 | | B x1 -> b x1 48 | | C (x1, x2) -> c (x1, x2))) 49 | (Repr.case1 "A" (Repr.result my_int_t Repr.int) 50 | (fun x1 -> A x1))) 51 | (Repr.case1 "B" Repr.unit (fun x1 -> B x1))) 52 | (Repr.case1 "C" (Repr.pair Repr.string Repr.int32) 53 | (fun (x1, x2) -> C (x1, x2)))) 54 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 55 | end 56 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/signature.ml: -------------------------------------------------------------------------------- 1 | (* Tests of the signature deriver *) 2 | module SigTests : sig 3 | type t = string [@@deriving repr] 4 | type foo = unit [@@deriving repr { name = "foo_repr" }] 5 | type my_int = int32 * t [@@deriving repr] 6 | 7 | type my_variant = 8 | | A of (my_int, int) result 9 | | B of unit 10 | | C of string * int32 11 | [@@deriving repr] 12 | end = struct 13 | type t = string [@@deriving repr] 14 | type foo = unit [@@deriving repr { name = "foo_repr" }] 15 | type my_int = int32 * t [@@deriving repr] 16 | 17 | type my_variant = 18 | | A of (my_int, int) result 19 | | B of unit 20 | | C of string * int32 21 | [@@deriving repr] 22 | end 23 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/tuple_deep.expected: -------------------------------------------------------------------------------- 1 | type deep_tuple = 2 | ((((int32 * int32) * int32 * int32) * int32 * int32) * int32 * int32) 3 | [@@deriving repr] 4 | include 5 | struct 6 | let deep_tuple_t = 7 | Repr.triple 8 | (Repr.triple 9 | (Repr.triple (Repr.pair Repr.int32 Repr.int32) Repr.int32 10 | Repr.int32) Repr.int32 Repr.int32) Repr.int32 Repr.int32 11 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 12 | let (_ : deep_tuple Repr.t) = deep_tuple_t 13 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/tuple_deep.ml: -------------------------------------------------------------------------------- 1 | (* Nested tuple type *) 2 | type deep_tuple = 3 | (((int32 * int32) * int32 * int32) * int32 * int32) * int32 * int32 4 | [@@deriving repr] 5 | 6 | let (_ : deep_tuple Repr.t) = deep_tuple_t 7 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/type_params.expected: -------------------------------------------------------------------------------- 1 | type 'a typ = 'a Repr.t 2 | module Id : 3 | sig 4 | type 'a t[@@deriving repr] 5 | include sig val t : 'a Repr.t -> 'a t Repr.t end[@@ocaml.doc "@inline"] 6 | [@@merlin.hide ] 7 | end = 8 | struct 9 | type 'a t = 'a[@@deriving repr] 10 | include struct let t a = a end[@@ocaml.doc "@inline"][@@merlin.hide ] 11 | end 12 | let __ : type a. a typ -> a Id.t typ = Id.t 13 | module Phantom : 14 | sig 15 | type _ t = int[@@deriving repr] 16 | include sig val t : 'a__001_ Repr.t -> 'a__001_ t Repr.t end[@@ocaml.doc 17 | "@inline"] 18 | [@@merlin.hide ] 19 | end = 20 | struct 21 | type _ t = int[@@deriving repr] 22 | include struct let t _ = Repr.int end[@@ocaml.doc "@inline"][@@merlin.hide 23 | ] 24 | end 25 | let __ : type a. a typ -> a Phantom.t typ = Phantom.t 26 | module Multiple : 27 | sig 28 | type ('a, 'b, 'c) t = { 29 | foo: 'a ; 30 | bar: 'b list ; 31 | baz: ('b * 'c) }[@@deriving repr] 32 | include 33 | sig 34 | val t : 'a Repr.t -> 'b Repr.t -> 'c Repr.t -> ('a, 'b, 'c) t Repr.t 35 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 36 | end = 37 | struct 38 | type ('a, 'b, 'c) t = { 39 | foo: 'a ; 40 | bar: 'b list ; 41 | baz: ('b * 'c) }[@@deriving repr] 42 | include 43 | struct 44 | let t a b c = 45 | Repr.sealr 46 | (Repr.(|+) 47 | (Repr.(|+) 48 | (Repr.(|+) 49 | (Repr.record "t" 50 | (fun foo -> fun bar -> fun baz -> { foo; bar; baz })) 51 | (Repr.field "foo" a (fun t -> t.foo))) 52 | (Repr.field "bar" (Repr.list b) (fun t -> t.bar))) 53 | (Repr.field "baz" (Repr.pair b c) (fun t -> t.baz))) 54 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 55 | end 56 | let __ : type a b c. a typ -> b typ -> c typ -> (a, b, c) Multiple.t typ = 57 | Multiple.t 58 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/type_params.ml: -------------------------------------------------------------------------------- 1 | type 'a typ = 'a Repr.t 2 | 3 | module Id : sig 4 | type 'a t [@@deriving repr] 5 | end = struct 6 | type 'a t = 'a [@@deriving repr] 7 | end 8 | 9 | let __ : type a. a typ -> a Id.t typ = Id.t 10 | 11 | module Phantom : sig 12 | type _ t = int [@@deriving repr] 13 | end = struct 14 | type _ t = int [@@deriving repr] 15 | end 16 | 17 | let __ : type a. a typ -> a Phantom.t typ = Phantom.t 18 | 19 | module Multiple : sig 20 | type ('a, 'b, 'c) t = { foo : 'a; bar : 'b list; baz : 'b * 'c } 21 | [@@deriving repr] 22 | end = struct 23 | type ('a, 'b, 'c) t = { foo : 'a; bar : 'b list; baz : 'b * 'c } 24 | [@@deriving repr] 25 | end 26 | 27 | let __ : type a b c. a typ -> b typ -> c typ -> (a, b, c) Multiple.t typ = 28 | Multiple.t 29 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/variant.expected: -------------------------------------------------------------------------------- 1 | type test_variant1 = 2 | | A [@@deriving repr] 3 | include 4 | struct 5 | let test_variant1_t = 6 | Repr.sealv 7 | (Repr.(|~) 8 | (Repr.variant "test_variant1" (fun a -> function | A -> a)) 9 | (Repr.case0 "A" A)) 10 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 11 | type test_variant2 = 12 | | A2 of int64 [@@deriving repr] 13 | include 14 | struct 15 | let test_variant2_t = 16 | Repr.sealv 17 | (Repr.(|~) 18 | (Repr.variant "test_variant2" 19 | (fun a2 -> function | A2 x1 -> a2 x1)) 20 | (Repr.case1 "A2" Repr.int64 (fun x1 -> A2 x1))) 21 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 22 | type test_variant3 = 23 | | A3 of string * test_variant2 [@@deriving repr] 24 | include 25 | struct 26 | let test_variant3_t = 27 | Repr.sealv 28 | (Repr.(|~) 29 | (Repr.variant "test_variant3" 30 | (fun a3 -> function | A3 (x1, x2) -> a3 (x1, x2))) 31 | (Repr.case1 "A3" (Repr.pair Repr.string test_variant2_t) 32 | (fun (x1, x2) -> A3 (x1, x2)))) 33 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 34 | type test_variant4 = 35 | | A4 36 | | B4 37 | | C4 [@@deriving repr] 38 | include 39 | struct 40 | let test_variant4_t = 41 | Repr.sealv 42 | (Repr.(|~) 43 | (Repr.(|~) 44 | (Repr.(|~) 45 | (Repr.variant "test_variant4" 46 | (fun a4 -> 47 | fun b4 -> 48 | fun c4 -> function | A4 -> a4 | B4 -> b4 | C4 -> c4)) 49 | (Repr.case0 "A4" A4)) (Repr.case0 "B4" B4)) 50 | (Repr.case0 "C4" C4)) 51 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 52 | type test_variant5 = 53 | | A5 54 | | B5 of string * test_variant4 55 | | C5 of int32 * string * unit [@@deriving repr] 56 | include 57 | struct 58 | let test_variant5_t = 59 | Repr.sealv 60 | (Repr.(|~) 61 | (Repr.(|~) 62 | (Repr.(|~) 63 | (Repr.variant "test_variant5" 64 | (fun a5 -> 65 | fun b5 -> 66 | fun c5 -> 67 | function 68 | | A5 -> a5 69 | | B5 (x1, x2) -> b5 (x1, x2) 70 | | C5 (x1, x2, x3) -> c5 (x1, x2, x3))) 71 | (Repr.case0 "A5" A5)) 72 | (Repr.case1 "B5" (Repr.pair Repr.string test_variant4_t) 73 | (fun (x1, x2) -> B5 (x1, x2)))) 74 | (Repr.case1 "C5" (Repr.triple Repr.int32 Repr.string Repr.unit) 75 | (fun (x1, x2, x3) -> C5 (x1, x2, x3)))) 76 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 77 | type test_variant6 = 78 | | Nil 79 | | Cons of string * test_variant6 [@@deriving repr] 80 | include 81 | struct 82 | let test_variant6_t = 83 | Repr.mu 84 | (fun test_variant6_t -> 85 | Repr.sealv 86 | (Repr.(|~) 87 | (Repr.(|~) 88 | (Repr.variant "test_variant6" 89 | (fun nil -> 90 | fun cons -> 91 | function 92 | | Nil -> nil 93 | | Cons (x1, x2) -> cons (x1, x2))) 94 | (Repr.case0 "Nil" Nil)) 95 | (Repr.case1 "Cons" (Repr.pair Repr.string test_variant6_t) 96 | (fun (x1, x2) -> Cons (x1, x2))))) 97 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 98 | -------------------------------------------------------------------------------- /test/ppx_repr/deriver/passing/variant.ml: -------------------------------------------------------------------------------- 1 | (* Variants *) 2 | type test_variant1 = A [@@deriving repr] 3 | type test_variant2 = A2 of int64 [@@deriving repr] 4 | type test_variant3 = A3 of string * test_variant2 [@@deriving repr] 5 | type test_variant4 = A4 | B4 | C4 [@@deriving repr] 6 | 7 | type test_variant5 = 8 | | A5 9 | | B5 of string * test_variant4 10 | | C5 of int32 * string * unit 11 | [@@deriving repr] 12 | 13 | type test_variant6 = Nil | Cons of string * test_variant6 [@@deriving repr] 14 | -------------------------------------------------------------------------------- /test/repr/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name main) 3 | ; These tests cannot be associated with the [repr] package, as tempting as it 4 | ; seems. They depend on [ppx_repr] for convenience, which introduces a cyclic 5 | ; dependency since [ppx_repr] depends on [repr] in its [ppx_runtime_libraries] 6 | ; stanza. This cycle cannot be resolved by adding a [post] flag. 7 | ; See https://github.com/ocaml/opam/issues/4267. 8 | (package ppx_repr) 9 | (libraries alcotest repr hex optint) 10 | (preprocess 11 | (pps ppx_repr))) 12 | -------------------------------------------------------------------------------- /test/repr/import.ml: -------------------------------------------------------------------------------- 1 | module Alcotest = struct 2 | include Alcotest 3 | 4 | let gcheck ?pos typ msg a b = 5 | let equal = Repr.(unstage (equal typ)) in 6 | let pp = Repr.pp_dump typ in 7 | check ?pos (testable pp equal) msg a b 8 | 9 | let string = testable Fmt.Dump.string String.equal 10 | end 11 | -------------------------------------------------------------------------------- /test/repr/main.mli: -------------------------------------------------------------------------------- 1 | (* intentionally empty *) 2 | -------------------------------------------------------------------------------- /test/repr/test_pre_hash.ml: -------------------------------------------------------------------------------- 1 | let check_string_eq pos ~expected actual = 2 | Alcotest.(check ~pos string) "" expected actual 3 | 4 | let check_string_neq pos x y = Alcotest.(check ~pos (neg string)) "" x y 5 | 6 | let to_to_string : type a. (a -> (string -> unit) -> unit) -> a -> string = 7 | fun encoder -> 8 | let buf = Buffer.create 0 in 9 | fun x -> 10 | let append_string = Buffer.add_string buf in 11 | encoder x append_string; 12 | let result = Buffer.contents buf in 13 | Buffer.clear buf; 14 | result 15 | 16 | (* Test that an overridden [pre_hash] function nested inside a large type is 17 | used correctly. *) 18 | let test_nested_custom () = 19 | let module X = struct 20 | (* A type that stores its [pre_hash] directly: *) 21 | type custom = { pre_hash : string; ignored_data : int } [@@deriving repr] 22 | 23 | let custom_t = 24 | let pre_hash { pre_hash; _ } f = f pre_hash in 25 | Repr.like ~pre_hash custom_t 26 | 27 | type pair = custom * custom [@@deriving repr ~pre_hash] 28 | end in 29 | let pre_hash_pair = to_to_string X.pre_hash_pair in 30 | let input = 31 | ( { X.pre_hash = "a"; ignored_data = 0 }, 32 | { X.pre_hash = "b"; ignored_data = 0 } ) 33 | in 34 | (* Pre-hash of the pair is the concatenation of the precomputed component 35 | pre-hashes. *) 36 | check_string_eq __POS__ ~expected:"ab" (pre_hash_pair input) 37 | 38 | (* Tests that the pre-hashing function for a given representable type [t] is 39 | injective (i.e. that two non-equal values of type [t] always have non-equal 40 | pre-hashes). A non-injective pre-hash function would be subject to preimage 41 | attacks. *) 42 | let test_injective () = 43 | let module X = struct 44 | type string_pair = string * string [@@deriving repr ~pre_hash] 45 | end in 46 | (* Test that pair components are boxed: *) 47 | let () = 48 | let pre_hash = to_to_string X.pre_hash_string_pair in 49 | let x = pre_hash ("a", "b") in 50 | let y = pre_hash ("ab", "") in 51 | check_string_neq __POS__ x y 52 | in 53 | () 54 | 55 | let tests = 56 | [ 57 | ("nested custom", `Quick, test_nested_custom); 58 | ("injective", `Quick, test_injective); 59 | ] 60 | -------------------------------------------------------------------------------- /test/repr/test_pre_hash.mli: -------------------------------------------------------------------------------- 1 | val tests : unit Alcotest.test_case list 2 | -------------------------------------------------------------------------------- /test/repr/test_size_of.ml: -------------------------------------------------------------------------------- 1 | module T = Repr 2 | 3 | let encode_bin t = T.(unstage (encode_bin t)) 4 | 5 | let encode_bin typ v = 6 | let buffer = Buffer.create 0 in 7 | encode_bin typ v (Buffer.add_string buffer); 8 | Buffer.contents buffer 9 | 10 | let random_string len = String.init len (fun _ -> char_of_int (Random.int 256)) 11 | 12 | let check_unknown ~__POS__:pos typ = 13 | match T.Size.of_value typ with 14 | | Unknown -> () 15 | | Dynamic _ | Static _ -> 16 | Alcotest.failf ~pos 17 | "Expected type to have unknown size, but (Dynamic _ | Static _) was \ 18 | received." 19 | 20 | let check_static ~__POS__:pos typ expected v = 21 | match T.Size.of_value typ with 22 | | Unknown | Dynamic _ -> 23 | Alcotest.failf ~pos 24 | "Expected type to have static size %d, but (Unknown | Dynamic _) was \ 25 | received." 26 | expected 27 | | Static n -> ( 28 | Alcotest.(check ~pos int) "Expected static size" expected n; 29 | 30 | (* Check that the encoding actually occupies [n] bytes *) 31 | let actual_size = String.length (encode_bin typ v) in 32 | Alcotest.(check ~pos int) 33 | "Actual size must match static spec" expected actual_size; 34 | 35 | (* We require [∀ n. (of_value = Static n) ⇔ (of_encoding = Static n)] *) 36 | match T.Size.of_encoding typ with 37 | | Unknown | Dynamic _ -> 38 | Alcotest.failf ~pos 39 | "Type has a static [of_value] sizer, but a non-static \ 40 | [of_encoding] sizer." 41 | | Static n' -> 42 | Alcotest.(check ~pos int) "Reported static sizes must be equal" n n') 43 | 44 | let check_dynamic ~__POS__:pos typ expected v = 45 | Fmt.pr "Testing type: %a@." T.pp_ty typ; 46 | let unexpected fmt = 47 | Alcotest.failf ~pos 48 | ("Expected type to have dynamic size, but " ^^ fmt ^^ " was received.") 49 | in 50 | match T.Size.(of_value typ, of_encoding typ) with 51 | | Unknown, _ | _, Unknown -> unexpected "Unknown" 52 | | Static n, _ | _, Static n -> unexpected "Static %d" n 53 | | Dynamic encode, Dynamic decode -> 54 | Alcotest.(check ~pos int) "Expected dynamic size" expected (encode v); 55 | 56 | (* Check that the encoding actually occupies [n] bytes *) 57 | let encoding = encode_bin typ v in 58 | let actual_size = String.length encoding in 59 | Alcotest.(check ~pos int) 60 | "Actual size must match dynamic spec" expected actual_size; 61 | 62 | (* Check that the size is correctly recovered from the encoding, even after 63 | adding some random surrounding context. *) 64 | let left_pad = 1 in 65 | let right_pad = 0 in 66 | let wrapped_encoding = 67 | random_string left_pad ^ encoding ^ random_string right_pad 68 | in 69 | let recovered_length = decode wrapped_encoding left_pad in 70 | Fmt.epr "wrapped_encoding (left %d, right %d): %a@." left_pad right_pad 71 | Fmt.(Dump.list (fun ppf x -> Fmt.pf ppf "%d" x)) 72 | (String.to_seq wrapped_encoding |> List.of_seq |> List.map Char.code); 73 | Alcotest.(check ~pos int) 74 | "Recovered length must match dynamic spec" expected recovered_length 75 | 76 | let test_primitive () = 77 | check_static ~__POS__ T.unit 0 (); 78 | check_static ~__POS__ T.bool 1 true; 79 | check_static ~__POS__ T.char 1 ' '; 80 | check_static ~__POS__ T.int32 4 1l; 81 | check_static ~__POS__ T.int63 8 Optint.Int63.zero; 82 | check_static ~__POS__ T.int64 8 (-1L); 83 | check_static ~__POS__ T.float 8 Float.nan 84 | 85 | let test_int () = 86 | let test_cases = 87 | (* Test a range of integers that fit correctly on this platform *) 88 | [ 89 | (__POS__, 7); 90 | (__POS__, 14); 91 | (__POS__, 21); 92 | (__POS__, 28); 93 | (__POS__, 35); 94 | (__POS__, 42); 95 | (__POS__, 49); 96 | (__POS__, 56); 97 | ] 98 | |> List.filter (fun (_, i) -> i < Sys.int_size) 99 | |> List.map (fun (p, i) -> (p, 1 lsl i)) 100 | in 101 | ListLabels.iteri test_cases ~f:(fun i (pos, p) -> 102 | check_dynamic ~__POS__:pos T.int (i + 1) (p - 1); 103 | check_dynamic ~__POS__:pos T.int (i + 2) p) 104 | 105 | let test_container () = 106 | let module X = struct 107 | type two = bool * bool [@@deriving repr] 108 | type three = bool * bool * bool [@@deriving repr] 109 | 110 | let two = (true, true) 111 | let three = (true, true, true) 112 | let thirty = List.init 10 (fun _ -> three) 113 | let thirty_t = T.(list ~len:(`Fixed 10) three_t) 114 | end in 115 | let open X in 116 | check_static ~__POS__ two_t 2 two; 117 | check_static ~__POS__ three_t 3 three; 118 | check_static ~__POS__ thirty_t (3 * 10) thirty; 119 | check_static ~__POS__ [%typ: char * int32 * int64] (1 + 4 + 8) ('1', 4l, 8L); 120 | 121 | (* Option with statically sized elements *) 122 | check_dynamic ~__POS__ [%typ: bool option list] 123 | (1 + (2 + 1 + 2)) 124 | [ Some true; None; Some false ]; 125 | 126 | (* Option with dynamically sized elements *) 127 | check_dynamic ~__POS__ [%typ: int option list] 128 | (1 + (2 + 1 + 3 + 1 + 4)) 129 | [ Some 1; None; Some (1 lsl 7); None; Some (1 lsl 14) ] 130 | 131 | let test_variant () = 132 | let module X = struct 133 | type enum = A | B | C [@@deriving repr] 134 | type enum' = A | B of unit [@@deriving repr] 135 | type equal_size = A of bool | B of char [@@deriving repr] 136 | 137 | type mixed = Argless | Unit of unit | Char of char | Int of int 138 | [@@deriving repr] 139 | end in 140 | let open X in 141 | check_static ~__POS__ enum_t 1 A; 142 | check_static ~__POS__ enum'_t 1 (B ()); 143 | check_static ~__POS__ equal_size_t 2 (A true); 144 | check_static ~__POS__ [%typ: unit option] 1 None; 145 | 146 | check_dynamic ~__POS__ mixed_t 1 Argless 147 | 148 | let test_recursive () = 149 | let module X = struct 150 | type int_list = [] | ( :: ) of int * int_list [@@deriving repr] 151 | 152 | type int_tree = Leaf of int | Branch of int_tree * int_tree 153 | [@@deriving repr] 154 | 155 | type odd = S of even 156 | and even = Z | S' of odd [@@deriving repr] 157 | end in 158 | let open X in 159 | check_dynamic ~__POS__ int_list_t 1 []; 160 | check_dynamic ~__POS__ int_list_t 7 [ 1; 2; 3 ]; 161 | 162 | let leaf_size = 2 (* tag + short int *) in 163 | let branch_size = 1 (* tag, excluding subterms *) in 164 | check_dynamic ~__POS__ int_tree_t leaf_size (Leaf 0); 165 | check_dynamic ~__POS__ int_tree_t 166 | (branch_size + (2 * leaf_size)) 167 | (Branch (Leaf 1, Leaf 2)); 168 | check_dynamic ~__POS__ int_tree_t 169 | ((3 * branch_size) + (4 * leaf_size)) 170 | (Branch (Branch (Leaf 1, Leaf 2), Branch (Leaf 3, Leaf 4))); 171 | 172 | check_dynamic ~__POS__ even_t 1 Z; 173 | check_dynamic ~__POS__ odd_t 2 (S Z); 174 | check_dynamic ~__POS__ even_t 3 (S' (S Z)); 175 | check_dynamic ~__POS__ odd_t 4 (S (S' (S Z))); 176 | 177 | let faux_recursive_t = T.(mu (fun _ -> char)) in 178 | check_static ~__POS__ faux_recursive_t 1 'a' 179 | 180 | let test_unknown () = 181 | let module X = struct 182 | type opaque = Opaque [@@deriving repr] 183 | 184 | let opaque_t = 185 | let encode_bin = T.(unstage @@ encode_bin opaque_t) in 186 | let decode_bin = T.(unstage @@ decode_bin opaque_t) in 187 | let size_of = T.Size.custom_dynamic () in 188 | T.like ~bin:(encode_bin, decode_bin, size_of) opaque_t 189 | 190 | type int_list = Cons of int * int_list | Nil of opaque [@@deriving repr] 191 | end in 192 | let open X in 193 | check_unknown ~__POS__ opaque_t; 194 | check_unknown ~__POS__ int_list_t; 195 | () 196 | 197 | let tests = 198 | [ 199 | ("primitive", `Quick, test_primitive); 200 | ("int", `Quick, test_int); 201 | ("container", `Quick, test_container); 202 | ("variant", `Quick, test_variant); 203 | ("recursive", `Quick, test_recursive); 204 | ("unknown", `Quick, test_unknown); 205 | ] 206 | -------------------------------------------------------------------------------- /test/repr/test_size_of.mli: -------------------------------------------------------------------------------- 1 | val tests : unit Alcotest.test_case list 2 | --------------------------------------------------------------------------------