Source file extension.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
(** Extension mechanism for custom GPX elements *)
(** Main extension type *)
type t = {
namespace : string option;
name : string;
attributes : (string * string) list;
content : content;
}
(** Content types for extensions *)
and content =
| Text of string
| Elements of t list
| Mixed of string * t list
(** {2 Extension Operations} *)
(** Create extension with flexible content *)
let make ?namespace ~name ~attributes ~content () =
{ namespace; name; attributes; content }
(** Create an extension with text content *)
let make_text ~name ?namespace ?(attributes=[]) text =
{ namespace; name; attributes; content = Text text }
(** Create an extension with element content *)
let make_elements ~name ?namespace ?(attributes=[]) elements =
{ namespace; name; attributes; content = Elements elements }
(** Create an extension with mixed content *)
let make_mixed ~name ?namespace ?(attributes=[]) text elements =
{ namespace; name; attributes; content = Mixed (text, elements) }
(** Get extension name *)
let name t = t.name
(** Get optional namespace *)
let namespace t = t.namespace
(** Get attributes *)
let attributes t = t.attributes
(** Get content *)
let content t = t.content
(** Create text content *)
let text_content text = Text text
(** Create elements content *)
let elements_content elements = Elements elements
(** Create mixed content *)
let mixed_content text elements = Mixed (text, elements)
(** Find attribute value by name *)
let find_attribute name t =
List.assoc_opt name t.attributes
(** Add or update attribute *)
let set_attribute name value t =
let attributes =
(name, value) :: List.remove_assoc name t.attributes
in
{ t with attributes }
(** Compare extensions *)
let rec compare t1 t2 =
let ns_cmp = Option.compare String.compare t1.namespace t2.namespace in
if ns_cmp <> 0 then ns_cmp
else
let name_cmp = String.compare t1.name t2.name in
if name_cmp <> 0 then name_cmp
else
let attr_cmp = compare_attributes t1.attributes t2.attributes in
if attr_cmp <> 0 then attr_cmp
else compare_content t1.content t2.content
and compare_attributes attrs1 attrs2 =
let sorted1 = List.sort (fun (k1,_) (k2,_) -> String.compare k1 k2) attrs1 in
let sorted2 = List.sort (fun (k1,_) (k2,_) -> String.compare k1 k2) attrs2 in
List.compare (fun (k1,v1) (k2,v2) ->
let k_cmp = String.compare k1 k2 in
if k_cmp <> 0 then k_cmp else String.compare v1 v2
) sorted1 sorted2
and compare_content c1 c2 = match c1, c2 with
| Text s1, Text s2 -> String.compare s1 s2
| Elements e1, Elements e2 -> List.compare compare e1 e2
| Mixed (s1, e1), Mixed (s2, e2) ->
let s_cmp = String.compare s1 s2 in
if s_cmp <> 0 then s_cmp else List.compare compare e1 e2
| Text _, _ -> -1
| Elements _, Text _ -> 1
| Elements _, Mixed _ -> -1
| Mixed _, _ -> 1
(** Test extension equality *)
let equal t1 t2 = compare t1 t2 = 0
(** Pretty print extension *)
let rec pp ppf t =
match t.namespace with
| Some ns -> Format.fprintf ppf "<%s:%s" ns t.name
| None -> Format.fprintf ppf "<%s" t.name;
List.iter (fun (k, v) -> Format.fprintf ppf " %s=\"%s\"" k v) t.attributes;
match t.content with
| Text "" -> Format.fprintf ppf "/>"
| Text text -> Format.fprintf ppf ">%s</%s>" text (qualified_name t)
| Elements [] -> Format.fprintf ppf "/>"
| Elements elements ->
Format.fprintf ppf ">";
List.iter (Format.fprintf ppf "%a" pp) elements;
Format.fprintf ppf "</%s>" (qualified_name t)
| Mixed (text, []) -> Format.fprintf ppf ">%s</%s>" text (qualified_name t)
| Mixed (text, elements) ->
Format.fprintf ppf ">%s" text;
List.iter (Format.fprintf ppf "%a" pp) elements;
Format.fprintf ppf "</%s>" (qualified_name t)
and qualified_name t =
match t.namespace with
| Some ns -> ns ^ ":" ^ t.name
| None -> t.name
(** {2 Content Operations} *)
(** Check if content is text *)
let is_text_content = function Text _ -> true | _ -> false
(** Check if content is elements *)
let is_elements_content = function Elements _ -> true | _ -> false
(** Check if content is mixed *)
let is_mixed_content = function Mixed _ -> true | _ -> false
(** Extract text content *)
let = function Text s -> Some s | _ -> None
(** Extract element content *)
let = function Elements e -> Some e | _ -> None
(** Extract mixed content *)
let = function Mixed (s, e) -> Some (s, e) | _ -> None