Source file j.ml

(*********************************************************************************)
(*                OCaml-RDF                                                      *)
(*                                                                               *)
(*    Copyright (C) 2012-2024 Institut National de Recherche en Informatique     *)
(*    et en Automatique. All rights reserved.                                    *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU Lesser General Public License version        *)
(*    3 as published by the Free Software Foundation.                            *)
(*                                                                               *)
(*    This program is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              *)
(*    GNU General Public License for more details.                               *)
(*                                                                               *)
(*    You should have received a copy of the GNU General Public License          *)
(*    along with this program; if not, write to the Free Software                *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

(** JSON documents. *)

type loc = int * int (** 1-based line * 0-based column *)

type range = loc * loc

let string_of_range ((l1,c1), (l2,c2)) =
  if l1 = l2
  then Printf.sprintf "line %d, characters %d-%d" l1 c1 c2
  else Printf.sprintf "line %d, character %d to line %d, character %d" l1 c1 l2 c2

type 'a ranged = { loc : range option ; data : 'a }
let ranged ?loc data = { loc ; data }

type error = ..

type error += Invalid_json of string

exception Error of error
let error e = raise (Error e)

type key = string ranged
type map = (key * json) list
and json_t = [
  | `Obj of (key * json) list
  | `List of json list
  | `String of string
  | `Bool of bool
  | `Float of float
  | `Null
  ]
and json = json_t ranged
let json ?loc data = { loc ; data }

exception Escape of ((int * int) * (int * int)) * Jsonm.error
let string_of_error range err =
  let b = Buffer.create 256 in
  Buffer.add_string b (string_of_range range) ;
  Buffer.add_string b ": ";
  let fmt = Format.formatter_of_buffer b in
  Jsonm.pp_error fmt err;
  Format.pp_print_flush fmt ();
  Buffer.contents b

let dec d = match Jsonm.decode d with
  | `Lexeme l -> l
  | `Error e -> raise (Escape (Jsonm.decoded_range d, e))
  | `End | `Await -> assert false

let loc_start d = fst (Jsonm.decoded_range d)
let loc_end d = snd (Jsonm.decoded_range d)
let range d = Jsonm.decoded_range d

let rec value v k d =
  match v with
  | `Os -> obj (loc_start d) [] k d
  | `As -> arr (loc_start d) [] k d
  | `Null | `Bool _ | `String _ | `Float _ as v ->
      let v = json ~loc: (range d) v in
      k v d
  | _ -> assert false
and arr loc_start vs k d =
  match dec d with
  | `Ae ->
      let loc = (loc_start, loc_end d) in
      let v = json ~loc (`List (List.rev vs)) in
      k v d
  | v -> value v (fun v -> arr loc_start (v :: vs) k) d
and obj loc_start ms k d =
  match dec d with
  | `Oe ->
      let loc = (loc_start, loc_end d) in
      let v = json ~loc (`Obj (List.rev ms)) in
      k v d
  | `Name n ->
      let key = ranged n in
      value (dec d) (fun v -> obj loc_start ((key, v) :: ms) k) d
  | _ -> assert false

let json_of_src ?encoding
  (src : [`Channel of in_channel | `String of string])
    =
  let d = Jsonm.decoder ?encoding src in
  try Ok (value (dec d) (fun v _ -> v) d) with
  | Escape (r, e) -> Error (r, e)

let enc e l = ignore (Jsonm.encode e (`Lexeme l))
let rec value v k e = match v with
  | `List vs -> arr vs k e
  | `Obj ms -> obj ms k e
  | `Null | `Bool _ | `Float _ | `String _ as v -> enc e v; k e
and arr vs k e = enc e `As; arr_vs vs k e
and arr_vs vs k e = match vs with
  | v :: vs' -> value v.data (arr_vs vs' k) e
  | [] -> enc e `Ae; k e
and obj ms k e = enc e `Os; obj_ms ms k e
and obj_ms ms k e = match ms with
  | (key, v) :: ms -> enc e (`Name key.data); value v.data (obj_ms ms k) e
  | [] -> enc e `Oe; k e

let json_to_dst ~minify
  (dst : [`Channel of out_channel | `Buffer of Buffer.t ])
    (json : json)
    =
  let e = Jsonm.encoder ~minify dst in
  let finish e = ignore (Jsonm.encode e `End) in
  match json.data with `List _ | `Obj _ as json -> value json finish e
  | _ -> invalid_arg "invalid json text"

