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 ----------------------------
 fff.scm       | 378 +++++++++++++++++-----------------------------------------
 2 files changed, 108 insertions(+), 453 deletions(-)
 delete mode 100644 fff-parse.scm
 mode change 100755 => 100644 fff.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)))))
diff --git a/fff.scm b/fff.scm
old mode 100755
new mode 100644
index c349765..6e524ad
--- a/fff.scm
+++ b/fff.scm
@@ -1,345 +1,183 @@
-#!/bin/sh
-#| -*- scheme -*-
-exec guile -e main -s "$0" "$@"
-
-Flat Fuck Format
---- a new configuration format, because who doesn't need that?
-
-Copyright (C) 2023 Case Duckworth <acdw@acdw.net>
-
-Everyone is permitted to do whatever with this software, without
-limitation.  This software comes without any warranty whatsoever,
-but with two pieces of advice:
-
-- Don't hurt yourself.
-- Make good choices.
-
-Commentary:
-
-This script will convert files defined in the Flat Fuck Format (fff) into json.
-It will not convert anything back to fff.  fff is explicitly made to be as
-simple as possible, and exclusively human-written.  If a machine writes your
-configuration, ... use a better configuration format.  Or make your program
-scriptable!
-
-FLAT FUCK FORMAT : Specification
-|#
-!#
-
-
-;;; Format
-
-(use-modules (ice-9 peg))
-
-;;; Structure
+(use-modules (ice-9 peg)
+             (ice-9 match))
 
 (define-peg-pattern fff all
   (and (* (or WHITESPACE NEWLINE))
        (* (or comment
               object
               array
-              object-item))
-       blanks
+              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)
-       blanks))
+       (+ object-item)))
 
 (define-peg-pattern array all
   (and name
-       (+ array-item)
-       blanks))
-
-(define-peg-pattern anon all
-  (and (+ object-item)
-       blanks))
-
-;; (define-peg-pattern anon-array all
-;;   (and (+ array-item)
-;;        (* NEWLINE)))
+       (+ array-item)))
 
-(define-peg-pattern name body
-  (and key COLON COLON NEWLINE))
+(define-peg-pattern item all
+  object-item)
 
 (define-peg-pattern object-item body
   (and key (* WHITESPACE)
        COLON (* WHITESPACE)
-       (or ref val)
-       blanks))
+       (or ref val)))
 
 (define-peg-pattern array-item body
   (and (* WHITESPACE)
        COLON (* WHITESPACE)
-       (or ref val)
-       blanks))
+       (or ref val)))
+
+(define-peg-pattern name all
+  (and key COLON COLON (* WHITESPACE) NEWLINE))
 
 (define-peg-pattern key body
   (+ (and (not-followed-by COLON)
-          NONEWLINE)))
-
-;; (define-peg-pattern key body
-;;   key-raw)
+          nonl)))
 
 (define-peg-pattern val all
-  (* NONEWLINE))
+  (and (* nonl)
+       NEWLINE))
 
 (define-peg-pattern ref all
-  (and AT key))
-
-;;; Comments
-
-(define-peg-pattern comment none
-  (and HASH (* WHITESPACE)
-       (* (and (not-followed-by NEWLINE)
-               peg-any))
-       blanks))
-
-(define-peg-pattern blanks none
-  (* NEWLINE))
-
-;;; Escaped characters
+  (and AT key NEWLINE))
 
 (define-peg-pattern escaped body
   (and BACKSLASH (or (and NEWLINE (* WHITESPACE))
                      peg-any)))
 
-;;; Terminals
-
-(define-peg-pattern BACKSLASH none
-  "\\")
+(define-peg-pattern blanks none
+  (+ NEWLINE))
 
-(define-peg-pattern COLON none
-  ":")
+(define-peg-pattern nonl body
+  (or escaped
+      (and (not-followed-by NEWLINE)
+           peg-any)))
 
 (define-peg-pattern NEWLINE none
-  "\n")
+  (or "\r\n" "\r" "\n"))
 
 (define-peg-pattern WHITESPACE none
   (or " " "\t"))
 
