-
Notifications
You must be signed in to change notification settings - Fork 125
/
xml.ml
282 lines (252 loc) · 8.66 KB
/
xml.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
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
#<Debugvar:DEBUG_XML>
module List = BaseList
(* -- *)
let debug fmt =
#<If> Printf.eprintf ("[Xml]"^^fmt)
#<Else> Printf.ifprintf stdout fmt
#<End>
(* FIXME: unifier avec Qml *)
type value =
| Value of string
(* FIXME: remettre ??? | Func of string * value list *)
(* string * string list (* parameters *) *)
;;
type parameters = value StringMap.t (* name *) (* FIXME: stringmap (* ns *) *)
;;
type nid = int
;;
type node =
{ nns : string option
; nname : string
; npars : parameters
; ncontent : content list
; nparent : int
}
and content =
| Text of string
| Node of nid
;;
type xml =
{ header : (string * value) list (* parameters *)
; count : int
; main : int list
; nodes : node IntMap.t (* nidmap *) }
;;
let empty_xml =
{ header = []
; count = 0
; main = []
; nodes = IntMap.empty
}
;;
let add_node node elt = { node with ncontent = (elt :: node.ncontent) }
let new_node n o =
{ nns = None
; nname = n
; npars = StringMap.from_list o
; ncontent = []
; nparent = -1
}
let rewrite l =
let rec aux ok stack xml = function
| `one ((n, _) as t) :: tl -> aux ok stack xml (`start t :: `stop n :: tl)
| `start (n, o) :: tl ->
debug "start: %s" n;
let nid = xml.count
and node = new_node n o in
let stack, is_main = match stack with
| (snid, snode) :: stl ->
(nid, { node with nparent = snid }) ::
(snid, add_node snode (Node nid)) :: stl, false
| _ ->
[nid, node], true
in
let xml = if is_main then { xml with main = nid :: xml.main } else xml in
aux ok stack { xml with count = succ nid } tl
| `stop n :: tl ->
debug "stop: %s" n;
begin match stack with
| (nid, node) :: stl ->
if node.nname = n then
let node = { node with ncontent = List.rev node.ncontent } in
aux ok stl { xml with nodes = IntMap.add nid node xml.nodes } tl
else (
debug "error in rewrite: closing tag %s which is not last open tag" n;
aux false stack xml tl
)
| _ ->
debug "error in rewrite: closing tag %s which is not open" n;
aux false stack xml tl
end
| `text t :: tl ->
debug "text: %s" t;
begin match stack with
| (nid, node) :: stl ->
let node = add_node node (Text t) in
aux ok ((nid, node)::stl) xml tl
| _ ->
debug "error in rewrite: text '%s' outside of tag (skipped)" t;
aux false stack xml tl
end
| `space :: tl ->
let l = if stack=[] then tl else (`text " " :: tl) in
aux ok stack xml l
| _ ->
if stack=[] then { xml with main = List.rev xml.main }, ok
else
let id = fst (List.hd stack) in
let name = (snd (List.hd stack)).nname in
debug "error in rewrite: tag <%d:%s> is never closed" id name;
aux false stack xml [`stop name]
in
aux true [] empty_xml l
let print_options m =
StringMap.fold (
fun x (Value y) acc ->
acc ^ Printf.sprintf " %s=\"%s\"" x (String.escaped y)
) m ""
let print_header m =
List.fold_left (
fun acc (x, Value y) ->
acc ^ Printf.sprintf " %s=\"%s\"" x (String.escaped y)
) "" m
(** print options and apply a function to each element
-> utilisé par exemple pour remplacer
action: par javascript: dans les lients *)
let print_options_f f m =
StringMap.fold (
fun x (Value y) acc ->
acc ^ Printf.sprintf " %s=\"%s\"" x (String.escaped (f x y))
) m ""
let fold f1 f2 init xml =
let rec aux ~path acc nid =
let path = nid :: path in
let node = IntMap.find nid xml.nodes in
let acc = f1 acc node.nname node.npars in
List.fold_left (
fun acc x -> match x with
| Text t -> f2 acc path t
| Node n -> aux ~path acc n
) acc node.ncontent
in
List.fold_left (aux ~path:[]) init xml.main
(* List.map ( *)
(* fun x -> match x with *)
(* | Text t -> f node.nname node.npars t *)
(* | n -> n *)
(* ) node.ncontent *)
let change_content f node =
let rec aux acc_content acc_nodes = function
| (Text t) :: tl ->
let items, delete, insert = f node.nname node.npars t in
let acc_nodes = insert @ acc_nodes in
if delete then None, acc_nodes
else aux (items @ acc_content) acc_nodes (* FIXME: check rev *) tl
| n :: tl -> aux (n :: acc_content) acc_nodes tl
| _ -> Some (List.rev acc_content), acc_nodes
in aux [] [] node.ncontent
let delete_node ?(replace=[]) xml parent nid =
match parent with
| None -> { xml with main = List.remove_all nid xml.main }
| Some p ->
let parent_node = IntMap.find p xml.nodes in
let parent_content = List.replace (Node nid) (List.map (fun x -> Node x) replace) parent_node.ncontent in
{ xml with nodes = IntMap.add p { parent_node with ncontent = parent_content } xml.nodes }
let insert_node parent (xml, nid_list) (n, o, content) =
debug "insert_node" ;
let nid = xml.count
and node = new_node n o in
let node =
{ node with
nparent = (match parent with Some p -> p | _ -> -1)
; ncontent = content } in
{ xml with nodes = IntMap.add nid node xml.nodes ; count = succ xml.count },
nid :: nid_list
(** map sur le texte des noeuds Xml *)
(* FIXME: rename *)
let map f xml =
let rec aux parent xml nid =
let node = IntMap.find nid xml.nodes in
match change_content f node with
| Some ncontent, _insert ->
(* nouveau contenu de la node *)
let xml =
{ xml with nodes =
IntMap.add nid { node with ncontent = ncontent } xml.nodes }
(* liste des nid à modifier *)
and next = List.fold_left (
fun acc x -> match x with
| Node n -> n :: acc
| _ -> acc
) [] node.ncontent
in
List.fold_left (aux (Some nid)) xml next
| _, insert ->
let xml, nid_list = List.fold_left (insert_node parent) (xml, []) insert in
delete_node xml parent nid ~replace:nid_list
in
List.fold_left (aux None) xml xml.main
let print ?(header=false) ?(pretty=false) xml =
let nl = if pretty then "\n" else "" in
let rec aux b nid =
let node = IntMap.find nid xml.nodes in
let b = FBuffer.add b (Printf.sprintf "<%s%s>%s" node.nname (print_options node.npars) nl) in
let b = List.fold_left (
fun acc x -> match x with
| Text t -> FBuffer.add acc t
| Node n -> aux acc n
) b node.ncontent in
FBuffer.add b (Printf.sprintf "</%s>%s" node.nname nl)
in
let b = FBuffer.make ~name:"Xml.print" 256 in
let b =
if header then
FBuffer.add b (Printf.sprintf "<?xml%s ?>%s" (print_header xml.header) nl)
else b in
FBuffer.contents (List.fold_left aux b xml.main)
(** construit un stringmap: id -> nid pour un xml
retourne également un booléen FAUX si les ids sont correctes, VRAI si une id est redéfinie
*)
let build_ids ?(tag="id") xml =
IntMap.fold (
fun id node (acc, err) ->
if StringMap.mem tag node.npars then
let (Value value) = StringMap.find tag node.npars in
let mem = StringMap.mem value acc in
#<If> if mem then
debug "Warning: id %s is defined several times" value #<End>;
StringMap.add value id acc, mem or err
else (acc, err)
) xml.nodes (StringMap.empty, false)
(** construit un stringmap: class -> nid list (classée par position décroissante) pour un xml *)
let build_classes ?(tag="class") xml =
IntMap.fold (
fun id node acc ->
if StringMap.mem tag node.npars then
let (Value value) = StringMap.find tag node.npars in
let list = if StringMap.mem value acc then StringMap.find value acc else [] in
StringMap.add value (id::list) acc
else acc
) xml.nodes StringMap.empty
(** liste (id, tag)* des parents du noeud nid *)
let tag_path xml nid =
let rec aux path id =
if id = 0 then path
else
let node = IntMap.find id xml.nodes in
aux ((node.nparent, node.nname)::path) node.nparent
in
aux [] nid