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
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
(* 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 list_map_cps : ('a -> 'b cps) -> 'a list -> 'b list cps =
fun f l throw k ->
let rec loop accumulator = function
| [] -> k (List.rev accumulator)
| x::l -> f x throw (fun x' -> loop (x'::accumulator) l)
in
loop [] l
module Parsing =
struct
type context_entry =
{f : string -> string option;
previous : context_entry}
type context = context_entry ref
let parse qualified_name =
try
let colon_index = String.index qualified_name ':' in
if colon_index = 0 then
raise Not_found;
let prefix = String.sub qualified_name 0 colon_index in
let suffix =
String.sub qualified_name
(colon_index + 1)
(String.length qualified_name - colon_index - 1)
in
prefix, suffix
with Not_found -> ("", qualified_name)
let init top_level =
let f = function
| "xml" -> Some xml_ns
| "xmlns" -> Some xmlns_ns
| s -> top_level s
in
let rec entry = {f; previous = entry} in
ref entry
let expand_element report context raw_element_name throw k =
let ns, name = parse raw_element_name in
match !context.f ns with
| Some uri -> k (uri, name)
| None ->
match ns with
| "" -> k ("", name)
| prefix ->
report () (`Bad_namespace prefix) throw (fun () -> k (prefix, name))
let push report context raw_element_name raw_attributes throw k =
let parsed_attributes =
raw_attributes |> List.map (fun (name, value) -> parse name, value) in
let f =
parsed_attributes |> List.fold_left (fun f -> function
| ("xmlns", prefix), uri ->
(fun p -> if p = prefix then Some uri else f p)
| ("", "xmlns"), uri ->
(fun p -> if p = "" then Some uri else f p)
| _ -> f)
!context.f
in
let entry = {f; previous = !context} in
context := entry;
expand_element report context raw_element_name throw
(fun expanded_element_name ->
list_map_cps begin fun (name, value) _ k ->
match name with
| "", "xmlns" -> k ((xmlns_ns, "xmlns"), value)
| "", name -> k (("", name), value)
| ns, name ->
match f ns with
| Some uri -> k ((uri, name), value)
| None ->
report () (`Bad_namespace ns) throw (fun () -> k ((ns, name), value))
end parsed_attributes throw (fun expanded_attributes ->
k (expanded_element_name, expanded_attributes)))
let pop ({contents = {previous}} as context) =
context := previous
end
module StringMap = Map.Make (String)
module Writing =
struct
type context_entry =
{namespace_to_prefix : string list StringMap.t;
prefix_to_namespace : string StringMap.t;
previous : context_entry}
type context = context_entry ref * (string -> string option)
let init top_level =
let namespace_to_prefix =
StringMap.empty
|> StringMap.add "" [""]
|> StringMap.add xml_ns ["xml"]
|> StringMap.add xmlns_ns ["xmlns"]
in
let prefix_to_namespace =
StringMap.empty
|> StringMap.add "" ""
|> StringMap.add "xml" xml_ns
|> StringMap.add "xmlns" xmlns_ns
in
let rec entry =
{namespace_to_prefix; prefix_to_namespace; previous = entry} in
ref entry, top_level
let lookup report allow_default context namespace throw k =
let candidate_prefixes =
try StringMap.find namespace !(fst context).namespace_to_prefix
with Not_found -> []
in
let prefix =
try
Some (candidate_prefixes |> List.find (fun prefix ->
(allow_default || prefix <> "") &&
begin
try StringMap.find prefix !(fst context).prefix_to_namespace =
namespace
with Not_found -> false
end))
with Not_found -> None
in
let prefix =
match prefix with
| Some _ -> prefix
| None ->
match snd context namespace with
| None -> None
| Some prefix ->
if not allow_default && prefix = "" ||
StringMap.mem prefix !(fst context).prefix_to_namespace then
None
else Some prefix
in
match prefix with
| None -> report () (`Bad_namespace namespace) throw (fun () -> k "")
| Some prefix -> k prefix
let format prefix name =
match prefix with
| "" -> name
| prefix -> prefix ^ ":" ^ name
let unexpand_element report context (namespace, name) throw k =
lookup report true context namespace throw (fun prefix ->
k (format prefix name))
let unexpand_attribute report context ((namespace, name), value) throw k =
match namespace with
| "" -> k (name, value)
| uri ->
if uri = xmlns_ns && name = "xmlns" then k ("xmlns", value)
else
lookup report false context namespace throw (fun prefix ->
k (format prefix name, value))
let extend k v map =
let vs =
try StringMap.find k map
with Not_found -> []
in
StringMap.add k (v::vs) map
let push report context element_name attributes throw k =
let namespace_to_prefix, prefix_to_namespace =
attributes |> List.fold_left (fun (ns_to_prefix, prefix_to_ns) -> function
| (ns, "xmlns"), uri when ns = xmlns_ns ->
extend uri "" ns_to_prefix,
StringMap.add "" uri prefix_to_ns
| (ns, prefix), uri when ns = xmlns_ns ->
extend uri prefix ns_to_prefix,
StringMap.add prefix uri prefix_to_ns
| _ -> ns_to_prefix, prefix_to_ns)
(!(fst context).namespace_to_prefix, !(fst context).prefix_to_namespace)
in
let entry =
{namespace_to_prefix; prefix_to_namespace; previous = !(fst context)} in
(fst context) := entry;
unexpand_element report context element_name throw (fun element_name ->
list_map_cps (unexpand_attribute report context) attributes throw
(fun attributes ->
k (element_name, attributes)))
let pop ({contents = {previous}}, _ as context) =
(fst context) := previous
end