├── .github └── workflows │ └── main.yml ├── .gitignore ├── CHANGES.md ├── LICENSE.md ├── README.md ├── doc └── api.odocl ├── dune-project ├── records.opam ├── src ├── dune ├── record.ml ├── record.mli └── records.mllib └── test ├── dune ├── example.ml └── tests.ml /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | name: main 2 | 3 | on: 4 | - pull_request 5 | - push 6 | 7 | jobs: 8 | build: 9 | strategy: 10 | fail-fast: false 11 | matrix: 12 | os: 13 | - macos-latest 14 | - ubuntu-latest 15 | - windows-latest 16 | ocaml-compiler: 17 | - 4.08.0 18 | - 4.12.0 19 | runs-on: ${{ matrix.os }} 20 | steps: 21 | - name: Checkout code 22 | uses: actions/checkout@v3 23 | - name: Use OCaml ${{ matrix.ocaml-version }} 24 | uses: ocaml/setup-ocaml@v2 25 | with: 26 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 27 | - run: opam pin add records.dev . --no-action 28 | - run: opam depext records --yes --with-test 29 | - run: opam install . --deps-only --with-test 30 | - run: opam exec -- dune build @all @runtest 31 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.install 2 | *.merlin 3 | *.native 4 | _build 5 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## v1.0.0 2 | 3 | *2023-04-28* 4 | 5 | - Build with Dune >= 2.0. 6 | - Require OCaml >= 4.08. 7 | - Require Yojson >= 1.6 and support Yojson 2.x. 8 | 9 | ## v0.8.0 10 | 11 | *2017-01-03* 12 | 13 | ### Breaking changes 14 | 15 | - Remove `Record.format` (#32) - was previously deprecated. 16 | The alternative is to invoke `yojson` by hand. 17 | 18 | ### Deprecated functions 19 | 20 | - Deprecate `Type.list` and `Type.product_2` (#30). 21 | The alternative is to write converter functions by hand or by using 22 | `ppx_deriving_yojson`. 23 | 24 | ### New features 25 | 26 | - Add `Type.int{32,64}` (#28) 27 | 28 | ### Build system 29 | 30 | - Use docker in Travis (#31) 31 | - Add `descr` file for `topkg opam`. 32 | - Add `org:cryptosense` tag. 33 | - Add merlin configuration (#29). 34 | 35 | ## v0.7.0 36 | 37 | *2016-09-21* 38 | 39 | - Support OCaml 4.04 40 | - Build using topkg: 41 | - Autogenerate API docs 42 | - Build example 43 | - Add `Record.Type.result` for `result` values 44 | - Deprecate `Record.format` 45 | 46 | ## v0.6.0 47 | 48 | *2016-08-01* 49 | 50 | (This release contains breaking changes, indicated by a star) 51 | 52 | - Remove deprecated functions 53 | * `Record.format` now outputs a string based on `Yojson.Safe`. 54 | * Update `of_yojson` function to use `Result` to be compatible with 55 | `ppx_deriving_yojson >= 3.0` (#18). The `of_string` parameter of `make_string` 56 | follows the same convention. 57 | - Compile with debugging information (#17). 58 | - Install library with profiling information (#19). 59 | 60 | ## v0.5.0 61 | 62 | *2016-01-27* 63 | 64 | (This release contains breaking changes, indicated by a star) 65 | 66 | - Install .cmxs, .cmt, .cmti, .mli files (#10) 67 | - Move `declare`, `field`, `seal`, `make`, `layout_name` and 68 | `layout_id` to a `Record.Unsafe` submodule (#9) 69 | - Move `Polid` to `Record.Polid` 70 | - Require ocaml >= 4.02.0 for deprecation warnings 71 | * Target `Yojson.Safe` (#15): 72 | - a compatibility layer is provided in the `Record` module. 73 | - users should migrate to the new functions in the sub modules that are 74 | expressed in terms of `Safe`. The `Basic` interface will go away. 75 | * The `Safe` variant, already in a submodule, switches to `Safe`. 76 | 77 | ## v0.4.0 78 | 79 | *2016-01-04* 80 | 81 | - Make the type of 'content' abstract (#7) 82 | - Add a Safe sub-module for type-safe creation of layouts (#8), 83 | thanks Jeremy Yallop! 84 | 85 | ## v0.3.1 86 | 87 | *2015-12-01* 88 | 89 | - Compile with `-safe-string` (#6) 90 | - Add a bytecode-only target 91 | 92 | ## v0.3.0 93 | 94 | *2015-08-31* 95 | 96 | - Delete embedded .travis-opam.sh (#2) 97 | - Add `Record.declare0` (#4) 98 | - Add `Type.view` (#5) 99 | 100 | ## v0.2.0 101 | 102 | *2015-08-17* 103 | 104 | - Sort OPAM fields 105 | - Add ocaml-version bound 106 | - Support OCaml 4.00 107 | - Bisect is not necessary to run the test suite 108 | - Add `Record.declare{1,2,3,4}` to build fixed-size layouts 109 | - Add `Record.layout_type` to use layout as types 110 | - Add 'yojson' dependency to the META file (#3), thanks Jeremy Yallop! 111 | 112 | ## v0.1.0 113 | 114 | *2015-08-03* 115 | 116 | - Initial release 117 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014-2015, Cryptosense SA 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 | 1. Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | 2. Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 15 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 16 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 17 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 18 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 20 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 21 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 22 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 23 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 24 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Dynamic records 2 | 3 | [![Build Status][build_status_badge]][build_status_link] 4 | 5 | This library enables you to define and manipulate dynamic records in OCaml. 6 | 7 | ## Example 8 | 9 | Let us define a "point" record with three integer fields: x, y and z. 10 | 11 | First, declare a new record layout. 12 | 13 | ```ocaml 14 | module Point = (val Record.Safe.declare "point") 15 | ``` 16 | 17 | Second, define the fields. They have the type `(int, Point.s) field` 18 | (`Point.s` is a phantom type that guarantees type safety). 19 | 20 | ```ocaml 21 | let x = Point.field "x" Record.Type.int 22 | let y = Point.field "y" Record.Type.int 23 | let z = Point.field "z" Record.Type.int 24 | ``` 25 | 26 | Third, "seal" this record structure. This prevents it from being further modified. 27 | Structures must be sealed before they can be used. 28 | 29 | ```ocaml 30 | let () = Point.seal () 31 | ``` 32 | 33 | At this point, you have a working record structure. The next step is to create 34 | actual records. They have the type `Point.s Record.t` and are created using 35 | `Point.make`. Initially their fields have no value. 36 | 37 | ```ocaml 38 | let _ = 39 | let p = Point.make () in 40 | Record.set p x 3; 41 | Record.set p y 4; 42 | Record.set p z 5; 43 | Record.format Format.std_formatter p 44 | ``` 45 | 46 | The last line outputs: 47 | 48 | ```json 49 | {"x":3,"y":4,"z":5} 50 | ``` 51 | 52 | ## Licensing 53 | 54 | This library is available under the 2-clause BSD license. 55 | See `COPYING` for more information. 56 | 57 | [build_status_badge]: https://github.com/cryptosense/records/actions/workflows/main.yml/badge.svg 58 | [build_status_link]: https://github.com/cryptosense/records/actions/workflows/main.yml 59 | -------------------------------------------------------------------------------- /doc/api.odocl: -------------------------------------------------------------------------------- 1 | Record 2 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.0) 2 | -------------------------------------------------------------------------------- /records.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Cryptosense " 3 | authors: [ 4 | "Cryptosense " 5 | "Etienne Millon " 6 | ] 7 | homepage: "https://github.com/cryptosense/records" 8 | bug-reports: "https://github.com/cryptosense/records/issues" 9 | license: "BSD-2-Clause" 10 | dev-repo: "git+https://github.com/cryptosense/records.git" 11 | doc: "https://cryptosense.github.io/records/doc" 12 | build: [ 13 | ["dune" "build" "-p" name "-j" jobs] 14 | ] 15 | run-test: [ 16 | ["dune" "runtest" "-p" name "-j" jobs] 17 | ] 18 | depends: [ 19 | "dune" {>= "2.0"} 20 | "ocaml" {>= "4.08.0"} 21 | "ounit" {with-test & >= "2.0.0"} 22 | "yojson" {>= "1.6.0"} 23 | ] 24 | tags: ["org:cryptosense"] 25 | synopsis: "Dynamic records" 26 | description: """ 27 | This library enables you to define and manipulate dynamic records in OCaml. 28 | """ 29 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name records) 3 | (wrapped false) 4 | (libraries 5 | yojson 6 | ) 7 | ) 8 | -------------------------------------------------------------------------------- /src/record.ml: -------------------------------------------------------------------------------- 1 | open Result 2 | 3 | module Json_safe = struct 4 | let (>>=) x f = 5 | match x with 6 | | Error _ as e -> e 7 | | Ok y -> f y 8 | 9 | let (>>|) x f = 10 | x >>= fun y -> Ok (f y) 11 | 12 | let rec mapM_ f = function 13 | | [] -> Ok () 14 | | x::xs -> 15 | f x >>= fun () -> 16 | mapM_ f xs 17 | 18 | let rec assoc_option key = function 19 | | [] -> None 20 | | (k, v)::_ when k = key -> Some v 21 | | _::l -> assoc_option key l 22 | 23 | let member key = function 24 | | `Assoc kvs -> 25 | begin 26 | match assoc_option key kvs with 27 | | Some j -> Ok j 28 | | None -> Error (Printf.sprintf "Key not found: %s" key) 29 | end 30 | | _ -> Error "Not a JSON object" 31 | 32 | end 33 | 34 | module Type = struct 35 | type 'a t = 36 | { name: string; 37 | to_yojson: ('a -> Yojson.Safe.t); 38 | of_yojson: (Yojson.Safe.t -> ('a, string) result); 39 | } 40 | 41 | let name t = t.name 42 | let of_yojson t = t.of_yojson 43 | let to_yojson t = t.to_yojson 44 | 45 | let make ~name ~to_yojson ~of_yojson () = 46 | { 47 | name; 48 | to_yojson; 49 | of_yojson; 50 | } 51 | 52 | let make_string ~name ~to_string ~of_string () = 53 | let to_yojson x = `String (to_string x) in 54 | let of_yojson = function 55 | | `String s -> of_string s 56 | | _ -> Error (Printf.sprintf "(while parsing %s) not a string" name) 57 | in 58 | make ~name ~to_yojson ~of_yojson () 59 | 60 | exception UnserializedException of string 61 | 62 | let exn = 63 | let to_string x = Printexc.to_string x in 64 | let of_string x = Ok (UnserializedException x) 65 | in 66 | make_string ~name:"exn" ~to_string ~of_string () 67 | 68 | let result ta tb = 69 | let open Json_safe in 70 | let to_yojson = function 71 | | Ok x -> `Assoc ["Ok", ta.to_yojson x] 72 | | Error x -> `Assoc ["Error", tb.to_yojson x] 73 | in 74 | let of_yojson = 75 | function 76 | | `Assoc ["Ok", x] -> 77 | ta.of_yojson x >>| fun y -> 78 | Ok y 79 | | `Assoc ["Error", x] -> 80 | tb.of_yojson x >>| fun y -> 81 | Error y 82 | | _ -> Error "result_of_json" 83 | in 84 | make 85 | ~name: (Printf.sprintf "(%s,%s) Result.t" ta.name tb.name ) 86 | ~to_yojson 87 | ~of_yojson 88 | () 89 | 90 | let unit = 91 | make 92 | ~name: "unit" 93 | ~to_yojson: (fun () -> `Null) 94 | ~of_yojson: (fun _ -> Ok ()) 95 | () 96 | 97 | let string = 98 | let of_yojson = function 99 | | `String s -> Ok s 100 | | _ -> Error "Not a JSON string" 101 | in 102 | make 103 | ~name:"string" 104 | ~to_yojson: (fun s -> `String s) 105 | ~of_yojson 106 | () 107 | 108 | let int = 109 | let of_yojson = function 110 | | `Int s -> Ok s 111 | | _ -> Error "Not a JSON int" 112 | in 113 | make 114 | ~name:"int" 115 | ~to_yojson: (fun s -> `Int s) 116 | ~of_yojson 117 | () 118 | 119 | let int32 = 120 | let of_yojson = function 121 | | `Int x -> Ok (Int32.of_int x) 122 | | `Intlit x -> Ok (Int32.of_string x) 123 | | _ -> Error "int32.of_yojson" 124 | in 125 | let to_yojson n = `Intlit (Int32.to_string n) in 126 | make 127 | ~name:"int32" 128 | ~to_yojson 129 | ~of_yojson 130 | () 131 | 132 | let int64 = 133 | let of_yojson = function 134 | | `Int x -> Ok (Int64.of_int x) 135 | | `Intlit x -> Ok (Int64.of_string x) 136 | | _ -> Error "int32.of_yojson" 137 | in 138 | let to_yojson n = `Intlit (Int64.to_string n) in 139 | make 140 | ~name:"int64" 141 | ~to_yojson 142 | ~of_yojson 143 | () 144 | 145 | let view ~name ~read ~write typ = 146 | let to_yojson b = 147 | typ.to_yojson (write b) 148 | in 149 | let of_yojson bj = 150 | let open Json_safe in 151 | (typ.of_yojson bj) >>= read 152 | in 153 | make ~name ~to_yojson ~of_yojson () 154 | end 155 | 156 | module Polid = struct 157 | type 'a t = int 158 | 159 | let fresh = 160 | let counter = ref (-1) in 161 | fun () -> 162 | incr counter; 163 | !counter 164 | 165 | type (_, _) equal = 166 | | Equal: ('a, 'a) equal 167 | | Different: ('a, 'b) equal 168 | 169 | let equal (type a) (type b) (a: a t) (b: b t): (a, b) equal = 170 | if a = b then 171 | (Obj.magic (Equal: (a, a) equal): (a, b) equal) 172 | else 173 | Different 174 | 175 | let to_int x = 176 | x 177 | 178 | let is_equal (type a) (type b) (a: a t) (b: b t): bool = 179 | a = b 180 | end 181 | 182 | module Field = struct 183 | type ('a, 's) t = 184 | { 185 | polid: 'a Polid.t; 186 | fname: string; 187 | ftype: 'a Type.t; 188 | foffset: int; 189 | } 190 | 191 | let name field = 192 | field.fname 193 | 194 | let ftype field = 195 | field.ftype 196 | end 197 | 198 | type 's layout = 199 | { 200 | name: string; 201 | uid: 's Polid.t; 202 | mutable fields: 's boxed_field list; 203 | mutable sealed: bool 204 | } 205 | 206 | and _ boxed_field = BoxedField: ('a,'s) Field.t -> 's boxed_field 207 | 208 | type 'a t = 209 | { 210 | layout: 'a layout; 211 | content: 'a content; 212 | } 213 | and 'a content 214 | 215 | let equal (type a) (type b) (a: a layout) (b: b layout): (a, b) Polid.equal = 216 | Polid.equal a.uid b.uid 217 | 218 | exception ModifyingSealedStruct of string 219 | 220 | exception AllocatingUnsealedStruct of string 221 | 222 | (* The [dummy] is a place holder for t fields. We use it 223 | instead of boxing each value in an option. If the user accesses a 224 | field that contains this dummy value, we raise an exception (the 225 | field was not initialized.). This avoid an extra layer of boxing 226 | w.r.t. to the solution in which each field is an option. *) 227 | let dummy = Obj.repr (ref ()) 228 | 229 | let field_safe (type s) (type a) (layout: s layout) label (ty : a Type.t): 230 | (a,s) Field.t = 231 | if layout.sealed 232 | then raise (ModifyingSealedStruct layout.name); 233 | 234 | let foffset = List.length layout.fields in 235 | let field = 236 | let open Field in 237 | { 238 | polid = Polid.fresh (); 239 | fname = label; 240 | ftype = ty; 241 | foffset; 242 | } 243 | in 244 | layout.fields <- BoxedField field :: layout.fields; 245 | field 246 | 247 | module Unsafe = struct 248 | let declare (type s) name : s layout = 249 | { 250 | name; 251 | uid = Polid.fresh (); 252 | fields = []; 253 | sealed = false; 254 | } 255 | 256 | let seal (type s) (layout: s layout) : unit = 257 | if layout.sealed 258 | then raise (ModifyingSealedStruct layout.name); 259 | 260 | layout.fields <- List.rev layout.fields; 261 | layout.sealed <- true; 262 | () 263 | 264 | let field (type s) (type a) (layout: s layout) label (ty : a Type.t): 265 | (a,s) Field.t = 266 | field_safe layout label ty 267 | 268 | let make (type s) : s layout -> s t = 269 | fun (layout: s layout) -> 270 | if not layout.sealed 271 | then raise (AllocatingUnsealedStruct layout.name); 272 | 273 | let size = List.length layout.fields in 274 | let obj = Obj.new_block 0 size in 275 | for i = 0 to size - 1 do 276 | Obj.set_field obj i dummy; 277 | done; 278 | {layout; 279 | content = Obj.obj obj} 280 | 281 | let layout_name layout = layout.name 282 | 283 | let layout_id t = t.uid 284 | end 285 | 286 | exception UndefinedField of string 287 | 288 | let get_layout t = t.layout 289 | 290 | let get record field = 291 | let open Field in 292 | let f = Obj.field (Obj.repr record.content) field.foffset in 293 | if f == dummy 294 | then raise (UndefinedField (field.fname)); 295 | Obj.obj f 296 | 297 | let set record field value = 298 | let open Field in 299 | Obj.set_field (Obj.repr record.content) field.foffset 300 | (Obj.repr value) 301 | 302 | (* There are three ways to handle fields that are not set: raise an 303 | error, map them to `Null, or skip the field. If some fields might 304 | not be set, we should use the 2nd or the 3rd. Maybe this kind of 305 | behavior could be set at field creation time? *) 306 | let to_yojson (type s) (s : s t) : Yojson.Safe.t = 307 | let fields = 308 | List.map 309 | (fun (BoxedField f) -> 310 | let value = 311 | try 312 | (Field.ftype f).Type.to_yojson (get s f) 313 | with UndefinedField _ -> 314 | `Null 315 | in 316 | Field.name f, value) 317 | s.layout.fields 318 | in 319 | `Assoc fields 320 | 321 | (* todo: the error handling here is plain wrong. Should do something 322 | special in the `Null case. *) 323 | let of_yojson (type s) (s: s layout) (json: Yojson.Safe.t) : (s t, string) result = 324 | let open Json_safe in 325 | let r = Unsafe.make s in 326 | let field_value (BoxedField f) = 327 | let open Type in 328 | let key = Field.name f in 329 | let typ = Field.ftype f in 330 | member key json >>= fun m -> 331 | typ.of_yojson m >>| fun v -> 332 | set r f v 333 | in 334 | Json_safe.mapM_ field_value s.fields >>| fun () -> 335 | r 336 | 337 | module Util = struct 338 | let layout_type layout = 339 | let name = Unsafe.layout_name layout in 340 | let of_yojson = of_yojson layout in 341 | Type.make 342 | ~name 343 | ~to_yojson 344 | ~of_yojson 345 | () 346 | 347 | let declare0 ~name = 348 | let layout = Unsafe.declare name in 349 | Unsafe.seal layout; 350 | layout 351 | 352 | let declare1 ~name ~f1_name ~f1_type = 353 | let layout = Unsafe.declare name in 354 | let f1 = field_safe layout f1_name f1_type in 355 | Unsafe.seal layout; 356 | (layout, f1) 357 | 358 | let declare2 ~name ~f1_name ~f1_type ~f2_name ~f2_type = 359 | let layout = Unsafe.declare name in 360 | let f1 = field_safe layout f1_name f1_type in 361 | let f2 = field_safe layout f2_name f2_type in 362 | Unsafe.seal layout; 363 | (layout, f1, f2) 364 | 365 | let declare3 ~name ~f1_name ~f1_type ~f2_name ~f2_type 366 | ~f3_name ~f3_type = 367 | let layout = Unsafe.declare name in 368 | let f1 = field_safe layout f1_name f1_type in 369 | let f2 = field_safe layout f2_name f2_type in 370 | let f3 = field_safe layout f3_name f3_type in 371 | Unsafe.seal layout; 372 | (layout, f1, f2, f3) 373 | 374 | let declare4 ~name ~f1_name ~f1_type ~f2_name ~f2_type 375 | ~f3_name ~f3_type ~f4_name ~f4_type = 376 | let layout = Unsafe.declare name in 377 | let f1 = field_safe layout f1_name f1_type in 378 | let f2 = field_safe layout f2_name f2_type in 379 | let f3 = field_safe layout f3_name f3_type in 380 | let f4 = field_safe layout f4_name f4_type in 381 | Unsafe.seal layout; 382 | (layout, f1, f2, f3, f4) 383 | end 384 | 385 | module Safe = 386 | struct 387 | module type LAYOUT = 388 | sig 389 | type s 390 | val layout : s layout 391 | val field : string -> 'a Type.t -> ('a, s) Field.t 392 | val seal : unit -> unit 393 | val layout_name : string 394 | val layout_id : s Polid.t 395 | val make : unit -> s t 396 | end 397 | 398 | module Declare(X: sig val name : string end) : LAYOUT = 399 | struct 400 | type s 401 | let layout = Unsafe.declare X.name 402 | let field n t = field_safe layout n t 403 | let seal () = Unsafe.seal layout 404 | let layout_name = layout.name 405 | let layout_id = layout.uid 406 | let make () = Unsafe.make layout 407 | end 408 | 409 | let declare : string -> (module LAYOUT) = 410 | fun name -> (module (Declare (struct let name = name end))) 411 | end 412 | -------------------------------------------------------------------------------- /src/record.mli: -------------------------------------------------------------------------------- 1 | (** Dynamic records *) 2 | 3 | (** {2 Layouts} *) 4 | 5 | (** The representation of record types. ['s] is usually a phantom type. 6 | Two interfaces are provided for creating layouts, in [Unsafe] and [Safe]. 7 | *) 8 | type 's layout 9 | 10 | (** Raised by [field] or [seal] if layout has already been sealed. *) 11 | exception ModifyingSealedStruct of string 12 | 13 | (** {2 Records} *) 14 | 15 | (** The representation of record values. *) 16 | type 's t = 17 | { 18 | layout: 's layout; 19 | content: 's content; 20 | } 21 | and 's content 22 | 23 | (** Get the layout of a record. *) 24 | val get_layout : 'a t -> 'a layout 25 | 26 | (** Raised by [make] when the corresponding layout has not been sealed. *) 27 | exception AllocatingUnsealedStruct of string 28 | 29 | (** {3 Type converters} *) 30 | module Type : sig 31 | (** 32 | How to convert a type to and from JSON. 33 | *) 34 | type 'a t 35 | 36 | val name : 'a t -> string 37 | val of_yojson : 'a t -> (Yojson.Safe.t -> ('a, string) Result.t) 38 | val to_yojson : 'a t -> ('a -> Yojson.Safe.t) 39 | 40 | (** Declare a new type. *) 41 | val make: 42 | name: string -> 43 | to_yojson: ('a -> Yojson.Safe.t) -> 44 | of_yojson: (Yojson.Safe.t -> ('a, string) Result.t) -> 45 | unit -> 'a t 46 | 47 | (** Declare a new type that marshal/unmarshal to strings. *) 48 | val make_string: 49 | name: string -> 50 | to_string: ('a -> string) -> 51 | of_string: (string -> ('a, string) Result.t) -> 52 | unit -> 'a t 53 | 54 | (** How to represent exceptions. *) 55 | val exn: exn t 56 | 57 | (** Raised by [exn.of_json] *) 58 | exception UnserializedException of string 59 | 60 | (** How to represent [unit]. *) 61 | val unit: unit t 62 | 63 | (** How to represent [string]. *) 64 | val string: string t 65 | 66 | (** How to represent [int]. *) 67 | val int: int t 68 | 69 | (** How to represent [int32]. *) 70 | val int32: int32 t 71 | 72 | (** How to represent [int64]. *) 73 | val int64: int64 t 74 | 75 | (** Build a representation of a [result]. *) 76 | val result : 'a t -> 'b t -> ('a, 'b) Result.t t 77 | 78 | (** Build a ['b] type which has the same JSON encoding as the ['a] type from 79 | conversion functions [read] and [write]. *) 80 | val view : 81 | name:string -> 82 | read:('a -> ('b, string) Result.t) -> 83 | write:('b -> 'a) -> 84 | 'a t -> 85 | 'b t 86 | end 87 | 88 | module Field : sig 89 | (** A field of type ['a] within a ['s layout]. *) 90 | type ('a,'s) t 91 | 92 | (** Get the name of the field (as passed to [field]). *) 93 | val name : ('a, 's) t -> string 94 | 95 | (** Get the type of the field (as passed to [field]). *) 96 | val ftype : ('a, 's) t -> 'a Type.t 97 | end 98 | 99 | (** Get the value of a field. *) 100 | val get: 's t -> ('a,'s) Field.t -> 'a 101 | 102 | (** Set the value of a field. *) 103 | val set: 's t -> ('a,'s) Field.t -> 'a -> unit 104 | 105 | (** Raised by [get] if the field was not set. *) 106 | exception UndefinedField of string 107 | 108 | module Polid : sig 109 | (** The type of identifiers associated to type ['a]. *) 110 | type 'a t 111 | 112 | (** Make a new, fresh identifier. 113 | This is the only way to obtain a value of type [t]. *) 114 | val fresh: unit -> 'a t 115 | 116 | (** Type constraint which is conditioned on identifier equality. *) 117 | type ('a, 'b) equal = 118 | | Equal: ('a, 'a) equal 119 | | Different: ('a, 'b) equal 120 | 121 | (** Equality predicate. *) 122 | val equal: 'a t -> 'b t -> ('a, 'b) equal 123 | 124 | (** Convert an identifier to an integer. 125 | The integer is guaranteed to be unique for each call to {!fresh}. *) 126 | val to_int: 'a t -> int 127 | 128 | (** [equal] projected to a plain [bool]. *) 129 | val is_equal: 'a t -> 'b t -> bool 130 | end 131 | 132 | (** {3 Unsafe interface} *) 133 | module Unsafe : sig 134 | (** The [Unsafe.declare] function returns a ['s layout], which is only safe 135 | when ['s] is only instanciated once in this context. 136 | 137 | @see for discussion 138 | *) 139 | 140 | (** Create a new layout with the given name. *) 141 | val declare : string -> 's layout 142 | 143 | (** Add a field to a layout. This modifies the layout and returns the field. *) 144 | val field: 's layout -> string -> 'a Type.t -> ('a,'s) Field.t 145 | 146 | (** Make the layout unmodifiable. It is necessary before constructing values. *) 147 | val seal : 's layout -> unit 148 | 149 | (** Allocate a record of a given layout, with all fields initially unset. *) 150 | val make: 's layout -> 's t 151 | 152 | (** Get the name that was given to a layout. *) 153 | val layout_name : 's layout -> string 154 | 155 | (** Get the unique identifier given to a layout. *) 156 | val layout_id: 's layout -> 's Polid.t 157 | end 158 | 159 | (** {3 Safe interface} *) 160 | module Safe : 161 | sig 162 | (** 163 | This interface is similar to [Unsafe] except that the phantom type normally 164 | passed to [declare] is generated by a functor. This has the other advantage 165 | of making the [layout] argument implicit in the output module. 166 | *) 167 | 168 | module type LAYOUT = 169 | sig 170 | type s 171 | 172 | (** A value representing the layout. *) 173 | val layout : s layout 174 | 175 | (** Add a field to the layout. This modifies the layout and returns the field. *) 176 | val field : string -> 'a Type.t -> ('a, s) Field.t 177 | 178 | (** Make the layout unmodifiable. It is necessary before constructing values. *) 179 | val seal : unit -> unit 180 | 181 | (** The name that was given to the layout. *) 182 | val layout_name : string 183 | 184 | (** The unique identifier given to a layout. *) 185 | val layout_id : s Polid.t 186 | 187 | (** Allocate a record of the layout, with all fields initially unset. *) 188 | val make : unit -> s t 189 | end 190 | 191 | (** Create a new layout with the given name. *) 192 | val declare : string -> (module LAYOUT) 193 | end 194 | 195 | (** {2 Miscellaneous} *) 196 | 197 | (** Convert a record to JSON. *) 198 | val to_yojson: 'a t -> Yojson.Safe.t 199 | 200 | (** Convert a JSON value into a given schema. *) 201 | val of_yojson: 'a layout -> Yojson.Safe.t -> ('a t, string) Result.t 202 | 203 | module Util : sig 204 | (** Get the [Type.t] representation of a layout. *) 205 | val layout_type : 'a layout -> 'a t Type.t 206 | 207 | (** Shortcut to build a layout with no fields. *) 208 | val declare0 : name:string -> 's layout 209 | 210 | (** Shortcut to build a layout with 1 field. *) 211 | val declare1 : name:string 212 | -> f1_name:string 213 | -> f1_type:'a Type.t 214 | -> ('s layout * ('a, 's) Field.t) 215 | 216 | (** Shortcut to build a layout with 2 fields. *) 217 | val declare2 : name:string 218 | -> f1_name:string 219 | -> f1_type:'a1 Type.t 220 | -> f2_name:string 221 | -> f2_type:'a2 Type.t 222 | -> ('s layout * ('a1, 's) Field.t * ('a2, 's) Field.t) 223 | 224 | (** Shortcut to build a layout with 3 fields. *) 225 | val declare3 : name:string 226 | -> f1_name:string 227 | -> f1_type:'a1 Type.t 228 | -> f2_name:string 229 | -> f2_type:'a2 Type.t 230 | -> f3_name:string 231 | -> f3_type:'a3 Type.t 232 | -> ('s layout * ('a1, 's) Field.t * ('a2, 's) Field.t 233 | * ('a3, 's) Field.t) 234 | 235 | (** Shortcut to build a layout with 4 fields. *) 236 | val declare4 : name:string 237 | -> f1_name:string 238 | -> f1_type:'a1 Type.t 239 | -> f2_name:string 240 | -> f2_type:'a2 Type.t 241 | -> f3_name:string 242 | -> f3_type:'a3 Type.t 243 | -> f4_name:string 244 | -> f4_type:'a4 Type.t 245 | -> ('s layout * ('a1, 's) Field.t * ('a2, 's) Field.t 246 | * ('a3, 's) Field.t * ('a4, 's) Field.t) 247 | end 248 | 249 | (** Equality predicate. *) 250 | val equal: 'a layout -> 'b layout -> ('a, 'b) Polid.equal 251 | -------------------------------------------------------------------------------- /src/records.mllib: -------------------------------------------------------------------------------- 1 | Record 2 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name tests) 3 | (libraries 4 | oUnit 5 | records 6 | ) 7 | ) 8 | -------------------------------------------------------------------------------- /test/example.ml: -------------------------------------------------------------------------------- 1 | type point 2 | let point : point Record.layout = Record.Unsafe.declare "point" 3 | 4 | let x = Record.Unsafe.field point "x" Record.Type.int 5 | let y = Record.Unsafe.field point "y" Record.Type.int 6 | let z = Record.Unsafe.field point "z" Record.Type.int 7 | 8 | let () = Record.Unsafe.seal point 9 | 10 | let _ = 11 | let p = Record.Unsafe.make point in 12 | Record.set p x 3; 13 | Record.set p y 4; 14 | Record.set p z 5; 15 | Yojson.Safe.to_channel stdout @@ Record.to_yojson p 16 | -------------------------------------------------------------------------------- /test/tests.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | open Result 3 | 4 | type r 5 | let rt : r Record.layout = Record.Unsafe.declare "r" 6 | let x = Record.Unsafe.field rt "x" Record.Type.int 7 | let () = Record.Unsafe.seal rt 8 | 9 | module Safe_layouts = 10 | struct 11 | module Rt = (val Record.Safe.declare "r") 12 | let x = Rt.field "x" Record.Type.int 13 | let () = Rt.seal () 14 | 15 | module Rres = (val Record.Safe.declare "rr") 16 | let value_r1 = Rres.field "r1" (Record.Type.result Record.Type.int Record.Type.string) 17 | let value_r2 = Rres.field "r2" (Record.Type.result Record.Type.int Record.Type.string) 18 | let () = Rres.seal () 19 | end 20 | 21 | let set_get _ctxt = 22 | let r = Record.Unsafe.make rt in 23 | Record.set r x 2; 24 | assert_equal 2 (Record.get r x) 25 | 26 | let safe_set_get _ctxt = 27 | let open Safe_layouts in 28 | let r = Rt.make () in 29 | Record.set r x 2; 30 | assert_equal 2 (Record.get r x) 31 | 32 | let get_undef _ctxt = 33 | let r = Record.Unsafe.make rt in 34 | let e = Record.UndefinedField "x" in 35 | assert_raises e (fun () -> 36 | Record.get r x 37 | ) 38 | 39 | let safe_get_undef _ctxt = 40 | let open Safe_layouts in 41 | let r = Rt.make () in 42 | let e = Record.UndefinedField "x" in 43 | assert_raises e (fun () -> 44 | Record.get r x 45 | ) 46 | 47 | let extend_after_seal _ctxt = 48 | let e = Record.ModifyingSealedStruct "r" in 49 | assert_raises e (fun () -> 50 | Record.Unsafe.field rt "y" Record.Type.int 51 | ) 52 | 53 | let safe_extend_after_seal _ctxt = 54 | let open Safe_layouts in 55 | let e = Record.ModifyingSealedStruct "r" in 56 | assert_raises e (fun () -> 57 | Record.Unsafe.field Rt.layout "y" Record.Type.int 58 | ) 59 | 60 | let seal_twice _ctxt = 61 | let e = Record.ModifyingSealedStruct "r" in 62 | assert_raises e (fun () -> 63 | Record.Unsafe.seal rt 64 | ) 65 | 66 | let safe_seal_twice _ctxt = 67 | let open Safe_layouts in 68 | let e = Record.ModifyingSealedStruct "r" in 69 | assert_raises e (fun () -> 70 | Record.Unsafe.seal Rt.layout 71 | ) 72 | 73 | let make_unsealed _ctxt (type r2) = 74 | let rt2 : r2 Record.layout = Record.Unsafe.declare "r2" in 75 | let _x2 = Record.Unsafe.field rt2 "x2" Record.Type.int in 76 | let e = Record.AllocatingUnsealedStruct "r2" in 77 | assert_raises e (fun () -> 78 | Record.Unsafe.make rt2 79 | ) 80 | 81 | let safe_make_unsealed _ctxt = 82 | let module Rt2 = (val Record.Safe.declare "r2") in 83 | let _x2 = Rt2.field "x2" Record.Type.int in 84 | let e = Record.AllocatingUnsealedStruct "r2" in 85 | assert_raises e (fun () -> 86 | Rt2.make () 87 | ) 88 | 89 | let layout_name _ctxt = 90 | assert_equal "r" (Record.Unsafe.layout_name rt) 91 | 92 | let safe_layout_name _ctxt = 93 | assert_equal "r" Safe_layouts.Rt.layout_name 94 | 95 | let layout_id _ctxt = 96 | let id1 = Record.Unsafe.layout_id rt in 97 | let id2 = Record.Unsafe.layout_id rt in 98 | let id3 = Record.Polid.fresh () in 99 | assert_bool "layout_id is pure" (Record.Polid.equal id1 id2 = Record.Polid.Equal); 100 | assert_equal ~msg:"layout_id is pure (int)" (Record.Polid.to_int id1) (Record.Polid.to_int id2); 101 | assert_bool "fresh returns a different id" (Record.Polid.equal id1 id3 = Record.Polid.Different) 102 | 103 | let safe_layout_id _ctxt = 104 | let open Safe_layouts in 105 | let id1 = Rt.layout_id in 106 | let id2 = Record.Polid.fresh () in 107 | assert_bool "fresh returns a different id" (Record.Polid.equal id1 id2 = Record.Polid.Different) 108 | 109 | let field_name _ctxt = 110 | assert_equal "x" (Record.Field.name x) 111 | 112 | let safe_field_name _ctxt = 113 | assert_equal "x" (Record.Field.name Safe_layouts.x) 114 | 115 | let field_type _ctxt = 116 | assert_equal "int" (Record.Type.name (Record.Field.ftype x)) 117 | 118 | let safe_field_type _ctxt = 119 | assert_equal "int" (Record.Type.name (Record.Field.ftype Safe_layouts.x)) 120 | 121 | let record_layout _ctxt = 122 | let r = Record.Unsafe.make rt in 123 | let l = Record.get_layout r in 124 | assert_bool "layout is the same" 125 | (Record.Polid.is_equal 126 | (Record.Unsafe.layout_id l) 127 | (Record.Unsafe.layout_id rt) 128 | ) 129 | 130 | let safe_record_layout _ctxt = 131 | let open Safe_layouts in 132 | let r = Rt.make () in 133 | let l = Record.get_layout r in 134 | assert_bool "layout is the same" 135 | (Record.Polid.is_equal 136 | (Record.Unsafe.layout_id l) 137 | Rt.layout_id 138 | ) 139 | 140 | let force = function 141 | | Ok x -> x 142 | | Error _ -> assert false 143 | 144 | let of_json _ctxt = 145 | let j = `Assoc [("x", `Int 2)] in 146 | let r = force @@ Record.of_yojson rt j in 147 | assert_equal 2 (Record.get r x) 148 | 149 | let safe_of_json _ctxt = 150 | let j = `Assoc [("x", `Int 2)] in 151 | let r = force @@ Record.of_yojson Safe_layouts.Rt.layout j in 152 | assert_equal 2 (Record.get r Safe_layouts.x) 153 | 154 | let to_json _ctxt = 155 | let r = Record.Unsafe.make rt in 156 | Record.set r x 2; 157 | let expected = `Assoc [("x", `Int 2)] in 158 | let printer = Yojson.Safe.pretty_to_string in 159 | assert_equal ~printer expected (Record.to_yojson r) 160 | 161 | let safe_to_json _ctxt = 162 | let open Safe_layouts in 163 | let r = Rt.make () in 164 | Record.set r x 2; 165 | let expected = `Assoc [("x", `Int 2)] in 166 | let printer = Yojson.Safe.pretty_to_string in 167 | assert_equal ~printer expected (Record.to_yojson r) 168 | 169 | let to_json_null _ctxt = 170 | let r = Record.Unsafe.make rt in 171 | let expected = `Assoc [("x", `Null)] in 172 | let printer = Yojson.Safe.pretty_to_string in 173 | assert_equal ~printer expected (Record.to_yojson r) 174 | 175 | let safe_to_json_null _ctxt = 176 | let open Safe_layouts in 177 | let r = Rt.make () in 178 | let expected = `Assoc [("x", `Null)] in 179 | let printer = Yojson.Safe.pretty_to_string in 180 | assert_equal ~printer expected (Record.to_yojson r) 181 | 182 | let safe_json_result _ctxt = 183 | let open Safe_layouts in 184 | let r = Rres.make () in 185 | Record.set r value_r1 (Ok 35); 186 | Record.set r value_r2 (Error "no"); 187 | let json = 188 | `Assoc 189 | [ "r1", `Assoc ["Ok", `Int 35] 190 | ; "r2", `Assoc ["Error", `String "no"] 191 | ] 192 | in 193 | let printer = Yojson.Safe.pretty_to_string in 194 | assert_equal ~printer json (Record.to_yojson r); 195 | let recovered_1 = force @@ Record.of_yojson Rres.layout json in 196 | assert_equal (Ok 35) (Record.get recovered_1 value_r1); 197 | let recovered_2 = force @@ Record.of_yojson Rres.layout json in 198 | assert_equal (Error "no") (Record.get recovered_2 value_r2) 199 | 200 | let declare0 _ctxt = 201 | let l = Record.Util.declare0 ~name:"r" in 202 | assert_equal "r" (Record.Unsafe.layout_name l) 203 | 204 | let declare1 _ctxt = 205 | let (l, f) = Record.Util.declare1 ~name:"r" ~f1_name:"x" ~f1_type:Record.Type.int in 206 | assert_equal "r" (Record.Unsafe.layout_name l); 207 | assert_equal "x" (Record.Field.name f) 208 | 209 | let declare2 _ctxt = 210 | let (l, f1, f2) = 211 | Record.Util.declare2 ~name:"r" 212 | ~f1_name:"f1" ~f1_type:Record.Type.int 213 | ~f2_name:"f2" ~f2_type:Record.Type.int 214 | in 215 | assert_equal "r" (Record.Unsafe.layout_name l); 216 | assert_equal "f1" (Record.Field.name f1); 217 | assert_equal "f2" (Record.Field.name f2) 218 | 219 | let declare3 _ctxt = 220 | let (l, f1, f2, f3) = 221 | Record.Util.declare3 ~name:"r" 222 | ~f1_name:"f1" ~f1_type:Record.Type.int 223 | ~f2_name:"f2" ~f2_type:Record.Type.int 224 | ~f3_name:"f3" ~f3_type:Record.Type.int 225 | in 226 | assert_equal "r" (Record.Unsafe.layout_name l); 227 | assert_equal "f1" (Record.Field.name f1); 228 | assert_equal "f2" (Record.Field.name f2); 229 | assert_equal "f3" (Record.Field.name f3) 230 | 231 | let declare4 _ctxt = 232 | let (l, f1, f2, f3, f4) = 233 | Record.Util.declare4 ~name:"r" 234 | ~f1_name:"f1" ~f1_type:Record.Type.int 235 | ~f2_name:"f2" ~f2_type:Record.Type.int 236 | ~f3_name:"f3" ~f3_type:Record.Type.int 237 | ~f4_name:"f4" ~f4_type:Record.Type.int 238 | in 239 | assert_equal "r" (Record.Unsafe.layout_name l); 240 | assert_equal "f1" (Record.Field.name f1); 241 | assert_equal "f2" (Record.Field.name f2); 242 | assert_equal "f3" (Record.Field.name f3); 243 | assert_equal "f4" (Record.Field.name f4) 244 | 245 | let layout_type ctxt = 246 | let rt_typ = Record.Util.layout_type rt in 247 | let (la, fa1, fa2) = 248 | Record.Util.declare2 ~name:"pair" 249 | ~f1_name:"f1" ~f1_type:rt_typ 250 | ~f2_name:"f2" ~f2_type:rt_typ 251 | in 252 | let r = Record.Unsafe.make rt in 253 | Record.set r x 3; 254 | let rp = Record.Unsafe.make la in 255 | Record.set rp fa1 r; 256 | Record.set rp fa2 r; 257 | let printer = Yojson.Safe.pretty_to_string in 258 | let expected = 259 | `Assoc 260 | [ ("f1", `Assoc [("x", `Int 3)]) 261 | ; ("f2", `Assoc [("x", `Int 3)]) 262 | ] 263 | in 264 | assert_equal ~ctxt ~printer expected (Record.to_yojson rp) 265 | 266 | let safe_layout_type ctxt = 267 | let open Safe_layouts in 268 | let rt_typ = Record.Util.layout_type Rt.layout in 269 | let module La = (val Record.Safe.declare "pair") in 270 | let fa1 = La.field "f1" rt_typ in 271 | let fa2 = La.field "f2" rt_typ in 272 | let () = La.seal () in 273 | let r = Rt.make () in 274 | Record.set r x 3; 275 | let rp = La.make () in 276 | Record.set rp fa1 r; 277 | Record.set rp fa2 r; 278 | let printer = Yojson.Safe.pretty_to_string in 279 | let expected = 280 | `Assoc 281 | [ ("f1", `Assoc [("x", `Int 3)]) 282 | ; ("f2", `Assoc [("x", `Int 3)]) 283 | ] 284 | in 285 | assert_equal ~ctxt ~printer expected (Record.to_yojson rp) 286 | 287 | let view ctxt = 288 | let read n = 289 | match Char.chr n with 290 | | c -> Ok c 291 | | exception (Invalid_argument _) -> Error "read" 292 | in 293 | let write c = 294 | Char.code c 295 | in 296 | let char_as_int = 297 | let open Record.Type in 298 | view 299 | ~name:"char_as_int" 300 | ~read 301 | ~write 302 | int 303 | in 304 | let j = `Int 0x41 in 305 | let c = 'A' in 306 | assert_equal ~ctxt (Ok c) (Record.Type.of_yojson char_as_int j); 307 | assert_equal ~ctxt j (Record.Type.to_yojson char_as_int c) 308 | 309 | let suite = 310 | "Records" >::: 311 | [ "Set & get" >:: set_get 312 | ; "Get undefined field" >:: get_undef 313 | ; "Extend a sealed layout" >:: extend_after_seal 314 | ; "Seal a sealed layout" >:: seal_twice 315 | ; "Instanciate an unsealed layout" >:: make_unsealed 316 | ; "Layout name" >:: layout_name 317 | ; "Layout id" >:: layout_id 318 | ; "Field name" >:: field_name 319 | ; "Field type" >:: field_type 320 | ; "Record layout" >:: record_layout 321 | ; "JSON reader" >:: of_json 322 | ; "JSON writer" >:: to_json 323 | ; "JSON writer (null field)" >:: to_json_null 324 | ; "declare0" >:: declare0 325 | ; "declare1" >:: declare1 326 | ; "declare2" >:: declare2 327 | ; "declare3" >:: declare3 328 | ; "declare4" >:: declare4 329 | ; "layout_type" >:: layout_type 330 | ; "view" >:: view 331 | ; "Safe set & get" >:: safe_set_get 332 | ; "Safe get undefined field" >:: safe_get_undef 333 | ; "Safe extend a sealed layout" >:: safe_extend_after_seal 334 | ; "Safe seal a sealed layout" >:: safe_seal_twice 335 | ; "Safe instanciate an unsealed layout" >:: safe_make_unsealed 336 | ; "Safe layout name" >:: safe_layout_name 337 | ; "Safe layout id" >:: safe_layout_id 338 | ; "Safe field name" >:: safe_field_name 339 | ; "Safe field type" >:: safe_field_type 340 | ; "Safe record layout" >:: safe_record_layout 341 | ; "Safe JSON reader" >:: safe_of_json 342 | ; "Safe JSON writer" >:: safe_to_json 343 | ; "Safe JSON writer (null field)" >:: safe_to_json_null 344 | ; "Safe JSON (result)" >:: safe_json_result 345 | ; "Safe layout_type" >:: safe_layout_type 346 | ] 347 | 348 | let _ = run_test_tt_main suite 349 | --------------------------------------------------------------------------------