-(define-peg-pattern NONEWLINE body
-  (or escaped
-      (and (not-followed-by NEWLINE)
-           peg-any)))
+(define-peg-pattern BACKSLASH none "\\")
+
+(define-peg-pattern COLON none ":")
 
-(define-peg-pattern HASH none
-  "#")
+(define-peg-pattern HASH none "#")
 
-(define-peg-pattern AT none
-  "@")
+(define-peg-pattern AT none "@")
 
 
-;;; Serialization
-;; I want fff to serialize to a structure that's compatible with the structure
-;; guile-json uses ( https://github.com/aconchillo/guile-json )
+(define (ensure-nested-list x)
+  (if (list? (car x))
+      x
+      (list x)))
 
-(use-modules (ice-9 exceptions)
-             (ice-9 match))
+(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 (car-safe x)
-;;   (if (pair? x)
-;;       (car x)
-;;       #f))
-
-;; (define (fff-tree->scm tree)
-;;   (let loop ((rest (cdr tree))
-;;              (accum '()))
-;;     (if (null? rest)
-;;         (reverse accum)
-;;         (let ((this (match (car rest)
-;;                       (`(anon . ,obj)
-;;                        (cons 'anon (fff-object->scm obj)))
-;;                       (`(object  ,name ,obj)
-;;                        (cons (cons 'obj name) (fff-object->scm obj)))
-;;                       (`(array ,name ,arr)
-;;                        (cons (cons 'arr name) (fff-array->scm arr))))))
-;;           (loop (cdr rest) (cons this accum))))))
-
 (define (fff->scm str)
-  (let ((fff (peg:tree
-              (match-pattern fff str))))
-    (if fff
-        (fff/refs->scm (fff->scm/refs fff))
+  (let ((tree (peg:tree (match-pattern fff str))))
+    (if (fff? tree)
+        (fff-ref-resolve (fff-tree->ref-tree tree))
         #f)))
 
-(define (fff->scm/refs tree)
+(define (fff-tree->ref-tree tree)
   (let loop ((xs (cdr tree))
              (it '()))
     (if (null? xs)
         (reverse it)
         (loop (cdr xs)
               (match (car xs)
-                ;; (`(anon . ,obj)
-                ;;  ;; Because of how peg's parsing works it collapses one-element
-                ;;  ;; lists, necessitating this check.
-                ;;  (if (pair? (car obj))
-                ;;      ;; We could use `map-in-order', but according to JSON the
-                ;;      ;; order of an object's keys doesn't matter ....
-                ;;      (append (map fff-pair->scm obj) it)
-                ;;      (cons (fff-pair->scm obj) it)))
-                (`(array ,name ,vals)
+                (`(object (name ,name) ,pairs)
                  (cons (cons name
-                             (list->vector (map fff-val->scm vals)))
+                             (map fff-pair->scm
+                                  (ensure-nested-list pairs)))
                        it))
-                (`(object ,name ,pairs)
+                (`(array (name ,name) ,values)
                  (cons (cons name
-                             (map fff-pair->scm pairs))
+                             (list->vector (map fff-value->scm
+                                                (ensure-nested-list values))))
                        it))
                 (`(item . ,pair)
                  (cons (fff-pair->scm pair)
                        it))
                 (_ it))))))
 
-(define (fff-val->scm val)
-  (match val
-    (`(val ,v) v)
-    (`(ref ,r) (lambda (alist)
-                 (assoc-ref alist r)))))
-
-(define (fff-pair->scm pair)
-  (cons (cdr pair) (fff-val->scm (cadr pair))))
-
-(define (atom? x)
-  (and (not (null? x))
-       (not (pair? x))))
-
-(define (fff/refs->scm tree)
+(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)
-            (not (member (car x) dupes)))
+            (if keep-dupes?
+                #t
+                (not (member (or (car-safe x) x)
+                             dupes))))
           (let loop ((xs tree)
-                     (it '())
-                     (v? #f))
+                     (v? #f)
+                     (it '()))
             (if (null? xs)
-                ((if v? list->vector identity) (reverse it))
-                (loop (cdr xs)
-                      (cons (let ((x (car xs)))
-                              (cond
-                               ((atom? x)
-                                x)
-                               ((procedure? (cdr x))
-                                (set! dupes (cons (car x) dupes))
-                                (cons (car x)
-                                      ((cdr x) tree)))
-                               ((atom? (cdr x))
-                                x)
-                               ((vector? (cdr x))
-                                (cons (car x)
-                                      (loop (vector->list (cdr x)) '() #t)))
-                               (else
-                                (cons (car x)  ; still not tail-recursive!
-                                      (loop (cdr x) '() #f)))))
-                            it)
-                      v?)))))
-
-;; (define (ref-resolve tree)
-;;   (map (lambda (x)
-;;          (display x)
-;;          (cond
-;;           ((atom? x)
-;;            (display ": atom\n")
-;;            x)
-;;           ((procedure? (cdr x))
-;;            (display " (cdr): procedure\n")
-;;            (cons (car x) ((cdr x) )))
-;;           ((atom? (cdr x))
-;;            (display " (cdr): atom\n")
-;;            x)
-;;           (else ; not tail-recursive!
-;;            (display " ...\n")
-;;            (cons (car x) (ref-resolve (cdr x))))))
-;;        tree))
-
-;; (define (fff-object->scm obj)
-;;   (let loop ((rest obj)
-;;              (accum '()))
-;;     (if (null? rest)
-;;         (reverse accum)
-;;         (let* ((this (car rest))
-;;                (k (car (assq-ref this 'key)))
-;;                (v (car-safe (assq-ref this 'val)))
-;;                (r (assq-ref this 'ref)))
-;;           (loop (cdr rest)
-;;                 (cons (cond
-;;                        (v (cons k v))
-;;                        (r (cons 'ref (cons k r)))
-;;                        (else 'fuck))
-;;                       accum))))))
+                ((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-array->scm arr)
-;;   (let loop ((rest arr)
-;;              (accum '()))
-;;     (if (null? rest)
-;;         (list->vector (reverse accum))
-;;         (let* ((this (car rest)))
-;;           (loop (cdr rest)
-;;                 (cons (case (car this)
-;;                         ((val) (cadr this))
-;;                         ((ref) this))
-;;                       accum))))))
-
-
-;;; Testing
-
-(use-modules (ice-9 textual-ports))
-
-(define test-input
-  (call-with-input-file "/home/case/var/fff.fff" get-string-all))
-
-(define test-input2
-  "
-a: 1
-b:2
-
-c:3
-
-d::
-da: 10
-db: 20
-
-e::
-: 30
-:40
-:     50
-
-f::
-z: @d
-y: @a
-
-g::
-f: @f
-another one: @f
-")
-
-(use-modules (ice-9 format))
-
-(define (test-parse input)
-  (let loop ((str "")
-             (num 0)
-             (lst (string-split input #\newline)))
-    (if (or (null? lst)
-            (not (match-pattern fff str)))
-        (format #t "~s~%" lst)
-        (begin
-          ;; (display (peg:tree (match-pattern fff str)))
-          (format #t "~s~%" (match-pattern fff str))
-          (when (match-pattern fff str)
-            (format #t "~s~%~%" (car lst)))
-          (loop (string-append str "\n" (car lst))
-                (+ num 1)
-                (cdr lst))))))
-
-
-;;; Notes
+(define (fff-pair->scm pair)
+  (cons (car pair) (fff-value->scm (cadr pair))))
 
-#|
-allow only `key:value` or named objects (list::..., dict::...)
-put everything in a big object/dict
-resolve references: fff string => list with refs (lambdas ?) => resolved list
-|#
+(define (fff-value->scm val)
+  (match val
+    (`(val ,v) v)
+    (`(ref ,r) (lambda (alist)
+                 (assoc-ref alist r)))))
-- 
cgit 1.4.1-21-gabe81