Source file b0_json.ml

(*---------------------------------------------------------------------------
   Copyright (c) 2016 The b0 programmers. All rights reserved.
   SPDX-License-Identifier: ISC
  ---------------------------------------------------------------------------*)

open B0_text

module Json = struct

  (* JSON text *)

  type loc = Tloc.t
  type mem = (string * loc) * t
  and t =
  [ `Null of loc
  | `Bool of bool * loc
  | `Float of float * loc
  | `String of string * loc
  | `A of t list * loc
  | `O of mem list * loc ]

  let loc_nil = Tloc.nil
  let loc = function
  | `Null l | `Bool (_, l) | `Float (_, l) | `String (_, l) | `A (_, l)
  | `O (_, l) -> l

  (* Constructors *)

  let null = `Null loc_nil
  let bool b = `Bool (b, loc_nil)
  let float f = `Float (f, loc_nil)
  let string s = `String (s, loc_nil)
  let array vs = `A (vs, loc_nil)
  let mem n v = ((n, loc_nil), v)
  let obj mems = `O (mems, loc_nil)

  (* Accessors *)

  let kind = function
  | `Null _ -> "null" | `Bool _ -> "bool" | `Float _ -> "float"
  | `String _ -> "string" | `A _ -> "array" | `O _ -> "object"

  let err_exp exp fnd =
    Format.asprintf "%a: %s but expected %s" Tloc.pp (loc fnd) (kind fnd) exp

  let err_exp_null = err_exp "null"
  let err_exp_bool = err_exp "bool"
  let err_exp_float = err_exp "number"
  let err_exp_string = err_exp "string"
  let err_exp_array = err_exp "array"
  let err_exp_obj = err_exp "object"

  let err e = Error e
  let to_null = function `Null _ -> Ok () | j -> err (err_exp_null j)
  let to_bool = function `Bool (b, _) -> Ok b | j -> err (err_exp_bool j)
  let to_float = function `Float (f, _) -> Ok f | j -> err (err_exp_float j)
  let to_string = function `String (s,_) -> Ok s | j -> err (err_exp_string j)
  let to_array = function `A (vs, _) -> Ok vs | j -> err (err_exp_array j)
  let to_obj = function `O (mems, _) -> Ok mems | j -> err (err_exp_obj j)

  let err = invalid_arg
  let get_null = function `Null _ -> () | j -> err (err_exp_null j)
  let get_bool = function `Bool (b, _) -> b | j -> err (err_exp_bool j)
  let get_float = function `Float (f, _) -> f | j -> err (err_exp_float j)
  let get_string = function `String (s,_) -> s | j -> err (err_exp_string j)
  let get_array = function `A (vs, _) -> vs | j -> err (err_exp_array j)
  let get_obj = function `O (mems, _) -> mems | j -> err (err_exp_obj j)

  (* Decode *)

  (* FIXME add positions and reuse Tlex. *)

  type decoder = { t : Buffer.t; i : string; mutable pos : int; }
  let decoder s = { t = Buffer.create 255; i = s; pos = 0 }
  let accept d = d.pos <- d.pos + 1 [@@ ocaml.inline]
  let treset d = Buffer.reset d.t [@@ ocaml.inline]
  let taccept d = Buffer.add_char d.t d.i.[d.pos]; accept d; [@@ ocaml.inline]
  let taddc d c = Buffer.add_char d.t c [@@ ocaml.inline]
  let taddu d u = Tdec.buffer_add_uchar d.t u
  let token d = Buffer.contents d.t [@@ ocaml.inline]
  let eoi d = d.pos = String.length d.i [@@ ocaml.inline]
  let byte d = match eoi d with
  | true -> 0xFFF
  | false -> Char.code d.i.[d.pos]
  [@@ ocaml.inline]

  let err d fmt =
    Format.kasprintf (fun s -> raise_notrace (Failure s)) ("%d: " ^^ fmt) d.pos

  let pp_byte ppf d = match byte d with
  | 0xFFF -> Format.fprintf ppf "end of input"
  | b -> Format.fprintf ppf "%C" (Char.chr b)

  type utf_8_case =
  | L1 | L2 | L3_E0 | L3_E1_EC_or_EE_EF | L3_ED | L4_F0 | L4_F1_F3 | L4_F4 | E

  let utf_8_case =
