;; A parser for the 'TeX strings' inside BibTeX (scare-quotes deliberate).
;;
;; 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 'klipspringer 'unicode)
(define-macro (%module-verbosity-flag%) 512)

;; procedures provided in module subtex*
(define *provide-in-starred-version* (inlet))
(define-macro (module-provide-starred sym . syms)
  `(varlet *provide-in-starred-version*
           . ,(apply append
                     (map (λ (s)
                            `((#_quote ,s) ,s))
                          (cons sym syms)))))

;; a 'bstring' is a 'braced string',
;; referring to TeX {braced content} parsed from a string.
;; The idea is that a bstring can be handled much as a `string?` or
;; `ustring?` object, but in ways that preserve internal structure.
;; Specifically, no-break-spaces are handled separately, and internal
;; braced content.
;;
;; Also, when they are parsed, all TeX \commands are examined within
;; the string, and may be substituted appropriately.
;;
;; If these match a ‘well-known’ LaTeX accent such as \'e for "é",
;; then the escape sequence is replaced by that letter.  The specific
;; list is in misc/unicode/characters.scm
;;
;; If the command matches a string which can be looked up in
;; user-char-command, then the escape sequence is replaced by the
;; output of that.
;;
;; Otherwise, the escape sequence is turned into a string.
;;
;; Escape sequences are not special after this point.

;; The functions in this module are exposed and documented only selectively.
;; Only `bstring?`, `user-char-command`, `parse-subtex`, and `ustring->ustring`
;; are exposed by the module `'subtex`, and the later two are very
;; similar to each other.
;;
;; However other procedures are exposed in module `'subtex*`, for use
;; by the `authors.scm` module.  These are to be used only internally.

