Source file odoc_html_frontend.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
module Html : sig
  type t

  val string_of_list : t list -> string

  type attr

  val a_class : string list -> attr
  val code : a:attr list -> t list -> t
  val span : a:attr list -> t list -> t
  val div : a:attr list -> t list -> t
  val txt : string -> t

  module Unsafe : sig
    val data : string -> t
  end
end = struct
  type t = Raw of string | Txt of string | Concat of t list

  let add_escape_string buf s =
    (* https://discuss.ocaml.org/t/html-encoding-of-string/4289/4 *)
    let add s = Buffer.add_string buf s in
    let len = String.length s in
    let max_idx = len - 1 in
    let flush start i =
      if start < len then Buffer.add_substring buf s start (i - start)
    in
    let rec loop start i =
      if i > max_idx then flush start i
      else
        match String.get s i with
        | '&' -> escape "&amp;" start i
        | '<' -> escape "&lt;" start i
        | '>' -> escape "&gt;" start i
        | '\'' -> escape "&apos;" start i
        | '"' -> escape "&quot;" start i
        | '@' -> escape "&commat;" start i
        | _ -> loop start (i + 1)
    and escape amperstr start i =
      flush start i;
      add amperstr;
      let next = i + 1 in
      loop next next
    in
    loop 0 0

  let to_string t =
    let buf = Buffer.create 16 in
    let rec go = function
      | Raw s -> Buffer.add_string buf s
      | Txt s -> add_escape_string buf s
      | Concat xs -> List.iter go xs
    in
    go t;
    Buffer.contents buf

  let string_of_list lst = to_string (Concat lst)

  type attr = t

  let a_class lst =
    Concat [ Raw "class=\""; Txt (String.concat " " lst); Raw "\"" ]

  let attrs = function [] -> Concat [] | xs -> Concat (Raw " " :: xs)

  let block name ~a body =
    let name = Raw name in
    Concat
      [ Raw "<"; name; attrs a; Raw ">"; Concat body; Raw "</"; name; Raw ">" ]

  let code = block "code"
  let span = block "span"
  let div = block "div"
  let txt s = Txt s

  module Unsafe = struct
    let data s = Raw s
  end
end

let of_strings ~kind ~prefix_name ~name ~rhs ~typedecl_params ~doc =
  let open Html in
  let kind = code ~a:[ a_class [ "entry-kind" ] ] [ txt kind ]
  and typedecl_params =
    match typedecl_params with
    | None -> []
    | Some p ->
        [
          span
            ~a:
              [
                a_class
                  [
                    (* the parameter of the typedecl are highlighted as if part of main entry name. *)
                    "entry-name";
                  ];
              ]
            [ txt (p ^ " ") ];
        ]
  and prefix_name =
    match prefix_name with
    | None -> []
    | Some "" -> []
    | Some prefix_name ->
        [ span ~a:[ a_class [ "prefix-name" ] ] [ txt prefix_name ] ]
  and name =
    match name with
    | Some name -> [ span ~a:[ a_class [ "entry-name" ] ] [ txt name ] ]
    | None -> []
  and rhs =
    match rhs with
    | None -> []
    | Some rhs -> [ code ~a:[ a_class [ "entry-rhs" ] ] [ txt rhs ] ]
  in
  Html.string_of_list
    [
      kind;
      code
        ~a:[ a_class [ "entry-title" ] ]
        (typedecl_params @ prefix_name @ name @ rhs);
      div ~a:[ a_class [ "entry-comment" ] ] [ Unsafe.data doc ];
    ]

let kind_doc = "doc"
let kind_typedecl = "type"
let kind_module = "mod"
let kind_exception = "exn"
let kind_class_type = "class"
let kind_class = "class"
let kind_method = "meth"
let kind_extension_constructor = "cons"
let kind_module_type = "sig"
let kind_constructor = "cons"
let kind_field = "field"
let kind_value = "val"
let kind_extension = "ext"