Source file `doc.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
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
open Import

type inline = Doc_types.inline =
  | Text of string
  | Code of string

type block = Doc_types.block =
  | Paragraph of inline list
  | Pre of string

type doc = block list

(* Parse and print ATD's own "text" format *)
module Text = struct

  let parse loc s =
    try (Doc_lexer.parse_string s : block list)
    with e ->
      failwith (Printf.sprintf "%s:\nInvalid format for doc.text %S:\n%s"
                  (Ast.string_of_loc loc) s (Printexc.to_string e))

  (*
     Escape as little as we can get away with depending on the context:
     - always: \ -> \\
     - normal text mode: {{ -> \{\{
     - code: }} -> \}\}
     - pre: }}} -> \}\}\}
  *)

  let escape_text_re =
    Re.Pcre.regexp {|\{\{\|\\|}

  let escape_code_re =
    Re.Pcre.regexp {|\}\}|\\|}

  let escape_pre_re =
    Re.Pcre.regexp {|\}\}\}|\\|}

  let escape_text s =
    Re.Pcre.substitute ~rex:escape_text_re ~subst:(function
      | "{{" -> {|\{\{|}
      | {|\|} -> {|\\|}
      | s -> s (* bug *)
    ) s

  let escape_code s =
    Re.Pcre.substitute ~rex:escape_code_re ~subst:(function
      | "}}" -> {|\}\}|}
      | {|\|} -> {|\\|}
      | s -> s (* bug *)
    ) s

  let escape_pre s =
    Re.Pcre.substitute ~rex:escape_pre_re ~subst:(function
      | "}}}" -> {|\}\}\}|}
      | {|\|} -> {|\\|}
      | s -> s (* bug *)
    ) s

  let compact_whitespace =
    let rex = Re.Pcre.regexp "(?: \t\r\n)+" in
    fun s ->
      Re.Pcre.substitute ~rex ~subst:(fun _ -> " ") s

  (* - remove leading and trailing whitespace
     - turn inner whitespace sequences into a single space *)
  let normalize_inline s =
    s
    |> String.trim
    |> compact_whitespace

  let concat_nonempty sep xs =
    xs
    |> List.filter ((<>) "")
    |> String.concat sep

  let print_inline (x : Doc_types.inline) =
    match x with
    | Text s -> s |> normalize_inline |> escape_text
    | Code s ->
        match s |> normalize_inline |> escape_code with
        | "" -> ""
        | s ->
            let first_space =
              if s.[0] = '{' then
                " "
              else
                ""
            in
            let last_space =
              if s.[String.length s - 1] = '}' then
                " "
              else
                ""
            in
            sprintf "{{%s%s%s}}"
              first_space s last_space

  let print_block (x : Doc_types.block) =
    match x with
    | Paragraph xs ->
        xs
        |> List.map print_inline
        |> concat_nonempty " "
    | Pre s ->
        let content = escape_pre s in
        match content with
        | "" -> ""
        | s ->
            let first_newline =
              if s.[0] <> '\n' then
                "\n"
              else
                ""
            in
            let last_newline =
              if s.[String.length s - 1] <> '\n' then
                "\n"
              else
                ""
            in
            sprintf "{{{%s%s%s}}}"
              first_newline s last_newline

  let print_blocks blocks =
    blocks
    |> List.map print_block
    |> String.concat "\n\n"
end

let parse_text = Text.parse
let print_text = Text.print_blocks

(*
   This must hold all the valid annotations of the form
   '<doc ...>'.
*)
let annot_schema : Annot.schema = [
  {
    section = "doc";
    fields = [
      Module_head, "text";
      Type_def, "text";
      Variant, "text";
      Field, "text";
      (* Tolerate but deprecate?
      Type_expr, "text"; *)
    ]
  }
]

let get_doc loc an : doc option =
  Annot.get_opt_field
    ~parse:(fun s -> Some (parse_text loc s))
    ~sections:["doc"]
    ~field:"text" an

(* Conversion to HTML *)

let html_escape buf s =
  String.iter (
    function
        '<' -> Buffer.add_string buf "&lt;"
      | '>' -> Buffer.add_string buf "&gt;"
      | '&' -> Buffer.add_string buf "&amp;"
      | '"' -> Buffer.add_string buf "&quot;"
      | c -> Buffer.add_char buf c
  ) s

let print_inline buf = function
  | Text s -> html_escape buf s
  | Code s -> bprintf buf "<code>%a</code>" html_escape s

let html_of_doc blocks =
  let buf = Buffer.create 300 in
  bprintf buf "\n<div class=\"atd-doc\">\n";
  List.iter (function
    | Paragraph l ->
        Buffer.add_string buf "<p>\n";
        List.iter (print_inline buf) l;
        Buffer.add_string buf "\n</p>\n"
    | Pre s ->
        Buffer.add_string buf "<pre>\n";
        html_escape buf s;
        Buffer.add_string buf "</pre>\n"
  ) blocks;
  bprintf buf "\n</div>\n";
  Buffer.contents buf