jon.recoil.org
this repo has no description
1module Pkg_args = struct
2 type t = {
3 odoc_dir : Fpath.t;
4 odocl_dir : Fpath.t;
5 includes : Fpath.Set.t;
6 pages : Fpath.t Util.StringMap.t;
7 libs : Fpath.t Util.StringMap.t;
8 }
9
10 let v ~odoc_dir ~odocl_dir ~includes ~pages ~libs =
11 let includes = Fpath.Set.of_list includes in
12 let pages, libs = Util.StringMap.(of_list pages, of_list libs) in
13 { odoc_dir; odocl_dir; includes; pages; libs }
14
15 let map_rel dir m =
16 Util.StringMap.fold (fun a b acc -> (a, Fpath.(dir // b)) :: acc) m []
17
18 let compiled_pages v = map_rel v.odoc_dir v.pages
19 let compiled_libs v = map_rel v.odoc_dir v.libs
20 let includes (x : t) =
21 List.map (fun y -> Fpath.(x.odoc_dir // y)) (Fpath.Set.to_list x.includes)
22 let linked_pages v = map_rel v.odocl_dir v.pages
23 let linked_libs v = map_rel v.odocl_dir v.libs
24
25 let combine v1 v2 =
26 if v1.odoc_dir <> v2.odoc_dir then
27 Fmt.invalid_arg "combine: odoc_dir differs";
28 if v1.odocl_dir <> v2.odocl_dir then
29 Fmt.invalid_arg "combine: odocl_dir differs";
30 {
31 odoc_dir = v1.odoc_dir;
32 odocl_dir = v1.odocl_dir;
33 includes = Fpath.Set.union v1.includes v2.includes;
34 pages = Util.StringMap.union (fun _ x _ -> Some x) v1.pages v2.pages;
35 libs = Util.StringMap.union (fun _ x _ -> Some x) v1.libs v2.libs;
36 }
37
38 let pp fmt x =
39 let sfp_pp =
40 Fmt.(
41 list ~sep:comma (fun fmt (a, b) ->
42 Format.fprintf fmt "(%s, %a)" a Fpath.pp b))
43 in
44 Format.fprintf fmt
45 "@[<hov>odoc_dir: %a@;\
46 odocl_dir: %a@;\
47 includes: %a@;\
48 pages: [%a]@;\
49 libs: [%a]@]"
50 Fpath.pp x.odoc_dir Fpath.pp x.odocl_dir
51 Fmt.Dump.(list Fpath.pp)
52 (Fpath.Set.to_list x.includes)
53 sfp_pp
54 (Util.StringMap.bindings x.pages)
55 sfp_pp
56 (Util.StringMap.bindings x.libs)
57end
58
59type sidebar = { output_file : Fpath.t; json : bool; pkg_dir : Fpath.t }
60
61type index = {
62 roots : Fpath.t list;
63 output_file : Fpath.t;
64 json : bool;
65 search_dir : Fpath.t;
66 sidebar : sidebar option;
67}
68
69let pp_index fmt x =
70 Format.fprintf fmt
71 "@[<hov>roots: %a@;output_file: %a@;json: %b@;search_dir: %a@]"
72 (Fmt.list Fpath.pp) x.roots Fpath.pp x.output_file x.json Fpath.pp
73 x.search_dir
74
75type 'a t = {
76 parent_id : Odoc.Id.t;
77 input_file : Fpath.t;
78 input_copy : Fpath.t option;
79 (* Used to stash cmtis from virtual libraries into the odoc dir for voodoo mode.
80 See https://github.com/ocaml/odoc/pull/1309 *)
81 output_dir : Fpath.t;
82 odoc_file : Fpath.t;
83 odocl_file : Fpath.t;
84 pkg_args : Pkg_args.t;
85 pkgname : string option;
86 index : index option;
87 enable_warnings : bool;
88 to_output : bool;
89 kind : 'a;
90}
91
92type intf_extra = {
93 hidden : bool;
94 hash : string;
95 deps : (string * Digest.t) list;
96}
97
98and intf = [ `Intf of intf_extra ]
99
100type impl_extra = { src_id : Odoc.Id.t; src_path : Fpath.t }
101type impl = [ `Impl of impl_extra ]
102
103type mld = [ `Mld ]
104type md = [ `Md ]
105type asset = [ `Asset ]
106
107type all_kinds = [ impl | intf | mld | asset | md ]
108type any = all_kinds t
109
110let rec pp_kind : all_kinds Fmt.t =
111 fun fmt x ->
112 match x with
113 | `Intf x -> Format.fprintf fmt "`Intf %a" pp_intf_extra x
114 | `Impl x -> Format.fprintf fmt "`Impl %a" pp_impl_extra x
115 | `Mld -> Format.fprintf fmt "`Mld"
116 | `Md -> Format.fprintf fmt "`Md"
117 | `Asset -> Format.fprintf fmt "`Asset"
118
119and pp_intf_extra fmt x =
120 Format.fprintf fmt "@[<hov>hidden: %b@;hash: %s@;deps: [%a]@]" x.hidden x.hash
121 Fmt.Dump.(list (pair string string))
122 x.deps
123
124and pp_impl_extra fmt x =
125 Format.fprintf fmt "@[<hov>src_id: %s@;src_path: %a@]"
126 (Odoc.Id.to_string x.src_id)
127 Fpath.pp x.src_path
128
129and pp : all_kinds t Fmt.t =
130 fun fmt x ->
131 Format.fprintf fmt
132 "@[<hov>parent_id: %s@;\
133 input_file: %a@;\
134 output_dir: %a@;\
135 odoc_file: %a@;\
136 odocl_file: %a@;\
137 pkg_args: %a@;\
138 pkgname: %a@;\
139 index: %a@;\
140 kind:%a@;\
141 @]"
142 (Odoc.Id.to_string x.parent_id)
143 Fpath.pp x.input_file Fpath.pp x.output_dir Fpath.pp x.odoc_file Fpath.pp
144 x.odocl_file Pkg_args.pp x.pkg_args (Fmt.option Fmt.string) x.pkgname
145 (Fmt.option pp_index) x.index pp_kind
146 (x.kind :> all_kinds)
147
148let pkg_dir : Packages.t -> Fpath.t = fun pkg -> pkg.pkg_dir
149let doc_dir : Packages.t -> Fpath.t = fun pkg -> pkg.doc_dir
150let lib_dir (pkg : Packages.t) (lib : Packages.libty) =
151 match lib.id_override with
152 | Some id -> Fpath.v id
153 | None -> Fpath.(doc_dir pkg / lib.Packages.lib_name)
154let src_dir pkg = Fpath.(doc_dir pkg / "src")
155let src_lib_dir (pkg : Packages.t) (lib : Packages.libty) =
156 match lib.id_override with
157 | Some id -> Fpath.v id
158 | None -> Fpath.(src_dir pkg / lib.Packages.lib_name)
159
160type dirs = {
161 odoc_dir : Fpath.t;
162 odocl_dir : Fpath.t;
163 index_dir : Fpath.t;
164 mld_dir : Fpath.t;
165}
166
167let fix_virtual ~(precompiled_units : intf t list Util.StringMap.t)
168 ~(units : intf t list Util.StringMap.t) =
169 Logs.debug (fun m ->
170 m "Fixing virtual libraries: %d precompiled units, %d other units"
171 (Util.StringMap.cardinal precompiled_units)
172 (Util.StringMap.cardinal units));
173 let all =
174 Util.StringMap.union
175 (fun h x y ->
176 Logs.debug (fun m ->
177 m "Unifying hash %s (%d, %d)" h (List.length x) (List.length y));
178 Some (x @ y))
179 precompiled_units units
180 in
181 Util.StringMap.map
182 (fun units ->
183 List.map
184 (fun unit ->
185 let uhash = match unit.kind with `Intf { hash; _ } -> hash in
186 if not (Fpath.has_ext "cmt" unit.input_file) then unit
187 else
188 match Util.StringMap.find uhash all with
189 | [ _ ] -> unit
190 | xs -> (
191 let unit_name =
192 Fpath.rem_ext unit.input_file |> Fpath.basename
193 in
194 match
195 List.filter
196 (fun (x : intf t) ->
197 (match x.kind with `Intf { hash; _ } -> uhash = hash)
198 && Fpath.has_ext "cmti" x.input_file
199 && Fpath.rem_ext x.input_file |> Fpath.basename
200 = unit_name)
201 xs
202 with
203 | [ x ] -> { unit with input_file = x.input_file }
204 | xs -> (
205 Logs.debug (fun m ->
206 m
207 "Duplicate hash found, but multiple (%d) matching \
208 cmti found for %a"
209 (List.length xs) Fpath.pp unit.input_file);
210 let possibles =
211 List.find_map
212 (fun x ->
213 match x.input_copy with
214 | Some x ->
215 if
216 x |> Bos.OS.File.exists
217 |> Result.value ~default:false
218 then Some x
219 else None
220 | None -> None)
221 xs
222 in
223 match possibles with
224 | None ->
225 Logs.debug (fun m -> m "Not replacing input file");
226 unit
227 | Some x ->
228 Logs.debug (fun m ->
229 m "Replacing input_file of unit with %a" Fpath.pp x);
230 { unit with input_file = x })))
231 units)
232 units