forked from camlspotter/ocamloscope
-
Notifications
You must be signed in to change notification settings - Fork 0
/
oCamlFind.ml
401 lines (338 loc) · 12.1 KB
/
oCamlFind.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
open Spotlib.Spot
open List
open Ppx_orakuda
module Scanner = Fl_metascanner
module Package = struct
type raw = Fl_package_base.package =
{ package_name : string;
package_dir : string;
package_defs : Scanner.pkg_definition list;
package_priv : Fl_package_base.package_priv
}
type t = {
name : string;
dir : string;
defs : (string * string) list
} [@@deriving conv{ocaml}]
let convert t =
{ name = t.package_name;
dir = t.package_dir;
defs = map (fun def -> def.Scanner.def_var, def.Scanner.def_value) t.package_defs }
let name p = p.name
let find_var v p = assoc_opt v p.defs
let version = find_var "version"
let requires p =
match find_var "requires" p with
| None -> None
| Some s -> Some (Regexp.split {m|[\s,]+|m} s)
let top_name p =
match String.split1 (function '.' -> true | _ -> false) p.name with
| Some (x,_) -> x
| None -> p.name
let is_distributed_with_ocaml p =
version p = Some "[distributed with Ocaml]"
(* Wierd hack for "distributed with Ocaml" things
META for the packages from OCaml distribution contains
a strange field browse_interfaces. It is a very strnage string
but helps to know which modules belong to which base package.
*)
let parse_browse_interfaces p =
find_var "browse_interfaces" p
|> Option.map (fun v ->
filter_map (fun s ->
let s = {s|\s//g|s} s in
match s with
| "" -> None
| _ -> Some s)
& Regexp.split {m| Unit name: |m} v)
let has_browse_interfaces p =
exists (fun (k,_) -> k = "browse_interfaces") p.defs
let is_top p = not & String.contains p.name '.'
let group ps =
let tbl = Hashtbl.create 107 in
iter (fun p -> Hashtbl.alter tbl (top_name p) (function
| None -> Some [p]
| Some ps -> Some (p::ps))) ps;
tbl
end
type ocamlfind = unit
let init () = Findlib.init ()
let get_packages () =
map (Fl_package_base.query *> Package.convert) & Fl_package_base.list_packages ()
let get_stdlib_dir () = Findlib.ocaml_stdlib ()
type modules = {
targets : (Module_path.t * Cmfile.CMIDigest.t) list;
reachable_tops : (Module_path.t * string list (** module name *) * Cmfile.CMIDigest.t option) list
} [@@deriving conv{ocaml}]
let scan_installed_files =
(* almost of all the subpackages use the same dir of its parents. So memoizing is required. *)
let f dir =
let res = ref [] in
Unix.Find.find [dir] ~f:(fun path ->
match Filename.split_extension path#base with
| _body, "" -> ()
| _body, dot_ext ->
res := (path#path, Module_path.of_path path#path, dot_ext) :: !res);
!res
in
let f = memoize f in
fun p -> f & p.Package.dir
let installed_cmi_resolver p =
let tbl =
scan_installed_files p
|> filter_map (fun (_path, mpath, ext) ->
match ext with
| ".cmi" ->
begin match Cmfile.cmi_md5 mpath with
| Some (_, digest) -> Some ((Module_path.modname mpath, digest), mpath)
| None -> !!% "???: %s@." & Module_path.to_string mpath; assert false
end
| _ -> None)
|> Hashtbl.of_list 107
in
fun ~modname ~digest -> Hashtbl.find_opt tbl (modname, digest)
(* META directory thing
directory = "^" for stdlib dir
./compiler-libs/META:directory= "+compiler-libs"
./threads/META: directory = "+vmthreads"
./threads/META: directory = "+threads"
./ocamlbuild/META:directory= "^ocamlbuild"
./eliom/META:directory = "server"
./eliom/META:directory = "client"
./eliom/META:directory = "syntax"
*)
(* This does not really find mli only module but cmis w/o values.
But even if such a module has ml and cmo, it can be accessed
from other packages as an mli only module, so it is ok.
*)
let find_mli_only_module = memoize & fun dir ->
let found = ref [] in
let open Infix in
(* !!% "Finding mli only module in %s...@." dir; *)
Unix.Find.(find [dir] ~f:(fun path ->
if path#is_dir && path#depth > 0 then prune ()
else if String.is_postfix ".cmi" path#base then
if Cmfile.cmi_without_value path#path then
(* CR jfuruse: double read of cmi files *)
let mpath = Module_path.of_path path#path in
(* CR jfuruse: it is redundant. *)
let cmi_md5 = match Cmfile.cmi_md5 mpath with
| None -> assert false
| Some (_, d) -> d
in
found +::= (mpath, cmi_md5)
else ()
else ()));
!found
|-
iter (fun (mpath, _) ->
!!% "mli only module: %s@." & Module_path.to_string mpath)
(* CR jfuruse: BUG: mli only modules are ignored by this method.
*)
let get_modules build_table ~stdlib_dir p =
Util.with_ocamled_cache
~encoder: ocaml_of_modules
~decoder: modules_of_ocaml
(Conf.data_dir ^/ "ocamlfind_" ^ p.Package.name ^ ".bin") & fun () ->
!!% "Scanning OCamlFind package %s...@." p.Package.name;
let defs = p.Package.defs in
let dir = p.Package.dir in
let targets, mpath_md5s =
(* stdlib_dir is "contaminated", so we need a special handling *)
if p.dir = stdlib_dir then begin
match Package.parse_browse_interfaces p with
| None -> assert false
| Some modules ->
!!% "%s is with browse interface list@." & p.Package.name;
let mpath_md5s =
filter_map (fun n ->
let mpath = Module_path.of_string & stdlib_dir ^/ n in
match Cmfile.cmi_md5 mpath with
| None ->
(* lib/ocaml/arith_flags.cmi is not installed,
while there is arith_flags.cmx!
*)
(* CR jfuruse:
Warning: No cmi file for /../lib/ocaml/Condition
Warning: No cmi file for /../lib/ocaml/Event
Warning: No cmi file for /../lib/ocaml/Mutex
Warning: No cmi file for /../lib/ocaml/Thread
Warning: No cmi file for /../lib/ocaml/ThreadUnix
*)
!!% "Warning: No cmi file for %s@." & Module_path.to_string mpath;
None
| Some (_path, d) -> Some (mpath, d))
modules
in
mpath_md5s,
map (fun (mpath,digest) ->
mpath, [ Module_path.modname mpath ], Some digest) mpath_md5s
end else begin
assert (p.Package.name <> "stdlib");
let files_in_archive =
(
filter_map (fun (k,v) ->
if k = "archive" then Some v else None) defs
|> concat_map (String.split (function ' ' -> true | _ -> false))
|> map (fun s -> dir ^/ s)
)
in
let resolver = installed_cmi_resolver p in
Cmfile.load_archive build_table resolver files_in_archive
end
in
let mli_only_modules =
(* Special handling of stdlib dir *)
if dir = stdlib_dir && p.Package.name <> "stdlib" then []
else find_mli_only_module dir
in
let targets = unique & targets @ mli_only_modules in
let reachable_tops = unique (mpath_md5s @ map (fun (m,d) -> m, [ Module_path.modname m], Some d) mli_only_modules) in
{ targets; reachable_tops }
|- fun _ ->
if Conf.show_scanned_ocamlfind_module_list then begin
iter (fun (mpath, md5) ->
!!% " %s %s@." (Cmfile.CMIDigest.to_string md5) (Module_path.to_string mpath)) targets;
iter (fun (mpath, ml_path, md5) ->
!!% " TOPS: %s %s %s@."
(match md5 with Some md5 -> Cmfile.CMIDigest.to_string md5 | None -> "--------------------------------")
(String.concat "." ml_path)
(Module_path.to_string mpath)) reachable_tops
end
(*
|- fun _ ->
!!% " targets=%d tops=%d@."
(length targets) (length mpath_md5s)
*)
(*
|- fun { reachable_tops } ->
!!% "@[<2>SCAN %s:@ @[<v>%a@]@]@."
p.Package.Package.name
Format.(list "@," (fun ppf (mpath, dopt) ->
fprintf ppf "%s: %s"
(match dopt with
| None -> "NO MD5"
| Some d -> Digest.to_hex d)
(Module_path.to_string mpath))) reachable_tops
*)
let make_cmi_md5_packages_tbl xs =
let tbl = Hashtbl.create 1023 in
flip iter xs (fun (p, { reachable_tops= mpath_md5_list }) ->
flip iter mpath_md5_list & fun (mpath, ml_path, md5) ->
Hashtbl.alter tbl (Module_path.modname mpath, md5) (function
| None -> Some [p, ml_path]
| Some ps -> Some ((p, ml_path)::ps)));
tbl
let find_packages modules =
let cmi_md5_packages_tbl = make_cmi_md5_packages_tbl modules in
fun path ->
try
let mpath = Module_path.of_path path in
match Cmfile.cmi_md5 mpath with
| None ->
!!% "Warning: No cmi for %s@." path;
None
| Some (_p, md5) ->
let modname = Module_path.modname mpath in
begin try
match Hashtbl.find cmi_md5_packages_tbl (modname, Some md5) with
| [] ->
!!% "Warning: %s:%s in cmi_md5_packages_tbl but = []@." path (Cmfile.CMIDigest.to_string md5);
assert false
| v -> Some v
with
| Not_found ->
(* the same cmi was not found in OCamlFind installation directory *)
!!% "Warning: No OCamlFind package (therefore inaccessible) for %s %s@." (Cmfile.CMIDigest.to_string md5) path;
None
end
with
| _ -> assert false
let find_packages modules_list =
let f = memoize & find_packages modules_list in
fun ~file_path -> f file_path
(*
|- !!% "find_packages: %s : %a@."
path
(Format.option (Format.list ",@ " (fun ppf p -> Format.string ppf p.Package.name)))
*)
let choose_best_package_name = function
| [] -> assert false
| pack_names ->
pack_names
|> map (fun s -> String.length s, s)
|> sort_then_group (fun (l1, _) (l2, _) -> compare l1 l2)
|> hd
|> map snd
|> sort compare
|> hd
module Packages = struct
type t = {
id: int;
name: string;
packages : string list
}
let to_strings x = x.packages
module ForSave = struct
type t = string list [@@deriving conv{ocaml}]
let of_strings ss = map Hcons.string & sort compare ss
end
let ocaml_of_t t = ForSave.ocaml_of_t t.packages
let cntr = UniqueID.create ()
let tbl = Hashtbl.create 107
let wrap = memoize & fun pkgs ->
let id = UniqueID.get cntr in
let best_name = match pkgs with
| [] -> "<no packages>"
| _ -> choose_best_package_name pkgs
in
let name = !% "%s#%d" best_name id in
{ id; name; packages=pkgs } |- Hashtbl.replace tbl name
let of_strings pkgs = wrap & ForSave.of_strings pkgs
let hcons x = of_strings x.packages
let t_of_ocaml_exn ?trace o = wrap & ForSave.t_of_ocaml_exn ?trace o
let t_of_ocaml ?trace o = let open Result in ForSave.t_of_ocaml ?trace o >>| wrap
(* prepare {no packages#0} and {stdlib#1} *)
let () = ignore & of_strings []
let () = ignore & of_strings ["stdlib"]
let exact_string_of {packages=ps} = "{" ^ String.concat "," ps ^ "}"
let compare ps1 ps2 =
if ps1 == ps2 then 0
else
match ps1.packages, ps2.packages with
| [ "stdlib" ], _ -> -1
| _, [ "stdlib" ] -> 1
| _ -> compare ps1.name ps2.name
let to_string_for_printing t = "{" ^ t.name ^ "}"
let to_id x = x.name
let of_id s =
try Hashtbl.find tbl s
with Not_found ->
!!% "No packages found for %s@." s;
!!% " I know %s@." & String.concat " " & map fst & Hashtbl.to_list tbl;
raise Not_found
let report () =
!!% "Current OCamlFind package sets: %d@." & Hashtbl.length tbl
(* CR jfuruse: When oco.bin already exists, it prints 2.
It is strange but ok, since packages are with well-defined id numbers
in oco.bin.
It will affect the size of the cache of [cached_match], which
is not pretty good therefore should be fixed.
*)
let match_ s t =
List.exists (fun p ->
s = p
|| match String.is_prefix' s p with
| None -> false
| Some "" -> assert false
| Some s -> String.unsafe_get s 0 = '.') t.packages
let cached_match s =
let cache = Hashtbl.create (max 400 (Hashtbl.length tbl)) in
fun t ->
match Hashtbl.find cache t.id with
| x -> x
| exception Not_found ->
let res = match_ s t in
Hashtbl.replace cache t.id res;
res
end