├── .github └── workflows │ └── workflow.yml ├── .gitignore ├── Changelog ├── LICENSE ├── Makefile ├── README.md ├── drivers ├── generic │ ├── dune │ ├── ppx_protocol_driver.ml │ └── ppx_protocol_driver.mli ├── json │ ├── bench │ │ ├── bench.ml │ │ └── dune │ ├── dune │ ├── json.ml │ ├── json.mli │ ├── test │ │ ├── dune │ │ ├── test_attrib.ml │ │ ├── unittest.expected │ │ └── unittest.ml │ ├── test_expect.ml │ └── test_expect.mli ├── jsonm │ ├── dune │ ├── jsonm.ml │ ├── jsonm.mli │ └── test │ │ ├── dune │ │ ├── unittest.expected │ │ └── unittest.ml ├── msgpack │ ├── dune │ ├── msgpack.ml │ ├── msgpack.mli │ └── test │ │ ├── dune │ │ ├── test_types.ml │ │ ├── unittest.expected │ │ └── unittest.ml ├── xml_light │ ├── dune │ ├── test │ │ ├── dune │ │ ├── unittest.expected │ │ └── unittest.ml │ ├── xml_light.ml │ └── xml_light.mli ├── xmlm │ ├── dune │ ├── test │ │ ├── dune │ │ ├── unittest.expected │ │ └── unittest.ml │ ├── xmlm.ml │ └── xmlm.mli └── yaml │ ├── dune │ ├── global │ ├── dune │ └── global.ml │ ├── test │ ├── dune │ ├── unittest.expected │ └── unittest.ml │ ├── yaml.ml │ └── yaml.mli ├── dune-project ├── ppx ├── dune ├── ppx_protocol_conv.ml ├── ppx_protocol_conv.mli └── test │ ├── dune │ ├── test_driver.ml │ ├── test_driver.mli │ ├── unittest.expected │ └── unittest.ml ├── ppx_protocol_conv.opam ├── ppx_protocol_conv_json.opam ├── ppx_protocol_conv_jsonm.opam ├── ppx_protocol_conv_msgpack.opam ├── ppx_protocol_conv_xml_light.opam ├── ppx_protocol_conv_xmlm.opam ├── ppx_protocol_conv_yaml.opam ├── runtime ├── dune └── runtime.ml ├── test ├── dune ├── error.ml ├── test_arrays.ml ├── test_arrays.mli ├── test_driver.ml ├── test_driver.mli ├── test_exceptions.ml ├── test_lists.ml ├── test_lists.mli ├── test_nonrec.ml ├── test_nonrec.mli ├── test_option_unit.ml ├── test_option_unit.mli ├── test_param_types.ml ├── test_param_types.mli ├── test_poly.ml ├── test_poly.mli ├── test_record.ml ├── test_record.mli ├── test_result.ml ├── test_sig.ml ├── test_sig.mli ├── test_types.ml ├── test_types.mli ├── test_unit.ml ├── test_unit.mli ├── test_variant.ml ├── test_variant.mli ├── testable.ml └── unittest.ml └── type.ml /.github/workflows/workflow.yml: -------------------------------------------------------------------------------- 1 | name: Main workflow 2 | 3 | on: 4 | - push 5 | - workflow_dispatch 6 | 7 | 8 | jobs: 9 | build: 10 | strategy: 11 | fail-fast: false 12 | matrix: 13 | os: 14 | - ubuntu-latest 15 | ocaml-compiler: 16 | - 4.08.x 17 | - 4 18 | - 5 19 | include: 20 | - ocaml-compiler: 4.08.x 21 | packages: 'ppx_protocol_conv.opam ppx_protocol_conv_json.opam ppx_protocol_conv_msgpack.opam ppx_protocol_conv_xmlm.opam ppx_protocol_conv_yaml.opam ppx_protocol_conv_xml_light.opam' 22 | - ocaml-compiler: 4 23 | packages: 'ppx_protocol_conv.opam ppx_protocol_conv_json.opam ppx_protocol_conv_msgpack.opam ppx_protocol_conv_xmlm.opam ppx_protocol_conv_yaml.opam ppx_protocol_conv_xml_light.opam' 24 | - ocaml-compiler: 5 25 | packages: 'ppx_protocol_conv.opam ppx_protocol_conv_json.opam ppx_protocol_conv_msgpack.opam ppx_protocol_conv_xmlm.opam ppx_protocol_conv_yaml.opam ppx_protocol_conv_xml_light.opam' 26 | runs-on: ${{ matrix.os }} 27 | 28 | steps: 29 | - name: Checkout code 30 | uses: actions/checkout@v4 31 | 32 | - name: Use OCaml ${{ matrix.ocaml-compiler }} 33 | uses: ocaml/setup-ocaml@v3 34 | with: 35 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 36 | opam-local-packages: ${{ matrix.packages }} 37 | 38 | - run: | 39 | opam install . --deps-only --with-doc --with-test 40 | opam exec -- dune runtest 41 | 42 | - run: | 43 | for package in ${{ matrix.packages }}; do 44 | opam install ${package/.opam/} --with-doc --with-test 45 | done 46 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | _opam 3 | .merlin 4 | drivers/json/test/types.ml 5 | test.ml 6 | ppx_protocol_conv*.install 7 | bench.txt 8 | -------------------------------------------------------------------------------- /Changelog: -------------------------------------------------------------------------------- 1 | -*- mode: fundamental -*- 2 | 3 | Changes marked with '*' indicates a changes that breaks backward compatibility 4 | 5 | - [ ] Support extensible polymorphic variants 6 | - [ ] Switch to use result type for all serialization 7 | - [ ] Support attribute [@nobuiltin] attribute to treat types as abstract 8 | - [ ] Support Result.t, List.t, Option.t, Int.t, et. al 9 | - [ ] Add namespaces to attributes 10 | - [ ] Unify xmlm and xml_light driver to share codebase 11 | 12 | ## 5.2.2 13 | - [x] Fix compatability with Ocaml 5 14 | - [x] Avoid linking against ppxlib 15 | 16 | ## 5.2.1 17 | - [x] Set minimum ocaml version to 4.08 18 | - [x] Remove warnings on using kprintf and switch to reference Stdlib and not Caml 19 | - [x] Require yojson >= 1.6.0 and remove upper constraint on yojson 20 | - [x] Fix package description for yaml driver 21 | 22 | ## 5.2.0 23 | - [x] Extend tests to serialize and deserialize to string for completeness 24 | - [x] Fix bugs when deserializing msgpck 25 | - [x] Test using yaml >= 3.0.0 and msgpck >= 1.7.0 26 | - [x] Enable tests for xmlm driver and fix naming of raw serialized composed types 27 | - [x] Enable tests for xml_light driver and fix naming of raw serialized composed types 28 | 29 | ## 5.1.3 (2020-09-23) 30 | - [x] Remove dependency on stdio 31 | - [x] Fix warning when compiling with 4.11 32 | 33 | ## 5.1.2 (2020-06-26) 34 | - [x] Compatible with Base v0.14 35 | 36 | ## 5.1.1 (2020-05-10) 37 | - [x] Add xmlm driver for xml (by Nick Betteridge) 38 | 39 | 40 | ## 5.1.0 (2020-02-01) 41 | - [x] Add support for primitive type 'bytes' 42 | - [x] Add of__exn for deserializing of Driver.t 43 | - [x] Dont depend on ppxlib for the runtime 44 | - [x] Remove dependency on base 45 | - [x] Support result type 46 | - [x] Require ppx >= 0.9.0 => support ocaml 4.10 (Thanks kit-ty-kate) 47 | 48 | ## 5.0.0 (2019-04-19) 49 | - [x] Add option make make lazy type indeed lazy 50 | - [x] Add option to mangle variant names 51 | - [*] Refactor tuple, variant and record code to be more efficient 52 | - [x] Reduce amount of closures in generated code 53 | - [*] support nativeint 54 | - [x] Remove superfluous rec flag from generated code 55 | - [x] Cache partial results for recursive types 56 | - [x] Fix signatures for parameterized types 57 | - [x] Create helper module for tuple, record and variant. 58 | - [x] Add strict option 59 | - [*] create t_to_driver and t_to_driver_exn 60 | - [x] Move some documentation to wiki pages 61 | - [x] Add a TLDR to the README, including dune build instructions 62 | - [x] Allow core < v.013 63 | - [x] Switch to use alcotest 64 | - [x] Expose constructor to driver error type for custom parsers. (@paurkedal) 65 | 66 | ## 4.0.0 (released 2019-03-26) 67 | - [*] Support "@default" argument on record fields. #9 68 | - [x] Add @name attribute to be compatible with ppx_deriving_yojson 69 | - [*] Support ref cells 70 | - [*] Serialize unit to Null instead of the empty list 71 | - [*] Replace mangle option with driver functors. 72 | - [x] Add compatability with yojson 1.5 73 | 74 | ## 3.2.0 75 | - [x] Require ppx_protocol_conv in all drivers. #12 76 | - [*] Handle char primitive type 77 | 78 | ## 3.1.3 79 | - [x] Require yojson >= 1.6.0 80 | - [x] Require ppxlib >= 0.3.0 81 | 82 | ## 3.1.2 83 | - [x] Support arrays 84 | 85 | ## 3.1.1 86 | - [x] Do not reference ppx in libraries 87 | 88 | ## 3.1.0 89 | - [x] Generalise json/jsonm/yaml/msgpack driver into one. 90 | - [x] Switch to dune 91 | - [x] Use ppxlib 92 | - [x] Xml: Decode to the empty string 93 | 94 | ## 3.0.0 95 | - [x] Support inline records 96 | - [x] Improve error messages on unsupported type constructs 97 | - [x] Support polymorphic variants 98 | - [x] Support parameterised types 99 | - [x] Improve deserialisation error messages 100 | - [x] Make `None` and `Some None` map to distinct values 101 | - [x] Fix error when emitting code for types declared nonrec 102 | - [x] Msgpack: Add fine grained control of serialised types 103 | - [x] *Only emit _protocol for types named t (Breaks backward compatibility) 104 | 105 | ## 2.0.1 106 | - [x] Move tests to own packages 107 | 108 | ## 2.0.0 109 | - [x] Split drivers into multiple driver packages 110 | - [x] Implement yaml driver 111 | 112 | ## 1.0.0 113 | - [x] Xml driver: Error when deserialising singleton lists in records 114 | 115 | ## 0.10.0 116 | - [x] Suport for non-recursive types 117 | - [x] Add alias to allow use without 't_' for types named 't' to mimic deriving_yojson behaviour 118 | 119 | ## 0.9.0 120 | - [x] Handle lazy types. 121 | - [x] Allow overriding Variant constructor names in serialisation 122 | - [x] Add t_of_xml and t_to_xml to drivers. 123 | 124 | - [x] Support int32 and int64 125 | - [x] Don't require all drivers to accept a flags parameter 126 | - [x] Add support for variants 127 | - [x] Support of_protocol and to_protocol 128 | - [x] Add msgpack driver 129 | - [x] Renamed package to ppx_protocol_conv 130 | 131 | ## 0.8 132 | - [x] Initial release 133 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2017, Anders Peter Fugmann 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | * Neither the name of the copyright holder nor the names of its 17 | contributors may be used to endorse or promote products derived from 18 | this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 21 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 24 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 26 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 27 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 28 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: build clean install uninstall reinstall test release doc 2 | .DEFAULT_GOAL = build 3 | build: 4 | dune build @install 5 | 6 | clean: 7 | dune clean 8 | 9 | install: 10 | dune build @install 11 | dune install 12 | 13 | uninstall: 14 | dune uninstall 15 | 16 | reinstall: uninstall install 17 | 18 | test: 19 | dune runtest 20 | 21 | release: 22 | opam publish 23 | 24 | doc: 25 | dune build @doc 26 | 27 | gh-pages: doc 28 | git clone `git config --get remote.origin.url` .gh-pages --reference . 29 | git -C .gh-pages checkout --orphan gh-pages 30 | git -C .gh-pages reset 31 | git -C .gh-pages clean -dxf 32 | cp -r _build/default/_doc/_html/* .gh-pages 33 | git -C .gh-pages add . 34 | git -C .gh-pages config user.email 'docs@ppx_protocol_conv' 35 | git -C .gh-pages commit -m "Update Pages" 36 | git -C .gh-pages push origin gh-pages -f 37 | rm -rf .gh-pages 38 | 39 | .PHONY: bench 40 | bench: 41 | dune clean 42 | dune exec drivers/json/bench/bench.exe --profile bench -- -all-values | tee bench.txt 43 | sed -i 's/[┴┬┼│├┤┌┐┘└]/|/g' bench.txt 44 | sed -i 's/[─]/-/g' bench.txt 45 | 46 | debug: 47 | dumpast type.ml 48 | _build/default/.ppx/ppx_protocol_conv+ppx_sexp_conv+ppx_driver.runner/ppx.exe type.ml 49 | 50 | drivers/json/test/types.ml: force 51 | ./_build/default/.ppx/9f9eea5d5804b6e3d527fb158983e793/ppx.exe -pretty type.ml | ocamlformat - --name=b | sed 's/\[@@[^\]*\]//' > drivers/json/test/types.ml 52 | 53 | .PHONY: force 54 | force: 55 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Ppx Protocol Conv 2 | Ppx protocol conv (de)serializers using deriving, which allows for 3 | plugable 4 | (de)serializers. [Api](https://andersfugmann.github.io/ppx_protocol_conv). 5 | 6 | This page contains an simple overview of functionality provided. 7 | More information is available in the [wiki pages](https://github.com/andersfugmann/ppx_protocol_conv/wiki) 8 | 9 | [![Main workflow](https://github.com/andersfugmann/ppx_protocol_conv/actions/workflows/workflow.yml/badge.svg)](https://github.com/andersfugmann/ppx_protocol_conv/actions/workflows/workflow.yml) 10 | 11 | # Table of contents 12 | 1. [Features](#features) 13 | 1. [Examples](#examples) 14 | 1. [Drivers](#drivers) 15 | 1. [Custom drivers](#custom-drivers) 16 | 1. [Not supported](#not-supported) 17 | 18 | ## Features 19 | The ppx supports the following features: 20 | * records 21 | * recursive and non-recursive types 22 | * variants 23 | * polymophic variants 24 | * All primitive types (except nativeint) 25 | 26 | The following drivers exists 27 | * `Json` which serializes to `Yojson.Safe.t` 28 | * `Jsonm` which serializes to `Ezjsonm.value` 29 | * `Msgpack` which serializes to `Msgpck.t` 30 | * `Yaml` which serializes to `Yaml.t` 31 | * `Xml_light` which serializes to `Xml.xml list` 32 | * `Xmlm` which serializes to `Ezxmlm.node` 33 | 34 | ## Examples 35 | ```ocaml 36 | open Protocol_conv_json 37 | type a = { 38 | x: int; 39 | y: string [@key "Y"] 40 | z: int list [@default [2;3]] 41 | } [@@deriving protocol ~driver:(module Json)] 42 | 43 | type b = A of int 44 | | B of int [@key "b"] 45 | | C 46 | [@@deriving protocol ~driver:(module Json)] 47 | ``` 48 | 49 | will generate the functions: 50 | ```ocaml 51 | val a_to_json: a -> Json.t 52 | val a_of_json_exn: Json.t -> a 53 | val a_of_json: Json.t -> (a, exn) result 54 | 55 | val b_to_json: a -> Json.t 56 | val b_of_json_exn: Json.t -> a 57 | val b_of_json: Json.t -> (b, exn) result 58 | ``` 59 | 60 | ```ocaml 61 | a_to_json { x=42; y:"really"; z:[6;7] } 62 | ``` 63 | Evaluates to 64 | ```ocaml 65 | [ "x", `Int 42; "Y", `String "really"; "z", `List [ `Int 6; `Int 7 ] ] (* Yojson.Safe.json *) 66 | ``` 67 | 68 | `to_protocol` deriver will generate serilisation of the 69 | type. `of_protocol` deriver generates de-serilisation of the type, 70 | while `protocol` deriver will generate both serilisation and de-serilisation functions. 71 | 72 | ## Attributes 73 | Record label names can be changed using `[@key ]` 74 | 75 | Variant and polymorphic variant constructors names can be changed using the `[@name ]` 76 | attribute. 77 | 78 | If a record field is not present in the input when deserialising, as default value can be 79 | assigned using `[@default ]`. If the value to be serialized 80 | matches the default value, the field will be omitted (Some drivers 81 | allow disabling this functonality. Comparrison uses polymorphic compare, so be careful. 82 | 83 | ## Signatures 84 | The ppx also handles signature, but disallows 85 | `[@key ...]`, `[@default ...]` and `[@name] ....` as these does not impact signatures. 86 | 87 | ## Drivers 88 | 89 | Drivers specify concrete serialization and deserialization. 90 | Users of the library can elect to implement their own driver see 91 | [custom drivers](#custom-drivers), or use predefined drivers: 92 | 93 | * `Json` which serializes to `Yojson.Safe.t` 94 | * `Jsonm` which serializes to `Ezjsonm.value` 95 | * `Msgpack` which serializes to `Msgpck.t` 96 | * `Yaml` which serializes to `Yaml.t` 97 | * `Xml_light` which serializes to `Xml.xml list` 98 | * `Xmlm` which serializes to `Ezxmlm.node` 99 | 100 | ## Custom drivers 101 | It is easy to provide custom drivers by implementing the signature: 102 | 103 | ```ocaml 104 | include Protocol_conv.Runtime.Driver with 105 | type t = ... 106 | ``` 107 | See the `drivers` directory for examples on how to implemented new drivers. 108 | Submissions of new drivers are more than welcome. 109 | 110 | ## Not supported 111 | * Generalised algebraic datatypes 112 | * Extensible types 113 | * Extensible polymorphic variants 114 | -------------------------------------------------------------------------------- /drivers/generic/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_protocol_driver) 3 | (public_name ppx_protocol_conv.driver) 4 | (libraries ppx_protocol_conv.runtime) 5 | (flags :standard -w -3) 6 | (synopsis "generic (de)serialization driver for ppx_protocol_conv") 7 | ) 8 | -------------------------------------------------------------------------------- /drivers/generic/ppx_protocol_driver.ml: -------------------------------------------------------------------------------- 1 | open Protocol_conv 2 | open Runtime 3 | open StdLabels 4 | 5 | module type Parameters = sig 6 | val field_name: string -> string 7 | val variant_name: string -> string 8 | val constructors_without_arguments_as_string: bool 9 | val omit_default_values: bool 10 | val eager: bool 11 | val strict: bool 12 | end 13 | 14 | module Default_parameters : Parameters = struct 15 | let field_name name = name 16 | let variant_name name = name 17 | let constructors_without_arguments_as_string = true 18 | let omit_default_values = true 19 | let eager = true 20 | let strict = false 21 | end 22 | 23 | module type Driver = sig 24 | type t 25 | val to_string_hum: t -> string 26 | 27 | val to_list: t -> t list 28 | val of_list: t list -> t 29 | val is_list: t -> bool 30 | 31 | val to_alist: t -> (string * t) list 32 | val of_alist: (string * t) list -> t 33 | val is_alist: t -> bool 34 | 35 | val to_char: t -> char 36 | val of_char: char -> t 37 | 38 | val to_int: t -> int 39 | val of_int: int -> t 40 | 41 | val to_int32: t -> int32 42 | val of_int32: int32 -> t 43 | 44 | val to_int64: t -> int64 45 | val of_int64: int64 -> t 46 | 47 | val to_nativeint: t -> nativeint 48 | val of_nativeint: nativeint -> t 49 | 50 | val to_float: t -> float 51 | val of_float: float -> t 52 | 53 | val to_string: t -> string 54 | val of_string: string -> t 55 | val is_string: t -> bool 56 | 57 | val to_bool: t -> bool 58 | val of_bool: bool -> t 59 | 60 | val to_bytes: t -> bytes 61 | val of_bytes: bytes -> t 62 | 63 | val null: t 64 | val is_null: t -> bool 65 | end 66 | 67 | let mangle str = 68 | let chars = 69 | let chars = ref [] in 70 | String.iter ~f:(fun ch -> chars := ch :: !chars) str; 71 | List.rev !chars 72 | in 73 | let rec inner = function 74 | | '_' :: '_' :: cs -> inner ('_' :: cs) 75 | | '_' :: c :: cs -> Char.uppercase_ascii c :: inner cs 76 | | '_' :: [] -> [] 77 | | c :: cs -> c :: inner cs 78 | | [] -> [] 79 | in 80 | let res_arr = inner chars |> Array.of_list in 81 | String.init (Array.length res_arr) ~f:(fun i -> res_arr.(i)) 82 | 83 | module Make(Driver: Driver)(P: Parameters) = struct 84 | type t = Driver.t 85 | type error = string * t option 86 | exception Protocol_error of error 87 | 88 | let make_error ?value msg = (msg, value) 89 | 90 | let error_to_string_hum: error -> string = function 91 | | (s, Some t) -> Printf.sprintf "%s. Got: %s" s (Driver.to_string_hum t) 92 | | (s, None) -> s 93 | 94 | (* Register exception printer *) 95 | let () = Printexc.register_printer (function 96 | | Protocol_error err -> Some (error_to_string_hum err) 97 | | _ -> None) 98 | 99 | let to_string_hum = Driver.to_string_hum 100 | 101 | let raise_errorf t fmt = 102 | Printf.kprintf (fun s -> raise (Protocol_error (s, t))) fmt 103 | 104 | let try_with: (t -> 'a) -> t -> ('a, error) Runtime.result = fun f t -> 105 | match f t with 106 | | v -> Ok v 107 | | exception (Protocol_error e) -> Error e 108 | 109 | let wrap t f x = match f x with 110 | | v -> v 111 | | exception Helper.Protocol_error s -> raise (Protocol_error (s, Some t)) 112 | | exception e -> raise (Protocol_error (Printexc.to_string e, Some t)) 113 | 114 | 115 | let to_record: (t, 'a, 'b) Record_in.t -> 'a -> t -> 'b = fun spec constr -> 116 | let spec = Helper.map_record_in P.field_name spec in 117 | let f = Helper.to_record ~strict:P.strict spec constr in 118 | fun t -> wrap t f (wrap t Driver.to_alist t) 119 | 120 | let of_record: type a. (t, a, t) Record_out.t -> a = fun spec -> 121 | let spec = Helper.map_record_out P.field_name spec in 122 | Helper.of_record ~omit_default:P.omit_default_values Driver.of_alist spec 123 | 124 | let to_tuple: (t, 'a, 'b) Tuple_in.t -> 'a -> t -> 'b = fun spec constr -> 125 | let f = Helper.to_tuple spec constr in 126 | fun t -> wrap t f (wrap t Driver.to_list t) 127 | 128 | let of_tuple: (t, 'a, t) Tuple_out.t -> 'a = fun spec -> 129 | Helper.of_tuple Driver.of_list spec 130 | 131 | let to_variant: (t, 'a) Variant_in.t list -> t -> 'a = fun spec -> 132 | let f = Helper.to_variant (Helper.map_constructor_names P.variant_name spec) in 133 | 134 | match P.constructors_without_arguments_as_string with 135 | | true -> begin 136 | function 137 | | t when Driver.is_string t -> wrap t (f (wrap t Driver.to_string t)) [] 138 | | t when Driver.is_list t -> begin 139 | match Driver.to_list t with 140 | | name :: args when Driver.is_string name -> wrap t f ((Driver.to_string name)) args 141 | | _ :: _ -> raise_errorf (Some t) "First element in the list must be the constructor name when name when deserialising variant" 142 | | [] -> raise_errorf (Some t) "Empty list found when deserialising variant" 143 | end 144 | | t -> raise_errorf (Some t) "Expected list or string when deserialising variant" 145 | end 146 | | false -> begin 147 | function 148 | | t when Driver.is_list t -> begin 149 | match Driver.to_list t with 150 | | name :: args when Driver.is_string name -> wrap t (f (Driver.to_string name)) args 151 | | _ :: _ -> raise_errorf (Some t) "First element in the list must be the constructor name when name when deserialising variant" 152 | | [] -> raise_errorf (Some t) "Empty list found when deserialising variant" 153 | end 154 | | t -> raise_errorf (Some t) "Expected list when deserialising variant" 155 | end 156 | 157 | let of_variant: string -> (t, 'a, t) Tuple_out.t -> 'a = 158 | let of_variant name = 159 | let name = P.variant_name name |> Driver.of_string in 160 | function 161 | | [] when P.constructors_without_arguments_as_string -> name 162 | | ts -> Driver.of_list (name :: ts) 163 | in 164 | fun name spec -> Helper.of_variant of_variant name spec 165 | 166 | let get_option = function 167 | | t when Driver.is_alist t -> begin 168 | match Driver.to_alist t with 169 | | [("__option", t)] -> Some t 170 | | _ -> None 171 | end 172 | | _ -> None 173 | 174 | (* If the type is an empty list, thats also null. *) 175 | let to_option: (t -> 'a) -> t -> 'a option = fun to_value_fun -> function 176 | | t when Driver.is_null t -> None 177 | | t -> 178 | let t = match (get_option t) with Some t -> t | None -> t in 179 | Some (to_value_fun t) 180 | 181 | let of_option: ('a -> t) -> 'a option -> t = fun of_value_fun -> function 182 | | None -> Driver.null 183 | | Some v -> 184 | let mk_option t = Driver.of_alist [ ("__option", t) ] in 185 | match of_value_fun v with 186 | | t when Driver.is_null t -> mk_option t 187 | | t when (get_option t) <> None -> 188 | mk_option t 189 | | t -> t 190 | 191 | let to_ref: (t -> 'a) -> t -> 'a ref = fun to_value_fun t -> 192 | let v = to_value_fun t in 193 | ref v 194 | 195 | let of_ref: ('a -> t) -> 'a ref -> t = fun of_value_fun v -> 196 | of_value_fun !v 197 | 198 | let to_result: (t -> 'a) -> (t -> 'b) -> t -> ('a, 'b) result = fun to_ok to_err -> 199 | let ok = Runtime.Tuple_in.(Cons (to_ok, Nil)) in 200 | let err = Runtime.Tuple_in.(Cons (to_err, Nil)) in 201 | to_variant Runtime.Variant_in.[Variant ("Ok", ok, fun v -> Ok v); Variant ("Error", err, fun v -> Error v)] 202 | 203 | let of_result: ('a -> t) -> ('b -> t) -> ('a, 'b) result -> t = fun of_ok of_err -> 204 | let of_ok = of_variant "Ok" Runtime.Tuple_out.(Cons (of_ok, Nil)) in 205 | let of_err = of_variant "Error" Runtime.Tuple_out.(Cons (of_err, Nil)) in 206 | function 207 | | Ok ok -> of_ok ok 208 | | Error err -> of_err err 209 | 210 | let to_list: (t -> 'a) -> t -> 'a list = fun to_value_fun t -> 211 | Helper.list_map ~f:to_value_fun (wrap t Driver.to_list t) 212 | 213 | let of_list: ('a -> t) -> 'a list -> t = fun of_value_fun v -> 214 | Helper.list_map ~f:of_value_fun v |> Driver.of_list 215 | 216 | let to_array: (t -> 'a) -> t -> 'a array = fun to_value_fun t -> 217 | to_list to_value_fun t |> Array.of_list 218 | 219 | let of_array: ('a -> t) -> 'a array -> t = fun of_value_fun v -> 220 | Array.to_list v |> of_list of_value_fun 221 | 222 | let to_lazy_t: (t -> 'a) -> t -> 'a lazy_t = fun to_value_fun -> 223 | match P.eager with 224 | | true -> fun t -> Lazy.from_val (to_value_fun t) 225 | | false -> fun t -> Lazy.from_fun (fun () -> to_value_fun t) 226 | 227 | let of_lazy_t: ('a -> t) -> 'a lazy_t -> t = fun of_value_fun v -> 228 | Lazy.force v |> of_value_fun 229 | 230 | let to_char t = try Driver.to_char t with _ -> raise_errorf (Some t) "char expected" 231 | let of_char = Driver.of_char 232 | 233 | let to_int t = try Driver.to_int t with _ -> raise_errorf (Some t) "int expected" 234 | let of_int = Driver.of_int 235 | 236 | let to_int32 t = try Driver.to_int32 t with _ -> raise_errorf (Some t) "int32 expected" 237 | let of_int32 = Driver.of_int32 238 | 239 | let to_int64 t = try Driver.to_int64 t with _ -> raise_errorf (Some t) "int64 expected" 240 | let of_int64 = Driver.of_int64 241 | 242 | let to_nativeint t = try Driver.to_nativeint t with _ -> raise_errorf (Some t) "nativeint expected" 243 | let of_nativeint = Driver.of_nativeint 244 | 245 | let to_string t = try Driver.to_string t with _ -> raise_errorf (Some t) "string expected" 246 | let of_string = Driver.of_string 247 | 248 | let to_float t = try Driver.to_float t with _ -> raise_errorf (Some t) "float expected" 249 | let of_float = Driver.of_float 250 | 251 | let to_bool t = try Driver.to_bool t with _ -> raise_errorf (Some t) "bool expected" 252 | let of_bool = Driver.of_bool 253 | 254 | let to_bytes t = try Driver.to_bytes t with _ -> raise_errorf (Some t) "bytes expected" 255 | let of_bytes = Driver.of_bytes 256 | 257 | let to_unit t = to_option (fun _ -> ()) t 258 | |> function Some _ -> raise_errorf (Some t) "Unit expected" 259 | | None -> () 260 | 261 | let of_unit () = of_option (fun _ -> failwith "Should call with None") None 262 | end 263 | -------------------------------------------------------------------------------- /drivers/generic/ppx_protocol_driver.mli: -------------------------------------------------------------------------------- 1 | module type Parameters = sig 2 | (** Map field names of records 3 | Mapping is done after applying [[@key]] attribute. 4 | 5 | Default is [identity] 6 | *) 7 | val field_name: string -> string 8 | 9 | (** Map variant and constructor names. 10 | Mapping is done after applying [[@name]] attribute. 11 | 12 | Default is [identity] 13 | *) 14 | val variant_name: string -> string 15 | 16 | (** Map constructors with no arguments to a string. 17 | If true, constructors without arguments are mapped to a string, instead of 18 | than a list containing only the constructor / variant name. 19 | 20 | Default is [true] 21 | *) 22 | val constructors_without_arguments_as_string: bool 23 | 24 | (** Omit default values from output. 25 | If true, default values 26 | are not serialized. Note that this uses polymorphic compare 27 | to determine if a field value is the same as the default value. 28 | 29 | Default is [true] 30 | *) 31 | val omit_default_values: bool 32 | 33 | (** Lazy evaluate lazy fields. 34 | If true, lazy fields are parsed eagerly. 35 | If false, lazy fields are parsed first when forced, which means they 36 | will hold the serialized structure until forced, and forcing 37 | might raise a parse error. 38 | 39 | Default is [true] 40 | *) 41 | val eager: bool 42 | 43 | (** Fail if unknown fields are encountered when deserialising records. 44 | 45 | Default is [false] 46 | *) 47 | val strict: bool 48 | end 49 | 50 | (** Set of default Parameters *) 51 | module Default_parameters : Parameters 52 | 53 | module type Driver = sig 54 | type t 55 | val to_string_hum: t -> string 56 | 57 | val to_list: t -> t list 58 | val of_list: t list -> t 59 | val is_list: t -> bool 60 | 61 | val to_alist: t -> (string * t) list 62 | val of_alist: (string * t) list -> t 63 | val is_alist: t -> bool 64 | 65 | val to_char: t -> char 66 | val of_char: char -> t 67 | 68 | val to_int: t -> int 69 | val of_int: int -> t 70 | 71 | val to_int32: t -> int32 72 | val of_int32: int32 -> t 73 | 74 | val to_int64: t -> int64 75 | val of_int64: int64 -> t 76 | 77 | val to_nativeint: t -> nativeint 78 | val of_nativeint: nativeint -> t 79 | 80 | val to_float: t -> float 81 | val of_float: float -> t 82 | 83 | val to_string: t -> string 84 | val of_string: string -> t 85 | val is_string: t -> bool 86 | 87 | val to_bool: t -> bool 88 | val of_bool: bool -> t 89 | 90 | val to_bytes: t -> bytes 91 | val of_bytes: bytes -> t 92 | 93 | val null: t 94 | val is_null: t -> bool 95 | end 96 | 97 | (** Helper function to convert snake case identifiers to 98 | camel case, e.g. a_bcd_ef -> aBcdEf 99 | *) 100 | val mangle: string -> string 101 | 102 | module Make: functor (D : Driver)(P : Parameters) -> 103 | Protocol_conv.Runtime.Driver with type t = D.t 104 | -------------------------------------------------------------------------------- /drivers/json/bench/bench.ml: -------------------------------------------------------------------------------- 1 | open Protocol_conv_json 2 | open Base 3 | open Core_bench 4 | 5 | (* Constant random number seed to make tests comparable *) 6 | let () = Random.init 12345678 7 | 8 | module Json = Json.Make(struct 9 | include Ppx_protocol_driver.Default_parameters 10 | let omit_default_values = true 11 | let strict = true 12 | let constructors_without_arguments_as_string = true 13 | end) 14 | 15 | module type Test = sig 16 | val name : string 17 | type t 18 | val t: unit -> t 19 | val to_json: t -> Json.t 20 | val to_yojson: t -> Yojson.Safe.t 21 | val of_json: Json.t -> (t, Json.error) Protocol_conv.Runtime.result 22 | val of_yojson: Yojson.Safe.t -> t Ppx_deriving_yojson_runtime.error_or 23 | end 24 | 25 | 26 | let int () = Random.int 10 27 | let float () = Random.float 1000. 28 | let string () = String.init (Random.int 10) ~f:(fun _ -> Char.to_int 'a' + Random.int 20 |> Char.of_int_exn) 29 | let list ?length f () = let length = Option.value ~default:(Random.int 64) length in List.init length ~f:(fun _ -> f ()) 30 | let option f () = match Random.bool () with | true -> Some (f ()) | false -> None 31 | 32 | module Test_tuple = struct 33 | type t = (int * int * string * int * int) 34 | [@@deriving protocol ~driver:(module Json), yojson] 35 | let t () = (int (), int (), string (), int (), int ()) 36 | let name = "Tuple" 37 | end 38 | 39 | module Test_variant_record = struct 40 | let name = "Variant with record" 41 | type t = A of { a: int; b: int; c: int; d: int; e: int; f: int; } 42 | | B of { a: int; b: int; c: int; d: int; e: int; f: int; } 43 | | C of { a: int; b: int; c: int; d: int; e: int; f: int; } 44 | | D of { a: int; b: int; c: int; d: int; e: int; f: int; } 45 | [@@deriving protocol ~driver:(module Json), yojson] 46 | let t () = C { 47 | a = int (); 48 | b = int (); 49 | c = int (); 50 | d = int (); 51 | e = int (); 52 | f = int (); 53 | } 54 | end 55 | 56 | module Test_record : Test = struct 57 | let name = "Record" 58 | type t = { a: int; b: int; c: int; d: int; e: int; f: int; } 59 | [@@deriving protocol ~driver:(module Json), yojson] 60 | let t () = { 61 | a = int (); 62 | b = int (); 63 | c = int (); 64 | d = int (); 65 | e = int (); 66 | f = int (); 67 | } 68 | end 69 | 70 | type a = A of int | B of string | C of float | D of (int * int) 71 | [@@deriving protocol ~driver:(module Json), yojson] 72 | let a () = match Random.int 4 with 73 | | 0 -> A (int ()) 74 | | 1 -> B (string ()) 75 | | 2 -> C (float ()) 76 | | 3 -> D (int (), int ()) 77 | | _ -> failwith "a" 78 | 79 | 80 | type b = { a: a; b: a list; c: int } 81 | [@@deriving protocol ~driver:(module Json), yojson] 82 | let b () = { 83 | a = a (); 84 | b = list a (); 85 | c = int () [@default 0]; 86 | } 87 | 88 | type c = [ `A of string | `B of c * c | `C of int option list] 89 | [@@deriving protocol ~driver:(module Json), yojson] 90 | let rec c () = match Random.int 3 with 91 | | 0 -> `A (string ()) 92 | | 1 -> `B (c (), c ()) 93 | | 2 -> `C (list (option int) ()) 94 | | _ -> failwith "c" 95 | 96 | type d = { a: a list; b: b list; c: c list; } 97 | [@@deriving protocol ~driver:(module Json), yojson] 98 | let d () = 99 | { a = list a (); 100 | b = list b (); 101 | c = list c (); 102 | } 103 | 104 | 105 | type e = A0 | A1 | A2 | A3 | A4 | A5 | A6 | A7 | A8 | A9 | A10 | A11 | A12 | A13 | A14 | A15 | A16 | A17 | A18 | A19 106 | [@@deriving protocol ~driver:(module Json), yojson] 107 | let e () = match Random.int 20 with 108 | | 0 -> A0 109 | | 1 -> A1 110 | | 2 -> A2 111 | | 3 -> A3 112 | | 4 -> A4 113 | | 5 -> A5 114 | | 6 -> A6 115 | | 7 -> A7 116 | | 8 -> A8 117 | | 9 -> A9 118 | | 10 -> A10 119 | | 11 -> A11 120 | | 12 -> A12 121 | | 13 -> A13 122 | | 14 -> A14 123 | | 15 -> A15 124 | | 16 -> A16 125 | | 17 -> A17 126 | | 18 -> A18 127 | | 19 -> A19 128 | | _ -> failwith "e" 129 | 130 | module Test_enum : Test = struct 131 | let name = "Enum" 132 | type u = A0 | A1 | A2 | A3 | A4 | A5 | A6 | A7 | A8 | A9 | A10 | A11 | A12 | A13 | A14 | A15 | A16 | A17 | A18 | A19 133 | and t = u list 134 | [@@deriving protocol ~driver:(module Json), yojson] 135 | let u () = match Random.int 20 with 136 | | 0 -> A0 | 1 -> A1 | 2 -> A2 | 3 -> A3 | 4 -> A4 | 5 -> A5 | 6 -> A6 | 7 -> A7 | 8 -> A8 | 9 -> A9 | 10 -> A10 137 | | 11 -> A11 | 12 -> A12 | 13 -> A13 | 14 -> A14 | 15 -> A15 | 16 -> A16 | 17 -> A17 | 18 -> A18 | 19 -> A19 | _ -> failwith "e" 138 | let t () = list ~length:10 u () 139 | end 140 | 141 | type f = d * e 142 | [@@deriving protocol ~driver:(module Json), yojson] 143 | let f () = d (), e () 144 | 145 | module Test_full : Test = struct 146 | let name = "Test full" 147 | type t = f list 148 | [@@deriving protocol ~driver:(module Json), yojson] 149 | let t () = list ~length:1 f () 150 | end 151 | 152 | 153 | let bench (module X: Test) = 154 | let t = X.t () in 155 | let json = X.to_json t in 156 | let yojson = X.to_yojson t in 157 | Core.Command.run @@ Bench.make_command @@ [ 158 | Bench.Test.create_group ~name:X.name [ 159 | Bench.Test.create_group ~name:"Deserialize" [ 160 | Bench.Test.create ~name:"to_yojson" 161 | (fun () -> X.of_yojson yojson); 162 | Bench.Test.create ~name:"to_json" 163 | (fun () -> X.of_json json); 164 | ] 165 | ] 166 | ]; 167 | Core.Command.run @@ Bench.make_command @@ [ 168 | Bench.Test.create_group ~name:X.name [ 169 | Bench.Test.create_group ~name:"Serialize" [ 170 | Bench.Test.create ~name:"to_yojson" 171 | (fun () -> X.to_yojson t); 172 | Bench.Test.create ~name:"to_json" 173 | (fun () -> X.to_json t); 174 | ]; 175 | ]; 176 | ]; 177 | () 178 | (* 179 | module Bench_lookup = struct 180 | type t = 181 | | A0 182 | | A1 183 | | A2 184 | | A3 185 | | A4 186 | | A5 187 | | A6 188 | | A7 189 | | A8 190 | | A9 191 | | A10 192 | | A11 193 | | A12 194 | | A13 195 | | A14 196 | | A15 197 | | A16 198 | | A17 199 | | A18 200 | | A19 201 | 202 | let alist = [ 203 | "A0", A0; 204 | "B1", A1; 205 | "C2", A2; 206 | "D3", A3; 207 | "E4", A4; 208 | "F5", A5; 209 | "G6", A6; 210 | "H7", A7; 211 | "I8", A8; 212 | "J9", A9; 213 | "A10", A10; 214 | "B11", A11; 215 | "C12", A12; 216 | "D13", A13; 217 | "E14", A14; 218 | "F15", A15; 219 | "G16", A16; 220 | "H17", A17; 221 | "I18", A18; 222 | "J19", A19; 223 | ] 224 | 225 | let test_keys = List.map ~f:fst alist 226 | |> fun l -> List.permute l 227 | 228 | let ocaml = function 229 | | "A0" -> Some A0 230 | | "B1" -> Some A1 231 | | "C2" -> Some A2 232 | | "D3" -> Some A3 233 | | "E4" -> Some A4 234 | | "F5" -> Some A5 235 | | "G6" -> Some A6 236 | | "H7" -> Some A7 237 | | "I8" -> Some A8 238 | | "J9" -> Some A9 239 | | "A10" -> Some A10 240 | | "B11" -> Some A11 241 | | "C12" -> Some A12 242 | | "D13" -> Some A13 243 | | "E14" -> Some A14 244 | | "F15" -> Some A15 245 | | "G16" -> Some A16 246 | | "H17" -> Some A17 247 | | "I18" -> Some A18 248 | | "J19" -> Some A19 249 | | _ -> None 250 | 251 | let tests = [ 252 | "ocaml", ocaml; 253 | "hashtbl", Protocol_conv.Runtime.Helper.Hashtbl_lookup.of_alist alist; 254 | "map", Protocol_conv.Runtime.Helper.Map_lookup.of_alist alist; 255 | "radix", Protocol_conv.Runtime.Helper.Radix_lookup.of_alist alist; 256 | "cmph", Protocol_conv.Runtime.Helper.Cmph_lookup.of_alist alist; 257 | "alist", Protocol_conv.Runtime.Helper.List_lookup.of_alist alist; 258 | ] 259 | 260 | let bench () = 261 | Core.Command.run @@ Bench.make_command @@ 262 | List.map ~f:(fun (name, f) -> 263 | Bench.Test.create ~name 264 | (fun () -> List.iter test_keys ~f:(fun x -> f x |> ignore)) ) tests 265 | end 266 | *) 267 | 268 | let () = 269 | bench (module Test_record); 270 | bench (module Test_tuple); 271 | bench (module Test_enum); 272 | bench (module Test_variant_record); 273 | bench (module Test_full); 274 | -------------------------------------------------------------------------------- /drivers/json/bench/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name bench) 3 | (libraries ppx_protocol_conv_json core_bench) 4 | (preprocess (pps ppx_protocol_conv ppx_deriving_yojson))) 5 | -------------------------------------------------------------------------------- /drivers/json/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name protocol_conv_json) 3 | (public_name ppx_protocol_conv_json) 4 | (private_modules test_expect) 5 | (libraries ppx_protocol_conv.runtime ppx_protocol_conv.driver yojson) 6 | (synopsis "yojson (de)serialization driver for ppx_protocol_conv") 7 | (preprocess (pps ppx_protocol_conv ppx_expect)) 8 | ) 9 | -------------------------------------------------------------------------------- /drivers/json/json.ml: -------------------------------------------------------------------------------- 1 | module Driver : Ppx_protocol_driver.Driver with type t = Yojson.Safe.t [@warning "-3"] = struct 2 | type t = Yojson.Safe.t [@warning "-3"] 3 | 4 | let to_string_hum t = 5 | Yojson.Safe.pretty_to_string t 6 | 7 | let of_list l = `List l 8 | let to_list = function `List l -> l | _ -> failwith "List expected" 9 | let is_list = function `List _ -> true | _ -> false 10 | 11 | let of_alist a = `Assoc a 12 | let to_alist = function `Assoc a -> a | _ -> failwith "Assoc expected" 13 | let is_alist = function `Assoc _ -> true | _ -> false 14 | 15 | let of_int i = `Int i 16 | let to_int = function `Int i -> i | _ -> failwith "Int expected" 17 | 18 | let of_int32 i = Int32.to_int i |> of_int 19 | let to_int32 t = to_int t |> Int32.of_int 20 | 21 | let of_int64 i = Int64.to_int i |> of_int 22 | let to_int64 t = to_int t |> Int64.of_int 23 | 24 | let of_nativeint i = Nativeint.to_int i |> of_int 25 | let to_nativeint t = to_int t |> Nativeint.of_int 26 | 27 | let of_float f = `Float f 28 | let to_float = function `Float f -> f | _ -> failwith "Float expected" 29 | 30 | let of_string s = `String s 31 | let to_string = function `String s -> s | _ -> failwith "String expected" 32 | let is_string = function `String _ -> true | _ -> false 33 | 34 | let of_char c = of_string (String.make 1 c) 35 | let to_char t = match to_string t with 36 | | s when String.length s = 1 -> s.[0] 37 | | _ -> failwith "Got string with length != 1 when reading type 'char'" 38 | 39 | let of_bool b = `Bool b 40 | let to_bool = function `Bool b -> b | _ -> failwith "Bool expected" 41 | 42 | let of_bytes b = `String (Bytes.to_string b) 43 | let to_bytes = function `String b -> Bytes.of_string b 44 | | _ -> failwith "Bytes expected" 45 | 46 | let null = `Null 47 | let is_null = function `Null -> true | _ -> false 48 | end 49 | 50 | include Ppx_protocol_driver.Make(Driver)(Ppx_protocol_driver.Default_parameters) 51 | module Make(P: Ppx_protocol_driver.Parameters) = Ppx_protocol_driver.Make(Driver)(P) 52 | 53 | module Yojson = struct 54 | include Make(struct 55 | include Ppx_protocol_driver.Default_parameters 56 | let omit_default_values = true 57 | let constructors_without_arguments_as_string = false 58 | let eager = true 59 | let strict = true 60 | end) 61 | let of_yojson_exn t = t 62 | let of_yojson t = Ok t 63 | let to_yojson t = t 64 | end 65 | 66 | (* Allow referencing Json.t in structures. *) 67 | let of_json_exn t = t 68 | let of_json t = Ok t 69 | let to_json t = t 70 | -------------------------------------------------------------------------------- /drivers/json/json.mli: -------------------------------------------------------------------------------- 1 | (* Json Protocol *) 2 | include Protocol_conv.Runtime.Driver with type t = Yojson.Safe.t [@@warning "-3"] 3 | module Make(P: Ppx_protocol_driver.Parameters) : (Protocol_conv.Runtime.Driver with type t = Yojson.Safe.t) [@@warning "-3"] 4 | module Yojson : sig 5 | include Protocol_conv.Runtime.Driver with type t = Yojson.Safe.t [@@warning "-3"] 6 | val of_yojson_exn: t -> t 7 | val of_yojson: t -> (t, error) Protocol_conv.Runtime.result 8 | val to_yojson: t -> t 9 | end 10 | 11 | val of_json_exn: t -> t 12 | val of_json: t -> (t, error) Protocol_conv.Runtime.result 13 | val to_json: t -> t 14 | -------------------------------------------------------------------------------- /drivers/json/test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name unittest) 3 | (libraries test ppx_protocol_conv_json) 4 | (preprocess (pps ppx_protocol_conv ppx_sexp_conv ppx_expect)) 5 | ) 6 | 7 | (rule 8 | (targets unittest.output) 9 | (deps unittest.exe) 10 | (action (run %{deps})) 11 | ) 12 | 13 | (alias 14 | (name runtest) 15 | (package ppx_protocol_conv_json) 16 | (action (diff unittest.expected unittest.output)) 17 | ) 18 | -------------------------------------------------------------------------------- /drivers/json/test/test_attrib.ml: -------------------------------------------------------------------------------- 1 | (* Extra tests *) 2 | open Sexplib.Std 3 | open Protocol_conv_json 4 | type u = A of int [@name "AAA"] | B of string [@name "BBB"] 5 | [@@deriving protocol ~driver:(module Json), sexp] 6 | type t = { 7 | i : int [@name "Integer"]; 8 | u: u [@key "Poly"]; 9 | } [@@deriving protocol ~driver:(module Json), sexp] 10 | 11 | let fmt formatter t = 12 | Stdlib.Format.fprintf formatter "%s" (Base.Sexp.to_string_hum (sexp_of_t t)) 13 | 14 | let fmt_yojson formatter t = 15 | Stdlib.Format.fprintf formatter "%s" (Yojson.Safe.pretty_to_string t) 16 | 17 | 18 | let test_attrib_name () = 19 | let t = { i = 5; u = A 3; } in 20 | let j = [("i", `Int 5); ("Poly", `List [`String "AAA"; `Int 3])] |> List.rev in 21 | Alcotest.(check (of_pp fmt)) "Deserialize" t (`Assoc j |> of_json_exn); 22 | Alcotest.(check (of_pp fmt_yojson)) "Serialize" (to_json t) (`Assoc j); 23 | () 24 | 25 | let test_attrib_key () = 26 | let t = { i = 5; u = B "abc"; } in 27 | let j = [("i", `Int 5); ("Poly", `List [`String "BBB"; `String "abc"])] |> List.rev in 28 | Alcotest.(check (of_pp fmt)) "Deserialize" t (`Assoc j |> of_json_exn); 29 | Alcotest.(check (of_pp fmt_yojson)) "Serialize" (to_json t) (`Assoc j); 30 | () 31 | 32 | let test = 33 | __MODULE__, 34 | [ Alcotest.test_case "Attrib name" `Quick test_attrib_name; 35 | Alcotest.test_case "Attrib key" `Quick test_attrib_key; ] 36 | -------------------------------------------------------------------------------- /drivers/json/test/unittest.expected: -------------------------------------------------------------------------------- 1 | === json.SingleElem === 2 | [] 3 | === json.SingleElem === 4 | [ 2 ] 5 | === json.Longarray === 6 | [ 4, 2, 3, 1 ] 7 | === json.EmptyInsideRec === 8 | { "c": "c", "V": [], "a": "a" } 9 | === json.SingleInsideRec === 10 | { "c": "c", "V": [ 2 ], "a": "a" } 11 | === json.MultiInsideRec === 12 | { "c": "c", "V": [ 4, 2, 3, 1 ], "a": "a" } 13 | === json.ArrayOfArrays === 14 | { "a": [ [ 2, 3 ], [ 4, 5 ] ] } 15 | === json.ArrayOfArrays2 === 16 | [ [], [ [], [ 2 ], [ 3, 4 ] ], [ [] ], [ [ 2 ] ] ] 17 | === json.Tuple === 18 | [ 19 | [ 20 | 10, 21 | [ 20, 30, 40 ], 22 | [ "s50", "s60", "s70" ], 23 | [ [ 100, 200 ], [ 300, 400 ], [ 500, 600 ] ] 24 | ], 25 | [ 26 | 11, 27 | [ 21, 31, 41 ], 28 | [ "s51", "s61", "s71" ], 29 | [ [ 101, 201 ], [ 301, 401 ], [ 501, 601 ] ] 30 | ], 31 | [ 32 | 12, 33 | [ 22, 32, 42 ], 34 | [ "s52", "s62", "s72" ], 35 | [ [ 102, 202 ], [ 302, 402 ], [ 502, 602 ] ] 36 | ], 37 | [ 38 | 13, 39 | [ 23, 33, 43 ], 40 | [ "s53", "s63", "s73" ], 41 | [ [ 103, 203 ], [ 303, 403 ], [ 503, 603 ] ] 42 | ] 43 | ] 44 | === json.Any === 45 | { 46 | "u": { "ua": 7 }, 47 | "v": [ "B", [ 5, 6, 7 ], [ 10, 11, 12 ] ], 48 | "z": 101, 49 | "record": { "y": "string", "x": 5 }, 50 | "varray": [ 51 | [ "B", [ 5, 6, 7 ], [ 10, 11, 12 ] ], 52 | [ "B", [ 5, 6, 7 ], [ 10, 11, 12 ] ], 53 | [ "B", [ 5, 6, 7 ], [ 10, 11, 12 ] ] 54 | ], 55 | "vlist": [ 56 | [ "B", [ 5, 6, 7 ], [ 10, 11, 12 ] ], 57 | [ "B", [ 5, 6, 7 ], [ 10, 11, 12 ] ], 58 | [ "B", [ 5, 6, 7 ], [ 10, 11, 12 ] ] 59 | ], 60 | "tuple": [ 5, "protocol", false ], 61 | "intref": 4, 62 | "intoption": 100, 63 | "intlist": [ 3, 4, 5 ], 64 | "bytes": "bytes", 65 | "string2": "1", 66 | "string": "string", 67 | "float": 3.14, 68 | "nativeint": 20, 69 | "int64": 10, 70 | "int32": 5, 71 | "int": 2, 72 | "char": "x", 73 | "bool": true 74 | } 75 | === json.Record === 76 | { 77 | "t_il": [ 1000, 1001, 1002 ], 78 | "t_tl": [ 79 | [ 100, 101, [ "s100", "s101" ] ], 80 | [ 110, 111, [ "s110", "s111" ] ], 81 | [ 120, 121, [ "s120", "s121" ] ], 82 | [ 130, 131, [ "s130", "s131" ] ], 83 | [ 140, 141, [ "s140", "s141" ] ] 84 | ], 85 | "t_t": [ 100, 101, [ "s100", "s101" ] ], 86 | "t_i": 1000, 87 | "t_bl": [], 88 | "t_b": { 89 | "b_al": [ 90 | { "a_string": "s7", "a_int": 7 }, 91 | { "a_string": "s8", "a_int": 8 }, 92 | { "a_string": "s9", "a_int": 9 } 93 | ], 94 | "b_a": { "a_string": "s6", "a_int": 6 }, 95 | "b_string": "s5", 96 | "b_int": 5 97 | }, 98 | "t_al": [ 99 | { "a_string": "s2", "a_int": 2 }, 100 | { "a_string": "s3", "a_int": 3 }, 101 | { "a_string": "s4", "a_int": 4 } 102 | ], 103 | "t_a": { "a_string": "s1", "a_int": 1 } 104 | } 105 | === json.list === 106 | { "a": [ 1, 2, 3 ] } 107 | === json.Lists === 108 | { 109 | "l": [ 110 | [ "A", [ 1, 2, 3 ] ], 111 | [ "B", [ [ 1, 2 ], [ 3, 4, 5 ], [ 2 ] ], [ 3, 1 ], 5 ], 112 | [ "C", [ 1, 2, 3 ], [ 3, 4, 5 ] ] 113 | ], 114 | "c": [ 100, 101, 102, 103 ], 115 | "b": [ [ 8, 9 ], [ 10, 20, 30, 40 ] ], 116 | "a": [ [ 1, 2, 3 ], [], [ 10, 20, 30, 40 ], [ 100, 101 ] ] 117 | } 118 | === json.array === 119 | { "a": [ 1, 2, 3 ] } 120 | === json.EmptyList === 121 | [] 122 | === json.SingleElem === 123 | [ 2 ] 124 | === json.Longlist === 125 | [ 4, 3, 2, 1 ] 126 | === json.EmptyInsideRec === 127 | { "c": "c", "V": [], "a": "a" } 128 | === json.SingleInsideRec === 129 | { "c": "c", "V": [ 2 ], "a": "a" } 130 | === json.MultiInsideRec === 131 | { "c": "c", "V": [ 4, 2, 3, 1 ], "a": "a" } 132 | === json.ListOfLists === 133 | { "a": [ [ 2, 3 ], [ 4, 5 ] ] } 134 | === json.ListOfLists2 === 135 | [ [], [ [], [ 2 ], [ 3, 4 ] ], [ [] ], [ [ 2 ] ] ] 136 | === json.Nonrec === 137 | [ "A", [ "Cons", 4, [ "Cons", 3, "Nil" ] ] ] 138 | === json.Nonrec2 === 139 | [ "Cons", 4, [ "Cons", 3, "Nil" ] ] 140 | === json.None === 141 | null 142 | === json.Some None === 143 | { "__option": null } 144 | === json.Some Some None === 145 | { "__option": { "__option": null } } 146 | === json.Some Some Some Unit === 147 | { "__option": { "__option": { "__option": { "__option": null } } } } 148 | === json.simple === 149 | 5 150 | === json.record === 151 | { "a": 5 } 152 | === json.multiple === 153 | [ 5, "5", true ] 154 | === json.reference === 155 | { "a": { "a": 5 } } 156 | === json.recursive === 157 | { "c": { "b": { "a": 5 } } } 158 | === json.Simple === 159 | [ "A", [ "B", 5 ], [ "C", [ 6, 7 ] ], [ "D", [ 8, 9 ] ] ] 160 | === json.Tree === 161 | [ "Node", [ [ "Node", [ "Leaf", 3, "Leaf" ] ], 10, "Leaf" ] ] 162 | === json.MutualRecursion === 163 | [ 164 | "T1", [ "V", [ "T", [ "V", [ "V1", [ "V1", [ "V1", [ "V0", 5 ] ] ] ] ] ] ] 165 | ] 166 | === json.InsideRec === 167 | { "c": "c", "V": "A", "a": "a" } 168 | === json.RecordList === 169 | { "objects": [ { "key": 1 }, { "key": 2 } ] } 170 | === json.SimpleRecord === 171 | { 172 | "HostId": "SDsd", 173 | "RequestId": "sdfsd", 174 | "Endpoint": null, 175 | "Bucket": null, 176 | "Message": "Message", 177 | "Code": "Error" 178 | } 179 | === json.Test_sig === 180 | { "x": [ "A", [ [ "A", 7 ], 7, 7, [ "B", 0.7 ], 7 ] ] } 181 | === json.Test_sig2 === 182 | [ 183 | 1, 184 | 2.0, 185 | "3.0", 186 | null, 187 | [ "A", 1 ], 188 | { "c": "3.0", "b": 2.0, "a": 1 }, 189 | [ "A", 1 ] 190 | ] 191 | === json.S3 === 192 | { 193 | "Contents": [ { "ETag": "Etag", "StorageClass": "STANDARD" } ], 194 | "Prefix": "prefix" 195 | } 196 | === json.Types === 197 | { 198 | "baz": { 199 | "y_yd": [ "Variant_two1", 1 ], 200 | "y_yc": [ "three", [ 100, 200, 300 ] ], 201 | "y_b": [ "two", [ 10, 20, 30 ] ], 202 | "y_a": 2 203 | }, 204 | "bar": "true", 205 | "foo": 1 206 | } 207 | === json.Some Some Some true === 208 | true 209 | === json.Some Some None === 210 | { "__option": { "__option": null } } 211 | === json.Some None === 212 | { "__option": null } 213 | === json.None === 214 | null 215 | === json.Some Some Some true === 216 | { "a": true } 217 | === json.Some Some None === 218 | { "a": { "__option": { "__option": null } } } 219 | === json.Some None === 220 | { "a": { "__option": null } } 221 | === json.None === 222 | { "a": null } 223 | === json.unit option option list option option === 224 | [ { "__option": { "__option": null } }, { "__option": null }, null ] 225 | === json.confuse deserialization by using reserved word === 226 | { "o": { "option": true } } 227 | === json.Simple === 228 | [ "A", [ "B", 5 ], [ "C", 6, 7 ], [ "D", [ 8, 9 ] ] ] 229 | === json.Tuple === 230 | [ "A", [ 3, 4 ] ] 231 | === json.Tree === 232 | [ "Node", [ "Node", "Leaf", 3, "Leaf" ], 10, "Leaf" ] 233 | === json.MutualRecursion === 234 | [ 235 | "T1", [ "V", [ "T", [ "V", [ "V1", [ "V1", [ "V1", [ "V0", 5 ] ] ] ] ] ] ] 236 | ] 237 | === json.InsideRec === 238 | { "c": "c", "V": "A", "a": "a" } 239 | === json.InlineRecord === 240 | [ "A", { "a": "a" } ] 241 | === json.InlineRecord2 === 242 | [ "aa", { "b": [ "aa", { "b": [ "B", 5 ], "A": "a" } ], "A": "a" } ] 243 | === json.Poly === 244 | [ "aaa", 5 ] 245 | === json.Option.Ok === 246 | [ "Ok", 2 ] 247 | === json.Option.Error === 248 | [ "Error", "Error string" ] 249 | -------------------------------------------------------------------------------- /drivers/json/test/unittest.ml: -------------------------------------------------------------------------------- 1 | open Protocol_conv_json 2 | module Driver = struct 3 | let name = "json" 4 | let serialize t = Yojson.Safe.pretty_to_string t 5 | let deserialize t = Yojson.Safe.from_string t 6 | include Json 7 | let of_driver_exn = of_json_exn 8 | let of_driver = of_json 9 | let to_driver = to_json 10 | let sexp_of_t : t -> Sexplib.Sexp.t = fun t -> 11 | Sexplib.Std.sexp_of_string (to_string_hum t) 12 | end 13 | 14 | module Unittest = Test.Unittest.Make(Driver) 15 | 16 | module Yojson_Driver = struct 17 | let name = "yojson" 18 | let serialize t = Yojson.Safe.pretty_to_string t 19 | let deserialize t = Yojson.Safe.from_string t 20 | include Json.Yojson 21 | let of_driver_exn = of_yojson_exn 22 | let of_driver = of_yojson 23 | let to_driver = to_yojson 24 | let sexp_of_t : t -> Sexplib.Sexp.t = fun t -> 25 | Sexplib.Std.sexp_of_string (to_string_hum t) 26 | end 27 | module Unittest_yojson = Test.Unittest.Make(Yojson_Driver) 28 | 29 | (* 30 | module Identity = struct 31 | open Sexplib.Std 32 | type v = {int: a; string: b;} 33 | [@@deriving protocol ~driver:(module Json), sexp] 34 | type t = { t: Json.t; } 35 | [@@deriving protocol ~driver:(module Json), sexp] 36 | let t = { a = 5; b = "s"} |> to_json in 37 | let t = { t } 38 | Alcotest.(check (of_pp fmt)) "Deserialize" t (`Assoc y |> of_json_exn); 39 | Alcotest.(check (of_pp fmt_yojson)) "Serialize" (to_json t) (`Assoc j); 40 | 41 | 42 | end 43 | *) 44 | let () = Unittest.run ~extra:[Test_attrib.test] () 45 | let () = Unittest_yojson.run ~extra:[Test_attrib.test] () 46 | -------------------------------------------------------------------------------- /drivers/json/test_expect.ml: -------------------------------------------------------------------------------- 1 | module Default_parameters = Ppx_protocol_driver.Default_parameters 2 | module Make = Json.Make 3 | 4 | (** Test parameters. *) 5 | module Test = struct 6 | module Standard = struct 7 | module Json = Make(Default_parameters) 8 | type u = A | B of int 9 | and t = { 10 | int: int; 11 | u: u; 12 | uu: u; 13 | } [@@deriving protocol ~driver:(module Json)] 14 | let t = { int = 5; u = A; uu = B 5 } 15 | let%test _ = t |> to_json |> of_json_exn = t 16 | let%expect_test _ = 17 | let s = Json.to_string_hum (to_json t) in 18 | print_endline s; 19 | [%expect {| { "uu": [ "B", 5 ], "u": "A", "int": 5 } |}] 20 | end 21 | 22 | module Field_upper = struct 23 | module Json = Make( 24 | struct 25 | include Default_parameters 26 | let field_name name = "F_" ^ name 27 | let variant_name name = "V_" ^ name 28 | end) 29 | type u = A | B of int 30 | and t = { 31 | int: int; 32 | u: u; 33 | uu: u; 34 | v: [ `A of int ] 35 | } [@@deriving protocol ~driver:(module Json)] 36 | 37 | let t = { int = 5; u = A; uu = B 5; v = `A 6 } 38 | let%test _ = t |> to_json |> of_json_exn = t 39 | let%expect_test _ = 40 | let s = Json.to_string_hum (to_json t) in 41 | print_endline s; 42 | [%expect {| { "F_v": [ "V_A", 6 ], "F_uu": [ "V_B", 5 ], "F_u": "V_A", "F_int": 5 } |}] 43 | end 44 | 45 | module Singleton_as_list = struct 46 | module Json = Make( 47 | struct 48 | include Default_parameters 49 | let constructors_without_arguments_as_string = false 50 | end) 51 | type u = A | B of int 52 | and t = { 53 | int: int; 54 | u: u; 55 | uu: u; 56 | v: [ `X | `Y of int ]; 57 | } [@@deriving protocol ~driver:(module Json)] 58 | 59 | let t = { int = 5; u = A; uu = B 5; v = `X } 60 | let%test _ = t |> to_json |> of_json_exn = t 61 | let%expect_test _ = 62 | let s = Json.to_string_hum (to_json t) in 63 | print_endline s; 64 | [%expect {| { "v": [ "X" ], "uu": [ "B", 5 ], "u": [ "A" ], "int": 5 } |}] 65 | end 66 | 67 | module Omit_default = struct 68 | module Json = Make( 69 | struct 70 | include Default_parameters 71 | let omit_default_values = true 72 | end) 73 | type u = A | B of int 74 | and t = { 75 | int: int; [@default 5] 76 | u: u; 77 | uu: u; 78 | } [@@deriving protocol ~driver:(module Json)] 79 | 80 | let t = { int = 5; u = A; uu = B 5 } 81 | let%test _ = t |> to_json |> of_json_exn = t 82 | let%expect_test _ = 83 | let s = Json.to_string_hum (to_json t) in 84 | print_endline s; 85 | [%expect {| { "uu": [ "B", 5 ], "u": "A" } |}] 86 | end 87 | 88 | module Keep_default = struct 89 | module Json = Make( 90 | struct 91 | include Default_parameters 92 | let omit_default_values = false 93 | end) 94 | 95 | type u = A | B of int 96 | and t = { 97 | int: int; [@default 5] 98 | u: u; 99 | uu: u; 100 | } [@@deriving protocol ~driver:(module Json)] 101 | 102 | let t = { int = 5; u = A; uu = B 5 } 103 | let%test _ = t |> to_json |> of_json_exn = t 104 | let%expect_test _ = 105 | let s = Json.to_string_hum (to_json t) in 106 | print_endline s; 107 | [%expect {| { "uu": [ "B", 5 ], "u": "A", "int": 5 } |}] 108 | end 109 | 110 | module Field_name_count = struct 111 | let count = ref 0 112 | module Json = Make( 113 | struct 114 | include Default_parameters 115 | let field_name name = incr count; name 116 | end) 117 | type u = A of { x:int; y: int; z:int } | B 118 | [@@deriving protocol ~driver:(module Json)] 119 | type t = { 120 | a: int; 121 | b: int; 122 | c: u; 123 | } 124 | [@@deriving protocol ~driver:(module Json)] 125 | let expect = !count 126 | let t = { a=5; b=5; c=B } 127 | let%test _ = t |> to_json |> of_json_exn = t 128 | let%expect_test _ = 129 | let c1 = !count in 130 | let _ = t |> to_json |> of_json_exn in 131 | let c2 = !count in 132 | let _ = t |> to_json |> of_json_exn in 133 | let c3 = !count in 134 | Printf.printf "%d -> %d -> %d -> %d" expect c1 c2 c3; 135 | [%expect {| 12 -> 12 -> 12 -> 12 |}] 136 | 137 | end 138 | 139 | module Variant_name_count = struct 140 | let count = ref 0 141 | module Json = Make( 142 | struct 143 | include Default_parameters 144 | let variant_name name = incr count; name 145 | end) 146 | type t = A of u | B 147 | and u = X of t | Y 148 | [@@deriving protocol ~driver:(module Json)] 149 | let expect = !count 150 | let t = A (X (A (X ( B)))) 151 | let%expect_test _ = 152 | let c1 = !count in 153 | let _ = t |> to_json |> of_json_exn in 154 | let c2 = !count in 155 | let _ = t |> to_json |> of_json_exn in 156 | let c3 = !count in 157 | Printf.printf "%d -> %d -> %d -> %d" expect c1 c2 c3; 158 | [%expect {| 0 -> 0 -> 8 -> 8 |}] 159 | end 160 | 161 | module Test_lazy = struct 162 | module Json = Make( 163 | struct 164 | include Default_parameters 165 | let eager = false 166 | end) 167 | type t = int * int lazy_t 168 | [@@deriving protocol ~driver:(module Json)] 169 | 170 | let%expect_test _ = 171 | let (a, b) = of_json_exn (`List [ `Int 5; `String "ipsum"]) in 172 | Printf.printf "First: %d\n%!" a; 173 | begin 174 | try 175 | Printf.printf "Lazy: %d\n" (Lazy.force b) 176 | with 177 | | Json.Protocol_error err -> Printf.eprintf "Lazy: Got expected error: %s" (Json.error_to_string_hum err); 178 | end; 179 | [%expect {| 180 | First: 5 181 | Lazy: Got expected error: int expected. Got: "ipsum" |}] 182 | end 183 | 184 | module Yojson_test = struct 185 | module Json = Json.Yojson 186 | type 'a v = A of int | B of { int: int; t: 'a } | C [@name "C-D"] 187 | and t = { 188 | int : int [@default 5]; 189 | float: float [@key "Float"]; 190 | string: string; 191 | t_option: t option; 192 | int_option: int option; 193 | int_list: int list; 194 | v: t v; 195 | u: [`A of int | `B of t | `C [@name "CC"] ] 196 | } 197 | [@@deriving protocol ~driver:(module Json)] 198 | 199 | let tree = 200 | { int = 5; 201 | float = 6.0; 202 | string = "TestStr"; 203 | t_option = None; 204 | int_option = Some 7; 205 | int_list = [4;5;6;7;8]; 206 | v = C; 207 | u = `A 5; 208 | } 209 | let tree = 210 | { tree with 211 | v = B { int = 100; t = tree}; 212 | u = `C; 213 | } 214 | let tree = 215 | { tree with 216 | v = A 21; 217 | u = `B tree; 218 | int = 7; 219 | } 220 | let yojson_result = {| 221 | { 222 | "int": 7, 223 | "Float": 6.0, 224 | "string": "TestStr", 225 | "t_option": null, 226 | "int_option": 7, 227 | "int_list": [ 4, 5, 6, 7, 8 ], 228 | "v": [ "A", 21 ], 229 | "u": [ 230 | "B", 231 | { 232 | "Float": 6.0, 233 | "string": "TestStr", 234 | "t_option": null, 235 | "int_option": 7, 236 | "int_list": [ 4, 5, 6, 7, 8 ], 237 | "v": [ 238 | "B", 239 | { 240 | "int": 100, 241 | "t": { 242 | "Float": 6.0, 243 | "string": "TestStr", 244 | "t_option": null, 245 | "int_option": 7, 246 | "int_list": [ 4, 5, 6, 7, 8 ], 247 | "v": [ "C-D" ], 248 | "u": [ "A", 5 ] 249 | } 250 | } 251 | ], 252 | "u": [ "CC" ] 253 | } 254 | ] 255 | } |} |> Yojson.Safe.from_string 256 | 257 | let t = tree 258 | let%test _ = yojson_result |> of_json_exn = t 259 | let%test _ = t |> to_json |> of_json_exn = t 260 | end 261 | 262 | end 263 | -------------------------------------------------------------------------------- /drivers/json/test_expect.mli: -------------------------------------------------------------------------------- 1 | (* Intentional empty *) 2 | -------------------------------------------------------------------------------- /drivers/jsonm/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name protocol_conv_jsonm) 3 | (public_name ppx_protocol_conv_jsonm) 4 | (libraries ppx_protocol_conv.runtime ppx_protocol_conv.driver ezjsonm) 5 | (synopsis "jsonm (de)serialization driver for ppx_protocol_conv based on ezjsonm") 6 | ) 7 | -------------------------------------------------------------------------------- /drivers/jsonm/jsonm.ml: -------------------------------------------------------------------------------- 1 | let identity x = x 2 | 3 | module Driver : Ppx_protocol_driver.Driver with type t = Ezjsonm.value = struct 4 | type t = Ezjsonm.value 5 | 6 | let to_string_hum t = 7 | Ezjsonm.wrap t |> Ezjsonm.to_string ~minify:false 8 | 9 | let of_list = Ezjsonm.list identity 10 | let to_list = Ezjsonm.get_list identity 11 | let is_list = function `A _ -> true | _ -> false 12 | 13 | let of_alist = Ezjsonm.dict 14 | let to_alist = Ezjsonm.get_dict 15 | let is_alist = function `O _ -> true | _ -> false 16 | 17 | let to_int = Ezjsonm.get_int 18 | let of_int = Ezjsonm.int 19 | 20 | let to_int32 = Ezjsonm.get_int32 21 | let of_int32 = Ezjsonm.int32 22 | 23 | let to_int64 = Ezjsonm.get_int64 24 | let of_int64 = Ezjsonm.int64 25 | 26 | let of_nativeint i = Nativeint.to_int i |> of_int 27 | let to_nativeint t = to_int t |> Nativeint.of_int 28 | 29 | let to_float = Ezjsonm.get_float 30 | let of_float = Ezjsonm.float 31 | 32 | let to_string = Ezjsonm.get_string 33 | let of_string = Ezjsonm.string 34 | let is_string = function `String _ -> true | _ -> false 35 | 36 | let of_char c = of_string (String.make 1 c) 37 | let to_char t = match to_string t with 38 | | s when String.length s = 1 -> s.[0] 39 | | _ -> failwith "Got string with length != 1 when reading type 'char'" 40 | 41 | let to_bool = Ezjsonm.get_bool 42 | let of_bool = Ezjsonm.bool 43 | 44 | let to_bytes j = j |> Ezjsonm.get_string |> Bytes.of_string 45 | let of_bytes b = b |> Bytes.to_string |> Ezjsonm.string 46 | 47 | let null = `Null 48 | let is_null = function `Null -> true | _ -> false 49 | end 50 | 51 | include Ppx_protocol_driver.Make(Driver)(Ppx_protocol_driver.Default_parameters) 52 | module Make(P: Ppx_protocol_driver.Parameters) = Ppx_protocol_driver.Make(Driver)(P) 53 | 54 | let of_jsonm_exn = identity 55 | let of_jsonm t = Ok t 56 | let to_jsonm = identity 57 | -------------------------------------------------------------------------------- /drivers/jsonm/jsonm.mli: -------------------------------------------------------------------------------- 1 | include Protocol_conv.Runtime.Driver with type t = Ezjsonm.value 2 | module Make(P: Ppx_protocol_driver.Parameters) : (Protocol_conv.Runtime.Driver with type t = Ezjsonm.value) 3 | val of_jsonm_exn: t -> t 4 | val of_jsonm: t -> (t, error) Protocol_conv.Runtime.result 5 | val to_jsonm: t -> t 6 | -------------------------------------------------------------------------------- /drivers/jsonm/test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name unittest) 3 | (libraries test ppx_protocol_conv_jsonm) 4 | ) 5 | 6 | (rule 7 | (targets unittest.output) 8 | (deps unittest.exe) 9 | (action (run %{deps})) 10 | ) 11 | 12 | (alias 13 | (name runtest) 14 | (package ppx_protocol_conv_jsonm) 15 | (action (diff unittest.expected unittest.output)) 16 | ) 17 | -------------------------------------------------------------------------------- /drivers/jsonm/test/unittest.ml: -------------------------------------------------------------------------------- 1 | module Driver = struct 2 | let name = "jsonm" 3 | let serialize t = Ezjsonm.(to_string (wrap t)) 4 | let deserialize t = Ezjsonm.(from_string t |> unwrap) 5 | include Protocol_conv_jsonm.Jsonm 6 | let of_driver_exn = of_jsonm_exn 7 | let of_driver = of_jsonm 8 | let to_driver = to_jsonm 9 | let sexp_of_t : t -> Sexplib.Sexp.t = fun t -> 10 | Sexplib.Std.sexp_of_string (to_string_hum t) 11 | end 12 | module Unittest = Test.Unittest.Make (Driver) 13 | let () = Unittest.run () 14 | -------------------------------------------------------------------------------- /drivers/msgpack/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name protocol_conv_msgpack) 3 | (public_name ppx_protocol_conv_msgpack) 4 | (libraries ppx_protocol_conv.runtime ppx_protocol_conv.driver msgpck) 5 | (synopsis "msgpack (de)serialization driver for ppx_protocol_conv") 6 | ) 7 | -------------------------------------------------------------------------------- /drivers/msgpack/msgpack.ml: -------------------------------------------------------------------------------- 1 | module Driver : Ppx_protocol_driver.Driver with type t = Msgpck.t = struct 2 | type t = Msgpck.t 3 | 4 | let to_string_hum t = Format.asprintf "%a" Msgpck.pp t 5 | 6 | let of_list = Msgpck.of_list 7 | let to_list = Msgpck.to_list 8 | let is_list = function Msgpck.List _ -> true | _ -> false 9 | 10 | let of_alist alist = List.map (fun (k, v) -> Msgpck.of_string k, v) alist |> Msgpck.of_map 11 | let to_alist t = Msgpck.to_map t |> List.map (fun (k, v) -> (Msgpck.to_string k, v)) 12 | 13 | let is_alist = function Msgpck.Map _ -> true | _ -> false 14 | 15 | let to_int = function Msgpck.Int i -> i 16 | | Msgpck.Int32 i -> Int32.to_int i 17 | | Msgpck.Uint32 i -> Int32.to_int i 18 | | Msgpck.Int64 i -> Int64.to_int i 19 | | Msgpck.Uint64 i -> Int64.to_int i 20 | | _ -> failwith "int expected" 21 | 22 | let of_int = Msgpck.of_int 23 | 24 | let of_int32 = Msgpck.of_int32 25 | let to_int32 v = to_int v |> Int32.of_int 26 | 27 | let of_int64 = Msgpck.of_int64 28 | let to_int64 v = to_int v |> Int64.of_int 29 | 30 | let of_nativeint v = Nativeint.to_int v |> of_int 31 | let to_nativeint t = to_int t |> Nativeint.of_int 32 | 33 | let to_float = function Msgpck.Float f -> f 34 | | Msgpck.Float32 i -> Int32.float_of_bits i 35 | | _ -> failwith "float expected" 36 | let of_float = Msgpck.of_float 37 | 38 | let of_string = Msgpck.of_string 39 | let to_string = Msgpck.to_string 40 | let is_string = function Msgpck.String _ -> true | _ -> false 41 | 42 | let of_char c = of_string (String.make 1 c) 43 | let to_char t = match to_string t with 44 | | s when String.length s = 1 -> s.[0] 45 | | _ -> failwith "Got string with length != 1 when reading type 'char'" 46 | 47 | let of_bool = Msgpck.of_bool 48 | let to_bool = Msgpck.to_bool 49 | 50 | let of_bytes b = Bytes.to_string b |> Msgpck.of_bytes 51 | let to_bytes m = Msgpck.to_bytes m |> Bytes.of_string 52 | 53 | let null = Msgpck.Nil 54 | let is_null = function Msgpck.Nil -> true | _ -> false 55 | end 56 | include Ppx_protocol_driver.Make(Driver)(Ppx_protocol_driver.Default_parameters) 57 | module Make(P: Ppx_protocol_driver.Parameters) = Ppx_protocol_driver.Make(Driver)(P) 58 | 59 | type nonrec bytes = string 60 | let bytes_of_msgpack_exn = Msgpck.to_bytes 61 | let bytes_to_msgpack = Msgpck.of_bytes 62 | 63 | type uint32 = int 64 | let uint32_of_msgpack_exn t = Msgpck.to_uint32 t |> Int32.to_int 65 | let uint32_to_msgpack v = Int32.of_int v |> Msgpck.of_uint32 66 | 67 | type uint64 = int 68 | let uint64_of_msgpack_exn t = Msgpck.to_uint64 t |> Int64.to_int 69 | let uint64_to_msgpack v = Int64.of_int v |> Msgpck.of_uint64 70 | 71 | type float32 = float 72 | let float32_of_msgpack_exn t = Msgpck.to_float32 t |> Int32.float_of_bits 73 | let float32_to_msgpack v = Int32.bits_of_float v |> Msgpck.of_float32 74 | 75 | let of_msgpack_exn t = t 76 | let of_msgpack t = Ok t 77 | let to_msgpack t = t 78 | -------------------------------------------------------------------------------- /drivers/msgpack/msgpack.mli: -------------------------------------------------------------------------------- 1 | module Make(P: Ppx_protocol_driver.Parameters) : (Protocol_conv.Runtime.Driver with type t = Msgpck.t) 2 | include Protocol_conv.Runtime.Driver with type t = Msgpck.t 3 | 4 | val of_msgpack_exn: t -> t 5 | val of_msgpack: t -> (t, error) Protocol_conv.Runtime.result 6 | val to_msgpack: t -> t 7 | 8 | type bytes = string 9 | val bytes_of_msgpack_exn: t -> bytes 10 | val bytes_to_msgpack: bytes -> t 11 | 12 | type uint32 = int 13 | val uint32_of_msgpack_exn: t -> uint32 14 | val uint32_to_msgpack: uint32 -> t 15 | 16 | type uint64 = int 17 | val uint64_of_msgpack_exn: t -> uint64 18 | val uint64_to_msgpack: uint64 -> t 19 | 20 | type float32 = float 21 | val float32_of_msgpack_exn: t -> float32 22 | val float32_to_msgpack: float32 -> t 23 | -------------------------------------------------------------------------------- /drivers/msgpack/test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name unittest) 3 | (libraries test protocol_conv_msgpack sexplib) 4 | (preprocess (pps ppx_protocol_conv ppx_sexp_conv)) 5 | ) 6 | 7 | (rule 8 | (targets unittest.output) 9 | (deps unittest.exe) 10 | (action (run %{deps})) 11 | ) 12 | 13 | (alias 14 | (name runtest) 15 | (package ppx_protocol_conv_msgpack) 16 | (action (diff unittest.expected unittest.output)) 17 | ) 18 | -------------------------------------------------------------------------------- /drivers/msgpack/test/test_types.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Std 2 | open Protocol_conv_msgpack 3 | 4 | module Msgpack = struct 5 | include Msgpack 6 | let sexp_of_float32 = sexp_of_float 7 | let sexp_of_uint32 = sexp_of_int 8 | let sexp_of_uint64 = sexp_of_int 9 | let sexp_of_bytes = sexp_of_string 10 | end 11 | 12 | 13 | type t = { 14 | int: int; 15 | string: string; 16 | float: float; 17 | unit: unit; 18 | float32: Msgpack.float32; 19 | int32: int32; 20 | int64: int64; 21 | uint32: Msgpack.uint32; 22 | uint64: Msgpack.uint64; 23 | bytes: Msgpack.bytes; 24 | } 25 | [@@deriving protocol ~driver:(module Msgpack), sexp_of] 26 | 27 | let test_types () = 28 | let t = { 29 | int = 0; 30 | string = "a"; 31 | float = 0.0; 32 | unit = (); 33 | float32 = 0.0; 34 | int32 = Int32.one; 35 | int64 = Int64.one; 36 | uint32 = 0; 37 | uint64 = 0; 38 | bytes = "asd"; 39 | } 40 | in 41 | let m = to_msgpack t in 42 | let t' = of_msgpack_exn m in 43 | let fmt : t Fmt.t = fun formatter t -> 44 | Format.fprintf formatter "%s" (Base.Sexp.to_string_hum (sexp_of_t t)) 45 | in 46 | Alcotest.(check (of_pp fmt)) "Identity" t t'; 47 | () 48 | 49 | let tests = __MODULE__, [ Alcotest.test_case "Msgpack types" `Quick test_types; ] 50 | -------------------------------------------------------------------------------- /drivers/msgpack/test/unittest.expected: -------------------------------------------------------------------------------- 1 | === msgpack.SingleElem === 2 | [] 3 | === msgpack.SingleElem === 4 | [2] 5 | === msgpack.Longarray === 6 | [4, 2, 3, 1] 7 | === msgpack.EmptyInsideRec === 8 | {c: c, V: [], a: a} 9 | === msgpack.SingleInsideRec === 10 | {c: c, V: [2], a: a} 11 | === msgpack.MultiInsideRec === 12 | {c: c, V: [4, 2, 3, 1], a: a} 13 | === msgpack.ArrayOfArrays === 14 | {a: [[2, 3], [4, 5]]} 15 | === msgpack.ArrayOfArrays2 === 16 | [[], [[], [2], [3, 4]], [[]], [[2]]] 17 | === msgpack.Tuple === 18 | [[10, [20, 30, 40], [s50, s60, s70], [[100, 200], [300, 400], [500, 600]]], 19 | [11, [21, 31, 41], [s51, s61, s71], [[101, 201], [301, 401], [501, 601]]], 20 | [12, [22, 32, 42], [s52, s62, s72], [[102, 202], [302, 402], [502, 602]]], 21 | [13, [23, 33, 43], [s53, s63, s73], [[103, 203], [303, 403], [503, 603]]]] 22 | === msgpack.Any === 23 | {u: {ua: 7}, v: [B, [5, 6, 7], [10, 11, 12]], z: 101, record: 24 | {y: string, x: 5}, varray: 25 | [[B, [5, 6, 7], [10, 11, 12]], [B, [5, 6, 7], [10, 11, 12]], 26 | [B, [5, 6, 7], [10, 11, 12]]], vlist: 27 | [[B, [5, 6, 7], [10, 11, 12]], [B, [5, 6, 7], [10, 11, 12]], 28 | [B, [5, 6, 7], [10, 11, 12]]], tuple: [5, protocol, false], intref: 4, 29 | intoption: 100, intlist: [3, 4, 5], bytes: "bytes", string2: 1, string: 30 | string, float: 3.14, nativeint: 20, int64: 10L, int32: 5l, int: 2, char: x, 31 | bool: true} 32 | === msgpack.Record === 33 | {t_il: [1000, 1001, 1002], t_tl: 34 | [[100, 101, [s100, s101]], [110, 111, [s110, s111]], 35 | [120, 121, [s120, s121]], [130, 131, [s130, s131]], 36 | [140, 141, [s140, s141]]], t_t: [100, 101, [s100, s101]], t_i: 1000, t_bl: 37 | [], t_b: 38 | {b_al: 39 | [{a_string: s7, a_int: 7}, {a_string: s8, a_int: 8}, 40 | {a_string: s9, a_int: 9}], b_a: {a_string: s6, a_int: 6}, b_string: s5, 41 | b_int: 5}, t_al: 42 | [{a_string: s2, a_int: 2}, {a_string: s3, a_int: 3}, 43 | {a_string: s4, a_int: 4}], t_a: {a_string: s1, a_int: 1}} 44 | === msgpack.list === 45 | {a: [1, 2, 3]} 46 | === msgpack.Lists === 47 | {l: 48 | [[A, [1, 2, 3]], [B, [[1, 2], [3, 4, 5], [2]], [3, 1], 5], 49 | [C, [1, 2, 3], [3, 4, 5]]], c: [100, 101, 102, 103], b: 50 | [[8, 9], [10, 20, 30, 40]], a: [[1, 2, 3], [], [10, 20, 30, 40], [100, 101]]} 51 | === msgpack.array === 52 | {a: [1, 2, 3]} 53 | === msgpack.EmptyList === 54 | [] 55 | === msgpack.SingleElem === 56 | [2] 57 | === msgpack.Longlist === 58 | [4, 3, 2, 1] 59 | === msgpack.EmptyInsideRec === 60 | {c: c, V: [], a: a} 61 | === msgpack.SingleInsideRec === 62 | {c: c, V: [2], a: a} 63 | === msgpack.MultiInsideRec === 64 | {c: c, V: [4, 2, 3, 1], a: a} 65 | === msgpack.ListOfLists === 66 | {a: [[2, 3], [4, 5]]} 67 | === msgpack.ListOfLists2 === 68 | [[], [[], [2], [3, 4]], [[]], [[2]]] 69 | === msgpack.Nonrec === 70 | [A, [Cons, 4, [Cons, 3, Nil]]] 71 | === msgpack.Nonrec2 === 72 | [Cons, 4, [Cons, 3, Nil]] 73 | === msgpack.None === 74 | () 75 | === msgpack.Some None === 76 | {__option: ()} 77 | === msgpack.Some Some None === 78 | {__option: {__option: ()}} 79 | === msgpack.Some Some Some Unit === 80 | {__option: {__option: {__option: {__option: ()}}}} 81 | === msgpack.simple === 82 | 5 83 | === msgpack.record === 84 | {a: 5} 85 | === msgpack.multiple === 86 | [5, 5, true] 87 | === msgpack.reference === 88 | {a: {a: 5}} 89 | === msgpack.recursive === 90 | {c: {b: {a: 5}}} 91 | === msgpack.Simple === 92 | [A, [B, 5], [C, [6, 7]], [D, [8, 9]]] 93 | === msgpack.Tree === 94 | [Node, [[Node, [Leaf, 3, Leaf]], 10, Leaf]] 95 | === msgpack.MutualRecursion === 96 | [T1, [V, [T, [V, [V1, [V1, [V1, [V0, 5]]]]]]]] 97 | === msgpack.InsideRec === 98 | {c: c, V: A, a: a} 99 | === msgpack.RecordList === 100 | {objects: [{key: 1}, {key: 2}]} 101 | === msgpack.SimpleRecord === 102 | {HostId: SDsd, RequestId: sdfsd, Endpoint: (), Bucket: (), Message: Message, 103 | Code: Error} 104 | === msgpack.Test_sig === 105 | {x: [A, [[A, 7], 7, 7, [B, 0.7], 7]]} 106 | === msgpack.Test_sig2 === 107 | [1, 2., 3.0, (), [A, 1], {c: 3.0, b: 2., a: 1}, [A, 1]] 108 | === msgpack.S3 === 109 | {Contents: [{ETag: Etag, StorageClass: STANDARD}], Prefix: prefix} 110 | === msgpack.Types === 111 | {baz: 112 | {y_yd: [Variant_two1, 1], y_yc: [three, [100, 200, 300]], y_b: 113 | [two, [10, 20, 30]], y_a: 2}, bar: true, foo: 1} 114 | === msgpack.Some Some Some true === 115 | true 116 | === msgpack.Some Some None === 117 | {__option: {__option: ()}} 118 | === msgpack.Some None === 119 | {__option: ()} 120 | === msgpack.None === 121 | () 122 | === msgpack.Some Some Some true === 123 | {a: true} 124 | === msgpack.Some Some None === 125 | {a: {__option: {__option: ()}}} 126 | === msgpack.Some None === 127 | {a: {__option: ()}} 128 | === msgpack.None === 129 | {a: ()} 130 | === msgpack.unit option option list option option === 131 | [{__option: {__option: ()}}, {__option: ()}, ()] 132 | === msgpack.confuse deserialization by using reserved word === 133 | {o: {option: true}} 134 | === msgpack.Simple === 135 | [A, [B, 5], [C, 6, 7], [D, [8, 9]]] 136 | === msgpack.Tuple === 137 | [A, [3, 4]] 138 | === msgpack.Tree === 139 | [Node, [Node, Leaf, 3, Leaf], 10, Leaf] 140 | === msgpack.MutualRecursion === 141 | [T1, [V, [T, [V, [V1, [V1, [V1, [V0, 5]]]]]]]] 142 | === msgpack.InsideRec === 143 | {c: c, V: A, a: a} 144 | === msgpack.InlineRecord === 145 | [A, {a: a}] 146 | === msgpack.InlineRecord2 === 147 | [aa, {b: [aa, {b: [B, 5], A: a}], A: a}] 148 | === msgpack.Poly === 149 | [aaa, 5] 150 | === msgpack.Option.Ok === 151 | [Ok, 2] 152 | === msgpack.Option.Error === 153 | [Error, Error string] 154 | -------------------------------------------------------------------------------- /drivers/msgpack/test/unittest.ml: -------------------------------------------------------------------------------- 1 | module Driver = struct 2 | let serialize t = Msgpck.String.to_string t |> Bytes.to_string 3 | let deserialize t = Msgpck.String.read ~pos:0 t |> snd 4 | let name = "msgpack" 5 | include Protocol_conv_msgpack.Msgpack 6 | let of_driver_exn = of_msgpack_exn 7 | let of_driver = of_msgpack 8 | let to_driver = to_msgpack 9 | let sexp_of_t : t -> Sexplib.Sexp.t = fun t -> 10 | Sexplib.Std.sexp_of_string (to_string_hum t) 11 | end 12 | module Unittest = Test.Unittest.Make (Driver) 13 | let () = Unittest.run ~extra:[Test_types.tests] () 14 | -------------------------------------------------------------------------------- /drivers/xml_light/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name protocol_conv_xml) 3 | (public_name ppx_protocol_conv_xml_light) 4 | (flags :standard -w -3) 5 | (libraries ppx_protocol_conv.runtime ppx_protocol_conv.driver xml-light) 6 | (synopsis "xml-light (de)serialization driver for ppx_protocol_conv") 7 | ) 8 | -------------------------------------------------------------------------------- /drivers/xml_light/test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name unittest) 3 | (libraries test protocol_conv_xml) 4 | ) 5 | 6 | (rule 7 | (targets unittest.output) 8 | (deps unittest.exe) 9 | (action (run %{deps})) 10 | ) 11 | 12 | (alias 13 | (name runtest) 14 | (package ppx_protocol_conv_xml_light) 15 | (action (diff unittest.expected unittest.output)) 16 | ) 17 | -------------------------------------------------------------------------------- /drivers/xml_light/test/unittest.expected: -------------------------------------------------------------------------------- 1 | === xml_light.SingleElem === 2 | 3 | === xml_light.SingleElem === 4 | 5 |

