From 1b731657d9b161c717193bdf8c853ec574346de5 Mon Sep 17 00:00:00 2001
From: Case Duckworth
Date: Mon, 20 Mar 2023 16:30:52 -0500
Subject: Make fff-parse.scm the actual thing

So far so good
---
 fff-parse.scm | 183 ----------------------------------------------------------
 1 file changed, 183 deletions(-)
 delete mode 100644 fff-parse.scm

(limited to 'fff-parse.scm')

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