;; Test Unicode support at the Scheme level,
;; complementing lower-level support in test-unicode.c.
;;
;; 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" 'unicode)

(print-warning 'push #f)

;; Note: in the tests below we are depending on the fact that
;; s7 Does The Right Thing when it comes to strings which are (as
;; here) encoded in UTF-8 in the source file.  We could be more
;; careful about this, and carefully assemble byte-vectors in all
;; cases, rather than just the cases where we want to construct
;; invalid encodings.  But we can get away with it just now.
;;
;; This tests the functions in the unicode module (see unicode.scm),
;; which are rather low-level functions for reading codepoints from
;; files.  There are also what are effectively unicode tests in
;; test-misc.scm, covering character classes, and case-folding.

(cond ((*beastie* 'icu-version-string)
       => (λ (icu)
            (printf "  (with ICU ~a)~%" icu)))
      (else
       (printf "  (without ICU)~%")))

(test-suite
 "simple decoding"

 (assert-equal (unicode-decode/utf8 "abçdé") #"abçdé")
 ;; dodgy UTF8:
 ;; ...invalid characters
 (assert-equal (unicode-decode/utf8 (byte-vector->string #u(#x41 #xff #x42)))
               #"A�B")
 ;; the following is basically just
 ;; (assert-equal (unicode-decode/utf8
 ;;                (byte-vector->string #u(#xc3 #xa9             ;"é"
 ;;                                             #xe0 #x80 #xaf)))     ;overlong 'P'
 ;;               '(#xe9 #xfffd))          ; "é�"
 ;; but the ICU decoder ends up (legitimately) producing three
 ;; replacement-characters, though my non-ICU version (legitimately)
 ;; produces only one.
 (let ((l (unicode-decode/utf8
           (byte-vector->string #u(#xc3 #xa9                ;"é"
                                        #xe0 #x80 #xaf))))) ;overlong 'P'
   (assert-equal (ustring-ref l 0) #xe9)
   (assert-equal (ustring-ref l 1) #xfffd))

 ;; ...embedded within otherwise good UTF-8
 (assert-equal (unicode-decode/utf8
                (byte-vector->string #u(#x61
                                        #xc3 #xa9 ;é
                                        #xff      ;invalid
                                        #xc3 #xbc ;ü
                                        #x62)))
               #"aé�üb")

 (define (read-utf8-from-port p)
   (let loop ((c0 (unicode-decode1/port/utf8 p))
              (res '()))
     (if (eof-object? c0)
         (reverse res)
         (loop (unicode-decode1/port/utf8 p) (cons c0 res)))))
 (assert-equal
  (call-with-input-string "aé日𐀀"       ;require 0/1/2/3 UTF-8 bytes
    read-utf8-from-port)
  '(#x61 #xe9 #x65e5 #x10000))
 (assert-equal
  (call-with-input-string
      (byte-vector->string #u(#x41 #xc3 #x42 #x43 #x44 #x45)) ;garbled UTF-8, incomplete
    read-utf8-from-port)
  '(#x41 #xfffd #x45))
 (assert-equal
  (call-with-input-string
      (byte-vector->string #u(#x41 #xc3)) ;garbled UTF-8, early EOF
    read-utf8-from-port)
  '(#x41)))

(test-suite
 "simple encoding"
 (assert-equal (unicode-encode/utf8 '(97 98 231 100 233)) "abçdé")
 (assert-equal (unicode-encode/utf8 '(#\a #\b 231 #\d 233)) "abçdé") ;integers or chars
 (assert-equal (unicode-encode1/utf8 97) "a")
 (assert-equal (unicode-encode1/utf8 #\a) "a")
 ;; same, but with an iterator argument
 (assert-equal (unicode-encode/utf8 (make-iterator '(97 98 231 100 233))) "abçdé"))

(define (drain-unicode-reader r)
  (let loop ()
    (let ((cp (r)))
      (if (eof-object? cp)
          '()
          (cons cp (loop))))))
(test-suite
 "unicode-reader"
 (let ((ur (make-unicode-reader/string "aéb")))
   (assert-true (unicode-reader? ur))
   (assert-equal (unicode-reader-source ur) "\"aéb\"")
   (assert-exception :tag wrong-type-arg
                     :body (unicode-reader-source "hello"))

   (assert-equal (unicode-reader-location ur) "\"aéb\"[0]")
   (assert-equal (ur 'location) "\"aéb\"[0]")
   (assert-exception :tag wrong-type-arg
                     :body (ur 'wibble))

   (let ((r2 (make-unicode-reader/string "aéb")))
     (assert-true (unicode-reader? r2))
     (assert-true (equal? ur r2))
     (assert-true (equal? r2 ur))
     (assert-true (equivalent? ur r2))
     (assert-true (equivalent? r2 ur))
     (r2)
     ;; no longer equal, but still equivalent
     (assert-true  (equivalent? ur r2))
     (assert-false (equal? ur r2)))

   (assert-equal (drain-unicode-reader ur)
                 '(97 233 98)))
 ;; we can also use this as an argument to unicode-reader-read
 (let ((r (make-unicode-reader/string "aéb")))
   (assert-equal (let loop ((cp (unicode-reader-read r)))
                   (if (eof-object? cp)
                       '()
                       (cons cp (loop (unicode-reader-read r)))))
                 '(97 233 98)))

 ;; and again, with :ascii-characters?
 (let ((ur (make-unicode-reader/string "aéb" :ascii-characters? #t)))
   (assert-equal (drain-unicode-reader ur)
                 '(#\a 233 #\b)))

 (let ((fn "tmp-unicode-read.txt"))
   (with-output-to-temporary-file fn
     (λ ()
       (printf "abçdé~%f~%")))
   (let ((ur (make-unicode-reader/file fn)))
     (assert-equal (unicode-reader-source ur) fn)
     (assert-equal (unicode-reader-location ur) (sprintf "~a:1" fn))
     (assert-equal (drain-unicode-reader ur)
                   '(97 98 231 100 233 10 102 10))
     ;; now on line 3
     (assert-equal (unicode-reader-location ur) (sprintf "~a:3" fn)))

   (let ((ur (make-unicode-reader/file fn :ascii-characters? #t)))
     (assert-equal (drain-unicode-reader ur)
                   '(#\a #\b 231 #\d 233 #\newline #\f #\newline))))

 ;; bad input, as above
 (assert-equal (drain-unicode-reader
                (make-unicode-reader/string
                 (byte-vector->string #u(#x41 #xff #x42))))
               '(#x41 #xfffd #x42))
 ;; (and see above for why we are using (take l 2))
 (let ((l (drain-unicode-reader
                (make-unicode-reader/string
                 (byte-vector->string #u(#xc3 #xa9          ;"é"
                                         #xe0 #x80 #xaf)))))) ;overlong 'P'
   (assert-equal (take l 2) '(#xe9 #xfffd)))
 (assert-equal (drain-unicode-reader
                (make-unicode-reader/string
                 (byte-vector->string #u(#xc3 #xa9 ;"é"
                                         #xc3)))) ;only one part of two-byte sequence
               '(#xe9 #xfffd))

 (let ((sa (make-unicode-reader/string "a"))
       (f1 (make-unicode-reader/file "bib-t01-simple.bib")))
   (assert-false (equivalent? sa
                                               (make-unicode-reader/string "b")))
   (assert-true  (equivalent? sa
                                               (make-unicode-reader/string "a")))
   (assert-false (equivalent? sa f1))
   (assert-false (equivalent? f1 sa)) ;args in opposite order
   (assert-true  (equivalent? f1
                                               (make-unicode-reader/file "./../test/bib-t01-simple.bib")))
   (assert-false (equivalent? f1
                                               (make-unicode-reader/file "bib-t02-strings.bib")))

   ;; the following two should throw no errors
   (assert-false (equivalent? f1 "foo"))
   (assert-false (equivalent? "foo" f1))
   ;; these are equal strings, but neither is a reader
   (assert-true (equivalent? "foo" "foo"))

   ;; non-existing file
   (assert-exception (make-unicode-reader/file "not-a-file"))))

(test-suite
 "ustring"
 (let ((us (make-ustring)))
   (assert-true (ustring? us))
   (assert-equal (ustring-length us) 0)

   (for-each (λ (c)
               (ustring-append! us c))
             '(#\a
               #xe9                     ;é
               #x0621                   ;ARABIC LETTER HAMZA
               #x10000)) ;LINEAR B SYLLABLE B008 A (requires two units in UTF-16)

   (assert-equal (ustring-length us) 4)
   ;; various ways to write
   (assert-equal (object->string us) "#\"aéء𐀀\"")
   (assert-equal (object->string us :readable) "#\"aéء𐀀\"")
   (assert-equal (object->string us :display) "aéء𐀀")
   (assert-equal (object->string us #t) "#\"aéء𐀀\"")
   (assert-equal (object->string us #f) "aéء𐀀")
   (assert-equal (ustring->string us) "#\"aéء𐀀\"")
   (assert-equal (ustring->string us :display) "aéء𐀀")
   (assert-equal (ustring->symbol us) 'aéء𐀀)
   (assert-equal (with-output-to-string
                   (λ ()
                     (display us)))
                 "aéء𐀀")
   (assert-equal (with-output-to-string
                   (λ ()
                     (write us)))
                 "#\"aéء𐀀\"")
   (assert-equal (sprintf "~s -> ~a" us us) "#\"aéء𐀀\" -> aéء𐀀")

   (assert-equal (symbol->ustring 'foo) #"foo")

   (assert-equal (ustring-ref us 0) #x61)
   (assert-equal (ustring-ref us 1) #xe9)
   (assert-equal (ustring-ref us 2) #x0621)
   (assert-equal (ustring-ref us 3) #x10000)
   (assert-exception :tag out-of-range
                     :body (ustring-ref us 4))
   (assert-exception :tag out-of-range
                     :body (ustring-ref us -1))

   ;; similarly/alternatively
   (assert-equal (us 0) #x61)
   (assert-equal (us 3) #x10000))

 ;; equality
 (assert-true  (ustring=? #"abc" #"abc"))
 (assert-false (ustring=? #"abc" #"abcd"))
 (assert-false (ustring=? #"abcd" #"abc"))
 (assert-true  (ustring=? #"" #""))
 (assert-false (ustring=? #"abc" 1))       ;without error
 (assert-true  (ustring=? #"abc" "abc"))   ;converts plain strings
 (assert-true  (ustring=? "abc" #"abc"))   ;...both ways
 (assert-false (ustring=? #"a�b" #"a���b"))

 ;; ustring=? is equivalent to equal?
 ;; (this test is redundant, since the correct result is repeatedly assumed below)
 (assert-true  (equal? #"abc" #"abc"))
 (assert-false (equal? #"abc" #"abcd"))

 ;; substrings
 (let ((us #"01234567"))
   (assert-equal (ustring-substring us 0) #"01234567")
   (assert-equal (ustring-substring us 0 #f) #"01234567")
   (assert-equal (ustring-substring us 0 4) #"0123")
   (assert-equal (ustring-substring us 4) #"4567")
   (assert-equal (ustring-substring us 4 6) #"45")
   (assert-equal (ustring-substring us 4 8) #"4567")

   (assert-exception :tag wrong-type-arg
                     :body (ustring-substring us 4 'end))
   (assert-exception :tag wrong-type-arg
                     :body (ustring-substring us 4 3)))

 (let ((us #"aé𐀀a"))                    ;includes character outside BMP
   (assert-equal (ustring-substring us 0) #"aé𐀀a")
   (assert-equal (ustring-substring us 0 2) #"aé")
   (assert-equal (ustring-substring us 2 3) #"𐀀")
   (assert-equal (ustring-substring us 2 #f) #"𐀀a"))

 (let ((us (ustring-append #\a #\b #\c))
       (us0 (make-ustring)))
   (assert-true  (= (ustring->hash us) (ustring->hash #"abc")))
   (assert-false (= (ustring->hash us) (ustring->hash #"abcd")))
   (assert-false (= (ustring->hash us) (ustring->hash us0)))
   (assert-true  (= (ustring->hash us0) (ustring->hash #""))))
 (if (*beastie* 'icu-version)
     (let ((initial-language (unicode-get-locale #f 'language)))
       ;; we'd quite like to test that this name is #"en", but that
       ;; would make the test dependent on the system's default locale.
       (assert-true (ustring? initial-language))

       ;; language-dependent sorting: this is the example
       ;; illustrated in https://www.unicode.org/reports/tr10/
       (let ((initial-locale (unicode-set-locale! "de")))
         (assert-true (ustring<? #"öog" #"zog"))
         (unicode-set-locale! "sv")
         (assert-false (ustring<? #"öog" #"zog"))

         (let ((locales (unicode-get-locales))) ;list of available locales
           (assert-true (list? locales))
           (assert-true (string? (car locales))))

         (let ((locale-alist (unicode-get-locale)))
           ;; should be ((name . #"locale-name") ...),
           ;; relating to the currently-preferred locale, 'sv'
           (assert-true (list? locale-alist))
           (assert-true (symbol? (caar locale-alist)))
           (assert-true (ustring? (cdar locale-alist)))
           (assert-equal (assq 'language locale-alist)
                         '(language . #"sv")))
         (let ((locale-alist (unicode-get-locale #f)))
           ;; should be the same
           (assert-true (list? locale-alist))
           (assert-true (symbol? (caar locale-alist)))
           (assert-true (ustring? (cdar locale-alist)))
           (assert-equal (assq 'language locale-alist)
                         '(language . #"sv")))
         (let ((locale-alist (unicode-get-locale "en")))
           ;; should be for english
           (assert-true (list? locale-alist))
           (assert-true (symbol? (caar locale-alist)))
           (assert-true (ustring? (cdar locale-alist)))
           (assert-equal (assq 'display-language locale-alist)
                         '(display-language . #"English")))
         (let ((locale-name (unicode-get-locale "en" 'name)))
           (assert-equal locale-name #"en"))
         (let ((locale-name (unicode-get-locale #f 'name)))
           (assert-equal locale-name #"sv"))

         ;; tidy up -- reset to the initial state,
         (unicode-set-locale! initial-locale)
         ;; and confirm
         (assert-equal (unicode-get-locale #f 'language)
                       initial-language)))
     (begin
       ;; the flag isn't implemented in the ICU case
       (assert-true  (ustring=? #"a�b" #"a���b" :collapse-replacements))

       (assert-true (null? (unicode-get-locale)))
       (assert-true (null? (unicode-get-locale "en")))
       (assert-false (unicode-get-locale "en" 'name))))

 (assert-true (ustring<? #"a" #"b"))
 (assert-false (ustring<? #"b" #"a"))
 (assert-false (ustring<? #"a" #"a"))

 (assert-equal (ustring-index #"abc" #\a) 0)
 (assert-equal (ustring-index #"abc" #x62) 1)
 (assert-equal (ustring-index #"abc" #\x) #f)
 (assert-equal (ustring-index #"abcabc" #\a :start 2) 3)
 (assert-equal (ustring-index #"abcdef" #\d :end 2) #f)
 (assert-equal (ustring-index #"" #\a) #f) ;and no error
 ;; the range of both :start and :end is 0..len
 (assert-equal (ustring-index #"abc" #\a :start 0) 0)
 (assert-equal (ustring-index #"abc" #\c :start 3) #f)
 (assert-equal (ustring-index #"abc" #\c :end 0) #f)
 (assert-equal (ustring-index #"abc" #\c :end 3) 2)
 (assert-exception :tag out-of-range
                   :body (ustring-index #"abc" #\a :start 4))
 (assert-exception :tag out-of-range
                   :body (ustring-index #"abc" #\a :end 4))
 (assert-exception :tag out-of-range
                   :body (ustring-index #"abc" #\a :start -1))
 (assert-exception :tag out-of-range
                   :body (ustring-index #"abc" #\a :end -1))
 (assert-exception :tag wrong-type-arg
                   :body (ustring-index "hello" #\h))
 (assert-exception :tag wrong-type-arg
                   :body (ustring-index #"abc" "c"))
 (assert-exception :tag wrong-type-arg
                   :body (ustring-index #"abc" #\c :start #f))
 (assert-exception :tag wrong-type-arg
                   :body (ustring-index #"abc" #\c :start 'start))

 ;; ustring-index with a procedure
 (assert-equal (ustring-index #"abc" (λ (ch) (= ch #x62)))
               1)
 (assert-equal (ustring-index #"abcabc" (λ (ch) (= ch #x62)) :start 2)
               4)
 (assert-equal (ustring-index #"abcabc" (λ (ch) (= ch #x62)) :start 4) ;start at the char
               4)
 (assert-equal (ustring-index #"abcdef" (λ (ch) (= ch #x65)) :end 3)
               #f)
 (assert-equal (ustring-index #"abcdef" (λ (ch) (= ch #x65)) :end 4) ;end not included
               #f)
 (assert-equal (ustring-index #"abc" (λ (ch) (= ch #x70)))
               #f)

 (assert-equal (ustring-split #"one:two:three" #\:)
               '(#"one" #"two" #"three"))
 (assert-equal (ustring-split #"one:two-three" "-:")
               '(#"one" #"two" #"three"))
 (assert-equal (ustring-split #"" ":")
               '())
 (assert-equal (ustring-split #"one:" #\:)
               '(#"one" #""))
 (assert-equal (ustring-split #":one" #\:)
               '(#"" #"one"))
 (assert-equal (ustring-split '(#x61 #x2d #x62) #\-)
               '(#"a" #"b"))

 (assert-equal (ustring-tokenize #"one    two three")
               '(#"one" #"two" #"three"))
 (assert-equal (ustring-tokenize #"   one ")
               '(#"one"))
 (assert-equal (ustring-tokenize #"")
               '())
 (assert-equal (ustring-tokenize #"   ")
               '())

 (let ((us (make-ustring "abc"))
       (us2 (make-ustring #x61 #\b "c")))
   (assert-equal us us2)

   (assert-equal (ustring-append! us "def" us2 #xe9 #\a) #"abcdefabcéa")
   (assert-equal us #"abcdefabcéa"))     ;ustring us has changed
                                        ;(assert-equal (object->string us) "abcdefabcéa")

 ;; test ustring-iterator support
 (assert-equal (map list #"aé𐀀z")
               '((#x61) (#xe9) (#x10000) (#x7a)))
 (assert-equal (map values #"") '())

 (let ((us (make-ustring)))
   ;; appending lists
   (ustring-append! us #\a '(#\b (#\c #\d) #\e) '(#\f) '())
   (assert-equal (object->string us :display) "abcdef"))
 (let ((us (make-ustring "x")))
   ;; it's OK to have no arguments to append
   (assert-equal (ustring-append! us) us)
   (assert-equal us #"x"))              ;unchanged

 (let ((us (make-ustring "foo")))
   (assert-equal (ustring-append us "bar") #"foobar")
   (assert-equal us #"foo"))            ;ustring us has not changed
 ;; ustring-append is an alternative way of creating ustrings,
 ;; since the first argument doesn't have to be a ustring
 (assert-equal (ustring-append "foo" #"bar" #\a #xe9 '(#"end")) #"foobaraéend")
 ;; OK with a single argument
 (assert-equal (ustring-append "foo") #"foo")

 ;; mappings (more commentary about these characters in test-unicode.c)
 (let ((us (make-ustring "aA"
                         "["            ;non-letter
                         "éÉ"
                         #x01c4 #x01c5 #x01c6)))
   (assert-equal (map values (ustring-uppercase! us))
                 '(#x41 #x41 #x5b #xc9 #xc9 #x01c4 #x01c4 #x01c4))
   (assert-equal (map values us)        ;confirm the original string has been changed
                 '(#x41 #x41 #x5b #xc9 #xc9 #x01c4 #x01c4 #x01c4))
   (assert-equal (map values (ustring-lowercase! us))
                 '(#x61 #x61 #x5b #xe9 #xe9 #x01c6 #x01c6 #x01c6))
   (assert-equal (map values (ustring-titlecase! us))
                 '(#x41 #x41 #x5b #xc9 #xc9 #x01c5 #x01c5 #x01c5)))

 ;; test the #"..." reader procedure
 (let ((u1 (make-ustring "abc"))
       (u2 #"abc"))
   (assert-equal u1 u2)
   (assert-equal (ustring-length u1) 3))
 (let ((u1 #"abé"))
   (assert-equal u1 (make-ustring "abé"))
   (assert-equal (ustring-length u1) 3)) ;not 4

 (assert-equal (ustring-length #"") 0)
 (assert-equal (make-ustring "") #"")
 (assert-equal (ustring->string #"") "#\"\"")
 (assert-equal (ustring->string #"" :display) "")

 ;; space edge-cases
 (assert-equal #" " (make-ustring " "))
 (assert-equal #" x " (make-ustring " x "))
 (assert-equal (ustring-length #"") 0)

 ;; unicode in the string is fine, obviously,
 ;; in both the make-ustring and #"..." forms
 (let ((us1 (make-ustring "abé twö"))
       (us2 #"abé twö"))
   (assert-equal (map values us1)
                 '(#x61 #x62 #xe9 #x20
                        #x74 #x77 #xf6))
   (assert-equal (map values us2)
                 '(#x61 #x62 #xe9 #x20
                        #x74 #x77 #xf6))
   (assert-equal us1 us2))

 ;; escapes
 ;; the #"..." form includes escapes \\, \" and \n,
 ;; with all others being ignored with a warning
 (assert-equal (map values #"a\\b]c\nd\"e\xf")
               (map char->integer
                    '(#\a #\\ #\b #\]
                      #\c #\newline
                      #\d #\"
                      #\e               ;\x ignored
                      #\f)))
 ;; When reading using make-ustring, on the other hand, the string
 ;; being converted is a normal string, which should have the same escapes
 (let ((us (make-ustring "a\\b]c\nd\"e")))
   (assert-equal (map values us)
                 '(#x61 #x5c
                   #x62 #x5d
                   #x63 #x0a
                   #x64 #x22
                   #x65))
   (assert-equal (object->string us)  ; Also test the write form, here
                 "#\"a\\\\b]c\\nd\\\"e\""))

 (assert-equal (with-input-from-string "#\"tab\\tignored\"" read)
               #"tabignored")

 ;; The following cases are rather pathological,
 ;; and test non-changingness of an earlier version of the reader,
 ;; which returned the string-so-far on EOF.  I now think it's better
 ;; to fail with an exception in this case.
 ;; (though really, the result matters less than not failing)
 ;; (assert-equal (with-input-from-string
 ;;                   "#\"hello" ;unfinished at end of input
 ;;                 read)
 ;;               #"hello")
 ;; (assert-equal (with-input-from-string
 ;;                   "#"hello\\)" ;')' is a delimiter
 ;;                 read)
 ;;               #"hello")
 ;; (assert-equal (with-input-from-string
 ;;                   "#"hello there\\" ;unfinished escape ignored
 ;;                 read)
 ;;               #"hello there")

 ;; ustring cache
 (let ((u #"hello"))
   (assert-false (ustring-cache-get* u 'k1))
   (assert-equal (ustring-cache-set!* u 'k1 "v1") "v1") ;set, and should return the thing set
   (assert-equal (ustring-cache-get* u 'k1) "v1")
   (assert-false (ustring-cache-get* u 'k2))

   (ustring-cache-set!* u 'k1 "v1a")
   (ustring-cache-set!* u 'k2 99)
   (assert-equal (ustring-cache-get* u 'k1) "v1a")
   (assert-equal (ustring-cache-get* u 'k2) 99)

   ;; any change to the ustring should invalidate the cache
   (ustring-append! u ", world")
   (assert-false (ustring-cache-get* u 'k1))
   (assert-false (ustring-cache-get* u 'k2))

   (ustring-cache-set!* u 'k1 "v1")
   (ustring-uppercase! u)
   (assert-equal u #"HELLO, WORLD")
   (assert-false (ustring-cache-get* u 'k1))

   (ustring-cache-set!* u 'k1 "v1")
   (ustring-lowercase! u)
   (assert-equal u #"hello, world")
   (assert-false (ustring-cache-get* u 'k1))

   (ustring-cache-set!* u 'k1 "v1")
   (assert-equal (ustring-uppercase u) #"HELLO, WORLD") ;new ustring
   (assert-equal (ustring-cache-get* u 'k1) "v1")

   ;; wrong argument error
   (assert-exception :tag wrong-type-arg
                     :body (ustring-cache-set!* u "string" "value"))))

(exit/failures)