this repo has no description
Initial
+4109
+25
idl/dune
+25
idl/dune
···
1
+
(library
2
+
(name js_top_worker_rpc)
3
+
(public_name js_top_worker.rpc)
4
+
(modules idl rpc rpcmarshal toplevel_api_gen)
5
+
(libraries rresult))
6
+
7
+
(library
8
+
(name js_top_worker_rpc_codegen)
9
+
(modules toplevel_api)
10
+
(enabled_if (>= %{ocaml_version} 4.12))
11
+
(package js_top_worker_codegen)
12
+
(preprocess (pps ppx_deriving_rpc)))
13
+
14
+
(rule
15
+
(target toplevel_api_gen.ml.gen)
16
+
(enabled_if (>= %{ocaml_version} 4.12))
17
+
(action
18
+
(with-stderr-to %{target} (run ocamlc -stop-after parsing -dsource %{dep:toplevel_api.pp.ml}))))
19
+
20
+
(rule
21
+
(alias runtest)
22
+
(enabled_if (>= %{ocaml_version} 4.12))
23
+
(action
24
+
(diff toplevel_api_gen.ml toplevel_api_gen.ml.gen)))
25
+
+679
idl/idl.ml
+679
idl/idl.ml
···
1
+
module Param = struct
2
+
type 'a t =
3
+
{ name : string option
4
+
; description : string list
5
+
; typedef : 'a Rpc.Types.def
6
+
; version : Rpc.Version.t option
7
+
}
8
+
9
+
type boxed = Boxed : 'a t -> boxed
10
+
11
+
let mk ?name ?description ?version typedef =
12
+
let description =
13
+
match description with
14
+
| Some d -> d
15
+
| None -> typedef.Rpc.Types.description
16
+
in
17
+
{ name; description; version; typedef }
18
+
end
19
+
20
+
module Error = struct
21
+
type 'a t =
22
+
{ def : 'a Rpc.Types.def
23
+
; raiser : 'a -> exn
24
+
; matcher : exn -> 'a option
25
+
}
26
+
27
+
module type ERROR = sig
28
+
type t
29
+
30
+
val t : t Rpc.Types.def
31
+
val internal_error_of : exn -> t option
32
+
end
33
+
34
+
module Make (T : ERROR) = struct
35
+
exception Exn of T.t
36
+
37
+
let () =
38
+
let printer = function
39
+
| Exn x ->
40
+
Some
41
+
(Printf.sprintf
42
+
"IDL Error: %s"
43
+
(Rpcmarshal.marshal T.t.Rpc.Types.ty x |> Rpc.to_string))
44
+
| _ -> None
45
+
in
46
+
Printexc.register_printer printer
47
+
48
+
49
+
let error =
50
+
{ def = T.t
51
+
; raiser =
52
+
(function
53
+
| e -> Exn e)
54
+
; matcher =
55
+
(function
56
+
| Exn e -> Some e
57
+
| e -> T.internal_error_of e)
58
+
}
59
+
end
60
+
end
61
+
62
+
module Interface = struct
63
+
type description =
64
+
{ name : string
65
+
; namespace : string option
66
+
; description : string list
67
+
; version : Rpc.Version.t
68
+
}
69
+
end
70
+
71
+
module type RPC = sig
72
+
type implementation
73
+
type 'a res
74
+
type ('a, 'b) comp
75
+
type _ fn
76
+
77
+
val implement : Interface.description -> implementation
78
+
val ( @-> ) : 'a Param.t -> 'b fn -> ('a -> 'b) fn
79
+
val returning : 'a Param.t -> 'b Error.t -> ('a, 'b) comp fn
80
+
val declare : string -> string list -> 'a fn -> 'a res
81
+
val declare_notification : string -> string list -> 'a fn -> 'a res
82
+
end
83
+
84
+
module type MONAD = sig
85
+
type 'a t
86
+
87
+
val return : 'a -> 'a t
88
+
val bind : 'a t -> ('a -> 'b t) -> 'b t
89
+
val fail : exn -> 'a t
90
+
end
91
+
92
+
exception MarshalError of string
93
+
exception UnknownMethod of string
94
+
exception UnboundImplementation of string list
95
+
exception NoDescription
96
+
97
+
let get_wire_name description name =
98
+
match description with
99
+
| None -> name
100
+
| Some d ->
101
+
(match d.Interface.namespace with
102
+
| Some ns -> Printf.sprintf "%s.%s" ns name
103
+
| None -> name)
104
+
105
+
106
+
let get_arg call has_named name is_opt =
107
+
match has_named, name, call.Rpc.params with
108
+
| true, Some n, Rpc.Dict named :: unnamed ->
109
+
(match List.partition (fun (x, _) -> x = n) named with
110
+
| (_, arg) :: dups, others when is_opt ->
111
+
Ok
112
+
(Rpc.Enum [ arg ], { call with Rpc.params = Rpc.Dict (dups @ others) :: unnamed })
113
+
| (_, arg) :: dups, others ->
114
+
Ok (arg, { call with Rpc.params = Rpc.Dict (dups @ others) :: unnamed })
115
+
| [], _others when is_opt -> Ok (Rpc.Enum [], call)
116
+
| _, _ -> Error (`Msg (Printf.sprintf "Expecting named argument '%s'" n)))
117
+
| true, None, Rpc.Dict named :: unnamed ->
118
+
(match unnamed with
119
+
| head :: tail -> Ok (head, { call with Rpc.params = Rpc.Dict named :: tail })
120
+
| _ -> Error (`Msg "Incorrect number of arguments"))
121
+
| true, _, _ ->
122
+
Error
123
+
(`Msg
124
+
"Marshalling error: Expecting dict as first argument when named parameters exist")
125
+
| false, None, head :: tail -> Ok (head, { call with Rpc.params = tail })
126
+
| false, None, [] -> Error (`Msg "Incorrect number of arguments")
127
+
| false, Some _, _ -> failwith "Can't happen by construction"
128
+
129
+
130
+
module Make (M : MONAD) = struct
131
+
module type RPCTRANSFORMER = sig
132
+
type 'a box
133
+
type ('a, 'b) resultb = ('a, 'b) result box
134
+
type rpcfn = Rpc.call -> Rpc.response M.t
135
+
136
+
val lift : ('a -> 'b M.t) -> 'a -> 'b box
137
+
val bind : 'a box -> ('a -> 'b M.t) -> 'b box
138
+
val return : 'a -> 'a box
139
+
val get : 'a box -> 'a M.t
140
+
val ( !@ ) : 'a box -> 'a M.t
141
+
val put : 'a M.t -> 'a box
142
+
val ( ~@ ) : 'a M.t -> 'a box
143
+
end
144
+
145
+
module T = struct
146
+
type 'a box = { box : 'a M.t }
147
+
type ('a, 'b) resultb = ('a, 'b) result box
148
+
type rpcfn = Rpc.call -> Rpc.response M.t
149
+
150
+
let lift f x = { box = f x }
151
+
let bind { box = x } f = { box = M.bind x f }
152
+
let return x = { box = M.return x }
153
+
let get { box = x } = x
154
+
let ( !@ ) = get
155
+
let put x = { box = x }
156
+
let ( ~@ ) = put
157
+
end
158
+
159
+
type client_implementation = unit
160
+
type server_implementation = (string, T.rpcfn option) Hashtbl.t
161
+
162
+
module ErrM : sig
163
+
val return : 'a -> ('a, 'b) T.resultb
164
+
val return_err : 'b -> ('a, 'b) T.resultb
165
+
166
+
val checked_bind
167
+
: ('a, 'b) T.resultb
168
+
-> ('a -> ('c, 'd) T.resultb)
169
+
-> ('b -> ('c, 'd) T.resultb)
170
+
-> ('c, 'd) T.resultb
171
+
172
+
val bind : ('a, 'b) T.resultb -> ('a -> ('c, 'b) T.resultb) -> ('c, 'b) T.resultb
173
+
val ( >>= ) : ('a, 'b) T.resultb -> ('a -> ('c, 'b) T.resultb) -> ('c, 'b) T.resultb
174
+
end = struct
175
+
let return x = T.put (M.return (Ok x))
176
+
let return_err e = T.put (M.return (Error e))
177
+
178
+
let checked_bind x f f1 =
179
+
T.bind
180
+
x
181
+
T.(
182
+
function
183
+
| Ok x -> !@(f x)
184
+
| Error x -> !@(f1 x))
185
+
186
+
187
+
let bind x f = checked_bind x f return_err
188
+
let ( >>= ) x f = bind x f
189
+
end
190
+
191
+
module GenClient () = struct
192
+
type implementation = client_implementation
193
+
type 'a res = T.rpcfn -> 'a
194
+
type ('a, 'b) comp = ('a, 'b) T.resultb
195
+
196
+
type _ fn =
197
+
| Function : 'a Param.t * 'b fn -> ('a -> 'b) fn
198
+
| Returning : ('a Param.t * 'b Error.t) -> ('a, 'b) comp fn
199
+
200
+
let description = ref None
201
+
let strict = ref false
202
+
let make_strict () = strict := true
203
+
204
+
let implement x =
205
+
description := Some x;
206
+
()
207
+
208
+
209
+
let returning a err = Returning (a, err)
210
+
let ( @-> ) t f = Function (t, f)
211
+
212
+
let declare_ is_notification name _ ty (rpc : T.rpcfn) =
213
+
let rec inner : type b. (string * Rpc.t) list option * Rpc.t list -> b fn -> b =
214
+
fun (named, unnamed) -> function
215
+
| Function (t, f) ->
216
+
let cur_named =
217
+
match named with
218
+
| Some l -> l
219
+
| None -> []
220
+
in
221
+
fun v ->
222
+
(match t.Param.name with
223
+
| Some n ->
224
+
(match t.Param.typedef.Rpc.Types.ty, v with
225
+
| Rpc.Types.Option ty, Some v' ->
226
+
let marshalled = Rpcmarshal.marshal ty v' in
227
+
inner (Some ((n, marshalled) :: cur_named), unnamed) f
228
+
| Rpc.Types.Option _ty, None -> inner (Some cur_named, unnamed) f
229
+
| ty, v ->
230
+
let marshalled = Rpcmarshal.marshal ty v in
231
+
inner (Some ((n, marshalled) :: cur_named), unnamed) f)
232
+
| None ->
233
+
let marshalled = Rpcmarshal.marshal t.Param.typedef.Rpc.Types.ty v in
234
+
inner (named, marshalled :: unnamed) f)
235
+
| Returning (t, e) ->
236
+
let wire_name = get_wire_name !description name in
237
+
let args =
238
+
match named with
239
+
| None -> List.rev unnamed
240
+
| Some l -> Rpc.Dict l :: List.rev unnamed
241
+
in
242
+
let call' = Rpc.call wire_name args in
243
+
let call = { call' with is_notification } in
244
+
let rpc = T.put (rpc call) in
245
+
let res =
246
+
T.bind rpc (fun r ->
247
+
if r.Rpc.success
248
+
then (
249
+
match
250
+
Rpcmarshal.unmarshal t.Param.typedef.Rpc.Types.ty r.Rpc.contents
251
+
with
252
+
| Ok x -> M.return (Ok x)
253
+
| Error (`Msg x) -> M.fail (MarshalError x))
254
+
else (
255
+
match Rpcmarshal.unmarshal e.Error.def.Rpc.Types.ty r.Rpc.contents with
256
+
| Ok x ->
257
+
if !strict then M.fail (e.Error.raiser x) else M.return (Error x)
258
+
| Error (`Msg x) -> M.fail (MarshalError x)))
259
+
in
260
+
res
261
+
in
262
+
inner (None, []) ty
263
+
264
+
265
+
let declare_notification name a ty (rpc : T.rpcfn) = declare_ true name a ty rpc
266
+
let declare name a ty (rpc : T.rpcfn) = declare_ false name a ty rpc
267
+
end
268
+
269
+
let server hashtbl =
270
+
let impl = Hashtbl.create (Hashtbl.length hashtbl) in
271
+
let unbound_impls =
272
+
Hashtbl.fold
273
+
(fun key fn acc ->
274
+
match fn with
275
+
| None -> key :: acc
276
+
| Some fn ->
277
+
Hashtbl.add impl key fn;
278
+
acc)
279
+
hashtbl
280
+
[]
281
+
in
282
+
if unbound_impls <> [] then raise (UnboundImplementation unbound_impls);
283
+
fun call ->
284
+
let fn =
285
+
try Hashtbl.find impl call.Rpc.name with
286
+
| Not_found -> raise (UnknownMethod call.Rpc.name)
287
+
in
288
+
fn call
289
+
290
+
291
+
let combine hashtbls =
292
+
let result = Hashtbl.create 16 in
293
+
List.iter (Hashtbl.iter (fun k v -> Hashtbl.add result k v)) hashtbls;
294
+
result
295
+
296
+
297
+
module GenServer () = struct
298
+
type implementation = server_implementation
299
+
type ('a, 'b) comp = ('a, 'b) T.resultb
300
+
type 'a res = 'a -> unit
301
+
302
+
type _ fn =
303
+
| Function : 'a Param.t * 'b fn -> ('a -> 'b) fn
304
+
| Returning : ('a Param.t * 'b Error.t) -> ('a, 'b) comp fn
305
+
306
+
let funcs = Hashtbl.create 20
307
+
let description = ref None
308
+
309
+
let implement x =
310
+
description := Some x;
311
+
funcs
312
+
313
+
314
+
let returning a b = Returning (a, b)
315
+
let ( @-> ) t f = Function (t, f)
316
+
317
+
let rec has_named_args : type a. a fn -> bool = function
318
+
| Function (t, f) ->
319
+
(match t.Param.name with
320
+
| Some _ -> true
321
+
| None -> has_named_args f)
322
+
| Returning (_, _) -> false
323
+
324
+
325
+
let declare_ : bool -> string -> string list -> 'a fn -> 'a res =
326
+
fun is_notification name _ ty ->
327
+
let ( >>= ) = M.bind in
328
+
(* We do not know the wire name yet as the description may still be unset *)
329
+
Hashtbl.add funcs name None;
330
+
fun impl ->
331
+
((* Sanity check: ensure the description has been set before we declare
332
+
any RPCs. Here we raise an exception immediately and let everything fail. *)
333
+
match !description with
334
+
| Some _ -> ()
335
+
| None -> raise NoDescription);
336
+
let rpcfn =
337
+
let has_named = has_named_args ty in
338
+
let rec inner : type a. a fn -> a -> T.rpcfn =
339
+
fun f impl call ->
340
+
match f with
341
+
| Function (t, f) ->
342
+
let is_opt =
343
+
match t.Param.typedef.Rpc.Types.ty with
344
+
| Rpc.Types.Option _ -> true
345
+
| _ -> false
346
+
in
347
+
(match get_arg call has_named t.Param.name is_opt with
348
+
| Ok (x, y) -> M.return (x, y)
349
+
| Error (`Msg m) -> M.fail (MarshalError m))
350
+
>>= fun (arg_rpc, call') ->
351
+
let z = Rpcmarshal.unmarshal t.Param.typedef.Rpc.Types.ty arg_rpc in
352
+
(match z with
353
+
| Ok arg -> inner f (impl arg) call'
354
+
| Error (`Msg m) -> M.fail (MarshalError m))
355
+
| Returning (t, e) ->
356
+
T.bind impl (function
357
+
| Ok x ->
358
+
let res =
359
+
Rpc.success (Rpcmarshal.marshal t.Param.typedef.Rpc.Types.ty x)
360
+
in
361
+
M.return { res with is_notification }
362
+
| Error y ->
363
+
let res =
364
+
Rpc.failure (Rpcmarshal.marshal e.Error.def.Rpc.Types.ty y)
365
+
in
366
+
M.return { res with is_notification })
367
+
|> T.get
368
+
in
369
+
inner ty impl
370
+
in
371
+
Hashtbl.remove funcs name;
372
+
(* The wire name might be different from the name *)
373
+
let wire_name = get_wire_name !description name in
374
+
Hashtbl.add funcs wire_name (Some rpcfn)
375
+
376
+
377
+
let declare_notification name a ty = declare_ true name a ty
378
+
let declare name a ty = declare_ false name a ty
379
+
end
380
+
end
381
+
382
+
module ExnM = struct
383
+
type 'a t =
384
+
| V of 'a
385
+
| E of exn
386
+
387
+
let return x = V x
388
+
389
+
let lift f x =
390
+
match f x with
391
+
| y -> V y
392
+
| exception e -> E e
393
+
394
+
395
+
let bind x (f : 'a -> 'b t) : 'b t =
396
+
match x with
397
+
| V x -> f x
398
+
| E e -> E e
399
+
400
+
401
+
let ( >>= ) = bind
402
+
let fail e = E e
403
+
404
+
let run = function
405
+
| V x -> x
406
+
| E e -> raise e
407
+
end
408
+
409
+
module IdM = struct
410
+
type 'a t = T of 'a
411
+
412
+
let return x = T x
413
+
let lift f x = T (f x)
414
+
let bind (T x) f = f x
415
+
let ( >>= ) = bind
416
+
let fail e = raise e
417
+
let run (T x) = x
418
+
end
419
+
420
+
(* A default error variant as an example. In real code, this is more easily expressed by using the PPX:
421
+
type default_error = InternalError of string [@@deriving rpcty]
422
+
*)
423
+
module DefaultError = struct
424
+
type t = InternalError of string
425
+
426
+
exception InternalErrorExn of string
427
+
428
+
let internalerror : (string, t) Rpc.Types.tag =
429
+
let open Rpc.Types in
430
+
{ tname = "InternalError"
431
+
; tdescription = [ "Internal Error" ]
432
+
; tversion = Some (1, 0, 0)
433
+
; tcontents = Basic String
434
+
; tpreview =
435
+
(function
436
+
| InternalError s -> Some s)
437
+
; treview = (fun s -> InternalError s)
438
+
}
439
+
440
+
441
+
(* And then we can create the 'variant' type *)
442
+
let t : t Rpc.Types.variant =
443
+
let open Rpc.Types in
444
+
{ vname = "t"
445
+
; variants = [ BoxedTag internalerror ]
446
+
; vversion = Some (1, 0, 0)
447
+
; vdefault = Some (InternalError "Unknown error tag!")
448
+
; vconstructor =
449
+
(fun s t ->
450
+
match s with
451
+
| "InternalError" -> begin
452
+
match t.tget (Basic String) with
453
+
| Ok s -> Ok (internalerror.treview s)
454
+
| Error y -> Error y
455
+
end
456
+
| s -> Error (`Msg (Printf.sprintf "Unknown tag '%s'" s)))
457
+
}
458
+
459
+
460
+
let def =
461
+
let open Rpc.Types in
462
+
{ name = "default_error"
463
+
; description = [ "Errors declared as part of the interface" ]
464
+
; ty = Variant t
465
+
}
466
+
467
+
468
+
let err =
469
+
let open Error in
470
+
{ def
471
+
; raiser =
472
+
(function
473
+
| InternalError s -> raise (InternalErrorExn s))
474
+
; matcher =
475
+
(function
476
+
| InternalErrorExn s -> Some (InternalError s)
477
+
| _ -> None)
478
+
}
479
+
end
480
+
481
+
module Exn = struct
482
+
type rpcfn = Rpc.call -> Rpc.response
483
+
type client_implementation = unit
484
+
type server_implementation = (string, rpcfn option) Hashtbl.t
485
+
486
+
module GenClient (R : sig
487
+
val rpc : rpcfn
488
+
end) =
489
+
struct
490
+
type implementation = client_implementation
491
+
type ('a, 'b) comp = 'a
492
+
type 'a res = 'a
493
+
494
+
type _ fn =
495
+
| Function : 'a Param.t * 'b fn -> ('a -> 'b) fn
496
+
| Returning : ('a Param.t * 'b Error.t) -> ('a, _) comp fn
497
+
498
+
let description = ref None
499
+
500
+
let implement x =
501
+
description := Some x;
502
+
()
503
+
504
+
505
+
let returning a err = Returning (a, err)
506
+
let ( @-> ) t f = Function (t, f)
507
+
508
+
let declare_ is_notification name _ ty =
509
+
let rec inner : type b. (string * Rpc.t) list option * Rpc.t list -> b fn -> b =
510
+
fun (named, unnamed) -> function
511
+
| Function (t, f) ->
512
+
let cur_named =
513
+
match named with
514
+
| Some l -> l
515
+
| None -> []
516
+
in
517
+
fun v ->
518
+
(match t.Param.name with
519
+
| Some n ->
520
+
(match t.Param.typedef.Rpc.Types.ty, v with
521
+
| Rpc.Types.Option ty, Some v' ->
522
+
let marshalled = Rpcmarshal.marshal ty v' in
523
+
inner (Some ((n, marshalled) :: cur_named), unnamed) f
524
+
| Rpc.Types.Option _ty, None -> inner (Some cur_named, unnamed) f
525
+
| ty, v ->
526
+
let marshalled = Rpcmarshal.marshal ty v in
527
+
inner (Some ((n, marshalled) :: cur_named), unnamed) f)
528
+
| None ->
529
+
let marshalled = Rpcmarshal.marshal t.Param.typedef.Rpc.Types.ty v in
530
+
inner (named, marshalled :: unnamed) f)
531
+
| Returning (t, e) ->
532
+
let wire_name = get_wire_name !description name in
533
+
let args =
534
+
match named with
535
+
| None -> List.rev unnamed
536
+
| Some l -> Rpc.Dict l :: List.rev unnamed
537
+
in
538
+
let call' = Rpc.call wire_name args in
539
+
let call = { call' with is_notification } in
540
+
let r = R.rpc call in
541
+
if r.Rpc.success
542
+
then (
543
+
match Rpcmarshal.unmarshal t.Param.typedef.Rpc.Types.ty r.Rpc.contents with
544
+
| Ok x -> x
545
+
| Error (`Msg x) -> raise (MarshalError x))
546
+
else (
547
+
match Rpcmarshal.unmarshal e.Error.def.Rpc.Types.ty r.Rpc.contents with
548
+
| Ok x -> raise (e.Error.raiser x)
549
+
| Error (`Msg x) -> raise (MarshalError x))
550
+
in
551
+
inner (None, []) ty
552
+
553
+
554
+
let declare name a ty = declare_ false name a ty
555
+
let declare_notification name a ty = declare_ true name a ty
556
+
end
557
+
558
+
let server hashtbl =
559
+
let impl = Hashtbl.create (Hashtbl.length hashtbl) in
560
+
let unbound_impls =
561
+
Hashtbl.fold
562
+
(fun key fn acc ->
563
+
match fn with
564
+
| None -> key :: acc
565
+
| Some fn ->
566
+
Hashtbl.add impl key fn;
567
+
acc)
568
+
hashtbl
569
+
[]
570
+
in
571
+
if unbound_impls <> [] then raise (UnboundImplementation unbound_impls);
572
+
fun call ->
573
+
let fn =
574
+
try Hashtbl.find impl call.Rpc.name with
575
+
| Not_found -> raise (UnknownMethod call.Rpc.name)
576
+
in
577
+
fn call
578
+
579
+
580
+
let combine hashtbls =
581
+
let result = Hashtbl.create 16 in
582
+
List.iter (Hashtbl.iter (fun k v -> Hashtbl.add result k v)) hashtbls;
583
+
result
584
+
585
+
586
+
module GenServer () = struct
587
+
type implementation = server_implementation
588
+
type ('a, 'b) comp = 'a
589
+
type 'a res = 'a -> unit
590
+
591
+
type _ fn =
592
+
| Function : 'a Param.t * 'b fn -> ('a -> 'b) fn
593
+
| Returning : ('a Param.t * 'b Error.t) -> ('a, _) comp fn
594
+
595
+
let funcs = Hashtbl.create 20
596
+
let description = ref None
597
+
598
+
let implement x =
599
+
description := Some x;
600
+
funcs
601
+
602
+
603
+
let returning a b = Returning (a, b)
604
+
let ( @-> ) t f = Function (t, f)
605
+
606
+
type boxed_error = BoxedError : 'a Error.t -> boxed_error
607
+
608
+
let rec get_error_ty : type a. a fn -> boxed_error = function
609
+
| Function (_, f) -> get_error_ty f
610
+
| Returning (_, e) -> BoxedError e
611
+
612
+
613
+
let rec has_named_args : type a. a fn -> bool = function
614
+
| Function (t, f) ->
615
+
(match t.Param.name with
616
+
| Some _ -> true
617
+
| None -> has_named_args f)
618
+
| Returning (_, _) -> false
619
+
620
+
621
+
let declare_ : bool -> string -> string list -> 'a fn -> 'a res =
622
+
fun is_notification name _ ty ->
623
+
(* We do not know the wire name yet as the description may still be unset *)
624
+
Hashtbl.add funcs name None;
625
+
fun impl ->
626
+
((* Sanity check: ensure the description has been set before we declare
627
+
any RPCs *)
628
+
match !description with
629
+
| Some _ -> ()
630
+
| None -> raise NoDescription);
631
+
let rpcfn =
632
+
let has_named = has_named_args ty in
633
+
let rec inner : type a. a fn -> a -> Rpc.call -> Rpc.response =
634
+
fun f impl call ->
635
+
try
636
+
match f with
637
+
| Function (t, f) ->
638
+
let is_opt =
639
+
match t.Param.typedef.Rpc.Types.ty with
640
+
| Rpc.Types.Option _ -> true
641
+
| _ -> false
642
+
in
643
+
let arg_rpc, call' =
644
+
match get_arg call has_named t.Param.name is_opt with
645
+
| Ok (x, y) -> x, y
646
+
| Error (`Msg m) -> raise (MarshalError m)
647
+
in
648
+
let z = Rpcmarshal.unmarshal t.Param.typedef.Rpc.Types.ty arg_rpc in
649
+
let arg =
650
+
match z with
651
+
| Ok arg -> arg
652
+
| Error (`Msg m) -> raise (MarshalError m)
653
+
in
654
+
inner f (impl arg) call'
655
+
| Returning (t, _) ->
656
+
let call =
657
+
Rpc.success (Rpcmarshal.marshal t.Param.typedef.Rpc.Types.ty impl)
658
+
in
659
+
{ call with is_notification }
660
+
with
661
+
| e ->
662
+
let (BoxedError error_ty) = get_error_ty f in
663
+
(match error_ty.Error.matcher e with
664
+
| Some y ->
665
+
Rpc.failure (Rpcmarshal.marshal error_ty.Error.def.Rpc.Types.ty y)
666
+
| None -> raise e)
667
+
in
668
+
inner ty impl
669
+
in
670
+
Hashtbl.remove funcs name;
671
+
(* The wire name might be different from the name *)
672
+
let wire_name = get_wire_name !description name in
673
+
Hashtbl.add funcs wire_name (Some rpcfn)
674
+
675
+
676
+
let declare name a ty = declare_ true name a ty
677
+
let declare_notification name a ty = declare_ false name a ty
678
+
end
679
+
end
+375
idl/rpc.ml
+375
idl/rpc.ml
···
1
+
(*
2
+
* Copyright (c) 2006-2009 Citrix Systems Inc.
3
+
* Copyright (c) 2006-2014 Thomas Gazagnaire <thomas@gazagnaire.org>
4
+
*
5
+
* Permission to use, copy, modify, and distribute this software for any
6
+
* purpose with or without fee is hereby granted, provided that the above
7
+
* copyright notice and this permission notice appear in all copies.
8
+
*
9
+
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
10
+
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
11
+
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
12
+
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
13
+
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
14
+
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
15
+
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
16
+
*)
17
+
18
+
let debug = ref false
19
+
let set_debug x = debug := x
20
+
let get_debug () = !debug
21
+
22
+
type msg = [ `Msg of string ]
23
+
24
+
type t =
25
+
| Int of int64
26
+
| Int32 of int32
27
+
| Bool of bool
28
+
| Float of float
29
+
| String of string
30
+
| DateTime of string
31
+
| Enum of t list
32
+
| Dict of (string * t) list
33
+
| Base64 of string
34
+
| Null
35
+
36
+
module Version = struct
37
+
type t = int * int * int
38
+
39
+
let compare (x, y, z) (x', y', z') =
40
+
let cmp a b fn () =
41
+
let c = compare a b in
42
+
if c <> 0 then c else fn ()
43
+
in
44
+
cmp x x' (cmp y y' (cmp z z' (fun () -> 0))) ()
45
+
end
46
+
47
+
module Types = struct
48
+
type _ basic =
49
+
| Int : int basic
50
+
| Int32 : int32 basic
51
+
| Int64 : int64 basic
52
+
| Bool : bool basic
53
+
| Float : float basic
54
+
| String : string basic
55
+
| Char : char basic
56
+
57
+
type _ typ =
58
+
| Basic : 'a basic -> 'a typ
59
+
| DateTime : string typ
60
+
| Base64 : string typ
61
+
| Array : 'a typ -> 'a array typ
62
+
| List : 'a typ -> 'a list typ
63
+
| Dict : 'a basic * 'b typ -> ('a * 'b) list typ
64
+
| Unit : unit typ
65
+
| Option : 'a typ -> 'a option typ
66
+
| Tuple : 'a typ * 'b typ -> ('a * 'b) typ
67
+
| Tuple3 : 'a typ * 'b typ * 'c typ -> ('a * 'b * 'c) typ
68
+
| Tuple4 : 'a typ * 'b typ * 'c typ * 'd typ -> ('a * 'b * 'c * 'd) typ
69
+
| Struct : 'a structure -> 'a typ
70
+
| Variant : 'a variant -> 'a typ
71
+
| Abstract : 'a abstract -> 'a typ
72
+
73
+
(* A type definition has a name and description *)
74
+
and 'a def =
75
+
{ name : string
76
+
; description : string list
77
+
; ty : 'a typ
78
+
}
79
+
80
+
and boxed_def = BoxedDef : 'a def -> boxed_def
81
+
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
+
}
92
+
93
+
and 'a boxed_field = BoxedField : ('a, 's) field -> 's boxed_field
94
+
95
+
and field_getter =
96
+
{ field_get : 'a. string -> 'a typ -> ('a, msg) result }
97
+
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
+
}
104
+
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
+
}
113
+
114
+
and 'a boxed_tag = BoxedTag : ('a, 's) tag -> 's boxed_tag
115
+
116
+
and tag_getter = { tget : 'a. 'a typ -> ('a, msg) result }
117
+
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
+
}
125
+
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
+
}
132
+
133
+
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" ] }
136
+
let bool = { name = "bool"; ty = Basic Bool; description = [ "Boolean" ] }
137
+
138
+
let float =
139
+
{ name = "float"; ty = Basic Float; description = [ "Floating-point number" ] }
140
+
141
+
142
+
let string = { name = "string"; ty = Basic String; description = [ "String" ] }
143
+
let char = { name = "char"; ty = Basic Char; description = [ "Char" ] }
144
+
let unit = { name = "unit"; ty = Unit; description = [ "Unit" ] }
145
+
146
+
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
+
end
157
+
158
+
exception Runtime_error of string * t
159
+
exception Runtime_exception of string * string
160
+
161
+
let map_strings sep fn l = String.concat sep (List.map fn l)
162
+
163
+
let rec to_string t =
164
+
let open Printf in
165
+
match t with
166
+
| Int i -> sprintf "I(%Li)" i
167
+
| Int32 i -> sprintf "I32(%li)" i
168
+
| Bool b -> sprintf "B(%b)" b
169
+
| Float f -> sprintf "F(%g)" f
170
+
| String s -> sprintf "S(%s)" s
171
+
| DateTime s -> sprintf "D(%s)" s
172
+
| Enum ts -> sprintf "[%s]" (map_strings ";" to_string ts)
173
+
| Dict ts ->
174
+
sprintf "{%s}" (map_strings ";" (fun (s, t) -> sprintf "%s:%s" s (to_string t)) ts)
175
+
| Base64 s -> sprintf "B64(%s)" s
176
+
| Null -> "N"
177
+
178
+
179
+
let rpc_of_t x = x
180
+
let rpc_of_int64 i = Int i
181
+
let rpc_of_int32 i = Int (Int64.of_int32 i)
182
+
let rpc_of_int i = Int (Int64.of_int i)
183
+
let rpc_of_bool b = Bool b
184
+
let rpc_of_float f = Float f
185
+
let rpc_of_string s = String s
186
+
let rpc_of_dateTime s = DateTime s
187
+
let rpc_of_base64 s = Base64 s
188
+
let rpc_of_unit () = Null
189
+
let rpc_of_char x = Int (Int64.of_int (Char.code x))
190
+
191
+
let int64_of_rpc = function
192
+
| Int i -> i
193
+
| String s -> Int64.of_string s
194
+
| x -> failwith (Printf.sprintf "Expected int64, got '%s'" (to_string x))
195
+
196
+
197
+
let int32_of_rpc = function
198
+
| Int i -> Int64.to_int32 i
199
+
| String s -> Int32.of_string s
200
+
| x -> failwith (Printf.sprintf "Expected int32, got '%s'" (to_string x))
201
+
202
+
203
+
let int_of_rpc = function
204
+
| Int i -> Int64.to_int i
205
+
| String s -> int_of_string s
206
+
| x -> failwith (Printf.sprintf "Expected int, got '%s'" (to_string x))
207
+
208
+
209
+
let bool_of_rpc = function
210
+
| Bool b -> b
211
+
| x -> failwith (Printf.sprintf "Expected bool, got '%s'" (to_string x))
212
+
213
+
214
+
let float_of_rpc = function
215
+
| Float f -> f
216
+
| Int i -> Int64.to_float i
217
+
| Int32 i -> Int32.to_float i
218
+
| String s -> float_of_string s
219
+
| x -> failwith (Printf.sprintf "Expected float, got '%s'" (to_string x))
220
+
221
+
222
+
let string_of_rpc = function
223
+
| String s -> s
224
+
| x -> failwith (Printf.sprintf "Expected string, got '%s'" (to_string x))
225
+
226
+
227
+
let dateTime_of_rpc = function
228
+
| DateTime s -> s
229
+
| x -> failwith (Printf.sprintf "Expected DateTime, got '%s'" (to_string x))
230
+
231
+
232
+
let base64_of_rpc = function
233
+
| _ -> failwith "Base64 Unhandled"
234
+
235
+
236
+
let unit_of_rpc = function
237
+
| Null -> ()
238
+
| x -> failwith (Printf.sprintf "Expected unit, got '%s'" (to_string x))
239
+
240
+
241
+
let char_of_rpc x =
242
+
let x = int_of_rpc x in
243
+
if x < 0 || x > 255
244
+
then failwith (Printf.sprintf "Char out of range (%d)" x)
245
+
else Char.chr x
246
+
247
+
248
+
let t_of_rpc t = t
249
+
250
+
let lowerfn = function
251
+
| String s -> String (String.lowercase_ascii s)
252
+
| Enum (String s :: ss) -> Enum (String (String.lowercase_ascii s) :: ss)
253
+
| x -> x
254
+
255
+
256
+
module ResultUnmarshallers = struct
257
+
let error_msg m = Error (`Msg m)
258
+
let ok x = Ok x
259
+
260
+
let int64_of_rpc = function
261
+
| 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))
265
+
| x -> error_msg (Printf.sprintf "Expected int64, got '%s'" (to_string x))
266
+
267
+
268
+
let int32_of_rpc = function
269
+
| 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))
273
+
| x -> error_msg (Printf.sprintf "Expected int32, got '%s'" (to_string x))
274
+
275
+
276
+
let int_of_rpc = function
277
+
| 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))
281
+
| x -> error_msg (Printf.sprintf "Expected int, got '%s'" (to_string x))
282
+
283
+
284
+
let bool_of_rpc = function
285
+
| Bool b -> ok b
286
+
| x -> error_msg (Printf.sprintf "Expected bool, got '%s'" (to_string x))
287
+
288
+
289
+
let float_of_rpc = function
290
+
| Float f -> ok f
291
+
| Int i -> ok (Int64.to_float i)
292
+
| 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))
296
+
| x -> error_msg (Printf.sprintf "Expected float, got '%s'" (to_string x))
297
+
298
+
299
+
let string_of_rpc = function
300
+
| String s -> ok s
301
+
| x -> error_msg (Printf.sprintf "Expected string, got '%s'" (to_string x))
302
+
303
+
304
+
let dateTime_of_rpc = function
305
+
| DateTime s -> ok s
306
+
| x -> error_msg (Printf.sprintf "Expected DateTime, got '%s'" (to_string x))
307
+
308
+
309
+
let base64_of_rpc = function
310
+
| _ -> error_msg "Base64 Unhandled"
311
+
312
+
313
+
let unit_of_rpc = function
314
+
| Null -> ok ()
315
+
| x -> error_msg (Printf.sprintf "Expected unit, got '%s'" (to_string x))
316
+
317
+
318
+
let char_of_rpc x =
319
+
match (int_of_rpc x) with
320
+
| Ok x ->
321
+
if x < 0 || x > 255
322
+
then error_msg (Printf.sprintf "Char out of range (%d)" x)
323
+
else ok (Char.chr x)
324
+
| Error y -> Error y
325
+
326
+
let t_of_rpc t = ok t
327
+
end
328
+
329
+
let struct_extend rpc default_rpc =
330
+
match rpc, default_rpc with
331
+
| 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)
338
+
| _, _ -> rpc
339
+
340
+
341
+
type callback = string list -> t -> unit
342
+
343
+
type call =
344
+
{ name : string
345
+
; params : t list
346
+
; is_notification : bool
347
+
}
348
+
349
+
let call name params = { name; params; is_notification = false }
350
+
let notification name params = { name; params; is_notification = true }
351
+
352
+
let string_of_call call =
353
+
Printf.sprintf
354
+
"-> %s(%s)"
355
+
call.name
356
+
(String.concat "," (List.map to_string call.params))
357
+
358
+
359
+
type response =
360
+
{ success : bool
361
+
; contents : t
362
+
; is_notification : bool
363
+
}
364
+
365
+
let string_of_response response =
366
+
Printf.sprintf
367
+
"<- %s(%s)"
368
+
(if response.success then "success" else "failure")
369
+
(to_string response.contents)
370
+
371
+
372
+
(* is_notification is to be set as true only if the call was a notification *)
373
+
374
+
let success v = { success = true; contents = v; is_notification = false }
375
+
let failure v = { success = false; contents = v; is_notification = false }
+220
idl/rpc.mli
+220
idl/rpc.mli
···
1
+
(*
2
+
* Copyright (c) 2006-2009 Citrix Systems Inc.
3
+
* Copyright (c) 2006-2014 Thomas Gazagnaire <thomas@gazagnaire.org>
4
+
*
5
+
* Permission to use, copy, modify, and distribute this software for any
6
+
* purpose with or without fee is hereby granted, provided that the above
7
+
* copyright notice and this permission notice appear in all copies.
8
+
*
9
+
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
10
+
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
11
+
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
12
+
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
13
+
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
14
+
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
15
+
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
16
+
*)
17
+
18
+
(** {2 Value} *)
19
+
type msg = [ `Msg of string ]
20
+
21
+
type t =
22
+
| Int of int64
23
+
| Int32 of int32
24
+
| Bool of bool
25
+
| Float of float
26
+
| String of string
27
+
| DateTime of string
28
+
| Enum of t list
29
+
| Dict of (string * t) list
30
+
| Base64 of string
31
+
| Null
32
+
33
+
val to_string : t -> string
34
+
35
+
module Version : sig
36
+
type t = int * int * int
37
+
38
+
val compare : t -> t -> int
39
+
end
40
+
41
+
(** {2 Type declarations} *)
42
+
module Types : sig
43
+
type _ basic =
44
+
| Int : int basic
45
+
| Int32 : int32 basic
46
+
| Int64 : int64 basic
47
+
| Bool : bool basic
48
+
| Float : float basic
49
+
| String : string basic
50
+
| Char : char basic
51
+
52
+
type _ typ =
53
+
| Basic : 'a basic -> 'a typ
54
+
| DateTime : string typ
55
+
| Base64 : string typ
56
+
| Array : 'a typ -> 'a array typ
57
+
| List : 'a typ -> 'a list typ
58
+
| Dict : 'a basic * 'b typ -> ('a * 'b) list typ
59
+
| Unit : unit typ
60
+
| Option : 'a typ -> 'a option typ
61
+
| Tuple : 'a typ * 'b typ -> ('a * 'b) typ
62
+
| Tuple3 : 'a typ * 'b typ * 'c typ -> ('a * 'b * 'c) typ
63
+
| Tuple4 : 'a typ * 'b typ * 'c typ * 'd typ -> ('a * 'b * 'c * 'd) typ
64
+
| Struct : 'a structure -> 'a typ
65
+
| Variant : 'a variant -> 'a typ
66
+
| Abstract : 'a abstract -> 'a typ
67
+
68
+
and 'a def =
69
+
{ name : string
70
+
; description : string list
71
+
; ty : 'a typ
72
+
}
73
+
74
+
and boxed_def = BoxedDef : 'a def -> boxed_def
75
+
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
+
}
85
+
86
+
and 'a boxed_field = BoxedField : ('a, 's) field -> 's boxed_field
87
+
88
+
and field_getter =
89
+
{ field_get : 'a. string -> 'a typ -> ('a, msg) result }
90
+
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
+
}
97
+
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
+
}
107
+
108
+
and 'a boxed_tag = BoxedTag : ('a, 's) tag -> 's boxed_tag
109
+
110
+
and tag_getter = { tget : 'a. 'a typ -> ('a, msg) result }
111
+
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
+
}
119
+
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
+
}
126
+
127
+
val int : int def
128
+
val int32 : int32 def
129
+
val int64 : int64 def
130
+
val bool : bool def
131
+
val float : float def
132
+
val string : string def
133
+
val char : char def
134
+
val unit : unit def
135
+
val default_types : boxed_def list
136
+
end
137
+
138
+
(** {2 Basic constructors} *)
139
+
140
+
val rpc_of_int64 : int64 -> t
141
+
val rpc_of_int32 : int32 -> t
142
+
val rpc_of_int : int -> t
143
+
val rpc_of_bool : bool -> t
144
+
val rpc_of_float : float -> t
145
+
val rpc_of_string : string -> t
146
+
val rpc_of_dateTime : string -> t
147
+
val rpc_of_base64 : string -> t
148
+
val rpc_of_t : t -> t
149
+
val rpc_of_unit : unit -> t
150
+
val rpc_of_char : char -> t
151
+
val int64_of_rpc : t -> int64
152
+
val int32_of_rpc : t -> int32
153
+
val int_of_rpc : t -> int
154
+
val bool_of_rpc : t -> bool
155
+
val float_of_rpc : t -> float
156
+
val string_of_rpc : t -> string
157
+
val dateTime_of_rpc : t -> string
158
+
val base64_of_rpc : t -> string
159
+
val t_of_rpc : t -> t
160
+
val char_of_rpc : t -> char
161
+
val unit_of_rpc : t -> unit
162
+
163
+
module ResultUnmarshallers : sig
164
+
val int64_of_rpc : t -> (int64, msg) result
165
+
val int32_of_rpc : t -> (int32, msg) result
166
+
val int_of_rpc : t -> (int, msg) result
167
+
val bool_of_rpc : t -> (bool, msg) result
168
+
val float_of_rpc : t -> (float, msg) result
169
+
val string_of_rpc : t -> (string, msg) result
170
+
val dateTime_of_rpc : t -> (string, msg) result
171
+
val base64_of_rpc : t -> (string, msg) result
172
+
val t_of_rpc : t -> (t, msg) result
173
+
val unit_of_rpc : t -> (unit, msg) result
174
+
val char_of_rpc : t -> (char, msg) result
175
+
end
176
+
177
+
(** {2 Calls} *)
178
+
179
+
type callback = string list -> t -> unit
180
+
181
+
type call =
182
+
{ name : string
183
+
; params : t list
184
+
; is_notification : bool
185
+
}
186
+
187
+
val call : string -> t list -> call
188
+
val notification : string -> t list -> call
189
+
val string_of_call : call -> string
190
+
191
+
(** {2 Responses} *)
192
+
193
+
type response =
194
+
{ success : bool
195
+
; contents : t
196
+
; is_notification : bool
197
+
}
198
+
199
+
val string_of_response : response -> string
200
+
val success : t -> response
201
+
val failure : t -> response
202
+
203
+
(** {2 Run-time errors} *)
204
+
205
+
exception Runtime_error of string * t
206
+
exception Runtime_exception of string * string
207
+
208
+
(** {2 Debug options} *)
209
+
val set_debug : bool -> unit
210
+
211
+
val get_debug : unit -> bool
212
+
213
+
(** Helper *)
214
+
val lowerfn : t -> t
215
+
216
+
(** [struct_extend rpc1 rpc2] first checks that [rpc1] and [rpc2] are both
217
+
* dictionaries. If this is the case then [struct_extend] will create a new
218
+
* [Rpc.t] which contains all key-value pairs from [rpc1], as well as all
219
+
* key-value pairs from [rpc2] for which the key does not exist in [rpc1]. *)
220
+
val struct_extend : t -> t -> t
+267
idl/rpcmarshal.ml
+267
idl/rpcmarshal.ml
···
1
+
(* Basic type definitions *)
2
+
open Rpc.Types
3
+
4
+
type err = [ `Msg of string ]
5
+
6
+
let tailrec_map f l = List.rev_map f l |> List.rev
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
10
+
let return x = Ok x
11
+
let ok x = Ok x
12
+
13
+
let rec unmarshal : type a. a typ -> Rpc.t -> (a, err) result =
14
+
fun t v ->
15
+
let open Rpc in
16
+
let open Rpc.ResultUnmarshallers in
17
+
let list_helper typ l =
18
+
List.fold_left
19
+
(fun acc v ->
20
+
match acc, unmarshal typ v with
21
+
| Ok a, Ok v -> Ok (v :: a)
22
+
| _, 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)))
29
+
| x, _ -> x)
30
+
(Ok [])
31
+
l
32
+
>>| List.rev
33
+
in
34
+
match t with
35
+
| Basic Int -> int_of_rpc v
36
+
| Basic Int32 -> int32_of_rpc v
37
+
| Basic Int64 -> int64_of_rpc v
38
+
| Basic Bool -> bool_of_rpc v
39
+
| Basic Float -> float_of_rpc v
40
+
| Basic String -> string_of_rpc v
41
+
| Basic Char -> int_of_rpc v >>| Char.chr
42
+
| DateTime -> dateTime_of_rpc v
43
+
| 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"))
69
+
| 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)))
132
+
| 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
140
+
| Abstract { of_rpc; _ } -> of_rpc v
141
+
142
+
143
+
let rec marshal : type a. a typ -> a -> Rpc.t =
144
+
fun t v ->
145
+
let open Rpc in
146
+
let rpc_of_basic : type a. a basic -> a -> Rpc.t =
147
+
fun t v ->
148
+
match t with
149
+
| Int -> rpc_of_int v
150
+
| Int32 -> rpc_of_int32 v
151
+
| Int64 -> rpc_of_int64 v
152
+
| Bool -> rpc_of_bool v
153
+
| Float -> rpc_of_float v
154
+
| String -> rpc_of_string v
155
+
| Char -> rpc_of_int (Char.code v)
156
+
in
157
+
match t with
158
+
| Basic t -> rpc_of_basic t v
159
+
| DateTime -> rpc_of_dateTime v
160
+
| Base64 -> rpc_of_base64 v
161
+
| Array typ -> Enum (tailrec_map (marshal typ) (Array.to_list v))
162
+
| List (Tuple (Basic String, typ)) ->
163
+
Dict (tailrec_map (fun (x, y) -> x, marshal typ y) v)
164
+
| List typ -> Enum (tailrec_map (marshal typ) v)
165
+
| Dict (String, typ) -> Rpc.Dict (tailrec_map (fun (k, v) -> k, marshal typ v) v)
166
+
| Dict (basic, typ) ->
167
+
Rpc.Enum
168
+
(tailrec_map (fun (k, v) -> Rpc.Enum [ rpc_of_basic basic k; marshal typ v ]) v)
169
+
| Unit -> rpc_of_unit v
170
+
| 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")
179
+
| Tuple (x, y) -> Rpc.Enum [ marshal x (fst v); marshal y (snd v) ]
180
+
| Tuple3 (x, y, z) ->
181
+
let vx, vy, vz = v in
182
+
Rpc.Enum [ marshal x vx; marshal y vy; marshal z vz ]
183
+
| 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 ]
186
+
| Struct { fields; _ } ->
187
+
let fields =
188
+
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
214
+
| Abstract { rpc_of; _ } -> rpc_of v
215
+
216
+
217
+
let ocaml_of_basic : type a. a basic -> string = function
218
+
| Int64 -> "int64"
219
+
| Int32 -> "int32"
220
+
| Int -> "int"
221
+
| String -> "string"
222
+
| Float -> "float"
223
+
| Bool -> "bool"
224
+
| Char -> "char"
225
+
226
+
227
+
let rec ocaml_of_t : type a. a typ -> string = function
228
+
| Basic b -> ocaml_of_basic b
229
+
| DateTime -> "string"
230
+
| Base64 -> "base64"
231
+
| Array t -> ocaml_of_t t ^ " list"
232
+
| List t -> ocaml_of_t t ^ " list"
233
+
| Dict (b, t) -> Printf.sprintf "(%s * %s) list" (ocaml_of_basic b) (ocaml_of_t t)
234
+
| Unit -> "unit"
235
+
| Option t -> ocaml_of_t t ^ " option"
236
+
| Tuple (a, b) -> Printf.sprintf "(%s * %s)" (ocaml_of_t a) (ocaml_of_t b)
237
+
| Tuple3 (a, b, c) ->
238
+
Printf.sprintf "(%s * %s * %s)" (ocaml_of_t a) (ocaml_of_t b) (ocaml_of_t c)
239
+
| 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)
246
+
| 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)
254
+
| 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
267
+
| Abstract _ -> "<abstract>"
+94
idl/toplevel_api.ml
+94
idl/toplevel_api.ml
···
1
+
(** IDL for talking to the toplevel webworker *)
2
+
3
+
open Rpc
4
+
open Idl
5
+
6
+
(** An area to be highlighted *)
7
+
type highlight =
8
+
{ line1 : int
9
+
; line2 : int
10
+
; col1 : int
11
+
; col2 : int
12
+
}
13
+
[@@deriving rpcty]
14
+
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
+
}
23
+
[@@deriving rpcty]
24
+
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
29
+
inserted *)
30
+
; completions : string list (** The list of possible completions *)
31
+
}
32
+
[@@deriving rpcty]
33
+
34
+
(** For now we are only using a simple error type *)
35
+
type err = InternalError of string [@@deriving rpcty]
36
+
37
+
module E = Idl.Error.Make (struct
38
+
type t = err
39
+
40
+
let t = err
41
+
42
+
let internal_error_of e = Some (InternalError (Printexc.to_string e))
43
+
end)
44
+
45
+
let err = E.error
46
+
47
+
module Make (R : RPC) = struct
48
+
open R
49
+
50
+
let description =
51
+
Interface.
52
+
{ name = "Toplevel"
53
+
; namespace = None
54
+
; description =
55
+
[ "Functions for manipulating the toplevel worker thread" ]
56
+
; version = 1, 0, 0
57
+
}
58
+
59
+
let implementation = implement description
60
+
61
+
let unit_p = Param.mk Types.unit
62
+
63
+
let phrase_p = Param.mk Types.string
64
+
65
+
let exec_result_p = Param.mk exec_result
66
+
67
+
let completion_p = Param.mk completion_result
68
+
69
+
let setup =
70
+
declare
71
+
"setup"
72
+
[ "Initialise the toplevel. Return value is the initial blurb "
73
+
; "printed when starting a toplevel."
74
+
]
75
+
(unit_p @-> returning exec_result_p err)
76
+
77
+
let exec =
78
+
declare
79
+
"exec"
80
+
[ "Execute a phrase using the toplevel. The toplevel must have been"
81
+
; "Initialised first."
82
+
]
83
+
(phrase_p @-> returning exec_result_p err)
84
+
85
+
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."
92
+
]
93
+
(phrase_p @-> returning completion_p err)
94
+
end
+409
idl/toplevel_api_gen.ml
+409
idl/toplevel_api_gen.ml
···
1
+
[@@@ocaml.ppx.context
2
+
{
3
+
tool_name = "ppx_driver";
4
+
include_dirs = [];
5
+
load_path = [];
6
+
open_modules = [];
7
+
for_package = None;
8
+
debug = false;
9
+
use_threads = false;
10
+
use_vmthreads = false;
11
+
recursive_types = false;
12
+
principal = false;
13
+
transparent_modules = false;
14
+
unboxed_types = false;
15
+
unsafe_string = false;
16
+
cookies = [("library-name", "js_top_worker_rpc_dummy")]
17
+
}]
18
+
[@@@ocaml.text " IDL for talking to the toplevel webworker "]
19
+
open Rpc
20
+
open Idl
21
+
type highlight = {
22
+
line1: int ;
23
+
line2: int ;
24
+
col1: int ;
25
+
col2: int }[@@ocaml.doc " An area to be highlighted "][@@deriving rpcty]
26
+
include
27
+
struct
28
+
let _ = fun (_ : highlight) -> ()
29
+
let rec (highlight_line1 : (_, highlight) Rpc.Types.field) =
30
+
{
31
+
Rpc.Types.fname = "line1";
32
+
Rpc.Types.field = (let open Rpc.Types in Basic Int);
33
+
Rpc.Types.fdefault = None;
34
+
Rpc.Types.fdescription = [];
35
+
Rpc.Types.fversion = None;
36
+
Rpc.Types.fget = (fun _r -> _r.line1);
37
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with line1 = v })
38
+
}
39
+
and (highlight_line2 : (_, highlight) Rpc.Types.field) =
40
+
{
41
+
Rpc.Types.fname = "line2";
42
+
Rpc.Types.field = (let open Rpc.Types in Basic Int);
43
+
Rpc.Types.fdefault = None;
44
+
Rpc.Types.fdescription = [];
45
+
Rpc.Types.fversion = None;
46
+
Rpc.Types.fget = (fun _r -> _r.line2);
47
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with line2 = v })
48
+
}
49
+
and (highlight_col1 : (_, highlight) Rpc.Types.field) =
50
+
{
51
+
Rpc.Types.fname = "col1";
52
+
Rpc.Types.field = (let open Rpc.Types in Basic Int);
53
+
Rpc.Types.fdefault = None;
54
+
Rpc.Types.fdescription = [];
55
+
Rpc.Types.fversion = None;
56
+
Rpc.Types.fget = (fun _r -> _r.col1);
57
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with col1 = v })
58
+
}
59
+
and (highlight_col2 : (_, highlight) Rpc.Types.field) =
60
+
{
61
+
Rpc.Types.fname = "col2";
62
+
Rpc.Types.field = (let open Rpc.Types in Basic Int);
63
+
Rpc.Types.fdefault = None;
64
+
Rpc.Types.fdescription = [];
65
+
Rpc.Types.fversion = None;
66
+
Rpc.Types.fget = (fun _r -> _r.col2);
67
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with col2 = v })
68
+
}
69
+
and typ_of_highlight =
70
+
Rpc.Types.Struct
71
+
({
72
+
Rpc.Types.fields =
73
+
[Rpc.Types.BoxedField highlight_line1;
74
+
Rpc.Types.BoxedField highlight_line2;
75
+
Rpc.Types.BoxedField highlight_col1;
76
+
Rpc.Types.BoxedField highlight_col2];
77
+
Rpc.Types.sname = "highlight";
78
+
Rpc.Types.version = None;
79
+
Rpc.Types.constructor =
80
+
(fun getter ->
81
+
let open Rresult.R in
82
+
(getter.Rpc.Types.field_get "col2"
83
+
(let open Rpc.Types in Basic Int))
84
+
>>=
85
+
(fun highlight_col2 ->
86
+
(getter.Rpc.Types.field_get "col1"
87
+
(let open Rpc.Types in Basic Int))
88
+
>>=
89
+
(fun highlight_col1 ->
90
+
(getter.Rpc.Types.field_get "line2"
91
+
(let open Rpc.Types in Basic Int))
92
+
>>=
93
+
(fun highlight_line2 ->
94
+
(getter.Rpc.Types.field_get "line1"
95
+
(let open Rpc.Types in Basic Int))
96
+
>>=
97
+
(fun highlight_line1 ->
98
+
return
99
+
{
100
+
line1 = highlight_line1;
101
+
line2 = highlight_line2;
102
+
col1 = highlight_col1;
103
+
col2 = highlight_col2
104
+
})))))
105
+
} : highlight Rpc.Types.structure)
106
+
and highlight =
107
+
{
108
+
Rpc.Types.name = "highlight";
109
+
Rpc.Types.description = ["An area to be highlighted"];
110
+
Rpc.Types.ty = typ_of_highlight
111
+
}
112
+
let _ = highlight_line1
113
+
and _ = highlight_line2
114
+
and _ = highlight_col1
115
+
and _ = highlight_col2
116
+
and _ = typ_of_highlight
117
+
and _ = highlight
118
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
119
+
type exec_result =
120
+
{
121
+
stdout: string option ;
122
+
stderr: string option ;
123
+
sharp_ppf: string option ;
124
+
caml_ppf: string option ;
125
+
highlight: highlight option }[@@ocaml.doc
126
+
" Represents the result of executing a toplevel phrase "]
127
+
[@@deriving rpcty]
128
+
include
129
+
struct
130
+
let _ = fun (_ : exec_result) -> ()
131
+
let rec (exec_result_stdout : (_, exec_result) Rpc.Types.field) =
132
+
{
133
+
Rpc.Types.fname = "stdout";
134
+
Rpc.Types.field =
135
+
(Rpc.Types.Option (let open Rpc.Types in Basic String));
136
+
Rpc.Types.fdefault = None;
137
+
Rpc.Types.fdescription = [];
138
+
Rpc.Types.fversion = None;
139
+
Rpc.Types.fget = (fun _r -> _r.stdout);
140
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with stdout = v })
141
+
}
142
+
and (exec_result_stderr : (_, exec_result) Rpc.Types.field) =
143
+
{
144
+
Rpc.Types.fname = "stderr";
145
+
Rpc.Types.field =
146
+
(Rpc.Types.Option (let open Rpc.Types in Basic String));
147
+
Rpc.Types.fdefault = None;
148
+
Rpc.Types.fdescription = [];
149
+
Rpc.Types.fversion = None;
150
+
Rpc.Types.fget = (fun _r -> _r.stderr);
151
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with stderr = v })
152
+
}
153
+
and (exec_result_sharp_ppf : (_, exec_result) Rpc.Types.field) =
154
+
{
155
+
Rpc.Types.fname = "sharp_ppf";
156
+
Rpc.Types.field =
157
+
(Rpc.Types.Option (let open Rpc.Types in Basic String));
158
+
Rpc.Types.fdefault = None;
159
+
Rpc.Types.fdescription = [];
160
+
Rpc.Types.fversion = None;
161
+
Rpc.Types.fget = (fun _r -> _r.sharp_ppf);
162
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with sharp_ppf = v })
163
+
}
164
+
and (exec_result_caml_ppf : (_, exec_result) Rpc.Types.field) =
165
+
{
166
+
Rpc.Types.fname = "caml_ppf";
167
+
Rpc.Types.field =
168
+
(Rpc.Types.Option (let open Rpc.Types in Basic String));
169
+
Rpc.Types.fdefault = None;
170
+
Rpc.Types.fdescription = [];
171
+
Rpc.Types.fversion = None;
172
+
Rpc.Types.fget = (fun _r -> _r.caml_ppf);
173
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with caml_ppf = v })
174
+
}
175
+
and (exec_result_highlight : (_, exec_result) Rpc.Types.field) =
176
+
{
177
+
Rpc.Types.fname = "highlight";
178
+
Rpc.Types.field = (Rpc.Types.Option typ_of_highlight);
179
+
Rpc.Types.fdefault = None;
180
+
Rpc.Types.fdescription = [];
181
+
Rpc.Types.fversion = None;
182
+
Rpc.Types.fget = (fun _r -> _r.highlight);
183
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with highlight = v })
184
+
}
185
+
and typ_of_exec_result =
186
+
Rpc.Types.Struct
187
+
({
188
+
Rpc.Types.fields =
189
+
[Rpc.Types.BoxedField exec_result_stdout;
190
+
Rpc.Types.BoxedField exec_result_stderr;
191
+
Rpc.Types.BoxedField exec_result_sharp_ppf;
192
+
Rpc.Types.BoxedField exec_result_caml_ppf;
193
+
Rpc.Types.BoxedField exec_result_highlight];
194
+
Rpc.Types.sname = "exec_result";
195
+
Rpc.Types.version = None;
196
+
Rpc.Types.constructor =
197
+
(fun getter ->
198
+
let open Rresult.R in
199
+
(getter.Rpc.Types.field_get "highlight"
200
+
(Rpc.Types.Option typ_of_highlight))
201
+
>>=
202
+
(fun exec_result_highlight ->
203
+
(getter.Rpc.Types.field_get "caml_ppf"
204
+
(Rpc.Types.Option
205
+
(let open Rpc.Types in Basic String)))
206
+
>>=
207
+
(fun exec_result_caml_ppf ->
208
+
(getter.Rpc.Types.field_get "sharp_ppf"
209
+
(Rpc.Types.Option
210
+
(let open Rpc.Types in Basic String)))
211
+
>>=
212
+
(fun exec_result_sharp_ppf ->
213
+
(getter.Rpc.Types.field_get "stderr"
214
+
(Rpc.Types.Option
215
+
(let open Rpc.Types in Basic String)))
216
+
>>=
217
+
(fun exec_result_stderr ->
218
+
(getter.Rpc.Types.field_get "stdout"
219
+
(Rpc.Types.Option
220
+
(let open Rpc.Types in
221
+
Basic String)))
222
+
>>=
223
+
(fun exec_result_stdout ->
224
+
return
225
+
{
226
+
stdout = exec_result_stdout;
227
+
stderr = exec_result_stderr;
228
+
sharp_ppf =
229
+
exec_result_sharp_ppf;
230
+
caml_ppf =
231
+
exec_result_caml_ppf;
232
+
highlight =
233
+
exec_result_highlight
234
+
}))))))
235
+
} : exec_result Rpc.Types.structure)
236
+
and exec_result =
237
+
{
238
+
Rpc.Types.name = "exec_result";
239
+
Rpc.Types.description =
240
+
["Represents the result of executing a toplevel phrase"];
241
+
Rpc.Types.ty = typ_of_exec_result
242
+
}
243
+
let _ = exec_result_stdout
244
+
and _ = exec_result_stderr
245
+
and _ = exec_result_sharp_ppf
246
+
and _ = exec_result_caml_ppf
247
+
and _ = exec_result_highlight
248
+
and _ = typ_of_exec_result
249
+
and _ = exec_result
250
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
251
+
type completion_result =
252
+
{
253
+
n: int
254
+
[@ocaml.doc
255
+
" The position in the input string from where the completions may be\n inserted "];
256
+
completions: string list [@ocaml.doc " The list of possible completions "]}
257
+
[@@ocaml.doc " The result returned by a 'complete' call. "][@@deriving rpcty]
258
+
include
259
+
struct
260
+
let _ = fun (_ : completion_result) -> ()
261
+
let rec (completion_result_n : (_, completion_result) Rpc.Types.field) =
262
+
{
263
+
Rpc.Types.fname = "n";
264
+
Rpc.Types.field = (let open Rpc.Types in Basic Int);
265
+
Rpc.Types.fdefault = None;
266
+
Rpc.Types.fdescription =
267
+
["The position in the input string from where the completions may be";
268
+
"inserted"];
269
+
Rpc.Types.fversion = None;
270
+
Rpc.Types.fget = (fun _r -> _r.n);
271
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with n = v })
272
+
}
273
+
and (completion_result_completions :
274
+
(_, completion_result) Rpc.Types.field) =
275
+
{
276
+
Rpc.Types.fname = "completions";
277
+
Rpc.Types.field =
278
+
(Rpc.Types.List (let open Rpc.Types in Basic String));
279
+
Rpc.Types.fdefault = None;
280
+
Rpc.Types.fdescription = ["The list of possible completions"];
281
+
Rpc.Types.fversion = None;
282
+
Rpc.Types.fget = (fun _r -> _r.completions);
283
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with completions = v })
284
+
}
285
+
and typ_of_completion_result =
286
+
Rpc.Types.Struct
287
+
({
288
+
Rpc.Types.fields =
289
+
[Rpc.Types.BoxedField completion_result_n;
290
+
Rpc.Types.BoxedField completion_result_completions];
291
+
Rpc.Types.sname = "completion_result";
292
+
Rpc.Types.version = None;
293
+
Rpc.Types.constructor =
294
+
(fun getter ->
295
+
let open Rresult.R in
296
+
(getter.Rpc.Types.field_get "completions"
297
+
(Rpc.Types.List (let open Rpc.Types in Basic String)))
298
+
>>=
299
+
(fun completion_result_completions ->
300
+
(getter.Rpc.Types.field_get "n"
301
+
(let open Rpc.Types in Basic Int))
302
+
>>=
303
+
(fun completion_result_n ->
304
+
return
305
+
{
306
+
n = completion_result_n;
307
+
completions = completion_result_completions
308
+
})))
309
+
} : completion_result Rpc.Types.structure)
310
+
and completion_result =
311
+
{
312
+
Rpc.Types.name = "completion_result";
313
+
Rpc.Types.description = ["The result returned by a 'complete' call."];
314
+
Rpc.Types.ty = typ_of_completion_result
315
+
}
316
+
let _ = completion_result_n
317
+
and _ = completion_result_completions
318
+
and _ = typ_of_completion_result
319
+
and _ = completion_result
320
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
321
+
type err =
322
+
| InternalError of string [@@ocaml.doc
323
+
" For now we are only using a simple error type "]
324
+
[@@deriving rpcty]
325
+
include
326
+
struct
327
+
let _ = fun (_ : err) -> ()
328
+
let rec typ_of_err =
329
+
Rpc.Types.Variant
330
+
({
331
+
Rpc.Types.vname = "err";
332
+
Rpc.Types.variants =
333
+
[BoxedTag
334
+
{
335
+
Rpc.Types.tname = "InternalError";
336
+
Rpc.Types.tcontents =
337
+
((let open Rpc.Types in Basic String));
338
+
Rpc.Types.tversion = None;
339
+
Rpc.Types.tdescription = [];
340
+
Rpc.Types.tpreview =
341
+
((function | InternalError a0 -> Some a0));
342
+
Rpc.Types.treview = ((function | a0 -> InternalError a0))
343
+
}];
344
+
Rpc.Types.vdefault = None;
345
+
Rpc.Types.vversion = None;
346
+
Rpc.Types.vconstructor =
347
+
(fun s' ->
348
+
fun t ->
349
+
let s = String.lowercase_ascii s' in
350
+
match s with
351
+
| "internalerror" ->
352
+
Rresult.R.bind
353
+
(t.tget (let open Rpc.Types in Basic String))
354
+
(function | a0 -> Rresult.R.ok (InternalError a0))
355
+
| _ ->
356
+
Rresult.R.error_msg
357
+
(Printf.sprintf "Unknown tag '%s'" s))
358
+
} : err Rpc.Types.variant)
359
+
and err =
360
+
{
361
+
Rpc.Types.name = "err";
362
+
Rpc.Types.description =
363
+
["For now we are only using a simple error type"];
364
+
Rpc.Types.ty = typ_of_err
365
+
}
366
+
let _ = typ_of_err
367
+
and _ = err
368
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
369
+
module E =
370
+
(Idl.Error.Make)(struct
371
+
type t = err
372
+
let t = err
373
+
let internal_error_of e =
374
+
Some (InternalError (Printexc.to_string e))
375
+
end)
376
+
let err = E.error
377
+
module Make(R:RPC) =
378
+
struct
379
+
open R
380
+
let description =
381
+
let open Interface in
382
+
{
383
+
name = "Toplevel";
384
+
namespace = None;
385
+
description =
386
+
["Functions for manipulating the toplevel worker thread"];
387
+
version = (1, 0, 0)
388
+
}
389
+
let implementation = implement description
390
+
let unit_p = Param.mk Types.unit
391
+
let phrase_p = Param.mk Types.string
392
+
let exec_result_p = Param.mk exec_result
393
+
let completion_p = Param.mk completion_result
394
+
let setup =
395
+
declare "setup"
396
+
["Initialise the toplevel. Return value is the initial blurb ";
397
+
"printed when starting a toplevel."]
398
+
(unit_p @-> (returning exec_result_p err))
399
+
let exec =
400
+
declare "exec"
401
+
["Execute a phrase using the toplevel. The toplevel must have been";
402
+
"Initialised first."] (phrase_p @-> (returning exec_result_p err))
403
+
let complete =
404
+
declare "complete"
405
+
["Find completions of the incomplete phrase. Completion occurs at the";
406
+
"end of the phrase passed in. If completion is required at a point";
407
+
"other than the end of a string, then take the substring before calling";
408
+
"this API."] (phrase_p @-> (returning completion_p err))
409
+
end
js_top_worker.opam
js_top_worker.opam
This is a binary file and will not be displayed.
js_top_worker_codegen.opam
js_top_worker_codegen.opam
This is a binary file and will not be displayed.
+23
lib/dune
+23
lib/dune
···
1
+
; Worker library
2
+
3
+
(library
4
+
(name worker)
5
+
(modules worker uTop_complete uTop_lexer uTop_token uTop)
6
+
(libraries
7
+
js_top_worker_rpc
8
+
js_of_ocaml-toplevel
9
+
js_of_ocaml-compiler
10
+
astring
11
+
)
12
+
(preprocess
13
+
(per_module
14
+
((action
15
+
(run %{bin:cppo} -V OCAML:%{ocaml_version} %{input-file}))
16
+
uTop_complete
17
+
uTop)
18
+
((pps js_of_ocaml-ppx)
19
+
worker))))
20
+
21
+
(ocamllex uTop_lexer)
22
+
23
+
+339
lib/uTop.ml
+339
lib/uTop.ml
···
1
+
(*
2
+
* uTop.ml
3
+
* -------
4
+
* Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
5
+
* Licence : BSD3
6
+
*
7
+
* This file is a part of utop.
8
+
*)
9
+
10
+
[@@@warning "-27"]
11
+
12
+
13
+
module String_set = Set.Make(String)
14
+
15
+
let version = "2.7.0"
16
+
17
+
(* +-----------------------------------------------------------------+
18
+
| Keywords |
19
+
+-----------------------------------------------------------------+ *)
20
+
21
+
let default_keywords = [
22
+
"and"; "as"; "assert"; "begin"; "class"; "constraint"; "do";
23
+
"done"; "downto"; "else"; "end"; "exception"; "external";
24
+
"for"; "fun"; "function"; "functor"; "if"; "in"; "include";
25
+
"inherit"; "initializer"; "lazy"; "let"; "match"; "method"; "module";
26
+
"mutable"; "new"; "object"; "of"; "open"; "private"; "rec"; "sig";
27
+
"struct"; "then"; "to"; "try"; "type"; "val"; "virtual";
28
+
"when"; "while"; "with"; "try_lwt"; "finally"; "for_lwt"; "lwt";
29
+
]
30
+
31
+
let keywords = ref (String_set.of_list default_keywords)
32
+
let add_keyword kwd = keywords := String_set.add kwd !keywords
33
+
34
+
(* +-----------------------------------------------------------------+
35
+
| Error reporting |
36
+
+-----------------------------------------------------------------+ *)
37
+
38
+
let get_message func x =
39
+
let buffer = Buffer.create 1024 in
40
+
let pp = Format.formatter_of_buffer buffer in
41
+
func pp x;
42
+
Format.pp_print_flush pp ();
43
+
Buffer.contents buffer
44
+
45
+
let get_ocaml_error_message exn =
46
+
let buffer = Buffer.create 1024 in
47
+
let pp = Format.formatter_of_buffer buffer in
48
+
Errors.report_error pp exn;
49
+
Format.pp_print_flush pp ();
50
+
let str = Buffer.contents buffer in
51
+
try
52
+
Scanf.sscanf
53
+
str
54
+
"Characters %d-%d:\n%[\000-\255]"
55
+
(fun start stop msg -> ((start, stop), msg))
56
+
with _ ->
57
+
((0, 0), str)
58
+
59
+
let collect_formatters buf pps f =
60
+
(* First flush all formatters. *)
61
+
List.iter (fun pp -> Format.pp_print_flush pp ()) pps;
62
+
(* Save all formatter functions. *)
63
+
let save = List.map (fun pp -> Format.pp_get_formatter_out_functions pp ()) pps in
64
+
let restore () =
65
+
List.iter2
66
+
(fun pp out_functions ->
67
+
Format.pp_print_flush pp ();
68
+
Format.pp_set_formatter_out_functions pp out_functions)
69
+
pps save
70
+
in
71
+
(* Output functions. *)
72
+
let out_functions =
73
+
let ppb = Format.formatter_of_buffer buf in
74
+
Format.pp_get_formatter_out_functions ppb ()
75
+
in
76
+
(* Replace formatter functions. *)
77
+
List.iter
78
+
(fun pp ->
79
+
Format.pp_set_formatter_out_functions pp out_functions)
80
+
pps;
81
+
try
82
+
let x = f () in
83
+
restore ();
84
+
x
85
+
with exn ->
86
+
restore ();
87
+
raise exn
88
+
89
+
let discard_formatters pps f =
90
+
(* First flush all formatters. *)
91
+
List.iter (fun pp -> Format.pp_print_flush pp ()) pps;
92
+
(* Save all formatter functions. *)
93
+
let save = List.map (fun pp -> Format.pp_get_formatter_out_functions pp ()) pps in
94
+
let restore () =
95
+
List.iter2
96
+
(fun pp out_functions ->
97
+
Format.pp_print_flush pp ();
98
+
Format.pp_set_formatter_out_functions pp out_functions)
99
+
pps save
100
+
in
101
+
(* Output functions. *)
102
+
let out_functions = {
103
+
Format.out_string = (fun _ _ _ -> ()); out_flush = ignore;
104
+
out_newline = ignore; out_spaces = ignore
105
+
#if OCAML_VERSION >= (4, 06, 0)
106
+
; out_indent = ignore
107
+
#endif
108
+
} in
109
+
(* Replace formatter functions. *)
110
+
List.iter (fun pp -> Format.pp_set_formatter_out_functions pp out_functions) pps;
111
+
try
112
+
let x = f () in
113
+
restore ();
114
+
x
115
+
with exn ->
116
+
restore ();
117
+
raise exn
118
+
119
+
(* +-----------------------------------------------------------------+
120
+
| Parsing |
121
+
+-----------------------------------------------------------------+ *)
122
+
123
+
type location = int * int
124
+
125
+
type 'a result =
126
+
| Value of 'a
127
+
| Error of location list * string
128
+
129
+
exception Need_more
130
+
131
+
let input_name = "//toplevel//"
132
+
133
+
let lexbuf_of_string eof str =
134
+
let pos = ref 0 in
135
+
let lexbuf =
136
+
Lexing.from_function
137
+
(fun buf len ->
138
+
if !pos = String.length str then begin
139
+
eof := true;
140
+
0
141
+
end else begin
142
+
let len = min len (String.length str - !pos) in
143
+
String.blit str !pos buf 0 len;
144
+
pos := !pos + len;
145
+
len
146
+
end)
147
+
in
148
+
Location.init lexbuf input_name;
149
+
lexbuf
150
+
151
+
let mkloc loc =
152
+
(loc.Location.loc_start.Lexing.pos_cnum,
153
+
loc.Location.loc_end.Lexing.pos_cnum)
154
+
155
+
let parse_default parse str eos_is_error =
156
+
let eof = ref false in
157
+
let lexbuf = lexbuf_of_string eof str in
158
+
try
159
+
(* Try to parse the phrase. *)
160
+
let phrase = parse lexbuf in
161
+
Value phrase
162
+
with
163
+
| _ when !eof && not eos_is_error ->
164
+
(* This is not an error, we just need more input. *)
165
+
raise Need_more
166
+
| End_of_file ->
167
+
(* If the string is empty, do not report an error. *)
168
+
raise Need_more
169
+
| Lexer.Error (error, loc) ->
170
+
#if OCAML_VERSION >= (4, 08, 0)
171
+
(match Location.error_of_exn (Lexer.Error (error, loc)) with
172
+
| Some (`Ok error)->
173
+
Error ([mkloc loc], get_message Location.print_report error)
174
+
| _-> raise Need_more)
175
+
#else
176
+
Error ([mkloc loc], get_message Lexer.report_error error)
177
+
#endif
178
+
| Syntaxerr.Error error -> begin
179
+
match error with
180
+
| Syntaxerr.Unclosed (opening_loc, opening, closing_loc, closing) ->
181
+
Error ([mkloc opening_loc; mkloc closing_loc],
182
+
Printf.sprintf "Syntax error: '%s' expected, the highlighted '%s' might be unmatched" closing opening)
183
+
| Syntaxerr.Applicative_path loc ->
184
+
Error ([mkloc loc],
185
+
"Syntax error: applicative paths of the form F(X).t are not supported when the option -no-app-funct is set.")
186
+
| Syntaxerr.Other loc ->
187
+
Error ([mkloc loc],
188
+
"Syntax error")
189
+
| Syntaxerr.Expecting (loc, nonterm) ->
190
+
Error ([mkloc loc],
191
+
Printf.sprintf "Syntax error: %s expected." nonterm)
192
+
| Syntaxerr.Variable_in_scope (loc, var) ->
193
+
Error ([mkloc loc],
194
+
Printf.sprintf "In this scoped type, variable '%s is reserved for the local type %s." var var)
195
+
| Syntaxerr.Not_expecting (loc, nonterm) ->
196
+
Error ([mkloc loc],
197
+
Printf.sprintf "Syntax error: %s not expected" nonterm)
198
+
| Syntaxerr.Ill_formed_ast (loc, s) ->
199
+
Error ([mkloc loc],
200
+
Printf.sprintf "Error: broken invariant in parsetree: %s" s)
201
+
#if OCAML_VERSION >= (4, 03, 0)
202
+
| Syntaxerr.Invalid_package_type (loc, s) ->
203
+
Error ([mkloc loc],
204
+
Printf.sprintf "Invalid package type: %s" s)
205
+
#endif
206
+
end
207
+
| Syntaxerr.Escape_error | Parsing.Parse_error ->
208
+
Error ([mkloc (Location.curr lexbuf)],
209
+
"Syntax error")
210
+
| exn ->
211
+
Error ([], "Unknown parsing error (please report it to the utop project): " ^ Printexc.to_string exn)
212
+
213
+
let parse_toplevel_phrase_default = parse_default Parse.toplevel_phrase
214
+
let parse_toplevel_phrase = ref parse_toplevel_phrase_default
215
+
216
+
(* +-----------------------------------------------------------------+
217
+
| Safety checking |
218
+
+-----------------------------------------------------------------+ *)
219
+
220
+
let null = Format.make_formatter (fun str ofs len -> ()) ignore
221
+
222
+
let rec last head tail =
223
+
match tail with
224
+
| [] ->
225
+
head
226
+
| head :: tail ->
227
+
last head tail
228
+
229
+
let with_loc loc str = {
230
+
Location.txt = str;
231
+
Location.loc = loc;
232
+
}
233
+
234
+
#if OCAML_VERSION >= (4, 03, 0)
235
+
let nolabel = Asttypes.Nolabel
236
+
#else
237
+
let nolabel = ""
238
+
#endif
239
+
240
+
(* Check that the given phrase can be evaluated without typing/compile
241
+
errors. *)
242
+
let check_phrase phrase =
243
+
let open Parsetree in
244
+
match phrase with
245
+
| Ptop_dir _ ->
246
+
None
247
+
| Ptop_def [] ->
248
+
None
249
+
| Ptop_def (item :: items) ->
250
+
let loc = {
251
+
Location.loc_start = item.pstr_loc.Location.loc_start;
252
+
Location.loc_end = (last item items).pstr_loc.Location.loc_end;
253
+
Location.loc_ghost = false;
254
+
} in
255
+
(* Backup. *)
256
+
let snap = Btype.snapshot () in
257
+
let env = !Toploop.toplevel_env in
258
+
(* Construct "let _ () = let module _ = struct <items> end in ()" in order to test
259
+
the typing and compilation of [items] without evaluating them. *)
260
+
let unit = with_loc loc (Longident.Lident "()") in
261
+
let top_def =
262
+
let open Ast_helper in
263
+
with_default_loc loc
264
+
(fun () ->
265
+
Str.eval
266
+
(Exp.fun_ nolabel None (Pat.construct unit None)
267
+
(Exp.letmodule (with_loc loc
268
+
#if OCAML_VERSION >= (4, 10, 0)
269
+
(Some "_")
270
+
#else
271
+
"_"
272
+
#endif
273
+
)
274
+
(Mod.structure (item :: items))
275
+
(Exp.construct unit None))))
276
+
in
277
+
let check_phrase = Ptop_def [top_def] in
278
+
try
279
+
let _ =
280
+
discard_formatters [Format.err_formatter] (fun () ->
281
+
Env.reset_cache_toplevel ();
282
+
Toploop.execute_phrase false null check_phrase)
283
+
in
284
+
(* The phrase is safe. *)
285
+
Toploop.toplevel_env := env;
286
+
Btype.backtrack snap;
287
+
None
288
+
with exn ->
289
+
(* The phrase contains errors. *)
290
+
let loc, msg = get_ocaml_error_message exn in
291
+
Toploop.toplevel_env := env;
292
+
Btype.backtrack snap;
293
+
Some ([loc], msg)
294
+
295
+
296
+
297
+
(*let try_finally ~always work=
298
+
#if OCAML_VERSION >= (4, 08, 0)
299
+
Misc.try_finally ~always work
300
+
#else
301
+
Misc.try_finally work always
302
+
#endif
303
+
304
+
let use_output command =
305
+
let fn = Filename.temp_file "ocaml" "_toploop.ml" in
306
+
try_finally ~always:(fun () ->
307
+
try Sys.remove fn with Sys_error _ -> ())
308
+
(fun () ->
309
+
match
310
+
Printf.ksprintf Sys.command "%s > %s"
311
+
command
312
+
(Filename.quote fn)
313
+
with
314
+
| 0 ->
315
+
ignore (Toploop.use_file Format.std_formatter fn : bool)
316
+
| n ->
317
+
Format.printf "Command exited with code %d.@." n)
318
+
319
+
let () =
320
+
let name = "use_output" in
321
+
if not (Hashtbl.mem Toploop.directive_table name) then
322
+
Hashtbl.add
323
+
Toploop.directive_table
324
+
name
325
+
(Toploop.Directive_string use_output)
326
+
*)
327
+
328
+
(* +-----------------------------------------------------------------+
329
+
| Compiler-libs re-exports |
330
+
+-----------------------------------------------------------------+ *)
331
+
332
+
#if OCAML_VERSION >= (4, 08, 0)
333
+
let get_load_path ()= Load_path.get_paths ()
334
+
let set_load_path path= Load_path.init path
335
+
#else
336
+
let get_load_path ()= !Config.load_path
337
+
let set_load_path path= Config.load_path := path
338
+
#endif
339
+
+105
lib/uTop.mli
+105
lib/uTop.mli
···
1
+
(*
2
+
* uTop.mli
3
+
* --------
4
+
* Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
5
+
* Licence : BSD3
6
+
*
7
+
* This file is a part of utop.
8
+
*)
9
+
10
+
(** UTop configuration. *)
11
+
12
+
val version : string
13
+
(** Version of utop. *)
14
+
15
+
val keywords : Set.Make(String).t ref
16
+
(** The set of OCaml keywords. *)
17
+
18
+
val add_keyword : string -> unit
19
+
(** Add a new OCaml keyword. *)
20
+
21
+
(** Type of a string-location. It is composed of a start and stop offsets (in
22
+
bytes). *)
23
+
type location = int * int
24
+
25
+
(** Result of a function processing a programx. *)
26
+
type 'a result =
27
+
| Value of 'a (** The function succeeded and returned this value. *)
28
+
| Error of location list * string
29
+
(** The function failed. Arguments are a list of locations to highlight in
30
+
the source and an error message. *)
31
+
32
+
(** Exception raised by a parser when it need more data. *)
33
+
exception Need_more
34
+
35
+
val parse_toplevel_phrase
36
+
: (string -> bool -> Parsetree.toplevel_phrase result) ref
37
+
(** [parse_toplevel_phrase] is the function used to parse a phrase typed in the
38
+
toplevel.
39
+
40
+
Its arguments are:
41
+
42
+
- [input]: the string to parse
43
+
- [eos_is_error]
44
+
45
+
If [eos_is_error] is [true] and the parser reach the end of input, then
46
+
{!Parse_failure} should be returned.
47
+
48
+
If [eos_is_error] is [false] and the parser reach the end of input, the
49
+
exception {!Need_more} must be thrown.
50
+
51
+
Except for {!Need_more}, the function must not raise any exception. *)
52
+
53
+
val parse_toplevel_phrase_default
54
+
: string
55
+
-> bool
56
+
-> Parsetree.toplevel_phrase result
57
+
(** The default parser for toplevel phrases. It uses the standard ocaml parser. *)
58
+
59
+
val parse_default : (Lexing.lexbuf -> 'a) -> string -> bool -> 'a result
60
+
(** The default parser. It uses the standard ocaml parser. *)
61
+
62
+
val input_name : string
63
+
(** The name you must use in location to let ocaml know that it is from the
64
+
toplevel. *)
65
+
66
+
val lexbuf_of_string : bool ref -> string -> Lexing.lexbuf
67
+
(** [lexbuf_of_string eof str] is the same as [Lexing.from_string
68
+
str]
69
+
except that if the lexer reach the end of [str] then [eof] is set to [true]. *)
70
+
71
+
(** {6 Helpers} *)
72
+
73
+
val get_message : (Format.formatter -> 'a -> unit) -> 'a -> string
74
+
(** [get_message printer x] applies [printer] on [x] and returns everything it
75
+
prints as a string. *)
76
+
77
+
val get_ocaml_error_message : exn -> location * string
78
+
(** [get_ocaml_error_message exn] returns the location and error message for the
79
+
exception [exn] which must be an exception from the compiler. *)
80
+
81
+
val check_phrase : Parsetree.toplevel_phrase -> (location list * string) option
82
+
(** [check_phrase phrase] checks that [phrase] can be executed without typing or
83
+
compilation errors. It returns [None] if [phrase] is OK and an error message
84
+
otherwise.
85
+
86
+
If the result is [None] it is guaranteed that [Toploop.execute_phrase] won't
87
+
raise any exception. *)
88
+
89
+
val collect_formatters : Buffer.t -> Format.formatter list -> (unit -> 'a) -> 'a
90
+
(** [collect_formatters buf pps f] executes [f] and redirect everything it
91
+
prints on [pps] to [buf]. *)
92
+
93
+
val discard_formatters : Format.formatter list -> (unit -> 'a) -> 'a
94
+
(** [discard_formatters pps f] executes [f], dropping everything it prints on
95
+
[pps]. *)
96
+
97
+
(** {6 compiler-libs reexports} *)
98
+
99
+
val get_load_path : unit -> string list
100
+
101
+
val set_load_path : string list -> unit
102
+
(** [get_load_path] and [set_load_path] manage the include directories.
103
+
104
+
The internal variable contains the list of directories added by
105
+
findlib-required packages and [#directory] directives. *)
+1081
lib/uTop_complete.ml
+1081
lib/uTop_complete.ml
···
1
+
(*
2
+
* uTop_complete.ml
3
+
* ----------------
4
+
* Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
5
+
* Licence : BSD3
6
+
*
7
+
* This file is a part of utop.
8
+
*)
9
+
10
+
[@@@warning "-9-27-32"]
11
+
12
+
open Types
13
+
open UTop_token
14
+
15
+
module String_set = Set.Make(String)
16
+
module String_map = Map.Make(String)
17
+
18
+
let lookup_assoc word words = List.filter (fun (word', _) -> Astring.String.is_prefix ~affix:word word') words
19
+
let lookup word words = List.filter (fun word' -> Astring.String.is_prefix word' ~affix:word) words
20
+
21
+
let set_of_list = List.fold_left (fun set x -> String_set.add x set) String_set.empty
22
+
23
+
(* +-----------------------------------------------------------------+
24
+
| Utils |
25
+
+-----------------------------------------------------------------+ *)
26
+
27
+
(* Transform a non-empty list of strings into a long-identifier. *)
28
+
let longident_of_list = function
29
+
| [] ->
30
+
invalid_arg "UTop_complete.longident_of_list"
31
+
| component :: rest ->
32
+
let rec loop acc = function
33
+
| [] -> acc
34
+
| component :: rest -> loop (Longident.Ldot(acc, component)) rest
35
+
in
36
+
loop (Longident.Lident component) rest
37
+
38
+
(* Check whether an identifier is a valid one. *)
39
+
let is_valid_identifier id =
40
+
id <> "" &&
41
+
(match id.[0] with
42
+
| 'A' .. 'Z' | 'a' .. 'z' | '_' -> true
43
+
| _ -> false)
44
+
45
+
let add id set = if is_valid_identifier id then String_set.add id set else set
46
+
47
+
let lookup_env f x env =
48
+
try
49
+
Some (f x env)
50
+
with Not_found | Env.Error _ ->
51
+
None
52
+
53
+
(* +-----------------------------------------------------------------+
54
+
| Parsing |
55
+
+-----------------------------------------------------------------+ *)
56
+
57
+
(* The following functions takes a list of tokens in reverse order. *)
58
+
59
+
type value_or_field = Value | Field
60
+
(* Either a value, or a record field. *)
61
+
62
+
(* Parse something of the form [M1.M2. ... .Mn.id] or
63
+
[field.M1.M2. ... .Mn.id] *)
64
+
let parse_longident tokens =
65
+
let rec loop acc tokens =
66
+
match tokens with
67
+
| (Symbol ".", _) :: (Uident id, _) :: tokens ->
68
+
loop (id :: acc) tokens
69
+
| (Symbol ".", _) :: (Lident id, _) :: tokens ->
70
+
(Field,
71
+
match acc with
72
+
| [] -> None
73
+
| l -> Some (longident_of_list l))
74
+
| _ ->
75
+
(Value,
76
+
match acc with
77
+
| [] -> None
78
+
| l -> Some (longident_of_list l))
79
+
in
80
+
match tokens with
81
+
| ((Comment (_, false) | String (_, false) | Quotation (_, false)), _) :: _ ->
82
+
(* An unterminated command, string, or quotation. *)
83
+
None
84
+
| ((Uident id | Lident id), { idx1 = start }) :: tokens ->
85
+
(* An identifier. *)
86
+
let kind, path = loop [] tokens in
87
+
Some (kind, path, start, id)
88
+
| (Blanks, { idx2 = stop }) :: tokens ->
89
+
(* Some blanks at the end. *)
90
+
let kind, path = loop [] tokens in
91
+
Some (kind, path, stop, "")
92
+
| (_, { idx2 = stop }) :: _ ->
93
+
(* Otherwise complete after the last token. *)
94
+
let kind, path = loop [] tokens in
95
+
Some (kind, path, stop, "")
96
+
| [] ->
97
+
None
98
+
99
+
(* Parse something of the form [M1.M2. ... .Mn.id#m1#m2# ... #mp#m] *)
100
+
let parse_method tokens =
101
+
(* Collect [M1.M2. ... .Mn.id] and returns the corresponding
102
+
longidentifier. *)
103
+
let rec loop_uidents acc tokens =
104
+
match tokens with
105
+
| (Symbol ".", _) :: (Uident id, _) :: tokens ->
106
+
loop_uidents (id :: acc) tokens
107
+
| _ ->
108
+
longident_of_list acc
109
+
in
110
+
(* Collect [m1#m2# ... #mp] *)
111
+
let rec loop_methods acc tokens =
112
+
match tokens with
113
+
| (Lident meth, _) :: (Symbol "#", _) :: tokens ->
114
+
loop_methods (meth :: acc) tokens
115
+
| (Lident id, _) :: tokens ->
116
+
Some (loop_uidents [id] tokens, acc)
117
+
| _ ->
118
+
None
119
+
in
120
+
match tokens with
121
+
| (Lident meth, { idx1 = start }) :: (Symbol "#", _) :: tokens -> begin
122
+
match loop_methods [] tokens with
123
+
| None -> None
124
+
| Some (path, meths) -> Some (path, meths, start, meth)
125
+
end
126
+
| (Symbol "#", { idx2 = stop }) :: tokens
127
+
| (Blanks, { idx2 = stop }) :: (Symbol "#", _) :: tokens -> begin
128
+
match loop_methods [] tokens with
129
+
| None -> None
130
+
| Some (path, meths) -> Some (path, meths, stop, "")
131
+
end
132
+
| _ ->
133
+
None
134
+
135
+
type label_kind = Required | Optional
136
+
(* Kind of labels: required or optional. *)
137
+
138
+
type fun_or_new = Fun | New
139
+
(* Either a function application, either an object creation. *)
140
+
141
+
(* Parse something of the form [M1.M2. ... .Mn.id#m1#m2# ... #mp expr1 ... exprq ~label]
142
+
or [new M1.M2. ... .Mn.id expr1 ... exprq ~label] *)
143
+
let parse_label tokens =
144
+
(* Collect [M1.M2. ... .Mn] *)
145
+
let rec loop_uidents acc_uidents acc_methods tokens =
146
+
match tokens with
147
+
| (Lident "new", _) :: _ ->
148
+
Some (New, longident_of_list acc_uidents, acc_methods)
149
+
| ((Lident id | Uident id), _) :: _ when String_set.mem id !UTop.keywords ->
150
+
Some (Fun, longident_of_list acc_uidents, acc_methods)
151
+
| (Symbol ".", _) :: (Uident id, _) :: tokens ->
152
+
loop_uidents (id :: acc_uidents) acc_methods tokens
153
+
| (Symbol ("~" | "?" | ":" | "." | "#" | "!" | "`"), _) :: tokens ->
154
+
search tokens
155
+
| (Symbol ")", _) :: tokens ->
156
+
skip tokens "(" []
157
+
| (Symbol "}", _) :: tokens ->
158
+
skip tokens "{" []
159
+
| (Symbol "]", _) :: tokens ->
160
+
skip tokens "[" []
161
+
| (Symbol _, _) :: _ ->
162
+
Some (Fun, longident_of_list acc_uidents, acc_methods)
163
+
| [] ->
164
+
Some (Fun, longident_of_list acc_uidents, acc_methods)
165
+
| _ ->
166
+
search tokens
167
+
and loop_methods acc tokens =
168
+
match tokens with
169
+
| ((Lident id | Uident id), _) :: _ when String_set.mem id !UTop.keywords ->
170
+
None
171
+
| (Symbol ("~" | "?" | ":" | "." | "#" | "!" | "`"), _) :: tokens ->
172
+
search tokens
173
+
| (Symbol ")", _) :: tokens ->
174
+
skip tokens "(" []
175
+
| (Symbol "}", _) :: tokens ->
176
+
skip tokens "{" []
177
+
| (Symbol "]", _) :: tokens ->
178
+
skip tokens "[" []
179
+
| (Symbol _, _) :: _ ->
180
+
None
181
+
| (Lident id, _) :: (Symbol "#", _) :: tokens ->
182
+
loop_methods (id :: acc) tokens
183
+
| (Lident id, _) :: tokens ->
184
+
loop_uidents [id] acc tokens
185
+
| [] ->
186
+
None
187
+
| _ ->
188
+
search tokens
189
+
and search tokens =
190
+
match tokens with
191
+
| ((Lident id | Uident id), _) :: _ when String_set.mem id !UTop.keywords ->
192
+
None
193
+
| (Symbol ("~" | "?" | ":" | "." | "#" | "!" | "`"), _) :: tokens ->
194
+
search tokens
195
+
| (Symbol ")", _) :: tokens ->
196
+
skip tokens "(" []
197
+
| (Symbol "}", _) :: tokens ->
198
+
skip tokens "{" []
199
+
| (Symbol "]", _) :: tokens ->
200
+
skip tokens "[" []
201
+
| (Symbol _, _) :: _ ->
202
+
None
203
+
| (Lident id, _) :: (Symbol "#", _) :: tokens ->
204
+
loop_methods [id] tokens
205
+
| (Lident id, _) :: tokens ->
206
+
loop_uidents [id] [] tokens
207
+
| _ :: tokens ->
208
+
search tokens
209
+
| [] ->
210
+
None
211
+
and skip tokens top stack =
212
+
match tokens with
213
+
| (Symbol symbol, _) :: tokens when symbol = top -> begin
214
+
match stack with
215
+
| [] -> search tokens
216
+
| top :: stack -> skip tokens top stack
217
+
end
218
+
| (Symbol ")", _) :: tokens ->
219
+
skip tokens "(" (top :: stack)
220
+
| (Symbol "}", _) :: tokens ->
221
+
skip tokens "{" (top :: stack)
222
+
| (Symbol "]", _) :: tokens ->
223
+
skip tokens "[" (top :: stack)
224
+
| _ :: tokens ->
225
+
skip tokens top stack
226
+
| [] ->
227
+
None
228
+
in
229
+
match tokens with
230
+
| (Lident label, { idx1 = start }) :: (Symbol "~", _) :: tokens -> begin
231
+
match search tokens with
232
+
| None -> None
233
+
| Some (kind, id, meths) -> Some (kind, id, meths, Required, start, label)
234
+
end
235
+
| (Symbol "~", { idx2 = stop }) :: tokens -> begin
236
+
match search tokens with
237
+
| None -> None
238
+
| Some (kind, id, meths) -> Some (kind, id, meths, Required, stop, "")
239
+
end
240
+
| (Lident label, { idx1 = start }) :: (Symbol "?", _) :: tokens -> begin
241
+
match search tokens with
242
+
| None -> None
243
+
| Some (kind, id, meths) -> Some (kind, id, meths, Optional, start, label)
244
+
end
245
+
| (Symbol "?", { idx2 = stop }) :: tokens -> begin
246
+
match search tokens with
247
+
| None -> None
248
+
| Some (kind, id, meths) -> Some (kind, id, meths, Optional, stop, "")
249
+
end
250
+
| _ ->
251
+
None
252
+
253
+
(* +-----------------------------------------------------------------+
254
+
| Directive listing |
255
+
+-----------------------------------------------------------------+ *)
256
+
257
+
let list_directives phrase_terminator =
258
+
String_map.bindings
259
+
(Hashtbl.fold
260
+
(fun dir kind map ->
261
+
let suffix =
262
+
match kind with
263
+
| Toploop.Directive_none _ -> phrase_terminator
264
+
| Toploop.Directive_string _ -> " \""
265
+
| Toploop.Directive_bool _ | Toploop.Directive_int _ | Toploop.Directive_ident _ -> " "
266
+
in
267
+
String_map.add dir suffix map)
268
+
Toploop.directive_table
269
+
String_map.empty)
270
+
271
+
(* +-----------------------------------------------------------------+
272
+
| File listing |
273
+
+-----------------------------------------------------------------+ *)
274
+
275
+
type file_kind = Directory | File
276
+
277
+
let basename name =
278
+
let name' = Filename.basename name in
279
+
if name' = "." && not (Astring.String.is_suffix name ~affix:".") then
280
+
""
281
+
else
282
+
name'
283
+
284
+
let add_files filter acc dir =
285
+
Array.fold_left
286
+
(fun map name ->
287
+
let absolute_name = Filename.concat dir name in
288
+
if try Sys.is_directory absolute_name with Sys_error _ -> false then
289
+
String_map.add (Filename.concat name "") Directory map
290
+
else if filter name then
291
+
String_map.add name File map
292
+
else
293
+
map)
294
+
acc
295
+
(try Sys.readdir dir with Sys_error _ -> [||])
296
+
297
+
let list_directories dir =
298
+
String_set.elements
299
+
(Array.fold_left
300
+
(fun set name ->
301
+
let absolute_name = Filename.concat dir name in
302
+
if try Sys.is_directory absolute_name with Sys_error _ -> false then
303
+
String_set.add name set
304
+
else
305
+
set)
306
+
String_set.empty
307
+
(try Sys.readdir (if dir = "" then Filename.current_dir_name else dir) with Sys_error _ -> [||]))
308
+
309
+
let path () = []
310
+
311
+
(* +-----------------------------------------------------------------+
312
+
| Names listing |
313
+
+-----------------------------------------------------------------+ *)
314
+
315
+
module Path_map = Map.Make(struct type t = Path.t let compare = compare end)
316
+
module Longident_map = Map.Make(struct type t = Longident.t let compare = compare end)
317
+
318
+
(* All names accessible without a path. *)
319
+
let global_names = ref None
320
+
let global_names_revised = ref None
321
+
322
+
(* All names accessible with a path, by path. *)
323
+
let local_names_by_path = ref Path_map.empty
324
+
325
+
(* All names accessible with a path, by long identifier. *)
326
+
let local_names_by_longident = ref Longident_map.empty
327
+
328
+
(* All record fields accessible without a path. *)
329
+
let global_fields = ref None
330
+
331
+
(* All record fields accessible with a path, by path. *)
332
+
let local_fields_by_path = ref Path_map.empty
333
+
334
+
(* All record fields accessible with a path, by long identifier. *)
335
+
let local_fields_by_longident = ref Longident_map.empty
336
+
337
+
(* All visible modules according to Config.load_path. *)
338
+
let visible_modules = ref None
339
+
340
+
let reset () =
341
+
visible_modules := None;
342
+
global_names := None;
343
+
global_names_revised := None;
344
+
local_names_by_path := Path_map.empty;
345
+
local_names_by_longident := Longident_map.empty;
346
+
global_fields := None;
347
+
local_fields_by_path := Path_map.empty;
348
+
local_fields_by_longident := Longident_map.empty
349
+
350
+
let get_cached var f =
351
+
match !var with
352
+
| Some x ->
353
+
x
354
+
| None ->
355
+
let x = f () in
356
+
var := Some x;
357
+
x
358
+
359
+
(* List all visible modules. *)
360
+
let visible_modules () =
361
+
get_cached visible_modules
362
+
(fun () ->
363
+
List.fold_left
364
+
(fun acc dir ->
365
+
try
366
+
Array.fold_left
367
+
(fun acc fname ->
368
+
if Filename.check_suffix fname ".cmi" then
369
+
String_set.add (String.capitalize_ascii (Filename.chop_suffix fname ".cmi")) acc
370
+
else
371
+
acc)
372
+
acc
373
+
(Sys.readdir (if dir = "" then Filename.current_dir_name else dir))
374
+
with Sys_error _ ->
375
+
acc)
376
+
#if OCAML_VERSION >= (4, 08, 0)
377
+
String_set.empty @@ Load_path.get_paths ()
378
+
#else
379
+
String_set.empty !Config.load_path
380
+
#endif
381
+
)
382
+
383
+
let field_name { ld_id = id } = Ident.name id
384
+
let constructor_name { cd_id = id } = Ident.name id
385
+
386
+
let add_fields_of_type decl acc =
387
+
match decl.type_kind with
388
+
#if OCAML_VERSION >= (4, 13, 0)
389
+
| Type_variant (constructors,_) ->
390
+
#else
391
+
| Type_variant constructors ->
392
+
#endif
393
+
acc
394
+
| Type_record (fields, _) ->
395
+
List.fold_left (fun acc field -> add (field_name field) acc) acc fields
396
+
| Type_abstract ->
397
+
acc
398
+
| Type_open ->
399
+
acc
400
+
401
+
let add_names_of_type decl acc =
402
+
match decl.type_kind with
403
+
#if OCAML_VERSION >= (4, 13, 0)
404
+
| Type_variant (constructors,_) ->
405
+
#else
406
+
| Type_variant constructors ->
407
+
#endif
408
+
List.fold_left (fun acc cstr -> add (constructor_name cstr) acc) acc constructors
409
+
| Type_record (fields, _) ->
410
+
List.fold_left (fun acc field -> add (field_name field) acc) acc fields
411
+
| Type_abstract ->
412
+
acc
413
+
| Type_open ->
414
+
acc
415
+
416
+
#if OCAML_VERSION >= (4, 08, 0)
417
+
let path_of_mty_alias = function
418
+
| Mty_alias path -> path
419
+
| _ -> assert false
420
+
#elif OCAML_VERSION >= (4, 04, 0)
421
+
let path_of_mty_alias = function
422
+
| Mty_alias (_, path) -> path
423
+
| _ -> assert false
424
+
#else
425
+
let path_of_mty_alias = function
426
+
| Mty_alias path -> path
427
+
| _ -> assert false
428
+
#endif
429
+
430
+
let rec names_of_module_type = function
431
+
| Mty_signature decls ->
432
+
List.fold_left
433
+
(fun acc decl -> match decl with
434
+
#if OCAML_VERSION >= (4, 08, 0)
435
+
| Sig_value (id, _, _)
436
+
| Sig_typext (id, _, _, _)
437
+
| Sig_module (id, _, _, _, _)
438
+
| Sig_modtype (id, _, _)
439
+
| Sig_class (id, _, _, _)
440
+
| Sig_class_type (id, _, _, _) ->
441
+
#else
442
+
| Sig_value (id, _)
443
+
| Sig_typext (id, _, _)
444
+
| Sig_module (id, _, _)
445
+
| Sig_modtype (id, _)
446
+
| Sig_class (id, _, _)
447
+
| Sig_class_type (id, _, _) ->
448
+
#endif
449
+
add (Ident.name id) acc
450
+
#if OCAML_VERSION >= (4, 08, 0)
451
+
| Sig_type (id, decl, _, _) ->
452
+
#else
453
+
| Sig_type (id, decl, _) ->
454
+
#endif
455
+
add_names_of_type decl (add (Ident.name id) acc))
456
+
String_set.empty decls
457
+
| Mty_ident path -> begin
458
+
match lookup_env Env.find_modtype path !Toploop.toplevel_env with
459
+
| Some { mtd_type = None } -> String_set.empty
460
+
| Some { mtd_type = Some module_type } -> names_of_module_type module_type
461
+
| None -> String_set.empty
462
+
end
463
+
| Mty_alias _ as mty_alias -> begin
464
+
let path = path_of_mty_alias mty_alias in
465
+
match lookup_env Env.find_module path !Toploop.toplevel_env with
466
+
| None -> String_set.empty
467
+
| Some { md_type = module_type } -> names_of_module_type module_type
468
+
end
469
+
| _ ->
470
+
String_set.empty
471
+
472
+
let rec fields_of_module_type = function
473
+
| Mty_signature decls ->
474
+
List.fold_left
475
+
(fun acc decl -> match decl with
476
+
| Sig_value _
477
+
| Sig_typext _
478
+
| Sig_module _
479
+
| Sig_modtype _
480
+
| Sig_class _
481
+
| Sig_class_type _ ->
482
+
acc
483
+
#if OCAML_VERSION >= (4, 08, 0)
484
+
| Sig_type (_, decl, _, _) ->
485
+
#else
486
+
| Sig_type (_, decl, _) ->
487
+
#endif
488
+
add_fields_of_type decl acc)
489
+
String_set.empty decls
490
+
| Mty_ident path -> begin
491
+
match lookup_env Env.find_modtype path !Toploop.toplevel_env with
492
+
| Some { mtd_type = None } -> String_set.empty
493
+
| Some { mtd_type = Some module_type } -> fields_of_module_type module_type
494
+
| None -> String_set.empty
495
+
end
496
+
| Mty_alias _ as mty_alias -> begin
497
+
let path = path_of_mty_alias mty_alias in
498
+
match lookup_env Env.find_module path !Toploop.toplevel_env with
499
+
| None -> String_set.empty
500
+
| Some { md_type = module_type } -> fields_of_module_type module_type
501
+
end
502
+
| _ ->
503
+
String_set.empty
504
+
505
+
let lookup_module id env =
506
+
#if OCAML_VERSION >= (4, 10, 0)
507
+
let path, decl = Env.find_module_by_name id env in
508
+
(path, decl.md_type)
509
+
#else
510
+
let path = Env.lookup_module id env ~load:true in
511
+
(path, (Env.find_module path env).md_type)
512
+
#endif
513
+
514
+
let find_module path env = (Env.find_module path env).md_type
515
+
516
+
let names_of_module longident =
517
+
try
518
+
Longident_map.find longident !local_names_by_longident
519
+
with Not_found ->
520
+
match lookup_env lookup_module longident !Toploop.toplevel_env with
521
+
| Some(path, module_type) ->
522
+
let names = names_of_module_type module_type in
523
+
local_names_by_path := Path_map.add path names !local_names_by_path;
524
+
local_names_by_longident := Longident_map.add longident names !local_names_by_longident;
525
+
names
526
+
| None ->
527
+
local_names_by_longident := Longident_map.add longident String_set.empty !local_names_by_longident;
528
+
String_set.empty
529
+
530
+
let fields_of_module longident =
531
+
try
532
+
Longident_map.find longident !local_fields_by_longident
533
+
with Not_found ->
534
+
match lookup_env lookup_module longident !Toploop.toplevel_env with
535
+
| Some(path, module_type) ->
536
+
let fields = fields_of_module_type module_type in
537
+
local_fields_by_path := Path_map.add path fields !local_fields_by_path;
538
+
local_fields_by_longident := Longident_map.add longident fields !local_fields_by_longident;
539
+
fields
540
+
| None ->
541
+
local_fields_by_longident := Longident_map.add longident String_set.empty !local_fields_by_longident;
542
+
String_set.empty
543
+
544
+
let list_global_names () =
545
+
let rec loop acc = function
546
+
| Env.Env_empty -> acc
547
+
#if OCAML_VERSION >= (4, 10, 0)
548
+
| Env.Env_value_unbound _-> acc
549
+
| Env.Env_module_unbound _-> acc
550
+
#endif
551
+
| Env.Env_value(summary, id, _) ->
552
+
loop (add (Ident.name id) acc) summary
553
+
| Env.Env_type(summary, id, decl) ->
554
+
loop (add_names_of_type decl (add (Ident.name id) acc)) summary
555
+
| Env.Env_extension(summary, id, _) ->
556
+
loop (add (Ident.name id) acc) summary
557
+
#if OCAML_VERSION >= (4, 08, 0)
558
+
| Env.Env_module(summary, id, _, _) ->
559
+
#else
560
+
| Env.Env_module(summary, id, _) ->
561
+
#endif
562
+
loop (add (Ident.name id) acc) summary
563
+
| Env.Env_modtype(summary, id, _) ->
564
+
loop (add (Ident.name id) acc) summary
565
+
| Env.Env_class(summary, id, _) ->
566
+
loop (add (Ident.name id) acc) summary
567
+
| Env.Env_cltype(summary, id, _) ->
568
+
loop (add (Ident.name id) acc) summary
569
+
| Env.Env_functor_arg(summary, id) ->
570
+
loop (add (Ident.name id) acc) summary
571
+
#if OCAML_VERSION >= (4, 08, 0)
572
+
| Env.Env_persistent (summary, id) ->
573
+
loop (add (Ident.name id) acc) summary
574
+
#endif
575
+
#if OCAML_VERSION >= (4, 04, 0)
576
+
| Env.Env_constraints (summary, _) ->
577
+
loop acc summary
578
+
#endif
579
+
#if OCAML_VERSION >= (4, 10, 0)
580
+
| Env.Env_copy_types summary ->
581
+
loop acc summary
582
+
#elif OCAML_VERSION >= (4, 06, 0)
583
+
| Env.Env_copy_types (summary, _) ->
584
+
loop acc summary
585
+
#endif
586
+
#if OCAML_VERSION >= (4, 08, 0)
587
+
| Env.Env_open(summary, path) ->
588
+
#elif OCAML_VERSION >= (4, 07, 0)
589
+
| Env.Env_open(summary, _, path) ->
590
+
#else
591
+
| Env.Env_open(summary, path) ->
592
+
#endif
593
+
match try Some (Path_map.find path !local_names_by_path) with Not_found -> None with
594
+
| Some names ->
595
+
loop (String_set.union acc names) summary
596
+
| None ->
597
+
match lookup_env find_module path !Toploop.toplevel_env with
598
+
| Some module_type ->
599
+
let names = names_of_module_type module_type in
600
+
local_names_by_path := Path_map.add path names !local_names_by_path;
601
+
loop (String_set.union acc names) summary
602
+
| None ->
603
+
local_names_by_path := Path_map.add path String_set.empty !local_names_by_path;
604
+
loop acc summary
605
+
in
606
+
(* Add names of the environment: *)
607
+
let acc = loop String_set.empty (Env.summary !Toploop.toplevel_env) in
608
+
(* Add accessible modules: *)
609
+
String_set.union acc (visible_modules ())
610
+
611
+
let global_names () = get_cached global_names list_global_names
612
+
613
+
let replace x y set =
614
+
if String_set.mem x set then
615
+
String_set.add y (String_set.remove x set)
616
+
else
617
+
set
618
+
619
+
let list_global_fields () =
620
+
let rec loop acc = function
621
+
| Env.Env_empty -> acc
622
+
#if OCAML_VERSION >= (4, 10, 0)
623
+
| Env.Env_value_unbound _-> acc
624
+
| Env.Env_module_unbound _-> acc
625
+
#endif
626
+
| Env.Env_value(summary, id, _) ->
627
+
loop (add (Ident.name id) acc) summary
628
+
| Env.Env_type(summary, id, decl) ->
629
+
loop (add_fields_of_type decl (add (Ident.name id) acc)) summary
630
+
| Env.Env_extension(summary, id, _) ->
631
+
loop (add (Ident.name id) acc) summary
632
+
#if OCAML_VERSION >= (4, 08, 0)
633
+
| Env.Env_module(summary, id, _, _) ->
634
+
#else
635
+
| Env.Env_module(summary, id, _) ->
636
+
#endif
637
+
loop (add (Ident.name id) acc) summary
638
+
| Env.Env_functor_arg(summary, id) ->
639
+
loop (add (Ident.name id) acc) summary
640
+
| Env.Env_modtype(summary, id, _) ->
641
+
loop (add (Ident.name id) acc) summary
642
+
| Env.Env_class(summary, id, _) ->
643
+
loop (add (Ident.name id) acc) summary
644
+
| Env.Env_cltype(summary, id, _) ->
645
+
loop (add (Ident.name id) acc) summary
646
+
#if OCAML_VERSION >= (4, 08, 0)
647
+
| Env.Env_persistent (summary, id) ->
648
+
loop (add (Ident.name id) acc) summary
649
+
#endif
650
+
#if OCAML_VERSION >= (4, 04, 0)
651
+
| Env.Env_constraints (summary, _) ->
652
+
loop acc summary
653
+
#endif
654
+
#if OCAML_VERSION >= (4, 10, 0)
655
+
| Env.Env_copy_types summary ->
656
+
loop acc summary
657
+
#elif OCAML_VERSION >= (4, 06, 0)
658
+
| Env.Env_copy_types (summary, _) ->
659
+
loop acc summary
660
+
#endif
661
+
#if OCAML_VERSION >= (4, 07, 0)
662
+
#if OCAML_VERSION >= (4, 08, 0)
663
+
| Env.Env_open(summary, path) ->
664
+
#else
665
+
| Env.Env_open(summary, _, path) ->
666
+
#endif
667
+
#else
668
+
| Env.Env_open(summary, path) ->
669
+
#endif
670
+
match try Some (Path_map.find path !local_fields_by_path) with Not_found -> None with
671
+
| Some fields ->
672
+
loop (String_set.union acc fields) summary
673
+
| None ->
674
+
match lookup_env find_module path !Toploop.toplevel_env with
675
+
| Some module_type ->
676
+
let fields = fields_of_module_type module_type in
677
+
local_fields_by_path := Path_map.add path fields !local_fields_by_path;
678
+
loop (String_set.union acc fields) summary
679
+
| None ->
680
+
local_fields_by_path := Path_map.add path String_set.empty !local_fields_by_path;
681
+
loop acc summary
682
+
in
683
+
(* Add fields of the environment: *)
684
+
let acc = loop String_set.empty (Env.summary !Toploop.toplevel_env) in
685
+
(* Add accessible modules: *)
686
+
String_set.union acc (visible_modules ())
687
+
688
+
let global_fields () = get_cached global_fields list_global_fields
689
+
690
+
(* +-----------------------------------------------------------------+
691
+
| Listing methods |
692
+
+-----------------------------------------------------------------+ *)
693
+
694
+
let rec find_method meth type_expr =
695
+
match type_expr.desc with
696
+
| Tlink type_expr ->
697
+
find_method meth type_expr
698
+
| Tobject (type_expr, _) ->
699
+
find_method meth type_expr
700
+
| Tfield (name, _, type_expr, rest) ->
701
+
if name = meth then
702
+
Some type_expr
703
+
else
704
+
find_method meth rest
705
+
| Tpoly (type_expr, _) ->
706
+
find_method meth type_expr
707
+
| Tconstr (path, _, _) -> begin
708
+
match lookup_env Env.find_type path !Toploop.toplevel_env with
709
+
| None
710
+
| Some { type_manifest = None } ->
711
+
None
712
+
| Some { type_manifest = Some type_expr } ->
713
+
find_method meth type_expr
714
+
end
715
+
| _ ->
716
+
None
717
+
718
+
let rec methods_of_type acc type_expr =
719
+
match type_expr.desc with
720
+
| Tlink type_expr ->
721
+
methods_of_type acc type_expr
722
+
| Tobject (type_expr, _) ->
723
+
methods_of_type acc type_expr
724
+
| Tfield (name, _, _, rest) ->
725
+
methods_of_type (add name acc) rest
726
+
| Tpoly (type_expr, _) ->
727
+
methods_of_type acc type_expr
728
+
| Tconstr (path, _, _) -> begin
729
+
match lookup_env Env.find_type path !Toploop.toplevel_env with
730
+
| None
731
+
| Some { type_manifest = None } ->
732
+
acc
733
+
| Some { type_manifest = Some type_expr } ->
734
+
methods_of_type acc type_expr
735
+
end
736
+
| _ ->
737
+
acc
738
+
739
+
let rec find_object meths type_expr =
740
+
match meths with
741
+
| [] ->
742
+
Some type_expr
743
+
| meth :: meths ->
744
+
match find_method meth type_expr with
745
+
| Some type_expr ->
746
+
find_object meths type_expr
747
+
| None ->
748
+
None
749
+
750
+
let methods_of_object longident meths =
751
+
let lookup_value=
752
+
#if OCAML_VERSION >= (4, 10, 0)
753
+
Env.find_value_by_name
754
+
#else
755
+
Env.lookup_value
756
+
#endif
757
+
in
758
+
match lookup_env lookup_value longident !Toploop.toplevel_env with
759
+
| None ->
760
+
[]
761
+
| Some (path, { val_type = type_expr }) ->
762
+
match find_object meths type_expr with
763
+
| None ->
764
+
[]
765
+
| Some type_expr ->
766
+
String_set.elements (methods_of_type String_set.empty type_expr)
767
+
768
+
(* +-----------------------------------------------------------------+
769
+
| Listing labels |
770
+
+-----------------------------------------------------------------+ *)
771
+
772
+
let rec labels_of_type acc type_expr =
773
+
match type_expr.desc with
774
+
| Tlink te ->
775
+
labels_of_type acc te
776
+
| Tpoly (te, _) ->
777
+
labels_of_type acc te
778
+
| Tarrow(label, _, te, _) ->
779
+
#if OCAML_VERSION < (4, 03, 0)
780
+
if label = "" then
781
+
labels_of_type acc te
782
+
else if label.[0] = '?' then
783
+
labels_of_type (String_map.add (String.sub label 1 (String.length label - 1)) Optional acc) te
784
+
else
785
+
labels_of_type (String_map.add label Required acc) te
786
+
#else
787
+
(match label with
788
+
| Nolabel ->
789
+
labels_of_type acc te
790
+
| Optional label ->
791
+
labels_of_type (String_map.add label Optional acc) te
792
+
| Labelled label ->
793
+
labels_of_type (String_map.add label Required acc) te)
794
+
#endif
795
+
| Tconstr(path, _, _) -> begin
796
+
match lookup_env Env.find_type path !Toploop.toplevel_env with
797
+
| None
798
+
| Some { type_manifest = None } ->
799
+
String_map.bindings acc
800
+
| Some { type_manifest = Some type_expr } ->
801
+
labels_of_type acc type_expr
802
+
end
803
+
| _ ->
804
+
String_map.bindings acc
805
+
806
+
let labels_of_function longident meths =
807
+
let lookup_value=
808
+
#if OCAML_VERSION >= (4, 10, 0)
809
+
Env.find_value_by_name
810
+
#else
811
+
Env.lookup_value
812
+
#endif
813
+
in
814
+
match lookup_env lookup_value longident !Toploop.toplevel_env with
815
+
| None ->
816
+
[]
817
+
| Some (path, { val_type = type_expr }) ->
818
+
match find_object meths type_expr with
819
+
| None ->
820
+
[]
821
+
| Some type_expr ->
822
+
labels_of_type String_map.empty type_expr
823
+
824
+
let labels_of_newclass longident =
825
+
let lookup_class=
826
+
#if OCAML_VERSION >= (4, 10, 0)
827
+
Env.find_class_by_name
828
+
#else
829
+
Env.lookup_class
830
+
#endif
831
+
in
832
+
match lookup_env lookup_class longident !Toploop.toplevel_env with
833
+
| None ->
834
+
[]
835
+
| Some (path, { cty_new = None }) ->
836
+
[]
837
+
| Some (path, { cty_new = Some type_expr }) ->
838
+
labels_of_type String_map.empty type_expr
839
+
840
+
(* +-----------------------------------------------------------------+
841
+
| Tokens processing |
842
+
+-----------------------------------------------------------------+ *)
843
+
844
+
(* Filter blanks and comments except for the last token. *)
845
+
let filter tokens =
846
+
let rec aux acc = function
847
+
| [] -> acc
848
+
| [((Blanks | Comment (_, true)), loc)] -> (Blanks, loc) :: acc
849
+
| ((Blanks | Comment (_, true)), _) :: rest -> aux acc rest
850
+
| x :: rest -> aux (x :: acc) rest
851
+
in
852
+
List.rev (aux [] tokens)
853
+
854
+
(* Reverse and filter blanks and comments except for the last
855
+
token. *)
856
+
let rec rev_filter acc tokens =
857
+
match tokens with
858
+
| [] -> acc
859
+
| [((Blanks | Comment (_, true)), loc)] -> (Blanks, loc) :: acc
860
+
| ((Blanks | Comment (_, true)), _) :: rest -> rev_filter acc rest
861
+
| x :: rest -> rev_filter (x :: acc) rest
862
+
863
+
(* Find the current context. *)
864
+
let rec find_context tokens = function
865
+
| [] ->
866
+
Some (rev_filter [] tokens)
867
+
| [(Quotation (items, false), _)] ->
868
+
find_context_in_quotation items
869
+
| _ :: rest ->
870
+
find_context tokens rest
871
+
872
+
and find_context_in_quotation = function
873
+
| [] ->
874
+
None
875
+
| [(Quot_anti { a_closing = None; a_contents = tokens }, _)] ->
876
+
find_context tokens tokens
877
+
| _ :: rest ->
878
+
find_context_in_quotation rest
879
+
880
+
(* +-----------------------------------------------------------------+
881
+
| Completion |
882
+
+-----------------------------------------------------------------+ *)
883
+
884
+
#if OCAML_VERSION < (4, 11, 0)
885
+
let longident_parse= Longident.parse
886
+
#else
887
+
let longident_parse str=
888
+
let lexbuf= Lexing.from_string str in
889
+
Parse.longident lexbuf
890
+
#endif
891
+
892
+
let complete ~phrase_terminator ~input =
893
+
let true_name, false_name = ("true", "false") in
894
+
let tokens = UTop_lexer.lex_string input in
895
+
(* Filter blanks and comments. *)
896
+
let tokens = filter tokens in
897
+
match tokens with
898
+
899
+
(* Completion on directive names. *)
900
+
| [(Symbol "#", { idx2 = stop })]
901
+
| [(Symbol "#", _); (Blanks, { idx2 = stop })] ->
902
+
(stop, list_directives phrase_terminator)
903
+
| [(Symbol "#", _); ((Lident src | Uident src), { idx1 = start })] ->
904
+
(start, lookup_assoc src (list_directives phrase_terminator))
905
+
906
+
(* Complete with ";;" when possible. *)
907
+
| [(Symbol "#", _); ((Lident _ | Uident _), _); (String (_, true), { idx2 = stop })]
908
+
| [(Symbol "#", _); ((Lident _ | Uident _), _); (String (_, true), _); (Blanks, { idx2 = stop })] ->
909
+
(stop, [(phrase_terminator, "")])
910
+
| [(Symbol "#", _); ((Lident _ | Uident _), _); (String (_, true), _); (Symbol sym, { idx1 = start })] ->
911
+
if Astring.String.is_prefix phrase_terminator ~affix:sym then
912
+
(start, [(phrase_terminator, "")])
913
+
else
914
+
(0, [])
915
+
916
+
(* Completion on #require. *)
917
+
| [(Symbol "#", _); (Lident "require", _); (String (tlen, false), loc)] ->
918
+
let pkg = String.sub input (loc.ofs1 + tlen) (String.length input - loc.ofs1 - tlen) in
919
+
let pkgs = lookup pkg [] in
920
+
(loc.idx1 + 1, List.map (fun pkg -> (pkg, "\"" ^ phrase_terminator)) (List.sort compare pkgs))
921
+
922
+
| [(Symbol "#", _); (Lident "typeof", _); (String (tlen, false), loc)] ->
923
+
let prefix = String.sub input (loc.ofs1 + tlen) (String.length input - loc.ofs1 - tlen) in
924
+
begin match longident_parse prefix with
925
+
| Longident.Ldot (lident, last_prefix) ->
926
+
let set = names_of_module lident in
927
+
let compls = lookup last_prefix (String_set.elements set) in
928
+
let start = loc.idx1 + 1 + (String.length prefix - String.length last_prefix) in
929
+
(start, List.map (fun w -> (w, "")) compls)
930
+
| _ ->
931
+
let set = global_names () in
932
+
let compls = lookup prefix (String_set.elements set) in
933
+
(loc.idx1 + 1, List.map (fun w -> (w, "")) compls)
934
+
end
935
+
936
+
(* Completion on #load. *)
937
+
| [(Symbol "#", _); (Lident ("load" | "load_rec"), _); (String (tlen, false), loc)] ->
938
+
let file = String.sub input (loc.ofs1 + tlen) (String.length input - loc.ofs1 - tlen) in
939
+
let filter name = Filename.check_suffix name ".cma" || Filename.check_suffix name ".cmo" in
940
+
let map =
941
+
if Filename.is_relative file then
942
+
let dir = Filename.dirname file in
943
+
List.fold_left
944
+
(fun acc d -> add_files filter acc (Filename.concat d dir))
945
+
String_map.empty
946
+
(Filename.current_dir_name ::
947
+
#if OCAML_VERSION >= (4, 08, 0)
948
+
(Load_path.get_paths ())
949
+
#else
950
+
!Config.load_path
951
+
#endif
952
+
)
953
+
954
+
else
955
+
add_files filter String_map.empty (Filename.dirname file)
956
+
in
957
+
let list = String_map.bindings map in
958
+
let name = basename file in
959
+
let result = lookup_assoc name list in
960
+
(loc.idx2 - String.length name,
961
+
List.map (function (w, Directory) -> (w, "") | (w, File) -> (w, "\"" ^ phrase_terminator)) result)
962
+
963
+
(* Completion on #use and #mod_use *)
964
+
| [(Symbol "#", _); (Lident "use", _); (String (tlen, false), loc)]
965
+
| [(Symbol "#", _); (Lident "mod_use", _); (String (tlen, false), loc)] ->
966
+
let file = String.sub input (loc.ofs1 + tlen) (String.length input - loc.ofs1 - tlen) in
967
+
let filter name =
968
+
match try Some (String.rindex name '.') with Not_found -> None with
969
+
| None ->
970
+
true
971
+
| Some idx ->
972
+
let ext = String.sub name (idx + 1) (String.length name - (idx + 1)) in
973
+
ext = "ml"
974
+
in
975
+
let map =
976
+
if Filename.is_relative file then
977
+
let dir = Filename.dirname file in
978
+
List.fold_left
979
+
(fun acc d -> add_files filter acc (Filename.concat d dir))
980
+
String_map.empty
981
+
(Filename.current_dir_name ::
982
+
#if OCAML_VERSION >= (4, 08, 0)
983
+
(Load_path.get_paths ())
984
+
#else
985
+
!Config.load_path
986
+
#endif
987
+
)
988
+
else
989
+
add_files filter String_map.empty (Filename.dirname file)
990
+
in
991
+
let list = String_map.bindings map in
992
+
let name = basename file in
993
+
let result = lookup_assoc name list in
994
+
(loc.idx2 - String.length name,
995
+
List.map (function (w, Directory) -> (w, "") | (w, File) -> (w, "\"" ^ phrase_terminator)) result)
996
+
997
+
(* Completion on #directory and #cd. *)
998
+
| [(Symbol "#", _); (Lident ("cd" | "directory"), _); (String (tlen, false), loc)] ->
999
+
let file = String.sub input (loc.ofs1 + tlen) (String.length input - loc.ofs1 - tlen) in
1000
+
let list = list_directories (Filename.dirname file) in
1001
+
let name = basename file in
1002
+
let result = lookup name list in
1003
+
(loc.idx2 - String.length name, List.map (function dir -> (dir, "")) result)
1004
+
1005
+
(* Generic completion on directives. *)
1006
+
| [(Symbol "#", _); ((Lident dir | Uident dir), _); (Blanks, { idx2 = stop })] ->
1007
+
(stop,
1008
+
match try Some (Hashtbl.find Toploop.directive_table dir) with Not_found -> None with
1009
+
| Some (Toploop.Directive_none _) -> [(phrase_terminator, "")]
1010
+
| Some (Toploop.Directive_string _) -> [(" \"", "")]
1011
+
| Some (Toploop.Directive_bool _) -> [(true_name, phrase_terminator); (false_name, phrase_terminator)]
1012
+
| Some (Toploop.Directive_int _) -> []
1013
+
| Some (Toploop.Directive_ident _) -> List.map (fun w -> (w, "")) (String_set.elements (global_names ()))
1014
+
| None -> [])
1015
+
| (Symbol "#", _) :: ((Lident dir | Uident dir), _) :: tokens -> begin
1016
+
match try Some (Hashtbl.find Toploop.directive_table dir) with Not_found -> None with
1017
+
| Some (Toploop.Directive_none _) ->
1018
+
(0, [])
1019
+
| Some (Toploop.Directive_string _) ->
1020
+
(0, [])
1021
+
| Some (Toploop.Directive_bool _) -> begin
1022
+
match tokens with
1023
+
| [(Lident id, { idx1 = start })] ->
1024
+
(start, lookup_assoc id [(true_name, phrase_terminator); (false_name, phrase_terminator)])
1025
+
| _ ->
1026
+
(0, [])
1027
+
end
1028
+
| Some (Toploop.Directive_int _) ->
1029
+
(0, [])
1030
+
| Some (Toploop.Directive_ident _) -> begin
1031
+
match parse_longident (List.rev tokens) with
1032
+
| Some (Value, None, start, id) ->
1033
+
(start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (global_names ()))))
1034
+
| Some (Value, Some longident, start, id) ->
1035
+
(start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (names_of_module longident))))
1036
+
| _ ->
1037
+
(0, [])
1038
+
end
1039
+
| None ->
1040
+
(0, [])
1041
+
end
1042
+
1043
+
(* Completion on identifiers. *)
1044
+
| _ ->
1045
+
match find_context tokens tokens with
1046
+
| None ->
1047
+
(0, [])
1048
+
| Some [] ->
1049
+
(0, List.map (fun w -> (w, "")) (String_set.elements (String_set.union !UTop.keywords (global_names ()))))
1050
+
| Some tokens ->
1051
+
match parse_method tokens with
1052
+
| Some (longident, meths, start, meth) ->
1053
+
(start, List.map (fun w -> (w, "")) (lookup meth (methods_of_object longident meths)))
1054
+
| None ->
1055
+
match parse_label tokens with
1056
+
| Some (Fun, longident, meths, Optional, start, label) ->
1057
+
(start, List.map (fun (w, kind) -> (w, ":")) (lookup_assoc label (List.filter (function (w, Optional) -> true | (w, Required) -> false) (labels_of_function longident meths))))
1058
+
| Some (Fun, longident, meths, Required, start, label) ->
1059
+
(start, List.map (fun (w, kind) -> (w, ":")) (lookup_assoc label (labels_of_function longident meths)))
1060
+
| Some (New, longident, meths, Optional, start, label) ->
1061
+
(start, List.map (fun (w, kind) -> (w, ":")) (lookup_assoc label (List.filter (function (w, Optional) -> true | (w, Required) -> false) (labels_of_newclass longident))))
1062
+
| Some (New, longident, meths, Required, start, label) ->
1063
+
(start, List.map (fun (w, kind) -> (w, ":")) (lookup_assoc label (labels_of_newclass longident)))
1064
+
| None ->
1065
+
match parse_longident tokens with
1066
+
| None ->
1067
+
(0, [])
1068
+
| Some (Value, None, start, id) ->
1069
+
(start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (String_set.union !UTop.keywords (global_names ())))))
1070
+
| Some (Value, Some longident, start, id) ->
1071
+
(start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (names_of_module longident))))
1072
+
| Some (Field, None, start, id) ->
1073
+
(start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (global_fields ()))))
1074
+
| Some (Field, Some longident, start, id) ->
1075
+
(start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (fields_of_module longident))))
1076
+
1077
+
let complete ~phrase_terminator ~input =
1078
+
try
1079
+
(complete ~phrase_terminator ~input : int * (string * string) list)
1080
+
with Cmi_format.Error _ ->
1081
+
(0, [])
+20
lib/uTop_complete.mli
+20
lib/uTop_complete.mli
···
1
+
(*
2
+
* uTop_complete.mli
3
+
* -----------------
4
+
* Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
5
+
* Licence : BSD3
6
+
*
7
+
* This file is a part of utop.
8
+
*)
9
+
10
+
(** OCaml completion. *)
11
+
12
+
val complete
13
+
: phrase_terminator:string
14
+
-> input:string
15
+
-> int * (string * string) list
16
+
(** [complete ~phrase_terminator ~input] returns the start of the completed word
17
+
in [input] and the list of possible completions with their suffixes. *)
18
+
19
+
val reset : unit -> unit
20
+
(** Reset global cache. It must be called before each interactive read line. *)
+11
lib/uTop_lexer.mli
+11
lib/uTop_lexer.mli
···
1
+
(*
2
+
* uTop_lexer.mli
3
+
* --------------
4
+
* Copyright : (c) 2012, Jeremie Dimino <jeremie@dimino.org>
5
+
* Licence : BSD3
6
+
*
7
+
* This file is a part of utop.
8
+
*)
9
+
10
+
val lex_string : string -> (UTop_token.t * UTop_token.location) list
11
+
(** [lex_string str] returns all the tokens contained in [str]. *)
+230
lib/uTop_lexer.mll
+230
lib/uTop_lexer.mll
···
1
+
(*
2
+
* uTop_lexer.mll
3
+
* --------------
4
+
* Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
5
+
* Licence : BSD3
6
+
*
7
+
* This file is a part of utop.
8
+
*)
9
+
10
+
(* Lexer for the OCaml language. *)
11
+
12
+
{
13
+
open Lexing
14
+
open UTop_token
15
+
16
+
let mkloc idx1 idx2 ofs1 ofs2 = {
17
+
idx1 = idx1;
18
+
idx2 = idx2;
19
+
ofs1 = ofs1;
20
+
ofs2 = ofs2;
21
+
}
22
+
23
+
(* Only for ascii-only lexemes. *)
24
+
let lexeme_loc idx lexbuf =
25
+
let ofs1 = lexeme_start lexbuf and ofs2 = lexeme_end lexbuf in
26
+
{
27
+
idx1 = idx;
28
+
idx2 = idx + (ofs2 - ofs1);
29
+
ofs1 = ofs1;
30
+
ofs2 = ofs2;
31
+
}
32
+
33
+
let _merge_loc l1 l2 = {
34
+
idx1 = l1.idx1;
35
+
idx2 = l2.idx2;
36
+
ofs1 = l1.ofs1;
37
+
ofs2 = l2.ofs2;
38
+
}
39
+
40
+
}
41
+
42
+
let uchar = ['\x00' - '\x7f'] | _ [ '\x80' - '\xbf' ]*
43
+
44
+
let blank = [' ' '\009' '\012']
45
+
let lowercase = ['a'-'z' '_']
46
+
let uppercase = ['A'-'Z']
47
+
let identchar = ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9']
48
+
let lident = lowercase identchar*
49
+
let uident = uppercase identchar*
50
+
let ident = (lowercase|uppercase) identchar*
51
+
52
+
let hexa_char = ['0'-'9' 'A'-'F' 'a'-'f']
53
+
let decimal_literal =
54
+
['0'-'9'] ['0'-'9' '_']*
55
+
let hex_literal =
56
+
'0' ['x' 'X'] hexa_char ['0'-'9' 'A'-'F' 'a'-'f' '_']*
57
+
let oct_literal =
58
+
'0' ['o' 'O'] ['0'-'7'] ['0'-'7' '_']*
59
+
let bin_literal =
60
+
'0' ['b' 'B'] ['0'-'1'] ['0'-'1' '_']*
61
+
let int_literal =
62
+
decimal_literal | hex_literal | oct_literal | bin_literal
63
+
let float_literal =
64
+
['0'-'9'] ['0'-'9' '_']*
65
+
('.' ['0'-'9' '_']* )?
66
+
(['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)?
67
+
68
+
let symbolchar =
69
+
['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~']
70
+
71
+
rule tokens idx acc = parse
72
+
| eof
73
+
{ (idx, None, List.rev acc) }
74
+
| ('\n' | blank)+
75
+
{ let loc = lexeme_loc idx lexbuf in
76
+
tokens loc.idx2 ((Blanks, loc) :: acc) lexbuf }
77
+
| lident
78
+
{ let src = lexeme lexbuf in
79
+
let loc = lexeme_loc idx lexbuf in
80
+
let tok =
81
+
match src with
82
+
| ("true" | "false") ->
83
+
Constant src
84
+
| _ ->
85
+
Lident src
86
+
in
87
+
tokens loc.idx2 ((tok, loc) :: acc) lexbuf }
88
+
| uident
89
+
{ let src = lexeme lexbuf in
90
+
let loc = lexeme_loc idx lexbuf in
91
+
let tok = Uident src in
92
+
tokens loc.idx2 ((tok, loc) :: acc) lexbuf }
93
+
| int_literal "l"
94
+
| int_literal "L"
95
+
| int_literal "n"
96
+
| int_literal
97
+
| float_literal
98
+
{ let loc = lexeme_loc idx lexbuf in
99
+
let tok = Constant (lexeme lexbuf) in
100
+
tokens loc.idx2 ((tok, loc) :: acc) lexbuf }
101
+
| '"'
102
+
{ let ofs = lexeme_start lexbuf in
103
+
let item, idx2= cm_string (idx + 1) lexbuf in
104
+
let loc = mkloc idx idx2 ofs (lexeme_end lexbuf) in
105
+
tokens idx2 ((item, loc) :: acc) lexbuf }
106
+
| '{' (lowercase* as tag) '|'
107
+
{ let ofs = lexeme_start lexbuf in
108
+
let delim_len = String.length tag + 2 in
109
+
let idx2, terminated = quoted_string (idx + delim_len) tag lexbuf in
110
+
let loc = mkloc idx idx2 ofs (lexeme_end lexbuf) in
111
+
tokens idx2 ((String (delim_len, terminated), loc) :: acc) lexbuf }
112
+
| "'" [^'\'' '\\'] "'"
113
+
| "'\\" ['\\' '"' 'n' 't' 'b' 'r' ' ' '\'' 'x' '0'-'9'] eof
114
+
| "'\\" ['\\' '"' 'n' 't' 'b' 'r' ' ' '\''] "'"
115
+
| "'\\" (['0'-'9'] ['0'-'9'] | 'x' hexa_char) eof
116
+
| "'\\" (['0'-'9'] ['0'-'9'] ['0'-'9'] | 'x' hexa_char hexa_char) eof
117
+
| "'\\" (['0'-'9'] ['0'-'9'] ['0'-'9'] | 'x' hexa_char hexa_char) "'"
118
+
{ let loc = lexeme_loc idx lexbuf in
119
+
tokens loc.idx2 ((Char, loc) :: acc) lexbuf }
120
+
| "'\\" uchar
121
+
{ let loc = mkloc idx (idx + 3) (lexeme_start lexbuf) (lexeme_end lexbuf) in
122
+
tokens loc.idx2 ((Error, loc) :: acc) lexbuf }
123
+
| "(*)"
124
+
{ let loc = lexeme_loc idx lexbuf in
125
+
tokens loc.idx2 ((Comment (Comment_reg, true), loc) :: acc) lexbuf }
126
+
| "(**)"
127
+
{ let loc = lexeme_loc idx lexbuf in
128
+
tokens loc.idx2 ((Comment (Comment_doc, true), loc) :: acc) lexbuf }
129
+
| "(**"
130
+
{ let ofs = lexeme_start lexbuf in
131
+
let idx2, terminated = comment (idx + 3) 0 lexbuf in
132
+
let loc = mkloc idx idx2 ofs (lexeme_end lexbuf) in
133
+
tokens idx2 ((Comment (Comment_doc, terminated), loc) :: acc) lexbuf }
134
+
| "(*"
135
+
{ let ofs = lexeme_start lexbuf in
136
+
let idx2, terminated = comment (idx + 2) 0 lexbuf in
137
+
let loc = mkloc idx idx2 ofs (lexeme_end lexbuf) in
138
+
tokens idx2 ((Comment (Comment_reg, terminated), loc) :: acc) lexbuf }
139
+
| ""
140
+
{ symbol idx acc lexbuf }
141
+
142
+
and symbol idx acc = parse
143
+
| "(" | ")"
144
+
| "[" | "]"
145
+
| "{" | "}"
146
+
| "`"
147
+
| "#"
148
+
| ","
149
+
| ";" | ";;"
150
+
| symbolchar+
151
+
{ let loc = lexeme_loc idx lexbuf in
152
+
let tok = Symbol (lexeme lexbuf) in
153
+
tokens loc.idx2 ((tok, loc) :: acc) lexbuf }
154
+
| uchar
155
+
{
156
+
let loc = mkloc idx (idx + 1) (lexeme_start lexbuf) (lexeme_end lexbuf) in
157
+
tokens loc.idx2 ((Error, loc) :: acc) lexbuf
158
+
}
159
+
160
+
and cm_string idx= parse
161
+
| '"'
162
+
{ (String (1, true), idx+1) }
163
+
| "\\\""
164
+
{ let idx2, terminated= string (idx + 2) lexbuf in
165
+
(String (1, terminated), idx2)
166
+
}
167
+
| uchar
168
+
{
169
+
170
+
let idx2, terminated= string (idx + 1) lexbuf in
171
+
(String (1, terminated), idx2)
172
+
}
173
+
| eof
174
+
{ (String (1, false), idx) }
175
+
176
+
and comment idx depth = parse
177
+
| "(*"
178
+
{ comment (idx + 2) (depth + 1) lexbuf }
179
+
| "*)"
180
+
{ if depth = 0 then
181
+
(idx + 2, true)
182
+
else
183
+
comment (idx + 2) (depth - 1) lexbuf }
184
+
| '"'
185
+
{ let idx, terminated = string (idx + 1) lexbuf in
186
+
if terminated then
187
+
comment idx depth lexbuf
188
+
else
189
+
(idx, false) }
190
+
| uchar
191
+
{
192
+
comment (idx + 1) depth lexbuf
193
+
194
+
}
195
+
| eof
196
+
{ (idx, false) }
197
+
198
+
and string idx = parse
199
+
| '"'
200
+
{ (idx + 1, true) }
201
+
| "\\\""
202
+
{ string (idx + 2) lexbuf }
203
+
| uchar
204
+
{
205
+
string (idx + 1) lexbuf
206
+
207
+
}
208
+
| eof
209
+
{ (idx, false) }
210
+
211
+
and quoted_string idx tag = parse
212
+
| '|' (lowercase* as tag2) '}'
213
+
{ let idx = idx + 2 + String.length tag2 in
214
+
if tag = tag2 then
215
+
(idx, true)
216
+
else
217
+
quoted_string idx tag lexbuf }
218
+
| eof
219
+
{ (idx, false) }
220
+
| uchar
221
+
{
222
+
quoted_string (idx + 1) tag lexbuf
223
+
224
+
}
225
+
226
+
{
227
+
let lex_string str =
228
+
let _, _, items = tokens 0 [] (Lexing.from_string str) in
229
+
items
230
+
}
+50
lib/uTop_token.ml
+50
lib/uTop_token.ml
···
1
+
(*
2
+
* uTop_token.ml
3
+
* -------------
4
+
* Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
5
+
* Licence : BSD3
6
+
*
7
+
* This file is a part of utop.
8
+
*)
9
+
10
+
(** Tokens.
11
+
12
+
The type of tokens is semi-structured: parentheses construct and quotations
13
+
are nested and others tokens are flat list. *)
14
+
15
+
(** 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
+
23
+
type t =
24
+
| Symbol of string
25
+
| Lident of string
26
+
| Uident of string
27
+
| Constant of string
28
+
| Char
29
+
| String of int * bool (** [String (quote_size, terminated)]. *)
30
+
| Comment of comment_kind * bool (** [Comment (kind, terminated)]. *)
31
+
| Blanks
32
+
| Error
33
+
| Quotation of (quotation_item * location) list * bool
34
+
(** [Quotation (items, terminated)]. *)
35
+
36
+
and comment_kind =
37
+
| Comment_reg (** Regular comment. *)
38
+
| Comment_doc (** Documentation comment. *)
39
+
40
+
and quotation_item =
41
+
| Quot_data
42
+
| Quot_anti of antiquotation
43
+
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
+
}
+177
lib/worker.ml
+177
lib/worker.ml
···
1
+
open Js_of_ocaml_toplevel
2
+
open Js_top_worker_rpc
3
+
4
+
(* OCamlorg toplevel in a web worker
5
+
6
+
This communicates with the toplevel code via the API defined in
7
+
{!Toplevel_api}. This allows the OCaml execution to not block the "main
8
+
thread" keeping the page responsive. *)
9
+
10
+
module Version = struct
11
+
type t = int list
12
+
13
+
let split_char ~sep p =
14
+
let len = String.length p in
15
+
let rec split beg cur =
16
+
if cur >= len then
17
+
if cur - beg > 0 then [ String.sub p beg (cur - beg) ] else []
18
+
else if sep p.[cur] then
19
+
String.sub p beg (cur - beg) :: split (cur + 1) (cur + 1)
20
+
else
21
+
split beg (cur + 1)
22
+
in
23
+
split 0 0
24
+
25
+
let split v =
26
+
match
27
+
split_char ~sep:(function '+' | '-' | '~' -> true | _ -> false) v
28
+
with
29
+
| [] ->
30
+
assert false
31
+
| x :: _ ->
32
+
List.map
33
+
int_of_string
34
+
(split_char ~sep:(function '.' -> true | _ -> false) x)
35
+
36
+
let current = split Sys.ocaml_version
37
+
38
+
let compint (a : int) b = compare a b
39
+
40
+
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)
52
+
end
53
+
54
+
let exec' s =
55
+
let res : bool = JsooTop.use Format.std_formatter s in
56
+
if not res then Format.eprintf "error while evaluating %s@." s
57
+
58
+
let setup () =
59
+
JsooTop.initialize ();
60
+
Sys.interactive := false;
61
+
if Version.compare Version.current [ 4; 07 ] >= 0 then exec' "open Stdlib";
62
+
let header1 = Printf.sprintf " %s version %%s" "OCaml" in
63
+
let header2 =
64
+
Printf.sprintf
65
+
" Compiled with Js_of_ocaml version %s"
66
+
Js_of_ocaml.Sys_js.js_of_ocaml_version
67
+
in
68
+
exec' (Printf.sprintf "Format.printf \"%s@.\" Sys.ocaml_version;;" header1);
69
+
exec' (Printf.sprintf "Format.printf \"%s@.\";;" header2);
70
+
exec' "#enable \"pretty\";;";
71
+
exec' "#disable \"shortvar\";;";
72
+
Toploop.add_directive
73
+
"load_js"
74
+
(Toploop.Directive_string
75
+
(fun name -> Js_of_ocaml.Js.Unsafe.global##load_script_ name))
76
+
Toploop.{ section = ""; doc = "Load a javascript script" };
77
+
Sys.interactive := true;
78
+
()
79
+
80
+
let setup_printers () =
81
+
exec' "let _print_unit fmt (_ : 'a) : 'a = Format.pp_print_string fmt \"()\"";
82
+
Topdirs.dir_install_printer
83
+
Format.std_formatter
84
+
Longident.(Lident "_print_unit")
85
+
86
+
let stdout_buff = Buffer.create 100
87
+
88
+
let stderr_buff = Buffer.create 100
89
+
90
+
(* RPC function implementations *)
91
+
92
+
module M = Idl.IdM (* Server is synchronous *)
93
+
94
+
module IdlM = Idl.Make (M)
95
+
96
+
module Server = Toplevel_api_gen.Make (IdlM.GenServer ())
97
+
98
+
(* These are all required to return the appropriate value for the API within the
99
+
[IdlM.T] monad. The simplest way to do this is to use [IdlM.ErrM.return] for
100
+
the success case and [IdlM.ErrM.return_err] for the failure case *)
101
+
102
+
let buff_opt b = match Buffer.contents b with "" -> None | s -> Some s
103
+
104
+
let execute =
105
+
let code_buff = Buffer.create 100 in
106
+
let res_buff = Buffer.create 100 in
107
+
let pp_code = Format.formatter_of_buffer code_buff in
108
+
let pp_result = Format.formatter_of_buffer res_buff in
109
+
let highlighted = ref None in
110
+
let highlight_location loc =
111
+
let _file1, line1, col1 = Location.get_pos_info loc.Location.loc_start in
112
+
let _file2, line2, col2 = Location.get_pos_info loc.Location.loc_end in
113
+
highlighted := Some Toplevel_api_gen.{ line1; col1; line2; col2 }
114
+
in
115
+
fun phrase ->
116
+
Buffer.clear code_buff;
117
+
Buffer.clear res_buff;
118
+
Buffer.clear stderr_buff;
119
+
Buffer.clear stdout_buff;
120
+
JsooTop.execute true ~pp_code ~highlight_location pp_result phrase;
121
+
Format.pp_print_flush pp_code ();
122
+
Format.pp_print_flush pp_result ();
123
+
IdlM.ErrM.return
124
+
Toplevel_api_gen.
125
+
{ stdout = buff_opt stdout_buff
126
+
; stderr = buff_opt stderr_buff
127
+
; sharp_ppf = buff_opt code_buff
128
+
; caml_ppf = buff_opt res_buff
129
+
; highlight = !highlighted
130
+
}
131
+
132
+
let setup () =
133
+
Js_of_ocaml.Sys_js.set_channel_flusher stdout (Buffer.add_string stdout_buff);
134
+
Js_of_ocaml.Sys_js.set_channel_flusher stderr (Buffer.add_string stderr_buff);
135
+
setup ();
136
+
setup_printers ();
137
+
IdlM.ErrM.return
138
+
Toplevel_api_gen.
139
+
{ stdout = buff_opt stdout_buff
140
+
; stderr = buff_opt stderr_buff
141
+
; sharp_ppf = None
142
+
; caml_ppf = None
143
+
; highlight = None
144
+
}
145
+
146
+
let complete phrase =
147
+
let contains_double_underscore s =
148
+
let len = String.length s in
149
+
let rec aux i =
150
+
if i > len - 2 then
151
+
false
152
+
else if s.[i] = '_' && s.[i + 1] = '_' then
153
+
true
154
+
else
155
+
aux (i + 1)
156
+
in
157
+
aux 0
158
+
in
159
+
let n, res = UTop_complete.complete ~phrase_terminator:";;" ~input:phrase in
160
+
let res =
161
+
List.filter (fun (l, _) -> not (contains_double_underscore l)) res
162
+
in
163
+
let completions = List.map fst res in
164
+
IdlM.ErrM.return Toplevel_api_gen.{ n; completions }
165
+
166
+
let server process e =
167
+
let call : Rpc.call = e in
168
+
M.bind (process call) (fun response -> Js_of_ocaml.Worker.post_message (response : Rpc.response));
169
+
()
170
+
171
+
let run () =
172
+
(* Here we bind the server stub functions to the implementations *)
173
+
Server.complete complete;
174
+
Server.exec execute;
175
+
Server.setup setup;
176
+
let rpc_fn = IdlM.server Server.implementation in
177
+
Js_of_ocaml.Worker.set_onmessage (server rpc_fn)