1 files changed, 166 insertions, 0 deletions

@@ -0,0 +1,166 @@
+;;; (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))