;; Functions supporting (basic) json-file parsing
;;
;; This file is part of Beastie <https://purl.org/nxg/dist/beastie>
;; SPDX-FileCopyrightText: 2025 Norman Gray <https://nxg.me.uk>
;; SPDX-License-Identifier: BSD-2-Clause

(define *requires-implementation-functions*
  '(parse-json-source**))

(define-macro (%module-verbosity-flag%) 256)

(define/provide* (parse-json-file fn
                                  (on-error (λ (msg)
                                              (print-warning msg)
                                              #f)))
  #"""`(parse-json-file filename [:on-error func])` :
  parse the contents of a file containing JSON,
  and return as a sexp; if the filename is `#f`, then parse stdin.

  On any parsing error, the function calls the `on-error` procedure,
  passing it an error message.  The default procedure prints the message
  as a warning and returns `#f`.  Since `false` is a legitimate JSON input,
  this also would produce `#f` as output: if it is necessary to distinguish
  an error from a successful parse of `false`, then a non-default `on-error`
  procedure can do so.

  Numbers are reported as floats, strings as `ustring?`, lists as
  lists, objects as hash-tables, and `false`, `true` and `null` as
  `#f`, `#t` and `()` respectively.

  See RFC 8259.
  This is a strict parser, and will object to any malformed input.
  We don't recognise any extensions, such as comments in the file."""
  (let ((res (parse-json-source** #t fn)))
    (if (car res)
        (cdr res)
        (on-error (cdr res)))))

(define/provide* (parse-json-string str
                                    (on-error (λ (msg)
                                                (print-warning msg)
                                                #f)))
  "`(parse-json-string str [:on-error func])` : similar to parse-json-file."
  (let ((res (parse-json-source** #f str)))
    (if (car res)
        (cdr res)
        (on-error (cdr res)))))

(define (json-write*! j indent)
  (define (write-with-seps* j start mid end)
    (let loop ((l j)
               (sep start))
      (if (null? l)
          (display end)
          (begin
            (display sep)
            (when (char=? (string-ref sep (- (length sep) 1)) #\newline)
              (let loop ((n indent))
                (when (> n 0)
                  (display "  ")
                  (loop (- n 1)))))
            (json-write*! (car l) (+ indent 1))
            (loop (cdr l) mid)))))
  (cond ((or (string? j)
             (number? j))
         (write j))
        ((symbol? j)
         (printf "\"~a\"" j))
        ((and (pair? j)
              (symbol? (car j)))
         (json-write*! (car j) (+ indent 1))
         (display ": ")
         (json-write*! (cdr j) (+ indent 1)))
        ((hash-table? j)
         (write-with-seps* (map values j) "{\n" ",\n" "}"))
        ((null? j) (display "null"))
        ((boolean? j)
         (display (if j "true" "false")))
        ((list? j)
         (cond ((null? j) (printf "[]"))
               ((every (λ (p)
                         (and (pair? p) (symbol? (car p))))
                       j)
                ;; alist
                ;; sort the keys, to make this reproducible/testable
                (write-with-seps* (sort! j
                                         (λ (a b)
                                           (symbol<? (car a) (car b))))
                                  "{\n" ",\n" "}"))
               (else (write-with-seps* j "[\n" ",\n" "]"))))
        ((vector? j)
         (write-with-seps* (vector->list j) "[\n" ",\n" "]"))
        (else
         (eprintf "json-write!: unexpected object type ~s; giving it a go...~%" j)
         (display j))))

(define/provide (json-write! j)
  #"""`(json-write! sexp)` : write the sexp as JSON, to the `(current-output-port)`.

  Mapping to output:
    * numbers are written as JSON numbers
    * strings and symbols are written as JSON strings
    * hash-tables and alists are written as JSON objects
    * non-empty lists, and vectors, are written as JSON lists
    * `#f`, `#t`, and `()` are written as JSON `false`, `true`, and `null`, respectively.

  Because multiple Scheme structures are written to the small range of
  JSON types, it's not possible in general to round-trip structures via JSON."""
  (json-write*! j 1)
  #<unspecified>)