This example demonstrates merlin with dynamic loading of cmis. Load the
83 | 'Network' tab of the developer tools to see the requests and responses.
84 | See also the static example.
85 |
86 |
87 |
88 |
89 |
90 |
--------------------------------------------------------------------------------
/src/protocol/protocol.ml:
--------------------------------------------------------------------------------
1 | open Merlin_kernel
2 | module Location = Ocaml_parsing.Location
3 |
4 | type source = string
5 |
6 | (** CMIs are provided either statically or as URLs to be downloaded on demand *)
7 |
8 | (** Dynamic cmis are loaded from beneath the given url. In addition the
9 | top-level modules are specified, and prefixes for other modules. For
10 | example, for the OCaml standard library, a user might pass:
11 |
12 | {[
13 | { dcs_url="/static/stdlib";
14 | dcs_toplevel_modules=["Stdlib"];
15 | dcs_file_prefixes=["stdlib__"]; }
16 | ]}
17 |
18 | In which case, merlin will expect to be able to download a valid file
19 | from the url ["/static/stdlib/stdlib.cmi"] corresponding to the
20 | specified toplevel module, and it will also attempt to download any
21 | module with the prefix ["Stdlib__"] from the same base url, so for
22 | example if an attempt is made to look up the module ["Stdlib__Foo"]
23 | then merlin-js will attempt to download a file from the url
24 | ["/static/stdlib/stdlib__Foo.cmi"].
25 | *)
26 |
27 | type dynamic_cmis = {
28 | dcs_url : string;
29 | dcs_toplevel_modules : string list;
30 | dcs_file_prefixes : string list;
31 | }
32 |
33 | type static_cmi = {
34 | sc_name : string; (* capitalised, e.g. 'Stdlib' *)
35 | sc_content : string;
36 | }
37 |
38 | type cmis = {
39 | static_cmis : static_cmi list;
40 | dynamic_cmis : dynamic_cmis option;
41 | }
42 |
43 | type action =
44 | | Complete_prefix of source * Msource.position
45 | | Type_enclosing of source * Msource.position
46 | | All_errors of source
47 | | Add_cmis of cmis
48 |
49 | let action_to_string = function
50 | | Complete_prefix _ -> "Complete_prefix"
51 | | Type_enclosing _ -> "Type_enclosing"
52 | | All_errors _ -> "All_errors"
53 | | Add_cmis _ -> "Add_cmis"
54 |
55 | type error = {
56 | kind : Location.report_kind;
57 | loc: Location.t;
58 | main : string;
59 | sub : string list;
60 | source : Location.error_source;
61 | }
62 |
63 | type completions = {
64 | from: int;
65 | to_: int;
66 | entries : Query_protocol.Compl.entry list
67 | }
68 |
69 | type is_tail_position =
70 | [`No | `Tail_position | `Tail_call]
71 |
72 | (* type errors = { from: int; to_: int; entries: error list } *)
73 | type answer =
74 | | Ready
75 | | Errors of error list
76 | | Completions of completions
77 | | Typed_enclosings of
78 | (Location.t * [ `Index of int | `String of string ] * is_tail_position) list
79 | | Added_cmis
80 |
81 | let answer_to_string = function
82 | | Ready -> "Ready"
83 | | Errors _ -> "Errors"
84 | | Completions _ -> "Completions"
85 | | Typed_enclosings _ -> "Type_enclosings"
86 | | Added_cmis -> "Added_cmis"
87 |
88 | let report_source_to_string = function
89 | | Location.Lexer -> "lexer"
90 | | Location.Parser -> "parser"
91 | | Location.Typer -> "typer"
92 | | Location.Warning -> "warning" (* todo incorrect ?*)
93 | | Location.Unknown -> "unknown"
94 | | Location.Env -> "env"
95 | | Location.Config -> "config"
96 |
--------------------------------------------------------------------------------
/src/client/merlin_client.ml:
--------------------------------------------------------------------------------
1 | module type WORKER = sig
2 | type t
3 | val post : t -> Protocol.action -> unit
4 | end
5 |
6 | module Make (Worker : WORKER) = struct
7 | (* When a query is sent to the Worker we keep the Future result in an indexed
8 | table so that the on_message function will be able to determine the Future when
9 | the answer is posted by the Worker.
10 | The Worker works synchronously so we expect answer to arrive in order. *)
11 | type worker = {
12 | worker: Worker.t;
13 | queue: (Protocol.answer -> unit) Queue.t
14 | }
15 |
16 | let add_fut worker res = Queue.add res worker.queue
17 | let res_fut worker v = (Queue.take worker.queue) v
18 |
19 | let on_message worker data = res_fut worker data
20 |
21 | let make_worker worker =
22 | let queue = Queue.create () in
23 | { worker; queue }
24 |
25 | (* todo share that with worker *)
26 | type action = Completion | Type_enclosing | Errors
27 |
28 | type errors = Protocol.error list
29 |
30 | let query ~action worker (*todo: other queries*) =
31 | let fut, set = Fut.create () in
32 | add_fut worker set;
33 | Worker.post worker.worker action;
34 | fut
35 |
36 | let query_errors worker (source : string) =
37 | let open Fut.Syntax in
38 | let action = Protocol.All_errors source in
39 | let+ data : Protocol.answer = query ~action worker in
40 | match data with
41 | | Protocol.Errors errors -> errors
42 | | _ -> assert false
43 |
44 | let query_completions worker (source : string) position =
45 | let open Fut.Syntax in
46 | let action = Protocol.Complete_prefix (source, position) in
47 | let+ data : Protocol.answer = query ~action worker in
48 | match data with
49 | | Protocol.Completions compl -> compl
50 | | _ -> assert false
51 |
52 | let query_type worker (source : string) position =
53 | let open Fut.Syntax in
54 | let action = Protocol.Type_enclosing (source, position) in
55 | let+ data : Protocol.answer = query ~action worker in
56 | match data with
57 | | Protocol.Typed_enclosings l -> l
58 | | _ -> assert false
59 |
60 | let add_cmis worker cmis =
61 | let open Fut.Syntax in
62 | let action = Protocol.Add_cmis cmis in
63 | let+ data : Protocol.answer = query ~action worker in
64 | match data with
65 | | Protocol.Added_cmis -> ()
66 | | _ -> assert false
67 | end
68 |
69 | module Webworker = struct
70 | include Brr_webworkers.Worker
71 |
72 | let post t action =
73 | let bytes = Marshal.to_string action []
74 | |> Js_of_ocaml.Js.bytestring in
75 | post t bytes
76 | end
77 |
78 | include Make (Webworker)
79 |
80 | let make_worker url =
81 | let worker = make_worker @@ Webworker.create @@ Jstr.of_string url in
82 | let ready, set_ready = Fut.create () in
83 | let on_message m =
84 | let m = Brr.Ev.as_type m in
85 | let data_marshaled = Brr_io.Message.Ev.data m |> Js_of_ocaml.Js.to_bytestring in
86 | let data : Protocol.answer = Marshal.from_string data_marshaled 0 in
87 | match data with
88 | | Protocol.Ready -> set_ready ()
89 | | _ -> on_message worker data
90 | in
91 | let _listen =
92 | Brr.Ev.listen Brr_io.Message.Ev.message on_message
93 | @@ Webworker.as_target worker.worker
94 | in
95 | worker, ready
96 |
--------------------------------------------------------------------------------
/src/extension/merlin_codemirror.ml:
--------------------------------------------------------------------------------
1 | open Code_mirror
2 | open Brr
3 |
4 | module Utils = Utils
5 |
6 | let ocaml = Jv.get Jv.global "__CM__mllike" |> Stream.Language.of_jv
7 | let ocaml = Stream.Language.define ocaml
8 |
9 | module Extensions (Worker : Merlin_client.WORKER) = struct
10 |
11 | module Merlin_client = Merlin_client.Make (Worker)
12 | type worker = Merlin_client.worker
13 |
14 | let linter worker = fun view ->
15 | let open Fut.Syntax in
16 | let doc = Utils.get_full_doc @@ Editor.View.state view in
17 | let* worker = worker in
18 | let+ result = Merlin_client.query_errors worker doc in
19 | List.map (fun Protocol.{ kind; loc; main; sub = _; source } ->
20 | let from = loc.loc_start.pos_cnum in
21 | let to_ = loc.loc_end.pos_cnum in
22 | let source = Protocol.report_source_to_string source in
23 | let severity = match kind with
24 | | Report_error
25 | | Report_warning_as_error _
26 | | Report_alert_as_error _ -> Lint.Diagnostic.Error
27 | | Report_warning _ -> Lint.Diagnostic.Warning
28 | | Report_alert _ -> Lint.Diagnostic.Info
29 | in
30 | Lint.Diagnostic.create ~source ~from ~to_ ~severity ~message:main ()
31 | ) result
32 | |> Array.of_list
33 |
34 | let keywords = List.map
35 | (fun label ->
36 | Autocomplete.Completion.create ~label ~type_:"keyword" ())
37 | [
38 | "as"; "do"; "else"; "end"; "exception"; "fun"; "functor"; "if"; "in";
39 | "include"; "let"; "of"; "open"; "rec"; "struct"; "then"; "type"; "val";
40 | "while"; "with"; "and"; "assert"; "begin"; "class"; "constraint";
41 | "done"; "downto"; "external"; "function"; "initializer"; "lazy";
42 | "match"; "method"; "module"; "mutable"; "new"; "nonrec"; "object";
43 | "private"; "sig"; "to"; "try"; "value"; "virtual"; "when";
44 | ]
45 |
46 | let merlin_completion worker = fun ctx ->
47 | let open Fut.Syntax in
48 | let source = Utils.get_full_doc @@ Autocomplete.Context.state ctx in
49 | let pos = Autocomplete.Context.pos ctx in
50 | let+ { from; to_; entries } =
51 | let* worker = worker in
52 | Merlin_client.query_completions worker source (`Offset pos)
53 | in
54 | let options =
55 | let num_completions = List.length entries in
56 | List.mapi (fun i Query_protocol.Compl.{ name; desc; _ } ->
57 | let boost = num_completions - i in
58 | Autocomplete.Completion.create ~label:name ~detail:desc ~boost ()) entries
59 | in
60 | Some (Autocomplete.Result.create ~filter:true ~from ~to_ ~options ())
61 |
62 | let autocomplete worker =
63 | let override = [
64 | Autocomplete.Source.from_list keywords;
65 | Autocomplete.Source.create @@ merlin_completion worker]
66 | in
67 | let config = Autocomplete.config () ~override in
68 | Autocomplete.create ~config ()
69 |
70 | let tooltip_on_hover worker =
71 | let open Tooltip in
72 | hover_tooltip @@
73 | fun ~view ~pos ~side:_ ->
74 | let open Fut.Syntax in
75 | let doc = Utils.get_full_doc @@ Editor.View.state view in
76 | let pos = `Offset pos in
77 | let* worker = worker in
78 | let+ result = Merlin_client.query_type worker doc pos in
79 | match result with
80 | | (loc, `String type_, _)::_ ->
81 | let create _view =
82 | let dom = El.div [El.txt' type_] in
83 | Tooltip_view.create ~dom ()
84 | in
85 | let pos = loc.loc_start.pos_cnum in
86 | let end_ = loc.loc_end.pos_cnum in
87 | Some (Tooltip.create ~pos ~end_ ~above:true ~arrow:true ~create ())
88 | | _ -> None
89 |
90 | let linter worker = Lint.create (linter worker)
91 |
92 | let all_extensions worker = [|
93 | linter worker;
94 | autocomplete worker;
95 | tooltip_on_hover worker
96 | |]
97 | end
98 |
99 | module type Config = sig
100 | val worker_url : string
101 | val cmis : Protocol.cmis
102 | end
103 |
104 | module Make (Config : Config) = struct
105 | let worker =
106 | let open Fut.Syntax in
107 | let worker, ready = Merlin_client.make_worker Config.worker_url in
108 | let* () = ready in
109 | (* Initial Cmi loading should be the first request. Todo: make it clearer in
110 | the protocol that this is a mandatory initial exchange: Start worker ->
111 | worker sends Ready -> client sends Add_cmis *)
112 | let+ () = Merlin_client.add_cmis worker Config.cmis in
113 | worker
114 |
115 | open Extensions (Merlin_client.Webworker)
116 |
117 | let autocomplete = autocomplete worker
118 | let tooltip_on_hover = tooltip_on_hover worker
119 | let linter = linter worker
120 | let all_extensions = all_extensions worker
121 | end
122 |
--------------------------------------------------------------------------------
/src/worker/worker.ml:
--------------------------------------------------------------------------------
1 | open Merlin_utils
2 | open Std
3 | open Js_of_ocaml
4 | open Merlin_kernel
5 | module Location = Ocaml_parsing.Location
6 |
7 | let stdlib_path = "/static/cmis"
8 | let log s = Console.console##log (Js.string s)
9 |
10 | let sync_get url =
11 | let x = XmlHttpRequest.create () in
12 | x##.responseType := Js.string "arraybuffer";
13 | x##_open (Js.string "GET") (Js.string url) Js._false;
14 | x##send Js.null;
15 | match x##.status with
16 | | 200 ->
17 | Js.Opt.case
18 | (File.CoerceTo.arrayBuffer x##.response)
19 | (fun () ->
20 | Console.console##log (Js.string "Failed to receive file");
21 | None)
22 | (fun b -> Some (Typed_array.String.of_arrayBuffer b))
23 | | _ -> None
24 |
25 | let filename_of_module unit_name =
26 | Printf.sprintf "%s.cmi" (String.uncapitalize_ascii unit_name)
27 |
28 | let reset_dirs () =
29 | Ocaml_utils.Directory_content_cache.clear ();
30 | let open Ocaml_utils.Load_path in
31 | let { visible; hidden } = get_paths () in
32 | reset ();
33 | init ~auto_include:no_auto_include ~visible ~hidden
34 |
35 | let add_dynamic_cmis dcs =
36 | let open Ocaml_typing.Persistent_env.Persistent_signature in
37 | let old_loader = !load in
38 |
39 | let fetch =
40 | (fun filename ->
41 | let url = Filename.concat dcs.Protocol.dcs_url filename in
42 | sync_get url)
43 | in
44 |
45 | List.iter ~f:(fun name ->
46 | let filename = filename_of_module name in
47 | match fetch (filename_of_module name) with
48 | | Some content ->
49 | let name = Filename.(concat stdlib_path filename) in
50 | Sys_js.create_file ~name ~content
51 | | None -> ()) dcs.dcs_toplevel_modules;
52 |
53 | let new_load ~allow_hidden ~unit_name =
54 | let filename = filename_of_module unit_name in
55 | let fs_name = Filename.(concat stdlib_path filename) in
56 | (* Check if it's already been downloaded. This will be the
57 | case for all toplevel cmis. Also check whether we're supposed
58 | to handle this cmi *)
59 | if
60 | not (Sys.file_exists fs_name) &&
61 | List.exists ~f:(fun prefix ->
62 | String.starts_with ~prefix filename) dcs.dcs_file_prefixes
63 | then begin
64 | match fetch filename with
65 | | Some x ->
66 | Sys_js.create_file ~name:fs_name ~content:x;
67 | (* At this point we need to tell merlin that the dir contents
68 | have changed *)
69 | reset_dirs ()
70 | | None ->
71 | Printf.eprintf "Warning: Expected to find cmi at: %s\n%!"
72 | (Filename.concat dcs.Protocol.dcs_url filename)
73 | end;
74 | old_loader ~allow_hidden ~unit_name
75 | in
76 | load := new_load
77 |
78 | let add_cmis { Protocol.static_cmis; dynamic_cmis } =
79 | List.iter static_cmis ~f:(fun { Protocol.sc_name; sc_content } ->
80 | let filename = Printf.sprintf "%s.cmi" (String.uncapitalize_ascii sc_name) in
81 | let name = Filename.(concat stdlib_path filename) in
82 | Sys_js.create_file ~name ~content:sc_content);
83 | Option.iter ~f:add_dynamic_cmis dynamic_cmis;
84 | Protocol.Added_cmis
85 |
86 | let config =
87 | let initial = Mconfig.initial in
88 | { initial with
89 | merlin = { initial.merlin with
90 | stdlib = Some stdlib_path }}
91 |
92 | let make_pipeline source =
93 | Mpipeline.make config source
94 |
95 | let dispatch source query =
96 | let pipeline = make_pipeline source in
97 | Mpipeline.with_pipeline pipeline @@ fun () -> (
98 | Query_commands.dispatch pipeline query
99 | )
100 |
101 | module Completion = struct
102 | (* Prefixing code from ocaml-lsp-server *)
103 | let rfindi =
104 | let rec loop s ~f i =
105 | if i < 0 then
106 | None
107 | else if f (String.unsafe_get s i) then
108 | Some i
109 | else
110 | loop s ~f (i - 1)
111 | in
112 | fun ?from s ~f ->
113 | let from =
114 | let len = String.length s in
115 | match from with
116 | | None -> len - 1
117 | | Some i ->
118 | if i > len - 1 then
119 | raise @@ Invalid_argument "rfindi: invalid from"
120 | else
121 | i
122 | in
123 | loop s ~f from
124 | let lsplit2 s ~on =
125 | match String.index_opt s on with
126 | | None -> None
127 | | Some i ->
128 | let open String in
129 | Some (sub s ~pos:0 ~len:i, sub s ~pos:(i + 1) ~len:(length s - i - 1))
130 |
131 | (** @see reference *)
132 | let prefix_of_position ?(short_path = false) source position =
133 | match Msource.text source with
134 | | "" -> ""
135 | | text ->
136 | let from =
137 | let (`Offset index) = Msource.get_offset source position in
138 | min (String.length text - 1) (index - 1)
139 | in
140 | let pos =
141 | let should_terminate = ref false in
142 | let has_seen_dot = ref false in
143 | let is_prefix_char c =
144 | if !should_terminate then
145 | false
146 | else
147 | match c with
148 | | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '\'' | '_'
149 | (* Infix function characters *)
150 | | '$' | '&' | '*' | '+' | '-' | '/' | '=' | '>'
151 | | '@' | '^' | '!' | '?' | '%' | '<' | ':' | '~' | '#' ->
152 | true
153 | | '`' ->
154 | if !has_seen_dot then
155 | false
156 | else (
157 | should_terminate := true;
158 | true
159 | ) | '.' ->
160 | has_seen_dot := true;
161 | not short_path
162 | | _ -> false
163 | in
164 | rfindi text ~from ~f:(fun c -> not (is_prefix_char c))
165 | in
166 | let pos =
167 | match pos with
168 | | None -> 0
169 | | Some pos -> pos + 1
170 | in
171 | let len = from - pos + 1 in
172 | let reconstructed_prefix = String.sub text ~pos ~len in
173 | (* if we reconstructed [~f:ignore] or [?f:ignore], we should take only
174 | [ignore], so: *)
175 | if
176 | String.is_prefixed ~by:"~" reconstructed_prefix
177 | || String.is_prefixed ~by:"?" reconstructed_prefix
178 | then
179 | match lsplit2 reconstructed_prefix ~on:':' with
180 | | Some (_, s) -> s
181 | | None -> reconstructed_prefix
182 | else
183 | reconstructed_prefix
184 |
185 |
186 | let at_pos source position =
187 | let prefix = prefix_of_position source position in
188 | let `Offset to_ = Msource.get_offset source position in
189 | let from =
190 | to_ - String.length (prefix_of_position ~short_path:true source position)
191 | in
192 | if prefix = "" then
193 | None
194 | else
195 | let query = Query_protocol.Complete_prefix (prefix, position, [], true, true)
196 | in
197 | Some (from, to_, dispatch source query)
198 | end
199 | (*
200 | let dump () =
201 | let query = Query_protocol.Dump [`String "paths"] in
202 | dispatch (Msource.make "") query *)
203 |
204 | (* let dump_config () =
205 | let pipeline = make_pipeline (Msource.make "") in
206 | Mpipeline.with_pipeline pipeline @@ fun () ->
207 | Mconfig.dump (Mpipeline.final_config pipeline)
208 | |> Json.pretty_to_string *)
209 |
210 | let on_message = function
211 | | Protocol.Complete_prefix (source, position) ->
212 | let source = Msource.make source in
213 | begin match Completion.at_pos source position with
214 | | Some (from, to_, compl) ->
215 | let entries = compl.entries in
216 | Protocol.Completions { from; to_; entries; }
217 | | None ->
218 | Protocol.Completions { from = 0; to_ = 0; entries = []; }
219 | end
220 | | Type_enclosing (source, position) ->
221 | let source = Msource.make source in
222 | let query = Query_protocol.Type_enclosing (None, position, None) in
223 | Protocol.Typed_enclosings (dispatch source query)
224 | | Protocol.All_errors source ->
225 | let source = Msource.make source in
226 | let query = Query_protocol.Errors {
227 | lexing = true;
228 | parsing = true;
229 | typing = true;
230 | }
231 | in
232 | let errors =
233 | dispatch source query
234 | |> List.map ~f:(fun (Location.{kind; sub; source; _} as error) ->
235 | let of_sub sub =
236 | Location.print_sub_msg Format.str_formatter sub;
237 | String.trim (Format.flush_str_formatter ())
238 | in
239 | let loc = Location.loc_of_report error in
240 | let main =
241 | Format.asprintf "@[%a@]" Location.print_main error |> String.trim
242 | in
243 | Protocol.{
244 | kind;
245 | loc;
246 | main;
247 | sub = List.map ~f:of_sub sub;
248 | source;
249 | })
250 | in
251 | Protocol.Errors errors
252 | | Add_cmis cmis ->
253 | add_cmis cmis
254 |
255 | let post res =
256 | Marshal.to_string res []
257 | |> Js.bytestring
258 | |> Worker.post_message
259 |
260 | let run () =
261 | Console.console##log (Js.string "Worker running");
262 | Worker.set_onmessage (fun marshaled_message ->
263 | let action : Protocol.action =
264 | let str = Js.to_bytestring marshaled_message in
265 | Marshal.from_string str 0
266 | in
267 | log @@ Printf.sprintf "Received message with action %S"
268 | (Protocol.action_to_string action);
269 | let res = on_message action in
270 | log @@ Printf.sprintf "Sending message with answer %S"
271 | (Protocol.answer_to_string res);
272 | post res);
273 | post Protocol.Ready
274 |
--------------------------------------------------------------------------------