jon.recoil.org
this repo has no description
1open Js_of_ocaml_toplevel
2open X_protocol
3
4module Value_env : sig
5 type t
6
7 val empty : t
8 val capture : t -> Ident.t list -> t
9 val restore : t -> unit
10end = struct
11 module String_map = Map.Make (String)
12
13 type t = Obj.t String_map.t
14
15 let empty = String_map.empty
16
17 let capture t idents =
18 List.fold_left
19 (fun t ident ->
20 let name = Translmod.toplevel_name ident in
21#if defined OXCAML
22 let v = Toploop.getvalue name in
23#else
24 let v = Topeval.getvalue name in
25#endif
26 String_map.add name v t)
27 t idents
28
29 let restore t = String_map.iter (fun name v ->
30#if defined OXCAML
31 Toploop.setvalue name v
32#else
33 Topeval.setvalue name v
34#endif
35 ) t
36end
37
38module Environment = struct
39 let environments = ref []
40 let init () = environments := [ (0, !Toploop.toplevel_env, Value_env.empty) ]
41
42 let reset id =
43 let rec go id = function
44 | [] -> failwith ("no environment " ^ string_of_int id)
45 | (id', _, _) :: xs when id' >= id && xs <> [] -> go id xs
46 | ((_, typing_env, value_env) as x) :: xs ->
47 Toploop.toplevel_env := typing_env;
48 Value_env.restore value_env;
49 x :: xs
50 in
51 environments := go id !environments
52
53 let capture id =
54 let values =
55 match !environments with
56 | [] -> invalid_arg "empty environment"
57 | (_, previous_env, previous_values) :: _ ->
58 let idents = Env.diff previous_env !Toploop.toplevel_env in
59 Value_env.capture previous_values idents
60 in
61 environments := (id, !Toploop.toplevel_env, values) :: !environments
62end
63
64let setup_toplevel () =
65 let _ = JsooTop.initialize () in
66 Sys.interactive := false;
67 Environment.init ()
68
69let rec parse_use_file ~caml_ppf lex =
70 let _at = lex.Lexing.lex_curr_pos in
71 match !Toploop.parse_toplevel_phrase lex with
72 | ok -> Ok ok :: parse_use_file ~caml_ppf lex
73 | exception End_of_file -> []
74 | exception err -> [ Error err ]
75
76let ppx_rewriters = ref []
77
78let preprocess_structure str =
79 let open Ast_mapper in
80 List.fold_right
81 (fun ppx_rewriter str ->
82 let mapper = ppx_rewriter [] in
83 mapper.structure mapper str)
84 !ppx_rewriters str
85
86let preprocess_phrase phrase =
87 let open Parsetree in
88 match phrase with
89 | Ptop_def str -> Ptop_def (preprocess_structure str)
90 | Ptop_dir _ as x -> x
91
92let execute ~id ~line_number ~output code_text =
93 Environment.reset id;
94 let outputs = ref [] in
95 let buf = Buffer.create 64 in
96 let caml_ppf = Format.formatter_of_buffer buf in
97 let content = code_text ^ " ;;" in
98 let lexer = Lexing.from_string content in
99 Lexing.set_position lexer
100 { pos_fname = ""; pos_lnum = line_number; pos_bol = 0; pos_cnum = 0 };
101 let phrases = parse_use_file ~caml_ppf lexer in
102 Js_of_ocaml.Sys_js.set_channel_flusher stdout (fun str ->
103 outputs := Stdout str :: !outputs);
104 Js_of_ocaml.Sys_js.set_channel_flusher stderr (fun str ->
105 outputs := Stderr str :: !outputs);
106 let get_out () =
107 Format.pp_print_flush caml_ppf ();
108 let meta = Buffer.contents buf in
109 Buffer.clear buf;
110 let out = if meta = "" then !outputs else Meta meta :: !outputs in
111 outputs := [];
112 List.rev out
113 in
114 let respond ~(at_loc : Location.t) =
115 let loc = at_loc.loc_end.pos_cnum in
116 let out = get_out () in
117 output ~loc out
118 in
119 List.iter
120 (function
121 | Error err -> Errors.report_error caml_ppf err
122 | Ok phrase ->
123 let sub_phrases =
124 match phrase with
125 | Parsetree.Ptop_def s ->
126 List.map (fun s -> Parsetree.Ptop_def [ s ]) s
127 | Ptop_dir _ -> [ phrase ]
128 in
129 List.iter
130 (fun phrase ->
131 let at_loc =
132 match phrase with
133 | Parsetree.Ptop_def ({ pstr_loc = loc; _ } :: _) -> loc
134 | Ptop_dir { pdir_loc = loc; _ } -> loc
135 | _ -> assert false
136 in
137 X_ocaml_lib.id := (id, at_loc.loc_end.pos_cnum);
138 try
139 Location.reset ();
140 let phrase = preprocess_phrase phrase in
141 let _r = Toploop.execute_phrase true caml_ppf phrase in
142 respond ~at_loc
143 with _exn ->
144 Errors.report_error caml_ppf _exn;
145 respond ~at_loc)
146 sub_phrases)
147 phrases;
148 Environment.capture id;
149 get_out ()
150
151let () =
152 Ast_mapper.register_function :=
153 fun _ f -> ppx_rewriters := f :: !ppx_rewriters