Source file `toc.ml`

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
open Ast.Util

let rec remove_links inline =
  match inline with
  | Concat (attr, inlines) -> Concat (attr, List.map remove_links inlines)
  | Emph (attr, inline) -> Emph (attr, remove_links inline)
  | Strong (attr, inline) -> Emph (attr, remove_links inline)
  | Link (_, link) -> link.label
  | Image (attr, link) ->
      Image (attr, { link with label = remove_links link.label })
  | Hard_break _ | Soft_break _ | Html _ | Code _ | Text _ -> inline

let headers =
  let remove_links_f = remove_links in
  fun ?(remove_links = false) doc ->
    let headers = ref [] in
    let rec loop blocks =
      List.iter
        (function
          | Heading (attr, level, inline) ->
              let inline =
                if remove_links then remove_links_f inline else inline
              in
              headers := (attr, level, inline) :: !headers
          | Blockquote (_, blocks) -> loop blocks
          | List (_, _, _, block_lists) -> List.iter loop block_lists
          | Paragraph _ | Thematic_break _ | Html_block _ | Definition_list _
          | Code_block _ | Table _ ->
              ())
        blocks
    in
    loop doc;
    List.rev !headers

(* Given a list of headers — in the order of the document — go to the
   requested subsection.  We first seek for the [number]th header at
   [level]. *)
let rec find_start headers level number subsections =
  match headers with
  | (_, header_level, _) :: tl when header_level > level ->
      (* Skip, right [level]-header not yet reached. *)
      if number = 0 then
        (* Assume empty section at [level], do not consume token. *)
        match subsections with
        | [] -> headers (* no subsection to find *)
        | n :: subsections -> find_start headers (level + 1) n subsections
      else find_start tl level number subsections
  | (_, header_level, _) :: tl when header_level = level ->
      (* At proper [level].  Have we reached the [number] one? *)
      if number <= 1 then
        match subsections with
        | [] -> tl (* no subsection to find *)
        | n :: subsections -> find_start tl (level + 1) n subsections
      else find_start tl level (number - 1) subsections
  | _ ->
      (* Sought [level] has not been found in the current section *)
      []

let unordered_list items = List ([], Bullet '*', Tight, items)

let find_id attributes =
  List.find_map
    (function k, v when String.equal "id" k -> Some v | _ -> None)
    attributes

let link attributes label =
  let inline =
    match find_id attributes with
    | None -> label
    | Some id -> Link ([], { label; destination = "#" ^ id; title = None })
  in
  Paragraph ([], inline)

let rec make_toc
    (headers : ('attr * int * 'a inline) list)
    ~min_level
    ~max_level =
  match headers with
  | _ when min_level > max_level -> ([], headers)
  | [] -> ([], [])
  | (_, level, _) :: _ when level < min_level -> ([], headers)
  | (_, level, _) :: tl when level > max_level ->
      make_toc tl ~min_level ~max_level
  | (attr, level, t) :: tl when level = min_level ->
      let sub_toc, tl = make_toc tl ~min_level:(min_level + 1) ~max_level in
      let toc_entry =
        match sub_toc with
        | [] -> [ link attr t ]
        | _ -> [ link attr t; unordered_list sub_toc ]
      in
      let toc, tl = make_toc tl ~min_level ~max_level in
      (toc_entry :: toc, tl)
  | _ ->
      let sub_toc, tl =
        make_toc headers ~min_level:(min_level + 1) ~max_level
      in
      let toc, tl = make_toc tl ~min_level ~max_level in
      ([ unordered_list sub_toc ] :: toc, tl)

let toc ?(start = []) ?(depth = 2) doc =
  if depth < 1 then invalid_arg "Omd.toc: ~depth must be >= 1";
  let headers = headers ~remove_links:true doc in
  let headers =
    match start with
    | [] -> headers
    | number :: _ when number < 0 ->
        invalid_arg "Omd.toc: level 1 start must be >= 0"
    | number :: subsections -> find_start headers 1 number subsections
  in
  let len = List.length start in
  let toc, _ = make_toc headers ~min_level:(len + 1) ~max_level:(len + depth) in
  match toc with [] -> [] | _ -> [ unordered_list toc ]