#| 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.
 |#

(define-record-type <not-a-stream-error>
  (not-a-stream-error obj)
  not-a-stream-error?
  (obj not-a-stream-error:obj))

(define-record-type <malformed-reference-error>
  (malformed-reference-error stream)
  malformed-reference-error?
  (stream malformed-reference-error:stream))

(define-record-type <stream-error>
  (stream-error stream)
  stream-error?
  (stream stream-error:stream))

;;; Stream destructors.

(define (stream-pair=> stream)
  (cond-values
    (when-ct (stream-pair? stream)
      (values (stream-car stream) (stream-cdr stream)))))

(define (stream-predicate=> stream predicate?)
  (cond-values
    (after ((let (stream-pair=> stream) => (head stream))
            (when (predicate? head)))
      (values head stream))))

(define-syntax with-stream-predicates
  (syntax-rules ()
    ((_ stream ((predicate? name) ...) body ...)
     (after ((let (stream-predicate=> stream predicate?) => (name stream))
             ...)
       body ...))))

;;; Mapping destructors.

(define (mapping-ref=> mapping key)
  (mapping-ref mapping key (lambda () (values))))

(define (mapping-new-field mapping key val)
  (mapping-set mapping key (flexvector val)))

;;; Flexvector utils.

(define (flexvector-update-last! fv update)
  (let ((len (flexvector-length fv)))
    (flexvector-set! fv
                     (- len 1)
                     (update (flexvector-ref fv (- len 1))))))

;;; Parsing each line.

(define (prefix-char? ch)
  (or (char-upper-case? ch) (char-numeric? ch)))

(define (end=> stream)
  (cond-values
    (when-ct (stream-null? stream)
      stream)
    (with-stream-predicates stream (((cut eqv? #\return <>) _)
                                    ((cut eqv? #\newline <>) _))
      stream)
    (with-stream-predicates stream (((cut eqv? #\newline <>) _))
      stream)))

(define (read-rest stream)
  (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 (prefix=> stream)
  (let ((ws? (lambda (x)
               (char=? x #\space))))
    (cond-values
      (with-stream-predicates stream ((prefix-char? char1)
                                      (prefix-char? char2)
                                      (ws? _)
                                      (ws? _)
                                      ((cut char=? #\- <>) _)
                                      (ws? _))
        (let-values (((rest stream) (read-rest stream)))
          (values (string char1 char2) rest stream))))))

;;; Parsing of references.

(define (read-reference stream mapping last-name)
  (cond-thunk
    (after ((let (prefix=> stream) => (name rest stream)))
      (cond-thunk
        (when-ct (equal? name "ER")
          (values stream mapping))
        (after ((let (mapping-ref=> mapping name) => (fv)))
          (flexvector-add-back! fv rest)
          (read-reference stream mapping name))
        (else
         (read-reference stream
                         (mapping-new-field mapping
                                            name
                                            rest)
                         name))))
    (when-ct (stream-null? stream)
      (values stream mapping))
    (else
     (let-values
         (((fv) (mapping-ref mapping
                           last-name
                           (lambda () (error "internal error" stream))))
          ((rest stream) (read-rest stream)))
       (flexvector-update-last! fv
                                (lambda (last)
                                  (string-append last "\n" rest)))
       (read-reference stream mapping last-name)))))

(define (read-new-reference stream mapping)
  (cond-thunk
    (when-ct (stream-null? stream)
      mapping)
    (after ((let (prefix=> stream) => (name rest stream))
            (when (string=? name "TY")))
      (let-values (((stream mapping)
                    (read-reference stream
                                    (mapping-new-field mapping name rest)
                                    name)))
        (read-new-reference stream mapping)))
    (else (raise (malformed-reference-error stream)))))

(define (ris->mapping port)
  (read-new-reference (port->stream port)
                      (mapping (make-default-comparator))))