2

6 | 7 | === xml_light.Longarray === 8 | 9 |

4

10 |

2

11 |

3

12 |

1

13 | 14 | === xml_light.EmptyInsideRec === 15 | 16 | c 17 | a 18 | 19 | === xml_light.SingleInsideRec === 20 | 21 | c 22 | 2 23 | a 24 | 25 | === xml_light.MultiInsideRec === 26 | 27 | c 28 | 4 29 | 2 30 | 3 31 | 1 32 | a 33 | 34 | === xml_light.ArrayOfArrays === 35 | 36 | 37 |

2

38 |

3

39 | 40 | 41 |

4

42 |

5

43 | 44 | 45 | === xml_light.ArrayOfArrays2 === 46 | 47 | 48 | 49 | 50 | 51 |

2

52 | 53 | 54 |

3

55 |

4

56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 |

2

64 | 65 | 66 | 67 | === xml_light.Tuple === 68 | 69 | 70 | 71 | 200 72 | 100 73 | 74 | 75 | 400 76 | 300 77 | 78 | 79 | 600 80 | 500 81 | 82 | s50 83 | s60 84 | s70 85 | 20 86 | 30 87 | 40 88 | 10 89 | 90 | 91 | 92 | 201 93 | 101 94 | 95 | 96 | 401 97 | 301 98 | 99 | 100 | 601 101 | 501 102 | 103 | s51 104 | s61 105 | s71 106 | 21 107 | 31 108 | 41 109 | 11 110 | 111 | 112 | 113 | 202 114 | 102 115 | 116 | 117 | 402 118 | 302 119 | 120 | 121 | 602 122 | 502 123 | 124 | s52 125 | s62 126 | s72 127 | 22 128 | 32 129 | 42 130 | 12 131 | 132 | 133 | 134 | 203 135 | 103 136 | 137 | 138 | 403 139 | 303 140 | 141 | 142 | 603 143 | 503 144 | 145 | s53 146 | s63 147 | s73 148 | 23 149 | 33 150 | 43 151 | 13 152 | 153 | 154 | === xml_light.Any === 155 | 156 | 157 | 7 158 | 159 | 160 | B 161 | 162 |

