Source file xml_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
let escape s =
let buffer = Buffer.create (String.length s) in
String.iter (function
| '"' -> Buffer.add_string buffer """
| '&' -> Buffer.add_string buffer "&"
| '\'' -> Buffer.add_string buffer "'"
| '<' -> Buffer.add_string buffer "<"
| '>' -> Buffer.add_string buffer ">"
| c -> Buffer.add_char buffer c)
s;
Buffer.contents buffer
let attribute_strings end_ attributes =
let rec prepend_attributes words = function
| [] -> words
| (name, value)::more ->
prepend_attributes
(" "::name::"=\""::(escape value)::"\""::words) more
in
prepend_attributes [end_] (List.rev attributes)
open Common
open Kstream
let write report prefix signals =
let signals = enumerate signals in
let open_elements = ref [] in
let namespaces = Namespace.Writing.init prefix 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
| i, (`Start_element (name, attributes) as signal) ->
(fun k' ->
next signals throw (fun () -> k' false) (fun s ->
match s with
| _, `End_element -> k' true
| _, (`Text _ | `Start_element _ | `Comment _ | `PI _ | `Doctype _ |
`Xml _) -> push signals s; k' false))
(fun self_closing ->
Namespace.Writing.push (fun () -> report (signal, i))
namespaces name attributes
throw (fun (formatted_name, formatted_attributes) ->
open_elements := formatted_name::!open_elements;
if self_closing then begin
Namespace.Writing.pop namespaces;
open_elements :=
match !open_elements with
| [] -> []
| _::rest -> rest
end;
let end_ = if self_closing then "/>" else ">" in
let tag =
"<"::formatted_name::(attribute_strings end_ formatted_attributes)
in
emit_list tag throw e k))
| _, `End_element ->
Namespace.Writing.pop namespaces;
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
emit_list (List.map escape ss) throw e k
| _, `Xml {version; encoding; standalone} ->
let attributes =
match standalone with
| None -> []
| Some true -> ["standalone", "yes"]
| Some false -> ["standalone", "no"]
in
let attributes =
match encoding with
| None -> attributes
| Some encoding -> ("encoding", encoding)::attributes
in
let attributes = ("version", version)::attributes in
let declaration = "<?xml"::(attribute_strings "?>" attributes) in
emit_list declaration throw e k
| _, `Doctype {raw_text} ->
begin match raw_text with
| None -> next_signal throw e k
| Some text -> emit_list ["<!DOCTYPE "; text; ">"] throw e k
end
| _, `PI (target, s) ->
emit_list ["<?"; target; " "; s; "?>"] throw e k
| _, `Comment s ->
emit_list ["<!--"; s; "-->"] throw e k
end
in
(fun throw e k -> !queue throw e k) |> make