#| Copyright 2024 Peter McGoron
 |
 | Licensed under the Apache License, Version 2.0 (the "License");
 |
 | you may not use this file except in compliance with the License.
 | You may obtain a copy of the License at
 |
 |     http://www.apache.org/licenses/LICENSE-2.0
 |
 | Unless required by applicable law or agreed to in writing, software
 | distributed under the License is distributed on an "AS IS" BASIS,
 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 | See the License for the specific language governing permissions and
 | limitations under the License.
 |#

;;; Stream destructors.

(define (stream-pair=> stream)
  ;; Destructure a stream into its car and cdr.
  (cond-values
    (when-ct (stream-pair? stream)
      (values (stream-car stream) (stream-cdr stream)))))

(define (stream-predicate=> stream predicate?)
  ;; Destructure a stream into its car and cdr if the car satisfies
  ;; PREDICATE?
  (cond-values
    (after ((let (stream-pair=> stream) => (head stream))
            (when (predicate? head)))
      (values head stream))))

(define-syntax with-stream-predicates
  ;; Sequence stream predicates together.
  ;; The final cdr is bound to STREAM. The resultant CAR of each test
  ;; is bound to NAME.
  (syntax-rules ()
    ((_ stream ((predicate? name) ...) body ...)
     (after ((let (stream-predicate=> stream predicate?) => (name stream))
             ...)
       body ...))))

;;; Mapping utils.

(define (add-to-mapping mapping name rest)
  ;; Add REST to the flexvector mapped to NAME in MAPPING. If NAME is
  ;; not mapped, allocate a new flexvector with REST as its first element.
  (let ((fv (mapping-ref/default mapping name #f)))
    (cond
      (fv (flexvector-add-back! fv rest)
          mapping)
      (else (mapping-set mapping name (flexvector rest))))))

;;; Flexvector utils.

(define (flexvector-update-last! fv update)
  ;; Update the last value in FV with the result of applying UPDATE
  ;; to the last value in FV.
  (let ((len (flexvector-length fv)))
    (flexvector-set! fv
                     (- len 1)
                     (update (flexvector-ref fv (- len 1))))))

(define (append-new-line! fv rest)
  ;; Append to the last value in FV the string REST.
  (flexvector-update-last! fv
                           (lambda (x)
                             (string-append x "\n" rest))))

;;; Parsing each line.

(define (field-char? ch)
  ;; Check if CH is a valid RIS field char.
  (or (char-upper-case? ch) (char-numeric? ch)))

(define (end=> stream)
  ;; Check if STREAM is at the end of a line.
  (cond-values
    ;; EOF is end of line
    (when-ct (stream-null? stream)
      stream)
    ;; Handle CRLF
    (with-stream-predicates stream (((cut eqv? #\return <>) _)
                                    ((cut eqv? #\newline <>) _))
      stream)
    ;; Handle LF
    (with-stream-predicates stream (((cut eqv? #\newline <>) _))
      stream)))

(define (read-rest stream)
  ;; Read the rest of the stream up to the end of a line, and return
  ;; it as a string.
  (let ((fv (flexvector)))
    (let read-rest ((stream stream))
      (cond-thunk
        (after ((let (end=> stream) => (stream)))
          (values (flexvector->string fv) stream))
        (after ((let (stream-predicate=> stream char?)
                  => (x stream)))
          (flexvector-add-back! fv x)
          (read-rest stream))
        (else (raise (stream-error stream)))))))

(define (field=> stream)
  ;; At the start of a line, read a field specifier, or return no
  ;; values.
  ;; 
  ;; TODO: This needs to read /[A-Z0-9]{2,}  - /
  (let ((ws? (lambda (x)
               (char=? x #\space))))
    (cond-values
      (with-stream-predicates stream ((field-char? char1)
                                      (field-char? char2)
                                      (ws? _)
                                      (ws? _)
                                      ((cut char=? #\- <>) _)
                                      (ws? _))
        (let-values (((rest stream) (read-rest stream)))
          (values (string char1 char2) rest stream))))))

;;; Parsing of references.

(define (add/special-fields mapping name rest)
  (let ((mapping (add-to-mapping mapping name rest)))
    ;; If NAME is an author field, append the name to the special field
    ;; AUTHOR.
    (if (author-field? name)
        (add-to-mapping mapping "AUTHOR" rest)
        mapping)))

(define (read-reference stream mapping last-name)
  ;; Read an entire reference up to the ER field. This function starts
  ;; at the beginning of a line.
  ;; 
  ;; All new fields are added to MAPPING. Repeated fields are appended
  ;; to a flexvector that the field name maps to.
  ;; 
  ;; If the beginning of the line is not a field, then it is a
  ;; continuation of the last field, specified by LAST-NAME.
  ;; 
  ;; Returns (VALUES STREAM MAPPING) after ER.
  (cond-thunk
    (after ((let (field=> stream) => (name rest stream)))
      (if (equal? name "ER")
          (values stream mapping)
          (let ((mapping (add/special-fields mapping name rest)))
            (read-reference stream mapping name))))
    (when-ct (stream-null? stream)
      (values stream mapping))
    (else
     (let-values
         (((fv) (mapping-ref mapping last-name))
          ((rest stream) (read-rest stream)))
       (append-new-line! rest)
       (read-reference stream mapping last-name)))))

(define (new-mapping name rest)
  (add-to-mapping (mapping (make-default-comparator)) name rest))

(define (read-new-reference stream references-fv)
  ;; Read the start of a new reference.
  ;; 
  ;; If the file is at EOF, return MAPPING.
  ;; Otherwise, read the TY field of the new reference. If there is no
  ;; TY field, raise MALFORMED-REFERENCE-ERROR.
  (cond-thunk
    (when-ct (stream-null? stream)
      references-fv)
    (after ((let (field=> stream) => (name rest stream))
            (when (string=? name "TY")))
      (let-values (((stream ref-mapping)
                    (read-reference stream
                                    (new-mapping name rest)
                                    name)))
        (flexvector-add-back! references-fv ref-mapping)
        (read-new-reference stream references-fv)))
    (else (raise (malformed-reference-error stream)))))

(define (ris->mapping port)
  (read-new-reference (port->stream port)
                      (flexvector)))