Source file `json_adapter.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
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
(* Json adapters. See .mli. *)

let normalize_type_field type_field_name (x : Yojson.Safe.t) : Yojson.Safe.t =
  match x with
  | `Assoc fields ->
      (match List.assoc type_field_name fields with
       | `String type_ -> `List [ `String type_; x ]
       | exception Not_found -> x
       | _ -> x (* malformed *)
      )
  | `String type_ as x -> x
  | malformed -> malformed

let restore_type_field type_field_name (x : Yojson.Safe.t) : Yojson.Safe.t =
  match x with
  | `List [ `String type_; `Assoc fields ] ->
      let fields =
        (type_field_name, `String type_) ::
        List.filter (fun (k, v) -> k <> type_field_name) fields
      in
      `Assoc fields
  | `String type_ as x -> x
  | malformed -> malformed

module type S = sig
  val normalize : Yojson.Safe.t -> Yojson.Safe.t
  val restore : Yojson.Safe.t -> Yojson.Safe.t
end

module Type_field = struct
  module type Param = sig
    val type_field_name : string
  end

  module Make (Param : Param) : S = struct
    let normalize = normalize_type_field Param.type_field_name

    let restore = restore_type_field Param.type_field_name
  end

  module Default_param : Param = struct
    let type_field_name = "type"
  end

  include Make (Default_param)
end

module One_field = struct
  open Yojson.Safe

  let normalize (x : t) : t =
    match x with
    | `Assoc [name, value] -> `List [`String name; value]
    | `String _ as x -> x
    | malformed -> malformed

  let restore (x : t) : t =
    match x with
    | `List [`String name; value] -> `Assoc [name, value]
    | `String _ as x -> x
    | malformed -> malformed
end

module Type_and_value_fields = struct
  module type Param = sig
    val type_field_name : string
    val value_field_name : string
    val known_tags : (string list * string) option
  end

  module Make (Param : Param) : S = struct
    open Yojson.Safe
    open Param

    let is_known_tag =
      match known_tags with
      | None -> (fun _ -> true)
      | Some (l, _) ->
          let tbl = Hashtbl.create (2 * List.length l) in
          List.iter (fun x -> Hashtbl.add tbl x ()) l;
          Hashtbl.mem tbl

    let is_catch_all_tag =
      match known_tags with
      | None -> (fun _ -> false)
      | Some (_, s) -> ((=) s)

    let catch_all_tag () =
      match known_tags with
      | None -> assert false
      | Some (_, s) -> s

    let wrap_variant type_ value =
      let variant = `List [`String type_; value] in
      if is_known_tag type_ then
        variant
      else
        `List [ `String (catch_all_tag ()); variant ]

    let wrap_enum type_ =
      if is_known_tag type_ then
        `String type_
      else
        `List [ `String (catch_all_tag ()); `Null ]

    let normalize (x : t) : t =
      let open Yojson.Safe.Util in
      match x with
      | `Assoc fields ->
          let type_ = member type_field_name x |> to_string in
          let found = ref false in
          let fields =
            List.map (fun ((k, v) as field) ->
              if k = value_field_name then (
                found := true;
                (k, wrap_variant type_ v)
              )
              else
                field
            ) fields
          in
          let fields =
            if !found then
              fields
            else
              (value_field_name, wrap_enum type_) :: fields
          in
          `Assoc fields
      | malformed -> malformed

    let unwrap_value (x : t) =
      match x with
      | `String tag -> (tag, None)
      | `List [`String tag; v] ->
          if is_catch_all_tag tag then (
            match v with
            | `List [`String real_tag; `Null] -> (real_tag, None)
            | `List [`String real_tag; real_v] -> (real_tag, Some real_v)
            | _ -> failwith ("Malformed json field " ^ value_field_name)
          )
          else
            (tag, Some v)
      | malformed -> failwith ("Malformed json field " ^ value_field_name)

    let restore (x : t) : t =
      match x with
      | `Assoc fields ->
          let type_ = ref None in
          let fields =
            List.fold_right (fun ((k, tagged) as field) acc ->
              if k = value_field_name then (
                let tag, opt_value = unwrap_value tagged in
                type_ := Some tag;
                match opt_value with
                | None -> acc
                | Some v -> (value_field_name, v) :: acc
              )
              else if k = type_field_name then
                acc
              else
                field :: acc
              ) fields []
          in
          let fields =
            match !type_ with
            | None -> fields
            | Some tag -> (type_field_name, `String tag) :: fields
          in
          `Assoc fields
      | malformed -> malformed
  end
end