(use-modules (ice-9 peg)
             (ice-9 match))

(define-peg-pattern fff all
  (and (* (or WHITESPACE NEWLINE))
       (* (or comment
              object
              array
              item
              blanks))
       (* NEWLINE)
       (not-followed-by peg-any)))

(define-peg-pattern comment none
  (and HASH (* WHITESPACE)
       (* (and (not-followed-by NEWLINE)
               peg-any))))

(define-peg-pattern object all
  (and name
       (+ object-item)))

(define-peg-pattern array all
  (and name
       (+ array-item)))

(define-peg-pattern item all
  object-item)

(define-peg-pattern object-item body
  (and key (* WHITESPACE)
       COLON (* WHITESPACE)
       (or ref val)))

(define-peg-pattern array-item body
  (and (* WHITESPACE)
       COLON (* WHITESPACE)
       (or ref val)))

(define-peg-pattern name all
  (and key COLON COLON (* WHITESPACE) NEWLINE))

(define-peg-pattern key body
  (+ (and (not-followed-by COLON)
          nonl)))

(define-peg-pattern val all
  (and (* nonl)
       NEWLINE))

(define-peg-pattern ref all
  (and AT key NEWLINE))

(define-peg-pattern escaped body
  (and BACKSLASH (or (and NEWLINE (* WHITESPACE))
                     peg-any)))

(define-peg-pattern blanks none
  (+ NEWLINE))

(define-peg-pattern nonl body
  (or escaped
      (and (not-followed-by NEWLINE)
           peg-any)))

(define-peg-pattern NEWLINE none
  (or "\r\n" "\r" "\n"))

(define-peg-pattern WHITESPACE none
  (or " " "\t"))

(define-peg-pattern BACKSLASH none "\\")

(define-peg-pattern COLON none ":")

(define-peg-pattern HASH none "#")

(define-peg-pattern AT none "@")


(define (ensure-nested-list x)
  (if (list? (car x))
      x
      (list x)))

(define (atom? x)
  (and (not (null? x))
       (not (pair? x))))

(define (car-safe x)
  (if (pair? x)
      (car x)
      #f))


(define (fff? x)
  (and (pair? x)
       (eq? (car x) 'fff)))

(define (fff->scm str)
  (let ((tree (peg:tree (match-pattern fff str))))
    (if (fff? tree)
        (fff-ref-resolve (fff-tree->ref-tree tree))
        #f)))

(define (fff-tree->ref-tree tree)
  (let loop ((xs (cdr tree))
             (it '()))
    (if (null? xs)
        (reverse it)
        (loop (cdr xs)
              (match (car xs)
                (`(object (name ,name) ,pairs)
                 (cons (cons name
                             (map fff-pair->scm
                                  (ensure-nested-list pairs)))
                       it))
                (`(array (name ,name) ,values)
                 (cons (cons name
                             (list->vector (map fff-value->scm
                                                (ensure-nested-list values))))
                       it))
                (`(item . ,pair)
                 (cons (fff-pair->scm pair)
                       it))
                (_ it))))))

(define* (fff-ref-resolve tree #:optional environment keep-dupes?)
  (define dupes '())
  (define env (append (or environment '())
                      '(("true" . #t)
                        ("false" . #f)
                        ("null" . null))))
  (filter (lambda (x)
            (if keep-dupes?
                #t
                (not (member (or (car-safe x) x)
                             dupes))))
          (let loop ((xs tree)
                     (v? #f)
                     (it '()))
            (if (null? xs)
                ((if v? list->vector identity)
                 (reverse it))
                (begin
                  (loop (cdr xs)
                        v?
                        (cons (let ((x (car xs)))
                                (cond
                                 ((atom? x)
                                  (set! env (cons x env))
                                  x)
                                 ((procedure? (cdr x))
                                  (set! dupes (cons (car x) dupes))
                                  (let ((res
                                         (cons (car x)
                                               ((cdr x) (append env tree)))))
                                    (set! env (cons res env))
                                    res))
                                 ((atom? (cdr x))
                                  (set! env (cons x env))
                                  x)
                                 ((vector? (cdr x))
                                  (let ((vl (vector->list (cdr x))))
                                    (set! env (cons (fff-ref-resolve vl env #t)
                                                    env))
                                    (cons (car x)
                                          (loop vl #t '()))))
                                 (else   ; object
                                  (set! env (cons (fff-ref-resolve x env #t)
                                                  env))
                                  (cons (car x) ; not tail-recursive!
                                        (loop (cdr x) #f '())))))
                              it)))))))

(define (fff-pair->scm pair)
  (cons (car pair) (fff-value->scm (cadr pair))))

(define (fff-value->scm val)
  (match val
    (`(val ,v) v)
    (`(ref ,r) (lambda (alist)
                 (assoc-ref alist r)))))