5

163 |

6

164 |

7

165 | 166 | 167 |

10

168 |

11

169 |

12

170 | 171 | 172 | 101 173 | 174 | string 175 | 5 176 | 177 | 178 | B 179 | 180 |

5

181 |

6

182 |

7

183 | 184 | 185 |

10

186 |

11

187 |

12

188 | 189 | 190 | 191 | B 192 | 193 |

5

194 |

6

195 |

7

196 | 197 | 198 |

10

199 |

11

200 |

12

201 | 202 | 203 | 204 | B 205 | 206 |

5

207 |

6

208 |

7

209 | 210 | 211 |

10

212 |

11

213 |

12

214 | 215 | 216 | 217 | B 218 | 219 |

5

220 |

6

221 |

7

222 | 223 | 224 |

10

225 |

11

226 |

12

227 | 228 | 229 | 230 | B 231 | 232 |

5

233 |

6

234 |

7

235 | 236 | 237 |

10

238 |

11

239 |

12

240 | 241 | 242 | 243 | B 244 | 245 |

5

246 |

6

247 |

7

248 | 249 | 250 |

10

251 |

11

252 |

12

253 | 254 | 255 | 256 | false 257 | protocol 258 | 5 259 | 260 | 4 261 | 100 262 | 3 263 | 4 264 | 5 265 | bytes 266 | 1 267 | string 268 | 3.14 269 | 20 270 | 10 271 | 5 272 | 2 273 | x 274 | true 275 | 276 | === xml_light.Record === 277 | 278 | 1000 279 | 1001 280 | 1002 281 | 282 | s100 283 | s101 284 | 101 285 | 100 286 | 287 | 288 | s110 289 | s111 290 | 111 291 | 110 292 | 293 | 294 | s120 295 | s121 296 | 121 297 | 120 298 | 299 | 300 | s130 301 | s131 302 | 131 303 | 130 304 | 305 | 306 | s140 307 | s141 308 | 141 309 | 140 310 | 311 | 312 | s100 313 | s101 314 | 101 315 | 100 316 | 317 | 1000 318 | 319 | 320 | s7 321 | 7 322 | 323 | 324 | s8 325 | 8 326 | 327 | 328 | s9 329 | 9 330 | 331 | 332 | s6 333 | 6 334 | 335 | s5 336 | 5 337 | 338 | 339 | s2 340 | 2 341 | 342 | 343 | s3 344 | 3 345 | 346 | 347 | s4 348 | 4 349 | 350 | 351 | s1 352 | 1 353 | 354 | 355 | === xml_light.list === 356 | 357 | 1 358 | 2 359 | 3 360 | 361 | === xml_light.Lists === 362 | 363 | 364 | A 365 | 366 |

