serializable_builtin_j.ml 3.16 KB
Newer Older
Stephane Glondu's avatar
Stephane Glondu committed
1 2 3
(**************************************************************************)
(*                                BELENIOS                                *)
(*                                                                        *)
Stephane Glondu's avatar
Stephane Glondu committed
4
(*  Copyright © 2012-2018 Inria                                           *)
Stephane Glondu's avatar
Stephane Glondu committed
5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21
(*                                                                        *)
(*  This program is free software: you can redistribute it and/or modify  *)
(*  it under the terms of the GNU Affero General Public License as        *)
(*  published by the Free Software Foundation, either version 3 of the    *)
(*  License, or (at your option) any later version, with the additional   *)
(*  exemption that compiling, linking, and/or using OpenSSL is allowed.   *)
(*                                                                        *)
(*  This program is distributed in the hope that it will be useful, but   *)
(*  WITHOUT ANY WARRANTY; without even the implied warranty of            *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU     *)
(*  Affero General Public License for more details.                       *)
(*                                                                        *)
(*  You should have received a copy of the GNU Affero General Public      *)
(*  License along with this program.  If not, see                         *)
(*  <http://www.gnu.org/licenses/>.                                       *)
(**************************************************************************)

22
open Platform
23
open Serializable_builtin_t
Stephane Glondu's avatar
Stephane Glondu committed
24

25
(** {1 Helpers for interacting with atd-generated stuff} *)
Stephane Glondu's avatar
Stephane Glondu committed
26

27
let make_write to_string buf x =
Stephane Glondu's avatar
Stephane Glondu committed
28
  Bi_outbuf.add_char buf '"';
29
  Bi_outbuf.add_string buf (to_string x);
Stephane Glondu's avatar
Stephane Glondu committed
30 31
  Bi_outbuf.add_char buf '"'

32
let make_read name of_string state buf =
33 34
  match Yojson.Safe.from_lexbuf ~stream:true state buf with
  | `String s -> of_string s
35
  | _ -> invalid_arg (name ^ ": a string was expected")
36 37 38 39 40

(** {1 Serializers for type number} *)

let write_number = make_write Z.to_string

41
let read_number = make_read "read_number" Z.of_string
42

Stephane Glondu's avatar
Stephane Glondu committed
43 44
(** {1 Serializers for type uuid} *)

45
let write_uuid = make_write raw_string_of_uuid
Stephane Glondu's avatar
Stephane Glondu committed
46

47
let read_uuid = make_read "read_uuid" uuid_of_raw_string
Stephane Glondu's avatar
Stephane Glondu committed
48

49 50 51 52 53 54 55 56 57
(** {1 Serializers for type int_or_null} *)

let write_int_or_null buf = function
  | Some n -> Bi_outbuf.add_string buf (string_of_int n)
  | None -> Bi_outbuf.add_string buf "null"

let int_or_null_of_json = function
  | `Int i -> Some i
  | `Null -> None
58
  | _ -> invalid_arg "int_or_null_of_json: unexpected input"
59 60 61 62

let read_int_or_null state buf =
  int_or_null_of_json (Yojson.Safe.from_lexbuf ~stream:true state buf)

63 64 65 66 67 68 69 70 71 72 73
(** {1 Serializers for type string_set} *)

let write_string_set buf set =
  `List (SSet.elements set |> List.map (fun x -> `String x)) |>
  Yojson.Safe.to_outbuf buf

let string_set_of_json = function
  | `List xs ->
    List.fold_left (fun accu x ->
      match x with
      | `String y -> SSet.add y accu
74
      | _ -> invalid_arg "string_set_of_json: a string was expected"
75
    ) SSet.empty xs
76
  | _ -> invalid_arg "string_set_of_json: a list was expected"
77 78 79

let read_string_set state buf =
  Yojson.Safe.from_lexbuf ~stream:true state buf |> string_set_of_json