Declarative JSON data manipulation for OCaml
1(*---------------------------------------------------------------------------
2 Copyright (c) 2024 The jsont programmers. All rights reserved.
3 SPDX-License-Identifier: ISC
4 ---------------------------------------------------------------------------*)
5
6(* GeoJSON codec https://datatracker.ietf.org/doc/html/rfc7946
7
8 Note: a few length constraints on arrays should be checked,
9 a combinators should be added for that.
10
11 In contrast to Topojson the structure is a bit more annoying to
12 model because there is subtyping on the "type" field: GeoJSON
13 objects can be Feature, FeatureCollection or any Geometry object
14 and Geometry objects are recursive on themselves (but not on
15 Feature or Feature collection) and FeatureCollection only have
16 Feature objects. We handle this by redoing the cases to handle only
17 the subsets. *)
18
19type float_array = float array
20
21let float_array_codec ~kind = Json.Codec.array ~kind Json.Codec.number
22
23type 'a garray = 'a array
24
25let garray = Json.Codec.array
26
27module Bbox = struct
28 type t = float_array
29
30 let codec = float_array_codec ~kind:"Bbox"
31end
32
33module Position = struct
34 type t = float_array
35
36 let codec = float_array_codec ~kind:"Position"
37end
38
39module Geojson_object = struct
40 type 'a t = { type' : 'a; bbox : Bbox.t option; unknown : Json.t }
41
42 let make type' bbox unknown = { type'; bbox; unknown }
43 let type' o = o.type'
44 let bbox o = o.bbox
45 let unknown o = o.unknown
46
47 let finish_codec map =
48 map
49 |> Json.Codec.Object.opt_member "bbox" Bbox.codec ~enc:bbox
50 |> Json.Codec.Object.keep_unknown Json.Codec.Value.members ~enc:unknown
51 |> Json.Codec.Object.seal
52
53 let geometry ~kind coordinates =
54 Json.Codec.Object.map ~kind make
55 |> Json.Codec.Object.member "coordinates" coordinates ~enc:type'
56 |> finish_codec
57end
58
59module Point = struct
60 type t = Position.t
61
62 let codec = Geojson_object.geometry ~kind:"Point" Position.codec
63end
64
65module Multi_point = struct
66 type t = Position.t garray
67
68 let codec = Geojson_object.geometry ~kind:"MultiPoint" (garray Position.codec)
69end
70
71module Line_string = struct
72 type t = Position.t garray
73
74 let codec = Geojson_object.geometry ~kind:"LineString" (garray Position.codec)
75end
76
77module Multi_line_string = struct
78 type t = Line_string.t garray
79
80 let codec =
81 Geojson_object.geometry ~kind:"LineString" (garray (garray Position.codec))
82end
83
84module Polygon = struct
85 type t = Line_string.t garray
86
87 let codec =
88 Geojson_object.geometry ~kind:"Polygon" (garray (garray Position.codec))
89end
90
91module Multi_polygon = struct
92 type t = Polygon.t garray
93
94 let codec =
95 Geojson_object.geometry ~kind:"MultiPolygon"
96 (garray (garray (garray Position.codec)))
97end
98
99module Geojson = struct
100 type 'a object' = 'a Geojson_object.t
101
102 type geometry =
103 [ `Point of Point.t object'
104 | `Multi_point of Multi_point.t object'
105 | `Line_string of Line_string.t object'
106 | `Multi_line_string of Multi_line_string.t object'
107 | `Polygon of Polygon.t object'
108 | `Multi_polygon of Multi_polygon.t object'
109 | `Geometry_collection of geometry_collection object' ]
110
111 and geometry_collection = geometry list
112
113 module Feature = struct
114 type id = [ `Number of float | `String of string ]
115
116 type t = {
117 id : id option;
118 geometry : geometry option;
119 properties : Json.t option;
120 }
121
122 let make id geometry properties = { id; geometry; properties }
123
124 let make_geojson_object id geometry properties =
125 Geojson_object.make (make id geometry properties)
126
127 let id f = f.id
128 let geometry f = f.geometry
129 let properties f = f.properties
130
131 type collection = t object' list
132 end
133
134 type t =
135 [ `Feature of Feature.t object'
136 | `Feature_collection of Feature.collection object'
137 | geometry ]
138
139 let point v = `Point v
140 let multi_point v = `Multi_point v
141 let line_string v = `Line_string v
142 let multi_line_string v = `Multi_line_string v
143 let polygon v = `Polygon v
144 let multi_polygon v = `Multi_polygon v
145 let geometry_collection vs = `Geometry_collection vs
146 let feature v = `Feature v
147 let feature_collection vs = `Feature_collection vs
148
149 let feature_id_codec =
150 let number =
151 let dec n = `Number n in
152 let enc = function `Number n -> n | _ -> assert false in
153 Json.Codec.map ~dec ~enc Json.Codec.number
154 in
155 let string =
156 let dec n = `String n in
157 let enc = function `String n -> n | _ -> assert false in
158 Json.Codec.map ~dec ~enc Json.Codec.string
159 in
160 let enc = function `Number _ -> number | `String _ -> string in
161 Json.Codec.any ~kind:"id" ~dec_number:number ~dec_string:string ~enc ()
162
163 (* The first two Json types below handle subtyping by redoing
164 cases for subsets of types. *)
165
166 let case_map obj dec =
167 Json.Codec.Object.Case.map (Json.Codec.kind obj) obj ~dec
168
169 let rec geometry_codec =
170 lazy begin
171 let case_point = case_map Point.codec point in
172 let case_multi_point = case_map Multi_point.codec multi_point in
173 let case_line_string = case_map Line_string.codec line_string in
174 let case_multi_line_string =
175 case_map Multi_line_string.codec multi_line_string
176 in
177 let case_polygon = case_map Polygon.codec polygon in
178 let case_multi_polygon = case_map Multi_polygon.codec multi_polygon in
179 let case_geometry_collection =
180 case_map (Lazy.force geometry_collection_codec) geometry_collection
181 in
182 let enc_case = function
183 | `Point v -> Json.Codec.Object.Case.value case_point v
184 | `Multi_point v -> Json.Codec.Object.Case.value case_multi_point v
185 | `Line_string v -> Json.Codec.Object.Case.value case_line_string v
186 | `Multi_line_string v ->
187 Json.Codec.Object.Case.value case_multi_line_string v
188 | `Polygon v -> Json.Codec.Object.Case.value case_polygon v
189 | `Multi_polygon v -> Json.Codec.Object.Case.value case_multi_polygon v
190 | `Geometry_collection v ->
191 Json.Codec.Object.Case.value case_geometry_collection v
192 in
193 let cases =
194 Json.Codec.Object.Case.
195 [
196 make case_point;
197 make case_multi_point;
198 make case_line_string;
199 make case_multi_line_string;
200 make case_polygon;
201 make case_multi_polygon;
202 make case_geometry_collection;
203 ]
204 in
205 Json.Codec.Object.map ~kind:"Geometry object" Fun.id
206 |> Json.Codec.Object.case_member "type" Json.Codec.string ~enc:Fun.id
207 ~enc_case cases ~tag_to_string:Fun.id ~tag_compare:String.compare
208 |> Json.Codec.Object.seal
209 end
210
211 and feature_codec : Feature.t object' Json.Codec.t Lazy.t =
212 lazy begin
213 let case_feature = case_map (Lazy.force case_feature_codec) Fun.id in
214 let enc_case v = Json.Codec.Object.Case.value case_feature v in
215 let cases = Json.Codec.Object.Case.[ make case_feature ] in
216 Json.Codec.Object.map ~kind:"Feature" Fun.id
217 |> Json.Codec.Object.case_member "type" Json.Codec.string ~enc:Fun.id
218 ~enc_case cases ~tag_to_string:Fun.id ~tag_compare:String.compare
219 |> Json.Codec.Object.seal
220 end
221
222 and case_feature_codec : Feature.t object' Json.Codec.t Lazy.t =
223 lazy begin
224 Json.Codec.Object.map ~kind:"Feature" Feature.make_geojson_object
225 |> Json.Codec.Object.opt_member "id" feature_id_codec ~enc:(fun o ->
226 Feature.id (Geojson_object.type' o))
227 |> Json.Codec.Object.member "geometry"
228 (Json.Codec.option (Json.Codec.fix geometry_codec))
229 ~enc:(fun o -> Feature.geometry (Geojson_object.type' o))
230 |> Json.Codec.Object.member "properties"
231 (Json.Codec.option Json.Codec.Value.object') ~enc:(fun o ->
232 Feature.properties (Geojson_object.type' o))
233 |> Geojson_object.finish_codec
234 end
235
236 and geometry_collection_codec =
237 lazy begin
238 Json.Codec.Object.map ~kind:"GeometryCollection" Geojson_object.make
239 |> Json.Codec.Object.member "geometries"
240 (Json.Codec.list (Json.Codec.fix geometry_codec))
241 ~enc:Geojson_object.type'
242 |> Geojson_object.finish_codec
243 end
244
245 and feature_collection_json =
246 lazy begin
247 Json.Codec.Object.map ~kind:"FeatureCollection" Geojson_object.make
248 |> Json.Codec.Object.member "features"
249 Json.Codec.(list (Json.Codec.fix feature_codec))
250 ~enc:Geojson_object.type'
251 |> Geojson_object.finish_codec
252 end
253
254 and codec : t Json.Codec.t Lazy.t =
255 lazy begin
256 let case_point = case_map Point.codec point in
257 let case_multi_point = case_map Multi_point.codec multi_point in
258 let case_line_string = case_map Line_string.codec line_string in
259 let case_multi_line_string =
260 case_map Multi_line_string.codec multi_line_string
261 in
262 let case_polygon = case_map Polygon.codec polygon in
263 let case_multi_polygon = case_map Multi_polygon.codec multi_polygon in
264 let case_geometry_collection =
265 case_map (Lazy.force geometry_collection_codec) geometry_collection
266 in
267 let case_feature = case_map (Lazy.force case_feature_codec) feature in
268 let case_feature_collection =
269 case_map (Lazy.force feature_collection_json) feature_collection
270 in
271 let enc_case = function
272 | `Point v -> Json.Codec.Object.Case.value case_point v
273 | `Multi_point v -> Json.Codec.Object.Case.value case_multi_point v
274 | `Line_string v -> Json.Codec.Object.Case.value case_line_string v
275 | `Multi_line_string v ->
276 Json.Codec.Object.Case.value case_multi_line_string v
277 | `Polygon v -> Json.Codec.Object.Case.value case_polygon v
278 | `Multi_polygon v -> Json.Codec.Object.Case.value case_multi_polygon v
279 | `Geometry_collection v ->
280 Json.Codec.Object.Case.value case_geometry_collection v
281 | `Feature v -> Json.Codec.Object.Case.value case_feature v
282 | `Feature_collection v ->
283 Json.Codec.Object.Case.value case_feature_collection v
284 in
285 let cases =
286 Json.Codec.Object.Case.
287 [
288 make case_point;
289 make case_multi_point;
290 make case_line_string;
291 make case_multi_line_string;
292 make case_polygon;
293 make case_multi_polygon;
294 make case_geometry_collection;
295 make case_feature;
296 make case_feature_collection;
297 ]
298 in
299 Json.Codec.Object.map ~kind:"GeoJSON" Fun.id
300 |> Json.Codec.Object.case_member "type" Json.Codec.string ~enc:Fun.id
301 ~enc_case cases ~tag_to_string:Fun.id ~tag_compare:String.compare
302 |> Json.Codec.Object.seal
303 end
304
305 let codec = Lazy.force codec
306end
307
308(* Command line interface *)
309
310let ( let* ) = Result.bind
311let strf = Printf.sprintf
312
313let log_if_error ~use = function
314 | Ok v -> v
315 | Error e ->
316 let lines = String.split_on_char '\n' e in
317 Format.eprintf "@[%a @[<v>%a@]@]" Json.Error.puterr ()
318 (Format.pp_print_list Format.pp_print_string)
319 lines;
320 use
321
322let with_infile file f =
323 (* XXX add something to bytesrw. *)
324 let process file ic =
325 try Ok (f (Bytesrw.Bytes.Reader.of_in_channel ic))
326 with Sys_error e -> Error (Format.sprintf "@[<v>%s:@,%s@]" file e)
327 in
328 try
329 match file with
330 | "-" -> process file In_channel.stdin
331 | file -> In_channel.with_open_bin file (process file)
332 with Sys_error e -> Error e
333
334let trip ~file ~indent ~meta ~dec_only =
335 log_if_error ~use:1 @@ with_infile file
336 @@ fun r ->
337 log_if_error ~use:1
338 @@
339 let* t = Json.of_reader ~file ~meta Geojson.codec r in
340 if dec_only then Ok 0
341 else
342 let w = Bytesrw.Bytes.Writer.of_out_channel stdout in
343 Json.to_writer ?indent ~eod:true Geojson.codec t w;
344 Ok 0
345
346open Cmdliner
347open Cmdliner.Term.Syntax
348
349let geojson =
350 Cmd.v (Cmd.info "geojson" ~doc:"round trip GeoJSON")
351 @@
352 let+ file =
353 let doc = "$(docv) is the GeoJSON file. Use $(b,-) for stdin." in
354 Arg.(value & pos 0 string "-" & info [] ~doc ~docv:"FILE")
355 and+ locs =
356 let doc = "Preserve locations (better errors)." in
357 Arg.(value & flag & info [ "l"; "locs" ] ~doc)
358 and+ indent =
359 let fmt = [ ("indent", Some 2); ("minify", None) ] in
360 let doc = strf "Output style. Must be %s." (Arg.doc_alts_enum fmt) in
361 Arg.(value & opt (enum fmt) None & info [ "f"; "format" ] ~doc ~docv:"FMT")
362 and+ dec_only =
363 let doc = "Decode only." in
364 Arg.(value & flag & info [ "d" ] ~doc)
365 in
366 let meta = if locs then `Locs else `None in
367 trip ~file ~indent ~meta ~dec_only
368
369let main () = Cmd.eval' geojson
370let () = if !Sys.interactive then () else exit (main ())