this repo has no description
Support other versions of OCaml
+142
-15
+7
-1
example/example.ml
+7
-1
example/example.ml
···
15
15
Option.iter (fun s -> log ("stdout: " ^ s)) o.stdout;
16
16
Option.iter (fun s -> log ("stderr: " ^ s)) o.stderr;
17
17
Option.iter (fun s -> log ("sharp_ppf: " ^ s)) o.sharp_ppf;
18
-
Option.iter (fun s -> log ("caml_ppf: " ^ s)) o.caml_ppf
18
+
Option.iter (fun s -> log ("caml_ppf: " ^ s)) o.caml_ppf;
19
+
let strloc (line,col) =
20
+
"(" ^ string_of_int line ^ "," ^ string_of_int col ^ ")"
21
+
in
22
+
Option.iter (fun h ->
23
+
let open Toplevel_api_gen in
24
+
log ("highlight " ^ strloc (h.line1, h.col1) ^ " to " ^ strloc (h.line2, h.col2))) o.highlight
19
25
20
26
let _ =
21
27
let ( let* ) = Lwt_result.bind in
+7
-1
idl/toplevel_api.ml
+7
-1
idl/toplevel_api.ml
···
34
34
35
35
type init_libs = { cmi_urls : string list; cmas : cma list } [@@deriving rpcty]
36
36
37
-
(** For now we are only using a simple error type *)
38
37
type err = InternalError of string [@@deriving rpcty]
39
38
40
39
module E = Idl.Error.Make (struct
···
62
61
let implementation = implement description
63
62
let unit_p = Param.mk Types.unit
64
63
let phrase_p = Param.mk Types.string
64
+
let typecheck_result_p = Param.mk exec_result
65
65
let exec_result_p = Param.mk exec_result
66
66
let completion_p = Param.mk completion_result
67
67
···
88
88
"must be initialised first.";
89
89
]
90
90
(unit_p @-> returning exec_result_p err)
91
+
92
+
let typecheck =
93
+
declare
94
+
"typecheck"
95
+
[ "Typecheck a phrase without actually executing it." ]
96
+
(phrase_p @-> returning typecheck_result_p err)
91
97
92
98
let exec =
93
99
declare "exec"
+9
-6
idl/toplevel_api_gen.ml
+9
-6
idl/toplevel_api_gen.ml
···
441
441
and _ = init_libs
442
442
end[@@ocaml.doc "@inline"][@@merlin.hide ]
443
443
type err =
444
-
| InternalError of string [@@ocaml.doc
445
-
" For now we are only using a simple error type "]
446
-
[@@deriving rpcty]
444
+
| InternalError of string [@@deriving rpcty]
447
445
include
448
446
struct
449
447
let _ = fun (_ : err) -> ()
···
481
479
and err =
482
480
{
483
481
Rpc.Types.name = "err";
484
-
Rpc.Types.description =
485
-
["For now we are only using a simple error type"];
482
+
Rpc.Types.description = [];
486
483
Rpc.Types.ty = typ_of_err
487
484
}
488
485
let _ = typ_of_err
···
511
508
let implementation = implement description
512
509
let unit_p = Param.mk Types.unit
513
510
let phrase_p = Param.mk Types.string
511
+
let typecheck_result_p = Param.mk exec_result
514
512
let exec_result_p = Param.mk exec_result
515
513
let completion_p = Param.mk completion_result
516
514
let init_libs =
···
520
518
"MUST include the urls from which they may be fetched"]
521
519
init_libs
522
520
let init =
523
-
declare "init" ["Initialise the toplevel."]
521
+
declare "init"
522
+
["Initialise the toplevel. This must be called before any other API."]
524
523
(init_libs @-> (returning unit_p err))
525
524
let setup =
526
525
declare "setup"
···
528
527
"printed when starting a toplevel. Note that the toplevel";
529
528
"must be initialised first."]
530
529
(unit_p @-> (returning exec_result_p err))
530
+
let typecheck =
531
+
declare "typecheck"
532
+
["Typecheck a phrase without actually executing it."]
533
+
(phrase_p @-> (returning typecheck_result_p err))
531
534
let exec =
532
535
declare "exec"
533
536
["Execute a phrase using the toplevel. The toplevel must have been";
+8
lib/dune
+8
lib/dune
+111
-7
lib/worker.ml
lib/worker.cppo.ml
+111
-7
lib/worker.ml
lib/worker.cppo.ml
···
1
1
open Js_of_ocaml_toplevel
2
2
open Js_top_worker_rpc
3
3
4
+
let optbind : 'a option -> ('a -> 'b option) -> 'b option = fun x fn -> match x with | None -> None | Some a -> fn a
5
+
4
6
let log fmt =
5
7
Format.kasprintf
6
8
(fun s -> Js_of_ocaml.(Firebug.console##log (Js.string s)))
···
141
143
142
144
type signature = Types.signature_item list
143
145
type flags = Cmi_format.pers_flags list
144
-
type header = Misc.modname * signature
146
+
type header = string * signature
147
+
type crcs = (string * Digest.t option) list
145
148
146
149
(** The following two functions are taken from cmi_format.ml in
147
150
the compiler, but changed to work on bytes rather than input
···
150
153
let offset = 0 in
151
154
let (name, sign) = (Marshal.from_bytes str offset : header) in
152
155
let offset = offset + Marshal.total_size str offset in
153
-
let crcs = (Marshal.from_bytes str offset : Misc.crcs) in
156
+
let crcs = (Marshal.from_bytes str offset : crcs) in
154
157
let offset = offset + Marshal.total_size str offset in
155
158
let flags = (Marshal.from_bytes str offset : flags) in
156
159
{
···
188
191
(fun cmi -> (Filename.basename cmi |> Filename.chop_extension, cmi))
189
192
init_libs.cmi_urls
190
193
in
191
-
let old_loader = !Persistent_env.Persistent_signature.load in
192
-
(Persistent_env.Persistent_signature.load :=
194
+
#if OCAML_VERSION < (4,9,0)
195
+
let open Env.Persistent_signature in
196
+
#else
197
+
let open Persistent_env.Persistent_signature in
198
+
#endif
199
+
let old_loader = !load in
200
+
(load :=
193
201
fun ~unit_name ->
194
202
let result =
195
-
Option.bind
196
-
(List.assoc_opt (String.uncapitalize_ascii unit_name) cmi_files)
203
+
optbind
204
+
(try Some (List.assoc (String.uncapitalize_ascii unit_name) cmi_files) with _ -> None)
197
205
sync_get
198
206
in
199
207
match result with
200
208
| Some x ->
201
209
Some
202
210
{
203
-
Persistent_env.Persistent_signature.filename =
211
+
filename =
204
212
Sys.executable_name;
205
213
cmi = read_cmi unit_name (Bytes.of_string x);
206
214
}
···
264
272
Js_of_ocaml.Worker.post_message (Marshal.to_string response []));
265
273
()
266
274
275
+
let loc = function
276
+
| Syntaxerr.Error x ->
277
+
Some (Syntaxerr.location_of_error x)
278
+
| Lexer.Error (_, loc)
279
+
| Typecore.Error (loc, _, _)
280
+
| Typetexp.Error (loc, _, _)
281
+
| Typeclass.Error (loc, _, _)
282
+
| Typemod.Error (loc, _, _)
283
+
| Typedecl.Error (loc, _)
284
+
| Translcore.Error (loc, _)
285
+
| Translclass.Error (loc, _)
286
+
| Translmod.Error (loc, _) ->
287
+
Some loc
288
+
| _ ->
289
+
None
290
+
291
+
let refill_lexbuf s p ppf buffer len =
292
+
if !p = String.length s then
293
+
0
294
+
else
295
+
let len', nl =
296
+
try String.index_from s !p '\n' - !p + 1, false with
297
+
| _ ->
298
+
String.length s - !p, true
299
+
in
300
+
let len'' = min len len' in
301
+
String.blit s !p buffer 0 len'';
302
+
(match ppf with
303
+
| Some ppf ->
304
+
Format.fprintf ppf "%s" (Bytes.sub_string buffer 0 len'');
305
+
if nl then Format.pp_print_newline ppf ();
306
+
Format.pp_print_flush ppf ()
307
+
| None ->
308
+
());
309
+
p := !p + len'';
310
+
len''
311
+
312
+
let typecheck_phrase =
313
+
let res_buff = Buffer.create 100 in
314
+
let pp_result = Format.formatter_of_buffer res_buff in
315
+
let highlighted = ref None in
316
+
let highlight_location loc =
317
+
let _file1, line1, col1 = Location.get_pos_info loc.Location.loc_start in
318
+
let _file2, line2, col2 = Location.get_pos_info loc.Location.loc_end in
319
+
highlighted := Some Toplevel_api_gen.{ line1; col1; line2; col2 }
320
+
in
321
+
fun phr ->
322
+
Buffer.clear res_buff;
323
+
Buffer.clear stderr_buff;
324
+
Buffer.clear stdout_buff;
325
+
try
326
+
let lb = Lexing.from_function (refill_lexbuf phr (ref 0) None) in
327
+
let phr = !Toploop.parse_toplevel_phrase lb in
328
+
let phr = Toploop.preprocess_phrase pp_result phr in
329
+
match phr with
330
+
| Parsetree.Ptop_def sstr ->
331
+
let oldenv = !Toploop.toplevel_env in
332
+
Typecore.reset_delayed_checks ();
333
+
#if OCAML_VERSION >= (4,9,0)
334
+
let str, sg, sn, newenv = Typemod.type_toplevel_phrase oldenv sstr in
335
+
let sg' = Typemod.Signature_names.simplify newenv sn sg in
336
+
ignore (Includemod.signatures ~mark:Mark_positive oldenv sg sg');
337
+
#else
338
+
let str, sg, newenv = Typemod.type_toplevel_phrase oldenv sstr in
339
+
let sg' = Typemod.simplify_signature sg in
340
+
ignore (Includemod.signatures oldenv sg sg');
341
+
#endif
342
+
Typecore.force_delayed_checks ();
343
+
Printtyped.implementation pp_result str;
344
+
Format.pp_print_flush pp_result ();
345
+
Warnings.check_fatal ();
346
+
flush_all ();
347
+
IdlM.ErrM.return
348
+
Toplevel_api_gen.
349
+
{ stdout = buff_opt stdout_buff
350
+
; stderr = buff_opt stderr_buff
351
+
; sharp_ppf = None
352
+
; caml_ppf = buff_opt res_buff
353
+
; highlight = !highlighted
354
+
}
355
+
| _ ->
356
+
failwith "Typechecking"
357
+
with
358
+
| x ->
359
+
(match loc x with None -> () | Some loc -> highlight_location loc);
360
+
Errors.report_error Format.err_formatter x;
361
+
IdlM.ErrM.return
362
+
Toplevel_api_gen.
363
+
{ stdout = buff_opt stdout_buff
364
+
; stderr = buff_opt stderr_buff
365
+
; sharp_ppf = None
366
+
; caml_ppf = buff_opt res_buff
367
+
; highlight = !highlighted
368
+
}
369
+
267
370
let run () =
268
371
(* Here we bind the server stub functions to the implementations *)
269
372
let open Js_of_ocaml in
···
274
377
Server.exec execute;
275
378
Server.setup setup;
276
379
Server.init init;
380
+
Server.typecheck typecheck_phrase;
277
381
let rpc_fn = IdlM.server Server.implementation in
278
382
Js_of_ocaml.Worker.set_onmessage (server rpc_fn);
279
383
Firebug.console##log (Js.string "All finished")