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
|
(* TyXML
* http://www.ocsigen.org/tyxml
* Copyright (C) 2004 Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
* Copyright (C) 2011 Pierre Chambart, Grégoire Henry
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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 Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Suite 500, Boston, MA 02110-1301, USA.
*)
module Make(Xml : Xml_sigs.Iterable) = struct
open Xml
(** Iterators *)
let amap1 f n =
match content n with
| Empty | Comment _ | PCDATA _ | EncodedPCDATA _ | Entity _ -> n
| Leaf (name, attribs) -> leaf ~a:(f name attribs) name
| Node (name, attribs, elts) -> node ~a:(f name attribs) name elts
let rec amap f n =
match content n with
| Empty | Comment _ | PCDATA _ | EncodedPCDATA _ | Entity _ -> n
| Leaf (name, attribs) -> leaf ~a:(f name attribs) name
| Node (name, attribs, elts) ->
node ~a:(f name attribs) name (List.map (amap f) elts)
let rec add_float_attrib name value = function
| [] -> [float_attrib name value]
| head :: tail when aname head = name ->
float_attrib name value :: tail
| head :: tail -> head :: add_float_attrib name value tail
let map_float_attrib is_attrib f l =
let aux head = match acontent head with
| AFloat value when is_attrib (aname head) -> float_attrib (aname head) (f value)
| _ -> head in
List.map aux l
let rec add_int_attrib name value = function
| [] -> [int_attrib name value]
| head :: tail when aname head = name ->
int_attrib name value :: tail
| head :: tail -> head :: add_int_attrib name value tail
let rec rm_attrib is_attrib = function
| [] -> []
| head :: tail when is_attrib (aname head) -> rm_attrib is_attrib tail
| head :: tail -> head :: rm_attrib is_attrib tail
let map_int_attrib is_attrib f l =
let aux head = match acontent head with
| AInt value when is_attrib (aname head) -> int_attrib (aname head) (f value)
| _ -> head in
List.map aux l
let rec add_string_attrib name value = function
| [] -> [string_attrib name value]
| head :: tail when aname head = name ->
string_attrib name value :: tail
| head :: tail -> head :: add_string_attrib name value tail
let map_string_attrib is_attrib f l =
let aux head = match acontent head with
| AStr value when is_attrib (aname head) -> string_attrib (aname head) (f value)
| _ -> head in
List.map aux l
let rec add_space_sep_attrib name value = function
| [] -> [space_sep_attrib name [value]]
| head :: tail ->
match acontent head with
| AStrL (Space, values') when aname head = name ->
space_sep_attrib name (value :: values') :: tail
| _ when aname head = name ->
space_sep_attrib name [value] :: tail
| _ -> head :: add_space_sep_attrib name value tail
let rec add_comma_sep_attrib name value = function
| [] -> [comma_sep_attrib name [value]]
| head :: tail ->
match acontent head with
| AStrL (Comma, values') when aname head = name ->
comma_sep_attrib name (value :: values') :: tail
| _ when aname head = name ->
comma_sep_attrib name [value] :: tail
| _ -> head :: add_comma_sep_attrib name value tail
let rec rm_attrib_from_list is_attrib is_value = function
| [] -> []
| head :: tail ->
match acontent head with
| AStrL (sep, values) when is_attrib (aname head) ->
begin match List.filter (fun v -> not (is_value v)) values with
| [] -> tail
| values' ->
match sep with
| Space -> space_sep_attrib (aname head) values' :: tail
| Comma -> comma_sep_attrib (aname head) values' :: tail
end
| _ -> head :: rm_attrib_from_list is_attrib is_value tail
let map_string_attrib_in_list is_attrib f l =
let aux head = match acontent head with
| AStrL (sep, values) when is_attrib (aname head) ->
begin match sep with
| Comma -> comma_sep_attrib (aname head) (List.map f values)
| Space -> space_sep_attrib (aname head) (List.map f values)
end
| _ -> head in
List.map aux l
let rec fold of_empty of_comment of_txt of_encodedpcdata of_entity
of_leaf of_node n =
match content n with
| Empty -> of_empty ()
| Comment s -> of_comment s
| PCDATA s -> of_txt s
| EncodedPCDATA s -> of_encodedpcdata s
| Entity s -> of_entity s
| Leaf (name, attribs) -> of_leaf name attribs
| Node (name, attribs, elts) ->
of_node name attribs
(List.map (fold of_empty of_comment of_txt of_encodedpcdata of_entity of_leaf of_node) elts)
let all_entities elt =
let f _ = [] in
fold f f f f f
(fun _ename _attribs -> []) (fun _ename _attribs elts -> List.flatten elts)
elt
let flatmap f l = List.concat (List.map f l)
let translate root_leaf root_node sub_leaf sub_node update_state state n =
let rec translate' state n =
match content n with
| (Empty | Comment _ | PCDATA _ | EncodedPCDATA _ | Entity _) -> [n]
| Leaf (name, attribs) ->
sub_leaf state name attribs
| Node (name, attribs, elts) ->
sub_node state name attribs
(flatmap (translate' (update_state name attribs state)) elts)
in
match content n with
| (Empty | Comment _ | PCDATA _ | EncodedPCDATA _ | Entity _) -> n
| Leaf (name, attribs) ->
root_leaf name attribs
| Node (name, attribs, elts) ->
root_node name attribs (flatmap (translate' state) elts)
end
|
