-
Notifications
You must be signed in to change notification settings - Fork 125
/
bslJson.ml
127 lines (101 loc) · 5.44 KB
/
bslJson.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
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA 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 OPA. If not, see <http://www.gnu.org/licenses/>.
*)
##opa-type RPC.Json.json
##extern-type RPC.Json.private.native = JsonTypes.json
##extern-type ll_json_list_repr = JsonTypes.json (*RPC.Json.private.native*) list
##extern-type ll_json_record_repr = (string * JsonTypes.json (*RPC.Json.private.native*)) list
##module Json
let field_int = ServerLib.static_field_of_name "Int"
let field_float = ServerLib.static_field_of_name "Float"
let field_bool = ServerLib.static_field_of_name "Bool"
let field_string= ServerLib.static_field_of_name "String"
let field_list = ServerLib.static_field_of_name "List"
let field_record= ServerLib.static_field_of_name "Record"
let field_fst = ServerLib.static_field_of_name "f1"
let field_snd = ServerLib.static_field_of_name "f2"
let field_hd = ServerLib.static_field_of_name "hd"
let field_tl = ServerLib.static_field_of_name "tl"
let field_nil = ServerLib.static_field_of_name "nil"
let make_int x = ServerLib.make_record (ServerLib.add_field ServerLib.empty_record_constructor field_int x)
let make_float x = ServerLib.make_record (ServerLib.add_field ServerLib.empty_record_constructor field_float x)
let make_bool x = ServerLib.make_record (ServerLib.add_field ServerLib.empty_record_constructor field_bool (ServerLib.wrap_bool x))
let make_string x = ServerLib.make_record (ServerLib.add_field ServerLib.empty_record_constructor field_string x)
let make_list x = ServerLib.make_record (ServerLib.add_field ServerLib.empty_record_constructor field_list x)
let make_record x = ServerLib.make_record (ServerLib.add_field ServerLib.empty_record_constructor field_record x)
let shared_nil = ServerLib.make_simple_record field_nil
let shared_void = make_record shared_nil
let make_nil () = shared_nil
let make_pair x y = ServerLib.make_record (ServerLib.add_field (ServerLib.add_field ServerLib.empty_record_constructor field_fst x) field_snd y)
(**
* This part concerns translation of a OPA Json object to/from Json
* implementation in OCaml. It's defined on libqml/libqml/jsonTypes.ml.
*)
##register of_json_repr: RPC.Json.private.native -> option(RPC.Json.json)
let of_json_repr js =
let rec aux = function
| JsonTypes.Int i -> make_int i
| JsonTypes.Float f -> make_float f
| JsonTypes.Bool b -> make_bool b
| JsonTypes.Void -> shared_void
| JsonTypes.String s-> make_string s
| JsonTypes.Array l ->
make_list (
List.fold_right (fun x acc ->
let cons = ServerLib.empty_record_constructor in
let cons = ServerLib.add_field cons field_hd (aux x) in
let cons = ServerLib.add_field cons field_tl acc in
ServerLib.make_record cons
)
l shared_nil
)
| JsonTypes.Record r ->
make_record (List.fold_right (fun (x,y) acc ->
let cons = ServerLib.empty_record_constructor in
let cons = ServerLib.add_field cons field_hd (make_pair x (aux y)) in
let cons = ServerLib.add_field cons field_tl acc in
ServerLib.make_record cons
)
r shared_nil
)
in
Some (wrap_opa_rpc_json_json (aux js))
##register of_string: string -> option(RPC.Json.json)
let of_string s = match JsonLex.transform true s with
| None -> None
| Some x -> of_json_repr x
##register of_latin1_string: string -> option(RPC.Json.json)
let of_latin1_string s = match JsonLex.transform false s with
| None -> None
| Some x -> of_json_repr x
##register json_list_empty : -> ll_json_list_repr
let json_list_empty () = []
##register json_list_cons : RPC.Json.private.native, ll_json_list_repr -> ll_json_list_repr
let json_list_cons a b = a::b
##register json_record_empty : -> ll_json_record_repr
let json_record_empty () = []
##register json_record_cons : string, RPC.Json.private.native, ll_json_record_repr -> ll_json_record_repr
let json_record_cons s b r = (s,b)::r
##register json_repr_int : int -> RPC.Json.private.native
let json_repr_int i = JsonTypes.Int i
##register json_repr_float : float -> RPC.Json.private.native
let json_repr_float f = JsonTypes.Float f
##register json_repr_string : string -> RPC.Json.private.native
let json_repr_string s = JsonTypes.String s
##register json_repr_bool : bool -> RPC.Json.private.native
let json_repr_bool b = JsonTypes.Bool b
##register json_repr_array : ll_json_list_repr -> RPC.Json.private.native
let json_repr_array lst = JsonTypes.Array lst
##register json_repr_record : ll_json_record_repr -> RPC.Json.private.native
let json_repr_record lst = JsonTypes.Record (List.rev lst)
##endmodule