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
let clean_string str = String.trim str
let make_key (ns, key) =
let ns = Option.fold ~none:"" ~some:(fun x -> x ^ ":") ns in
clean_string ns ^ clean_string key
let escape =
String.fold_left
(fun res -> function
| '<' -> res ^ "<"
| '>' -> res ^ ">"
| '&' -> res ^ "&"
| '\'' -> res ^ "'"
| '"' -> res ^ """
| c -> res ^ String.make 1 c)
""
module Attr = struct
type key = string option * string
type t = key * string
module M = Stdlib.Map.Make (struct
type t = key
let compare k1 k2 =
let k1 = make_key k1 and k2 = make_key k2 in
Stdlib.String.compare k1 k2
end)
type set = string M.t
let make f ?ns ~key value = ((ns, key), f value)
let string = make (fun x -> x)
let int = make string_of_int
let float = make string_of_float
let bool = make string_of_bool
let char = make (String.make 1)
let escaped = make escape
let from_list = M.of_list
let to_string (key, value) = make_key key ^ "=" ^ Format.asprintf "%S" value
let set_to_string set =
set |> M.to_list |> List.map to_string |> String.concat " "
end
type node =
| Node of bool * (string option * string) * Attr.set * node list
| Leaf of bool * (string option * string) * Attr.set * string option
| Maybe of node option
type t = { version : string; encoding : string; standalone : bool; root : node }
let document ?(version = "1.0") ?(encoding = "utf-8") ?(standalone = false) root
=
{ version; encoding; standalone; root }
let opt n = Maybe n
let node ?ns ~name ?(attr = []) body =
Node
( true
, (ns, name)
, Attr.from_list attr
, List.filter_map (function Maybe x -> x | x -> Some x) body )
let leaf ?(indent = true) ?ns ~name ?(attr = []) body =
Leaf (indent, (ns, name), Attr.from_list attr, body)
let may f x = opt (Option.map f x)
let may_leaf ?indent ?(finalize = fun x -> Some x) ~name f v =
opt @@ Option.map (fun x -> leaf ?indent ~name (finalize (f x))) v
let rec namespace ~ns = function
| Leaf (i, (_, name), attr, value) -> Leaf (i, (Some ns, name), attr, value)
| Maybe on -> Maybe (Option.map (namespace ~ns) on)
| Node (i, (_, name), attr, value) ->
Node (i, (Some ns, name), attr, List.map (namespace ~ns) value)
let cdata str = Some ("<![CDATA[" ^ str ^ "]]>")
let escape str = Some (escape str)
let { version; encoding; standalone; _ } =
let attributes =
let base =
Attr.[ string ~key:"version" version; string ~key:"encoding" encoding ]
in
if standalone then Attr.string ~key:"standalone" "yes" :: base else base
in
"<?xml " ^ (attributes |> List.map Attr.to_string |> String.concat " ") ^ "?>"
let close_tag = "/>"
let close_name name = "</" ^ name ^ ">"
let make_indent need i = if need then String.make (i * 2) ' ' else ""
let node_to_string node =
let rec aux t = function
| Maybe (Some node) -> aux t node
| Maybe None -> ""
| (Node (_, key, attr, _) | Leaf (_, key, attr, _)) as node ->
let indent = make_indent true t in
let name = make_key key in
let attr = Attr.set_to_string attr in
let attr = if String.(equal empty attr) then "" else " " ^ attr in
let opening = indent ^ "<" ^ name ^ attr in
let closing = closing t indent name node in
opening ^ closing
and closing t indent name = function
| Maybe _ -> assert false
| Leaf (_, _, _, None) | Node (_, _, _, []) -> close_tag
| Leaf (i, _, _, Some str) ->
if String.length str > 80 && i then
let indent_ctn = make_indent i (succ t) in
let cl = if i then "\n" else "" in
">" ^ cl ^ indent_ctn ^ str ^ cl ^ indent ^ close_name name
else ">" ^ str ^ close_name name
| Node (i, _, _, li) ->
let cl = if i then "\n" else "" in
">"
^ cl
^ (List.filter_map
(function Maybe None -> None | x -> Some (aux (succ t) x))
li
|> String.concat cl)
^ cl
^ indent
^ close_name name
in
aux 0 node
let to_string ({ root; _ } as doc) =
let = header_to_string doc in
header ^ "\n" ^ node_to_string root