this repo has no description
1(* Classify directories in ocamlfind *)
2
3(* Given a directory with cmis, cmas and so on, partition the modules between the libraries *)
4(* open Bos *)
5
6open Odoc_utils
7open Cmo_format
8
9module StringSet = Set.Make (String)
10let list_of_stringset x =
11 StringSet.fold (fun a b -> a :: b) x []
12
13let debug = ref false
14
15let log fmt =
16 if !debug then Format.printf fmt else Format.ifprintf Format.std_formatter fmt
17
18#if defined OXCAML
19let name_of_import import = Import_info.name import |> Compilation_unit.Name.to_string
20let intf_info import = Option.map snd (Import_info.Intf.info import)
21let cmt_imports cmt_infos = Array.to_list cmt_infos.Cmt_format.cmt_imports
22let cmi_crcs cmi_infos = Array.to_list cmi_infos.Cmi_format.cmi_crcs
23#else
24let name_of_import (cu, _) = cu
25let intf_info (_, info) = info
26let cmt_imports cmt_infos = cmt_infos.Cmt_format.cmt_imports
27let cmi_crcs cmi_infos = cmi_infos.Cmi_format.cmi_crcs
28#endif
29
30module Archive = struct
31 type name = string
32
33 type t = {
34 name : name;
35 modules : StringSet.t;
36 intf_deps : StringSet.t;
37 impl_deps : StringSet.t;
38 }
39 let empty name =
40 {
41 name;
42 modules = StringSet.empty;
43 intf_deps = StringSet.empty;
44 impl_deps = StringSet.empty;
45 }
46
47 let normalise s =
48 {
49 s with
50 intf_deps = StringSet.diff s.intf_deps s.modules;
51 impl_deps = StringSet.diff s.impl_deps s.modules;
52 }
53
54#if defined OXCAML
55 let cu_imports cu = Array.to_list cu.cu_imports
56#else
57 let cu_imports cu = cu.cu_imports
58#endif
59
60 let add_cu lib cu =
61 normalise
62 {
63 lib with
64 modules =
65 StringSet.add (Odoc_model.Compat.compunit_name cu.cu_name) lib.modules;
66 intf_deps =
67 List.fold_left
68 (fun deps import -> StringSet.add (name_of_import import) deps)
69 lib.intf_deps (cu_imports cu);
70 impl_deps =
71 List.fold_left
72 (fun deps id -> StringSet.add id deps)
73 lib.impl_deps
74 (Odoc_model.Compat.required_compunit_names cu);
75 }
76
77 let add_unit_info lib (unit, cmis, cmxs) =
78 let name =
79 unit
80#if defined OXCAML
81 |> Compilation_unit.name_as_string
82#endif
83 in
84 normalise
85 {
86 lib with
87 modules = StringSet.add name lib.modules;
88 intf_deps =
89 List.fold_left
90 (fun deps import -> StringSet.add (name_of_import import) deps)
91 lib.intf_deps cmis;
92 impl_deps =
93 List.fold_left
94 (fun deps import -> StringSet.add (name_of_import import) deps)
95 lib.impl_deps cmxs;
96 }
97
98 let add_module_by_name lib name =
99 normalise { lib with modules = StringSet.add name lib.modules }
100
101 let filter_by_cmis valid_cmis lib =
102 {
103 lib with
104 modules = StringSet.filter (fun m -> List.mem m valid_cmis) lib.modules;
105 }
106
107 let has_modules a = StringSet.cardinal a.modules > 0
108
109 let pp ppf lib =
110 Fmt.pf ppf "Name: %s@.Modules: %a@.Intf deps: %a@.Impl_deps: %a@." lib.name
111 Fmt.(list ~sep:sp string)
112 (StringSet.elements lib.modules)
113 Fmt.(list ~sep:sp string)
114 (StringSet.elements lib.intf_deps)
115 Fmt.(list ~sep:sp string)
116 (StringSet.elements lib.impl_deps)
117end
118
119module Cmi = struct
120 let get_deps filename =
121 let cmi, _cmt = Cmt_format.read filename in
122 match cmi with
123 | Some cmi ->
124 let cmi_crcs = cmi_crcs cmi in
125 List.map name_of_import cmi_crcs |> StringSet.of_list
126 | None -> StringSet.empty
127end
128
129module Deps = struct
130 type t = (string * StringSet.t) list
131
132 let closure deps =
133 let rec inner acc l =
134 match l with
135 | [] -> acc
136 | (x, deps) :: rest ->
137 let acc =
138 List.map
139 (fun (y, ydeps) ->
140 if StringSet.mem x ydeps then (y, StringSet.union ydeps deps)
141 else (y, ydeps))
142 acc
143 in
144 inner acc rest
145 in
146 let eq (l1 : t) (l2 : t) =
147 (* Note that the keys in l1 and l2 never change, only the values, so it's
148 safe to iterate over the keys of just one of l1 or l2 *)
149 List.for_all
150 (fun (x, deps) ->
151 try
152 let deps' = List.assoc x l2 in
153 StringSet.equal deps deps'
154 with Not_found -> false)
155 l1
156 in
157 let rec loop acc =
158 let acc' = inner acc deps in
159 if eq acc acc' then acc else loop acc'
160 in
161 loop deps
162
163 (* Return a dag showing dependencies between archives due to module initialisation order.
164 In rare cases, modules are shared between archives which would lead to the graph
165 having cycles, so we explicitly remove those from consideration by checking that the
166 intersection of module names in the archives is empty. These archives can't be linked
167 together anyway. *)
168 let impl_deps archives =
169 List.map
170 (fun (l1 : Archive.t) ->
171 let deps =
172 List.filter
173 (fun (l2 : Archive.t) ->
174 ((StringSet.inter l1.modules l2.modules |> StringSet.cardinal) = 0) &&
175 not
176 @@ StringSet.is_empty
177 (StringSet.inter l1.impl_deps l2.modules))
178 archives
179 in
180 (l1.name, List.map (fun x -> x.Archive.name) deps |> StringSet.of_list))
181 archives
182 |> closure
183end
184
185let read_cma ic init =
186 let toc_pos = input_binary_int ic in
187 seek_in ic toc_pos;
188 let toc = (input_value ic : library) in
189 close_in ic;
190 Ok (List.fold_left Archive.add_cu init toc.lib_units)
191
192let read_cmxa ic init =
193 let li = (input_value ic : Cmx_format.library_infos) in
194 close_in ic;
195#if defined OXCAML
196 (* FIXME: This OxCaml-specific code is awful and can be gotten rid of
197 once this PR (which was inspired by having to write this very code) is merged:
198 https://github.com/oxcaml/oxcaml/pull/2673 *)
199 let get_masked array i ~mask =
200 if Misc.Bitmap.get mask i then Some (Array.get array i) else None
201 in
202 let bitmap_to_list b ~array =
203 List.init (Array.length array) (fun i -> i)
204 |> List.filter_map (fun i -> get_masked array i ~mask:b)
205 in
206 let units =
207 List.map
208 (fun (unit : Cmx_format.lib_unit_info) ->
209 let cmis = bitmap_to_list unit.li_imports_cmi ~array:li.lib_imports_cmi in
210 let cmxs = bitmap_to_list unit.li_imports_cmx ~array:li.lib_imports_cmx in
211 unit.li_name, cmis, cmxs)
212 li.lib_units
213 in
214#else
215 let units =
216 List.map
217 (fun (u, _) -> u.Cmx_format.ui_name, u.ui_imports_cmi, u.ui_imports_cmx)
218 li.lib_units
219 in
220#endif
221 Ok (List.fold_left Archive.add_unit_info init units)
222
223
224#if OCAML_VERSION >= (4, 12, 0)
225open Misc
226
227let read_library ic init =
228 let open Magic_number in
229 match read_current_info ~expected_kind:None ic with
230 | Ok { kind = Cma; version = _ } -> read_cma ic init
231#if defined OXCAML
232 | Ok { kind = Cmxa; version = _ } ->
233#else
234 | Ok { kind = Cmxa _; version = _ } ->
235#endif
236 read_cmxa ic init
237 | Ok { kind = _; version = _ } -> Error (`Msg "Not a valid library")
238 | Error _ -> Error (`Msg "Not a valid file")
239#else
240let read_library ic init =
241 let len_magic_number = String.length Config.cmo_magic_number in
242 let magic_number = really_input_string ic len_magic_number in
243 if magic_number = Config.cma_magic_number then read_cma ic init
244 else if magic_number = Config.cmxa_magic_number then read_cmxa ic init
245 else Error (`Msg "Not a valid library")
246#endif
247
248#if OCAML_VERSION > (4, 12, 0)
249let read_cmi ic =
250 let open Magic_number in
251 match read_current_info ~expected_kind:None ic with
252 | Ok { kind = Cmi; version = _ } ->
253 let cmi = (input_value ic : Cmi_format.cmi_infos) in
254 close_in ic;
255 Ok cmi
256 | Ok { kind = _; version = _ } -> Error (`Msg "Not a valid cmi")
257 | Error _ -> Error (`Msg "Not a valid file")
258#else
259let read_cmi ic =
260 let len_magic_number = String.length Config.cmo_magic_number in
261 let magic_number = really_input_string ic len_magic_number in
262 if magic_number = Config.cmi_magic_number
263 then begin
264 let cmi = (input_value ic : Cmi_format.cmi_infos) in
265 close_in ic;
266 Ok cmi
267 end else Error (`Msg "Not a valid file")
268
269#endif
270
271let classify files libraries =
272 let libraries = Fpath.Set.elements libraries in
273
274 let archives =
275 List.map
276 (fun lpath ->
277 let path ext = Fpath.(set_ext ext lpath |> to_string) in
278 let paths = [ path ".cma"; path ".cmxa" ] in
279 List.fold_left
280 (fun cur path ->
281 if not (Sys.file_exists path) then cur
282 else
283 Io_utils.with_open_in_bin path (fun ic ->
284 match read_library ic cur with
285 | Ok lib -> lib
286 | Error (`Msg m) ->
287 Format.eprintf "Error reading library: %s\n%!" m;
288 cur))
289 (Archive.empty (Fpath.basename lpath)) paths)
290 libraries
291 in
292
293 let cmis = List.filter (Fpath.has_ext ".cmi") files in
294 let cmi_names =
295 List.map
296 (fun f -> Fpath.(rem_ext f |> basename |> Astring.String.Ascii.capitalize))
297 cmis
298 in
299
300 let _impls, intfs =
301 let check f ext =
302 Sys.file_exists Fpath.(set_ext ext f |> to_string)
303 in
304 List.partition (fun f -> check f ".cmo" || check f "cmx") cmis
305 in
306
307 let intfs_deps =
308 List.map
309 (fun f ->
310 let modname =
311 Filename.chop_suffix (Fpath.basename f) ".cmi" |> Astring.String.Ascii.capitalize
312 in
313 (modname, Cmi.get_deps Fpath.(f |> to_string)))
314 intfs
315 in
316
317 let modules = List.map fst intfs_deps in
318
319 let orphaned_modules =
320 List.filter
321 (fun module_name ->
322 not
323 @@ List.exists
324 (fun lib -> StringSet.mem module_name lib.Archive.modules)
325 archives)
326 modules
327 in
328
329 let libdeps = Deps.impl_deps archives in
330
331 let rec topo_sort l =
332 match l with
333 | [] -> []
334 | _ ->
335 let no_deps, rest =
336 List.partition (function _, x -> StringSet.is_empty x) l
337 in
338 let no_dep_names = List.map fst no_deps |> StringSet.of_list in
339 let rest =
340 List.map (fun (x, deps) -> (x, StringSet.diff deps no_dep_names)) rest
341 in
342 (list_of_stringset no_dep_names) @ topo_sort rest
343 in
344
345 let all_sorted = topo_sort libdeps in
346 let find_lib m =
347 log "Checking module: %s\n%!" m;
348
349 (* If our module depends on a library, it shouldn't be in any dependency of that library *)
350 log "Modules dependencies: %a\n%!"
351 Fmt.(list ~sep:sp string)
352 (List.assoc m intfs_deps |> list_of_stringset);
353 let denylist =
354 List.fold_left
355 (fun acc archive ->
356 let lib_dependent_modules =
357 StringSet.inter (List.assoc m intfs_deps) archive.Archive.modules
358 in
359 if StringSet.cardinal lib_dependent_modules > 0 then (
360 log "Module %s has dependencies [%a] in archive %s\n%!" m
361 Fmt.(list ~sep:sp string)
362 (list_of_stringset lib_dependent_modules)
363 archive.Archive.name;
364 log "Therefore denying: %a\n%!"
365 Fmt.(list ~sep:sp string)
366 (List.assoc archive.name libdeps
367 |> list_of_stringset);
368 StringSet.union acc (List.assoc archive.name libdeps))
369 else acc)
370 StringSet.empty archives
371 in
372
373 log "Denylist: %a\n%!"
374 Fmt.(list ~sep:sp string)
375 (StringSet.elements denylist);
376
377 (* If library x depends upon our module, our module can't be in any library that depends upon x *)
378 let denylist2 =
379 List.fold_left
380 (fun acc archive ->
381 if StringSet.mem m archive.Archive.intf_deps then (
382 log "Archive %s is dependent on interface of module %s\n%!"
383 archive.Archive.name m;
384 List.fold_left
385 (fun acc (x, deps) ->
386 if StringSet.mem archive.name deps then (
387 log "archive %s depends on archive %s so removing it!\n%!" x
388 archive.name;
389 StringSet.add x acc)
390 else acc)
391 acc libdeps)
392 else acc)
393 StringSet.empty archives
394 in
395 log "Denylist2: %a\n%!"
396 Fmt.(list ~sep:sp string)
397 (StringSet.elements denylist2);
398
399 (* We prefer to put the module into a library that depends upon our module *)
400 let goodlist =
401 List.fold_left
402 (fun acc archive ->
403 if StringSet.mem m archive.Archive.intf_deps then
404 StringSet.add archive.name acc
405 else acc)
406 StringSet.empty archives
407 in
408 log "Goodlist: %a\n%!"
409 Fmt.(list ~sep:sp string)
410 (StringSet.elements goodlist);
411
412 let goodlist2 =
413 List.fold_left
414 (fun acc archive ->
415 if
416 StringSet.inter archive.Archive.modules (List.assoc m intfs_deps)
417 |> StringSet.cardinal > 0
418 then StringSet.add archive.name acc
419 else acc)
420 StringSet.empty archives
421 in
422
423 let goodlist = StringSet.union goodlist goodlist2 in
424
425 log "Goodlist: %a\n%!"
426 Fmt.(list ~sep:sp string)
427 (StringSet.elements goodlist);
428
429 let possibilities =
430 StringSet.of_list (List.map (fun x -> x.Archive.name) archives)
431 in
432 let possibilities = StringSet.diff possibilities denylist in
433 let possibilities = StringSet.diff possibilities denylist2 in
434
435 let possibilities =
436 if StringSet.is_empty possibilities then goodlist
437 (* This can happen, e.g. if Instruct was an interface only module *)
438 else StringSet.inter goodlist possibilities
439 in
440
441 log "Possibilities: %a\n%!"
442 Fmt.(list ~sep:sp string)
443 (StringSet.elements possibilities);
444
445 let result =
446 try List.find (fun lib -> StringSet.mem lib possibilities) all_sorted
447 with Not_found ->
448 log "Defaulting to %s\n%!" (List.hd all_sorted);
449 List.hd all_sorted
450 in
451
452 List.find (fun a -> a.Archive.name = result) archives
453 in
454
455 let module_libs =
456 List.map
457 (fun modname -> (modname, (find_lib modname).Archive.name))
458 orphaned_modules
459 in
460
461 List.iter
462 (fun a ->
463 let archive_all =
464 List.fold_left
465 (fun a (m, lib) ->
466 if lib = a.Archive.name then Archive.add_module_by_name a m else a)
467 a module_libs
468 in
469 let archive = Archive.filter_by_cmis cmi_names archive_all in
470 if Archive.has_modules archive then
471 Printf.printf "%s %s\n" a.Archive.name
472 (archive.Archive.modules |> StringSet.elements |> String.concat ~sep:" "))
473 archives;
474
475 ()
476
477let classify dirs =
478 let files =
479 List.map (fun dir ->
480 Sys.readdir dir |> Array.to_list |> List.map (fun p -> Fpath.(v dir / p))) dirs |> List.flatten in
481
482 let libraries =
483 List.fold_left
484 (fun acc p ->
485 if Fpath.has_ext ".cma" p || Fpath.has_ext ".cmxa" p then
486 Fpath.Set.add Fpath.(rem_ext p) acc
487 else acc)
488 Fpath.Set.empty files
489 in
490
491 if Fpath.Set.cardinal libraries = 0 then Ok ()
492 else Ok (classify files libraries)