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

(module "s7unit.scm" 'klipspringer 'unicode)

;; Expose the detailed structure of a parse result, for testing
(define-values (parse-result-test drain)
  (let ()
    (module/expose 'klipspringer)

    (define (drain inp)
      (if (list? inp)
          (map input->string/eof/debug* inp)
          (input->string/eof/debug* inp)))

    (define (parse-result-test parser source)
      (let ((res (parser (make-parser-input source))))
                                        ;(printf "parse-result-test ~s -> ~s~%" source res)
        (cond ((consumed? res)
               (let ((r (consumed-result res)))
                 (if (error? r)
                     (list 'consumed
                           'error
                           #f           ;(error-msg r)
                           (drain (error-inputs r)))
                     (list 'consumed
                           'ok
                           (ok-value r)
                           (drain (ok-input r))))))
              ((empty? res)
               (let ((e (empty-result res)))
                 (if (error? e)
                     (list 'empty
                           'error
                           #f           ;(error-msg e)
                           (drain (error-inputs e)))
                     (list 'empty
                           'ok
                           (ok-value e)
                           (drain (ok-input e))))))
              (else
               (sprintf "unexpected parse result: ~s" res)))))
    (values parse-result-test input->string/eof/debug*)))

;; Macro assert-parse, in variants.
;;
;; assert-parse/plain:
;; Call parse-result-test with a string argument, and
;; compare the result with an expectation.
;; We wrap the string in a reader with :ascii-characters? #t only for
;; convenience when writing the tests.
;; This argument won't be a string if we want to pass some codepoints
;; to this test.
;;
;; Below, it might occur to me to wrap ,str in unicode-decode/utf8,
;; but I shouldn't do this, since we want to be able to control
;; whether this gets chars or codepoints
;; (define-macro (assert-parse/plain str p result)
;;   `(assert-equal ,str                   ;useful label?
;;                  (parse-result-test
;;                   ,p
;;                   (make-unicode-reader/string ,str :ascii-characters? #t))
;;                  ,result))
;; (define-macro (assert-parse/ints ints p result)
;;   `(assert-equal ,ints                  ;useful label?
;;                  (parse-result-test
;;                   ,p
;;                   (list->lexeme-source ,ints))
;;                  ,result))
(define-macro (assert-parse/plain str p result)
  `(assert-equal ,str                   ;useful label?
                 (parse-result-test
                  ,p
                  ,(if (string? str)
                      `(make-unicode-reader/string ,str :ascii-characters? #t)
                      `(list->lexeme-source ,str)))
                 ,result))

;; assert-parse/debug is just like assert-parse/plain, but echoes its results
(define-macro (assert-parse/debug str p result)
  `(begin (printf ">>> assert-parse: ~s~%" ,str #;(string->list ,str))
          (let ((res (parse-result-test
                      ,p
                      ,(if (string? str)
                           `(make-unicode-reader/string ,str :ascii-characters? #t)
                           `(list->lexeme-source ,str)))))
            (printf "  result ~s~%" res)
            (assert-equal ,str res ,result))))

;; assert-parse-x2:
;; This expands into two assertions, one using characters
;; and one using integers.  This doesn't work for all cases
;; -- it doesn't work where there's a (return #\char), for example --
;; and those cases where it won't work are marked with assert-parse*,
;; rather than assert-parse.
(define (list->lexeme-source integer-list)
  ;; given a list of integers, make a lexeme-source function
  (let ((l integer-list))
    (λ ()
      (if (null? l)
          #<eof>
          (let ((c (car l)))
            (set! l (cdr l))
            c)))))
(define (all-char->integer lst)
  ;; recursively convert all characters in the list into the corresponding codepoints
  (map (λ (x)
         (cond ((char? x) (char->integer x))
               ((list? x) (all-char->integer x))
               ((vector? x) (list->vector (all-char->integer x)))
               (else x)))
       lst))
(define-macro (assert-parse-x2 str p result)
  `(begin
     (assert-parse/plain ,str ,p ,result)
     (assert-equal ,str
                   (parse-result-test
                    ,p
                    (list->lexeme-source (unicode-decode/utf8 ,str)))
                   (all-char->integer ,result))))

;; Either...
;; set assert-parse to be one of assert-parse/{plain,debug} and
;; assert-parse* to be assert-parse...
(define assert-parse assert-parse/plain)
;(define assert-parse assert-parse/debug)
(define assert-parse* assert-parse)
;;
;; Or...
;; define assert-parse to be the -x2 variant, and assert-parse* is the
;; plain variant
;; (define assert-parse assert-parse-x2)
;; (define assert-parse* assert-parse/plain)

(test-suite
 "internal functions"
 (module/expose 'klipspringer)

 (assert-true (parser-input? (make-input/source* (make-unicode-reader/string "a") #f)))
 (assert-false (parser-input? "hello"))
 (let ((inp (make-input/source* (make-unicode-reader/string "abc") #f)))
   (assert-equal (list (input-car inp)
                       (input-car inp)
                       (input-car inp))
                 '(97 97 97))
   (assert-equal (input-car (input-cdr inp)) 98)
   ;; we are uncommitted to the format of this response, but it should be a string
   (assert-equal (input-location inp) "\"abc\"[2]")))

(test-suite
 "basic parser operations"
 (assert-parse "a" $letter '(consumed ok #\a ""))
 (assert-parse "1" $letter '(empty error #f ("1")))
 (assert-parse "a" (parser-compose $letter) '(consumed ok #\a ""))
 (assert-parse "a" (parser-compose (return 'foo)) '(empty ok foo "a"))
                                        ;(assert-parse "a" zero '(#f . "a")) ??
 (assert-parse "(a)"
               (>>= (char #\()
                    (λ (skip1)
                                        ;(printf "skip1=~s~%" skip1)
                      (>>= $letter
                           (λ (x)
                                        ;(printf "x=~s~%" x)
                             (>>= (char #\))
                                  (λ (skip2)
                                        ;(printf "skip2=~s~%" skip2)
                                    (return x)))))))
               '(consumed ok #\a ""))

 (let ((a (char #\a))
       (b (char #\b)))
   ;; confirm the consumption rules of [leijden01] Fig.1
   (assert-parse "ab"
                 (>>= a                 ;both parsers consume
                      (λ (_) b))
                 '(consumed ok #\b ""))
   (assert-parse "ab"
                 (>>= (return 'ignored) ;first parse doesn't consume
                      (λ (_) a))
                 '(consumed ok #\a "b"))
   (assert-parse* "ab"
                  (>>= a                 ;second parse doesn't consume
                       (λ (_) (return #\x)))
                  '(consumed ok #\x "b"))
   (assert-parse* "ab"
                  (>>= (return 'ignored) ;neither parser consumes
                       (λ (_) (return #\x)))
                  '(empty ok #\x "ab")))

 (let ((p (>> (char #\()
              (>>= $letter
                   (λ (x)
                     (>> (char #\))
                         (return x)))))))
   (assert-parse "(a)" p '(consumed ok #\a ""))
   (assert-parse "a" p '(empty error #f ("a"))))

 ;; the documentation (copied from Racket parsec) states that the
 ;; following two cases should produce the same result.
 (assert-parse "a1"
               (parser-compose (x <- $letter)
                               (y <- $digit)
                               (return (list x y)))
               '(consumed ok (#\a #\1) ""))
 (assert-parse "a1"
               (parser-seq $letter $digit)
               '(consumed ok (#\a #\1) ""))
 ;; and a variant
 (assert-parse "a1"
               (parser-seq $letter
                           $digit
                           :combine-with cons)
               '(consumed ok (#\a . #\1) ""))
 ;; and again, but with the keyword not at the end,
 ;; and adding :description
 (let ((p (parser-seq $letter
                      :combine-with cons
                      :description "test"
                      $digit)))
   (assert-parse "a1"
                 p
                 '(consumed ok (#\a . #\1) ""))
   (assert-equal (get-parser-description p) "test"))
 ;; base case
 (assert-parse "a"
               (parser-seq $letter)
               `(consumed ok (#\a) ""))
 ;; with (~ ...)
 (assert-parse "[ab]"
               (parser-seq (~ (char #\[))
                           $letter
                           $letter
                           (~ (char #\])))
               '(consumed ok (#\a #\b) ""))

 (let ((p (string "str")))
   (assert-parse "str"    p '(consumed ok #"str" ""))
   (assert-parse "stx"    p '(consumed error #f ("stx" "x")))
   (assert-parse "notstr" p '(empty error #f ("notstr" "notstr")))
   (assert-parse "str"    (try p) '(consumed ok #"str" ""))
   (assert-parse "stx"    (try p) '(empty error #f ("stx" "stx" "x")))
   (assert-parse "notstr" (try p) '(empty error #f ("notstr" "notstr")))
   (assert-parse '(115 116 114) p '(consumed ok #"str" "")))
 (let ((p (string "roué")))
   (assert-parse "RouÉs" p '(empty error #f ("RouÉs" "RouÉs")))
   (assert-parse "roués" p '(consumed ok #"roué" "s")))

 (let ((p (string/ci "sTr")))           ;u/c in target string is fine
   (assert-parse "str"			p '(consumed ok #"str" ""))
   (assert-parse "StR"			p '(consumed ok #"str" ""))
   (assert-parse '(#x73 #x74 #x72)	p '(consumed ok #"str" "")) ;"str"
   (assert-parse '(#x53 #x54 #x52)	p '(consumed ok #"str" ""))) ;"STR"
 (assert-parse "Roués" (string/ci "rOuÉ") '(consumed ok #"roué" "s"))

 (assert-parse "a" (<or> $letter) '(consumed ok #\a ""))
 (let ((p (<or> $letter $digit (char #\@))))
   (assert-parse "a" p '(consumed ok #\a ""))
   (assert-parse "ab" p '(consumed ok #\a "b"))
   (assert-parse "2" p '(consumed ok #\2 ""))
   (assert-parse "@" p '(consumed ok #\@ ""))
   (assert-parse "!" p '(empty error #f ("!"))))

 (let ((p (many $letter)))              ;multiple letters
   (assert-parse "abc123" p '(consumed ok (#\a #\b #\c) "123"))
   (assert-parse "3"                    ;should match zero occurrences
                 p
                 '(empty ok () "3")))

 (let ((p (many1 $letter))) ;should fail to match zero occurrences
   (assert-parse "a4" p '(consumed ok (#\a) "4"))
   (assert-parse "5"  p '(empty error #f ("5"))))

 (let ((p (many/n $letter 2)))
   (assert-parse "6" p '(empty error #f ("6")))
   (assert-parse "a7" p '(empty error #f ("a7"))) ;is 'empty' correct?
   (assert-parse "ab8" p '(consumed ok (#\a #\b) "8"))
   (assert-parse "abcde9" p '(consumed ok (#\a #\b #\c #\d #\e) "9")))

 (let ((p (many/n $letter 2 :max 4)))
   (assert-parse "a" p '(empty error #f ("a"))) ;is empty right?
   (assert-parse "ab" p '(consumed ok (#\a #\b) ""))
   (assert-parse "abc" p '(consumed ok (#\a #\b #\c) ""))
   (assert-parse "abcd" p '(consumed ok (#\a #\b #\c #\d) ""))
   (assert-parse "abcde" p '(consumed ok (#\a #\b #\c #\d) "e")))

 (let ((p (parser-seq (~ $spaces) ;a parser which can consume before failing
                      (satisfy/char char-alpha?)
                      :combine-with values ;avoid an extra layer of list in result
                      )))
   (assert-parse "a    b  1"	(many p)	'(consumed ok (#\a #\b) "  1"))
   (assert-parse "a b  1"	(many1 p)	'(consumed ok (#\a #\b) "  1"))
   (assert-parse "a b  1"	(many/n p 2)	'(consumed ok (#\a #\b) "  1"))
   (assert-parse "a b  1"	(many/n p 3)	'(consumed error #f ("a b  1" "1" "1")))
   (assert-parse "a b  c d 1"	(many/n p 0 2)	'(consumed ok (#\a #\b) "  c d 1"))
   ;; no match at beginning of string
   (assert-parse "  1 a"	(many p)	'(consumed ok () "  1 a"))
   (assert-parse "  1 a"	(many1 p)	'(consumed error #f ("  1 a" "1 a" "1 a"))))

 (let ((p (parser-seq (many $letter)
                      (many $digit))))
   (assert-parse "123seq"
                 p
                 '(consumed ok (() (#\1 #\2 #\3)) "seq"))
   (assert-parse "seq123"
                 p
                 '(consumed ok ((#\s #\e #\q) (#\1 #\2 #\3)) ""))
   (assert-parse "seq1a"                ;alternating
                 p
                 '(consumed ok ((#\s #\e #\q) (#\1)) "a"))
   (assert-parse "1seq2"                ;alternating, but wrong way round
                 p
                 '(consumed ok (() (#\1)) "seq2"))

   ;; Unicode.
   ;; character 'ߧ'=U+07e7 is 'NKO LETTER NYA
   ;; WOLOSO' and is nearly the last 2-byte-encoded letter, 'अ'=U+0905
   ;; is the first uncomplicated letter encoded into 3 bytes, and
   ;; 'ￜ' = U+ffdc appears to be the last letter in the BMP (still in 3 bytes)
   (assert-parse "aéߧअￜ0９"
                 p
                 '(consumed ok ((#\a #xe9 #x07e7 #x0905 #xffdc) (#\0 #xff19)) "")))

 (assert-parse "{braced}x"
               (parser-one (char #\{) (~> (many $letter)) (char #\}))
               '(consumed ok (#\b #\r #\a #\c #\e #\d) "x"))
 (assert-parse "{b}x"
               (parser-one (char #\{) (~> (many $letter))) ;~> at end
               '(consumed ok (#\b) "}x"))
 (assert-parse "b}x"
               (parser-one (~> (many $letter)) (char #\})) ;~> at start
               '(consumed ok (#\b) "x"))

 (assert-parse "foo" $space  '(empty error #f ("foo")))
 (assert-parse "   " $space  '(consumed ok #\space "  "))
 (assert-parse "   " $spaces '(consumed ok (#\space #\space #\space) ""))
 (assert-parse ""    $spaces '(empty ok () ""))

 ;; The consumed/empty and single/list results here match Racket's parsack
 (assert-parse "\n"	$newline '(consumed ok #\newline ""))
 (assert-parse "\t"	$newline '(empty error #f ("\t")))
 (assert-parse "\t"	$tab '(consumed ok #\tab ""))
 (assert-parse "\n"	$eol '(consumed ok (#\newline) ""))
 (assert-parse "\r"	$eol '(consumed ok (#\return) ""))
 (assert-parse "\n\r"	$eol '(consumed ok (#\newline #\return) ""))
 (assert-parse "\r\n"	$eol '(consumed ok (#\return #\newline) ""))
 (assert-parse "\t"	$eol '(empty error #f ("\t" "\t")))

 (assert-parse "a" $any '(consumed ok #\a ""))
 (assert-parse "any" $any '(consumed ok #\a "ny"))
 (assert-parse "" $any '(empty error #f ("")))

 (let ((p (oneOf "abc")))
   (assert-parse "aoneOf" p '(consumed ok #\a "oneOf"))
   (assert-parse "oneOf"  p '(empty error #f ("oneOf"))))
 (let ((p (oneOf "eé")))                ;same, but with codepoints
   (assert-parse "ex" p '(consumed ok #\e "x"))
   (assert-parse "éx" p '(consumed ok #xe9 "x")))
 (let ((p (noneOf "abc")))
   (assert-parse "oneOf"  p '(consumed ok #\o "neOf"))
   (assert-parse "coneOf" p '(empty error #f ("coneOf"))))
 (let ((p (noneOf "eé")))
   (assert-parse "ax" p '(consumed ok #\a "x"))
   (assert-parse "ex" p '(empty error #f ("ex")))
   (assert-parse "éx" p '(empty error #f ("éx"))))
 (let ((p (many1 (noneOf "%@")))
       (tag (parser-seq (char #\@) (many $letter))))
   (assert-parse "@foo123" p	'(empty error #f ("@foo123")))
   (assert-parse "@foo123" tag	'(consumed ok (#\@ (#\f #\o #\o)) "123"))
   (assert-parse "abc@foo" p	'(consumed ok (#\a #\b #\c) "@foo"))
   (assert-parse "abc@foo" tag	'(empty error #f ("abc@foo" "abc@foo")))
   (assert-parse "abc@foo123" (many (<or> p tag))
                 '(consumed ok
                            ((#\a #\b #\c)
                             (#\@ (#\f #\o #\o))
                             (#\1 #\2 #\3))
                            ""))
   (assert-parse "%@foo" (many (<or> p tag))
                 '(empty ok () "%@foo")))

 (let ((p (lookAhead $letter)))
   (assert-parse "look" p '(empty ok #\l "look"))
   (assert-parse "1look" p '(empty error #f ("1look"))))
 (assert-parse* "look2" (lookAhead (return #\x)) ;succeed with empty result
                '(empty ok #\x "look2"))

 (assert-parse "error" $err '(empty error #f ("error")))

 ;; other combinators

 (let ((p (skipMany $letter)))
   (assert-parse "a1"		p '(consumed ok () "1"))
   (assert-parse "abcd1"	p '(consumed ok () "1"))
   (assert-parse "123"		p '(empty ok () "123")))

 (let ((p (skipMany1 $letter)))
   (assert-parse "a1"		p '(consumed ok () "1"))
   (assert-parse "abcd1"	p '(consumed ok () "1"))
   (assert-parse "123"		p '(empty error #f ("123" "123"))))

 (let ((p (sepBy1 $letter (many $space))))
   (assert-parse "a    b"	p '(consumed ok (#\a #\b) ""))
   (assert-parse "a"		p '(consumed ok (#\a) ""))
   (assert-parse ""		p '(empty error #f ("" "" "")))
   (assert-parse "ab"		p '(consumed ok (#\a #\b) ""))
   (assert-parse "a  1"		p '(consumed ok (#\a) "  1"))
   (assert-parse "1a"		p '(empty error #f ("1a" "1a" "1a"))))

 (let ((p (sepBy $letter (many $space))))
   (assert-parse "a  b "	p '(consumed ok (#\a #\b) " "))
   (assert-parse "a1"		p '(consumed ok (#\a) "1"))
   (assert-parse "1"		p '(empty ok () "1")))

 (let ((p (between (char #\[) (char #\]) $letter)))
   (assert-parse "[a]"	p	'(consumed ok #\a ""))
   (assert-parse "[ a]"	p       '(empty error #f ("[ a]" " a]" " a]")))
   (assert-parse "ab"	p	'(empty error #f ("ab" "ab")))
   (assert-parse "[ax"	p	'(empty error #f ("[ax" "x" "x"))))
 ;; similar, but with a more complicated parser
 (define (ows p)
   (parser-seq p (~ $spaces)))
 (let ((p (between (ows (char #\[)) (ows (char #\])) (many1 $letter))))
   (assert-parse "[  bc]" p	'(consumed ok (#\b #\c) ""))
   (assert-parse "[ 1]" p	'(empty error #f ("[ 1]" "1]" "1]")))
   (assert-parse "[]" p		'(empty error #f ("[]" "]" "]"))))

 ;; hmm: should these have further error-input details?
 (assert-parse "not"      (<!> $letter)      '(empty error #f ("not")))
 (assert-parse "1not"     (<!> $letter)      '(consumed ok #\1 "not"))
 (assert-parse "notx"     (<!> (return #\x)) '(empty error #f ("notx")))
 (assert-parse "noterror" (<!> $err)         '(consumed ok #\n "oterror"))

 ;; similar, with the second argument
 (assert-parse "not2"    (<!> $letter $any) '(empty error #f ("not2"))) ;same as no-arg
 (let ((ld (<!> $letter $digit)))
   (assert-parse "not2" ld '(empty error #f ("not2")))
   (assert-parse "1ot2" ld '(consumed ok #\1 "ot2"))
   (assert-parse "_ot2" ld '(empty error #f ("_ot2"))))

 ;; Note: the following works with these parsers in this order, but
 ;; doesn't in the other order, because <or> doesn't implement a
 ;; longest-match semantics.  Needs more thought.
 (let ((p (<or> (parser-compose (l <- (many $letter))
                                (char #\@)
                                (return (append l '(at))))
                (parser-compose (l <- (many $letter))
                                (d <- (many $digit))
                                (return (append l d)))))
       (ptry (<or> (try (parser-compose (l <- (many $letter))
                                        (char #\@)
                                        (return (append l '(at)))))
                   (parser-compose (l <- (many $letter))
                                   (d <- (many $digit))
                                   (return (append l d))))))
   (assert-parse "comp123a" p '(consumed error #f ("123a" "123a")))
   (assert-parse "comp@a"   p '(consumed ok (#\c #\o #\m #\p at) "a"))
   (assert-parse "comp_a"   p '(consumed error #f ("_a" "_a")))

   (assert-parse "comp123b" ptry '(consumed ok (#\c #\o #\m #\p #\1 #\2 #\3) "b"))
   (assert-parse "comp@b"   ptry '(consumed ok (#\c #\o #\m #\p at) "b"))
   (assert-parse "comp_b"   ptry '(consumed ok (#\c #\o #\m #\p) "_b")))

 (let ((p (<any> $letter $digit)))
   (assert-parse "ab"	p	'(consumed ok #\a "b"))
   (assert-parse "1a"	p	'(consumed ok #\1 "a"))
   (assert-parse "_"	p	'(empty error #f ("_"))))

 ;; the contrast between these is...
 (assert-parse "1" (<any> (return '()) $digit) '(empty ok () "1"))
 (assert-parse "1" (<or> (return '()) $digit) '(consumed ok #\1 ""))

 ;; if no parsers consume input, then <or> backtracks to return the result of the first success.
 (assert-parse "1"
               (<or> (return "a") (return "b") (return "c"))
               '(empty ok "a" "1"))

 ;; test-case from Racket parsack documentation
 (let ((p (string "ab")))
   (assert-parse "ac"	p	'(consumed error #f ("ac" "c")))
   (assert-parse "ac"	(try p)	'(empty error #f ("ac" "ac" "c"))))

 )

(test-suite
 "sub-inputs"
 (module/expose 'klipspringer)          ;for make-parser-input

 (let* ((p1 (make-parser-input "ab"))
        (p2 (make-parser-input "12" :parent p1)))
   (assert-equal (drain p2) "12ab")
   ;; and a second time
   (assert-equal (drain p2) "12ab")
   (assert-equal (drain p1) "ab"))

 ;; checking parents, and input loops
 (let ((p1 (make-parser-input "1")))
   (assert-exception (make-parser-input "1" :parent p1))
   (assert-exception (make-parser-input "1" :parent (make-parser-input "2" :parent p1))))

 ;; files:
 ;; the files are arbitrary, here -- we don't actually parse them:
 ;; the goal is to be able to identify input/include loops
 (let ((r1 (make-unicode-reader/file "bib-t01-simple.bib"))
       (r2 (make-unicode-reader/file "./../test/bib-t01-simple.bib")))
   (assert-exception :body (make-parser-input r1 :parent (make-parser-input r1))
                     :re (regexp "input loop"))
   (assert-exception :body (make-parser-input r1 :parent (make-parser-input r2))
                     :re "input loop")
   (assert-exception :body (make-parser-input r1
                                              :parent (make-parser-input "string"
                                                                         :parent (make-parser-input r2)))
                     :re "input loop")
   (assert-true (parser-input?
                 (make-parser-input r1
                                    :parent (make-parser-input "string")))))

 ;; return with new-input
 (assert-parse "ab"
               (parser-compose $letter
                               (return #\x
                                       :new-input (λ (i)
                                                    (make-parser-input
                                                     (make-unicode-reader/string "boo!")
                                                     :parent i))))
               '(consumed ok #\x "boo!b")))

(test-suite
 ;; test the interface behaviour of the exposed function parse-result
 "high-level function"

 (define letters
   (many $letter))

 (assert-equal (parse-result letters
                             (make-unicode-reader/string "abc1" :ascii-characters? #t))
               '(#\a #\b #\c))
 (assert-equal (parse-result letters
                             (make-unicode-reader/string "abc2" :ascii-characters? #t))
               '(#\a #\b #\c))
 (assert-equal (parse-result letters "abc3")
               '(#x61 #x62 #x63))

 (receive (res inp)
     (parse-result2 letters "abc6")
   (assert-equal res '(#x61 #x62 #x63))
   (assert-equal (drain inp) "6"))

 ;; bad source argument to parse-result
 (assert-exception (parse-result letters 99))

 (assert-exception (parse-result $letter "99")) ;fails, consuming no input
 (let ((res (parse-result $letter "99" :on-error list)))
   ;; the +description+ of the $letter parser is "char-alpha?"
   (assert-equal (car res) "char-alpha?"))

 (let ((string->lexemes
        (λ (str)
          (let ((i 0))
            (λ ()
              (if (= i (string-length str))
                  #<eof>
                  (let ((c (string-ref str i)))
                    (set! i (+ i 1))
                    c)))))))
   ;; Call parse-result with a lexeme-source rather than a string:
   ;; this (a) confirms this is still supported;
   ;; and (b) tests the error-handling code when the lexeme-source is one
   ;; which doesn't support calling with 'location as argument.
   (assert-exception (parse-result $letter (string->lexemes "99")))))