• Home
  • Features
  • Pricing
  • Docs
  • Announcements
  • Sign In

ocaml / odoc / 3135

05 May 2026 06:47AM UTC coverage: 71.021% (-0.1%) from 71.162%
3135

Pull #1407

github

web-flow
Merge e33dd8b1b into 5e9c5c031
Pull Request #1407: OxCaml: Support for unboxed named types

1 of 31 new or added lines in 10 files covered. (3.23%)

11 existing lines in 3 files now uncovered.

10411 of 14659 relevant lines covered (71.02%)

5887.22 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

82.35
/src/document/generator.ml
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

17
open Odoc_utils
18
open Odoc_model.Names
19
module Location = Odoc_model.Location_
20
module Paths = Odoc_model.Paths
21
open Types
22
module O = Codefmt
23
open O.Infix
24

25
let tag tag t = O.span ~attr:tag t
13,407✔
26

27
let label t =
28
  match t with
3,263✔
29
  | Odoc_model.Lang.TypeExpr.Label s -> tag "label" (O.txt s)
574✔
30
  | Optional s | RawOptional s -> tag "optlabel" (O.txt "?" ++ O.txt s)
1✔
31

32
let type_var tv = tag "type-var" (O.txt tv)
9,487✔
33

34
let enclose ~l ~r x = O.span (O.txt l ++ x ++ O.txt r)
14,348✔
35

36
let resolved p content =
37
  let link = { Link.target = Internal (Resolved p); content; tooltip = None } in
159,791✔
38
  O.elt [ inline @@ Link link ]
159,791✔
39

40
let path p content = resolved (Url.from_path p) content
2,955✔
41

42
let unresolved content =
43
  let link = { Link.target = Internal Unresolved; content; tooltip = None } in
582✔
44
  O.elt [ inline @@ Link link ]
582✔
45

46
let path_to_id path =
47
  let url = Url.Anchor.from_identifier (path :> Paths.Identifier.t) in
7,529✔
48
  Some url
7,529✔
49

50
let source_anchor source_loc =
51
  match source_loc with
7,891✔
52
  | Some id ->
104✔
53
      Some
54
        (Url.Anchor.from_identifier
104✔
55
           (id : Paths.Identifier.SourceLocation.t :> Paths.Identifier.t))
56
  | _ -> None
7,787✔
57

58
let attach_expansion ?(status = `Default) (eq, o, e) page text =
1,602✔
59
  match page with
3,445✔
60
  | None -> O.documentedSrc text
701✔
61
  | Some (page : Page.t) ->
2,744✔
62
      let url = page.url in
63
      let summary = O.render text in
64
      let expansion =
2,744✔
65
        O.documentedSrc (O.txt eq ++ O.keyword o)
2,744✔
66
        @ DocumentedSrc.[ Subpage { status; content = page } ]
67
        @ O.documentedSrc (O.keyword e)
2,744✔
68
      in
69
      DocumentedSrc.
70
        [ Alternative (Expansion { summary; url; status; expansion }) ]
71

72
let mk_heading ?(level = 1) ?label text =
366✔
73
  let title = [ inline @@ Text text ] in
366✔
74
  Item.Heading { label; level; title; source_anchor = None }
75

76
(** Returns the preamble as an item. Stop the preamble at the first heading. The
77
    rest is inserted into [items]. *)
78
let prepare_preamble comment items =
79
  let preamble, first_comment =
3,314✔
80
    List.split_at
81
      ~f:(function
82
        | { Odoc_model.Location_.value = `Heading _; _ } -> true | _ -> false)
32✔
83
      comment
84
  in
85
  (Comment.standalone preamble, Comment.standalone first_comment @ items)
3,314✔
86

87
let make_expansion_page ~source_anchor url comments items =
88
  let comment = List.concat comments in
3,314✔
89
  let preamble, items = prepare_preamble comment items in
3,314✔
90
  { Page.preamble; items; url; source_anchor }
3,314✔
91

92
include Generator_signatures
93

94
module Make (Syntax : SYNTAX) = struct
95
  module Link : sig
96
    val from_path : Paths.Path.t -> text
97

98
    val from_fragment : Paths.Fragment.leaf -> text
99
  end = struct
100
    open Paths
101

102
    let rec from_path : Path.t -> text =
103
     fun path ->
104
      match path with
181,953✔
105
      | `Identifier (id, _) ->
245✔
106
          unresolved [ inline @@ Text (Identifier.name id) ]
245✔
107
      | `Substituted m -> from_path (m :> Path.t)
×
108
      | `SubstitutedMT m -> from_path (m :> Path.t)
×
109
      | `SubstitutedT m -> from_path (m :> Path.t)
×
110
      | `SubstitutedCT m -> from_path (m :> Path.t)
×
NEW
111
      | `Unbox t -> from_path (t :> Path.t)
×
112
      | `Root root -> unresolved [ inline @@ Text (ModuleName.to_string root) ]
305✔
113
      | `Forward root -> unresolved [ inline @@ Text root ] (* FIXME *)
×
114
      | `Dot (prefix, suffix) ->
305✔
115
          let link = from_path (prefix :> Path.t) in
116
          link ++ O.txt ("." ^ ModuleName.to_string suffix)
305✔
117
      | `DotT (prefix, suffix) ->
297✔
118
          let link = from_path (prefix :> Path.t) in
119
          link ++ O.txt ("." ^ TypeName.to_string suffix)
297✔
120
      | `DotMT (prefix, suffix) ->
×
121
          let link = from_path (prefix :> Path.t) in
122
          link ++ O.txt ("." ^ ModuleTypeName.to_string suffix)
×
123
      | `DotV (prefix, suffix) ->
×
124
          let link = from_path (prefix :> Path.t) in
125
          link ++ O.txt ("." ^ ValueName.to_string suffix)
×
126
      | `Apply (p1, p2) ->
×
127
          let link1 = from_path (p1 :> Path.t) in
128
          let link2 = from_path (p2 :> Path.t) in
×
129
          link1 ++ O.txt "(" ++ link2 ++ O.txt ")"
×
130
      | `Resolved _ when Paths.Path.is_hidden path ->
180,801✔
131
          let txt = Url.render_path path in
32✔
132
          unresolved [ inline @@ Text txt ]
32✔
133
      | `Resolved rp -> (
180,769✔
134
          (* If the path is pointing to an opaque module or module type
135
             there won't be a page generated - so we stop before; at
136
             the parent page, and link instead to the anchor representing
137
             the declaration of the opaque module(_type) *)
138
          let stop_before =
139
            match rp with
140
            | `OpaqueModule _ | `OpaqueModuleType _ -> true
8✔
141
            | _ -> false
180,561✔
142
          in
143
          let txt = [ inline @@ Text (Url.render_path path) ] in
180,769✔
144
          match Paths.Path.Resolved.identifier rp with
145
          | Some id ->
156,330✔
146
              let href = Url.from_identifier ~stop_before id in
147
              resolved href txt
156,330✔
148
          | None -> O.elt txt)
24,439✔
149

150
    let dot prefix suffix = prefix ^ "." ^ suffix
49✔
151

152
    let rec render_fragment_any : Fragment.t -> string =
153
     fun fragment ->
154
      match fragment with
×
155
      | `Resolved rr -> render_resolved_fragment rr
×
156
      | `Dot (`Root, suffix) -> suffix
×
157
      | `Dot (prefix, suffix) ->
×
158
          dot (render_fragment_any (prefix :> Fragment.t)) suffix
×
159
      | `Root -> assert false
160

161
    and render_resolved_fragment : Fragment.Resolved.t -> string =
162
      let open Fragment.Resolved in
163
      fun fragment ->
164
        match fragment with
376✔
165
        | `Root _ -> assert false
166
        | `Subst (_, rr) -> render_resolved_fragment (rr :> t)