let from_string ?encoding s = json_of_src ?encoding (`String s)
let from_string_exn ?encoding s =
  match from_string ?encoding s with
  | Ok x -> x
  | Error (range, e) -> error (Invalid_json (string_of_error range e))

let to_string ?(minify=false) json =
  let b = Buffer.create 256 in
  (match json.data with
   | `Null -> Buffer.add_string b "null"
   | `Bool true -> Buffer.add_string b "true"
   | `Bool false ->Buffer.add_string b "false"
   | `Float f -> Printf.bprintf b "%E" f
   | `String str -> Printf.bprintf b "%S" str
   | x ->  json_to_dst ~minify (`Buffer b) json
  );
  Buffer.contents b

let pp ppf j = Format.fprintf ppf "%s" (to_string j)
let ppm ppf j = Format.fprintf ppf "%s" (to_string ~minify:true j)

let map_get =
  let rec find k = function
  | [] -> None
  | ({ data }, v) :: _ when data = k -> Some v
  | _ :: q -> find k q
  in
  fun fields k -> find k (List.rev fields)

let (-->>) = map_get
let (-->) fields name = Option.map (fun { data } -> data) (fields-->>name)
let (-?>) json name =
  match json.data with
  | `Obj fields -> fields-->>name
  | _ -> None

let string ?loc str = json ?loc (`String str)
let string_of_opt ?loc str =
  string ?loc (match str with None -> "None" | Some str -> str)
let list ?loc l = json ?loc (`List l)
let obj ?loc fields = json ?loc (`Obj fields)
let null = json `Null
let bool ?loc b = json ?loc (`Bool b)
let float ?loc f = json ?loc (`Float f)

let rec compare { data = data1 } { data = data2 } =
  match data1, data2 with
  | `Null, `Null -> 0
  | `Null, _ -> -1
  | _, `Null -> 1
  | `Float f1, `Float f2 -> Float.compare f1 f2
  | `Float _, _ -> -1
  | _, `Float _ -> 1
  | `Bool b1, `Bool b2 -> Bool.compare b1 b2
  | `Bool _, _ -> -1
  | _, `Bool _ -> 1
  | `String s1, `String s2 -> String.compare s1 s2
  | `String _, _ -> -1
  | _, `String _ -> 1
  | `List l1, `List l2 -> List.compare compare l1 l2
  | `List _, _ -> -1
  | _, `List _ -> 1
  | `Obj o1, `Obj o2 -> map_compare o1 o2

and key_value_compare (k1, v1) (k2, v2) =
  match String.compare k1.data k2.data with
  | 0 -> compare v1 v2
  | x -> x
and map_compare map1 map2 =
   let map1 = sort_map map1 and map2 = sort_map map2 in
   List.compare key_value_compare map1 map2

and sort_map map = List.sort key_value_compare map

let rec normalize (j:json) =
  match j.data with
  | `List l -> list ?loc:j.loc (List.map normalize l)
  | `Obj map ->
      let map = List.map (fun (k,v) -> (k, normalize v)) map in
      obj ?loc:j.loc (sort_map map)
  | _ -> j

let equal j1 j2 = compare j1 j2 = 0

let to_array j =
  match j.data with
  | `List _ -> j
  | _ -> list [j]

let values j = match j.data with
  | `List l -> l
  | _ -> [j]

let is_scalar j = match j.data with
  | `Obj _ | `List _ | `Null -> false
  | _ -> true

let is_string_array =
  let pred = function { data = `String _ } -> true | _ -> false in
  fun j ->
    match j.data with
    | `List l -> List.for_all pred l
    | _ -> false

let string_of_json_opt = function None -> "None" | Some j -> to_string j

let map_add_value =
  let rec iter acc k v = function
  | [] -> (ranged k, v) :: acc
  | (k1, _) :: q when k1.data = k ->
      acc @ ((k1, v) :: q)
  | h :: q -> iter (h::acc) k v q
  in
  fun map k v -> iter [] k v map

let map_remove_value map k =
  List.filter (fun (k1, _) -> k1.data <> k) map

let map_pp ppf map =
  Format.fprintf ppf "%s" (to_string (obj map))

let opt_map_pp ppf = function
| None -> Format.fprintf ppf "None"
| Some map -> map_pp ppf map