package markup

  1. Overview
  2. Docs

Source file html_writer.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
(* This file is part of Markup.ml, released under the MIT license. See
   LICENSE.md for details, or visit https://github.com/aantron/markup.ml. *)

open Common

let escape_attribute s =
  let buffer = Buffer.create (String.length s) in
  Uutf.String.fold_utf_8 (fun () _ -> function
    | `Malformed _ -> ()
    | `Uchar c ->
      let c = Uchar.to_int c in
      match c with
      | 0x0026 -> Buffer.add_string buffer "&"
      | 0x00A0 -> Buffer.add_string buffer " "
      | 0x0022 -> Buffer.add_string buffer """
      | _ -> add_utf_8 buffer c)
    () s;
  Buffer.contents buffer

let escape_text s =
  let buffer = Buffer.create (String.length s) in
  Uutf.String.fold_utf_8 (fun () _ -> function
    | `Malformed _ -> ()
    | `Uchar c ->
      let c = Uchar.to_int c in
      match c with
      | 0x0026 -> Buffer.add_string buffer "&"
      | 0x00A0 -> Buffer.add_string buffer " "
      | 0x003C -> Buffer.add_string buffer "<"
      | 0x003E -> Buffer.add_string buffer ">"
      | _ -> add_utf_8 buffer c)
    () s;
  Buffer.contents buffer

let void_elements =
  ["area"; "base"; "basefont"; "bgsound"; "br"; "col"; "embed"; "frame"; "hr";
   "img"; "input"; "keygen"; "link"; "meta"; "param"; "source"; "track"; "wbr"]

let prepend_newline_for = ["pre"; "textarea"; "listing"]

let rec starts_with_newline = function
  | [] -> false
  | s::more ->
    if String.length s = 0 then starts_with_newline more
    else s.[0] = '\x0A'

open Kstream

let literal_text_elements =
  ["style"; "script"; "xmp"; "iframe"; "noembed"; "noframes"; "plaintext"]

let write ?(escape_attribute=escape_attribute) ?(escape_text=escape_text) signals =
  let open_elements = ref [] in

  let in_literal_text_element () =
    match !open_elements with
      | element :: _ -> List.mem element literal_text_elements
      | _ -> false in

  let rec queue = ref next_signal

  and emit_list l throw e k =
    match l with
    | [] -> next_signal throw e k
    | s::more ->
      queue := emit_list more;
      k s

  and next_signal throw e k =
    next signals throw e begin function
      | `Start_element ((ns, name') as name, attributes) ->
        let tag_name =
          match name with
          | ns, local_name
              when list_mem_string ns [html_ns; svg_ns; mathml_ns] ->
            local_name
          | ns, local_name when ns = xml_ns -> "xml:" ^ local_name
          | ns, local_name when ns = xmlns_ns -> "xmlns:" ^ local_name
          | ns, local_name when ns = xlink_ns -> "xlink:" ^ local_name
          | _, local_name -> (* An error. *) local_name
        in

        let attributes =
          attributes |> List.map (fun ((ns, local_name) as name, value) ->
            let name =
              match name with
              | "", _ -> local_name
              | _ when ns = xml_ns -> "xml:" ^ local_name
              | _, "xmlns" when ns = xmlns_ns -> "xmlns"
              | _ when ns = xmlns_ns -> "xmlns:" ^ local_name
              | _ when ns = xlink_ns -> "xlink:" ^ local_name
              | _ -> (* An error. *) local_name
            in
            name, value)
        in

        let rec prepend_attributes words = function
          | [] -> words
          | (name, value)::more ->
            prepend_attributes
              (" "::name::"=\""::(escape_attribute value)::"\""::words) more
        in

        let tag =
          "<"::tag_name::(prepend_attributes [">"] (List.rev attributes)) in

        let is_void = ns = html_ns && list_mem_string name' void_elements in

        if is_void then
          peek signals throw (fun () -> emit_list tag throw e k) (function
            | `End_element ->
              next_option signals throw (fun _ ->
              emit_list tag throw e k)
            | `Start_element _ | `Text _ | `Comment _ | `PI _ | `Xml _
            | `Doctype _ ->
              open_elements := tag_name::!open_elements;
              emit_list tag throw e k)
        else begin
          open_elements := tag_name::!open_elements;

          if ns = html_ns && list_mem_string name' prepend_newline_for then
            peek_option signals throw (function
              | Some (`Text ss) when starts_with_newline ss ->
                emit_list (tag @ ["\n"]) throw e k
              | Some (`Text _ | `Start_element _ | `End_element | `Comment _ |
                      `PI _ | `Doctype _ | `Xml _)
              | None -> emit_list tag throw e k)
          else
            emit_list tag throw e k
        end

      | `End_element ->
        begin match !open_elements with
        | [] -> next_signal throw e k
        | name::rest ->
          open_elements := rest;
          emit_list ["</"; name; ">"] throw e k
        end

      | `Text ss ->
        if List.for_all (fun s -> String.length s = 0) ss then
          next_signal throw e k
        else if in_literal_text_element () then
          emit_list ss throw e k
        else
          emit_list (List.map escape_text ss) throw e k

      | `Comment s ->
        emit_list ["<!--"; s; "-->"] throw e k

      | `PI (target, s) ->
        emit_list ["<?"; target; " "; s; ">"] throw e k

      | `Doctype _ as doctype ->
        emit_list [signal_to_string doctype] throw e k

      | `Xml _ ->
        next_signal throw e k
    end

  in

  (fun throw e k -> !queue throw e k) |> make