jon.recoil.org
this repo has no description
1(** {1 OCaml Toplevel Implementation}
2
3 This module provides the core toplevel functionality for js_top_worker.
4 It implements phrase execution, type checking, and Merlin integration
5 (completion, errors, type info).
6
7 The module is parameterized by a backend signature [S] which provides
8 platform-specific operations for different environments (WebWorker,
9 Node.js, Unix). *)
10
11open Js_top_worker_rpc
12module M = Rpc_lwt.ErrM (* Server is not synchronous *)
13module IdlM = Rpc_lwt
14
15let ( let* ) = Lwt.bind
16
17(** {2 Cell Dependency System}
18
19 Cells are identified by string IDs and can depend on previous cells.
20 Each cell is wrapped in a module [Cell__<id>] so that later cells can
21 access earlier bindings via [open Cell__<id>]. *)
22
23type captured = { stdout : string; stderr : string }
24
25let modname_of_id id = "Cell__" ^ id
26
27let is_mangled_broken orig src =
28 String.length orig <> String.length src
29 || Seq.exists2
30 (fun c c' -> c <> c' && c' <> ' ')
31 (String.to_seq orig) (String.to_seq src)
32
33let mangle_toplevel is_toplevel orig_source deps =
34 let src =
35 if not is_toplevel then orig_source
36 else if
37 String.length orig_source < 2
38 || orig_source.[0] <> '#'
39 || orig_source.[1] <> ' '
40 then (
41 Logs.err (fun m ->
42 m "xx Warning, ignoring toplevel block without a leading '# '.\n%!");
43 orig_source)
44 else
45 try
46 let s = String.sub orig_source 2 (String.length orig_source - 2) in
47 let list =
48 try Ocamltop.parse_toplevel s
49 with _ -> Ocamltop.fallback_parse_toplevel s
50 in
51 let lines =
52 List.map
53 (fun (phr, junk, output) ->
54 let l1 =
55 Printf.sprintf " %s%s" phr
56 (String.make (String.length junk) ' ')
57 in
58 match output with
59 | [] -> l1
60 | _ ->
61 let s =
62 List.map (fun x -> String.make (String.length x) ' ') output
63 in
64 String.concat "\n" (l1 :: s))
65 list
66 in
67 String.concat "\n" lines
68 with e ->
69 Logs.err (fun m ->
70 m "Error in mangle_toplevel: %s" (Printexc.to_string e));
71 let ppf = Format.err_formatter in
72 let _ = Location.report_exception ppf e in
73 orig_source
74 in
75 let line1 =
76 List.map (fun id -> Printf.sprintf "open %s" (modname_of_id id)) deps
77 |> String.concat " "
78 in
79 let line1 = if line1 = "" then "" else line1 ^ ";;\n" in
80 Logs.debug (fun m -> m "Line 1: '%s'\n%!" line1);
81 Logs.debug (fun m -> m "Source: %s\n%!" src);
82 if is_mangled_broken orig_source src then (
83 Printf.printf "Warning: mangled source is broken\n%!";
84 Printf.printf "orig length: %d\n%!" (String.length orig_source);
85 Printf.printf "src length: %d\n%!" (String.length src));
86 (line1, src)
87
88(** {2 PPX Preprocessing}
89
90 Handles PPX rewriter registration and application. Supports:
91 - Old-style [Ast_mapper] PPXs (e.g., [Ppx_js.mapper] for js_of_ocaml)
92 - [ppx_deriving]-based PPXs (registered via [Ppx_deriving.register])
93 - Modern [ppxlib]-based PPXs (registered via [Ppxlib.Driver])
94
95 The [Ppx_js.mapper] is registered by default to support js_of_ocaml
96 syntax extensions. Other PPXs can be dynamically loaded via [#require]. *)
97
98module JsooTopPpx = struct
99 open Js_of_ocaml_compiler.Stdlib
100
101 (** Old-style Ast_mapper rewriters *)
102 let ppx_rewriters = ref [ (fun _ -> Ppx_js.mapper) ]
103
104 let () =
105 Ast_mapper.register_function :=
106 fun _ f -> ppx_rewriters := f :: !ppx_rewriters
107
108 (** Apply old-style Ast_mapper rewriters *)
109 let apply_ast_mapper_rewriters_structure str =
110 let open Ast_mapper in
111 List.fold_right !ppx_rewriters ~init:str ~f:(fun ppx_rewriter str ->
112 let mapper = ppx_rewriter [] in
113 mapper.structure mapper str)
114
115 let apply_ast_mapper_rewriters_signature sg =
116 let open Ast_mapper in
117 List.fold_right !ppx_rewriters ~init:sg ~f:(fun ppx_rewriter sg ->
118 let mapper = ppx_rewriter [] in
119 mapper.signature mapper sg)
120
121 (** Apply ppx_deriving transformations using its mapper class.
122 This handles [@@deriving] attributes for dynamically loaded derivers. *)
123 let apply_ppx_deriving_structure str =
124 let mapper = new Ppx_deriving.mapper in
125 mapper#structure str
126
127 let apply_ppx_deriving_signature sg =
128 let mapper = new Ppx_deriving.mapper in
129 mapper#signature sg
130
131 (** Apply all PPX transformations in order:
132 1. Old-style Ast_mapper (e.g., Ppx_js)
133 2. ppx_deriving derivers
134 3. ppxlib-based PPXs
135 Handles AST version conversion between compiler's Parsetree and ppxlib's internal AST. *)
136 let preprocess_structure str =
137 str
138 |> apply_ast_mapper_rewriters_structure
139 |> Ppxlib_ast.Selected_ast.of_ocaml Structure
140 |> apply_ppx_deriving_structure
141 |> Ppxlib.Driver.map_structure
142 |> Ppxlib_ast.Selected_ast.to_ocaml Structure
143
144 let preprocess_signature sg =
145 sg
146 |> apply_ast_mapper_rewriters_signature
147 |> Ppxlib_ast.Selected_ast.of_ocaml Signature
148 |> apply_ppx_deriving_signature
149 |> Ppxlib.Driver.map_signature
150 |> Ppxlib_ast.Selected_ast.to_ocaml Signature
151
152 let preprocess_phrase phrase =
153 let open Parsetree in
154 match phrase with
155 | Ptop_def str -> Ptop_def (preprocess_structure str)
156 | Ptop_dir _ as x -> x
157end
158
159(** {2 Backend Signature}
160
161 Platform-specific operations that must be provided by each backend
162 (WebWorker, Node.js, Unix). *)
163
164module type S = sig
165 type findlib_t
166
167 val capture : (unit -> 'a) -> unit -> captured * 'a
168 val create_file : name:string -> content:string -> unit
169 val sync_get : string -> string option
170 val async_get : string -> (string, [> `Msg of string ]) result Lwt.t
171 val import_scripts : string list -> unit
172 val init_function : string -> unit -> unit
173 val get_stdlib_dcs : string -> Toplevel_api_gen.dynamic_cmis list
174 val findlib_init : string -> findlib_t Lwt.t
175 val path : string
176
177 val require :
178 bool -> findlib_t -> string list -> Toplevel_api_gen.dynamic_cmis list
179end
180
181(** {2 Main Functor}
182
183 The toplevel implementation, parameterized by backend operations. *)
184
185module Make (S : S) = struct
186 (** {3 Global State}
187
188 These are shared across all environments. *)
189
190 let functions : (unit -> unit) list option ref = ref None
191 let requires : string list ref = ref []
192 let path : string option ref = ref None
193 let findlib_v : S.findlib_t Lwt.t option ref = ref None
194 let findlib_resolved : S.findlib_t option ref = ref None
195 let execution_allowed = ref true
196
197 (** {3 Environment Management}
198
199 Helper to resolve env_id string to an Environment.t.
200 Empty string means the default environment. *)
201
202 let resolve_env env_id =
203 let id = if env_id = "" then Environment.default_id else env_id in
204 Environment.get_or_create id
205
206 (** {3 Lexer Helpers} *)
207
208 let refill_lexbuf s p ppf buffer len =
209 if !p = String.length s then 0
210 else
211 let len', nl =
212 try (String.index_from s !p '\n' - !p + 1, false)
213 with _ -> (String.length s - !p, true)
214 in
215 let len'' = min len len' in
216 String.blit s !p buffer 0 len'';
217 (match ppf with
218 | Some ppf ->
219 Format.fprintf ppf "%s" (Bytes.sub_string buffer 0 len'');
220 if nl then Format.pp_print_newline ppf ();
221 Format.pp_print_flush ppf ()
222 | None -> ());
223 p := !p + len'';
224 len''
225
226 (** {3 Setup and Initialization} *)
227
228 let exec' s =
229 S.capture
230 (fun () ->
231 let res : bool = Toploop.use_silently Format.std_formatter (String s) in
232 if not res then Format.eprintf "error while evaluating %s@." s)
233 ()
234
235 (** {3 Custom Require Directive}
236
237 Replaces the standard findlib #require with one that loads JavaScript
238 archives via importScripts. This is necessary because in js_of_ocaml,
239 we can't use Topdirs.dir_load to load .cma files - we need to load
240 .cma.js files via importScripts instead. *)
241
242 let add_dynamic_cmis_sync dcs =
243 (* Synchronous version for #require directive.
244 Fetches and installs toplevel CMIs synchronously. *)
245 let furl = "file://" in
246 let l = String.length furl in
247 if String.length dcs.Toplevel_api_gen.dcs_url > l
248 && String.sub dcs.dcs_url 0 l = furl
249 then begin
250 let path = String.sub dcs.dcs_url l (String.length dcs.dcs_url - l) in
251 Topdirs.dir_directory path
252 end
253 else begin
254 (* Web URL - fetch CMIs synchronously *)
255 let fetch_sync filename =
256 let url = Filename.concat dcs.Toplevel_api_gen.dcs_url filename in
257 S.sync_get url
258 in
259 let path =
260 match !path with Some p -> p | None -> failwith "Path not set"
261 in
262 let to_cmi_filename name =
263 Printf.sprintf "%s.cmi" (String.uncapitalize_ascii name)
264 in
265 Logs.info (fun m -> m "Adding toplevel modules for dynamic cmis from %s" dcs.dcs_url);
266 Logs.info (fun m -> m " toplevel modules: %s"
267 (String.concat ", " dcs.dcs_toplevel_modules));
268 (* Fetch and create toplevel module CMIs *)
269 List.iter
270 (fun name ->
271 let filename = to_cmi_filename name in
272 match fetch_sync filename with
273 | Some content ->
274 let fs_name = Filename.(concat path filename) in
275 (try S.create_file ~name:fs_name ~content with _ -> ())
276 | None -> ())
277 dcs.dcs_toplevel_modules;
278 (* Install on-demand loader for prefixed modules *)
279 if dcs.dcs_file_prefixes <> [] then begin
280 let open Persistent_env.Persistent_signature in
281 let old_loader = !load in
282#if defined OXCAML
283 load := fun ~allow_hidden ~unit_name ->
284 let filename = to_cmi_filename (Compilation_unit.Name.to_string unit_name) in
285#else
286 load := fun ~allow_hidden ~unit_name ->
287 let filename = to_cmi_filename unit_name in
288#endif
289 let fs_name = Filename.(concat path filename) in
290 if (not (Sys.file_exists fs_name))
291 && List.exists
292 (fun prefix -> String.starts_with ~prefix filename)
293 dcs.dcs_file_prefixes
294 then begin
295 Logs.info (fun m -> m "Fetching %s\n%!" filename);
296 match fetch_sync filename with
297 | Some content ->
298 (try S.create_file ~name:fs_name ~content with _ -> ())
299 | None -> ()
300 end;
301 old_loader ~allow_hidden ~unit_name
302 end
303 end
304
305 let register_require_directive () =
306 let require_handler pkg =
307 Logs.info (fun m -> m "Custom #require: loading %s" pkg);
308 match !findlib_resolved with
309 | None ->
310 Format.eprintf "Error: findlib not initialized@."
311 | Some v ->
312 let cmi_only = not !execution_allowed in
313 let dcs_list = S.require cmi_only v [pkg] in
314 List.iter add_dynamic_cmis_sync dcs_list;
315 Logs.info (fun m -> m "Custom #require: %s loaded" pkg)
316 in
317 (* Replace the standard findlib #require directive with our custom one.
318 We use add_directive which will override the existing one. *)
319 let info = { Toploop.section = "Findlib"; doc = "Load a package (js_top_worker)" } in
320 Toploop.add_directive "require" (Toploop.Directive_string require_handler) info
321
322 let setup functions () =
323 let stdout_buff = Buffer.create 100 in
324 let stderr_buff = Buffer.create 100 in
325
326 let combine o =
327 Buffer.add_string stdout_buff o.stdout;
328 Buffer.add_string stderr_buff o.stderr
329 in
330
331 let exec' s =
332 let o, () = exec' s in
333 combine o
334 in
335 Sys.interactive := false;
336
337 Toploop.input_name := "//toplevel//";
338 let path =
339 match !path with Some p -> p | None -> failwith "Path not set"
340 in
341
342 Topdirs.dir_directory path;
343
344 Toploop.initialize_toplevel_env ();
345
346 List.iter (fun f -> f ()) functions;
347 exec' "open Stdlib";
348 let header1 = Printf.sprintf " %s version %%s" "OCaml" in
349 exec' (Printf.sprintf "Format.printf \"%s@.\" Sys.ocaml_version;;" header1);
350 exec' "#enable \"pretty\";;";
351 exec' "#disable \"shortvar\";;";
352 Sys.interactive := true;
353 Logs.info (fun m -> m "Setup complete");
354 {
355 stdout = Buffer.contents stdout_buff;
356 stderr = Buffer.contents stderr_buff;
357 }
358
359 (** {3 Output Helpers} *)
360
361 let stdout_buff = Buffer.create 100
362 let stderr_buff = Buffer.create 100
363
364 let buff_opt b =
365 match String.trim (Buffer.contents b) with "" -> None | s -> Some s
366
367 let string_opt s = match String.trim s with "" -> None | s -> Some s
368
369 let loc = function
370 | Syntaxerr.Error x -> Some (Syntaxerr.location_of_error x)
371 | Lexer.Error (_, loc)
372 | Typecore.Error (loc, _, _)
373 | Typetexp.Error (loc, _, _)
374 | Typeclass.Error (loc, _, _)
375 | Typemod.Error (loc, _, _)
376 | Typedecl.Error (loc, _)
377 | Translcore.Error (loc, _)
378 | Translclass.Error (loc, _)
379 | Translmod.Error (loc, _) ->
380 Some loc
381 | _ -> None
382
383 (** {3 Phrase Execution}
384
385 Executes OCaml phrases in an environment, capturing all output.
386 Handles parsing, PPX preprocessing, and execution with error reporting. *)
387
388 let execute_in_env env phrase =
389 let code_buff = Buffer.create 100 in
390 let res_buff = Buffer.create 100 in
391 let pp_code = Format.formatter_of_buffer code_buff in
392 let pp_result = Format.formatter_of_buffer res_buff in
393 let highlighted = ref None in
394 let set_highlight loc =
395 let _file1, line1, col1 = Location.get_pos_info loc.Location.loc_start in
396 let _file2, line2, col2 = Location.get_pos_info loc.Location.loc_end in
397 highlighted := Some Toplevel_api_gen.{ line1; col1; line2; col2 }
398 in
399 Buffer.clear code_buff;
400 Buffer.clear res_buff;
401 Buffer.clear stderr_buff;
402 Buffer.clear stdout_buff;
403 let phrase =
404 let l = String.length phrase in
405 if l >= 2 && String.sub phrase (l - 2) 2 = ";;" then phrase
406 else phrase ^ ";;"
407 in
408 let o, () =
409 Environment.with_env env (fun () ->
410 S.capture
411 (fun () ->
412 let lb = Lexing.from_function (refill_lexbuf phrase (ref 0) (Some pp_code)) in
413 (try
414 while true do
415 try
416 let phr = !Toploop.parse_toplevel_phrase lb in
417 let phr = JsooTopPpx.preprocess_phrase phr in
418 ignore (Toploop.execute_phrase true pp_result phr : bool)
419 with
420 | End_of_file -> raise End_of_file
421 | x ->
422 (match loc x with Some l -> set_highlight l | None -> ());
423 Errors.report_error Format.err_formatter x
424 done
425 with End_of_file -> ());
426 flush_all ())
427 ())
428 in
429 let mime_vals = Mime_printer.get () in
430 Format.pp_print_flush pp_code ();
431 Format.pp_print_flush pp_result ();
432 Toplevel_api_gen.
433 {
434 stdout = string_opt o.stdout;
435 stderr = string_opt o.stderr;
436 sharp_ppf = buff_opt code_buff;
437 caml_ppf = buff_opt res_buff;
438 highlight = !highlighted;
439 mime_vals;
440 }
441
442 (** {3 Incremental Phrase Execution}
443
444 Executes OCaml phrases incrementally, calling a callback after each
445 phrase with its output and location. *)
446
447 type phrase_output = {
448 loc : int;
449 caml_ppf : string option;
450 mime_vals : Toplevel_api_gen.mime_val list;
451 }
452
453 let execute_in_env_incremental env phrase ~on_phrase_output =
454 let code_buff = Buffer.create 100 in
455 let res_buff = Buffer.create 100 in
456 let pp_code = Format.formatter_of_buffer code_buff in
457 let pp_result = Format.formatter_of_buffer res_buff in
458 let highlighted = ref None in
459 let set_highlight loc =
460 let _file1, line1, col1 = Location.get_pos_info loc.Location.loc_start in
461 let _file2, line2, col2 = Location.get_pos_info loc.Location.loc_end in
462 highlighted := Some Toplevel_api_gen.{ line1; col1; line2; col2 }
463 in
464 Buffer.clear code_buff;
465 Buffer.clear res_buff;
466 Buffer.clear stderr_buff;
467 Buffer.clear stdout_buff;
468 let phrase =
469 let l = String.length phrase in
470 if l >= 2 && String.sub phrase (l - 2) 2 = ";;" then phrase
471 else phrase ^ ";;"
472 in
473 let o, () =
474 Environment.with_env env (fun () ->
475 S.capture
476 (fun () ->
477 let lb = Lexing.from_function (refill_lexbuf phrase (ref 0) (Some pp_code)) in
478 (try
479 while true do
480 try
481 let phr = !Toploop.parse_toplevel_phrase lb in
482 let phr = JsooTopPpx.preprocess_phrase phr in
483 ignore (Toploop.execute_phrase true pp_result phr : bool);
484 (* Get location from phrase AST *)
485 let loc = match phr with
486 | Parsetree.Ptop_def ({ pstr_loc; _ } :: _) ->
487 pstr_loc.loc_end.pos_cnum
488 | Parsetree.Ptop_dir { pdir_loc; _ } ->
489 pdir_loc.loc_end.pos_cnum
490 | _ -> lb.lex_curr_p.pos_cnum
491 in
492 (* Flush and get current output *)
493 Format.pp_print_flush pp_result ();
494 let caml_ppf = buff_opt res_buff in
495 let mime_vals = Mime_printer.get () in
496 (* Call callback with phrase output *)
497 on_phrase_output { loc; caml_ppf; mime_vals };
498 (* Clear for next phrase *)
499 Buffer.clear res_buff
500 with
501 | End_of_file -> raise End_of_file
502 | x ->
503 (match loc x with Some l -> set_highlight l | None -> ());
504 Errors.report_error Format.err_formatter x
505 done
506 with End_of_file -> ());
507 flush_all ())
508 ())
509 in
510 (* Get any remaining mime_vals (shouldn't be any after last callback) *)
511 let mime_vals = Mime_printer.get () in
512 Format.pp_print_flush pp_code ();
513 Format.pp_print_flush pp_result ();
514 Toplevel_api_gen.
515 {
516 stdout = string_opt o.stdout;
517 stderr = string_opt o.stderr;
518 sharp_ppf = buff_opt code_buff;
519 caml_ppf = buff_opt res_buff;
520 highlight = !highlighted;
521 mime_vals;
522 }
523
524 (** {3 Dynamic CMI Loading}
525
526 Handles loading .cmi files on demand for packages that weren't
527 compiled into the worker. *)
528
529 let filename_of_module unit_name =
530 Printf.sprintf "%s.cmi" (String.uncapitalize_ascii unit_name)
531
532 let get_dirs () =
533 let { Load_path.visible; hidden } = Load_path.get_paths () in
534 visible @ hidden
535
536 let reset_dirs () =
537 Ocaml_utils.Directory_content_cache.clear ();
538 let open Ocaml_utils.Load_path in
539 let dirs = get_dirs () in
540 reset ();
541 List.iter (fun p -> prepend_dir (Dir.create ~hidden:false p)) dirs
542
543 let reset_dirs_comp () =
544 let open Load_path in
545 let dirs = get_dirs () in
546 reset ();
547 List.iter (fun p -> prepend_dir (Dir.create ~hidden:false p)) dirs
548
549 let add_dynamic_cmis dcs =
550 let fetch filename =
551 let url = Filename.concat dcs.Toplevel_api_gen.dcs_url filename in
552 S.async_get url
553 in
554 let fetch_sync filename =
555 let url = Filename.concat dcs.Toplevel_api_gen.dcs_url filename in
556 S.sync_get url
557 in
558 let path =
559 match !path with Some p -> p | None -> failwith "Path not set"
560 in
561 let ( let* ) = Lwt.bind in
562 let* () =
563 Logs.info (fun m -> m "Adding toplevel modules for dynamic cmis from %s" dcs.dcs_url);
564 Logs.info (fun m -> m " toplevel modules: %s"
565 (String.concat ", " dcs.dcs_toplevel_modules));
566 Lwt_list.iter_p
567 (fun name ->
568 let filename = filename_of_module name in
569 let* r = fetch (filename_of_module name) in
570 let () =
571 match r with
572 | Ok content -> (
573 let name = Filename.(concat path filename) in
574 try S.create_file ~name ~content with _ -> ())
575 | Error _ -> ()
576 in
577 Lwt.return ())
578 dcs.dcs_toplevel_modules
579 in
580
581#if defined OXCAML
582 let new_load :
583 'a 'b.
584 s:string ->
585 to_string:('a -> string) ->
586 old_loader:(allow_hidden:bool -> unit_name:'a -> 'b option) ->
587 allow_hidden:bool ->
588 unit_name:'a ->
589 'b option =
590 fun ~s ~to_string ~old_loader ~allow_hidden ~unit_name ->
591 let filename = filename_of_module (to_string unit_name) in
592#else
593 let new_load ~s ~old_loader ~allow_hidden ~unit_name =
594 let filename = filename_of_module unit_name in
595#endif
596
597 let fs_name = Filename.(concat path filename) in
598 (* Check if it's already been downloaded. This will be the
599 case for all toplevel cmis. Also check whether we're supposed
600 to handle this cmi *)
601 (* if Sys.file_exists fs_name
602 then Logs.info (fun m -> m "Found: %s" fs_name)
603 else Logs.info (fun m -> m "No sign of %s locally" fs_name); *)
604 if
605 (not (Sys.file_exists fs_name))
606 && List.exists
607 (fun prefix -> String.starts_with ~prefix filename)
608 dcs.dcs_file_prefixes
609 then (
610 Logs.info (fun m -> m "Fetching %s\n%!" filename);
611 match fetch_sync filename with
612 | Some x ->
613 (try S.create_file ~name:fs_name ~content:x with _ -> ());
614 (* At this point we need to tell merlin that the dir contents
615 have changed *)
616 if s = "merl" then reset_dirs () else reset_dirs_comp ()
617 | None ->
618 Printf.eprintf "Warning: Expected to find cmi at: %s\n%!"
619 (Filename.concat dcs.Toplevel_api_gen.dcs_url filename));
620 if s = "merl" then reset_dirs () else reset_dirs_comp ();
621 old_loader ~allow_hidden ~unit_name
622 in
623 let furl = "file://" in
624 let l = String.length furl in
625 let () =
626 if String.length dcs.dcs_url > l && String.sub dcs.dcs_url 0 l = furl then
627 let path = String.sub dcs.dcs_url l (String.length dcs.dcs_url - l) in
628 Topdirs.dir_directory path
629 else
630 let open Persistent_env.Persistent_signature in
631 let old_loader = !load in
632#if defined OXCAML
633 load := new_load ~s:"comp" ~to_string:Compilation_unit.Name.to_string ~old_loader;
634#else
635 load := new_load ~s:"comp" ~old_loader;
636#endif
637
638#if defined OXCAML
639 let open Persistent_env.Persistent_signature in
640 let old_loader = !load in
641 load := new_load ~s:"merl" ~to_string:Compilation_unit.Name.to_string ~old_loader
642#else
643 let open Ocaml_typing.Persistent_env.Persistent_signature in
644 let old_loader = !load in
645 load := new_load ~s:"merl" ~old_loader
646#endif
647 in
648 Lwt.return ()
649
650 (** {3 RPC Handlers}
651
652 Functions that implement the toplevel RPC API. Each function returns
653 results in the [IdlM.ErrM] monad. *)
654
655 let init (init_libs : Toplevel_api_gen.init_config) =
656 Lwt.catch
657 (fun () ->
658 Logs.info (fun m -> m "init()");
659 path := Some S.path;
660
661 let findlib_path = Option.value ~default:"findlib_index.json" init_libs.findlib_index in
662 findlib_v := Some (S.findlib_init findlib_path);
663
664 let stdlib_dcs =
665 match init_libs.stdlib_dcs with
666 | Some dcs -> dcs
667 | None -> "lib/ocaml/dynamic_cmis.json"
668 in
669 let* () =
670 match S.get_stdlib_dcs stdlib_dcs with
671 | [ dcs ] -> add_dynamic_cmis dcs
672 | _ -> Lwt.return ()
673 in
674#if defined OXCAML
675 Language_extension.(set_universe_and_enable_all Universe.Beta);
676#endif
677 Clflags.no_check_prims := true;
678
679 requires := init_libs.findlib_requires;
680 functions := Some [];
681 execution_allowed := init_libs.execute;
682
683 (* Set up the toplevel environment *)
684 Logs.info (fun m -> m "init() finished");
685
686 Lwt.return (Ok ()))
687 (fun e ->
688 Lwt.return
689 (Error (Toplevel_api_gen.InternalError (Printexc.to_string e))))
690
691 let setup env_id =
692 Lwt.catch
693 (fun () ->
694 let env = resolve_env env_id in
695 Logs.info (fun m -> m "setup() for env %s..." (Environment.id env));
696
697 if Environment.is_setup env then (
698 Logs.info (fun m -> m "setup() already done for env %s" (Environment.id env));
699 Lwt.return
700 (Ok
701 Toplevel_api_gen.
702 {
703 stdout = None;
704 stderr = Some "Environment already set up";
705 sharp_ppf = None;
706 caml_ppf = None;
707 highlight = None;
708 mime_vals = [];
709 }))
710 else
711 let o =
712 Environment.with_env env (fun () ->
713 try
714 match !functions with
715 | Some l -> setup l ()
716 | None -> failwith "Error: toplevel has not been initialised"
717 with
718 | Persistent_env.Error e ->
719 Persistent_env.report_error Format.err_formatter e;
720 let err = Format.asprintf "%a" Persistent_env.report_error e in
721 failwith ("Error: " ^ err)
722#if defined OXCAML
723 | Env.Error e ->
724 Env.report_error ~level:0 Format.err_formatter e;
725 let err = Format.asprintf "%a" (Env.report_error ~level:0) e in
726 failwith ("Error: " ^ err))
727#else
728 | Env.Error _ as exn ->
729 Location.report_exception Format.err_formatter exn;
730 let err = Format.asprintf "%a" Location.report_exception exn in
731 failwith ("Error: " ^ err))
732#endif
733 in
734
735 let* dcs =
736 match !findlib_v with
737 | Some v ->
738 let* v = v in
739 (* Store the resolved findlib value for use by #require directive *)
740 findlib_resolved := Some v;
741 (* Register our custom #require directive that uses findlibish *)
742 register_require_directive ();
743 Lwt.return (S.require (not !execution_allowed) v !requires)
744 | None -> Lwt.return []
745 in
746
747 let* () = Lwt_list.iter_p add_dynamic_cmis dcs in
748
749 Environment.mark_setup env;
750 Logs.info (fun m -> m "setup() finished for env %s" (Environment.id env));
751
752 Lwt.return
753 (Ok
754 Toplevel_api_gen.
755 {
756 stdout = string_opt o.stdout;
757 stderr = string_opt o.stderr;
758 sharp_ppf = None;
759 caml_ppf = None;
760 highlight = None;
761 mime_vals = [];
762 }))
763 (fun e ->
764 Lwt.return
765 (Error (Toplevel_api_gen.InternalError (Printexc.to_string e))))
766
767 let handle_toplevel env stripped =
768 if String.length stripped < 2 || stripped.[0] <> '#' || stripped.[1] <> ' '
769 then (
770 Printf.eprintf
771 "Warning, ignoring toplevel block without a leading '# '.\n";
772 IdlM.ErrM.return
773 { Toplevel_api_gen.script = stripped; mime_vals = []; parts = [] })
774 else
775 let s = String.sub stripped 2 (String.length stripped - 2) in
776 let list = Ocamltop.parse_toplevel s in
777 let buf = Buffer.create 1024 in
778 let mime_vals =
779 List.fold_left
780 (fun acc (phr, _junk, _output) ->
781 let new_output = execute_in_env env phr in
782 Printf.bprintf buf "# %s\n" phr;
783 let r =
784 Option.to_list new_output.stdout
785 @ Option.to_list new_output.stderr
786 @ Option.to_list new_output.caml_ppf
787 in
788 let r =
789 List.concat_map (fun l -> Astring.String.cuts ~sep:"\n" l) r
790 in
791 List.iter (fun x -> Printf.bprintf buf " %s\n" x) r;
792 let mime_vals = new_output.mime_vals in
793 acc @ mime_vals)
794 [] list
795 in
796 let content_txt = Buffer.contents buf in
797 let content_txt =
798 String.sub content_txt 0 (String.length content_txt - 1)
799 in
800 let result =
801 { Toplevel_api_gen.script = content_txt; mime_vals; parts = [] }
802 in
803 IdlM.ErrM.return result
804
805 let exec_toplevel env_id (phrase : string) =
806 let env = resolve_env env_id in
807 try handle_toplevel env phrase
808 with e ->
809 Logs.info (fun m -> m "Error: %s" (Printexc.to_string e));
810 IdlM.ErrM.return_err
811 (Toplevel_api_gen.InternalError (Printexc.to_string e))
812
813 let execute env_id (phrase : string) =
814 Logs.info (fun m -> m "execute() for env_id=%s" env_id);
815 let env = resolve_env env_id in
816 let result = execute_in_env env phrase in
817 Logs.info (fun m -> m "execute() done for env_id=%s" env_id);
818 IdlM.ErrM.return result
819
820 let execute_incremental env_id (phrase : string) ~on_phrase_output =
821 Logs.info (fun m -> m "execute_incremental() for env_id=%s" env_id);
822 let env = resolve_env env_id in
823 let result = execute_in_env_incremental env phrase ~on_phrase_output in
824 Logs.info (fun m -> m "execute_incremental() done for env_id=%s" env_id);
825 IdlM.ErrM.return result
826
827 (** {3 Merlin Integration}
828
829 Code intelligence features powered by Merlin: completion, type info,
830 error diagnostics. *)
831
832 let config () =
833 let path =
834 match !path with Some p -> p | None -> failwith "Path not set"
835 in
836 let initial = Merlin_kernel.Mconfig.initial in
837 { initial with merlin = { initial.merlin with stdlib = Some path } }
838
839 let make_pipeline source = Merlin_kernel.Mpipeline.make (config ()) source
840
841 let wdispatch source query =
842 let pipeline = make_pipeline source in
843 Merlin_kernel.Mpipeline.with_pipeline pipeline @@ fun () ->
844 Query_commands.dispatch pipeline query
845
846 (** Completion prefix extraction, adapted from ocaml-lsp-server. *)
847 module Completion = struct
848 open Merlin_utils
849 open Std
850 open Merlin_kernel
851
852 (* Prefixing code from ocaml-lsp-server *)
853 let rfindi =
854 let rec loop s ~f i =
855 if i < 0 then None
856 else if f (String.unsafe_get s i) then Some i
857 else loop s ~f (i - 1)
858 in
859 fun ?from s ~f ->
860 let from =
861 let len = String.length s in
862 match from with
863 | None -> len - 1
864 | Some i ->
865 if i > len - 1 then
866 raise @@ Invalid_argument "rfindi: invalid from"
867 else i
868 in
869 loop s ~f from
870
871 let lsplit2 s ~on =
872 match String.index_opt s on with
873 | None -> None
874 | Some i ->
875 let open StdLabels.String in
876 Some (sub s ~pos:0 ~len:i, sub s ~pos:(i + 1) ~len:(length s - i - 1))
877
878 (** @see <https://ocaml.org/manual/lex.html> reference *)
879 let prefix_of_position ?(short_path = false) source position =
880 match Msource.text source with
881 | "" -> ""
882 | text ->
883 let from =
884 let (`Offset index) = Msource.get_offset source position in
885 min (String.length text - 1) (index - 1)
886 in
887 let pos =
888 let should_terminate = ref false in
889 let has_seen_dot = ref false in
890 let is_prefix_char c =
891 if !should_terminate then false
892 else
893 match c with
894 | 'a' .. 'z'
895 | 'A' .. 'Z'
896 | '0' .. '9'
897 | '\'' | '_'
898 (* Infix function characters *)
899 | '$' | '&' | '*' | '+' | '-' | '/' | '=' | '>' | '@' | '^'
900 | '!' | '?' | '%' | '<' | ':' | '~' | '#' ->
901 true
902 | '`' ->
903 if !has_seen_dot then false
904 else (
905 should_terminate := true;
906 true)
907 | '.' ->
908 has_seen_dot := true;
909 not short_path
910 | _ -> false
911 in
912 rfindi text ~from ~f:(fun c -> not (is_prefix_char c))
913 in
914 let pos = match pos with None -> 0 | Some pos -> pos + 1 in
915 let len = from - pos + 1 in
916 let reconstructed_prefix = StdLabels.String.sub text ~pos ~len in
917 (* if we reconstructed [~f:ignore] or [?f:ignore], we should take only
918 [ignore], so: *)
919 if
920 String.is_prefixed ~by:"~" reconstructed_prefix
921 || String.is_prefixed ~by:"?" reconstructed_prefix
922 then
923 match lsplit2 reconstructed_prefix ~on:':' with
924 | Some (_, s) -> s
925 | None -> reconstructed_prefix
926 else reconstructed_prefix
927
928 let at_pos source position =
929 let prefix = prefix_of_position source position in
930 let (`Offset to_) = Msource.get_offset source position in
931 let from =
932 to_
933 - String.length (prefix_of_position ~short_path:true source position)
934 in
935 if prefix = "" then None
936 else
937 let query =
938 Query_protocol.Complete_prefix (prefix, position, [], true, true)
939 in
940 Some (from, to_, wdispatch source query)
941 end
942
943 let complete_prefix env_id id deps is_toplevel source position =
944 let _env = resolve_env env_id in (* Reserved for future use *)
945 try
946 Logs.info (fun m -> m "completing for id: %s" (match id with Some x -> x | None -> "(none)"));
947
948 let line1, src = mangle_toplevel is_toplevel source deps in
949 Logs.info (fun m -> m "line1: '%s' (length: %d)" line1 (String.length line1));
950 Logs.info (fun m -> m "src: '%s' (length: %d)" src (String.length src));
951 let src = line1 ^ src in
952 let source = Merlin_kernel.Msource.make src in
953 let map_kind :
954 [ `Value
955 | `Constructor
956 | `Variant
957 | `Label
958 | `Module
959 | `Modtype
960 | `Type
961 | `MethodCall
962 | `Keyword ] ->
963 Toplevel_api_gen.kind_ty = function
964 | `Value -> Value
965 | `Constructor -> Constructor
966 | `Variant -> Variant
967 | `Label -> Label
968 | `Module -> Module
969 | `Modtype -> Modtype
970 | `Type -> Type
971 | `MethodCall -> MethodCall
972 | `Keyword -> Keyword
973 in
974 let position =
975 match position with
976 | Toplevel_api_gen.Start -> `Offset (String.length line1)
977 | Offset x -> `Offset (x + String.length line1)
978 | Logical (x, y) -> `Logical (x + 1, y)
979 | End -> `End
980 in
981
982 (match position with
983 | `Offset x ->
984 let first_char = String.sub src (x-1) 1 in
985 Logs.info (fun m -> m "complete after offset: %s" first_char)
986 | _ -> ());
987
988 match Completion.at_pos source position with
989 | Some (from, to_, compl) ->
990 let entries =
991 List.map
992 (fun (entry : Query_protocol.Compl.entry) ->
993 {
994 Toplevel_api_gen.name = entry.name;
995 kind = map_kind entry.kind;
996 desc = entry.desc;
997 info = entry.info;
998 deprecated = entry.deprecated;
999 })
1000 compl.entries
1001 in
1002 let l1l = String.length line1 in
1003 IdlM.ErrM.return { Toplevel_api_gen.from = from - l1l; to_ = to_ - l1l; entries }
1004 | None ->
1005 IdlM.ErrM.return { Toplevel_api_gen.from = 0; to_ = 0; entries = [] }
1006 with e ->
1007 Logs.info (fun m -> m "Error: %s" (Printexc.to_string e));
1008 IdlM.ErrM.return_err
1009 (Toplevel_api_gen.InternalError (Printexc.to_string e))
1010
1011 let add_cmi execution_env id deps source =
1012 Logs.info (fun m -> m "add_cmi");
1013 let dep_modules = List.map modname_of_id deps in
1014 let loc = Location.none in
1015 let path =
1016 match !path with Some p -> p | None -> failwith "Path not set"
1017 in
1018 let filename = modname_of_id id |> String.uncapitalize_ascii in
1019 let prefix = Printf.sprintf "%s/%s" path filename in
1020 let filename = Printf.sprintf "%s.ml" prefix in
1021 Logs.info (fun m -> m "prefix: %s" prefix);
1022 let oc = open_out filename in
1023 Printf.fprintf oc "%s" source;
1024 close_out oc;
1025 (try Sys.remove (prefix ^ ".cmi") with Sys_error _ -> ());
1026#if defined OXCAML
1027 let unit_info = Unit_info.make ~source_file:filename Impl prefix
1028 ~for_pack_prefix:Compilation_unit.Prefix.empty in
1029#else
1030 let unit_info = Unit_info.make ~source_file:filename Impl prefix in
1031#endif
1032 try
1033 let store = Local_store.fresh () in
1034 Local_store.with_store store (fun () ->
1035 Local_store.reset ();
1036 let env =
1037 Typemod.initial_env ~loc ~initially_opened_module:(Some "Stdlib")
1038 ~open_implicit_modules:dep_modules
1039 in
1040 let lexbuf = Lexing.from_string source in
1041 let ast = Parse.implementation lexbuf in
1042 Logs.info (fun m -> m "About to type_implementation");
1043#if defined OXCAML
1044 let _ = Typemod.type_implementation unit_info
1045 (Compilation_unit.of_string (modname_of_id id)) env ast in
1046#else
1047 let _ = Typemod.type_implementation unit_info env ast in
1048#endif
1049 let b = Sys.file_exists (prefix ^ ".cmi") in
1050 Environment.remove_failed_cell execution_env id;
1051 Logs.info (fun m -> m "file_exists: %s = %b" (prefix ^ ".cmi") b));
1052 Ocaml_typing.Cmi_cache.clear ()
1053 with
1054#if defined OXCAML
1055 | Env.Error e ->
1056 Logs.err (fun m -> m "Env.Error: %a" (Env.report_error ~level:0) e);
1057 Environment.add_failed_cell execution_env id;
1058 ()
1059#else
1060 | Env.Error _ as exn ->
1061 Logs.err (fun m -> m "Env.Error: %a" Location.report_exception exn);
1062 Environment.add_failed_cell execution_env id;
1063 ()
1064#endif
1065 | exn ->
1066 let s = Printexc.to_string exn in
1067 Logs.err (fun m -> m "Error in add_cmi: %s" s);
1068 Logs.err (fun m -> m "Backtrace: %s" (Printexc.get_backtrace ()));
1069 let ppf = Format.err_formatter in
1070 let _ = Location.report_exception ppf exn in
1071 Environment.add_failed_cell execution_env id;
1072 ()
1073
1074 let map_pos line1 pos =
1075 (* Only subtract line number when there's actually a prepended line *)
1076 let line_offset = if line1 = "" then 0 else 1 in
1077 Lexing.
1078 {
1079 pos with
1080 pos_bol = pos.pos_bol - String.length line1;
1081 pos_lnum = pos.pos_lnum - line_offset;
1082 pos_cnum = pos.pos_cnum - String.length line1;
1083 }
1084
1085 let map_loc line1 (loc : Ocaml_parsing.Location.t) =
1086 {
1087 loc with
1088 Ocaml_utils.Warnings.loc_start = map_pos line1 loc.loc_start;
1089 Ocaml_utils.Warnings.loc_end = map_pos line1 loc.loc_end;
1090 }
1091
1092 let query_errors env_id id deps is_toplevel orig_source =
1093 let execution_env = resolve_env env_id in
1094 try
1095 let deps =
1096 List.filter (fun dep -> not (Environment.is_cell_failed execution_env dep)) deps
1097 in
1098 let line1, src = mangle_toplevel is_toplevel orig_source deps in
1099 let full_source = line1 ^ src in
1100 let source = Merlin_kernel.Msource.make full_source in
1101 let query =
1102 Query_protocol.Errors { lexing = true; parsing = true; typing = true }
1103 in
1104 let errors =
1105 wdispatch source query
1106 |> StdLabels.List.filter_map
1107 ~f:(fun
1108 (Ocaml_parsing.Location.{ kind; main = _; sub; source; _ } as
1109 error)
1110 ->
1111 let of_sub sub =
1112 Ocaml_parsing.Location.print_sub_msg Format.str_formatter sub;
1113 String.trim (Format.flush_str_formatter ())
1114 in
1115 let loc =
1116 map_loc line1 (Ocaml_parsing.Location.loc_of_report error)
1117 in
1118 let main =
1119 Format.asprintf "@[%a@]" Ocaml_parsing.Location.print_main
1120 error
1121 |> String.trim
1122 in
1123 if loc.loc_start.pos_lnum = 0 then None
1124 else
1125 Some
1126 {
1127 Toplevel_api_gen.kind;
1128 loc;
1129 main;
1130 sub = StdLabels.List.map ~f:of_sub sub;
1131 source;
1132 })
1133 in
1134 (* Only track cell CMIs when id is provided (notebook mode) *)
1135 (match id with
1136 | Some cell_id ->
1137 if List.length errors = 0 then add_cmi execution_env cell_id deps src
1138 else Environment.add_failed_cell execution_env cell_id
1139 | None -> ());
1140
1141 (* Logs.info (fun m -> m "Got to end"); *)
1142 IdlM.ErrM.return errors
1143 with e ->
1144 Logs.info (fun m -> m "Error: %s" (Printexc.to_string e));
1145 IdlM.ErrM.return_err
1146 (Toplevel_api_gen.InternalError (Printexc.to_string e))
1147
1148 let type_enclosing env_id _id deps is_toplevel orig_source position =
1149 let execution_env = resolve_env env_id in
1150 try
1151 let deps =
1152 List.filter (fun dep -> not (Environment.is_cell_failed execution_env dep)) deps
1153 in
1154 let line1, src = mangle_toplevel is_toplevel orig_source deps in
1155 let src = line1 ^ src in
1156 let position =
1157 match position with
1158 | Toplevel_api_gen.Start -> `Start
1159 | Offset x -> `Offset (x + String.length line1)
1160 | Logical (x, y) -> `Logical (x + 1, y)
1161 | End -> `End
1162 in
1163 let source = Merlin_kernel.Msource.make src in
1164 let query = Query_protocol.Type_enclosing (None, position, None) in
1165 let enclosing = wdispatch source query in
1166 let map_index_or_string = function
1167 | `Index i -> Toplevel_api_gen.Index i
1168 | `String s -> String s
1169 in
1170 let map_tail_position = function
1171 | `No -> Toplevel_api_gen.No
1172 | `Tail_position -> Tail_position
1173 | `Tail_call -> Tail_call
1174 in
1175 let enclosing =
1176 List.map
1177 (fun (x, y, z) ->
1178 (map_loc line1 x, map_index_or_string y, map_tail_position z))
1179 enclosing
1180 in
1181 IdlM.ErrM.return enclosing
1182 with e ->
1183 Logs.info (fun m -> m "Error: %s" (Printexc.to_string e));
1184 IdlM.ErrM.return_err
1185 (Toplevel_api_gen.InternalError (Printexc.to_string e))
1186
1187 (** {3 Environment Management RPCs} *)
1188
1189 let create_env env_id =
1190 Lwt.catch
1191 (fun () ->
1192 Logs.info (fun m -> m "create_env(%s)" env_id);
1193 let _env = Environment.create env_id in
1194 Lwt.return (Ok ()))
1195 (fun e ->
1196 Lwt.return
1197 (Error (Toplevel_api_gen.InternalError (Printexc.to_string e))))
1198
1199 let destroy_env env_id =
1200 Lwt.catch
1201 (fun () ->
1202 Logs.info (fun m -> m "destroy_env(%s)" env_id);
1203 Environment.destroy env_id;
1204 Lwt.return (Ok ()))
1205 (fun e ->
1206 Lwt.return
1207 (Error (Toplevel_api_gen.InternalError (Printexc.to_string e))))
1208
1209 let list_envs () =
1210 Lwt.catch
1211 (fun () ->
1212 let envs = Environment.list () in
1213 Logs.info (fun m -> m "list_envs() -> [%s]" (String.concat ", " envs));
1214 Lwt.return (Ok envs))
1215 (fun e ->
1216 Lwt.return
1217 (Error (Toplevel_api_gen.InternalError (Printexc.to_string e))))
1218end