8✔
167
        | `Alias (_, rr) -> render_resolved_fragment (rr :> t)
24✔
168
        | `Module (`Root _, s) -> ModuleName.to_string s
121✔
169
        | `Module_type (`Root _, s) -> ModuleTypeName.to_string s
32✔
170
        | `Type (`Root _, s) -> TypeName.to_string s
142✔
171
        | `Class (`Root _, s) -> TypeName.to_string s
×
172
        | `ClassType (`Root _, s) -> TypeName.to_string s
×
173
        | `Module (rr, s) ->
8✔
174
            dot (render_resolved_fragment (rr :> t)) (ModuleName.to_string s)
8✔
175
        | `Module_type (rr, s) ->
16✔
176
            dot
177
              (render_resolved_fragment (rr :> t))
16✔
178
              (ModuleTypeName.to_string s)
16✔
179
        | `Type (rr, s) ->
25✔
180
            dot (render_resolved_fragment (rr :> t)) (TypeName.to_string s)
25✔
181
        | `Class (rr, s) ->
×
182
            dot (render_resolved_fragment (rr :> t)) (TypeName.to_string s)
×
183
        | `ClassType (rr, s) ->
×
184
            dot (render_resolved_fragment (rr :> t)) (TypeName.to_string s)
×
185
        | `OpaqueModule r -> render_resolved_fragment (r :> t)
×
186

187
    let resolved_fragment_to_ir : Fragment.Resolved.leaf -> text =
188
     fun fragment ->
189
      let open Fragment in
295✔
190
      let id = Resolved.identifier (fragment :> Resolved.t) in
191
      let txt = render_resolved_fragment (fragment :> Resolved.t) in
295✔
192
      match id with
295✔
193
      | Some id ->
295✔
194
          let href = Url.from_identifier ~stop_before:false id in
195
          resolved href [ inline @@ Text txt ]
295✔
196
      | None -> unresolved [ inline @@ Text txt ]
×
197

198
    let from_fragment : Fragment.leaf -> text = function
199
      | `Resolved r
295✔
200
        when not (Fragment.Resolved.is_hidden (r :> Fragment.Resolved.t)) ->
295✔
201
          resolved_fragment_to_ir r
295✔
202
      | f ->
×
203
          let txt = render_fragment_any (f :> Fragment.t) in
204
          unresolved [ inline @@ Text txt ]
×
205
  end
206

207
  module Impl = struct
208
    let impl ~infos src =
209
      let l =
28✔
210
        infos
211
        |> List.sort (fun (_, (l1, e1)) (_, (l2, e2)) ->
212
               if l1 = l2 then compare e2 e1
133✔
213
                 (* If two intervals open at the same time, we open
214
                    first the one that closes last *)
215
               else compare l1 l2)
3,166✔
216
      in
217
      let get_src a b =
28✔
218
        let in_bound x = min (max x 0) (String.length src) in
1,696✔
219
        let a = in_bound a and b = in_bound b in
1,696✔
220
        let a, b = (min a b, max a b) in
1,696✔
221
        String.with_range src ~first:a ~len:(b - a)
222
      in
223
      let plain_code = function
224
        | "" -> []
596✔
225
        | s -> [ Types.Source_page.Plain_code s ]
1,100✔
226
      in
227
      let min (a : int) b = if a < b then a else b in
161✔
228
      let rec extract from to_ list aux =
229
        match list with
1,696✔
230
        | (k, (loc_start, loc_end)) :: q when loc_start < to_ ->
1,640✔
231
            let loc_end = min loc_end to_ in
834✔
232
            (* In case of inconsistent [a  [b    a] b]
233
               we do                   [a  [b  b]a] *)
234
            let initial = plain_code (get_src from loc_start) in
834✔
235
            let next, q = extract loc_start loc_end q [] in
834✔
236
            extract loc_end to_ q
834✔
237
              ([ Types.Source_page.Tagged_code (k, List.rev next) ]
834✔
238
              @ initial @ aux)
239
        | q -> (plain_code (get_src from to_) @ aux, q)
862✔
240
      in
241
      let doc, _ = extract 0 (String.length src) l [] in
28✔
242
      List.rev doc
28✔
243
  end
244

245
  module Source_page : sig
246
    val source :
247
      Paths.Identifier.SourcePage.t ->
248
      Syntax_highlighter.infos ->
249
      Lang.Source_info.t ->
250
      string ->
251
      Source_page.t
252
  end = struct
253
    let path id = Url.Path.from_identifier id
28✔
254

255
    let to_link { Lang.Source_info.documentation; implementation } =
256
      let documentation =
34✔
257
        (* Since documentation link are not rendered, we comment the code to
258
           extract the href, and always output [None] *)
259
        ignore documentation;
260
        None
261
        (* let open Paths.Path.Resolved in *)
262
        (* match documentation with *)
263
        (* | Some (`Resolved p) when not (is_hidden (p :> t)) -> ( *)
264
        (*     let id = identifier (p :> t) in *)
265
        (*     match Url.from_identifier ~stop_before:false id with *)
266
        (*     | Ok link -> Some link *)
267
        (*     | _ -> None) *)
268
        (* | _ -> None *)
269
      in
270
      let implementation =
271
        match implementation with
272
        | Some (Odoc_model.Lang.Source_info.Resolved id) ->
15✔
273
            Some (Url.Anchor.from_identifier (id :> Paths.Identifier.t))
15✔
274
        | _ -> None
19✔
275
      in
276
      Some (Source_page.Link { implementation; documentation })
277

278
    let info_of_info : Lang.Source_info.annotation -> Source_page.info option =
279
      function
280
      | Definition id -> (
99✔
281
          match id.iv with
282
          | `SourceLocation (_, def) -> Some (Anchor (DefName.to_string def))
95✔
283
          | `SourceLocationInternal (_, local) ->
4✔
284
              Some (Anchor (LocalName.to_string local))
4✔
285
          | _ -> None)
×
286
      | Module v -> to_link v
11✔
287
      | ModuleType v -> to_link v
1✔
288
      | Type v -> to_link v
7✔
289
      | Value v -> to_link v
15✔
290

291
    let source id syntax_info infos source_code =
292
      let url = path id in
28✔
293
      let mapper (info, loc) =
28✔
294
        match info_of_info info with Some x -> Some (x, loc) | None -> None
×
295
      in
296
      let infos = Odoc_utils.List.filter_map mapper infos in
297
      let syntax_info =
28✔
298
        List.rev_map (fun (ty, loc) -> (Source_page.Syntax ty, loc)) syntax_info
701✔
299
        |> List.rev
28✔
300
      in
301
      let contents = Impl.impl ~infos:(infos @ syntax_info) source_code in
28✔
302
      { Source_page.url; contents }
28✔
303
  end
304

305
  module Type_expression : sig
306
    val type_expr : ?needs_parentheses:bool -> Lang.TypeExpr.t -> text
307

308
    val format_type_path :
309
      delim:[ `parens | `brackets ] -> Lang.TypeExpr.t list -> text -> text
310
  end = struct
311
    let rec te_variant (t : Odoc_model.Lang.TypeExpr.Polymorphic_variant.t) =
312
      let style_arguments ~constant arguments =
75,143✔
313
        (* Multiple arguments in a polymorphic variant constructor correspond
314
           to a conjunction of types, not a product: [`Lbl int&float].
315
           If constant is [true], the conjunction starts with an empty type,
316
           for instance [`Lbl &int].
317
        *)
318
        let wrapped_type_expr =
1,873✔
319
          (* type conjunction in Reason is printed as `Lbl (t1)&(t2)` *)
320
          if Syntax.Type.Variant.parenthesize_params then fun x ->
×
321
            enclose ~l:"(" ~r:")" (type_expr x)
×
322
          else fun x -> type_expr x
1,873✔
323
        in
324
        let arguments =
325
          O.list arguments ~sep:(O.txt " & ") ~f:wrapped_type_expr
1,873✔
326
        in
327
        if constant then O.txt "& " ++ arguments else arguments
×
328
      in
329
      let rec style_elements ~add_pipe = function
330
        | [] -> O.noop
75,143✔
331
        | first :: rest ->
108,795✔
332
            let first =
333
              match first with
334
              | Odoc_model.Lang.TypeExpr.Polymorphic_variant.Type te ->
40,832✔
335
                  let res = O.box_hv @@ type_expr te in
40,832✔
336
                  if add_pipe then O.sp ++ O.span (O.txt "| " ++ res) else res
2,565✔
337
              | Constructor { constant; name; arguments; _ } ->
67,963✔
338
                  let constr =
339
                    let name = "`" ^ name in
340
                    if add_pipe then O.span (O.txt ("| " ^ name))
31,095✔
341
                    else O.txt name
36,868✔
342
                  in
343
                  let res =
344
                    O.box_hv
345
                      (match arguments with
346
                      | [] -> constr
66,090✔
347
                      | _ ->
1,873✔
348
                          let arguments = style_arguments ~constant arguments in
349
                          O.span
1,873✔
350
                            (if Syntax.Type.Variant.parenthesize_params then
351
                               constr ++ arguments
×
352
                             else constr ++ O.txt " of" ++ O.sp ++ arguments))
1,873✔
353
                  in
354
                  if add_pipe then O.sp ++ res else res
31,095✔
355
            in
356
            first ++ style_elements ~add_pipe:true rest
108,795✔
357
      in
358
      let elements = style_elements ~add_pipe:false t.elements in
359
      O.box_hv_no_indent
75,143✔
360
      @@ O.span
75,143✔
361
           (match t.kind with
362
           | Fixed -> O.txt "[ " ++ elements ++ O.txt " ]"
7,068✔
363
           | Open -> O.txt "[> " ++ elements ++ O.txt " ]"
40,908✔
364
           | Closed [] -> O.txt "[< " ++ elements ++ O.txt " ]"
27,132✔
365
           | Closed lst ->
35✔
366
               let constrs = String.concat ~sep:" " lst in
367
               O.txt "[< " ++ elements ++ O.txt (" " ^ constrs ^ " ]"))
35✔
368

369
    and te_object (t : Odoc_model.Lang.TypeExpr.Object.t) =
370
      let fields =
80✔
371
        O.list
372
          ~sep:(O.sp ++ O.txt Syntax.Obj.field_separator)
80✔
373
          t.fields
374
          ~f:(function
375
            | Odoc_model.Lang.TypeExpr.Object.Method { name; type_ } ->
120✔
376
                O.box_hv_no_indent
377
                @@ O.txt (name ^ Syntax.Type.annotation_separator)
120✔
378
                   ++ O.cut ++ type_expr type_
120✔
379
            | Inherit type_ -> O.box_hv_no_indent @@ type_expr type_)
×
380
      in
381
      let open_tag =
80✔
382
        if t.open_ then O.txt Syntax.Obj.open_tag_extendable
32✔
383
        else O.txt Syntax.Obj.open_tag_closed
48✔
384
      in
385
      let close_tag =
386
        if t.open_ then O.txt Syntax.Obj.close_tag_extendable
32✔
387
        else O.txt Syntax.Obj.close_tag_closed
48✔
388
      in
389
      O.span (open_tag ++ fields ++ close_tag)
80✔
390

391
    and format_type_path ~delim (params : Odoc_model.Lang.TypeExpr.t list)
392
        (path : text) : text =
393
      O.box_hv
179,533✔
394
      @@
395
      match params with
396
      | [] -> path
94,880✔
397
      | [ param ] ->
71,291✔
398
          let param = type_expr ~needs_parentheses:true param in
399
          let args =
71,291✔
400
            if Syntax.Type.parenthesize_constructor then
401
              O.txt "(" ++ param ++ O.txt ")"
×
402
            else param
71,291✔
403
          in
404
          Syntax.Type.handle_constructor_params path args
71,291✔
405
      | params ->
13,362✔
406
          let params = O.list params ~sep:(O.txt "," ++ O.sp) ~f:type_expr in
13,362✔
407
          let params =
13,362✔
408
            match delim with
409
            | `parens -> enclose ~l:"(" params ~r:")"
13,362✔
410
            | `brackets -> enclose ~l:"[" params ~r:"]"
×
411
          in
412
          Syntax.Type.handle_constructor_params path (O.box_hv params)
13,362✔
413

414
    and tuple ?(needs_parentheses = false) ~boxed lst =
×
415
      let opt_label = function
677✔
416
        | None -> O.noop
1,544✔
417
        | Some lbl -> tag "label" (O.txt lbl) ++ O.txt ":" ++ O.cut
×
418
      in
419
      let res =
420
        O.box_hv_no_indent
421
          (O.list lst ~sep:Syntax.Type.Tuple.element_separator
677✔
422
             ~f:(fun (lbl, typ) ->
423
               opt_label lbl ++ type_expr ~needs_parentheses:true typ))
1,544✔
424
      in
425
      let lparen = if boxed then "(" else "#(" in
×
426
      if Syntax.Type.Tuple.always_parenthesize || needs_parentheses || not boxed
×
427
      then enclose ~l:lparen res ~r:")"
131✔
428
      else res
546✔
429

430
    and type_expr ?(needs_parentheses = false) (t : Odoc_model.Lang.TypeExpr.t)
191,635✔
431
        =
432
      let enclose_parens_if_needed res =
312,108✔
433
        if needs_parentheses then enclose ~l:"(" res ~r:")" else res
831✔
434
      in
435
      match t with
436
      | Var s -> type_var (Syntax.Type.var_prefix ^ s)
9,469✔
437
      | Any -> type_var Syntax.Type.any
18✔
438
      | Alias (te, alias) ->
133✔
439
          enclose_parens_if_needed
440
            (type_expr ~needs_parentheses:true te
133✔
441
            ++ O.txt " " ++ O.keyword "as" ++ O.txt " '" ++ O.txt alias)
133✔
442
      | Arrow (None, src, dst) ->
43,802✔
443
          let res =
444
            O.span
43,802✔
445
              ((O.box_hv @@ type_expr ~needs_parentheses:true src)
43,802✔
446
              ++ O.txt " " ++ Syntax.Type.arrow)
43,802✔
447
            ++ O.sp ++ type_expr dst
43,802✔
448
            (* ++ O.end_hv *)
449
          in
450
          enclose_parens_if_needed res
43,802✔
451
      | Arrow (Some (RawOptional _ as lbl), _src, dst) ->
1✔
452
          let res =
453
            O.span
1✔
454
              (O.box_hv
1✔
455
              @@ label lbl ++ O.txt ":"
1✔
456
                 ++ tag "error" (O.txt "???")
1✔
457
                 ++ O.txt " " ++ Syntax.Type.arrow)
1✔
458
            ++ O.sp ++ type_expr dst
1✔
459
          in
460
          enclose_parens_if_needed res
1✔
461
      | Arrow (Some lbl, src, dst) ->
3,262✔
462
          let res =
463
            O.span
3,262✔
464
              ((O.box_hv
3,262✔
465
               @@ label lbl ++ O.txt ":" ++ O.cut
3,262✔
466
                  ++ (O.box_hv @@ type_expr ~needs_parentheses:true src))
3,262✔
467
              ++ O.txt " " ++ Syntax.Type.arrow)
3,262✔
468
            ++ O.sp ++ type_expr dst
3,262✔
469
          in
470
          enclose_parens_if_needed res
3,262✔
471
      | Tuple lst -> tuple ~needs_parentheses ~boxed:true lst
677✔
472
      | Unboxed_tuple lst -> tuple ~needs_parentheses ~boxed:false lst
×
473
      | Constr (path, args) ->
179,467✔
474
          let link = Link.from_path (path :> Paths.Path.t) in
475
          format_type_path ~delim:`parens args link
179,467✔
476
      | Polymorphic_variant v -> te_variant v
75,143✔
477
      | Object o -> te_object o
80✔
478
      | Class (path, args) ->
8✔
479
          format_type_path ~delim:`brackets args
480
            (Link.from_path (path :> Paths.Path.t))
8✔
481
      | Poly (polyvars, t) ->
24✔
482
          enclose_parens_if_needed
483
          @@ O.txt ("'" ^ String.concat ~sep:" '" polyvars ^ ". ")
24✔
484
             ++ type_expr t
24✔
485
      | Quote t -> O.span (O.txt "<[ " ++ O.box_hv (type_expr t) ++ O.txt " ]>")
×
486
      | Splice t -> O.span (O.txt "$" ++ type_expr ~needs_parentheses:true t)
×
487
      | Package pkg ->
24✔
488
          enclose ~l:"(" ~r:")"
489
            (O.keyword "module" ++ O.txt " " ++ package_path pkg)
24✔
490
      | Arrow_functor (lbl, m_arg, dst) ->
×
491
          let lbl =
492
            match lbl with None -> O.noop | Some lbl -> label lbl ++ O.txt ":"
×
493
          in
494
          let name =
495
            match m_arg.id.iv with
496
            | `Parameter (_, name) -> ModuleName.to_string name
×
497
          in
498
          let dst = type_expr dst in
499
          let pkg =
×
500
            enclose ~l:"(" ~r:")"
501
            @@ O.keyword "module" ++ O.txt " " ++ O.txt name ++ O.txt " : "
×
502
               ++ package_path m_arg.package
×
503
          in
504
          lbl ++ pkg ++ O.sp ++ Syntax.Type.arrow ++ O.sp ++ dst
×
505

506
    and package_path pkg =
507
      Link.from_path (pkg.path :> Paths.Path.t)
24✔
508
      ++
509
      match pkg.substitutions with
510
      | [] -> O.noop
16✔
511
      | fst :: lst ->
8✔
512
          O.sp
513
          ++ O.box_hv (O.keyword "with" ++ O.txt " " ++ package_subst fst)
8✔
514
          ++ O.list lst ~f:(fun s ->
8✔
515
                 O.cut
8✔
516
                 ++ (O.box_hv
8✔
517
                    @@ O.txt " " ++ O.keyword "and" ++ O.txt " "
8✔
518
                       ++ package_subst s))
8✔
519

520
    and package_subst
521
        ((frag_typ, te) : Paths.Fragment.Type.t * Odoc_model.Lang.TypeExpr.t) :
522
        text =
523
      let typath = Link.from_fragment (frag_typ :> Paths.Fragment.leaf) in
16✔
524
      O.keyword "type" ++ O.txt " " ++ typath ++ O.txt " =" ++ O.sp
16✔
525
      ++ type_expr te
16✔
526
  end
527

528
  open Type_expression
529

530
  (* Also handles constructor declarations for exceptions and extensible
531
     variants, and exposes a few helpers used in formatting classes and signature
532
     constraints. *)
533
  module Type_declaration : sig
534
    val type_decl :
535
      ?is_substitution:bool ->
536
      Lang.Signature.recursive * Lang.TypeDecl.t ->
537
      Item.t
538

539
    val extension : Lang.Extension.t -> Item.t
540

541
    val record : Lang.TypeDecl.Field.t list -> DocumentedSrc.one list
542

543
    val unboxed_record :
544
      Lang.TypeDecl.UnboxedField.t list -> DocumentedSrc.one list
545

546
    val exn : Lang.Exception.t -> Item.t
547

548
    val format_params :
549
      ?delim:[ `parens | `brackets ] -> Lang.TypeDecl.param list -> text
550

551
    val format_manifest :
552
      ?is_substitution:bool ->
553
      ?compact_variants:bool ->
554
      Lang.TypeDecl.Equation.t ->
555
      text * bool
556

557
    val format_constraints : (Lang.TypeExpr.t * Lang.TypeExpr.t) list -> text
558
  end = struct
559
    let record fields =
560
      let field mutable_ id typ =
86✔
561
        let url = Url.from_identifier ~stop_before:true id in
155✔
562
        let name = Paths.Identifier.name id in
155✔
563
        let attrs = [ "def"; "record"; Url.Anchor.string_of_kind url.kind ] in
155✔
564
        let cell =
565
          (* O.td ~a:[ O.a_class ["def"; kind ] ]
566
           *   [O.a ~a:[O.a_href ("#" ^ anchor); O.a_class ["anchor"]] []
567
           *   ; *)
568
          O.code
569
            ((if mutable_ then O.keyword "mutable" ++ O.txt " " else O.noop)
24✔
570
            ++ O.txt name
155✔
571
            ++ O.txt Syntax.Type.annotation_separator
155✔
572
            ++ type_expr typ
155✔
573
            ++ O.txt Syntax.Type.Record.field_separator)
155✔
574
          (* ] *)
575
        in
576
        (url, attrs, cell)
155✔
577
      in
578
      let rows =
579
        fields
580
        |> List.map (fun fld ->
581
               let open Odoc_model.Lang.TypeDecl.Field in
155✔
582
               let url, attrs, code =
583
                 field fld.mutable_ (fld.id :> Paths.Identifier.t) fld.type_
584
               in
585
               let anchor = Some url in
155✔
586
               let doc = fld.doc.elements in
587
               let rhs = Comment.to_ir doc in
588
               let doc = if not (Comment.has_doc doc) then [] else rhs in
64✔
589
               let markers = Syntax.Comment.markers in
590
               DocumentedSrc.Documented { anchor; attrs; code; doc; markers })
591
      in
592
      let content =
86✔
593
        O.documentedSrc (O.txt "{") @ rows @ O.documentedSrc (O.txt "}")
86✔
594
      in
595
      content
596

597
    let unboxed_record fields =
598
      let field mutable_ id typ =
×
599
        let url = Url.from_identifier ~stop_before:true id in
×
600
        let name = Paths.Identifier.name id in
×
601
        let attrs = [ "def"; "record"; Url.Anchor.string_of_kind url.kind ] in
×
602
        let cell =
603
          (* O.td ~a:[ O.a_class ["def"; kind ] ]
604
           *   [O.a ~a:[O.a_href ("#" ^ anchor); O.a_class ["anchor"]] []
605
           *   ; *)
606
          O.code
607
            ((if mutable_ then O.keyword "mutable" ++ O.txt " " else O.noop)
×
608
            ++ O.txt name
×
609
            ++ O.txt Syntax.Type.annotation_separator
×
610
            ++ type_expr typ
×
611
            ++ O.txt Syntax.Type.Record.field_separator)
×
612
          (* ] *)
613
        in
614
        (url, attrs, cell)
×
615
      in
616
      let rows =
617
        fields
618
        |> List.map (fun fld ->
619
               let open Odoc_model.Lang.TypeDecl.UnboxedField in
×
620
               let url, attrs, code =
621
                 field fld.mutable_ (fld.id :> Paths.Identifier.t) fld.type_
622
               in
623
               let anchor = Some url in
×
624
               let doc = fld.doc.elements in
625
               let rhs = Comment.to_ir doc in
626
               let doc = if not (Comment.has_doc doc) then [] else rhs in
×
627
               let markers = Syntax.Comment.markers in
628
               DocumentedSrc.Documented { anchor; attrs; code; doc; markers })
629
      in
630
      let content =
×
631
        O.documentedSrc (O.txt "#{") @ rows @ O.documentedSrc (O.txt "}")
×
632
      in
633
      content
634

635
    let constructor :
636
        Paths.Identifier.t ->
637
        Odoc_model.Lang.TypeDecl.Constructor.argument ->
638
        Odoc_model.Lang.TypeExpr.t option ->
639
        DocumentedSrc.t =
640
     fun id args ret_type ->
641
      let name = Paths.Identifier.name id in
656✔
642
      let kind = Url.(kind id |> Anchor.string_of_kind) in
656✔
643
      let cstr = tag kind (O.txt name) in
656✔
644
      let is_gadt, ret_type =
656✔
645
        match ret_type with
646
        | None -> (false, O.noop)
520✔
647
        | Some te ->
136✔
648
            let constant = match args with Tuple [] -> true | _ -> false in
48✔
649
            let ret_type =
650
              O.txt " "
136✔
651
              ++ (if constant then O.txt ":" else Syntax.Type.GADT.arrow)
48✔
652
              ++ O.txt " " ++ type_expr te
136✔
653
            in
654
            (true, ret_type)
136✔
655
      in
656
      match args with
657
      | Tuple [] -> O.documentedSrc (cstr ++ ret_type)
289✔
658
      | Tuple lst ->
350✔
659
          let params =
660
            O.list lst ~sep:Syntax.Type.Tuple.element_separator
661
              ~f:(type_expr ~needs_parentheses:is_gadt)
662
          in
663
          O.documentedSrc
350✔
664
            (cstr
665
            ++ (if Syntax.Type.Variant.parenthesize_params then
350✔
666
                  O.txt "(" ++ params ++ O.txt ")"
×
667
                else
668
                  (if is_gadt then O.txt Syntax.Type.annotation_separator
88✔
669
                   else O.txt " " ++ O.keyword "of" ++ O.txt " ")
262✔
670
                  ++ params)
350✔
671
            ++ ret_type)
350✔
672
      | Record fields ->
17✔
673
          if is_gadt then
674
            O.documentedSrc (cstr ++ O.txt Syntax.Type.annotation_separator)
×
675
            @ record fields @ O.documentedSrc ret_type
×
676
          else
677
            O.documentedSrc (cstr ++ O.txt " " ++ O.keyword "of" ++ O.txt " ")
17✔
678
            @ record fields
17✔
679

680
    let variant cstrs : DocumentedSrc.t =
681
      let constructor id args res =
235✔
682
        let url = Url.from_identifier ~stop_before:true id in
436✔
683
        let attrs = [ "def"; "variant"; Url.Anchor.string_of_kind url.kind ] in
436✔
684
        let content =
685
          let doc = constructor id args res in
686
          O.documentedSrc (O.txt "| ") @ doc
436✔
687
        in
688
        (url, attrs, content)
689
      in
690
      match cstrs with
691
      | [] -> O.documentedSrc (O.txt "|")
×
692
      | _ :: _ ->
235✔
693
          let rows =
694
            cstrs
695
            |> List.map (fun cstr ->
696
                   let open Odoc_model.Lang.TypeDecl.Constructor in
436✔
697
                   let url, attrs, code =
698
                     constructor
699
                       (cstr.id :> Paths.Identifier.t)
700
                       cstr.args cstr.res
701
                   in
702
                   let anchor = Some url in
436✔
703
                   let doc = cstr.doc.elements in
704
                   let rhs = Comment.to_ir doc in
705
                   let doc = if not (Comment.has_doc doc) then [] else rhs in
73✔
706
                   let markers = Syntax.Comment.markers in
707
                   DocumentedSrc.Nested { anchor; attrs; code; doc; markers })
708
          in
709
          rows
235✔
710

711
    let extension_constructor (t : Odoc_model.Lang.Extension.Constructor.t) =
712
      let id = (t.id :> Paths.Identifier.t) in
154✔
713
      let url = Url.from_identifier ~stop_before:true id in
714
      let anchor = Some url in
154✔
715
      let attrs = [ "def"; "variant"; Url.Anchor.string_of_kind url.kind ] in
154✔
716
      let code = O.documentedSrc (O.txt "| ") @ constructor id t.args t.res in
154✔
717
      let doc = Comment.to_ir t.doc.elements in
718
      let markers = Syntax.Comment.markers in
154✔
719
      DocumentedSrc.Nested { anchor; attrs; code; doc; markers }
720

721
    let extension (t : Odoc_model.Lang.Extension.t) =
722
      let prefix =
126✔
723
        O.keyword "type" ++ O.txt " "
126✔
724
        ++ Link.from_path (t.type_path :> Paths.Path.t)
126✔
725
        ++ O.txt " +=" ++ O.sp
126✔
726
        ++
727
        if t.private_ then O.keyword Syntax.Type.private_keyword ++ O.sp
8✔
728
        else O.noop
118✔
729
      in
730
      let content =
126✔
731
        O.documentedSrc prefix
126✔
732
        @ List.map extension_constructor t.constructors
126✔
733
        @ O.documentedSrc
126✔
734
            (if Syntax.Type.type_def_semicolon then O.txt ";" else O.noop)
×
735
      in
736
      let attr = [ "type"; "extension" ] in
737
      let anchor = Some (Url.Anchor.extension_decl t) in
126✔
738
      let doc = Comment.to_ir t.doc.elements in
739
      let source_anchor =
126✔
740
        (* Take the anchor from the first constructor only for consistency with
741
           regular variants. *)
742
        match t.constructors with
743
        | hd :: _ -> source_anchor hd.source_loc
126✔
744
        | [] -> None
×
745
      in
746
      Item.Declaration { attr; anchor; doc; content; source_anchor }
747

748
    let exn (t : Odoc_model.Lang.Exception.t) =
749
      let cstr = constructor (t.id :> Paths.Identifier.t) t.args t.res in
66✔
750
      let content =
66✔
751
        O.documentedSrc (O.keyword "exception" ++ O.txt " ")
66✔
752
        @ cstr
753
        @ O.documentedSrc
66✔
754
            (if Syntax.Type.Exception.semicolon then O.txt ";" else O.noop)
×
755
      in
756
      let attr = [ "exception" ] in
757
      let anchor = path_to_id t.id in
758
      let doc = Comment.to_ir t.doc.elements in
66✔
759
      let source_anchor = source_anchor t.source_loc in
66✔
760
      Item.Declaration { attr; anchor; doc; content; source_anchor }
66✔
761

762
    let polymorphic_variant ~type_ident
763
        (t : Odoc_model.Lang.TypeExpr.Polymorphic_variant.t) =
764
      let row item =
74✔
765
        let kind_approx, cstr, doc =
156✔
766
          match item with
767
          | Odoc_model.Lang.TypeExpr.Polymorphic_variant.Type te ->
24✔
768
              ("unknown", O.documentedSrc (type_expr te), None)
24✔
769
          | Constructor { constant; name; arguments; doc; _ } -> (
132✔
770
              let cstr = "`" ^ name in
771
              ( "constructor",
772
                (match arguments with
773
                | [] -> O.documentedSrc (O.txt cstr)
58✔
774
                | _ ->
74✔
775
                    (* Multiple arguments in a polymorphic variant constructor correspond
776
                       to a conjunction of types, not a product: [`Lbl int&float].
777
                       If constant is [true], the conjunction starts with an empty type,
778
                       for instance [`Lbl &int].
779
                    *)
780
                    let wrapped_type_expr =
781
                      (* type conjunction in Reason is printed as `Lbl (t1)&(t2)` *)
782
                      if Syntax.Type.Variant.parenthesize_params then fun x ->
×
783
                        O.txt "(" ++ type_expr x ++ O.txt ")"
×
784
                      else fun x -> type_expr x
74✔
785
                    in
786
                    let params =
787
                      O.box_hv
788
                      @@ O.list arguments
74✔
789
                           ~sep:(O.txt " &" ++ O.sp)
74✔
790
                           ~f:wrapped_type_expr
791
                    in
792
                    let params =
74✔
793
                      if constant then O.txt "& " ++ params else params
×
794
                    in
795
                    O.documentedSrc
74✔
796
                      (O.txt cstr
74✔
797
                      ++
74✔
798
                      if Syntax.Type.Variant.parenthesize_params then params
×
799
                      else O.txt " " ++ O.keyword "of" ++ O.sp ++ params)),
74✔
800
                match doc with
801
                | { elements = []; _ } -> None
132✔
802
                | _ -> Some (Comment.to_ir doc.elements) ))
×
803
        in
804
        let markers = Syntax.Comment.markers in
805
        try
806
          let url = Url.Anchor.polymorphic_variant ~type_ident item in
807
          let attrs =
156✔
808
            [ "def"; "variant"; Url.Anchor.string_of_kind url.kind ]
156✔
809
          in
810
          let anchor = Some url in
811
          let code = O.documentedSrc (O.txt "| ") @ cstr in
156✔
812
          let doc = match doc with None -> [] | Some doc -> doc in
×
813
          DocumentedSrc.Nested { attrs; anchor; code; doc; markers }
814
        with Failure s ->
×
815
          Printf.eprintf "ERROR: %s\n%!" s;
816
          let code = O.documentedSrc (O.txt "| ") @ cstr in
×
817
          let attrs = [ "def"; kind_approx ] in
818
          let doc = [] in
819
          let anchor = None in
820
          DocumentedSrc.Nested { attrs; anchor; code; doc; markers }
821
      in
822
      let variants = List.map row t.elements in
823
      let intro, ending =
74✔
824
        match t.kind with
825
        | Fixed -> (O.documentedSrc (O.txt "[ "), O.documentedSrc (O.txt " ]"))
66✔
826
        | Open -> (O.documentedSrc (O.txt "[> "), O.documentedSrc (O.txt " ]"))
8✔
827
        | Closed [] ->
×
828
            (O.documentedSrc (O.txt "[< "), O.documentedSrc (O.txt " ]"))
×
829
        | Closed lst ->
×
830
            let constrs = String.concat ~sep:" " lst in
831
            ( O.documentedSrc (O.txt "[< "),
×
832
              O.documentedSrc (O.txt (" " ^ constrs ^ " ]")) )
×
833
      in
834
      intro @ variants @ ending
835

836
    let format_params :
837
        'row.
838
        ?delim:[ `parens | `brackets ] ->
839
        Odoc_model.Lang.TypeDecl.param list ->
840
        text =
841
     fun ?(delim = `parens) params ->
472✔
842
      let format_param { Odoc_model.Lang.TypeDecl.desc; variance; injectivity }
563✔
843
          =
844
        let desc =
624✔
845
          match desc with
846
          | Odoc_model.Lang.TypeDecl.Any -> [ "_" ]
37✔
847
          | Var s -> [ "'"; s ]
587✔
848
        in
849
        let var_desc =
850
          match variance with
851
          | None -> desc
608✔
852
          | Some Odoc_model.Lang.TypeDecl.Pos -> "+" :: desc
8✔
853
          | Some Odoc_model.Lang.TypeDecl.Neg -> "-" :: desc
8✔
854
          | Some Odoc_model.Lang.TypeDecl.Bivariant -> "+" :: "-" :: desc
×
855
        in
856
        let final = if injectivity then "!" :: var_desc else var_desc in
×
857
        String.concat ~sep:"" final
858
      in
859
      O.txt
860
        (match params with
861
        | [] -> ""
59✔
862
        | [ x ] -> format_param x |> Syntax.Type.handle_format_params
388✔
863
        | lst -> (
116✔
864
            let params = String.concat ~sep:", " (List.map format_param lst) in
116✔
865
            (match delim with `parens -> "(" | `brackets -> "[")
×
866
            ^ params
867
            ^ match delim with `parens -> ")" | `brackets -> "]"))
×
868

869
    let format_constraints constraints =
870
      O.list constraints ~f:(fun (t1, t2) ->
3,103✔
871
          O.sp
104✔
872
          ++ (O.box_hv
104✔
873
             @@ O.keyword "constraint" ++ O.sp
104✔
874
                ++ O.box_hv_no_indent (type_expr t1)
104✔
875
                ++ O.txt " =" ++ O.sp
104✔
876
                ++ O.box_hv_no_indent (type_expr t2)))
104✔
877

878
    let format_manifest :
879
        'inner_row 'outer_row.
880
        ?is_substitution:bool ->
881
        ?compact_variants:bool ->
882
        Odoc_model.Lang.TypeDecl.Equation.t ->
883
        text * bool =
884
     fun ?(is_substitution = false) ?(compact_variants = true) equation ->
104✔
885
      let _ = compact_variants in
3,021✔
886
      (* TODO *)
887
      let private_ = equation.private_ in
888
      match equation.manifest with
889
      | None -> (O.noop, private_)
1,753✔
890
      | Some t ->
1,268✔
891
          let manifest =
892
            O.txt (if is_substitution then " :=" else " =")
23✔
893
            ++ O.sp
1,268✔
894
            ++ (if private_ then
1,268✔
895
                  O.keyword Syntax.Type.private_keyword ++ O.txt " "
8✔
896
                else O.noop)
1,260✔
897
            ++ type_expr t
1,268✔
898
          in
899
          (manifest, false)
1,268✔
900

901
    let type_decl ?(is_substitution = false)
2,968✔
902
        ((recursive, t) : Lang.Signature.recursive * Lang.TypeDecl.t) =
903
      let keyword' =
2,991✔
904
        match recursive with
905
        | Ordinary | Rec -> O.keyword "type"
×
906
        | And -> O.keyword "and"
18✔
907
        | Nonrec -> O.keyword "type" ++ O.txt " " ++ O.keyword "nonrec"
1✔
908
      in
909
      let tyname = Paths.Identifier.name t.id in
910
      let tconstr =
2,991✔
911
        match t.equation.params with
912
        | [] -> O.txt tyname
2,545✔
913
        | l ->
446✔
914
            let params = format_params l in
915
            Syntax.Type.handle_constructor_params (O.txt tyname) params
446✔
916
      in
917
      let intro = keyword' ++ O.txt " " ++ tconstr in
2,991✔
918
      let constraints = format_constraints t.equation.constraints in
2,991✔
919
      let manifest, need_private, long_prefix =
2,991✔
920
        match t.equation.manifest with
921
        | Some (Odoc_model.Lang.TypeExpr.Polymorphic_variant variant) ->
74✔
922
            let code =
923
              polymorphic_variant
924
                ~type_ident:(t.id :> Paths.Identifier.t)
925
                variant
926
            in
927
            let manifest =
74✔
928
              O.documentedSrc
74✔
929
                (O.ignore intro
74✔
930
                ++ O.txt (if is_substitution then " :=" else " =")
×
931
                ++ O.sp
74✔
932
                ++
74✔
933
                if t.equation.private_ then
934
                  O.keyword Syntax.Type.private_keyword ++ O.txt " "
8✔
935
                else O.noop)
66✔
936
              @ code
937
            in
938
            (manifest, false, O.noop)
939
        | _ ->
2,917✔
940
            let manifest, need_private =
941
              format_manifest ~is_substitution t.equation
942
            in
943
            let text = O.ignore intro ++ manifest in
2,917✔
944
            (O.documentedSrc @@ text, need_private, text)
2,917✔
945
      in
946
      let representation =
947
        match t.representation with
948
        | None -> []
2,629✔
949
        | Some repr ->
362✔
950
            let content =
951
              match repr with
952
              | Extensible -> O.documentedSrc (O.txt "..")
61✔
953
              | Variant cstrs -> variant cstrs
235✔
954
              | Record fields -> record fields
66✔
955
              | Record_unboxed_product fields -> unboxed_record fields
×
956
            in
957
            if List.length content > 0 then
362✔
958
              O.documentedSrc
362✔
959
                (O.ignore long_prefix ++ O.txt " =" ++ O.sp
362✔
960
                ++
362✔
961
                if need_private then
962
                  O.keyword Syntax.Type.private_keyword ++ O.txt " "
8✔
963
                else O.noop)
354✔
964
              @ content
965
            else []
×
966
      in
967
      let content =
968
        O.documentedSrc intro @ manifest @ representation
2,991✔
969
        @ O.documentedSrc constraints
2,991✔
970
        @ O.documentedSrc
2,991✔
971
            (if Syntax.Type.type_def_semicolon then O.txt ";" else O.noop)
×
972
      in
973
      let attr = "type" :: (if is_substitution then [ "subst" ] else []) in
23✔
974
      let anchor = path_to_id t.id in
975
      let doc = Comment.to_ir t.doc.elements in
2,991✔
976
      let source_anchor = source_anchor t.source_loc in
2,991✔
977
      Item.Declaration { attr; anchor; doc; content; source_anchor }
2,991✔
978
  end
979

980
  open Type_declaration
981

982
  module Value : sig
983
    val value : Lang.Value.t -> Item.t
984
  end = struct
985
    let value (t : Odoc_model.Lang.Value.t) =
986
      let extra_attr, semicolon =
912✔
987
        match t.value with
988
        | Abstract -> ([], Syntax.Value.semicolon)
888✔
989
        | External _ -> ([ "external" ], Syntax.Type.External.semicolon)
24✔
990
      in
991
      let name = Paths.Identifier.name t.id in
992
      let content =
912✔
993
        O.documentedSrc
994
          (O.box_hv
912✔
995
          @@ O.keyword Syntax.Value.variable_keyword
912✔
996
             ++ O.txt " " ++ O.txt name
912✔
997
             ++ O.txt Syntax.Type.annotation_separator
912✔
998
             ++ O.cut ++ type_expr t.type_
912✔
999
             ++ if semicolon then O.txt ";" else O.noop)
×
1000
      in
1001
      let attr = [ "value" ] @ extra_attr in
912✔
1002
      let anchor = path_to_id t.id in
1003
      let doc = Comment.to_ir t.doc.elements in
912✔
1004
      let source_anchor = source_anchor t.source_loc in
912✔
1005
      Item.Declaration { attr; anchor; doc; content; source_anchor }
912✔
1006
  end
1007

1008
  open Value
1009

1010
  (* This chunk of code is responsible for sectioning list of items
1011
     according to headings by extracting headings as Items.
1012

1013
     TODO: This sectioning would be better done as a pass on the model directly.
1014
  *)
1015
  module Sectioning : sig
1016
    open Odoc_model
1017

1018
    val comment_items : Comment.elements -> Item.t list
1019

1020
    val docs : Comment.elements -> Item.t list * Item.t list
1021
  end = struct
1022
    let take_until_heading_or_end (docs : Odoc_model.Comment.elements) =
1023
      let content, _, rest =
693✔
1024
        Doctree.Take.until docs ~classify:(fun b ->
1025
            match b.Location.value with
1,481✔
1026
            | `Heading _ -> Stop_and_keep
202✔
1027
            | #Odoc_model.Comment.attached_block_element as doc ->
1,279✔
1028
                let content = Comment.attached_block_element doc in
1029
                Accum content)
1,279✔
1030
      in
1031
      (content, rest)
693✔
1032

1033
    let comment_items (input0 : Odoc_model.Comment.elements) =
1034
      let rec loop input_comment acc =
963✔
1035
        match input_comment with
2,493✔
1036
        | [] -> List.rev acc
963✔
1037
        | element :: input_comment -> (
1,530✔
1038
            match element.Location.value with
1039
            | `Heading h ->
837✔
1040
                let item = Comment.heading h in
1041
                loop input_comment (item :: acc)
837✔
1042
            | _ ->
693✔
1043
                let content, input_comment =
1044
                  take_until_heading_or_end (element :: input_comment)
1045
                in
1046
                let item = Item.Text content in
693✔
1047
                loop input_comment (item :: acc))
1048
      in
1049
      loop input0 []
1050

1051
    (* For doc pages, we want the header to contain everything until
1052
       the first heading, then everything before the next heading which
1053
       is either lower, or a section.
1054
    *)
1055
    let docs input_comment =
1056
      let items = comment_items input_comment in
69✔
1057
      let until_first_heading, o, items =
69✔
1058
        Doctree.Take.until items ~classify:(function
1059
          | Item.Heading h as i -> Stop_and_accum ([ i ], Some h.level)
69✔
1060
          | i -> Accum [ i ])
×
1061
      in
1062
      match o with
69✔
1063
      | None -> (until_first_heading, items)
×
1064
      | Some level ->
69✔
1065
          let max_level = if level = 1 then 2 else level in
×
1066
          let before_second_heading, _, items =
1067
            Doctree.Take.until items ~classify:(function
1068
              | Item.Heading h when h.level >= max_level -> Stop_and_keep
13✔
1069
              | i -> Accum [ i ])
38✔
1070
          in
1071
          let header = until_first_heading @ before_second_heading in
69✔
1072
          (header, items)
1073
  end
1074

1075
  module Class : sig
1076
    val class_ : Lang.Class.t -> Item.t
1077

1078
    val class_type : Lang.ClassType.t -> Item.t
1079
  end = struct
1080
    let class_type_expr (cte : Odoc_model.Lang.ClassType.expr) =
1081
      match cte with
249✔
1082
      | Constr (path, args) ->
58✔
1083
          let link = Link.from_path (path :> Paths.Path.t) in
1084
          format_type_path ~delim:`brackets args link
58✔
1085
      | Signature _ ->
191✔
1086
          Syntax.Class.open_tag ++ O.txt " ... " ++ Syntax.Class.close_tag
191✔
1087

1088
    let method_ (t : Odoc_model.Lang.Method.t) =
1089
      let name = Paths.Identifier.name t.id in
90✔
1090
      let virtual_ =
90✔
1091
        if t.virtual_ then O.keyword "virtual" ++ O.txt " " else O.noop
8✔
1092
      in
1093
      let private_ =
1094
        if t.private_ then O.keyword "private" ++ O.txt " " else O.noop
8✔
1095
      in
1096
      let content =
1097
        O.documentedSrc
1098
          (O.keyword "method" ++ O.txt " " ++ private_ ++ virtual_ ++ O.txt name
90✔
1099
          ++ O.txt Syntax.Type.annotation_separator
90✔
1100
          ++ type_expr t.type_)
90✔
1101
      in
1102
      let attr = [ "method" ] in
90✔
1103
      let anchor = path_to_id t.id in
1104
      let doc = Comment.to_ir t.doc.elements in
90✔
1105
      Item.Declaration { attr; anchor; doc; content; source_anchor = None }
90✔
1106

1107
    let instance_variable (t : Odoc_model.Lang.InstanceVariable.t) =
1108
      let name = Paths.Identifier.name t.id in
17✔
1109
      let virtual_ =
17✔
1110
        if t.virtual_ then O.keyword "virtual" ++ O.txt " " else O.noop
8✔
1111
      in
1112
      let mutable_ =
1113
        if t.mutable_ then O.keyword "mutable" ++ O.txt " " else O.noop
8✔
1114
      in
1115
      let content =
1116
        O.documentedSrc
1117
          (O.keyword "val" ++ O.txt " " ++ mutable_ ++ virtual_ ++ O.txt name
17✔
1118
          ++ O.txt Syntax.Type.annotation_separator
17✔
1119
          ++ type_expr t.type_)
17✔
1120
      in
1121
      let attr = [ "value"; "instance-variable" ] in
17✔
1122
      let anchor = path_to_id t.id in
1123
      let doc = Comment.to_ir t.doc.elements in
17✔
1124
      Item.Declaration { attr; anchor; doc; content; source_anchor = None }
17✔
1125

1126
    let inherit_ (ih : Lang.ClassSignature.Inherit.t) =
1127
      let cte =
16✔
1128
        match ih.expr with
1129
        | Signature _ -> assert false (* Bold. *)
1130
        | cty -> cty
16✔
1131
      in
1132
      let content =
1133
        O.documentedSrc (O.keyword "inherit" ++ O.txt " " ++ class_type_expr cte)
16✔
1134
      in
1135
      let attr = [ "inherit" ] in
16✔
1136
      let anchor = None in
1137
      let doc = Comment.to_ir ih.doc.elements in
1138
      Item.Declaration { attr; anchor; doc; content; source_anchor = None }
16✔
1139

1140
    let constraint_ (cst : Lang.ClassSignature.Constraint.t) =
1141
      let content =
8✔
1142
        O.documentedSrc (format_constraints [ (cst.left, cst.right) ])
8✔
1143
      in
1144
      let attr = [] in
8✔
1145
      let anchor = None in
1146
      let doc = Comment.to_ir cst.doc.elements in
1147
      Item.Declaration { attr; anchor; doc; content; source_anchor = None }
8✔
1148

1149
    let class_signature (c : Lang.ClassSignature.t) =
1150
      let rec loop l acc_items =
233✔
1151
        match l with
388✔
1152
        | [] -> List.rev acc_items
233✔
1153
        | item :: rest -> (
155✔
1154
            let continue item = loop rest (item :: acc_items) in
131✔
1155
            match (item : Lang.ClassSignature.item) with
1156
            | Inherit cty -> continue @@ inherit_ cty
16✔
1157
            | Method m -> continue @@ method_ m
90✔
1158
            | InstanceVariable v -> continue @@ instance_variable v
17✔
1159
            | Constraint cst -> continue @@ constraint_ cst
8✔
1160
            | Comment `Stop ->
8✔
1161
                let rest =
1162
                  List.skip_until rest ~p:(function
1163
                    | Lang.ClassSignature.Comment `Stop -> true
8✔
1164
                    | _ -> false)
8✔
1165
                in
1166
                loop rest acc_items
8✔
1167
            | Comment (`Docs c) ->
16✔
1168
                let items = Sectioning.comment_items c.elements in
1169
                loop rest (List.rev_append items acc_items))
16✔
1170
      in
1171
      (* FIXME: use [t.self] *)
1172
      (c.doc.elements, loop c.items [])
233✔
1173

1174
    let rec class_decl (cd : Odoc_model.Lang.Class.decl) =
1175
      match cd with
182✔
1176
      | ClassType expr -> class_type_expr expr
166✔
1177
      (* TODO: factorize the following with [type_expr] *)
1178
      | Arrow (None, src, dst) ->
16✔
1179
          O.span
16✔
1180
            (type_expr ~needs_parentheses:true src
16✔
1181
            ++ O.txt " " ++ Syntax.Type.arrow)
16✔
1182
          ++ O.txt " " ++ class_decl dst
16✔
1183
      | Arrow (Some (RawOptional _ as lbl), _src, dst) ->
×
1184
          O.span
×
1185
            (O.box_hv
×
1186
            @@ label lbl ++ O.txt ":"
×
1187
               ++ tag "error" (O.txt "???")
×
1188
               ++ O.txt " " ++ Syntax.Type.arrow)
×
1189
          ++ O.sp ++ class_decl dst
×
1190
      | Arrow (Some lbl, src, dst) ->
×
1191
          O.span
×
1192
            (label lbl ++ O.txt ":"
×
1193
            ++ type_expr ~needs_parentheses:true src
×
1194
            ++ O.txt " " ++ Syntax.Type.arrow)
×
1195
          ++ O.txt " " ++ class_decl dst
×
1196

1197
    let class_ (t : Odoc_model.Lang.Class.t) =
1198
      let name = Paths.Identifier.name t.id in
166✔
1199
      let params =
166✔
1200
        match t.params with
1201
        | [] -> O.noop
142✔
1202
        | _ :: _ as params -> format_params ~delim:`brackets params ++ O.txt " "
24✔
1203
      in
1204
      let virtual_ =
1205
        if t.virtual_ then O.keyword "virtual" ++ O.txt " " else O.noop
24✔
1206
      in
1207

1208
      let source_anchor = source_anchor t.source_loc in
1209
      let cname, expansion, expansion_doc =
166✔
1210
        match t.expansion with
1211
        | None -> (O.documentedSrc @@ O.txt name, None, None)
×
1212
        | Some csig ->
166✔
1213
            let expansion_doc, items = class_signature csig in
1214
            let url = Url.Path.from_identifier t.id in
166✔
1215
            let page =
166✔
1216
              make_expansion_page ~source_anchor url
1217
                [ t.doc.elements; expansion_doc ]
1218
                items
1219
            in
1220
            ( O.documentedSrc @@ path url [ inline @@ Text name ],
166✔
1221
              Some page,
1222
              Some expansion_doc )
1223
      in
1224
      let summary =
1225
        O.txt Syntax.Type.annotation_separator ++ class_decl t.type_
166✔
1226
      in
1227
      let cd =
166✔
1228
        attach_expansion
1229
          (Syntax.Type.annotation_separator, "object", "end")
1230
          expansion summary
1231
      in
1232
      let content =
166✔
1233
        O.documentedSrc (O.keyword "class" ++ O.txt " " ++ virtual_ ++ params)
166✔
1234
        @ cname @ cd
1235
      in
1236
      let attr = [ "class" ] in
1237
      let anchor = path_to_id t.id in
1238
      let doc = Comment.synopsis ~decl_doc:t.doc.elements ~expansion_doc in
166✔
1239
      Item.Declaration { attr; anchor; doc; content; source_anchor }
1240

1241
    let class_type (t : Odoc_model.Lang.ClassType.t) =
1242
      let name = Paths.Identifier.name t.id in
67✔
1243
      let params = format_params ~delim:`brackets t.params in
67✔
1244
      let virtual_ =
67✔
1245
        if t.virtual_ then O.keyword "virtual" ++ O.txt " " else O.noop
8✔
1246
      in
1247
      let source_anchor = source_anchor t.source_loc in
1248
      let cname, expansion, expansion_doc =
67✔
1249
        match t.expansion with
1250
        | None -> (O.documentedSrc @@ O.txt name, None, None)
×
1251
        | Some csig ->
67✔
1252
            let url = Url.Path.from_identifier t.id in
1253
            let expansion_doc, items = class_signature csig in
67✔
1254
            let page =
67✔
1255
              make_expansion_page ~source_anchor url
1256
                [ t.doc.elements; expansion_doc ]
1257
                items
1258
            in
1259
            ( O.documentedSrc @@ path url [ inline @@ Text name ],
67✔
1260
              Some page,
1261
              Some expansion_doc )
1262
      in
1263
      let summary = O.txt " = " ++ class_type_expr t.expr in
67✔
1264
      let expr = attach_expansion (" = ", "object", "end") expansion summary in
67✔
1265
      let content =
67✔
1266
        O.documentedSrc
67✔
1267
          (O.keyword "class" ++ O.txt " " ++ O.keyword "type" ++ O.txt " "
67✔
1268
         ++ virtual_ ++ params ++ O.txt " ")
67✔
1269
        @ cname @ expr
1270
      in
1271
      let attr = [ "class-type" ] in
1272
      let anchor = path_to_id t.id in
1273
      let doc = Comment.synopsis ~decl_doc:t.doc.elements ~expansion_doc in
67✔
1274
      Item.Declaration { attr; anchor; doc; content; source_anchor }
1275
  end
1276

1277
  open Class
1278

1279
  module Module : sig
1280
    val signature : Lang.Signature.t -> Comment.Comment.elements * Item.t list
1281
    (** Returns [header_doc, content]. *)
1282
  end = struct
1283
    let internal_module m =
1284
      let open Lang.Module in
1,924✔
1285
      match m.id.iv with
1286
      | `Module (_, name) when ModuleName.is_hidden name -> true
81✔
1287
      | _ -> false
1,843✔
1288

1289
    let internal_type t =
1290
      let open Lang.TypeDecl in
2,969✔
1291
      match t.id.iv with
1292
      | `Type (_, name) when TypeName.is_hidden name -> true
1✔
1293
      | _ -> false
2,968✔
1294

1295
    let internal_value v =
1296
      let open Lang.Value in
1,018✔
1297
      match v.id.iv with
1298
      | `Value (_, name) when ValueName.is_hidden name -> true
106✔
1299
      | _ -> false
912✔
1300

1301
    let internal_module_type t =
1302
      let open Lang.ModuleType in
1,361✔
1303
      match t.id.iv with
1304
      | `ModuleType (_, name) when ModuleTypeName.is_hidden name -> true
×
1305
      | _ -> false
1,361✔
1306

1307
    let internal_module_substitution t =
1308
      let open Lang.ModuleSubstitution in
8✔
1309
      match t.id.iv with
1310
      | `Module (_, name) when ModuleName.is_hidden name -> true
×
1311
      | _ -> false
8✔
1312

1313
    let internal_module_type_substitution t =
1314
      let open Lang.ModuleTypeSubstitution in
8✔
1315
      match t.id.iv with
1316
      | `ModuleType (_, name) when ModuleTypeName.is_hidden name -> true
×
1317
      | _ -> false
8✔
1318

1319
    let rec signature (s : Lang.Signature.t) =
1320
      let rec loop l acc_items =
3,582✔
1321
        match l with
12,543✔
1322
        | [] -> List.rev acc_items
3,582✔
1323
        | item :: rest -> (
8,961✔
1324
            let continue (item : Item.t) = loop rest (item :: acc_items) in
7,838✔
1325
            match (item : Lang.Signature.item) with
1326
            | Module (_, m) when internal_module m -> loop rest acc_items
81✔
1327
            | Type (_, t) when internal_type t -> loop rest acc_items
1✔
1328
            | Value v when internal_value v -> loop rest acc_items
106✔
1329
            | ModuleType m when internal_module_type m -> loop rest acc_items
×
1330
            | ModuleSubstitution m when internal_module_substitution m ->
8✔
1331
                loop rest acc_items
×
1332
            | ModuleTypeSubstitution m when internal_module_type_substitution m
8✔
1333
              ->
1334
                loop rest acc_items
×
1335
            | ModuleTypeSubstitution m -> continue @@ module_type_substitution m
8✔
1336
            | Module (_, m) -> continue @@ module_ m
1,843✔
1337
            | ModuleType m -> continue @@ module_type m
1,361✔
1338
            | Class (_, c) -> continue @@ class_ c
166✔
1339
            | ClassType (_, c) -> continue @@ class_type c
67✔
1340
            | Include m -> continue @@ include_ m
290✔
1341
            | ModuleSubstitution m -> continue @@ module_substitution m
8✔
1342
            | TypeSubstitution t ->
23✔
1343
                continue @@ type_decl ~is_substitution:true (Ordinary, t)
23✔
1344
            | Type (r, t) -> continue @@ type_decl (r, t)
2,968✔
1345
            | TypExt e -> continue @@ extension e
126✔
1346
            | Exception e -> continue @@ exn e
66✔
1347
            | Value v -> continue @@ value v
912✔
1348
            | Open o ->
82✔
1349
                let items = Sectioning.comment_items o.doc.elements in
1350
                loop rest (List.rev_append items acc_items)
82✔
1351
            | Comment `Stop ->
57✔
1352
                let rest =
1353
                  List.skip_until rest ~p:(function
1354
                    | Lang.Signature.Comment `Stop -> true
49✔
1355
                    | _ -> false)
65✔
1356
                in
1357
                loop rest acc_items
57✔
1358
            | Comment (`Docs c) ->
796✔
1359
                let items = Sectioning.comment_items c.elements in
1360
                loop rest (List.rev_append items acc_items))
796✔
1361
      in
1362
      ((Lang.extract_signature_doc s).elements, loop s.items [])
3,582✔
1363

1364
    and functor_parameter :
1365
        Odoc_model.Lang.FunctorParameter.parameter -> DocumentedSrc.t =
1366
     fun arg ->
1367
      let open Odoc_model.Lang.FunctorParameter in
211✔
1368
      let name = Paths.Identifier.name arg.id in
1369
      let render_ty = arg.expr in
211✔
1370
      let modtyp =
1371
        mty_in_decl (arg.id :> Paths.Identifier.Signature.t) render_ty
1372
      in
1373
      let modname, mod_decl =
211✔
1374
        match expansion_of_module_type_expr arg.expr with
1375
        | None ->
×
1376
            let modname = O.txt (Paths.Identifier.name arg.id) in
×
1377
            (modname, O.documentedSrc modtyp)
×
1378
        | Some (expansion_doc, items) ->
211✔
1379
            let url = Url.Path.from_identifier arg.id in
1380
            let modname = path url [ inline @@ Text name ] in
211✔
1381
            let type_with_expansion =
211✔
1382
              let content =
1383
                make_expansion_page ~source_anchor:None url [ expansion_doc ]
1384
                  items
1385
              in
1386
              let summary = O.render modtyp in
211✔
1387
              let status = `Default in
211✔
1388
              let expansion =
1389
                O.documentedSrc
211✔
1390
                  (O.txt Syntax.Type.annotation_separator ++ O.keyword "sig")
211✔
1391
                @ DocumentedSrc.[ Subpage { content; status } ]
1392
                @ O.documentedSrc (O.keyword "end")
211✔
1393
              in
1394
              DocumentedSrc.
1395
                [
1396
                  Alternative
1397
                    (Expansion { status = `Default; summary; url; expansion });
1398
                ]
1399
            in
1400
            (modname, type_with_expansion)
1401
      in
1402
      O.documentedSrc (O.keyword "module" ++ O.txt " ")
211✔
1403
      @ O.documentedSrc modname @ mod_decl
211✔
1404

1405
    and module_substitution (t : Odoc_model.Lang.ModuleSubstitution.t) =
1406
      let name = Paths.Identifier.name t.id in
8✔
1407
      let path = Link.from_path (t.manifest :> Paths.Path.t) in
8✔
1408
      let content =
8✔
1409
        O.documentedSrc
1410
          (O.keyword "module" ++ O.txt " " ++ O.txt name ++ O.txt " :=" ++ O.sp
8✔
1411
         ++ path)
8✔
1412
      in
1413
      let attr = [ "module-substitution" ] in
8✔
1414
      let anchor = path_to_id t.id in
1415
      let doc = Comment.to_ir t.doc.elements in
8✔
1416
      Item.Declaration { attr; anchor; doc; content; source_anchor = None }
8✔
1417

1418
    and module_type_substitution (t : Odoc_model.Lang.ModuleTypeSubstitution.t)
1419
        =
1420
      let prefix =
8✔
1421
        O.keyword "module" ++ O.txt " " ++ O.keyword "type" ++ O.txt " "
8✔
1422
      in
1423
      let source_anchor = None in
8✔
1424
      let modname = Paths.Identifier.name t.id in
1425
      let modname, expansion_doc, mty =
8✔
1426
        module_type_manifest ~subst:true ~source_anchor modname t.id
1427
          t.doc.elements (Some t.manifest) prefix
1428
      in
1429
      let content =
8✔
1430
        O.documentedSrc (prefix ++ modname)
8✔
1431
        @ mty
1432
        @ O.documentedSrc
8✔
1433
            (if Syntax.Mod.close_tag_semicolon then O.txt ";" else O.noop)
×
1434
      in
1435
      let attr = [ "module-type" ] in
1436
      let anchor = path_to_id t.id in
1437
      let doc = Comment.synopsis ~decl_doc:t.doc.elements ~expansion_doc in
8✔
1438
      Item.Declaration { attr; anchor; doc; content; source_anchor }
1439

1440
    and simple_expansion :
1441
        Odoc_model.Lang.ModuleType.simple_expansion ->
1442
        Comment.Comment.elements * Item.t list =
1443
     fun t ->
1444
      let rec extract_functor_params
2,933✔
1445
          (f : Odoc_model.Lang.ModuleType.simple_expansion) =
1446
        match f with
3,152✔
1447
        | Signature sg -> (None, sg)
2,933✔
1448
        | Functor (p, expansion) ->
219✔
1449
            let add_to params =
1450
              match p with Unit -> params | Named p -> p :: params
8✔
1451
            in
1452
            let params, sg = extract_functor_params expansion in
1453
            let params = match params with None -> [] | Some p -> p in
36✔
1454
            (Some (add_to params), sg)
219✔
1455
      in
1456
      match extract_functor_params t with
1457
      | None, sg -> signature sg
2,750✔
1458
      | Some params, sg ->
183✔
1459
          let sg_doc, content = signature sg in
1460
          let params =
183✔
1461
            let decl_of_arg arg =
1462
              let content = functor_parameter arg in
211✔
1463
              let attr = [ "parameter" ] in
211✔
1464
              let anchor =
1465
                Some (Url.Anchor.from_identifier (arg.id :> Paths.Identifier.t))
211✔
1466
              in
1467
              let doc = [] in
1468
              [
1469
                Item.Declaration
1470
                  { content; anchor; attr; doc; source_anchor = None };
1471
              ]
1472
            in
1473
            List.concat_map decl_of_arg params
183✔
1474
          in
1475
          let prelude = mk_heading ~label:"parameters" "Parameters" :: params
183✔
1476
          and content = mk_heading ~label:"signature" "Signature" :: content in
183✔
1477
          (sg_doc, prelude @ content)
1478

1479
    and expansion_of_module_type_expr :
1480
        Odoc_model.Lang.ModuleType.expr ->
1481
        (Comment.Comment.elements * Item.t list) option =
1482
     fun t ->
1483
      let rec simple_expansion_of (t : Odoc_model.Lang.ModuleType.expr) =
3,218✔
1484
        match t with
3,437✔
1485
        | Path { p_expansion = None; _ }
379✔
1486
        | TypeOf { t_expansion = None; _ }
8✔
1487
        | With { w_expansion = None; _ }
×
1488
        | Strengthen { s_expansion = None; _ } ->
×
1489
            None
1490
        | Path { p_expansion = Some e; _ }
426✔
1491
        | TypeOf { t_expansion = Some e; _ }
56✔
1492
        | With { w_expansion = Some e; _ }
218✔
1493
        | Strengthen { s_expansion = Some e; _ } ->
×
1494
            Some e
1495
        | Signature sg -> Some (Signature sg)
2,131✔
1496
        | Functor (f_parameter, e) -> (
219✔
1497
            match simple_expansion_of e with
1498
            | Some e -> Some (Functor (f_parameter, e))
211✔
1499
            | None -> None)
8✔
1500
      in
1501
      match simple_expansion_of t with
1502
      | None -> None
387✔
1503
      | Some e -> Some (simple_expansion e)
2,831✔
1504

1505
    and module_ : Odoc_model.Lang.Module.t -> Item.t =
1506
     fun t ->
1507
      let modname = Paths.Identifier.name t.id in
1,843✔
1508
      let expansion =
1,843✔
1509
        match t.type_ with
1510
        | Alias (_, Some e) -> Some (simple_expansion e)
102✔
1511
        | Alias (_, None) -> None
186✔
1512
        | ModuleType e -> expansion_of_module_type_expr e
1,555✔
1513
      in
1514
      let source_anchor = source_anchor t.source_loc in
1515
      let modname, status, expansion, expansion_doc =
1,843✔
1516
        match expansion with
1517
        | None -> (O.txt modname, `Default, None, None)
322✔
1518
        | Some (expansion_doc, items) ->
1,521✔
1519
            let status =
1520
              match t.type_ with
1521
              | ModuleType (Signature _) -> `Inline
987✔
1522
              | _ -> `Default
534✔
1523
            in
1524
            let url = Url.Path.from_identifier t.id in
1525
            let link = path url [ inline @@ Text modname ] in
1,521✔
1526
            let page =
1,521✔
1527
              make_expansion_page ~source_anchor url
1528
                [ t.doc.elements; expansion_doc ]
1529
                items
1530
            in
1531
            (link, status, Some page, Some expansion_doc)
1,521✔
1532
      in
1533
      let intro = O.keyword "module" ++ O.txt " " ++ modname in
1,843✔
1534
      let summary = O.ignore intro ++ mdexpr_in_decl t.id t.type_ in
1,843✔
1535
      let modexpr =
1,843✔
1536
        attach_expansion ~status
1537
          (Syntax.Type.annotation_separator, "sig", "end")
1538
          expansion summary
1539
      in
1540
      let content =
1,843✔
1541
        O.documentedSrc intro @ modexpr
1,843✔
1542
        @ O.documentedSrc
1,843✔
1543
            (if Syntax.Mod.close_tag_semicolon then O.txt ";" else O.noop)
×
1544
      in
1545
      let attr = [ "module" ] in
1546
      let anchor = path_to_id t.id in
1547
      let doc = Comment.synopsis ~decl_doc:t.doc.elements ~expansion_doc in
1,843✔
1548
      Item.Declaration { attr; anchor; doc; content; source_anchor }
1549

1550
    and simple_expansion_in_decl (base : Paths.Identifier.Module.t) se =
1551
      let rec ty_of_se :
102✔
1552
          Lang.ModuleType.simple_expansion -> Lang.ModuleType.expr = function
1553
        | Signature sg -> Signature sg
102✔
1554
        | Functor (arg, sg) -> Functor (arg, ty_of_se sg)
×
1555
      in
1556
      mty_in_decl (base :> Paths.Identifier.Signature.t) (ty_of_se se)
102✔
1557

1558
    and mdexpr_in_decl (base : Paths.Identifier.Module.t) md =
1559
      let sig_dotdotdot =
1,843✔
1560
        O.txt Syntax.Type.annotation_separator
1,843✔
1561
        ++ O.cut ++ Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag
1,843✔
1562
      in
1563
      match md with
1,843✔
1564
      | Alias (_, Some se) -> simple_expansion_in_decl base se
102✔
1565
      | Alias (p, _) when not Paths.Path.(is_hidden (p :> t)) ->
186✔
1566
          O.txt " =" ++ O.sp ++ mdexpr md
186✔
1567
      | Alias _ -> sig_dotdotdot
×
1568
      | ModuleType mt -> mty_in_decl (base :> Paths.Identifier.Signature.t) mt
1,555✔
1569

1570
    and mdexpr : Odoc_model.Lang.Module.decl -> text = function
1571
      | Alias (mod_path, _) -> Link.from_path (mod_path :> Paths.Path.t)
242✔
1572
      | ModuleType mt -> mty mt
×
1573

1574
    and module_type_manifest ~subst ~source_anchor modname id doc manifest
1575
        prefix =
1576
      let expansion =
1,369✔
1577
        match manifest with
1578
        | None -> None
128✔
1579
        | Some e -> expansion_of_module_type_expr e
1,241✔
1580
      in
1581
      let modname, expansion, expansion_doc =
1582
        match expansion with
1583
        | None -> (O.txt modname, None, None)
379✔
1584
        | Some (expansion_doc, items) ->
990✔
1585
            let url = Url.Path.from_identifier id in
1586
            let link = path url [ inline @@ Text modname ] in
990✔
1587
            let page =
990✔
1588
              make_expansion_page ~source_anchor url [ doc; expansion_doc ]
1589
                items
1590
            in
1591
            (link, Some page, Some expansion_doc)
990✔
1592
      in
1593
      let summary =
1594
        match manifest with
1595
        | None -> O.noop
128✔
1596
        | Some expr ->
1,241✔
1597
            O.ignore (prefix ++ modname)
1,241✔
1598
            ++ (if subst then O.txt " :=" ++ O.sp else O.txt " =" ++ O.sp)
8✔
1599
            ++ mty expr
1,241✔
1600
      in
1601
      ( modname,
1602
        expansion_doc,
1603
        attach_expansion (" = ", "sig", "end") expansion summary )
1,369✔
1604

1605
    and module_type (t : Odoc_model.Lang.ModuleType.t) =
1606
      let prefix =
1,361✔
1607
        O.keyword "module" ++ O.txt " " ++ O.keyword "type" ++ O.txt " "
1,361✔
1608
      in
1609
      let modname = Paths.Identifier.name t.id in
1,361✔
1610
      let source_anchor = source_anchor t.source_loc in
1,361✔
1611
      let modname, expansion_doc, mty =
1,361✔
1612
        module_type_manifest ~subst:false ~source_anchor modname t.id
1613
          t.doc.elements t.expr prefix
1614
      in
1615
      let content =
1,361✔
1616
        O.documentedSrc (prefix ++ modname)
1,361✔
1617
        @ mty
1618
        @ O.documentedSrc
1,361✔
1619
            (if Syntax.Mod.close_tag_semicolon then O.txt ";" else O.noop)
×
1620
      in
1621
      let attr = [ "module-type" ] in
1622
      let anchor = path_to_id t.id in
1623
      let doc = Comment.synopsis ~decl_doc:t.doc.elements ~expansion_doc in
1,361✔
1624
      Item.Declaration { attr; anchor; doc; content; source_anchor }
1625

1626
    and umty_hidden : Odoc_model.Lang.ModuleType.U.expr -> bool = function
1627
      | Path p -> Paths.Path.(is_hidden (p :> t))
403✔
1628
      | With (_, expr) -> umty_hidden expr
25✔
1629
      | TypeOf (ModPath m, _) | TypeOf (StructInclude m, _) ->
42✔
1630
          Paths.Path.(is_hidden (m :> t))
1631
      | Signature _ -> false
14✔
1632
      | Strengthen (expr, p, _) ->
×
1633
          umty_hidden expr || Paths.Path.(is_hidden (p :> t))
×
1634

1635
    and mty_hidden : Odoc_model.Lang.ModuleType.expr -> bool = function
1636
      | Path { p_path = mty_path; _ } -> Paths.Path.(is_hidden (mty_path :> t))
837✔
1637
      | With { w_expr; _ } -> umty_hidden w_expr
218✔
1638
      | TypeOf { t_desc = ModPath m; _ }
48✔
1639
      | TypeOf { t_desc = StructInclude m; _ } ->
16✔
1640
          Paths.Path.(is_hidden (m :> t))
1641
      | _ -> false
2,297✔
1642

1643
    and mty_with subs expr =
1644
      umty expr ++ O.sp ++ O.keyword "with" ++ O.txt " "
238✔
1645
      ++ O.list
238✔
1646
           ~sep:(O.cut ++ O.txt " " ++ O.keyword "and" ++ O.txt " ")
238✔
1647
           ~f:(fun x -> O.span (substitution x))
279✔
1648
           subs
1649

1650
    and mty_strengthen expr path =
1651
      umty expr ++ O.sp ++ O.keyword "with" ++ O.txt " "
×
1652
      ++ Link.from_path (path :> Paths.Path.t)
×
1653

1654
    and mty_typeof t_desc =
1655
      match t_desc with
154✔
1656
      | Odoc_model.Lang.ModuleType.ModPath m ->
90✔
1657
          O.keyword "module" ++ O.txt " " ++ O.keyword "type" ++ O.txt " "
90✔
1658
          ++ O.keyword "of" ++ O.txt " "
90✔
1659
          ++ Link.from_path (m :> Paths.Path.t)
90✔
1660
      | StructInclude m ->
64✔
1661
          O.keyword "module" ++ O.txt " " ++ O.keyword "type" ++ O.txt " "
64✔
1662
          ++ O.keyword "of" ++ O.txt " " ++ O.keyword "struct" ++ O.txt " "
64✔
1663
          ++ O.keyword "include" ++ O.txt " "
64✔
1664
          ++ Link.from_path (m :> Paths.Path.t)
64✔
1665
          ++ O.txt " " ++ O.keyword "end"
64✔
1666

1667
    and is_elidable_with_u : Odoc_model.Lang.ModuleType.U.expr -> bool =
1668
      function
1669
      | Path _ -> false
213✔
1670
      | Signature _ -> true
5✔
1671
      | With (_, expr) -> is_elidable_with_u expr
×
1672
      | TypeOf _ -> false
25✔
1673
      | Strengthen (expr, _, _) -> is_elidable_with_u expr
×
1674

1675
    and umty : Odoc_model.Lang.ModuleType.U.expr -> text =
1676
     fun m ->
1677
      match m with
527✔
1678
      | Path p -> Link.from_path (p :> Paths.Path.t)
403✔
1679
      | Signature _ ->
9✔
1680
          Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag
9✔
1681
      | With (_, expr) when is_elidable_with_u expr ->
25✔
1682
          Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag
5✔
1683
      | With (subs, expr) -> mty_with subs expr
20✔
1684
      | TypeOf (t_desc, _) -> mty_typeof t_desc
90✔
1685
      | Strengthen (expr, _, _) when is_elidable_with_u expr ->
×
1686
          Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag
×
1687
      | Strengthen (expr, p, _) -> mty_strengthen expr (p :> Paths.Path.t)
×
1688

1689
    and mty : Odoc_model.Lang.ModuleType.expr -> text =
1690
     fun m ->
1691
      if mty_hidden m then
3,416✔
1692
        Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag
×
1693
      else
1694
        match m with
3,416✔
1695
        | Path { p_path = mty_path; _ } ->
837✔
1696
            Link.from_path (mty_path :> Paths.Path.t)
1697
        | Functor (Unit, expr) ->
×
1698
            (if Syntax.Mod.functor_keyword then O.keyword "functor" else O.noop)
×
1699
            ++ O.span (O.txt " () " ++ Syntax.Type.arrow)
×
1700
            ++ O.sp ++ mty expr
×
1701
        | Functor (Named arg, expr) ->
48✔
1702
            let arg_expr = arg.expr in
1703
            let stop_before = expansion_of_module_type_expr arg_expr = None in
48✔
1704
            let name =
1705
              let open Odoc_model.Lang.FunctorParameter in
1706
              let name = Paths.Identifier.name arg.id in
1707
              let href =
48✔
1708
                Url.from_identifier ~stop_before (arg.id :> Paths.Identifier.t)
1709
              in
1710
              resolved href [ inline @@ Text name ]
48✔
1711
            in
1712
            (if Syntax.Mod.functor_keyword then O.keyword "functor" else O.noop)
×
1713
            ++ (O.box_hv @@ O.span
48✔
1714
               @@ O.txt " (" ++ name
48✔
1715
                  ++ O.txt Syntax.Type.annotation_separator
48✔
1716
                  ++ mty arg_expr ++ O.txt ")" ++ O.txt " " ++ Syntax.Type.arrow
48✔
1717
               )
1718
            ++ O.sp ++ mty expr
48✔
1719
        | With { w_expr; _ } when is_elidable_with_u w_expr ->
218✔
1720
            Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag
×
1721
        | With { w_substitutions; w_expr; _ } ->
218✔
1722
            O.box_hv @@ mty_with w_substitutions w_expr
218✔
1723
        | TypeOf { t_desc; _ } -> mty_typeof t_desc
64✔
1724
        | Signature _ ->
2,249✔
1725
            Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag
2,249✔
1726
        | Strengthen { s_expr; _ } when is_elidable_with_u s_expr ->
×
1727
            Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag
×
1728
        | Strengthen { s_expr; s_path; _ } ->
×
1729
            O.box_hv @@ mty_strengthen s_expr (s_path :> Paths.Path.t)
×
1730

1731
    and mty_in_decl :
1732
        Paths.Identifier.Signature.t -> Odoc_model.Lang.ModuleType.expr -> text
1733
        =
1734
     fun base -> function
1735
      | (Path _ | Signature _ | With _ | TypeOf _ | Strengthen _) as m ->
×
1736
          O.txt Syntax.Type.annotation_separator ++ O.cut ++ mty m
1,868✔
1737
      | Functor _ as m when not Syntax.Mod.functor_contraction ->
171✔
1738
          O.txt Syntax.Type.annotation_separator ++ O.cut ++ mty m
×
1739
      | Functor (arg, expr) ->
171✔
1740
          let text_arg =
1741
            match arg with
1742
            | Unit -> O.txt "()"
8✔
1743
            | Named arg ->
163✔
1744
                let arg_expr = arg.expr in
1745
                let stop_before =
1746
                  expansion_of_module_type_expr arg_expr = None
163✔
1747
                in
1748
                let name =
1749
                  let open Odoc_model.Lang.FunctorParameter in
1750
                  let name = Paths.Identifier.name arg.id in
1751
                  let href =
163✔
1752
                    Url.from_identifier ~stop_before
1753
                      (arg.id :> Paths.Identifier.t)
1754
                  in
1755
                  resolved href [ inline @@ Text name ]
163✔
1756
                in
1757
                O.box_hv
163✔
1758
                @@ O.txt "(" ++ name
163✔
1759
                   ++ O.txt Syntax.Type.annotation_separator
163✔
1760
                   ++ O.cut ++ mty arg.expr ++ O.txt ")"
163✔
1761
          in
1762
          O.sp ++ text_arg ++ mty_in_decl base expr
171✔
1763

1764
    (* TODO : Centralize the list juggling for type parameters *)
1765
    and type_expr_in_subst td typath =
1766
      let typath = Link.from_fragment typath in
151✔
1767
      match td.Lang.TypeDecl.Equation.params with
151✔
1768
      | [] -> typath
125✔
1769
      | l -> Syntax.Type.handle_substitution_params typath (format_params l)
26✔
1770

1771
    and substitution : Odoc_model.Lang.ModuleType.substitution -> text =
1772
      function
1773
      | ModuleEq (frag_mod, md) ->
56✔
1774
          O.box_hv
1775
          @@ O.keyword "module" ++ O.txt " "
56✔
1776
             ++ Link.from_fragment (frag_mod :> Paths.Fragment.leaf)
56✔
1777
             ++ O.txt " =" ++ O.sp ++ mdexpr md
56✔
1778
      | ModuleTypeEq (frag_mty, md) ->
32✔
1779
          O.box_hv
1780
          @@ O.keyword "module" ++ O.txt " " ++ O.keyword "type" ++ O.txt " "
32✔
1781
             ++ Link.from_fragment (frag_mty :> Paths.Fragment.leaf)
32✔
1782
             ++ O.txt " =" ++ O.sp ++ mty md
32✔
1783
      | TypeEq (frag_typ, td) ->
104✔
1784
          O.box_hv
1785
          @@ O.keyword "type" ++ O.txt " "
104✔
1786
             ++ type_expr_in_subst td (frag_typ :> Paths.Fragment.leaf)
104✔
1787
             ++ fst (format_manifest td)
104✔
1788
             ++ format_constraints
104✔
1789
                  td.Odoc_model.Lang.TypeDecl.Equation.constraints
1790
      | ModuleSubst (frag_mod, mod_path) ->
24✔
1791
          O.box_hv
1792
          @@ O.keyword "module" ++ O.txt " "
24✔
1793
             ++ Link.from_fragment (frag_mod :> Paths.Fragment.leaf)
24✔
1794
             ++ O.txt " :=" ++ O.sp
24✔
1795
             ++ Link.from_path (mod_path :> Paths.Path.t)
24✔
1796
      | ModuleTypeSubst (frag_mty, md) ->
16✔
1797
          O.box_hv
1798
          @@ O.keyword "module" ++ O.txt " " ++ O.keyword "type" ++ O.txt " "
16✔
1799
             ++ Link.from_fragment (frag_mty :> Paths.Fragment.leaf)
16✔
1800
             ++ O.txt " :=" ++ O.sp ++ mty md
16✔
1801
      | TypeSubst (frag_typ, td) -> (
47✔
1802
          O.box_hv
1803
          @@ O.keyword "type" ++ O.txt " "
47✔
1804
             ++ type_expr_in_subst td (frag_typ :> Paths.Fragment.leaf)
47✔
1805
             ++ O.txt " :=" ++ O.sp
47✔
1806
             ++
47✔
1807
             match td.Lang.TypeDecl.Equation.manifest with
1808
             | None -> assert false (* cf loader/cmti *)
1809
             | Some te -> type_expr te)
47✔
1810

1811
    and include_ (t : Odoc_model.Lang.Include.t) =
1812
      let decl_hidden =
290✔
1813
        match t.decl with
1814
        | Alias p -> Paths.Path.(is_hidden (p :> t))
×
1815
        | ModuleType mty -> umty_hidden mty
290✔
1816
      in
1817
      let status = if decl_hidden then `Inline else t.status in
1✔
1818

1819
      let _, content = signature t.expansion.content in
1820
      let summary =
290✔
1821
        if decl_hidden then O.render (O.keyword "include" ++ O.txt " ...")
1✔
1822
        else
1823
          let include_decl =
289✔
1824
            match t.decl with
1825
            | Odoc_model.Lang.Include.Alias mod_path ->
×
1826
                Link.from_path (mod_path :> Paths.Path.t)
×
1827
            | ModuleType mt -> umty mt
289✔
1828
          in
1829
          O.render
289✔
1830
            (O.keyword "include" ++ O.txt " " ++ include_decl
289✔
1831
            ++ if Syntax.Mod.include_semicolon then O.keyword ";" else O.noop)
×
1832
      in
1833
      let content = { Include.content; status; summary } in
1834
      let attr = [ "include" ] in
1835
      let anchor = None in
1836
      let doc =
1837
        (* Documentation attached to includes behave differently than other
1838
           declarations, which show only the synopsis. We can't only show the
1839
           synopsis because no page is generated to render it and we'd loose
1840
           the full documentation.
1841
           The documentation from the expansion is not used. *)
1842
        Comment.to_ir t.doc.elements
1843
      in
1844
      Item.Include { attr; anchor; doc; content; source_anchor = None }
290✔
1845
  end
1846

1847
  open Module
1848

1849
  module Page : sig
1850
    val compilation_unit : Lang.Compilation_unit.t -> Document.t
1851

1852
    val page : Lang.Page.t -> Document.t
1853

1854
    val implementation :
1855
      Lang.Implementation.t ->
1856
      Syntax_highlighter.infos ->
1857
      string ->
1858
      Document.t list
1859
  end = struct
1860
    let pack : Lang.Compilation_unit.Packed.t -> Item.t list =
1861
     fun t ->
1862
      let f x =
×
1863
        let id = x.Lang.Compilation_unit.Packed.id in
×
1864
        let modname = Paths.Identifier.name id in
1865
        let md_def =
×
1866
          O.keyword "module" ++ O.txt " " ++ O.txt modname ++ O.txt " = "
×
1867
          ++ Link.from_path (x.path :> Paths.Path.t)
×
1868
        in
1869
        let content = O.documentedSrc md_def in
×
1870
        let anchor =
×
1871
          Some (Url.Anchor.from_identifier (id :> Paths.Identifier.t))
×
1872
        in
1873
        let attr = [ "modules" ] in
1874
        let doc = [] in
1875
        let decl = { Item.anchor; content; attr; doc; source_anchor = None } in
1876
        Item.Declaration decl
1877
      in
1878
      List.map f t
1879

1880
    let compilation_unit (t : Odoc_model.Lang.Compilation_unit.t) =
1881
      let url = Url.Path.from_identifier t.id in
359✔
1882
      let unit_doc, items =
359✔
1883
        match t.content with
1884
        | Module sign -> signature sign
359✔
1885
        | Pack packed -> ([], pack packed)
×
1886
      in
1887
      let source_anchor = source_anchor t.source_loc in
1888
      let page = make_expansion_page ~source_anchor url [ unit_doc ] items in
359✔
1889
      Document.Page page
359✔
1890

1891
    let page (t : Odoc_model.Lang.Page.t) =
1892
      (*let name =
1893
          match t.name.iv with `Page (_, name) | `LeafPage (_, name) -> name
1894
        in*)
1895
      (*let title = Odoc_model.Names.PageName.to_string name in*)
1896
      let url = Url.Path.from_identifier t.name in
69✔
1897
      let preamble, items = Sectioning.docs t.content.elements in
69✔
1898
      let source_anchor = None in
69✔
1899
      Document.Page { Page.preamble; items; url; source_anchor }
1900

1901
    let implementation (v : Odoc_model.Lang.Implementation.t) syntax_info
1902
        source_code =
1903
      match v.id with
28✔
1904
      | None -> []
×
1905
      | Some id ->
28✔
1906
          [
1907
            Document.Source_page
1908
              (Source_page.source id syntax_info v.source_info source_code);
28✔
1909
          ]
1910
  end
1911

1912
  include Page
1913

1914
  let type_expr = type_expr
1915

1916
  let record = record
1917

1918
  let unboxed_record = unboxed_record
1919
end
STATUS · Troubleshooting · Open an Issue · Sales · Support · CAREERS · ENTERPRISE · START FREE · SCHEDULE DEMO
ANNOUNCEMENTS · TWITTER · TOS & SLA · Supported CI Services · What's a CI service? · Automated Testing

© 2026 Coveralls, Inc