;;; (fff read) --- read an fff file into a scheme structure
;; (C) Case Duckworth <acdw@acdw.net>

(import (scheme base)
        (scheme case-lambda)

        (fff parse)

        (srfi 1)
        (utf8))

;;; Parameters

(define chunk-size
  (make-parameter 2048))

(define ignore-comments?
  (make-parameter #t))

(define base-environment
  (make-parameter '(("true" . #t)
                    ("false" . #f)
                    ("null" . null))))

;;; Transforming parsed intermediate representation into fff

(define (comment? it)
  (eq? 'comment (car it)))

(define (singleton it)
  (if (pair? it)
      (if (not (pair? (cdr it)))
          #t
          (and (eq? 'ref (cadr it))
               (not (pair? (cddr it)))
               'ref))
      #f))

(define (resolve-ref obj env)
  (let ((ref (cddr obj)))
    (if (assoc ref env)
        (cons (car obj)
              (cdr (assoc ref env)))
        (error "Reference doesn't exist: " ref env))))

(define (resolve-refs obj env)
  ;;; Resolve references in OBJ using ENV.
  (let loop ((items (cdr obj))
             (new-obj (list (car obj)))
             (resolved-refs '()))
    (if (null? items)
        (values (reverse new-obj)
                resolved-refs)

        (let ((this (car items)))
          (if (and (pair? (cdr this))
                   (eq? 'ref (cadr this)))
              (loop (cdr items)
                    (cons (resolve-ref this env) new-obj)
                    (cons (cddr this) resolved-refs))
              (loop (cdr items)
                    (cons this new-obj)
                    resolved-refs))))))

(define (maybe-vector obj)
  (let loop ((items (cdr obj))
             (type #f))
    (cond
     ((comment? obj)
      (cons 'comment
            (apply string-append
                   (map (lambda (s)
                          (string-append s "\n"))
                        (cdr obj)))))
     ((and (null? items)
           (eq? type 'object))
      obj)
     ((and (null? items)
           (eq? type 'vector))
      (cons (car obj)
            (list->vector (map cdr (cdr obj)))))
     ((not (pair? items))
      obj)
     (else
      (loop (cdr items)
            (if (caar items)
                (if (eq? type 'vector)
                    (error "Item type mismatch" 'object type)
                    'object)
                (if (eq? type 'object)
                    (error "Item type mismatch" 'vector type)
                    'vector)))))))

(define (%fff->scm fff env acc dupes)
  (if (null? fff)
      (map maybe-vector
           (reverse
            (filter
             (lambda (x) (not (member (car x) dupes)))
             acc)))
      (let ((this (car fff))
            (rest (cdr fff)))
        (cond
         ((comment? this)
          (if (ignore-comments?)
              (%fff->scm (cdr fff) env acc dupes)
              (%fff->scm rest env (cons this acc) dupes)))
         ((singleton this) =>
          (lambda (x)
            (%fff->scm rest
                       (cons this env)
                       (cons (if (eq? 'ref x)
                                 (resolve-ref this (append env fff))
                                 this)
                             acc)
                       (if (eq? 'ref x)
                           (cons (cddr this) dupes)
                           dupes))))
         (else
          (let-values (((resolved references)
                        (resolve-refs this (append env fff))))
            (%fff->scm rest
                       (cons this env)
                       (cons resolved acc)
                       (append references dupes))))))))

(define fff->scm
  (case-lambda
    ((fff)
     (%fff->scm fff (base-environment) '() '()))
    ((fff env)
     (%fff->scm fff env '() '()))))

;;; Reading fff

(define (read-port port)
  (let loop ((next (read-string (chunk-size) port))
             (blank? #f)
             (acc '()))
    (cond
     ((or (eof-object? next)
          (and blank? (equal? next "")))
      (close-input-port port)
      (apply string-append (reverse acc)))
     ((equal? next "")
      (loop (read-string (chunk-size) port)
            #t
            (cons next acc)))
     (else
      (loop (read-string (chunk-size) port)
            blank?
            (cons next acc))))))

(define (%read-fff port)
  (or (fff->scm (parse-fff (read-port port)))
      (error "Invalid fff" port)))

(define read-fff
  (case-lambda
    (()
     (%read-fff (current-input-port)))
    ((port)
     (%read-fff port))))

(define (read-fff-string str)
  (call-with-port (open-input-string str) %read-fff))