;; This file is part of Beastie <https://purl.org/nxg/dist/beastie>
;; SPDX-FileCopyrightText: 2023 Norman Gray <https://nxg.me.uk>
;; SPDX-License-Identifier: BSD-2-Clause

(module "s7unit.scm" 'bibtex 'xexpr 'unicode)

(print-warning 'push #f)

;; We don't care about the ordering of the keys in the output JSON,
;; but it seems to be unstable, so hard to check, unless we add an
;; otherwise-redundant sort! in write-json!.  So skip the check
;; (test-suite
;;  "JSON"
;;  (assert-equal (bibtex-to-json
;;                 (list (make-bibtex-entry 'book 'key2
;;                                    '((author . "Another Author")
;;                                      (year . 2000)))
;;                       (make-bibtex-entry 'article 'key
;;                                    '((year . 1999)))))
;;                ;; we don't care about the ordering below
;;                "[{\"type\": \"book\",\n  \"key\": \"key2\",\n  \"fields\": {\"year\": 2000,\n  \"author\": \"Another Author\"}},\n  {\"type\": \"article\",\n  \"key\": \"key\",\n  \"fields\": {\"year\": 1999}}]") )

(test-suite
 "citation selection"
 (let ((entry-list
        (sort!
         (map cdr
              (parse-bibtex-string
               "@book{key2, author={Another Author}, year={2000}} @article{key1, year={1999}}"))
         entry<?)))
   (assert-equal (map entry-key (filter-entries entry-list 'all))
                 '(key1 key2))
   (assert-equal (map entry-key (filter-entries entry-list '(key2)))
                 '(key2))
   (assert-equal (filter-entries entry-list '()) '())))

(test-suite
 "regular expressions"

 (let ((r1 (regexp "[0-9]+"))
       (r2 (regexp "[0-9]+"))
       (r3 (regexp "[a-z]+")))
   (assert-true (regexp? r1))
   (assert-true (regexp=? r1 r2))
   (assert-false (regexp=? r1 r3))
   (assert-true (equal? r1 r2))
   (assert-false (equal? r1 r3))

   (assert-equal (regexp-match? r1 "abc123def") #t)
   (assert-equal (regexp-match? r1 "abc") #f)
   (assert-true  (regexp-match? r1 "123" :start 2))
   (assert-false (regexp-match? r1 "123" :start 3))

   (assert-equal (regexp-match-positions r1 "abc123def") '((3 . 6)))
   (assert-false (regexp-match-positions r1 "abc123def" 6))
   (assert-false (regexp-match-positions r1 "abc"))

   (assert-equal (regexp-match-positions r1 "123" 2) '((2 . 3))) ;start at the end of the string
   (assert-false (regexp-match-positions r1 "123" 3)) ;start just past the end of the string
   ;; the following have been errors, in the past, but I think
   ;; returning #f makes more sense (and matches Racket)
   (assert-false (regexp-match-positions r1 "123" :start 99)) ;start well past the end of the string

   (assert-exception (regexp-match-positions r1 "123" :start -1))

   (assert-equal (regexp-match r1 "abc123def") '("123"))
   (assert-equal (regexp-match r1 "abc123def" :start 6) #f))

 ;; empty regexps
 (let ((r (regexp "")))
   (assert-true (regexp? r))
   (assert-true (regexp-match? r "foo"))
   (assert-equal (regexp-match r "foo") '(""))
   (assert-equal (regexp-match-positions r "foo") '((0 . 0))))

 ;; matching subexpressions
 (let ((r (regexp "([a-z]([0-9]+)).")))
   (assert-equal (regexp-match-positions r "abc10xy")
                 '((2 . 6)              ;matches c10x -- whole regexp
                   (2 . 5)              ;matches c10  -- first group
                   (3 . 5)))            ;matches 10   -- second group
   (assert-equal (regexp-match r "abc10xy")
                 '("c10x" "c10" "10")))

 ;; subexpressions which don't participate in the match
 (let ((r (regexp "[a-z]+([0-9]+)?-")))
   (assert-equal (regexp-match-positions r "a-") '((0 . 2) #f))
   (assert-equal (regexp-match r "a-") '("a-" #f))
   ;; again, with start offset
   (assert-equal (regexp-match-positions r "abc-" :start 1) '((1 . 4) #f))
   (assert-equal (regexp-match r "abc-" :start 1) '("bc-" #f)))

 ;; matching start-of-string
 (let ((r (regexp "^[a-z].*")))
   (assert-equal (regexp-match-positions r "ab12cd") '((0 . 6)))
   (assert-false (regexp-match-positions r "ab12cd" :start 2))
   (assert-equal (regexp-match-positions r "ab12cd" :start 4) '((4 . 6))))

 ;; ...and end-of-string
 (let ((r (regexp "[a-z]$")))
   (assert-equal (regexp-match-positions r "ab") '((1 . 2)))
   (assert-equal (regexp-match-positions r "a1") #f))

 ;; case insensitive
 (let ((r (regexp "[a-z]+" 'ignore-case)))
   (assert-equal (regexp-match-positions r "123abc") '((3 . 6)))
   (assert-equal (regexp-match-positions r "123ABC") '((3 . 6))))

 ;; start and end
 (let ((r (regexp "[a-z]+")))
   (assert-equal r (regexp-match-positions r "abcde") '((0 . 5)))
   (assert-equal r (regexp-match-positions r "abcde" :start 2) '((2 . 5))))

 ;; regexps as strings
 (assert-equal (regexp-match-positions "([a-z]+)" "123abc456") '((3 . 6) (3 . 6)))
 (assert-equal (regexp-match "([a-z]+)" "123abc456") '("abc" "abc"))
 (assert-true (regexp-match? "[a-z]+" "123abc456"))

 ;; newline processing
 (assert-equal (regexp-match-positions/multi ;string regexp argument
                "^[a-z]+" "abc\n123\ndef\n")
               '((0 . 3)))
 (assert-equal (regexp-match-positions/multi ;with 'newline flag: ^ matches multiple start-of-line
                (regexp "^[a-z]+" 'newline) "abc\n123\ndef\n")
               '((0 . 3) (8 . 11)))
 (assert-equal (regexp-match-positions/multi ;newline flag plus match-select
                (regexp "^([a-z])[a-z]*" 'newline)
                "abc\n123\ndef\n"
                :match-select cadr)     ;select only first submatch
               '((0 . 1) (8 . 9)))
 (assert-equal (regexp-match-positions/multi
                (regexp "a")
                "aaa")
               '((0 . 1) (1 . 2) (2 . 3)))

 ;; the next two are from the racket docs
 (assert-equal (regexp-match-positions/multi (regexp "x.") "12x4x6")
               '((2 . 4) (4 . 6)))
 (assert-equal (regexp-match-positions/multi (regexp "x*") "12x4x6")
               '((0 . 0) (1 . 1) (2 . 3) (3 . 3) (4 . 5) (5 . 5) (6 . 6)))
 (assert-equal (regexp-match-positions/multi
                (regexp "[^;]*")
                "one;two")
               '((0 . 3) (3 . 3) (4 . 7) (7 . 7)))
 (assert-equal (regexp-match-positions/multi ;includes zero-length matches
                (regexp "[^;]*")
                ";one;two; ;;five;")
               '((0 . 0)
                 (1 . 4) (4 . 4)
                 (5 . 8) (8 . 8)
                 (9 . 10) (10 . 10) (11 . 11)
                 (12 . 16) (16 . 16) (17 . 17)))

 ;; repeating (some of) the above, with string output rather than positions
 (assert-equal (regexp-match/multi           ;^ matches only at the beginning of the string
                "^[a-z]+" "abc\n123\ndef\n")
               '("abc"))
 (assert-equal (regexp-match/multi           ;with newline flag
                (regexp "^[a-z]+" 'newline) "abc\n123\ndef\n")
               '("abc" "def"))
 (assert-equal (regexp-match/multi
                (regexp "^([a-z])[a-z]*" 'newline)
                "abc\n123\ndef\n"
                :match-select cadr)     ;select only first submatch
               '("a" "d"))

 ;; These are from (or derived from) the Racket docs
 (let ((spaces (regexp " +")))
   (assert-equal (regexp-split spaces "123") ;no match
                 '("123"))
   (assert-equal (regexp-split spaces "12  34") ;final part length>1
                 '("12" "34"))
   (assert-equal (regexp-split spaces "1 2") ;final part of length=1
                 '("1" "2"))
   (assert-equal (regexp-split spaces "1 ") ;final part empty
                 '("1" ""))
   (assert-equal (regexp-split spaces " 1   2 ") ;starting with the separator
                 '("" "1" "2" ""))
   (assert-equal (regexp-split spaces "")
                 '("")))

 (assert-equal (regexp-split (regexp ".") "12  34")
               '("" "" "" "" "" "" ""))
 (assert-equal (regexp-split (regexp "") "12  34")
               '("" "1" "2" " " " " "3" "4" ""))
 (assert-equal (regexp-split (regexp " *") "12  34")
               '("" "1" "2" "" "3" "4" "")))

(test-suite
 "SRFI replacements"

 ;; these test cases are from SRFI-1
 (assert-equal (take '(a b c d e) 2) '(a b))
 (assert-equal (drop '(a b c d e) 2) '(c d e))
 (assert-equal (take-right '(a b c d e) 2) '(d e))
 (assert-equal (drop-right '(a b c d e) 2) '(a b c))
 ;; others are deductions
 (assert-equal (take '(a b c d e) 0) '())
 (assert-equal (drop '(a b c d e) 0) '(a b c d e))
 (assert-equal (take-right '(a b c d e) 0) '())
 (assert-equal (drop-right '(a b c d e) 0) '(a b c d e))
 (assert-exception (take '(a b c) 4))
 (assert-exception (drop '(a b c) 4))
 (assert-exception (take-right '(a b c) 4))
 (assert-exception (drop-right '(a b c) 4))
 (assert-exception (take '(a b c) -1))

 ;; fold:
 ;; The first few test cases are from SRFI-1.
 (assert-equal (fold + 0 '(1 2 3)) 6)   ; Add up the elements of LIS.
 (assert-equal (fold cons '() '(1 2 3)) '(3 2 1)) ; Reverse LIS.
 (assert-equal                          ; How many symbols in LIS?
  (fold (λ (x count)
          (if (symbol? x) (+ count 1) count))
        0
        '(a 1 "b" c 2 "d"))
  2)
 (assert-equal                  ; Length of the longest string in LIS:
  (fold (λ (s max-len)
          (max max-len (string-length s)))
        0
        '("one" "two" "three" "four"))
  5)
 (assert-equal (fold + 0 (make-iterator '(1 2 3))) 6) ;as above, but with explicit iterator
 (assert-equal                                        ;inlet has implicit iterator
  (fold (λ (x knil)
          (cons (car x) knil))
        '()
        (inlet 'a 1 'b 2))
  '(b a))

 ;; filter, with lists and with iterators
 (assert-equal (filter symbol? '(a 1 "b" c 2 "d")) '(a c))
 (assert-equal (filter symbol? (make-iterator '(a 1 "b" c 2 "d"))) '(a c))
 (assert-equal
  (filter (λ (p)
            (> (cdr p) 0))
          (inlet 'a 1 'b -2 'c 3 'd -4)) ;implicit iterator
  '((a . 1) (c . 3)))

 ;; any and every...
 (assert-equal (every integer? '()) #t)
 (assert-true (every integer? '(1 2 3)))
 (assert-false (every integer? '(1 x 3)))

 ;; again, with iterator
 (assert-true (every integer? (make-iterator '())))
 (assert-true (every integer? (make-iterator '(1 2 3))))
 (assert-false (every integer? (make-iterator '(1 a 3))))

 (assert-false (any integer? '()))
 (assert-false (any integer? (make-iterator '())))

 (assert-true (every char-lower? "abc")) ;uses iterator
 (assert-true (every char-lower? #"abc"))
 (assert-true (any char-lower? "abc"))
 (assert-true (any char-lower? #"abc"))
 (assert-exception :tag wrong-type-arg
                   :body (every char-lower? 1)) ;no iterator
 (assert-exception :tag wrong-type-arg
                   :body (any char-lower? 1))

 (let ((testpred (λ (x)                 ;returns truthy, other than #t
                   (and (integer? x)
                        (cons 'yes x)))))
   ;;check we return the last application
   (assert-equal (every testpred '(1 2 3))			'(yes . 3))
   (assert-equal (every testpred (make-iterator '(1 2 3)))	'(yes . 3))
   (assert-false (every testpred '(1 "string" 3)))

   (assert-equal (any testpred '(a 3 b 2.7))			'(yes . 3))
   (assert-equal (any testpred (make-iterator '(a 3 b 2.7)))	'(yes . 3))
   (assert-false (any testpred '(a 3.1 b 2.7))))

 (let ((positive? (λ (x) ;raises an error if the argument isn't a number
                    (> x 0))))
   ;; SRFI-1 doesn't say what should happen if the predicate raises an error:
   ;; we don't do anything special (like treat it as false),
   ;; but if we shouldn't get to that value in the list, then that should be fine.
   (assert-false (every positive? '(1 -1 a)))
   (assert-true (any positive? '(-1 1 a))))

 ;; other list procedures...
 (assert-equal (list (split-at '(a b c d e f g h) 3))
               '((a b c) (d e f g h)))
 (assert-equal (list (split-at '(a b c) 0))
               '(() (a b c)))
 (assert-equal (list (split-at '(a b c) 3))
               '((a b c) ()))
 (assert-exception (split-at '(a b c) 6))
 (assert-exception (split-at '(a b c) -1))

 (assert-equal (last '(a b c)) 'c)
 (assert-exception (last '()))
 (assert-equal (last-pair '(a b c)) '(c))
 (assert-equal (last-pair '(a)) '(a))
 (assert-exception (last-pair '()))

 (assert-equal (flatten '(1 (2 3 (4) 5) 6 ()))
               '(1 2 3 4 5 6))
 (assert-equal (flatten 1)
               '(1))
 (assert-equal (flatten '())
               '())

 (assert-equal (intersperse 'x '()) '())
 (assert-equal (intersperse 'x '(a b c)) '(a x b x c))

 (let ((c (circular-list 1 2 3)))
   (assert-false (null? c))
   (assert-equal (let loop ((cc c)
                            (res '())
                            (n 10))
                   (if (= n 0)
                       (reverse res)
                       (loop (cdr cc)
                             (cons (car cc) res)
                             (- n 1))))
                 '(1 2 3 1 2 3 1 2 3 1))
   (assert-equal (take c 5)
                 '(1 2 3 1 2)))

 (assert-equal (zip '(one two three)
                    '(1 2 3)
                    '(odd even odd even odd even odd even))
               '((one 1 odd) (two 2 even) (three 3 odd)))
 (assert-equal (zip '(1 2 3)) '((1) (2) (3)))
 (assert-equal (zip '(1 2 3 4) (circular-list #f #t))
               '((1 #f) (2 #t) (3 #f) (4 #t)))

 ;; string procedures (SRFI-13)...
 (assert-equal (string-index "abcabc" #\a) 0)
 (assert-false (string-index "abca" #\x))
 (assert-equal (string-index "abcabc" (λ (c) (char=? c #\c))) 2) ;predicate
 (assert-equal (string-index "abcabc" #\a :start 1) 3)           ;keyword arg
 (assert-false (string-index "abcabc" #\c :end 2))
 (assert-equal (string-index "abc" #\c) 2) ;last char in string
 (assert-equal (string-index-right "abcabc" #\a) 3)
 (assert-false (string-index-right "abca" #\x))
 (assert-equal (string-index-right "abcabc" (λ (c) (char=? c #\c))) 5) ;predicate
 (assert-false (string-index-right "abcabc" #\a :start 4)) ;#\a at start of specified range
 (assert-equal (string-index-right "abcabc" #\c :end 4) 2)
 (assert-equal (string-index-right "abc" #\a) 0)  ;at end of scan
 (assert-equal (string-index "a\nb" #\newline) 1) ;non-graphic char

 (assert-equal (string-index "a\nb" "\t\n") 1)    ;char-class
 (assert-equal (string-index-right "abcd" "cb") 2)

 (assert-equal (string-trim " abc") "abc")
 (assert-equal (string-trim "    ") "")
 (assert-equal (string-trim "") "")
 (let* ((abc "abc")
        (t (string-trim abc)))
   (assert-true (eq? t abc)))           ;same object

 (let* ((abc "abc")                     ;no trailing space
        (t (string-trim-right abc)))
   (assert-true (eq? t abc)))                      ;same object
 (assert-equal (string-trim-right "abc\n") "abc") ;one trailing space
 (assert-equal (string-trim-right "abc  ") "abc") ;multiple
 (assert-equal (string-trim-right "") "")
 (assert-equal (string-trim-right " \n\t") "")

 (assert-equal (string-trim-both " abc d   \t e  \nf  ") "abc d   \t e  \nf")
 (assert-equal (string-trim-both "\nabc\ndef\n") "abc\ndef")
 (assert-equal (string-trim-both " \n  abc  \n  def    \n") "abc  \n  def")
 (let* ((abc "abc")
        (t (string-trim-both abc)))
   (assert-true (eq? t abc)))           ;same object
 (assert-equal (string-trim-both "  \t") "")
 (assert-equal (string-trim-both "") "")

 (assert-equal (string-trim ",abc," ",") "abc,")
 (assert-equal (string-trim-right ",abc," (λ (c) (char=? c #\,))) ",abc")
 (assert-equal (string-trim-both ",abc," #\,) "abc")

 ;; string-split isn't actually a SRFI-13 function
 (assert-equal (string-split "one:two" #\:) '("one" "two"))
 (assert-equal (string-split "one:two:" #\:) '("one" "two" ""))
 (assert-equal (string-split "one" #\:) '("one"))
 (assert-equal (string-split ":one" #\:) '("" "one"))
 (assert-equal (string-split "" #\:) '())
 (assert-equal (string-split "one:two;three"
                             (λ (c)
                               (or (char=? c #\:) (char=? c #\;))))
               '("one" "two" "three"))
 (assert-equal (string-split "one:two;three" ";:")
               '("one" "two" "three"))
 (assert-equal (string-split "one:two::three" #\:)
               '("one" "two" "" "three"))
 ;; as opposed to...
 ;; (assert-equal (string-split "one two    \t  three" char-whitespace?)
 ;;               '("one" "two" "three"))

 ;; I briefly considered having string-split work with things other
 ;; than string? instances, but thought better of it
 (assert-exception :tag wrong-type-arg
                   :body (string-split #"one:two:three" #\:))

 (assert-equal (string-tokenize "one    two three")
               '("one" "two" "three"))
 (assert-equal (string-tokenize "   one ")
               '("one"))
 (assert-equal (string-tokenize "")
               '())
 (assert-equal (string-tokenize "   ")
               '())

 (assert-true  (string-prefix? "one" "one two"))
 (assert-false (string-prefix? "one" "two"))
 (assert-true  (string-prefix? "" "x")) ;not actually specified by SRFI-13
 (assert-false (string-prefix? "one" "o")) ;different code-path

 (assert-true  (string-suffix? "two" "one two"))
 (assert-false (string-suffix? "one" "one two"))
 (assert-true  (string-suffix? "" "one"))
 (assert-false (string-suffix? "one" "o"))

 (let ((l '("1" "2" "3")))
   (assert-equal (string-join l) "1 2 3")
   (assert-equal (string-join l ":") "1:2:3")
   (assert-equal (string-join l ":" 'infix) "1:2:3")
   (assert-equal (string-join l ":" 'prefix) ":1:2:3")
   (assert-equal (string-join l ":" 'suffix) "1:2:3:")
   (assert-equal (string-join l ":" 'strict-infix) "1:2:3")

 ;; test-cases from SRFI-13
 (assert-equal (string-join '()   ":" 'infix) ""))
 (assert-exception :tag beastie
                   :body (string-join '() ":" 'strict-infix))
 (assert-equal (string-join '("") ":") "")
 (assert-equal (string-join '()   ":" 'suffix) "")
 (assert-equal (string-join '("") ":" 'suffix) ":")
 (assert-equal (string-join '()   ":" 'prefix) "")
 (assert-equal (string-join '("") ":" 'prefix) ":")
)



(test-suite
 "path-manipulations"

 ;; I seem to have written a set of tests for explode path, but either
 ;; forgotten to write the function, or written and lost it.  Hmm...
 ;;
 (assert-equal (explode-path "one/two/three") '("one" "two" "three"))
 (assert-equal (explode-path "/one//two//three") '("/" "one" "two" "three"))
 (assert-equal (explode-path "one") '("one"))
 (assert-equal (explode-path "/one") '("/" "one"))
 (assert-equal (explode-path "////one") '("/" "one"))
 (assert-equal (explode-path "one//two/../three/.//four") '("one" "two" up "three" same "four"))

 (assert-equal (list (split-path "one/two/three")) '("one/two" "three" #f))
 (assert-equal (list (split-path "one/two/three/")) '("one/two" "three" #t))
 (assert-equal (list (split-path "/one/two/three/")) '("/one/two" "three" #t))
 ;; normalise by removing redundant separators
 ;; no... not implemented -- doesn't seem worth the effort
 ;(assert-equal (list (split-path "one//two//three")) '("one/two" "three" #f))

 (assert-equal (list (split-path "two")) '(relative "two" #f))

 ;; The behaviour here (meaning, in the Racket docs) is slightly
 ;; unexpected to me.  I'd have expected (split-path "/two") to
 ;; produce (#f "two" #f), since "/two" seems to be 'a' root
 ;; directory.  But no, further thought suggests that 'a root
 ;; directory' means "/" singular, and these docs are just carefully
 ;; equivocating between unix- and Windows-style FSs.
 (assert-equal (list (split-path "/two")) '("/" "two" #f))
 (assert-equal (list (split-path "/")) '(#f "/" #t)) ;...according to Racket

 (assert-equal (list (split-path "one/..")) '("one" up #f))
 (assert-equal (list (split-path "one/.")) '("one" same #f))
 (assert-equal (list (split-path "")) '(relative "" #f)) ;Racket objects to an invalid path

 (assert-equal (path-replace-extension "one/two.ext" ".new") "one/two.new")
 (assert-equal (path-replace-extension "one/two" ".new") "one/two.new")
 (assert-equal (path-replace-extension "one/.two" ".new") "one/.two.new")

 (assert-true  (absolute-path? "/one/two"))
 (assert-false (absolute-path? "one/two"))
 (assert-false (absolute-path? ""))

 (assert-false (relative-path? "/one/two"))
 (assert-true  (relative-path? "one/two"))
 (assert-true (relative-path? ""))

 (let ((cwd (current-directory)))
   (assert-equal (path->complete-path "/one/two") "/one/two")
   (assert-equal (path->complete-path "one/two") (string-append cwd "/one/two"))
   (assert-equal (path->complete-path "/one/two" "/other") "/one/two")
   (assert-equal (path->complete-path "one/two" "/other") "/other/one/two")
   (assert-exception (path->complete-path "one/two" "other")))

 (assert-equal (build-path "foo") "foo")
 (assert-equal (build-path "foo" "bar") "foo/bar")
 (assert-equal (build-path "/foo" 'same "bar" 'up "baz") "/foo/./bar/../baz"))

(test-suite
 "promises"
 (define n 0)
 (define p1
   (delay
     (set! n (+ n 1))
     (+ 2 3)))
 (assert-true (promise? p1))
 (assert-equal (force p1) 5)
 (assert-equal (force p1) 5)            ;should re-evaluate
 (assert-equal n 1)

 (assert-equal (force 'foo) 'foo))

(test-suite
 "structs"
 (let ()
   (struct s f1 (f2 :mutable))
   (assert-false (defined? 'set-s-f1!))
   (assert-true (defined? 'set-s-f2!))
   (let ((ts (make-s "v1" 2)))
     (assert-true (s? ts))
     (assert-false (s? 'wibble))
     (assert-false (s? #()))           ;empty vector -- shouldn't fail
     ;; the next is a vector with first argument the same as the
     ;; structure (which is what make-s produces)
     ;; -- this should fail: it shouldn't be possible to trick
     ;; the predicate with something that looks like the real thing
     (assert-false (s? #("s")))

     (assert-equal (s-f1 ts) "v1")
     (assert-equal (s-f2 ts) 2)

     (set-s-f2! ts 3)
     (assert-equal (s-f2 ts) 3)))

 (let ()
   (struct s f1 f2
           :guard (λ (f1 f2)            ;swaps values
                    (if f1
                        (values f2 (number->string f1))
                        (beastie-error "f1 not true"))))
   (let ((ts (make-s 1 2)))
     (assert-equal (s-f1 ts) 2)
     (assert-equal (s-f2 ts) "1"))
   (assert-exception (make-s #f 2)))

 ;; bad call: :guard keyword but not procedure
 (assert-exception (struct s f1 :guard)))

(test-suite
 "ctype and friends"
 (assert-true  (char-alpha? #\a))
 (assert-true  (char-alnum? #\a))
 (assert-false (char-digit? #\a))
 (assert-false (char-space? #\a))
 (assert-false (char-space? #\+))
 (assert-true  (char-xdigit? #\a))
 (assert-true  (char-xdigit? #\A))
 (assert-false (char-xdigit? #\g))

 (assert-true  (char-alpha? #x65))   ;e (ie, these work with integers/codepoints, too)

 (assert-true  (char-alpha? #xe9))   ;é
 (assert-true  (char-alnum? #xe9))
 (assert-false (char-digit? #xe9))
 (assert-false (char-space? #xe9))
 (assert-true  (char-space? #xa0))    ;no-break space
 (assert-true  (char-alpha? #x3b1))  ;\alpha
 (assert-true  (char-alpha? #x3400)) ;first character in CJK Unified Ideograph Extension A
 (assert-false (char-digit? #x3400))
 (assert-true  (char-alpha? #x4dbf)) ;...and last
 (assert-false (char-alpha? #x4dc0)) ;...next
 ;; first characters in planes 1 and 2:
 ;; these are 'alpha' characters, but the mycu code doesn't handle
 ;; codepoints outside BMP
 (if (*beastie* 'icu-version)
     (begin
       (assert-true (char-alpha? #x10000))
       (assert-true (char-alpha? #x20000)))
     (begin
       (assert-false (char-alpha? #x10000))
       (assert-false (char-alpha? #x20000))))
 (assert-false (char-digit? #x10000))
 (assert-false (char-space? #x10000))

 (assert-true (char-upper? #\A))
 (assert-true (char-upper? #xc1))       ;Á
 (assert-false (char-lower? #xc1))
 (assert-true (char-lower? #\a))
 (assert-true (char-lower? #xe9))       ;é
 (assert-false (char-upper? #xe9))
 ;(assert-true (char-other-letter? #x0294)) ;glottal stop
 (assert-false (char-upper? #x0294))
 (assert-false (char-lower? #x0294))

 ;; char-space? should regard the whitespace characters below U+20 as
 ;; spaces, too, even though they're not category Z in Unicode terms.
 (assert-true (char-space? #x09))       ;horizontal tab
 (assert-true (char-space? #x0a))       ;newline
 (assert-true (char-space? #x0b))       ;vertical tab
 (assert-true (char-space? #x0c))       ;new-page / form-feed
 (assert-true (char-space? #x0d))       ;carriage return

 (assert-true (char-punct? #\,))
 (assert-true (char-punct? #x5b))       ;left square bracket
 (assert-false (char-punct? #xe9))      ;é

 (assert-true (char-cntrl? #x0001))
 (assert-true (char-cntrl? #xad))       ;soft hyphen, category Cf
 (assert-false (char-cntrl? #xe9))      ;é

 ;; the following don't have ctype analogues
 (assert-true (char-symbol? #\$))
 (assert-true (char-symbol? #xa2))      ;cent sign
 (assert-true (char-mark? #x300))       ;grave accent
 ;; sanity-check
 (assert-false (char-symbol? #x300))
 (assert-false (char-mark? #\a))

 ;; these echo the more comprehensive tests in test-unicode.c
 ;; (ie, these are testing the s7 interface, rather than the Unicode logic)
 (let ((yes (λ (c) (assert-true (uchar-alphabetic? c))))
       (no  (λ (c) (assert-false (uchar-alphabetic? c)))))
   (no #\@)
   (yes #\A)
   (yes #x41)                           ;'A' as hex
   (yes #\z)
   (no #\{)
   (yes #x950)
   (no #x951))

 ;; the following functions should produce false for anything above
 ;; the ASCII range (and not fail)
 (assert-false (char-blank? #x1000))
 (assert-false (char-graph? #x1001))
 (assert-false (char-print? #x1002))
 (assert-false (char-xdigit? #x1003))

 ;; it's OK to call these with non-char/non-integer arguments
 (assert-false (char-alpha? "hello"))
 (assert-false (char-graph? "hello"))

 ;; the char-wordbreak? function is slightly different from char-space?
 (assert-true (char-wordbreak? #x20))
 (assert-false (char-wordbreak? #xa0))  ;non-breaking space
 (assert-true (char-wordbreak? #x2000)) ;en quad
 (assert-false (char-wordbreak? #x2007)) ;figure space

 (assert-false (char-nbsp? #\space))
 (assert-true (char-nbsp? #x00a0))      ;no-break space
 (assert-true (char-nbsp? #x2007))      ;figure space
 (assert-true (char-nbsp? #x202f))      ;narrow no-break space

 ;; case-folding
 ;;
 ;; The principal tests of these functions are in test-unicode.c.  The
 ;; tests here are really just testing the wrapping in Scheme.
 (assert-equal (uchar-upcase #\a) #x41)
 (assert-equal (uchar-upcase #x61) #x41)
 (assert-equal (uchar-downcase #\A) #x61)
 (assert-equal (uchar-downcase #x41) #x61)
 ;; for these ones, see test-unicode.c
 (assert-equal (uchar-upcase #x1c5) #x1c4)
 (assert-equal (uchar-downcase #x1c5) #x1c6)
 (assert-equal (uchar-titlecase #x1c5) #x1c5)
 (let ((s #"Aa@"))
   (assert-equal (ustring-uppercase s) #"AA@")
   (assert-equal s #"Aa@")
   (assert-equal (ustring-uppercase! s) #"AA@")
   (assert-equal s #"AA@"))
 (let* ((s0 #"DžAa@")
        (s (make-ustring s0)))
   (assert-equal (ustring-uppercase s) (make-ustring #x01c4 #x41 #x41 #x40))
   (assert-equal (ustring-lowercase s) (make-ustring #x01c6 #x61 #x61 #x40))
   (assert-equal (ustring-titlecase s) (make-ustring #x01c5 #x41 #x41 #x40))
   (assert-equal s s0)                  ;haven't modified s

   (assert-equal (ustring-uppercase! s) (make-ustring #x01c4 #x41 #x41 #x40))
   (assert-false (equal? s s0))
   (assert-equal (ustring-lowercase! s) (make-ustring #x01c6 #x61 #x61 #x40))
   (assert-equal (ustring-titlecase! s) (make-ustring #x01c5 #x41 #x41 #x40)))

 ;; fallback behaviour: if given something other than an integer or character,
 ;; then return the argument unchanged
 (assert-equal (uchar-upcase 'sym) 'sym)
 (assert-equal (uchar-upcase "str") "str")
 (assert-equal (uchar-upcase #"ustr") #"ustr")
 ;; similarly
 (assert-equal (uchar-downcase 'sym) 'sym)
 (assert-equal (uchar-titlecase 'sym) 'sym)
 )


(test-suite
 "resolve-file"
 (module/expose 'utils)                 ;expose resolve-file/plain and /kpse

 (with-output-to-temporary-file "tmp-kpse.tex" (λ () (printf "\\relax")))
 (with-output-to-temporary-file "tmp-kpse.bib" (λ () (printf "empty")))

 (when *kpsewhich-path*
   ;; kpsewhich is available
   (assert-equal (resolve-file/kpse "tmp-kpse" ".bib") "./tmp-kpse.bib")
   (assert-equal (resolve-file/kpse "tmp-kpse" ".tex") "./tmp-kpse.tex")
   ;; For kpsewhich the 'format' .aux implies the .tex search path
   ;; (we don't, I think, depend on this behaviour, so this test might
   ;; be changeable in future, but do it here so that we can detect regressions)
   ;; This test _fails_ when we don't have kpsewhich, but are
   ;; substituting it with resolve-file/plain, so skip it.
   (assert-equal (resolve-file/kpse "tmp-kpse" ".aux") "./tmp-kpse.tex")
   ;; we can't do the following test with, eg, .foo, since kpse ignores extensions
   ;; it doesn't recognise
   (assert-exception (resolve-file/kpse "tmp-kpse" ".bst"))
   (assert-false (resolve-file/kpse "tmp-kpse" ".bst" :error-if-not-found? #f)))

 (assert-equal (resolve-file/plain "tmp-kpse" ".bib")
               (build-path (current-directory) "tmp-kpse.bib"))
 (assert-equal (resolve-file/plain "tmp-kpse" ".tex")
               (build-path (current-directory) "tmp-kpse.tex"))
 (assert-equal (resolve-file/plain "tmp-kpse.bib")
               (build-path (current-directory) "tmp-kpse.bib"))
 (assert-equal (resolve-file/plain "tmp-kpse.tex")
               (build-path (current-directory) "tmp-kpse.tex"))
 ;; we haven't created tmp-kpse.bst
 (assert-exception (resolve-file/plain "tmp-kpse" ".bst"))
 (assert-false (resolve-file/plain "tmp-kpse" ".bst" :error-if-not-found? #f))

 (let ((bibinputs (getenv "BIBINPUTS"))
       (bstinputs (getenv "BSTINPUTS"))
       (texinputs (getenv "TEXINPUTS")))
   (dynamic-wind
       (λ ()
         (setenv "BIBINPUTS" "/nowhere:../misc")
         (setenv "BSTINPUTS" "/nowhere:../misc")
         (setenv "TEXINPUTS" "/nowhere"))
       (λ ()
         (let ((bibpath                 ;actual known path
                (build-path (current-directory) "../misc/bibtex-parse-authors.bib")))
           (assert-equal (resolve-file/plain "bibtex-parse-authors" ".bib")
                         bibpath)
           ;; it must still work when it's given an absolute path
           (assert-equal (resolve-file/plain bibpath ".bib")
                         bibpath))
         (assert-equal (resolve-file/plain "bibtex-parse-authors.bst")
                       (build-path (current-directory) "../misc/bibtex-parse-authors.bst"))
         (assert-equal (resolve-file/plain "tmp-kpse.tex" :error-if-not-found? #f) #f))
       (λ ()
         (setenv "BIBINPUTS" bibinputs)
         (setenv "BSTINPUTS" bstinputs)
         (setenv "TEXINPUTS" texinputs)))))

(test-suite
 "getopt"
 ;; getopt* is an internal function -- the test here is a regression test,
 ;; rather than a functional one
 (assert-equal (getopt* "ab:c:"
                        '("test-util" "-a" "-b2" "-c" "carg" "one" "two")
                        #f)
               '(((#\c . "carg") (#\b . "2") (#\a . "")) "one" "two"))
 (assert-equal (getopt* "a" '("test-util" "-a" "-b" "-c") #f)
               '(((#\a . ""))))
 (assert-equal (getopt* "a" '("test-util" "-a" "-b" "-c") #t)
               '(((#\? . #\c) (#\? . #\b) (#\a . ""))))
 (assert-equal (getopt* "" '("test-util") #f)
               '(()))

 (let ((a1? #f)
       (b1-val #f))
   (assert-equal (list
                  (getopt '((#\a
                             "Set a true"
                             (set! a1? #t))
                            (#\b bb
                             "Value of b"
                             (set! b1-val bb)))
                          :command-line '("test-util1" "-a" "-bbarg" "one" "two")))
                 '("test-util1"
                   ((#\b . "barg") (#\a . #t))
                   ("one" "two")))
   (assert-true a1?)
   (assert-equal b1-val "barg"))

 ;; bad option -c is ignored, and a "--" option
 (let ((a2? #f)
       (b2-val #f))
   (let-temporarily ((*command-line* '("test-util2" "-b" "barg" "-c" "--" "one" "-t")))
     (assert-equal (list
                    (getopt '((#\a
                               "Set a true"
                               (set! a2? #t))
                              (#\b bb
                               "Value of b"
                               (set! b2-val bb)))))
                   '("test-util2"
                     ((#\b . "barg"))
                     ("one" "-t"))))
   (assert-false a2?)
   (assert-equal b2-val "barg"))

 ;; no argument to -b, and no overall arguments
 (let ((a3? #f)
       (b3-val #f))
   (let-temporarily ((*command-line* '("test-util3" "-a" "-b")))
     (assert-equal (list
                    (getopt '((#\a
                               "Set a true"
                               (set! a3? #t))
                              (#\b bb
                               "Value of b"
                               (set! b3-val bb)))))
                   '("test-util3"
                     ((#\a . #t))
                     ())))
   (assert-true a3?))

 ;; check no-options case works as expected
 (let-temporarily ((*command-line* '("test-util4" "one" "two")))
   (assert-equal (list (getopt '()))
                 '("test-util4"
                   ()
                   ("one" "two"))))
 )

(test-suite
 "triple-quotes/reader macros"
 ;; If #" isn't followed by two quotes, then it's a ustring #"xx" or #"".

 ;; zero, one and two line inputs are edge-cases
 (assert-equal #"""""" "")
 (assert-equal #"""one""" "one")
 (assert-equal #"""one
                   two""" "one\ntwo")
 (assert-equal #"""one
                   two
                   three""" "one\ntwo\nthree")

 ;; indents
 (assert-equal #"""Here is a string.
  With "a" second line.
    Third indented."""
               "Here is a string.\nWith \"a\" second line.\n  Third indented.")
 (assert-equal #"""First.

    Second line after blank.
      Third indented.

    Fourth: no newline."""
               "First.\n\nSecond line after blank.\n  Third indented.\n\nFourth: no newline.")
 (assert-equal #"""
    Leading empty line, and trailing newline.
    """
               "Leading empty line, and trailing newline.\n")

 ;; various quotes and other characters in the string
 (assert-equal #"""Line

`(list 'p (λ (e) (foo e 'a1)) 'q)`.
Two quotes: "".
(ie, XPath "p[@a1]/q"."""
"Line\n\n`(list 'p (λ (e) (foo e 'a1)) 'q)`.\nTwo quotes: \"\".\n(ie, XPath \"p[@a1]/q\".")

 ;; The examples in the Julia documentation
 ;; https://docs.julialang.org/en/v1/manual/strings/
 ;; the trailing line governs the indentation
 (assert-equal #"""
           Hello,
           world1.
         """
    "  Hello,\n  world1.\n")
 (assert-equal #"""    This
         is
           a test"""
    "    This\nis\n  a test")
 (assert-equal #"""hello1""" "hello1")
 (assert-equal #"""
     hello2""" "hello2")
 (assert-equal #"""

     hello3""" "\nhello3")
 (assert-equal #"""
         Hello,
         world2."""
    "Hello,\nworld2.")

 ;; Julia also allows continuation lines, but we don't support that.
 ;;  julia> """
 ;;          Averylong\
 ;;          word"""
 ;; "Averylongword"
 )

(test-suite
 "subprocess"
 (let ((nw (print-warning 'get-count)))
   (assert-equal (subprocess "echo" "hello") "hello\n")
   (assert-equal (subprocess "true") "") ;no output
   (assert-equal (subprocess "false") #f) ;non-zero exit status
   (assert-equal
    (catch #t
      (lambda ()
        (catch 'subprocess
          (lambda ()
            ;; call a non-existing command
            (subprocess "wsgft"))
          (lambda (tag msg . rest)
            ;;(format #t "tag=~s  msg=~s  status=~s~%" tag (apply format #t msg) (caddr msg))
            "subprocess failed correctly")))
      (lambda (tag msg . rest)
        (format #f "unexpected exception: tag ~a, msg: ~a" tag (apply format #f msg))))
    "subprocess failed correctly")
   (assert-exception :tag wrong-number-of-args
                     :body (subprocess))
   (assert-exception :tag wrong-type-arg
                     :body (subprocess "echo" 1))
   (assert-exception :tag wrong-type-arg
                     :body (subprocess 'echo))

   ;; one warning from (subprocess "false") ...no, no longer
                                        ;(assert-equal (print-warning 'get-count) (+ nw 1))
   ))

(test-suite
 "modules"

 (define-macro (assert-all-undefined . syms)
   `(let* ((currenv (curlet))
           (d? (λ (s) (defined? s currenv))))
      (if (any d? (#_quote ,syms))
          (assert-fail 'all-undefined
                       (sprintf "not all undefined: ~s -> ~s"
                                (#_quote ,syms)
                                (map d? (#_quote ,syms))))
          (assert-true 'all-undefined))))

 ;; basic case: after load, we can see the provided symbols but not the private ones
 (with-output-to-temporary-file "tmp-mod-basic.scm"
   (λ ()
     (printf #"""(define (f-basic) 11)
                 (define (f-basic-private) 12)
                 (module-provide f-basic)""")))
 (let ()
   (module "tmp-mod-basic.scm")         ;only the provided symbols
   (assert-true  (defined? 'f-basic))
   (assert-false (defined? 'f-basic-private)))
 (assert-all-undefined f-basic f-basic-private) ;but nothing leaks
 (let ()
   (module/expose "tmp-mod-basic.scm")  ;all symbols visible
   (assert-true  (defined? 'f-basic))
   (assert-true  (defined? 'f-basic-private)))
 (assert-all-undefined f-basic f-basic-private)

 ;; as above, but with a built-in module
 (let ()
   (module 'bst)
   (assert-true  (defined? 'parse-bst-file))
   (assert-false (defined? 'bst:make-comment)))
 (let ()
   (module/expose 'bst)
   (assert-true  (defined? 'parse-bst-file))
   (assert-true  (defined? 'bst:make-comment)))
 (assert-all-undefined parse-bst-file bst:make-comment)

 ;; a module loads two submodules
 (with-output-to-temporary-file "tmp-mod-submod.scm"
   (λ ()
     (printf #"""(define/provide (f-submod) 21)
                 (define (f-submod-private) 22)
                 (module "tmp-mod-basic.scm")
                 (module 'bst)""")))
 (let ()
   (module "tmp-mod-submod.scm") ;symbols in sub-modules shouldn't leak
   (assert-true  (defined? 'f-submod))
   (assert-false (defined? 'f-submod-private)) ;private to tmp-mod-submod
   (assert-false (defined? 'f-basic)) ;provided by -basic to -submod, but not provided
   (assert-false (defined? 'f-basic-private)) ;private to -submod
   (assert-false (defined? 'parse-bst-file)) ;provided by 'bst to -submod, but not provided
   (assert-false (defined? 'bst:make-comment))) ;private to 'bst
 (assert-all-undefined f-submod f-submod-private
                       f-basic f-basic-private
                       parse-bst-file bst:make-comment)

 ;; With module/expose, all symbols defined in the given module are
 ;; also available in the caller.  This currently _includes_ symbols
 ;; which are provided to the module by submodules.
 ;;
 ;; It would probably be better if these _were not_ included – ie,
 ;; only the symbols defined in the given module should be exposed,
 ;; not things provided to it – but this would require some intricate
 ;; reworking of the module/let* support in runtime.scm (‘intricate’
 ;; => I tried, and got more confused than it was worth while
 ;; pursuing).
 ;;
 ;; The two commented-out tests below would have the given results
 ;; only with this latter behaviour.
 ;;
 ;; The current behaviour (exposing those provided symbols) makes some
 ;; sense, but means it's hard to predict what gets provided, and
 ;; can result in duplicate definitions (an error, now that (varlet
 ;; env source-env) objects to redefinitions).
 (let ()
   (module/expose "tmp-mod-submod.scm")
   (assert-true  (defined? 'f-submod))        ;as usual
   (assert-true  (defined? 'f-submod-private)) ;private, but exposed
   ;(assert-false (defined? 'f-basic))        ;provided to -submod, but not included in expose
   (assert-false (defined? 'f-basic-private)) ;not provided to -submod
   ;(assert-false (defined? 'parse-bst-file)) ;provided to -submod, not exposed
   (assert-false (defined? 'bst:make-comment))) ;not provided to -submod
 (assert-all-undefined f-submod f-submod-private
                       f-basic f-basic-private
                       parse-bst-file bst:make-comment)

 ;; (with-output-to-temporary-file "tmp-mod-submod2.scm"
 ;;    (λ ()
 ;;      (printf "(define/provide (public1) 'sub-module-2) (define (private1) 'private1) (module'bst)")))
 ;; (let ()
 ;;   )

 ;; loading two things in the one form
 (let ()
   (module "tmp-mod-basic.scm" 'bst)
   (assert-true  (defined? 'f-basic))
   (assert-false (defined? 'f-basic-private))
   (assert-true  (defined? 'parse-bst-file))
   (assert-false (defined? 'bst:make-comment)))
 (assert-all-undefined f-basic f-basic-private)

 ;; error: module provides nothing: should result in an exception
 (with-output-to-temporary-file "tmp-mod-empty.scm"
   (λ ()
     (printf "(define (m31) 31)")))     ;no provides
 (let ()
   (assert-exception
    (module "tmp-mod-empty.scm")))
 (assert-all-undefined m31)

 ;; error: module-loading loop: should result in an exception
 (with-output-to-temporary-file "tmp-mod-loop1.scm"
   (λ ()
     (printf "(define/provide (ml1) 'loop1) (module \"tmp-mod-loop2.scm\")")))
 (with-output-to-temporary-file "tmp-mod-loop2.scm"
   (λ ()
     (printf "(define/provide (ml2) 'loop2) (module \"tmp-mod-loop1.scm\")")))
 (assert-exception (let () (module "tmp-mod-loop1.scm")))
 (assert-all-undefined ml1 ml2)

 (assert-exception :tag io-error
                   :body (module "not-existing.scm"))
 (assert-exception (module 'absent))

 ;; In the following case, the 'bst module also loads _and exposes_
 ;; the 'bibtex module, and this fails when bibtex is subsequently
 ;; loaded.  This is why runtime.scm:module/let* is written to avoid
 ;; adding definitions to a let when they already exist.  See the
 ;; notes about module/expose above, and the module/let* procedure.
 (let ()
   (module/expose 'bst)
   (module 'bibtex)
   ;; shouldn't throw an error
   (assert-true #t))                    ;to count +1
 )

(test-suite
 "ragbag"
 (assert-true  (symbol<? 'a 'b))
 (assert-false (symbol<? 'b 'a))
 (assert-false (symbol<? 'a 'a))
 (assert-true  (symbol<? 'a 'b 'c 'd 'e))
 (assert-false (symbol<? 'a 'b 'd 'c 'e))
 ;; trivial cases
 (assert-true  (symbol<? 'a))
 (assert-true  (symbol<?))
 ;; bad calls
 (assert-exception :tag wrong-type-arg
                   :body (symbol<? 'a "a"))
 (assert-exception :tag wrong-type-arg
                   :body (symbol<? 'a 'b "c"))

 (let ((i (compose-iterators* (make-iterator "abc") (make-iterator #(1 2 3)))))
   (assert-equal (map values i)
                 '(#\a #\b #\c 1 2 3))
   (assert-true (eof-object? (i))))

 ;; none of the following should return undefined,
 ;; and the first should all be non-false
 (for-each (λ (key)
             (assert-true (*beastie* key)))
           '(version-string version-integers date revision s7-version
                            build-platform run-platform
                            unicode-version))
 ;; the following will be #f in a non-ICU build, but won't be undefined
 (let ((v  (*beastie* 'icu-version)))
   (if v
       (begin
         (assert-true (list? v))
         (assert-equal (length v) 3)
         (assert-true (every integer? v))
         (assert-true (string? (*beastie* 'icu-version-string))))
       (assert-false (*beastie* 'icu-version-string))))) ;...and not undefined

;; let this test-suite come last, simply because the big
;; multi-line string messes up Emacs highlighting
(test-suite
 "xexpr manipulations and writing"

 (define (xexpr-disassemble/list xe)
   (call-with-values (λ ()
                       (xexpr-disassemble xe))
     list))
 (assert-equal (xexpr-disassemble/list '(el)) '(el () ()))
 (assert-equal (xexpr-disassemble/list '(el ((k v)))) '(el ((k v)) ()))
 (assert-equal (xexpr-disassemble/list '(el ((k1 v1) (k2 v2)) "t1" "t2"))
               '(el ((k1 v1) (k2 v2)) ("t1" "t2")))
 (assert-equal (xexpr-disassemble/list '(el ())) '(el () ()))
 (assert-equal (xexpr-disassemble/list '(el "t")) '(el () ("t")))

 (assert-equal (with-output-to-string
                 (lambda ()
                   (xexpr-write/xml! '(div
                                       (p)
                                       (p ())
                                       (p ((a1 "v1")))
                                       (p "p1")
                                       (p () "p2")
                                       (p ((a1 "v1")) "p3")
                                       (p ((a1 "v&1\"")) "p4<>")
                                       (p "a" nbsp "b" 33)))))
               "<div><p /><p /><p a1=\"v1\" /><p>p1</p><p>p2</p><p a1=\"v1\">p3</p><p a1=\"v&amp;1&quot;\">p4&lt;&gt;</p><p>a&nbsp;b&#x21;</p></div>")

 ;; similar, but with ustrings
 (assert-equal (with-output-to-string
                 (λ ()
                   (xexpr-write/xml!
                    '(div (p ((a1 #"v1")) #"Body <&>")))))
               "<div><p a1=\"v1\">Body &lt;&amp;&gt;</p></div>")

 ;; entities: symbols in the body should be interpreted as XML entity references
 (let ((xexpr '(p "Hello" nbsp
                  " a pound: " pound
                  " std " amp ", "
                  lt ", "
                  gt ", "
                  apos ", "
                  quot
                  " and undefined: " wibble)))
   (assert-equal (with-output-to-string
                   (λ ()
                     (xexpr-write/xml! xexpr)))
                 "<p>Hello&nbsp; a pound: &pound; std &amp;, &lt;, &gt;, &apos;, &quot; and undefined: &wibble;</p>")
   ;; Entities &amp; and &lt; musn't be expanded when writing XML.
   ;; Entity &gt; could be, but we choose not to, for symmetry and tidiness.
   (assert-equal (with-output-to-string
                   (λ ()
                     (xexpr-write/xml! xexpr :expand-entities? #t)))
                 "<p>Hello  a pound: £ std &amp;, &lt;, &gt;, ', \" and undefined: &wibble;</p>")
   ;; we choose to have xexpr-write/xhtml! default to :exspand-entities?
   (assert-true (string-suffix?
                 "<p>Hello  a pound: £ std &amp;, &lt;, &gt;, ', \" and undefined: &wibble;</p></body></html>"
                 (with-output-to-string
                   (λ ()
                     (xexpr-write/xhtml! xexpr)))))

   ;; here, the choice to format undefined entities/symbols as
   ;; [symbol] is unspecified (thus we're uncommitted to it), and it's
   ;; in the test only to ensure it doesn't cause an error
   (assert-equal (with-output-to-string
                   (λ ()
                     (xexpr-write/python! xexpr)))
                 "['p', 'Hello', \" \", ' a pound: ', \"£\", ' std ', \"&\", ', ', \"<\", ', ', \">\", ', ', \"'\", ', ', \"\\\"\", ' and undefined: ', '[wibble]']")

   (assert-equal (with-output-to-string
                    (λ ()
                      (xexpr-write/md! (list xexpr))))
                 "\nHello  a pound: £ std &, <, >, ', \" and undefined: \"[wibble]\"\n\n")

   (let ((xexpr/string (with-output-to-string
                         (λ ()
                           (xexpr-write/sexp! xexpr)))))
   (assert-equal (with-input-from-string xexpr/string read)
                 xexpr)))

 ;; formatting of xexprs with attributes containing escapable characters
 (let ((xexpr/att  '(p ((att "&<>'\"£")))))
   (assert-equal (with-output-to-string
                   (λ ()
                     (xexpr-write/xml! xexpr/att)))
                 "<p att=\"&amp;&lt;&gt;&apos;&quot;£\" />")
   ;; within attributes, we need to have quot and apos unexpanded,
   ;; even when expand-antities? is true
   (assert-equal (with-output-to-string
                   (λ ()
                     (xexpr-write/xml! xexpr/att :expand-entities? #t)))
                 "<p att=\"&amp;&lt;&gt;&apos;&quot;£\" />")

   ;; Python attributes require slightly different handling
   (assert-equal (with-output-to-string
                   (λ ()
                     (xexpr-write/python! xexpr/att)))
                 "['p', [['att', '&<>\\'\"£']]]"))

 ;; xexprs including ustring content
 ;; (I don't think I ever generate attributes with ustrings)
 (assert-equal (with-output-to-string
                 (λ ()
                   (xexpr-write/xml! '(p #"abc" (span #"&<>'\"£\"")))))
               "<p>abc<span>&amp;&lt;&gt;&apos;&quot;£&quot;</span></p>")

 ;; Few attributes are examined in Markdown output.
 ;; There's no escaping required (that's right, isn't it?),
 ;; in either content or attributes.
 (assert-equal (with-output-to-string
                 (λ ()
                   (xexpr-write/md! '((a ((href "urn:example&")) "&<>'\"x")
                                      " "
                                      (img ((alt "&<>'\"x") (src "urn:example&")))))))
               "[&<>'\"x](urn:example&) ![&<>'\"x](urn:example&)\n")

 ;; skip this test: don't commit to (head...) contents just now
 #;(assert-equal (with-output-to-string
                 (lambda ()
                   (xexpr-write/xhtml! '(div (p "Hello")))))
               "<!DOCTYPE html\n  PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"\n  \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n<html xmlns=\"http://www.w3.org/1999/xhtml\"><head><title>Dummy title</title></head><body><div><p>Hello</p></div></body></html>")

 ;; xexpr searching
 (let ((d1 '(div
             (p "hello")
             (p () "hello " (em "there"))
             (h1 "heading")
             (p "and " (em "more") " still")
             ;; not matched with (pem): the em is not a child of p
             (p (x (em "x-inner")))
             ;; the inner one is matched with (p em)
             (p (p (em "p-inner")))
             (div
              ;; searching for p should find only the outer element here
              ;; not the inner p in addition
              (p "p1" (p (em "boo!")))
              (div (p "pdiv"))
              (p "p2 " (em ((a1 "v1")) "p2em")))))

       (d2 '(div
             (p)
             (p "p1")
             (p () "p2")
             (p ((a1 "v1")) "p3")
             (p ((x "nothing")) (p ((a1 "v3")) "p4a") "p4b")
             (p ((x "nothing")) (p ((a1 "v4") (a2 "v4a")) (p "p5a") "p5b"))
             (p ((x "nothing")) (q ((a1 "v5")) (q "p5a") "p6b"))
             (other ((a1 v3))))))
   (assert-equal (xexpr-path-search '(div) d1) (list d1))
   (assert-equal (xexpr-path-search '(p) d1)
                 '((p "hello")
                   (p () "hello " (em "there"))
                   (p "and " (em "more") " still")
                   (p (x (em "x-inner")))
                   (p (p (em "p-inner")))
                   (p "p1" (p (em "boo!")))
                   (p "pdiv")
                   (p "p2 " (em ((a1 "v1")) "p2em"))))
   (assert-equal (xexpr-path-search '(p em) d1)
                 '((em "there")
                   (em "more")
                   (em "p-inner")
                   (em "boo!")
                   (em ((a1 "v1")) "p2em")))
   (assert-equal (xexpr-path-search '(p p) d2)
                 '((p ((a1 "v3")) "p4a")
                   (p ((a1 "v4") (a2 "v4a")) (p "p5a") "p5b")))
   (assert-equal (xexpr-path-search '(p a1:) d2)
                 '((a1 "v1") (a1 "v3") (a1 "v4")))

   (assert-equal (xexpr-path-search
                  (list 'p (lambda (e) (xexpr-get-attribute e 'x)))
                  d2)
                 '((p ((x "nothing")) (p ((a1 "v3")) "p4a") "p4b")
                   (p ((x "nothing")) (p ((a1 "v4") (a2 "v4a")) (p "p5a") "p5b"))
                   (p ((x "nothing")) (q ((a1 "v5")) (q "p5a") "p6b"))))
   (assert-equal (xexpr-path-search
                  (list 'p (lambda (e) (xexpr-get-attribute e 'x)) 'q)
                  d2)
                 '((q ((a1 "v5")) (q "p5a") "p6b")))
   (assert-equal (xexpr-path-search
                  (list 'p (lambda (e)
                             (cond ((xexpr-get-attribute e 'a1)
                                    => (lambda (v) (string=? v "v4")))
                                   (else #f))) 'p)
                  d2)
                 '((p "p5a"))))

 (assert-equal (xexpr-text "foo") "foo")
 ;; entities...
 (assert-equal (xexpr-text '(p
                             "one" amp  ;core
                             "two" ndash ;'extra'
                             "three" odd ;unknown
                             "four"))
               "one&two–threeoddfour")
 ;; nested text
 (assert-equal (xexpr-text '(p
                             "one "
                             (em "two" (strong "three"))
                             "four"
                             (em (strong "five"))
                             (a ((href "url")) "body")))
               "one twothreefourfivebody")

 (let ((md (with-output-to-string
             (λ ()
               (xexpr-write/md! '((p ((a1 "v1")) "p1")
                                  (h1 "h1")
                                  (p () (a ((href "url")) "p2"))
                                  (hr)
                                  (h2 ((a1 "v1")) (em "h2"))
                                  (p "p4<>" "v&1\"")
                                  (p "a" amp "b" nbsp "c"
                                     ;33 -- digits produce a warning
                                     )))))))
    (assert-equal md #"""

p1


h1
====

[p2](url)

----


_h2_
----

p4<>v&1"

a&b c

"""
      ))
  (let ((md (with-output-to-string
              (λ ()
                (xexpr-write/md! '((p "Text")
                                   (blockquote "\none\ntwo\n\nthree")
                                   (p "Text")
                                   (ul (li "UItem 1") (li "UItem 2"))
                                   (p "Text")
                                   (ol (li "Oitem 1") (li "OItem 2"))))))))
    (assert-equal md #"""

Text

> 
> one
> two
> 
> three


Text

  1. UItem 1
  1. UItem 2

Text

  * Oitem 1
  * OItem 2

"""))
)

(exit/failures)