jon.recoil.org
this repo has no description
1(* Kinda findlib, sorta *)
2
3type library = {
4 name : string;
5 meta_uri : Uri.t;
6 archive_name : string option;
7 dir : string option;
8 deps : string list;
9 children : library list;
10 mutable loaded : bool;
11}
12
13let rec flatten_libs libs =
14 let handle_lib l =
15 let children = flatten_libs l.children in
16 l :: children
17 in
18 List.map handle_lib libs |> List.flatten
19
20let preloaded =
21 [
22 "angstrom";
23 "astring";
24 "compiler-libs.common";
25 "compiler-libs.toplevel";
26 "findlib";
27 "findlib.top";
28 "fpath";
29 "js_of_ocaml-compiler";
30 "js_of_ocaml-ppx";
31 "js_of_ocaml-toplevel";
32 "js_top_worker";
33 "js_top_worker-rpc";
34 "logs";
35 "logs.browser";
36 "merlin-lib.kernel";
37 "merlin-lib.ocaml_parsing";
38 "merlin-lib.query_commands";
39 "merlin-lib.query_protocol";
40 "merlin-lib.utils";
41 "mime_printer";
42 "uri";
43 ]
44
45let rec read_libraries_from_pkg_defs ~library_name ~dir meta_uri pkg_expr =
46 try
47 Jslib.log "Reading library: %s" library_name;
48 let pkg_defs = pkg_expr.Fl_metascanner.pkg_defs in
49 (* Try to find archive with various predicates.
50 PPX packages often only define archive(ppx_driver,byte), so we need to
51 check multiple predicate combinations to find the right archive. *)
52 let archive_filename =
53 (* First try with ppx_driver,byte - this catches PPX libraries like ppx_deriving.show *)
54 try Some (Fl_metascanner.lookup "archive" [ "ppx_driver"; "byte" ] pkg_defs)
55 with _ -> (
56 (* Then try plain byte *)
57 try Some (Fl_metascanner.lookup "archive" [ "byte" ] pkg_defs)
58 with _ -> (
59 (* Then try native as fallback *)
60 try Some (Fl_metascanner.lookup "archive" [ "native" ] pkg_defs)
61 with _ -> None))
62 in
63
64 (* Use -ppx_driver predicate for toplevel use - this ensures PPX packages
65 pull in their runtime dependencies (e.g., ppx_deriving.show requires
66 ppx_deriving.runtime when not using ppx_driver) *)
67 let predicates = ["-ppx_driver"] in
68 let deps_str =
69 try Fl_metascanner.lookup "requires" predicates pkg_defs with _ -> "" in
70 let deps = Astring.String.fields ~empty:false deps_str in
71 let subdir =
72 List.find_opt (fun d -> d.Fl_metascanner.def_var = "directory") pkg_defs
73 |> Option.map (fun d -> d.Fl_metascanner.def_value)
74 in
75 let dir =
76 match (dir, subdir) with
77 | None, None -> None
78 | Some d, None -> Some d
79 | None, Some d -> Some d
80 | Some d1, Some d2 -> Some (Filename.concat d1 d2)
81 in
82 let archive_name =
83 Option.bind archive_filename (fun a ->
84 let file_name_len = String.length a in
85 if file_name_len > 0 then Some (Filename.chop_extension a) else None)
86 in
87 Jslib.log "Number of children: %d" (List.length pkg_expr.pkg_children);
88 let children =
89 List.filter_map
90 (fun (n, expr) ->
91 Jslib.log "Found child: %s" n;
92 let library_name = library_name ^ "." ^ n in
93 match
94 read_libraries_from_pkg_defs ~library_name ~dir meta_uri expr
95 with
96 | Ok l -> Some l
97 | Error (`Msg m) ->
98 Jslib.log "Error reading sub-library: %s" m;
99 None)
100 pkg_expr.pkg_children
101 in
102 Ok
103 {
104 name = library_name;
105 archive_name;
106 dir;
107 deps;
108 meta_uri;
109 loaded = false;
110 children;
111 }
112 with Not_found -> Error (`Msg "Failed to read libraries from pkg_defs")
113
114type t = library list
115
116let dcs_filename = "dynamic_cmis.json"
117
118let fetch_dynamic_cmis sync_get url =
119 match sync_get url with
120 | None -> Error (`Msg "Failed to fetch dynamic cmis")
121 | Some json ->
122 let rpc = Jsonrpc.of_string json in
123 Rpcmarshal.unmarshal
124 Js_top_worker_rpc.Toplevel_api_gen.typ_of_dynamic_cmis rpc
125
126let (let*) = Lwt.bind
127
128(** Parse a findlib_index file (JSON or legacy text format) and return
129 the list of META file paths and universe paths.
130
131 JSON format: {"meta_files": ["path/to/META", ...], "universes": ["universe1", ...]}
132
133 meta_files: direct paths to META files
134 universes: paths to other universes (directories containing findlib_index) *)
135let parse_findlib_index content =
136 (* Try JSON format first *)
137 try
138 let json = Yojson.Safe.from_string content in
139 let open Yojson.Safe.Util in
140 (* Support both "meta_files" and "metas" for compatibility *)
141 let meta_files =
142 try json |> member "meta_files" |> to_list |> List.map to_string
143 with _ ->
144 try json |> member "metas" |> to_list |> List.map to_string
145 with _ -> []
146 in
147 (* Support both "universes" and "deps" for compatibility *)
148 let universes =
149 try json |> member "universes" |> to_list |> List.map to_string
150 with _ ->
151 try json |> member "deps" |> to_list |> List.map to_string
152 with _ -> []
153 in
154 (meta_files, universes)
155 with _ ->
156 (* Fall back to legacy whitespace-separated format (no universes) *)
157 (Astring.String.fields ~empty:false content, [])
158
159(** Load a single META file and parse it into a library *)
160let load_meta async_get meta_path =
161 let* res = async_get meta_path in
162 match res with
163 | Error (`Msg m) ->
164 Jslib.log "Error fetching findlib meta %s: %s" meta_path m;
165 Lwt.return_none
166 | Ok meta_content ->
167 match Angstrom.parse_string ~consume:All Uri.Parser.uri_reference meta_path with
168 | Ok uri -> (
169 Jslib.log "Parsed uri: %s" (Uri.path uri);
170 let path = Uri.path uri in
171 let file = Fpath.v path in
172 let base_library_name =
173 if Fpath.basename file = "META" then
174 Fpath.parent file |> Fpath.basename
175 else Fpath.get_ext file
176 in
177 let lexing = Lexing.from_string meta_content in
178 try
179 let meta = Fl_metascanner.parse_lexing lexing in
180 let libraries =
181 read_libraries_from_pkg_defs ~library_name:base_library_name
182 ~dir:None uri meta
183 in
184 Lwt.return (Result.to_option libraries)
185 with _ ->
186 Jslib.log "Failed to parse meta: %s" (Uri.path uri);
187 Lwt.return_none)
188 | Error m ->
189 Jslib.log "Failed to parse uri: %s" m;
190 Lwt.return_none
191
192(** Resolve a path relative to the directory of the base URL.
193 Used for meta_files which are relative to their findlib_index.
194 e.g. base="http://host/demo1/base/findlib_index", path="lib/base/META"
195 => "http://host/demo1/base/lib/base/META" *)
196let resolve_relative_to_dir ~base path =
197 match Angstrom.parse_string ~consume:All Uri.Parser.uri_reference base with
198 | Ok base_uri ->
199 let base_path = Uri.path base_uri in
200 let parent_dir =
201 match Fpath.of_string base_path with
202 | Ok p -> Fpath.parent p |> Fpath.to_string
203 | Error _ -> "/"
204 in
205 let resolved = Filename.concat parent_dir path in
206 Uri.with_path base_uri resolved |> Uri.to_string
207 | Error _ -> path
208
209(** Resolve a path as absolute from root (preserving scheme/host from base).
210 Used for universe paths which are already full paths from root.
211 e.g. base="http://host/demo1/findlib_index", path="demo1/base/findlib_index"
212 => "http://host/demo1/base/findlib_index" *)
213let resolve_from_root ~base path =
214 match Angstrom.parse_string ~consume:All Uri.Parser.uri_reference base with
215 | Ok base_uri ->
216 let resolved = "/" ^ path in
217 Uri.with_path base_uri resolved |> Uri.to_string
218 | Error _ -> "/" ^ path
219
220let init (async_get : string -> (string, [>`Msg of string]) result Lwt.t) findlib_index : t Lwt.t =
221 Jslib.log "Initializing findlib";
222 (* Track visited universes to avoid infinite loops *)
223 let visited = Hashtbl.create 16 in
224 let rec load_universe index_url =
225 if Hashtbl.mem visited index_url then
226 Lwt.return []
227 else begin
228 Hashtbl.add visited index_url ();
229 let* findlib_txt = async_get index_url in
230 match findlib_txt with
231 | Error (`Msg m) ->
232 Jslib.log "Error fetching findlib index %s: %s" index_url m;
233 Lwt.return []
234 | Ok content ->
235 let meta_files, universes = parse_findlib_index content in
236 Jslib.log "Loaded findlib_index %s: %d META files, %d universes"
237 index_url (List.length meta_files) (List.length universes);
238 (* Resolve META paths relative to findlib_index directory *)
239 let resolved_metas =
240 List.map (fun p -> resolve_relative_to_dir ~base:index_url p) meta_files
241 in
242 (* Load META files from this universe *)
243 let* local_libs = Lwt_list.filter_map_p (load_meta async_get) resolved_metas in
244 (* Resolve universe paths from root (they're already full paths) *)
245 let universe_index_urls =
246 List.map (fun u ->
247 resolve_from_root ~base:index_url (Filename.concat u "findlib_index.json"))
248 universes
249 in
250 let* universe_libs = Lwt_list.map_p load_universe universe_index_urls in
251 Lwt.return (local_libs @ List.flatten universe_libs)
252 end
253 in
254 let* all_libs = load_universe findlib_index in
255 Lwt.return (flatten_libs all_libs)
256
257let require ~import_scripts sync_get cmi_only v packages =
258 let rec require dcss package :
259 Js_top_worker_rpc.Toplevel_api_gen.dynamic_cmis list =
260 match List.find (fun lib -> lib.name = package) v with
261 | exception Not_found ->
262 Jslib.log "Package %s not found" package;
263 let available =
264 v
265 |> List.map (fun lib ->
266 Printf.sprintf "%s (%d)" lib.name (List.length lib.children))
267 |> String.concat ", "
268 in
269 Jslib.log "Available packages: %s" available;
270 dcss
271 | lib ->
272 if lib.loaded then dcss
273 else (
274 Jslib.log "Loading package %s" lib.name;
275 Jslib.log "lib.dir: %s" (Option.value ~default:"None" lib.dir);
276 let dep_dcs = List.fold_left require dcss lib.deps in
277 let path = Fpath.(v (Uri.path lib.meta_uri) |> parent) in
278 let dir =
279 match lib.dir with
280 | None -> path
281 | Some "+" -> Fpath.parent path (* "+" means parent dir in findlib *)
282 | Some d when String.length d > 0 && d.[0] = '^' ->
283 (* "^" prefix means relative to stdlib dir - treat as parent *)
284 Fpath.parent path
285 | Some d -> Fpath.(path // v d)
286 in
287 let dcs = Fpath.(dir / dcs_filename |> to_string) in
288 let uri = Uri.with_path lib.meta_uri dcs in
289 Jslib.log "uri: %s" (Uri.to_string uri);
290 match fetch_dynamic_cmis sync_get (Uri.to_string uri) with
291 | Ok dcs ->
292 let should_load =
293 (not (List.mem lib.name preloaded)) && not cmi_only
294 in
295 Option.iter
296 (fun archive ->
297 if should_load then begin
298 let archive_js =
299 Fpath.(dir / (archive ^ ".cma.js") |> to_string)
300 in
301 import_scripts
302 [ Uri.with_path uri archive_js |> Uri.to_string ]
303 end)
304 lib.archive_name;
305 lib.loaded <- true;
306 Jslib.log "Finished loading package %s" lib.name;
307 dcs :: dep_dcs
308 | Error (`Msg m) ->
309 Jslib.log "Failed to unmarshal dynamic_cms from url %s: %s"
310 (Uri.to_string uri) m;
311 dcss)
312 in
313 List.fold_left require [] packages