jon.recoil.org
this repo has no description
1open Merlin_utils
2open Std
3open Merlin_kernel
4module Location = Ocaml_parsing.Location
5
6let stdlib_path = "/static/cmis"
7
8let sync_get url =
9 let open Js_of_ocaml in
10 let x = XmlHttpRequest.create () in
11 x##.responseType := Js.string "arraybuffer";
12 x##_open (Js.string "GET") (Js.string url) Js._false;
13 x##send Js.null;
14 match x##.status with
15 | 200 ->
16 Js.Opt.case
17 (File.CoerceTo.arrayBuffer x##.response)
18 (fun () ->
19 Js_of_ocaml.Console.console##log (Js.string "Failed to receive file");
20 None)
21 (fun b -> Some (Typed_array.String.of_arrayBuffer b))
22 | _ -> None
23
24let filename_of_module unit_name =
25 Printf.sprintf "%s.cmi" (String.uncapitalize_ascii unit_name)
26
27let reset_dirs () =
28 Ocaml_utils.Directory_content_cache.clear ();
29 let open Ocaml_utils.Load_path in
30 let { visible; hidden } = get_paths () in
31 reset ();
32 init ~auto_include:no_auto_include ~visible ~hidden
33
34let add_dynamic_cmis dcs =
35 let open Ocaml_typing.Persistent_env.Persistent_signature in
36 let old_loader = !load in
37
38 let fetch =
39 (fun filename ->
40 let url = Filename.concat dcs.Protocol.dcs_url filename in
41 sync_get url)
42 in
43
44 List.iter ~f:(fun name ->
45 let filename = filename_of_module name in
46 match fetch (filename_of_module name) with
47 | Some content ->
48 let name = Filename.(concat stdlib_path filename) in
49 Js_of_ocaml.Sys_js.create_file ~name ~content
50 | None -> ()) dcs.dcs_toplevel_modules;
51
52 let new_load ~allow_hidden ~unit_name =
53#if defined OXCAML
54 let unit_name_str = Ocaml_typing.Compilation_unit.Name.to_string unit_name in
55#else
56 let unit_name_str = unit_name in
57#endif
58 let filename = filename_of_module unit_name_str in
59 let fs_name = Filename.(concat stdlib_path filename) in
60 (* Check if it's already been downloaded. This will be the
61 case for all toplevel cmis. Also check whether we're supposed
62 to handle this cmi *)
63 if
64 not (Sys.file_exists fs_name) &&
65 List.exists ~f:(fun prefix ->
66 String.starts_with ~prefix filename) dcs.dcs_file_prefixes
67 then begin
68 match fetch filename with
69 | Some x ->
70 Js_of_ocaml.Sys_js.create_file ~name:fs_name ~content:x;
71 (* At this point we need to tell merlin that the dir contents
72 have changed *)
73 reset_dirs ()
74 | None ->
75 Printf.eprintf "Warning: Expected to find cmi at: %s\n%!"
76 (Filename.concat dcs.Protocol.dcs_url filename)
77 end;
78 old_loader ~allow_hidden ~unit_name
79 in
80 load := new_load
81
82 let add_cmis { Protocol.static_cmis; dynamic_cmis } =
83 List.iter static_cmis ~f:(fun { Protocol.sc_name; sc_content } ->
84 let filename = Printf.sprintf "%s.cmi" (String.uncapitalize_ascii sc_name) in
85 let name = Filename.(concat stdlib_path filename) in
86 Js_of_ocaml.Sys_js.create_file ~name ~content:sc_content);
87 Option.iter ~f:add_dynamic_cmis dynamic_cmis;
88 Protocol.Added_cmis
89
90let config ?filename () =
91 let initial = Mconfig.initial in
92 let query = match filename with
93 | Some f -> { initial.query with filename = f }
94 | None -> initial.query
95 in
96 { initial with
97 merlin = { initial.merlin with stdlib = Some stdlib_path };
98 query }
99
100let make_pipeline ?filename source =
101 Mpipeline.make (config ?filename ()) source
102
103let dispatch ?filename source query =
104 let pipeline = make_pipeline ?filename source in
105 Mpipeline.with_pipeline pipeline @@ fun () -> (
106 Query_commands.dispatch pipeline query
107 )
108
109module Completion = struct
110 (* Prefixing code from ocaml-lsp-server *)
111 let rfindi =
112 let rec loop s ~f i =
113 if i < 0 then
114 None
115 else if f (String.unsafe_get s i) then
116 Some i
117 else
118 loop s ~f (i - 1)
119 in
120 fun ?from s ~f ->
121 let from =
122 let len = String.length s in
123 match from with
124 | None -> len - 1
125 | Some i ->
126 if i > len - 1 then
127 raise @@ Invalid_argument "rfindi: invalid from"
128 else
129 i
130 in
131 loop s ~f from
132 let lsplit2 s ~on =
133 match String.index_opt s on with
134 | None -> None
135 | Some i ->
136 let open String in
137 Some (sub s ~pos:0 ~len:i, sub s ~pos:(i + 1) ~len:(length s - i - 1))
138
139 (** @see <https://ocaml.org/manual/lex.html> reference *)
140 let prefix_of_position ?(short_path = false) source position =
141 match Msource.text source with
142 | "" -> ""
143 | text ->
144 let from =
145 let (`Offset index) = Msource.get_offset source position in
146 min (String.length text - 1) (index - 1)
147 in
148 let pos =
149 let should_terminate = ref false in
150 let has_seen_dot = ref false in
151 let is_prefix_char c =
152 if !should_terminate then
153 false
154 else
155 match c with
156 | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '\'' | '_'
157 (* Infix function characters *)
158 | '$' | '&' | '*' | '+' | '-' | '/' | '=' | '>'
159 | '@' | '^' | '!' | '?' | '%' | '<' | ':' | '~' | '#' ->
160 true
161 | '`' ->
162 if !has_seen_dot then
163 false
164 else (
165 should_terminate := true;
166 true
167 ) | '.' ->
168 has_seen_dot := true;
169 not short_path
170 | _ -> false
171 in
172 rfindi text ~from ~f:(fun c -> not (is_prefix_char c))
173 in
174 let pos =
175 match pos with
176 | None -> 0
177 | Some pos -> pos + 1
178 in
179 let len = from - pos + 1 in
180 let reconstructed_prefix = String.sub text ~pos ~len in
181 (* if we reconstructed [~f:ignore] or [?f:ignore], we should take only
182 [ignore], so: *)
183 if
184 String.is_prefixed ~by:"~" reconstructed_prefix
185 || String.is_prefixed ~by:"?" reconstructed_prefix
186 then
187 match lsplit2 reconstructed_prefix ~on:':' with
188 | Some (_, s) -> s
189 | None -> reconstructed_prefix
190 else
191 reconstructed_prefix
192
193
194 let at_pos ?filename source position =
195 let prefix = prefix_of_position source position in
196 let `Offset to_ = Msource.get_offset source position in
197 let from =
198 to_ - String.length (prefix_of_position ~short_path:true source position)
199 in
200 if prefix = "" then
201 None
202 else
203 let query = Query_protocol.Complete_prefix (prefix, position, [], true, true)
204 in
205 Some (from, to_, dispatch ?filename source query)
206end
207(*
208let dump () =
209 let query = Query_protocol.Dump [`String "paths"] in
210 dispatch (Msource.make "") query *)
211
212(* let dump_config () =
213 let pipeline = make_pipeline (Msource.make "") in
214 Mpipeline.with_pipeline pipeline @@ fun () ->
215 Mconfig.dump (Mpipeline.final_config pipeline)
216 |> Json.pretty_to_string *)
217
218let on_message = function
219 | Protocol.Complete_prefix (source, position, filename) ->
220 let source = Msource.make source in
221 begin match Completion.at_pos ?filename source position with
222 | Some (from, to_, compl) ->
223 let entries = compl.entries in
224 Protocol.Completions { from; to_; entries; }
225 | None ->
226 Protocol.Completions { from = 0; to_ = 0; entries = []; }
227 end
228 | Type_enclosing (source, position, filename) ->
229 let source = Msource.make source in
230 let query = Query_protocol.Type_enclosing (None, position, None) in
231 Protocol.Typed_enclosings (dispatch ?filename source query)
232 | Protocol.All_errors (source, filename) ->
233 let source = Msource.make source in
234 let query = Query_protocol.Errors {
235 lexing = true;
236 parsing = true;
237 typing = true;
238 }
239 in
240 let errors =
241 dispatch ?filename source query
242 |> List.map ~f:(fun (Location.{kind; sub; source; _} as error) ->
243 let of_sub sub =
244 Location.print_sub_msg Format.str_formatter sub;
245 String.trim (Format.flush_str_formatter ())
246 in
247 let loc = Location.loc_of_report error in
248 let main =
249 Format.asprintf "@[%a@]" Location.print_main error |> String.trim
250 in
251 Protocol.{
252 kind;
253 loc;
254 main;
255 sub = List.map ~f:of_sub sub;
256 source;
257 })
258 in
259 Protocol.Errors errors
260 | Add_cmis cmis ->
261 add_cmis cmis
262
263let run () =
264 Js_of_ocaml.Worker.set_onmessage @@ fun marshaled_message ->
265 let action : Protocol.action = Marshal.from_bytes marshaled_message 0 in
266 let res = on_message action in
267 let res = Marshal.to_bytes res [] in
268 Js_of_ocaml.Worker.post_message res