;; A parser for .bib files.
;;
;; 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/structs 'unicode 'subtex)

(define *requires-implementation-functions*
  '(make-biblex* biblex? biblex-load-hook*))
(define *provides-implementation-functions*
  '(make-biblex*))
(define *module-load-hook* 'biblex-load-hook*)

(define-macro (%module-verbosity-flag%) 2) ;same as bibtex.scm

;; The 'bib2-string-table' is the table of lookups applied to strings in .bib files.
;; It's settable here, in @string items in .bib files, or @macro calls in .bst files.
;; This is provided externally, but not intended to be used directly;
;; it is called by BIB-STRING-TABLE and BIB-STRING-TABLE-SET! in bibtex.scm.
(define bib2-string-table*
  (let ((*table* (make-hash-table 16 (cons ustring=? ustring->hash))))
    ;; all the keys and values in the table must be ustrings
    (λ (k . rest)
      #"""`(bib2-string-table* k [value])` : set (with `value`)
      or retrive (without) a value in the .bib @string lookup table"""
      (cond ((eqv? k '*reset-for-tests*)
             ;; magic keyword:
             ;; reset for use in test harness
             ;; this must match the initial value above
             (set! *table* (make-hash-table 16 (cons ustring=? ustring->hash))))

            ((ustring? k)
             (cond ((not (ustring? k))
                    (beastie-error "bib-string-table: key must be ustring, not ~s" k))
                   ((null? rest)
                    (*table* k))
                   ((not (ustring? (car rest)))
                    (beast-error "bib-string-table: value must be ustring, not ~s" (car rest)))
                   (else
                    (hash-table-set! *table* k (car rest)))))

            (else
             (beastie-error "bib-string-table: key must be ustring, not ~s" k))))))
(module-provide bib2-string-table*)

;; This is where we enforce our rules about what characters can appear
;; in entry-types, keys, and field-names.  We do this in the functions
;; simple-ustring->symbol and entry-key->symbol, which turn lists of
;; codepoints into a symbol, but which, if they object to a character,
;; raise a beastie-error with a subtag 'disallowed-character.
;;
;; Note that the lexer in lex-bib2.c will recognise an entry-start
;; lexeme only if the '@' is followed by a letter; we don't
;; double-check this here.
;;
;; I think we could handle, or display, these errors more gracefully -- TODO.
(define *allowed-entry-key-characters/string* ":./_&-")
(define *allowed-entry-key-characters*
  (map char->integer (string->list *allowed-entry-key-characters/string*)))
(define *allowed-simple-string-characters/string* "-_.:")
(define *allowed-simple-string-characters*
  (map char->integer (string->list *allowed-simple-string-characters/string*)))

;; simple string is the entry-type or field names;
;; these are additionally downcased

;; Alphabetic => Lowercase + Uppercase + Lt + Lm + Lo + Nl + Other_Alphabetic
(define (simple-ustring->symbol us)
  (define (simple-char? c)
    (or (uchar-word-character? c)
        (char-digit? c)
        (and (< c #x80)
             (memq c *allowed-simple-string-characters*))))

  (if (every simple-char? (make-iterator (ustring-lowercase! us)))
      (ustring->symbol us)
      (let ((bad-char (any (λ (c)
                             (and (not (simple-char? c))
                                  c))
                           (make-iterator us))))
        (beastie-error 'disallowed-character
                       (sprintf "character ~a not allowed in simple string ~s (must be alnum or [~s])"
                                (show-char* bad-char)
                                us
                                *allowed-simple-string-characters/string*)))))

;; entry-key is slightly more liberal
;; these are not downcased
(define (entry-key->symbol us)
  (define (entry-character? c)
    (or (uchar-word-character? c)
        (char-digit? c)
        (char-symbol? c)
        (and (< c #x80)
             (memq c *allowed-entry-key-characters*))))

  (if (every entry-character? (make-iterator us))
      (ustring->symbol us)
      (let ((bad-char (any (λ (c)
                             (and (not (entry-character? c))
                                  c))
                           (make-iterator us))))
        (beastie-error 'disallowed-character
                       (sprintf "character '~a' not allowed in entry-key ~s (must be alnum/symbol/~s"
                                (show-char* bad-char)
                                us
                                *allowed-entry-key-characters/string*)))))

(define (show-char* c)
  (if (and (integer? c) (< c #x80))
      (integer->char c)
      (sprintf "~a (U+~x)" (unicode-encode1/utf8 c) c)))

;; Parsers

;; return a parser which will match a lexeme of the given type
(define (lexeme-of-type type-symbol)
  (let ((+description+ (sprintf "<~a>" type-symbol)))
    (λ (inp)
      (let ((l0 (input-car inp)))
        (cond ((eof-object? l0)
               (make-empty
                (make-error (list +description+)
                            (list inp))))
              ((eqv? (car l0) type-symbol)
               (make-consumed (make-ok (cdr l0) (input-cdr inp))))
              (else
               (make-empty
                (make-error (list +description+)
                            (list inp)))))))))

;; the first three have l-values, obtained by (ok-value (consumed-result x)),
;; which are of type ustring?
(define $entry-start (lexeme-of-type 'entry-type))
(define $quoted-string (lexeme-of-type 'quoted-string))
(define $unquoted-string (lexeme-of-type 'unquoted-string))

;; the following don't have l-values
(define $preamble (lexeme-of-type 'preamble))
(define $stringdef (lexeme-of-type 'stringdef))
(define $include (lexeme-of-type 'include))

(define $start-entry (lexeme-of-type 'entry-open-brace))
(define $end-entry (lexeme-of-type 'entry-close-brace))
(define $equals (lexeme-of-type 'equals))
(define $comma (lexeme-of-type 'comma))
(define $hash (lexeme-of-type 'hash))

(define concatenated-string
  ;; This evaluates to a single ustring?
  ;; That is, we _don't_ preserve abbreviations (ie, `month=jan`) past
  ;; this point.
  (>>= (sepBy (<or> (>>= $unquoted-string
                         (λ (us)
                           (return
                            (let ()
                              (ustring-lowercase! us)
                              (if (every char-digit? us) ;(char-digit? (ustring-car s/string))
                                  us    ;a number; don't lookup
                                  (or (bib2-string-table* us)
                                      us))))))
                    $quoted-string)
              $hash)
       (λ (ustrings)
         (return
          (if (null? ustrings)
              (make-ustring)
              (apply ustring-append! ustrings))))))

(define key-value
  (parser-compose (k <- $unquoted-string)
                  $equals
                  (v <- concatenated-string) ;ustring?
                  (return
                   (cons (ustring-lowercase! k) v))))
(set-parser-description! key-value "<key=value>")

(define (make-bibtex-entry-result* type key fields)
  (print-info "make-bibtex-entry-result* type=~s  key=~s  fields=~s" type key fields)
  (return
   `(,(simple-ustring->symbol type)
     ,(entry-key->symbol key)
     . ,(map (λ (field)                 ;field is (key . value)
               (let ((key (car field))
                     (value (cdr field)))
                 (cons (simple-ustring->symbol key)
                       (parse-subtex value)))) ;ustring?
             fields))))

;; If we try to define a string in terms of itself --
;; that is, @string{s = "foo" # s} --
;; then we currently silently regard the 's' as undefined,
;; so the above would define 's' as "foos".
;; A reasonable alternative would be to raise an error.
;;
;; btxdoc.pdf doesn't say what happens in this case,
;; but bibtex the program warns "string name "s" is used in its own
;; definition" and defines 's' ignoring the 's' on the RHS.
(define stringdef*
  (parser-compose $stringdef
                  $start-entry
                  (key <- $unquoted-string)
                  $equals
                  (value <- concatenated-string) ;ustring?
                  $end-entry
                  (begin
                    (ustring-lowercase! key)
                    (bib2-string-table* key value)
                    (return #f))))
(set-parser-description! stringdef* "<@string>")

(define preamble*                       ;evaluates to ('preamble . value/ustring?)
  (parser-compose $preamble
                  $start-entry
                  (s <- concatenated-string) ;ustring?
                  $end-entry
                  (return
                   (cons 'preamble
                         (parse-subtex s)))))
(set-parser-description! preamble* "<@preamble>")

;; The make-parser-input call checks for an input loop
;; (ie, where we are about to include a file which is including this one),
;; and we stop parsing at this point.
;; A reasonable alternative would be to simply ignore the transgressing include,
;; and press on.  Since this is an extension to BibTeX,
;; there's no guidance there on what should happen here.
;;
;; Note that, if this was @include{foo}, and if there is a @string{foo=...},
;; then foo will have been expanded.
(define include*
  (parser-compose $include
                  $start-entry
                  (path <- concatenated-string) ;ustring?
                  $end-entry
                  ;; path is a ustring, whether
                  ;; this was @include{foo} or @include{"foo"}
                  (return #f
                          :new-input (λ (inp)
                                       (make-parser-input
                                        (make-biblex*
                                         (make-unicode-reader/file path))
                                        :parent inp)))))
(set-parser-description! include* "<@include>")

(define bibtex-entry-empty*
  (parser-compose (type <- $entry-start)
                  $start-entry
                  (key <- $unquoted-string)
                  $end-entry
                  ;; might we want to add an exception handler here?
                  (make-bibtex-entry-result* type key '())))
(define bibtex-entry-normal*
  (parser-compose (type <- $entry-start)
                  $start-entry
                  (key <- $unquoted-string)
                  $comma
                  (fields <- (sepBy key-value $comma))
                  (<or> (parser-seq $comma $end-entry)
                        $end-entry)
                  (make-bibtex-entry-result* type key fields)))

(define bibtex-entry
  (<any> stringdef* preamble* include* bibtex-entry-normal* bibtex-entry-empty*))
(set-parser-description! bibtex-entry "<bibtex-entry>")

(define bibtex-file
  (many bibtex-entry))

(module-provide bibtex-entry bibtex-file)

(define/provide (parse-bibtex2/string str)
  (parse-result bibtex-file
                (make-parser-input
                 (make-biblex*
                  (make-unicode-reader/string str)))))