;; 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

(module "s7unit.scm" 'json)

(print-warning 'push #f)

(test-suite
 "JSON parsing"

 ;; The tests here confirm that valid JSON will parse correctly;
 ;; we don't (yet) try terribly hard to deal with pathologically invalid input.
 ;;
 ;; Indeed, we (now) reject with anything that isn't
 ;; strictly valid according to RFC 8259.
 ;; See the test-suite at <https://github.com/nst/JSONTestSuite>.

 (let ((j (parse-json-string
           #"""{ "one": 1,
                 "two": [2, "three", true, false, null],
                 "three": {},
                 "four": []}""")))
   (assert-equal (j 'one) 1.0)
   (assert-equal (j 'two) '(2.0 #"three" #t #f ()))
   (let ((j3 (j 'three)))
     (assert-true (hash-table? j3))
     (assert-equal (hash-table-entries j3) 0))
   (assert-equal (j 'four) '()))

 ;; exercise the number possibilities
 (assert-equal (parse-json-string "[1, 2.5, -3e2, 4.096E+3, 125e-3]")
               '(1.0 2.5 -300.0 4096.0 0.125))

 ;; ...and strings
 (assert-equal (parse-json-string "\"\"") #"")
 ;; unterminated string (invalid JSON – fail)
 (assert-equal (parse-json-string "\"foo") #f)

 ;; ...boolean and case details
 (assert-equal (parse-json-string "true") #t)
 (assert-equal (parse-json-string "false"
                                  :on-error (λ (msg) 'no))
               #f)
 ;; keywords are case sensitive: uppercase forbidden
 (assert-equal (parse-json-string "TRUE"
                                  :on-error (λ (msg) 'no))
               'no)
 (assert-equal (parse-json-string "FALSE"
                                  :on-error (λ (msg) 'no))
               'no)
 (assert-equal (parse-json-string "NULL"
                                  :on-error (λ (msg) 'no))
               'no)

 ;; The following is hard to write the test-case for!
 ;;(assert-equal (parse-json-string "\"a\\\"b\\\\c\\/d\\be\\ff\\ng\\rh\\t\\u0041i\\u2262j\"") "foo")
 (assert-equal (parse-json-string "\"a\\\"b\\\"\\\\c\\/d\\t\\u0041i\\u2262j\"")
               #"a\"b\"\\c/d	Ai≢j")
 (assert-equal (parse-json-string "\"\\u00410\"") #"A0") ;\u should be maximum 4 characters
 ;;(assert-equal (parse-json-string "\"\\u41\"") #"A") ;short \u escape
 (assert-equal (parse-json-string "\"\\u41\"") #f) ;currently an error
 (assert-equal (parse-json-string "\"a\\xb\"") #f) ;bad escape, \x
 (assert-equal (parse-json-string "\"\\U00410\"") #f) ;\U is not a synonym for \u

 ;; the example of non-BMP characters, in RFC 8259, is the G-clef, U+1d11e
 ;; (and confirm mixed case is OK for the escape)
 (assert-equal (parse-json-string "\"a\\ud834\\uDD1Eb\"") #"a𝄞b")
 ;; Note that we _can't_ play edge-case games where we put a \u escape
 ;; for a high-surrogate before an actual low-surrogate, because the
 ;; input string is specified to be in UTF-8, where no surrogates of
 ;; any type can appear.

 ;; surrogates wrong way round
 (assert-equal (parse-json-string "\"a\\udd1e\\ud834b\"") #f)
 ;; high surrogate not followed by low
 (assert-equal (parse-json-string "\"a\\ud834bc\"") #f)

 ;; it's OK to have Unicode in strings
 (assert-equal (parse-json-string "\"aéb\"") #"aéb")

 ;; a JSON string must contain one and only one value
 (assert-equal (parse-json-string "") #f)
 (assert-equal (parse-json-string "123 \"foo\"") #f)

 ;; alternative error behaviour
 (assert-equal (parse-json-string "\"foo" :on-error (λ (msg)
                                                      'boo))
               'boo)
 ;; the following tests a slightly different code path
 (assert-equal (parse-json-string "" :on-error (λ (msg)
                                                 'boo))
               'boo))

(test-suite
 "JSON edge cases"
 ;; these tests are fairly unexpected cases, several of which are drawn from
 ;; https://github.com/nst/JSONTestSuite, which is referenced by
 ;; http://seriot.ch/parsing_json.php
 ;; a zero-length string as key is legal JSON, but we special-case this
 (assert-equal (parse-json-string "{\"\": 0}") (hash-table '_ 0.0))
 ;; characters that must be escaped: RFC, Sect.7:
 ;;
 ;;   All Unicode characters may be placed within the
 ;;   quotation marks, except for the characters that MUST be escaped:
 ;;   quotation mark, reverse solidus, and the control characters (U+0000
 ;;   through U+001F).
 (assert-false (parse-json-string "[\"new\nline\"]")) ;control characters
 (assert-false (parse-json-string "[\"literal	tab\"]"))
 (assert-false (parse-json-string "\"\\x\"")) ;backslash (when not acting as escape)
 )

(test-suite
 "JSON writing"
 ;; we test JSON writing by whether it can be parsed by parse-json-string
 (let ((json (with-output-to-string
               (λ ()
                 ;; the alist and hashes here are single-entry,
                 ;; so they sort trivially (for ease of testing)
                 (json-write! (list 1.0 "a\\b" 'c #t #f '()
                                    '((alist-1 . v1))
                                    #(1 2)
                                    (hash-table 'a (hash-table 'b #t))))))))
   ;(eprintf "json=~s~%" json)
   (assert-equal (parse-json-string json)
                 `(1.0 #"a\\b" #"c" #t #f ()
                       ,(hash-table 'alist-1 #"v1")
                       (1.0 2.0)
                       ,(hash-table 'a (hash-table 'b #t))))))