;; This is a simple implementation of a combinatorial parser.
;;
;; The [klipspringer](https://en.wikipedia.org/wiki/Klipspringer) is a small robust
;; (and unutterably cute) bovid
;; (ie, like the bison and the yak).
;;
;; This probably needs substantial reorganisation, between here, core.c and
;; runtime.scm, to get namespaces in the tidy places.
;;
;; See [hutton96, leijen01] and https://docs.racket-lang.org/parsack/index.html
;;
;; @techreport{hutton96,
;; 	author = {Graham Hutton and Erik Meijer},
;; 	institution = {University of Nottingham},
;; 	title = {Monadic Parser Combinators},
;; 	url = {https://nottingham-repository.worktribe.com/output/1024440},
;; 	year = 1996}
;;
;; @techreport{leijen01,
;; 	author = {Daan Leijen and Erik Meijer},
;; 	institution = {University of Utrecht},
;; 	note = {Cited as 'Electronic Notes in Theoretical Computer Science 41 No. 1 (2001)', but that doesn't seem to actually exist. I could find it only at Researchgate},
;; 	title = {Parsec: A Practical Parser Library},
;; 	url = {https://www.researchgate.net/publication/2534571_Parsec_Direct_Style_Monadic_Parser_Combinators_For_The_Real_World},
;; 	year = 2001}
;;
;; The implementation here is based on the two references above, but
;; _heavily_ inspired, with many thanks, by the
;; [Racket parsack](https://docs.racket-lang.org/parsack/index.html)
;; library, from which much of the documentation below has been
;; copied, and against which most of the semantics have been verified.
;;
;; 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 'unicode)
(define-macro (%module-verbosity-flag%) 128)

;; In the type declarations below,
;;
;;   * LEXEME? is whatever the lexeme-source returns
;;     (eg, the objects returned by parse-mdblock.lex),
;;   * VALUE? is whatever the results are (eg, xexprs)
;;   * PARSER? is (parser-input? -> (or/c consumed? empty?)

;; Set the documentation string for a function, for those cases where
;; we can't just use the docstring in the function definition.
;;
;; At some point between 2026-04 and 2026-07, s7 stopped allowing
;; varlet to replace an existing binding, so we have to check first.
(define (set-documentation f str)
  (if (defined? '+documentation+ (funclet f) #t)
      (let-set! (funclet f) '+documentation+ str)
      (varlet (funclet f) '+documentation+ str)))

;; A reader such as returned by make-unicode-reader/file is a lexeme
;; source, since it will return lexemes when called without arguments.
;; It will also return a location, when called with argument 'location.
;; We therefore don't have to define any functions to wrap this.

(define/provide (lexeme-source? x)
  #"""`(lexeme-source? x)` :
  True if the argument is a procedure which can be called with zero arguments,
  returning a lexeme at a time.  When the source of lexemes is
  exhausted, the function should return `#<eof>`.

  The lexemes here are whatever the parser expects to consume.
  The parsers predefined in this module expect to process characters
  or Unicode codepoints, but the framework is not restricted to that.

  A `lexeme-source?` is `(-> lexeme?)`,
  but we permit it to have optional arguments, eg, for debugging.
  If the function can be given an argument `'location`, upon which it
  will return a string indicative of a current location, then that
  will be used when reporting errors."""
  (or (iterator? x)
      (and (procedure? x)
           (= (car (arity x)) 0))))    ;arity -> (min . max) arguments

;;;; Inputs
;;
;; Given a `lexeme-source?` which consumes a single lexeme (ie, with
;; side-effect), an `input*?` structure will return a sequence of such
;; lexemes _functionally_.
;;
;; That is:
;;
;;   * `(input-car inp)` : returns the next lexeme in the input, repeatedly
;;   * `(input-cdr inp)` : returns an input? which starts at the next
;;     element.  This new `input?` will be different, in the sense of
;;     `eq?`, from the argument.
;;
;; Note that this mechanism ends up always including one lexeme of
;; read-ahead (in the input* object), which might be an eof-object?.
;;
;; This means that this might not work properly when reading a single
;; lexeme from a source that will subsequently be read by something
;; other than this parser.  For example, if the source were stdin, and
;; the lexeme-source object read-char, and if we intended to parse a
;; matched pair of braces {...} from the before handing it back to the
;; caller, then this would not work, because it would have already
;; called read-char to read the next char from the input, when it
;; returns the #\} via input-car.  We could get round this particular
;; case by avoiding this prospective read-ahead in input-car, but
;; (a) that makes input-car significantly more complicated, and
;; (b) would still imply a problematic read-ahead if we were parsing
;; something like /a*/, acting on "aaabc".  The best thing is probably
;; to document this mechanism as taking ownership of the
;; lexeme-source, which then should be regarded as being in an
;; indeterminate state after the parse is finished.
(struct input*
        source                          ;lexeme-source?
        lexeme1                         ;the next lexeme
        (next-input :mutable)           ;the next input, or #f
        at-eof?                         ;true if the input is at EOF
        parent)                         ;an input

;; wrap make-input*, adding validation and some initialisation
(define (make-input/source* lexeme-source parent)
  #"""(lexeme-source? -> parser-input?) :
  Given a function which will return lexemes, this returns a `parser-input?`
  which will consume them."""
  (unless (lexeme-source? lexeme-source)
    (beastie-error "make-input/source* : ~s is not a lexeme-source" lexeme-source))

  (unless (or (not parent)
              (input*? parent))
    (beastie-error "make-input/source*: parent ~s is not an input*" parent))

  (when (let loop ((i parent))
          ;; two unicode-reader? objects are equivalent? if they have
          ;; the same source-string or the same file -- return #t if
          ;; `parent` or any of its ancestors are equivalent? to lexeme-source
          #;(eprintf "make-input/source*: lexeme-source=~s  i=~s  => equivalent? ~s~%"
                   lexeme-source i (equivalent? lexeme-source (and i (input*-source i))))
          (and i
               (or (equivalent? lexeme-source (input*-source i))
                   (loop (input*-parent i)))))
    (beastie-error 'klipspringer
                   "make-input: input loop: ~a"
                   (string-join
                    (cons (source-location lexeme-source)
                          (let ancestors ((i parent))
                            (if i
                                (cons (input-location i)
                                      (ancestors (input*-parent i)))
                                '())))
                    " -> ")))

  (make-input* lexeme-source
               (lexeme-source)
               #f
               #f
               parent))

(define/provide (parser-input? x)
  "`(parser-input? any)`: returns `#t` if the argument is an input, returned by `make-input/source*`."
  (input*? x))

;; Given a lexeme-source, return location information for it.
;; The format of this is currently unspecified.
(define (source-location s)
  (catch #t
    (λ ()
      (s 'location))
    (λ _
      s)))

(define (input-location inp)
  #"""`(input-location input)` : return a string indicating the name of the
  input, and an indication of the current position within it.
  The format of this string is currently unspecified."""
  (if (input*? inp)
      (source-location (input*-source inp))
      (beastie-error "input-location: called with non-input ~s" inp)))

(define (input-car inp)
  #"""(parser-input? -> lexeme?) :
  return the first element of the lexeme list.
  This is functional: it does _not_ directly consume the input, but
  will repeatedly return the same car, given the same input."""
  ;; it would be nice to be able to report the parser that is calling this,
  ;; but it's not obvious how to do that -- s7 bacros?
  (unless (input*? inp)
    (beastie-error "input-car: called with non-input ~s" inp))
  (print-trace "<<input ~s" (let ((c (input*-lexeme1 inp)))
                              (if (and (integer? c) (< c #x80))
                                  (integer->char c)
                                  c)))
  (input*-lexeme1 inp))

(define (input-cdr inp)
  #"""(parser-input? -> parser-input?) :
  Return a new `parser-input?` which refers to the contents of the input
  after the first element has been removed.  Like `input-car`, this
  is functional."""
  (cond ((not (input*? inp))
         (beastie-error "input-cdr: called with non-input ~s" inp))
        ((input*-at-eof? inp)
         inp)
        ((input*-next-input inp))
        (else
         (let* ((next-lexeme ((input*-source inp)))
                (next-input
                 (if (eof-object? next-lexeme)
                     (or (input*-parent inp) ;resume reading from parent
                         (make-input* (input*-source inp)
                                      #<eof> ;this lexeme
                                      #f     ;no next input
                                      #t     ;at eof
                                      #f))   ;no parent
                     (make-input* (input*-source inp)
                                  next-lexeme
                                  #f
                                  #f
                                  (input*-parent inp)))))
           (set-input*-next-input! inp next-input)
           next-input))))

;; Show the state of an input, by listing the lexemes already read.
;; This doesn't read anything further from the input.
(define (input->string/debug* inp)
  (define (get-lexemes i)
    (cons (input*-lexeme1 i)
          (if (input*-next-input i)
              (get-lexemes (input*-next-input i))
              '())))
  (cond ((input*-at-eof? inp)
         (sprintf "<input*: ~a eof>" (input-location inp)))
        ((input*-parent inp)
         (sprintf "<input*: ~a [~a] parent ~s>"
                  (input-location inp)
                  (get-lexemes inp)
                  (input->string/debug* (input*-parent inp))))
        (else
         (sprintf "<input*: ~a [~a]>"
                  (input-location inp)
                  (get-lexemes inp)))))

;; Drain an input, for debugging.
;; This reads (and thus consumes) the input to EOF, or to a limit of MAX lexemes.
(define* (input->string/eof/debug* inp (max 16))
  #"""`(input->string/eof/debug* input [:max 16])` :
  show the contents of an input as a string,
  up to a maximum number of characters."""
  ;; it's helpful here to write a trace, to make clear, during debugging,
  ;; why characters are now being read from the input
  (print-trace "input->string/eof/debug*...")
  (cond ((eof-object? (input-car inp)) "")
        ((or (integer? (input-car inp)) (char? (input-car inp)))
         (unicode-encode/utf8
          (let loop ((i inp)
                     (n max))
            (let ((c1 (input-car i)))
              (cond ((eof-object? c1)
                     '())
                    ((= n 0)
                     '(#\. #\. #\.))
                    ((and (integer? c1) (char-space? c1))
                     (cons #x2423       ;U+2423 OPEN BOX (graphic for space)
                           (loop (input-cdr i)
                                 (- n 1)))
                     #;(append (string->list (sprintf "<~s>" (integer->char c1)))
                             (loop (input-cdr i) (- n 1))))
                    (else
                     (cons c1
                           (loop (input-cdr i)
                                 (- n 1)))))))))
        (else
         (let loop ((i inp)
                    (n max))
           (let ((c1 (input-car i)))
             (cond ((eof-object? c1) '())
                   ((= n 0) 'more)
                   (else (cons c1 (loop (input-cdr i) (- n 1))))))))))

(define* (make-parser-input source (parent #f))
  #"""`(make-parser-input source [:parent parser-input?])` :
  construct a `parser-input?` for `parse-result`.
  The argument can be a `parser-input?` (which is returned unchanged),
  a `lexeme-source?` (which includes `unicode-reader?`),
  or a `string?` (which is a string to read from, rather than a filename).

  If the keyword `:parent` is present, then when the current source is exhausted,
  input will be drawn from the parent input source.

  The `parser-input?` object will read from the `source` as required,
  including reading ahead, thus you should not expect the source (eg,
  `read-char`) to be in any particular state after this
  `parser-input?` has finished with it."""
  (cond ((parser-input? source)
         (print-info "make-parser-input: parser-input ~s" source)
         source)
        ((lexeme-source? source)
         (print-info "make-parser-input: lexeme-source ~s" source)
         (make-input/source* source parent))
        ((string? source)
         (print-info "make-parser-input: string ~s" source)
         (make-input/source* (make-unicode-reader/string source) parent))
        (else
         (beastie-error 'klipspringer
                        "make-parser-input: requires a lexeme-source? (or string?) argument, not ~s"
                        source))))

;; The following structs are not exposed.

;; The type of successful result from parsers.
(struct ok value input)

;; An ERROR? is the result of a non-matching parse.
;; It contains a message, but this is currently ignored.
;; I've switched to inputs being a chain of input objects;
;; should I have description(s) be a parallel chain of parser descriptions?
(struct error
        descriptions                    ;list of descriptions of the thing(s) being parsed
        inputs                          ;the inputs we were reading from at the time
        :guard (λ (d i)
                 (let ((d-ok? (and d
                                   (every (λ (x) (or (string? x)
                                                     (promise? x)))
                                          d)))
                       (i-ok? (every parser-input? i)))
                   (cond ((and d-ok? i-ok?) (values d i))
                         ((not d-ok?)
                          (beastie-error "make-error: non-string descriptions: ~s" d))
                         (else
                          (beastie-error "make-error: non-input inputs: ~s" i))))))

(define (result->string/debug* st)
  (if (ok? st)
      (sprintf "<ok: ~s>" (ok-value st))
      (sprintf "<error: ~a from ~a>"
               (force (car (error-descriptions st)))
               (input->string/debug* (car (error-inputs st))))))

(define (make-error-message err)
  "Given an error object, produce a where-are-we message"
  (define (show-car inp)
    (let ((l (input-car inp)))
      ;; if this is a low integer, we presume (but don't depend
      ;; on) this is better displayed as a character
      (if (and (integer? l) (< l #x80))
          (integer->char l)
          l)))
  (let ((inputs (error-inputs err)))
    (case (length inputs)
      ((0) (beastie-error 'klipspringer "Unexpectedly short list of error inputs!"))
      ((1) (sprintf "expected ~s; but found ~s"
                    (force (error-descriptions err))
                    (show-car (car inputs))))
      (else
       ;(eprintf "error-descriptions: ~s~%" (map force (error-descriptions err)))
       (sprintf "expected~%  ~a~%but found inputs~%  ~a"
                (string-join
                 (map force (error-descriptions err))
                 "\n  ")
                (string-join
                 (map (λ (i)
                        (if i
                            (input->string/debug* i)
                            "??"))
                      inputs)
                 "\n  <- ")
                #;(string-join
                 (map (λ (inp)
                        (sprintf "~s" (input-car inp)))
                      inputs)
                 " <- ")))
      #;(else
       (sprintf "expected ~a, but found ~s within structure starting ~s"
                (force (error-descriptions err))
                (show-car (car (last-pair inputs)))
                (show-car (car inputs)))))))

;; This function retrieves the +description+ label associated with a
;; function, if available. It's mostly for internal use, but it does
;; no harm to provide it.
(define/provide (get-parser-description p)
  #"""`(get-parser-description p)` : given a parser `p`, retrieve its self-description.
  This is used in error messages, but might be useful for other debugging tasks."""
  (if p
      (with-let (funclet p)
                (if (defined? '+description+)
                    (force +description+)
                    "<anonymous-function>"))
      "??"))
(define/provide (set-parser-description! p str)
  ;; compare procedure set-documentation
  #"""`(set-parser-description! parser? string?)` :
  Sets a parser's self-description.  It may be useful to set this,
  since the framework may use this when generating error messages."""
  (if (defined? '+description+ (funclet p) #t)
      (let-set! (funclet p) '+description+ str)
      (varlet (funclet p) '+description+ str)))

;; A CONSUMED? result contains either an OK? or an ERROR? struct,
;; which did consume input.
;; CONSUMED-RESULT returns the result.
;; (possibly have consumed-result return #f if the object isn't a `consumed?`)
(struct consumed result)

;; An EMPTY? result contains either an OK? or an ERROR? struct,
;; which did _not_ consume input.
;; EMPTY-RESULT returns the result,
(struct empty result)

;;;; Parsers and combinators
;;
;; A successful parse produces a consumed? result
;; return : parser?
;; (define/provide (return v)
;;   #"""`(return v [:new-input proc])` : creates a parser that consumes no input
;;   and always succeeds, returning `v`.

;;   If `new-input` is present, then it is a function which, given an `input?`,
;;   returns a new `input?`, which is the one subsequently used."""
;;   ;; should this new-input functionality be available on other parsers?
;;   (let ((+description+ (delay (sprintf "(return ~s)" v))))
;;     (λ (inp-return)
;;       (make-empty (make-ok v inp-return)))))
;; (define/provide (return/input v new-input)
;;   #"""`(return v [:new-input proc])` : creates a parser that consumes no input
;;   and always succeeds, returning `v`.

;;   If `new-input` is present, then it is a function which, given an `input?`,
;;   returns a new `input?`, which is the one subsequently used."""
;;   ;; should this new-input functionality be available on other parsers?
;;   (let ((+description+ (delay (sprintf "(return ~s)" v))))
;;     (λ (inp-return)
;;       (make-empty (make-ok v (new-input inp-return))))))
(define/provide* (return v (new-input #f))
  #"""`(return v [:new-input proc])` : creates a parser that consumes no input
  and always succeeds, returning `v`.

  If `new-input` is present, then it is a function which, given an `input?`,
  returns a new `input?`, which is the one subsequently used."""
  ;; should this new-input functionality be available on other parsers?
  (let ((+description+ (delay (sprintf "(return ~s)" v))))
    (λ (inp-return)
      (print-trace "~a" (force +description+))
      (if new-input
          (make-empty (make-ok v (new-input inp-return)))
          (make-empty (make-ok v inp-return))))))

;; a 'fail' result is represented by returning an empty? error? result
;;
;; [hutton96] talks of a zero parser, saying
;;
;; Dually, the parser zero always fails, regardless of the input string:
;;
;;     zero :: Parser a
;;     zero = \inp -> []
;;
;; But neither leijen01 nor the Racket parsack library mention this,
;; so I'm neither sure (a) if it's necessary, nor (b) what it should
;; evaluate to.  Until I have some clarity on that, I should probably
;; omit this.
;;
;; (define/provide (zero inp)
;;   "Creates a parser which always fails."
;;   ;; is the following correct? -- is this always an error, or always empty?
;;   (make-empty-result (make-error "Empty result (inp=~s)" inp)))

;; The bind operator.
;; >>= : (parser? (value? -> parser?) -> parser?
(define/provide (>>= p f)
  #"""`(>>= p f)` : (parser? (value? -> parser?) -> parser?).
  This is the monadic bind operator for parsers.

  Creates a parser that first parses with `p`; If `p` fails, the error result is returned.

  Otherwise, the parse result is passed to `f`, and we continue parsing
  with the _parser_ created from applying `f`.

  That is, in `(>>= p f)`,
  `p` is a parser : `(parser-input? -> result?)`;
  `f` is a function : `(value? -> parser?)`,
  which acts on the value parsed by `p`, to produce a parser.

  Example:

      (parse-result
        (>>= (char #\()
             (λ (skip1)
               (>>= $letter
                    (λ (x)
                      (>>= (char #\))
                           (λ (skip2)
                             (return x)))))))
        "(a)")

      => #\a

  """
  ;; The following permits the result to be single-valued;
  ;; a multi-valued version is straightforward to define,
  ;; but would surely have ramifications elsewhere!
  (let ((+description+ (delay (sprintf "(>>= ~a)" (get-parser-description p)))))
    (λ (inp-bind)
      (let ((m (p inp-bind)))
        ;; m is empty? or consumed?
        ;;(eprintf ">>= applied (~s ~a) => ~s~%" p (input-car inp-bind) m)
        (cond ((empty? m)
               (let ((res (empty-result m)))
                 (if (error? res)
                     (make-empty ; or just m, here?
                      (make-error (cons +description+
                                        (error-descriptions res))
                                  (cons inp-bind
                                        (error-inputs res))))
                     ((f (ok-value res)) (ok-input res)))))
              ((consumed? m)
               (let ((res (consumed-result m)))
                 (if (error? res)
                     (make-consumed ; or just m?
                      (make-error (cons +description+
                                        (error-descriptions res))
                                  (cons inp-bind
                                        (error-inputs res))))
                     (let ((res2 ((f (ok-value res)) (ok-input res))))
                       ;; ensure that we evaluate to a consumed result
                       (if (consumed? res2)
                           res2
                           (make-consumed (empty-result res2)))))))
              (else (beastie-error "unexpected return in >>= : ~s" res)))))))

(define/provide (>> p q)
  #"""`(>> p q)` :
  Equivalent to `(>>= p (λ (x) q))` where _x_ is not in _q_.
  Creates a parser that first parses with _p_, and if successful,
  ignores the result, then parses with _q_.

  Example:

      (parse-result
         (>> (char #\()
             (>>= $letter
                  (λ (x)
                    (>> (char #\))
                        (return x)))))
         "(a)")
      => #\a

  """
  (λ (inp)
    (let ((m (p inp)))
      (cond ((empty? m)
             (let ((res (empty-result m)))
               (if (ok? res)
                   (q (ok-input res))
                   m)))
            ((consumed? m)
             (let ((res (consumed-result m)))
               (if (ok? res)
                   (q (ok-input res))
                   m)))
            (else (beastie-error "unexpected return in >> : ~s" res))))))

;; PARSER-COMPOSE : (parser? | (var '<- parser?))  ... -> parser?
;;
;; Racket spec:
;;
;; (parse-result
;;    (parser-compose (char #\[)
;;                    (x <- $letter)
;;                    (y <- $letter)
;;                    (char #\])
;;                    (return (list x y)))
;;    "[ab]")
;; '(#\a #\b)
;;
;; It would be nice to extend this to include a :description keyword,
;; but that's fiddly.  See parser-seq for how I've done this elsewhere.
(define-macro (parser-compose expr . exprs)
  #"""`(parser? | (var '<- parser?))  ... -> parser?` :
  Compose a sequence of parsers with `>>=`.  Parsers wrapped in `var <- parser`
  will bind the parse result to the given variable.  For example,

      (parser-compose (char #\[)
                      (x <- $letter)
                      (y <- $letter)
                      (char #\])
                      (return (list x y)))

  parses `"[ab]"` to `'(#\a #\b)`."""
  (cond ((null? exprs) `,expr)
        ((and (list? expr)
              (= (length expr) 3)
              (eqv? (cadr expr) '<-))
         `(>>= ,(caddr expr)
               (lambda (,(car expr))
                 (parser-compose ,@exprs))))
        (else
         `(>>= ,expr
               (lambda (,(gensym))
                 (parser-compose ,@exprs))))))
(module-provide parser-compose)

;; PARSER-SEQ : (parser? | ('~ parser?)) ... -> parser?
;;
;; Racket:
;; (parser-seq p q) is syntactically equivalent to
;; (parser-compose (x <- p) (y <- q) (return (list x y))).
;; Any parser wrapped in (~ parser?) doesn't pass on the result to the
;; final list.
(define-macro (parser-seq expr . exprs)
  #"""`(parser-seq p q)` is syntactically equivalent to
  `(parser-compose (x <- p) (y <- q) (return (list x y)))`.
  Any parser wrapped in `(~ ...)` doesn't pass on the result to the
  final list.

  If the keyword `:combine-with` is present, then its value specifies a function
  which is applied to the list of results, instead of `list`.

  If the keyword `:description` is present, then its value gives a brief
  name for the parser, used in error messages.
  """
  (let ((kws+seq (let loop ((specs (cons expr exprs))
                            (keywords '())
                            (result '()))
                   (if (null? specs)
                       (cons (apply hash-table keywords) (reverse! result))
                       (let ((s1 (car specs)))
                         (cond ((keyword? s1)
                                (loop (cddr specs) `(,s1 ,(cadr specs) . ,keywords) result))
                               ((and (list? s1) (eqv? (car s1) '~))
                                (loop (cdr specs) keywords
                                      (cons (cons #f (cadr s1))
                                            result)))
                               (else
                                (loop (cdr specs) keywords
                                      (cons (cons #t s1)
                                            result)))))))))
    `(let ((+description+ ,(or ((car kws+seq) :description)
                               `(delay
                                  (sprintf "(parser-seq ~a)"
                                           (string-join
                                            (map get-parser-description
                                                 (list . ,(map cdr (cdr kws+seq)))))))))
           (f ,(let loop ((ss (cdr kws+seq))
                          (result '()))
                 (if (null? ss)
                     `(return (,(or ((car kws+seq) :combine-with) 'list) . ,(reverse! result)))
                     (if (caar ss)
                         (let ((a (gensym)))
                           `(>>= ,(cdar ss)
                                 (λ (,a)
                                   ,(loop (cdr ss) (cons a result)))))
                         `(>>= ,(cdar ss)
                               (λ (_)
                                 ,(loop (cdr ss) result))))))))
       ;; If we don't do the following, then the function ends up with
       ;; the +description+ associated with >>=
       (set-parser-description! f +description+)
       f)))

;; The following is what this macro was like before I added the +description+.
;; Somewhat simpler, but I _think_ (in retrospect) it re-evaluated the
;; combined parsers each time
;;
;; (define-macro (parser-seq expr . exprs)
;;   #"""`(parser-seq p q)` is syntactically equivalent to
;;   `(parser-compose (x <- p) (y <- q) (return (list x y)))`.
;;   Any parser wrapped in `(~ parser?)` doesn't pass on the result to the
;;   final list.
;;
;;   If the keyword `:combine-with` is present, then its value specifies a function
;;   which is applied to the list of results, instead of `list`."""
;;   (let loop ((ps (cons expr exprs))
;;              (result '())
;;              (combine 'list))
;;     (if (null? ps)
;;         `(return (,combine . ,(reverse! result)))
;;         (let ((p1 (car ps)))
;;           (cond ((eqv? p1 :combine-with)
;;                  (if (null? (cdr ps))
;;                      (beastie-error "parser-seq: missing argument to :combine-with")
;;                      (loop (cddr ps) result (cadr ps))))
;;                 ((and (list? p1)
;;                       (= (length p1) 2)
;;                       (eqv? (car p1) '~))
;;                  `(>>= ,(cadr p1)
;;                        (λ (_)
;;                          ,(loop (cdr ps) result combine))))
;;                 (else
;;                  (let ((a (gensym)))
;;                    `(>>= ,p1
;;                          (λ (,a)
;;                            ,(loop (cdr ps) (cons a result) combine))))))))))
(module-provide parser-seq)

(define-macro (parser-one p . rest)
  #"""`(parser-one p ...)` where `p` is either a parser or `(~> parser?)` :
  Combines parsers but only return the result of the parser wrapped with `~>`.
  Precisely one parser must be wrapped with `~>`."""
  (let ((res (gensym)))
    (let loop ((ps (cons p rest))
               (got-1? #f))
      (cond ((null? ps)
             (if got-1?
                 `(return ,res)
                 (beastie-error "parser-one: failed to find any ~~> in ~s" (cons p ps))))
            ((and (list? (car ps))
                  (= (length (car ps)) 2)
                  (eqv? (caar ps) '~>))
             (if got-1?
                 (beastie-error "parser-one: found more than one ~~> in ~s" (cons p ps))
                 `(>>= ,(cadar ps)
                       (λ (,res)
                         ,(loop (cdr ps) #t)))))
            (else
             `(>>= ,(car ps)
                   (λ (_)
                     ,(loop (cdr ps) got-1?))))))))
(module-provide parser-one)

(define (string* str target/ustring ci?)
  (let ((ok-result (λ (in)
                     (make-consumed (make-ok target/ustring in))))
        (target/list (ustring->list target/ustring))
        (cp=? (if ci?
                  (λ (a b)
                    ;; uchar-downcase returns #f if its argument isn't char or integer.
                    ;; The value of a has already been downcased,
                    ;; and coerced to a codepoint.
                    (let ((b_ (uchar-downcase b)))
                      (and a b_
                           (= a b_))))
                  (λ (a b)
                    ;; The value of a has already been coerced to a codepoint.
                    (= a (->cp b)))))
        (+description+ (delay
                         (sprintf "(~a ~a)"
                                  (if ci? "string/ci" "string")
                                  target/ustring))))
    (λ (string-inp)
      (let loop ((sl target/list)
                 (in string-inp)
                 (consumed? #f))
        (cond ((null? sl)
               (ok-result in))
              ((cp=? (car sl) (input-car in))
               (loop (cdr sl) (input-cdr in) #t))
              (else
               ((if consumed? make-consumed make-empty)
                (make-error (list str (object->string (input-car in)))
                            (list string-inp in)))))))))
(define/provide (string str)
  "`(string str)` : Creates a parser that parses and returns `str` as a list of codepoints."
  (string* str (unicode-decode/utf8 str) #f))

(define/provide (string/ci str)
  #"""`(string/ci str)` : Creates a parser that parses and returns `str`
  as a list of chars.  The comparison is done case-insensitively,
  and it is the lowercased codepoints of the input string that are returned."""
  (string* str (ustring-lowercase (unicode-decode/utf8 str)) #t))

;; <or> : parser? ... -> parser?
(define/provide (<or> p . pp)
  #"""`(<or> p ...)`: Creates a parser that tries the given parsers in order,
  returning with the result of the first parser that consumes input.

  If no parsers consume input,
  then `<or>` backtracks to return the result of the first success."""
  (let ((+description+ (delay
                         (sprintf "(<or> ~a)"
                                  (string-join (map get-parser-description (cons p pp)))))))
    ;(eprintf "<or> description -> ~s~%" +description+)
    (λ (inp-or)
      (let loop ((ps (cons p pp))
                 (first-success #f))
                                        ;(printf "<or> ps=~s  input=~s~%" ps inp-or)
        (if (null? ps)
            (or first-success
                (make-empty (make-error (list +description+) (list inp-or))))
            (let ((res ((car ps) inp-or)))
                                        ;(printf "  <or>  ps=~s  i=~s  => ~s~%" (car ps) inp-or res)
              (cond ((consumed? res) res)
                    ((empty? res)
                     (if (and (not first-success)
                              (ok? (empty-result res)))
                         (loop (cdr ps) res)
                         (loop (cdr ps) first-success)))
                    (else
                     (beastie-error 'klipspringer
                                    "parser ~s returned ~s, not consumed? or empty?"
                                    (procedure-source (car ps)) res)))))))))

(define/provide (<any> p . pp)
  #"""`(<any> p ...)` : Creates a parser that tries the given parsers in order,
  returning with the result of the first successful parse, even if no input is consumed.
  Produces an error if it not given at least one parser.
  See `<or>` for a related, alternative parser.

  Example:

       > (parse-result (<any> $letter $digit) "1")
       #\1

  Notes:
    * `<any>` immediately returns when it encounters a successful parse,
      even if the parse consumed no input.

      Example:

          > (parse-result (<any> (return null) $digit) "1")
          '()

    * See also `<or>`, a related parser that continues
      to try subsequent parsers so long as each of the
      previous parsers consumes no input,
      even if one of the previous parsers returns successfully.

      Example:

          > (parse-result (<or> (return null) $digit) "1")
          #\1

  """
  (let ((+description+ (delay
                         (sprintf "(<any> ~a)"
                                  (string-join (map get-parser-description (cons p pp)))))))
    (λ (inp-any)
      (let loop ((ps (cons p pp)))
        (if (null? ps)
            (make-empty (make-error (list +description+) (list inp-any)))
            (let ((res ((car ps) inp-any)))
              (if (or (and (consumed? res) (ok? (consumed-result res)))
                      (and (empty? res) (ok? (empty-result res))))
                  res
                  (loop (cdr ps)))))))))

(define* (many/n* p min max (description #f))
  (let ((+description+ (or description
                           (delay
                             (sprintf "(many{~a,~a} ~a)" min (or max "*")
                                    (get-parser-description p))))))
    (λ (inp-many)
      (let loop ((result '())
                 (i inp-many)
                 (n 0))
        (let ((m (p i)))
          ;;(eprintf "many/n*: p=~s(~s/~s)  i=~s => ~s~%" p n min i m)
          (cond ((consumed? m)
                 (let ((r (consumed-result m)))
                   (cond ((ok? r)
                          (if (and max (= n max))
                              (make-consumed (make-ok (reverse! result) i))
                              (loop (cons (ok-value r) result)
                                    (ok-input r)
                                    (+ n 1))))
                         ((< n min)
                          (make-consumed
                           (make-error (cons +description+
                                             (error-descriptions r))
                                       (cons inp-many
                                             (error-inputs r)))))
                         (else
                          (make-consumed
                           (make-ok (reverse! result) i))))))
                ((< n min)              ;too few matches
                 (make-empty (make-error (list +description+) (list inp-many))))
                (else                   ;ok number of matches
                 (if (null? result)
                     (make-empty (make-ok '() i))
                     (make-consumed (make-ok (reverse! result) i))))))))))
(define/provide (many p)
  #"""`(many p)` : Creates a parser that parses with p zero or more times.
  It returns a list of objects parsed by `p`."""
  (many/n* p 0 #f))
(define/provide (many1 p)
  "`(many1 p)` : like `(many p)`, but creates a parser that parses with p one or more times."
  (many/n* p 1 #f))
(define/provide* (many/n p n (max #f))
  #"""`(many/n p n [:max max])` : like `(many p)`,
  but creates a parser that parses with `p` at least `n` times.
  If `:max` is present, then this sets a maximum number of matches."""
  (many/n* p n max))

(define/provide (try p)
  #"""`(try p)` : lookahead function.
  Creates a parser that tries to parse with `p` but does not consume input if `p` fails.

  For example:

      > (parse-result (string "ab") (open-input-string "ac"))
      (consumed #<error>)
      > ((try (string "ab")) (open-input-string "ac"))
      (empty #<error>)"""

  (let ((+description+ (delay (sprintf "(try ~a)" (get-parser-description p)))))
    (λ (inp-try)
      (let ((m (p inp-try)))
        (if (and (consumed? m) (error? (consumed-result m)))
            (make-empty
             ;;make an error with the description from m, but the input from here
             ;;(possibly add +description+ from here?)
             ;; Think: is it actually useful, to the consumer,
             ;; to add this extra description?
             (make-error (cons +description+
                               (error-descriptions (consumed-result m)))
                         (cons inp-try
                               (error-inputs (consumed-result m)))))
            m)))))

(define/provide ($err input-err)
  "$err : a parser that always returns an error"
  (make-empty (make-error (list "$err parser") (list input-err))))

(define (->cp ci)
  (cond ((char? ci) (char->integer ci))
        ((integer? ci) ci)
        ((eof-object? ci) 0)           ;convenient to handle this here
                                        ;(else (error "->cp given ~s" ci))
        ;; rather than throw an error, on the grounds this is a caller mistake,
        ;; it's convenient to return unicode-replacement-character,
        ;; and avoid some type tests
        (else #xfffd)))

;; (roughly) character parsing primitives, and useful parsers built from them
(define/provide* (satisfy pred? (description #f))
  #"""`(satisfy pred? [description])` :
  creates a parser which consumes and returns one lexeme if it satisfies `pred?`.
  For example, `$letter` is equivalent to `(satisfy char-alphabetic?)`.

  If the argument `description` is present,
  then it is a compact description of the parser,
  for use in error messages."""
  (let ((+description+ (or description (object->string pred?))))
    (λ (inp-satisfy)
      (let ((l0 (input-car inp-satisfy)))
        (cond ((eof-object? l0)
               (make-empty (make-error (list +description+) (list inp-satisfy))))
              ((pred? l0)
               (make-consumed (make-ok l0 (input-cdr inp-satisfy))))
              (else
               (make-empty (make-error (list +description+) (list inp-satisfy)))))))))

(define/provide* (satisfy/char pred? (description #f))
  #"""Like `satisfy`, except that the lexeme is additionally required
  to be a char or integer.
  The predicate must accept both chars and integers as argument."""
  (satisfy (λ (satisfy-c)
             (and (or (char? satisfy-c) (integer? satisfy-c))
                  (pred? satisfy-c)))
           :description description))

(define/provide (oneOf str)
  #"""`(oneOf str)` : Creates a parser that consumes and returns
  one character if the character appears in str.
  `str` may be a UTF-8 string, and the arguments may be characters
  or (integer) codepoints."""
  (let ((ustr (unicode-decode/utf8 str)))
    (satisfy/char (λ (c)
                    (ustring-index ustr c))
                  :description (sprintf "(character in [~a])" str))))
(define/provide (noneOf str)
  #"""`(noneOf str)` : Creates a parser that consumes and returns
  one character if the character does _not_ appear in str.
  `str` may be a UTF-8 string, and the arguments may be characters
  or (integer) codepoints."""
  (let ((ustr (unicode-decode/utf8 str)))
    (satisfy/char (λ (c)
                    (not (ustring-index ustr c)))
                  :description (sprintf "(character not in [~a])" str))))

(define/provide (char c)
  "`(char c)` : creates a parser that parses and returns char c."
  ;; (satisfy (λ (char-c) (and (char? char-c) (char=? char-c c))))
  (let ((cp (->cp c)))
    (satisfy/char (λ (char-c)
                    (= cp (->cp char-c)))
                  :description (sprintf "(the character ~s)" c))))

(define $letter
  (satisfy/char char-alpha? "char-alpha?"))
(set-documentation $letter "Parses an alphabetic character.")

(define $digit
  (satisfy/char char-digit? "char-digit?"))
(set-documentation $digit "Parses a digit.")

(define $alphaNum
  (satisfy/char char-alnum? "char-alnum?"))
(set-documentation $alphaNum "Parses an alphabetic character, or a digit")
;(set-parser-description! $alphaNum "<alphanumeric>")

(define $space
  (satisfy/char char-space? "char-space?"))
(set-documentation $space "Parses a single space")

(define $spaces
  (many $space))
(set-documentation $spaces "Parses zero or more spaces")
(set-parser-description! $spaces "<optional whitespace>")

(define $spaces1
  (many1 $space))
(set-documentation $spaces1 "Parses one or more spaces")
(set-parser-description! $spaces1 "<whitespace>")

(define $wordbreak
  (many (satisfy/char char-wordbreak? "optional word break")))
(set-documentation $wordbreak
                   #"""Matches zero or more ‘word break’ codepoints.
                   This is almost the same as `$spaces`,
                   except that it _excludes_ non-breaking spaces.
                   This matches the Unicode/ICU `u_isWhitespace()` function,
                   and (thus) the Java `Character.isWhitespace()` function.""")
(set-parser-description! $wordbreak "<optional wordbreak>")

(define $wordbreak1
  (many1 (satisfy/char char-wordbreak? "word break")))
(set-documentation $wordbreak1
                   #"""Matches one or more ‘word break’ codepoints.
                   This is almost the same as `$spaces`,
                   See `$wordbreak`.""")
(set-parser-description! $wordbreak1 "<wordbreak>")

(define $newline
  (char #\newline))
(set-documentation $newline
                   "Parses newline char. This is the singular #\n character. See also $eol.")
(set-parser-description! $newline "<newline>")

(define $eol
  (>>= (<or> (parser-seq (char #\newline) (many/n* (char #\return) 0 1))
             (parser-seq (char #\return)  (many/n* (char #\newline) 0 1)))
       (λ (res)
         ;; res is (in the first case) either (#\newline ()) or (#\newline (#\return))
         (let ((c2 (cadr res)))
           (return (cons (car res) c2))))))
(set-documentation $eol
  #"""Parses end of line.
  `$eol` succeeds on "\n", "\r", "\r\n", or "\n\r". See also `$newline`.""")

(define $tab
  (char #\tab))
(set-documentation $tab "Parses the tab character.")
(set-parser-description! $tab "<tab>")

(module-provide $letter $digit $alphaNum $space $spaces $spaces1 $wordbreak $wordbreak1 $newline $tab $eol)

(define/provide ($any inp)
  "Matches any lexeme, and returns it."
  (let ((l (input-car inp)))
    (if (eof-object? l)
        (make-empty (make-error (list "$any") (list inp)))
        (make-consumed (make-ok l (input-cdr inp))))))
(set-parser-description! $any "<any!>")

(define/provide ($eof inp)
  "Parses end-of-file"
  (let ((l (input-car inp)))
    (if (eof-object? l)
        (make-empty (make-ok l inp))
        (make-empty (make-error (list "$eof") (list inp))))))
(set-parser-description! $eof "<eof>")

;; Other combinators

(define/provide (skipMany p)
  "`(skipMany p)` : creates a parser that parses with `p` multiple times, but returns only `()`."
  (>>= (many/n* p 0 #f)
       (λ (l)
         (return '()))))
(define/provide (skipMany1 p)
  "`(skipMany1 p)` : creates a parser that parses with `p` at least once, but returns only `()`."
  (>>= (many/n* p 1 #f)
       (λ (l)
         (return '()))))

(define/provide (sepBy1 p sep)
  #"""`(sepBy1 p sep)` : creates a parser that repeatedly parses with _p_ one or more times,
  where each parse of _p_ is separated with a parse of _sep_.
  Only the results of _p_ are returned."""
  (>>= (parser-seq p
                   (many (try (parser-one sep (~> p)))))
       (λ (l)
         ;; (car l) is the result of the first p,
         ;; (cadr l) is the list of results of successive p
         (return (cons (car l) (cadr l))))))

(define/provide (sepBy p sep)
  "Like _sepBy1_, but parses zero or more times."
  (let ((res (<or> (sepBy1 p sep)
                   (return '()))))
    (set-parser-description! res (delay (sprintf "<~a separated by ~a>" p sep)))
    res))

(define/provide (between open close p)
  #"""`(between open close p)` :Creates a parser that parses with _p_ only if it’s surrounded
  by _open_ and _close_.  Only the result of _p_ is returned."""
  (try (parser-seq (~ open) p (~ close) :combine-with values)))

(define/provide (lookAhead p)
  "`(lookAhead p)` : Creates a parser that parses with p and returns its result, but consumes no input."
  (λ (inp-lookahead)
    (let ((m (p inp-lookahead)))
      (let ((res (if (consumed? m) (consumed-result m) (empty-result m))))
        (if (and (consumed? m) (ok? res))
            (make-empty (make-ok (ok-value res) inp-lookahead))
            m)))))

(define/provide* (<!> p (q $any))
  #"""`(<!> p [q])` : Creates a parser that errors if `p` successfully parses input,
  otherwise parses with `q`.  The parser `q` defaults to `$any`."""
  (let ((+description+ (delay (sprintf "<!> ~a" (get-parser-description p)))))
    (λ (inp-not)
      (let ((m (p inp-not)))
        (let ((res (if (consumed? m) (consumed-result m) (empty-result m))))
          (if (ok? res)
              (make-empty (make-error (list +description+)
                                      (list inp-not)
                                      #;(let ((r1 (consumed-result m)))
                                        (if (ok? r1)
                                            (list inp-not (ok-input r1))
                                            (cons inp-not (error-inputs r1))))))
              ;($any inp-not)
              (q inp-not)))))))

;;;; The main interface to this module
(define/provide* (parse-result parser source (on-error 'exception))
  #"""`(parse-result p src [:on-error handler])`:
  parses the given source with parser `p`, and returns the successful result.

  The `src` may be a `string?` or a `lexeme-source?`.
  The `lexeme-source?` argument is as documented in the predicate
  function.  The function `make-unicode-reader/file` is an example of
  such a function.

  If the parse fails, then this procedure raises an exception with subtag `klipspringer`.
  If instead the keyword `:on-error` is present and provides a handler procedure,
  then this procedure returns, instead of the result of the parse,
  the result of applying the handler procedure to three arguments,
  namely a description of the parser that failed,
  an error message,
  and an indication of the failure location in the input."""
  (receive (result new-inp)
      (parse-result2 parser source on-error)
    ;; if result is #f, then new-inp is the return value of the on-error function
    (or result new-inp)))

(define/provide* (parse-result2 parser source (on-error 'exception))
  #"""`(parse-result2 p src [:on-error handler]) -> <any> input?` :
  parses the given source, and returns, as multiple values,
  the successful result
  _and_ a new input object which represents the current state of the input.

  If the parse fails, then this procedure raises an exception with subtag `klipspringer`.
  If instead the keyword `:on-error` is present and provides a handler procedure,
  then this procedure returns, as multiple values, `#f`,
  and the result of applying the handler procedure to three arguments,
  namely a description of the parser that failed,
  an error message,
  and an indication of the failure location in the input.

  Otherwise, see `parse-result`."""
  ;; on-error undocumented so far -- change that?

  (print-trace "parse-result2: parser=~s  source=~s" parser source)
  ;; I'm not convinced all this clever rethrowing is actually necessary,
  ;; Certainly, it confuses the hell out of me.
  (let ((lexeme-input (make-parser-input source)))
    (catch 'beastie
      (λ ()
        (let ((m (parser lexeme-input)))
          (let ((res (if (consumed? m)
                         (consumed-result m)
                         (empty-result m))))
            (print-trace "  (parse-result2) => ~a" (result->string/debug* res))
            (cond ((ok? res)
                   (values (ok-value res)
                           (ok-input res)))
                  ((eqv? on-error 'exception)
                   (let ((loc (input-location lexeme-input)))
                     (beastie-error 'klipspringer
                                    "Failed to parse ~s (~a)~%parser ~a~%failed: ~a"
                                    (input->string/debug* lexeme-input)
                                    loc
                                    (get-parser-description parser)
                                    (make-error-message res))))
                  (else
                   (if (procedure? on-error)
                       (values #f
                               (on-error (get-parser-description parser)
                                         (make-error-message res)
                                         (input-location lexeme-input)))
                       (beastie-error "parse-result2: on-error must be a procedure, not ~s"
                                      on-error)))))))
      (λ (tag info)
        ;; TAG is 'beastie
        ;; INFO is (message ((possible-location . "xxx") (subtag . 'symbol) ...))
        ;(eprintf "parse-result2 error: tag=~s  info=~s~%" tag info)
        (let ((extra-info (cadr info)))
          (if (assv 'klipspringer extra-info) ;if parsing error
              (throw tag info)                ;...just rethrow
              (let ((message (car info)))     ;other beastie error
                (beastie-error 'klipspringer
                               "Error while parsing ~s (~a): ~a"
                               (input->string/debug* lexeme-input)
                               (input-location lexeme-input)
                               message))))))))