1

367 |

2

368 |

3

369 | 370 | 371 | 372 | B 373 | 374 | 375 |

1

376 |

2

377 | 378 | 379 |

3

380 |

4

381 |

5

382 | 383 | 384 |

2

385 | 386 | 387 | 388 |

3

389 |

1

390 | 391 |

5

392 | 393 | 394 | C 395 | 396 |

1

397 |

2

398 |

3

399 | 400 | 401 |

3

402 |

4

403 |

5

404 | 405 | 406 | 100 407 | 101 408 | 102 409 | 103 410 | 411 | 10 412 | 20 413 | 30 414 | 40 415 | 8 416 | 9 417 | 418 | 419 |

1

420 |

2

421 |

3

422 | 423 | 424 | 425 |

10

426 |

20

427 |

30

428 |

40

429 | 430 | 431 |

100

432 |

101

433 | 434 | 435 | === xml_light.array === 436 | 437 | 1 438 | 2 439 | 3 440 | 441 | === xml_light.EmptyList === 442 | 443 | === xml_light.SingleElem === 444 | 445 |

2

446 | 447 | === xml_light.Longlist === 448 | 449 |

4

450 |

3

451 |

2

452 |

1

453 | 454 | === xml_light.EmptyInsideRec === 455 | 456 | c 457 | a 458 | 459 | === xml_light.SingleInsideRec === 460 | 461 | c 462 | 2 463 | a 464 | 465 | === xml_light.MultiInsideRec === 466 | 467 | c 468 | 4 469 | 2 470 | 3 471 | 1 472 | a 473 | 474 | === xml_light.ListOfLists === 475 | 476 | 477 |

2

478 |

3

479 | 480 | 481 |

4

482 |

5

483 | 484 | 485 | === xml_light.ListOfLists2 === 486 | 487 | 488 | 489 | 490 | 491 |

2

492 | 493 | 494 |

3

495 |

4

496 | 497 | 498 | 499 | 500 | 501 | 502 | 503 |

2

504 | 505 | 506 | 507 | === xml_light.Nonrec === 508 | 509 | A 510 | 511 | Cons 512 |

4

513 | 514 | Cons 515 |

3

516 | Nil 517 | 518 | 519 | 520 | === xml_light.Nonrec2 === 521 | 522 | Cons 523 |

4

524 | 525 | Cons 526 |

3

527 | Nil 528 | 529 | 530 | === xml_light.None === 531 | <__option/> 532 | === xml_light.Some None === 533 | <__option> 534 | <__option/> 535 | 536 | === xml_light.Some Some None === 537 | <__option> 538 | <__option> 539 | <__option/> 540 | 541 | 542 | === xml_light.Some Some Some Unit === 543 |

()

544 | === xml_light.simple === 545 |

5

546 | === xml_light.record === 547 | 548 | 5 549 | 550 | === xml_light.multiple === 551 | 552 | true 553 | 5 554 | 5 555 | 556 | === xml_light.reference === 557 | 558 | 559 | 5 560 | 561 | 562 | === xml_light.recursive === 563 | 564 | 565 | 566 | 5 567 | 568 | 569 | 570 | === xml_light.Simple === 571 | 572 | A 573 | 574 | B 575 |

5

576 | 577 | 578 | C 579 | 580 | 7 581 | 6 582 | 583 | 584 | 585 | D 586 | 587 | 9 588 | 8 589 | 590 | 591 | 592 | === xml_light.Tree === 593 | 594 | Node 595 | 596 | Leaf 597 | 10 598 | 599 | Node 600 | 601 | Leaf 602 | 3 603 | Leaf 604 | 605 | 606 | 607 | 608 | === xml_light.MutualRecursion === 609 | 610 | T1 611 | 612 | V 613 | 614 | T 615 | 616 | V 617 | 618 | V1 619 | 620 | V1 621 | 622 | V1 623 | 624 | V0 625 |

5

626 | 627 | 628 | 629 | 630 | 631 | 632 | 633 | 634 | === xml_light.InsideRec === 635 | 636 | c 637 | A 638 | a 639 | 640 | === xml_light.RecordList === 641 | 642 | 643 | 1 644 | 645 | 646 | 2 647 | 648 | 649 | === xml_light.SimpleRecord === 650 | 651 | SDsd 652 | sdfsd 653 | 654 | 655 | Message 656 | Error 657 | 658 | === xml_light.Test_sig === 659 | 660 | 661 | A 662 | 663 | 7 664 | 665 | B 666 |

0.7

667 | 668 | 7 669 | 7 670 | 671 | A 672 |

7

673 | 674 | 675 | 676 | 677 | === xml_light.Test_sig2 === 678 | 679 | 680 | A 681 |

1

682 | 683 | 684 | 3.0 685 | 2. 686 | 1 687 | 688 | 689 | A 690 |

1

691 | 692 | () 693 | 3.0 694 | 2. 695 | 1 696 | 697 | === xml_light.S3 === 698 | 699 | 700 | Etag 701 | STANDARD 702 | 703 | prefix 704 | 705 | === xml_light.Types === 706 | 707 | 708 | 709 | Variant_two1 710 |

1

711 | 712 | 713 | 100 714 | 200 715 | 300 716 | three 717 | 718 | 719 | 10 720 | 20 721 | 30 722 | two 723 | 724 | 2 725 | 726 | true 727 | 1 728 | 729 | === xml_light.Some Some Some true === 730 |

true

731 | === xml_light.Some Some None === 732 | <__option> 733 | <__option> 734 | <__option/> 735 | 736 | 737 | === xml_light.Some None === 738 | <__option> 739 | <__option/> 740 | 741 | === xml_light.None === 742 | <__option/> 743 | === xml_light.Some Some Some true === 744 | 745 | true 746 | 747 | === xml_light.Some Some None === 748 | 749 | 750 | <__option> 751 | <__option/> 752 | 753 | 754 | 755 | === xml_light.Some None === 756 | 757 | 758 | <__option/> 759 | 760 | 761 | === xml_light.None === 762 | 763 | 764 | 765 | === xml_light.unit option option list option option === 766 | 767 |

()

768 | <__option> 769 | <__option/> 770 | 771 | <__option/> 772 | 773 | === xml_light.confuse deserialization by using reserved word === 774 | 775 | 776 | 777 | 778 | 779 | === xml_light.Simple === 780 | 781 | A 782 | 783 | B 784 |

5

785 | 786 | 787 | C 788 |

6

789 |

7

790 | 791 | 792 | D 793 | 794 | 9 795 | 8 796 | 797 | 798 | 799 | === xml_light.Tuple === 800 | 801 | A 802 | 803 | 4 804 | 3 805 | 806 | 807 | === xml_light.Tree === 808 | 809 | Node 810 | 811 | Node 812 | Leaf 813 |

3

814 | Leaf 815 | 816 |

10

817 | Leaf 818 | 819 | === xml_light.MutualRecursion === 820 | 821 | T1 822 | 823 | V 824 | 825 | T 826 | 827 | V 828 | 829 | V1 830 | 831 | V1 832 | 833 | V1 834 | 835 | V0 836 |

5

837 | 838 | 839 | 840 | 841 | 842 | 843 | 844 | 845 | === xml_light.InsideRec === 846 | 847 | c 848 | A 849 | a 850 | 851 | === xml_light.InlineRecord === 852 | 853 | A 854 | 855 | a 856 | 857 | 858 | === xml_light.InlineRecord2 === 859 | 860 | aa 861 | 862 | 863 | aa 864 | 865 | 866 | B 867 |

5

868 | 869 | a 870 | 871 | 872 | a 873 | 874 | 875 | === xml_light.Poly === 876 | 877 | aaa 878 |

5

879 | 880 | === xml_light.Option.Ok === 881 | 882 | Ok 883 |

2

884 | 885 | === xml_light.Option.Error === 886 | 887 | Error 888 |

Error string

