jon.recoil.org
this repo has no description
1let init =
2 let initialized = ref false in
3 fun () ->
4 if !initialized then ()
5 else
6 let prefix = Opam.prefix () in
7 let env_camllib = Fpath.(v prefix / "lib" / "ocaml" |> to_string) in
8 let config = Fpath.(v prefix / "lib" / "findlib.conf" |> to_string) in
9 Findlib.init ~config ~env_camllib ()
10
11let all () =
12 init ();
13 Fl_package_base.list_packages ()
14
15let get_dir lib =
16 try
17 init ();
18 Fl_package_base.query lib |> fun x ->
19 Ok Fpath.(v x.package_dir |> to_dir_path)
20 with e ->
21 Logs.err (fun m -> m "Error: %s\n" (Printexc.to_string e));
22 Error (`Msg "Error getting directory")
23
24let archives pkg =
25 init ();
26 let package = Fl_package_base.query pkg in
27 let get_1 preds =
28 try
29 [
30 Fl_metascanner.lookup "archive" preds
31 package.Fl_package_base.package_defs;
32 ]
33 with _ -> []
34 in
35 match pkg with
36 | "stdlib" -> [ "stdlib.cma"; "stdlib.cmxa" ]
37 | _ ->
38 get_1 [ "native" ] @ get_1 [ "byte" ]
39 @ get_1 [ "native"; "ppx_driver" ]
40 @ get_1 [ "byte"; "ppx_driver" ]
41 |> List.filter (fun x -> String.length x > 0)
42 |> List.sort_uniq String.compare
43
44let sub_libraries top =
45 init ();
46 let packages = Fl_package_base.list_packages () in
47 List.fold_left
48 (fun acc lib ->
49 let package = String.split_on_char '.' lib |> List.hd in
50 if package = top then Util.StringSet.add lib acc else acc)
51 Util.StringSet.empty packages
52
53(* Returns deep dependencies for the given package *)
54let rec dep =
55 let memo = ref Util.StringMap.empty in
56 fun pkg ->
57 init ();
58 try Util.StringMap.find pkg !memo
59 with Not_found -> (
60 try
61 let deps = Fl_package_base.requires ~preds:[ "ppx_driver" ] pkg in
62 let result =
63 List.fold_left
64 (fun acc x ->
65 match dep x with
66 | Ok dep_deps -> Util.StringSet.(union acc (add x dep_deps))
67 | Error _ -> acc)
68 Util.StringSet.empty deps
69 in
70 memo := Util.StringMap.add pkg (Ok result) !memo;
71 Ok result
72 with e ->
73 let result = Error (`Msg (Printexc.to_string e)) in
74 memo := Util.StringMap.add pkg result !memo;
75 result)
76
77let deps pkgs =
78 let results = List.map dep pkgs in
79 Ok
80 (List.fold_left Util.StringSet.union
81 (Util.StringSet.singleton "stdlib")
82 (List.map (Result.value ~default:Util.StringSet.empty) results))
83
84module Db = struct
85 type t = {
86 all_libs : Util.StringSet.t;
87 all_lib_deps : Util.StringSet.t Util.StringMap.t;
88 lib_dirs_and_archives : (string * Fpath.t * Util.StringSet.t) list;
89 archives_by_dir : Util.StringSet.t Fpath.map;
90 libname_of_archive : string Fpath.map;
91 cmi_only_libs : (Fpath.t * string) list;
92 }
93
94 let create libs =
95 let _ = Opam.prefix () in
96 let libs = Util.StringSet.to_seq libs |> List.of_seq in
97
98 (* First, find the complete set of libraries - that is, including all of
99 the dependencies of the libraries supplied on the commandline *)
100 let all_libs_deps =
101 match deps libs with
102 | Error (`Msg msg) ->
103 Logs.err (fun m -> m "Error finding dependencies: %s" msg);
104 Util.StringSet.empty
105 | Ok libs -> Util.StringSet.add "stdlib" libs
106 in
107
108 let all_libs_set =
109 Util.StringSet.union all_libs_deps (Util.StringSet.of_list libs)
110 in
111 let all_libs = Util.StringSet.elements all_libs_set in
112
113 (* Now we need the dependency tree of those libraries *)
114 let all_lib_deps =
115 List.fold_right
116 (fun lib_name acc ->
117 match deps [ lib_name ] with
118 | Ok deps -> Util.StringMap.add lib_name deps acc
119 | Error (`Msg msg) ->
120 Logs.err (fun m ->
121 m
122 "Error finding dependencies of library '%s' through \
123 ocamlfind: %s"
124 lib_name msg);
125 acc)
126 all_libs Util.StringMap.empty
127 in
128
129 (* We also need to find, for each library, the library directory and
130 the list of archives for that library *)
131 let lib_dirs_and_archives =
132 List.filter_map
133 (fun lib ->
134 match get_dir lib with
135 | Error _ ->
136 Logs.err (fun m -> m "No dir for library %s" lib);
137 None
138 | Ok p ->
139 let archives = archives lib in
140 let archives =
141 List.map
142 (fun x ->
143 try Filename.chop_extension x
144 with e ->
145 Logs.err (fun m -> m "Can't chop extension from %s" x);
146 raise e)
147 archives
148 in
149 let archives = Util.StringSet.(of_list archives) in
150 Some (lib, p, archives))
151 all_libs
152 in
153
154 (* An individual directory may contain multiple libraries, each with
155 zero or more archives. We need to know which directories contain
156 which archives *)
157 let archives_by_dir =
158 List.fold_left
159 (fun set (_lib, p, archives) ->
160 Fpath.Map.update p
161 (function
162 | Some set -> Some (Util.StringSet.union set archives)
163 | None -> Some archives)
164 set)
165 Fpath.Map.empty lib_dirs_and_archives
166 in
167
168 (* Compute the mapping between full path of an archive to the
169 name of the libary *)
170 let libname_of_archive =
171 List.fold_left
172 (fun map (lib, dir, archives) ->
173 match Util.StringSet.elements archives with
174 | [] -> map
175 | [ archive ] ->
176 Fpath.Map.update
177 Fpath.(dir / archive)
178 (function
179 | None -> Some lib
180 | Some x ->
181 Logs.info (fun m ->
182 m
183 "Multiple libraries for archive %s: %s and %s. \
184 Arbitrarily picking the latter."
185 archive x lib);
186 Some lib)
187 map
188 | xs ->
189 Logs.err (fun m ->
190 m "multiple archives detected: [%a]"
191 Fmt.(list ~sep:sp string)
192 xs);
193 assert false)
194 Fpath.Map.empty lib_dirs_and_archives
195 in
196
197 (* We also need to know about libraries that have no archives at all
198 (these are virtual libraries usually) *)
199 let cmi_only_libs =
200 List.fold_left
201 (fun map (lib, dir, archives) ->
202 match Util.StringSet.elements archives with
203 | [] -> (dir, lib) :: map
204 | _ -> map)
205 [] lib_dirs_and_archives
206 in
207 {
208 all_libs = all_libs_set;
209 all_lib_deps;
210 lib_dirs_and_archives;
211 archives_by_dir;
212 libname_of_archive;
213 cmi_only_libs;
214 }
215end