jon.recoil.org
this repo has no description
1(*
2 * Copyright (c) 2016 Thomas Refis <trefis@janestreet.com>
3 *
4 * Permission to use, copy, modify, and distribute this software for any
5 * purpose with or without fee is hereby granted, provided that the above
6 * copyright notice and this permission notice appear in all copies.
7 *
8 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
9 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
10 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
11 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
12 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
13 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
14 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
15 *)
16
17open Odoc_utils
18open Odoc_model.Names
19module Location = Odoc_model.Location_
20module Paths = Odoc_model.Paths
21open Types
22module O = Codefmt
23open O.Infix
24
25let tag tag t = O.span ~attr:tag t
26
27let label t =
28 match t with
29 | Odoc_model.Lang.TypeExpr.Label s -> tag "label" (O.txt s)
30 | Optional s | RawOptional s -> tag "optlabel" (O.txt "?" ++ O.txt s)
31
32let type_var tv = tag "type-var" (O.txt tv)
33
34let enclose ~l ~r x = O.span (O.txt l ++ x ++ O.txt r)
35
36let mode_names ms =
37 O.list ms ~sep:(O.txt " ") ~f:(fun m -> O.mode m)
38
39let resolved p content =
40 let link = { Link.target = Internal (Resolved p); content; tooltip = None } in
41 O.elt [ inline @@ Link link ]
42
43let path p content = resolved (Url.from_path p) content
44
45let unresolved content =
46 let link = { Link.target = Internal Unresolved; content; tooltip = None } in
47 O.elt [ inline @@ Link link ]
48
49let path_to_id path =
50 let url = Url.Anchor.from_identifier (path :> Paths.Identifier.t) in
51 Some url
52
53let source_anchor source_loc =
54 match source_loc with
55 | Some id ->
56 Some
57 (Url.Anchor.from_identifier
58 (id : Paths.Identifier.SourceLocation.t :> Paths.Identifier.t))
59 | _ -> None
60
61let attach_expansion ?(status = `Default) (eq, o, e) page text =
62 match page with
63 | None -> O.documentedSrc text
64 | Some (page : Page.t) ->
65 let url = page.url in
66 let summary = O.render text in
67 let expansion =
68 O.documentedSrc (O.txt eq ++ O.keyword o)
69 @ DocumentedSrc.[ Subpage { status; content = page } ]
70 @ O.documentedSrc (O.keyword e)
71 in
72 DocumentedSrc.
73 [ Alternative (Expansion { summary; url; status; expansion }) ]
74
75let mk_heading ?(level = 1) ?label text =
76 let title = [ inline @@ Text text ] in
77 Item.Heading { label; level; title; source_anchor = None }
78
79(** Returns the preamble as an item. Stop the preamble at the first heading. The
80 rest is inserted into [items]. *)
81let prepare_preamble comment items =
82 let preamble, first_comment =
83 List.split_at
84 ~f:(function
85 | { Odoc_model.Location_.value = `Heading _; _ } -> true | _ -> false)
86 comment
87 in
88 (Comment.standalone preamble, Comment.standalone first_comment @ items)
89
90let make_expansion_page ~source_anchor url comments items =
91 (* Save any resources accumulated before this page - they belong to
92 the parent/main page's content, not this nested expansion. *)
93 let saved_resources = Comment.Resources.take () in
94 let saved_assets = Comment.Assets.take () in
95 let comment = List.concat comments in
96 let preamble, items = prepare_preamble comment items in
97 let resources = Comment.Resources.take () in
98 let assets = Comment.Assets.take () in
99 (* Restore the parent's resources *)
100 Comment.Resources.add saved_resources;
101 Comment.Assets.add saved_assets;
102 { Page.preamble; items; url; source_anchor; resources; assets }
103
104include Generator_signatures
105
106module Make (Syntax : SYNTAX) = struct
107 module Link : sig
108 val from_path : Paths.Path.t -> text
109
110 val from_fragment : Paths.Fragment.leaf -> text
111 end = struct
112 open Paths
113
114 let rec from_path : Path.t -> text =
115 fun path ->
116 match path with
117 | `Identifier (id, _) ->
118 unresolved [ inline @@ Text (Identifier.name id) ]
119 | `Substituted m -> from_path (m :> Path.t)
120 | `SubstitutedMT m -> from_path (m :> Path.t)
121 | `SubstitutedT m -> from_path (m :> Path.t)
122 | `SubstitutedCT m -> from_path (m :> Path.t)
123 | `Root root -> unresolved [ inline @@ Text (ModuleName.to_string root) ]
124 | `Forward root -> unresolved [ inline @@ Text root ] (* FIXME *)
125 | `Dot (prefix, suffix) ->
126 let link = from_path (prefix :> Path.t) in
127 link ++ O.txt ("." ^ ModuleName.to_string suffix)
128 | `DotT (prefix, suffix) ->
129 let link = from_path (prefix :> Path.t) in
130 link ++ O.txt ("." ^ TypeName.to_string suffix)
131 | `DotMT (prefix, suffix) ->
132 let link = from_path (prefix :> Path.t) in
133 link ++ O.txt ("." ^ ModuleTypeName.to_string suffix)
134 | `DotV (prefix, suffix) ->
135 let link = from_path (prefix :> Path.t) in
136 link ++ O.txt ("." ^ ValueName.to_string suffix)
137 | `Apply (p1, p2) ->
138 let link1 = from_path (p1 :> Path.t) in
139 let link2 = from_path (p2 :> Path.t) in
140 link1 ++ O.txt "(" ++ link2 ++ O.txt ")"
141 | `Resolved _ when Paths.Path.is_hidden path ->
142 let txt = Url.render_path path in
143 unresolved [ inline @@ Text txt ]
144 | `Resolved rp -> (
145 (* If the path is pointing to an opaque module or module type
146 there won't be a page generated - so we stop before; at
147 the parent page, and link instead to the anchor representing
148 the declaration of the opaque module(_type) *)
149 let stop_before =
150 match rp with
151 | `OpaqueModule _ | `OpaqueModuleType _ -> true
152 | _ -> false
153 in
154 let txt = [ inline @@ Text (Url.render_path path) ] in
155 match Paths.Path.Resolved.identifier rp with
156 | Some id ->
157 let href = Url.from_identifier ~stop_before id in
158 resolved href txt
159 | None -> O.elt txt)
160
161 let dot prefix suffix = prefix ^ "." ^ suffix
162
163 let rec render_fragment_any : Fragment.t -> string =
164 fun fragment ->
165 match fragment with
166 | `Resolved rr -> render_resolved_fragment rr
167 | `Dot (`Root, suffix) -> suffix
168 | `Dot (prefix, suffix) ->
169 dot (render_fragment_any (prefix :> Fragment.t)) suffix
170 | `Root -> assert false
171
172 and render_resolved_fragment : Fragment.Resolved.t -> string =
173 let open Fragment.Resolved in
174 fun fragment ->
175 match fragment with
176 | `Root _ -> assert false
177 | `Subst (_, rr) -> render_resolved_fragment (rr :> t)
178 | `Alias (_, rr) -> render_resolved_fragment (rr :> t)
179 | `Module (`Root _, s) -> ModuleName.to_string s
180 | `Module_type (`Root _, s) -> ModuleTypeName.to_string s
181 | `Type (`Root _, s) -> TypeName.to_string s
182 | `Class (`Root _, s) -> TypeName.to_string s
183 | `ClassType (`Root _, s) -> TypeName.to_string s
184 | `Module (rr, s) ->
185 dot (render_resolved_fragment (rr :> t)) (ModuleName.to_string s)
186 | `Module_type (rr, s) ->
187 dot
188 (render_resolved_fragment (rr :> t))
189 (ModuleTypeName.to_string s)
190 | `Type (rr, s) ->
191 dot (render_resolved_fragment (rr :> t)) (TypeName.to_string s)
192 | `Class (rr, s) ->
193 dot (render_resolved_fragment (rr :> t)) (TypeName.to_string s)
194 | `ClassType (rr, s) ->
195 dot (render_resolved_fragment (rr :> t)) (TypeName.to_string s)
196 | `OpaqueModule r -> render_resolved_fragment (r :> t)
197
198 let resolved_fragment_to_ir : Fragment.Resolved.leaf -> text =
199 fun fragment ->
200 let open Fragment in
201 let id = Resolved.identifier (fragment :> Resolved.t) in
202 let txt = render_resolved_fragment (fragment :> Resolved.t) in
203 match id with
204 | Some id ->
205 let href = Url.from_identifier ~stop_before:false id in
206 resolved href [ inline @@ Text txt ]
207 | None -> unresolved [ inline @@ Text txt ]
208
209 let from_fragment : Fragment.leaf -> text = function
210 | `Resolved r
211 when not (Fragment.Resolved.is_hidden (r :> Fragment.Resolved.t)) ->
212 resolved_fragment_to_ir r
213 | f ->
214 let txt = render_fragment_any (f :> Fragment.t) in
215 unresolved [ inline @@ Text txt ]
216 end
217
218 module Impl = struct
219 let impl ~infos src =
220 let l =
221 infos
222 |> List.sort (fun (_, (l1, e1)) (_, (l2, e2)) ->
223 if l1 = l2 then compare e2 e1
224 (* If two intervals open at the same time, we open
225 first the one that closes last *)
226 else compare l1 l2)
227 in
228 let get_src a b =
229 let in_bound x = min (max x 0) (String.length src) in
230 let a = in_bound a and b = in_bound b in
231 let a, b = (min a b, max a b) in
232 String.with_range src ~first:a ~len:(b - a)
233 in
234 let plain_code = function
235 | "" -> []
236 | s -> [ Types.Source_page.Plain_code s ]
237 in
238 let min (a : int) b = if a < b then a else b in
239 let rec extract from to_ list aux =
240 match list with
241 | (k, (loc_start, loc_end)) :: q when loc_start < to_ ->
242 let loc_end = min loc_end to_ in
243 (* In case of inconsistent [a [b a] b]
244 we do [a [b b]a] *)
245 let initial = plain_code (get_src from loc_start) in
246 let next, q = extract loc_start loc_end q [] in
247 extract loc_end to_ q
248 ([ Types.Source_page.Tagged_code (k, List.rev next) ]
249 @ initial @ aux)
250 | q -> (plain_code (get_src from to_) @ aux, q)
251 in
252 let doc, _ = extract 0 (String.length src) l [] in
253 List.rev doc
254 end
255
256 module Source_page : sig
257 val source :
258 Paths.Identifier.SourcePage.t ->
259 Syntax_highlighter.infos ->
260 Lang.Source_info.t ->
261 string ->
262 Source_page.t
263 end = struct
264 let path id = Url.Path.from_identifier id
265
266 let to_link { Lang.Source_info.documentation; implementation } =
267 let documentation =
268 (* Since documentation link are not rendered, we comment the code to
269 extract the href, and always output [None] *)
270 ignore documentation;
271 None
272 (* let open Paths.Path.Resolved in *)
273 (* match documentation with *)
274 (* | Some (`Resolved p) when not (is_hidden (p :> t)) -> ( *)
275 (* let id = identifier (p :> t) in *)
276 (* match Url.from_identifier ~stop_before:false id with *)
277 (* | Ok link -> Some link *)
278 (* | _ -> None) *)
279 (* | _ -> None *)
280 in
281 let implementation =
282 match implementation with
283 | Some (Odoc_model.Lang.Source_info.Resolved id) ->
284 Some (Url.Anchor.from_identifier (id :> Paths.Identifier.t))
285 | _ -> None
286 in
287 Some (Source_page.Link { implementation; documentation })
288
289 let info_of_info : Lang.Source_info.annotation -> Source_page.info option =
290 function
291 | Definition id -> (
292 match id.iv with
293 | `SourceLocation (_, def) -> Some (Anchor (DefName.to_string def))
294 | `SourceLocationInternal (_, local) ->
295 Some (Anchor (LocalName.to_string local))
296 | _ -> None)
297 | Module v -> to_link v
298 | ModuleType v -> to_link v
299 | Type v -> to_link v
300 | Value v -> to_link v
301
302 let source id syntax_info infos source_code =
303 let url = path id in
304 let mapper (info, (loc : Lang.Source_info.location_in_file)) =
305 match info_of_info info with Some x -> Some (x, (loc.loc_start.pos_cnum, loc.loc_end.pos_cnum)) | None -> None
306 in
307 let infos = Odoc_utils.List.filter_map mapper infos in
308 let syntax_info =
309 List.rev_map (fun (ty, loc) -> (Source_page.Syntax ty, loc)) syntax_info
310 |> List.rev
311 in
312 let contents = Impl.impl ~infos:(infos @ syntax_info) source_code in
313 { Source_page.url; contents }
314 end
315
316 module Type_expression : sig
317 val type_expr : ?needs_parentheses:bool -> Lang.TypeExpr.t -> text
318
319 val format_type_path :
320 delim:[ `parens | `brackets ] -> Lang.TypeExpr.t list -> text -> text
321 end = struct
322 let rec te_variant (t : Odoc_model.Lang.TypeExpr.Polymorphic_variant.t) =
323 let style_arguments ~constant arguments =
324 (* Multiple arguments in a polymorphic variant constructor correspond
325 to a conjunction of types, not a product: [`Lbl int&float].
326 If constant is [true], the conjunction starts with an empty type,
327 for instance [`Lbl &int].
328 *)
329 let wrapped_type_expr =
330 (* type conjunction in Reason is printed as `Lbl (t1)&(t2)` *)
331 if Syntax.Type.Variant.parenthesize_params then fun x ->
332 enclose ~l:"(" ~r:")" (type_expr x)
333 else fun x -> type_expr x
334 in
335 let arguments =
336 O.list arguments ~sep:(O.txt " & ") ~f:wrapped_type_expr
337 in
338 if constant then O.txt "& " ++ arguments else arguments
339 in
340 let rec style_elements ~add_pipe = function
341 | [] -> O.noop
342 | first :: rest ->
343 let first =
344 match first with
345 | Odoc_model.Lang.TypeExpr.Polymorphic_variant.Type te ->
346 let res = O.box_hv @@ type_expr te in
347 if add_pipe then O.sp ++ O.span (O.txt "| " ++ res) else res
348 | Constructor { constant; name; arguments; _ } ->
349 let constr =
350 let name = "`" ^ name in
351 if add_pipe then O.span (O.txt ("| " ^ name))
352 else O.txt name
353 in
354 let res =
355 O.box_hv
356 (match arguments with
357 | [] -> constr
358 | _ ->
359 let arguments = style_arguments ~constant arguments in
360 O.span
361 (if Syntax.Type.Variant.parenthesize_params then
362 constr ++ arguments
363 else constr ++ O.txt " of" ++ O.sp ++ arguments))
364 in
365 if add_pipe then O.sp ++ res else res
366 in
367 first ++ style_elements ~add_pipe:true rest
368 in
369 let elements = style_elements ~add_pipe:false t.elements in
370 O.box_hv_no_indent
371 @@ O.span
372 (match t.kind with
373 | Fixed -> O.txt "[ " ++ elements ++ O.txt " ]"
374 | Open -> O.txt "[> " ++ elements ++ O.txt " ]"
375 | Closed [] -> O.txt "[< " ++ elements ++ O.txt " ]"
376 | Closed lst ->
377 let constrs = String.concat ~sep:" " lst in
378 O.txt "[< " ++ elements ++ O.txt (" " ^ constrs ^ " ]"))
379
380 and te_object (t : Odoc_model.Lang.TypeExpr.Object.t) =
381 let fields =
382 O.list
383 ~sep:(O.sp ++ O.txt Syntax.Obj.field_separator)
384 t.fields
385 ~f:(function
386 | Odoc_model.Lang.TypeExpr.Object.Method { name; type_ } ->
387 O.box_hv_no_indent
388 @@ O.txt (name ^ Syntax.Type.annotation_separator)
389 ++ O.cut ++ type_expr type_
390 | Inherit type_ -> O.box_hv_no_indent @@ type_expr type_)
391 in
392 let open_tag =
393 if t.open_ then O.txt Syntax.Obj.open_tag_extendable
394 else O.txt Syntax.Obj.open_tag_closed
395 in
396 let close_tag =
397 if t.open_ then O.txt Syntax.Obj.close_tag_extendable
398 else O.txt Syntax.Obj.close_tag_closed
399 in
400 O.span (open_tag ++ fields ++ close_tag)
401
402 and format_type_path ~delim (params : Odoc_model.Lang.TypeExpr.t list)
403 (path : text) : text =
404 O.box_hv
405 @@
406 match params with
407 | [] -> path
408 | [ param ] ->
409 let param = type_expr ~needs_parentheses:true param in
410 let args =
411 if Syntax.Type.parenthesize_constructor then
412 O.txt "(" ++ param ++ O.txt ")"
413 else param
414 in
415 Syntax.Type.handle_constructor_params path args
416 | params ->
417 let params = O.list params ~sep:(O.txt "," ++ O.sp) ~f:type_expr in
418 let params =
419 match delim with
420 | `parens -> enclose ~l:"(" params ~r:")"
421 | `brackets -> enclose ~l:"[" params ~r:"]"
422 in
423 Syntax.Type.handle_constructor_params path (O.box_hv params)
424
425 and tuple ?(needs_parentheses = false) ~boxed lst =
426 let opt_label = function
427 None -> O.noop
428 | Some lbl -> O.txt lbl ++ O.txt ":" ++ O.cut
429 in
430 let res =
431 O.box_hv_no_indent
432 (O.list lst ~sep:Syntax.Type.Tuple.element_separator
433 ~f:(fun (lbl, typ) ->
434 opt_label lbl ++ type_expr ~needs_parentheses:true typ))
435 in
436 let lparen = if boxed then "(" else "#(" in
437 if Syntax.Type.Tuple.always_parenthesize || needs_parentheses || not boxed then
438 enclose ~l:lparen res ~r:")"
439 else res
440
441 and type_expr ?(needs_parentheses = false) (t : Odoc_model.Lang.TypeExpr.t)
442 =
443 let enclose_parens_if_needed res =
444 if needs_parentheses then enclose ~l:"(" res ~r:")" else res
445 in
446 match t with
447 | Var (s, None) -> type_var (Syntax.Type.var_prefix ^ s)
448 | Var (s, Some jkind) ->
449 enclose ~l:"(" ~r:")"
450 (type_var (Syntax.Type.var_prefix ^ s)
451 ++ O.txt " " ++ O.keyword ":" ++ O.txt " " ++ O.mode jkind)
452 | Any -> type_var Syntax.Type.any
453 | Alias (te, alias) ->
454 enclose_parens_if_needed
455 (type_expr ~needs_parentheses:true te
456 ++ O.txt " " ++ O.keyword "as" ++ O.txt " '" ++ O.txt alias)
457 | Arrow (None, src, dst, modes, ret_modes) ->
458 let mode_suffix = match modes with
459 | [] -> O.noop
460 | ms ->
461 O.txt " " ++ O.keyword "@" ++ O.txt " "
462 ++ mode_names ms
463 in
464 let dst_needs_parens = ret_modes <> [] && (match dst with Arrow _ -> true | _ -> false) in
465 let dst_rendered = type_expr ~needs_parentheses:dst_needs_parens dst in
466 let ret_suffix = match ret_modes with
467 | [] -> O.noop
468 | ms ->
469 O.txt " " ++ O.keyword "@" ++ O.txt " "
470 ++ mode_names ms
471 in
472 let res =
473 O.span
474 ((O.box_hv @@ type_expr ~needs_parentheses:true src ++ mode_suffix)
475 ++ O.txt " " ++ Syntax.Type.arrow)
476 ++ O.sp ++ dst_rendered ++ ret_suffix
477 in
478 if not needs_parentheses then res else enclose ~l:"(" res ~r:")"
479 | Arrow (Some (RawOptional _ as lbl), _src, dst, _modes, _ret_modes) ->
480 let res =
481 O.span
482 (O.box_hv
483 @@ label lbl ++ O.txt ":"
484 ++ tag "error" (O.txt "???")
485 ++ O.txt " " ++ Syntax.Type.arrow)
486 ++ O.sp ++ type_expr dst
487 in
488 if not needs_parentheses then res else enclose ~l:"(" res ~r:")"
489 | Arrow (Some lbl, src, dst, modes, ret_modes) ->
490 let mode_suffix = match modes with
491 | [] -> O.noop
492 | ms ->
493 O.txt " " ++ O.keyword "@" ++ O.txt " "
494 ++ mode_names ms
495 in
496 let dst_needs_parens = ret_modes <> [] && (match dst with Arrow _ -> true | _ -> false) in
497 let dst_rendered = type_expr ~needs_parentheses:dst_needs_parens dst in
498 let ret_suffix = match ret_modes with
499 | [] -> O.noop
500 | ms ->
501 O.txt " " ++ O.keyword "@" ++ O.txt " "
502 ++ mode_names ms
503 in
504 let res =
505 O.span
506 ((O.box_hv
507 @@ label lbl ++ O.txt ":" ++ O.cut
508 ++ (O.box_hv @@ type_expr ~needs_parentheses:true src)
509 ++ mode_suffix)
510 ++ O.txt " " ++ Syntax.Type.arrow)
511 ++ O.sp ++ dst_rendered ++ ret_suffix
512 in
513 if not needs_parentheses then res else enclose ~l:"(" res ~r:")"
514 | Tuple lst -> tuple ~needs_parentheses ~boxed:true lst
515 | Unboxed_tuple lst -> tuple ~needs_parentheses ~boxed:false lst
516 | Constr (path, args) ->
517 let link = Link.from_path (path :> Paths.Path.t) in
518 format_type_path ~delim:`parens args link
519 | Polymorphic_variant v -> te_variant v
520 | Object o -> te_object o
521 | Class (path, args) ->
522 format_type_path ~delim:`brackets args
523 (Link.from_path (path :> Paths.Path.t))
524 | Poly (polyvars, t) ->
525 let render_var (name, jkind) = match jkind with
526 | None -> O.txt ("'" ^ name)
527 | Some jk -> O.txt ("('" ^ name ^ " : ") ++ O.mode jk ++ O.txt ")"
528 in
529 O.list polyvars ~sep:(O.txt " ") ~f:render_var ++ O.txt ". "
530 ++ type_expr t
531 | Quote t ->
532 O.span (O.txt "<[ " ++ O.box_hv (type_expr t) ++ O.txt " ]>")
533 | Splice t ->
534 O.span (O.txt "$" ++ type_expr ~needs_parentheses:true t)
535 | Package pkg ->
536 enclose ~l:"(" ~r:")"
537 (O.keyword "module" ++ O.txt " "
538 ++ Link.from_path (pkg.path :> Paths.Path.t)
539 ++
540 match pkg.substitutions with
541 | [] -> O.noop
542 | fst :: lst ->
543 O.sp
544 ++ O.box_hv (O.keyword "with" ++ O.txt " " ++ package_subst fst)
545 ++ O.list lst ~f:(fun s ->
546 O.cut
547 ++ (O.box_hv
548 @@ O.txt " " ++ O.keyword "and" ++ O.txt " "
549 ++ package_subst s)))
550
551 and package_subst
552 ((frag_typ, te) : Paths.Fragment.Type.t * Odoc_model.Lang.TypeExpr.t) :
553 text =
554 let typath = Link.from_fragment (frag_typ :> Paths.Fragment.leaf) in
555 O.keyword "type" ++ O.txt " " ++ typath ++ O.txt " =" ++ O.sp
556 ++ type_expr te
557 end
558
559 open Type_expression
560
561 (* Also handles constructor declarations for exceptions and extensible
562 variants, and exposes a few helpers used in formatting classes and signature
563 constraints. *)
564 module Type_declaration : sig
565 val type_decl :
566 ?is_substitution:bool ->
567 Lang.Signature.recursive * Lang.TypeDecl.t ->
568 Item.t
569
570 val extension : Lang.Extension.t -> Item.t
571
572 val record : Lang.TypeDecl.Field.t list -> DocumentedSrc.one list
573
574 val unboxed_record : Lang.TypeDecl.UnboxedField.t list -> DocumentedSrc.one list
575
576 val exn : Lang.Exception.t -> Item.t
577
578 val format_params :
579 ?delim:[ `parens | `brackets ] -> Lang.TypeDecl.param list -> text
580
581 val format_manifest :
582 ?is_substitution:bool ->
583 ?compact_variants:bool ->
584 Lang.TypeDecl.Equation.t ->
585 text * bool
586
587 val format_constraints : (Lang.TypeExpr.t * Lang.TypeExpr.t) list -> text
588 end = struct
589 let record fields =
590 let field mutable_ id typ =
591 let url = Url.from_identifier ~stop_before:true id in
592 let name = Paths.Identifier.name id in
593 let attrs = [ "def"; "record"; Url.Anchor.string_of_kind url.kind ] in
594 let cell =
595 (* O.td ~a:[ O.a_class ["def"; kind ] ]
596 * [O.a ~a:[O.a_href ("#" ^ anchor); O.a_class ["anchor"]] []
597 * ; *)
598 O.code
599 ((if mutable_ then O.keyword "mutable" ++ O.txt " " else O.noop)
600 ++ O.txt name
601 ++ O.txt Syntax.Type.annotation_separator
602 ++ type_expr typ
603 ++ O.txt Syntax.Type.Record.field_separator)
604 (* ] *)
605 in
606 (url, attrs, cell)
607 in
608 let rows =
609 fields
610 |> List.map (fun fld ->
611 let open Odoc_model.Lang.TypeDecl.Field in
612 let url, attrs, code =
613 field fld.mutable_ (fld.id :> Paths.Identifier.t) fld.type_
614 in
615 let anchor = Some url in
616 let doc = fld.doc.elements in
617 let rhs = Comment.to_ir doc in
618 let doc = if not (Comment.has_doc doc) then [] else rhs in
619 let markers = Syntax.Comment.markers in
620 DocumentedSrc.Documented { anchor; attrs; code; doc; markers })
621 in
622 let content =
623 O.documentedSrc (O.txt "{") @ rows @ O.documentedSrc (O.txt "}")
624 in
625 content
626
627 let unboxed_record fields =
628 let field mutable_ id typ =
629 let url = Url.from_identifier ~stop_before:true id in
630 let name = Paths.Identifier.name id in
631 let attrs =
632 [ "def"; "record"; Url.Anchor.string_of_kind url.kind ]
633 in
634 let cell =
635 (* O.td ~a:[ O.a_class ["def"; kind ] ]
636 * [O.a ~a:[O.a_href ("#" ^ anchor); O.a_class ["anchor"]] []
637 * ; *)
638 O.code
639 ((if mutable_ then O.keyword "mutable" ++ O.txt " " else O.noop)
640 ++ O.txt name
641 ++ O.txt Syntax.Type.annotation_separator
642 ++ type_expr typ
643 ++ O.txt Syntax.Type.Record.field_separator)
644 (* ] *)
645 in
646 (url, attrs, cell)
647 in
648 let rows =
649 fields
650 |> List.map (fun fld ->
651 let open Odoc_model.Lang.TypeDecl.UnboxedField in
652 let url, attrs, code =
653 field fld.mutable_ (fld.id :> Paths.Identifier.t) fld.type_
654 in
655 let anchor = Some url in
656 let doc = fld.doc.elements in
657 let rhs = Comment.to_ir doc in
658 let doc = if not (Comment.has_doc doc) then [] else rhs in
659 let markers = Syntax.Comment.markers in
660 DocumentedSrc.Documented { anchor; attrs; code; doc; markers })
661 in
662 let content =
663 O.documentedSrc (O.txt "#{") @ rows @ O.documentedSrc (O.txt "}")
664 in
665 content
666
667 let constructor :
668 Paths.Identifier.t ->
669 Odoc_model.Lang.TypeDecl.Constructor.argument ->
670 Odoc_model.Lang.TypeExpr.t option ->
671 DocumentedSrc.t =
672 fun id args ret_type ->
673 let name = Paths.Identifier.name id in
674 let kind = Url.(kind id |> Anchor.string_of_kind) in
675 let cstr = tag kind (O.txt name) in
676 let is_gadt, ret_type =
677 match ret_type with
678 | None -> (false, O.noop)
679 | Some te ->
680 let constant = match args with Tuple [] -> true | _ -> false in
681 let ret_type =
682 O.txt " "
683 ++ (if constant then O.txt ":" else Syntax.Type.GADT.arrow)
684 ++ O.txt " " ++ type_expr te
685 in
686 (true, ret_type)
687 in
688 match args with
689 | Tuple [] -> O.documentedSrc (cstr ++ ret_type)
690 | Tuple lst ->
691 let params =
692 O.list lst ~sep:Syntax.Type.Tuple.element_separator
693 ~f:(type_expr ~needs_parentheses:is_gadt)
694 in
695 O.documentedSrc
696 (cstr
697 ++ (if Syntax.Type.Variant.parenthesize_params then
698 O.txt "(" ++ params ++ O.txt ")"
699 else
700 (if is_gadt then O.txt Syntax.Type.annotation_separator
701 else O.txt " " ++ O.keyword "of" ++ O.txt " ")
702 ++ params)
703 ++ ret_type)
704 | Record fields ->
705 if is_gadt then
706 O.documentedSrc (cstr ++ O.txt Syntax.Type.annotation_separator)
707 @ record fields @ O.documentedSrc ret_type
708 else
709 O.documentedSrc (cstr ++ O.txt " " ++ O.keyword "of" ++ O.txt " ")
710 @ record fields
711
712 let variant cstrs : DocumentedSrc.t =
713 let constructor id args res =
714 let url = Url.from_identifier ~stop_before:true id in
715 let attrs = [ "def"; "variant"; Url.Anchor.string_of_kind url.kind ] in
716 let content =
717 let doc = constructor id args res in
718 O.documentedSrc (O.txt "| ") @ doc
719 in
720 (url, attrs, content)
721 in
722 match cstrs with
723 | [] -> O.documentedSrc (O.txt "|")
724 | _ :: _ ->
725 let rows =
726 cstrs
727 |> List.map (fun cstr ->
728 let open Odoc_model.Lang.TypeDecl.Constructor in
729 let url, attrs, code =
730 constructor
731 (cstr.id :> Paths.Identifier.t)
732 cstr.args cstr.res
733 in
734 let anchor = Some url in
735 let doc = cstr.doc.elements in
736 let rhs = Comment.to_ir doc in
737 let doc = if not (Comment.has_doc doc) then [] else rhs in
738 let markers = Syntax.Comment.markers in
739 DocumentedSrc.Nested { anchor; attrs; code; doc; markers })
740 in
741 rows
742
743 let extension_constructor (t : Odoc_model.Lang.Extension.Constructor.t) =
744 let id = (t.id :> Paths.Identifier.t) in
745 let url = Url.from_identifier ~stop_before:true id in
746 let anchor = Some url in
747 let attrs = [ "def"; "variant"; Url.Anchor.string_of_kind url.kind ] in
748 let code = O.documentedSrc (O.txt "| ") @ constructor id t.args t.res in
749 let doc = Comment.to_ir t.doc.elements in
750 let markers = Syntax.Comment.markers in
751 DocumentedSrc.Nested { anchor; attrs; code; doc; markers }
752
753 let extension (t : Odoc_model.Lang.Extension.t) =
754 let prefix =
755 O.keyword "type" ++ O.txt " "
756 ++ Link.from_path (t.type_path :> Paths.Path.t)
757 ++ O.txt " +=" ++ O.sp
758 ++
759 if t.private_ then O.keyword Syntax.Type.private_keyword ++ O.sp
760 else O.noop
761 in
762 let content =
763 O.documentedSrc prefix
764 @ List.map extension_constructor t.constructors
765 @ O.documentedSrc
766 (if Syntax.Type.type_def_semicolon then O.txt ";" else O.noop)
767 in
768 let attr = [ "type"; "extension" ] in
769 let anchor = Some (Url.Anchor.extension_decl t) in
770 let doc = Comment.to_ir t.doc.elements in
771 let source_anchor =
772 (* Take the anchor from the first constructor only for consistency with
773 regular variants. *)
774 match t.constructors with
775 | hd :: _ -> source_anchor hd.source_loc
776 | [] -> None
777 in
778 Item.Declaration { attr; anchor; doc; content; source_anchor }
779
780 let exn (t : Odoc_model.Lang.Exception.t) =
781 let cstr = constructor (t.id :> Paths.Identifier.t) t.args t.res in
782 let content =
783 O.documentedSrc (O.keyword "exception" ++ O.txt " ")
784 @ cstr
785 @ O.documentedSrc
786 (if Syntax.Type.Exception.semicolon then O.txt ";" else O.noop)
787 in
788 let attr = [ "exception" ] in
789 let anchor = path_to_id t.id in
790 let doc = Comment.to_ir t.doc.elements in
791 let source_anchor = source_anchor t.source_loc in
792 Item.Declaration { attr; anchor; doc; content; source_anchor }
793
794 let polymorphic_variant ~type_ident
795 (t : Odoc_model.Lang.TypeExpr.Polymorphic_variant.t) =
796 let row item =
797 let kind_approx, cstr, doc =
798 match item with
799 | Odoc_model.Lang.TypeExpr.Polymorphic_variant.Type te ->
800 ("unknown", O.documentedSrc (type_expr te), None)
801 | Constructor { constant; name; arguments; doc; _ } -> (
802 let cstr = "`" ^ name in
803 ( "constructor",
804 (match arguments with
805 | [] -> O.documentedSrc (O.txt cstr)
806 | _ ->
807 (* Multiple arguments in a polymorphic variant constructor correspond
808 to a conjunction of types, not a product: [`Lbl int&float].
809 If constant is [true], the conjunction starts with an empty type,
810 for instance [`Lbl &int].
811 *)
812 let wrapped_type_expr =
813 (* type conjunction in Reason is printed as `Lbl (t1)&(t2)` *)
814 if Syntax.Type.Variant.parenthesize_params then fun x ->
815 O.txt "(" ++ type_expr x ++ O.txt ")"
816 else fun x -> type_expr x
817 in
818 let params =
819 O.box_hv
820 @@ O.list arguments
821 ~sep:(O.txt " &" ++ O.sp)
822 ~f:wrapped_type_expr
823 in
824 let params =
825 if constant then O.txt "& " ++ params else params
826 in
827 O.documentedSrc
828 (O.txt cstr
829 ++
830 if Syntax.Type.Variant.parenthesize_params then params
831 else O.txt " " ++ O.keyword "of" ++ O.sp ++ params)),
832 match doc with
833 | { elements = []; _ } -> None
834 | _ -> Some (Comment.to_ir doc.elements) ))
835 in
836 let markers = Syntax.Comment.markers in
837 try
838 let url = Url.Anchor.polymorphic_variant ~type_ident item in
839 let attrs =
840 [ "def"; "variant"; Url.Anchor.string_of_kind url.kind ]
841 in
842 let anchor = Some url in
843 let code = O.documentedSrc (O.txt "| ") @ cstr in
844 let doc = match doc with None -> [] | Some doc -> doc in
845 DocumentedSrc.Nested { attrs; anchor; code; doc; markers }
846 with Failure s ->
847 Printf.eprintf "ERROR: %s\n%!" s;
848 let code = O.documentedSrc (O.txt "| ") @ cstr in
849 let attrs = [ "def"; kind_approx ] in
850 let doc = [] in
851 let anchor = None in
852 DocumentedSrc.Nested { attrs; anchor; code; doc; markers }
853 in
854 let variants = List.map row t.elements in
855 let intro, ending =
856 match t.kind with
857 | Fixed -> (O.documentedSrc (O.txt "[ "), O.documentedSrc (O.txt " ]"))
858 | Open -> (O.documentedSrc (O.txt "[> "), O.documentedSrc (O.txt " ]"))
859 | Closed [] ->
860 (O.documentedSrc (O.txt "[< "), O.documentedSrc (O.txt " ]"))
861 | Closed lst ->
862 let constrs = String.concat ~sep:" " lst in
863 ( O.documentedSrc (O.txt "[< "),
864 O.documentedSrc (O.txt (" " ^ constrs ^ " ]")) )
865 in
866 intro @ variants @ ending
867
868 let format_params :
869 'row.
870 ?delim:[ `parens | `brackets ] ->
871 Odoc_model.Lang.TypeDecl.param list ->
872 text =
873 fun ?(delim = `parens) params ->
874 let format_param { Odoc_model.Lang.TypeDecl.desc; variance; injectivity }
875 =
876 let desc =
877 match desc with
878 | Odoc_model.Lang.TypeDecl.Any -> O.txt "_"
879 | Var (s, None) -> O.txt ("'" ^ s)
880 | Var (s, Some jkind) ->
881 O.txt ("('" ^ s ^ " : ") ++ O.mode jkind ++ O.txt ")"
882 in
883 let var_desc =
884 match variance with
885 | None -> desc
886 | Some Odoc_model.Lang.TypeDecl.Pos -> O.txt "+" ++ desc
887 | Some Odoc_model.Lang.TypeDecl.Neg -> O.txt "-" ++ desc
888 | Some Odoc_model.Lang.TypeDecl.Bivariant -> O.txt "+" ++ O.txt "-" ++ desc
889 in
890 if injectivity then O.txt "!" ++ var_desc else var_desc
891 in
892 match params with
893 | [] -> O.noop
894 | [ x ] -> Syntax.Type.handle_format_params (format_param x)
895 | lst ->
896 O.txt (match delim with `parens -> "(" | `brackets -> "[")
897 ++ O.list lst ~sep:(O.txt ", ") ~f:format_param
898 ++ O.txt (match delim with `parens -> ")" | `brackets -> "]")
899
900 let format_constraints constraints =
901 O.list constraints ~f:(fun (t1, t2) ->
902 O.sp
903 ++ (O.box_hv
904 @@ O.keyword "constraint" ++ O.sp
905 ++ O.box_hv_no_indent (type_expr t1)
906 ++ O.txt " =" ++ O.sp
907 ++ O.box_hv_no_indent (type_expr t2)))
908
909 let format_manifest :
910 'inner_row 'outer_row.
911 ?is_substitution:bool ->
912 ?compact_variants:bool ->
913 Odoc_model.Lang.TypeDecl.Equation.t ->
914 text * bool =
915 fun ?(is_substitution = false) ?(compact_variants = true) equation ->
916 let _ = compact_variants in
917 (* TODO *)
918 let private_ = equation.private_ in
919 match equation.manifest with
920 | None -> (O.noop, private_)
921 | Some t ->
922 let manifest =
923 O.txt (if is_substitution then " :=" else " =")
924 ++ O.sp
925 ++ (if private_ then
926 O.keyword Syntax.Type.private_keyword ++ O.txt " "
927 else O.noop)
928 ++ type_expr t
929 in
930 (manifest, false)
931
932 let type_decl ?(is_substitution = false)
933 ((recursive, t) : Lang.Signature.recursive * Lang.TypeDecl.t) =
934 let keyword' =
935 match recursive with
936 | Ordinary | Rec -> O.keyword "type"
937 | And -> O.keyword "and"
938 | Nonrec -> O.keyword "type" ++ O.txt " " ++ O.keyword "nonrec"
939 in
940 let tyname = Paths.Identifier.name t.id in
941 let tconstr =
942 match t.equation.params with
943 | [] -> O.txt tyname
944 | l ->
945 let params = format_params l in
946 Syntax.Type.handle_constructor_params (O.txt tyname) params
947 in
948 let intro = keyword' ++ O.txt " " ++ tconstr in
949 let constraints = format_constraints t.equation.constraints in
950 let manifest, need_private, long_prefix =
951 match t.equation.manifest with
952 | Some (Odoc_model.Lang.TypeExpr.Polymorphic_variant variant) ->
953 let code =
954 polymorphic_variant
955 ~type_ident:(t.id :> Paths.Identifier.t)
956 variant
957 in
958 let manifest =
959 O.documentedSrc
960 (O.ignore intro
961 ++ O.txt (if is_substitution then " :=" else " =")
962 ++ O.sp
963 ++
964 if t.equation.private_ then
965 O.keyword Syntax.Type.private_keyword ++ O.txt " "
966 else O.noop)
967 @ code
968 in
969 (manifest, false, O.noop)
970 | _ ->
971 let manifest, need_private =
972 format_manifest ~is_substitution t.equation
973 in
974 let text = O.ignore intro ++ manifest in
975 (O.documentedSrc @@ text, need_private, text)
976 in
977 let representation =
978 match t.representation with
979 | None -> []
980 | Some repr ->
981 let content =
982 match repr with
983 | Extensible -> O.documentedSrc (O.txt "..")
984 | Variant cstrs -> variant cstrs
985 | Record fields -> record fields
986 | Record_unboxed_product fields -> unboxed_record fields
987 in
988 if List.length content > 0 then
989 O.documentedSrc
990 (O.ignore long_prefix ++ O.txt " =" ++ O.sp
991 ++
992 if need_private then
993 O.keyword Syntax.Type.private_keyword ++ O.txt " "
994 else O.noop)
995 @ content
996 else []
997 in
998 let content =
999 O.documentedSrc intro @ manifest @ representation
1000 @ O.documentedSrc constraints
1001 @ O.documentedSrc
1002 (if Syntax.Type.type_def_semicolon then O.txt ";" else O.noop)
1003 in
1004 let attr = "type" :: (if is_substitution then [ "subst" ] else []) in
1005 let anchor = path_to_id t.id in
1006 let doc = Comment.to_ir t.doc.elements in
1007 let source_anchor = source_anchor t.source_loc in
1008 Item.Declaration { attr; anchor; doc; content; source_anchor }
1009 end
1010
1011 open Type_declaration
1012
1013 module Value : sig
1014 val value : Lang.Value.t -> Item.t
1015 end = struct
1016 let value (t : Odoc_model.Lang.Value.t) =
1017 let extra_attr, semicolon =
1018 match t.value with
1019 | Abstract -> ([], Syntax.Value.semicolon)
1020 | External _ -> ([ "external" ], Syntax.Type.External.semicolon)
1021 in
1022 let name = Paths.Identifier.name t.id in
1023 let content =
1024 O.documentedSrc
1025 (O.box_hv
1026 @@ O.keyword Syntax.Value.variable_keyword
1027 ++ O.txt " " ++ O.txt name
1028 ++ O.txt Syntax.Type.annotation_separator
1029 ++ O.cut ++ type_expr t.type_
1030 ++ (match t.modalities with
1031 | [] -> O.noop
1032 | ms -> O.txt " " ++ O.keyword "@@" ++ O.txt " "
1033 ++ mode_names ms)
1034 ++ if semicolon then O.txt ";" else O.noop)
1035 in
1036 let attr = [ "value" ] @ extra_attr in
1037 let anchor = path_to_id t.id in
1038 let doc = Comment.to_ir t.doc.elements in
1039 let source_anchor = source_anchor t.source_loc in
1040 Item.Declaration { attr; anchor; doc; content; source_anchor }
1041 end
1042
1043 open Value
1044
1045 (* This chunk of code is responsible for sectioning list of items
1046 according to headings by extracting headings as Items.
1047
1048 TODO: This sectioning would be better done as a pass on the model directly.
1049 *)
1050 module Sectioning : sig
1051 open Odoc_model
1052
1053 val comment_items : Comment.elements -> Item.t list
1054
1055 val docs : Comment.elements -> Item.t list * Item.t list
1056 end = struct
1057 let take_until_heading_or_end (docs : Odoc_model.Comment.elements) =
1058 let content, _, rest =
1059 Doctree.Take.until docs ~classify:(fun b ->
1060 match b.Location.value with
1061 | `Heading _ -> Stop_and_keep
1062 | #Odoc_model.Comment.attached_block_element as doc ->
1063 let content = Comment.attached_block_element doc in
1064 Accum content)
1065 in
1066 (content, rest)
1067
1068 let comment_items (input0 : Odoc_model.Comment.elements) =
1069 let rec loop input_comment acc =
1070 match input_comment with
1071 | [] -> List.rev acc
1072 | element :: input_comment -> (
1073 match element.Location.value with
1074 | `Heading h ->
1075 let item = Comment.heading h in
1076 loop input_comment (item :: acc)
1077 | _ ->
1078 let content, input_comment =
1079 take_until_heading_or_end (element :: input_comment)
1080 in
1081 let item = Item.Text content in
1082 loop input_comment (item :: acc))
1083 in
1084 loop input0 []
1085
1086 (* For doc pages, we want the header to contain everything until
1087 the first heading, then everything before the next heading which
1088 is either lower, or a section.
1089 *)
1090 let docs input_comment =
1091 let items = comment_items input_comment in
1092 let until_first_heading, o, items =
1093 Doctree.Take.until items ~classify:(function
1094 | Item.Heading h as i -> Stop_and_accum ([ i ], Some h.level)
1095 | i -> Accum [ i ])
1096 in
1097 match o with
1098 | None -> (until_first_heading, items)
1099 | Some level ->
1100 let max_level = if level = 1 then 2 else level in
1101 let before_second_heading, _, items =
1102 Doctree.Take.until items ~classify:(function
1103 | Item.Heading h when h.level >= max_level -> Stop_and_keep
1104 | i -> Accum [ i ])
1105 in
1106 let header = until_first_heading @ before_second_heading in
1107 (header, items)
1108 end
1109
1110 module Class : sig
1111 val class_ : Lang.Class.t -> Item.t
1112
1113 val class_type : Lang.ClassType.t -> Item.t
1114 end = struct
1115 let class_type_expr (cte : Odoc_model.Lang.ClassType.expr) =
1116 match cte with
1117 | Constr (path, args) ->
1118 let link = Link.from_path (path :> Paths.Path.t) in
1119 format_type_path ~delim:`brackets args link
1120 | Signature _ ->
1121 Syntax.Class.open_tag ++ O.txt " ... " ++ Syntax.Class.close_tag
1122
1123 let method_ (t : Odoc_model.Lang.Method.t) =
1124 let name = Paths.Identifier.name t.id in
1125 let virtual_ =
1126 if t.virtual_ then O.keyword "virtual" ++ O.txt " " else O.noop
1127 in
1128 let private_ =
1129 if t.private_ then O.keyword "private" ++ O.txt " " else O.noop
1130 in
1131 let content =
1132 O.documentedSrc
1133 (O.keyword "method" ++ O.txt " " ++ private_ ++ virtual_ ++ O.txt name
1134 ++ O.txt Syntax.Type.annotation_separator
1135 ++ type_expr t.type_)
1136 in
1137 let attr = [ "method" ] in
1138 let anchor = path_to_id t.id in
1139 let doc = Comment.to_ir t.doc.elements in
1140 Item.Declaration { attr; anchor; doc; content; source_anchor = None }
1141
1142 let instance_variable (t : Odoc_model.Lang.InstanceVariable.t) =
1143 let name = Paths.Identifier.name t.id in
1144 let virtual_ =
1145 if t.virtual_ then O.keyword "virtual" ++ O.txt " " else O.noop
1146 in
1147 let mutable_ =
1148 if t.mutable_ then O.keyword "mutable" ++ O.txt " " else O.noop
1149 in
1150 let content =
1151 O.documentedSrc
1152 (O.keyword "val" ++ O.txt " " ++ mutable_ ++ virtual_ ++ O.txt name
1153 ++ O.txt Syntax.Type.annotation_separator
1154 ++ type_expr t.type_)
1155 in
1156 let attr = [ "value"; "instance-variable" ] in
1157 let anchor = path_to_id t.id in
1158 let doc = Comment.to_ir t.doc.elements in
1159 Item.Declaration { attr; anchor; doc; content; source_anchor = None }
1160
1161 let inherit_ (ih : Lang.ClassSignature.Inherit.t) =
1162 let cte =
1163 match ih.expr with
1164 | Signature _ -> assert false (* Bold. *)
1165 | cty -> cty
1166 in
1167 let content =
1168 O.documentedSrc (O.keyword "inherit" ++ O.txt " " ++ class_type_expr cte)
1169 in
1170 let attr = [ "inherit" ] in
1171 let anchor = None in
1172 let doc = Comment.to_ir ih.doc.elements in
1173 Item.Declaration { attr; anchor; doc; content; source_anchor = None }
1174
1175 let constraint_ (cst : Lang.ClassSignature.Constraint.t) =
1176 let content =
1177 O.documentedSrc (format_constraints [ (cst.left, cst.right) ])
1178 in
1179 let attr = [] in
1180 let anchor = None in
1181 let doc = Comment.to_ir cst.doc.elements in
1182 Item.Declaration { attr; anchor; doc; content; source_anchor = None }
1183
1184 let class_signature (c : Lang.ClassSignature.t) =
1185 let rec loop l acc_items =
1186 match l with
1187 | [] -> List.rev acc_items
1188 | item :: rest -> (
1189 let continue item = loop rest (item :: acc_items) in
1190 match (item : Lang.ClassSignature.item) with
1191 | Inherit cty -> continue @@ inherit_ cty
1192 | Method m -> continue @@ method_ m
1193 | InstanceVariable v -> continue @@ instance_variable v
1194 | Constraint cst -> continue @@ constraint_ cst
1195 | Comment `Stop ->
1196 let rest =
1197 List.skip_until rest ~p:(function
1198 | Lang.ClassSignature.Comment `Stop -> true
1199 | _ -> false)
1200 in
1201 loop rest acc_items
1202 | Comment (`Docs c) ->
1203 let items = Sectioning.comment_items c.elements in
1204 loop rest (List.rev_append items acc_items))
1205 in
1206 (* FIXME: use [t.self] *)
1207 (c.doc.elements, loop c.items [])
1208
1209 let rec class_decl (cd : Odoc_model.Lang.Class.decl) =
1210 match cd with
1211 | ClassType expr -> class_type_expr expr
1212 (* TODO: factorize the following with [type_expr] *)
1213 | Arrow (None, src, dst) ->
1214 O.span
1215 (type_expr ~needs_parentheses:true src
1216 ++ O.txt " " ++ Syntax.Type.arrow)
1217 ++ O.txt " " ++ class_decl dst
1218 | Arrow (Some (RawOptional _ as lbl), _src, dst) ->
1219 O.span
1220 (O.box_hv
1221 @@ label lbl ++ O.txt ":"
1222 ++ tag "error" (O.txt "???")
1223 ++ O.txt " " ++ Syntax.Type.arrow)
1224 ++ O.sp ++ class_decl dst
1225 | Arrow (Some lbl, src, dst) ->
1226 O.span
1227 (label lbl ++ O.txt ":"
1228 ++ type_expr ~needs_parentheses:true src
1229 ++ O.txt " " ++ Syntax.Type.arrow)
1230 ++ O.txt " " ++ class_decl dst
1231
1232 let class_ (t : Odoc_model.Lang.Class.t) =
1233 let name = Paths.Identifier.name t.id in
1234 let params =
1235 match t.params with
1236 | [] -> O.noop
1237 | _ :: _ as params -> format_params ~delim:`brackets params ++ O.txt " "
1238 in
1239 let virtual_ =
1240 if t.virtual_ then O.keyword "virtual" ++ O.txt " " else O.noop
1241 in
1242
1243 let source_anchor = source_anchor t.source_loc in
1244 let cname, expansion, expansion_doc =
1245 match t.expansion with
1246 | None -> (O.documentedSrc @@ O.txt name, None, None)
1247 | Some csig ->
1248 let expansion_doc, items = class_signature csig in
1249 let url = Url.Path.from_identifier t.id in
1250 let page =
1251 make_expansion_page ~source_anchor url
1252 [ t.doc.elements; expansion_doc ]
1253 items
1254 in
1255 ( O.documentedSrc @@ path url [ inline @@ Text name ],
1256 Some page,
1257 Some expansion_doc )
1258 in
1259 let summary =
1260 O.txt Syntax.Type.annotation_separator ++ class_decl t.type_
1261 in
1262 let cd =
1263 attach_expansion
1264 (Syntax.Type.annotation_separator, "object", "end")
1265 expansion summary
1266 in
1267 let content =
1268 O.documentedSrc (O.keyword "class" ++ O.txt " " ++ virtual_ ++ params)
1269 @ cname @ cd
1270 in
1271 let attr = [ "class" ] in
1272 let anchor = path_to_id t.id in
1273 let doc = Comment.synopsis ~decl_doc:t.doc.elements ~expansion_doc in
1274 Item.Declaration { attr; anchor; doc; content; source_anchor }
1275
1276 let class_type (t : Odoc_model.Lang.ClassType.t) =
1277 let name = Paths.Identifier.name t.id in
1278 let params = format_params ~delim:`brackets t.params in
1279 let virtual_ =
1280 if t.virtual_ then O.keyword "virtual" ++ O.txt " " else O.noop
1281 in
1282 let source_anchor = source_anchor t.source_loc in
1283 let cname, expansion, expansion_doc =
1284 match t.expansion with
1285 | None -> (O.documentedSrc @@ O.txt name, None, None)
1286 | Some csig ->
1287 let url = Url.Path.from_identifier t.id in
1288 let expansion_doc, items = class_signature csig in
1289 let page =
1290 make_expansion_page ~source_anchor url
1291 [ t.doc.elements; expansion_doc ]
1292 items
1293 in
1294 ( O.documentedSrc @@ path url [ inline @@ Text name ],
1295 Some page,
1296 Some expansion_doc )
1297 in
1298 let summary = O.txt " = " ++ class_type_expr t.expr in
1299 let expr = attach_expansion (" = ", "object", "end") expansion summary in
1300 let content =
1301 O.documentedSrc
1302 (O.keyword "class" ++ O.txt " " ++ O.keyword "type" ++ O.txt " "
1303 ++ virtual_ ++ params ++ O.txt " ")
1304 @ cname @ expr
1305 in
1306 let attr = [ "class-type" ] in
1307 let anchor = path_to_id t.id in
1308 let doc = Comment.synopsis ~decl_doc:t.doc.elements ~expansion_doc in
1309 Item.Declaration { attr; anchor; doc; content; source_anchor }
1310 end
1311
1312 open Class
1313
1314 module Module : sig
1315 val signature : Lang.Signature.t -> Comment.Comment.elements * Item.t list
1316 (** Returns [header_doc, content]. *)
1317 end = struct
1318 let internal_module m =
1319 let open Lang.Module in
1320 match m.id.iv with
1321 | `Module (_, name) when ModuleName.is_hidden name -> true
1322 | _ -> false
1323
1324 let internal_type t =
1325 let open Lang.TypeDecl in
1326 match t.id.iv with
1327 | `Type (_, name) when TypeName.is_hidden name -> true
1328 | _ -> false
1329
1330 let internal_value v =
1331 let open Lang.Value in
1332 match v.id.iv with
1333 | `Value (_, name) when ValueName.is_hidden name -> true
1334 | _ -> false
1335
1336 let internal_module_type t =
1337 let open Lang.ModuleType in
1338 match t.id.iv with
1339 | `ModuleType (_, name) when ModuleTypeName.is_hidden name -> true
1340 | _ -> false
1341
1342 let internal_module_substitution t =
1343 let open Lang.ModuleSubstitution in
1344 match t.id.iv with
1345 | `Module (_, name) when ModuleName.is_hidden name -> true
1346 | _ -> false
1347
1348 let internal_module_type_substitution t =
1349 let open Lang.ModuleTypeSubstitution in
1350 match t.id.iv with
1351 | `ModuleType (_, name) when ModuleTypeName.is_hidden name -> true
1352 | _ -> false
1353
1354 let rec signature (s : Lang.Signature.t) =
1355 let rec loop l acc_items =
1356 match l with
1357 | [] -> List.rev acc_items
1358 | item :: rest -> (
1359 let continue (item : Item.t) = loop rest (item :: acc_items) in
1360 match (item : Lang.Signature.item) with
1361 | Module (_, m) when internal_module m -> loop rest acc_items
1362 | Type (_, t) when internal_type t -> loop rest acc_items
1363 | Value v when internal_value v -> loop rest acc_items
1364 | ModuleType m when internal_module_type m -> loop rest acc_items
1365 | ModuleSubstitution m when internal_module_substitution m ->
1366 loop rest acc_items
1367 | ModuleTypeSubstitution m when internal_module_type_substitution m
1368 ->
1369 loop rest acc_items
1370 | ModuleTypeSubstitution m -> continue @@ module_type_substitution m
1371 | Module (_, m) -> continue @@ module_ m
1372 | ModuleType m -> continue @@ module_type m
1373 | Class (_, c) -> continue @@ class_ c
1374 | ClassType (_, c) -> continue @@ class_type c
1375 | Include m -> continue @@ include_ m
1376 | ModuleSubstitution m -> continue @@ module_substitution m
1377 | TypeSubstitution t ->
1378 continue @@ type_decl ~is_substitution:true (Ordinary, t)
1379 | Type (r, t) -> continue @@ type_decl (r, t)
1380 | TypExt e -> continue @@ extension e
1381 | Exception e -> continue @@ exn e
1382 | Value v -> continue @@ value v
1383 | Open o ->
1384 let items = Sectioning.comment_items o.doc.elements in
1385 loop rest (List.rev_append items acc_items)
1386 | Comment `Stop ->
1387 let rest =
1388 List.skip_until rest ~p:(function
1389 | Lang.Signature.Comment `Stop -> true
1390 | _ -> false)
1391 in
1392 loop rest acc_items
1393 | Comment (`Docs c) ->
1394 let items = Sectioning.comment_items c.elements in
1395 loop rest (List.rev_append items acc_items))
1396 in
1397 ((Lang.extract_signature_doc s).elements, loop s.items [])
1398
1399 and functor_parameter :
1400 Odoc_model.Lang.FunctorParameter.parameter -> DocumentedSrc.t =
1401 fun arg ->
1402 let open Odoc_model.Lang.FunctorParameter in
1403 let name = Paths.Identifier.name arg.id in
1404 let render_ty = arg.expr in
1405 let modtyp =
1406 mty_in_decl (arg.id :> Paths.Identifier.Signature.t) render_ty
1407 in
1408 let modname, mod_decl =
1409 match expansion_of_module_type_expr arg.expr with
1410 | None ->
1411 let modname = O.txt (Paths.Identifier.name arg.id) in
1412 (modname, O.documentedSrc modtyp)
1413 | Some (expansion_doc, items) ->
1414 let url = Url.Path.from_identifier arg.id in
1415 let modname = path url [ inline @@ Text name ] in
1416 let type_with_expansion =
1417 let content =
1418 make_expansion_page ~source_anchor:None url [ expansion_doc ]
1419 items
1420 in
1421 let summary = O.render modtyp in
1422 let status = `Default in
1423 let expansion =
1424 O.documentedSrc
1425 (O.txt Syntax.Type.annotation_separator ++ O.keyword "sig")
1426 @ DocumentedSrc.[ Subpage { content; status } ]
1427 @ O.documentedSrc (O.keyword "end")
1428 in
1429 DocumentedSrc.
1430 [
1431 Alternative
1432 (Expansion { status = `Default; summary; url; expansion });
1433 ]
1434 in
1435 (modname, type_with_expansion)
1436 in
1437 O.documentedSrc (O.keyword "module" ++ O.txt " ")
1438 @ O.documentedSrc modname @ mod_decl
1439
1440 and module_substitution (t : Odoc_model.Lang.ModuleSubstitution.t) =
1441 let name = Paths.Identifier.name t.id in
1442 let path = Link.from_path (t.manifest :> Paths.Path.t) in
1443 let content =
1444 O.documentedSrc
1445 (O.keyword "module" ++ O.txt " " ++ O.txt name ++ O.txt " :=" ++ O.sp
1446 ++ path)
1447 in
1448 let attr = [ "module-substitution" ] in
1449 let anchor = path_to_id t.id in
1450 let doc = Comment.to_ir t.doc.elements in
1451 Item.Declaration { attr; anchor; doc; content; source_anchor = None }
1452
1453 and module_type_substitution (t : Odoc_model.Lang.ModuleTypeSubstitution.t)
1454 =
1455 let prefix =
1456 O.keyword "module" ++ O.txt " " ++ O.keyword "type" ++ O.txt " "
1457 in
1458 let source_anchor = None in
1459 let modname = Paths.Identifier.name t.id in
1460 let modname, expansion_doc, mty =
1461 module_type_manifest ~subst:true ~source_anchor modname t.id
1462 t.doc.elements (Some t.manifest) prefix
1463 in
1464 let content =
1465 O.documentedSrc (prefix ++ modname)
1466 @ mty
1467 @ O.documentedSrc
1468 (if Syntax.Mod.close_tag_semicolon then O.txt ";" else O.noop)
1469 in
1470 let attr = [ "module-type" ] in
1471 let anchor = path_to_id t.id in
1472 let doc = Comment.synopsis ~decl_doc:t.doc.elements ~expansion_doc in
1473 Item.Declaration { attr; anchor; doc; content; source_anchor }
1474
1475 and simple_expansion :
1476 Odoc_model.Lang.ModuleType.simple_expansion ->
1477 Comment.Comment.elements * Item.t list =
1478 fun t ->
1479 let rec extract_functor_params
1480 (f : Odoc_model.Lang.ModuleType.simple_expansion) =
1481 match f with
1482 | Signature sg -> (None, sg)
1483 | Functor (p, expansion) ->
1484 let add_to params =
1485 match p with Unit -> params | Named p -> p :: params
1486 in
1487 let params, sg = extract_functor_params expansion in
1488 let params = match params with None -> [] | Some p -> p in
1489 (Some (add_to params), sg)
1490 in
1491 match extract_functor_params t with
1492 | None, sg -> signature sg
1493 | Some params, sg ->
1494 let sg_doc, content = signature sg in
1495 let params =
1496 let decl_of_arg arg =
1497 let content = functor_parameter arg in
1498 let attr = [ "parameter" ] in
1499 let anchor =
1500 Some (Url.Anchor.from_identifier (arg.id :> Paths.Identifier.t))
1501 in
1502 let doc = [] in
1503 [
1504 Item.Declaration
1505 { content; anchor; attr; doc; source_anchor = None };
1506 ]
1507 in
1508 List.concat_map decl_of_arg params
1509 in
1510 let prelude = mk_heading ~label:"parameters" "Parameters" :: params
1511 and content = mk_heading ~label:"signature" "Signature" :: content in
1512 (sg_doc, prelude @ content)
1513
1514 and expansion_of_module_type_expr :
1515 Odoc_model.Lang.ModuleType.expr ->
1516 (Comment.Comment.elements * Item.t list) option =
1517 fun t ->
1518 let rec simple_expansion_of (t : Odoc_model.Lang.ModuleType.expr) =
1519 match t with
1520 | Path { p_expansion = None; _ }
1521 | TypeOf { t_expansion = None; _ }
1522 | With { w_expansion = None; _ }
1523 | Strengthen { s_expansion = None; _ } ->
1524 None
1525 | Path { p_expansion = Some e; _ }
1526 | TypeOf { t_expansion = Some e; _ }
1527 | With { w_expansion = Some e; _ }
1528 | Strengthen { s_expansion = Some e; _ } ->
1529 Some e
1530 | Signature sg -> Some (Signature sg)
1531 | Functor (f_parameter, e) -> (
1532 match simple_expansion_of e with
1533 | Some e -> Some (Functor (f_parameter, e))
1534 | None -> None)
1535 in
1536 match simple_expansion_of t with
1537 | None -> None
1538 | Some e -> Some (simple_expansion e)
1539
1540 and module_ : Odoc_model.Lang.Module.t -> Item.t =
1541 fun t ->
1542 let modname = Paths.Identifier.name t.id in
1543 let expansion =
1544 match t.type_ with
1545 | Alias (_, Some e) -> Some (simple_expansion e)
1546 | Alias (_, None) -> None
1547 | ModuleType e -> expansion_of_module_type_expr e
1548 in
1549 let source_anchor = source_anchor t.source_loc in
1550 let modname, status, expansion, expansion_doc =
1551 match expansion with
1552 | None -> (O.txt modname, `Default, None, None)
1553 | Some (expansion_doc, items) ->
1554 let status =
1555 match t.type_ with
1556 | ModuleType (Signature _) -> `Inline
1557 | _ -> `Default
1558 in
1559 let url = Url.Path.from_identifier t.id in
1560 let link = path url [ inline @@ Text modname ] in
1561 let page =
1562 make_expansion_page ~source_anchor url
1563 [ t.doc.elements; expansion_doc ]
1564 items
1565 in
1566 (link, status, Some page, Some expansion_doc)
1567 in
1568 let intro = O.keyword "module" ++ O.txt " " ++ modname in
1569 let summary = O.ignore intro ++ mdexpr_in_decl t.id t.type_ in
1570 let modexpr =
1571 attach_expansion ~status
1572 (Syntax.Type.annotation_separator, "sig", "end")
1573 expansion summary
1574 in
1575 let content =
1576 O.documentedSrc intro @ modexpr
1577 @ O.documentedSrc
1578 (if Syntax.Mod.close_tag_semicolon then O.txt ";" else O.noop)
1579 in
1580 let attr = [ "module" ] in
1581 let anchor = path_to_id t.id in
1582 let doc = Comment.synopsis ~decl_doc:t.doc.elements ~expansion_doc in
1583 Item.Declaration { attr; anchor; doc; content; source_anchor }
1584
1585 and simple_expansion_in_decl (base : Paths.Identifier.Module.t) se =
1586 let rec ty_of_se :
1587 Lang.ModuleType.simple_expansion -> Lang.ModuleType.expr = function
1588 | Signature sg -> Signature sg
1589 | Functor (arg, sg) -> Functor (arg, ty_of_se sg)
1590 in
1591 mty_in_decl (base :> Paths.Identifier.Signature.t) (ty_of_se se)
1592
1593 and mdexpr_in_decl (base : Paths.Identifier.Module.t) md =
1594 let sig_dotdotdot =
1595 O.txt Syntax.Type.annotation_separator
1596 ++ O.cut ++ Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag
1597 in
1598 match md with
1599 | Alias (_, Some se) -> simple_expansion_in_decl base se
1600 | Alias (p, _) when not Paths.Path.(is_hidden (p :> t)) ->
1601 O.txt " =" ++ O.sp ++ mdexpr md
1602 | Alias _ -> sig_dotdotdot
1603 | ModuleType mt -> mty_in_decl (base :> Paths.Identifier.Signature.t) mt
1604
1605 and mdexpr : Odoc_model.Lang.Module.decl -> text = function
1606 | Alias (mod_path, _) -> Link.from_path (mod_path :> Paths.Path.t)
1607 | ModuleType mt -> mty mt
1608
1609 and module_type_manifest ~subst ~source_anchor modname id doc manifest
1610 prefix =
1611 let expansion =
1612 match manifest with
1613 | None -> None
1614 | Some e -> expansion_of_module_type_expr e
1615 in
1616 let modname, expansion, expansion_doc =
1617 match expansion with
1618 | None -> (O.txt modname, None, None)
1619 | Some (expansion_doc, items) ->
1620 let url = Url.Path.from_identifier id in
1621 let link = path url [ inline @@ Text modname ] in
1622 let page =
1623 make_expansion_page ~source_anchor url [ doc; expansion_doc ]
1624 items
1625 in
1626 (link, Some page, Some expansion_doc)
1627 in
1628 let summary =
1629 match manifest with
1630 | None -> O.noop
1631 | Some expr ->
1632 O.ignore (prefix ++ modname)
1633 ++ (if subst then O.txt " :=" ++ O.sp else O.txt " =" ++ O.sp)
1634 ++ mty expr
1635 in
1636 ( modname,
1637 expansion_doc,
1638 attach_expansion (" = ", "sig", "end") expansion summary )
1639
1640 and module_type (t : Odoc_model.Lang.ModuleType.t) =
1641 let prefix =
1642 O.keyword "module" ++ O.txt " " ++ O.keyword "type" ++ O.txt " "
1643 in
1644 let modname = Paths.Identifier.name t.id in
1645 let source_anchor = source_anchor t.source_loc in
1646 let modname, expansion_doc, mty =
1647 module_type_manifest ~subst:false ~source_anchor modname t.id
1648 t.doc.elements t.expr prefix
1649 in
1650 let content =
1651 O.documentedSrc (prefix ++ modname)
1652 @ mty
1653 @ O.documentedSrc
1654 (if Syntax.Mod.close_tag_semicolon then O.txt ";" else O.noop)
1655 in
1656 let attr = [ "module-type" ] in
1657 let anchor = path_to_id t.id in
1658 let doc = Comment.synopsis ~decl_doc:t.doc.elements ~expansion_doc in
1659 Item.Declaration { attr; anchor; doc; content; source_anchor }
1660
1661 and umty_hidden : Odoc_model.Lang.ModuleType.U.expr -> bool = function
1662 | Path p -> Paths.Path.(is_hidden (p :> t))
1663 | With (_, expr) -> umty_hidden expr
1664 | TypeOf (ModPath m, _) | TypeOf (StructInclude m, _) ->
1665 Paths.Path.(is_hidden (m :> t))
1666 | Signature _ -> false
1667 | Strengthen (expr, p, _) ->
1668 umty_hidden expr || Paths.Path.(is_hidden (p :> t))
1669
1670 and mty_hidden : Odoc_model.Lang.ModuleType.expr -> bool = function
1671 | Path { p_path = mty_path; _ } -> Paths.Path.(is_hidden (mty_path :> t))
1672 | With { w_expr; _ } -> umty_hidden w_expr
1673 | TypeOf { t_desc = ModPath m; _ }
1674 | TypeOf { t_desc = StructInclude m; _ } ->
1675 Paths.Path.(is_hidden (m :> t))
1676 | _ -> false
1677
1678 and mty_with subs expr =
1679 umty expr ++ O.sp ++ O.keyword "with" ++ O.txt " "
1680 ++ O.list
1681 ~sep:(O.cut ++ O.txt " " ++ O.keyword "and" ++ O.txt " ")
1682 ~f:(fun x -> O.span (substitution x))
1683 subs
1684
1685 and mty_strengthen expr path =
1686 umty expr ++ O.sp ++ O.keyword "with" ++ O.txt " "
1687 ++ Link.from_path (path :> Paths.Path.t)
1688
1689 and mty_typeof t_desc =
1690 match t_desc with
1691 | Odoc_model.Lang.ModuleType.ModPath m ->
1692 O.keyword "module" ++ O.txt " " ++ O.keyword "type" ++ O.txt " "
1693 ++ O.keyword "of" ++ O.txt " "
1694 ++ Link.from_path (m :> Paths.Path.t)
1695 | StructInclude m ->
1696 O.keyword "module" ++ O.txt " " ++ O.keyword "type" ++ O.txt " "
1697 ++ O.keyword "of" ++ O.txt " " ++ O.keyword "struct" ++ O.txt " "
1698 ++ O.keyword "include" ++ O.txt " "
1699 ++ Link.from_path (m :> Paths.Path.t)
1700 ++ O.txt " " ++ O.keyword "end"
1701
1702 and is_elidable_with_u : Odoc_model.Lang.ModuleType.U.expr -> bool =
1703 function
1704 | Path _ -> false
1705 | Signature _ -> true
1706 | With (_, expr) -> is_elidable_with_u expr
1707 | TypeOf _ -> false
1708 | Strengthen (expr,_,_) -> is_elidable_with_u expr
1709
1710 and umty : Odoc_model.Lang.ModuleType.U.expr -> text =
1711 fun m ->
1712 match m with
1713 | Path p -> Link.from_path (p :> Paths.Path.t)
1714 | Signature _ ->
1715 Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag
1716 | With (_, expr) when is_elidable_with_u expr ->
1717 Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag
1718 | With (subs, expr) -> mty_with subs expr
1719 | TypeOf (t_desc, _) -> mty_typeof t_desc
1720 | Strengthen (expr, _, _) when is_elidable_with_u expr ->
1721 Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag
1722 | Strengthen (expr, p, _) -> mty_strengthen expr (p :> Paths.Path.t)
1723
1724 and mty : Odoc_model.Lang.ModuleType.expr -> text =
1725 fun m ->
1726 if mty_hidden m then
1727 Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag
1728 else
1729 match m with
1730 | Path { p_path = mty_path; _ } ->
1731 Link.from_path (mty_path :> Paths.Path.t)
1732 | Functor (Unit, expr) ->
1733 (if Syntax.Mod.functor_keyword then O.keyword "functor" else O.noop)
1734 ++ O.span (O.txt " () " ++ Syntax.Type.arrow)
1735 ++ O.sp ++ mty expr
1736 | Functor (Named arg, expr) ->
1737 let arg_expr = arg.expr in
1738 let stop_before = expansion_of_module_type_expr arg_expr = None in
1739 let name =
1740 let open Odoc_model.Lang.FunctorParameter in
1741 let name = Paths.Identifier.name arg.id in
1742 let href =
1743 Url.from_identifier ~stop_before (arg.id :> Paths.Identifier.t)
1744 in
1745 resolved href [ inline @@ Text name ]
1746 in
1747 (if Syntax.Mod.functor_keyword then O.keyword "functor" else O.noop)
1748 ++ (O.box_hv @@ O.span
1749 @@ O.txt " (" ++ name
1750 ++ O.txt Syntax.Type.annotation_separator
1751 ++ mty arg_expr ++ O.txt ")" ++ O.txt " " ++ Syntax.Type.arrow
1752 )
1753 ++ O.sp ++ mty expr
1754 | With { w_expr; _ } when is_elidable_with_u w_expr ->
1755 Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag
1756 | With { w_substitutions; w_expr; _ } ->
1757 O.box_hv @@ mty_with w_substitutions w_expr
1758 | TypeOf { t_desc; _ } -> mty_typeof t_desc
1759 | Signature _ ->
1760 Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag
1761 | Strengthen { s_expr; _ } when is_elidable_with_u s_expr ->
1762 Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag
1763 | Strengthen { s_expr; s_path; _ } ->
1764 O.box_hv @@ mty_strengthen s_expr (s_path :> Paths.Path.t)
1765 and mty_in_decl :
1766 Paths.Identifier.Signature.t -> Odoc_model.Lang.ModuleType.expr -> text
1767 =
1768 fun base -> function
1769 | (Path _ | Signature _ | With _ | TypeOf _ | Strengthen _) as m ->
1770 O.txt Syntax.Type.annotation_separator ++ O.cut ++ mty m
1771 | Functor _ as m when not Syntax.Mod.functor_contraction ->
1772 O.txt Syntax.Type.annotation_separator ++ O.cut ++ mty m
1773 | Functor (arg, expr) ->
1774 let text_arg =
1775 match arg with
1776 | Unit -> O.txt "()"
1777 | Named arg ->
1778 let arg_expr = arg.expr in
1779 let stop_before =
1780 expansion_of_module_type_expr arg_expr = None
1781 in
1782 let name =
1783 let open Odoc_model.Lang.FunctorParameter in
1784 let name = Paths.Identifier.name arg.id in
1785 let href =
1786 Url.from_identifier ~stop_before
1787 (arg.id :> Paths.Identifier.t)
1788 in
1789 resolved href [ inline @@ Text name ]
1790 in
1791 O.box_hv
1792 @@ O.txt "(" ++ name
1793 ++ O.txt Syntax.Type.annotation_separator
1794 ++ O.cut ++ mty arg.expr ++ O.txt ")"
1795 in
1796 O.sp ++ text_arg ++ mty_in_decl base expr
1797
1798 (* TODO : Centralize the list juggling for type parameters *)
1799 and type_expr_in_subst td typath =
1800 let typath = Link.from_fragment typath in
1801 match td.Lang.TypeDecl.Equation.params with
1802 | [] -> typath
1803 | l -> Syntax.Type.handle_substitution_params typath (format_params l)
1804
1805 and substitution : Odoc_model.Lang.ModuleType.substitution -> text =
1806 function
1807 | ModuleEq (frag_mod, md) ->
1808 O.box_hv
1809 @@ O.keyword "module" ++ O.txt " "
1810 ++ Link.from_fragment (frag_mod :> Paths.Fragment.leaf)
1811 ++ O.txt " =" ++ O.sp ++ mdexpr md
1812 | ModuleTypeEq (frag_mty, md) ->
1813 O.box_hv
1814 @@ O.keyword "module" ++ O.txt " " ++ O.keyword "type" ++ O.txt " "
1815 ++ Link.from_fragment (frag_mty :> Paths.Fragment.leaf)
1816 ++ O.txt " =" ++ O.sp ++ mty md
1817 | TypeEq (frag_typ, td) ->
1818 O.box_hv
1819 @@ O.keyword "type" ++ O.txt " "
1820 ++ type_expr_in_subst td (frag_typ :> Paths.Fragment.leaf)
1821 ++ fst (format_manifest td)
1822 ++ format_constraints
1823 td.Odoc_model.Lang.TypeDecl.Equation.constraints
1824 | ModuleSubst (frag_mod, mod_path) ->
1825 O.box_hv
1826 @@ O.keyword "module" ++ O.txt " "
1827 ++ Link.from_fragment (frag_mod :> Paths.Fragment.leaf)
1828 ++ O.txt " :=" ++ O.sp
1829 ++ Link.from_path (mod_path :> Paths.Path.t)
1830 | ModuleTypeSubst (frag_mty, md) ->
1831 O.box_hv
1832 @@ O.keyword "module" ++ O.txt " " ++ O.keyword "type" ++ O.txt " "
1833 ++ Link.from_fragment (frag_mty :> Paths.Fragment.leaf)
1834 ++ O.txt " :=" ++ O.sp ++ mty md
1835 | TypeSubst (frag_typ, td) -> (
1836 O.box_hv
1837 @@ O.keyword "type" ++ O.txt " "
1838 ++ type_expr_in_subst td (frag_typ :> Paths.Fragment.leaf)
1839 ++ O.txt " :=" ++ O.sp
1840 ++
1841 match td.Lang.TypeDecl.Equation.manifest with
1842 | None -> assert false (* cf loader/cmti *)
1843 | Some te -> type_expr te)
1844
1845 and include_ (t : Odoc_model.Lang.Include.t) =
1846 let decl_hidden =
1847 match t.decl with
1848 | Alias p -> Paths.Path.(is_hidden (p :> t))
1849 | ModuleType mty -> umty_hidden mty
1850 in
1851 let status = if decl_hidden then `Inline else t.status in
1852
1853 let _, content = signature t.expansion.content in
1854 let summary =
1855 if decl_hidden then O.render (O.keyword "include" ++ O.txt " ...")
1856 else
1857 let include_decl =
1858 match t.decl with
1859 | Odoc_model.Lang.Include.Alias mod_path ->
1860 Link.from_path (mod_path :> Paths.Path.t)
1861 | ModuleType mt -> umty mt
1862 in
1863 O.render
1864 (O.keyword "include" ++ O.txt " " ++ include_decl
1865 ++ if Syntax.Mod.include_semicolon then O.keyword ";" else O.noop)
1866 in
1867 let content = { Include.content; status; summary } in
1868 let attr = [ "include" ] in
1869 let anchor = None in
1870 let doc =
1871 (* Documentation attached to includes behave differently than other
1872 declarations, which show only the synopsis. We can't only show the
1873 synopsis because no page is generated to render it and we'd loose
1874 the full documentation.
1875 The documentation from the expansion is not used. *)
1876 Comment.to_ir t.doc.elements
1877 in
1878 Item.Include { attr; anchor; doc; content; source_anchor = None }
1879 end
1880
1881 open Module
1882
1883 module Page : sig
1884 val compilation_unit : Lang.Compilation_unit.t -> Document.t
1885
1886 val page : Lang.Page.t -> Document.t
1887
1888 val implementation :
1889 Lang.Implementation.t ->
1890 Syntax_highlighter.infos ->
1891 string ->
1892 Document.t list
1893 end = struct
1894 let pack : Lang.Compilation_unit.Packed.t -> Item.t list =
1895 fun t ->
1896 let f x =
1897 let id = x.Lang.Compilation_unit.Packed.id in
1898 let modname = Paths.Identifier.name id in
1899 let md_def =
1900 O.keyword "module" ++ O.txt " " ++ O.txt modname ++ O.txt " = "
1901 ++ Link.from_path (x.path :> Paths.Path.t)
1902 in
1903 let content = O.documentedSrc md_def in
1904 let anchor =
1905 Some (Url.Anchor.from_identifier (id :> Paths.Identifier.t))
1906 in
1907 let attr = [ "modules" ] in
1908 let doc = [] in
1909 let decl = { Item.anchor; content; attr; doc; source_anchor = None } in
1910 Item.Declaration decl
1911 in
1912 List.map f t
1913
1914 let compilation_unit (t : Odoc_model.Lang.Compilation_unit.t) =
1915 let url = Url.Path.from_identifier t.id in
1916 let unit_doc, items =
1917 match t.content with
1918 | Module sign -> signature sign
1919 | Pack packed -> ([], pack packed)
1920 in
1921 let source_anchor = source_anchor t.source_loc in
1922 let page = make_expansion_page ~source_anchor url [ unit_doc ] items in
1923 (* Collect any remaining resources that were accumulated during signature
1924 processing but not captured by nested pages. These belong to the
1925 top-level compilation unit. *)
1926 let remaining_resources = Comment.Resources.take () in
1927 let remaining_assets = Comment.Assets.take () in
1928 let page =
1929 { page with
1930 Page.resources = page.Page.resources @ remaining_resources;
1931 assets = page.assets @ remaining_assets }
1932 in
1933 Document.Page page
1934
1935 let page (t : Odoc_model.Lang.Page.t) =
1936 (*let name =
1937 match t.name.iv with `Page (_, name) | `LeafPage (_, name) -> name
1938 in*)
1939 (*let title = Odoc_model.Names.PageName.to_string name in*)
1940 let url = Url.Path.from_identifier t.name in
1941 let preamble, items = Sectioning.docs t.content.elements in
1942 let source_anchor = None in
1943 let resources = Comment.Resources.take () in
1944 let assets = Comment.Assets.take () in
1945 Document.Page { Page.preamble; items; url; source_anchor; resources; assets }
1946
1947 let implementation (v : Odoc_model.Lang.Implementation.t) syntax_info
1948 source_code =
1949 match v.id with
1950 | None -> []
1951 | Some id ->
1952 [
1953 Document.Source_page
1954 (Source_page.source id syntax_info v.source_info source_code);
1955 ]
1956 end
1957
1958 include Page
1959
1960 let type_expr = type_expr
1961
1962 let record = record
1963
1964 let unboxed_record = unboxed_record
1965end