├── .gitignore ├── .ocp-indent ├── .travis.yml ├── CHANGES.md ├── LICENSE.md ├── Makefile ├── README.md ├── depyt.opam ├── dune-project ├── src ├── depyt.ml ├── depyt.mli └── dune └── test ├── dune └── test.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | tmp 3 | *~ 4 | \.\#* 5 | \#*# 6 | *.install 7 | *.native 8 | *.byte 9 | _opam 10 | -------------------------------------------------------------------------------- /.ocp-indent: -------------------------------------------------------------------------------- 1 | strict_with=always,match_clause=4,strict_else=never 2 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | sudo: required 3 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-opam.sh 4 | script: bash -ex .travis-opam.sh 5 | env: 6 | global: 7 | - PACKAGE=depyt 8 | matrix: 9 | - OCAML_VERSION=4.03 10 | - OCAML_VERSION=4.04 11 | - OCAML_VERSION=4.05 12 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ### 0.3.0 (2022-03-10) 2 | 3 | - Add support for OCaml 4.14 and 5.00 (#22, @kit-ty-kate) 4 | 5 | ### 0.2.0 (2016-07-12) 6 | 7 | - add `like` to describe similar/bijective types (@samoht) 8 | - rename `pp` to dump (@samoht) 9 | - use jbuilder (@samoht) 10 | - add `decode_json_lexemes` (@samoht) 11 | 12 | ### 0.1.0 (2016-11-27) 13 | 14 | First release. 15 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 Thomas Gazagnaire 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all clean doc test 2 | 3 | all: 4 | dune build 5 | 6 | test: 7 | dune runtest 8 | 9 | doc: 10 | dune build @doc 11 | 12 | clean: 13 | dune clean 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ### Depyt — yet-an-other type combinator library 2 | 3 | Depyt provides type combinators to define runtime representation for 4 | OCaml types and generic operations to manipulate values with a runtime 5 | type representation. 6 | 7 | The type combinators supports all the usual type primitives but also 8 | compact definitions of records and variants. It also allows to define 9 | the runtime representation of recursive types. 10 | 11 | Depyt is a modern reboot of 12 | [Dyntype](https://github.com/mirage/dyntype) but using 13 | [GADT](https://en.wikipedia.org/wiki/Generalized_algebraic_data_type)s-based 14 | combinators instead of syntax-extensions. When we originally wrote 15 | Dyntype (in 2012) GADTs were not available in OCaml and 16 | [camlp4](https://github.com/ocaml/camlp4) was everywhere -- this is 17 | not the case anymore. Finally, Depyt avoids some of the performance 18 | caveats present in Dyntype by avoiding allocating and converting 19 | between intermediate formats. 20 | 21 | #### Variants 22 | 23 | For instance, to define variants: 24 | 25 | ```ocaml 26 | # #require "depyt";; 27 | # open Depyt;; 28 | # type t = Foo | Bar of string option;; 29 | type t = Foo | Bar of string option 30 | # let t = 31 | variant "v" (fun foo bar -> function Foo -> foo | Bar x -> bar x) 32 | |~ case0 "Foo" Foo 33 | |~ case1 "Bar" (option string) (fun x -> Bar x) 34 | |> sealv 35 | ;; 36 | val t : t Depyt.t = 37 | # Fmt.pr "t = %a\n%!" (dump t) Foo;; 38 | t = Foo 39 | - : unit = () 40 | # compare t Foo (Bar (Some "a"));; 41 | - : int = -1 42 | # compare t Foo (Bar (Some "a"));; 43 | - : int = -1 44 | ``` 45 | 46 | #### Records 47 | 48 | To define records: 49 | 50 | ```ocaml 51 | # type t = { foo: int option; bar: string list };; 52 | type t = { foo : int option; bar : string list; } 53 | # let t = 54 | record "r" (fun foo bar -> { foo; bar }) 55 | |+ field "foo" (option int) (fun t -> t.foo) 56 | |+ field "bar" (list string) (fun t -> t.bar) 57 | |> sealr 58 | ;; 59 | val t : t Depyt.t = 60 | # Fmt.pr "%a\n%!" (dump t) { foo = Some 3; bar = ["foo"] };; 61 | { foo = Some 3; bar = ["foo"]; } 62 | - : unit = () 63 | # (* [None] fields do not appear in the generated JSON *) 64 | # Fmt.pr "%a\n%!" (pp_json t) { foo = None; bar = ["1";"2"] };; 65 | {"bar":["1","2"]} 66 | - : unit = () 67 | ``` 68 | 69 | Depyt is distributed under the ISC license. 70 | 71 | Homepage: https://github.com/samoht/depyt 72 | 73 | ## Installation 74 | 75 | Depyt can be installed with `opam`: 76 | 77 | opam install depyt 78 | 79 | If you don't use `opam` consult the [`opam`](opam) file for build 80 | instructions. 81 | 82 | ## Documentation 83 | 84 | The documentation and API reference is automatically generated by from 85 | the source interfaces. It can be consulted [online][doc] or via 86 | `odig doc depyt`. 87 | 88 | [doc]: https://samoht.github.io/depyt/doc 89 | -------------------------------------------------------------------------------- /depyt.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | synopsis: "Yet-an-other type combinator library" 3 | description: """ 4 | Depyt provides type combinators to define runtime representation for 5 | OCaml types and generic operations to manipulate values with a runtime 6 | type representation. 7 | 8 | The type combinators supports all the usual type primitives but also 9 | compact definitions of records and variants. It also allows to define 10 | the runtime representation of recursive types. 11 | 12 | Depyt is a modern reboot of 13 | [Dyntype](https://github.com/mirage/dyntype) but using 14 | [GADT](https://en.wikipedia.org/wiki/Generalized_algebraic_data_type)s-based 15 | combinators instead of syntax-extensions. When we originally wrote 16 | Dyntype (in 2012) GADTs were not available in OCaml and 17 | [camlp4](https://github.com/ocaml/camlp4) was everywhere -- this is 18 | not the case anymore. Finally, Depyt avoids some of the performance 19 | caveats present in Dyntype by avoiding allocating and converting 20 | between intermediate formats. 21 | """ 22 | maintainer: "Thomas Gazagnaire " 23 | authors: ["Thomas Gazagnaire "] 24 | homepage: "https://github.com/samoht/depyt" 25 | dev-repo: "git+https://github.com/samoht/depyt.git" 26 | bug-reports: "https://github.com/samoht/depyt/issues" 27 | doc: "https://samoht.github.io/depyt/doc" 28 | license: "ISC" 29 | tags: ["org:mirage"] 30 | 31 | build: [ 32 | ["dune" "subst"] {dev} 33 | ["dune" "build" "-p" name "-j" jobs] 34 | ] 35 | run-test: ["dune" "runtest" "-p" name "-j" jobs] 36 | 37 | depends: [ 38 | "ocaml" {>= "4.08"} 39 | "dune" {>= "1.0"} 40 | "cstruct" {>= "1.8.0"} 41 | "fmt" {>= "0.8.7"} 42 | "jsonm" {>= "0.9.1"} 43 | "ocplib-endian" {>= "0.7"} 44 | "alcotest" {with-test} 45 | ] 46 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.0) 2 | (name depyt) 3 | -------------------------------------------------------------------------------- /src/depyt.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Thomas Gazagnaire. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | type (_, _) eq = Refl: ('a, 'a) eq 8 | 9 | module Witness : sig 10 | type 'a t 11 | val make : unit -> 'a t 12 | val eq : 'a t -> 'b t -> ('a, 'b) eq option 13 | end = struct 14 | 15 | type _ equality = .. 16 | 17 | module type Inst = sig 18 | type t 19 | type _ equality += Eq : t equality 20 | end 21 | 22 | type 'a t = (module Inst with type t = 'a) 23 | 24 | let make: type a. unit -> a t = fun () -> 25 | let module Inst = struct 26 | type t = a 27 | type _ equality += Eq : t equality 28 | end 29 | in 30 | (module Inst) 31 | 32 | let eq: type a b. a t -> b t -> (a, b) eq option = 33 | fun (module A) (module B) -> 34 | match A.Eq with 35 | | B.Eq -> Some Refl 36 | | _ -> None 37 | 38 | end 39 | 40 | type _ t = 41 | | Self : 'a self -> 'a t 42 | | Like : ('a, 'b) like -> 'b t 43 | | Prim : 'a prim -> 'a t 44 | | List : 'a t -> 'a list t 45 | | Array : 'a t -> 'a array t 46 | | Tuple : 'a tuple -> 'a t 47 | | Option : 'a t -> 'a option t 48 | | Record : 'a record -> 'a t 49 | | Variant: 'a variant -> 'a t 50 | 51 | and ('a, 'b) like = { 52 | x: 'a t; 53 | f: ('a -> 'b); 54 | g: ('b -> 'a); 55 | lwit: 'b Witness.t; 56 | } 57 | 58 | and 'a self = { 59 | mutable self: 'a t; 60 | } 61 | 62 | and 'a prim = 63 | | Unit : unit prim 64 | | Bool : bool prim 65 | | Char : char prim 66 | | Int : int prim 67 | | Int32 : int32 prim 68 | | Int64 : int64 prim 69 | | Float : float prim 70 | | String : string prim 71 | 72 | and 'a tuple = 73 | | Pair : 'a t * 'b t -> ('a * 'b) tuple 74 | | Triple : 'a t * 'b t * 'c t -> ('a * 'b * 'c) tuple 75 | 76 | and 'a record = { 77 | rwit : 'a Witness.t; 78 | rname : string; 79 | rfields: 'a fields_and_constr; 80 | } 81 | 82 | and 'a fields_and_constr = 83 | | Fields: ('a, 'b) fields * 'b -> 'a fields_and_constr 84 | 85 | and ('a, 'b) fields = 86 | | F0: ('a, 'a) fields 87 | | F1: ('a, 'b) field * ('a, 'c) fields -> ('a, 'b -> 'c) fields 88 | 89 | and ('a, 'b) field = { 90 | fname: string; 91 | ftype: 'b t; 92 | fget : 'a -> 'b; 93 | } 94 | 95 | and 'a variant = { 96 | vwit : 'a Witness.t; 97 | vname : string; 98 | vcases: 'a a_case array; 99 | vget : 'a -> 'a case_v; 100 | } 101 | 102 | and 'a a_case = 103 | | C0: 'a case0 -> 'a a_case 104 | | C1: ('a, 'b) case1 -> 'a a_case 105 | 106 | and 'a case_v = 107 | | CV0: 'a case0 -> 'a case_v 108 | | CV1: ('a, 'b) case1 * 'b -> 'a case_v 109 | 110 | and 'a case0 = { 111 | ctag0 : int; 112 | cname0: string; 113 | c0 : 'a; 114 | } 115 | 116 | and ('a, 'b) case1 = { 117 | ctag1 : int; 118 | cname1: string; 119 | ctype1: 'b t; 120 | c1 : 'b -> 'a; 121 | } 122 | 123 | type _ a_field = Field: ('a, 'b) field -> 'a a_field 124 | 125 | module Refl = struct 126 | 127 | let prim: type a b. a prim -> b prim -> (a, b) eq option = fun a b -> 128 | match a, b with 129 | | Unit , Unit -> Some Refl 130 | | Int , Int -> Some Refl 131 | | String, String -> Some Refl 132 | | _ -> None 133 | 134 | let rec eq: type a b. a t -> b t -> (a, b) eq option = fun a b -> 135 | match a, b with 136 | | Self a, b -> eq a.self b 137 | | a, Self b -> eq a b.self 138 | | Like a, Like b -> Witness.eq a.lwit b.lwit 139 | | Prim a, Prim b -> prim a b 140 | | List a, List b -> 141 | (match eq a b with Some Refl -> Some Refl | None -> None) 142 | | Tuple a, Tuple b -> tuple a b 143 | | Option a, Option b -> 144 | (match eq a b with Some Refl -> Some Refl | None -> None) 145 | | Record a, Record b -> Witness.eq a.rwit b.rwit 146 | | Variant a, Variant b -> Witness.eq a.vwit b.vwit 147 | | _ -> None 148 | 149 | and tuple: type a b. a tuple -> b tuple -> (a, b) eq option = fun a b -> 150 | match a, b with 151 | | Pair (a0, a1), Pair (b0, b1) -> 152 | (match eq a0 b0, eq a1 b1 with 153 | | Some Refl, Some Refl -> Some Refl 154 | | _ -> None) 155 | | Triple (a0, a1, a2), Triple (b0, b1, b2) -> 156 | (match eq a0 b0, eq a1 b1, eq a2 b2 with 157 | | Some Refl, Some Refl, Some Refl -> Some Refl 158 | | _ -> None) 159 | | _ -> None 160 | 161 | end 162 | 163 | let unit = Prim Unit 164 | let bool = Prim Bool 165 | let char = Prim Char 166 | let int = Prim Int 167 | let int32 = Prim Int32 168 | let int64 = Prim Int64 169 | let float = Prim Float 170 | let string = Prim String 171 | 172 | let list l = List l 173 | let array a = Array a 174 | let pair a b = Tuple (Pair (a, b)) 175 | let triple a b c = Tuple (Triple (a, b, c)) 176 | let option a = Option a 177 | 178 | let like (type a b) (x: a t) (f: a -> b) (g: b -> a) = 179 | Like { x; f; g; lwit = Witness.make () } 180 | 181 | (* fix points *) 182 | 183 | let mu: type a. (a t -> a t) -> a t = fun f -> 184 | let rec fake_x = { self = Self fake_x } in 185 | let real_x = f (Self fake_x) in 186 | fake_x.self <- real_x; 187 | real_x 188 | 189 | let mu2: type a b. (a t -> b t -> a t * b t) -> a t * b t = fun f -> 190 | let rec fake_x = { self = Self fake_x } in 191 | let rec fake_y = { self =Self fake_y } in 192 | let real_x, real_y = f (Self fake_x) (Self fake_y) in 193 | fake_x.self <- real_x; 194 | fake_y.self <- real_y; 195 | real_x, real_y 196 | 197 | (* records *) 198 | 199 | type ('a, 'b, 'c) open_record = 200 | ('a, 'c) fields -> string * 'b * ('a, 'b) fields 201 | 202 | let field fname ftype fget = { fname; ftype; fget } 203 | 204 | let record: string -> 'b -> ('a, 'b, 'b) open_record = 205 | fun n c fs -> n, c, fs 206 | 207 | let app: type a b c d. 208 | (a, b, c -> d) open_record -> (a, c) field -> (a, b, d) open_record 209 | = fun r f fs -> 210 | let n, c, fs = r (F1 (f, fs)) in 211 | n, c, fs 212 | 213 | let sealr: type a b. (a, b, a) open_record -> a t = 214 | fun r -> 215 | let rname, c, fs = r F0 in 216 | let rwit = Witness.make () in 217 | Record { rwit; rname; rfields = Fields (fs, c) } 218 | 219 | let (|+) = app 220 | 221 | (* variants *) 222 | 223 | type 'a case_p = 'a case_v 224 | 225 | type ('a, 'b) case = int -> ('a a_case * 'b) 226 | 227 | let case0 cname0 c0 ctag0 = 228 | let c = { ctag0; cname0; c0 } in 229 | C0 c, CV0 c 230 | 231 | let case1 cname1 ctype1 c1 ctag1 = 232 | let c = { ctag1; cname1; ctype1; c1 } in 233 | C1 c, fun v -> CV1 (c, v) 234 | 235 | type ('a, 'b, 'c) open_variant = 'a a_case list -> string * 'c * 'a a_case list 236 | 237 | let variant n c vs = n, c, vs 238 | 239 | let app v c cs = 240 | let n, fc, cs = v cs in 241 | let c, f = c (List.length cs) in 242 | n, fc f, (c :: cs) 243 | 244 | let sealv v = 245 | let vname, vget, vcases = v [] in 246 | let vwit = Witness.make () in 247 | let vcases = Array.of_list (List.rev vcases) in 248 | Variant { vwit; vname; vcases ; vget } 249 | 250 | let (|~) = app 251 | 252 | let enum vname l = 253 | let vwit = Witness.make () in 254 | let _, vcases, mk = 255 | List.fold_left (fun (ctag0, cases, mk) (n, v) -> 256 | let c = { ctag0; cname0 = n; c0 = v } in 257 | ctag0+1, (C0 c :: cases), (v, CV0 c) :: mk 258 | ) (0, [], []) l 259 | in 260 | let vcases = Array.of_list (List.rev vcases) in 261 | Variant { vwit; vname; vcases; vget = fun x -> List.assq x mk } 262 | 263 | let rec fields_aux: type a b. (a, b) fields -> a a_field list = function 264 | | F0 -> [] 265 | | F1 (h, t) -> Field h :: fields_aux t 266 | 267 | let fields r = match r.rfields with 268 | | Fields (f, _) -> fields_aux f 269 | 270 | module Dump = struct 271 | 272 | let unit ppf () = Fmt.string ppf "()" 273 | let bool = Fmt.bool 274 | let char = Fmt.char 275 | let int = Fmt.int 276 | let int32 = Fmt.int32 277 | let int64 = Fmt.int64 278 | let float = Fmt.float 279 | let string ppf x = Fmt.pf ppf "%S" x 280 | let list = Fmt.Dump.list 281 | let array = Fmt.Dump.array 282 | let pair = Fmt.Dump.pair 283 | let triple a b c ppf (x, y, z) = Fmt.pf ppf "(%a, %a, %a)" a x b y c z 284 | let option = Fmt.Dump.option 285 | 286 | let rec t: type a. a t -> a Fmt.t = function 287 | | Self s -> t s.self 288 | | Like b -> like b 289 | | Prim t -> prim t 290 | | List l -> list (t l) 291 | | Array a -> array (t a) 292 | | Tuple t -> tuple t 293 | | Option x -> option (t x) 294 | | Record r -> record r 295 | | Variant v -> variant v 296 | 297 | and tuple: type a. a tuple -> a Fmt.t = function 298 | | Pair (x,y) -> pair (t x) (t y) 299 | | Triple (x,y,z) -> triple (t x) (t y) (t z) 300 | 301 | and like: type a b. (a, b) like -> b Fmt.t = 302 | fun {x; g; _ } ppf b -> t x ppf (g b) 303 | 304 | and prim: type a. a prim -> a Fmt.t = function 305 | | Unit -> unit 306 | | Bool -> bool 307 | | Char -> char 308 | | Int -> int 309 | | Int32 -> int32 310 | | Int64 -> int64 311 | | Float -> float 312 | | String -> string 313 | 314 | and record: type a. a record -> a Fmt.t = fun r ppf x -> 315 | let fields = fields r in 316 | Fmt.pf ppf "@[{@ "; 317 | List.iter (fun (Field t) -> 318 | Fmt.pf ppf "%s = %a;@ " t.fname (field t) x 319 | ) fields; 320 | Fmt.pf ppf "}@]" 321 | 322 | and field: type a b. (a, b) field -> a Fmt.t = fun f ppf x -> 323 | t f.ftype ppf (f.fget x) 324 | 325 | and variant: type a. a variant -> a Fmt.t = fun v ppf x -> 326 | case_v ppf (v.vget x) 327 | 328 | and case_v: type a. a case_v Fmt.t = fun ppf -> function 329 | | CV0 x -> Fmt.string ppf x.cname0 330 | | CV1 (x, vx) -> Fmt.pf ppf "@[<2>%s %a@]" x.cname1 (t x.ctype1) vx 331 | 332 | end 333 | 334 | let dump = Dump.t 335 | 336 | type 'a equal = 'a -> 'a -> bool 337 | 338 | module Equal = struct 339 | 340 | let unit _ _ = true 341 | let bool (x:bool) (y:bool) = x = y 342 | let char (x:char) (y:char) = x = y 343 | let int (x:int) (y:int) = x = y 344 | let int32 (x:int32) (y:int32) = x = y 345 | let int64 (x:int64) (y:int64) = x = y 346 | let string x y = x == y || String.compare x y = 0 347 | 348 | (* NOTE: equality is ill-defined on float *) 349 | let float (x:float) (y:float) = x = y 350 | 351 | let list e x y = 352 | x == y || (List.length x = List.length y && List.for_all2 e x y) 353 | 354 | let array e x y = 355 | x == y || 356 | (Array.length x = Array.length y && 357 | let rec aux = function 358 | | -1 -> true 359 | | i -> e x.(i) y.(i) && aux (i-1) 360 | in aux (Array.length x - 1)) 361 | 362 | let pair ex ey (x1, y1 as a) (x2, y2 as b) = 363 | a == b || (ex x1 x2 && ey y1 y2) 364 | 365 | let triple ex ey ez (x1, y1, z1 as a) (x2, y2, z2 as b) = 366 | a == b || (ex x1 x2 && ey y1 y2 && ez z1 z2) 367 | 368 | let option e x y = 369 | x == y || 370 | match x, y with 371 | | None , None -> true 372 | | Some x, Some y -> e x y 373 | | _ -> false 374 | 375 | let rec t: type a. a t -> a equal = function 376 | | Self s -> t s.self 377 | | Like b -> like b 378 | | Prim p -> prim p 379 | | List l -> list (t l) 380 | | Array a -> array (t a) 381 | | Tuple t -> tuple t 382 | | Option x -> option (t x) 383 | | Record r -> record r 384 | | Variant v -> variant v 385 | 386 | and tuple: type a. a tuple -> a equal = function 387 | | Pair (a, b) -> pair (t a) (t b) 388 | | Triple (a, b, c) -> triple (t a) (t b) (t c) 389 | 390 | and like: type a b. (a, b) like -> b equal = 391 | fun { x; g; _ } u v -> t x (g u) (g v) 392 | 393 | and prim: type a. a prim -> a equal = function 394 | | Unit -> unit 395 | | Bool -> bool 396 | | Char -> char 397 | | Int -> int 398 | | Int32 -> int32 399 | | Int64 -> int64 400 | | Float -> float 401 | | String -> string 402 | 403 | and record: type a. a record -> a equal = fun r x y -> 404 | List.for_all (function Field f -> field f x y) (fields r) 405 | 406 | and field: type a b. (a, b) field -> a equal = fun f x y -> 407 | t f.ftype (f.fget x) (f.fget y) 408 | 409 | and variant: type a. a variant -> a equal = fun v x y -> 410 | case_v (v.vget x) (v.vget y) 411 | 412 | and case_v: type a. a case_v equal = fun x y -> 413 | match x, y with 414 | | CV0 x , CV0 y -> int x.ctag0 y.ctag0 415 | | CV1 (x, vx), CV1 (y, vy) -> int x.ctag1 y.ctag1 && 416 | eq (x.ctype1, vx) (y.ctype1, vy) 417 | | _ -> false 418 | 419 | and eq: type a b. (a t * a) -> (b t * b) -> bool = fun (tx, x) (ty, y) -> 420 | match Refl.eq tx ty with 421 | | Some Refl -> t tx x y 422 | | None -> assert false (* this should never happen *) 423 | 424 | end 425 | 426 | let equal = Equal.t 427 | 428 | type 'a compare = 'a -> 'a -> int 429 | 430 | module Compare = struct 431 | 432 | let unit (_:unit) (_:unit) = 0 433 | let bool (x:bool) (y:bool) = Stdlib.compare x y 434 | let char = Char.compare 435 | let int (x:int) (y:int) = Stdlib.compare x y 436 | let int32 = Int32.compare 437 | let int64 = Int64.compare 438 | let float (x:float) (y:float) = Stdlib.compare x y 439 | let string x y = if x == y then 0 else String.compare x y 440 | 441 | let list c x y = 442 | if x == y then 0 else 443 | let rec aux x y = match x, y with 444 | | [], [] -> 0 445 | | [], _ -> -1 446 | | _ , [] -> 1 447 | | xx::x,yy::y -> match c xx yy with 448 | | 0 -> aux x y 449 | | i -> i 450 | in 451 | aux x y 452 | 453 | let array c x y = 454 | if x == y then 0 else 455 | let lenx = Array.length x in 456 | let leny = Array.length y in 457 | if lenx > leny then 1 458 | else if lenx < leny then -1 459 | else 460 | let rec aux i = match c x.(i) y.(i) with 461 | | 0 when i+1 = lenx -> 0 462 | | 0 -> aux (i+1) 463 | | i -> i 464 | in 465 | aux 0 466 | 467 | let pair cx cy (x1, y1 as a) (x2, y2 as b) = 468 | if a == b then 0 else 469 | match cx x1 x2 with 470 | | 0 -> cy y1 y2 471 | | i -> i 472 | 473 | let triple cx cy cz (x1, y1, z1 as a) (x2, y2, z2 as b) = 474 | if a == b then 0 else 475 | match cx x1 x2 with 476 | | 0 -> pair cy cz (y1, z1) (y2, z2) 477 | | i -> i 478 | 479 | let option c x y = 480 | if x == y then 0 else 481 | match x, y with 482 | | None , None -> 0 483 | | Some _, None -> 1 484 | | None , Some _ -> -1 485 | | Some x, Some y -> c x y 486 | 487 | let rec t: type a. a t -> a compare = function 488 | | Self s -> t s.self 489 | | Like b -> like b 490 | | Prim p -> prim p 491 | | List l -> list (t l) 492 | | Array a -> array (t a) 493 | | Tuple t -> tuple t 494 | | Option x -> option (t x) 495 | | Record r -> record r 496 | | Variant v -> variant v 497 | 498 | and tuple: type a. a tuple -> a compare = function 499 | | Pair (x,y) -> pair (t x) (t y) 500 | | Triple (x,y,z) -> triple (t x) (t y) (t z) 501 | 502 | and like: type a b. (a, b) like -> b compare = 503 | fun { x; g; _ } u v -> t x (g u) (g v) 504 | 505 | and prim: type a. a prim -> a compare = function 506 | | Unit -> unit 507 | | Bool -> bool 508 | | Char -> char 509 | | Int -> int 510 | | Int32 -> int32 511 | | Int64 -> int64 512 | | Float -> float 513 | | String -> string 514 | 515 | and record: type a. a record -> a compare = fun r x y -> 516 | let rec aux = function 517 | | [] -> 0 518 | | Field f :: t -> match field f x y with 0 -> aux t | i -> i 519 | in 520 | aux (fields r) 521 | 522 | and field: type a b. (a, b) field -> a compare = fun f x y -> 523 | t f.ftype (f.fget x) (f.fget y) 524 | 525 | and variant: type a. a variant -> a compare = fun v x y -> 526 | case_v (v.vget x) (v.vget y) 527 | 528 | and case_v: type a. a case_v compare = fun x y -> 529 | match x, y with 530 | | CV0 x , CV0 y -> int x.ctag0 y.ctag0 531 | | CV0 x , CV1 (y, _) -> int x.ctag0 y.ctag1 532 | | CV1 (x, _) , CV0 y -> int x.ctag1 y.ctag0 533 | | CV1 (x, vx), CV1 (y, vy) -> 534 | match int x.ctag1 y.ctag1 with 535 | | 0 -> compare (x.ctype1, vx) (y.ctype1, vy) 536 | | i -> i 537 | 538 | and compare: type a b. (a t * a) -> (b t * b) -> int = fun (tx, x) (ty, y) -> 539 | match Refl.eq tx ty with 540 | | Some Refl -> t tx x y 541 | | None -> assert false (* this should never happen *) 542 | 543 | end 544 | 545 | let compare = Compare.t 546 | 547 | type buffer = 548 | | C of Cstruct.t 549 | | B of bytes 550 | 551 | type 'a size_of = 'a -> int 552 | type 'a write = buffer -> pos:int -> 'a -> int 553 | type 'a read = buffer -> pos:int -> int * 'a 554 | 555 | module Size_of = struct 556 | 557 | let unit () = 0 558 | let int8 (_:int) = 1 559 | let char (_:char) = 1 560 | let int (_:int) = 8 (* NOTE: to be portable, we consider int=int64 *) 561 | let int32 (_:int32) = 4 562 | let int64 (_:int64) = 8 563 | let bool (_:bool) = 1 564 | let float (_:float) = 8 (* NOTE: we consider 'double' here *) 565 | let string s = (int 0) + String.length s 566 | let list l x = List.fold_left (fun acc x -> acc + l x) (int 0) x 567 | let array l x = Array.fold_left (fun acc x -> acc + l x) (int 0) x 568 | let pair a b (x, y) = a x + b y 569 | let triple a b c (x, y, z) = a x + b y + c z 570 | let option o = function 571 | | None -> int8 0 572 | | Some x -> (int8 0) + o x 573 | 574 | let rec t: type a. a t -> a size_of = function 575 | | Self s -> t s.self 576 | | Like b -> like b 577 | | Prim t -> prim t 578 | | List l -> list (t l) 579 | | Array a -> array (t a) 580 | | Tuple t -> tuple t 581 | | Option x -> option (t x) 582 | | Record r -> record r 583 | | Variant v -> variant v 584 | 585 | and tuple: type a. a tuple -> a size_of = function 586 | | Pair (x,y) -> pair (t x) (t y) 587 | | Triple (x,y,z) -> triple (t x) (t y) (t z) 588 | 589 | and like: type a b. (a, b) like -> b size_of = 590 | fun { x; g; _ } u -> t x (g u) 591 | 592 | and prim: type a. a prim -> a size_of = function 593 | | Unit -> unit 594 | | Bool -> bool 595 | | Char -> char 596 | | Int -> int 597 | | Int32 -> int32 598 | | Int64 -> int64 599 | | Float -> float 600 | | String -> string 601 | 602 | and record: type a. a record -> a size_of = fun r x -> 603 | let fields = fields r in 604 | List.fold_left (fun acc (Field f) -> acc + field f x) 0 fields 605 | 606 | and field: type a b. (a, b) field -> a size_of = fun f x -> 607 | t f.ftype (f.fget x) 608 | 609 | and variant: type a. a variant -> a size_of = fun v x -> 610 | match v.vget x with 611 | | CV0 _ -> (int8 0) 612 | | CV1 (x, vx) -> (int8 0) + t x.ctype1 vx 613 | 614 | end 615 | 616 | module B = EndianBytes.BigEndian 617 | 618 | module Write = struct 619 | 620 | let (>>=) = (|>) 621 | 622 | let unit _ ~pos () = pos 623 | 624 | let int8 buf ~pos i = match buf with 625 | | C buf -> Cstruct.set_uint8 buf pos i; pos+1 626 | | B buf -> B.set_int8 buf pos i; pos+1 627 | 628 | let char buf ~pos c = match buf with 629 | | C buf -> Cstruct.set_char buf pos c; pos+1 630 | | B buf -> B.set_char buf pos c; pos+1 631 | 632 | let int32 buf ~pos i = match buf with 633 | | C buf -> Cstruct.BE.set_uint32 buf pos i; pos+4 634 | | B buf -> B.set_int32 buf pos i; pos+4 635 | 636 | let int64 buf ~pos i = match buf with 637 | | C buf -> Cstruct.BE.set_uint64 buf pos i; pos+8 638 | | B buf -> B.set_int64 buf pos i; pos+8 639 | 640 | let int buf ~pos i = int64 buf ~pos (Int64.of_int i) 641 | let float buf ~pos f = int64 buf ~pos (Int64.bits_of_float f) 642 | 643 | let string buf ~pos str = 644 | let len = String.length str in 645 | let pos = int buf ~pos len in 646 | let () = match buf with 647 | | C buf -> Cstruct.blit_from_string str 0 buf pos len 648 | | B buf -> Bytes.blit_string str 0 buf pos len 649 | in pos+len 650 | 651 | let list l buf ~pos x = 652 | let pos = int buf ~pos (List.length x) in 653 | List.fold_left (fun pos i -> l buf ~pos i) pos x 654 | 655 | let array l buf ~pos x = 656 | let pos = int buf ~pos (Array.length x) in 657 | Array.fold_left (fun pos i -> l buf ~pos i) pos x 658 | 659 | let pair a b buf ~pos (x, y) = 660 | a buf ~pos x >>= fun pos -> 661 | b buf ~pos y 662 | 663 | let triple a b c buf ~pos (x, y, z) = 664 | a buf ~pos x >>= fun pos -> 665 | pair b c buf ~pos (y, z) 666 | 667 | let bool buf ~pos = function 668 | | false -> int8 buf ~pos 0 669 | | true -> int8 buf ~pos 1 670 | 671 | let option o buf ~pos = function 672 | | None -> bool buf ~pos false 673 | | Some x -> bool buf ~pos true >>= fun pos -> o buf ~pos x 674 | 675 | let rec t: type a. a t -> a write = function 676 | | Self s -> t s.self 677 | | Like b -> like b 678 | | Prim t -> prim t 679 | | List l -> list (t l) 680 | | Array a -> array (t a) 681 | | Tuple t -> tuple t 682 | | Option x -> option (t x) 683 | | Record r -> record r 684 | | Variant v -> variant v 685 | 686 | and tuple: type a. a tuple -> a write = function 687 | | Pair (x,y) -> pair (t x) (t y) 688 | | Triple (x,y,z) -> triple (t x) (t y) (t z) 689 | 690 | and like: type a b. (a, b) like -> b write = 691 | fun { x; g; _ } buf ~pos u -> t x buf ~pos (g u) 692 | 693 | and prim: type a. a prim -> a write = function 694 | | Unit -> unit 695 | | Bool -> bool 696 | | Char -> char 697 | | Int -> int 698 | | Int32 -> int32 699 | | Int64 -> int64 700 | | Float -> float 701 | | String -> string 702 | 703 | and record: type a. a record -> a write = fun r buf ~pos x -> 704 | let fields = fields r in 705 | List.fold_left (fun pos (Field f) -> field f buf ~pos x) pos fields 706 | 707 | and field: type a b. (a, b) field -> a write = fun f buf ~pos x -> 708 | t f.ftype buf ~pos (f.fget x) 709 | 710 | and variant: type a. a variant -> a write = fun v buf ~pos x -> 711 | case_v buf ~pos (v.vget x) 712 | 713 | and case_v: type a. a case_v write = fun buf ~pos c -> 714 | match c with 715 | | CV0 c -> int8 buf ~pos c.ctag0 716 | | CV1 (c,v) -> 717 | int8 buf ~pos c.ctag1 >>= fun pos -> 718 | t c.ctype1 buf ~pos v 719 | 720 | end 721 | 722 | module Read = struct 723 | 724 | let (>|=) (pos, x) f = pos, f x 725 | let (>>=) (pos, x) f = f (pos, x) 726 | let ok pos x = (pos, x) 727 | 728 | type 'a res = int * 'a 729 | 730 | let unit _ ~pos = ok pos () 731 | 732 | let int8 buf ~pos = match buf with 733 | | C buf -> ok (pos+1) (Cstruct.get_uint8 buf pos) 734 | | B buf -> ok (pos+1) (B.get_int8 buf pos) 735 | 736 | let char buf ~pos = match buf with 737 | | C buf -> ok (pos+1) (Cstruct.get_char buf pos) 738 | | B buf -> ok (pos+1) (B.get_char buf pos) 739 | 740 | let int32 buf ~pos = match buf with 741 | | C buf -> ok (pos+4) (Cstruct.BE.get_uint32 buf pos) 742 | | B buf -> ok (pos+4) (B.get_int32 buf pos) 743 | 744 | let int64 buf ~pos = match buf with 745 | | C buf -> ok (pos+8) (Cstruct.BE.get_uint64 buf pos) 746 | | B buf -> ok (pos+8) (B.get_int64 buf pos) 747 | 748 | let bool buf ~pos = int8 buf ~pos >|= function 0 -> false | _ -> true 749 | let int buf ~pos = int64 buf ~pos >|= Int64.to_int 750 | let float buf ~pos = int64 buf ~pos >|= Int64.float_of_bits 751 | 752 | let string buf ~pos = 753 | int buf ~pos >>= fun (pos, len) -> 754 | let str = Bytes.create len in 755 | let () = match buf with 756 | | C buf -> Cstruct.blit_to_bytes buf pos str 0 len 757 | | B buf -> Bytes.blit buf pos str 0 len 758 | in 759 | ok (pos+len) (Bytes.unsafe_to_string str) 760 | 761 | let list l buf ~pos = 762 | int buf ~pos >>= fun (pos, len) -> 763 | let rec aux acc ~pos = function 764 | | 0 -> ok pos (List.rev acc) 765 | | n -> 766 | l buf ~pos >>= fun (pos, x) -> 767 | aux (x :: acc) ~pos (n - 1) 768 | in 769 | aux [] ~pos len 770 | 771 | let array l buf ~pos = list l buf ~pos >|= Array.of_list 772 | 773 | let pair a b buf ~pos = 774 | a buf ~pos >>= fun (pos, a) -> 775 | b buf ~pos >|= fun b -> 776 | (a, b) 777 | 778 | let triple a b c buf ~pos = 779 | a buf ~pos >>= fun (pos, a) -> 780 | b buf ~pos >>= fun (pos, b) -> 781 | c buf ~pos >|= fun c -> 782 | (a, b, c) 783 | 784 | let option: type a. a read -> a option read = fun o buf ~pos -> 785 | int8 buf ~pos >>= function 786 | | pos, 0 -> ok pos None 787 | | pos, _ -> o buf ~pos >|= fun x -> Some x 788 | 789 | let rec t: type a. a t -> a read = function 790 | | Self s -> t s.self 791 | | Like b -> like b 792 | | Prim t -> prim t 793 | | List l -> list (t l) 794 | | Array a -> array (t a) 795 | | Tuple t -> tuple t 796 | | Option x -> option (t x) 797 | | Record r -> record r 798 | | Variant v -> variant v 799 | 800 | and tuple: type a. a tuple -> a read = function 801 | | Pair (x,y) -> pair (t x) (t y) 802 | | Triple (x,y,z) -> triple (t x) (t y) (t z) 803 | 804 | and like: type a b. (a, b) like -> b read = 805 | fun { x; f; _ } buf ~pos -> t x buf ~pos >|= f 806 | 807 | and prim: type a. a prim -> a read = function 808 | | Unit -> unit 809 | | Bool -> bool 810 | | Char -> char 811 | | Int -> int 812 | | Int32 -> int32 813 | | Int64 -> int64 814 | | Float -> float 815 | | String -> string 816 | 817 | and record: type a. a record -> a read = fun r buf ~pos -> 818 | match r.rfields with 819 | | Fields (fs, c) -> 820 | let rec aux: type b. pos:int -> b -> (a, b) fields -> a res 821 | = fun ~pos f -> function 822 | | F0 -> ok pos f 823 | | F1 (h, t) -> 824 | field h buf ~pos >>= fun (pos, x) -> 825 | aux ~pos (f x) t 826 | in 827 | aux ~pos c fs 828 | 829 | and field: type a b. (a, b) field -> b read = fun f -> t f.ftype 830 | 831 | and variant: type a. a variant -> a read = fun v buf ~pos -> 832 | (* FIXME: we support 'only' 256 variants *) 833 | int8 buf ~pos >>= fun (pos, i) -> 834 | case v.vcases.(i) buf ~pos 835 | 836 | and case: type a. a a_case -> a read = fun c buf ~pos -> 837 | match c with 838 | | C0 c -> ok pos c.c0 839 | | C1 c -> t c.ctype1 buf ~pos >|= c.c1 840 | 841 | end 842 | 843 | let size_of = Size_of.t 844 | let read = Read.t 845 | let write = Write.t 846 | 847 | type 'a encode_json = Jsonm.encoder -> 'a -> unit 848 | 849 | module Encode_json = struct 850 | 851 | let lexeme e l = ignore (Jsonm.encode e (`Lexeme l)) 852 | 853 | let unit e () = lexeme e `Null 854 | let string e s = lexeme e (`String s) 855 | let char e c = string e (String.make 1 c) 856 | let float e f = lexeme e (`Float f) 857 | let int32 e i = float e (Int32.to_float i) 858 | let int64 e i = float e (Int64.to_float i) 859 | let int e i = float e (float_of_int i) 860 | let bool e = function false -> float e 0. | _ -> float e 1. 861 | 862 | let list l e x = 863 | lexeme e `As; 864 | List.iter (l e) x; 865 | lexeme e `Ae 866 | 867 | let array l e x = 868 | lexeme e `As; 869 | Array.iter (l e) x; 870 | lexeme e `Ae 871 | 872 | let pair a b e (x, y) = 873 | lexeme e `As; 874 | a e x; 875 | b e y; 876 | lexeme e `Ae 877 | 878 | let triple a b c e (x, y, z) = 879 | lexeme e `As; 880 | a e x; 881 | b e y; 882 | c e z; 883 | lexeme e `Ae 884 | 885 | let option o e = function 886 | | None -> lexeme e `Null 887 | | Some x -> o e x 888 | 889 | let rec t: type a. a t -> a encode_json = function 890 | | Self s -> t s.self 891 | | Like b -> like b 892 | | Prim t -> prim t 893 | | List l -> list (t l) 894 | | Array a -> array (t a) 895 | | Tuple t -> tuple t 896 | | Option x -> option (t x) 897 | | Record r -> record r 898 | | Variant v -> variant v 899 | 900 | and tuple: type a. a tuple -> a encode_json = function 901 | | Pair (x,y) -> pair (t x) (t y) 902 | | Triple (x,y,z) -> triple (t x) (t y) (t z) 903 | 904 | and like: type a b. (a, b) like -> b encode_json = 905 | fun { x; g; _ } e u -> t x e (g u) 906 | 907 | and prim: type a. a prim -> a encode_json = function 908 | | Unit -> unit 909 | | Bool -> bool 910 | | Char -> char 911 | | Int -> int 912 | | Int32 -> int32 913 | | Int64 -> int64 914 | | Float -> float 915 | | String -> string 916 | 917 | and record: type a. a record -> a encode_json = fun r e x -> 918 | let fields = fields r in 919 | lexeme e `Os; 920 | List.iter (fun (Field f) -> 921 | match f.ftype, f.fget x with 922 | | Option _, None -> () 923 | | Option o, Some x -> lexeme e (`Name f.fname); t o e x 924 | | tx , x -> lexeme e (`Name f.fname); t tx e x 925 | ) fields; 926 | lexeme e `Oe 927 | 928 | and variant: type a. a variant -> a encode_json = fun v e x -> 929 | case_v e (v.vget x) 930 | 931 | and case_v: type a. a case_v encode_json = fun e c -> 932 | match c with 933 | | CV0 c -> string e c.cname0 934 | | CV1 (c,v) -> 935 | lexeme e `Os; 936 | lexeme e (`Name c.cname1); 937 | t c.ctype1 e v; 938 | lexeme e `Oe 939 | 940 | end 941 | 942 | let encode_json = Encode_json.t 943 | 944 | let pp_json ?minify t ppf x = 945 | let buf = Buffer.create 42 in 946 | let e = Jsonm.encoder ?minify (`Buffer buf) in 947 | let wrap_and_encode () = encode_json (list t) e [x] in 948 | let encode () = encode_json t e x in 949 | let () = match t with 950 | | Prim _ -> wrap_and_encode () 951 | | Variant v -> 952 | (match v.vget x with 953 | | CV0 _ -> wrap_and_encode () 954 | | _ -> encode ()) 955 | | _ -> encode () 956 | in 957 | ignore (Jsonm.encode e `End); 958 | Fmt.string ppf (Buffer.contents buf) 959 | 960 | module Decode_json = struct 961 | 962 | type decoder = { 963 | mutable lexemes: Jsonm.lexeme list; 964 | d: Jsonm.decoder; 965 | } 966 | 967 | type 'a decode = decoder -> ('a, string) result 968 | 969 | let decoder d = { lexemes = []; d } 970 | let of_lexemes lexemes = { lexemes; d = Jsonm.decoder (`String "") } 971 | let rewind e l = e.lexemes <- l :: e.lexemes 972 | 973 | let lexeme e = 974 | match e.lexemes with 975 | | h::t -> e.lexemes <- t; Ok h 976 | | [] -> 977 | match Jsonm.decode e.d with 978 | | `Lexeme e -> Ok e 979 | | `Error e -> Error (Fmt.to_to_string Jsonm.pp_error e) 980 | | `End | `Await -> assert false 981 | 982 | let (>>=) l f = match l with 983 | | Error _ as e -> e 984 | | Ok l -> f l 985 | 986 | let (>|=) l f = match l with 987 | | Ok l -> Ok (f l) 988 | | Error _ as e -> e 989 | 990 | let error e got expected = 991 | let _, (l, c) = Jsonm.decoded_range e.d in 992 | Error (Fmt.str 993 | "line %d, character %d:\nFound lexeme %a, but \ 994 | lexeme %s was expected" l c Jsonm.pp_lexeme got expected) 995 | 996 | let expect_lexeme e expected = 997 | lexeme e >>= fun got -> 998 | if expected = got then Ok () 999 | else error e got (Fmt.to_to_string Jsonm.pp_lexeme expected) 1000 | 1001 | (* read all lexemes until the end of the next well-formed value *) 1002 | let value e = 1003 | let lexemes = ref [] in 1004 | let objs = ref 0 in 1005 | let arrs = ref 0 in 1006 | let rec aux () = 1007 | lexeme e >>= fun l -> 1008 | lexemes := l :: !lexemes; 1009 | let () = match l with 1010 | | `Os -> incr objs 1011 | | `As -> incr arrs 1012 | | `Oe -> decr objs 1013 | | `Ae -> decr arrs 1014 | | `Name _ 1015 | | `Null 1016 | | `Bool _ 1017 | | `String _ 1018 | | `Float _ -> () 1019 | in 1020 | if !objs > 0 || !arrs > 0 then aux () 1021 | else Ok () 1022 | in 1023 | aux () >|= fun () -> 1024 | List.rev !lexemes 1025 | 1026 | let unit e = expect_lexeme e `Null 1027 | 1028 | let string e = 1029 | lexeme e >>= function 1030 | | `String s -> Ok s 1031 | | l -> error e l "`String" 1032 | 1033 | let float e = 1034 | lexeme e >>= function 1035 | | `Float f -> Ok f 1036 | | l -> error e l "`Float" 1037 | 1038 | let char e = 1039 | lexeme e >>= function 1040 | | `String s when String.length s = 1 -> Ok (String.get s 1) 1041 | | l -> error e l "`String[1]" 1042 | 1043 | let int32 e = float e >|= Int32.of_float 1044 | let int64 e = float e >|= Int64.of_float 1045 | let int e = float e >|= int_of_float 1046 | let bool e = int e >|= function 0 -> false | _ -> true 1047 | 1048 | let list l e = 1049 | expect_lexeme e `As >>= fun () -> 1050 | let rec aux acc = 1051 | lexeme e >>= function 1052 | | `Ae -> Ok (List.rev acc) 1053 | | lex -> 1054 | rewind e lex; 1055 | l e >>= fun v -> 1056 | aux (v :: acc) 1057 | in 1058 | aux [] 1059 | 1060 | let array l e = list l e >|= Array.of_list 1061 | 1062 | let pair a b e = 1063 | expect_lexeme e `As >>= fun () -> 1064 | a e >>= fun x -> 1065 | b e >>= fun y -> 1066 | expect_lexeme e `Ae >|= fun () -> 1067 | x, y 1068 | 1069 | let triple a b c e = 1070 | expect_lexeme e `As >>= fun () -> 1071 | a e >>= fun x -> 1072 | b e >>= fun y -> 1073 | c e >>= fun z -> 1074 | expect_lexeme e `Ae >|= fun () -> 1075 | x, y, z 1076 | 1077 | let option o e = 1078 | lexeme e >>= function 1079 | | `Null -> Ok None 1080 | | lex -> 1081 | rewind e lex; 1082 | o e >|= fun v -> Some v 1083 | 1084 | let rec t: type a. a t -> a decode = function 1085 | | Self s -> t s.self 1086 | | Like b -> like b 1087 | | Prim t -> prim t 1088 | | List l -> list (t l) 1089 | | Array a -> array (t a) 1090 | | Tuple t -> tuple t 1091 | | Option x -> option (t x) 1092 | | Record r -> record r 1093 | | Variant v -> variant v 1094 | 1095 | and tuple: type a. a tuple -> a decode = function 1096 | | Pair (x,y) -> pair (t x) (t y) 1097 | | Triple (x,y,z) -> triple (t x) (t y) (t z) 1098 | 1099 | and like: type a b. (a, b) like -> b decode = 1100 | fun { x; f; _ } e -> t x e >|= f 1101 | 1102 | and prim: type a. a prim -> a decode = function 1103 | | Unit -> unit 1104 | | Bool -> bool 1105 | | Char -> char 1106 | | Int -> int 1107 | | Int32 -> int32 1108 | | Int64 -> int64 1109 | | Float -> float 1110 | | String -> string 1111 | 1112 | and record: type a. a record -> a decode = fun r e -> 1113 | expect_lexeme e `Os >>= fun () -> 1114 | let rec soup acc = 1115 | lexeme e >>= function 1116 | | `Name n -> 1117 | value e >>= fun s -> 1118 | soup ((n, s) :: acc) 1119 | | `Oe -> Ok acc 1120 | | l -> error e l "`Record-contents" 1121 | in 1122 | soup [] >>= fun soup -> 1123 | let rec aux: type a b. (a, b) fields -> b -> (a, string) result = fun f c -> 1124 | match f with 1125 | | F0 -> Ok c 1126 | | F1 (h, f) -> 1127 | let v = 1128 | try 1129 | let s = List.assoc h.fname soup in 1130 | let e = of_lexemes s in 1131 | t h.ftype e 1132 | with Not_found -> 1133 | match h.ftype with 1134 | | Option _ -> Ok None 1135 | | _ -> 1136 | Error (Fmt.str "missing value for %s.%s" r.rname h.fname) 1137 | in 1138 | match v with 1139 | | Ok v -> aux f (c v) 1140 | | Error _ as e -> e 1141 | in 1142 | let Fields (f, c) = r.rfields in 1143 | aux f c 1144 | 1145 | and variant: type a. a variant -> a decode = fun v e -> 1146 | lexeme e >>= function 1147 | | `String s -> case0 s v e 1148 | | `Os -> case1 v e 1149 | | l -> error e l "(`String | `Os)" 1150 | 1151 | and case0: type a. string -> a variant -> a decode = fun s v _e -> 1152 | let rec aux i = match v.vcases.(i) with 1153 | | C0 c when String.compare c.cname0 s = 0 -> Ok c.c0 1154 | | _ -> if i < Array.length v.vcases then aux (i+1) else Error "variant" 1155 | in 1156 | aux 0 1157 | 1158 | and case1: type a. a variant -> a decode = fun v e -> 1159 | lexeme e >>= function 1160 | | `Name s -> 1161 | let rec aux i = match v.vcases.(i) with 1162 | | C1 c when String.compare c.cname1 s = 0 -> t c.ctype1 e >|= c.c1 1163 | | _ -> if i < Array.length v.vcases then aux (i+1) else Error "variant" 1164 | in 1165 | aux 0 >>= fun c -> 1166 | expect_lexeme e `Oe >|= fun () -> 1167 | c 1168 | | l -> error e l "`Name" 1169 | 1170 | end 1171 | 1172 | let decode_json x d = Decode_json.(t x @@ decoder d) 1173 | let decode_json_lexemes x ls = Decode_json.(t x @@ of_lexemes ls) 1174 | 1175 | (*--------------------------------------------------------------------------- 1176 | Copyright (c) 2016 Thomas Gazagnaire 1177 | 1178 | Permission to use, copy, modify, and/or distribute this software for any 1179 | purpose with or without fee is hereby granted, provided that the above 1180 | copyright notice and this permission notice appear in all copies. 1181 | 1182 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 1183 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 1184 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 1185 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 1186 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 1187 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 1188 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 1189 | ---------------------------------------------------------------------------*) 1190 | -------------------------------------------------------------------------------- /src/depyt.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Thomas Gazagnaire. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | (** Yet-an-other type combinator library 8 | 9 | [Depyt] provides type combinators to define runtime representation 10 | for OCaml types and {{!generics}generic operations} to manipulate 11 | values with a runtime type representation. 12 | 13 | The type combinators supports all the usual {{!primitives}type 14 | primitives} but also compact definitions of {{!records}records} 15 | and {{!variants}variants}. It also allows to define the runtime 16 | representation of {{!recursive}recursive types}. 17 | 18 | [Depyt] is a modern reboot of 19 | {{:https://github.com/mirage/dyntype}Dyntype} but using 20 | {{:https://en.wikipedia.org/wiki/Generalized_algebraic_data_type}GADT}s-based 21 | combinators instead of syntax-extensions. When we originally wrote 22 | [Dyntype] (in 2012) GADTs were not available in {i OCaml} and 23 | {{:https://github.com/ocaml/camlp4}camlp4} was everywhere -- this 24 | is not the case anymore. Finally, [Depyt] avoids some of the 25 | performance caveats present in [Dyntype] by avoiding allocating 26 | and converting between intermediate formats. 27 | 28 | {e %%VERSION%% — {{:%%PKG_HOMEPAGE%% }homepage}} *) 29 | 30 | (** {1 Depyt} *) 31 | 32 | type 'a t 33 | (** The type for runtime representation of values of type ['a]. *) 34 | 35 | (** {1:primitives Primitives} *) 36 | 37 | val unit: unit t 38 | (** [unit] is a representation of the unit type. *) 39 | 40 | val bool: bool t 41 | (** [bool] is a representation of the boolean type. *) 42 | 43 | val char: char t 44 | (** [char] is a representation of the character type. *) 45 | 46 | val int: int t 47 | (** [int] is a representation of the integer type. *) 48 | 49 | val int32: int32 t 50 | (** [int32] is a representation of the 32-bit integers type. *) 51 | 52 | val int64: int64 t 53 | (** [int64] is a representation of the 64-bit integer type. *) 54 | 55 | val float: float t 56 | (** [float] is a representation of the float type. *) 57 | 58 | val string: string t 59 | (** [string] is a representation of the string type. *) 60 | 61 | val list: 'a t -> 'a list t 62 | (** [list t] is a representation of list of values of type [t]. *) 63 | 64 | val array: 'a t -> 'a array t 65 | (** [array t] is a representation of array of values of type [t]. *) 66 | 67 | val option: 'a t -> 'a option t 68 | (** [option t] is a representation of value of type [t option]. *) 69 | 70 | val pair: 'a t -> 'b t -> ('a * 'b) t 71 | (** [pair x y] is a representation of values of type [x * y]. *) 72 | 73 | val triple: 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t 74 | (** [triple x y z] is a representation of values of type [x * y * 75 | z]. *) 76 | 77 | (** {1:records Records} *) 78 | 79 | type ('a, 'b) field 80 | (** The type for fields holding values of type ['b] and belonging to a 81 | record of type ['a]. *) 82 | 83 | val field: string -> 'a t -> ('b -> 'a) -> ('b, 'a) field 84 | (** [field n t g] is the representation of the field [n] of type [t] 85 | with getter [g]. 86 | 87 | For instance: 88 | 89 | {[ 90 | type t = { foo: string option } 91 | 92 | let foo = field "foo" (option string) (fun t -> t.x)]} 93 | *) 94 | 95 | type ('a, 'b, 'c) open_record 96 | (** The type for representing open records of type ['a] with 97 | constructors of type ['b]. ['c] represents the fields missings to 98 | the record, e.g. an open record initially holds ['c = 'b] and it 99 | can can be {{!sealr}sealed} when ['c = 'a]. *) 100 | 101 | val sealr: ('a, 'b, 'a) open_record -> 'a t 102 | (** [sealr r] seal the open record [r]. *) 103 | 104 | val (|+): 105 | ('a, 'b, 'c -> 'd) open_record -> ('a, 'c) field -> ('a, 'b, 'd) open_record 106 | (** [r |+ f] adds the field [f] to the open record [r]. *) 107 | 108 | val record: string -> 'b -> ('a, 'b, 'b) open_record 109 | (** [record n f fs] is the representation of the record called [n] of 110 | type ['a] using [f] as constructor and with the fields [fs]. 111 | 112 | Putting all together: 113 | 114 | {[ 115 | type t = { foo: string; bar = (int * string) list; } 116 | 117 | let t = 118 | record "t" (fun foo -> { foo }) 119 | |+ field "foo" string (fun t -> t.foo) 120 | |+ field "bar" (list (pair int string)) (fun t -> t.bar) 121 | |> sealr]} 122 | *) 123 | 124 | (** {1:variants Variants} *) 125 | 126 | type ('a, 'b) case 127 | (** The type for representing variant cases of type ['a] with 128 | patterns of type ['b]. *) 129 | 130 | type 'a case_p 131 | (** The type for representing patterns for a variant of type ['a]. *) 132 | 133 | val case0: string -> 'a -> ('a, 'a case_p) case 134 | (** [case0 n v] is a representation of a variant case [n] with no 135 | argument and a singleton pattern. e.g. 136 | 137 | {[ 138 | type t = Foo 139 | 140 | let foo = case0 "Foo" Foo]} 141 | *) 142 | 143 | val case1: string -> 'b t -> ('b -> 'a) -> ('a, 'b -> 'a case_p) case 144 | (** [case1 n t c] is a representation of a variant case [n] with 1 145 | argument of type [t] and a pattern [c] an function with one argument 146 | of type [t]. e.g. 147 | 148 | {[ 149 | type t = Foo of string 150 | 151 | let foo = case1 "Foo" string (fun s -> Foo s)]} 152 | *) 153 | 154 | type ('a, 'b, 'c) open_variant 155 | (** The type for representing open variants of type ['a] with pattern 156 | matching of type ['b]. ['c] represents the missing cases for the 157 | variant, e.g. initially variant hols [c' = 'b] and it can be 158 | {{!sealv}sealed} when ['c = 'a]. *) 159 | 160 | val sealv: ('a, 'b, 'a -> 'a case_p) open_variant -> 'a t 161 | (** [sealv v] seals the open variant [v]. *) 162 | 163 | val (|~): 164 | ('a, 'b, 'c -> 'd) open_variant -> ('a, 'c) case -> ('a, 'b, 'd) open_variant 165 | (** [v |~ c] is [v] augmented with the case [c]. *) 166 | 167 | val variant: string -> 'b -> ('a, 'b, 'b) open_variant 168 | (** [variant n c p] is a representation of a variant type containing 169 | the cases [c] and using [p] to deconstruct values. 170 | 171 | Putting all together: 172 | 173 | {[ 174 | type t = Foo | Bar of string 175 | 176 | let t = 177 | variant "t" (fun foo bar -> function 178 | | Foo -> foo 179 | | Bar s -> bar s) 180 | |~ case0 "Foo" Foo 181 | |~ case1 "Bar" string (fun x -> Bar x) 182 | |> sealr]} 183 | *) 184 | 185 | val enum: string -> (string * 'a) list -> 'a t 186 | (** [enum n l] is a representation of the variant type which has 187 | only constant variant case. e.g. 188 | 189 | {[ 190 | type t = Foo | Bar | Toto 191 | 192 | let t = enum "t" ["Foo", Foo; "Bar", Bar; "Toto", Toto]]} 193 | *) 194 | 195 | (** {1:recursive Recursive definitions} 196 | 197 | [Depyt] allows to create a limited form of recursive records and 198 | variants. 199 | 200 | {b TODO}: describe the limitations, e.g. only regular recursion and no 201 | use of the generics inside the [mu*] functions and the usual 202 | caveats with recursive values (such as infinite loops on most of 203 | the generics which don't check sharing). 204 | 205 | *) 206 | 207 | val mu: ('a t -> 'a t) -> 'a t 208 | (** [mu f] is the representation [r] such that [r = mu r]. 209 | 210 | For instance: 211 | 212 | {[ 213 | type x = { x: x option } 214 | 215 | let x = mu (fun x -> 216 | record "x" (fun x -> { x }) 217 | |+ field "x" x (fun x -> x.x) 218 | |> sealr)]} 219 | *) 220 | 221 | val mu2: ('a t -> 'b t -> 'a t * 'b t) -> 'a t * 'b t 222 | (** [mu2 f] is the representations [r] and [s] such that [r, s = mu2 r 223 | s]. 224 | 225 | For instance: 226 | 227 | {[ 228 | type r = { foo: int; bar: string list; z: z option } 229 | and z = { x: int; r: r list } 230 | 231 | (* Build the representation of [r] knowing [z]'s. *) 232 | let mkr z = 233 | record "r" (fun foo bar z -> { foo; bar; z }) 234 | |+ field "foo" int (fun t -> t.foo) 235 | |+ field "bar" (list string) (fun t -> t.bar) 236 | |+ field "z" (option z) (fun t -> t.z) 237 | |> sealr 238 | 239 | (* And the representation of [z] knowing [r]'s. *) 240 | let mkz r = 241 | record "z" (fun x r -> { x; r }) 242 | |+ field "x" int (fun t -> t.x) 243 | |+ field "r" (list r) (fun t -> t.r) 244 | |> sealr 245 | 246 | (* Tie the loop. *) 247 | let r, z = mu2 (fun r z -> mkr z, mkz y)]} 248 | *) 249 | 250 | (** {1:proj Bijections} 251 | 252 | Sometimes it is not always possible to describe precisely a type 253 | (or it could be too tedious) and it is easier to describe the 254 | relation with an other know type. This is what bijections are 255 | about. 256 | *) 257 | 258 | val like: 'a t -> ('a -> 'b) -> ('b -> 'a) -> 'b t 259 | (** [like x f g] is the description of a type which looks like [x] 260 | using the bijetion [(f, g)]. *) 261 | 262 | (** {1:generics Generic Operations} 263 | 264 | Given a value ['a t], it is possible to define generic operations 265 | on value of type ['a] such as pretty-printing, parsing and 266 | unparsing. 267 | *) 268 | 269 | val dump: 'a t -> 'a Fmt.t 270 | (** [dump t] dumps the values of type [t] as a parsable OCaml 271 | expression. *) 272 | 273 | val equal: 'a t -> 'a -> 'a -> bool 274 | (** [equal t] is the equality function between values of type [t]. *) 275 | 276 | val compare: 'a t -> 'a -> 'a -> int 277 | (** [compare t] compares values of type [t]. *) 278 | 279 | (** {2 Binary serialization} *) 280 | 281 | (** The type for buffers. *) 282 | type buffer = 283 | | C of Cstruct.t 284 | | B of bytes 285 | 286 | val size_of: 'a t -> 'a -> int 287 | (** [size_of t] is the size needed to serialize values of type [t]. *) 288 | 289 | val write: 'a t -> buffer -> pos:int -> 'a -> int 290 | (** [write t] serializes values of type [t]. Use [size_of] to 291 | pre-determine the size of the buffer. *) 292 | 293 | val read: 'a t -> buffer -> pos:int -> int * 'a 294 | (** [read t] reads a serialization of a value of type [t]. *) 295 | 296 | (** {2 JSON converters} *) 297 | 298 | val pp_json: ?minify:bool -> 'a t -> 'a Fmt.t 299 | (** Similar to {!dump} but pretty-prints the JSON representation instead 300 | of the OCaml one. See {!encode_json} for details about the encoding. 301 | 302 | For instance: 303 | 304 | {[ 305 | type t = { foo: int option; bar: string list };; 306 | 307 | let t = 308 | record "r" (fun foo bar -> { foo; bar }) 309 | |+ field "foo" (option int) (fun t -> t.foo) 310 | |+ field "bar" (list string) (fun t -> t.bar) 311 | |> sealr 312 | 313 | let s = Fmt.str "%a\n" (pp t) { foo = None; bar = ["foo"] } 314 | (* s is "{ foo = None; bar = [\"foo\"]; }" *) 315 | 316 | let j = Fmt.str "%a\n" (pp_json t) { foo = None; bar = ["foo"] } 317 | (* j is "{ \"bar\":[\"foo\"] }" *)]} 318 | 319 | {b NOTE:} this will automatically convert JSON fragments to valid 320 | JSON objects by adding an enclosing array if necessary. *) 321 | 322 | val encode_json: 'a t -> Jsonm.encoder -> 'a -> unit 323 | (** [encode_json t e] encodes [t] into the 324 | {{:http://erratique.ch/software/jsonm}jsonm} encoder [e]. The 325 | encoding is a relatively straightforward translation of the OCaml 326 | structure into JSON. The main highlights are: 327 | 328 | {ul 329 | {- OCaml [ints] are translated into JSON floats.} 330 | {- OCaml strings are translated into JSON strings. You must then 331 | ensure that the OCaml strings contains only valid UTF-8 332 | characters.} 333 | {- OCaml record fields of type ['a option] are automatically 334 | unboxed in their JSON representation. If the value if [None], 335 | the field is removed from the JSON object.} 336 | {- variant cases built using {!case0} are represented as strings.} 337 | {- variant cases built using {!case1} are represented as a record 338 | with one field; the field name is the name of the variant.} 339 | ul} 340 | 341 | {b NOTE:} this can be used to encode JSON fragments. That's the 342 | responsibility of the caller to ensure that the encoded JSON 343 | fragment fits properly into a well-formed JSON object. *) 344 | 345 | val decode_json: 'a t -> Jsonm.decoder -> ('a, string) Result.t 346 | (** [decode_json t e] decodes values of type [t] from the 347 | {{:http://erratique.ch/software/jsonm}jsonm} decoder [e]. *) 348 | 349 | val decode_json_lexemes: 'a t -> Jsonm.lexeme list -> ('a, string) Result.t 350 | (** [decode_json_lexemes] is similar to {!decode_json} but use an 351 | already decoded list of JSON lexemes instead of a decoder. *) 352 | 353 | (*--------------------------------------------------------------------------- 354 | Copyright (c) 2016 Thomas Gazagnaire 355 | 356 | Permission to use, copy, modify, and/or distribute this software for any 357 | purpose with or without fee is hereby granted, provided that the above 358 | copyright notice and this permission notice appear in all copies. 359 | 360 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 361 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 362 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 363 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 364 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 365 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 366 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 367 | ---------------------------------------------------------------------------*) 368 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name depyt) 3 | (public_name depyt) 4 | (libraries cstruct fmt jsonm ocplib-endian)) 5 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (libraries alcotest depyt)) 4 | 5 | (alias 6 | (name runtest) 7 | (deps test.exe) 8 | (action 9 | (run %{deps} --color=always))) 10 | 11 | ; (alias 12 | ; ((name runtest) 13 | ; (deps (../README.md (package depyt))) 14 | ; (action (progn 15 | ; (run mdx test ${<}) 16 | ; (diff? ${<} ${<}.corrected))))) 17 | -------------------------------------------------------------------------------- /test/test.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Thomas Gazagnaire. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | open Depyt 8 | 9 | let int_like = like int (fun x -> x) (fun x -> x) 10 | 11 | type r = { foo: int; bar: string list; z: z option } 12 | and z = { x: int; r: r list } 13 | 14 | let r, z = 15 | mu2 (fun r z -> 16 | record "r" (fun foo bar z -> { foo; bar; z }) 17 | |+ field "foo" int (fun t -> t.foo) 18 | |+ field "bar" (list string) (fun t -> t.bar) 19 | |+ field "z" (option z) (fun t -> t.z) 20 | |> sealr, 21 | record "z" (fun x r -> { x; r }) 22 | |+ field "x" int (fun t -> t.x) 23 | |+ field "r" (list r) (fun t -> t.r) 24 | |> sealr 25 | ) 26 | 27 | let r1 = { foo = 3; bar = ["aaa";"b"]; z = None } 28 | let r2 = { foo = 3; bar = ["aaa";"c"]; z = Some { x = 2; r = [r1; r1] } } 29 | 30 | type v = 31 | | Foo 32 | | Bar of int 33 | | Yo of x * v option 34 | 35 | and x = { 36 | r: r; 37 | i: (int * v) list; 38 | } 39 | 40 | let mkv v x = 41 | variant "v" (fun foo bar toto -> function 42 | | Foo -> foo 43 | | Bar x -> bar x 44 | | Yo (x, y) -> toto (x, y)) 45 | |~ case0 "Foo" Foo 46 | |~ case1 "Bar" int_like (fun x -> Bar x) 47 | |~ case1 "Yo" (pair x (option v)) (fun (x, y) -> Yo (x, y)) 48 | |> sealv 49 | 50 | let mkx v = 51 | record "x" (fun r i -> { r; i }) 52 | |+ field "r" r (fun x -> x.r) 53 | |+ field "i" (list (pair int v)) (fun x -> x.i) 54 | |> sealr 55 | 56 | let v, x = mu2 (fun v x -> mkv v x, mkx v) 57 | 58 | let v1 = Foo 59 | let v2 = Bar 0 60 | let v3 = 61 | Yo ({ r = r2; i = [ (1, v1); (2, v2); (3, v2); (4, Bar 3); (5, Bar 6)] }, 62 | Some v2) 63 | 64 | type my_e = Fooe | Bars | Toto | Tata 65 | let e = enum "e" ["Fooe", Fooe; "Bars", Bars; "Toto", Toto; "Tata", Tata] 66 | 67 | type y = [`E of my_e] 68 | let y = like e (fun e -> `E e) (fun (`E e) -> e) 69 | 70 | let e1 = Fooe 71 | let e2 = Bars 72 | let e3 = Toto 73 | let e4 = Tata 74 | 75 | let y1 = `E e1 76 | let y2 = `E e2 77 | 78 | (* FIXME: should go upstream *) 79 | let neg t = 80 | Alcotest.testable (Alcotest.pp t) (fun x y -> not (Alcotest.equal t x y)) 81 | 82 | let test t = Alcotest.testable (dump t) (equal t) 83 | 84 | let test_equal () = 85 | Alcotest.(check @@ test r) __LOC__ r1 r1; 86 | Alcotest.(check @@ test r) __LOC__ r2 r2; 87 | Alcotest.(check @@ test v) __LOC__ v1 v1; 88 | Alcotest.(check @@ test v) __LOC__ v2 v2; 89 | Alcotest.(check @@ test v) __LOC__ v3 v3; 90 | Alcotest.(check @@ neg @@ test r) __LOC__ r1 r2; 91 | Alcotest.(check @@ neg @@ test r) __LOC__ r2 r1; 92 | Alcotest.(check @@ neg @@ test v) __LOC__ v1 v2; 93 | Alcotest.(check @@ neg @@ test v) __LOC__ v2 v3; 94 | Alcotest.(check @@ neg @@ test v) __LOC__ v3 v1; 95 | Alcotest.(check @@ test e) __LOC__ e1 e1; 96 | Alcotest.(check @@ neg @@ test e) __LOC__ e1 e2; 97 | Alcotest.(check @@ neg @@ test e) __LOC__ e1 e3; 98 | Alcotest.(check @@ test y) __LOC__ y1 y1; 99 | Alcotest.(check @@ test y) __LOC__ y2 y2; 100 | Alcotest.(check @@ neg @@ test y) __LOC__ y1 y2 101 | 102 | let test_pp () = 103 | Fmt.pr "PP: %a\n" (dump r) r1; 104 | Fmt.pr "PP: %a\n" (dump r) r2; 105 | Fmt.pr "PP: %a\n" (dump v) v1; 106 | Fmt.pr "PP: %a\n" (dump v) v2; 107 | Fmt.pr "PP: %a\n" (dump v) v3; 108 | Fmt.pr "PP: %a\n" (dump e) e1; 109 | Fmt.pr "PP: %a\n" (dump e) e2; 110 | Fmt.pr "PP: %a\n" (dump e) e3; 111 | Fmt.pr "PP: %a\n" (dump y) y1; 112 | Fmt.pr "PP: %a\n" (dump y) y2 113 | 114 | let test_pp_json () = 115 | Fmt.pr "PP-JSON: %a\n" (pp_json r) r1; 116 | Fmt.pr "PP-JSON: %a\n" (pp_json r) r2; 117 | Fmt.pr "PP-JSON: %a\n" (pp_json v) v1; 118 | Fmt.pr "PP-JSON: %a\n" (pp_json v) v2; 119 | Fmt.pr "PP-JSON: %a\n" (pp_json v) v3; 120 | Fmt.pr "PP-JSON: %a\n" (pp_json e) e1; 121 | Fmt.pr "PP-JSON: %a\n" (pp_json e) e2; 122 | Fmt.pr "PP-JSON: %a\n" (pp_json e) e3; 123 | Fmt.pr "PP-JSON: %a\n" (pp_json e) e4; 124 | Fmt.pr "PP-JSON: %a\n" (pp_json y) y1; 125 | Fmt.pr "PP-JSON: %a\n" (pp_json y) y2 126 | 127 | let test_compare () = 128 | Alcotest.(check int) __LOC__ (compare r r1 r2) ~-1; 129 | Alcotest.(check int) __LOC__ (compare v v1 v2) ~-1; 130 | Alcotest.(check int) __LOC__ (compare v v2 v3) ~-1; 131 | Alcotest.(check int) __LOC__ (compare v v3 v1) 1; 132 | Alcotest.(check int) __LOC__ (compare e e1 e2) ~-1; 133 | Alcotest.(check int) __LOC__ (compare e e2 e3) ~-1; 134 | Alcotest.(check int) __LOC__ (compare e e3 e4) ~-1; 135 | Alcotest.(check int) __LOC__ (compare e e4 e1) 1; 136 | Alcotest.(check int) __LOC__ (compare y y1 y2) ~-1 137 | 138 | let test_bin_write () = 139 | let check t x = 140 | let len = size_of t x in 141 | let buf = C (Cstruct.create len) in 142 | let len'= write t buf ~pos:0 x in 143 | let msg = Fmt.str "%a\n%s" (dump t) x in 144 | Alcotest.(check int) (msg __LOC__) len len' 145 | in 146 | check r r1; 147 | check r r2; 148 | check v v1; 149 | check v v2; 150 | check v v3; 151 | check e e1; 152 | check e e2; 153 | check e e3; 154 | check y y1; 155 | check y y2 156 | 157 | let test_bin_read () = 158 | let check t x = 159 | let len = size_of t x in 160 | let buf = B (Bytes.create len) in 161 | let len' = write t buf ~pos:0 x in 162 | Alcotest.(check int) __LOC__ len len'; 163 | let len', y = read t buf ~pos:0 in 164 | Alcotest.(check int) __LOC__ len len'; 165 | Alcotest.(check @@ test t) __LOC__ x y 166 | in 167 | check r r1; 168 | check r r2; 169 | check v v1; 170 | check v v2; 171 | check v v3; 172 | check e e1; 173 | check e e2; 174 | check e e3; 175 | check y y1; 176 | check y y2 177 | 178 | let test_parse_json () = 179 | let check t x = 180 | (* we wrap the JSON fragment into a list to be sure that `pp_json` 181 | will not try to wrap the result in a list. *) 182 | let str = Fmt.to_to_string (pp_json (list t)) [x] in 183 | match decode_json (list t) (Jsonm.decoder (`String str)) with 184 | | Ok y -> Alcotest.(check @@ list (test t)) __LOC__ [x] y 185 | | Error e -> Alcotest.fail (__LOC__ ^ "\n" ^ e) 186 | in 187 | check r r1; 188 | check r r2; 189 | check v v1; 190 | check v v2; 191 | check v v3; 192 | check e e1; 193 | check e e2; 194 | check e e3; 195 | check y y1; 196 | check y y2 197 | 198 | let () = 199 | Alcotest.run "depyt" [ 200 | "basic", [ 201 | "pp" , `Quick, test_pp; 202 | "pp_json", `Quick, test_pp_json; 203 | "equal" , `Quick, test_equal; 204 | "compare", `Quick, test_compare; 205 | "write" , `Quick, test_bin_write; 206 | "read" , `Quick, test_bin_read; 207 | "json" , `Quick, test_parse_json; 208 | ] 209 | ] 210 | 211 | (*--------------------------------------------------------------------------- 212 | Copyright (c) 2016 Thomas Gazagnaire 213 | 214 | Permission to use, copy, modify, and/or distribute this software for any 215 | purpose with or without fee is hereby granted, provided that the above 216 | copyright notice and this permission notice appear in all copies. 217 | 218 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 219 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 220 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 221 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 222 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 223 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 224 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 225 | ---------------------------------------------------------------------------*) 226 | --------------------------------------------------------------------------------