889 | 890 | -------------------------------------------------------------------------------- /drivers/xml_light/test/unittest.ml: -------------------------------------------------------------------------------- 1 | module Driver = struct 2 | let name = "xml_light" 3 | let serialize t = Xml.to_string t 4 | let deserialize s = Xml.parse_string s 5 | include Protocol_conv_xml.Xml_light 6 | let of_driver_exn = of_xml_light_exn 7 | let of_driver = of_xml_light 8 | let to_driver = to_xml_light 9 | let sexp_of_t : t -> Sexplib.Sexp.t = fun t -> 10 | Sexplib.Std.sexp_of_string (to_string_hum t) 11 | end 12 | module Unittest = Test.Unittest.Make(Driver) 13 | let () = Unittest.run () 14 | -------------------------------------------------------------------------------- /drivers/xml_light/xml_light.ml: -------------------------------------------------------------------------------- 1 | (* Xml driver for ppx_protocol_conv *) 2 | open StdLabels 3 | open Protocol_conv.Runtime 4 | module Helper = Protocol_conv.Runtime.Helper 5 | type t = Xml.xml 6 | 7 | type error = string * t option 8 | exception Protocol_error of error 9 | module StringMap = Map.Make(String) 10 | 11 | let make_error ?value msg = (msg, value) 12 | 13 | let to_string_hum xml = Xml.to_string_fmt xml 14 | 15 | let error_to_string_hum: error -> string = function 16 | | (s, Some t) -> Printf.sprintf "%s. T: '%s'" s (to_string_hum t) 17 | | (s, None) -> s 18 | 19 | (* Register exception printer *) 20 | let () = Printexc.register_printer (function 21 | | Protocol_error err -> Some (error_to_string_hum err) 22 | | _ -> None) 23 | 24 | let try_with: (t -> 'a) -> t -> ('a, error) result = fun f t -> 25 | match f t with 26 | | v -> Ok v 27 | | exception (Protocol_error e) -> Error e 28 | 29 | let raise_errorf t fmt = 30 | Stdlib.Printf.kprintf (fun s -> raise (Protocol_error (s, t))) fmt 31 | 32 | let wrap t f x = match f x with 33 | | v -> v 34 | | exception Helper.Protocol_error s -> raise (Protocol_error (s, Some t)) 35 | 36 | let element name t = Xml.Element (name, [], t) 37 | 38 | let record_to_xml assoc = 39 | List.map ~f:( 40 | function 41 | | (field, Xml.Element ("record", attrs, xs)) -> [Xml.Element (field, attrs, xs)] 42 | | (field, Xml.Element ("variant", attrs, xs)) -> [Xml.Element (field, attrs, xs)] 43 | | (field, Xml.Element ("__option", attrs, xs)) -> [Xml.Element (field, attrs, xs)] 44 | | (field, Xml.Element (_, _, xs)) -> 45 | List.map ~f:(function 46 | | Xml.Element(_, attrs, xs) -> Xml.Element(field, attrs, xs) 47 | | PCData _ as p -> Xml.Element(field, [], [p]) 48 | ) xs 49 | | (field, e) -> raise_errorf (Some e) "Must be an element: %s" field 50 | ) assoc 51 | |> List.concat |> element "record" 52 | 53 | 54 | let of_variant: string -> (t, 'a, t) Tuple_out.t -> 'a = fun spec -> 55 | let to_t name args = Xml.Element("variant", [], Xml.PCData name :: args) in 56 | Helper.of_variant to_t spec 57 | 58 | let to_variant: (t, 'a) Variant_in.t list -> t -> 'a = fun spec -> 59 | let f = Helper.to_variant spec in 60 | function 61 | | Xml.Element(_, _, Xml.PCData s :: es) as t -> 62 | wrap t (f s) es 63 | | Xml.Element(name, _, []) as t -> raise_errorf (Some t) "No contents for variant type: %s" name 64 | | t -> raise_errorf (Some t) "Wrong variant data" 65 | 66 | let of_record: type a. (t, a, t) Record_out.t -> a = fun spec -> 67 | Helper.of_record ~omit_default:false record_to_xml spec 68 | 69 | let to_record: (t, 'constr, 'b) Record_in.t -> 'constr -> t -> 'b = fun spec constr -> 70 | let rec inner: type constr b. (t, constr, b) Record_in.t -> string list = function 71 | | Record_in.Cons ((field, _, _), xs) -> field :: inner xs 72 | | Record_in.Nil -> [] 73 | in 74 | let fields = inner spec in 75 | (* Join all elements, including default empty ones *) 76 | let default_map = List.fold_left fields ~init:StringMap.empty ~f:(fun acc field -> StringMap.add field [] acc) in 77 | let f = Helper.to_record spec constr in 78 | function 79 | | Xml.Element (_, _, xs) as t -> 80 | let args = 81 | List.fold_left ~init:default_map 82 | ~f:(fun map -> function 83 | | (Xml.Element(name, _, _) as x) -> 84 | let v = match StringMap.find name map with 85 | | l -> x :: l 86 | | exception Not_found -> [x] 87 | in 88 | StringMap.add name v map 89 | | _ -> map 90 | ) xs 91 | |> (fun map -> StringMap.fold (fun key v acc -> (key, v) :: acc) map []) 92 | |> List.map ~f:(function 93 | | field, [ Xml.Element (name, attrs, xs) ] -> field, Xml.Element (name, ("record", "unwrapped") :: attrs, xs) 94 | | field, [ Xml.PCData _ as d ] -> field, d 95 | | field, xs -> field, Xml.Element (field, [], List.rev xs) 96 | ) 97 | in 98 | wrap t f args 99 | | t -> raise_errorf (Some t) "Expected record element" 100 | 101 | 102 | let of_tuple: (t, 'a, t) Tuple_out.t -> 'a = fun spec -> 103 | let rec inner: type a b c. int -> (a, b, c) Tuple_out.t -> (a, b, c) Record_out.t = fun i -> function 104 | | Tuple_out.Cons (f, xs) -> 105 | let tail = inner (i+1) xs in 106 | Record_out.Cons ( (Printf.sprintf "t%d" i, f, None), tail) 107 | | Tuple_out.Nil -> Record_out.Nil 108 | in 109 | of_record (inner 0 spec) 110 | 111 | let to_tuple: type constr b. (t, constr, b) Tuple_in.t -> constr -> t -> b = fun spec constr -> 112 | let rec inner: type a b c. int -> (a, b, c) Tuple_in.t -> (a, b, c) Record_in.t = fun i -> function 113 | | Tuple_in.Cons (f, xs) -> 114 | let tail = inner (i+1) xs in 115 | Record_in.Cons ( (Printf.sprintf "t%d" i, f, None), tail) 116 | | Tuple_in.Nil -> Record_in.Nil 117 | in 118 | let spec = inner 0 spec in 119 | let f = to_record spec constr in 120 | fun t -> wrap t f t 121 | 122 | let to_option: (t -> 'a) -> t -> 'a option = fun to_value_fun t -> 123 | match t with 124 | | Xml.Element (_, (_, "unwrapped") :: _, []) 125 | | Xml.Element (_, _, []) 126 | | Xml.Element (_, _, [ PCData ""] ) -> 127 | None 128 | | Xml.Element (_, (_, "unwrapped") :: _, [ (Element ("__option", _, _) as t)]) 129 | | Xml.Element ("__option", _, [t]) 130 | | t -> 131 | Some (to_value_fun t) 132 | 133 | let of_option: ('a -> t) -> 'a option -> t = fun of_value_fun v -> 134 | match v with 135 | | None -> 136 | Xml.Element ("__option", [], []) 137 | | Some x -> begin 138 | match of_value_fun x with 139 | | (Xml.Element ("__option", _, _) as t) -> 140 | Xml.Element ("__option", [], [t]) 141 | | t -> 142 | t 143 | end 144 | 145 | let to_ref: (t -> 'a) -> t -> 'a ref = fun to_value_fun t -> 146 | let v = to_value_fun t in 147 | ref v 148 | 149 | let of_ref: ('a -> t) -> 'a ref -> t = fun of_value_fun v -> 150 | of_value_fun !v 151 | 152 | let to_result: (t -> 'a) -> (t -> 'b) -> t -> ('a, 'b) result = fun to_ok to_err -> 153 | let ok = Tuple_in.(Cons (to_ok, Nil)) in 154 | let err = Tuple_in.(Cons (to_err, Nil)) in 155 | to_variant Variant_in.[Variant ("Ok", ok, fun v -> Ok v); Variant ("Error", err, fun v -> Error v)] 156 | 157 | let of_result: ('a -> t) -> ('b -> t) -> ('a, 'b) result -> t = fun of_ok of_err -> 158 | let of_ok = of_variant "Ok" Tuple_out.(Cons (of_ok, Nil)) in 159 | let of_err = of_variant "Error" Tuple_out.(Cons (of_err, Nil)) in 160 | function 161 | | Ok ok -> of_ok ok 162 | | Error err -> of_err err 163 | 164 | 165 | (** If the given list has been unwrapped since its part of a record, we "rewrap it". *) 166 | let to_list: (t -> 'a) -> t -> 'a list = fun to_value_fun -> function 167 | | Xml.Element (_, [_, "unwrapped"], _) as elm -> 168 | (* If the given list has been unwrapped since its part of a record, we "rewrap it". *) 169 | [ to_value_fun elm ] 170 | | Xml.Element (_, _, ts) -> 171 | Helper.list_map ~f:(fun t -> to_value_fun t) ts 172 | | e -> raise_errorf (Some e) "Must be an element type" 173 | 174 | let of_list: ('a -> t) -> 'a list -> t = fun of_value_fun vs -> 175 | Xml.Element("l", [], Helper.list_map ~f:(fun v -> of_value_fun v) vs) 176 | 177 | let to_array: (t -> 'a) -> t -> 'a array = fun to_value_fun t -> 178 | to_list to_value_fun t |> Array.of_list 179 | 180 | let of_array: ('a -> t) -> 'a array -> t = fun of_value_fun vs -> 181 | of_list of_value_fun (Array.to_list vs) 182 | 183 | let to_lazy_t: (t -> 'a) -> t -> 'a lazy_t = fun to_value_fun t -> Lazy.from_fun (fun () -> to_value_fun t) 184 | 185 | let of_lazy_t: ('a -> t) -> 'a lazy_t -> t = fun of_value_fun v -> 186 | Lazy.force v |> of_value_fun 187 | 188 | let of_value to_string v = Xml.Element ("p", [], [ Xml.PCData (to_string v) ]) 189 | let to_value type_name of_string t = 190 | let s = match t with 191 | | Xml.Element(_, _, []) -> "" 192 | | Xml.Element(_, _, [PCData s]) -> s 193 | | Xml.Element(name, _, _) as e -> raise_errorf (Some e) "Primitive value expected in node: %s for %s" name type_name 194 | | Xml.PCData _ as e -> raise_errorf (Some e) "Primitive type not expected here when deserializing %s" type_name 195 | in 196 | try of_string s with 197 | | _ -> raise_errorf (Some t) "Failed to convert element to %s." type_name 198 | 199 | let to_bool = to_value "bool" bool_of_string 200 | let of_bool = of_value string_of_bool 201 | 202 | let to_int = to_value "int" int_of_string 203 | let of_int = of_value string_of_int 204 | 205 | let to_int32 = to_value "int32" Int32.of_string 206 | let of_int32 = of_value Int32.to_string 207 | 208 | let to_int64 = to_value "int64" Int64.of_string 209 | let of_int64 = of_value Int64.to_string 210 | 211 | let to_float = to_value "float" float_of_string 212 | let of_float = of_value string_of_float 213 | 214 | let to_string = to_value "string" (fun x -> x) 215 | let of_string = of_value (fun x -> x) 216 | 217 | let to_char = to_value "char" (function s when String.length s = 1 -> s.[0] 218 | | s -> raise_errorf None "Expected char, got %s" s) 219 | let of_char = of_value (fun c -> (String.make 1 c)) 220 | 221 | let to_bytes = to_value "bytes" Bytes.of_string 222 | let of_bytes = of_value Bytes.to_string 223 | 224 | let to_unit = to_value "unit" (function "()" -> () | _ -> raise_errorf None "Expected char") 225 | let of_unit = of_value (fun () -> "()") 226 | 227 | let to_nativeint = to_value "nativeint" Nativeint.of_string 228 | let of_nativeint = of_value Nativeint.to_string 229 | 230 | let of_xml_light_exn: t -> t = 231 | function 232 | | Xml.Element (_v, (_, "unwrapped") :: (("__name"), v') :: xs, d) -> Xml.Element (v', xs, d) 233 | | Xml.Element (v, (_, "unwrapped") :: xs, d) -> Xml.Element (v, xs, d) 234 | | Xml.Element (_v, (("__name"), v') :: xs, d) -> Xml.Element (v', xs, d) 235 | | x -> x 236 | 237 | let of_xml_light t = Ok (of_xml_light_exn t) 238 | let to_xml_light: t -> t = function 239 | | Xml.Element (v, attrs, d) -> Xml.Element (v, ( "__name", v) :: attrs, d) 240 | | v -> v 241 | -------------------------------------------------------------------------------- /drivers/xml_light/xml_light.mli: -------------------------------------------------------------------------------- 1 | include Protocol_conv.Runtime.Driver with type t = Xml.xml 2 | 3 | val of_xml_light_exn: t -> t 4 | val of_xml_light: t -> (t, error) Protocol_conv.Runtime.result 5 | val to_xml_light: t -> t 6 | -------------------------------------------------------------------------------- /drivers/xmlm/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name protocol_conv_xmlm) 3 | (public_name ppx_protocol_conv_xmlm) 4 | (flags :standard -w -3) 5 | (libraries ppx_protocol_conv.runtime ppx_protocol_conv.driver ezxmlm) 6 | (synopsis "xmlm (de)serialization driver for ppx_protocol_conv") 7 | ) 8 | -------------------------------------------------------------------------------- /drivers/xmlm/test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name unittest) 3 | (libraries test protocol_conv_xmlm) 4 | ) 5 | 6 | (rule 7 | (targets unittest.output) 8 | (deps unittest.exe) 9 | (action (run %{deps})) 10 | ) 11 | 12 | (alias 13 | (name runtest) 14 | (package ppx_protocol_conv_xmlm) 15 | (action (diff unittest.expected unittest.output)) 16 | ) 17 | -------------------------------------------------------------------------------- /drivers/xmlm/test/unittest.expected: -------------------------------------------------------------------------------- 1 | === xmlm.SingleElem === 2 | 3 | === xmlm.SingleElem === 4 |

2

 5 | === xmlm.Longarray === 6 |

4

2

3

1

 7 | === xmlm.EmptyInsideRec === 8 | ca 9 | === xmlm.SingleInsideRec === 10 | c2a 11 | === xmlm.MultiInsideRec === 12 | c4231a 13 | === xmlm.ArrayOfArrays === 14 |

2

3

4

5

 15 | === xmlm.ArrayOfArrays2 === 16 |

2

3

4

2

 17 | === xmlm.Tuple === 18 | 200100400300600500s50s60s7020304010201101401301601501s51s61s7121314111202102402302602502s52s62s7222324212203103403303603503s53s63s7323334313 19 | === xmlm.Any === 20 | 7B

5

6

7

10

11

12

101string5B

5

6

7

10

11

12

B

5

6

7

10

11

12

B

5

6

7

10

11

12

B

5

6

7

10

11

12

B

5

6

7

10

11

12

B

5

6

7

10

11

12

falseprotocol54100345bytes1string3.14201052xtrue 21 | === xmlm.Record === 22 | 100010011002s100s101101100s110s111111110s120s121121120s130s131131130s140s141141140s100s1011011001000s77s88s99s66s55s22s33s44s11 23 | === xmlm.list === 24 | 123 25 | === xmlm.Lists === 26 | A

1

2

3

B

1

2

3

4

5

2

3

1

5

C

1

2

3

3

4

5

1001011021031020304089

1

2

3

10

20

30

40

100

101

 27 | === xmlm.array === 28 | 123 29 | === xmlm.EmptyList === 30 | 31 | === xmlm.SingleElem === 32 |

2

 33 | === xmlm.Longlist === 34 |

4

3

2

1

 35 | === xmlm.EmptyInsideRec === 36 | ca 37 | === xmlm.SingleInsideRec === 38 | c2a 39 | === xmlm.MultiInsideRec === 40 | c4231a 41 | === xmlm.ListOfLists === 42 |

2

3

4

5

 43 | === xmlm.ListOfLists2 === 44 |

2

3

4

2

 45 | === xmlm.Nonrec === 46 | ACons

4

Cons

3

Nil 47 | === xmlm.Nonrec2 === 48 | Cons

4

Cons

3

Nil 49 | === xmlm.None === 50 | <__option/> 51 | === xmlm.Some None === 52 | <__option><__option/> 53 | === xmlm.Some Some None === 54 | <__option><__option><__option/> 55 | === xmlm.Some Some Some Unit === 56 |

()

57 | === xmlm.simple === 58 |

5

59 | === xmlm.record === 60 | 5 61 | === xmlm.multiple === 62 | true55 63 | === xmlm.reference === 64 | 5 65 | === xmlm.recursive === 66 | 5 67 | === xmlm.Simple === 68 | AB

5

C76D98 69 | === xmlm.Tree === 70 | NodeLeaf10NodeLeaf3Leaf 71 | === xmlm.MutualRecursion === 72 | T1VTVV1V1V1V0

5

 73 | === xmlm.InsideRec === 74 | cAa 75 | === xmlm.RecordList === 76 | 12 77 | === xmlm.SimpleRecord === 78 | SDsdsdfsdMessageError 79 | === xmlm.Test_sig === 80 | A7B

0.7

77A

7

 81 | === xmlm.Test_sig2 === 82 | A

1

3.02.1A

1

()3.02.1 83 | === xmlm.S3 === 84 | EtagSTANDARDprefix 85 | === xmlm.Types === 86 | Variant_two1

1

100200300three102030two2true1 87 | === xmlm.Some Some Some true === 88 |

true

89 | === xmlm.Some Some None === 90 | <__option><__option><__option/> 91 | === xmlm.Some None === 92 | <__option><__option/> 93 | === xmlm.None === 94 | <__option/> 95 | === xmlm.Some Some Some true === 96 | true 97 | === xmlm.Some Some None === 98 | <__option><__option/> 99 | === xmlm.Some None === 100 | <__option/> 101 | === xmlm.None === 102 | 103 | === xmlm.unit option option list option option === 104 |

()

<__option><__option/><__option/> 105 | === xmlm.confuse deserialization by using reserved word === 106 | 107 | === xmlm.Simple === 108 | AB

5

C

6

7

D98 109 | === xmlm.Tuple === 110 | A43 111 | === xmlm.Tree === 112 | NodeNodeLeaf

3

Leaf

10

Leaf 113 | === xmlm.MutualRecursion === 114 | T1VTVV1V1V1V0

5

 115 | === xmlm.InsideRec === 116 | cAa 117 | === xmlm.InlineRecord === 118 | Aa 119 | === xmlm.InlineRecord2 === 120 | aaaaB

5

aa 121 | === xmlm.Poly === 122 | aaa

5

 123 | === xmlm.Option.Ok === 124 | Ok

2

 125 | === xmlm.Option.Error === 126 | Error

Error string

 127 | -------------------------------------------------------------------------------- /drivers/xmlm/test/unittest.ml: -------------------------------------------------------------------------------- 1 | module Driver = struct 2 | let name = "xmlm" 3 | let serialize t = Ezxmlm.to_string [t] 4 | let deserialize t = Ezxmlm.from_string t |> snd |> List.hd 5 | include Protocol_conv_xmlm.Xmlm 6 | let of_driver_exn = of_xmlm_exn 7 | let of_driver = of_xmlm 8 | let to_driver = to_xmlm 9 | let sexp_of_t : t -> Sexplib.Sexp.t = fun t -> 10 | Sexplib.Std.sexp_of_string (to_string_hum t) 11 | end 12 | module Unittest = Test.Unittest.Make(Driver) 13 | let () = Unittest.run() 14 | -------------------------------------------------------------------------------- /drivers/xmlm/xmlm.ml: -------------------------------------------------------------------------------- 1 | (* Xml driver for ppx_protocol_conv *) 2 | open StdLabels 3 | open Protocol_conv.Runtime 4 | module Helper = Protocol_conv.Runtime.Helper 5 | type t = Ezxmlm.node 6 | 7 | type error = string * t option 8 | exception Protocol_error of error 9 | module StringMap = Map.Make(String) 10 | 11 | let make_error ?value msg = (msg, value) 12 | 13 | let to_string_hum xml = Ezxmlm.to_string [xml] 14 | 15 | let error_to_string_hum: error -> string = function 16 | | (s, Some t) -> Printf.sprintf "%s. T: '%s'" s (to_string_hum t) 17 | | (s, None) -> s 18 | 19 | (* Register exception printer *) 20 | let () = Printexc.register_printer (function 21 | | Protocol_error err -> Some (error_to_string_hum err) 22 | | _ -> None) 23 | 24 | let try_with: (t -> 'a) -> t -> ('a, error) result = fun f t -> 25 | match f t with 26 | | v -> Ok v 27 | | exception (Protocol_error e) -> Error e 28 | 29 | let raise_errorf t fmt = 30 | Printf.kprintf (fun s -> raise (Protocol_error (s, t))) fmt 31 | 32 | let wrap t f x = match f x with 33 | | v -> v 34 | | exception Helper.Protocol_error s -> raise (Protocol_error (s, Some t)) 35 | 36 | let element name t = Ezxmlm.make_tag name ([], t) 37 | 38 | let record_to_xml (assoc:(string * t) list) = 39 | List.map ~f:( 40 | function 41 | | (field, `El (((_,"record"), attrs), xs)) -> [`El ((("",field), attrs), xs)] 42 | | (field, `El (((_,"variant"), attrs), xs)) -> [`El ((("",field), attrs), xs)] 43 | | (field, `El (((_,"__option"), attrs), xs)) -> [`El ((("",field), attrs), xs)] 44 | | (field, `El (((_,_), _), xs)) -> 45 | List.map ~f:(function 46 | | `El (((_,_), attrs), xs) -> `El ((("",field), attrs), xs) 47 | | `Data _ as p -> `El ((("",field), []), [p]) 48 | ) xs 49 | | (field, e) -> raise_errorf (Some e) "Must be an element: %s" field 50 | ) assoc 51 | |> List.concat |> element "record" 52 | 53 | let of_variant: string -> (t, 'a, t) Tuple_out.t -> 'a = fun spec -> 54 | let to_t name args = `El ((("","variant"), []), `Data name :: args) in 55 | Helper.of_variant to_t spec 56 | 57 | let to_variant: (t, 'a) Variant_in.t list -> t -> 'a = fun spec -> 58 | let f = Helper.to_variant spec in 59 | function 60 | | `El (((_, _), _), (`Data s) :: es) as t -> 61 | wrap t (f s) es 62 | | `El (((_, name), _), []) as t -> raise_errorf (Some t) "No contents for variant type: %s" name 63 | | t -> raise_errorf (Some t) "Wrong variant data" 64 | 65 | let of_record: type a. (t, a, t) Record_out.t -> a = fun spec -> 66 | Helper.of_record ~omit_default:false record_to_xml spec 67 | 68 | let to_record: (t, 'constr, 'b) Record_in.t -> 'constr -> t -> 'b = fun spec constr -> 69 | let rec inner: type constr b. (t, constr, b) Record_in.t -> string list = function 70 | | Record_in.Cons ((field, _, _), xs) -> field :: inner xs 71 | | Record_in.Nil -> [] 72 | in 73 | let fields = inner spec in 74 | (* Join all elements, including default empty ones *) 75 | let default_map = List.fold_left fields ~init:StringMap.empty ~f:(fun acc field -> StringMap.add field [] acc) in 76 | let f = Helper.to_record spec constr in 77 | function 78 | | `El (((_,_), _), xs) as t -> 79 | let args = 80 | List.fold_left ~init:default_map 81 | ~f:(fun map -> function 82 | | `El (((_,name), _), _) as x -> 83 | let v = match StringMap.find name map with 84 | | l -> x :: l 85 | | exception Not_found -> [x] 86 | in 87 | StringMap.add name v map 88 | | _ -> map 89 | ) xs 90 | |> (fun map -> StringMap.fold (fun key v acc -> (key, v) :: acc) map []) 91 | |> List.map ~f:(function 92 | | (field, [ `El (((_, name), attrs), xs) ]) -> (field, `El ((("",name), (("","record"), "unwrapped") :: attrs), xs)) 93 | | (field, [ `Data _ as d ]) -> (field, d) 94 | | (field, xs) -> (field, `El ((("",field), []), List.rev xs)) 95 | ) 96 | in 97 | wrap t f args 98 | | t -> raise_errorf (Some t) "Expected record element" 99 | 100 | 101 | let of_tuple: (t, 'a, t) Tuple_out.t -> 'a = fun spec -> 102 | let rec inner: type a b c. int -> (a, b, c) Tuple_out.t -> (a, b, c) Record_out.t = fun i -> function 103 | | Tuple_out.Cons (f, xs) -> 104 | let tail = inner (i+1) xs in 105 | Record_out.Cons ( (Printf.sprintf "t%d" i, f, None), tail) 106 | | Tuple_out.Nil -> Record_out.Nil 107 | in 108 | of_record (inner 0 spec) 109 | 110 | let to_tuple: type constr b. (t, constr, b) Tuple_in.t -> constr -> t -> b = fun spec constr -> 111 | let rec inner: type a b c. int -> (a, b, c) Tuple_in.t -> (a, b, c) Record_in.t = fun i -> function 112 | | Tuple_in.Cons (f, xs) -> 113 | let tail = inner (i+1) xs in 114 | Record_in.Cons ( (Printf.sprintf "t%d" i, f, None), tail) 115 | | Tuple_in.Nil -> Record_in.Nil 116 | in 117 | let spec = inner 0 spec in 118 | let f = to_record spec constr in 119 | fun t -> wrap t f t 120 | 121 | let to_option: (t -> 'a) -> t -> 'a option = fun to_value_fun t -> 122 | match t with 123 | | (`El (((_,_), ((_,_), "unwrapped") :: _), [])) 124 | | (`El (((_,_), _), [])) 125 | | (`El (((_,_), _), [ `Data "" ] )) -> 126 | None 127 | | (`El (((_,_), ((_,_), "unwrapped") :: _), [ (`El ((((_,"__option"), _), _)) as t)])) 128 | | (`El (((_,"__option"), _), [t])) 129 | | t -> 130 | Some (to_value_fun t) 131 | 132 | let of_option: ('a -> t) -> 'a option -> t = fun of_value_fun v -> 133 | match v with 134 | | None -> 135 | (`El ((("","__option"), []), [])) 136 | | Some x -> begin 137 | match of_value_fun x with 138 | | (`El (((_,"__option"), _), _) as t) -> 139 | (`El ((("","__option"), []), [t])) 140 | | t -> 141 | t 142 | end 143 | 144 | let to_ref: (t -> 'a) -> t -> 'a ref = fun to_value_fun t -> 145 | let v = to_value_fun t in 146 | ref v 147 | 148 | let of_ref: ('a -> t) -> 'a ref -> t = fun of_value_fun v -> 149 | of_value_fun !v 150 | 151 | let to_result: (t -> 'a) -> (t -> 'b) -> t -> ('a, 'b) result = fun to_ok to_err -> 152 | let ok = Tuple_in.(Cons (to_ok, Nil)) in 153 | let err = Tuple_in.(Cons (to_err, Nil)) in 154 | to_variant Variant_in.[Variant ("Ok", ok, fun v -> Ok v); Variant ("Error", err, fun v -> Error v)] 155 | 156 | let of_result: ('a -> t) -> ('b -> t) -> ('a, 'b) result -> t = fun of_ok of_err -> 157 | let of_ok = of_variant "Ok" Tuple_out.(Cons (of_ok, Nil)) in 158 | let of_err = of_variant "Error" Tuple_out.(Cons (of_err, Nil)) in 159 | function 160 | | Ok ok -> of_ok ok 161 | | Error err -> of_err err 162 | 163 | (** If the given list has been unwrapped since its part of a record, we "rewrap it". *) 164 | let to_list: (t -> 'a) -> t -> 'a list = fun to_value_fun -> function 165 | | (`El ((_, (_, "unwrapped") :: _), _)) as elm -> 166 | (* If the given list has been unwrapped since its part of a record, we "rewrap it". *) 167 | [ to_value_fun elm ] 168 | | (`El ((_, _), ts)) -> 169 | Helper.list_map ~f:(fun t -> to_value_fun t) ts 170 | | e -> raise_errorf (Some e) "Must be an element type" 171 | 172 | let of_list: ('a -> t) -> 'a list -> t = fun of_value_fun vs -> 173 | (`El ((("","l"), []), Helper.list_map ~f:(fun v -> of_value_fun v) vs)) 174 | 175 | let to_array: (t -> 'a) -> t -> 'a array = fun to_value_fun t -> 176 | to_list to_value_fun t |> Array.of_list 177 | 178 | let of_array: ('a -> t) -> 'a array -> t = fun of_value_fun vs -> 179 | of_list of_value_fun (Array.to_list vs) 180 | 181 | let to_lazy_t: (t -> 'a) -> t -> 'a lazy_t = fun to_value_fun t -> Lazy.from_fun (fun () -> to_value_fun t) 182 | 183 | let of_lazy_t: ('a -> t) -> 'a lazy_t -> t = fun of_value_fun v -> 184 | Lazy.force v |> of_value_fun 185 | 186 | let of_value to_string v = (`El ((("","p"), []), [ `Data (to_string v) ])) 187 | 188 | let to_value type_name of_string t = 189 | let s = match t with 190 | | (`El ((_, _), [])) -> "" 191 | | (`El ((_, _), [`Data s])) -> s 192 | | (`El (((_,name), _), _)) as e -> raise_errorf (Some e) "Primitive value expected in node: %s for %s" name type_name 193 | | `Data _ as e -> raise_errorf (Some e) "Primitive type not expected here when deserializing %s" type_name 194 | in 195 | try of_string s with 196 | | _ -> raise_errorf (Some t) "Failed to convert element to %s." type_name 197 | 198 | let to_bool = to_value "bool" bool_of_string 199 | let of_bool = of_value string_of_bool 200 | 201 | let to_int = to_value "int" int_of_string 202 | let of_int = of_value string_of_int 203 | 204 | let to_int32 = to_value "int32" Int32.of_string 205 | let of_int32 = of_value Int32.to_string 206 | 207 | let to_int64 = to_value "int64" Int64.of_string 208 | let of_int64 = of_value Int64.to_string 209 | 210 | let to_float = to_value "float" float_of_string 211 | let of_float = of_value string_of_float 212 | 213 | let to_string = to_value "string" (fun x -> x) 214 | let of_string = of_value (fun x -> x) 215 | 216 | let to_char = to_value "char" (function s when String.length s = 1 -> s.[0] 217 | | s -> raise_errorf None "Expected char, got %s" s) 218 | let of_char = of_value (fun c -> (String.make 1 c)) 219 | 220 | let to_bytes = to_value "bytes" Bytes.of_string 221 | let of_bytes = of_value Bytes.to_string 222 | 223 | let to_unit = to_value "unit" (function "()" -> () | _ -> raise_errorf None "Expected unit") 224 | let of_unit = of_value (fun () -> "()") 225 | 226 | let to_nativeint = to_value "nativeint" Nativeint.of_string 227 | let of_nativeint = of_value Nativeint.to_string 228 | 229 | let of_xmlm_exn: t -> t = 230 | function 231 | | (`El ((_v, (_, "unwrapped") :: ((_, "__name"), v') :: xs), d)) -> (`El ((("", v'), xs), d)) 232 | | (`El ((v, (_, "unwrapped") :: xs), d)) -> (`El ((v, xs), d)) 233 | | (`El ((_v, ((_, "__name"), v') :: xs), d)) -> (`El ((("", v'), xs), d)) 234 | | x -> x 235 | 236 | let of_xmlm t = Ok (of_xmlm_exn t) 237 | let to_xmlm: t -> t = function 238 | | (`El ((v, attrs), d)) -> (`El ((v, (("", "__name"), snd v) :: attrs), d)) 239 | | v -> v 240 | -------------------------------------------------------------------------------- /drivers/xmlm/xmlm.mli: -------------------------------------------------------------------------------- 1 | include Protocol_conv.Runtime.Driver with type t = Ezxmlm.node 2 | 3 | val of_xmlm_exn: t -> t 4 | val of_xmlm: t -> (t, error) Protocol_conv.Runtime.result 5 | val to_xmlm: t -> t 6 | -------------------------------------------------------------------------------- /drivers/yaml/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name protocol_conv_yaml) 3 | (public_name ppx_protocol_conv_yaml) 4 | (libraries ppx_protocol_conv.runtime ppx_protocol_conv.driver global) 5 | (synopsis "yaml (de)serialization driver for ppx_protocol_conv") 6 | ) 7 | -------------------------------------------------------------------------------- /drivers/yaml/global/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name global) 3 | (public_name ppx_protocol_conv_yaml.lib) 4 | (libraries yaml) 5 | ) 6 | -------------------------------------------------------------------------------- /drivers/yaml/global/global.ml: -------------------------------------------------------------------------------- 1 | module Yaml = Yaml 2 | -------------------------------------------------------------------------------- /drivers/yaml/test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name unittest) 3 | (libraries test ppx_protocol_conv_yaml) 4 | ) 5 | 6 | (rule 7 | (targets unittest.output) 8 | (deps unittest.exe) 9 | (action (run %{deps})) 10 | ) 11 | 12 | (alias 13 | (name runtest) 14 | (package ppx_protocol_conv_yaml) 15 | (action (diff unittest.expected unittest.output)) 16 | ) 17 | -------------------------------------------------------------------------------- /drivers/yaml/test/unittest.expected: -------------------------------------------------------------------------------- 1 | === yaml.SingleElem === 2 | [] 3 | 4 | === yaml.SingleElem === 5 | - 2 6 | 7 | === yaml.Longarray === 8 | - 4 9 | - 2 10 | - 3 11 | - 1 12 | 13 | === yaml.EmptyInsideRec === 14 | c: c 15 | V: [] 16 | a: a 17 | 18 | === yaml.SingleInsideRec === 19 | c: c 20 | V: 21 | - 2 22 | a: a 23 | 24 | === yaml.MultiInsideRec === 25 | c: c 26 | V: 27 | - 4 28 | - 2 29 | - 3 30 | - 1 31 | a: a 32 | 33 | === yaml.ArrayOfArrays === 34 | a: 35 | - - 2 36 | - 3 37 | - - 4 38 | - 5 39 | 40 | === yaml.ArrayOfArrays2 === 41 | - [] 42 | - - [] 43 | - - 2 44 | - - 3 45 | - 4 46 | - - [] 47 | - - - 2 48 | 49 | === yaml.Tuple === 50 | - - 10 51 | - - 20 52 | - 30 53 | - 40 54 | - - s50 55 | - s60 56 | - s70 57 | - - - 100 58 | - 200 59 | - - 300 60 | - 400 61 | - - 500 62 | - 600 63 | - - 11 64 | - - 21 65 | - 31 66 | - 41 67 | - - s51 68 | - s61 69 | - s71 70 | - - - 101 71 | - 201 72 | - - 301 73 | - 401 74 | - - 501 75 | - 601 76 | - - 12 77 | - - 22 78 | - 32 79 | - 42 80 | - - s52 81 | - s62 82 | - s72 83 | - - - 102 84 | - 202 85 | - - 302 86 | - 402 87 | - - 502 88 | - 602 89 | - - 13 90 | - - 23 91 | - 33 92 | - 43 93 | - - s53 94 | - s63 95 | - s73 96 | - - - 103 97 | - 203 98 | - - 303 99 | - 403 100 | - - 503 101 | - 603 102 | 103 | === yaml.Any === 104 | u: 105 | ua: 7 106 | v: 107 | - B 108 | - - 5 109 | - 6 110 | - 7 111 | - - 10 112 | - 11 113 | - 12 114 | z: 101 115 | record: 116 | "y": string 117 | x: 5 118 | varray: 119 | - - B 120 | - - 5 121 | - 6 122 | - 7 123 | - - 10 124 | - 11 125 | - 12 126 | - - B 127 | - - 5 128 | - 6 129 | - 7 130 | - - 10 131 | - 11 132 | - 12 133 | - - B 134 | - - 5 135 | - 6 136 | - 7 137 | - - 10 138 | - 11 139 | - 12 140 | vlist: 141 | - - B 142 | - - 5 143 | - 6 144 | - 7 145 | - - 10 146 | - 11 147 | - 12 148 | - - B 149 | - - 5 150 | - 6 151 | - 7 152 | - - 10 153 | - 11 154 | - 12 155 | - - B 156 | - - 5 157 | - 6 158 | - 7 159 | - - 10 160 | - 11 161 | - 12 162 | tuple: 163 | - 5 164 | - protocol 165 | - false 166 | intref: 4 167 | intoption: 100 168 | intlist: 169 | - 3 170 | - 4 171 | - 5 172 | bytes: bytes 173 | string2: "1" 174 | string: string 175 | float: 3.14 176 | nativeint: 20 177 | int64: 10 178 | int32: 5 179 | int: 2 180 | char: x 181 | bool: true 182 | 183 | === yaml.Record === 184 | t_il: 185 | - 1000 186 | - 1001 187 | - 1002 188 | t_tl: 189 | - - 100 190 | - 101 191 | - - s100 192 | - s101 193 | - - 110 194 | - 111 195 | - - s110 196 | - s111 197 | - - 120 198 | - 121 199 | - - s120 200 | - s121 201 | - - 130 202 | - 131 203 | - - s130 204 | - s131 205 | - - 140 206 | - 141 207 | - - s140 208 | - s141 209 | t_t: 210 | - 100 211 | - 101 212 | - - s100 213 | - s101 214 | t_i: 1000 215 | t_bl: [] 216 | t_b: 217 | b_al: 218 | - a_string: s7 219 | a_int: 7 220 | - a_string: s8 221 | a_int: 8 222 | - a_string: s9 223 | a_int: 9 224 | b_a: 225 | a_string: s6 226 | a_int: 6 227 | b_string: s5 228 | b_int: 5 229 | t_al: 230 | - a_string: s2 231 | a_int: 2 232 | - a_string: s3 233 | a_int: 3 234 | - a_string: s4 235 | a_int: 4 236 | t_a: 237 | a_string: s1 238 | a_int: 1 239 | 240 | === yaml.list === 241 | a: 242 | - 1 243 | - 2 244 | - 3 245 | 246 | === yaml.Lists === 247 | l: 248 | - - A 249 | - - 1 250 | - 2 251 | - 3 252 | - - B 253 | - - - 1 254 | - 2 255 | - - 3 256 | - 4 257 | - 5 258 | - - 2 259 | - - 3 260 | - 1 261 | - 5 262 | - - C 263 | - - 1 264 | - 2 265 | - 3 266 | - - 3 267 | - 4 268 | - 5 269 | c: 270 | - 100 271 | - 101 272 | - 102 273 | - 103 274 | b: 275 | - - 8 276 | - 9 277 | - - 10 278 | - 20 279 | - 30 280 | - 40 281 | a: 282 | - - 1 283 | - 2 284 | - 3 285 | - [] 286 | - - 10 287 | - 20 288 | - 30 289 | - 40 290 | - - 100 291 | - 101 292 | 293 | === yaml.array === 294 | a: 295 | - 1 296 | - 2 297 | - 3 298 | 299 | === yaml.EmptyList === 300 | [] 301 | 302 | === yaml.SingleElem === 303 | - 2 304 | 305 | === yaml.Longlist === 306 | - 4 307 | - 3 308 | - 2 309 | - 1 310 | 311 | === yaml.EmptyInsideRec === 312 | c: c 313 | V: [] 314 | a: a 315 | 316 | === yaml.SingleInsideRec === 317 | c: c 318 | V: 319 | - 2 320 | a: a 321 | 322 | === yaml.MultiInsideRec === 323 | c: c 324 | V: 325 | - 4 326 | - 2 327 | - 3 328 | - 1 329 | a: a 330 | 331 | === yaml.ListOfLists === 332 | a: 333 | - - 2 334 | - 3 335 | - - 4 336 | - 5 337 | 338 | === yaml.ListOfLists2 === 339 | - [] 340 | - - [] 341 | - - 2 342 | - - 3 343 | - 4 344 | - - [] 345 | - - - 2 346 | 347 | === yaml.Nonrec === 348 | - A 349 | - - Cons 350 | - 4 351 | - - Cons 352 | - 3 353 | - Nil 354 | 355 | === yaml.Nonrec2 === 356 | - Cons 357 | - 4 358 | - - Cons 359 | - 3 360 | - Nil 361 | 362 | === yaml.None === 363 | 364 | 365 | === yaml.Some None === 366 | __option: 367 | 368 | === yaml.Some Some None === 369 | __option: 370 | __option: 371 | 372 | === yaml.Some Some Some Unit === 373 | __option: 374 | __option: 375 | __option: 376 | __option: 377 | 378 | === yaml.simple === 379 | 5 380 | 381 | === yaml.record === 382 | a: 5 383 | 384 | === yaml.multiple === 385 | - 5 386 | - "5" 387 | - true 388 | 389 | === yaml.reference === 390 | a: 391 | a: 5 392 | 393 | === yaml.recursive === 394 | c: 395 | b: 396 | a: 5 397 | 398 | === yaml.Simple === 399 | - A 400 | - - B 401 | - 5 402 | - - C 403 | - - 6 404 | - 7 405 | - - D 406 | - - 8 407 | - 9 408 | 409 | === yaml.Tree === 410 | - Node 411 | - - - Node 412 | - - Leaf 413 | - 3 414 | - Leaf 415 | - 10 416 | - Leaf 417 | 418 | === yaml.MutualRecursion === 419 | - T1 420 | - - V 421 | - - T 422 | - - V 423 | - - V1 424 | - - V1 425 | - - V1 426 | - - V0 427 | - 5 428 | 429 | === yaml.InsideRec === 430 | c: c 431 | V: A 432 | a: a 433 | 434 | === yaml.RecordList === 435 | objects: 436 | - key: 1 437 | - key: 2 438 | 439 | === yaml.SimpleRecord === 440 | HostId: SDsd 441 | RequestId: sdfsd 442 | Endpoint: 443 | Bucket: 444 | Message: Message 445 | Code: Error 446 | 447 | === yaml.Test_sig === 448 | x: 449 | - A 450 | - - - A 451 | - 7 452 | - 7 453 | - 7 454 | - - B 455 | - 0.7 456 | - 7 457 | 458 | === yaml.Test_sig2 === 459 | - 1 460 | - 2 461 | - "3.0" 462 | - 463 | - - A 464 | - 1 465 | - c: "3.0" 466 | b: 2 467 | a: 1 468 | - - A 469 | - 1 470 | 471 | === yaml.S3 === 472 | Contents: 473 | - ETag: Etag 474 | StorageClass: STANDARD 475 | Prefix: prefix 476 | 477 | === yaml.Types === 478 | baz: 479 | y_yd: 480 | - Variant_two1 481 | - 1 482 | y_yc: 483 | - three 484 | - - 100 485 | - 200 486 | - 300 487 | y_b: 488 | - two 489 | - - 10 490 | - 20 491 | - 30 492 | y_a: 2 493 | bar: "true" 494 | foo: 1 495 | 496 | === yaml.Some Some Some true === 497 | true 498 | 499 | === yaml.Some Some None === 500 | __option: 501 | __option: 502 | 503 | === yaml.Some None === 504 | __option: 505 | 506 | === yaml.None === 507 | 508 | 509 | === yaml.Some Some Some true === 510 | a: true 511 | 512 | === yaml.Some Some None === 513 | a: 514 | __option: 515 | __option: 516 | 517 | === yaml.Some None === 518 | a: 519 | __option: 520 | 521 | === yaml.None === 522 | a: 523 | 524 | === yaml.unit option option list option option === 525 | - __option: 526 | __option: 527 | - __option: 528 | - 529 | 530 | === yaml.confuse deserialization by using reserved word === 531 | o: 532 | option: true 533 | 534 | === yaml.Simple === 535 | - A 536 | - - B 537 | - 5 538 | - - C 539 | - 6 540 | - 7 541 | - - D 542 | - - 8 543 | - 9 544 | 545 | === yaml.Tuple === 546 | - A 547 | - - 3 548 | - 4 549 | 550 | === yaml.Tree === 551 | - Node 552 | - - Node 553 | - Leaf 554 | - 3 555 | - Leaf 556 | - 10 557 | - Leaf 558 | 559 | === yaml.MutualRecursion === 560 | - T1 561 | - - V 562 | - - T 563 | - - V 564 | - - V1 565 | - - V1 566 | - - V1 567 | - - V0 568 | - 5 569 | 570 | === yaml.InsideRec === 571 | c: c 572 | V: A 573 | a: a 574 | 575 | === yaml.InlineRecord === 576 | - A 577 | - a: a 578 | 579 | === yaml.InlineRecord2 === 580 | - aa 581 | - b: 582 | - aa 583 | - b: 584 | - B 585 | - 5 586 | A: a 587 | A: a 588 | 589 | === yaml.Poly === 590 | - aaa 591 | - 5 592 | 593 | === yaml.Option.Ok === 594 | - Ok 595 | - 2 596 | 597 | === yaml.Option.Error === 598 | - Error 599 | - Error string 600 | 601 | -------------------------------------------------------------------------------- /drivers/yaml/test/unittest.ml: -------------------------------------------------------------------------------- 1 | module Driver = struct 2 | let name = "yaml" 3 | let serialize t = Yaml.to_string_exn t 4 | let deserialize t = Yaml.of_string_exn t 5 | include Protocol_conv_yaml.Yaml 6 | let of_driver_exn = of_yaml_exn 7 | let of_driver = of_yaml 8 | let to_driver = to_yaml 9 | let sexp_of_t : t -> Sexplib.Sexp.t = fun t -> 10 | Sexplib.Std.sexp_of_string (to_string_hum t) 11 | end 12 | module Unittest = Test.Unittest.Make (Driver) 13 | let () = Unittest.run () 14 | -------------------------------------------------------------------------------- /drivers/yaml/yaml.ml: -------------------------------------------------------------------------------- 1 | module Yaml = Global.Yaml 2 | module Driver : Ppx_protocol_driver.Driver with type t = Yaml.value = struct 3 | type t = Yaml.value 4 | let to_string_hum t = Format.asprintf "%a" Yaml.pp t 5 | 6 | let of_list l = `A l 7 | let to_list = function `A l -> l | _ -> failwith "List expected" 8 | let is_list = function `A _ -> true | _ -> false 9 | 10 | let of_alist a = `O a 11 | let to_alist = function `O a -> a | _ -> failwith "Object expected" 12 | let is_alist = function `O _ -> true | _ -> false 13 | 14 | let of_int i = `Float (float_of_int i) 15 | let to_int = function 16 | | `Float f -> begin match modf f with 17 | | (f, i) when f <= epsilon_float -> int_of_float i 18 | | _ -> failwith "Int expected, got float" 19 | end 20 | | _ -> failwith "Int expected" 21 | 22 | let of_int32 i = Int32.to_int i |> of_int 23 | let to_int32 t = to_int t |> Int32.of_int 24 | 25 | let of_int64 i = Int64.to_int i |> of_int 26 | let to_int64 t = to_int t |> Int64.of_int 27 | 28 | let of_nativeint v = Nativeint.to_int v |> of_int 29 | let to_nativeint t = to_int t |> Nativeint.of_int 30 | 31 | let of_float f = `Float f 32 | let to_float = function `Float f -> f 33 | | _ -> failwith "Float expected" 34 | 35 | let of_string s = `String s 36 | let to_string = function `String s -> s 37 | | _ -> failwith "String expected" 38 | let is_string = function `String _ -> true | _ -> false 39 | 40 | let of_char c = of_string (String.make 1 c) 41 | let to_char t = match to_string t with 42 | | s when String.length s = 1 -> s.[0] 43 | | _ -> failwith "Got string with length != 1 when reading type 'char'" 44 | 45 | let of_bool b = `Bool b 46 | let to_bool = function `Bool b -> b 47 | | _ -> failwith "Bool expected" 48 | 49 | let of_bytes b = `String (Bytes.to_string b) 50 | let to_bytes = function `String b -> Bytes.of_string b 51 | | _ -> failwith "Bytes expected" 52 | 53 | let null = `Null 54 | let is_null = function `Null -> true | _ -> false 55 | end 56 | module Make(P: Ppx_protocol_driver.Parameters) = Ppx_protocol_driver.Make(Driver)(P) 57 | include Ppx_protocol_driver.Make(Driver)(Ppx_protocol_driver.Default_parameters) 58 | 59 | let of_yaml_exn t = t 60 | let of_yaml t = Ok t 61 | let to_yaml t = t 62 | -------------------------------------------------------------------------------- /drivers/yaml/yaml.mli: -------------------------------------------------------------------------------- 1 | (** Yaml Protocol *) 2 | module Make(P: Ppx_protocol_driver.Parameters) : (Protocol_conv.Runtime.Driver with type t = Global.Yaml.value) 3 | include Protocol_conv.Runtime.Driver with type t = Global.Yaml.value 4 | val of_yaml_exn: t -> t 5 | val of_yaml: t -> (t, error) Protocol_conv.Runtime.result 6 | val to_yaml: t -> t 7 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.2) 2 | (name ppx_protocol_conv) 3 | -------------------------------------------------------------------------------- /ppx/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_protocol_conv) 3 | (public_name ppx_protocol_conv) 4 | (kind ppx_deriver) 5 | (libraries base ppxlib) 6 | (preprocess (pps ppxlib.metaquot)) 7 | (synopsis "ppx to derive (de)serializers of a type") 8 | ) 9 | -------------------------------------------------------------------------------- /ppx/ppx_protocol_conv.mli: -------------------------------------------------------------------------------- 1 | (* Intentional empty *) 2 | -------------------------------------------------------------------------------- /ppx/test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name unittest) 3 | (libraries test ppx_protocol_conv) 4 | (preprocess (pps ppx_sexp_conv)) 5 | ) 6 | 7 | (rule 8 | (targets unittest.output) 9 | (deps unittest.exe) 10 | (action (run %{deps})) 11 | ) 12 | 13 | (alias 14 | (name runtest) 15 | (package ppx_protocol_conv) 16 | (action (diff unittest.expected unittest.output)) 17 | ) 18 | -------------------------------------------------------------------------------- /ppx/test/test_driver.ml: -------------------------------------------------------------------------------- 1 | open Protocol_conv 2 | open Runtime 3 | open Base 4 | 5 | type t = 6 | | Record of (string * t) list 7 | | Variant of string * t list 8 | | Tuple of t list 9 | | Option of t option 10 | | List of t list 11 | | Int of int 12 | | Int32 of int32 13 | | Int64 of int64 14 | | Nativeint of nativeint 15 | | String of string 16 | | Bytes of bytes 17 | | Float of float 18 | | Char of char 19 | | Bool of bool 20 | | Unit 21 | [@@deriving sexp] 22 | 23 | type error = string * t option 24 | exception Protocol_error of error 25 | 26 | let make_error ?value msg = (msg, value) 27 | 28 | let to_string_hum t = sexp_of_t t |> Sexp.to_string_hum 29 | let error_to_string_hum: error -> string = function 30 | | (s, Some t) -> Printf.sprintf "%s. T: '%s'" s (to_string_hum t) 31 | | (s, None) -> s 32 | 33 | (* Register exception printer *) 34 | let () = Stdlib.Printexc.register_printer (function 35 | | Protocol_error err -> Some (error_to_string_hum err) 36 | | _ -> None) 37 | 38 | let raise_errorf t fmt = 39 | Stdlib.Printf.ksprintf (fun s -> raise (Protocol_error (s, Some t))) fmt 40 | 41 | let try_with: (t -> 'a) -> t -> ('a, error) Runtime.result = fun f t -> 42 | match f t with 43 | | v -> Ok v 44 | | exception (Protocol_error e) -> Error e 45 | 46 | let to_variant: (t, 'a) Variant_in.t list -> t -> 'a = fun spec -> function 47 | | Variant (name, args) -> Helper.to_variant spec name args 48 | | t -> raise_errorf t "Variant expected" 49 | 50 | let of_variant: string -> (t, 'a, t) Tuple_out.t -> 'a = fun name spec -> 51 | Helper.of_variant (fun name args -> Variant (name, args)) name spec 52 | 53 | let to_record: (t, 'constr, 'b) Record_in.t -> 'constr -> t -> 'b = fun spec constr -> function 54 | | Record rs -> Helper.to_record spec constr rs 55 | | t -> raise_errorf t "Expected map for record" 56 | 57 | let of_record: type a. (t, a, t) Record_out.t -> a = fun spec -> 58 | Helper.of_record ~omit_default:false (fun rs -> Record rs) spec 59 | 60 | let to_tuple: (t, 'constr, 'b) Tuple_in.t -> 'constr -> t -> 'b = fun spec constr-> 61 | let f = Helper.to_tuple spec constr in 62 | function List ts -> f ts 63 | | t -> raise_errorf t "List expected to tuple" 64 | 65 | let of_tuple: type a. (t, a, t) Tuple_out.t -> a = fun spec -> 66 | Helper.of_tuple (fun l -> List l) spec 67 | 68 | let to_option: (t -> 'a) -> t -> 'a option = fun to_value_fun -> function 69 | | Option None -> None 70 | | Option (Some v) -> Some (to_value_fun v) 71 | | e -> raise_errorf e "Option type not found" 72 | 73 | let of_option: ('a -> t) -> 'a option -> t = fun of_value_fun -> function 74 | | None -> Option None 75 | | Some v -> Option (Some (of_value_fun v)) 76 | 77 | let to_ref: (t -> 'a) -> t -> 'a ref = fun to_value_fun t -> 78 | ref (to_value_fun t) 79 | 80 | let of_ref: ('a -> t) -> 'a ref -> t = fun of_value_fun v -> 81 | of_value_fun (!v) 82 | 83 | let to_list: (t -> 'a) -> t -> 'a list = fun to_value_fun -> function 84 | | List vs -> List.map ~f:to_value_fun vs 85 | | e -> raise_errorf e "List type not found" 86 | 87 | let of_list: ('a -> t) -> 'a list -> t = fun of_value_fun v -> 88 | List (List.map ~f:of_value_fun v) 89 | 90 | let to_array: (t -> 'a) -> t -> 'a array = fun to_value_fun t -> 91 | to_list to_value_fun t |> Array.of_list 92 | 93 | let of_array: ('a -> t) -> 'a array -> t = fun of_value_fun v -> 94 | of_list of_value_fun (Array.to_list v) 95 | 96 | let to_lazy_t: (t -> 'a) -> t -> 'a lazy_t = fun to_value_fun t -> 97 | Lazy.from_fun (fun () -> to_value_fun t) 98 | 99 | let of_lazy_t: ('a -> t) -> 'a lazy_t -> t = fun of_value_fun v -> 100 | Lazy.force v |> of_value_fun 101 | 102 | let to_result: (t -> 'a) -> (t -> 'b) -> t -> ('a, 'b) Result.t = fun to_ok to_err -> function 103 | | Variant ("Ok", [ok]) -> Ok (to_ok ok) 104 | | Variant ("Error", [err]) -> Error (to_err err) 105 | | e -> raise_errorf e "Variant OK | Error expected" 106 | 107 | let of_result: ('a -> t) -> ('b -> t) -> ('a, 'b) Result.t -> t = fun of_ok of_err -> function 108 | | Ok ok -> Variant ("Ok", [of_ok ok]) 109 | | Error err -> Variant ("Error", [of_err err]) 110 | 111 | let to_int = function Int i -> i | e -> raise_errorf e "Int type not found" 112 | let of_int i = Int i 113 | 114 | let to_int32 = function Int32 i -> i | e -> raise_errorf e "Int32 type not found" 115 | let of_int32 i = Int32 i 116 | 117 | let to_int64 = function Int64 i -> i | e -> raise_errorf e "Int64 type not found" 118 | let of_int64 i = Int64 i 119 | 120 | let to_string = function String s -> s | e -> raise_errorf e "String type not found" 121 | let of_string s = String s 122 | 123 | let to_float = function Float f -> f | e -> raise_errorf e "Float type not found" 124 | let of_float f = Float f 125 | 126 | let to_char = function Char c -> c | e -> raise_errorf e "String type not found" 127 | let of_char c = Char c 128 | 129 | let to_bool = function Bool b -> b | e -> raise_errorf e "Bool type not found" 130 | let of_bool b = Bool b 131 | 132 | let to_bytes = function Bytes b -> b | e -> raise_errorf e "Bytes type not found" 133 | let of_bytes b = Bytes b 134 | 135 | let to_unit = function Unit -> () | e -> raise_errorf e "Unit type not found" 136 | let of_unit () = Unit 137 | 138 | let to_nativeint = function Nativeint n -> n | e -> raise_errorf e "Nativeint not found" 139 | let of_nativeint n = Nativeint n 140 | 141 | let of_test_exn t = t 142 | let of_test t = Ok t 143 | let to_test t = t 144 | -------------------------------------------------------------------------------- /ppx/test/test_driver.mli: -------------------------------------------------------------------------------- 1 | type t = 2 | | Record of (string * t) list 3 | | Variant of string * t list 4 | | Tuple of t list 5 | | Option of t option 6 | | List of t list 7 | | Int of int 8 | | Int32 of int32 9 | | Int64 of int64 10 | | Nativeint of nativeint 11 | | String of string 12 | | Bytes of bytes 13 | | Float of float 14 | | Char of char 15 | | Bool of bool 16 | | Unit 17 | 18 | include Protocol_conv.Runtime.Driver with type t := t 19 | val of_test_exn: t -> t 20 | val of_test: t -> (t, error) Protocol_conv.Runtime.result 21 | val to_test: t -> t 22 | -------------------------------------------------------------------------------- /ppx/test/unittest.expected: -------------------------------------------------------------------------------- 1 | === ppx_test.SingleElem === 2 | (List ()) 3 | === ppx_test.SingleElem === 4 | (List ((Int 2))) 5 | === ppx_test.Longarray === 6 | (List ((Int 4) (Int 2) (Int 3) (Int 1))) 7 | === ppx_test.EmptyInsideRec === 8 | (Record ((c (String c)) (V (List ())) (a (String a)))) 9 | === ppx_test.SingleInsideRec === 10 | (Record ((c (String c)) (V (List ((Int 2)))) (a (String a)))) 11 | === ppx_test.MultiInsideRec === 12 | (Record 13 | ((c (String c)) (V (List ((Int 4) (Int 2) (Int 3) (Int 1)))) (a (String a)))) 14 | === ppx_test.ArrayOfArrays === 15 | (Record ((a (List ((List ((Int 2) (Int 3))) (List ((Int 4) (Int 5)))))))) 16 | === ppx_test.ArrayOfArrays2 === 17 | (List 18 | ((List ()) (List ((List ()) (List ((Int 2))) (List ((Int 3) (Int 4))))) 19 | (List ((List ()))) (List ((List ((Int 2))))))) 20 | === ppx_test.Tuple === 21 | (List 22 | ((List 23 | ((Int 10) (List ((Int 20) (Int 30) (Int 40))) 24 | (List ((String s50) (String s60) (String s70))) 25 | (List 26 | ((List ((Int 100) (Int 200))) (List ((Int 300) (Int 400))) 27 | (List ((Int 500) (Int 600))))))) 28 | (List 29 | ((Int 11) (List ((Int 21) (Int 31) (Int 41))) 30 | (List ((String s51) (String s61) (String s71))) 31 | (List 32 | ((List ((Int 101) (Int 201))) (List ((Int 301) (Int 401))) 33 | (List ((Int 501) (Int 601))))))) 34 | (List 35 | ((Int 12) (List ((Int 22) (Int 32) (Int 42))) 36 | (List ((String s52) (String s62) (String s72))) 37 | (List 38 | ((List ((Int 102) (Int 202))) (List ((Int 302) (Int 402))) 39 | (List ((Int 502) (Int 602))))))) 40 | (List 41 | ((Int 13) (List ((Int 23) (Int 33) (Int 43))) 42 | (List ((String s53) (String s63) (String s73))) 43 | (List 44 | ((List ((Int 103) (Int 203))) (List ((Int 303) (Int 403))) 45 | (List ((Int 503) (Int 603))))))))) 46 | === ppx_test.Any === 47 | (Record 48 | ((u (Record ((ua (Int 7))))) 49 | (v 50 | (Variant B 51 | ((List ((Int 5) (Int 6) (Int 7))) (List ((Int 10) (Int 11) (Int 12)))))) 52 | (z (Int 101)) (record (Record ((y (String string)) (x (Int 5))))) 53 | (varray 54 | (List 55 | ((Variant B 56 | ((List ((Int 5) (Int 6) (Int 7))) (List ((Int 10) (Int 11) (Int 12))))) 57 | (Variant B 58 | ((List ((Int 5) (Int 6) (Int 7))) (List ((Int 10) (Int 11) (Int 12))))) 59 | (Variant B 60 | ((List ((Int 5) (Int 6) (Int 7))) (List ((Int 10) (Int 11) (Int 12)))))))) 61 | (vlist 62 | (List 63 | ((Variant B 64 | ((List ((Int 5) (Int 6) (Int 7))) (List ((Int 10) (Int 11) (Int 12))))) 65 | (Variant B 66 | ((List ((Int 5) (Int 6) (Int 7))) (List ((Int 10) (Int 11) (Int 12))))) 67 | (Variant B 68 | ((List ((Int 5) (Int 6) (Int 7))) (List ((Int 10) (Int 11) (Int 12)))))))) 69 | (tuple (List ((Int 5) (String protocol) (Bool false)))) (intref (Int 4)) 70 | (intoption (Option ((Int 100)))) (intlist (List ((Int 3) (Int 4) (Int 5)))) 71 | (bytes (Bytes bytes)) (string2 (String 1)) (string (String string)) 72 | (float (Float 3.14)) (nativeint (Nativeint 20)) (int64 (Int64 10)) 73 | (int32 (Int32 5)) (int (Int 2)) (char (Char x)) (bool (Bool true)))) 74 | === ppx_test.Record === 75 | (Record 76 | ((t_il (List ((Int 1000) (Int 1001) (Int 1002)))) 77 | (t_tl 78 | (List 79 | ((List ((Int 100) (Int 101) (List ((String s100) (String s101))))) 80 | (List ((Int 110) (Int 111) (List ((String s110) (String s111))))) 81 | (List ((Int 120) (Int 121) (List ((String s120) (String s121))))) 82 | (List ((Int 130) (Int 131) (List ((String s130) (String s131))))) 83 | (List ((Int 140) (Int 141) (List ((String s140) (String s141)))))))) 84 | (t_t (List ((Int 100) (Int 101) (List ((String s100) (String s101)))))) 85 | (t_i (Int 1000)) (t_bl (List ())) 86 | (t_b 87 | (Record 88 | ((b_al 89 | (List 90 | ((Record ((a_string (String s7)) (a_int (Int 7)))) 91 | (Record ((a_string (String s8)) (a_int (Int 8)))) 92 | (Record ((a_string (String s9)) (a_int (Int 9))))))) 93 | (b_a (Record ((a_string (String s6)) (a_int (Int 6))))) 94 | (b_string (String s5)) (b_int (Int 5))))) 95 | (t_al 96 | (List 97 | ((Record ((a_string (String s2)) (a_int (Int 2)))) 98 | (Record ((a_string (String s3)) (a_int (Int 3)))) 99 | (Record ((a_string (String s4)) (a_int (Int 4))))))) 100 | (t_a (Record ((a_string (String s1)) (a_int (Int 1))))))) 101 | === ppx_test.list === 102 | (Record ((a (List ((Int 1) (Int 2) (Int 3)))))) 103 | === ppx_test.Lists === 104 | (Record 105 | ((l 106 | (List 107 | ((Variant A ((List ((Int 1) (Int 2) (Int 3))))) 108 | (Variant B 109 | ((List 110 | ((List ((Int 1) (Int 2))) (List ((Int 3) (Int 4) (Int 5))) 111 | (List ((Int 2))))) 112 | (List ((Int 3) (Int 1))) (Int 5))) 113 | (Variant C 114 | ((List ((Int 1) (Int 2) (Int 3))) (List ((Int 3) (Int 4) (Int 5)))))))) 115 | (c (List ((Int 100) (Int 101) (Int 102) (Int 103)))) 116 | (b 117 | (List 118 | ((List ((Int 8) (Int 9))) (List ((Int 10) (Int 20) (Int 30) (Int 40)))))) 119 | (a 120 | (List 121 | ((List ((Int 1) (Int 2) (Int 3))) (List ()) 122 | (List ((Int 10) (Int 20) (Int 30) (Int 40))) 123 | (List ((Int 100) (Int 101)))))))) 124 | === ppx_test.array === 125 | (Record ((a (List ((Int 1) (Int 2) (Int 3)))))) 126 | === ppx_test.EmptyList === 127 | (List ()) 128 | === ppx_test.SingleElem === 129 | (List ((Int 2))) 130 | === ppx_test.Longlist === 131 | (List ((Int 4) (Int 3) (Int 2) (Int 1))) 132 | === ppx_test.EmptyInsideRec === 133 | (Record ((c (String c)) (V (List ())) (a (String a)))) 134 | === ppx_test.SingleInsideRec === 135 | (Record ((c (String c)) (V (List ((Int 2)))) (a (String a)))) 136 | === ppx_test.MultiInsideRec === 137 | (Record 138 | ((c (String c)) (V (List ((Int 4) (Int 2) (Int 3) (Int 1)))) (a (String a)))) 139 | === ppx_test.ListOfLists === 140 | (Record ((a (List ((List ((Int 2) (Int 3))) (List ((Int 4) (Int 5)))))))) 141 | === ppx_test.ListOfLists2 === 142 | (List 143 | ((List ()) (List ((List ()) (List ((Int 2))) (List ((Int 3) (Int 4))))) 144 | (List ((List ()))) (List ((List ((Int 2))))))) 145 | === ppx_test.Nonrec === 146 | (Variant A 147 | ((Variant Cons ((Int 4) (Variant Cons ((Int 3) (Variant Nil ()))))))) 148 | === ppx_test.Nonrec2 === 149 | (Variant Cons ((Int 4) (Variant Cons ((Int 3) (Variant Nil ()))))) 150 | === ppx_test.None === 151 | (Option ()) 152 | === ppx_test.Some None === 153 | (Option ((Option ()))) 154 | === ppx_test.Some Some None === 155 | (Option ((Option ((Option ()))))) 156 | === ppx_test.Some Some Some Unit === 157 | (Option ((Option ((Option ((Option (Unit)))))))) 158 | === ppx_test.simple === 159 | (Int 5) 160 | === ppx_test.record === 161 | (Record ((a (Int 5)))) 162 | === ppx_test.multiple === 163 | (List ((Int 5) (String 5) (Bool true))) 164 | === ppx_test.reference === 165 | (Record ((a (Record ((a (Int 5))))))) 166 | === ppx_test.recursive === 167 | (Record ((c (Record ((b (Record ((a (Int 5)))))))))) 168 | === ppx_test.Simple === 169 | (List 170 | ((Variant A ()) (Variant B ((Int 5))) (Variant C ((List ((Int 6) (Int 7))))) 171 | (Variant D ((List ((Int 8) (Int 9))))))) 172 | === ppx_test.Tree === 173 | (Variant Node 174 | ((List 175 | ((Variant Node ((List ((Variant Leaf ()) (Int 3) (Variant Leaf ()))))) 176 | (Int 10) (Variant Leaf ()))))) 177 | === ppx_test.MutualRecursion === 178 | (Variant T1 179 | ((Variant V 180 | ((Variant T 181 | ((Variant V 182 | ((Variant V1 ((Variant V1 ((Variant V1 ((Variant V0 ((Int 5))))))))))))))))) 183 | === ppx_test.InsideRec === 184 | (Record ((c (String c)) (V (Variant A ())) (a (String a)))) 185 | === ppx_test.RecordList === 186 | (Record 187 | ((objects (List ((Record ((key (Int 1)))) (Record ((key (Int 2))))))))) 188 | === ppx_test.SimpleRecord === 189 | (Record 190 | ((HostId (String SDsd)) (RequestId (String sdfsd)) (Endpoint (Option ())) 191 | (Bucket (Option ())) (Message (String Message)) (Code (String Error)))) 192 | === ppx_test.Test_sig === 193 | (Record 194 | ((x 195 | (Variant A 196 | ((List 197 | ((Variant A ((Int 7))) (Int 7) (Int 7) (Variant B ((Float 0.7))) 198 | (Int 7)))))))) 199 | === ppx_test.Test_sig2 === 200 | (List 201 | ((Int 1) (Float 2) (String 3.0) Unit (Variant A ((Int 1))) 202 | (Record ((c (String 3.0)) (b (Float 2)) (a (Int 1)))) 203 | (Variant A ((Int 1))))) 204 | === ppx_test.S3 === 205 | (Record 206 | ((Contents 207 | (List 208 | ((Record ((ETag (String Etag)) (StorageClass (Variant STANDARD ()))))))) 209 | (Prefix (Option ((String prefix)))))) 210 | === ppx_test.Types === 211 | (Record 212 | ((baz 213 | (Record 214 | ((y_yd (Variant Variant_two1 ((Int 1)))) 215 | (y_yc 216 | (Option 217 | ((List ((String three) (List ((Int 100) (Int 200) (Int 300)))))))) 218 | (y_b (List ((String two) (List ((Int 10) (Int 20) (Int 30)))))) 219 | (y_a (Int 2))))) 220 | (bar (String true)) (foo (Int 1)))) 221 | === ppx_test.Some Some Some true === 222 | (Option ((Option ((Option ((Bool true))))))) 223 | === ppx_test.Some Some None === 224 | (Option ((Option ((Option ()))))) 225 | === ppx_test.Some None === 226 | (Option ((Option ()))) 227 | === ppx_test.None === 228 | (Option ()) 229 | === ppx_test.Some Some Some true === 230 | (Record ((a (Option ((Option ((Option ((Bool true)))))))))) 231 | === ppx_test.Some Some None === 232 | (Record ((a (Option ((Option ((Option ())))))))) 233 | === ppx_test.Some None === 234 | (Record ((a (Option ((Option ())))))) 235 | === ppx_test.None === 236 | (Record ((a (Option ())))) 237 | === ppx_test.unit option option list option option === 238 | (Option 239 | ((Option 240 | ((List ((Option ((Option (Unit)))) (Option ((Option ()))) (Option ()))))))) 241 | === ppx_test.confuse deserialization by using reserved word === 242 | (Record ((o (Record ((option (Option ((Option ((Bool true))))))))))) 243 | === ppx_test.Simple === 244 | (List 245 | ((Variant A ()) (Variant B ((Int 5))) (Variant C ((Int 6) (Int 7))) 246 | (Variant D ((List ((Int 8) (Int 9))))))) 247 | === ppx_test.Tuple === 248 | (Variant A ((List ((Int 3) (Int 4))))) 249 | === ppx_test.Tree === 250 | (Variant Node 251 | ((Variant Node ((Variant Leaf ()) (Int 3) (Variant Leaf ()))) (Int 10) 252 | (Variant Leaf ()))) 253 | === ppx_test.MutualRecursion === 254 | (Variant T1 255 | ((Variant V 256 | ((Variant T 257 | ((Variant V 258 | ((Variant V1 ((Variant V1 ((Variant V1 ((Variant V0 ((Int 5))))))))))))))))) 259 | === ppx_test.InsideRec === 260 | (Record ((c (String c)) (V (Variant A ())) (a (String a)))) 261 | === ppx_test.InlineRecord === 262 | (Variant A ((Record ((a (String a)))))) 263 | === ppx_test.InlineRecord2 === 264 | (Variant aa 265 | ((Record 266 | ((b (Variant aa ((Record ((b (Variant B ((Int 5)))) (A (String a))))))) 267 | (A (String a)))))) 268 | === ppx_test.Poly === 269 | (Variant aaa ((Int 5))) 270 | === ppx_test.Option.Ok === 271 | (Variant Ok ((Int 2))) 272 | === ppx_test.Option.Error === 273 | (Variant Error ((String "Error string"))) 274 | -------------------------------------------------------------------------------- /ppx/test/unittest.ml: -------------------------------------------------------------------------------- 1 | module Driver = struct 2 | let name = "ppx_test" 3 | let serialize t = Marshal.to_string t [] 4 | let deserialize t = Marshal.from_string t 0 5 | include Test_driver 6 | let of_driver_exn = of_test_exn 7 | let of_driver = of_test 8 | let to_driver = to_test 9 | let sexp_of_t : t -> Sexplib.Sexp.t = fun t -> 10 | Sexplib.Std.sexp_of_string (to_string_hum t) 11 | end 12 | module Unittest = Test.Unittest.Make (Driver) 13 | let () = Unittest.run () 14 | -------------------------------------------------------------------------------- /ppx_protocol_conv.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Anders Fugmann " 3 | authors: "Anders Fugmann" 4 | license: "BSD-3-Clause" 5 | homepage: "https://github.com/andersfugmann/ppx_protocol_conv" 6 | dev-repo: "git+https://github.com/andersfugmann/ppx_protocol_conv" 7 | bug-reports: "https://github.com/andersfugmann/ppx_protocol_conv/issues" 8 | build: [ 9 | ["dune" "subst"] {dev} 10 | ["dune" "build" "-p" name "-j" jobs] 11 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 12 | ] 13 | depends: [ 14 | "ocaml" {>= "4.07"} 15 | "base" {>= "v0.14.0" } 16 | "dune" {>= "1.2"} 17 | "ppxlib" {>= "0.9.0"} 18 | "ppx_sexp_conv" {with-test} 19 | "sexplib" {with-test} 20 | "alcotest" {with-test & >= "0.8.0"} 21 | ] 22 | synopsis: 23 | "Ppx for generating serialisation and de-serialisation functions of ocaml types" 24 | description: """ 25 | Ppx_protocol_conv generates code to serialize and de-serialize 26 | types. The ppx itself does not contain any protocol specific code, 27 | but relies on 'drivers' that defines serialisation and 28 | de-serialisation of basic types and structures. 29 | 30 | Pre-defined drivers are available in separate packages: 31 | ppx_protocol_conv_json (Yojson.Safe.json) 32 | ppx_protocol_conv_jsonm (Ezjson.value) 33 | ppx_protocol_conv_msgpack (Msgpck.t) 34 | ppx_protocol_conv_xml-light (Xml.xml) 35 | ppx_protocol_conv_xmlm (Xmlm.node) 36 | ppx_protocol_conv_yaml (Yaml.value)""" 37 | -------------------------------------------------------------------------------- /ppx_protocol_conv_json.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Anders Fugmann " 3 | authors: "Anders Fugmann" 4 | license: "BSD-3-Clause" 5 | homepage: "https://github.com/andersfugmann/ppx_protocol_conv" 6 | dev-repo: "git+https://github.com/andersfugmann/ppx_protocol_conv" 7 | bug-reports: "https://github.com/andersfugmann/ppx_protocol_conv/issues" 8 | build: [ 9 | ["dune" "subst"] {dev} 10 | ["dune" "build" "-p" name "-j" jobs] 11 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 12 | ] 13 | depends: [ 14 | "ocaml" {>= "4.08"} 15 | "ppx_protocol_conv" {= version} 16 | "yojson" {>= "1.6.0"} 17 | "dune" {>= "1.2"} 18 | "ppx_expect" 19 | "ppx_inline_test" 20 | "ppx_sexp_conv" {with-test} 21 | "sexplib" {with-test} 22 | "alcotest" {with-test & >= "0.8.0"} 23 | ] 24 | synopsis: "Json driver for Ppx_protocol_conv" 25 | description: """ 26 | This package provides a driver for json (Yojson.Safe.json) 27 | serialization and de-serialization using the yojson library""" 28 | -------------------------------------------------------------------------------- /ppx_protocol_conv_jsonm.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Anders Fugmann " 3 | authors: "Anders Fugmann" 4 | license: "BSD-3-Clause" 5 | homepage: "https://github.com/andersfugmann/ppx_protocol_conv" 6 | dev-repo: "git+https://github.com/andersfugmann/ppx_protocol_conv" 7 | bug-reports: "https://github.com/andersfugmann/ppx_protocol_conv/issues" 8 | build: [ 9 | ["dune" "subst"] {dev} 10 | ["dune" "build" "-p" name "-j" jobs] 11 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 12 | ] 13 | depends: [ 14 | "ocaml" {>= "4.08"} 15 | "ppx_protocol_conv" {= version} 16 | "ezjsonm" 17 | "dune" {>= "1.2"} 18 | "ppx_sexp_conv" {with-test} 19 | "sexplib" {with-test} 20 | "alcotest" {with-test & >= "0.8.0"} 21 | ] 22 | synopsis: "Jsonm driver for Ppx_protocol_conv" 23 | description: """ 24 | This package provides a driver for json (Ezjson.value) 25 | serialization and de-serialization using the Ezjson library""" 26 | -------------------------------------------------------------------------------- /ppx_protocol_conv_msgpack.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Anders Fugmann " 3 | authors: "Anders Fugmann" 4 | license: "BSD-3-Clause" 5 | homepage: "https://github.com/andersfugmann/ppx_protocol_conv" 6 | dev-repo: "git+https://github.com/andersfugmann/ppx_protocol_conv" 7 | bug-reports: "https://github.com/andersfugmann/ppx_protocol_conv/issues" 8 | build: [ 9 | ["dune" "subst"] {dev} 10 | ["dune" "build" "-p" name "-j" jobs] 11 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 12 | ] 13 | depends: [ 14 | "ocaml" {>= "4.08"} 15 | "ppx_protocol_conv" {= version} 16 | "msgpck" {>= "1.3"} 17 | "msgpck" {with-test & >= "1.7"} 18 | "dune" {>= "1.2"} 19 | "ppx_sexp_conv" {with-test} 20 | "sexplib" {with-test} 21 | "alcotest" {with-test & >= "0.8.0"} 22 | ] 23 | synopsis: "MessagePack driver for Ppx_protocol_conv" 24 | description: """ 25 | This package provides a driver for message pack (Msgpck.t) 26 | serialization and deserialization using the msgpck library""" 27 | -------------------------------------------------------------------------------- /ppx_protocol_conv_xml_light.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Anders Fugmann " 3 | authors: "Anders Fugmann" 4 | license: "BSD-3-Clause" 5 | homepage: "https://github.com/andersfugmann/ppx_protocol_conv" 6 | dev-repo: "git+https://github.com/andersfugmann/ppx_protocol_conv" 7 | bug-reports: "https://github.com/andersfugmann/ppx_protocol_conv/issues" 8 | build: [ 9 | ["dune" "subst"] {dev} 10 | ["dune" "build" "-p" name "-j" jobs] 11 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 12 | ] 13 | depends: [ 14 | "ocaml" {>= "4.08"} 15 | "ppx_protocol_conv" {= version} 16 | "xml-light" 17 | "dune" {>= "1.2"} 18 | "ppx_sexp_conv" {with-test} 19 | "sexplib" {with-test} 20 | "alcotest" {with-test & >= "0.8.0"} 21 | ] 22 | synopsis: "Xml driver for Ppx_protocol_conv" 23 | description: """ 24 | This package provides a driver for xml (Xml.t) serialization and 25 | de-serialization using the xml-light library""" 26 | -------------------------------------------------------------------------------- /ppx_protocol_conv_xmlm.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Anders Fugmann " 3 | authors: ["Anders Fugmann " "Nick Betteridge = "4.08"} 15 | "ppx_protocol_conv" {= version} 16 | "ezxmlm" 17 | "dune" {>= "1.2"} 18 | "ppx_sexp_conv" {with-test} 19 | "sexplib" {with-test} 20 | "alcotest" {with-test & >= "0.8.0"} 21 | ] 22 | synopsis: "Xmlm driver for Ppx_protocol_conv" 23 | description: """ 24 | This package provides a driver for xmlm (Ezxmlm.node) 25 | serialization and de-serialization using the Ezxmlm library""" 26 | -------------------------------------------------------------------------------- /ppx_protocol_conv_yaml.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Anders Fugmann " 3 | authors: "Anders Fugmann" 4 | license: "BSD-3-Clause" 5 | homepage: "https://github.com/andersfugmann/ppx_protocol_conv" 6 | dev-repo: "git+https://github.com/andersfugmann/ppx_protocol_conv" 7 | bug-reports: "https://github.com/andersfugmann/ppx_protocol_conv/issues" 8 | build: [ 9 | ["dune" "subst"] {dev} 10 | ["dune" "build" "-p" name "-j" jobs] 11 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 12 | ] 13 | depends: [ 14 | "ocaml" {>= "4.08"} 15 | "dune" {>= "1.2"} 16 | "ppx_protocol_conv" {= version} 17 | "yaml" { >= "2.0.0"} 18 | "yaml" {with-test & >= "3.0.0"} 19 | "ppx_sexp_conv" {with-test} 20 | "sexplib" {with-test} 21 | "alcotest" {with-test & >= "0.8.0"} 22 | ] 23 | synopsis: "Yaml driver for Ppx_protocol_conv" 24 | description: """ 25 | This package provides a driver for yaml (Yaml.value) 26 | serialization and de-serialization using the Yaml""" 27 | -------------------------------------------------------------------------------- /runtime/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name protocol_conv) 3 | (public_name ppx_protocol_conv.runtime) 4 | (synopsis "runtime library for ppx_protocol_conv") 5 | ) 6 | -------------------------------------------------------------------------------- /runtime/runtime.ml: -------------------------------------------------------------------------------- 1 | type nonrec ('v, 'e) result = ('v, 'e) result 2 | 3 | module Record_in = struct 4 | type (_, _, _) t = 5 | | Cons : (string * ('t -> 'a) * 'a option) * ('t, 'b, 'c) t -> ('t, 'a -> 'b, 'c) t 6 | | Nil : ('t, 'a, 'a) t 7 | let (^::) a b = Cons (a,b) 8 | end 9 | 10 | module Record_out = struct 11 | type (_, _, _) t = 12 | | Cons : (string * ('a -> 't) * 'a option) * ('t, 'b, 'c) t -> ('t, 'a -> 'b, 'c) t 13 | | Nil : ('t, 'a, 'a) t 14 | let (^::) a b = Cons (a,b) 15 | end 16 | 17 | module Tuple_in = struct 18 | type (_, _, _) t = 19 | | Cons : ('t -> 'a) * ('t, 'b, 'c) t -> ('t, 'a -> 'b, 'c) t 20 | | Nil : ('t, 'a, 'a) t 21 | let (^::) a b = Cons (a,b) 22 | end 23 | 24 | module Tuple_out = struct 25 | type (_, _, _) t = 26 | | Cons : ('a -> 't) * ('t, 'b, 'c) t -> ('t, 'a -> 'b, 'c) t 27 | | Nil : ('t, 'a, 'a) t 28 | let (^::) a b = Cons (a,b) 29 | end 30 | 31 | module Variant_in = struct 32 | type (_, _) t = Variant: string * ('a, 'constr, 'c) Tuple_in.t * 'constr -> ('a, 'c) t 33 | end 34 | 35 | (** Signature for a driver. Serialization function are on the form [of_XXX] and 36 | deserialization function are on the form [to_XXX]. 37 | 38 | All deserialization functions should only raise [Protocol_error] is the type could not be desrialized. 39 | *) 40 | module type Driver = sig 41 | 42 | (** Serialized type. This type should not be opaque, so it is recommended that 43 | drivers implement the signature as [Runtime.Driver with type t = ... ] 44 | *) 45 | type t 46 | 47 | (** Opaque error type *) 48 | type error 49 | 50 | (** Exception for protocol errors. The driver should make sure that 51 | this is the only exception raised when deserializing *) 52 | exception Protocol_error of error 53 | 54 | (** Construct an error to be raised from a custom parser. *) 55 | val make_error: ?value: t -> string -> error 56 | 57 | (** Convert an error type to a human readable string *) 58 | val error_to_string_hum: error -> string 59 | 60 | (** Convert t to a string *) 61 | val to_string_hum: t -> string 62 | 63 | (** Wrap deserialization function to convert exceptions into an result type *) 64 | val try_with: (t -> 'v) -> t -> ('v, error) result 65 | 66 | val to_variant: (t, 'a) Variant_in.t list -> t -> 'a 67 | val of_variant: string -> (t, 'a, t) Tuple_out.t -> 'a 68 | 69 | val to_record: (t, 'constr, 'b) Record_in.t -> 'constr -> t -> 'b 70 | val of_record: (t, 'a, t) Record_out.t -> 'a 71 | 72 | val to_tuple: (t, 'constr, 'b) Tuple_in.t -> 'constr -> t -> 'b 73 | val of_tuple: (t, 'a, t) Tuple_out.t -> 'a 74 | 75 | val to_option: (t -> 'a) -> t -> 'a option 76 | val of_option: ('a -> t) -> 'a option -> t 77 | val to_ref: (t -> 'a) -> t -> 'a ref 78 | val of_ref: ('a -> t) -> 'a ref -> t 79 | val to_list: (t -> 'a) -> t -> 'a list 80 | val of_list: ('a -> t) -> 'a list -> t 81 | val to_array: (t -> 'a) -> t -> 'a array 82 | val of_array: ('a -> t) -> 'a array -> t 83 | val to_lazy_t: (t -> 'a) -> t -> 'a lazy_t 84 | val of_lazy_t: ('a -> t) -> 'a lazy_t -> t 85 | val to_result: (t -> 'a) -> (t -> 'b) -> t -> ('a, 'b) result 86 | val of_result: ('a -> t) -> ('b -> t) -> ('a, 'b) result -> t 87 | val to_int: t -> int 88 | val of_int: int -> t 89 | val to_int32: t -> int32 90 | val of_int32: int32 -> t 91 | val to_int64: t -> int64 92 | val of_int64: int64 -> t 93 | val to_nativeint: t -> nativeint 94 | val of_nativeint: nativeint -> t 95 | val to_char: t -> char 96 | val of_char: char -> t 97 | val to_string: t -> string 98 | val of_string: string -> t 99 | val to_float: t -> float 100 | val of_float: float -> t 101 | val to_bool: t -> bool 102 | val of_bool: bool -> t 103 | val to_bytes: t -> bytes 104 | val of_bytes: bytes -> t 105 | val to_unit: t -> unit 106 | val of_unit: unit -> t 107 | end 108 | 109 | (** Module contains helper function for serializing and deserializing tuples, records and variants. 110 | Deserialization functions may raise [Helper.Protocol] exception. It is recommended that the calling functions 111 | convert this exception into a [Driver.Protocol_exception] 112 | *) 113 | module Helper = struct 114 | open StdLabels 115 | 116 | 117 | (** Tail recursive version of map *) 118 | 119 | let list_map ~f l = 120 | let slow_map ~f tl = 121 | List.rev_map ~f tl |> List.rev 122 | in 123 | 124 | let rec count_map ~f l ctr = 125 | match l with 126 | | [] -> [] 127 | | [ x1 ] -> 128 | let f1 = f x1 in 129 | [ f1 ] 130 | | [ x1; x2 ] -> 131 | let f1 = f x1 in 132 | let f2 = f x2 in 133 | [ f1; f2 ] 134 | | [ x1; x2; x3 ] -> 135 | let f1 = f x1 in 136 | let f2 = f x2 in 137 | let f3 = f x3 in 138 | [ f1; f2; f3 ] 139 | | [ x1; x2; x3; x4 ] -> 140 | let f1 = f x1 in 141 | let f2 = f x2 in 142 | let f3 = f x3 in 143 | let f4 = f x4 in 144 | [ f1; f2; f3; f4 ] 145 | | x1 :: x2 :: x3 :: x4 :: x5 :: tl -> 146 | let f1 = f x1 in 147 | let f2 = f x2 in 148 | let f3 = f x3 in 149 | let f4 = f x4 in 150 | let f5 = f x5 in 151 | f1 152 | :: f2 153 | :: f3 154 | :: f4 155 | :: f5 156 | :: (if ctr > 1000 then slow_map ~f tl else count_map ~f tl (ctr + 1)) 157 | in 158 | count_map ~f l 0 159 | 160 | let () = 161 | let l = [1;2;3;4;5] in 162 | let l' = list_map ~f:(fun x -> x + 2) l in 163 | let l'' = List.map ~f:(fun x -> x + 2) l in 164 | assert (l' = l''); 165 | 166 | 167 | (** Excpetion raised if the type could not be serialized *) 168 | exception Protocol_error of string 169 | 170 | (**/**) 171 | module type Lookup = sig 172 | val of_alist: (string * 'a) list -> string -> 'a option 173 | end 174 | module Hashtbl_lookup : Lookup = struct (* 20.22% *) 175 | let of_alist alist = 176 | let tbl = Hashtbl.create 0 in 177 | List.iter ~f:(fun (k, v) -> Hashtbl.add tbl k v) alist; 178 | fun k -> match Hashtbl.find tbl k with 179 | | k -> Some k 180 | | exception Not_found -> None 181 | end 182 | module Lookup = Hashtbl_lookup 183 | 184 | let raise_errorf: ('a, unit, string, 'b) format4 -> 'a = fun fmt -> Printf.ksprintf (fun s -> raise (Protocol_error s)) fmt 185 | (**/**) 186 | 187 | (** Map fields names of a [Record_in] structure *) 188 | let rec map_record_in: type t a b. (string -> string) -> (t, a, b) Record_in.t -> (t, a, b) Record_in.t = fun field -> function 189 | | Record_in.Cons ((field_name, to_value_func, default), xs) -> 190 | Record_in.Cons ((field field_name, to_value_func, default), map_record_in field xs) 191 | | Record_in.Nil -> Record_in.Nil 192 | 193 | (** {!to_record spec constructor ts} returns the constructed value. 194 | [ts] is a associative array [(string * t)] list, mapping fields to the deserialized value [t] 195 | if [strict] is true, an error will be raised if input contains an unknown field. 196 | If dublicate fields are found in the input, an error is raised 197 | *) 198 | let to_record: type t constr b. ?strict:bool -> (t, constr, b) Record_in.t -> constr -> (string * t) list -> b = 199 | let rec to_alist : type a b c. int -> (a, b, c) Record_in.t -> (string * int) list = fun idx -> function 200 | | Record_in.Cons ((field, _, _), xs) -> 201 | (field, idx) :: to_alist (idx + 1) xs 202 | | Record_in.Nil -> [] 203 | in 204 | let rec inner: type constr. int -> (t, constr, b) Record_in.t -> constr -> t option array -> b = fun idx -> 205 | let open Record_in in 206 | let value_of to_v field default t = match t, default with 207 | | Some t, _ -> to_v t 208 | | None, Some d -> d 209 | | None, None -> raise_errorf "Missing record field: %s" field 210 | in 211 | function 212 | | (Cons ((n1, f1, d1), xs)) -> 213 | let cont = inner (idx + 1) xs in 214 | fun constr values -> 215 | let v1 = value_of f1 n1 d1 values.(idx + 0) in 216 | cont (constr v1) values 217 | 218 | | Nil -> fun a _values -> a 219 | in 220 | fun ?(strict=false) spec constr -> 221 | let lookup, count = 222 | let alist = to_alist 0 spec in 223 | Lookup.of_alist alist, List.length alist 224 | in 225 | let f = inner 0 spec constr in 226 | 227 | fun values -> 228 | let value_array = Array.make count None in 229 | List.iter ~f:(fun (field, t) -> 230 | match lookup field with 231 | | None when strict -> raise_errorf "Unused field when deserialising record: %s" field 232 | | None -> () 233 | | Some idx -> begin 234 | match value_array.(idx) with 235 | | Some _ -> raise_errorf "Multiple fields with the same name: %s" field 236 | | None -> value_array.(idx) <- Some t 237 | end 238 | ) values; 239 | f value_array 240 | 241 | (** Map fields names of a [Record_out] structure *) 242 | let rec map_record_out: type t a. (string -> string) -> (t, a, t) Record_out.t -> (t, a, t) Record_out.t = 243 | fun field -> 244 | let open Record_out in 245 | function 246 | | Cons ((field_name, to_t, default), xs) -> 247 | Cons ((field field_name, to_t, default), map_record_out field xs) 248 | | Nil -> Nil 249 | 250 | type 't serialize_record = (string * 't) list -> 't 251 | 252 | (** {!of_record map_f spec} produces a valid deserialisation function for a record type 253 | The [map_f] function is called to produce the serialized result from a field_name, t association list. 254 | If [omit_default] is true, then default values are omitted from the output 255 | *) 256 | let of_record: type a t. omit_default:bool -> t serialize_record -> (t, a, t) Record_out.t -> a = 257 | fun ~omit_default serialize_record -> 258 | let rec inner: type a. (t, a, t) Record_out.t -> (string * t) list -> a = 259 | let open Record_out in 260 | function 261 | | Cons ((n1, f1, Some d1), xs) when omit_default -> 262 | begin 263 | let cont = inner xs in 264 | fun acc v1 -> match d1 = v1 with 265 | | true -> cont acc 266 | | false -> cont ((n1, f1 v1) :: acc) 267 | end 268 | | Cons ((n1, f1, _), xs) -> 269 | let cont = inner xs in 270 | fun acc v1 -> 271 | cont ((n1, f1 v1) :: acc) 272 | | Record_out.Nil -> 273 | fun acc -> serialize_record acc 274 | in 275 | fun spec -> inner spec [] 276 | 277 | (** {!to_tuple spec tlist} produces a tuple from the serialized values in [tlist] *) 278 | let rec to_tuple: type t a b. (t, a, b) Tuple_in.t -> a -> t list -> b = 279 | let open Tuple_in in 280 | function 281 | | Cons (f1, xs) -> begin 282 | let cont = to_tuple xs in 283 | fun constructor -> function 284 | | v1 :: ts -> cont (constructor (f1 v1)) ts 285 | | _ -> raise_errorf "Too few elements when parsing tuple" 286 | end 287 | | Nil -> fun a -> begin 288 | function 289 | | [] -> a 290 | | _ -> raise_errorf "Too many elements when parsing tuple" 291 | end 292 | 293 | type 't serialize_tuple = 't list -> 't 294 | let of_tuple: type t a. t serialize_tuple -> (t, a, t) Tuple_out.t -> a = fun serialize_tuple -> 295 | let rec inner: type a. (t, a, t) Tuple_out.t -> t list -> a = 296 | let open Tuple_out in 297 | function 298 | | Cons (f1, Cons (f2, (Cons (f3, (Cons (f4, Nil)))))) -> 299 | fun acc v1 v2 v3 v4 -> List.rev_append acc [f1 v1; f2 v2; f3 v3; f4 v4] |> serialize_tuple 300 | | Cons (f1, Cons (f2, (Cons (f3, Nil)))) -> 301 | fun acc v1 v2 v3 -> List.rev_append acc [f1 v1; f2 v2; f3 v3] |> serialize_tuple 302 | | Cons (f1, Cons (f2, Nil)) -> 303 | fun acc v1 v2 -> List.rev_append acc [f1 v1; f2 v2] |> serialize_tuple 304 | | Cons (f1, Nil) -> 305 | fun acc v1 -> List.rev_append acc [f1 v1] |> serialize_tuple 306 | | Nil -> 307 | fun acc -> List.rev acc |> serialize_tuple 308 | | Cons (f1, Cons (f2, (Cons (f3, (Cons (f4, Cons (f5, xs))))))) -> 309 | let cont = inner xs in 310 | fun acc v1 v2 v3 v4 v5 -> cont (f5 v5 :: f4 v4 :: f3 v3 :: f2 v2 :: f1 v1 :: acc) 311 | in 312 | fun spec -> inner spec [] 313 | 314 | type 't serialize_variant = string -> 't list -> 't 315 | 316 | (** {!of_variant spec v} serializes v and returns the serialized values 317 | as a list or map 318 | *) 319 | let of_variant: type t. t serialize_variant -> string -> (t, 'a, t) Tuple_out.t -> 'a = 320 | fun serialize_variant name spec -> 321 | of_tuple (serialize_variant name) spec 322 | 323 | (** Map field names in all inline records of the spec *) 324 | let map_constructor_names: (string -> string) -> ('t, 'a) Variant_in.t list -> ('t, 'a) Variant_in.t list = 325 | fun constructor variant -> 326 | List.map variant ~f:(fun (Variant_in.Variant (name, spec, constr)) -> Variant_in.Variant (constructor name, spec, constr)) 327 | 328 | let to_variant: ('t, 'a) Variant_in.t list -> string -> 't list -> 'a = fun spec -> 329 | let lookup = 330 | List.map spec ~f:(fun (Variant_in.Variant (name, spec, constr)) -> name, to_tuple spec constr) 331 | |> Lookup.of_alist 332 | in 333 | fun name args -> 334 | match lookup name with 335 | | None -> raise_errorf "Unknown variant name: %s" name 336 | | Some f -> f args 337 | end 338 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test) 3 | (libraries base alcotest ppx_protocol_conv.runtime sexplib) 4 | (preprocess (pps ppx_protocol_conv ppx_sexp_conv)) 5 | ) 6 | -------------------------------------------------------------------------------- /test/error.ml: -------------------------------------------------------------------------------- 1 | type x = int 2 | 3 | (* Generalized algebraic datatypes not supported *) 4 | type _ t = Int: int -> int t 5 | 6 | (* Extensible variant types not supported *) 7 | type attr = .. 8 | type attr += Str of string 9 | type attr += Int of int | Float of float 10 | 11 | (* Functions not supported *) 12 | type f = int -> int 13 | 14 | (* Inline records not supported *) 15 | type v = V of { a: int } 16 | 17 | type p = [ `A ] 18 | 19 | (* Inherited polymophic variants not supported *) 20 | type q = [ p | `B ] 21 | 22 | type u = private A | B of int 23 | (* [@@deriving protocol ~driver:(module Driver)] *) 24 | -------------------------------------------------------------------------------- /test/test_arrays.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Std 2 | module Make(Driver: Testable.Driver) = struct 3 | module M = Testable.Make(Driver) 4 | module EmptyArray : M.Testable = struct 5 | let name = "SingleElem" 6 | type t = int array 7 | [@@deriving protocol ~driver:(module Driver), sexp] 8 | 9 | let t = [||] 10 | end 11 | 12 | module Singleton : M.Testable = struct 13 | let name = "SingleElem" 14 | type t = int array 15 | [@@deriving protocol ~driver:(module Driver), sexp] 16 | 17 | let t = [|2|] 18 | end 19 | 20 | module LongArray : M.Testable = struct 21 | let name = "Longarray" 22 | type t = int array 23 | [@@deriving protocol ~driver:(module Driver), sexp] 24 | 25 | let t = [|4; 2; 3; 1|] 26 | end 27 | 28 | module EmptyInsideRec : M.Testable = struct 29 | let name = "EmptyInsideRec" 30 | type v = int [@key "A"] 31 | and t = { a : string; 32 | b : v array; [@key "V"] 33 | c : string; 34 | } 35 | [@@deriving protocol ~driver:(module Driver), sexp] 36 | 37 | let t = { a= "a"; b = [||]; c = "c" } 38 | end 39 | 40 | module SingleInsideRec : M.Testable = struct 41 | let name = "SingleInsideRec" 42 | type v = int [@key "A"] 43 | and t = { a : string; 44 | b : v array; [@key "V"] 45 | c : string; 46 | } 47 | [@@deriving protocol ~driver:(module Driver), sexp] 48 | 49 | let t = { a= "a"; b = [|2|]; c = "c" } 50 | end 51 | 52 | module MultiInsideRec : M.Testable = struct 53 | let name = "MultiInsideRec" 54 | type v = int [@key "A"] 55 | and t = { a : string; 56 | b : v array; [@key "V"] 57 | c : string; 58 | } 59 | [@@deriving protocol ~driver:(module Driver), sexp] 60 | 61 | let t = { a= "a"; b = [|4; 2; 3; 1|]; c = "c" } 62 | end 63 | 64 | module ArrayOfArrays : M.Testable = struct 65 | let name = "ArrayOfArrays" 66 | type v = int array 67 | and t = { a : v array; } 68 | [@@deriving protocol ~driver:(module Driver), sexp] 69 | 70 | let t = { a = [| [|2;3|]; [|4;5|] |] } 71 | end 72 | 73 | module ArrayOfArrays2 : M.Testable = struct 74 | let name = "ArrayOfArrays2" 75 | type t = int array array array 76 | [@@deriving protocol ~driver:(module Driver), sexp] 77 | 78 | let t = [| [||]; [| [||]; [|2|]; [|3;4|]; |]; [| [||] |]; [| [|2|] |]; |] 79 | end 80 | 81 | let unittest = __MODULE__, [ 82 | M.test (module EmptyArray); 83 | M.test (module Singleton); 84 | M.test (module LongArray); 85 | M.test (module EmptyInsideRec); 86 | M.test (module SingleInsideRec); 87 | M.test (module MultiInsideRec); 88 | M.test (module ArrayOfArrays); 89 | M.test (module ArrayOfArrays2); 90 | ] 91 | end 92 | -------------------------------------------------------------------------------- /test/test_arrays.mli: -------------------------------------------------------------------------------- 1 | module Make : functor (Driver : Testable.Driver) -> sig 2 | val unittest: unit Alcotest.test 3 | end 4 | -------------------------------------------------------------------------------- /test/test_driver.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | module Make(Driver: Testable.Driver) = struct 4 | module M = Testable.Make(Driver) 5 | module Tuple : M.Testable = struct 6 | let name = "Tuple" 7 | 8 | type t = (int * int list * string list * (int * int) list) list 9 | [@@deriving protocol ~driver:(module Driver), sexp] 10 | 11 | let t = [ 12 | (10, [20;30;40], ["s50"; "s60"; "s70"], [100, 200; 300, 400; 500, 600]); 13 | (11, [21;31;41], ["s51"; "s61"; "s71"], [101, 201; 301, 401; 501, 601]); 14 | (12, [22;32;42], ["s52"; "s62"; "s72"], [102, 202; 302, 402; 502, 602]); 15 | (13, [23;33;43], ["s53"; "s63"; "s73"], [103, 203; 303, 403; 503, 603]); 16 | ] 17 | end 18 | 19 | module Any : M.Testable = struct 20 | let name = "Any" 21 | 22 | type t1 = { x: int; y: string } 23 | and v = A | B of int list * int list | C of string 24 | and u = { ua: int } 25 | and t = { 26 | bool: bool; 27 | char: char; 28 | int: int; 29 | int32: int32; 30 | int64: int64; 31 | nativeint: nativeint; 32 | float: float; 33 | string: string; 34 | string2: string; 35 | bytes: bytes; 36 | intlist: int list; 37 | intoption: int option; 38 | intref: int ref; 39 | tuple: (int * string * bool); 40 | vlist: v list; 41 | varray: v array; 42 | record: t1; 43 | mutable z: int; 44 | v : Driver.t; 45 | u : Driver.t; 46 | } 47 | [@@deriving protocol ~driver:(module Driver), sexp_of] 48 | 49 | let v = B ([5; 6; 7], [10;11;12]) 50 | let u = { ua = 7 } 51 | let t = { 52 | bool = true; 53 | char = 'x'; 54 | int = 2; 55 | int32 = Int32.of_int_exn 5; 56 | int64 = Int64.of_int_exn 10; 57 | nativeint = Nativeint.of_int 20; 58 | float = 3.14; 59 | string = "string"; 60 | string2 = "1"; 61 | bytes = Bytes.of_string "bytes"; 62 | intlist = [3; 4; 5]; 63 | intoption = Some 100; 64 | intref = ref 4; 65 | tuple = (5, "protocol", false); 66 | vlist = [ v; v; v; ]; 67 | varray = [| v; v; v; |]; 68 | record = { x = 5; y = "string" }; 69 | z = 101; 70 | v = v_to_driver v; 71 | u = u_to_driver u; 72 | } 73 | end 74 | 75 | module Record : M.Testable = struct 76 | let name = "Record" 77 | type a = { 78 | a_int: int; 79 | a_string: string; 80 | } 81 | and b = { 82 | b_int: int; 83 | b_string: string; 84 | b_a: a; 85 | b_al: a list; 86 | } 87 | and t = { 88 | t_a: a; 89 | t_al: a list; 90 | t_b: b; 91 | t_bl: b list; 92 | t_i: int; 93 | t_t: (int * int * string list); 94 | t_tl: (int * int * string list) list; 95 | t_il: int list; 96 | } 97 | [@@deriving protocol ~driver:(module Driver), sexp_of] 98 | 99 | let t = { 100 | t_a = { a_int = 1; a_string = "s1"; }; 101 | t_al = [ 102 | { a_int = 2; a_string = "s2"; }; 103 | { a_int = 3; a_string = "s3"; }; 104 | { a_int = 4; a_string = "s4"; }; 105 | ]; 106 | t_b = { b_int = 5; 107 | b_string = "s5"; 108 | b_a = { a_int = 6; a_string = "s6"; }; 109 | b_al = [ 110 | { a_int = 7; a_string = "s7"; }; 111 | { a_int = 8; a_string = "s8"; }; 112 | { a_int = 9; a_string = "s9"; }; 113 | ]; 114 | }; 115 | t_bl = []; 116 | t_i = 1000; 117 | t_t = (100, 101, ["s100"; "s101"]); 118 | t_tl = [ 119 | (100, 101, ["s100"; "s101"]); 120 | (110, 111, ["s110"; "s111"]); 121 | (120, 121, ["s120"; "s121"]); 122 | (130, 131, ["s130"; "s131"]); 123 | (140, 141, ["s140"; "s141"]); 124 | ]; 125 | t_il = [1000; 1001; 1002] 126 | } 127 | end 128 | 129 | module List : M.Testable = struct 130 | let name = "list" 131 | type t = { a: int list } 132 | [@@deriving protocol ~driver:(module Driver), sexp] 133 | 134 | let t = { a = [1; 2; 3] } 135 | 136 | end 137 | 138 | module Array : M.Testable = struct 139 | let name = "array" 140 | type t = { a: int array } 141 | [@@deriving protocol ~driver:(module Driver), sexp] 142 | 143 | let t = { a = [|1; 2; 3|] } 144 | 145 | end 146 | 147 | 148 | module Lists : M.Testable = struct 149 | let name = "Lists" 150 | 151 | type l = A of int list | B of int list list * int list * int | C of int list * int list 152 | and t = { 153 | a: int list list; 154 | b: (int list * int list); 155 | c: int list; 156 | l: l list; 157 | } 158 | [@@deriving protocol ~driver:(module Driver), sexp] 159 | 160 | let t = { 161 | a = [ 162 | [ 1;2;3 ]; 163 | []; 164 | [10; 20; 30; 40]; 165 | [100; 101]; 166 | ]; 167 | 168 | b = ([8;9], [10;20;30;40]); 169 | c = [100; 101; 102; 103]; 170 | 171 | l = [ 172 | A [1;2;3]; 173 | B ([[1;2]; [3;4;5]; [2]], [3;1], 5); 174 | C ([1;2;3], [3;4;5]); 175 | ] 176 | } 177 | end 178 | let unittest = Stdlib.__MODULE__, [ 179 | M.test (module Tuple); 180 | M.test (module Any); 181 | M.test (module Record); 182 | M.test (module List); 183 | M.test (module Lists); 184 | M.test (module Array); 185 | ] 186 | 187 | end 188 | -------------------------------------------------------------------------------- /test/test_driver.mli: -------------------------------------------------------------------------------- 1 | module Make : functor (Driver : Testable.Driver) -> sig 2 | val unittest : unit Alcotest.test 3 | end 4 | -------------------------------------------------------------------------------- /test/test_exceptions.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Std 2 | 3 | let list_init ~len ~f = 4 | let rec inner acc = function 5 | | 0 -> acc 6 | | n -> inner (f (n-1) :: acc) (n - 1) 7 | in 8 | inner [] len 9 | 10 | module Make(Driver: Testable.Driver) = struct 11 | module M = Testable.Make(Driver) 12 | 13 | module Stack_overflow = struct 14 | type t = int list 15 | [@@deriving protocol ~driver:(module Driver), sexp] 16 | let t = list_init ~len:1_000_000 ~f:(fun i -> i) 17 | let name = "stack_overflow" 18 | let test = 19 | Alcotest.test_case name `Quick (fun () -> 20 | try 21 | to_driver t 22 | |> of_driver_exn 23 | |> ignore 24 | with 25 | | Failure "ignore" [@warning "-52"] -> () 26 | ) 27 | end 28 | 29 | module Exceptions = struct 30 | type t = { text: string } 31 | [@@deriving protocol ~driver:(module Driver), sexp] 32 | type u = string 33 | [@@deriving protocol ~driver:(module Driver), sexp] 34 | let t' = u_to_driver "test string" 35 | 36 | (* This should raise an exception *) 37 | let test = 38 | Alcotest.test_case "Test exception handling" `Quick (fun () -> 39 | of_driver t' |> ignore 40 | ) 41 | end 42 | 43 | let unittest = __MODULE__, [ 44 | Stack_overflow.test; 45 | Exceptions.test 46 | ] 47 | end 48 | -------------------------------------------------------------------------------- /test/test_lists.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Std 2 | 3 | module Make(Driver: Testable.Driver) = struct 4 | module M = Testable.Make(Driver) 5 | 6 | module EmptyList : M.Testable = struct 7 | let name = "EmptyList" 8 | type t = int list 9 | [@@deriving protocol ~driver:(module Driver), sexp] 10 | 11 | let t = [] 12 | end 13 | 14 | module Singleton : M.Testable = struct 15 | let name = "SingleElem" 16 | type t = int list 17 | [@@deriving protocol ~driver:(module Driver), sexp] 18 | 19 | let t = [2] 20 | end 21 | 22 | module LongList : M.Testable = struct 23 | let name = "Longlist" 24 | type t = int list 25 | [@@deriving protocol ~driver:(module Driver), sexp] 26 | 27 | let t = [4;3;2;1] 28 | end 29 | 30 | module EmptyInsideRec : M.Testable = struct 31 | let name = "EmptyInsideRec" 32 | type v = int [@key "A"] 33 | and t = { a : string; 34 | b : v list; [@key "V"] 35 | c : string; 36 | } 37 | [@@deriving protocol ~driver:(module Driver), sexp] 38 | 39 | let t = { a= "a"; b = []; c = "c" } 40 | end 41 | 42 | module SingleInsideRec : M.Testable = struct 43 | let name = "SingleInsideRec" 44 | type v = int [@key "A"] 45 | and t = { a : string; 46 | b : v list; [@key "V"] 47 | c : string; 48 | } 49 | [@@deriving protocol ~driver:(module Driver), sexp] 50 | 51 | let t = { a= "a"; b = [2]; c = "c" } 52 | end 53 | 54 | module MultiInsideRec : M.Testable = struct 55 | let name = "MultiInsideRec" 56 | type v = int [@key "A"] 57 | and t = { a : string; 58 | b : v list; [@key "V"] 59 | c : string; 60 | } 61 | [@@deriving protocol ~driver:(module Driver), sexp] 62 | 63 | let t = { a= "a"; b = [4; 2; 3; 1]; c = "c" } 64 | end 65 | 66 | module ListOfLists : M.Testable = struct 67 | let name = "ListOfLists" 68 | type v = int list 69 | and t = { a : v list; } 70 | [@@deriving protocol ~driver:(module Driver), sexp] 71 | 72 | let t = { a = [ [2;3]; [4;5] ] } 73 | end 74 | 75 | module ListOfLists2 : M.Testable = struct 76 | let name = "ListOfLists2" 77 | type t = int list list list 78 | [@@deriving protocol ~driver:(module Driver), sexp] 79 | 80 | let t = [ []; [ []; [2]; [3;4]; ]; [ [] ]; [ [2] ]; ] 81 | end 82 | 83 | 84 | let unittest = __MODULE__, [ 85 | M.test (module EmptyList); 86 | M.test (module Singleton); 87 | M.test (module LongList); 88 | M.test (module EmptyInsideRec); 89 | M.test (module SingleInsideRec); 90 | M.test (module MultiInsideRec); 91 | M.test (module ListOfLists); 92 | M.test (module ListOfLists2); 93 | ] 94 | end 95 | -------------------------------------------------------------------------------- /test/test_lists.mli: -------------------------------------------------------------------------------- 1 | module Make : functor (Driver : Testable.Driver) -> sig 2 | val unittest: unit Alcotest.test 3 | end 4 | -------------------------------------------------------------------------------- /test/test_nonrec.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Std 2 | module Make(Driver: Testable.Driver) = struct 3 | module M = Testable.Make(Driver) 4 | 5 | module Recursive = struct 6 | type t = Cons of int * t 7 | | Nil 8 | [@@deriving protocol ~driver:(module Driver), sexp] 9 | 10 | module Nonrec : M.Testable = struct 11 | let name = "Nonrec" 12 | type nonrec t = A of t 13 | [@@deriving protocol ~driver:(module Driver), sexp] 14 | let t = A (Cons (4, Cons (3, Nil))) 15 | end 16 | 17 | end 18 | 19 | module Recursive2 = struct 20 | type t = Cons of int * t | Nil 21 | [@@deriving protocol ~driver:(module Driver), sexp] 22 | 23 | module Nonrec : M.Testable = struct 24 | let name = "Nonrec2" 25 | type nonrec t = t 26 | [@@deriving protocol ~driver:(module Driver), sexp] 27 | let t = Cons (4, Cons (3, Nil)) 28 | end 29 | 30 | end 31 | let unittest = __MODULE__, [ 32 | M.test (module Recursive.Nonrec); 33 | M.test (module Recursive2.Nonrec); 34 | ] 35 | end 36 | -------------------------------------------------------------------------------- /test/test_nonrec.mli: -------------------------------------------------------------------------------- 1 | module Make : functor (Driver : Testable.Driver) -> sig 2 | val unittest: unit Alcotest.test 3 | end 4 | -------------------------------------------------------------------------------- /test/test_option_unit.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Std 2 | module Make(Driver: Testable.Driver) = struct 3 | module M = Testable.Make(Driver) 4 | type t = unit option option option option 5 | [@@deriving protocol ~driver:(module Driver), sexp] 6 | module None : M.Testable = struct 7 | type nonrec t = t [@@deriving protocol ~driver:(module Driver), sexp] 8 | let name = "None" 9 | let t = None 10 | end 11 | module Some_none : M.Testable = struct 12 | type nonrec t = t [@@deriving protocol ~driver:(module Driver), sexp] 13 | let name = "Some None" 14 | let t = Some None 15 | end 16 | module Some_some_none: M.Testable = struct 17 | type nonrec t = t [@@deriving protocol ~driver:(module Driver), sexp] 18 | let name = "Some Some None" 19 | let t = Some (Some None) 20 | end 21 | module Some_some_some_none : M.Testable = struct 22 | type nonrec t = t [@@deriving protocol ~driver:(module Driver), sexp] 23 | let name = "Some Some Some None" 24 | let t = Some (Some (Some None)) 25 | end 26 | module Some_some_some_some_unit : M.Testable = struct 27 | type nonrec t = t [@@deriving protocol ~driver:(module Driver), sexp] 28 | let name = "Some Some Some Unit" 29 | let t = Some (Some (Some (Some ()))) 30 | end 31 | let unittest = __MODULE__, [ 32 | M.test (module None); 33 | M.test (module Some_none); 34 | M.test (module Some_some_none); 35 | M.test (module Some_some_some_some_unit); 36 | ] 37 | end 38 | -------------------------------------------------------------------------------- /test/test_option_unit.mli: -------------------------------------------------------------------------------- 1 | module Make : functor (Driver : Testable.Driver) -> sig 2 | val unittest: unit Alcotest.test 3 | end 4 | -------------------------------------------------------------------------------- /test/test_param_types.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Std 2 | module Make(Driver: Testable.Driver) = struct 3 | module M = Testable.Make(Driver) 4 | module T1 : M.Testable = struct 5 | let name = "simple" 6 | type 'a v = 'a 7 | [@@deriving protocol ~driver:(module Driver), sexp] 8 | type t = int v 9 | [@@deriving protocol ~driver:(module Driver), sexp] 10 | let t = 5 11 | end 12 | 13 | module T2 : M.Testable = struct 14 | let name = "record" 15 | type 'a v = { a : 'a } 16 | [@@deriving protocol ~driver:(module Driver), sexp] 17 | type t = int v 18 | [@@deriving protocol ~driver:(module Driver), sexp] 19 | let t = { a = 5 } 20 | end 21 | 22 | module T3 : M.Testable = struct 23 | let name = "multiple" 24 | type ('a, 'b, 'c) v = ('a * 'b * 'c) 25 | [@@deriving protocol ~driver:(module Driver), sexp] 26 | 27 | type t = (int, string, bool) v 28 | [@@deriving protocol ~driver:(module Driver), sexp] 29 | let t = (5, "5", true) 30 | end 31 | 32 | module T4_1 = struct 33 | type 'a t = { a: 'a } 34 | [@@deriving protocol ~driver:(module Driver), sexp] 35 | end 36 | 37 | module T4 : M.Testable = struct 38 | let name = "reference" 39 | type 'a v = { a: 'a T4_1.t } 40 | [@@deriving protocol ~driver:(module Driver), sexp] 41 | type t = int v 42 | [@@deriving protocol ~driver:(module Driver), sexp] 43 | let t = { a = { T4_1.a = 5} } 44 | end 45 | 46 | module T5 : M.Testable = struct 47 | let name = "recursive" 48 | type 'a v = { a: 'a } 49 | [@@deriving protocol ~driver:(module Driver), sexp] 50 | type 'a u = { b: 'a } 51 | [@@deriving protocol ~driver:(module Driver), sexp] 52 | type 'a w = { c: 'a } 53 | [@@deriving protocol ~driver:(module Driver), sexp] 54 | 55 | type t = ((int v) u) w 56 | [@@deriving protocol ~driver:(module Driver), sexp] 57 | 58 | let t = { c = { b = { a = 5 }}} 59 | end 60 | 61 | let unittest = __MODULE__, [ 62 | M.test (module T1); 63 | M.test (module T2); 64 | M.test (module T3); 65 | M.test (module T4); 66 | M.test (module T5); 67 | ] 68 | 69 | end 70 | -------------------------------------------------------------------------------- /test/test_param_types.mli: -------------------------------------------------------------------------------- 1 | module Make : functor (Driver : Testable.Driver) -> sig 2 | val unittest: unit Alcotest.test 3 | end 4 | -------------------------------------------------------------------------------- /test/test_poly.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Std 2 | module Make(Driver: Testable.Driver) = struct 3 | module M = Testable.Make(Driver) 4 | 5 | module Simple : M.Testable = struct 6 | let name = "Simple" 7 | type v = [ `A | `B of int | `C of int * int | `D of (int * int) ] 8 | and t = v list 9 | [@@deriving protocol ~driver:(module Driver), sexp] 10 | 11 | let t = [ `A; `B 5; `C (6,7); `D (8,9) ] 12 | end 13 | 14 | module Tree : M.Testable = struct 15 | let name = "Tree" 16 | type t = [ `Node of t * int * t | `Leaf ] 17 | [@@deriving protocol ~driver:(module Driver), sexp] 18 | 19 | let t = `Node ( `Node (`Leaf, 3, `Leaf), 10, `Leaf) 20 | end 21 | 22 | module MutualRecursion : M.Testable = struct 23 | let name = "MutualRecursion" 24 | type v = [ `V1 of v | `V0 of int | `T of t ] 25 | and t = [ `T1 of t | `T2 of int | `V of v ] 26 | [@@deriving protocol ~driver:(module Driver), sexp] 27 | 28 | let t = `T1 (`V (`T (`V (`V1 (`V1 (`V1 (`V0 5))))))) 29 | end 30 | 31 | module InsideRec : M.Testable = struct 32 | let name = "InsideRec" 33 | type v = [ `V0 [@key "A"] 34 | | `V1 [@key "B"] ] 35 | 36 | and t = { a : string; 37 | b : v; [@key "V"] 38 | c : string; 39 | } 40 | [@@deriving protocol ~driver:(module Driver), sexp] 41 | 42 | let t = { a= "a"; b = `V0; c = "c" } 43 | end 44 | 45 | let unittest = __MODULE__, [ 46 | M.test (module Simple); 47 | M.test (module Tree); 48 | M.test (module MutualRecursion); 49 | M.test (module InsideRec); 50 | ] 51 | end 52 | -------------------------------------------------------------------------------- /test/test_poly.mli: -------------------------------------------------------------------------------- 1 | module Make : functor (Driver : Testable.Driver) -> sig 2 | val unittest : unit Alcotest.test 3 | end 4 | -------------------------------------------------------------------------------- /test/test_record.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Std 2 | module Make(Driver: Testable.Driver) = struct 3 | module M = Testable.Make(Driver) 4 | 5 | module SimpleRecord : M.Testable = struct 6 | let name = "SimpleRecord" 7 | type t = { 8 | code: string [@key "Code"]; 9 | message: string [@key "Message"]; 10 | bucket: string option [@key "Bucket"]; 11 | endpoint: string option [@key "Endpoint"]; 12 | request_id: string [@key "RequestId"]; 13 | host_id: string [@key "HostId"]; 14 | } 15 | [@@deriving protocol ~driver:(module Driver), sexp] 16 | 17 | let t = { code = "Error"; 18 | message = "Message"; 19 | bucket = None; 20 | endpoint = None; 21 | request_id = "sdfsd"; 22 | host_id = "SDsd"; 23 | } 24 | end 25 | 26 | module RecordList : M.Testable = struct 27 | let name = "RecordList" 28 | 29 | type objekt = { key: int } 30 | and t = { objects : objekt list } 31 | [@@deriving protocol ~driver:(module Driver), sexp] 32 | 33 | let t = { objects = [ { key = 1 }; { key = 2 } ] } 34 | end 35 | 36 | let unittest = __MODULE__, [ 37 | M.test (module RecordList); 38 | M.test (module SimpleRecord); 39 | ] 40 | end 41 | -------------------------------------------------------------------------------- /test/test_record.mli: -------------------------------------------------------------------------------- 1 | module Make : functor (Driver : Testable.Driver) -> sig 2 | val unittest: unit Alcotest.test 3 | end 4 | -------------------------------------------------------------------------------- /test/test_result.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Std 2 | module Make(Driver: Testable.Driver) = struct 3 | module M = Testable.Make(Driver) 4 | let result_of_sexp = Base.Result.t_of_sexp 5 | let sexp_of_result = Base.Result.sexp_of_t 6 | 7 | module Result_ok : M.Testable = struct 8 | let name = "Option.Ok" 9 | type t = (int, string) result 10 | [@@deriving protocol ~driver:(module Driver), sexp] 11 | let t = Ok 2 12 | end 13 | 14 | module Result_error : M.Testable = struct 15 | let name = "Option.Error" 16 | type t = (int, string) result 17 | [@@deriving protocol ~driver:(module Driver), sexp] 18 | let t = Error "Error string" 19 | end 20 | 21 | let unittest = __MODULE__, [ 22 | M.test (module Result_ok); 23 | M.test (module Result_error); 24 | ] 25 | end 26 | -------------------------------------------------------------------------------- /test/test_sig.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Std 2 | module Make(Driver: Testable.Driver) = struct 3 | module M = Testable.Make(Driver) 4 | module Signature : M.Testable = struct 5 | module Test_sig : sig 6 | type ('a, 'b, 'c, 'd, 'e) w = 'a * 'b * 'c * 'd * 'e 7 | and 'a u = A of ('a, int, int, 'a, int) w | B | C of 'a u 8 | and 'a v = { x : 'a u } 9 | and t = [`A of int | `B of float] v 10 | [@@deriving protocol ~driver:(module Driver), sexp] 11 | end = struct 12 | type ('a, 'b, 'c, 'd, 'e) w = 'a * 'b * 'c * 'd * 'e 13 | and 'a u = A of ('a, int, int, 'a, int) w | B | C of 'a u 14 | and 'a v = { x : 'a u } 15 | and t = [`A of int | `B of float] v 16 | [@@deriving protocol ~driver:(module Driver), sexp] 17 | end 18 | let name = "Test_sig" 19 | 20 | type t = Test_sig.t 21 | [@@deriving protocol ~driver:(module Driver), sexp] 22 | 23 | let t = { Test_sig.x = A (`A 7, 7, 7, `B 0.7, 7) } 24 | end 25 | 26 | module Signature2 : M.Testable = struct 27 | module Test_sig : sig 28 | type ('a, 'b, 'c, 'd, 'e, 'f, 'g) w = 'a * 'b * 'c * 'd * 'e * 'f * 'g 29 | and a = int 30 | and b = float 31 | and c = string 32 | and d = unit 33 | and ('a, 'b, 'c) e = A of 'a | B of 'b | C of 'c 34 | and ('a, 'b, 'c) f = { a: 'a; b: 'b; c: 'c} 35 | and ('a, 'b, 'c) g = [ `A of 'a | `B of 'b | `C of 'c] 36 | and t = (a, b, c, d, (a, b, c) e, (a, b, c) f, (a, b, c) g) w 37 | [@@deriving protocol ~driver:(module Driver), sexp] 38 | end = struct 39 | type ('a, 'b, 'c, 'd, 'e, 'f, 'g) w = 'a * 'b * 'c * 'd * 'e * 'f * 'g 40 | and a = int 41 | and b = float 42 | and c = string 43 | and d = unit 44 | and ('a, 'b, 'c) e = A of 'a | B of 'b | C of 'c 45 | and ('a, 'b, 'c) f = { a: 'a; b: 'b; c: 'c} 46 | and ('a, 'b, 'c) g = [ `A of 'a | `B of 'b | `C of 'c] 47 | and t = (a, b, c, d, (a, b, c) e, (a, b, c) f, (a, b, c) g) w 48 | [@@deriving protocol ~driver:(module Driver), sexp] 49 | end 50 | let name = "Test_sig2" 51 | type t = Test_sig.t 52 | [@@deriving protocol ~driver:(module Driver), sexp] 53 | let a = 1 54 | let b = 2.0 55 | let c = "3.0" 56 | let d = () 57 | let e = Test_sig.A a 58 | let f = { Test_sig.a; b; c} 59 | let g = `A a 60 | 61 | let t = (a, b, c, d, e, f, g) 62 | end 63 | 64 | let unittest = __MODULE__, [ 65 | M.test (module Signature); 66 | M.test (module Signature2); 67 | ] 68 | end 69 | -------------------------------------------------------------------------------- /test/test_sig.mli: -------------------------------------------------------------------------------- 1 | module Make : functor (Driver : Testable.Driver) -> sig 2 | val unittest: unit Alcotest.test 3 | end 4 | -------------------------------------------------------------------------------- /test/test_types.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Std 2 | 3 | module Make(Driver: Testable.Driver) = struct 4 | module M = Testable.Make(Driver) 5 | 6 | module S3 : M.Testable = struct 7 | let name = "S3" 8 | type storage_class = Standard [@key "STANDARD"] 9 | | Standard_ia [@key "STANDARD_IA"] 10 | | Reduced_redundancy [@key "REDUCED_REDUNDANCY"] 11 | | Glacier [@key "GLACIER"] 12 | 13 | 14 | and content = { 15 | storage_class: storage_class [@key "StorageClass"]; 16 | etag: string [@key "ETag"]; 17 | } 18 | and t = { 19 | prefix: string option [@key "Prefix"]; 20 | contents: content list [@key "Contents"]; 21 | } 22 | [@@deriving protocol ~driver:(module Driver), sexp] 23 | 24 | let t = { prefix = Some "prefix"; 25 | contents = [ { storage_class = Standard; etag = "Etag" } ] 26 | } 27 | end 28 | 29 | 30 | module T : M.Testable = struct 31 | let name = "Types" 32 | 33 | type a = string * int list 34 | and aopt = a option 35 | and v = Variant_one of int [@key "Variant_two1"] 36 | | Variant_two of string 37 | and y = { 38 | y_a: int [@key "y_a"]; 39 | y_b: a; 40 | y_c_: aopt [@key "y_yc"]; 41 | y_d_: v [@key "y_yd"]; 42 | } 43 | and t = { 44 | foo: int; 45 | bar: string; 46 | baz: y; 47 | } 48 | [@@deriving protocol ~driver:(module Driver), sexp] 49 | 50 | let t = { foo=1; 51 | bar="true"; 52 | baz={ y_a=2; 53 | y_b=("two", [10; 20; 30]); 54 | y_c_=Some ("three", [100; 200; 300]); 55 | y_d_=Variant_one 1 56 | }; 57 | } 58 | end 59 | let unittest = __MODULE__, [ 60 | M.test (module S3); 61 | M.test (module T); 62 | ] 63 | end 64 | -------------------------------------------------------------------------------- /test/test_types.mli: -------------------------------------------------------------------------------- 1 | module Make : functor (Driver : Testable.Driver) -> sig 2 | val unittest: unit Alcotest.test 3 | end 4 | -------------------------------------------------------------------------------- /test/test_unit.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Std 2 | 3 | module Make(Driver: Testable.Driver) = struct 4 | module M = Testable.Make(Driver) 5 | 6 | type t = bool option option option 7 | [@@deriving protocol ~driver:(module Driver), sexp] 8 | 9 | module T1 : M.Testable = struct 10 | let name = "Some Some Some true" 11 | type nonrec t = t 12 | [@@deriving protocol ~driver:(module Driver), sexp] 13 | 14 | let t = Some (Some (Some true)) 15 | end 16 | 17 | module T2 : M.Testable = struct 18 | let name = "Some Some None" 19 | type nonrec t = t 20 | [@@deriving protocol ~driver:(module Driver), sexp] 21 | 22 | let t = Some (Some None) 23 | end 24 | 25 | module T3 : M.Testable = struct 26 | let name = "Some None" 27 | type nonrec t = t 28 | [@@deriving protocol ~driver:(module Driver), sexp] 29 | 30 | let t = Some None 31 | end 32 | 33 | module T4 : M.Testable = struct 34 | let name = "None" 35 | type nonrec t = t 36 | [@@deriving protocol ~driver:(module Driver), sexp] 37 | let t = None 38 | end 39 | 40 | type u = { a: t } 41 | [@@deriving protocol ~driver:(module Driver), sexp] 42 | 43 | module T5 : M.Testable = struct 44 | let name = "Some Some Some true" 45 | type t = u 46 | [@@deriving protocol ~driver:(module Driver), sexp] 47 | 48 | let t = { a = Some (Some (Some true)) } 49 | end 50 | 51 | module T6 : M.Testable = struct 52 | let name = "Some Some None" 53 | type t = u 54 | [@@deriving protocol ~driver:(module Driver), sexp] 55 | 56 | let t = { a = Some (Some None) } 57 | end 58 | 59 | module T7 : M.Testable = struct 60 | let name = "Some None" 61 | type t = u 62 | [@@deriving protocol ~driver:(module Driver), sexp] 63 | 64 | let t = { a = Some None } 65 | end 66 | 67 | module T8 : M.Testable = struct 68 | let name = "None" 69 | type t = u 70 | [@@deriving protocol ~driver:(module Driver), sexp] 71 | 72 | let t = { a = None } 73 | end 74 | 75 | module T9 : M.Testable = struct 76 | let name = "unit option option list option option" 77 | type t = unit option option list option option 78 | [@@deriving protocol ~driver:(module Driver), sexp] 79 | let t = Some (Some ([Some (Some ()); Some None; None])) 80 | end 81 | 82 | module T10 : M.Testable = struct 83 | let name = "confuse deserialization by using reserved word" 84 | type v = { option: bool option option } 85 | [@@deriving protocol ~driver:(module Driver), sexp] 86 | type t = { o: v } 87 | [@@deriving protocol ~driver:(module Driver), sexp] 88 | let t = { o = { option = Some (Some true) } } 89 | end 90 | 91 | let unittest = __MODULE__, [ 92 | M.test (module T1); 93 | M.test (module T2); 94 | M.test (module T3); 95 | M.test (module T4); 96 | M.test (module T5); 97 | M.test (module T6); 98 | M.test (module T7); 99 | M.test (module T8); 100 | M.test (module T9); 101 | M.test (module T10); 102 | ] 103 | end 104 | -------------------------------------------------------------------------------- /test/test_unit.mli: -------------------------------------------------------------------------------- 1 | module Make : functor (Driver : Testable.Driver) -> sig 2 | val unittest: unit Alcotest.test 3 | end 4 | -------------------------------------------------------------------------------- /test/test_variant.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Std 2 | 3 | module Make(Driver: Testable.Driver) = struct 4 | module M = Testable.Make(Driver) 5 | 6 | module Simple : M.Testable = struct 7 | let name = "Simple" 8 | 9 | type v = A | B of int | C of int * int | D of (int * int) 10 | and t = v list 11 | [@@deriving protocol ~driver:(module Driver), sexp] 12 | 13 | let t = [ A; B 5; C (6,7); D (8,9) ] 14 | end 15 | 16 | module Tuple : M.Testable = struct 17 | let name = "Tuple" 18 | type t = A of (int * int) 19 | | B of int * int 20 | [@@deriving protocol ~driver:(module Driver), sexp] 21 | let t = A (3,4) 22 | end 23 | 24 | 25 | module Tree : M.Testable = struct 26 | let name = "Tree" 27 | type t = 28 | | Node of t * int * t 29 | | Leaf 30 | [@@deriving protocol ~driver:(module Driver), sexp] 31 | 32 | let t = Node ( Node (Leaf, 3, Leaf), 10, Leaf) 33 | end 34 | 35 | module MutualRecursion : M.Testable = struct 36 | let name = "MutualRecursion" 37 | type v = V1 of v 38 | | V0 of int 39 | | T of t 40 | and t = | T1 of t 41 | | T2 of int 42 | | V of v 43 | [@@deriving protocol ~driver:(module Driver), sexp] 44 | 45 | let t = T1 (V (T (V (V1 (V1 (V1 (V0 5))))))) 46 | end 47 | 48 | module InsideRec : M.Testable = struct 49 | let name = "InsideRec" 50 | type v = V0 [@key "A"] 51 | | V1 [@key "B"] 52 | 53 | and t = { a : string; 54 | b : v; [@key "V"] 55 | c : string; 56 | } 57 | [@@deriving protocol ~driver:(module Driver), sexp] 58 | 59 | let t = { a= "a"; b = V0; c = "c" } 60 | end 61 | 62 | module InlineRecord : M.Testable = struct 63 | let name = "InlineRecord" 64 | type t = A of { a : string; } 65 | | B of int 66 | | C of { x : int; y: int; } 67 | [@@deriving protocol ~driver:(module Driver), sexp] 68 | let t = A { a = "a" } 69 | end 70 | 71 | 72 | module InlineRecord2 : M.Testable = struct 73 | let name = "InlineRecord2" 74 | type t = A of { a : string [@key "A"]; b: t} [@key "aa"] 75 | | B of int 76 | | C of { x : int [@key "X"]; y: int [@key "Y"]; } 77 | [@@deriving protocol ~driver:(module Driver), sexp] 78 | let t = A { a = "a"; b = A { a = "a"; b = B 5 } } 79 | end 80 | 81 | module Poly : M.Testable = struct 82 | let name = "Poly" 83 | type t = [ `A of int [@key "aaa"]| `B of string ] 84 | [@@deriving protocol ~driver:(module Driver), sexp] 85 | let t = `A 5 86 | end 87 | let unittest = __MODULE__, [ 88 | M.test (module Simple); 89 | M.test (module Tuple); 90 | M.test (module Tree); 91 | M.test (module MutualRecursion); 92 | M.test (module InsideRec); 93 | M.test (module InlineRecord); 94 | M.test (module InlineRecord2); 95 | M.test (module Poly); 96 | ] 97 | end 98 | -------------------------------------------------------------------------------- /test/test_variant.mli: -------------------------------------------------------------------------------- 1 | module Make : functor (Driver : Testable.Driver) -> sig 2 | val unittest : unit Alcotest.test 3 | end 4 | -------------------------------------------------------------------------------- /test/testable.ml: -------------------------------------------------------------------------------- 1 | module type Driver = sig 2 | include Protocol_conv.Runtime.Driver 3 | val of_driver_exn: t -> t 4 | val of_driver: t -> (t, error) Protocol_conv.Runtime.result 5 | val to_driver: t -> t 6 | val name: string 7 | val serialize: t -> string 8 | val deserialize: string -> t 9 | val sexp_of_t: t -> Sexplib.Sexp.t 10 | end 11 | 12 | module type Test = functor(Driver: Driver) -> sig 13 | val unittest : printer:(Driver.t -> string) -> unit Alcotest.test 14 | end 15 | 16 | module Make (Driver: Driver) = struct 17 | module type Testable = sig 18 | type t [@@deriving protocol ~driver:(module Driver), sexp_of] 19 | val t: t 20 | val name: string 21 | end 22 | 23 | let test (module T : Testable) = 24 | let f () = 25 | let t = T.to_driver T.t in 26 | let out_ch = open_out_gen [Open_append] 0o644 "unittest.output" in 27 | Printf.fprintf out_ch "=== %s.%s ===\n%s\n" Driver.name T.name (Driver.to_string_hum t); 28 | close_out out_ch; 29 | 30 | let t' = 31 | try T.to_driver T.t |> Driver.serialize |> Driver.deserialize |> T.of_driver_exn with 32 | | exn -> 33 | Printf.printf "\n%s: Failed parsing:\n>>>>>\n%s.%s\n======\n%s\n<<<<<<\n" 34 | Driver.name T.name 35 | (Driver.to_string_hum t) 36 | (Base.Sexp.to_string_hum (T.sexp_of_t T.t)); 37 | raise exn 38 | in 39 | let fmt : T.t Fmt.t = fun formatter t -> 40 | Format.fprintf formatter "%s" (Base.Sexp.to_string_hum (T.sexp_of_t t)) 41 | in 42 | Alcotest.(check (of_pp fmt)) Driver.name T.t t' 43 | in 44 | let test_name = Printf.sprintf "%s.%s" Driver.name T.name in 45 | Alcotest.test_case test_name `Quick (fun () -> try f () with Failure "ignore" [@warning "-52"] -> ()) 46 | end 47 | -------------------------------------------------------------------------------- /test/unittest.ml: -------------------------------------------------------------------------------- 1 | module type Test_module = sig 2 | module Make : functor (Driver : Testable.Driver) -> sig 3 | val unittest: unit Alcotest.test 4 | end 5 | end 6 | 7 | let verbose = false 8 | module Make(Driver : Testable.Driver) = struct 9 | let test_modules : (module Test_module) list = 10 | [ 11 | (module Test_arrays); 12 | (module Test_driver); 13 | (module Test_lists); 14 | (module Test_nonrec); 15 | (module Test_option_unit); 16 | (module Test_param_types); 17 | (module Test_poly); 18 | (module Test_record); 19 | (module Test_sig); 20 | (module Test_types); 21 | (module Test_unit); 22 | (module Test_variant); 23 | (module Test_result); 24 | (module Test_exceptions); 25 | ] 26 | 27 | (* Create a list of tests *) 28 | let run ?(extra = []) () = 29 | let tests = 30 | List.map (fun (module Test : Test_module) -> 31 | let module T = Test.Make(Driver) in 32 | T.unittest) 33 | test_modules 34 | in 35 | let tests = tests @ extra in 36 | open_out "unittest.output" |> close_out; 37 | Alcotest.run Driver.name tests 38 | end 39 | -------------------------------------------------------------------------------- /type.ml: -------------------------------------------------------------------------------- 1 | open Protocol_conv_json 2 | 3 | module Test_sig : sig 4 | type a = int 5 | [@@deriving protocol ~driver:(module Json)] 6 | end = struct 7 | type a = int 8 | [@@deriving protocol ~driver:(module Json)] 9 | end 10 | --------------------------------------------------------------------------------