Source file melange_json.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
open Printf

type t = Yojson.Basic.t
(** The type of a JSON data structure *)

type json = t
(** Defined for convenience. *)

let classify = Classify.classify
let declassify = Classify.declassify
let to_string t = Yojson.Basic.to_string t

include Errors

let of_string s =
  try Yojson.Basic.from_string s
  with Yojson.Json_error msg -> raise (Of_string_error msg)

type 'a to_json = 'a -> json
(** Describe how to encode a value into JSON. *)

let to_json : json to_json = fun x -> x

let () =
  Printexc.register_printer (function
    | Of_json_error (Json_error str) ->
        Some (sprintf "Melange_json.Of_json_error(Json_error {|%s|})" str)
    | Of_json_error (Unexpected_variant str) ->
        Some
          (sprintf "Melange_json.Of_json_error(Unexpected_variant {|%s|})"
             str)
    | _ -> None)

type 'a of_json = json -> 'a
(** Describe how to decode a value from JSON. *)

let of_json : 'a of_json = fun x -> x

module Of_json = struct
  let typeof = function
    | `Assoc _ -> "object"
    | `Bool _ -> "bool"
    | `Float _ -> "float"
    | `Int _ -> "int"
    | `List _ -> "array"
    | `Null -> "null"
    | `String _ -> "string"

  let string = function
    | `String s -> s
    | json -> of_json_error_type_mismatch json "string"

  let bool = function
    | `Bool b -> b
    | json -> of_json_error_type_mismatch json "bool"

  let int = function
    | `Int i -> i
    | json -> of_json_error_type_mismatch json "int"

  let int64 = function
    | `String i as json -> (
        match Int64.of_string_opt i with
        | Some v -> v
        | None -> of_json_error_type_mismatch json "int64 as string")
    | json -> of_json_error_type_mismatch json "int64 as string"

  let float = function
    | `Float f -> f
    | `Int i -> float_of_int i
    | json -> of_json_error_type_mismatch json "float"

  let unit = function
    | `Null -> ()
    | json -> of_json_error_type_mismatch json "expected null"

  let option v_of_json = function
    | `Null -> None
    | json -> Some (v_of_json json)

  let list v_of_json = function
    | `List l -> List.map v_of_json l
    | json -> of_json_error_type_mismatch json "array"

  let array v_of_json = function
    | `List l -> Array.map v_of_json (Array.of_list l)
    | json -> of_json_error_type_mismatch json "array"

  let result ok_of_json err_of_json json =
    match json with
    | `List [ `String "Ok"; x ] -> Ok (ok_of_json x)
    | `List [ `String "Error"; x ] -> Error (err_of_json x)
    | _ ->
        of_json_error {|expected ["Ok"; _] or ["Error"; _]|} ~depth:2
          ~json
end

module To_json = struct
  let string v = `String v
  let bool v = `Bool v
  let int v = `Int v
  let int64 v = `String (Int64.to_string v)
  let float v = `Float v
  let unit () = `Null
  let list v_to_json vs = `List (List.map v_to_json vs)
  let array v_to_json vs = `List (Array.to_list (Array.map v_to_json vs))
  let option v_to_json = function None -> `Null | Some v -> v_to_json v

  let result a_to_json b_to_json v =
    match v with
    | Ok x -> `List [ `String "Ok"; a_to_json x ]
    | Error x -> `List [ `String "Error"; b_to_json x ]
end

module Primitives = struct
  let string_of_json = Of_json.string
  let bool_of_json = Of_json.bool
  let float_of_json = Of_json.float
  let int_of_json = Of_json.int
  let int64_of_json = Of_json.int64
  let option_of_json = Of_json.option
  let unit_of_json = Of_json.unit
  let result_of_json = Of_json.result
  let list_of_json = Of_json.list
  let array_of_json = Of_json.array
  let string_to_json = To_json.string
  let bool_to_json = To_json.bool
  let float_to_json = To_json.float
  let int_to_json = To_json.int
  let int64_to_json = To_json.int64
  let option_to_json = To_json.option
  let unit_to_json = To_json.unit
  let result_to_json = To_json.result
  let list_to_json = To_json.list
  let array_to_json = To_json.array
end