GPS Exchange Format library/CLI in OCaml
anil.recoil.org
1(** Extension mechanism for custom GPX elements *)
2
3(** Main extension type *)
4type t = {
5 namespace : string option;
6 name : string;
7 attributes : (string * string) list;
8 content : content;
9}
10
11(** Content types for extensions *)
12and content =
13 | Text of string
14 | Elements of t list
15 | Mixed of string * t list
16
17(** {2 Extension Operations} *)
18
19(** Create extension with flexible content *)
20let make ?namespace ~name ~attributes ~content () =
21 { namespace; name; attributes; content }
22
23(** Create an extension with text content *)
24let make_text ~name ?namespace ?(attributes=[]) text =
25 { namespace; name; attributes; content = Text text }
26
27(** Create an extension with element content *)
28let make_elements ~name ?namespace ?(attributes=[]) elements =
29 { namespace; name; attributes; content = Elements elements }
30
31(** Create an extension with mixed content *)
32let make_mixed ~name ?namespace ?(attributes=[]) text elements =
33 { namespace; name; attributes; content = Mixed (text, elements) }
34
35(** Get extension name *)
36let name t = t.name
37
38(** Get optional namespace *)
39let namespace t = t.namespace
40
41(** Get attributes *)
42let attributes t = t.attributes
43
44(** Get content *)
45let content t = t.content
46
47(** Create text content *)
48let text_content text = Text text
49
50(** Create elements content *)
51let elements_content elements = Elements elements
52
53(** Create mixed content *)
54let mixed_content text elements = Mixed (text, elements)
55
56(** Find attribute value by name *)
57let find_attribute name t =
58 List.assoc_opt name t.attributes
59
60(** Add or update attribute *)
61let set_attribute name value t =
62 let attributes =
63 (name, value) :: List.remove_assoc name t.attributes
64 in
65 { t with attributes }
66
67(** Compare extensions *)
68let rec compare t1 t2 =
69 let ns_cmp = Option.compare String.compare t1.namespace t2.namespace in
70 if ns_cmp <> 0 then ns_cmp
71 else
72 let name_cmp = String.compare t1.name t2.name in
73 if name_cmp <> 0 then name_cmp
74 else
75 let attr_cmp = compare_attributes t1.attributes t2.attributes in
76 if attr_cmp <> 0 then attr_cmp
77 else compare_content t1.content t2.content
78
79and compare_attributes attrs1 attrs2 =
80 let sorted1 = List.sort (fun (k1,_) (k2,_) -> String.compare k1 k2) attrs1 in
81 let sorted2 = List.sort (fun (k1,_) (k2,_) -> String.compare k1 k2) attrs2 in
82 List.compare (fun (k1,v1) (k2,v2) ->
83 let k_cmp = String.compare k1 k2 in
84 if k_cmp <> 0 then k_cmp else String.compare v1 v2
85 ) sorted1 sorted2
86
87and compare_content c1 c2 = match c1, c2 with
88 | Text s1, Text s2 -> String.compare s1 s2
89 | Elements e1, Elements e2 -> List.compare compare e1 e2
90 | Mixed (s1, e1), Mixed (s2, e2) ->
91 let s_cmp = String.compare s1 s2 in
92 if s_cmp <> 0 then s_cmp else List.compare compare e1 e2
93 | Text _, _ -> -1
94 | Elements _, Text _ -> 1
95 | Elements _, Mixed _ -> -1
96 | Mixed _, _ -> 1
97
98(** Test extension equality *)
99let equal t1 t2 = compare t1 t2 = 0
100
101(** Pretty print extension *)
102let rec pp ppf t =
103 match t.namespace with
104 | Some ns -> Format.fprintf ppf "<%s:%s" ns t.name
105 | None -> Format.fprintf ppf "<%s" t.name;
106 List.iter (fun (k, v) -> Format.fprintf ppf " %s=\"%s\"" k v) t.attributes;
107 match t.content with
108 | Text "" -> Format.fprintf ppf "/>"
109 | Text text -> Format.fprintf ppf ">%s</%s>" text (qualified_name t)
110 | Elements [] -> Format.fprintf ppf "/>"
111 | Elements elements ->
112 Format.fprintf ppf ">";
113 List.iter (Format.fprintf ppf "%a" pp) elements;
114 Format.fprintf ppf "</%s>" (qualified_name t)
115 | Mixed (text, []) -> Format.fprintf ppf ">%s</%s>" text (qualified_name t)
116 | Mixed (text, elements) ->
117 Format.fprintf ppf ">%s" text;
118 List.iter (Format.fprintf ppf "%a" pp) elements;
119 Format.fprintf ppf "</%s>" (qualified_name t)
120
121and qualified_name t =
122 match t.namespace with
123 | Some ns -> ns ^ ":" ^ t.name
124 | None -> t.name
125
126(** {2 Content Operations} *)
127
128(** Check if content is text *)
129let is_text_content = function Text _ -> true | _ -> false
130
131(** Check if content is elements *)
132let is_elements_content = function Elements _ -> true | _ -> false
133
134(** Check if content is mixed *)
135let is_mixed_content = function Mixed _ -> true | _ -> false
136
137(** Extract text content *)
138let text_content_extract = function Text s -> Some s | _ -> None
139
140(** Extract element content *)
141let elements_content_extract = function Elements e -> Some e | _ -> None
142
143(** Extract mixed content *)
144let mixed_content_extract = function Mixed (s, e) -> Some (s, e) | _ -> None