···
1
-
(** GPX XML writer using xmlm *)
1
+
(** GPX XML writer with complete spec coverage *)
(** Result binding operators *)
···
| Some text -> output_text_element writer name text
38
+
let output_optional_float_element writer name = function
39
+
| Some value -> output_text_element writer name (Printf.sprintf "%.6f" value)
42
+
let output_optional_degrees_element writer name = function
43
+
| Some degrees -> output_text_element writer name (Printf.sprintf "%.6f" (Coordinate.degrees_to_float degrees))
46
+
let output_optional_int_element writer name = function
47
+
| Some value -> output_text_element writer name (string_of_int value)
50
+
let output_optional_time_element writer name = function
51
+
| Some time -> output_text_element writer name (Ptime.to_rfc3339 time)
54
+
let output_optional_fix_element writer name = function
55
+
| Some fix_type -> output_text_element writer name (Waypoint.fix_type_to_string fix_type)
58
+
(** Write link elements *)
59
+
let output_link writer link =
60
+
let href = Link.href link in
61
+
let attrs = [(("", "href"), href)] in
62
+
let* () = output_element_start writer "link" attrs in
63
+
let* () = output_optional_text_element writer "text" (Link.text link) in
64
+
let* () = output_optional_text_element writer "type" (Link.type_ link) in
65
+
output_element_end writer
67
+
let output_links writer links =
68
+
let rec write_links = function
71
+
let* () = output_link writer link in
76
+
(** Write person (author) element *)
77
+
let output_person writer person =
78
+
let* () = output_element_start writer "author" [] in
79
+
let* () = output_optional_text_element writer "name" (Link.person_name person) in
80
+
let* () = match Link.person_email person with
82
+
(* Parse email into id and domain *)
83
+
(match String.index_opt email '@' with
85
+
let id = String.sub email 0 at_pos in
86
+
let domain = String.sub email (at_pos + 1) (String.length email - at_pos - 1) in
87
+
let attrs = [(("", "id"), id); (("", "domain"), domain)] in
88
+
let* () = output_element_start writer "email" attrs in
89
+
output_element_end writer
91
+
(* Invalid email format, skip *)
95
+
let* () = match Link.person_link person with
96
+
| Some link -> output_link writer link
99
+
output_element_end writer
101
+
(** Write copyright element *)
102
+
let output_copyright writer copyright =
103
+
let author = Link.copyright_author copyright in
104
+
let attrs = [(("", "author"), author)] in
105
+
let* () = output_element_start writer "copyright" attrs in
106
+
let* () = output_optional_int_element writer "year" (Link.copyright_year copyright) in
107
+
let* () = output_optional_text_element writer "license" (Link.copyright_license copyright) in
108
+
output_element_end writer
110
+
(** Write bounds element *)
111
+
let output_bounds writer bounds =
112
+
let (minlat, minlon, maxlat, maxlon) = Metadata.Bounds.bounds bounds in
114
+
(("", "minlat"), Printf.sprintf "%.6f" (Coordinate.latitude_to_float minlat));
115
+
(("", "minlon"), Printf.sprintf "%.6f" (Coordinate.longitude_to_float minlon));
116
+
(("", "maxlat"), Printf.sprintf "%.6f" (Coordinate.latitude_to_float maxlat));
117
+
(("", "maxlon"), Printf.sprintf "%.6f" (Coordinate.longitude_to_float maxlon));
119
+
let* () = output_element_start writer "bounds" attrs in
120
+
output_element_end writer
122
+
(** Write extensions element *)
123
+
let output_extensions writer extensions =
124
+
if extensions = [] then Ok ()
126
+
let* () = output_element_start writer "extensions" [] in
127
+
(* For now, skip writing extension content - would need full extension serialization *)
128
+
output_element_end writer
130
+
(** Write metadata element *)
131
+
let output_metadata writer metadata =
132
+
let* () = output_element_start writer "metadata" [] in
133
+
let* () = output_optional_text_element writer "name" (Metadata.name metadata) in
134
+
let* () = output_optional_text_element writer "desc" (Metadata.description metadata) in
135
+
let* () = match Metadata.author metadata with
136
+
| Some author -> output_person writer author
139
+
let* () = match Metadata.copyright metadata with
140
+
| Some copyright -> output_copyright writer copyright
143
+
let* () = output_links writer (Metadata.links metadata) in
144
+
let* () = output_optional_time_element writer "time" (Metadata.time metadata) in
145
+
let* () = output_optional_text_element writer "keywords" (Metadata.keywords metadata) in
146
+
let* () = match Metadata.bounds_opt metadata with
147
+
| Some bounds -> output_bounds writer bounds
150
+
let* () = output_extensions writer (Metadata.extensions metadata) in
151
+
output_element_end writer
153
+
(** Write waypoint elements (used for wpt, rtept, trkpt) *)
154
+
let output_waypoint_data writer waypoint =
155
+
let* () = output_optional_float_element writer "ele" (Waypoint.elevation waypoint) in
156
+
let* () = output_optional_time_element writer "time" (Waypoint.time waypoint) in
157
+
let* () = output_optional_degrees_element writer "magvar" (Waypoint.magvar waypoint) in
158
+
let* () = output_optional_float_element writer "geoidheight" (Waypoint.geoidheight waypoint) in
159
+
let* () = output_optional_text_element writer "name" (Waypoint.name waypoint) in
160
+
let* () = output_optional_text_element writer "cmt" (Waypoint.comment waypoint) in
161
+
let* () = output_optional_text_element writer "desc" (Waypoint.description waypoint) in
162
+
let* () = output_optional_text_element writer "src" (Waypoint.source waypoint) in
163
+
let* () = output_links writer (Waypoint.links waypoint) in
164
+
let* () = output_optional_text_element writer "sym" (Waypoint.symbol waypoint) in
165
+
let* () = output_optional_text_element writer "type" (Waypoint.type_ waypoint) in
166
+
let* () = output_optional_fix_element writer "fix" (Waypoint.fix waypoint) in
167
+
let* () = output_optional_int_element writer "sat" (Waypoint.sat waypoint) in
168
+
let* () = output_optional_float_element writer "hdop" (Waypoint.hdop waypoint) in
169
+
let* () = output_optional_float_element writer "vdop" (Waypoint.vdop waypoint) in
170
+
let* () = output_optional_float_element writer "pdop" (Waypoint.pdop waypoint) in
171
+
let* () = output_optional_float_element writer "ageofdgpsdata" (Waypoint.ageofdgpsdata waypoint) in
172
+
let* () = output_optional_int_element writer "dgpsid" (Waypoint.dgpsid waypoint) in
173
+
output_extensions writer (Waypoint.extensions waypoint)
175
+
(** Write waypoints *)
176
+
let output_waypoints writer waypoints =
177
+
let rec write_waypoints = function
180
+
let lat = Coordinate.latitude_to_float (Waypoint.lat wpt) in
181
+
let lon = Coordinate.longitude_to_float (Waypoint.lon wpt) in
183
+
(("", "lat"), Printf.sprintf "%.6f" lat);
184
+
(("", "lon"), Printf.sprintf "%.6f" lon);
186
+
let* () = output_element_start writer "wpt" attrs in
187
+
let* () = output_waypoint_data writer wpt in
188
+
let* () = output_element_end writer in
189
+
write_waypoints rest
191
+
write_waypoints waypoints
193
+
(** Write route points *)
194
+
let output_route_points writer points element_name =
195
+
let rec write_points = function
198
+
let lat = Coordinate.latitude_to_float (Waypoint.lat pt) in
199
+
let lon = Coordinate.longitude_to_float (Waypoint.lon pt) in
201
+
(("", "lat"), Printf.sprintf "%.6f" lat);
202
+
(("", "lon"), Printf.sprintf "%.6f" lon);
204
+
let* () = output_element_start writer element_name attrs in
205
+
let* () = output_waypoint_data writer pt in
206
+
let* () = output_element_end writer in
209
+
write_points points
211
+
(** Write routes *)
212
+
let output_routes writer routes =
213
+
let rec write_routes = function
216
+
let* () = output_element_start writer "rte" [] in
217
+
let* () = output_optional_text_element writer "name" (Route.name route) in
218
+
let* () = output_optional_text_element writer "cmt" (Route.comment route) in
219
+
let* () = output_optional_text_element writer "desc" (Route.description route) in
220
+
let* () = output_optional_text_element writer "src" (Route.source route) in
221
+
let* () = output_links writer (Route.links route) in
222
+
let* () = output_optional_int_element writer "number" (Route.number route) in
223
+
let* () = output_optional_text_element writer "type" (Route.type_ route) in
224
+
let* () = output_extensions writer (Route.extensions route) in
225
+
let* () = output_route_points writer (Route.points route) "rtept" in
226
+
let* () = output_element_end writer in
229
+
write_routes routes
231
+
(** Write track segments *)
232
+
let output_track_segments writer segments =
233
+
let rec write_segments = function
236
+
let* () = output_element_start writer "trkseg" [] in
237
+
let* () = output_route_points writer (Track.Segment.points seg) "trkpt" in
238
+
let* () = output_extensions writer (Track.Segment.extensions seg) in
239
+
let* () = output_element_end writer in
240
+
write_segments rest
242
+
write_segments segments
244
+
(** Write tracks *)
245
+
let output_tracks writer tracks =
246
+
let rec write_tracks = function
249
+
let* () = output_element_start writer "trk" [] in
250
+
let* () = output_optional_text_element writer "name" (Track.name track) in
251
+
let* () = output_optional_text_element writer "cmt" (Track.comment track) in
252
+
let* () = output_optional_text_element writer "desc" (Track.description track) in
253
+
let* () = output_optional_text_element writer "src" (Track.source track) in
254
+
let* () = output_links writer (Track.links track) in
255
+
let* () = output_optional_int_element writer "number" (Track.number track) in
256
+
let* () = output_optional_text_element writer "type" (Track.type_ track) in
257
+
let* () = output_extensions writer (Track.extensions track) in
258
+
let* () = output_track_segments writer (Track.segments track) in
259
+
let* () = output_element_end writer in
262
+
write_tracks tracks
(** Write a complete GPX document *)
let write ?(validate=false) output gpx =
let writer = Xmlm.make_output output in
···
(* Write metadata if present *)
let* () = match Doc.metadata gpx with
60
-
let* () = output_element_start writer "metadata" [] in
61
-
(* Write basic metadata fields *)
62
-
let* () = output_optional_text_element writer "name" (Metadata.name metadata) in
63
-
let* () = output_optional_text_element writer "desc" (Metadata.description metadata) in
64
-
let* () = output_optional_text_element writer "keywords" (Metadata.keywords metadata) in
65
-
output_element_end writer
285
+
| Some metadata -> output_metadata writer metadata
70
-
let waypoints = Doc.waypoints gpx in
71
-
let rec write_waypoints = function
74
-
let lat = Coordinate.latitude_to_float (Waypoint.lat wpt) in
75
-
let lon = Coordinate.longitude_to_float (Waypoint.lon wpt) in
77
-
(("", "lat"), Printf.sprintf "%.6f" lat);
78
-
(("", "lon"), Printf.sprintf "%.6f" lon);
80
-
let* () = output_element_start writer "wpt" attrs in
81
-
let* () = output_optional_text_element writer "name" (Waypoint.name wpt) in
82
-
let* () = output_optional_text_element writer "desc" (Waypoint.description wpt) in
83
-
let* () = output_element_end writer in
84
-
write_waypoints rest
86
-
let* () = write_waypoints waypoints in
290
+
let* () = output_waypoints writer (Doc.waypoints gpx) in
293
+
let* () = output_routes writer (Doc.routes gpx) in
296
+
let* () = output_tracks writer (Doc.tracks gpx) in
298
+
(* Write root-level extensions *)
299
+
let* () = output_extensions writer (Doc.extensions gpx) in
output_element_end writer
patrick.sirref.org
anil.recoil.org