jon.recoil.org
this repo has no description
1(* Voodoo *)
2
3let ( >>= ) = Result.bind
4
5type pkg = {
6 name : string;
7 version : string;
8 universe : string;
9 blessed : bool;
10 files : Fpath.t list;
11}
12
13let prep_path = ref "prep"
14
15(* We mark the paths that contain compiled units for both packages and libraries
16 by dropping in a marker file. The contents of the file is unimportant, as we
17 can determine which package or library we're looking at simply by its path. *)
18let lib_marker = ".odoc_lib_marker"
19let pkg_marker = ".odoc_pkg_marker"
20
21let top_dir pkg =
22 if pkg.blessed then Fpath.(v "p" / pkg.name / pkg.version)
23 else Fpath.(v "u" / pkg.universe / pkg.name / pkg.version)
24
25(* Use output from Voodoo Prep as input *)
26
27let find_universe_and_version pkg_name =
28 Bos.OS.Dir.contents Fpath.(v !prep_path / "universes") >>= fun universes ->
29 let universe =
30 match
31 List.find_opt
32 (fun u ->
33 match Bos.OS.Dir.exists Fpath.(u / pkg_name) with
34 | Ok b -> b
35 | Error _ -> false)
36 universes
37 with
38 | Some u -> Ok u
39 | None -> Error (`Msg (Format.sprintf "Failed to find package %s" pkg_name))
40 in
41 universe >>= fun u ->
42 Bos.OS.Dir.contents ~rel:true Fpath.(u / pkg_name) >>= fun version ->
43 match (Fpath.segs u, version) with
44 | _ :: _ :: u :: _, [ version ] -> Ok (u, Fpath.to_string version)
45 | _ -> Error (`Msg (Format.sprintf "Failed to find package %s" pkg_name))
46
47(* Given a directory containing for example [a.cma] and [b.cma], this
48 function returns a Fpath.Map.t mapping [dir/a.cma -> a] and [dir/b.cma -> b] *)
49let libname_of_archives_of_dir dir =
50 let files_res = Bos.OS.Dir.contents dir in
51 match files_res with
52 | Error _ -> Fpath.Map.empty
53 | Ok files ->
54 List.fold_left
55 (fun acc file ->
56 let base = Fpath.basename file in
57 if Astring.String.is_suffix ~affix:".cma" base then
58 let libname = String.sub base 0 (String.length base - 4) in
59 Fpath.Map.add Fpath.(dir / libname) libname acc
60 else acc)
61 Fpath.Map.empty files
62
63let metas_of_pkg pkg =
64 List.filter
65 (fun p ->
66 let filename = Fpath.filename p in
67 filename = "META")
68 pkg.files
69
70let of_voodoo pkg =
71 let metas = metas_of_pkg pkg in
72
73 let pkg_path =
74 Fpath.(v "prep" / "universes" / pkg.universe / pkg.name / pkg.version)
75 in
76
77 (* a map from libname to the set of dependencies of that library *)
78 let (all_lib_deps, cmi_only_libs) :
79 Util.StringSet.t Util.StringMap.t * (Fpath.t * string) list =
80 List.fold_left
81 (fun (d, c) meta ->
82 let full_meta_path = Fpath.(pkg_path // meta) in
83 let m = Library_names.process_meta_file full_meta_path in
84 let d' =
85 List.fold_left
86 (fun acc lib ->
87 Util.StringMap.add lib.Library_names.name
88 (Util.StringSet.of_list ("stdlib" :: lib.Library_names.deps))
89 acc)
90 d m.libraries
91 in
92 let c' =
93 List.fold_left
94 (fun acc (lib : Library_names.library) ->
95 match (lib.archive_name, lib.dir) with
96 | None, Some dir ->
97 Logs.debug (fun m -> m "Found cmi_only_lib in dir: %s" dir);
98 (Fpath.(m.meta_dir / dir), lib.name) :: acc
99 | None, None -> acc
100 | Some _, _ -> acc)
101 c m.libraries
102 in
103 (d', c'))
104 (Util.StringMap.empty, []) metas
105 in
106
107 let ss_pp fmt ss = Format.fprintf fmt "[%d]" (Util.StringSet.cardinal ss) in
108 Logs.debug (fun m ->
109 m "all_lib_deps: %a\n%!"
110 Fmt.(list ~sep:comma (pair ~sep:comma string ss_pp))
111 (Util.StringMap.bindings all_lib_deps));
112
113 let docs = Opam.classify_docs pkg_path (Some pkg.name) pkg.files in
114 let mlds, assets, other_docs = Packages.mk_mlds docs in
115
116 let config =
117 let config_file =
118 Fpath.(pkg_path / "doc" / pkg.name / "odoc-config.sexp")
119 in
120 match Bos.OS.File.read config_file with
121 | Error (`Msg msg) ->
122 Logs.debug (fun m ->
123 m "No config file found: %a\n%s\n%!" Fpath.pp config_file msg);
124 Global_config.empty
125 | Ok s ->
126 Logs.debug (fun m -> m "Config file: %a\n%!" Fpath.pp config_file);
127 Global_config.parse s
128 in
129
130 Logs.debug (fun m ->
131 m "Config.packages: %s\n%!" (String.concat ", " config.deps.packages));
132 let meta_libraries : Packages.libty list =
133 metas
134 |> List.filter_map (fun meta_file ->
135 let full_meta_path = Fpath.(pkg_path // meta_file) in
136 let m = Library_names.process_meta_file full_meta_path in
137 let libname_of_archive = Library_names.libname_of_archive m in
138 Fpath.Map.iter
139 (fun k v -> Logs.debug (fun m -> m "%a,%s\n%!" Fpath.pp k v))
140 libname_of_archive;
141
142 let directories = Library_names.directories m in
143 Some
144 (List.concat_map
145 (fun directory ->
146 Logs.debug (fun m ->
147 m "Processing directory: %a\n%!" Fpath.pp directory);
148 Packages.Lib.v ~libname_of_archive ~pkg_name:pkg.name
149 ~dir:directory ~cmtidir:None ~all_lib_deps ~cmi_only_libs
150 ~id_override:None)
151 Fpath.(Set.to_list directories)))
152 |> List.flatten
153 in
154
155 (* Check the main package lib directory even if there's no meta file *)
156 let non_meta_libraries =
157 let libdirs_without_meta =
158 List.filter
159 (fun p ->
160 match Fpath.segs p with
161 | "lib" :: _ :: _
162 when Sys.is_directory Fpath.(pkg_path // p |> to_string) ->
163 not
164 (List.exists
165 (fun lib ->
166 Fpath.equal
167 Fpath.(to_dir_path lib.Packages.dir)
168 Fpath.(to_dir_path (pkg_path // p)))
169 meta_libraries)
170 | _ -> false)
171 pkg.files
172 in
173
174 Logs.debug (fun m ->
175 m "libdirs_without_meta: %a\n%!"
176 Fmt.(list ~sep:comma Fpath.pp)
177 (List.map (fun p -> Fpath.(pkg_path // p)) libdirs_without_meta));
178
179 Logs.debug (fun m ->
180 m "lib dirs: %a\n%!"
181 Fmt.(list ~sep:comma Fpath.pp)
182 (List.map (fun (lib : Packages.libty) -> lib.dir) meta_libraries));
183
184 List.map
185 (fun libdir ->
186 let libname_of_archive =
187 libname_of_archives_of_dir Fpath.(pkg_path // libdir)
188 in
189 Logs.debug (fun m ->
190 m "Processing directory without META: %a" Fpath.pp libdir);
191 Packages.Lib.v ~libname_of_archive ~pkg_name:pkg.name
192 ~dir:Fpath.(pkg_path // libdir)
193 ~cmtidir:None ~all_lib_deps ~cmi_only_libs:[] ~id_override:None)
194 libdirs_without_meta
195 |> List.flatten
196 in
197 let libraries = meta_libraries @ non_meta_libraries in
198 let pkg_dir = top_dir pkg in
199 let doc_dir = Fpath.(pkg_dir / "doc") in
200 let result =
201 {
202 Packages.name = pkg.name;
203 version = pkg.version;
204 libraries;
205 mlds;
206 assets;
207 selected = true;
208 remaps = [];
209 other_docs;
210 pkg_dir;
211 doc_dir;
212 config;
213 }
214 in
215 result
216
217let pp ppf v =
218 Format.fprintf ppf "n: %s v: %s u: %s [\n" v.name v.version v.universe;
219 List.iter (fun fp -> Format.fprintf ppf "%a\n" Fpath.pp fp) v.files;
220 Format.fprintf ppf "]\n%!"
221
222let () = ignore pp
223
224let find_pkg pkg_name ~blessed =
225 let contents =
226 Bos.OS.Dir.fold_contents ~dotfiles:true
227 (fun p acc -> p :: acc)
228 []
229 Fpath.(v !prep_path)
230 in
231 match contents with
232 | Error _ -> None
233 | Ok c -> (
234 let sorted = List.sort (fun p1 p2 -> Fpath.compare p1 p2) c in
235 let last, packages =
236 List.fold_left
237 (fun (cur_opt, acc) file ->
238 match Fpath.segs file with
239 | "prep" :: "universes" :: u :: p :: v :: (_ :: _ as rest)
240 when p = pkg_name -> (
241 let file = Fpath.v (Astring.String.concat ~sep:"/" rest) in
242 match cur_opt with
243 | Some cur
244 when cur.name = p && cur.version = v && cur.universe = u ->
245 (Some { cur with files = file :: cur.files }, acc)
246 | _ ->
247 ( Some
248 {
249 name = p;
250 version = v;
251 universe = u;
252 blessed;
253 files = [ file ];
254 },
255 cur_opt :: acc ))
256 | _ -> (cur_opt, acc))
257 (None, []) sorted
258 in
259 let packages = List.filter_map (fun x -> x) (last :: packages) in
260 match packages with
261 | [ package ] -> Some package
262 | [] ->
263 Logs.err (fun m -> m "No package found for %s" pkg_name);
264 None
265 | _ ->
266 Logs.err (fun m -> m "Multiple packages found for %s" pkg_name);
267 None)
268
269let occurrence_file_of_pkg pkg =
270 let top_dir = top_dir pkg in
271 Fpath.(top_dir / "occurrences-all.odoc-occurrences")
272
273type extra_paths = {
274 pkgs : Fpath.t Util.StringMap.t;
275 libs : Fpath.t Util.StringMap.t;
276 libs_of_pkg : string list Util.StringMap.t;
277}
278
279let empty_extra_paths =
280 {
281 pkgs = Util.StringMap.empty;
282 libs = Util.StringMap.empty;
283 libs_of_pkg = Util.StringMap.empty;
284 }
285
286let extra_paths compile_dir =
287 let contents =
288 Bos.OS.Dir.fold_contents ~dotfiles:true
289 (fun p acc -> p :: acc)
290 [] compile_dir
291 in
292 let add_libs pkgname libname libs_of_pkg =
293 Util.StringMap.update pkgname
294 (function None -> Some [ libname ] | Some l -> Some (libname :: l))
295 libs_of_pkg
296 in
297 let pkgs, libs, libs_of_pkg =
298 match contents with
299 | Error _ ->
300 (Util.StringMap.empty, Util.StringMap.empty, Util.StringMap.empty)
301 | Ok c ->
302 List.fold_left
303 (fun (pkgs, libs, libs_of_pkg) abs_path ->
304 let path = Fpath.rem_prefix compile_dir abs_path |> Option.get in
305 match Fpath.segs path with
306 | [ "p"; pkg; _version; "doc"; libname; l ] when l = lib_marker ->
307 Logs.debug (fun m -> m "Found lib marker: %a" Fpath.pp path);
308 ( pkgs,
309 Util.StringMap.add libname (Fpath.parent path) libs,
310 add_libs pkg libname libs_of_pkg )
311 | [ "p"; pkg; _version; "doc"; l ] when l = pkg_marker ->
312 Logs.debug (fun m -> m "Found pkg marker: %a" Fpath.pp path);
313 ( Util.StringMap.add pkg (Fpath.parent path) pkgs,
314 libs,
315 libs_of_pkg )
316 | [ "u"; _universe; pkg; _version; "doc"; libname; l ]
317 when l = lib_marker ->
318 Logs.debug (fun m -> m "Found lib marker: %a" Fpath.pp path);
319 ( pkgs,
320 Util.StringMap.add libname (Fpath.parent path) libs,
321 add_libs pkg libname libs_of_pkg )
322 | [ "u"; _universe; pkg; _version; "doc"; l ] when l = pkg_marker ->
323 Logs.debug (fun m -> m "Found pkg marker: %a" Fpath.pp path);
324 ( Util.StringMap.add pkg (Fpath.parent path) pkgs,
325 libs,
326 libs_of_pkg )
327 | _ -> (pkgs, libs, libs_of_pkg))
328 (Util.StringMap.empty, Util.StringMap.empty, Util.StringMap.empty)
329 c
330 in
331 { pkgs; libs; libs_of_pkg }
332
333let write_lib_markers odoc_dir pkgs =
334 let write file str =
335 match Bos.OS.File.write file str with
336 | Ok () -> ()
337 | Error (`Msg msg) ->
338 Logs.err (fun m -> m "Failed to write lib marker: %s" msg)
339 in
340 List.iter
341 (fun (pkg : Packages.t) ->
342 let libs = pkg.libraries in
343 let pkg_path = Odoc_unit.doc_dir pkg in
344 let marker = Fpath.(odoc_dir // pkg_path / pkg_marker) in
345 write marker
346 (Fmt.str
347 "This marks this directory as the location of odoc files for the \
348 package %s"
349 pkg.name);
350
351 List.iter
352 (fun (lib : Packages.libty) ->
353 let lib_dir = Odoc_unit.lib_dir pkg lib in
354 let marker = Fpath.(odoc_dir // lib_dir / lib_marker) in
355 write marker
356 (Fmt.str
357 "This marks this directory as the location of odoc files for \
358 library %s in package %s"
359 lib.lib_name pkg.name))
360 libs)
361 pkgs