Initial commit (chicken version)

6 files changed, 351 insertions, 0 deletions

@@ -0,0 +1,17 @@
+;;; -*- scheme -*-
+
+#+chicken (import (r7rs))
+
+(let loop ((load-files '("fff.parse"
+                         "fff.read")))
+  (if (null? load-files)
+      #t
+      (let ((this (car load-files)))
+        (load (string-append (car load-files) ".sld"))
+        (eval `(import ,(map string->symbol (string-split this "."))))
+        (load (string-append (car load-files) ".ss"))
+        (loop (cdr load-files)))))
+
+(define input (call-with-input-file "test.fff" read-port))
+
+(print "Ready.")
@@ -0,0 +1,20 @@
+;;; (fff parse) --- parse fff format
+;; (C) Case Duckworth <acdw@acdw.net>
+
+#+chicken (import (r7rs))
+
+(define-library (fff parse)
+  (export
+   ;; FFF objects
+   fff-val
+   fff-key
+   fff-ref
+   fff-comment
+   fff-item
+   fff-item*
+   fff-object
+   fff-document
+   ;; Parsing procedure
+   parse-fff)
+
+  (include "fff.parse.ss"))
@@ -0,0 +1,125 @@
+;;; Syntax
+;; an fff document translates to a key-value object containing lists or other
+;; objects.  Nesting objects are accomplished using references, which start with @.
+
+;; # comments start with '#' and go to the end of the line.
+;; fff-object::
+;; key: value
+;; key2: value2
+;; key3: @reference # a reference refers to another defined object
+;;
+;; # lists are similar to objects, just without keys
+;; fff-list::
+;; : item1
+;; : item2
+;; : item3
+;;
+;; name: something # this is okay too
+
+(import (scheme base)
+        (scheme case-lambda)
+        (utf8)
+        (comparse)
+        (srfi 14))
+
+(define anything
+  (in char-set:full))
+
+(define nl+ws
+  (sequence* ((_ (is #\newline))
+              (_ ws*))
+    (result " ")))
+
+(define end
+  (any-of nl+ws
+          end-of-input))
+
+(define end*
+  (any-of (one-or-more nl+ws)
+          end-of-input))
+
+(define (escaped parser)
+  (preceded-by (is #\\) parser))
+
+(define (unescaped parser)
+  (none-of* (escaped parser)
+            parser))
+
+(define ws
+  (in char-set:blank))
+
+(define ws*
+  (zero-or-more ws))
+
+(define nonl
+  (in (char-set-delete char-set:full #\newline)))
+
+(define fff-val
+  (sequence* ((@? (maybe (escaped (is #\@))))
+              (v (as-string
+                  (zero-or-more
+                   (any-of (escaped nl+ws)
+                           (none-of* nl+ws item))))))
+    (result (if @?
+                (string-append "@" v)
+                v))))
+
+(define fff-key
+  (as-string
+   (one-or-more
+    (all-of (any-of (escaped (is #\:))
+                    (escaped nl+ws)
+                    (none-of* (is #\:) nl+ws item))))))
+
+(define fff-ref
+  (sequence* ((_ (unescaped (is #\@)))
+              (k fff-key))
+    (result (cons 'ref k))))
+
+(define fff-comment
+  (sequence* ((_ (one-or-more (is #\#)))
+              (_ ws*)
+              (c (as-string (zero-or-more nonl)))
+              (_ end*))
+    (result (cons 'comment c))))
+
+(define fff-comment+
+  (bind (one-or-more fff-comment)
+        (lambda (xs)
+          (result (cons 'comment (map cdr xs))))))
+
+(define fff-item
+  (sequence* ((k (maybe fff-key))
+              (_ ws*)
+              (_ (is #\:))
+              (_ ws*)
+              (v (any-of fff-ref fff-val))
+              (_ end))
+    (result (cons k v))))
+
+(define fff-item*
+  (sequence* ((k fff-key)
+              (_ ws*)
+              (_ (is #\:))
+              (_ ws*)
+              (v (any-of fff-ref fff-val))
+              (_ end*))
+    (result (cons k v))))
+
+(define fff-object
+  (sequence* ((name fff-key)
+              (_ ws*)
+              (_ (sequence (is #\:) (is #\:) (is #\newline)))
+              (contents (one-or-more
+                         (any-of fff-comment+
+                                 fff-item)))
+              (_ end*))
+    (result (cons name contents))))
+
+(define fff-document
+  (zero-or-more (any-of fff-comment+
+                        fff-object
+                        fff-item*)))
+
+(define (parse-fff x)
+  (parse fff-document x))
@@ -0,0 +1,15 @@
+;;; (fff read)
+
+#+chicken (import (r7rs))
+
+(define-library (fff read)
+  (export
+   ;; Parameters
+   chunk-size
+   ignore-comments?
+   base-environment
+   ;; Reading
+   read-fff
+   read-fff-string)
+
+  (include "fff.read.ss"))
@@ -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))
@@ -0,0 +1,8 @@
+# Thoughts
+
+## Files
+
+- (fff read)
+- (fff parse)
+- (fff json)
+- (fff write) <!-- do i want this though? hm -->