From ebd21bc83466eed2d70e3d6fc40156174d24f400 Mon Sep 17 00:00:00 2001
From: Case Duckworth
Date: Mon, 20 Mar 2023 16:30:32 -0500
Subject: First commit -- gross

---
 fff-parse.scm | 183 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 183 insertions(+)
 create mode 100644 fff-parse.scm

(limited to 'fff-parse.scm')

diff --git a/fff-parse.scm b/fff-parse.scm
new file mode 100644
index 0000000..6e524ad
--- /dev/null
+++ b/fff-parse.scm
@@ -0,0 +1,183 @@
+(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)))))
-- 
cgit 1.4.1-21-gabe81