jon.recoil.org
this repo has no description
1open Bos
2
3let opam = Cmd.v "opam"
4
5type package = { name : string; version : string }
6
7let pp fmt p = Format.fprintf fmt "%s.%s" p.name p.version
8
9let memoize f =
10 let r = ref None in
11 fun () ->
12 match !r with
13 | Some x -> x
14 | None ->
15 let x = f () in
16 r := Some x;
17 x
18
19let get_switch =
20 memoize @@ fun () ->
21 Util.lines_of_process Cmd.(opam % "switch" % "show") |> List.hd
22
23let prefix =
24 memoize @@ fun () ->
25 Util.lines_of_process
26 Cmd.(opam % "var" % "--switch" % get_switch () % "prefix")
27 |> List.hd
28
29let all_opam_packages =
30 memoize @@ fun () ->
31 let prefix = prefix () in
32 match Bos.OS.Dir.contents Fpath.(v prefix / ".opam-switch" / "packages") with
33 | Error (`Msg msg) ->
34 Logs.err (fun m -> m "Error listing opam packages: %s" msg);
35 []
36 | Ok contents ->
37 List.filter_map
38 (fun p ->
39 let name = Fpath.basename p in
40 match Astring.String.cut ~sep:"." name with
41 | Some (name, version) -> Some { name; version }
42 | None -> None)
43 contents
44
45let pkg_contents { name; _ } =
46 let prefix = Fpath.v (prefix ()) in
47 let changes_file =
48 Format.asprintf "%a/.opam-switch/install/%s.changes" Fpath.pp prefix name
49 in
50 let file = OpamFilename.raw changes_file in
51 let filename =
52 OpamFile.make @@ OpamFilename.raw @@ Filename.basename changes_file
53 in
54 let changed =
55 try
56 OpamFilename.with_contents
57 (fun str ->
58 OpamFile.Changes.read_from_string ~filename
59 @@
60 (* Field [opam-version] is invalid in [*.changes] files, displaying a warning. *)
61 if String.starts_with ~prefix:"opam-version" str then
62 match OpamStd.String.cut_at str '\n' with
63 | Some (_, str) -> str
64 | None -> assert false
65 else str)
66 file
67 with
68 | OpamSystem.File_not_found s ->
69 Logs.err (fun m ->
70 m "File not found: %s.\n%s\nConsidering it empty." changes_file s);
71 OpamStd.String.Map.empty
72 | OpamPp.Bad_version _ ->
73 Logs.err (fun m ->
74 m "Bad version while parsing %s.\nConsidering it empty."
75 changes_file);
76 OpamStd.String.Map.empty
77 | OpamPp.Bad_format _ ->
78 Logs.err (fun m ->
79 m "Bad format while parsing %s.\nConsidering it empty." changes_file);
80 OpamStd.String.Map.empty
81 in
82 let added =
83 OpamStd.String.Map.fold
84 (fun file x acc ->
85 match x with
86 | OpamDirTrack.Added _ -> (
87 try
88 if not @@ Sys.is_directory Fpath.(to_string (prefix // v file))
89 then file :: acc
90 else acc
91 with _ ->
92 acc
93 (* dose (and maybe others) sometimes creates a symlink to something that doesn't exist *)
94 )
95 | _ -> acc)
96 changed []
97 in
98 List.map Fpath.v added
99
100let deps pkgs =
101 let cmd =
102 Cmd.(
103 opam % "list" % "--recursive" % "-i" % "--columns" % "package" % "--color"
104 % "never" % "-s" % "--or")
105 in
106 let cmd =
107 List.fold_left (fun cmd pkg -> Cmd.(cmd % "--required-by" % pkg)) cmd pkgs
108 in
109 let out = Util.lines_of_process cmd in
110 List.filter_map
111 (fun x ->
112 match Astring.String.cut ~sep:"." x with
113 | Some (name, version) -> Some { name; version }
114 | None -> None)
115 out
116
117type doc_file = {
118 kind : [ `Mld | `Asset | `Other ];
119 file : Fpath.t;
120 rel_path : Fpath.t;
121}
122
123let pp_doc_file fmt { kind; file; rel_path } =
124 Format.fprintf fmt "kind: %a@,file: %a@,rel_path: %a@,"
125 (Fmt.of_to_string (function
126 | `Mld -> "`Mld"
127 | `Asset -> "`Asset"
128 | `Other -> "`Other"))
129 kind Fpath.pp file Fpath.pp rel_path
130
131type installed_files = {
132 libs : Fpath.set;
133 docs : doc_file list;
134 odoc_config : Fpath.t option;
135}
136
137type package_of_fpath = package Fpath.map
138
139(* Here we use an associative list *)
140type fpaths_of_package = (package * installed_files) list
141
142let pp_fpath_set fmt set =
143 Fpath.Set.iter (Format.fprintf fmt "%a@." Fpath.pp) set
144
145let pp_fpaths_of_package fmt l =
146 List.iter
147 (fun (p, { libs; docs; odoc_config }) ->
148 Format.fprintf fmt "%a:@,libs: %a@,docs: %a@,odoc_config: %a@," pp p
149 pp_fpath_set libs
150 Fmt.Dump.(list pp_doc_file)
151 docs (Fmt.option Fpath.pp) odoc_config)
152 l
153
154let classify_docs prefix only_package contents =
155 let pkg_match pkg =
156 match only_package with None -> true | Some p -> p = pkg
157 in
158
159 let is_dir f =
160 try Sys.is_directory (Fpath.to_string f) with Sys_error _ -> false
161 in
162
163 List.fold_left
164 (fun acc fpath ->
165 match Fpath.segs fpath with
166 | "doc" :: pkg :: "odoc-pages" :: _ :: _
167 when pkg_match pkg && not (is_dir Fpath.(prefix // fpath)) ->
168 Logs.debug (fun m -> m "Found odoc page: %a" Fpath.pp fpath);
169 let kind =
170 match Fpath.get_ext fpath with ".mld" -> `Mld | _ -> `Asset
171 in
172 let rel_path =
173 Fpath.rem_prefix Fpath.(v "doc" / pkg / "odoc-pages") fpath
174 |> Option.get
175 in
176 { kind; file = Fpath.(prefix // fpath); rel_path } :: acc
177 | "doc" :: pkg :: "odoc-assets" :: _ :: _
178 when pkg_match pkg && not (is_dir Fpath.(prefix // fpath)) ->
179 Logs.debug (fun m -> m "Found odoc page: %a" Fpath.pp fpath);
180 let rel_path =
181 Fpath.rem_prefix Fpath.(v "doc" / pkg / "odoc-assets") fpath
182 |> Option.get
183 in
184 let rel_path = Fpath.(v "_assets" // rel_path) in
185 { kind = `Asset; file = Fpath.(prefix // fpath); rel_path } :: acc
186 | [ "doc"; pkg; _ ]
187 when pkg_match pkg && not (is_dir Fpath.(prefix // fpath)) ->
188 Logs.debug (fun m -> m "Found other doc: %a" Fpath.pp fpath);
189 let rel_path = Fpath.base fpath in
190 { kind = `Other; file = Fpath.(prefix // fpath); rel_path } :: acc
191 | _ -> acc)
192 [] contents
193
194let classify_libs prefix only_package contents =
195 let pkg_match pkg =
196 match only_package with None -> true | Some p -> p = pkg
197 in
198
199 let libs =
200 List.fold_left
201 (fun set fpath ->
202 match Fpath.segs fpath with
203 | "lib" :: "stublibs" :: _ -> set
204 | "lib" :: pkg :: _ :: _
205 when Fpath.has_ext ".cmi" fpath && pkg_match pkg ->
206 Fpath.Set.add Fpath.(prefix // fpath |> split_base |> fst) set
207 | _ -> set)
208 Fpath.Set.empty contents
209 in
210 libs
211
212let find_odoc_config prefix only_package contents =
213 let pkg_match pkg =
214 match only_package with None -> true | Some p -> p = pkg
215 in
216
217 let opt =
218 List.find_opt
219 (fun fpath ->
220 match Fpath.segs fpath with
221 | [ "doc"; pkg; "odoc-config.sexp" ] -> pkg_match pkg
222 | _ -> false)
223 contents
224 in
225
226 Option.map (fun p -> Fpath.(prefix // p)) opt
227
228let dune_overrides () =
229 let ocamlpath = Sys.getenv_opt "OCAMLPATH" in
230 match ocamlpath with
231 | None -> []
232 | Some path -> (
233 (* OCAMLPATH is set in dune to be e.g. /Users/jon/odoc/_build/install/default/lib *)
234 (* Let's strip the 'lib' off and we can find the installed files *)
235 let path = Fpath.v path in
236 match Fpath.segs path |> List.rev with
237 | "lib" :: _ :: "install" :: "_build" :: _ -> (
238 (* Check it's of the right form *)
239 let base = Fpath.split_base path |> fst in
240 let contents =
241 Bos.OS.Dir.fold_contents
242 (fun x acc ->
243 match Fpath.relativize ~root:base x with
244 | None -> acc
245 | Some r -> r :: acc)
246 [] base
247 in
248 match contents with
249 | Ok contents ->
250 Logs.debug (fun m ->
251 m "dune install contents: %a"
252 Fmt.(Dump.list Fpath.pp)
253 contents);
254 let packages =
255 List.fold_left
256 (fun acc fpath ->
257 match Fpath.segs fpath with
258 | "lib" :: pkg :: _ :: _ -> Util.StringSet.add pkg acc
259 | "doc" :: pkg :: _ :: _ -> Util.StringSet.add pkg acc
260 | _ -> acc)
261 Util.StringSet.empty contents
262 in
263
264 Logs.debug (fun m ->
265 m "Found packages: %a"
266 Fmt.(Dump.list string)
267 (Util.StringSet.elements packages));
268 Util.StringSet.fold
269 (fun pkg acc ->
270 let libs = classify_libs base (Some pkg) contents in
271 let docs = classify_docs base (Some pkg) contents in
272 let odoc_config = find_odoc_config base (Some pkg) contents in
273 Logs.debug (fun m ->
274 m "pkg %s Found %d docs" pkg (List.length docs));
275 ({ name = pkg; version = "dev" }, { libs; docs; odoc_config })
276 :: acc)
277 packages []
278 | Error (`Msg msg) ->
279 Logs.err (fun m ->
280 m "Error listing dune install directory: %s" msg);
281 [])
282 | _ -> [])
283
284let check pkgs =
285 let cmd =
286 Cmd.(
287 opam % "list" % "-i" % "--columns" % "package" % "--color" % "never"
288 % "-s")
289 in
290 let cmd = List.fold_left Cmd.( % ) cmd pkgs in
291 let out = Util.lines_of_process cmd in
292 let res =
293 List.filter_map
294 (fun x ->
295 match Astring.String.cut ~sep:"." x with
296 | Some (name, _version) -> Some name
297 | None -> None)
298 out
299 in
300 let missing = Util.StringSet.(diff (of_list pkgs) (of_list res)) in
301 let dune_pkgnames =
302 Util.StringSet.of_list (List.map (fun (p, _) -> p.name) (dune_overrides ()))
303 in
304 let missing = Util.StringSet.diff missing dune_pkgnames in
305 if Util.StringSet.cardinal missing = 0 then Ok () else Error missing
306
307let pkg_to_dir_map () =
308 let dune_overrides = dune_overrides () in
309 let pkgs = all_opam_packages () in
310 let prefix = prefix () in
311 let pkg_content =
312 List.map
313 (fun p ->
314 let contents = pkg_contents p in
315 let libs = classify_libs (Fpath.v prefix) None contents in
316 let docs = classify_docs (Fpath.v prefix) None contents in
317 let odoc_config = find_odoc_config (Fpath.v prefix) None contents in
318 (p, { libs; docs; odoc_config }))
319 pkgs
320 in
321
322 (* Remove anything from opam that is present in the dune overrides *)
323 let pkg_content =
324 List.filter
325 (fun (p, _) ->
326 not @@ List.exists (fun (p', _) -> p.name = p'.name) dune_overrides)
327 pkg_content
328 in
329
330 let pkg_content = pkg_content @ dune_overrides in
331
332 let map =
333 List.fold_left
334 (fun map (p, { libs; _ }) ->
335 Fpath.Set.fold
336 (fun dir map ->
337 Fpath.Map.update dir
338 (function
339 | None -> Some p
340 | Some x ->
341 Logs.debug (fun m ->
342 m "Multiple packages (%a,%a) found for dir %a" pp x pp p
343 Fpath.pp dir);
344 Some p)
345 map)
346 libs map)
347 Fpath.Map.empty pkg_content
348 in
349 Logs.debug (fun m -> m "pkg_to_dir_map: %a" pp_fpaths_of_package pkg_content);
350 (pkg_content, map)