-
Notifications
You must be signed in to change notification settings - Fork 125
/
bslClientCode.ml
197 lines (182 loc) · 6.74 KB
/
bslClientCode.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
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
(*
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/>.
*)
(**
This module contains the deserialization of the client code
from a string directly into the opa client ast
The corresponding serialization is in Qmljs_serializer
*)
##register unser_adhoc : \
(opa[string] -> opa[_]), \
(opa[string] -> opa[_]), \
(opa[string] -> opa[_]), \
(opa[string] -> opa[_]), \
(opa[string] -> opa[_]), \
(opa[string] -> opa[_]), \
(opa[llarray(string)] -> opa[_]), \
(opa[string] -> opa[_]), \
(opa[string] -> opa[_]), \
(opa[string] -> opa[_]), \
(opa[string], opa[string] -> opa[_]), \
(opa[_], opa[_], opa[_], opa[_] -> _), \
string -> \
_
(* rpc, rpcdef, rpcuse, type, typedef, typeuse, set_distant, verbatim, ident, key, key_ident, code_elt*)
##register unser_server : \
(opa[option(string)], \
opa[_], \
opa[option(string)], \
opa[llarray(string)], \
opa[_], \
opa[llarray(string)], \
opa[llarray(string)] -> \
opa[_]), \
(opa[string] -> opa[_]), \
(opa[string] -> opa[_]), \
string -> \
opa[llarray(_)]
(* code_elt, rpc_def, type_def *)
##register[opacapi] serialize_string_length : string -> string
let ser_int b i = (* DIRTY DIRTY copy pasting *)
for j = 64 / 8 - 1 downto 0 do
Buffer.add_char b (Char.chr ((i lsr (j*8)) mod 256));
done
let serialize_string_length s =
let b = Buffer.create 10 in
ser_int b (String.length s);
Buffer.contents b
let s_nothing = ServerLib.make_simple_record (ServerLib.static_field_of_name "nothing")
type input = {string : string; mutable pos : int}
let end_of_input input =
input.pos = String.length input.string
let input_char input =
let c = input.string.[input.pos] in
input.pos <- input.pos + 1;
c
let input_byte input = Char.code (input_char input)
let really_input input s n len =
String.blit input.string input.pos s n len;
input.pos <- input.pos + len
let unser_int input =
let acc = ref 0 in
for j = 0 to 8 - 1 do
acc := !acc * 256 + input_byte input
done;
!acc
let unser_string input =
let length = unser_int input in
let s = String.create length in
really_input input s 0 length;
ServerLib.wrap_string s
let unser_bool_ref input =
match input_char input with
| '\000' -> BslReference.create ServerLib.false_
| '\001' -> BslReference.create ServerLib.true_
| _ -> assert false
let unser_array unser_a input =
let length = unser_int input in
let acc = LowLevelArray.create length (Obj.magic 0) in
for i = 0 to length - 1 do
LowLevelArray.set acc i (unser_a input)
done;
acc
let unser_option unser_a input =
match input_char input with
| '\000' -> ServerLib.none
| '\001' -> ServerLib.some (unser_a input)
| _ -> assert false
let unser unser_a input =
try
let r = unser_a input in
assert (end_of_input input);
r
with e ->
Printexc.print_backtrace stdout;
Printf.printf "BslClientCode: Parsing error at %d (strings outputted in ./parsed_string)\n%!" input.pos;
let a = open_out "parsed_string" in
Printf.fprintf a "%s" input.string;
Printf.fprintf a "\n\n\n\n";
Printf.fprintf a "%S" input.string;
close_out a;
raise e
let unser_adhoc rpc rpcdef rpcuse type_ typedef typeuse set_distant verbatim ident key key_ident code_elt string =
let input = {string; pos = 0} in
let unser_root = unser_bool_ref in
let unser_key_ident input =
match input_char input with
| '\000' -> Obj.magic (key (unser_string input))
| '\001' -> Obj.magic (ident (unser_string input))
| '\002' ->
let key = unser_string input in
let ident = unser_string input in
key_ident key ident
| _ -> assert false in
let unser_mini_expr input =
match input_char input with
| '\000' -> Obj.magic (verbatim (unser_string input))
| '\001' -> Obj.magic (ident (unser_string input))
| '\002' -> Obj.magic (verbatim (unser_string input))
| '\003' -> Obj.magic (set_distant (unser_array unser_string input))
| '\004' -> Obj.magic (rpcdef (unser_string input))
| '\005' -> Obj.magic (rpcuse (unser_string input))
| '\006' -> Obj.magic (typedef (unser_string input))
| '\007' -> Obj.magic (typeuse (unser_string input))
| _ -> assert false in
let unser_content input =
unser_array unser_mini_expr input in
let unser_definition input =
match input_char input with
| '\000' -> Obj.magic s_nothing
| '\001' -> Obj.magic (rpc (unser_string input))
| '\002' -> Obj.magic (type_ (unser_string input))
| _ -> assert false in
let unser_code_elt input =
let content = unser_content input in
let definition = unser_definition input in
let ident = unser_key_ident input in
let root = unser_root input in
(Obj.magic code_elt : _ -> _ -> _ -> _ -> _) content definition ident root in
let unser_code input =
unser_array unser_code_elt input in
Obj.magic (unser unser_code input)
let unser_server code_elt rpc type_ string =
let input = {string; pos = 0} in
let unser_root = unser_bool_ref in
let unser_rpc_key = unser_string in
let unser_type_key = unser_string in
let unser_ident = unser_string in
let unser_ident_field input = unser_option unser_ident input in
let unser_defines input =
match input_char input with
| '\000' -> Obj.magic s_nothing
| '\001' -> Obj.magic (rpc (unser_rpc_key input))
| '\002' -> Obj.magic (type_ (unser_type_key input))
| _ -> assert false in
let unser_ident_deps input =
unser_array unser_ident input in
let unser_rpc_deps input =
unser_array unser_rpc_key input in
let unser_type_deps input =
unser_array unser_type_key input in
let unser_code_elt input =
let client_equivalent = unser_ident_field input in
let defines = unser_defines input in
let ident = unser_ident_field input in
let ident_deps = unser_ident_deps input in
let root = unser_root input in
let rpc_deps = unser_rpc_deps input in
let type_deps = unser_type_deps input in
(Obj.magic code_elt : _ -> _ -> _ -> _ -> _ -> _ -> _ -> _) client_equivalent defines ident ident_deps root rpc_deps type_deps in
let unser_code input =
unser_array unser_code_elt input in
unser unser_code input