(*
  (* See https://tools.ietf.org/html/rfc3629#section-4 *)
  Printf.printf "[|";
  for i = 0 to 255 do
    if i mod 16 = 0 then Printf.printf "\n";
    if 0x00 <= i && i <= 0x7F then Printf.printf "L1; " else
    if 0xC2 <= i && i <= 0xDF then Printf.printf "L2; " else
    if 0xE0 = i then Printf.printf "L3_E0; " else
    if 0xE1 <= i && i <= 0xEC || 0xEE <= i && i <= 0xEF
    then Printf.printf "L3_E1_EC_or_EE_EF; " else
    if 0xED = i then Printf.printf "L3_ED;" else
    if 0xF0 = i then Printf.printf "L4_F0; " else
    if 0xF1 <= i && i <= 0xF3 then Printf.printf "L4_F1_F3; " else
    if 0xF4 = i then Printf.printf "L4_F4; " else
    Printf.printf "E; "
  done;
  Printf.printf "\n|]"
*)
  [|
    L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1;
    L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1;
    L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1;
    L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1;
    L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1;
    L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1;
    L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1;
    L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1; L1;
    E; E; E; E; E; E; E; E; E; E; E; E; E; E; E; E;
    E; E; E; E; E; E; E; E; E; E; E; E; E; E; E; E;
    E; E; E; E; E; E; E; E; E; E; E; E; E; E; E; E;
    E; E; E; E; E; E; E; E; E; E; E; E; E; E; E; E;
    E; E; L2; L2; L2; L2; L2; L2; L2; L2; L2; L2; L2; L2; L2; L2;
    L2; L2; L2; L2; L2; L2; L2; L2; L2; L2; L2; L2; L2; L2; L2; L2;
    L3_E0; L3_E1_EC_or_EE_EF; L3_E1_EC_or_EE_EF; L3_E1_EC_or_EE_EF;
    L3_E1_EC_or_EE_EF; L3_E1_EC_or_EE_EF; L3_E1_EC_or_EE_EF; L3_E1_EC_or_EE_EF;
    L3_E1_EC_or_EE_EF; L3_E1_EC_or_EE_EF; L3_E1_EC_or_EE_EF; L3_E1_EC_or_EE_EF;
    L3_E1_EC_or_EE_EF; L3_ED;L3_E1_EC_or_EE_EF; L3_E1_EC_or_EE_EF;
    L4_F0; L4_F1_F3; L4_F1_F3; L4_F1_F3; L4_F4; E; E; E; E; E; E; E; E; E; E; E;
  |]

  let taccept_utf_8 d =
    let err d = err d "expected UTF-8 byte found: %a" pp_byte d in
    let b = byte d in
    let accept_tail d =
      if (byte d lsr 6 = 0b10) then taccept d else err d [@@ocaml.inline]
  in
  match utf_8_case.(b) with
  | L1 -> taccept d
  | L2 -> taccept d; accept_tail d
  | L3_E0 ->
      taccept d;
      if (byte d - 0xA0 < 0xBF - 0xA0) then taccept d else err d;
      accept_tail d
  | L3_E1_EC_or_EE_EF -> taccept d; accept_tail d; accept_tail d
  | L3_ED ->
      taccept d;
      if (byte d - 0x80 < 0x9F - 0x80) then taccept d else err d;
      accept_tail d
  | L4_F0 ->
      taccept d;
      if (byte d - 0x90 < 0xBF - 0x90) then taccept d else err d;
      accept_tail d; accept_tail d
  | L4_F1_F3 -> taccept d; accept_tail d; accept_tail d; accept_tail d;
  | L4_F4 ->
      taccept d;
      if (byte d - 0x80 < 0x8F - 0x80) then taccept d else err d;
  | E -> err d

  let accept_bytes d bytes = (* first byte already checked *)
    let max = String.length bytes - 1 in
    let rec loop i = match i > max with
    | true -> ()
    | false ->
        match Char.code bytes.[i] = byte d with
        | true -> accept d; loop (i + 1)
        | false ->
            err d "expected %C found: %a while parsing '%s'"
              bytes.[i] pp_byte d bytes
    in
    accept d; loop 1

  let rec skip_ws d = match byte d with
  | 0x20 | 0x09 | 0x0A | 0x0D -> accept d; skip_ws d
  | _ -> ()

  let parse_true d = accept_bytes d "true"; `Bool (true, loc_nil)
  let parse_false d = accept_bytes d "false"; `Bool (false, loc_nil)
  let parse_null d = accept_bytes d "null"; `Null loc_nil
  let parse_number d = (* not fully compliant *)
    let conv d = try `Float (float_of_string (token d), loc_nil) with
    | Failure e -> err d "could not parse a float from: %S" (token d)
    in
    let rec taccept_non_sep d = match byte d with
    | 0x20 | 0x09 | 0x0A | 0x0D | 0x2C | 0x5D | 0x7D | 0xFFF -> conv d
    | _ -> taccept d; taccept_non_sep d
    in
    treset d; taccept d; taccept_non_sep d

  let rec parse_uescape d hi u count =
    let pp_ucp ppf d = Format.fprintf ppf "U+%04X" d in
    let err_not_lo d u = err d "not a low surrogate %a" pp_ucp u in
    let err_lo d u = err d "lone low surrogate %a" pp_ucp u in
    let err_hi d u = err d "lone high surrogate %a" pp_ucp u in
    match count > 0 with
    | true ->
        begin match byte d with
        | c when 0x30 <= c && c <= 0x39 ->
            accept d; parse_uescape d hi (u * 16 + c - 0x30) (count - 1)
        | c when 0x41 <= c && c <= 0x46 ->
            accept d; parse_uescape d hi (u * 16 + c - 0x37) (count - 1)
        | c when 0x61 <= c && c <= 0x66 ->
            accept d; parse_uescape d hi (u * 16 + c - 0x57) (count - 1)
        | c ->
            err d "expected hex digit found: %C" (Char.chr c)
        end
    | false ->
        match hi with
        | Some hi -> (* combine high and low surrogate into scalar value. *)
            if u < 0xDC00 || u > 0xDFFF then err_not_lo d u else
            let u = ((((hi land 0x3FF) lsl 10) lor (u land 0x3FF)) + 0x10000) in
            taddu d (Uchar.unsafe_of_int u)
        | None ->
            if u < 0xD800 || u > 0xDFFF then taddu d (Uchar.unsafe_of_int u)
            else if u > 0xDBFF then err_lo d u else
            match byte d with
            | 0x5C ->
                accept d;
                begin match byte d with
                | 0x75 -> accept d; parse_uescape d (Some u) 0 4
                | _ -> err_hi d u
                end
            | _ -> err_hi d u

  let parse_string d =
    let parse_escape d = match byte d with
    | (0x22 | 0x5C | 0x2F as b) -> taddc d (Char.chr b); accept d;
    | 0x62 -> taddc d '\x08'; accept d;
    | 0x66 -> taddc d '\x0C'; accept d;
    | 0x6E -> taddc d '\x0A'; accept d;
    | 0x72 -> taddc d '\x0D'; accept d;
    | 0x74 -> taddc d '\x09'; accept d;
    | 0x75 ->
        accept d; parse_uescape d None 0 4
    | _ -> err d "expected escape found: %a" pp_byte d
    in
    let rec loop d = match byte d with
    | 0x5C (* '\' *) -> accept d; parse_escape d; loop d
    | 0x22 (* '"' *) -> accept d; `String ((token d), loc_nil)
    | 0xFFF -> err d "unclosed string"
    | _ -> taccept_utf_8 d; loop d
    in
    accept d; treset d; loop d

  let rec parse_object d = match (accept d; skip_ws d; byte d) with
  | 0x7D (* '}' *) -> accept d; `O ([], loc_nil)
  | _ ->
      let parse_name d =
        let `String name = match (skip_ws d; byte d) with
        | 0x22 (* '"' *) -> parse_string d
        | _ -> err d "expected '\"' found: %a" pp_byte d
        in
        skip_ws d; name
      in
      let rec loop acc d =
        let name = parse_name d in
        match byte d with
        | 0x3A (* ':' *) ->
            let v = (accept d; parse_value d) in
            begin match byte d with
            | 0x2C (* ',' *) -> accept d; loop ((name, v) :: acc) d
            | 0x7D (* '}' *) -> accept d; `O (List.rev ((name, v) :: acc),
                                              loc_nil)
            | _ -> err d "expected ',' or '}' found: %a" pp_byte d
            end
        | _ -> err d "expected ':' found: %a" pp_byte d
      in
      loop [] d

  and parse_array d = match (accept d; skip_ws d; byte d) with
  | 0x5D (* ']' *) -> accept d; `A ([], loc_nil)
  | _ ->
      let rec loop acc d =
        let v = parse_value d in
        match byte d with
        | 0x2C (* ',' *) -> accept d; loop (v :: acc) d
        | 0x5D (* ']' *) -> accept d; `A (List.rev (v :: acc), loc_nil)
        | _ -> err d "expected ',' or ']' found: %a" pp_byte d
      in
      loop [] d

  and parse_value d : t =
    let v = match (skip_ws d; byte d) with
    | 0x22 (* '"' *) -> parse_string d
    | 0x74 (* 't' *) -> parse_true d
    | 0x66 (* 'f' *) -> parse_false d
    | 0x6E (* 'n' *) -> parse_null d
    | 0x7B (* '{' *) -> parse_object d
    | 0x5B (* '[' *) -> parse_array d
    | 0x2D (* '-' *) -> parse_number d
    | b when 0x30 (* '0' *) <= b && b <= 0x39 (* '9' *) -> parse_number d
    | _ -> err d "expected a JSON value found: %a" pp_byte d
    in
    skip_ws d;
    v

  let of_string ?(file = Tloc.no_file) s =
    try
      let d = decoder s in
      let v = parse_value d in
      match byte d with
      | 0xFFF (* eoi *) -> Ok v
      | _ -> err d "expected end of input found: %a" pp_byte d
    with
    | Failure e -> Error e

  (* JSON generation *)

  module G = struct
    (* Not T.R. we could CPS. *)

    type enc = { mutable sep : bool; b : Buffer.t }
    type t = enc -> unit

    let addc c enc = Buffer.add_char enc.b c
    let adds s enc = Buffer.add_string enc.b s
    let adds_esc s enc =
      let is_control =
        function '\x00' .. '\x1F' | '\x7F' -> true | _ -> false
      in
      let len = String.length s in
      let max_idx = len - 1 in
      let flush b start i =
        if start < len then Buffer.add_substring b s start (i - start);
      in
      let rec loop start i = match i > max_idx with
      | true -> flush enc.b start i
      | false ->
          let next = i + 1 in
          match String.get s i with
          | '"' -> flush enc.b start i; adds "\\\"" enc; loop next next
          | '\\' -> flush enc.b start i; adds "\\\\" enc; loop next next
          | c when is_control c ->
              flush enc.b start i;
              adds (Format.asprintf "\\u%04X" (Char.code c)) enc;
              loop next next
          | c -> loop start next
      in
      loop 0 0

    let null enc = adds "null" enc
    let bool b enc = adds (if b then "true" else "false") enc
    let int i enc = adds (string_of_int i) enc
    let float f enc = adds (Format.asprintf "%.16g" f) enc
    let string s enc = addc '"' enc; adds_esc s enc; addc '"' enc

    let nosep enc = enc.sep <- false
    let sep enc = enc.sep
    let set_sep sep enc = enc.sep <- sep
    let if_sep enc = if not enc.sep then enc.sep <- true else addc ',' enc

    type array = t
    let array enc = ()
    let array_end els enc =
      let sep = sep enc in
      addc '[' enc; nosep enc; els enc; addc ']' enc; set_sep sep enc

    let el e arr enc = arr enc; if_sep enc; e enc
    let el_if c e arr enc = if c then el (e ()) arr enc else arr enc

    type obj = t
    let obj enc = ()
    let obj_end mems enc =
      let sep = sep enc in
      addc '{' enc; nosep enc; mems enc; addc '}' enc; set_sep sep enc

    let mem m v obj enc = obj enc; if_sep enc; string m enc; addc ':' enc; v enc
    let mem_if c m v obj enc = if c then mem m (v ()) obj enc else obj enc

    (* Derived generators *)

    let strf fmt = Format.kasprintf string fmt
    let list elv l =
      array_end (List.fold_left (fun a v -> el (elv v) a) array l)

    let option some o = match o with None -> null | Some v -> some v
    let rec json = function
    | `Null _ -> null
    | `Bool (b, _) -> bool b
    | `Float (f, _) -> float f
    | `String (s, _) -> string s
    | `A (a, _) ->
        array_end @@ List.fold_left (fun a e -> el (json e) a) array a
    | `O (o, _) ->
        obj_end @@ List.fold_left (fun o ((m, _), v) -> mem m (json v) o) obj o

    (* Output generated values *)

    let buffer_add b g = g { sep = true; b }
    let to_string g =
      let b = Buffer.create 65535 in
      (buffer_add b g; Buffer.contents b)
  end

  let to_string v = G.to_string (G.json v)

  let pp ppf (v : t) = (* FIXME not T.R. *)
    let pp_string ppf s = (* FIXME quick & dirty escaping *)
      Format.pp_print_string ppf (G.to_string (G.json ((`String (s, loc_nil)))))
    in
    let pp_comma ppf () =
      Format.(pp_print_char ppf ','; pp_print_space ppf ())
    in
    let rec loop ppf = function
    | `Null _ -> Format.pp_print_string ppf "null"
    | `Bool (b,_ ) -> Format.pp_print_string ppf (if b then "true" else "false")
    | `Float (f, _) -> Format.fprintf ppf "%.16g" f
    | `String (s, _) -> pp_string ppf s
    | `A (a, _) ->
        Format.pp_open_box ppf 1;
        Format.pp_print_char ppf '[';
        Format.pp_print_list ~pp_sep:pp_comma loop ppf a;
        Format.pp_print_char ppf ']';
        Format.pp_close_box ppf ();
    | `O (o, _) ->
        let pp_mem ppf ((m, _), v) =
          Format.pp_open_box ppf 1;
          pp_string ppf m;
          Format.pp_print_char ppf ':'; Format.pp_print_space ppf ();
          loop ppf v;
          Format.pp_close_box ppf ();
        in
        Format.pp_open_vbox ppf 1;
        Format.pp_print_char ppf '{';
        Format.pp_print_list ~pp_sep:pp_comma pp_mem ppf o;
        Format.pp_print_char ppf '}';
        Format.pp_close_box ppf ();
    in
    loop ppf v
end

module Jsong = Json.G
module Jsonq = struct

  module Sset = Set.Make (String)
  module Smap = Map.Make (String)

  let pp_quote ppf s = Format.fprintf ppf "'%s'" s
  let pp_mem = pp_quote

  type path = (* Paths in JSON values, array and object member traversals. *)
    ([`A | `O of string] * Json.loc) list (* in reverse order *)

  let path_to_string p =
    let seg = function `A -> "[]" | `O n -> "." ^ n in
    String.concat "" (List.rev_map seg p)

  let path_to_trace ?(pp_mem = pp_mem) p =
    let seg = function
    | `A, l -> Format.asprintf "%a: in array" Tloc.pp l
    | `O m, l -> Format.asprintf "%a: in key %a" Tloc.pp l pp_mem m
    in
    String.concat "\n" (List.map seg p)

  (* Errors *)

  exception Err of path * Tloc.t * string

  let err p l msg = raise_notrace (Err (p, l, msg))
  let errf p l fmt = Format.kasprintf (err p l) fmt
  let err_exp exp p fnd =
    errf p (Json.loc fnd) "found %s but expected %s" (Json.kind fnd) exp

  let err_exp_null = err_exp "null"
  let err_exp_bool = err_exp "bool"
  let err_exp_float = err_exp "number"
  let err_exp_string = err_exp "string"
  let err_exp_array = err_exp "array"
  let err_exp_obj = err_exp "object"
  let err_empty_array p l = errf p l "unexpected empty array"
  let err_miss_mem p l n = errf p l "member %a unbound in object" pp_mem n
  let err_to_string ?pp_mem p loc msg =
    let pp_lines ppf s =
      Format.fprintf ppf "@[<v>%a@]"
        (Format.pp_print_list Format.pp_print_string)
        (String.split_on_char '\n' s)
    in
    match p with
    | [] -> Format.asprintf "%a:@\n%a" Tloc.pp loc pp_lines msg
    | p ->
        Format.asprintf "%a:@\n%a@\n  @[%a@]"
          Tloc.pp loc pp_lines msg pp_lines (path_to_trace p)

  (* Queries *)

  type 'a t = path -> Json.t -> 'a

  let query q s = try Ok (q [] s) with
  | Err (p, l, m) -> Error (err_to_string p l m)

  (* Succeeding and failing queries *)

  let succeed v p j = v
  let fail msg p j = err p (Json.loc j) msg
  let failf fmt = Format.kasprintf fail fmt

  (* Query combinators *)

  let app fq q p j = fq p j (q p j)
  let ( $ ) = app
  let pair q0 q1 p j = let v0 = q0 p j in v0, q1 p j
  let bind q f p j = f (q p j) p j
  let map f q p j = f (q p j)
  let some q p j = Some (q p j)

  (* JSON queries *)

  let fold ~null ~bool ~float ~string ~array ~obj p = function
  | `Null _ as j -> null p j
  | `Bool _ as j -> bool p j
  | `Float _ as j -> float p j
  | `String _ as j -> string p j
  | `A _ as j -> array p j
  | `O _ as j -> obj p j

  let partial_fold ?null ?bool ?float ?string ?array ?obj () p j =
    let with_q q p j = match q with
    | None ->
        let kind k = function None -> "" | Some _ -> k  in
        let kinds = [ kind "null" null; kind "bool" bool;
                      kind "number" float; kind "string" string;
                      kind "array" array; kind "obj" obj ]
        in
        let kinds = List.filter (fun s -> s <> "") kinds in
        let kinds = String.concat ", " kinds in
        (* FIXME use error messages from Err_msg *)
        let kinds = if kinds = "" then "nothing" else "one of " ^ kinds in
        err_exp kinds p j
    | Some q -> q p j
    in
    match j with
    | `Null _ as j -> with_q null p j
    | `Bool _ as j -> with_q bool p j
    | `Float _ as j -> with_q float p j
    | `String _ as j -> with_q string p j
    | `A _ as j -> with_q array p j
    | `O _ as j -> with_q obj p j

  let json p s = s
  let loc p s = Json.loc s
  let with_loc q p s = (q p s), Json.loc s

  (* Nulls *)

  let is_null p = function `Null _ -> true | j -> false
  let null p = function `Null _ -> () | j -> err_exp_null p j
  let nullable q p = function `Null _ -> None | j -> Some (q p j)

  (* Atomic values *)

  let bool p = function `Bool (b, _) -> b | j -> err_exp_bool p j
  let float p = function `Float (f, _) -> f | j -> err_exp_float p j
  let int = map truncate float
  let string p = function `String (s, _) -> s | j -> err_exp_string p j

  let string_to ~kind parse p = function
  | `String (s, _) as j ->
      (match parse s with Ok v -> v | Error m -> fail m p j)
  | j -> err_exp kind p j

  let enum ~kind ss p = function
  | `String (s, _) when Sset.mem s ss -> s
  | `String (s, l) ->
      let ss = Sset.elements ss in
      let hint, ss = match Tdec.err_suggest ss s with
      | [] -> Tdec.pp_must_be, ss
      | ss -> Tdec.pp_did_you_mean, ss
      in
      let kind ppf () = Format.pp_print_string ppf kind in
      let pp_v = Format.pp_print_string in
      errf p l "%a" (Tdec.pp_unknown' ~kind pp_v ~hint) (s, ss)
  | j -> err_exp kind p j

  let enum_map ~kind sm p = function
  | `String (s, l) ->
      begin match Smap.find s sm with
      | v -> v
      | exception Not_found ->
          let ss = Smap.fold (fun k _ acc -> k :: acc) sm [] in
          let hint, ss = match Tdec.err_suggest ss s with
          | [] -> Tdec.pp_must_be, ss
          | ss -> Tdec.pp_did_you_mean, ss
          in
          let kind ppf () = Format.pp_print_string ppf kind in
          let pp_v = Format.pp_print_string in
          errf p l "%a" (Tdec.pp_unknown' ~kind pp_v ~hint) (s, ss)
      end
  | j -> err_exp kind p j

  (* Array *)

  let is_empty_array p = function `A (a, _) -> a = [] | j -> err_exp_array p j
  let hd q p = function
  | `A ([], l) -> err_empty_array p l
  | `A (v :: _, l) -> q ((`A, l) :: p) v
  | j -> err_exp_array p j

  let tl q p = function
  | `A ([], l) -> err_empty_array p l
  | `A (_ :: [], l) -> q p (`A ([], Tloc.to_end l))
  | `A (_ :: (v :: _ as a), l) ->
      let l = Tloc.restart ~at:(Tloc.to_start (Json.loc v)) l in
      q p (`A (a, l))
  | j -> err_exp_array p j

  let nth ?absent n q p = function
  | `A (vs, l) ->
      let p = (`A, l) :: p in
      let k, vs = if n < 0 then - n - 1, List.rev vs else n, vs in
      let rec loop k = function
      | v :: vs when k = 0 -> q p v
      | _ :: vs -> loop (k - 1) vs
      | [] ->
          match absent with
          | None -> errf p l "%d: no such index in array" n
          | Some absent -> absent
      in
      loop k vs
  | j -> err_exp_array p j

  let fold_array f q acc p = function
  | `A (vs, l) ->
      let p = (`A, l) :: p in
      let add p acc v = f (q p v) acc in
      List.fold_left (add p) acc vs
  | j -> err_exp_array p j

  let array qv = map List.rev (fold_array (fun v acc -> v :: acc) qv [])

  (* Objects *)

  let rec mem_find n = function
  | ((n', _), j) :: ms when String.equal n' n -> Some j
  | _  :: ms -> mem_find n ms
  | [] -> None

  let mem : string -> 'a t -> 'a t = fun n q p -> function
  | `O (ms, l) ->
      begin match mem_find n ms with
      | None -> err_miss_mem p l n
      | Some j -> q  ((`O n, l) :: p) j
      end
  | j -> err_exp_obj p j

  let opt_mem n q ~absent p = function
  | `O (ms, l) ->
      begin match mem_find n ms with
      | None -> absent
      | Some j -> q ((`O n, l) :: p) j
      end
  | j -> err_exp_obj p j

  let mem_dom ~validate p = function
  | `O (ms, l) ->
      let add_mem = match validate with
      | None -> fun acc ((n, _), _) -> Sset.add n acc
      | Some dom ->
          fun acc ((n, _), _) -> match Sset.mem n dom with
          | true -> Sset.add n acc
          | false ->
              let ns = Sset.elements dom in
              let hint, ss = match Tdec.err_suggest ns n with
              | [] -> Tdec.pp_must_be, ns
              | ss -> Tdec.pp_did_you_mean, ss
              in
              let kind ppf () = Format.pp_print_string ppf "member" in
              let pp_v = Format.pp_print_string in
              errf p l "%a" (Tdec.pp_unknown' ~kind pp_v ~hint) (n, ss)
      in
      List.fold_left add_mem Sset.empty ms
  | j -> err_exp_obj p j
end