├── .gitignore ├── .merlin ├── .ocamlinit ├── .travis.yml ├── LICENSE ├── Makefile ├── README.md ├── cconv-ppx.opam ├── cconv.opam ├── dune ├── dune-project ├── src ├── bench │ ├── dune │ └── run_bench.ml ├── bencode │ ├── cConvBencode.ml │ ├── cConvBencode.mli │ └── dune ├── core │ ├── CConv.ml │ ├── CConv.mli │ └── dune ├── example │ ├── .merlin │ └── all.ml ├── ppx │ ├── dune │ └── ppx_deriving_cconv.cppo.ml ├── psexp │ ├── cConvPSexp.ml │ ├── cConvPSexp.mli │ └── dune ├── sexp │ ├── cConvSexp.ml │ ├── cConvSexp.mli │ └── dune └── yojson │ ├── cConvYojson.ml │ ├── cConvYojson.mli │ └── dune └── tests ├── dune └── run_tests_ppx.ml /.gitignore: -------------------------------------------------------------------------------- 1 | .*.swp 2 | .*.swo 3 | _build 4 | *.native 5 | *.byte 6 | .session 7 | *.docdir 8 | ppx/ppx_deriving_cconv.ml 9 | .merlin 10 | *.install 11 | -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | S src 2 | B _build/src 3 | S bench 4 | B _build/bench 5 | PKG ppx_deriving 6 | PKG compiler-libs 7 | PKG ppx_tools.metaquot 8 | FLG -w +a -w -4 -w -44 9 | -------------------------------------------------------------------------------- /.ocamlinit: -------------------------------------------------------------------------------- 1 | #directory "_build/src";; 2 | #load "cconv.cma";; 3 | 4 | #require "bencode";; 5 | #directory "_build/bencode/";; 6 | #load "cconv_bencode.cma";; 7 | 8 | #require "yojson";; 9 | #directory "_build/yojson/";; 10 | #load "cconv_yojson.cma";; 11 | 12 | #require "sexplib";; 13 | #directory "_build/sexp/";; 14 | #load "cconv_sexp.cma";; 15 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-docker.sh 3 | script: bash -ex .travis-docker.sh 4 | services: 5 | - docker 6 | env: 7 | global: 8 | - PINS="cconv:. cconv-ppx:." 9 | - DISTRO="ubuntu-16.04" 10 | matrix: 11 | - PACKAGE="cconv" OCAML_VERSION="4.03" EXTRA_DEPS="bencode" TESTS=false 12 | - PACKAGE="cconv" OCAML_VERSION="4.04" EXTRA_DEPS="bencode" TESTS=false 13 | - PACKAGE="cconv" OCAML_VERSION="4.06" EXTRA_DEPS="bencode" TESTS=false 14 | - PACKAGE="cconv" OCAML_VERSION="4.07" EXTRA_DEPS="bencode" TESTS=false 15 | #- PACKAGE="cconv-ppx" OCAML_VERSION="4.02.3" 16 | #- PACKAGE="cconv-ppx" OCAML_VERSION="4.03" 17 | - PACKAGE="cconv-ppx" OCAML_VERSION="4.04" 18 | - PACKAGE="cconv-ppx" OCAML_VERSION="4.06" 19 | - PACKAGE="cconv-ppx" OCAML_VERSION="4.07" 20 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012, Simon Cruanes 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. Redistributions in binary 9 | form must reproduce the above copyright notice, this list of conditions and 10 | the following disclaimer in the documentation and/or other materials 11 | provided with the distribution. 12 | 13 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 14 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 15 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 16 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 17 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 18 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 19 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 20 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 21 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 22 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 23 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) 2 | 3 | # Default rule 4 | default: 5 | @dune build @install 6 | 7 | dev: default test 8 | 9 | install: 10 | @dune install $(INSTALL_ARGS) 11 | 12 | uninstall: 13 | @dune uninstall $(INSTALL_ARGS) 14 | 15 | reinstall: uninstall reinstall 16 | 17 | doc: 18 | @dune build @doc 19 | 20 | test: 21 | @dune runtest --no-buffer --force 22 | 23 | bench: 24 | @dune build @runbench --no-buffer 25 | 26 | clean: 27 | @dune clean 28 | 29 | .PHONY: default install uninstall reinstall doc test bench clean 30 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # CConv [![build status](https://travis-ci.org/c-cube/cconv.svg?branch=master)](https://travis-ci.org/c-cube/cconv) 2 | 3 | Combinators for Type Conversion in OCaml. 4 | 5 | Documentation can be found [here](https://c-cube.github.io/cconv), 6 | and some toy examples in the `example` directory. 7 | 8 | ## Build and Install 9 | 10 | There are no dependencies. This should work with OCaml>=4.03.0. 11 | 12 | ``` 13 | $ make 14 | ``` 15 | 16 | Alternatively: 17 | 18 | ``` 19 | $ opam pin https://github.com/c-cube/cconv.git 20 | ``` 21 | 22 | Optional bindings to serialization libraries are available for `sexplib`, 23 | `yojson` and `bencode`. They will be installed via opam if the corresponding 24 | library is present. See [this section](#backends) to learn how to write 25 | your own serialization backends. 26 | 27 | ## License 28 | 29 | This code is free, under the BSD license. See the `LICENSE` file. 30 | 31 | ## Usage 32 | 33 | From `example/all.ml`: 34 | 35 | ```ocaml 36 | # #require "cconv";; 37 | ``` 38 | 39 | ```ocaml 40 | module Point = struct 41 | type t = { 42 | x : int; 43 | y : int; 44 | color : string; 45 | prev : t option; (* previous position, say *) 46 | } 47 | 48 | 49 | let encode = CConv.Encode.(record_fix 50 | (fun self -> 51 | let o_self = option self in 52 | {record_emit=fun into {x;y;color;prev} -> 53 | [ "x", int.emit into x 54 | ; "y", int.emit into y 55 | ; "color", string.emit into color 56 | ; "prev", o_self.emit into prev 57 | ] 58 | })) 59 | 60 | let decode = CConv.Decode.(record_fix 61 | (fun self -> { record_accept=fun src l -> 62 | let x = record_get "x" int src l in 63 | let y = record_get "y" int src l in 64 | let color = record_get "color" string src l in 65 | let prev = record_get "prev" (option self) src l in 66 | {x;y;color;prev} 67 | }) 68 | ) 69 | 70 | let p = { x=1; y=2; color="red"; prev=None; } 71 | let p2 = {x=1; y=3; color="yellow"; prev=Some p; } 72 | end 73 | ``` 74 | 75 | ```ocaml 76 | # (* convert into json *) 77 | # require "cconv.yojson";; 78 | # CConvYojson.encode Point.encode Point.p;; 79 | - : CConvYojson.t = 80 | `Assoc 81 | [("x", `Int 1); ("y", `Int 2); ("color", `String "red"); 82 | ("prev", `List [])] 83 | 84 | # let json = CConvYojson.encode Point.encode Point.p2;; 85 | val json : CConvYojson.t = 86 | `Assoc 87 | [("x", `Int 1); ("y", `Int 3); ("color", `String "yellow"); 88 | ("prev", 89 | `List 90 | [`Assoc 91 | [("x", `Int 1); ("y", `Int 2); ("color", `String "red"); 92 | ("prev", `List [])]])] 93 | 94 | # let p2' = CConvYojson.decode Point.decode json;; 95 | val p2' : Point.t CConvYojson.or_error = 96 | `Ok 97 | {Point.x = 1; y = 3; color = "yellow"; 98 | prev = Some {Point.x = 1; y = 2; color = "red"; prev = None}} 99 | 100 | # match p2' with `Ok x -> x = Point.p2 | `Error e -> failwith e;; 101 | - : bool = true 102 | ``` 103 | 104 | ```ocaml 105 | module Lambda = struct 106 | type t = 107 | | Var of string 108 | | App of t * t 109 | | Lambda of string * t 110 | 111 | let encode = CConv.Encode.(sum_fix 112 | (fun self -> {sum_emit=fun into t -> match t with 113 | | Var s -> "var", [string.emit into s] 114 | | App (t1,t2) -> "app", [self.emit into t1; self.emit into t2] 115 | | Lambda (v,t') -> "lambda", [string.emit into v; self.emit into t'] 116 | }) 117 | ) 118 | 119 | let decode = CConv.Decode.(sum_fix 120 | (fun self -> { 121 | sum_accept=fun src name args -> match name, args with 122 | | "var", [x] -> 123 | let x = apply src string x in 124 | Var x 125 | | "app", [x;y] -> 126 | let x = apply src self x in 127 | let y = apply src self y in 128 | App(x,y) 129 | | "lambda", [x;y] -> 130 | let x = apply src string x in 131 | let y = apply src self y in 132 | Lambda(x,y) 133 | | _ -> CConv.report_error "expected lambda-term" 134 | }) 135 | ) 136 | 137 | let t1 = Lambda ("x", App (Lambda ("y", App (Var "y", Var "x")), Var "x")) 138 | end 139 | ``` 140 | 141 | ```ocaml 142 | # (*convert into bencode *) 143 | #require "cconv.bencode";; 144 | 145 | # let b = CConvBencode.encode Lambda.encode Lambda.t1;; 146 | val b : Bencode.t = 147 | ... 148 | 149 | # let t2 = CConvBencode.decode Lambda.decode b;; 150 | val t2 : Lambda.t CConvBencode.or_error = 151 | `Ok 152 | (Lambda.Lambda ("x", 153 | Lambda.App 154 | (Lambda.Lambda ("y", Lambda.App (Lambda.Var "y", Lambda.Var "x")), 155 | Lambda.Var "x"))) 156 | ``` 157 | 158 | ## Backends 159 | 160 | It is quite easy to write a backend for your favorite format, assuming it 161 | can somehow represent atoms (strings, integers...), lists, records, sums, and is 162 | recursive. The simplest example is `sexplib` (as found in `sexp/cConvSexp.ml`): 163 | 164 | ```ocaml 165 | # #require "sexplib";; 166 | ``` 167 | 168 | ```ocaml 169 | type t = Sexplib.Sexp.t 170 | 171 | (* how to decode from Sexp *) 172 | let source = 173 | let open Sexplib.Sexp in 174 | let module D = CConv.Decode in 175 | let rec src = {D.emit=fun dec s -> match s with 176 | | Atom s -> dec.D.accept_string src s 177 | | List l -> dec.D.accept_list src l 178 | } in 179 | src 180 | 181 | (* how to encode into Sexp *) 182 | let target = 183 | let open Sexplib.Sexp in 184 | let module E = CConv.Encode in 185 | { E.unit = List []; 186 | bool = (fun b -> Atom (string_of_bool b)); 187 | float = (fun f -> Atom (string_of_float f)); 188 | int = (fun i -> Atom (string_of_int i)); 189 | string = (fun s -> Atom (String.escaped s)); 190 | option = (function None -> List[] | Some x -> List [x]); 191 | list = (fun l -> List l); 192 | char = (fun x -> Atom (String.make 1 x)); 193 | nativeint = (fun i -> Atom (Nativeint.to_string i)); 194 | int32 = (fun i -> Atom (Int32.to_string i)); 195 | int64 = (fun i -> Atom (Int64.to_string i)); 196 | record = (fun l -> List (List.map (fun (a,b) -> List [Atom a; b]) l)); 197 | tuple = (fun l -> List l); 198 | sum = (fun name l -> match l with 199 | | [] -> Atom name 200 | | _::_ -> List (Atom name :: l)); 201 | } 202 | 203 | ``` 204 | 205 | ## ppx_deriving_cconv 206 | 207 | A [ppx_deriving](https://github.com/ocaml-ppx/ppx_deriving) plugin. 208 | The point is to obtain many serializers/deserializers in one stroke. 209 | 210 | ### Usage 211 | 212 | First, `#require "cconv.ppx";;` or use the library `cconv.ppx` (depends 213 | on `ppx_deriving`). It provides three annotations: 214 | 215 | - `[@@deriving cconv]` derives an encoder and a decoder for the type 216 | - `[@@deriving encode]` derives only an encoder (print values) 217 | - `[@@deriving decode]` derives only a decoder (parse values) 218 | 219 | Example: 220 | 221 | ```ocaml 222 | # #require "cconv-ppx";; 223 | 224 | # type t = { 225 | x : int; 226 | y : int; 227 | color : string; 228 | prev : t option; (* previous position, say *) 229 | } [@@deriving cconv] ;; 230 | type t = { x : int; y : int; color : string; prev : t option; } 231 | val encode : t CConv.Encode.encoder = {CConv.Encode.emit = } 232 | val decode : t CConv.Decode.decoder = 233 | ... 234 | 235 | # type term = 236 | | Var of string 237 | | App of term * term 238 | | Lambda of string * term 239 | [@@deriving cconv];; 240 | type term = Var of string | App of term * term | Lambda of string * term 241 | val encode_term : term CConv.Encode.encoder = {CConv.Encode.emit = } 242 | val decode_term : term CConv.Decode.decoder = 243 | ... 244 | ``` 245 | 246 | Encoders/decoders can be used with several backend: 247 | 248 | ```ocaml 249 | # #require "cconv.yojson";; 250 | 251 | # CConvYojson.encode encode_term;; 252 | - : term -> CConvYojson.t = 253 | 254 | # CConvYojson.decode decode_term;; 255 | - : CConvYojson.t -> term CConvYojson.or_error = 256 | 257 | # #require "cconv.bencode";; 258 | # CConvBencode.encode encode_term;; 259 | - : term -> Bencode.t = 260 | 261 | # CConvBencode.decode decode_term;; 262 | - : Bencode.t -> term CConvBencode.or_error = 263 | 264 | # #require "sexplib";; 265 | # #require "cconv.sexp";; 266 | # CConvSexp.encode encode;; 267 | - : t -> CConvSexp.t = 268 | 269 | # CConvSexp.decode decode;; 270 | - : CConvSexp.t -> t CConvSexp.or_error = 271 | 272 | # let json = CConvYojson.encode [%encode: int list] [1;2;3];; 273 | val json : CConvYojson.t = `List [`Int 1; `Int 2; `Int 3] 274 | 275 | # let l = CConvYojson.decode [%decode: float list] json;; 276 | val l : float list CConvYojson.or_error = `Ok [1.; 2.; 3.] 277 | ``` 278 | 279 | ### Options 280 | 281 | Attributes can modify the behavior of `ppx_deriving_cconv`. They are as follows: 282 | 283 | - `[@encoder e]` to specify an encoder for a record field of variant argument. type attribute 284 | - `[@decoder d]` to specify a decoder for a record field or variant argument. type attribute 285 | 286 | ```ocaml 287 | type boxed_int = { 288 | bint : int; 289 | } [@@deriving cconv] 290 | 291 | let box_int bint = {bint} 292 | let unbox_int {bint} = bint 293 | 294 | type t = { 295 | i : (int 296 | [@encoder CConv.Encode.(map box_int encode_boxed_int)] 297 | [@decoder CConv.Decode.(map unbox_int decode_boxed_int)]); 298 | j : int; 299 | } [@@deriving cconv] 300 | ``` 301 | 302 | ```ocaml 303 | # CConvYojson.of_string_exn decode "{\"i\": {\"bint\": 100}, \"j\": 10}";; 304 | - : t = {i = 100; j = 10} 305 | ``` 306 | 307 | - `[@cconv.ignore]` to ignore the field for encoding (decoding will still require it) 308 | - `[@default expr]` to specify default value for a record field 309 | ```ocaml 310 | type pagination = { 311 | pages : int; 312 | current : int [@default 0]; 313 | } [@@deriving cconv] 314 | ``` 315 | 316 | - `[@key name]` to specify a name of record field in encoder / decoder 317 | ```ocaml 318 | type geo = { 319 | lat : float [@key "Latitude"]; 320 | lon : float [@key "Longitude"]; 321 | } [@@deriving cconv] 322 | ``` 323 | -------------------------------------------------------------------------------- /cconv-ppx.opam: -------------------------------------------------------------------------------- 1 | name: "cconv-ppx" 2 | version: "0.5" 3 | opam-version: "2.0" 4 | synopsis: "Combinators for Type Conversion in OCaml" 5 | author: "Simon Cruanes" 6 | maintainer: "simon.cruanes.2007@m4x.org" 7 | build: [ 8 | ["dune" "build" "-p" name "-j" jobs] 9 | ["dune" "build" "@doc" "-p" name] {with-doc} 10 | ["dune" "runtest" "-p" name] {with-test} 11 | ] 12 | depends: [ 13 | "dune" {build} 14 | "ocamlfind" {build} 15 | "cconv" 16 | "ppx_deriving" { >= "2.0" } 17 | "ppxlib" 18 | "cppo" {build} 19 | "ppx_tools" {build} 20 | "ppxfind" {build} 21 | "ocaml" { >= "4.02" } 22 | 23 | "mdx" {with-test} 24 | "sexplib" {with-test} 25 | "yojson" {with-test} 26 | "bencode" {with-test} 27 | "ounit" {with-test} 28 | ] 29 | tags: ["conversion" "gadt" "serialization" "ppx-deriving"] 30 | homepage: "https://github.com/c-cube/cconv/" 31 | doc: "https://c-cube.github.io/cconv" 32 | dev-repo: "git+https://github.com/c-cube/cconv.git" 33 | bug-reports: "https://github.com/c-cube/cconv/issues/" 34 | -------------------------------------------------------------------------------- /cconv.opam: -------------------------------------------------------------------------------- 1 | name: "cconv" 2 | version: "0.5" 3 | opam-version: "2.0" 4 | synopsis: "Combinators for Type Conversion in OCaml" 5 | author: "Simon Cruanes" 6 | maintainer: "simon.cruanes.2007@m4x.org" 7 | build: [ 8 | ["dune" "build" "-p" name "-j" jobs] 9 | ["dune" "build" "@doc" "-p" name] {with-doc} 10 | # ["dune" "runtest" "-p" name] {with-test} 11 | ] 12 | depends: [ 13 | "dune" {build} 14 | "ocaml" { >= "4.02" } 15 | ] 16 | depopts: [ 17 | "bencode" 18 | "sexplib" 19 | "yojson" 20 | ] 21 | tags: ["conversion" "gadt" "serialization"] 22 | homepage: "https://github.com/c-cube/cconv/" 23 | doc: "https://c-cube.github.io/cconv" 24 | dev-repo: "git+https://github.com/c-cube/cconv.git" 25 | bug-reports: "https://github.com/c-cube/cconv/issues/" 26 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | 2 | (alias 3 | (name runtest) 4 | (deps README.md) 5 | (action (progn 6 | (run mdx test %{deps}) 7 | (diff? %{deps} %{deps}.corrected)))) 8 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.1) 2 | -------------------------------------------------------------------------------- /src/bench/dune: -------------------------------------------------------------------------------- 1 | 2 | (executable 3 | (name run_bench) 4 | (libraries cconv cconv.yojson yojson benchmark ppx_deriving_yojson.runtime) 5 | (preprocess (pps ppx_deriving_yojson))) 6 | 7 | (alias 8 | (name runbench) 9 | (deps run_bench.exe) 10 | (action (run %{deps} -p encode -p decode))) 11 | -------------------------------------------------------------------------------- /src/bench/run_bench.ml: -------------------------------------------------------------------------------- 1 | 2 | (* benchmark encoding *) 3 | open Result 4 | 5 | module Point = struct 6 | type t = { 7 | x : int; 8 | y : int; 9 | color : string; 10 | prev : t option; (* previous position, say *) 11 | } [@@deriving yojson] 12 | 13 | let encode = CConv.Encode.(record_fix 14 | (fun self -> 15 | let o_self = option self in 16 | {record_emit=fun into {x;y;color;prev} -> 17 | [ "x", int.emit into x 18 | ; "y", int.emit into y 19 | ; "color", string.emit into color 20 | ; "prev", o_self.emit into prev 21 | ] 22 | } 23 | ) 24 | ) ;; 25 | 26 | let decode = CConv.Decode.(record_fix 27 | (fun self -> { record_accept=fun src l -> 28 | let x = record_get "x" int src l in 29 | let y = record_get "y" int src l in 30 | let color = record_get "color" string src l in 31 | let prev = record_get "prev" (option self) src l in 32 | {x;y;color;prev} 33 | }) 34 | ) 35 | 36 | let p = { x=1; y=2; color="red"; prev=None; } 37 | let p' = {x=1; y=3; color="yellow"; prev=Some p; } 38 | 39 | (* manual *) 40 | let rec to_json p = `Assoc 41 | [ "x", `Int p.x 42 | ; "y", `Int p.y 43 | ; "color", `String p.color 44 | ; "prev", match p.prev with 45 | | None -> `Null 46 | | Some p' -> to_json p' 47 | ] 48 | end 49 | 50 | module Lambda = struct 51 | type t = 52 | | Var of string 53 | | App of t * t 54 | | Lambda of string * t 55 | [@@deriving yojson] 56 | 57 | let encode = CConv.Encode.(sum_fix 58 | (fun self -> {sum_emit=fun into t -> match t with 59 | | Var s -> "var", [string.emit into s] 60 | | App (t1,t2) -> "app", [self.emit into t1; self.emit into t2] 61 | | Lambda (v,t') -> "lambda", [string.emit into v; self.emit into t'] 62 | }) 63 | ) 64 | 65 | let decode = CConv.Decode.(sum_fix 66 | (fun self -> { 67 | sum_accept=fun src name args -> match name, args with 68 | | "var", [x] -> 69 | let x = apply src string x in 70 | Var x 71 | | "app", [x;y] -> 72 | let x = apply src self x in 73 | let y = apply src self y in 74 | App(x,y) 75 | | "lambda", [x;y] -> 76 | let x = apply src string x in 77 | let y = apply src self y in 78 | Lambda(x,y) 79 | | _ -> CConv.report_error "expected lambda-term" 80 | }) 81 | ) 82 | 83 | let t1 = Lambda ("x", App (Lambda ("y", App (Var "y", Var "x")), Var "x")) 84 | 85 | let rec to_json = function 86 | | Var s -> `List [`String "var"; `String s] 87 | | App (t1,t2) -> `List [`String "app"; to_json t1; to_json t2] 88 | | Lambda(x,t) -> `List [`String "lambda"; `String x; to_json t] 89 | end 90 | 91 | (* encode x with encoder *) 92 | let bench_encoding encoder x = 93 | for _ = 1 to 10 do 94 | ignore (encoder x) 95 | done 96 | 97 | let bench_encoding_point () = 98 | print_endline "\nbenchmark points"; 99 | Benchmark.throughputN 4 100 | [ "manual", bench_encoding Point.to_json, Point.p' 101 | ; "cconv", bench_encoding (CConvYojson.encode Point.encode), Point.p' 102 | ; "deriving_yojson", bench_encoding Point.to_yojson, Point.p' 103 | ] 104 | 105 | let bench_encoding_term () = 106 | print_endline "\nbenchmark terms"; 107 | Benchmark.throughputN 4 108 | [ "manual", bench_encoding Lambda.to_json, Lambda.t1 109 | ; "cconv", bench_encoding (CConvYojson.encode Lambda.encode), Lambda.t1 110 | ; "deriving_yojson", bench_encoding Lambda.to_yojson, Lambda.t1 111 | ] 112 | 113 | (* decode x with decoder *) 114 | let bench_decoding dec x () = 115 | for _ = 1 to 10 do 116 | match dec x with 117 | | `Error msg -> failwith msg 118 | | `Ok _ -> () 119 | done 120 | 121 | let bench_decoding_result dec x () = 122 | for _ = 1 to 10 do 123 | match dec x with 124 | | Error msg -> failwith msg 125 | | Ok _ -> () 126 | done 127 | 128 | 129 | let bench_decoding_point () = 130 | print_endline "\nbenchmark points"; 131 | let j1 = CConvYojson.encode Point.encode Point.p' in 132 | let j2 = Point.to_yojson Point.p' in 133 | Benchmark.throughputN 3 134 | [ "cconv", bench_decoding (CConvYojson.decode Point.decode) j1, () 135 | ; "deriving_yojson", bench_decoding_result Point.of_yojson j2, () 136 | ] 137 | 138 | let bench_decoding_term () = 139 | print_endline "\nbenchmark terms"; 140 | let j1 = CConvYojson.encode Lambda.encode Lambda.t1 in 141 | let j2 = Lambda.to_yojson Lambda.t1 in 142 | Benchmark.throughputN 3 143 | [ "cconv", bench_decoding (CConvYojson.decode Lambda.decode) j1, () 144 | ; "deriving_yojson", bench_decoding_result Lambda.of_yojson j2, () 145 | ] 146 | 147 | 148 | let () = 149 | Benchmark.(Tree.(register ( 150 | concat 151 | [ "encode" @>> "point" @> lazy (bench_encoding_point ()) 152 | ; "encode" @>> "term" @> lazy (bench_encoding_term ()) 153 | ; "decode" @>> "point" @> lazy (bench_decoding_point ()) 154 | ; "decode" @>> "term" @> lazy (bench_decoding_term ()) 155 | ] 156 | ))); 157 | Benchmark.Tree.run_global () 158 | -------------------------------------------------------------------------------- /src/bencode/cConvBencode.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * CBencode - interface to Bencode 3 | * Copyright (C) 2014 Simon Cruanes 4 | * 5 | * This library is free software; you can redistribute it and/or 6 | * modify it under the terms of the GNU Lesser General Public 7 | * License as published by the Free Software Foundation; either 8 | * version 2.1 of the License, or (at your option) any later version, 9 | * with the special exception on linking described in file LICENSE. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Lesser General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU Lesser General Public 17 | * License along with this library; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | *) 20 | 21 | type 'a or_error = [ `Ok of 'a | `Error of string ] 22 | type t = Bencode.t 23 | 24 | let source = 25 | let module D = CConv.Decode in 26 | let rec src = {D.emit=fun dec b -> match b with 27 | | Bencode.String s -> dec.D.accept_string src s 28 | | Bencode.Integer i -> dec.D.accept_int src i 29 | | Bencode.List l -> dec.D.accept_list src l 30 | | Bencode.Dict l -> dec.D.accept_record src l 31 | } in 32 | src 33 | 34 | let output = 35 | let module E = CConv.Encode in 36 | { E.unit = Bencode.Integer 0; 37 | bool = (fun b -> Bencode.Integer (if b then 1 else 0)); 38 | float = (fun f -> Bencode.String (string_of_float f)); 39 | char = (fun x -> Bencode.String (String.make 1 x)); 40 | nativeint = (fun i -> Bencode.Integer (Nativeint.to_int i)); 41 | int32 = (fun i -> Bencode.Integer (Int32.to_int i)); 42 | int64 = (fun i -> Bencode.Integer (Int64.to_int i)); 43 | int = (fun i -> Bencode.Integer i); 44 | string = (fun s -> Bencode.String s); 45 | option = (function None -> Bencode.List[] | Some x -> Bencode.List [x]); 46 | list = (fun l -> Bencode.List l); 47 | record = (fun l -> Bencode.Dict l); 48 | tuple = (fun l -> Bencode.List l); 49 | sum = (fun name l -> match l with 50 | | [] -> Bencode.String name 51 | | _::_ -> Bencode.List (Bencode.String name :: l)); 52 | } 53 | 54 | let bencode_to_string = Bencode.encode_to_string 55 | 56 | let encode src x = CConv.encode src output x 57 | 58 | let decode dec x = CConv.decode source dec x 59 | 60 | let decode_exn dec x = CConv.decode_exn source dec x 61 | 62 | let to_string src x = 63 | bencode_to_string (encode src x) 64 | 65 | let of_string dec s = 66 | try 67 | let x = Bencode.decode (`String s) in 68 | decode dec x 69 | with Failure _ -> 70 | `Error "invalid B-encode string" 71 | 72 | let of_string_exn dec s = 73 | let x = Bencode.decode (`String s) in 74 | decode_exn dec x 75 | -------------------------------------------------------------------------------- /src/bencode/cConvBencode.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * CBencode - interface to Bencode 3 | * Copyright (C) 2014 Simon Cruanes 4 | * 5 | * This library is free software; you can redistribute it and/or 6 | * modify it under the terms of the GNU Lesser General Public 7 | * License as published by the Free Software Foundation; either 8 | * version 2.1 of the License, or (at your option) any later version, 9 | * with the special exception on linking described in file LICENSE. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Lesser General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU Lesser General Public 17 | * License along with this library; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | *) 20 | 21 | (** {1 Interface to Bencode} *) 22 | 23 | type 'a or_error = [ `Ok of 'a | `Error of string ] 24 | 25 | type t = Bencode.t 26 | 27 | val output : t CConv.Encode.output 28 | val source : t CConv.Decode.source 29 | 30 | val encode : 'src CConv.Encode.encoder -> 'src -> t 31 | val decode_exn : 'into CConv.Decode.decoder -> t -> 'into 32 | val decode : 'into CConv.Decode.decoder -> t -> 'into or_error 33 | 34 | val to_string : 'a CConv.Encode.encoder -> 'a -> string 35 | val of_string : 'a CConv.Decode.decoder -> string -> 'a or_error 36 | val of_string_exn : 'a CConv.Decode.decoder -> string -> 'a 37 | 38 | val bencode_to_string : t -> string 39 | -------------------------------------------------------------------------------- /src/bencode/dune: -------------------------------------------------------------------------------- 1 | 2 | (library 3 | (name CConvBencode) 4 | (public_name cconv.bencode) 5 | (synopsis "Combinators for Conversion (bencode)") 6 | (optional) 7 | (libraries cconv bencode)) 8 | -------------------------------------------------------------------------------- /src/core/CConv.ml: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | copyright (c) 2013-2014, simon cruanes 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. redistributions in binary 11 | form must reproduce the above copyright notice, this list of conditions and the 12 | following disclaimer in the documentation and/or other materials provided with 13 | the distribution. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 16 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 19 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 20 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 21 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 22 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 23 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 24 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | *) 26 | 27 | (** {1 Bidirectional Conversion} *) 28 | 29 | exception ConversionFailure of string 30 | 31 | exception IntermediateFailure of (string list * string) 32 | 33 | type 'a sequence = ('a -> unit) -> unit 34 | 35 | (* error-raising function *) 36 | let report_error msg = 37 | let b = Buffer.create 15 in 38 | Printf.bprintf b "conversion error: "; 39 | Printf.kbprintf 40 | (fun b -> raise (IntermediateFailure ([], (Buffer.contents b)))) 41 | b msg 42 | 43 | let formatted_error path msg = 44 | let path' = (String.concat " / " path) in 45 | raise (ConversionFailure (Printf.sprintf "%s at %s" msg path')) 46 | 47 | (* function to look up the given name in an association list *) 48 | let _get_field l name = 49 | try List.assoc name l 50 | with Not_found -> 51 | report_error "record field %s not found in source" name 52 | 53 | module Encode = struct 54 | type 'a output = { 55 | unit : 'a; 56 | bool : bool -> 'a; 57 | float : float -> 'a; 58 | char : char -> 'a; 59 | int : int -> 'a; 60 | nativeint : nativeint -> 'a; 61 | int32 : int32 -> 'a; 62 | int64 : int64 -> 'a; 63 | string : string -> 'a; 64 | list : 'a list -> 'a; 65 | option : 'a option -> 'a; 66 | record : (string * 'a) list -> 'a; 67 | tuple : 'a list -> 'a; 68 | sum : string -> 'a list -> 'a; 69 | } 70 | 71 | let string_target = { 72 | unit="()"; 73 | bool=string_of_bool; 74 | char=String.make 1; 75 | int=string_of_int; 76 | nativeint=Nativeint.to_string; 77 | int32=Int32.to_string; 78 | int64=Int64.to_string; 79 | float=string_of_float; 80 | string=(fun s -> "\"" ^ s ^ "\""); 81 | list=(fun l -> Printf.sprintf "[%s]" (String.concat "; " l)); 82 | record=(fun l -> 83 | let l = List.map (fun (name,s) -> name ^ "=" ^ s) l in 84 | Printf.sprintf "{%s}" (String.concat "; " l) 85 | ); 86 | option=(function None -> "None" | Some x -> "Some " ^ x); 87 | sum=(fun name l -> match l with 88 | | [] -> name 89 | | [x] -> Printf.sprintf "%s (%s)" name x 90 | | _ -> Printf.sprintf "%s (%s)" name (String.concat ", " l) 91 | ); 92 | tuple=(fun l -> Printf.sprintf "(%s)" (String.concat ", " l)); 93 | } 94 | 95 | type -'src encoder = { 96 | emit : 'into. 'into output -> 'src -> 'into 97 | } 98 | 99 | let unit = {emit=fun into () -> into.unit} 100 | let char = {emit=fun into x -> into.char x} 101 | let int = {emit=fun into i -> into.int i} 102 | let nativeint = {emit=fun into i -> into.nativeint i} 103 | let int32 = {emit=fun into i -> into.int32 i} 104 | let int64 = {emit=fun into i -> into.int64 i} 105 | let bool = {emit=fun into b -> into.bool b} 106 | let float = {emit=fun into f -> into.float f} 107 | let string = {emit=fun into s -> into.string s} 108 | let list encode_x = 109 | {emit=fun into l -> into.list (List.map (encode_x.emit into) l)} 110 | 111 | let option encode_x = 112 | {emit=fun into x -> match x with 113 | | None -> into.option None 114 | | Some x -> into.option (Some (encode_x.emit into x)) 115 | } 116 | 117 | let map f encode_fx = {emit=fun into x -> encode_fx.emit into (f x)} 118 | 119 | let array encode_x = {emit=fun into a -> 120 | into.list (Array.to_list (Array.map (encode_x.emit into) a)) 121 | } 122 | 123 | let seq_to_list seq = 124 | let r = ref [] in 125 | seq (fun x -> r := x :: !r); 126 | List.rev !r 127 | 128 | let sequence encode_x = 129 | map seq_to_list (list encode_x) 130 | 131 | (** {6 Composite Types} *) 132 | 133 | let apply into enc x = enc.emit into x 134 | 135 | type 'r record_encoder = { 136 | record_emit : 'into. 'into output -> 'r -> (string * 'into) list; 137 | } 138 | 139 | let record f = {emit=fun into r -> 140 | into.record (f.record_emit into r) 141 | } 142 | 143 | let record_fix f = 144 | let rec f' = {emit=fun into r -> 145 | let fields = (Lazy.force emit).record_emit into r in 146 | into.record fields 147 | } and emit = lazy (f f') in 148 | f' 149 | 150 | type 't tuple_encoder = { 151 | tuple_emit : 'into. 'into output -> 't -> 'into list; 152 | } 153 | 154 | let tuple f = {emit=fun into x -> 155 | into.tuple (f.tuple_emit into x) 156 | } 157 | 158 | let pair enc_x enc_y = {emit=fun into (x,y) -> 159 | into.tuple [enc_x.emit into x; enc_y.emit into y] 160 | } 161 | 162 | let triple enc_x enc_y enc_z = {emit=fun into (x,y,z) -> 163 | into.tuple [enc_x.emit into x; enc_y.emit into y; enc_z.emit into z] 164 | } 165 | 166 | let quad enc_x enc_y enc_z enc_w = {emit=fun into (x,y,z,w) -> 167 | into.tuple [enc_x.emit into x; enc_y.emit into y; 168 | enc_z.emit into z; enc_w.emit into w] 169 | } 170 | 171 | type 's sum_encoder = { 172 | sum_emit : 'into. 'into output -> 's -> string * 'into list 173 | } 174 | 175 | let sum f = {emit=fun into x -> 176 | let name, args = f.sum_emit into x in 177 | into.sum name args 178 | } 179 | 180 | let sum0 f = {emit=fun into x -> 181 | let name = f x in 182 | into.sum name [] 183 | } 184 | 185 | let sum_fix f = 186 | let rec f' = {emit=fun into x -> 187 | let name, args = (Lazy.force emit).sum_emit into x in 188 | into.sum name args 189 | } 190 | and emit = lazy (f f') in 191 | f' 192 | end 193 | 194 | module Decode = struct 195 | type 'src source = { 196 | emit : 'a. ('src,'a) inner_decoder -> 'src -> 'a; 197 | } (** Decode a value of type 'src *) 198 | 199 | and ('src, 'into) inner_decoder = { 200 | accept_unit : 'src source -> unit -> 'into; 201 | accept_bool : 'src source -> bool -> 'into; 202 | accept_float : 'src source -> float -> 'into; 203 | accept_int : 'src source -> int -> 'into; 204 | accept_int32 : 'src source -> int32 -> 'into; 205 | accept_int64 : 'src source -> int64 -> 'into; 206 | accept_nativeint : 'src source -> nativeint -> 'into; 207 | accept_char : 'src source -> char -> 'into; 208 | accept_string : 'src source -> string -> 'into; 209 | accept_list : 'src source -> 'src list -> 'into; 210 | accept_option : 'src source -> 'src option -> 'into; 211 | accept_record : 'src source -> (string * 'src) list -> 'into; 212 | accept_tuple : 'src source -> 'src list -> 'into; 213 | accept_sum : 'src source -> string -> 'src list -> 'into; 214 | } (** Decode a value of type 'src into a type 'into. 215 | The user must provide all functions but [accept] *) 216 | 217 | type 'into decoder = { 218 | dec : 'src. ('src, 'into) inner_decoder; 219 | } 220 | 221 | let apply_inner src dec x = src.emit dec x 222 | let apply src dec x = src.emit dec.dec x 223 | 224 | let fail_ obtained = report_error "unexpected %s" obtained 225 | 226 | let failing = 227 | { accept_unit=(fun _ _ -> fail_ "unit") 228 | ; accept_int=(fun _ _ -> fail_ "int") 229 | ; accept_nativeint=(fun _ _ -> fail_ "nativeint") 230 | ; accept_int32=(fun _ _ -> fail_ "int32") 231 | ; accept_int64=(fun _ _ -> fail_ "int64") 232 | ; accept_char=(fun _ _ -> fail_ "char") 233 | ; accept_float=(fun _ _ -> fail_ "float") 234 | ; accept_bool=(fun _ _ -> fail_ "bool") 235 | ; accept_string=(fun _ _ -> fail_ "string") 236 | ; accept_list=(fun _ _ -> fail_ "list") 237 | ; accept_option=(fun _ _ -> fail_ "option") 238 | ; accept_sum=(fun _ _ _ -> fail_ "sum") 239 | ; accept_record=(fun _ _ -> fail_ "record") 240 | ; accept_tuple=(fun _ _ -> fail_ "tuple") 241 | } 242 | 243 | let char = {dec={ 244 | failing with 245 | accept_char=(fun _ c -> c); 246 | accept_int=(fun _ x -> Char.chr x); 247 | accept_string=(fun _ s -> 248 | if String.length s = 1 then String.get s 0 else fail_ "string" 249 | ); 250 | }} 251 | 252 | let int = {dec={ 253 | failing with 254 | accept_int=(fun _ x -> x); 255 | accept_nativeint=(fun _ x -> Nativeint.to_int x); 256 | accept_int32=(fun _ x -> Int32.to_int x); 257 | accept_int64=(fun _ x -> Int64.to_int x); 258 | accept_float=(fun _ x-> int_of_float x); 259 | accept_string=(fun _ s -> 260 | try int_of_string s with Failure _ -> fail_ "string" 261 | ); 262 | }} 263 | 264 | let nativeint = {dec={ 265 | failing with 266 | accept_int=(fun _ x -> Nativeint.of_int x); 267 | accept_nativeint=(fun _ x -> x); 268 | accept_int32=(fun _ x -> Nativeint.of_int32 x); 269 | accept_int64=(fun _ x -> Int64.to_nativeint x); 270 | accept_float=(fun _ x-> Nativeint.of_float x); 271 | accept_string=(fun _ s -> 272 | try Nativeint.of_string s with Failure _ -> fail_ "string" 273 | ); 274 | }} 275 | 276 | let int32 = {dec={ 277 | failing with 278 | accept_int=(fun _ x -> Int32.of_int x); 279 | accept_nativeint=(fun _ x -> Nativeint.to_int32 x); 280 | accept_int32=(fun _ x -> x); 281 | accept_int64=(fun _ x -> Int64.to_int32 x); 282 | accept_float=(fun _ x-> Int32.of_float x); 283 | accept_string=(fun _ s -> 284 | try Int32.of_string s with Failure _ -> fail_ "string" 285 | ); 286 | }} 287 | 288 | let int64 = {dec={ 289 | failing with 290 | accept_int=(fun _ x -> Int64.of_int x); 291 | accept_nativeint=(fun _ x -> Int64.of_nativeint x); 292 | accept_int32=(fun _ x -> Int64.of_int32 x); 293 | accept_int64=(fun _ x -> x); 294 | accept_float=(fun _ x-> Int64.of_float x); 295 | accept_string=(fun _ s -> 296 | try Int64.of_string s with Failure _ -> fail_ "string" 297 | ); 298 | }} 299 | 300 | let bool = {dec={ 301 | failing with 302 | accept_bool=(fun _ x ->x); 303 | accept_int=(fun _ i -> if i=0 then false else true); 304 | accept_string=(fun _ s -> match s with 305 | | "true" | "True" -> true 306 | | "false" | "False" -> false 307 | | s -> fail_ s 308 | ); 309 | }} 310 | 311 | let unit = {dec={ 312 | failing with 313 | accept_unit=(fun _ _ ->()); 314 | accept_int=(fun _ i -> if i=0 then () else fail_ "expected unit"); 315 | accept_int32=(fun _ i -> if i=0l then () else fail_ "expected unit"); 316 | accept_int64=(fun _ i -> if i=0L then () else fail_ "expected unit"); 317 | accept_string=(fun _ s -> match s with 318 | | "()" -> () 319 | | s -> fail_ s 320 | ); 321 | }} 322 | 323 | let float = {dec={ 324 | failing with 325 | accept_float=(fun _ x->x); 326 | accept_int=(fun _ x -> float_of_int x); 327 | accept_string=(fun _ s -> 328 | try float_of_string s with Failure _ -> fail_ s 329 | ); 330 | }} 331 | 332 | let string = {dec={ 333 | failing with 334 | accept_float=(fun _ x -> string_of_float x); 335 | accept_int=(fun _ -> string_of_int); 336 | accept_unit=(fun _ _ -> "()"); 337 | accept_bool=(fun _ x ->string_of_bool x); 338 | accept_string=(fun _ x -> x); 339 | accept_sum=(fun _src name args -> 340 | if args=[] then name else fail_ "sum" 341 | ); 342 | }} 343 | 344 | let list dec_x = 345 | let emitter src l = 346 | let wrapper i v = 347 | try src.emit dec_x.dec v 348 | with IntermediateFailure (path, msg) -> 349 | raise (IntermediateFailure ((string_of_int i)::path, msg)) 350 | in 351 | List.mapi wrapper l in 352 | {dec={ 353 | failing with 354 | accept_list=emitter; 355 | accept_tuple=emitter; 356 | accept_option=(fun src o -> match o with 357 | | None -> [] 358 | | Some x -> [src.emit dec_x.dec x] 359 | ); 360 | }} 361 | 362 | let option dec_x = {dec={ 363 | failing with 364 | accept_option=(fun src o -> match o with 365 | | None -> None 366 | | Some x -> Some (src.emit dec_x.dec x) 367 | ); 368 | accept_list=(fun src l -> match l with 369 | | [] -> None 370 | | [x] -> Some (src.emit dec_x.dec x) 371 | | _ -> report_error "expected option, got list" 372 | ); 373 | accept_unit=(fun _src () -> None); 374 | }} 375 | 376 | let map f d = {dec= 377 | { accept_unit=(fun src x -> f (d.dec.accept_unit src x)) 378 | ; accept_bool=(fun src x -> f (d.dec.accept_bool src x)) 379 | ; accept_float=(fun src x -> f (d.dec.accept_float src x)) 380 | ; accept_char=(fun src x -> f (d.dec.accept_char src x)) 381 | ; accept_int=(fun src x -> f (d.dec.accept_int src x)) 382 | ; accept_int32=(fun src x -> f (d.dec.accept_int32 src x)) 383 | ; accept_int64=(fun src x -> f (d.dec.accept_int64 src x)) 384 | ; accept_nativeint=(fun src x -> f (d.dec.accept_nativeint src x)) 385 | ; accept_string=(fun src x -> f (d.dec.accept_string src x)) 386 | ; accept_list=(fun src l -> f (d.dec.accept_list src l)) 387 | ; accept_option=(fun src x -> f (d.dec.accept_option src x)) 388 | ; accept_record=(fun src l -> f (d.dec.accept_record src l)) 389 | ; accept_tuple=(fun src l -> f (d.dec.accept_tuple src l)) 390 | ; accept_sum=(fun src name l -> f (d.dec.accept_sum src name l)) 391 | }} 392 | 393 | let array dec_x = map Array.of_list (list dec_x) 394 | 395 | let seq_of_list l yield = List.iter yield l 396 | 397 | let sequence dec_x = map seq_of_list (list dec_x) 398 | 399 | let fail_accept_ expected = 400 | report_error "expected %s" expected 401 | 402 | let arg0 = function 403 | | [] -> () 404 | | _ -> fail_accept_ "empty list" 405 | 406 | let arg1 dec src = function 407 | | [x] -> src.emit dec.dec x 408 | | _ -> fail_accept_ "one-element list" 409 | 410 | let arg2 dec_x dec_y src = function 411 | | [x;y] -> src.emit dec_x.dec x, src.emit dec_y.dec y 412 | | _ -> fail_accept_ "2 elements" 413 | 414 | let arg3 dec_x dec_y dec_z src = function 415 | | [x;y;z] -> src.emit dec_x.dec x, src.emit dec_y.dec y, src.emit dec_z.dec z 416 | | _ -> fail_accept_ "3 elements" 417 | 418 | let pair dec_x dec_y = {dec={ 419 | failing with 420 | accept_list=(fun src l -> arg2 dec_x dec_y src l); 421 | accept_tuple=(fun src l -> arg2 dec_x dec_y src l); 422 | }} 423 | 424 | let triple dec_x dec_y dec_z = {dec={ 425 | failing with 426 | accept_list=(fun src l -> arg3 dec_x dec_y dec_z src l); 427 | accept_tuple=(fun src l -> arg3 dec_x dec_y dec_z src l); 428 | }} 429 | 430 | let record_get_opt name dec src l = 431 | let rec getter = function 432 | [] -> None 433 | | (name', x) :: _ when name=name' -> Some (src.emit dec.dec x) 434 | | _ :: tail -> getter tail in 435 | try getter l 436 | with IntermediateFailure (path, msg) -> 437 | raise (IntermediateFailure (name::path, msg)) 438 | 439 | let record_get name dec src l = 440 | match record_get_opt name dec src l with 441 | | Some v -> v 442 | | None -> report_error "could not find record field %s" name 443 | 444 | type 'into record_decoder = { 445 | record_accept : 'src. 'src source -> (string * 'src) list -> 'into; 446 | } 447 | 448 | (* put an item of an association list into [r] *) 449 | let get_assoc_pair () = { 450 | failing with 451 | accept_list=(fun src l -> match l with 452 | | [s; x] -> src.emit string.dec s, x 453 | | _ -> fail_accept_ "expected pair string/value" 454 | ); 455 | } 456 | 457 | let get_assoc_list src l = 458 | let getter = get_assoc_pair () in 459 | List.map (fun p -> src.emit getter p) l 460 | 461 | let record f = {dec={ 462 | failing with 463 | accept_record=(fun src l -> f.record_accept src l); 464 | accept_list=(fun src l -> 465 | let assoc = get_assoc_list src l in 466 | f.record_accept src assoc 467 | ); 468 | accept_tuple=(fun src l -> 469 | let assoc = get_assoc_list src l in 470 | f.record_accept src assoc 471 | ); 472 | }} 473 | 474 | let record_fix make_f = 475 | let rec self = lazy (record { 476 | record_accept=fun src l -> (Lazy.force f).record_accept src l 477 | }) 478 | and f = lazy (make_f (Lazy.force self)) in 479 | Lazy.force self 480 | 481 | type 'into sum_decoder = { 482 | sum_accept : 'src. 'src source -> string -> 'src list -> 'into; 483 | } 484 | 485 | let sum f = {dec={ 486 | failing with 487 | accept_sum=(fun src name args -> f.sum_accept src name args); 488 | accept_string=(fun src s -> f.sum_accept src s []); 489 | accept_list=(fun src l -> match l with 490 | | name::args -> 491 | let name = apply_inner src string.dec name in 492 | f.sum_accept src name args 493 | | [] -> fail_ "empty list when expecting sum" 494 | ); 495 | accept_tuple=(fun src l -> match l with 496 | | name::args -> 497 | let name = apply_inner src string.dec name in 498 | f.sum_accept src name args 499 | | [] -> fail_ "empty tuple when expecting sum" 500 | ); 501 | }} 502 | 503 | let sum_fix make_f = 504 | let rec self = lazy (sum { 505 | sum_accept=fun src name args -> (Lazy.force f).sum_accept src name args 506 | }) 507 | and f = lazy (make_f (Lazy.force self)) in 508 | Lazy.force self 509 | 510 | type 'into tuple_decoder = { 511 | tuple_accept : 'src. 'src source -> 'src list -> 'into; 512 | } 513 | 514 | let tuple f = {dec={ 515 | failing with 516 | accept_tuple=(fun src l -> f.tuple_accept src l); 517 | accept_list=(fun src l -> f.tuple_accept src l); 518 | }} 519 | end 520 | 521 | let encode enc target x = enc.Encode.emit target x 522 | 523 | let to_string enc x = enc.Encode.emit Encode.string_target x 524 | 525 | let decode_exn src dec x = 526 | try src.Decode.emit dec.Decode.dec x 527 | with 528 | | IntermediateFailure ([], msg) -> raise (ConversionFailure msg) 529 | | IntermediateFailure (path, msg) -> formatted_error path msg 530 | 531 | type 'a or_error = [ `Ok of 'a | `Error of string ] 532 | 533 | let decode src dec x = 534 | try `Ok (decode_exn src dec x) 535 | with ConversionFailure msg -> `Error msg 536 | -------------------------------------------------------------------------------- /src/core/CConv.mli: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | copyright (c) 2013-2014, simon cruanes 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. redistributions in binary 11 | form must reproduce the above copyright notice, this list of conditions and the 12 | following disclaimer in the documentation and/or other materials provided with 13 | the distribution. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 16 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 19 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 20 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 21 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 22 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 23 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 24 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | *) 26 | 27 | (** {1 Bidirectional Conversion} *) 28 | 29 | exception ConversionFailure of string 30 | 31 | type 'a sequence = ('a -> unit) -> unit 32 | 33 | val report_error : ('a, Buffer.t, unit, 'b) format4 -> 'a 34 | (** Helper to report conversion errors. 35 | @raise ConversionFailure if the conversion failed (!) *) 36 | 37 | (** {2 Encode} 38 | 39 | Helps encoding values into a serialization format (building 40 | values of some type 'a, such as a JSON tree) *) 41 | 42 | module Encode : sig 43 | type 'a output = { 44 | unit : 'a; 45 | bool : bool -> 'a; 46 | float : float -> 'a; 47 | char : char -> 'a; 48 | int : int -> 'a; 49 | nativeint : nativeint -> 'a; 50 | int32 : int32 -> 'a; 51 | int64 : int64 -> 'a; 52 | string : string -> 'a; 53 | list : 'a list -> 'a; 54 | option : 'a option -> 'a; 55 | record : (string * 'a) list -> 'a; 56 | tuple : 'a list -> 'a; 57 | sum : string -> 'a list -> 'a; 58 | } 59 | 60 | val string_target : string output 61 | (** Print values. Caution, inefficient! Should be used for debugging only *) 62 | 63 | type -'src encoder = { 64 | emit : 'into. 'into output -> 'src -> 'into 65 | } (** A way to encode values of type ['src] into any serialization format *) 66 | 67 | val unit : unit encoder 68 | val bool : bool encoder 69 | val float : float encoder 70 | val char : char encoder 71 | val int : int encoder 72 | val nativeint : nativeint encoder 73 | val int32 : int32 encoder 74 | val int64 : int64 encoder 75 | val string : string encoder 76 | val list : 'a encoder -> 'a list encoder 77 | val option : 'a encoder -> 'a option encoder 78 | 79 | val map : ('a -> 'b) -> 'b encoder -> 'a encoder 80 | val array : 'a encoder -> 'a array encoder 81 | val sequence : 'a encoder -> 'a sequence encoder 82 | 83 | (** {6 Composite Types} *) 84 | 85 | val apply : 'into output -> 'src encoder -> 'src -> 'into 86 | (** Helper to apply an encoder to a value *) 87 | 88 | type 'r record_encoder = { 89 | record_emit : 'into. 'into output -> 'r -> (string * 'into) list; 90 | } 91 | 92 | val record : 'r record_encoder -> 'r encoder 93 | (** Encode a record, using the polymorphic record {!record_encoder} to 94 | generate an association list *) 95 | 96 | val record_fix : ('r encoder -> 'r record_encoder) -> 'r encoder 97 | (** Fixpoint on record definition *) 98 | 99 | (** Example: 100 | {[ type point = {x:int; y:int; c:string};; 101 | let enc_point = record 102 | {record_emit=fun into {x;y;c} -> 103 | [ "x", into.int x 104 | ; "y", into.int y 105 | ; "c", into.string c 106 | ] 107 | } ;; 108 | ]} *) 109 | 110 | type 't tuple_encoder = { 111 | tuple_emit : 'into. 'into output -> 't -> 'into list; 112 | } 113 | 114 | val tuple : 'a tuple_encoder -> 'a encoder 115 | (** General encoding of tuples (returns a list of values) *) 116 | 117 | val pair : 'a encoder -> 118 | 'b encoder -> 119 | ('a * 'b) encoder 120 | 121 | val triple : 'a encoder -> 122 | 'b encoder -> 123 | 'c encoder -> 124 | ('a * 'b * 'c) encoder 125 | 126 | val quad : 'a encoder -> 127 | 'b encoder -> 128 | 'c encoder -> 129 | 'd encoder -> 130 | ('a * 'b * 'c * 'd) encoder 131 | 132 | type 's sum_encoder = { 133 | sum_emit : 'into. 'into output -> 's -> string * 'into list 134 | } 135 | 136 | val sum : 'a sum_encoder -> 'a encoder 137 | 138 | val sum0 : ('a -> string) -> 'a encoder 139 | (** Constant sums, only put the name *) 140 | 141 | val sum_fix : ('a encoder -> 'a sum_encoder) -> 'a encoder 142 | (** Fixpoint on sum types *) 143 | 144 | (** Example: 145 | {[ type tree = Empty | Leaf of int | Node of tree * tree;; 146 | let encode_tree = sum_fix 147 | (fun self -> {sum_emit=fun into x -> match x with 148 | | Empty -> "empty", [] 149 | | Leaf i -> "leaf", [int.emit into i] 150 | | Node (l,r) -> "node", [self.emit into l; self.emit into r] 151 | });; 152 | ]} *) 153 | end 154 | 155 | (** {2 Decode} 156 | 157 | A 'a decodee describes a way to traverse a value of some type representing 158 | a serialization format such as JSON or B-encode *) 159 | module Decode : sig 160 | type 'src source = { 161 | emit : 'a. ('src,'a) inner_decoder -> 'src -> 'a; 162 | } (** Decode a value of type 'src *) 163 | 164 | and ('src, 'into) inner_decoder = { 165 | accept_unit : 'src source -> unit -> 'into; 166 | accept_bool : 'src source -> bool -> 'into; 167 | accept_float : 'src source -> float -> 'into; 168 | accept_int : 'src source -> int -> 'into; 169 | accept_int32 : 'src source -> int32 -> 'into; 170 | accept_int64 : 'src source -> int64 -> 'into; 171 | accept_nativeint : 'src source -> nativeint -> 'into; 172 | accept_char : 'src source -> char -> 'into; 173 | accept_string : 'src source -> string -> 'into; 174 | accept_list : 'src source -> 'src list -> 'into; 175 | accept_option : 'src source -> 'src option -> 'into; 176 | accept_record : 'src source -> (string * 'src) list -> 'into; 177 | accept_tuple : 'src source -> 'src list -> 'into; 178 | accept_sum : 'src source -> string -> 'src list -> 'into; 179 | } (** Decode a value of type 'src into a type 'into. *) 180 | 181 | type 'into decoder = { 182 | dec : 'src. ('src, 'into) inner_decoder; 183 | } 184 | 185 | val apply : 'src source -> 'into decoder -> 'src -> 'into 186 | (** Apply a decoder to a source *) 187 | 188 | (** {6 Decoder Combinators} *) 189 | 190 | val int : int decoder 191 | val char : char decoder 192 | val int32 : int32 decoder 193 | val int64 : int64 decoder 194 | val nativeint : nativeint decoder 195 | val float : float decoder 196 | val bool : bool decoder 197 | val unit : unit decoder 198 | val string : string decoder 199 | 200 | val list : 'a decoder -> 'a list decoder 201 | val array : 'a decoder -> 'a array decoder 202 | val sequence : 'a decoder -> 'a sequence decoder 203 | 204 | val map : ('a -> 'b) -> 'a decoder -> 'b decoder 205 | (** Map the decoded value *) 206 | 207 | val arg0 : 'src list -> unit 208 | (** Only accepts an empty list/tuple *) 209 | 210 | val arg1 : 'a decoder -> 'src source -> 'src list -> 'a 211 | (** Only accepts a 1-element list/tuple *) 212 | 213 | val arg2 : 'a decoder -> 'b decoder -> 214 | 'src source -> 'src list -> 'a * 'b 215 | (** Only accepts a 2-elements list/tuple *) 216 | 217 | val arg3 : 'a decoder -> 218 | 'b decoder -> 219 | 'c decoder -> 220 | 'src source -> 221 | 'src list -> 'a * 'b * 'c 222 | (** Only accepts a 3-elements list/tuple *) 223 | 224 | val option : 'a decoder -> 'a option decoder 225 | (** Helper for options *) 226 | 227 | val pair : 'a decoder -> 'b decoder -> ('a * 'b) decoder 228 | 229 | val triple : 'a decoder -> 230 | 'b decoder -> 231 | 'c decoder -> 232 | ('a * 'b * 'c) decoder 233 | 234 | val record_get : string -> 'into decoder -> 235 | 'src source -> (string * 'src) list -> 236 | 'into 237 | (** [record_get name dec l] is a helper for decoding records. It is 238 | given a list of fields [l], and searches [name] through it. 239 | If [name] is found with a value [v], [dec.accept v] is called. 240 | Otherwise an error is raised *) 241 | 242 | val record_get_opt : string -> 'into decoder -> 243 | 'src source -> (string * 'src) list -> 244 | 'into option 245 | 246 | type 'into record_decoder = { 247 | record_accept : 'src. 'src source -> (string * 'src) list -> 'into; 248 | } 249 | 250 | val record : 'into record_decoder -> 'into decoder 251 | (** Decoder for records. It will adapt itself to association tuples 252 | and lists. *) 253 | 254 | val record_fix : ('into decoder -> 'into record_decoder) -> 255 | 'into decoder 256 | 257 | type 'into sum_decoder = { 258 | sum_accept : 'src. 'src source -> string -> 'src list -> 'into; 259 | } 260 | 261 | val sum : 'into sum_decoder -> 'into decoder 262 | (** Decoder for sums. It will adapt itself to strings, lists 263 | and tuples *) 264 | 265 | val sum_fix : ('into decoder -> 'into sum_decoder) -> 266 | 'into decoder 267 | 268 | type 'into tuple_decoder = { 269 | tuple_accept : 'src. 'src source -> 'src list -> 'into; 270 | } 271 | 272 | val tuple : 'into tuple_decoder -> 'into decoder 273 | (** Tuple decoder *) 274 | 275 | (** Examples: 276 | {[ 277 | type mytuple = int * string * float list ;; 278 | 279 | let decode_mytuple = tuple { 280 | tuple_accept=fun src l -> arg3 int int (list string) src l); 281 | };; 282 | 283 | (* OR, because triples are really easy: *) 284 | let decode_mytuple = triple int int (list string);; 285 | 286 | type point = { x:int; y:int; color:string };; 287 | 288 | let decode_point = record ~expected:"point" { 289 | record_accept=(fun src l -> 290 | let x = record_get "x" int src l in 291 | let y = record_get "y" int src l in 292 | let color = record_get "color" string src l in 293 | {x;y;color} 294 | ); 295 | };; 296 | ]} 297 | *) 298 | end 299 | 300 | type 'a or_error = [ `Ok of 'a | `Error of string ] 301 | 302 | val encode : 'src Encode.encoder -> 'into Encode.output -> 'src -> 'into 303 | (** Encode a value into the serialization format ['into] *) 304 | 305 | val to_string : 'src Encode.encoder -> 'src -> string 306 | (** Use {!Encode.string_target} to print the value *) 307 | 308 | val decode_exn : 'src Decode.source -> 'into Decode.decoder -> 'src -> 'into 309 | (** Decode a serialized value *) 310 | 311 | val decode : 'src Decode.source -> 'into Decode.decoder -> 'src -> 'into or_error 312 | 313 | -------------------------------------------------------------------------------- /src/core/dune: -------------------------------------------------------------------------------- 1 | 2 | (library 3 | (name CConv) 4 | (public_name cconv) 5 | (synopsis "Combinators for Conversion")) 6 | -------------------------------------------------------------------------------- /src/example/.merlin: -------------------------------------------------------------------------------- 1 | REC 2 | S . 3 | B ../_build/example/ 4 | PKG bencode 5 | PKG yojson 6 | PKG sexplib 7 | -------------------------------------------------------------------------------- /src/example/all.ml: -------------------------------------------------------------------------------- 1 | 2 | (** {1 Examples} *) 3 | 4 | (* tests *) 5 | 6 | module Point = struct 7 | type t = { 8 | x : int; 9 | y : int; 10 | color : string; 11 | prev : t option; (* previous position, say *) 12 | } 13 | 14 | let encode = CConv.Encode.(record_fix 15 | (fun self -> 16 | let o_self = option self in 17 | {record_emit=fun into {x;y;color;prev} -> 18 | [ "x", int.emit into x 19 | ; "y", int.emit into y 20 | ; "color", string.emit into color 21 | ; "prev", o_self.emit into prev 22 | ] 23 | } 24 | ) 25 | ) ;; 26 | 27 | 28 | let decode = CConv.Decode.(record_fix 29 | (fun self -> { record_accept=fun src l -> 30 | let x = record_get "x" int src l in 31 | let y = record_get "y" int src l in 32 | let color = record_get "color" string src l in 33 | let prev = record_get "prev" (option self) src l in 34 | {x;y;color;prev} 35 | }) 36 | ) 37 | 38 | let p = { x=1; y=2; color="red"; prev=None; } 39 | let p' = {x=1; y=3; color="yellow"; prev=Some p; } 40 | end 41 | 42 | module Lambda = struct 43 | type t = 44 | | Var of string 45 | | App of t * t 46 | | Lambda of string * t 47 | 48 | let encode = CConv.Encode.(sum_fix 49 | (fun self -> {sum_emit=fun into t -> match t with 50 | | Var s -> "var", [string.emit into s] 51 | | App (t1,t2) -> "app", [self.emit into t1; self.emit into t2] 52 | | Lambda (v,t') -> "lambda", [string.emit into v; self.emit into t'] 53 | }) 54 | ) 55 | 56 | let decode = CConv.Decode.(sum_fix 57 | (fun self -> { 58 | sum_accept=fun src name args -> match name, args with 59 | | "var", [x] -> 60 | let x = apply src string x in 61 | Var x 62 | | "app", [x;y] -> 63 | let x = apply src self x in 64 | let y = apply src self y in 65 | App(x,y) 66 | | "lambda", [x;y] -> 67 | let x = apply src string x in 68 | let y = apply src self y in 69 | Lambda(x,y) 70 | | _ -> CConv.report_error "expected lambda-term" 71 | }) 72 | ) 73 | 74 | let t1 = Lambda ("x", App (Lambda ("y", App (Var "y", Var "x")), Var "x")) 75 | end 76 | -------------------------------------------------------------------------------- /src/ppx/dune: -------------------------------------------------------------------------------- 1 | 2 | (library 3 | (name ppx_deriving_cconv) 4 | (public_name cconv-ppx) 5 | (synopsis "ppx deriving interface for cconv: [@@deriving cconv]") 6 | (kind ppx_deriver) 7 | (ppx_runtime_libraries cconv) 8 | (libraries ppx_deriving.api) 9 | (optional) 10 | (preprocess 11 | (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file}))) 12 | (flags :standard -warn-error -a+8 -w -9-27)) 13 | 14 | (rule 15 | (targets ppx_deriving_cconv.ml) 16 | (deps ppx_deriving_cconv.cppo.ml) 17 | (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets}))) 18 | -------------------------------------------------------------------------------- /src/ppx/ppx_deriving_cconv.cppo.ml: -------------------------------------------------------------------------------- 1 | (* Largely inspired from ppx_deriving_yojson *) 2 | 3 | open Longident 4 | open Location 5 | open Asttypes 6 | open Parsetree 7 | module AH = Ast_helper 8 | module AC = Ast_convenience 9 | 10 | let deriver = "cconv" 11 | let raise_errorf = Ppx_deriving.raise_errorf 12 | 13 | let encode_prefix = `Prefix "encode" 14 | let decode_prefix = `Prefix "decode" 15 | 16 | let argn = Printf.sprintf "arg%d" 17 | 18 | let attr_encoder attrs = 19 | Ppx_deriving.attr ~deriver "encoder" attrs |> 20 | Ppx_deriving.Arg.(get_attr ~deriver expr) 21 | 22 | let attr_decoder attrs = 23 | Ppx_deriving.attr ~deriver "decoder" attrs |> 24 | Ppx_deriving.Arg.(get_attr ~deriver expr) 25 | 26 | let attr_ignore attrs = 27 | Ppx_deriving.attr ~deriver "ignore" attrs |> 28 | Ppx_deriving.Arg.(get_flag ~deriver ) 29 | 30 | let attr_default attrs = 31 | Ppx_deriving.attr ~deriver "default" attrs |> 32 | Ppx_deriving.Arg.(get_attr ~deriver expr) 33 | 34 | let attr_string name default attrs = 35 | match Ppx_deriving.attr ~deriver name attrs |> 36 | Ppx_deriving.Arg.(get_attr ~deriver string) with 37 | | Some x -> x 38 | | None -> default 39 | 40 | let attr_key = attr_string "key" 41 | 42 | (* fold right, with index of element *) 43 | let fold_right_i f l acc = 44 | let rec fold' f acc i l = match l with 45 | | [] -> acc 46 | | x::tail -> 47 | let acc = fold' f acc (i+1) tail in 48 | f i x acc 49 | in 50 | fold' f acc 0 l 51 | 52 | #if OCAML_VERSION < (4, 03, 0) 53 | 54 | let extract_pcd_args_tuple_values ~loc pcd_args = pcd_args 55 | let contains_record_variant constrs = false 56 | 57 | #else 58 | 59 | let extract_pcd_args_tuple_values ~loc pcd_args = 60 | match pcd_args with 61 | | Pcstr_tuple l -> l 62 | | Pcstr_record _ -> 63 | (* When calling this method, the constructors have been checked 64 | already during pattern matching, but handle it just in case *) 65 | raise_errorf ~loc "%s cannot be derived for record variants" deriver 66 | 67 | let contains_record_variant constrs = 68 | let is_record_variant constr = 69 | match constr.pcd_args with 70 | | Pcstr_record _ -> true 71 | | Pcstr_tuple _ -> false in 72 | List.exists is_record_variant constrs 73 | 74 | #endif 75 | 76 | (* generate a [typ CConv.Encode.encoder] for the given [typ]. 77 | @param self an option contains the type being defined, and a reference 78 | indicating whether a self-reference was used *) 79 | let encode_of_typ ~self typ = 80 | let rec encode_of_typ typ = match attr_encoder typ.ptyp_attributes with 81 | | None -> encode_of_typ_rec typ 82 | | Some e -> e 83 | and encode_of_typ_rec typ = match typ with 84 | | [%type: unit] -> [%expr CConv.Encode.unit] 85 | | [%type: int] -> [%expr CConv.Encode.int] 86 | | [%type: float] -> [%expr CConv.Encode.float] 87 | | [%type: bool] -> [%expr CConv.Encode.bool] 88 | | [%type: string] -> [%expr CConv.Encode.string] 89 | | [%type: bytes] -> [%expr CConv.Encode.(map Bytes.to_string string)] 90 | | [%type: char] -> [%expr CConv.Encode.char] 91 | | [%type: [%t? typ] ref] -> [%expr CConv.Encode.(map (!) [%e encode_of_typ typ])] 92 | | [%type: [%t? typ] list] -> [%expr CConv.Encode.(list [%e encode_of_typ typ])] 93 | | [%type: int32] | [%type: Int32.t] -> [%expr CConv.Encode.int32] 94 | | [%type: int64] | [%type: Int64.t] -> [%expr CConv.Encode.int64] 95 | | [%type: nativeint] | [%type: Nativeint.t] -> [%expr CConv.Encode.nativeint] 96 | | [%type: [%t? typ] array] -> 97 | [%expr CConv.Encode.(array [%e encode_of_typ typ])] 98 | | [%type: [%t? typ] option] -> 99 | [%expr CConv.Encode.(option [%e encode_of_typ typ])] 100 | | { ptyp_desc = Ptyp_constr ({ txt = lid }, args) } -> 101 | begin match self, lid with 102 | | Some (name, used), Lident liname when liname=name -> 103 | (* typ is actually a recursive reference to the type 104 | being defined. Use a "self" variables that will be bound 105 | with [CConv.Encode.record_fix] or [CConv.Encode.sum_fix] *) 106 | used := true; 107 | AC.evar "self" 108 | | _ -> 109 | AC.app 110 | (AH.Exp.ident (mknoloc (Ppx_deriving.mangle_lid encode_prefix lid))) 111 | (List.map encode_of_typ args) 112 | end 113 | | { ptyp_desc = Ptyp_tuple typs } -> 114 | (* encode tuple, by destructuring it *) 115 | [%expr 116 | CConv.Encode.tuple 117 | {CConv.Encode.tuple_emit= 118 | fun into [%p AC.ptuple (List.mapi (fun i _ -> AC.pvar (argn i)) typs)] -> 119 | [%e fold_right_i 120 | (fun i typ acc -> 121 | [%expr 122 | [%e encode_of_typ typ].CConv.Encode.emit into 123 | [%e AC.evar (argn i)] :: 124 | [%e acc] 125 | ] 126 | ) typs [%expr []] 127 | ] 128 | } 129 | ] 130 | | { ptyp_desc = Ptyp_variant (fields, _, _); ptyp_loc } -> 131 | raise_errorf ~loc:ptyp_loc "%s cannot be derived for poly variants" deriver 132 | | { ptyp_desc = Ptyp_var name } -> 133 | [%expr ([%e AC.evar ("poly_"^name)] : 'a CConv.Encode.encoder)] 134 | | { ptyp_desc = Ptyp_alias (typ, name) } -> encode_of_typ typ 135 | | { ptyp_loc } -> 136 | raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" 137 | deriver (Ppx_deriving.string_of_core_type typ) 138 | in 139 | encode_of_typ typ 140 | 141 | (* make an encoder from a type declaration *) 142 | let encode_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = 143 | let encoder = 144 | match type_decl.ptype_kind, type_decl.ptype_manifest with 145 | | Ptype_abstract, Some manifest -> encode_of_typ ~self:None manifest 146 | | Ptype_variant constrs, _ when contains_record_variant constrs -> 147 | raise_errorf ~loc "%s cannot be derived for record variants" deriver 148 | | Ptype_variant constrs, _ -> 149 | let self_used = ref false in 150 | let self = Some (type_decl.ptype_name.txt, self_used) in 151 | (* pattern matching *) 152 | let cases = List.map 153 | (fun { pcd_name = { txt = name' }; pcd_args; pcd_attributes } -> 154 | let pcd_args = extract_pcd_args_tuple_values ~loc pcd_args in 155 | (* first, encode arguments *) 156 | let args = fold_right_i 157 | (fun i typ acc -> 158 | let encoder = encode_of_typ ~self typ in 159 | [%expr 160 | [%e encoder].CConv.Encode.emit into 161 | [%e AC.evar (argn i)] :: 162 | [%e acc] 163 | ] 164 | ) pcd_args [%expr []] 165 | in 166 | (* result is name,arguments *) 167 | let result = AC.tuple [AC.str name'; args] in 168 | (* the pattern case itself *) 169 | AH.Exp.case 170 | (AC.pconstr name' (List.mapi (fun i _ -> AC.pvar (argn i)) pcd_args)) 171 | result 172 | ) constrs 173 | in 174 | let f = AH.Exp.function_ cases in 175 | let f = [%expr {CConv.Encode.sum_emit=fun into -> [%e f]}] in 176 | if !self_used 177 | then [%expr CConv.Encode.sum_fix (fun self -> [%e f])] 178 | else [%expr CConv.Encode.sum [%e f]] 179 | | Ptype_record labels, _ -> 180 | let self_used = ref false in 181 | let self = Some (type_decl.ptype_name.txt, self_used) in 182 | (* build the function record->hlist (here, its body). The record 183 | is named "r". *) 184 | let destruct = fold_right_i 185 | (fun i field tail -> 186 | if attr_ignore field.pld_attributes 187 | then tail (* do not encode *) 188 | else 189 | let encoder = encode_of_typ ~self field.pld_type in 190 | let field_name = attr_key field.pld_name.txt field.pld_attributes in 191 | [%expr 192 | ( [%e AC.str field_name], 193 | [%e encoder].CConv.Encode.emit into 194 | [%e AH.Exp.field [%expr r] (AC.lid field.pld_name.txt)] 195 | ) :: [%e tail] 196 | ] 197 | ) labels [%expr []] 198 | in 199 | let destruct = [%expr {CConv.Encode.record_emit=fun into r -> [%e destruct]}] in 200 | if !self_used 201 | then [%expr CConv.Encode.record_fix (fun self -> [%e destruct])] 202 | else [%expr CConv.Encode.record [%e destruct]] 203 | | Ptype_abstract, None -> 204 | raise_errorf ~loc "%s cannot be derived for fully abstract types" deriver 205 | | Ptype_open, _ -> 206 | raise_errorf ~loc "%s cannot be derived for open types" deriver 207 | in 208 | let polymorphize = Ppx_deriving.poly_fun_of_type_decl type_decl in 209 | [AH.Vb.mk 210 | (AC.pvar (Ppx_deriving.mangle_type_decl encode_prefix type_decl)) 211 | (polymorphize [%expr ([%e encoder] : _ CConv.Encode.encoder)])] 212 | 213 | (* signature of the generated encoder *) 214 | let encode_sig_of_type ~options ~path type_decl = 215 | let typ = Ppx_deriving.core_type_of_type_decl type_decl in 216 | let polymorphize_enc = 217 | Ppx_deriving.poly_arrow_of_type_decl 218 | (fun var -> [%type: [%t var] CConv.Encode.encoder]) 219 | type_decl 220 | in 221 | [AH.Sig.value 222 | (AH.Val.mk (mknoloc (Ppx_deriving.mangle_type_decl encode_prefix type_decl)) 223 | (polymorphize_enc [%type: [%t typ] CConv.Encode.encoder])) 224 | ] 225 | 226 | (* generate a [typ CConv.Decode.decoder] for the given [typ]. 227 | @param self an option contains the type being defined, and a reference 228 | indicating whether a self-reference was used *) 229 | let decode_of_typ ~self typ = 230 | let rec decode_of_typ typ = match attr_decoder typ.ptyp_attributes with 231 | | None -> decode_of_typ_rec typ 232 | | Some d -> d 233 | and decode_of_typ_rec typ = match typ with 234 | | [%type: unit] -> [%expr CConv.Decode.unit] 235 | | [%type: int] -> [%expr CConv.Decode.int] 236 | | [%type: float] -> [%expr CConv.Decode.float] 237 | | [%type: bool] -> [%expr CConv.Decode.bool] 238 | | [%type: string] -> [%expr CConv.Decode.string] 239 | | [%type: bytes] -> [%expr CConv.Decode.(map Bytes.to_string string)] 240 | | [%type: char] -> [%expr CConv.Decode.char] 241 | | [%type: [%t? typ] ref] -> [%expr CConv.Decode.(map (!) [%e decode_of_typ typ])] 242 | | [%type: [%t? typ] list] -> [%expr CConv.Decode.(list [%e decode_of_typ typ])] 243 | | [%type: int32] | [%type: Int32.t] -> [%expr CConv.Decode.int32] 244 | | [%type: int64] | [%type: Int64.t] -> [%expr CConv.Decode.int64] 245 | | [%type: nativeint] | [%type: Nativeint.t] -> [%expr CConv.Decode.nativeint] 246 | | [%type: [%t? typ] array] -> 247 | [%expr CConv.Decode.(array [%e decode_of_typ typ])] 248 | | [%type: [%t? typ] option] -> 249 | [%expr CConv.Decode.(option [%e decode_of_typ typ])] 250 | | { ptyp_desc = Ptyp_constr ({ txt = lid }, args) } -> 251 | begin match self, lid with 252 | | Some (name, used), Lident liname when liname=name -> 253 | (* typ is actually a recursive reference to the type 254 | being defined. Use a "self" variables that will be bound 255 | with [CConv.Decode.record_fix] or [CConv.Decode.sum_fix] *) 256 | used := true; 257 | AC.evar "self" 258 | | _ -> 259 | AC.app 260 | (AH.Exp.ident (mknoloc (Ppx_deriving.mangle_lid decode_prefix lid))) 261 | (List.map decode_of_typ args) 262 | end 263 | | { ptyp_desc = Ptyp_tuple typs } -> 264 | (* decode tuple, matching on the list *) 265 | [%expr CConv.Decode.(tuple {tuple_accept=fun src args -> 266 | match args with 267 | | [%p (* didn't find how to build pattern [v1; v2; ...; vn] *) 268 | fold_right_i 269 | (fun i ty pat -> [%pat? [%p AC.pvar (argn i)] :: [%p pat]]) 270 | typs [%pat? []] 271 | ] -> 272 | [%e AC.tuple (List.mapi 273 | (fun i ty -> 274 | [%expr CConv.Decode.apply src 275 | [%e decode_of_typ ty] 276 | [%e AC.evar (argn i)] 277 | ] 278 | ) typs 279 | )] 280 | | _ -> 281 | CConv.report_error "expected %d-ary tuple" 282 | [%e AC.int (List.length typs)] 283 | })] 284 | | { ptyp_desc = Ptyp_variant (fields, _, _); ptyp_loc } -> 285 | raise_errorf ~loc:ptyp_loc "%s cannot be derived for poly variants" deriver 286 | | { ptyp_desc = Ptyp_var name } -> 287 | [%expr ([%e AC.evar ("poly_"^name)] : 'a CConv.Decode.decoder)] 288 | | { ptyp_desc = Ptyp_alias (typ, name) } -> decode_of_typ typ 289 | | { ptyp_loc } -> 290 | raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" 291 | deriver (Ppx_deriving.string_of_core_type typ) 292 | in 293 | decode_of_typ typ 294 | 295 | (* make an decoder from a type declaration *) 296 | let decode_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = 297 | let decoder = 298 | match type_decl.ptype_kind, type_decl.ptype_manifest with 299 | | Ptype_abstract, Some manifest -> decode_of_typ ~self:None manifest 300 | | Ptype_variant constrs, _ when contains_record_variant constrs -> 301 | raise_errorf ~loc "%s cannot be derived for record variants" deriver 302 | | Ptype_variant constrs, _ -> 303 | let self_used = ref false in 304 | let self = Some (type_decl.ptype_name.txt, self_used) in 305 | (* generate pattern matching cases *) 306 | let cases = List.map 307 | (fun { pcd_name = { txt = name' }; pcd_args; pcd_attributes } -> 308 | let pcd_args = extract_pcd_args_tuple_values ~loc pcd_args in 309 | AH.Exp.case 310 | [%pat? 311 | ([%p AC.pstr name'], 312 | [%p AC.plist (List.mapi (fun i ty -> AC.pvar (argn i)) pcd_args)] 313 | ) 314 | ] 315 | (AC.constr name' 316 | (List.mapi 317 | (fun i ty -> 318 | let decoder = match attr_decoder pcd_attributes with 319 | | None -> decode_of_typ ~self ty 320 | | Some d -> d 321 | in 322 | [%expr CConv.Decode.apply src 323 | [%e decoder] 324 | [%e AC.evar (argn i)] 325 | ] 326 | ) pcd_args 327 | ) 328 | ) 329 | ) constrs 330 | and last_case = AH.Exp.case 331 | (AH.Pat.any ()) [%expr CConv.report_error "expected sum"] 332 | in 333 | let sum_decoder = [%expr {CConv.Decode.sum_accept=fun src name args -> 334 | [%e AH.Exp.match_ 335 | [%expr (name,args)] 336 | (cases @ [last_case]) 337 | ] 338 | }] in 339 | if !self_used 340 | then [%expr CConv.Decode.sum_fix (fun self -> [%e sum_decoder]) ] 341 | else [%expr CConv.Decode.sum [%e sum_decoder]] 342 | | Ptype_record labels, _ -> 343 | let self_used = ref false in 344 | let self = Some (type_decl.ptype_name.txt, self_used) in 345 | (* build a list of 346 | let field = record_get "field" (decode field) src args in ... *) 347 | let bindings = fold_right_i 348 | (fun i field tail -> 349 | let decoder = match attr_decoder field.pld_attributes with 350 | | None -> decode_of_typ ~self field.pld_type 351 | | Some d -> d in 352 | let field_name = attr_key field.pld_name.txt field.pld_attributes in 353 | let body_expr = match attr_default field.pld_attributes with 354 | | Some default -> 355 | [%expr 356 | match CConv.Decode.record_get_opt [%e AC.str field_name] [%e decoder] src args with 357 | | Some v -> v 358 | | None -> [%e default]] 359 | | None -> [%expr CConv.Decode.record_get [%e AC.str field_name] [%e decoder] src args] 360 | in 361 | [%expr let [%p AC.pvar field.pld_name.txt] = [%e body_expr] in 362 | [%e tail]] 363 | ) labels 364 | (AC.record (* build the record *) 365 | (List.map 366 | (fun field -> 367 | let name = field.pld_name.txt in 368 | name, AC.evar name 369 | ) labels 370 | ) 371 | ) 372 | in 373 | let record_decoder = [%expr 374 | {CConv.Decode.record_accept=fun src args -> [%e bindings] } 375 | ] in 376 | if !self_used 377 | then [%expr CConv.Decode.record_fix (fun self -> [%e record_decoder])] 378 | else [%expr CConv.Decode.record [%e record_decoder]] 379 | | Ptype_abstract, None -> 380 | raise_errorf ~loc "%s cannot be derived for fully abstract types" deriver 381 | | Ptype_open, _ -> 382 | raise_errorf ~loc "%s cannot be derived for open types" deriver 383 | in 384 | let polymorphize = Ppx_deriving.poly_fun_of_type_decl type_decl in 385 | [AH.Vb.mk 386 | (AC.pvar (Ppx_deriving.mangle_type_decl decode_prefix type_decl)) 387 | (polymorphize [%expr ([%e decoder] : _ CConv.Decode.decoder)])] 388 | 389 | (* signature of the generated encoder *) 390 | let decode_sig_of_type ~options ~path type_decl = 391 | let typ = Ppx_deriving.core_type_of_type_decl type_decl in 392 | let polymorphize_enc = 393 | Ppx_deriving.poly_arrow_of_type_decl 394 | (fun var -> [%type: [%t var] CConv.Decode.decoder]) 395 | type_decl 396 | in 397 | [AH.Sig.value 398 | (AH.Val.mk (mknoloc (Ppx_deriving.mangle_type_decl decode_prefix type_decl)) 399 | (polymorphize_enc [%type: [%t typ] CConv.Decode.decoder])) 400 | ] 401 | 402 | let str_of_type ~options ~path type_decl = 403 | encode_of_type ~options ~path type_decl @ 404 | decode_of_type ~options ~path type_decl 405 | 406 | let sig_of_type ~options ~path type_decl = 407 | encode_sig_of_type ~options ~path type_decl @ 408 | decode_sig_of_type ~options ~path type_decl 409 | 410 | let () = 411 | let open Ppx_deriving in 412 | register (create "cconv" 413 | ~type_decl_str:(fun ~options ~path type_decls -> 414 | let recu = if List.length type_decls > 1 then Recursive else Nonrecursive in 415 | [AH.Str.value recu 416 | (List.concat (List.map (str_of_type ~options ~path) type_decls))] 417 | ) 418 | ~type_decl_sig: (fun ~options ~path type_decls -> 419 | List.concat (List.map (sig_of_type ~options ~path) type_decls) 420 | ) 421 | () 422 | ); 423 | register (create "encode" 424 | ~core_type:(encode_of_typ ~self:None) 425 | ~type_decl_str: (fun ~options ~path type_decls -> 426 | let recu = if List.length type_decls > 1 then Recursive else Nonrecursive in 427 | [AH.Str.value recu 428 | (List.concat (List.map (encode_of_type ~options ~path) type_decls))] 429 | ) 430 | ~type_decl_sig: (fun ~options ~path type_decls -> 431 | List.concat (List.map (encode_sig_of_type ~options ~path) type_decls) 432 | ) 433 | () 434 | ); 435 | register (create "decode" 436 | ~core_type:(fun typ -> (decode_of_typ ~self:None typ)) 437 | ~type_decl_str: (fun ~options ~path type_decls -> 438 | let recu = if List.length type_decls > 1 then Recursive else Nonrecursive in 439 | [AH.Str.value recu 440 | (List.concat (List.map (decode_of_type ~options ~path) type_decls))] 441 | ) 442 | ~type_decl_sig: (fun ~options ~path type_decls -> 443 | List.concat (List.map (decode_sig_of_type ~options ~path) type_decls) 444 | ) 445 | () 446 | ); 447 | () 448 | -------------------------------------------------------------------------------- /src/psexp/cConvPSexp.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * CSexp - interface to Sexplib 3 | * Copyright (C) 2014 Simon Cruanes 4 | * 5 | * This library is free software; you can redistribute it and/or 6 | * modify it under the terms of the GNU Lesser General Public 7 | * License as published by the Free Software Foundation; either 8 | * version 2.1 of the License, or (at your option) any later version, 9 | * with the special exception on linking described in file LICENSE. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Lesser General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU Lesser General Public 17 | * License along with this library; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | *) 20 | 21 | type 'a or_error = [ `Ok of 'a | `Error of string ] 22 | 23 | type t = 24 | [ `Atom of string 25 | | `List of t list 26 | ] 27 | 28 | let source = 29 | let module D = CConv.Decode in 30 | let rec src = {D.emit=fun dec s -> match s with 31 | | `Atom s -> dec.D.accept_string src s 32 | | `List l -> dec.D.accept_list src l 33 | } in 34 | src 35 | 36 | let output = 37 | let module E = CConv.Encode in 38 | { E.unit = `List []; 39 | bool = (fun b -> `Atom (string_of_bool b)); 40 | float = (fun f -> `Atom (string_of_float f)); 41 | char = (fun x -> `Atom (String.make 1 x)); 42 | nativeint = (fun i -> `Atom (Nativeint.to_string i)); 43 | int32 = (fun i -> `Atom (Int32.to_string i)); 44 | int64 = (fun i -> `Atom (Int64.to_string i)); 45 | int = (fun i -> `Atom (string_of_int i)); 46 | string = (fun s -> `Atom (String.escaped s)); 47 | option = (function None -> `List[] | Some x -> `List [x]); 48 | list = (fun l -> `List l); 49 | record = (fun l -> `List (List.map (fun (a,b) -> `List [`Atom a; b]) l)); 50 | tuple = (fun l -> `List l); 51 | sum = (fun name l -> match l with 52 | | [] -> `Atom name 53 | | _::_ -> `List (`Atom name :: l)); 54 | } 55 | 56 | let encode src x = CConv.encode src output x 57 | 58 | let decode dec x = CConv.decode source dec x 59 | 60 | let decode_exn dec x = CConv.decode_exn source dec x 61 | -------------------------------------------------------------------------------- /src/psexp/cConvPSexp.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * BatSexp - interface to Sexplib 3 | * Copyright (C) 2014 Simon Cruanes 4 | * 5 | * This library is free software; you can redistribute it and/or 6 | * modify it under the terms of the GNU Lesser General Public 7 | * License as published by the Free Software Foundation; either 8 | * version 2.1 of the License, or (at your option) any later version, 9 | * with the special exception on linking described in file LICENSE. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Lesser General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU Lesser General Public 17 | * License along with this library; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | *) 20 | 21 | (** {1 Polymorphic Variants S-expressions} 22 | 23 | These S-expressions are compatible with ocaml-containers' S-expressions. 24 | Howerver, they do not add any dependency and can be used without containers. *) 25 | 26 | type 'a or_error = [ `Ok of 'a | `Error of string ] 27 | 28 | type t = 29 | [ `Atom of string 30 | | `List of t list 31 | ] 32 | 33 | val output : t CConv.Encode.output 34 | val source : t CConv.Decode.source 35 | 36 | val encode : 'src CConv.Encode.encoder -> 'src -> t 37 | val decode_exn : 'into CConv.Decode.decoder -> t -> 'into 38 | val decode : 'into CConv.Decode.decoder -> t -> 'into or_error 39 | 40 | -------------------------------------------------------------------------------- /src/psexp/dune: -------------------------------------------------------------------------------- 1 | 2 | (library 3 | (name cConvPSexp) 4 | (public_name cconv.psexp) 5 | (synopsis "Combinators for Conversion (psexp)") 6 | (libraries cconv)) 7 | -------------------------------------------------------------------------------- /src/sexp/cConvSexp.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * CSexp - interface to Sexplib 3 | * Copyright (C) 2014 Simon Cruanes 4 | * 5 | * This library is free software; you can redistribute it and/or 6 | * modify it under the terms of the GNU Lesser General Public 7 | * License as published by the Free Software Foundation; either 8 | * version 2.1 of the License, or (at your option) any later version, 9 | * with the special exception on linking described in file LICENSE. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Lesser General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU Lesser General Public 17 | * License along with this library; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | *) 20 | 21 | type 'a or_error = [ `Ok of 'a | `Error of string ] 22 | 23 | type t = Sexplib.Sexp.t = 24 | | Atom of string 25 | | List of t list 26 | 27 | let source = 28 | let module D = CConv.Decode in 29 | let rec src = {D.emit=fun dec s -> match s with 30 | | Atom s -> dec.D.accept_string src s 31 | | List l -> dec.D.accept_list src l 32 | } in 33 | src 34 | 35 | let output = 36 | let module E = CConv.Encode in 37 | { E.unit = List []; 38 | bool = (fun b -> Atom (string_of_bool b)); 39 | float = (fun f -> Atom (string_of_float f)); 40 | char = (fun x -> Atom (String.make 1 x)); 41 | nativeint = (fun i -> Atom (Nativeint.to_string i)); 42 | int32 = (fun i -> Atom (Int32.to_string i)); 43 | int64 = (fun i -> Atom (Int64.to_string i)); 44 | int = (fun i -> Atom (string_of_int i)); 45 | string = (fun s -> Atom (String.escaped s)); 46 | list = (fun l -> List l); 47 | option = (function None -> List[] | Some x -> List [x]); 48 | record = (fun l -> List (List.map (fun (a,b) -> List [Atom a; b]) l)); 49 | tuple = (fun l -> List l); 50 | sum = (fun name l -> match l with 51 | | [] -> Atom name 52 | | _::_ -> List (Atom name :: l)); 53 | } 54 | 55 | let sexp_to_string = Sexplib.Sexp.to_string 56 | 57 | let encode src x = CConv.encode src output x 58 | 59 | let decode dec x = CConv.decode source dec x 60 | 61 | let decode_exn dec x = CConv.decode_exn source dec x 62 | 63 | let to_string src x = 64 | sexp_to_string (encode src x) 65 | 66 | let of_string dec s = 67 | try 68 | let x = Sexplib.Sexp.of_string s in 69 | decode dec x 70 | with Failure _ -> 71 | `Error "invalid Sexp string" 72 | 73 | let of_string_exn dec s = 74 | let x = Sexplib.Sexp.of_string s in 75 | decode_exn dec x 76 | -------------------------------------------------------------------------------- /src/sexp/cConvSexp.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * BatSexp - interface to Sexplib 3 | * Copyright (C) 2014 Simon Cruanes 4 | * 5 | * This library is free software; you can redistribute it and/or 6 | * modify it under the terms of the GNU Lesser General Public 7 | * License as published by the Free Software Foundation; either 8 | * version 2.1 of the License, or (at your option) any later version, 9 | * with the special exception on linking described in file LICENSE. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Lesser General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU Lesser General Public 17 | * License along with this library; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | *) 20 | 21 | (** {1 Interface to Sexplib} *) 22 | 23 | type 'a or_error = [ `Ok of 'a | `Error of string ] 24 | 25 | type t = Sexplib.Sexp.t = 26 | | Atom of string 27 | | List of t list 28 | 29 | val output : t CConv.Encode.output 30 | val source : t CConv.Decode.source 31 | 32 | val encode : 'src CConv.Encode.encoder -> 'src -> t 33 | val decode_exn : 'into CConv.Decode.decoder -> t -> 'into 34 | val decode : 'into CConv.Decode.decoder -> t -> 'into or_error 35 | 36 | val to_string : 'a CConv.Encode.encoder -> 'a -> string 37 | val of_string : 'a CConv.Decode.decoder -> string -> 'a or_error 38 | val of_string_exn : 'a CConv.Decode.decoder -> string -> 'a 39 | 40 | val sexp_to_string : t -> string 41 | -------------------------------------------------------------------------------- /src/sexp/dune: -------------------------------------------------------------------------------- 1 | 2 | (library 3 | (name CConvSexp) 4 | (public_name cconv.sexp) 5 | (synopsis "Combinators for Conversion (sexplib)") 6 | (optional) 7 | (libraries cconv sexplib)) 8 | -------------------------------------------------------------------------------- /src/yojson/cConvYojson.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * CYojson - interface to Yojson 3 | * Copyright (C) 2014 Simon Cruanes 4 | * 5 | * This library is free software; you can redistribute it and/or 6 | * modify it under the terms of the GNU Lesser General Public 7 | * License as published by the Free Software Foundation; either 8 | * version 2.1 of the License, or (at your option) any later version, 9 | * with the special exception on linking described in file LICENSE. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Lesser General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU Lesser General Public 17 | * License along with this library; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | *) 20 | 21 | 22 | type 'a or_error = [ `Ok of 'a | `Error of string ] 23 | 24 | type t = Yojson.Basic.json 25 | 26 | let source = 27 | let module D = CConv.Decode in 28 | let rec src = {D.emit=fun dec (x:t) -> match x with 29 | | `Bool b -> dec.D.accept_bool src b 30 | | `Int i -> dec.D.accept_int src i 31 | | `Float f -> dec.D.accept_float src f 32 | | `String s -> dec.D.accept_string src s 33 | | `Null -> dec.D.accept_unit src () 34 | | `List l -> dec.D.accept_list src l 35 | | `Assoc l -> dec.D.accept_record src l 36 | } in 37 | src 38 | 39 | let output = 40 | let module E = CConv.Encode in 41 | { E.unit= `Null; 42 | bool = (fun b -> `Bool b); 43 | float = (fun f -> `Float f); 44 | char = (fun c -> `String (String.make 1 c)); 45 | nativeint = (fun i -> `Int (Nativeint.to_int i)); 46 | int32 = (fun i -> `Int (Int32.to_int i)); 47 | int64 = (fun i -> `Int (Int64.to_int i)); 48 | int = (fun i -> `Int i); 49 | string = (fun s -> `String s); 50 | list = (fun l -> `List l); 51 | option = (function None -> `List [] | Some x -> `List [x]); 52 | record = (fun l -> `Assoc l); 53 | tuple = (fun l -> `List l); 54 | sum = (fun name l -> match l with 55 | | [] -> `String name 56 | | _::_ -> `List (`String name :: l)); 57 | } 58 | 59 | let json_to_string s = Yojson.Basic.to_string ~std:true s 60 | 61 | let encode src x = CConv.encode src output x 62 | 63 | let decode dec x = CConv.decode source dec x 64 | 65 | let decode_exn dec x = CConv.decode_exn source dec x 66 | 67 | let to_string src x = 68 | json_to_string (encode src x) 69 | 70 | let of_string dec s = 71 | try 72 | let x = Yojson.Basic.from_string s in 73 | decode dec x 74 | with Failure _ -> 75 | `Error "invalid JSON string" 76 | 77 | let of_string_exn dec s = 78 | let x = Yojson.Basic.from_string s in 79 | decode_exn dec x 80 | 81 | -------------------------------------------------------------------------------- /src/yojson/cConvYojson.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * CYojson - interface to Yojson 3 | * Copyright (C) 2014 Simon Cruanes 4 | * 5 | * This library is free software; you can redistribute it and/or 6 | * modify it under the terms of the GNU Lesser General Public 7 | * License as published by the Free Software Foundation; either 8 | * version 2.1 of the License, or (at your option) any later version, 9 | * with the special exception on linking described in file LICENSE. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Lesser General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU Lesser General Public 17 | * License along with this library; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | *) 20 | 21 | (** {1 Interface to Yojson} *) 22 | 23 | type 'a or_error = [ `Ok of 'a | `Error of string ] 24 | type t = Yojson.Basic.json 25 | 26 | 27 | val output : t CConv.Encode.output 28 | val source : t CConv.Decode.source 29 | 30 | val encode : 'src CConv.Encode.encoder -> 'src -> t 31 | val decode_exn : 'into CConv.Decode.decoder -> t -> 'into 32 | val decode : 'into CConv.Decode.decoder -> t -> 'into or_error 33 | 34 | val to_string : 'a CConv.Encode.encoder -> 'a -> string 35 | val of_string : 'a CConv.Decode.decoder -> string -> 'a or_error 36 | val of_string_exn : 'a CConv.Decode.decoder -> string -> 'a 37 | 38 | 39 | val json_to_string : t -> string 40 | -------------------------------------------------------------------------------- /src/yojson/dune: -------------------------------------------------------------------------------- 1 | 2 | (library 3 | (name CConvYojson) 4 | (public_name cconv.yojson) 5 | (synopsis "Combinators for Conversion (yojson)") 6 | (optional) 7 | (flags :standard -warn-error -3) 8 | (libraries cconv yojson)) 9 | -------------------------------------------------------------------------------- /tests/dune: -------------------------------------------------------------------------------- 1 | 2 | (executable 3 | (name run_tests_ppx) 4 | (libraries cconv cconv.yojson cconv.bencode 5 | yojson bencode oUnit) 6 | (preprocess (pps ppx_deriving.std ppx_deriving_cconv))) 7 | 8 | (alias 9 | (name runtest) 10 | (action (run ./run_tests_ppx.exe))) 11 | -------------------------------------------------------------------------------- /tests/run_tests_ppx.ml: -------------------------------------------------------------------------------- 1 | 2 | open OUnit 3 | 4 | module type S = sig 5 | type t [@@deriving cconv] 6 | val show : t -> string 7 | val name : string 8 | val examples : t list 9 | end 10 | 11 | module type TEST = sig 12 | val suite : OUnit.test (* automatically registered *) 13 | end 14 | 15 | let suites = ref [] 16 | let add_suite x = suites := x :: !suites 17 | 18 | module Make(X : S) : TEST = struct 19 | let bij_json ex () = 20 | let j = CConvYojson.encode X.encode ex in 21 | match CConvYojson.decode X.decode j with 22 | | `Ok ex' -> 23 | assert_equal ~printer:X.show ex' ex 24 | | `Error msg -> assert_failure msg 25 | 26 | let bij_bencode ex () = 27 | let j = CConvBencode.encode X.encode ex in 28 | match CConvBencode.decode X.decode j with 29 | | `Ok ex' -> 30 | assert_equal ~printer:X.show ex' ex 31 | | `Error msg -> assert_failure msg 32 | 33 | let suite_of_example ex = 34 | [ "bij_json" >:: bij_json ex 35 | ; "bij_bencode" >:: bij_bencode ex 36 | ] 37 | 38 | let suite = 39 | X.name >::: (List.map suite_of_example X.examples |> List.flatten) 40 | 41 | let () = add_suite suite 42 | end 43 | 44 | module M1 = Make(struct 45 | type t = { 46 | x : int; 47 | y : int; 48 | color : string; 49 | prev : t option; (* previous position, say *) 50 | } [@@deriving show, cconv] 51 | 52 | let name = "point" 53 | let p = { x=1; y=2; color="red"; prev=None; } 54 | let p' = {x=1; y=3; color="yellow"; prev=Some p; } 55 | let examples = [p; p'] 56 | end) 57 | 58 | module M2 = Make(struct 59 | type t = 60 | | Var of string 61 | | App of t * t 62 | | Lambda of string * t 63 | [@@deriving show, cconv] 64 | 65 | let name = "lambda-term" 66 | let t1 = Lambda ("x", App (Lambda ("y", App (Var "y", Var "x")), Var "x")) 67 | let examples = [t1] 68 | end) 69 | 70 | module M3 = struct 71 | module T = struct 72 | type boxed_int = { 73 | bint : int; 74 | } [@@deriving cconv, show] 75 | 76 | let box_int bint = {bint} 77 | let unbox_int {bint} = bint 78 | 79 | type t = { 80 | i : (int 81 | [@encoder CConv.Encode.(map box_int encode_boxed_int)] 82 | [@decoder CConv.Decode.(map unbox_int decode_boxed_int)]); 83 | j : int; 84 | } 85 | [@@deriving show, cconv] 86 | 87 | let name = "record_encoder" 88 | let t1 = { i=1; j=42 } 89 | let t2 = { i=10; j=0 } 90 | let t3 = { i=0; j=11 } 91 | let examples = [t1; t2; t3] 92 | end 93 | 94 | include Make(T) 95 | 96 | (* sort json record *) 97 | let sort_json = function 98 | | `Assoc l -> `Assoc (List.sort compare l) 99 | | x -> x 100 | 101 | let test_encode_yojson () = 102 | let json = CConvYojson.encode T.encode T.t1 |> sort_json in 103 | OUnit.assert_equal ~printer:(Yojson.Basic.pretty_to_string ~std:true) 104 | (`Assoc ["i", `Assoc ["bint", `Int 1]; "j", `Int 42]) json 105 | 106 | let suite2 = "" >::: 107 | [ "@encoder" >:: test_encode_yojson 108 | ] 109 | 110 | let () = add_suite suite2 111 | end 112 | 113 | module M4 = Make(struct 114 | type t = int * string [@@deriving cconv, show] 115 | let name = "pair" 116 | let examples = [1, "foo"; 2, "bar"; max_int, ""] 117 | end) 118 | 119 | module M5 = Make(struct 120 | type t = bool * (int * float * int32 * unit) * string list array 121 | [@@deriving cconv] 122 | let show _ = "" (* TODO: wait for deriving show to work on unit *) 123 | let name = "bifi32usla" 124 | let examples = [ 125 | true, (1, 3.14, 42l, ()), [| ["a"]; ["hello"; "world"] |] 126 | ] 127 | end) 128 | 129 | module M6 = Make(struct 130 | type t = { foo : string [@key "bar"]} [@@deriving cconv, show] 131 | let name = "key param" 132 | let t1 = { foo = "hi"} 133 | let examples = [t1] 134 | 135 | let test_encode_yojson () = 136 | let json = CConvYojson.encode encode t1 in 137 | OUnit.assert_equal ~printer:(Yojson.Basic.pretty_to_string ~std:true) 138 | (`Assoc ["bar", `String "hi"]) json 139 | 140 | let suite2 = "" >::: 141 | [ "@key" >:: test_encode_yojson] 142 | 143 | let () = add_suite suite2 144 | end) 145 | 146 | module M7 = Make(struct 147 | type t = { foo : string [@default "bar"]} [@@deriving cconv, show] 148 | let name = "default param" 149 | let t1 = { foo = "bar"} 150 | let examples = [t1] 151 | 152 | let test_decode_yojson () = 153 | let v = CConvYojson.decode_exn decode (`Assoc []) in 154 | OUnit.assert_equal ~printer:show {foo = "bar"} v 155 | 156 | let suite2 = "" >::: 157 | [ "@default" >:: test_decode_yojson] 158 | 159 | let () = add_suite suite2 160 | end) 161 | 162 | type record_ignore = { 163 | x : int; 164 | y : int [@ignore]; 165 | } [@@deriving show, cconv] 166 | 167 | let test_record_ignore () = 168 | let r = { x=1; y=2} in 169 | let json = CConvYojson.encode encode_record_ignore r in 170 | OUnit.assert_equal ~printer:(Yojson.Basic.pretty_to_string ~std:true) 171 | (`Assoc ["x", `Int 1]) json; 172 | () 173 | 174 | module Nested = struct 175 | type r = { 176 | z : int; 177 | ys : string list 178 | } [@@deriving show, cconv] 179 | 180 | type t = { 181 | r : r 182 | } [@@deriving show, cconv] 183 | end 184 | 185 | let test_exception () = 186 | let check_exception json expected = 187 | try CConvYojson.decode_exn Nested.decode json |> ignore 188 | with CConv.ConversionFailure msg -> 189 | OUnit.assert_equal ~printer:(fun x -> x) expected msg in 190 | check_exception 191 | (`Assoc ["r", `Assoc ["z", `Int 10; "ys", `List [`String "hello"; `List []]]]) 192 | "conversion error: unexpected list at r / ys / 1"; 193 | check_exception (`Int 1) "conversion error: unexpected int" 194 | 195 | let () = 196 | add_suite ("record_ignore" >:: test_record_ignore); 197 | add_suite ("exception" >:: test_exception) 198 | 199 | let _ = 200 | let suite = "cconv" >::: List.rev !suites in 201 | OUnit.run_test_tt_main suite 202 | --------------------------------------------------------------------------------