First commit -- gross

2 files changed, 528 insertions, 0 deletions

@@ -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)))))
@@ -0,0 +1,345 @@
+#!/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
+
+(define-peg-pattern fff all
+  (and (* (or WHITESPACE NEWLINE))
+       (* (or comment
+              object
+              array
+              object-item))
+       blanks
+       (not-followed-by peg-any)))
+
+(define-peg-pattern object all
+  (and name
+       (+ object-item)
+       blanks))
+
+(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)))
+
+(define-peg-pattern name body
+  (and key COLON COLON NEWLINE))
+
+(define-peg-pattern object-item body
+  (and key (* WHITESPACE)
+       COLON (* WHITESPACE)
+       (or ref val)
+       blanks))
+
+(define-peg-pattern array-item body
+  (and (* WHITESPACE)
+       COLON (* WHITESPACE)
+       (or ref val)
+       blanks))
+
+(define-peg-pattern key body
+  (+ (and (not-followed-by COLON)
+          NONEWLINE)))
+
+;; (define-peg-pattern key body
+;;   key-raw)
+
+(define-peg-pattern val all
+  (* NONEWLINE))
+
+(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
+
+(define-peg-pattern escaped body
+  (and BACKSLASH (or (and NEWLINE (* WHITESPACE))
+                     peg-any)))
+
+;;; Terminals
+
+(define-peg-pattern BACKSLASH none
+  "\\")
+
+(define-peg-pattern COLON none
+  ":")
+
+(define-peg-pattern NEWLINE none
+  "\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 HASH 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 )
+
+(use-modules (ice-9 exceptions)
+             (ice-9 match))
+
+(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))
+        #f)))
+
+(define (fff->scm/refs 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)
+                 (cons (cons name
+                             (list->vector (map fff-val->scm vals)))
+                       it))
+                (`(object ,name ,pairs)
+                 (cons (cons name
+                             (map fff-pair->scm pairs))
+                       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 dupes '())
+  (filter (lambda (x)
+            (not (member (car x) dupes)))
+          (let loop ((xs tree)
+                     (it '())
+                     (v? #f))
+            (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))))))
+
+;; (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
+
+#|
+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
+|#