this repo has no description
Better initialisation
+977
-838
+1
.ocamlformat
+1
.ocamlformat
···
1
+
version=0.19.0
+1
idl/.ocamlformat-ignore
+1
idl/.ocamlformat-ignore
···
1
+
toplevel_api_gen.ml
+329
-296
idl/idl.ml
+329
-296
idl/idl.ml
···
1
1
let logfn = ref (fun (_ : string) -> ())
2
+
2
3
module Param = struct
3
-
type 'a t =
4
-
{ name : string option
5
-
; description : string list
6
-
; typedef : 'a Rpc.Types.def
7
-
; version : Rpc.Version.t option
8
-
}
4
+
type 'a t = {
5
+
name : string option;
6
+
description : string list;
7
+
typedef : 'a Rpc.Types.def;
8
+
version : Rpc.Version.t option;
9
+
}
9
10
10
11
type boxed = Boxed : 'a t -> boxed
11
12
···
19
20
end
20
21
21
22
module Error = struct
22
-
type 'a t =
23
-
{ def : 'a Rpc.Types.def
24
-
; raiser : 'a -> exn
25
-
; matcher : exn -> 'a option
26
-
}
23
+
type 'a t = {
24
+
def : 'a Rpc.Types.def;
25
+
raiser : 'a -> exn;
26
+
matcher : exn -> 'a option;
27
+
}
27
28
28
29
module type ERROR = sig
29
30
type t
30
31
31
32
val t : t Rpc.Types.def
33
+
32
34
val internal_error_of : exn -> t option
33
35
end
34
36
···
38
40
let () =
39
41
let printer = function
40
42
| Exn x ->
41
-
Some
42
-
(Printf.sprintf
43
-
"IDL Error: %s"
44
-
(Rpcmarshal.marshal T.t.Rpc.Types.ty x |> Rpc.to_string))
43
+
Some
44
+
(Printf.sprintf "IDL Error: %s"
45
+
(Rpcmarshal.marshal T.t.Rpc.Types.ty x |> Rpc.to_string))
45
46
| _ -> None
46
47
in
47
48
Printexc.register_printer printer
48
49
49
-
50
50
let error =
51
-
{ def = T.t
52
-
; raiser =
53
-
(function
54
-
| e -> Exn e)
55
-
; matcher =
56
-
(function
57
-
| Exn e -> Some e
58
-
| e -> T.internal_error_of e)
51
+
{
52
+
def = T.t;
53
+
raiser = (function e -> Exn e);
54
+
matcher = (function Exn e -> Some e | e -> T.internal_error_of e);
59
55
}
60
56
end
61
57
end
62
58
63
59
module Interface = struct
64
-
type description =
65
-
{ name : string
66
-
; namespace : string option
67
-
; description : string list
68
-
; version : Rpc.Version.t
69
-
}
60
+
type description = {
61
+
name : string;
62
+
namespace : string option;
63
+
description : string list;
64
+
version : Rpc.Version.t;
65
+
}
70
66
end
71
67
72
68
module type RPC = sig
73
69
type implementation
70
+
74
71
type 'a res
72
+
75
73
type ('a, 'b) comp
74
+
76
75
type _ fn
77
76
78
77
val implement : Interface.description -> implementation
78
+
79
79
val ( @-> ) : 'a Param.t -> 'b fn -> ('a -> 'b) fn
80
+
80
81
val returning : 'a Param.t -> 'b Error.t -> ('a, 'b) comp fn
82
+
81
83
val declare : string -> string list -> 'a fn -> 'a res
84
+
82
85
val declare_notification : string -> string list -> 'a fn -> 'a res
83
86
end
84
87
···
86
89
type 'a t
87
90
88
91
val return : 'a -> 'a t
92
+
89
93
val bind : 'a t -> ('a -> 'b t) -> 'b t
94
+
90
95
val fail : exn -> 'a t
91
96
end
92
97
93
98
exception MarshalError of string
99
+
94
100
exception UnknownMethod of string
101
+
95
102
exception UnboundImplementation of string list
103
+
96
104
exception NoDescription
97
105
98
106
let get_wire_name description name =
99
107
match description with
100
108
| None -> name
101
-
| Some d ->
102
-
(match d.Interface.namespace with
103
-
| Some ns -> Printf.sprintf "%s.%s" ns name
104
-
| None -> name)
105
-
109
+
| Some d -> (
110
+
match d.Interface.namespace with
111
+
| Some ns -> Printf.sprintf "%s.%s" ns name
112
+
| None -> name)
106
113
107
114
let get_arg call has_named name is_opt =
108
-
match has_named, name, call.Rpc.params with
109
-
| true, Some n, Rpc.Dict named :: unnamed ->
110
-
(match List.partition (fun (x, _) -> x = n) named with
111
-
| (_, arg) :: dups, others when is_opt ->
112
-
Ok
113
-
(Rpc.Enum [ arg ], { call with Rpc.params = Rpc.Dict (dups @ others) :: unnamed })
114
-
| (_, arg) :: dups, others ->
115
-
Ok (arg, { call with Rpc.params = Rpc.Dict (dups @ others) :: unnamed })
116
-
| [], _others when is_opt -> Ok (Rpc.Enum [], call)
117
-
| _, _ -> Error (`Msg (Printf.sprintf "Expecting named argument '%s'" n)))
118
-
| true, None, Rpc.Dict named :: unnamed ->
119
-
(match unnamed with
120
-
| head :: tail -> Ok (head, { call with Rpc.params = Rpc.Dict named :: tail })
121
-
| _ -> Error (`Msg "Incorrect number of arguments"))
115
+
match (has_named, name, call.Rpc.params) with
116
+
| true, Some n, Rpc.Dict named :: unnamed -> (
117
+
match List.partition (fun (x, _) -> x = n) named with
118
+
| (_, arg) :: dups, others when is_opt ->
119
+
Ok
120
+
( Rpc.Enum [ arg ],
121
+
{ call with Rpc.params = Rpc.Dict (dups @ others) :: unnamed } )
122
+
| (_, arg) :: dups, others ->
123
+
Ok
124
+
(arg, { call with Rpc.params = Rpc.Dict (dups @ others) :: unnamed })
125
+
| [], _others when is_opt -> Ok (Rpc.Enum [], call)
126
+
| _, _ -> Error (`Msg (Printf.sprintf "Expecting named argument '%s'" n)))
127
+
| true, None, Rpc.Dict named :: unnamed -> (
128
+
match unnamed with
129
+
| head :: tail ->
130
+
Ok (head, { call with Rpc.params = Rpc.Dict named :: tail })
131
+
| _ -> Error (`Msg "Incorrect number of arguments"))
122
132
| true, _, _ ->
123
-
Error
124
-
(`Msg
125
-
"Marshalling error: Expecting dict as first argument when named parameters exist")
133
+
Error
134
+
(`Msg
135
+
"Marshalling error: Expecting dict as first argument when named \
136
+
parameters exist")
126
137
| false, None, head :: tail -> Ok (head, { call with Rpc.params = tail })
127
138
| false, None, [] -> Error (`Msg "Incorrect number of arguments")
128
139
| false, Some _, _ -> failwith "Can't happen by construction"
129
-
130
140
131
141
module Make (M : MONAD) = struct
132
142
module type RPCTRANSFORMER = sig
133
143
type 'a box
144
+
134
145
type ('a, 'b) resultb = ('a, 'b) result box
146
+
135
147
type rpcfn = Rpc.call -> Rpc.response M.t
136
148
137
149
val lift : ('a -> 'b M.t) -> 'a -> 'b box
150
+
138
151
val bind : 'a box -> ('a -> 'b M.t) -> 'b box
152
+
139
153
val return : 'a -> 'a box
154
+
140
155
val get : 'a box -> 'a M.t
156
+
141
157
val ( !@ ) : 'a box -> 'a M.t
158
+
142
159
val put : 'a M.t -> 'a box
160
+
143
161
val ( ~@ ) : 'a M.t -> 'a box
144
162
end
145
163
146
164
module T = struct
147
165
type 'a box = { box : 'a M.t }
166
+
148
167
type ('a, 'b) resultb = ('a, 'b) result box
168
+
149
169
type rpcfn = Rpc.call -> Rpc.response M.t
150
170
151
171
let lift f x = { box = f x }
172
+
152
173
let bind { box = x } f = { box = M.bind x f }
174
+
153
175
let return x = { box = M.return x }
176
+
154
177
let get { box = x } = x
178
+
155
179
let ( !@ ) = get
180
+
156
181
let put x = { box = x }
182
+
157
183
let ( ~@ ) = put
158
184
end
159
185
160
186
type client_implementation = unit
187
+
161
188
type server_implementation = (string, T.rpcfn option) Hashtbl.t
162
189
163
190
module ErrM : sig
164
191
val return : 'a -> ('a, 'b) T.resultb
192
+
165
193
val return_err : 'b -> ('a, 'b) T.resultb
166
194
167
-
val checked_bind
168
-
: ('a, 'b) T.resultb
169
-
-> ('a -> ('c, 'd) T.resultb)
170
-
-> ('b -> ('c, 'd) T.resultb)
171
-
-> ('c, 'd) T.resultb
195
+
val checked_bind :
196
+
('a, 'b) T.resultb ->
197
+
('a -> ('c, 'd) T.resultb) ->
198
+
('b -> ('c, 'd) T.resultb) ->
199
+
('c, 'd) T.resultb
172
200
173
-
val bind : ('a, 'b) T.resultb -> ('a -> ('c, 'b) T.resultb) -> ('c, 'b) T.resultb
174
-
val ( >>= ) : ('a, 'b) T.resultb -> ('a -> ('c, 'b) T.resultb) -> ('c, 'b) T.resultb
201
+
val bind :
202
+
('a, 'b) T.resultb -> ('a -> ('c, 'b) T.resultb) -> ('c, 'b) T.resultb
203
+
204
+
val ( >>= ) :
205
+
('a, 'b) T.resultb -> ('a -> ('c, 'b) T.resultb) -> ('c, 'b) T.resultb
175
206
end = struct
176
207
let return x = T.put (M.return (Ok x))
208
+
177
209
let return_err e = T.put (M.return (Error e))
178
210
179
211
let checked_bind x f f1 =
180
-
T.bind
181
-
x
182
-
T.(
183
-
function
184
-
| Ok x -> !@(f x)
185
-
| Error x -> !@(f1 x))
186
-
212
+
T.bind x T.(function Ok x -> !@(f x) | Error x -> !@(f1 x))
187
213
188
214
let bind x f = checked_bind x f return_err
215
+
189
216
let ( >>= ) x f = bind x f
190
217
end
191
218
192
219
module GenClient () = struct
193
220
type implementation = client_implementation
221
+
194
222
type 'a res = T.rpcfn -> 'a
223
+
195
224
type ('a, 'b) comp = ('a, 'b) T.resultb
196
225
197
226
type _ fn =
···
199
228
| Returning : ('a Param.t * 'b Error.t) -> ('a, 'b) comp fn
200
229
201
230
let description = ref None
231
+
202
232
let strict = ref false
233
+
203
234
let make_strict () = strict := true
204
235
205
236
let implement x =
206
237
description := Some x;
207
238
()
208
239
209
-
210
240
let returning a err = Returning (a, err)
241
+
211
242
let ( @-> ) t f = Function (t, f)
212
243
213
244
let declare_ is_notification name _ ty (rpc : T.rpcfn) =
214
-
let rec inner : type b. (string * Rpc.t) list option * Rpc.t list -> b fn -> b =
245
+
let rec inner :
246
+
type b. (string * Rpc.t) list option * Rpc.t list -> b fn -> b =
215
247
fun (named, unnamed) -> function
216
-
| Function (t, f) ->
217
-
let cur_named =
218
-
match named with
219
-
| Some l -> l
220
-
| None -> []
221
-
in
222
-
fun v ->
223
-
(match t.Param.name with
224
-
| Some n ->
225
-
(match t.Param.typedef.Rpc.Types.ty, v with
226
-
| Rpc.Types.Option ty, Some v' ->
227
-
let marshalled = Rpcmarshal.marshal ty v' in
228
-
inner (Some ((n, marshalled) :: cur_named), unnamed) f
229
-
| Rpc.Types.Option _ty, None -> inner (Some cur_named, unnamed) f
230
-
| ty, v ->
231
-
let marshalled = Rpcmarshal.marshal ty v in
232
-
inner (Some ((n, marshalled) :: cur_named), unnamed) f)
233
-
| None ->
234
-
let marshalled = Rpcmarshal.marshal t.Param.typedef.Rpc.Types.ty v in
235
-
inner (named, marshalled :: unnamed) f)
248
+
| Function (t, f) -> (
249
+
let cur_named = match named with Some l -> l | None -> [] in
250
+
fun v ->
251
+
match t.Param.name with
252
+
| Some n -> (
253
+
match (t.Param.typedef.Rpc.Types.ty, v) with
254
+
| Rpc.Types.Option ty, Some v' ->
255
+
let marshalled = Rpcmarshal.marshal ty v' in
256
+
inner (Some ((n, marshalled) :: cur_named), unnamed) f
257
+
| Rpc.Types.Option _ty, None ->
258
+
inner (Some cur_named, unnamed) f
259
+
| ty, v ->
260
+
let marshalled = Rpcmarshal.marshal ty v in
261
+
inner (Some ((n, marshalled) :: cur_named), unnamed) f)
262
+
| None ->
263
+
let marshalled =
264
+
Rpcmarshal.marshal t.Param.typedef.Rpc.Types.ty v
265
+
in
266
+
inner (named, marshalled :: unnamed) f)
236
267
| Returning (t, e) ->
237
-
let wire_name = get_wire_name !description name in
238
-
let args =
239
-
match named with
240
-
| None -> List.rev unnamed
241
-
| Some l -> Rpc.Dict l :: List.rev unnamed
242
-
in
243
-
let call' = Rpc.call wire_name args in
244
-
let call = { call' with is_notification } in
245
-
let rpc = T.put (rpc call) in
246
-
let res =
247
-
T.bind rpc (fun r ->
248
-
if r.Rpc.success
249
-
then (
250
-
match
251
-
Rpcmarshal.unmarshal t.Param.typedef.Rpc.Types.ty r.Rpc.contents
252
-
with
253
-
| Ok x -> M.return (Ok x)
254
-
| Error (`Msg x) -> M.fail (MarshalError x))
255
-
else (
256
-
match Rpcmarshal.unmarshal e.Error.def.Rpc.Types.ty r.Rpc.contents with
257
-
| Ok x ->
258
-
if !strict then M.fail (e.Error.raiser x) else M.return (Error x)
259
-
| Error (`Msg x) -> M.fail (MarshalError x)))
260
-
in
261
-
res
268
+
let wire_name = get_wire_name !description name in
269
+
let args =
270
+
match named with
271
+
| None -> List.rev unnamed
272
+
| Some l -> Rpc.Dict l :: List.rev unnamed
273
+
in
274
+
let call' = Rpc.call wire_name args in
275
+
let call = { call' with is_notification } in
276
+
let rpc = T.put (rpc call) in
277
+
let res =
278
+
T.bind rpc (fun r ->
279
+
if r.Rpc.success then
280
+
match
281
+
Rpcmarshal.unmarshal t.Param.typedef.Rpc.Types.ty
282
+
r.Rpc.contents
283
+
with
284
+
| Ok x -> M.return (Ok x)
285
+
| Error (`Msg x) -> M.fail (MarshalError x)
286
+
else
287
+
match
288
+
Rpcmarshal.unmarshal e.Error.def.Rpc.Types.ty
289
+
r.Rpc.contents
290
+
with
291
+
| Ok x ->
292
+
if !strict then M.fail (e.Error.raiser x)
293
+
else M.return (Error x)
294
+
| Error (`Msg x) -> M.fail (MarshalError x))
295
+
in
296
+
res
262
297
in
263
298
inner (None, []) ty
264
299
300
+
let declare_notification name a ty (rpc : T.rpcfn) =
301
+
declare_ true name a ty rpc
265
302
266
-
let declare_notification name a ty (rpc : T.rpcfn) = declare_ true name a ty rpc
267
303
let declare name a ty (rpc : T.rpcfn) = declare_ false name a ty rpc
268
304
end
269
305
···
275
311
match fn with
276
312
| None -> key :: acc
277
313
| Some fn ->
278
-
Hashtbl.add impl key fn;
279
-
acc)
280
-
hashtbl
281
-
[]
314
+
Hashtbl.add impl key fn;
315
+
acc)
316
+
hashtbl []
282
317
in
283
318
if unbound_impls <> [] then raise (UnboundImplementation unbound_impls);
284
319
fun call ->
285
320
let fn =
286
-
try Hashtbl.find impl call.Rpc.name with
287
-
| Not_found ->
321
+
try Hashtbl.find impl call.Rpc.name
322
+
with Not_found ->
288
323
!logfn "1";
289
-
Hashtbl.iter (fun key _ -> !logfn ("method: " ^ key ^ (Hashtbl.hash key |> string_of_int)); !logfn key) impl;
324
+
Hashtbl.iter
325
+
(fun key _ ->
326
+
!logfn ("method: " ^ key ^ (Hashtbl.hash key |> string_of_int));
327
+
!logfn key)
328
+
impl;
290
329
let _h = Hashtbl.hash call.Rpc.name in
291
330
292
-
!logfn (Printf.sprintf "Unknown method: %s %d" call.Rpc.name (Hashtbl.hash call.Rpc.name));
331
+
!logfn
332
+
(Printf.sprintf "Unknown method: %s %d" call.Rpc.name
333
+
(Hashtbl.hash call.Rpc.name));
293
334
!logfn call.Rpc.name;
294
335
raise (UnknownMethod call.Rpc.name)
295
336
in
296
337
fn call
297
338
298
-
299
339
let combine hashtbls =
300
340
let result = Hashtbl.create 16 in
301
341
List.iter (Hashtbl.iter (fun k v -> Hashtbl.add result k v)) hashtbls;
302
342
result
303
-
304
343
305
344
module GenServer () = struct
306
345
type implementation = server_implementation
346
+
307
347
type ('a, 'b) comp = ('a, 'b) T.resultb
348
+
308
349
type 'a res = 'a -> unit
309
350
310
351
type _ fn =
···
312
353
| Returning : ('a Param.t * 'b Error.t) -> ('a, 'b) comp fn
313
354
314
355
let funcs = Hashtbl.create 20
356
+
315
357
let description = ref None
316
358
317
359
let implement x =
318
360
description := Some x;
319
361
funcs
320
362
321
-
322
363
let returning a b = Returning (a, b)
364
+
323
365
let ( @-> ) t f = Function (t, f)
324
366
325
367
let rec has_named_args : type a. a fn -> bool = function
326
-
| Function (t, f) ->
327
-
(match t.Param.name with
328
-
| Some _ -> true
329
-
| None -> has_named_args f)
368
+
| Function (t, f) -> (
369
+
match t.Param.name with Some _ -> true | None -> has_named_args f)
330
370
| Returning (_, _) -> false
331
-
332
371
333
372
let declare_ : bool -> string -> string list -> 'a fn -> 'a res =
334
373
fun is_notification name _ ty ->
···
336
375
(* We do not know the wire name yet as the description may still be unset *)
337
376
Hashtbl.add funcs name None;
338
377
fun impl ->
339
-
((* Sanity check: ensure the description has been set before we declare
340
-
any RPCs. Here we raise an exception immediately and let everything fail. *)
341
-
match !description with
342
-
| Some _ -> ()
343
-
| None -> raise NoDescription);
378
+
(* Sanity check: ensure the description has been set before we declare
379
+
any RPCs. Here we raise an exception immediately and let everything fail. *)
380
+
(match !description with Some _ -> () | None -> raise NoDescription);
344
381
let rpcfn =
345
382
let has_named = has_named_args ty in
346
383
let rec inner : type a. a fn -> a -> T.rpcfn =
347
384
fun f impl call ->
348
385
match f with
349
-
| Function (t, f) ->
350
-
let is_opt =
351
-
match t.Param.typedef.Rpc.Types.ty with
352
-
| Rpc.Types.Option _ -> true
353
-
| _ -> false
354
-
in
355
-
(match get_arg call has_named t.Param.name is_opt with
356
-
| Ok (x, y) -> M.return (x, y)
357
-
| Error (`Msg m) -> M.fail (MarshalError m))
358
-
>>= fun (arg_rpc, call') ->
359
-
let z = Rpcmarshal.unmarshal t.Param.typedef.Rpc.Types.ty arg_rpc in
360
-
(match z with
361
-
| Ok arg -> inner f (impl arg) call'
362
-
| Error (`Msg m) -> M.fail (MarshalError m))
386
+
| Function (t, f) -> (
387
+
let is_opt =
388
+
match t.Param.typedef.Rpc.Types.ty with
389
+
| Rpc.Types.Option _ -> true
390
+
| _ -> false
391
+
in
392
+
(match get_arg call has_named t.Param.name is_opt with
393
+
| Ok (x, y) -> M.return (x, y)
394
+
| Error (`Msg m) -> M.fail (MarshalError m))
395
+
>>= fun (arg_rpc, call') ->
396
+
let z =
397
+
Rpcmarshal.unmarshal t.Param.typedef.Rpc.Types.ty arg_rpc
398
+
in
399
+
match z with
400
+
| Ok arg -> inner f (impl arg) call'
401
+
| Error (`Msg m) -> M.fail (MarshalError m))
363
402
| Returning (t, e) ->
364
-
T.bind impl (function
403
+
T.bind impl (function
365
404
| Ok x ->
366
-
let res =
367
-
Rpc.success (Rpcmarshal.marshal t.Param.typedef.Rpc.Types.ty x)
368
-
in
369
-
M.return { res with is_notification }
405
+
let res =
406
+
Rpc.success
407
+
(Rpcmarshal.marshal t.Param.typedef.Rpc.Types.ty x)
408
+
in
409
+
M.return { res with is_notification }
370
410
| Error y ->
371
-
let res =
372
-
Rpc.failure (Rpcmarshal.marshal e.Error.def.Rpc.Types.ty y)
373
-
in
374
-
M.return { res with is_notification })
375
-
|> T.get
411
+
let res =
412
+
Rpc.failure
413
+
(Rpcmarshal.marshal e.Error.def.Rpc.Types.ty y)
414
+
in
415
+
M.return { res with is_notification })
416
+
|> T.get
376
417
in
377
418
inner ty impl
378
419
in
···
380
421
(* The wire name might be different from the name *)
381
422
let wire_name = get_wire_name !description name in
382
423
Hashtbl.add funcs wire_name (Some rpcfn)
383
-
384
424
385
425
let declare_notification name a ty = declare_ true name a ty
426
+
386
427
let declare name a ty = declare_ false name a ty
387
428
end
388
429
end
389
430
390
431
module ExnM = struct
391
-
type 'a t =
392
-
| V of 'a
393
-
| E of exn
432
+
type 'a t = V of 'a | E of exn
394
433
395
434
let return x = V x
396
435
397
-
let lift f x =
398
-
match f x with
399
-
| y -> V y
400
-
| exception e -> E e
436
+
let lift f x = match f x with y -> V y | exception e -> E e
401
437
402
-
403
-
let bind x (f : 'a -> 'b t) : 'b t =
404
-
match x with
405
-
| V x -> f x
406
-
| E e -> E e
407
-
438
+
let bind x (f : 'a -> 'b t) : 'b t = match x with V x -> f x | E e -> E e
408
439
409
440
let ( >>= ) = bind
441
+
410
442
let fail e = E e
411
443
412
-
let run = function
413
-
| V x -> x
414
-
| E e -> raise e
444
+
let run = function V x -> x | E e -> raise e
415
445
end
416
446
417
447
module IdM = struct
418
448
type 'a t = T of 'a
419
449
420
450
let return x = T x
451
+
421
452
let lift f x = T (f x)
453
+
422
454
let bind (T x) f = f x
455
+
423
456
let ( >>= ) = bind
457
+
424
458
let fail e = raise e
459
+
425
460
let run (T x) = x
426
461
end
427
462
···
435
470
436
471
let internalerror : (string, t) Rpc.Types.tag =
437
472
let open Rpc.Types in
438
-
{ tname = "InternalError"
439
-
; tdescription = [ "Internal Error" ]
440
-
; tversion = Some (1, 0, 0)
441
-
; tcontents = Basic String
442
-
; tpreview =
443
-
(function
444
-
| InternalError s -> Some s)
445
-
; treview = (fun s -> InternalError s)
473
+
{
474
+
tname = "InternalError";
475
+
tdescription = [ "Internal Error" ];
476
+
tversion = Some (1, 0, 0);
477
+
tcontents = Basic String;
478
+
tpreview = (function InternalError s -> Some s);
479
+
treview = (fun s -> InternalError s);
446
480
}
447
481
448
-
449
482
(* And then we can create the 'variant' type *)
450
483
let t : t Rpc.Types.variant =
451
484
let open Rpc.Types in
452
-
{ vname = "t"
453
-
; variants = [ BoxedTag internalerror ]
454
-
; vversion = Some (1, 0, 0)
455
-
; vdefault = Some (InternalError "Unknown error tag!")
456
-
; vconstructor =
485
+
{
486
+
vname = "t";
487
+
variants = [ BoxedTag internalerror ];
488
+
vversion = Some (1, 0, 0);
489
+
vdefault = Some (InternalError "Unknown error tag!");
490
+
vconstructor =
457
491
(fun s t ->
458
492
match s with
459
-
| "InternalError" -> begin
493
+
| "InternalError" -> (
460
494
match t.tget (Basic String) with
461
495
| Ok s -> Ok (internalerror.treview s)
462
-
| Error y -> Error y
463
-
end
464
-
| s -> Error (`Msg (Printf.sprintf "Unknown tag '%s'" s)))
496
+
| Error y -> Error y)
497
+
| s -> Error (`Msg (Printf.sprintf "Unknown tag '%s'" s)));
465
498
}
466
-
467
499
468
500
let def =
469
501
let open Rpc.Types in
470
-
{ name = "default_error"
471
-
; description = [ "Errors declared as part of the interface" ]
472
-
; ty = Variant t
502
+
{
503
+
name = "default_error";
504
+
description = [ "Errors declared as part of the interface" ];
505
+
ty = Variant t;
473
506
}
474
-
475
507
476
508
let err =
477
509
let open Error in
478
-
{ def
479
-
; raiser =
480
-
(function
481
-
| InternalError s -> raise (InternalErrorExn s))
482
-
; matcher =
483
-
(function
484
-
| InternalErrorExn s -> Some (InternalError s)
485
-
| _ -> None)
510
+
{
511
+
def;
512
+
raiser = (function InternalError s -> raise (InternalErrorExn s));
513
+
matcher =
514
+
(function InternalErrorExn s -> Some (InternalError s) | _ -> None);
486
515
}
487
516
end
488
517
489
518
module Exn = struct
490
519
type rpcfn = Rpc.call -> Rpc.response
520
+
491
521
type client_implementation = unit
522
+
492
523
type server_implementation = (string, rpcfn option) Hashtbl.t
493
524
494
525
module GenClient (R : sig
···
496
527
end) =
497
528
struct
498
529
type implementation = client_implementation
530
+
499
531
type ('a, 'b) comp = 'a
532
+
500
533
type 'a res = 'a
501
534
502
535
type _ fn =
···
509
542
description := Some x;
510
543
()
511
544
545
+
let returning a err = Returning (a, err)
512
546
513
-
let returning a err = Returning (a, err)
514
547
let ( @-> ) t f = Function (t, f)
515
548
516
549
let declare_ is_notification name _ ty =
517
-
let rec inner : type b. (string * Rpc.t) list option * Rpc.t list -> b fn -> b =
550
+
let rec inner :
551
+
type b. (string * Rpc.t) list option * Rpc.t list -> b fn -> b =
518
552
fun (named, unnamed) -> function
519
-
| Function (t, f) ->
520
-
let cur_named =
521
-
match named with
522
-
| Some l -> l
523
-
| None -> []
524
-
in
525
-
fun v ->
526
-
(match t.Param.name with
527
-
| Some n ->
528
-
(match t.Param.typedef.Rpc.Types.ty, v with
529
-
| Rpc.Types.Option ty, Some v' ->
530
-
let marshalled = Rpcmarshal.marshal ty v' in
531
-
inner (Some ((n, marshalled) :: cur_named), unnamed) f
532
-
| Rpc.Types.Option _ty, None -> inner (Some cur_named, unnamed) f
533
-
| ty, v ->
534
-
let marshalled = Rpcmarshal.marshal ty v in
535
-
inner (Some ((n, marshalled) :: cur_named), unnamed) f)
536
-
| None ->
537
-
let marshalled = Rpcmarshal.marshal t.Param.typedef.Rpc.Types.ty v in
538
-
inner (named, marshalled :: unnamed) f)
539
-
| Returning (t, e) ->
540
-
let wire_name = get_wire_name !description name in
541
-
let args =
542
-
match named with
543
-
| None -> List.rev unnamed
544
-
| Some l -> Rpc.Dict l :: List.rev unnamed
545
-
in
546
-
let call' = Rpc.call wire_name args in
547
-
let call = { call' with is_notification } in
548
-
let r = R.rpc call in
549
-
if r.Rpc.success
550
-
then (
551
-
match Rpcmarshal.unmarshal t.Param.typedef.Rpc.Types.ty r.Rpc.contents with
552
-
| Ok x -> x
553
-
| Error (`Msg x) -> raise (MarshalError x))
554
-
else (
555
-
match Rpcmarshal.unmarshal e.Error.def.Rpc.Types.ty r.Rpc.contents with
556
-
| Ok x -> raise (e.Error.raiser x)
557
-
| Error (`Msg x) -> raise (MarshalError x))
553
+
| Function (t, f) -> (
554
+
let cur_named = match named with Some l -> l | None -> [] in
555
+
fun v ->
556
+
match t.Param.name with
557
+
| Some n -> (
558
+
match (t.Param.typedef.Rpc.Types.ty, v) with
559
+
| Rpc.Types.Option ty, Some v' ->
560
+
let marshalled = Rpcmarshal.marshal ty v' in
561
+
inner (Some ((n, marshalled) :: cur_named), unnamed) f
562
+
| Rpc.Types.Option _ty, None ->
563
+
inner (Some cur_named, unnamed) f
564
+
| ty, v ->
565
+
let marshalled = Rpcmarshal.marshal ty v in
566
+
inner (Some ((n, marshalled) :: cur_named), unnamed) f)
567
+
| None ->
568
+
let marshalled =
569
+
Rpcmarshal.marshal t.Param.typedef.Rpc.Types.ty v
570
+
in
571
+
inner (named, marshalled :: unnamed) f)
572
+
| Returning (t, e) -> (
573
+
let wire_name = get_wire_name !description name in
574
+
let args =
575
+
match named with
576
+
| None -> List.rev unnamed
577
+
| Some l -> Rpc.Dict l :: List.rev unnamed
578
+
in
579
+
let call' = Rpc.call wire_name args in
580
+
let call = { call' with is_notification } in
581
+
let r = R.rpc call in
582
+
if r.Rpc.success then
583
+
match
584
+
Rpcmarshal.unmarshal t.Param.typedef.Rpc.Types.ty r.Rpc.contents
585
+
with
586
+
| Ok x -> x
587
+
| Error (`Msg x) -> raise (MarshalError x)
588
+
else
589
+
match
590
+
Rpcmarshal.unmarshal e.Error.def.Rpc.Types.ty r.Rpc.contents
591
+
with
592
+
| Ok x -> raise (e.Error.raiser x)
593
+
| Error (`Msg x) -> raise (MarshalError x))
558
594
in
559
595
inner (None, []) ty
560
596
561
-
562
597
let declare name a ty = declare_ false name a ty
598
+
563
599
let declare_notification name a ty = declare_ true name a ty
564
600
end
565
601
···
571
607
match fn with
572
608
| None -> key :: acc
573
609
| Some fn ->
574
-
Hashtbl.add impl key fn;
575
-
acc)
576
-
hashtbl
577
-
[]
610
+
Hashtbl.add impl key fn;
611
+
acc)
612
+
hashtbl []
578
613
in
579
614
if unbound_impls <> [] then raise (UnboundImplementation unbound_impls);
580
615
fun call ->
581
616
let fn =
582
-
try Hashtbl.find impl call.Rpc.name with
583
-
| Not_found ->
617
+
try Hashtbl.find impl call.Rpc.name
618
+
with Not_found ->
584
619
!logfn "2";
585
620
Hashtbl.iter (fun key _ -> !logfn ("method: " ^ key)) impl;
586
621
!logfn (Printf.sprintf "Unknown method: %s" call.Rpc.name);
···
588
623
in
589
624
fn call
590
625
591
-
592
626
let combine hashtbls =
593
627
let result = Hashtbl.create 16 in
594
628
List.iter (Hashtbl.iter (fun k v -> Hashtbl.add result k v)) hashtbls;
595
629
result
596
630
597
-
598
631
module GenServer () = struct
599
632
type implementation = server_implementation
633
+
600
634
type ('a, 'b) comp = 'a
635
+
601
636
type 'a res = 'a -> unit
602
637
603
638
type _ fn =
···
605
640
| Returning : ('a Param.t * 'b Error.t) -> ('a, _) comp fn
606
641
607
642
let funcs = Hashtbl.create 20
643
+
608
644
let description = ref None
609
645
610
646
let implement x =
611
647
description := Some x;
612
648
funcs
613
649
614
-
615
650
let returning a b = Returning (a, b)
651
+
616
652
let ( @-> ) t f = Function (t, f)
617
653
618
654
type boxed_error = BoxedError : 'a Error.t -> boxed_error
···
621
657
| Function (_, f) -> get_error_ty f
622
658
| Returning (_, e) -> BoxedError e
623
659
624
-
625
660
let rec has_named_args : type a. a fn -> bool = function
626
-
| Function (t, f) ->
627
-
(match t.Param.name with
628
-
| Some _ -> true
629
-
| None -> has_named_args f)
661
+
| Function (t, f) -> (
662
+
match t.Param.name with Some _ -> true | None -> has_named_args f)
630
663
| Returning (_, _) -> false
631
-
632
664
633
665
let declare_ : bool -> string -> string list -> 'a fn -> 'a res =
634
666
fun is_notification name _ ty ->
635
667
(* We do not know the wire name yet as the description may still be unset *)
636
668
Hashtbl.add funcs name None;
637
669
fun impl ->
638
-
((* Sanity check: ensure the description has been set before we declare
639
-
any RPCs *)
640
-
match !description with
641
-
| Some _ -> ()
642
-
| None -> raise NoDescription);
670
+
(* Sanity check: ensure the description has been set before we declare
671
+
any RPCs *)
672
+
(match !description with Some _ -> () | None -> raise NoDescription);
643
673
let rpcfn =
644
674
let has_named = has_named_args ty in
645
675
let rec inner : type a. a fn -> a -> Rpc.call -> Rpc.response =
···
647
677
try
648
678
match f with
649
679
| Function (t, f) ->
650
-
let is_opt =
651
-
match t.Param.typedef.Rpc.Types.ty with
652
-
| Rpc.Types.Option _ -> true
653
-
| _ -> false
654
-
in
655
-
let arg_rpc, call' =
656
-
match get_arg call has_named t.Param.name is_opt with
657
-
| Ok (x, y) -> x, y
658
-
| Error (`Msg m) -> raise (MarshalError m)
659
-
in
660
-
let z = Rpcmarshal.unmarshal t.Param.typedef.Rpc.Types.ty arg_rpc in
661
-
let arg =
662
-
match z with
663
-
| Ok arg -> arg
664
-
| Error (`Msg m) -> raise (MarshalError m)
665
-
in
666
-
inner f (impl arg) call'
680
+
let is_opt =
681
+
match t.Param.typedef.Rpc.Types.ty with
682
+
| Rpc.Types.Option _ -> true
683
+
| _ -> false
684
+
in
685
+
let arg_rpc, call' =
686
+
match get_arg call has_named t.Param.name is_opt with
687
+
| Ok (x, y) -> (x, y)
688
+
| Error (`Msg m) -> raise (MarshalError m)
689
+
in
690
+
let z =
691
+
Rpcmarshal.unmarshal t.Param.typedef.Rpc.Types.ty arg_rpc
692
+
in
693
+
let arg =
694
+
match z with
695
+
| Ok arg -> arg
696
+
| Error (`Msg m) -> raise (MarshalError m)
697
+
in
698
+
inner f (impl arg) call'
667
699
| Returning (t, _) ->
668
-
let call =
669
-
Rpc.success (Rpcmarshal.marshal t.Param.typedef.Rpc.Types.ty impl)
670
-
in
671
-
{ call with is_notification }
672
-
with
673
-
| e ->
700
+
let call =
701
+
Rpc.success
702
+
(Rpcmarshal.marshal t.Param.typedef.Rpc.Types.ty impl)
703
+
in
704
+
{ call with is_notification }
705
+
with e -> (
674
706
let (BoxedError error_ty) = get_error_ty f in
675
-
(match error_ty.Error.matcher e with
707
+
match error_ty.Error.matcher e with
676
708
| Some y ->
677
-
Rpc.failure (Rpcmarshal.marshal error_ty.Error.def.Rpc.Types.ty y)
709
+
Rpc.failure
710
+
(Rpcmarshal.marshal error_ty.Error.def.Rpc.Types.ty y)
678
711
| None -> raise e)
679
712
in
680
713
inner ty impl
···
684
717
let wire_name = get_wire_name !description name in
685
718
Hashtbl.add funcs wire_name (Some rpcfn)
686
719
687
-
688
720
let declare name a ty = declare_ true name a ty
721
+
689
722
let declare_notification name a ty = declare_ false name a ty
690
723
end
691
724
end
+114
-125
idl/rpc.ml
+114
-125
idl/rpc.ml
···
16
16
*)
17
17
18
18
let debug = ref false
19
+
19
20
let set_debug x = debug := x
21
+
20
22
let get_debug () = !debug
21
23
22
24
type msg = [ `Msg of string ]
···
71
73
| Abstract : 'a abstract -> 'a typ
72
74
73
75
(* A type definition has a name and description *)
74
-
and 'a def =
75
-
{ name : string
76
-
; description : string list
77
-
; ty : 'a typ
78
-
}
76
+
and 'a def = { name : string; description : string list; ty : 'a typ }
79
77
80
78
and boxed_def = BoxedDef : 'a def -> boxed_def
81
79
82
-
and ('a, 's) field =
83
-
{ fname : string
84
-
; fdescription : string list
85
-
; fversion : Version.t option
86
-
; field : 'a typ
87
-
; fdefault : 'a option
88
-
; fget : 's -> 'a
89
-
; (* Lenses *)
90
-
fset : 'a -> 's -> 's
91
-
}
80
+
and ('a, 's) field = {
81
+
fname : string;
82
+
fdescription : string list;
83
+
fversion : Version.t option;
84
+
field : 'a typ;
85
+
fdefault : 'a option;
86
+
fget : 's -> 'a;
87
+
(* Lenses *)
88
+
fset : 'a -> 's -> 's;
89
+
}
92
90
93
91
and 'a boxed_field = BoxedField : ('a, 's) field -> 's boxed_field
94
92
95
-
and field_getter =
96
-
{ field_get : 'a. string -> 'a typ -> ('a, msg) result }
93
+
and field_getter = { field_get : 'a. string -> 'a typ -> ('a, msg) result }
97
94
98
-
and 'a structure =
99
-
{ sname : string
100
-
; fields : 'a boxed_field list
101
-
; version : Version.t option
102
-
; constructor : field_getter -> ('a, msg) result
103
-
}
95
+
and 'a structure = {
96
+
sname : string;
97
+
fields : 'a boxed_field list;
98
+
version : Version.t option;
99
+
constructor : field_getter -> ('a, msg) result;
100
+
}
104
101
105
-
and ('a, 's) tag =
106
-
{ tname : string
107
-
; tdescription : string list
108
-
; tversion : Version.t option
109
-
; tcontents : 'a typ
110
-
; tpreview : 's -> 'a option
111
-
; treview : 'a -> 's
112
-
}
102
+
and ('a, 's) tag = {
103
+
tname : string;
104
+
tdescription : string list;
105
+
tversion : Version.t option;
106
+
tcontents : 'a typ;
107
+
tpreview : 's -> 'a option;
108
+
treview : 'a -> 's;
109
+
}
113
110
114
111
and 'a boxed_tag = BoxedTag : ('a, 's) tag -> 's boxed_tag
115
112
116
113
and tag_getter = { tget : 'a. 'a typ -> ('a, msg) result }
117
114
118
-
and 'a variant =
119
-
{ vname : string
120
-
; variants : 'a boxed_tag list
121
-
; vdefault : 'a option
122
-
; vversion : Version.t option
123
-
; vconstructor : string -> tag_getter -> ('a, msg) result
124
-
}
115
+
and 'a variant = {
116
+
vname : string;
117
+
variants : 'a boxed_tag list;
118
+
vdefault : 'a option;
119
+
vversion : Version.t option;
120
+
vconstructor : string -> tag_getter -> ('a, msg) result;
121
+
}
125
122
126
-
and 'a abstract =
127
-
{ aname : string
128
-
; test_data : 'a list
129
-
; rpc_of : 'a -> t
130
-
; of_rpc : t -> ('a, msg) result
131
-
}
123
+
and 'a abstract = {
124
+
aname : string;
125
+
test_data : 'a list;
126
+
rpc_of : 'a -> t;
127
+
of_rpc : t -> ('a, msg) result;
128
+
}
132
129
133
130
let int = { name = "int"; ty = Basic Int; description = [ "Native integer" ] }
134
-
let int32 = { name = "int32"; ty = Basic Int32; description = [ "32-bit integer" ] }
135
-
let int64 = { name = "int64"; ty = Basic Int64; description = [ "64-bit integer" ] }
131
+
132
+
let int32 =
133
+
{ name = "int32"; ty = Basic Int32; description = [ "32-bit integer" ] }
134
+
135
+
let int64 =
136
+
{ name = "int64"; ty = Basic Int64; description = [ "64-bit integer" ] }
137
+
136
138
let bool = { name = "bool"; ty = Basic Bool; description = [ "Boolean" ] }
137
139
138
140
let float =
139
-
{ name = "float"; ty = Basic Float; description = [ "Floating-point number" ] }
141
+
{
142
+
name = "float";
143
+
ty = Basic Float;
144
+
description = [ "Floating-point number" ];
145
+
}
140
146
147
+
let string =
148
+
{ name = "string"; ty = Basic String; description = [ "String" ] }
141
149
142
-
let string = { name = "string"; ty = Basic String; description = [ "String" ] }
143
150
let char = { name = "char"; ty = Basic Char; description = [ "Char" ] }
151
+
144
152
let unit = { name = "unit"; ty = Unit; description = [ "Unit" ] }
145
153
146
154
let default_types =
147
-
[ BoxedDef int
148
-
; BoxedDef int32
149
-
; BoxedDef int64
150
-
; BoxedDef bool
151
-
; BoxedDef float
152
-
; BoxedDef string
153
-
; BoxedDef char
154
-
; BoxedDef unit
155
+
[
156
+
BoxedDef int;
157
+
BoxedDef int32;
158
+
BoxedDef int64;
159
+
BoxedDef bool;
160
+
BoxedDef float;
161
+
BoxedDef string;
162
+
BoxedDef char;
163
+
BoxedDef unit;
155
164
]
156
165
end
157
166
158
167
exception Runtime_error of string * t
168
+
159
169
exception Runtime_exception of string * string
160
170
161
171
let map_strings sep fn l = String.concat sep (List.map fn l)
···
171
181
| DateTime s -> sprintf "D(%s)" s
172
182
| Enum ts -> sprintf "[%s]" (map_strings ";" to_string ts)
173
183
| Dict ts ->
174
-
sprintf "{%s}" (map_strings ";" (fun (s, t) -> sprintf "%s:%s" s (to_string t)) ts)
184
+
sprintf "{%s}"
185
+
(map_strings ";" (fun (s, t) -> sprintf "%s:%s" s (to_string t)) ts)
175
186
| Base64 s -> sprintf "B64(%s)" s
176
187
| Null -> "N"
177
188
178
-
179
189
let rpc_of_t x = x
190
+
180
191
let rpc_of_int64 i = Int i
192
+
181
193
let rpc_of_int32 i = Int (Int64.of_int32 i)
194
+
182
195
let rpc_of_int i = Int (Int64.of_int i)
196
+
183
197
let rpc_of_bool b = Bool b
198
+
184
199
let rpc_of_float f = Float f
200
+
185
201
let rpc_of_string s = String s
202
+
186
203
let rpc_of_dateTime s = DateTime s
204
+
187
205
let rpc_of_base64 s = Base64 s
206
+
188
207
let rpc_of_unit () = Null
208
+
189
209
let rpc_of_char x = Int (Int64.of_int (Char.code x))
190
210
191
211
let int64_of_rpc = function
192
212
| Int i -> i
193
213
| String s -> Int64.of_string s
194
214
| x -> failwith (Printf.sprintf "Expected int64, got '%s'" (to_string x))
195
-
196
215
197
216
let int32_of_rpc = function
198
217
| Int i -> Int64.to_int32 i
199
218
| String s -> Int32.of_string s
200
219
| x -> failwith (Printf.sprintf "Expected int32, got '%s'" (to_string x))
201
220
202
-
203
221
let int_of_rpc = function
204
222
| Int i -> Int64.to_int i
205
223
| String s -> int_of_string s
206
224
| x -> failwith (Printf.sprintf "Expected int, got '%s'" (to_string x))
207
-
208
225
209
226
let bool_of_rpc = function
210
227
| Bool b -> b
211
228
| x -> failwith (Printf.sprintf "Expected bool, got '%s'" (to_string x))
212
229
213
-
214
230
let float_of_rpc = function
215
231
| Float f -> f
216
232
| Int i -> Int64.to_float i
217
233
| Int32 i -> Int32.to_float i
218
234
| String s -> float_of_string s
219
235
| x -> failwith (Printf.sprintf "Expected float, got '%s'" (to_string x))
220
-
221
236
222
237
let string_of_rpc = function
223
238
| String s -> s
224
239
| x -> failwith (Printf.sprintf "Expected string, got '%s'" (to_string x))
225
240
226
-
227
241
let dateTime_of_rpc = function
228
242
| DateTime s -> s
229
243
| x -> failwith (Printf.sprintf "Expected DateTime, got '%s'" (to_string x))
230
244
231
-
232
-
let base64_of_rpc = function
233
-
| _ -> failwith "Base64 Unhandled"
234
-
245
+
let base64_of_rpc = function _ -> failwith "Base64 Unhandled"
235
246
236
247
let unit_of_rpc = function
237
248
| Null -> ()
238
249
| x -> failwith (Printf.sprintf "Expected unit, got '%s'" (to_string x))
239
250
240
-
241
251
let char_of_rpc x =
242
252
let x = int_of_rpc x in
243
-
if x < 0 || x > 255
244
-
then failwith (Printf.sprintf "Char out of range (%d)" x)
253
+
if x < 0 || x > 255 then failwith (Printf.sprintf "Char out of range (%d)" x)
245
254
else Char.chr x
246
-
247
255
248
256
let t_of_rpc t = t
249
257
···
252
260
| Enum (String s :: ss) -> Enum (String (String.lowercase_ascii s) :: ss)
253
261
| x -> x
254
262
255
-
256
263
module ResultUnmarshallers = struct
257
264
let error_msg m = Error (`Msg m)
265
+
258
266
let ok x = Ok x
259
267
260
268
let int64_of_rpc = function
261
269
| Int i -> ok i
262
-
| String s ->
263
-
(try ok (Int64.of_string s) with
264
-
| _ -> error_msg (Printf.sprintf "Expected int64, got string '%s'" s))
270
+
| String s -> (
271
+
try ok (Int64.of_string s)
272
+
with _ ->
273
+
error_msg (Printf.sprintf "Expected int64, got string '%s'" s))
265
274
| x -> error_msg (Printf.sprintf "Expected int64, got '%s'" (to_string x))
266
-
267
275
268
276
let int32_of_rpc = function
269
277
| Int i -> ok (Int64.to_int32 i)
270
-
| String s ->
271
-
(try ok (Int32.of_string s) with
272
-
| _ -> error_msg (Printf.sprintf "Expected int32, got string '%s'" s))
278
+
| String s -> (
279
+
try ok (Int32.of_string s)
280
+
with _ ->
281
+
error_msg (Printf.sprintf "Expected int32, got string '%s'" s))
273
282
| x -> error_msg (Printf.sprintf "Expected int32, got '%s'" (to_string x))
274
283
275
-
276
284
let int_of_rpc = function
277
285
| Int i -> ok (Int64.to_int i)
278
-
| String s ->
279
-
(try ok (int_of_string s) with
280
-
| _ -> error_msg (Printf.sprintf "Expected int, got string '%s'" s))
286
+
| String s -> (
287
+
try ok (int_of_string s)
288
+
with _ -> error_msg (Printf.sprintf "Expected int, got string '%s'" s))
281
289
| x -> error_msg (Printf.sprintf "Expected int, got '%s'" (to_string x))
282
-
283
290
284
291
let bool_of_rpc = function
285
292
| Bool b -> ok b
286
293
| x -> error_msg (Printf.sprintf "Expected bool, got '%s'" (to_string x))
287
294
288
-
289
295
let float_of_rpc = function
290
296
| Float f -> ok f
291
297
| Int i -> ok (Int64.to_float i)
292
298
| Int32 i -> ok (Int32.to_float i)
293
-
| String s ->
294
-
(try ok (float_of_string s) with
295
-
| _ -> error_msg (Printf.sprintf "Expected float, got string '%s'" s))
299
+
| String s -> (
300
+
try ok (float_of_string s)
301
+
with _ ->
302
+
error_msg (Printf.sprintf "Expected float, got string '%s'" s))
296
303
| x -> error_msg (Printf.sprintf "Expected float, got '%s'" (to_string x))
297
-
298
304
299
305
let string_of_rpc = function
300
306
| String s -> ok s
301
307
| x -> error_msg (Printf.sprintf "Expected string, got '%s'" (to_string x))
302
308
303
-
304
309
let dateTime_of_rpc = function
305
310
| DateTime s -> ok s
306
-
| x -> error_msg (Printf.sprintf "Expected DateTime, got '%s'" (to_string x))
307
-
311
+
| x ->
312
+
error_msg (Printf.sprintf "Expected DateTime, got '%s'" (to_string x))
308
313
309
-
let base64_of_rpc = function
310
-
| _ -> error_msg "Base64 Unhandled"
311
-
314
+
let base64_of_rpc = function _ -> error_msg "Base64 Unhandled"
312
315
313
316
let unit_of_rpc = function
314
317
| Null -> ok ()
315
318
| x -> error_msg (Printf.sprintf "Expected unit, got '%s'" (to_string x))
316
319
317
-
318
320
let char_of_rpc x =
319
-
match (int_of_rpc x) with
321
+
match int_of_rpc x with
320
322
| Ok x ->
321
-
if x < 0 || x > 255
322
-
then error_msg (Printf.sprintf "Char out of range (%d)" x)
323
+
if x < 0 || x > 255 then
324
+
error_msg (Printf.sprintf "Char out of range (%d)" x)
323
325
else ok (Char.chr x)
324
326
| Error y -> Error y
325
327
···
327
329
end
328
330
329
331
let struct_extend rpc default_rpc =
330
-
match rpc, default_rpc with
332
+
match (rpc, default_rpc) with
331
333
| Dict real, Dict default_fields ->
332
-
Dict
333
-
(List.fold_left
334
-
(fun real (f, default) ->
335
-
if List.mem_assoc f real then real else (f, default) :: real)
336
-
real
337
-
default_fields)
334
+
Dict
335
+
(List.fold_left
336
+
(fun real (f, default) ->
337
+
if List.mem_assoc f real then real else (f, default) :: real)
338
+
real default_fields)
338
339
| _, _ -> rpc
339
-
340
340
341
341
type callback = string list -> t -> unit
342
342
343
-
type call =
344
-
{ name : string
345
-
; params : t list
346
-
; is_notification : bool
347
-
}
343
+
type call = { name : string; params : t list; is_notification : bool }
348
344
349
345
let call name params = { name; params; is_notification = false }
346
+
350
347
let notification name params = { name; params; is_notification = true }
351
348
352
349
let string_of_call call =
353
-
Printf.sprintf
354
-
"-> %s(%s)"
355
-
call.name
350
+
Printf.sprintf "-> %s(%s)" call.name
356
351
(String.concat "," (List.map to_string call.params))
357
352
358
-
359
-
type response =
360
-
{ success : bool
361
-
; contents : t
362
-
; is_notification : bool
363
-
}
353
+
type response = { success : bool; contents : t; is_notification : bool }
364
354
365
355
let string_of_response response =
366
-
Printf.sprintf
367
-
"<- %s(%s)"
356
+
Printf.sprintf "<- %s(%s)"
368
357
(if response.success then "success" else "failure")
369
358
(to_string response.contents)
370
-
371
359
372
360
(* is_notification is to be set as true only if the call was a notification *)
373
361
374
362
let success v = { success = true; contents = v; is_notification = false }
363
+
375
364
let failure v = { success = false; contents = v; is_notification = false }
+89
-58
idl/rpc.mli
+89
-58
idl/rpc.mli
···
15
15
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
16
16
*)
17
17
18
-
(** {2 Value} *)
19
18
type msg = [ `Msg of string ]
19
+
(** {2 Value} *)
20
20
21
21
type t =
22
22
| Int of int64
···
65
65
| Variant : 'a variant -> 'a typ
66
66
| Abstract : 'a abstract -> 'a typ
67
67
68
-
and 'a def =
69
-
{ name : string
70
-
; description : string list
71
-
; ty : 'a typ
72
-
}
68
+
and 'a def = { name : string; description : string list; ty : 'a typ }
73
69
74
70
and boxed_def = BoxedDef : 'a def -> boxed_def
75
71
76
-
and ('a, 's) field =
77
-
{ fname : string
78
-
; fdescription : string list
79
-
; fversion : Version.t option
80
-
; field : 'a typ
81
-
; fdefault : 'a option
82
-
; fget : 's -> 'a
83
-
; fset : 'a -> 's -> 's
84
-
}
72
+
and ('a, 's) field = {
73
+
fname : string;
74
+
fdescription : string list;
75
+
fversion : Version.t option;
76
+
field : 'a typ;
77
+
fdefault : 'a option;
78
+
fget : 's -> 'a;
79
+
fset : 'a -> 's -> 's;
80
+
}
85
81
86
82
and 'a boxed_field = BoxedField : ('a, 's) field -> 's boxed_field
87
83
88
-
and field_getter =
89
-
{ field_get : 'a. string -> 'a typ -> ('a, msg) result }
84
+
and field_getter = { field_get : 'a. string -> 'a typ -> ('a, msg) result }
90
85
91
-
and 'a structure =
92
-
{ sname : string
93
-
; fields : 'a boxed_field list
94
-
; version : Version.t option
95
-
; constructor : field_getter -> ('a, msg) result
96
-
}
86
+
and 'a structure = {
87
+
sname : string;
88
+
fields : 'a boxed_field list;
89
+
version : Version.t option;
90
+
constructor : field_getter -> ('a, msg) result;
91
+
}
97
92
98
-
and ('a, 's) tag =
99
-
{ tname : string
100
-
; tdescription : string list
101
-
; tversion : Version.t option
102
-
; tcontents : 'a typ
103
-
; tpreview : 's -> 'a option
104
-
; (* Prism *)
105
-
treview : 'a -> 's
106
-
}
93
+
and ('a, 's) tag = {
94
+
tname : string;
95
+
tdescription : string list;
96
+
tversion : Version.t option;
97
+
tcontents : 'a typ;
98
+
tpreview : 's -> 'a option;
99
+
(* Prism *)
100
+
treview : 'a -> 's;
101
+
}
107
102
108
103
and 'a boxed_tag = BoxedTag : ('a, 's) tag -> 's boxed_tag
109
104
110
105
and tag_getter = { tget : 'a. 'a typ -> ('a, msg) result }
111
106
112
-
and 'a variant =
113
-
{ vname : string
114
-
; variants : 'a boxed_tag list
115
-
; vdefault : 'a option
116
-
; vversion : Version.t option
117
-
; vconstructor : string -> tag_getter -> ('a, msg) result
118
-
}
107
+
and 'a variant = {
108
+
vname : string;
109
+
variants : 'a boxed_tag list;
110
+
vdefault : 'a option;
111
+
vversion : Version.t option;
112
+
vconstructor : string -> tag_getter -> ('a, msg) result;
113
+
}
119
114
120
-
and 'a abstract =
121
-
{ aname : string
122
-
; test_data : 'a list
123
-
; rpc_of : 'a -> t
124
-
; of_rpc : t -> ('a, msg) result
125
-
}
115
+
and 'a abstract = {
116
+
aname : string;
117
+
test_data : 'a list;
118
+
rpc_of : 'a -> t;
119
+
of_rpc : t -> ('a, msg) result;
120
+
}
126
121
127
122
val int : int def
123
+
128
124
val int32 : int32 def
125
+
129
126
val int64 : int64 def
127
+
130
128
val bool : bool def
129
+
131
130
val float : float def
131
+
132
132
val string : string def
133
+
133
134
val char : char def
135
+
134
136
val unit : unit def
137
+
135
138
val default_types : boxed_def list
136
139
end
137
140
138
141
(** {2 Basic constructors} *)
139
142
140
143
val rpc_of_int64 : int64 -> t
144
+
141
145
val rpc_of_int32 : int32 -> t
146
+
142
147
val rpc_of_int : int -> t
148
+
143
149
val rpc_of_bool : bool -> t
150
+
144
151
val rpc_of_float : float -> t
152
+
145
153
val rpc_of_string : string -> t
154
+
146
155
val rpc_of_dateTime : string -> t
156
+
147
157
val rpc_of_base64 : string -> t
158
+
148
159
val rpc_of_t : t -> t
160
+
149
161
val rpc_of_unit : unit -> t
162
+
150
163
val rpc_of_char : char -> t
164
+
151
165
val int64_of_rpc : t -> int64
166
+
152
167
val int32_of_rpc : t -> int32
168
+
153
169
val int_of_rpc : t -> int
170
+
154
171
val bool_of_rpc : t -> bool
172
+
155
173
val float_of_rpc : t -> float
174
+
156
175
val string_of_rpc : t -> string
176
+
157
177
val dateTime_of_rpc : t -> string
178
+
158
179
val base64_of_rpc : t -> string
180
+
159
181
val t_of_rpc : t -> t
182
+
160
183
val char_of_rpc : t -> char
184
+
161
185
val unit_of_rpc : t -> unit
162
186
163
187
module ResultUnmarshallers : sig
164
188
val int64_of_rpc : t -> (int64, msg) result
189
+
165
190
val int32_of_rpc : t -> (int32, msg) result
191
+
166
192
val int_of_rpc : t -> (int, msg) result
193
+
167
194
val bool_of_rpc : t -> (bool, msg) result
195
+
168
196
val float_of_rpc : t -> (float, msg) result
197
+
169
198
val string_of_rpc : t -> (string, msg) result
199
+
170
200
val dateTime_of_rpc : t -> (string, msg) result
201
+
171
202
val base64_of_rpc : t -> (string, msg) result
203
+
172
204
val t_of_rpc : t -> (t, msg) result
205
+
173
206
val unit_of_rpc : t -> (unit, msg) result
207
+
174
208
val char_of_rpc : t -> (char, msg) result
175
209
end
176
210
···
178
212
179
213
type callback = string list -> t -> unit
180
214
181
-
type call =
182
-
{ name : string
183
-
; params : t list
184
-
; is_notification : bool
185
-
}
215
+
type call = { name : string; params : t list; is_notification : bool }
186
216
187
217
val call : string -> t list -> call
218
+
188
219
val notification : string -> t list -> call
220
+
189
221
val string_of_call : call -> string
190
222
191
223
(** {2 Responses} *)
192
224
193
-
type response =
194
-
{ success : bool
195
-
; contents : t
196
-
; is_notification : bool
197
-
}
225
+
type response = { success : bool; contents : t; is_notification : bool }
198
226
199
227
val string_of_response : response -> string
228
+
200
229
val success : t -> response
230
+
201
231
val failure : t -> response
202
232
203
233
(** {2 Run-time errors} *)
204
234
205
235
exception Runtime_error of string * t
236
+
206
237
exception Runtime_exception of string * string
207
238
208
-
(** {2 Debug options} *)
209
239
val set_debug : bool -> unit
240
+
(** {2 Debug options} *)
210
241
211
242
val get_debug : unit -> bool
212
243
213
-
(** Helper *)
214
244
val lowerfn : t -> t
245
+
(** Helper *)
215
246
247
+
val struct_extend : t -> t -> t
216
248
(** [struct_extend rpc1 rpc2] first checks that [rpc1] and [rpc2] are both
217
249
* dictionaries. If this is the case then [struct_extend] will create a new
218
250
* [Rpc.t] which contains all key-value pairs from [rpc1], as well as all
219
251
* key-value pairs from [rpc2] for which the key does not exist in [rpc1]. *)
220
-
val struct_extend : t -> t -> t
+185
-177
idl/rpcmarshal.ml
+185
-177
idl/rpcmarshal.ml
···
5
5
6
6
let tailrec_map f l = List.rev_map f l |> List.rev
7
7
8
-
let (>>|) x f = match x with | Ok x -> Ok (f x) | Error y -> Error y
9
-
let (>>=) x f = match x with | Ok x -> f x | Error y -> Error y
8
+
let ( >>| ) x f = match x with Ok x -> Ok (f x) | Error y -> Error y
9
+
10
+
let ( >>= ) x f = match x with Ok x -> f x | Error y -> Error y
11
+
10
12
let return x = Ok x
13
+
11
14
let ok x = Ok x
12
15
13
16
let rec unmarshal : type a. a typ -> Rpc.t -> (a, err) result =
···
17
20
let list_helper typ l =
18
21
List.fold_left
19
22
(fun acc v ->
20
-
match acc, unmarshal typ v with
23
+
match (acc, unmarshal typ v) with
21
24
| Ok a, Ok v -> Ok (v :: a)
22
25
| _, Error (`Msg s) ->
23
-
Error
24
-
(`Msg
25
-
(Printf.sprintf
26
-
"Failed to unmarshal array: %s (when unmarshalling: %s)"
27
-
s
28
-
(Rpc.to_string v)))
26
+
Error
27
+
(`Msg
28
+
(Printf.sprintf
29
+
"Failed to unmarshal array: %s (when unmarshalling: %s)" s
30
+
(Rpc.to_string v)))
29
31
| x, _ -> x)
30
-
(Ok [])
31
-
l
32
+
(Ok []) l
32
33
>>| List.rev
33
34
in
34
35
match t with
···
41
42
| Basic Char -> int_of_rpc v >>| Char.chr
42
43
| DateTime -> dateTime_of_rpc v
43
44
| Base64 -> base64_of_rpc v
44
-
| Array typ ->
45
-
(match v with
46
-
| Enum xs -> list_helper typ xs >>| Array.of_list
47
-
| _ -> Error (`Msg "Expecting Array"))
48
-
| List (Tuple (Basic String, typ)) ->
49
-
(match v with
50
-
| Dict xs ->
51
-
let keys = tailrec_map fst xs in
52
-
let vs = tailrec_map snd xs in
53
-
list_helper typ vs >>= fun vs -> return (List.combine keys vs)
54
-
| _ -> Error (`Msg "Unhandled"))
55
-
| Dict (basic, typ) ->
56
-
(match v with
57
-
| Dict xs ->
58
-
(match basic with
59
-
| String ->
60
-
let keys = tailrec_map fst xs in
61
-
let vs = tailrec_map snd xs in
62
-
list_helper typ vs >>= fun vs -> return (List.combine keys vs)
63
-
| _ -> Error (`Msg "Expecting something other than a Dict type"))
64
-
| _ -> Error (`Msg "Unhandled"))
65
-
| List typ ->
66
-
(match v with
67
-
| Enum xs -> list_helper typ xs
68
-
| _ -> Error (`Msg "Expecting array"))
45
+
| Array typ -> (
46
+
match v with
47
+
| Enum xs -> list_helper typ xs >>| Array.of_list
48
+
| _ -> Error (`Msg "Expecting Array"))
49
+
| List (Tuple (Basic String, typ)) -> (
50
+
match v with
51
+
| Dict xs ->
52
+
let keys = tailrec_map fst xs in
53
+
let vs = tailrec_map snd xs in
54
+
list_helper typ vs >>= fun vs -> return (List.combine keys vs)
55
+
| _ -> Error (`Msg "Unhandled"))
56
+
| Dict (basic, typ) -> (
57
+
match v with
58
+
| Dict xs -> (
59
+
match basic with
60
+
| String ->
61
+
let keys = tailrec_map fst xs in
62
+
let vs = tailrec_map snd xs in
63
+
list_helper typ vs >>= fun vs -> return (List.combine keys vs)
64
+
| _ -> Error (`Msg "Expecting something other than a Dict type"))
65
+
| _ -> Error (`Msg "Unhandled"))
66
+
| List typ -> (
67
+
match v with
68
+
| Enum xs -> list_helper typ xs
69
+
| _ -> Error (`Msg "Expecting array"))
69
70
| Unit -> unit_of_rpc v
70
-
| Option t ->
71
-
(match v with
72
-
| Enum [ x ] -> unmarshal t x >>= fun x -> return (Some x)
73
-
| Enum [] -> return None
74
-
| y ->
75
-
Error (`Msg
76
-
(Printf.sprintf "Expecting an Enum value, got '%s'" (Rpc.to_string y))))
77
-
| Tuple (t1, t2) ->
78
-
(match v, t2 with
79
-
| Rpc.Enum list, Tuple (_, _) ->
80
-
unmarshal t1 (List.hd list)
81
-
>>= fun v1 -> unmarshal t2 (Rpc.Enum (List.tl list)) >>= fun v2 -> Ok (v1, v2)
82
-
| Rpc.Enum [ x; y ], _ ->
83
-
unmarshal t1 x >>= fun v1 -> unmarshal t2 y >>= fun v2 -> Ok (v1, v2)
84
-
| Rpc.Enum _, _ -> Error (`Msg "Too many items in a tuple!")
85
-
| _, _ -> Error (`Msg "Expecting Rpc.Enum when unmarshalling a tuple"))
86
-
| Tuple3 (t1, t2, t3) ->
87
-
(match v with
88
-
| Rpc.Enum [ x; y; z ] ->
89
-
unmarshal t1 x
90
-
>>= fun v1 ->
91
-
unmarshal t2 y >>= fun v2 -> unmarshal t3 z >>= fun v3 -> Ok (v1, v2, v3)
92
-
| Rpc.Enum _ ->
93
-
Error (`Msg "Expecting precisely 3 items when unmarshalling a Tuple3")
94
-
| _ -> Error (`Msg "Expecting Rpc.Enum when unmarshalling a tuple3"))
95
-
| Tuple4 (t1, t2, t3, t4) ->
96
-
(match v with
97
-
| Rpc.Enum [ x; y; z; a ] ->
98
-
unmarshal t1 x
99
-
>>= fun v1 ->
100
-
unmarshal t2 y
101
-
>>= fun v2 ->
102
-
unmarshal t3 z >>= fun v3 -> unmarshal t4 a >>= fun v4 -> Ok (v1, v2, v3, v4)
103
-
| Rpc.Enum _ ->
104
-
Error (`Msg
105
-
"Expecting precisely 4 items in an Enum when unmarshalling a Tuple4")
106
-
| _ -> Error (`Msg "Expecting Rpc.Enum when unmarshalling a tuple4"))
107
-
| Struct { constructor; sname; _ } ->
108
-
(match v with
109
-
| Rpc.Dict keys' ->
110
-
let keys = List.map (fun (s, v) -> String.lowercase_ascii s, v) keys' in
111
-
constructor
112
-
{ field_get =
113
-
(let x : type a. string -> a typ -> (a, Rpc.msg) result =
114
-
fun s ty ->
115
-
let s = String.lowercase_ascii s in
116
-
match ty with
117
-
| Option x ->
118
-
(try List.assoc s keys |> unmarshal x >>= fun o -> return (Some o) with
119
-
| _ -> return None)
120
-
| y ->
121
-
(try List.assoc s keys |> unmarshal y with
122
-
| Not_found ->
123
-
Error (`Msg
124
-
(Printf.sprintf
125
-
"No value found for key: '%s' when unmarshalling '%s'"
126
-
s
127
-
sname)))
128
-
in
129
-
x)
130
-
}
131
-
| _ -> Error (`Msg (Printf.sprintf "Expecting Rpc.Dict when unmarshalling a '%s'" sname)))
71
+
| Option t -> (
72
+
match v with
73
+
| Enum [ x ] -> unmarshal t x >>= fun x -> return (Some x)
74
+
| Enum [] -> return None
75
+
| y ->
76
+
Error
77
+
(`Msg
78
+
(Printf.sprintf "Expecting an Enum value, got '%s'"
79
+
(Rpc.to_string y))))
80
+
| Tuple (t1, t2) -> (
81
+
match (v, t2) with
82
+
| Rpc.Enum list, Tuple (_, _) ->
83
+
unmarshal t1 (List.hd list) >>= fun v1 ->
84
+
unmarshal t2 (Rpc.Enum (List.tl list)) >>= fun v2 -> Ok (v1, v2)
85
+
| Rpc.Enum [ x; y ], _ ->
86
+
unmarshal t1 x >>= fun v1 ->
87
+
unmarshal t2 y >>= fun v2 -> Ok (v1, v2)
88
+
| Rpc.Enum _, _ -> Error (`Msg "Too many items in a tuple!")
89
+
| _, _ -> Error (`Msg "Expecting Rpc.Enum when unmarshalling a tuple"))
90
+
| Tuple3 (t1, t2, t3) -> (
91
+
match v with
92
+
| Rpc.Enum [ x; y; z ] ->
93
+
unmarshal t1 x >>= fun v1 ->
94
+
unmarshal t2 y >>= fun v2 ->
95
+
unmarshal t3 z >>= fun v3 -> Ok (v1, v2, v3)
96
+
| Rpc.Enum _ ->
97
+
Error (`Msg "Expecting precisely 3 items when unmarshalling a Tuple3")
98
+
| _ -> Error (`Msg "Expecting Rpc.Enum when unmarshalling a tuple3"))
99
+
| Tuple4 (t1, t2, t3, t4) -> (
100
+
match v with
101
+
| Rpc.Enum [ x; y; z; a ] ->
102
+
unmarshal t1 x >>= fun v1 ->
103
+
unmarshal t2 y >>= fun v2 ->
104
+
unmarshal t3 z >>= fun v3 ->
105
+
unmarshal t4 a >>= fun v4 -> Ok (v1, v2, v3, v4)
106
+
| Rpc.Enum _ ->
107
+
Error
108
+
(`Msg
109
+
"Expecting precisely 4 items in an Enum when unmarshalling a \
110
+
Tuple4")
111
+
| _ -> Error (`Msg "Expecting Rpc.Enum when unmarshalling a tuple4"))
112
+
| Struct { constructor; sname; _ } -> (
113
+
match v with
114
+
| Rpc.Dict keys' ->
115
+
let keys =
116
+
List.map (fun (s, v) -> (String.lowercase_ascii s, v)) keys'
117
+
in
118
+
constructor
119
+
{
120
+
field_get =
121
+
(let x : type a. string -> a typ -> (a, Rpc.msg) result =
122
+
fun s ty ->
123
+
let s = String.lowercase_ascii s in
124
+
match ty with
125
+
| Option x -> (
126
+
try
127
+
List.assoc s keys |> unmarshal x >>= fun o ->
128
+
return (Some o)
129
+
with _ -> return None)
130
+
| y -> (
131
+
try List.assoc s keys |> unmarshal y
132
+
with Not_found ->
133
+
Error
134
+
(`Msg
135
+
(Printf.sprintf
136
+
"No value found for key: '%s' when \
137
+
unmarshalling '%s'"
138
+
s sname)))
139
+
in
140
+
x);
141
+
}
142
+
| _ ->
143
+
Error
144
+
(`Msg
145
+
(Printf.sprintf "Expecting Rpc.Dict when unmarshalling a '%s'"
146
+
sname)))
132
147
| Variant { vconstructor; _ } ->
133
-
(match v with
134
-
| Rpc.String name -> ok (name, Rpc.Null)
135
-
| Rpc.Enum [ Rpc.String name; contents ] -> ok (name, contents)
136
-
| _ -> Error (`Msg "Expecting String or Enum when unmarshalling a variant"))
137
-
>>= fun (name, contents) ->
138
-
let constr = { tget = (fun typ -> unmarshal typ contents) } in
139
-
vconstructor name constr
148
+
(match v with
149
+
| Rpc.String name -> ok (name, Rpc.Null)
150
+
| Rpc.Enum [ Rpc.String name; contents ] -> ok (name, contents)
151
+
| _ ->
152
+
Error (`Msg "Expecting String or Enum when unmarshalling a variant"))
153
+
>>= fun (name, contents) ->
154
+
let constr = { tget = (fun typ -> unmarshal typ contents) } in
155
+
vconstructor name constr
140
156
| Abstract { of_rpc; _ } -> of_rpc v
141
-
142
157
143
158
let rec marshal : type a. a typ -> a -> Rpc.t =
144
159
fun t v ->
···
160
175
| Base64 -> rpc_of_base64 v
161
176
| Array typ -> Enum (tailrec_map (marshal typ) (Array.to_list v))
162
177
| List (Tuple (Basic String, typ)) ->
163
-
Dict (tailrec_map (fun (x, y) -> x, marshal typ y) v)
178
+
Dict (tailrec_map (fun (x, y) -> (x, marshal typ y)) v)
164
179
| List typ -> Enum (tailrec_map (marshal typ) v)
165
-
| Dict (String, typ) -> Rpc.Dict (tailrec_map (fun (k, v) -> k, marshal typ v) v)
180
+
| Dict (String, typ) ->
181
+
Rpc.Dict (tailrec_map (fun (k, v) -> (k, marshal typ v)) v)
166
182
| Dict (basic, typ) ->
167
-
Rpc.Enum
168
-
(tailrec_map (fun (k, v) -> Rpc.Enum [ rpc_of_basic basic k; marshal typ v ]) v)
183
+
Rpc.Enum
184
+
(tailrec_map
185
+
(fun (k, v) -> Rpc.Enum [ rpc_of_basic basic k; marshal typ v ])
186
+
v)
169
187
| Unit -> rpc_of_unit v
170
188
| Option ty ->
171
-
Rpc.Enum
172
-
(match v with
173
-
| Some x -> [ marshal ty x ]
174
-
| None -> [])
175
-
| Tuple (x, (Tuple (_, _) as y)) ->
176
-
(match marshal y (snd v) with
177
-
| Rpc.Enum xs -> Rpc.Enum (marshal x (fst v) :: xs)
178
-
| _ -> failwith "Marshalling a tuple should always give an Enum")
189
+
Rpc.Enum (match v with Some x -> [ marshal ty x ] | None -> [])
190
+
| Tuple (x, (Tuple (_, _) as y)) -> (
191
+
match marshal y (snd v) with
192
+
| Rpc.Enum xs -> Rpc.Enum (marshal x (fst v) :: xs)
193
+
| _ -> failwith "Marshalling a tuple should always give an Enum")
179
194
| Tuple (x, y) -> Rpc.Enum [ marshal x (fst v); marshal y (snd v) ]
180
195
| Tuple3 (x, y, z) ->
181
-
let vx, vy, vz = v in
182
-
Rpc.Enum [ marshal x vx; marshal y vy; marshal z vz ]
196
+
let vx, vy, vz = v in
197
+
Rpc.Enum [ marshal x vx; marshal y vy; marshal z vz ]
183
198
| Tuple4 (x, y, z, a) ->
184
-
let vx, vy, vz, va = v in
185
-
Rpc.Enum [ marshal x vx; marshal y vy; marshal z vz; marshal a va ]
199
+
let vx, vy, vz, va = v in
200
+
Rpc.Enum [ marshal x vx; marshal y vy; marshal z vz; marshal a va ]
186
201
| Struct { fields; _ } ->
187
-
let fields =
202
+
let fields =
203
+
List.fold_left
204
+
(fun acc f ->
205
+
match f with
206
+
| BoxedField f -> (
207
+
let value = marshal f.field (f.fget v) in
208
+
match (f.field, value) with
209
+
| Option _, Rpc.Enum [] -> acc
210
+
| Option _, Rpc.Enum [ x ] -> (f.fname, x) :: acc
211
+
| _, _ -> (f.fname, value) :: acc))
212
+
[] fields
213
+
in
214
+
Rpc.Dict fields
215
+
| Variant { variants; _ } ->
188
216
List.fold_left
189
-
(fun acc f ->
190
-
match f with
191
-
| BoxedField f ->
192
-
let value = marshal f.field (f.fget v) in
193
-
(match f.field, value with
194
-
| Option _, Rpc.Enum [] -> acc
195
-
| Option _, Rpc.Enum [ x ] -> (f.fname, x) :: acc
196
-
| _, _ -> (f.fname, value) :: acc))
197
-
[]
198
-
fields
199
-
in
200
-
Rpc.Dict fields
201
-
| Variant { variants; _ } ->
202
-
List.fold_left
203
-
(fun acc t ->
204
-
match t with
205
-
| BoxedTag t ->
206
-
(match t.tpreview v with
207
-
| Some x ->
208
-
(match marshal t.tcontents x with
209
-
| Rpc.Null -> Rpc.String t.tname
210
-
| y -> Rpc.Enum [ Rpc.String t.tname; y ])
211
-
| None -> acc))
212
-
Rpc.Null
213
-
variants
217
+
(fun acc t ->
218
+
match t with
219
+
| BoxedTag t -> (
220
+
match t.tpreview v with
221
+
| Some x -> (
222
+
match marshal t.tcontents x with
223
+
| Rpc.Null -> Rpc.String t.tname
224
+
| y -> Rpc.Enum [ Rpc.String t.tname; y ])
225
+
| None -> acc))
226
+
Rpc.Null variants
214
227
| Abstract { rpc_of; _ } -> rpc_of v
215
228
216
-
217
229
let ocaml_of_basic : type a. a basic -> string = function
218
230
| Int64 -> "int64"
219
231
| Int32 -> "int32"
···
223
235
| Bool -> "bool"
224
236
| Char -> "char"
225
237
226
-
227
238
let rec ocaml_of_t : type a. a typ -> string = function
228
239
| Basic b -> ocaml_of_basic b
229
240
| DateTime -> "string"
230
241
| Base64 -> "base64"
231
242
| Array t -> ocaml_of_t t ^ " list"
232
243
| List t -> ocaml_of_t t ^ " list"
233
-
| Dict (b, t) -> Printf.sprintf "(%s * %s) list" (ocaml_of_basic b) (ocaml_of_t t)
244
+
| Dict (b, t) ->
245
+
Printf.sprintf "(%s * %s) list" (ocaml_of_basic b) (ocaml_of_t t)
234
246
| Unit -> "unit"
235
247
| Option t -> ocaml_of_t t ^ " option"
236
248
| Tuple (a, b) -> Printf.sprintf "(%s * %s)" (ocaml_of_t a) (ocaml_of_t b)
237
249
| Tuple3 (a, b, c) ->
238
-
Printf.sprintf "(%s * %s * %s)" (ocaml_of_t a) (ocaml_of_t b) (ocaml_of_t c)
250
+
Printf.sprintf "(%s * %s * %s)" (ocaml_of_t a) (ocaml_of_t b)
251
+
(ocaml_of_t c)
239
252
| Tuple4 (a, b, c, d) ->
240
-
Printf.sprintf
241
-
"(%s * %s * %s * %s)"
242
-
(ocaml_of_t a)
243
-
(ocaml_of_t b)
244
-
(ocaml_of_t c)
245
-
(ocaml_of_t d)
253
+
Printf.sprintf "(%s * %s * %s * %s)" (ocaml_of_t a) (ocaml_of_t b)
254
+
(ocaml_of_t c) (ocaml_of_t d)
246
255
| Struct { fields; _ } ->
247
-
let fields =
248
-
List.map
249
-
(function
250
-
| BoxedField f -> Printf.sprintf "%s: %s;" f.fname (ocaml_of_t f.field))
251
-
fields
252
-
in
253
-
Printf.sprintf "{ %s }" (String.concat " " fields)
256
+
let fields =
257
+
List.map
258
+
(function
259
+
| BoxedField f ->
260
+
Printf.sprintf "%s: %s;" f.fname (ocaml_of_t f.field))
261
+
fields
262
+
in
263
+
Printf.sprintf "{ %s }" (String.concat " " fields)
254
264
| Variant { variants; _ } ->
255
-
let tags =
256
-
List.map
257
-
(function
258
-
| BoxedTag t ->
259
-
Printf.sprintf
260
-
"| %s (%s) (** %s *)"
261
-
t.tname
262
-
(ocaml_of_t t.tcontents)
263
-
(String.concat " " t.tdescription))
264
-
variants
265
-
in
266
-
String.concat " " tags
265
+
let tags =
266
+
List.map
267
+
(function
268
+
| BoxedTag t ->
269
+
Printf.sprintf "| %s (%s) (** %s *)" t.tname
270
+
(ocaml_of_t t.tcontents)
271
+
(String.concat " " t.tdescription))
272
+
variants
273
+
in
274
+
String.concat " " tags
267
275
| Abstract _ -> "<abstract>"
+69
-40
idl/toplevel_api.ml
+69
-40
idl/toplevel_api.ml
···
3
3
open Rpc
4
4
open Idl
5
5
6
-
(** An area to be highlighted *)
7
-
type highlight =
8
-
{ line1 : int
9
-
; line2 : int
10
-
; col1 : int
11
-
; col2 : int
12
-
}
6
+
type highlight = { line1 : int; line2 : int; col1 : int; col2 : int }
13
7
[@@deriving rpcty]
8
+
(** An area to be highlighted *)
14
9
15
-
(** Represents the result of executing a toplevel phrase *)
16
-
type exec_result =
17
-
{ stdout : string option
18
-
; stderr : string option
19
-
; sharp_ppf : string option
20
-
; caml_ppf : string option
21
-
; highlight : highlight option
22
-
}
10
+
type exec_result = {
11
+
stdout : string option;
12
+
stderr : string option;
13
+
sharp_ppf : string option;
14
+
caml_ppf : string option;
15
+
highlight : highlight option;
16
+
}
23
17
[@@deriving rpcty]
18
+
(** Represents the result of executing a toplevel phrase *)
24
19
25
-
(** The result returned by a 'complete' call. *)
26
-
type completion_result =
27
-
{ n : int
28
-
(** The position in the input string from where the completions may be
20
+
type completion_result = {
21
+
n : int;
22
+
(** The position in the input string from where the completions may be
29
23
inserted *)
30
-
; completions : string list (** The list of possible completions *)
31
-
}
24
+
completions : string list; (** The list of possible completions *)
25
+
}
32
26
[@@deriving rpcty]
27
+
(** The result returned by a 'complete' call. *)
28
+
29
+
type string_list = string list [@@deriving rpcty]
30
+
(** Used by setup *)
31
+
32
+
type string_string_list = (string * string) list [@@deriving rpcty]
33
+
(** Used by setup *)
33
34
34
35
(** For now we are only using a simple error type *)
35
36
type err = InternalError of string [@@deriving rpcty]
···
49
50
50
51
let description =
51
52
Interface.
52
-
{ name = "Toplevel"
53
-
; namespace = None
54
-
; description =
55
-
[ "Functions for manipulating the toplevel worker thread" ]
56
-
; version = 1, 0, 0
53
+
{
54
+
name = "Toplevel";
55
+
namespace = None;
56
+
description =
57
+
[ "Functions for manipulating the toplevel worker thread" ];
58
+
version = (1, 0, 0);
57
59
}
58
60
59
61
let implementation = implement description
···
66
68
67
69
let completion_p = Param.mk completion_result
68
70
71
+
let cmas =
72
+
Param.mk ~name:"cmas"
73
+
~description:
74
+
[
75
+
"A list of pairs. The first element of the pair is a urls to a";
76
+
"cma file pre-compiled to javascript. The second item is the";
77
+
"name of the function to be invoked to load the cma file";
78
+
"(ie, the cma was compiled with --wrap-func).";
79
+
"These will be loaded synchronously during the init call.";
80
+
]
81
+
string_string_list
82
+
83
+
let cmis =
84
+
Param.mk ~name:"cmis"
85
+
~description:
86
+
[
87
+
"A list of urls of cmi files. These files will be loaded on demand";
88
+
"during evaluation of toplevel phrases.";
89
+
]
90
+
string_list
91
+
92
+
let init =
93
+
declare "init"
94
+
[ "Initialise the toplevel." ]
95
+
(cmas @-> cmis @-> returning unit_p err)
96
+
69
97
let setup =
70
-
declare
71
-
"setup"
72
-
[ "Initialise the toplevel. Return value is the initial blurb "
73
-
; "printed when starting a toplevel."
98
+
declare "setup"
99
+
[
100
+
"Start the toplevel. Return value is the initial blurb ";
101
+
"printed when starting a toplevel. Note that the toplevel";
102
+
"must be initialised first.";
74
103
]
75
104
(unit_p @-> returning exec_result_p err)
76
105
77
106
let exec =
78
-
declare
79
-
"exec"
80
-
[ "Execute a phrase using the toplevel. The toplevel must have been"
81
-
; "Initialised first."
107
+
declare "exec"
108
+
[
109
+
"Execute a phrase using the toplevel. The toplevel must have been";
110
+
"Initialised first.";
82
111
]
83
112
(phrase_p @-> returning exec_result_p err)
84
113
85
114
let complete =
86
-
declare
87
-
"complete"
88
-
[ "Find completions of the incomplete phrase. Completion occurs at the"
89
-
; "end of the phrase passed in. If completion is required at a point"
90
-
; "other than the end of a string, then take the substring before calling"
91
-
; "this API."
115
+
declare "complete"
116
+
[
117
+
"Find completions of the incomplete phrase. Completion occurs at the";
118
+
"end of the phrase passed in. If completion is required at a point";
119
+
"other than the end of a string, then take the substring before calling";
120
+
"this API.";
92
121
]
93
122
(phrase_p @-> returning completion_p err)
94
123
end
+54
-7
idl/toplevel_api_gen.ml
+54
-7
idl/toplevel_api_gen.ml
···
22
22
line1: int ;
23
23
line2: int ;
24
24
col1: int ;
25
-
col2: int }[@@ocaml.doc " An area to be highlighted "][@@deriving rpcty]
25
+
col2: int }[@@deriving rpcty][@@ocaml.doc " An area to be highlighted "]
26
26
include
27
27
struct
28
28
let _ = fun (_ : highlight) -> ()
···
122
122
stderr: string option ;
123
123
sharp_ppf: string option ;
124
124
caml_ppf: string option ;
125
-
highlight: highlight option }[@@ocaml.doc
126
-
" Represents the result of executing a toplevel phrase "]
127
-
[@@deriving rpcty]
125
+
highlight: highlight option }[@@deriving rpcty][@@ocaml.doc
126
+
" Represents the result of executing a toplevel phrase "]
128
127
include
129
128
struct
130
129
let _ = fun (_ : exec_result) -> ()
···
254
253
[@ocaml.doc
255
254
" The position in the input string from where the completions may be\n inserted "];
256
255
completions: string list [@ocaml.doc " The list of possible completions "]}
257
-
[@@ocaml.doc " The result returned by a 'complete' call. "][@@deriving rpcty]
256
+
[@@deriving rpcty][@@ocaml.doc " The result returned by a 'complete' call. "]
258
257
include
259
258
struct
260
259
let _ = fun (_ : completion_result) -> ()
···
318
317
and _ = typ_of_completion_result
319
318
and _ = completion_result
320
319
end[@@ocaml.doc "@inline"][@@merlin.hide ]
320
+
type string_list = string list[@@deriving rpcty][@@ocaml.doc
321
+
" Used by setup "]
322
+
include
323
+
struct
324
+
let _ = fun (_ : string_list) -> ()
325
+
let rec typ_of_string_list =
326
+
Rpc.Types.List (let open Rpc.Types in Basic String)
327
+
and string_list =
328
+
{
329
+
Rpc.Types.name = "string_list";
330
+
Rpc.Types.description = ["Used by setup"];
331
+
Rpc.Types.ty = typ_of_string_list
332
+
}
333
+
let _ = typ_of_string_list
334
+
and _ = string_list
335
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
336
+
type string_string_list = (string * string) list[@@deriving rpcty][@@ocaml.doc
337
+
" Used by setup "]
338
+
include
339
+
struct
340
+
let _ = fun (_ : string_string_list) -> ()
341
+
let rec typ_of_string_string_list =
342
+
Rpc.Types.Dict (Rpc.Types.String, (let open Rpc.Types in Basic String))
343
+
and string_string_list =
344
+
{
345
+
Rpc.Types.name = "string_string_list";
346
+
Rpc.Types.description = ["Used by setup"];
347
+
Rpc.Types.ty = typ_of_string_string_list
348
+
}
349
+
let _ = typ_of_string_string_list
350
+
and _ = string_string_list
351
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
321
352
type err =
322
353
| InternalError of string [@@ocaml.doc
323
354
" For now we are only using a simple error type "]
···
391
422
let phrase_p = Param.mk Types.string
392
423
let exec_result_p = Param.mk exec_result
393
424
let completion_p = Param.mk completion_result
425
+
let cmas =
426
+
Param.mk ~name:"cmas"
427
+
~description:["A list of pairs. The first element of the pair is a urls to a";
428
+
"cma file pre-compiled to javascript. The second item is the";
429
+
"name of the function to be invoked to load the cma file";
430
+
"(ie, the cma was compiled with --wrap-func).";
431
+
"These will be loaded synchronously during the init call."]
432
+
string_string_list
433
+
let cmis =
434
+
Param.mk ~name:"cmis"
435
+
~description:["A list of urls of cmi files. These files will be loaded on demand";
436
+
"during evaluation of toplevel phrases."] string_list
437
+
let init =
438
+
declare "init" ["Initialise the toplevel."]
439
+
(cmas @-> (cmis @-> (returning unit_p err)))
394
440
let setup =
395
441
declare "setup"
396
-
["Initialise the toplevel. Return value is the initial blurb ";
397
-
"printed when starting a toplevel."]
442
+
["Start the toplevel. Return value is the initial blurb ";
443
+
"printed when starting a toplevel. Note that the toplevel";
444
+
"must be initialised first."]
398
445
(unit_p @-> (returning exec_result_p err))
399
446
let exec =
400
447
declare "exec"
+1
-4
lib/dune
+1
-4
lib/dune
+6
-8
lib/uTop.mli
+6
-8
lib/uTop.mli
···
18
18
val add_keyword : string -> unit
19
19
(** Add a new OCaml keyword. *)
20
20
21
+
type location = int * int
21
22
(** Type of a string-location. It is composed of a start and stop offsets (in
22
23
bytes). *)
23
-
type location = int * int
24
24
25
25
(** Result of a function processing a programx. *)
26
26
type 'a result =
···
29
29
(** The function failed. Arguments are a list of locations to highlight in
30
30
the source and an error message. *)
31
31
32
-
(** Exception raised by a parser when it need more data. *)
33
32
exception Need_more
33
+
(** Exception raised by a parser when it need more data. *)
34
34
35
-
val parse_toplevel_phrase
36
-
: (string -> bool -> Parsetree.toplevel_phrase result) ref
35
+
val parse_toplevel_phrase :
36
+
(string -> bool -> Parsetree.toplevel_phrase result) ref
37
37
(** [parse_toplevel_phrase] is the function used to parse a phrase typed in the
38
38
toplevel.
39
39
···
50
50
51
51
Except for {!Need_more}, the function must not raise any exception. *)
52
52
53
-
val parse_toplevel_phrase_default
54
-
: string
55
-
-> bool
56
-
-> Parsetree.toplevel_phrase result
53
+
val parse_toplevel_phrase_default :
54
+
string -> bool -> Parsetree.toplevel_phrase result
57
55
(** The default parser for toplevel phrases. It uses the standard ocaml parser. *)
58
56
59
57
val parse_default : (Lexing.lexbuf -> 'a) -> string -> bool -> 'a result
+2
-4
lib/uTop_complete.mli
+2
-4
lib/uTop_complete.mli
···
9
9
10
10
(** OCaml completion. *)
11
11
12
-
val complete
13
-
: phrase_terminator:string
14
-
-> input:string
15
-
-> int * (string * string) list
12
+
val complete :
13
+
phrase_terminator:string -> input:string -> int * (string * string) list
16
14
(** [complete ~phrase_terminator ~input] returns the start of the completed word
17
15
in [input] and the list of possible completions with their suffixes. *)
18
16
+14
-16
lib/uTop_token.ml
+14
-16
lib/uTop_token.ml
···
12
12
The type of tokens is semi-structured: parentheses construct and quotations
13
13
are nested and others tokens are flat list. *)
14
14
15
+
type location = {
16
+
idx1 : int; (** Start position in unicode characters. *)
17
+
idx2 : int; (** Stop position in unicode characters. *)
18
+
ofs1 : int; (** Start position in bytes. *)
19
+
ofs2 : int; (** Stop position in bytes. *)
20
+
}
15
21
(** Locations in the source string, which is encoded in UTF-8. *)
16
-
type location =
17
-
{ idx1 : int (** Start position in unicode characters. *)
18
-
; idx2 : int (** Stop position in unicode characters. *)
19
-
; ofs1 : int (** Start position in bytes. *)
20
-
; ofs2 : int (** Stop position in bytes. *)
21
-
}
22
22
23
23
type t =
24
24
| Symbol of string
···
37
37
| Comment_reg (** Regular comment. *)
38
38
| Comment_doc (** Documentation comment. *)
39
39
40
-
and quotation_item =
41
-
| Quot_data
42
-
| Quot_anti of antiquotation
40
+
and quotation_item = Quot_data | Quot_anti of antiquotation
43
41
44
-
and antiquotation =
45
-
{ a_opening : location (** Location of the opening [$]. *)
46
-
; a_closing : location option (** Location of the closing [$]. *)
47
-
; a_name : (location * location) option
48
-
(** Location of the name and colon if any. *)
49
-
; a_contents : (t * location) list (** Contents of the location. *)
50
-
}
42
+
and antiquotation = {
43
+
a_opening : location; (** Location of the opening [$]. *)
44
+
a_closing : location option; (** Location of the closing [$]. *)
45
+
a_name : (location * location) option;
46
+
(** Location of the name and colon if any. *)
47
+
a_contents : (t * location) list; (** Contents of the location. *)
48
+
}
+112
-103
lib/worker.ml
+112
-103
lib/worker.ml
···
17
17
if cur - beg > 0 then [ String.sub p beg (cur - beg) ] else []
18
18
else if sep p.[cur] then
19
19
String.sub p beg (cur - beg) :: split (cur + 1) (cur + 1)
20
-
else
21
-
split beg (cur + 1)
20
+
else split beg (cur + 1)
22
21
in
23
22
split 0 0
24
23
···
26
25
match
27
26
split_char ~sep:(function '+' | '-' | '~' -> true | _ -> false) v
28
27
with
29
-
| [] ->
30
-
assert false
28
+
| [] -> assert false
31
29
| x :: _ ->
32
-
List.map
33
-
int_of_string
34
-
(split_char ~sep:(function '.' -> true | _ -> false) x)
30
+
List.map int_of_string
31
+
(split_char ~sep:(function '.' -> true | _ -> false) x)
35
32
36
33
let current = split Sys.ocaml_version
37
34
38
35
let compint (a : int) b = compare a b
39
36
40
37
let rec compare v v' =
41
-
match v, v' with
42
-
| [ x ], [ y ] ->
43
-
compint x y
44
-
| [], [] ->
45
-
0
46
-
| [], y :: _ ->
47
-
compint 0 y
48
-
| x :: _, [] ->
49
-
compint x 0
50
-
| x :: xs, y :: ys ->
51
-
(match compint x y with 0 -> compare xs ys | n -> n)
38
+
match (v, v') with
39
+
| [ x ], [ y ] -> compint x y
40
+
| [], [] -> 0
41
+
| [], y :: _ -> compint 0 y
42
+
| x :: _, [] -> compint x 0
43
+
| x :: xs, y :: ys -> (
44
+
match compint x y with 0 -> compare xs ys | n -> n)
52
45
end
53
46
54
47
let exec' s =
···
62
55
if Version.compare Version.current [ 4; 07 ] >= 0 then exec' "open Stdlib";
63
56
let header1 = Printf.sprintf " %s version %%s" "OCaml" in
64
57
let header2 =
65
-
Printf.sprintf
66
-
" Compiled with Js_of_ocaml version %s"
58
+
Printf.sprintf " Compiled with Js_of_ocaml version %s"
67
59
Js_of_ocaml.Sys_js.js_of_ocaml_version
68
60
in
69
61
exec' (Printf.sprintf "Format.printf \"%s@.\" Sys.ocaml_version;;" header1);
70
62
exec' (Printf.sprintf "Format.printf \"%s@.\";;" header2);
71
63
exec' "#enable \"pretty\";;";
72
64
exec' "#disable \"shortvar\";;";
73
-
Toploop.add_directive
74
-
"load_js"
65
+
Toploop.add_directive "load_js"
75
66
(Toploop.Directive_string
76
67
(fun name -> Js_of_ocaml.Js.Unsafe.global##load_script_ name))
77
68
Toploop.{ section = ""; doc = "Load a javascript script" };
···
80
71
81
72
let setup_printers () =
82
73
exec' "let _print_unit fmt (_ : 'a) : 'a = Format.pp_print_string fmt \"()\"";
83
-
Topdirs.dir_install_printer
84
-
Format.std_formatter
74
+
Topdirs.dir_install_printer Format.std_formatter
85
75
Longident.(Lident "_print_unit")
86
76
87
77
let stdout_buff = Buffer.create 100
···
123
113
Format.pp_print_flush pp_result ();
124
114
IdlM.ErrM.return
125
115
Toplevel_api_gen.
126
-
{ stdout = buff_opt stdout_buff
127
-
; stderr = buff_opt stderr_buff
128
-
; sharp_ppf = buff_opt code_buff
129
-
; caml_ppf = buff_opt res_buff
130
-
; highlight = !highlighted
116
+
{
117
+
stdout = buff_opt stdout_buff;
118
+
stderr = buff_opt stderr_buff;
119
+
sharp_ppf = buff_opt code_buff;
120
+
caml_ppf = buff_opt res_buff;
121
+
highlight = !highlighted;
131
122
}
132
123
133
-
let setup functions () =
124
+
let sync_get url =
125
+
let open Js_of_ocaml in
126
+
let x = XmlHttpRequest.create () in
127
+
x##.responseType := Js.string "arraybuffer";
128
+
x##_open (Js.string "GET") (Js.string url) Js._false;
129
+
x##send Js.null;
130
+
match x##.status with
131
+
| 200 ->
132
+
Js.Opt.case
133
+
(File.CoerceTo.arrayBuffer x##.response)
134
+
(fun () ->
135
+
Firebug.console##log (Js.string "Failed to receive file");
136
+
None)
137
+
(fun b -> Some (Typed_array.String.of_arrayBuffer b))
138
+
| _ -> None
139
+
140
+
let load_resource files =
141
+
let open Js_of_ocaml in
142
+
fun ~prefix ~path ->
143
+
Firebug.console##log
144
+
(Js.string
145
+
(Printf.sprintf "here we are, loading prefix=%s path=%s" prefix path));
146
+
(* let abs_filename = Filename.concat prefix path in *)
147
+
if List.mem_assoc path files then (
148
+
Firebug.console##log (Js.string "path is in files");
149
+
let f = sync_get (List.assoc path files) in
150
+
match f with
151
+
| Some content ->
152
+
Firebug.console##log
153
+
(Js.string
154
+
(Printf.sprintf "Got result (length=%d)" (String.length content)));
155
+
(* Sys_js.update_file ~name:abs_filename ~content; *)
156
+
Some content
157
+
| None -> None)
158
+
else (
159
+
Firebug.console##log (Js.string "path is NOT in files");
160
+
None)
161
+
162
+
let functions : (unit -> unit) list option ref = ref None
163
+
164
+
let init cmas cmis =
165
+
let open Js_of_ocaml in
166
+
try
167
+
Clflags.no_check_prims := true;
168
+
let cmi_files = List.map (fun cmi -> (Filename.basename cmi, cmi)) cmis in
169
+
Sys_js.mount ~path:"/dynamic/cmis" (load_resource cmi_files);
170
+
List.iter
171
+
(fun (path, _) -> Sys_js.register_lazy ("/dynamic/cmis/" ^ path))
172
+
cmi_files;
173
+
Topdirs.dir_directory "/dynamic/cmis";
174
+
Js_of_ocaml.Worker.import_scripts (List.map fst cmas);
175
+
functions :=
176
+
Some
177
+
(List.map
178
+
(fun func_name ->
179
+
Firebug.console##log (Js.string ("Function: " ^ func_name));
180
+
let func = Js.Unsafe.js_expr func_name in
181
+
fun () ->
182
+
Js.Unsafe.fun_call func [| Js.Unsafe.inject Dom_html.window |])
183
+
(List.map snd cmas));
184
+
IdlM.ErrM.return ()
185
+
with e ->
186
+
IdlM.ErrM.return_err (Toplevel_api_gen.InternalError (Printexc.to_string e))
187
+
188
+
let setup () =
189
+
let open Js_of_ocaml in
134
190
try
135
-
Js_of_ocaml.Sys_js.set_channel_flusher stdout (Buffer.add_string stdout_buff);
136
-
Js_of_ocaml.Sys_js.set_channel_flusher stderr (Buffer.add_string stderr_buff);
137
-
setup functions ();
191
+
Sys_js.set_channel_flusher stdout
192
+
(Buffer.add_string stdout_buff);
193
+
Sys_js.set_channel_flusher stderr
194
+
(Buffer.add_string stderr_buff);
195
+
(match !functions with
196
+
| Some l -> setup l ()
197
+
| None -> failwith "Error: toplevel has not been initialised");
138
198
setup_printers ();
139
199
IdlM.ErrM.return
140
200
Toplevel_api_gen.
141
-
{ stdout = buff_opt stdout_buff
142
-
; stderr = buff_opt stderr_buff
143
-
; sharp_ppf = None
144
-
; caml_ppf = None
145
-
; highlight = None
201
+
{
202
+
stdout = buff_opt stdout_buff;
203
+
stderr = buff_opt stderr_buff;
204
+
sharp_ppf = None;
205
+
caml_ppf = None;
206
+
highlight = None;
146
207
}
147
208
with e ->
148
209
IdlM.ErrM.return_err (Toplevel_api_gen.InternalError (Printexc.to_string e))
···
151
212
let contains_double_underscore s =
152
213
let len = String.length s in
153
214
let rec aux i =
154
-
if i > len - 2 then
155
-
false
156
-
else if s.[i] = '_' && s.[i + 1] = '_' then
157
-
true
158
-
else
159
-
aux (i + 1)
215
+
if i > len - 2 then false
216
+
else if s.[i] = '_' && s.[i + 1] = '_' then true
217
+
else aux (i + 1)
160
218
in
161
219
aux 0
162
220
in
···
169
227
170
228
let server process e =
171
229
let call : Rpc.call = Marshal.from_bytes e 0 in
172
-
M.bind (process call) (fun response -> Js_of_ocaml.Worker.post_message (Marshal.to_string response []));
230
+
M.bind (process call) (fun response ->
231
+
Js_of_ocaml.Worker.post_message (Marshal.to_string response []));
173
232
()
174
233
175
-
let sync_get url =
176
-
let open Js_of_ocaml in
177
-
let x = XmlHttpRequest.create () in
178
-
x##.responseType := (Js.string "arraybuffer");
179
-
x##_open (Js.string "GET") (Js.string url) Js._false;
180
-
x##send Js.null;
181
-
match x##.status with
182
-
| 200 ->
183
-
Js.Opt.case
184
-
(File.CoerceTo.arrayBuffer x##.response)
185
-
(fun () ->
186
-
Firebug.console##log (Js.string "Failed to receive file");
187
-
None)
188
-
(fun b ->
189
-
Some (Typed_array.String.of_arrayBuffer b))
190
-
| _ ->
191
-
None
192
-
193
-
let load_resource files =
194
-
let open Js_of_ocaml in
195
-
fun ~prefix ~path ->
196
-
Firebug.console##log (Js.string (Printf.sprintf "here we are, loading prefix=%s path=%s" prefix path));
197
-
(* let abs_filename = Filename.concat prefix path in *)
198
-
if List.mem_assoc path files
199
-
then begin
200
-
Firebug.console##log (Js.string "path is in files");
201
-
let f = sync_get (List.assoc path files) in
202
-
match f with
203
-
| Some content ->
204
-
Firebug.console##log (Js.string (Printf.sprintf "Got result (length=%d)" (String.length content)));
205
-
(* Sys_js.update_file ~name:abs_filename ~content; *)
206
-
Some content
207
-
| None ->
208
-
None
209
-
end
210
-
else
211
-
(Firebug.console##log (Js.string "path is NOT in files");
212
-
None)
213
-
214
-
let run files cmis functions =
234
+
let run () =
215
235
(* Here we bind the server stub functions to the implementations *)
216
236
let open Js_of_ocaml in
217
237
try
218
-
Js_top_worker_rpc.Idl.logfn := (fun s -> Js_of_ocaml.(Firebug.console##log ( s)));
219
-
ignore cmis;
220
-
Clflags.no_check_prims := true;
221
-
let cmi_files = List.map (fun cmi ->
222
-
(Filename.basename cmi, cmi)) cmis in
223
-
Sys_js.mount ~path:"/dynamic/cmis" (load_resource cmi_files);
224
-
List.iter (fun (path, _) -> Sys_js.register_lazy ("/dynamic/cmis/" ^ path)) cmi_files;
225
-
Topdirs.dir_directory "/dynamic/cmis";
226
-
Js_of_ocaml.Worker.import_scripts files;
227
-
let functions = List.map (fun func_name ->
228
-
Firebug.console##log (Js.string ("Function: " ^ func_name ));
229
-
let func = Js.Unsafe.js_expr func_name in
230
-
fun () -> Js.Unsafe.fun_call func [| Js.Unsafe.inject Dom_html.window |])
231
-
functions in
238
+
(Js_top_worker_rpc.Idl.logfn :=
239
+
fun s -> Js_of_ocaml.(Firebug.console##log s));
232
240
Server.complete complete;
233
241
Server.exec execute;
234
-
Server.setup (setup functions);
242
+
Server.setup setup;
243
+
Server.init init;
235
244
let rpc_fn = IdlM.server Server.implementation in
236
245
Js_of_ocaml.Worker.set_onmessage (server rpc_fn);
237
-
Firebug.console##log (Js.string "All finished");
238
-
with e ->
239
-
Firebug.console##log (Js.string ("Exception: " ^ Printexc.to_string e))
246
+
Firebug.console##log (Js.string "All finished")
247
+
with e ->
248
+
Firebug.console##log (Js.string ("Exception: " ^ Printexc.to_string e))