;; This function is mostly redundant, since the checking of
;; permissible content within bstrings is managed by
;; bstring-normalise-content*.
(define (bstring-content? x)
  #"""`(bstring-content? x)` : true if `x` is permitted content for a bstring.

  A bstring can contain:

     * `bstring?`, which corresponds to `{braced content}` within the input string; or
     * `ustring?`; or
     * the symbol `'nbsp`, representing a tie/tilde.

  Though this is the content of a bstring, you are not expected to
  manipulate the contents, and the object should be printed only using
  `bstring->ustring`."""
  (or (ustring? x)
      (bstring? x)
      (eqv? x 'nbsp)))

(define (make-bstring-iterator/chunks ts)
  (if (bstring? ts)
      (make-iterator (ts 'content))
      (beastie-error "make-bstring-iterator/chunks: not a bstring: ~s" ts)))
(define (make-bstring-iterator ts)
  ;; the resulting iterator returns bstring? as is,
  ;; but returns ustring? a character at a time
  (let* ((contents (make-bstring-iterator/chunks ts))
         (c1 #f))                       ;currently iterating item
    (make-iterator
     (let ((+iterator+ #t))
       (λ ()
         (let ((next (and c1 (c1))))
           (if (or (not next)
                   (eof-object? next))
               (let ((next-chunk (contents)))
                 ;(printf "next-chunk: ~s~%" next-chunk)
                 (cond
                  ((eof-object? next-chunk)
                   next-chunk)          ;end of iteration
                  ((ustring? next-chunk)
                   ;(printf "(ustring)~%")
                   (set! c1 (make-iterator next-chunk))
                   (c1))
                  ((bstring? next-chunk)
                   next-chunk)
                  ((eqv? next-chunk 'nbsp)
                   next-chunk)
                  (else
                   (beastie-error "unexpected item ~s in bstring" next-chunk))))
               next)))))))

(define/provide (ustring-iterator/bstrings us)
  #"""`(ustring-iterator/bstrings us)` : returns an iterator over the ustring,
  which will return single codepoint-integers on each call, just like the
  usual ustring iterator, except that it will return `{braced content}` as
  a single `bstring?` object, and non-breaking spaces (ie, from `"~"`)
  as a symbol `'nbsp`.

  This, along with `list->bstring`, allows you to work through a ustring
  in a TeX/bst-compatible fashion, by preserving no-break spaces,
  and identifying all content outside brace-level 0.
  It means that, given a ustring `#"ab~c{d}"`, the operation

      (list->bstring (map values (ustring-iterator/bstrings #"ab~c{d}")))

  is effectively a no-op."""
  (make-bstring-iterator (string->bstring us)))
(module-provide-starred ustring-iterator/bstrings)

;; Return the string content of the bstring
;; (internal function, so no type checking).
(define (bstring-content* ts)
  (unless (bstring? ts)
    (error 'wrong-type-arg "bstring-content*: expected bstring?, got ~s" ts))
  (ts 'content))

(define (simple-bstring-content* ts)
  ;; if the bstring consists of precisely one ustring, then return it;
  ;; otherwise #f.
  ;; (this is for the benefit of a fast path below)
  (let ((c (bstring-content* ts)))
    (and (= (length c) 1)
         (ustring? (car c))
         (car c))))

(define (bstring=? t1 t2)
  #"""`(bstring=? t1 t2)` : return true if both arguments are
  bstrings, with equal content.
  At present, this is not a fully successful equivalence function,
  since two bstrings with the same written form but different internal
  structures (eg, '(#"a" #"b") vs '(#"ab")) will show as non-equal."""
  #;(eprintf "bstring=? t1=~s  t2=~s : ~s and ~s~%" t1 t2
           (map object->string (bstring-content* t1))
           (map object->string (bstring-content* t2)))
  (and (bstring? t1)
       (bstring? t2)
       (equal? (bstring-content* t1) (bstring-content* t2))))
;; the following (like bstring-reader and bstring->ustring)
;; is only provided in subtex* because test-subtex uses it
(module-provide-starred bstring=?)

;; convenience, for debugging messages
(define (subtex-type-of* x)
  (cond ((bstring? x) 'bstring)
        ((ustring? x) 'ustring)
        (else (type-of x))))

;; A cmd? struct encapsulates a \\cs or \\cs{arg}.
;; This is only for passing these around more conveniently below
;; (and avoiding a couple of unparsings),
;; and these are normalised away in bstring-normalise-content*
(struct cmd
        cs                              ;the command name, as a ustring
        arg)                            ;the command argument, as a bstring, or #f

(define-values (make-bstring* bstring?)
  (let ((*tag* "bstring"))
    (values
     (λ (l)
       ;;(eprintf "make-bstring: l=~s ~s~%" l (map subtex-type-of* l))
       (openlet
           (inlet 'type *tag*
                  'content (if (list? l)
                               (bstring-normalise-content* l)
                               (beastie-error "can't construct bstring object with ~s" l))
                  'equal? bstring=?
                  'object->string (lambda* (ts1 (write? #t) (max-len 'ignored))
                                    (ustring->string
                                     (bstring->ustring ts1 :write write?)
                                     #f)) ;#f because this is already in a write format
                  'make-iterator make-bstring-iterator)))
     (λ (x)
       ;; Do I perhaps want to _not_ document the internals here,
       ;; since this is to be manipulated only by other functions.
       #"""`(bstring? x)` : return #t if the argument is a bstring.

        A `bstring?` is a 'TeX string', returned by `string->bstring`.
        The bstring can contain objects of type `bstring-content?`."""
       (and (let? x)
            (eq? (x 'type) *tag*))))))
(module-provide bstring?)
(module-provide-starred bstring?)

;; Normalise the argument to make-bstring*:
;; (listof (or/c bstring? bstring-content? cmd?)) -> (listof (or/c bstring? bstring-content?))
;;
;; The only changes are that
;;
;;   * cmd? instances are expanded to ustring?,
;;   * integer codepoints are turned into ustring?, and
;;   * sequences of ustring? or integer? items are coalesced into single ustrings.
;;
;; The latter is more for tidiness than functionality.
;; We aim to have no successive ustring objects,
;; but don't guarantee this.
;;
;; This is also the function which ensures that only objects of
;; acceptable types are included in bstrings.
(define (bstring-normalise-content* items)
  ;;(eprintf "bstring-normalise-content*: ~s~%" items)
  (let loop ((i items)
             (maybe-space #f)
             (res '())
             (our-ustring? #f))         ;true if (car res) is a ustring we own
    ;; maybe-space: if this is 'check, then we add an extra space
    ;; before (car i) if that starts with a letter;
    ;; if it's 'prime, then the next call will make it 'check;
    ;; otherwise it's #f.
    (if (null? i)
        (reverse! res)
        (let ((i0 (car i)))
          (cond ((or (bstring? i0)
                     (eqv? i0 'nbsp))
                 (loop (cdr i) #f (cons i0 res) #f))

                ((or (ustring? i0)
                     (integer? i0))
                 (cond ((and (eqv? maybe-space 'check)
                             (if (ustring? i0)
                                 (char-alpha? (ustring-car i0))
                                 (char-alpha? i0)))
                        ;; the next item starts with an alphabetic
                        ;; character, so yes, we do want to add a space
                        (loop (cons #x20 i)
                              #f
                              res
                              our-ustring?))

                       ((and (not (null? res))
                             (ustring? (car res)))
                        ;; previous item was a ustring?, so append
                        (if our-ustring?
                            (begin
                              (ustring-append! (car res) i0)
                              (loop (cdr i)
                                    (if (eqv? maybe-space 'prime) 'check #f)
                                    res
                                    #t))
                            (loop (cdr i)
                                  (if (eqv? maybe-space 'prime) 'check #f)
                                  ;; create a new ustring, so we don't change
                                  ;; an existing one which might be used elsewhere
                                  (cons (ustring-append (car res) i0)
                                        (cdr res))
                                  #t)))

                       ((ustring? i0)
                        (loop (cdr i)
                              (if (eqv? maybe-space 'prime) 'check #f)
                              (cons i0 res)
                              #f))

                       (else ; i0 is an integer (maybe-check can only be #f)
                        (loop (cdr i)
                              #f
                              (cons (make-ustring i0) res)
                              #t))))

                ((cmd? i0)
                 ;; an unrecognised \cs or \cs{arg} -- stringify it
                 (let ((cs (cmd-cs i0))
                       (arg (cmd-arg i0)))
                   ;; Turn this cs, with possible argument, into a ustring,
                   ;; and loop again, with the car of the first argument
                   ;; now being a ustring
                   (if arg
                       (loop (cons (make-ustring (sprintf "\\~a{~a}" cs arg))
                                   (cdr i))
                             #f
                             res
                             our-ustring?)
                       (loop (cons (make-ustring "\\" cs)
                                   (cdr i))
                             (if (char-alpha? (ustring-car cs)) 'prime #f)
                             res
                             our-ustring?))))

                (else
                 (beastie-error "bstring-normalise-content*: unexpected content ~s" i0)))))))

(define (bstring-create . items)
  #"""`(bstring-create bstring? | bstring-content? ...) -> bstring?`
  : append objects into a new bstring?.
  Creates a new string from the `bstring-content?` objects.

  Note that `(bstring-create #{a} #{b})` will produce the bstring `#{{a}{b}}`.
  If you want to append the contents, then see `bstring-append`."""
  (make-bstring* items))
(define/provide (list->bstring items)
  #"""`(list->bstring l)` : given a list of `ustring?`, `integer?`, `bstring?`,
  or `'nbsp`, create a new `bstring?` object."""
  (make-bstring* items))
(module-provide-starred list->bstring)

(define (bstring-append . items)
  #"""`(bstring-append bstring?...)`
  : append the _contents_ of the bstring arguments.
  Compare `bstring-create`."""
  (make-bstring*
   (apply append
          (map (λ (ts)
                 (unless (bstring? ts)
                   (error 'wrong-type-arg "bstring-append: arguments must all be bstring?, not ~s" ts))
                 (bstring-content* ts))
               items))))

(define (bstring-empty? b)
  "`(bstring-empty? t)` : true if the bstring has no content"
  (if (bstring? b)
      (null? (bstring-content* b))
      (error "Can't call bstring-empty? on ~s" b)))

(module-provide-starred bstring-create bstring-append bstring-empty?)

(define (bstring-length* ts)
  #"""`(bstring-length* ts)` : return the number of elements in the bstring
  (which is different from the number of characters in it)."""
  (length (bstring-content* ts)))

(define (bstring-length ts)
  "`(bstring-length ts)` : return the number of characters in the bstring."
  (if (bstring? ts)
      (apply +
             (map (λ (x)
                    (cond ((ustring? x)
                           (ustring-length x))
                          ((bstring? x)
                           (bstring-length x))
                          ((eqv? x 'nbsp) 1)
                          (else         ;this shouldn't be possible
                           (error 'wrong-type-arg "bstring-length*: found x=~s" x))))
                  (bstring-content* ts)))
      (error 'wrong-type-arg "bstring-length: requires bstring?, got ~s" ts)))
(module-provide-starred bstring-length)

(define (bstring-car ts)
  #"""`(bstring-car ts)` : return the first character in the bstring,
  as an integer, or `#f` if the bstring is empty.

    * If the first item in the bstring is a codepoint,
      then return the codepoint, obviously.
    * If the first item is a ustring,
      then return the first character of the ustring.
    * If the first item is a bstring,
      then return the bstring-car of it
      (note that this means that the bstring-car of `"{}a"` is `#f`).
  """
  (if (= (bstring-length* ts) 0)
      #f
      (let ((ts1 (car (bstring-content* ts))))
        (cond ((ustring? ts1) (ustring-car ts1))
              ((bstring? ts1) (bstring-car ts1))
              (else (beastie-error "bstring-car: unexpected content ~s in bstring" ts1))))))
(module-provide-starred bstring-car)

(define* (bstring-tokenize ts (pred? #f))
  #"""`(bstring-tokenize ts)` : split the bstring `ts` into a list of substrings,
  where each substring is a maximal non-empty contiguous sequence of characters
  separated by codepoints which match a predicate.

  Any `bstring?` objects within the bstring are regarded as unsplittable,
  so `#{a b{c d}}` would split into bstrings `#{a}` and `#{b{c d}}`.

  The predicate indicates codepoints which should be _included_ in the resulting tokens.
  The default is any character which is not ‘whitespace’,
  in the sense of one which matches `char-wordbreak?`.

  Returns a list of `bstring?`.

  This is similar to procedures `string-tokenize` and `ustring-tokenize`."""
  (unless (bstring? ts)
    (error 'wrong-type-arg "bstring-tokenize: requires bstring argument, got ~s" ts))
  (let ((included? (or pred? (λ (c) (not (char-wordbreak? c)))))
        (i (make-iterator ts)))
    (let loop ((i0 (i))
               (res '())
               (current-token '())
               (current-ustring (make-ustring)))
      (cond ((eof-object? i0)
             (cond ((> (ustring-length current-ustring) 0)
                    (loop i0 res (cons current-ustring current-token) (make-ustring)))
                   ((not (null? current-token))
                    (loop i0
                          (cons (apply bstring-create (reverse! current-token))
                                res)
                          '()
                          (make-ustring)))
                   (else                ;the result
                    (reverse! res))))
            ((bstring? i0)
             ;; add this to current-token
             (if (= (ustring-length current-ustring) 0)
                 (loop (i) res (cons i0 current-token) current-ustring)
                 (loop i0 res (cons current-ustring current-token) (make-ustring))))
            ((included? i0)
             ;; add this to current-ustring
             (ustring-append! current-ustring i0)
             (loop (i) res current-token current-ustring))
            (else
             (cond ((> (ustring-length current-ustring) 0)
                    ;; add this ustring to the current token, and recurse
                    (loop i0 res (cons current-ustring current-token) (make-ustring)))
                   ;; from here, we know current-ustring is empty
                   ((null? current-token)
                    ;; nothing to do
                    (loop (i) res current-token current-ustring))
                   (else
                    ;; add to the result
                    (loop (i)
                          (cons (apply bstring-create (reverse! current-token))
                                res)
                          '()
                          current-ustring))))))))

(define (bstring-join ts-list joiner)
  (unless (bstring? joiner)
    (error 'wrong-type-arg "bstring-join: expects joiner to be bstring?, got ~s" joiner))
  (if (null? ts-list)
      (bstring-create)
      (apply bstring-append
             (let loop ((tss (cdr ts-list))
                        (res (list (car ts-list))))
               (cond ((null? tss)
                      (reverse! res))
                     ((bstring? (car tss))
                      (loop (cdr tss)
                            `(,(car tss) ,joiner . ,res)))
                     (else
                      (error 'wrong-type-arg "bstring-join: expects list of bstring, got ~s" ts-list)))))))

(module-provide-starred bstring-tokenize bstring-join)


;;;; Parsing

;; For clarity, parsers here are named with a leading '$'

(define $codepoint
  (>>= (noneOf "\\${}~")
       (λ (cp)
         (return cp))))
(define $plain
  ;; returns a list of codepoints
  (>>= (many1 (noneOf "\\${}~ "))
       (λ (l)
         (return
          (apply make-ustring l)))))

;; When debugging we occasionally want to make NBSPs visible,
;; so pick a suitable integer here, such as #x2b for "+".
;; Cf authors.scm and test-authorlist.scm
;; (but note that various tests will spuriously break in this case).
;; Use something other than "~", to confirm we're not inadvertently just
;; passing that through.
(define $tilde
  (>>= (oneOf "~ ") ; either tilde or U+00A0, NO-BREAK SPACE
       (λ (_)
         (return 'nbsp))))

(define $maths
  (parser-compose (char #\$)
                  (maths <- (many1 (<or> (parser-seq (~ (char #\\)) ;ignore any command sequences
                                                     $any
                                                     :combine-with (λ (x) (list #x5c x)))
                                         (many (noneOf "$\\")))))
                  ;; If the $...$ is ended by EOF, and not '$',
                  ;; then we could
                  ;; (1) throw an error,
                  ;; (2) add in the missing '$', or
                  ;; (3) return the literal sequence.
                  ;; I think that (3) is best, on the grounds that we
                  ;; want this subtex parsing to be rather
                  ;; unintrusive, so any errors here are for TeX to
                  ;; discover later.
                  (terminator <- (<or> (char #\$) $eof))
                  (return
                   (make-ustring #\$
                                 maths
                                 (if (eof-object? terminator)
                                     '()
                                     #\$)))))

(define $bstring
  ;; Returns a single bstring? item.
  ;; Special case: if the thing to be returned is a single codepoint
  ;; above the ASCII range -- ie, {é} but not {e} or {ée} -- then return it unbraced,
  ;; as just a single codepoint.
  ;;
  ;; This is intended to support the BibTeX-described special case of
  ;; expanding "n{\'e}e" into "née".  However it also currently
  ;; matches the case where the thing in the braces is _not_ expanded,
  ;; and so "n{é}e" is parsed as "née", also.  This latter behaviour
  ;; might be undesirable, since the user might _want_ a single
  ;; Unicode character to be protected by braces, but avoiding it
  ;; would involve the $command production, below, flagging that a
  ;; resulting bstring has come about through command expansion, the
  ;; $subtex production passing that on, and this production
  ;; responding appropriately.  Possible, but this would also require
  ;; the other cases where a $subtex production appears to handle that
  ;; case, so this is a more extensive fix than it may at first seem,
  ;; to avoid a rather marginal issue.  The other thing to consider is
  ;; whether this special case should be restricted to level-1 braces
  ;; (which is what the BibTeX documentation describes); here, it
  ;; applies to all levels, which seems more consistent.
  (parser-compose (char #\{)
                  (content <- $subtex)   ;bstring?
                  (char #\})
                  (return
                   (let ((cp1 (and (= (bstring-length* content) 1)
                                   (let ((c1 (car (bstring-content* content))))
                                     (cond ((ustring? c1)
                                            (and (= (ustring-length c1) 1)
                                                 (ustring-car c1)))
                                           ((integer? c1) c1)
                                           (else #f))))))
                     (if (and cp1
                              (>= cp1 #x80))
                         cp1
                         content)))))

;; FIXME: this doesn't work, for some reason.
;; With $escapes included below (currently commented out) "\\'\\i" doesn't parse.
;;
;; But this doesn't matter, since "a\\}b" is parsed as an unrecognised
;; command sequence, which amounts to the same thing as escaping it.
(define $escapes
  ;; The only escapes we recognise are \{ and \}, which we parse as
  ;; '{' and '}', rather than as commands.
  ;; (parser-one (char #\\)
  ;;             (~> (<any> (char #\{) (char #\}))))
  (parser-seq (~ (char #\\))
              (<any> (char #\{) (char #\}))
              :combine-with (λ (l)
                              (eprintf "$escapes: l=~s~%" l)
                              l)))

(define $command
  ;; Parse a \cmd or \<char> command-sequence, looks it up,
  ;; returns a parser.
  ;; This parser may return a ustring or bstring expanded from the command, or
  ;; the parser which may go on to consume other input, which returns a ustring or bstring.
  ;;
  ;; This discards a backslash at the end of the string.  It's not
  ;; 100% clear to me that this is the right thing to do.  It's pretty
  ;; clearly an error, but by fixing it, we're being interventionist
  ;; in a way opposite to the discussion of non-terminated maths
  ;; above.  This also discards a command which has such an argument:
  ;; "a\v\" parses to "a".  Other behaviour would be sane.
  (parser-compose (char #\\)
                  (cs <- (<any>
                          $eof    ;error -- backslash at end of string
                          (many1 $letter) ;sequence of letters (ASCII only)
                          (<!> $letter))) ;one non-letter
                  (many $space)
                  (if (eof-object? cs)
                      $err
                      (let* ((cmdstr       ; list of codepoints -> string
                              ;; (because %subtex-mappings% is a string hash)
                              (unicode-encode/utf8
                               (if (list? cs)
                                   cs
                                   (list cs))))
                             (expn (or (user-char-command* cmdstr)
                                       (char-command cmdstr))))
                        ;(eprintf "command: ~s -> cmdstr ~s -> ~s~%" cs cmdstr expn)
                        (cond ((not expn)
                               (return (make-cmd (make-ustring cmdstr) #f)))
                              ((procedure? expn) expn) ;a parser
                              ((ustring? expn) (return expn))
                              ((string? expn) (return (make-ustring expn)))
                              ((integer? expn) (return expn))
                              (else
                               (print-warning "parse command: \\~a -> [peculiar] ~s"
                                              cs expn)
                               ;; FIXME: perhaps I should actually fail here,
                               ;; rather than return some gibberish
                               (return expn)))))))

(define $subtex
  ;; returns a list of bstring?, string?, or (listof integer) [ie, codepoints]
  ;(many (<any> bstring command tilde plain maths))
  (>>= (many (<any> $bstring
                    ;;$escapes -- not needed, see note above
                    $command $tilde $plain $maths))
       (λ (l)
         (return (apply bstring-create l)))))

;; this duplicates a non-exposed definition in klipspringer.scm
(define (->cp ci)
  (cond ((char? ci) (char->integer ci))
        ((integer? ci) ci)
        (else (error "->cp given ~s" ci))))

(define (make-arg-parser/lookup cs f)
  ;; Return a parser which will parse the argument of a `\cs` argument,
  ;; and then return F applied to that argument.
  ;; The command-sequence string cs will typically be a single letter;
  ;; we depend on this only to the extent that we assume that if the
  ;; first character of it is a letter, then all of the characters in
  ;; it are similar.
  ;;
  ;; If this lookup fails, it is because we are looking at something like
  ;; \"x, invalid (or at least unexpected) input which is ultimately a user error.
  ;; The POLA thing to do here is unclear: just the input as a string?
  (>>= (<or> $letter ;eg, \"u or \textbf u or \^<dotless-i> -> integer
             $bstring                   ;eg \"{u} -> (listof bstring?)
             ;;$escapes
             $command                   ;eg \"\i  -> ustring?
             $eof)
       (λ (c)
         (cond ((eof-object? c)
                ;; (return (make-cmd cs #f char-command?))
                ;; this parser for \cs _was_ expecting an argument:
                ;; returning "\cs" seems the least unexpected thing to do
                (print-info "(make-arg-parser/lookup) [eof]: -> \\~a" cs)
                                        ;(return (cons 'cmd (make-ustring cs)))
                (return (make-cmd (make-ustring cs) #f)))

               ((or (integer? c) (char? c)) ;codepoint
                (let* ((cp (->cp c))
                       (result (f cp)))
                  (print-info "(make-arg-parser/lookup) [char/integer]: \\~a{U+~x} -> ~s"
                              cs cp result)
                  (cond ((procedure? result) result) ;result is a parser
                        (result (return result))
                        (else
                         ;; the inner make-ustring is for the case where
                         ;; c is an integer codepoint
                         (return        ; the input, reassembled
                          (make-ustring
                           (sprintf "\\~a{~a}" cs
                                    (if (char? c)
                                        c
                                        (make-ustring c)))))))))

               ((bstring? c)
                ;; The content of this item is a bstring, as returned by
                ;; the subtex parser above.  We want to see if the
                ;; first item in that argument is one that f recognises.
                (let* ((content (bstring-content* c))
                       (arg (if (= (length content) 1)
                                (car content)
                                #f)))
                  (let ((result (f arg))) ;apply the function
                    (print-info "(make-arg-parser/lookup) [bstring]: \\~a{~s} -> ~s"
                                cs arg result)
                    (cond ((procedure? result) result) ;result is a parser
                          (result (return result))
                          (else (return (make-ustring (sprintf "\\~a{~a}" cs c))))))))

               ((cmd? c)
                ;; if we're seeing a cmd? here, then it's an unrecognised
                ;; one, so there won't be a lookup for it
                (return
                 (make-cmd cs
                           (make-bstring* (list #x5c (cmd-cs c))))))

               (else
                (beastie-error "Unexpected parse within make-arg-parser: ~s" c))))))

(define (binary-search v k cmp3 return-pair?)
  ;; If V is a vector of (k1 . v1), then search it for the k1 which
  ;; matches K.  The function CMP3 is applied to pairs of k, k1, and
  ;; returns negative/zero/positive if the first is ordered
  ;; before/equal/after the second.  The vector V must be sorted
  ;; consistent with this.
  ;;
  ;; If RETURN-PAIR? is true, then return the matching pair,
  ;; otherwise, return the cdr.
  (let bsearch ((nl 0)
                (nr (vector-length v)))
    (let ((sep (- nr nl)))
      ;(format #t "nl=~s  nr=~s  sep=~s~%" nl nr sep)
      (if (< sep 3)
          (let linear-search ((i nl))
            (if (= i nr)
                #f
                (let* ((vi (vector-ref v i))
                       (disc (cmp3 k (car vi))))
                  ;(format #t "  i=~s   cmp3(~s,~s) = ~s~%" i k (car (vector-ref v i)) disc)
                  (cond ((> disc 0) (linear-search (+ i 1)))
                        ((= disc 0) (if return-pair? vi (cdr vi)))
                        (else #f)))))
          (let* ((nm (+ nl (quotient sep 2)))
                 (vi (vector-ref v nm))
                 (disc (cmp3 k (car vi))))
            ;(format #t "  nm=~s  disc=~s~%" nm disc)
            (cond ((< disc 0) (bsearch nl nm))
                  ((= disc 0) (if return-pair? vi (cdr vi)))
                  (else (bsearch nm nr))))))))

(define (cmp3/string a b)
  ;; Given strings a and b, return 0 if they're string=?, and
  ;; negative/positive if a is lexicographically before/after b
  (cond ((string=? a b) 0)
        ((string<? a b) -1)
        (else +1)))

(define user-char-command*
  (let ((m (make-hash-table 8 string=? (cons string? procedure?))))
    (define (U x)
      (cond ((or (integer? x)
                 (string? x))
             (make-ustring x))
            ((or (ustring? x)
                 (bstring? x))
             x)
            (else (beastie-error "unexpected value in user-char-command: ~s" x))))
    (λ (k . vv)
      (cond ((eqv? k 'kill-all-user-chars-for-testing) ;magic
             (set! m (make-hash-table 8 string=? (cons string? procedure?))))
            ((null? vv)
             (m k))
            ((ustring? k)
             (user-char-command* (ustring->string k :display) (car vv)))
            ((not (string? k))
             (error 'wrong-type-arg "user-char-command: key must be string?, not ~s" k))
            (else
             (let ((genparser
                    (let ((v (car vv)))
                      (cond ((or (ustring? v)
                                 (bstring? v)) ;not a procedure; just a string
                             (return v))
                            ((or (string? v) (integer? v))
                             (return (U v)))
                            ((procedure? v)
                             (let ((nargs (car (arity v))))
                               (case nargs
                                 ((0) (return (U (v))))
                                 ((1) (>>= (<or> $bstring $codepoint)
                                           (λ (ts)
                                             (return (U (v (U ts)))))))
                                 ((2) (>>= (<or> $bstring $codepoint)
                                           (λ (ts1)
                                             (>>= (<or> $bstring $codepoint)
                                                  (λ (ts2)
                                                    (return (U (v (U ts1) (U ts2)))))))))
                                 ;; I'd need to think more about how to generalise this
                                 ;; to arbitrary nargs
                                 (else
                                  (beastie-error "user-char-command: unimplemented, nargs=~s" nargs)))))
                            (else (beastie-error "user-char-command: bad argument ~s (must be ustring? or procedure?)" v))))))
               (hash-table-set! m k genparser)))))))

(define/provide (user-char-command k v)
  #"""`(user-char-command key value)` : add a mapping for TeX-style `\\cmd` sequences.
  The `key` must be a `string?` or `ustring?`.
  The value may be a `string?`, `ustring?` or `integer?` codepoint,
  or a procedure of zero, one or two (currently no more) arguments,
  which evaluates to one of those types.

  Thus, after

       (user-char-command "pounds" #"£")
       (user-char-command "poundstring" "lb")
       (user-char-command "poundtstring" #{lb})
       (user-char-command "poundnum" #xa3)
       (user-char-command "poundsproc" (λ () #"£££"))
       (user-char-command "poundsproci" (λ () "££"))
       (user-char-command "poundsprocii" (λ () #xa3))
       (user-char-command "emph" (λ (a) (make-ustring (sprintf "**~a**" a))))
       (user-char-command "concat" (λ (a b)
                                     (sprintf "(~a/~a)" a b)))

  we might evaluate an input string as follows

      (ustring->string
       (ustring->ustring "ab\\pounds c \\emph{d} and \\concat e{f}"))
      -> "#"ab£c **d** and (e/f)""

  In an input string, any unrecognised commands are turned into a
  string version of the command, without error.  The only pre-defined
  commands are the single-character ones discussed in `parse-subtex`, below.

  If you are interested in expanding commands within `.bib` files,
  then these commands must be defined before the `.bib` file is read.
  """
  (user-char-command* k v))

(define (char-command cs)
  (let ((kv (binary-search %subtex-mappings% cs cmp3/string #t)))
    (and kv
         (let ((v (cdr kv)))
           (cond ((integer? v) v)
                 ((vector? v)
                  ;; v is a vector of (integer . integer) pairs.
                  ;; _Replace_ the cdr here with a parser which does a lookup of this vector.
                  ;; (this is an optimisation, which avoids us
                  ;; recreating this function on every call)
                  (set-cdr! kv
                            (make-arg-parser/lookup cs
                                                    (λ (arg)
                                                      (cond ((integer? arg)
                                                             (binary-search v arg - #f))
                                                            ((ustring? arg)
                                                             ;; if this is a single-character string,
                                                             ;; then look up the character;
                                                             ;; else no match
                                                             (if (= (ustring-length arg) 1)
                                                                 (binary-search v (ustring-car arg) - #f)
                                                                 #f))
                                                            (else #f)))))
                  (cdr kv))
                 ((procedure? v) v)     ;optimisation done before
                 (else
                  (beastie-error "char-command: unexpected search result \\~a -> ~s" cs v)))))))

;;;; writing bstrings

(define (bstring->ustring/display* ts show-braces nbsp)
  ;; The most common case is a bstring containing only a single ustring,
  ;; so include a fast path for this below.
  ;;
  ;; The argument show-braces is 'include, 'exclude, or 'skip-outermost:
  ;; see function bstring->ustring for discussion.
  (cond ((and (not (eqv? show-braces 'include))
              (simple-bstring-content* ts))) ;fast path
        (else                                ;the content is a mix of ustrings and bstrings
         (let ((i (if (iterator? ts)
                      ts
                      (make-bstring-iterator/chunks ts)))
               (result (if (eqv? show-braces 'include)
                           (make-ustring #\{)
                           (make-ustring))))
                                        ;(eprintf "(bstring->ustring/display* [[~s]] ~s)~%" (map values (ts 'content)) show-braces)
           (let loop ()
             (let ((c (i)))
               (cond ((eof-object? c)
                                        ;(eprintf "bstring->ustring/display*: result=~s~%" (subtex-type-of* result))
                      (when (eqv? show-braces 'include)
                        (ustring-append! result #\}))
                      result)

                     ((bstring? c)
                      (ustring-append! result
                                       (bstring->ustring/display* c
                                                                  (if (eqv? show-braces 'skip-outermost)
                                                                      'include
                                                                      show-braces)
                                                                  nbsp))
                      (loop))

                     ((ustring? c)
                      (ustring-append! result c)
                      (loop))

                     ((eqv? c 'nbsp)
                      (ustring-append! result nbsp)
                      (loop))

                     (else
                      (beastie-error "bstring->ustring/display*: unexpected content ~s" c)))))))))

(define (subtex-item->ustring/write* x)
  (cond ((ustring? x) x)
        ((bstring? x) (bstring->ustring/write* x #f))
        ((eqv? x 'nbsp) "~")
        (else (error 'wrong-type-arg "subtex-item->ustring/write*: unexpected argument ~s" x))))

(define (bstring->ustring/write* ts leading-hash?)
  ;(eprintf "bstring->ustring/write* ~s~%" (subtex-type-of* ts))
  (ustring-append
   (if leading-hash? "#{" "{")
   (map subtex-item->ustring/write*
        (if (iterator? ts) ts (make-bstring-iterator/chunks ts)))
   "}"))

;;;; The following is perhaps slightly too cute!
(define (bstring-reader str)
  #"""A reader for the syntax #{string \cmd{value}}.
  This can be used by calling
  `(set! *#readers* (cons (cons #\{ bstring-reader) *#readers*))`.

  There are no escapes recognised within the string.
  Thus `#{foo\nbar}` would be parsed as a string containing a command `\nbar`."""
  ;; we parse $subtex enclosed within {...}; that is, the outermost
  ;; braces don't act as level-1 braces.
  (parse-result $subtex
                (let ((i (compose-iterators*
                          (make-iterator (unicode-decode/utf8 str))
                          unicode-decode1/port/utf8))
                      (level 1)         ;last #\} will drop this to zero
                      (eof? #f))
                  (i)                   ;discard leading '{'
                  (λ ()
                    (if eof?
                        #<eof>
                        (let ((c (i)))
                          (when (eof-object? c)
                            (beastie-error "unexpected EOF in #{...}"))
                          (case c
                            ((#x7b)     ;#\{
                             (set! level (+ level 1))
                             c)
                            ((#x7d)     ;#\}
                             (set! level (- level 1))
                             (if (= level 0) ;closing brace
                                 (begin
                                   (set! eof? #t)
                                   #<eof>)
                                 c))
                            (else c))))))))
(module-provide-starred bstring-reader)
;(set! *#readers* (cons (cons #\{ bstring-reader) *#readers*))

;; this function can be given either a bstring?
;; or a list of bstring-content? items
;;
;; FIXME: I suspect what I actually want here is bstring->string, for output,
;; since that's what's probably about to happen to this string.
;; The generation of this string might involve some conversion of
;; string -> ustring, redundantly.
(define/provide* (bstring->ustring ts (write 'display) (nbsp "~"))
  #"""`(bstring->ustring ts [:write write/display/#t/#f/] [:nbsp string])` : format a bstring?.

  If the `:write` argument is `'display` or `#f` (the default),
  then produce a string for display;
  otherwise it should be `'write` or `#t` to produce a string that should be
  reparseable by `string->bstring`.

  If, instead of `'display`, the selector is `'display/braces` or
  `'display/without-braces`, then the output ustring is or is not displayed
  surrounded by braces, respectively.
  If it is just `:display` then the outermost braces are skipped,
  but inner ones are included.  This may seem a slightly fussy
  distinction, but recall that a .bib-file value like
  `"foo {bar}"` would be parsed as the bstring `#{foo {bar}}`, but the
  most natural way of printing this should end up with ‘foo {bar}’.
  I may add a settable global default
  (FIXME: cf subtex-load-hook* code above).

  The argument can alternatively be a list of `bstring-content?` objects.

  Note that this default, preferring display over write since that is more common,
  is opposite to the internal `object->string` function.
  """
  (cond ((not (or (bstring? ts) (iterator? ts)))
         (error 'wrong-type-arg "bstring->ustring: odd argument ~s" ts))
        ((or (eqv? write 'write)
             (and (boolean? write) write)) ;specifically #t
         (bstring->ustring/write* ts #t))
        (else
         (let* ((brace-handling (case write
                                  ((#f display) 'skip-outermost)
                                  ((display/braces) 'include)
                                  ((display/without-braces) 'exclude)
                                  (else
                                   (beastie-error "bstring->ustring: unexpected :write ~s" write))))
                (u (bstring->ustring/display* ts brace-handling nbsp)))
           (ustring-cache-set!* u 'bstring ts)
           u))))
(module-provide-starred bstring->ustring)

;; (define (bstring->string ts . rest)
;;   #"""`(bstring->string ts)` : convert a bstring all the way to a string.
;;   (Note: either this or bstring->ustring may disappear in future).

;;   If the optional second argument is `:display` or `#f` (the default),
;;   then produce a string for display;
;;   otherwise it should be `:write` or `#t` to produce a string that should be
;;   reparseable by `string->bstring`."""
;;   (let ((write? (and (not (null? rest)) (or (eq? :write (car rest)) (car rest)))))
;;     (ustring->string (bstring->ustring ts write?) :display)))

(define* (string->bstring str (on-error #f))
  #"""(string->bstring str [:on-error #f]) : parse a ‘subtex’ string or ustring,
  `str`, producing a `bstring?` object as result.

  Given:

      One \emph{sharp} ep{\'e}e {here}

  The function recognises both the TeX-style command `\emph`, and the
  TeX-style braces `{...}`, and and the ‘accent’ `{\'e}`, which it
  expands to ‘é’.  The result is an opaque `bstring?` object, which is
  manipulated and serialised using a number of procedures in this module.

  The string should be a valid UTF-8 string of characters or list of
  integer codepoints (ie, any unicode normalisation should be done
  elsewhere, perhaps by `unicode-decode/utf8).

  On error:
    * if ON-ERROR is `#f` (the default), then raise a beastie-error with subtag `'subtex`;
    * if ON-ERROR is `#t` return STR;
    * otherwise, return the keyword's argument as the function's value.

  That said, the procedure as currently implemented doesn't throw any
  errors on parse failures -- that is, we aim not to object to any input.
  The only errors thrown are for internal coding errors, which shouldn't
  be caught here.  I may remove this error-handling in future.

  Although this function is exposed for use in end-user programs,
  it is not much needed, as the expansion in question has generally
  been done when data is read from a `.bib` file.

  The type is called a 'TeX'-string because it primarily expands TeX ‘accents’
  such as `\'e`, but it expands a few other (La)TeX control sequences
  as well.  The list is unspecified, and not (currently) modifiable,
  but is intended to cover the control sequences often occurring in BibTeX
  databases.

  In the special case of braces (any level) enclosing a _single_ accented character,
  for example `n{\'e}e`, the character is expanded and the braces discarded,
  resulting in the bstring ‘née’;
  this tidies a common case often found in `.bib` files,
  and illustrated in the BibTeX documentation.  This special case does
  not extend to ASCII-range characters (ie, `n{e}e` is parsed as
  ‘n{e}e’), but it does extend to single Unicode characters written directly
  (ie, `n{é}e` is parsed as ‘née’); this is slightly inconsistent, and
  the behaviour here may change if it becomes clear that an alternative
  can be clearly defined.  The special case is strictly restricted to single
  characters, thus `n{\'ee}` becomes ‘n{ée}’."""

  (define (list->lexeme-source list-of-ints)
    (let ((l list-of-ints))
      (λ ()
        (if (null? l)
            #<eof>
            (let ((next (car l)))
              (set! l (cdr l))
              next)))))

  (define (parse-source src)
    (catch
     'beastie
     (λ ()
       (let ((res (parse-result $subtex src)))
         (print-info "string->bstring: parsing ~s -> ~s" str (map values res))
         res))
     (λ (tag info)
       (cond ((not on-error)
              (beastie-error 'subtex "Failed to parse subtex ~s (giving up) (tag=~s  info=~s)"
                             str tag info))
             ((boolean? on-error)       ;ie, #t
              (eprintf "Error parsing subtex: ~s (~s)~%" str info)
              str)
             (else on-error)))))

  (cond ((ustring? str)
         (or (ustring-cache-get* str 'bstring)
             (ustring-cache-set!* str
                                  'bstring
                                  (parse-source (make-iterator str)))))
        ((string? str) (parse-source str))
        ((bstring? str) str)            ;POLA
        ((list? str) (parse-source (list->lexeme-source str)))
        (else (beastie-error 'subtex "unexpected source to string->bstring: ~s" str))))

(define/provide* (parse-subtex str (on-error #f))
  #"""`(parse-subtex str [:on-error #f])` : parse a ‘subtex’ string or ustring,
  `str`, producing a `ustring?` object as result.

  Given:

      One \emph{sharp} ep{\'e}e {here}

  The function recognises both the TeX-style command `\emph`, and the
  TeX-style braces `{...}`, and and the ‘accent’ `{\'e}`, which it
  expands to ‘é’.  The result is an opaque `ustring?` object.

  The input string should be a ustring, a valid UTF-8 string of characters,
  or a list of integer codepoints.

  On error:
    * if ON-ERROR is `#f` (the default), then raise a beastie-error with subtag `'subtex`;
    * if ON-ERROR is `#t` return STR;
    * otherwise, return the keyword's argument as the function's value.

  That said, the procedure as currently implemented doesn't throw any
  errors on parse failures -- that is, we aim not to object to any input.
  The only errors thrown are for internal coding errors, which shouldn't
  be caught here.  I may remove this error-handling in future.

  Although this function is exposed for use in end-user programs,
  it is not much needed, as the expansion in question has generally
  been done when data is read from a `.bib` file.

  The type is called a 'TeX'-string because it primarily expands TeX ‘accents’
  such as `\'e`, but it expands a few other (La)TeX control sequences
  as well.  The list is unspecified, and not (currently) modifiable,
  but is intended to cover the control sequences often occurring in BibTeX
  databases.

  In the special case of braces (any level) enclosing a _single_ accented character,
  for example `n{\'e}e`, the character is expanded and the braces discarded,
  resulting in the bstring ‘née’;
  this tidies a common case often found in `.bib` files,
  and illustrated in the BibTeX documentation.  This special case does
  not extend to ASCII-range characters (ie, `n{e}e` is parsed as
  ‘n{e}e’), but it does extend to single Unicode characters written directly
  (ie, `n{é}e` is parsed as ‘née’); this is slightly inconsistent, and
  the behaviour here may change if it becomes clear that an alternative
  can be clearly defined.  The special case is strictly restricted to single
  characters, thus `n{\'ee}` becomes ‘n{ée}’.

  A tilde in the input (`~`) is interpreted as a non-breaking space,
  in the usual TeX way.
  An actual no-break space character (Unicode U+00A0) is equivalent."""
  (bstring->ustring (string->bstring str on-error)))

;; It would make more sense for this procedure to be in the 'unicode
;; module, but we can't do that because that would require providing
;; bstring->ustring and string->bstring to that module.  (a) I'd
;; rather avoid because it's untidy, and (b) I can't do that because
;; then that module would depend on this one, and this one on that,
;; circularly.
;;
;; Fixing this would require more substantial restructuring.

(define/provide* (ustring->ustring str (braces? #t) (nbsp "~"))
  #"""`(ustring->ustring str [:braces? #t/#f] [:nbsp "?"])` :
  rewrite a string? or ustring? into a ustring?, respecting ‘subtex’ conventions,
  and controlling the display.

  This is very similar in effect to the combination of `parse-subtex` (qv)
  and `bstring->ustring`, but lets you control
  the resulting ustring somewhat.

  If `:braces?` is `#t` (the default), then `{...}` braces in the input
  appear in the output.  If it is `#f`, then they are suppressed
  (which is useful when the output result is not intended to be processed by TeX).

  If `:nbsp str` is present, then that string is used when displaying a
  non-breaking space in the input.  The default is `"~"` (ie, the usual TeX character),
  but setting this to a string containing a Unicode no-break space is an alternative.
  Thus, given the string `"a~é {\~n}{c}"` (with a no-break space in the middle),
  `(ustring->ustring s)` would evaluate to `#"a~é~ñ{c}"`, but
  `(ustring->ustring s :braces? #f :nbsp "+")` would evaluate to `#"a+é+ñc"`."""
  (bstring->ustring (string->bstring str)
                    :write (if braces? 'display 'display/without-braces)
                    :nbsp nbsp))

(module-provide-starred user-char-command string->bstring parse-subtex ustring->ustring)

(define/provide (untexify-string-or-list x)
  #"""`(untexify-string-or-list x)` : untexify a string or list.
  This removes braces and `"~"` from an input string, or a list containing strings.
  This wraps the function `ustring->ustring`."""
  (cond ((string? x)
         (untexify-string-or-list (make-ustring x)))
        ((ustring? x)
         (bstring->ustring (string->bstring x)
                           :write 'display/without-braces
                           :nbsp " "))
        ((list? x)
         (map untexify-string-or-list x))
        (else x)))
(module-provide-starred untexify-string-or-list)