Make fff-parse.scm the actual thing

So far so good
author: Case Duckworth 2023-03-20 16:30:52 -0500
committer: Case Duckworth 2023-03-20 16:30:52 -0500
commit: 1b731657d9b161c717193bdf8c853ec574346de5 (patch)
tree: 88b637c892ba074f311ae1f62e7bfb8812e39097
parent: First commit -- gross (diff)
download: fff-1b731657d9b161c717193bdf8c853ec574346de5.tar.gz
fff-1b731657d9b161c717193bdf8c853ec574346de5.zip
2 files changed, 108 insertions, 453 deletions
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
index c349765..6e524ad 100755..100644
--- a/fff.scm
+++ b/fff.scm

@@ -1,345 +1,183 @@
-#!/bin/sh
+(use-modules (ice-9 peg)
-#| -*- scheme -*-
+             (ice-9 match))
-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))
+              item
-       blanks
+              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)
+       (+ object-item)))
-       blanks))
 (define-peg-pattern array all
  (and name
-       (+ array-item)
+       (+ 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
+(define-peg-pattern item all
-  (and key COLON COLON NEWLINE))
+  object-item)
 (define-peg-pattern object-item body
  (and key (* WHITESPACE)
       COLON (* WHITESPACE)
-       (or ref val)
+       (or ref val)))
-       blanks))
 (define-peg-pattern array-item body
  (and (* WHITESPACE)
       COLON (* WHITESPACE)
-       (or ref val)
+       (or ref val)))
-       blanks))
+(define-peg-pattern name all
+  (and key COLON COLON (* WHITESPACE) NEWLINE))
 (define-peg-pattern key body
  (+ (and (not-followed-by COLON)
-          NONEWLINE)))
+          nonl)))
-;; (define-peg-pattern key body
-;;   key-raw)
 (define-peg-pattern val all
-  (* NONEWLINE))
+  (and (* nonl)
+       NEWLINE))
 (define-peg-pattern ref all
-  (and AT key))
+  (and AT key NEWLINE))
-;;; 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 blanks none
+  (+ NEWLINE))
-(define-peg-pattern BACKSLASH none
-  "\\")
-(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
+(define-peg-pattern BACKSLASH none "\\")
-  (or escaped
-      (and (not-followed-by NEWLINE)
+(define-peg-pattern COLON none ":")
-           peg-any)))
-(define-peg-pattern HASH none
+(define-peg-pattern HASH none "#")
-  "#")
-(define-peg-pattern AT none
+(define-peg-pattern AT none "@")
-  "@")
-;;; Serialization
+(define (ensure-nested-list x)
-;; I want fff to serialize to a structure that's compatible with the structure
+  (if (list? (car x))
-;; guile-json uses ( https://github.com/aconchillo/guile-json )
+      x
+      (list x)))
-(use-modules (ice-9 exceptions)
+(define (atom? x)
-             (ice-9 match))
+  (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
+  (let ((tree (peg:tree (match-pattern fff str))))
-              (match-pattern fff str))))
+    (if (fff? tree)
-    (if fff
+        (fff-ref-resolve (fff-tree->ref-tree tree))
-        (fff/refs->scm (fff->scm/refs fff))
        #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)
+                (`(object (name ,name) ,pairs)
-                ;;  ;; 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)))
+                             (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)
+(define* (fff-ref-resolve tree #:optional environment keep-dupes?)
-  (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 '())
+  (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))
+                ((if v? list->vector identity)
-                (loop (cdr xs)
+                 (reverse it))
-                      (cons (let ((x (car xs)))
+                (begin
-                              (cond
+                  (loop (cdr xs)
-                               ((atom? x)
+                        v?
-                                x)
+                        (cons (let ((x (car xs)))
-                               ((procedure? (cdr x))
+                                (cond
-                                (set! dupes (cons (car x) dupes))
+                                 ((atom? x)
-                                (cons (car x)
+                                  (set! env (cons x env))
-                                      ((cdr x) tree)))
+                                  x)
-                               ((atom? (cdr x))
+                                 ((procedure? (cdr x))
-                                x)
+                                  (set! dupes (cons (car x) dupes))
-                               ((vector? (cdr x))
+                                  (let ((res
-                                (cons (car x)
+                                         (cons (car x)
-                                      (loop (vector->list (cdr x)) '() #t)))
+                                               ((cdr x) (append env tree)))))
-                               (else
+                                    (set! env (cons res env))
-                                (cons (car x)  ; still not tail-recursive!
+                                    res))
-                                      (loop (cdr x) '() #f)))))
+                                 ((atom? (cdr x))
-                            it)
+                                  (set! env (cons x env))
-                      v?)))))
+                                  x)
+                                 ((vector? (cdr x))
-;; (define (ref-resolve tree)
+                                  (let ((vl (vector->list (cdr x))))
-;;   (map (lambda (x)
+                                    (set! env (cons (fff-ref-resolve vl env #t)
-;;          (display x)
+                                                    env))
-;;          (cond
+                                    (cons (car x)
-;;           ((atom? x)
+                                          (loop vl #t '()))))
-;;            (display ": atom\n")
+                                 (else   ; object
-;;            x)
+                                  (set! env (cons (fff-ref-resolve x env #t)
-;;           ((procedure? (cdr x))
+                                                  env))
-;;            (display " (cdr): procedure\n")
+                                  (cons (car x) ; not tail-recursive!
-;;            (cons (car x) ((cdr x) )))
+                                        (loop (cdr x) #f '())))))
-;;           ((atom? (cdr x))
+                              it)))))))
-;;            (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)
+(define (fff-pair->scm pair)
-;;   (let loop ((rest arr)
+  (cons (car pair) (fff-value->scm (cadr pair))))
-;;              (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-value->scm val)
-allow only `key:value` or named objects (list::..., dict::...)
+  (match val
-put everything in a big object/dict
+    (`(val ,v) v)
-resolve references: fff string => list with refs (lambdas ?) => resolved list
+    (`(ref ,r) (lambda (alist)
-|#
+                 (assoc-ref alist r)))))
author	Case Duckworth	2023-03-20 16:30:52 -0500
committer	Case Duckworth	2023-03-20 16:30:52 -0500
commit	1b731657d9b161c717193bdf8c853ec574346de5 (patch)
tree	88b637c892ba074f311ae1f62e7bfb8812e39097
parent	First commit -- gross (diff)
download	fff-1b731657d9b161c717193bdf8c853ec574346de5.tar.gz fff-1b731657d9b161c717193bdf8c853ec574346de5.zip

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 @@
1	(use-modules (ice-9 peg)
2	(ice-9 match))
3
4	(define-peg-pattern fff all
5	(and (* (or WHITESPACE NEWLINE))
6	(* (or comment
7	object
8	array
9	item
10	blanks))
11	(* NEWLINE)
12	(not-followed-by peg-any)))
13
14	(define-peg-pattern comment none
15	(and HASH (* WHITESPACE)
16	(* (and (not-followed-by NEWLINE)
17	peg-any))))
18
19	(define-peg-pattern object all
20	(and name
21	(+ object-item)))
22
23	(define-peg-pattern array all
24	(and name
25	(+ array-item)))
26
27	(define-peg-pattern item all
28	object-item)
29
30	(define-peg-pattern object-item body
31	(and key (* WHITESPACE)
32	COLON (* WHITESPACE)
33	(or ref val)))
34
35	(define-peg-pattern array-item body
36	(and (* WHITESPACE)
37	COLON (* WHITESPACE)
38	(or ref val)))
39
40	(define-peg-pattern name all
41	(and key COLON COLON (* WHITESPACE) NEWLINE))
42
43	(define-peg-pattern key body
44	(+ (and (not-followed-by COLON)
45	nonl)))
46
47	(define-peg-pattern val all
48	(and (* nonl)
49	NEWLINE))
50
51	(define-peg-pattern ref all
52	(and AT key NEWLINE))
53
54	(define-peg-pattern escaped body
55	(and BACKSLASH (or (and NEWLINE (* WHITESPACE))
56	peg-any)))
57
58	(define-peg-pattern blanks none
59	(+ NEWLINE))
60
61	(define-peg-pattern nonl body
62	(or escaped
63	(and (not-followed-by NEWLINE)
64	peg-any)))
65
66	(define-peg-pattern NEWLINE none
67	(or "\r\n" "\r" "\n"))
68
69	(define-peg-pattern WHITESPACE none
70	(or " " "\t"))
71
72	(define-peg-pattern BACKSLASH none "\\")
73
74	(define-peg-pattern COLON none ":")
75
76	(define-peg-pattern HASH none "#")
77
78	(define-peg-pattern AT none "@")
79
80
81	(define (ensure-nested-list x)
82	(if (list? (car x))
83	x
84	(list x)))
85
86	(define (atom? x)
87	(and (not (null? x))
88	(not (pair? x))))
89
90	(define (car-safe x)
91	(if (pair? x)
92	(car x)
93	#f))
94
95
96	(define (fff? x)
97	(and (pair? x)
98	(eq? (car x) 'fff)))
99
100	(define (fff->scm str)
101	(let ((tree (peg:tree (match-pattern fff str))))
102	(if (fff? tree)
103	(fff-ref-resolve (fff-tree->ref-tree tree))
104	#f)))
105
106	(define (fff-tree->ref-tree tree)
107	(let loop ((xs (cdr tree))
108	(it '()))
109	(if (null? xs)
110	(reverse it)
111	(loop (cdr xs)
112	(match (car xs)
113	(`(object (name ,name) ,pairs)
114	(cons (cons name
115	(map fff-pair->scm
116	(ensure-nested-list pairs)))
117	it))
118	(`(array (name ,name) ,values)
119	(cons (cons name
120	(list->vector (map fff-value->scm
121	(ensure-nested-list values))))
122	it))
123	(`(item . ,pair)
124	(cons (fff-pair->scm pair)
125	it))
126	(_ it))))))
127
128	(define* (fff-ref-resolve tree #:optional environment keep-dupes?)
129	(define dupes '())
130	(define env (append (or environment '())
131	'(("true" . #t)
132	("false" . #f)
133	("null" . null))))
134	(filter (lambda (x)
135	(if keep-dupes?
136	#t
137	(not (member (or (car-safe x) x)
138	dupes))))
139	(let loop ((xs tree)
140	(v? #f)
141	(it '()))
142	(if (null? xs)
143	((if v? list->vector identity)
144	(reverse it))
145	(begin
146	(loop (cdr xs)
147	v?
148	(cons (let ((x (car xs)))
149	(cond
150	((atom? x)
151	(set! env (cons x env))
152	x)
153	((procedure? (cdr x))
154	(set! dupes (cons (car x) dupes))
155	(let ((res
156	(cons (car x)
157	((cdr x) (append env tree)))))
158	(set! env (cons res env))
159	res))
160	((atom? (cdr x))
161	(set! env (cons x env))
162	x)
163	((vector? (cdr x))
164	(let ((vl (vector->list (cdr x))))
165	(set! env (cons (fff-ref-resolve vl env #t)
166	env))
167	(cons (car x)
168	(loop vl #t '()))))
169	(else ; object
170	(set! env (cons (fff-ref-resolve x env #t)
171	env))
172	(cons (car x) ; not tail-recursive!
173	(loop (cdr x) #f '())))))
174	it)))))))
175
176	(define (fff-pair->scm pair)
177	(cons (car pair) (fff-value->scm (cadr pair))))
178
179	(define (fff-value->scm val)
180	(match val
181	(`(val ,v) v)
182	(`(ref ,r) (lambda (alist)
183	(assoc-ref alist r)))))


diff --git a/fff.scm b/fff.scm index c349765..6e524ad 100755..100644 --- a/fff.scm +++ b/fff.scm
@@ -1,345 +1,183 @@
1	#!/bin/sh	1	(use-modules (ice-9 peg)
2	#\| -- scheme --	2	(ice-9 match))
3	exec guile -e main -s "$0" "$@"
4
5	Flat Fuck Format
6	--- a new configuration format, because who doesn't need that?
7
8	Copyright (C) 2023 Case Duckworth <acdw@acdw.net>
9
10	Everyone is permitted to do whatever with this software, without
11	limitation. This software comes without any warranty whatsoever,
12	but with two pieces of advice:
13
14	- Don't hurt yourself.
15	- Make good choices.
16
17	Commentary:
18
19	This script will convert files defined in the Flat Fuck Format (fff) into json.
20	It will not convert anything back to fff. fff is explicitly made to be as
21	simple as possible, and exclusively human-written. If a machine writes your
22	configuration, ... use a better configuration format. Or make your program
23	scriptable!
24
25	FLAT FUCK FORMAT : Specification
26	\|#
27	!#
28
29
30	;;; Format
31
32	(use-modules (ice-9 peg))
33
34	;;; Structure
35		3
36	(define-peg-pattern fff all	4	(define-peg-pattern fff all
37	(and (* (or WHITESPACE NEWLINE))	5	(and (* (or WHITESPACE NEWLINE))
38	(* (or comment	6	(* (or comment
39	object	7	object
40	array	8	array
41	object-item))	9	item
42	blanks	10	blanks))
		11	(* NEWLINE)
43	(not-followed-by peg-any)))	12	(not-followed-by peg-any)))
44		13
		14	(define-peg-pattern comment none
		15	(and HASH (* WHITESPACE)
		16	(* (and (not-followed-by NEWLINE)
		17	peg-any))))
		18
45	(define-peg-pattern object all	19	(define-peg-pattern object all
46	(and name	20	(and name
47	(+ object-item)	21	(+ object-item)))
48	blanks))
49		22
50	(define-peg-pattern array all	23	(define-peg-pattern array all
51	(and name	24	(and name
52	(+ array-item)	25	(+ array-item)))
53	blanks))
54
55	(define-peg-pattern anon all
56	(and (+ object-item)
57	blanks))
58
59	;; (define-peg-pattern anon-array all
60	;; (and (+ array-item)
61	;; (* NEWLINE)))
62		26
63	(define-peg-pattern name body	27	(define-peg-pattern item all
64	(and key COLON COLON NEWLINE))	28	object-item)
65		29
66	(define-peg-pattern object-item body	30	(define-peg-pattern object-item body
67	(and key (* WHITESPACE)	31	(and key (* WHITESPACE)
68	COLON (* WHITESPACE)	32	COLON (* WHITESPACE)
69	(or ref val)	33	(or ref val)))
70	blanks))
71		34
72	(define-peg-pattern array-item body	35	(define-peg-pattern array-item body
73	(and (* WHITESPACE)	36	(and (* WHITESPACE)
74	COLON (* WHITESPACE)	37	COLON (* WHITESPACE)
75	(or ref val)	38	(or ref val)))
76	blanks))	39
		40	(define-peg-pattern name all
		41	(and key COLON COLON (* WHITESPACE) NEWLINE))
77		42
78	(define-peg-pattern key body	43	(define-peg-pattern key body
79	(+ (and (not-followed-by COLON)	44	(+ (and (not-followed-by COLON)
80	NONEWLINE)))	45	nonl)))
81
82	;; (define-peg-pattern key body
83	;; key-raw)
84		46
85	(define-peg-pattern val all	47	(define-peg-pattern val all
86	(* NONEWLINE))	48	(and (* nonl)
		49	NEWLINE))
87		50
88	(define-peg-pattern ref all	51	(define-peg-pattern ref all
89	(and AT key))	52	(and AT key NEWLINE))
90
91	;;; Comments
92
93	(define-peg-pattern comment none
94	(and HASH (* WHITESPACE)
95	(* (and (not-followed-by NEWLINE)
96	peg-any))
97	blanks))
98
99	(define-peg-pattern blanks none
100	(* NEWLINE))
101
102	;;; Escaped characters
103		53
104	(define-peg-pattern escaped body	54	(define-peg-pattern escaped body
105	(and BACKSLASH (or (and NEWLINE (* WHITESPACE))	55	(and BACKSLASH (or (and NEWLINE (* WHITESPACE))
106	peg-any)))	56	peg-any)))
107		57
108	;;; Terminals	58	(define-peg-pattern blanks none
109		59	(+ NEWLINE))
110	(define-peg-pattern BACKSLASH none
111	"\\")
112		60
113	(define-peg-pattern COLON none	61	(define-peg-pattern nonl body
114	":")	62	(or escaped
		63	(and (not-followed-by NEWLINE)
		64	peg-any)))
115		65
116	(define-peg-pattern NEWLINE none	66	(define-peg-pattern NEWLINE none
117	"\n")	67	(or "\r\n" "\r" "\n"))
118		68
119	(define-peg-pattern WHITESPACE none	69	(define-peg-pattern WHITESPACE none
120	(or " " "\t"))	70	(or " " "\t"))
121		71
122	(define-peg-pattern NONEWLINE body	72	(define-peg-pattern BACKSLASH none "\\")
123	(or escaped	73
124	(and (not-followed-by NEWLINE)	74	(define-peg-pattern COLON none ":")
125	peg-any)))
126		75
127	(define-peg-pattern HASH none	76	(define-peg-pattern HASH none "#")
128	"#")
129		77
130	(define-peg-pattern AT none	78	(define-peg-pattern AT none "@")
131	"@")
132		79
133		80
134	;;; Serialization	81	(define (ensure-nested-list x)
135	;; I want fff to serialize to a structure that's compatible with the structure	82	(if (list? (car x))
136	;; guile-json uses ( https://github.com/aconchillo/guile-json )	83	x
		84	(list x)))
137		85
138	(use-modules (ice-9 exceptions)	86	(define (atom? x)
139	(ice-9 match))	87	(and (not (null? x))
		88	(not (pair? x))))
		89
		90	(define (car-safe x)
		91	(if (pair? x)
		92	(car x)
		93	#f))
140		94
		95
141	(define (fff? x)	96	(define (fff? x)
142	(and (pair? x)	97	(and (pair? x)
143	(eq? (car x) 'fff)))	98	(eq? (car x) 'fff)))
144		99
145	;; (define (car-safe x)
146	;; (if (pair? x)
147	;; (car x)
148	;; #f))
149
150	;; (define (fff-tree->scm tree)
151	;; (let loop ((rest (cdr tree))
152	;; (accum '()))
153	;; (if (null? rest)
154	;; (reverse accum)
155	;; (let ((this (match (car rest)
156	;; (`(anon . ,obj)
157	;; (cons 'anon (fff-object->scm obj)))
158	;; (`(object ,name ,obj)
159	;; (cons (cons 'obj name) (fff-object->scm obj)))
160	;; (`(array ,name ,arr)
161	;; (cons (cons 'arr name) (fff-array->scm arr))))))
162	;; (loop (cdr rest) (cons this accum))))))
163
164	(define (fff->scm str)	100	(define (fff->scm str)
165	(let ((fff (peg:tree	101	(let ((tree (peg:tree (match-pattern fff str))))
166	(match-pattern fff str))))	102	(if (fff? tree)
167	(if fff	103	(fff-ref-resolve (fff-tree->ref-tree tree))
168	(fff/refs->scm (fff->scm/refs fff))
169	#f)))	104	#f)))
170		105
171	(define (fff->scm/refs tree)	106	(define (fff-tree->ref-tree tree)
172	(let loop ((xs (cdr tree))	107	(let loop ((xs (cdr tree))
173	(it '()))	108	(it '()))
174	(if (null? xs)	109	(if (null? xs)
175	(reverse it)	110	(reverse it)
176	(loop (cdr xs)	111	(loop (cdr xs)
177	(match (car xs)	112	(match (car xs)
178	;; (`(anon . ,obj)	113	(`(object (name ,name) ,pairs)
179	;; ;; Because of how peg's parsing works it collapses one-element
180	;; ;; lists, necessitating this check.
181	;; (if (pair? (car obj))
182	;; ;; We could use `map-in-order', but according to JSON the
183	;; ;; order of an object's keys doesn't matter ....
184	;; (append (map fff-pair->scm obj) it)
185	;; (cons (fff-pair->scm obj) it)))
186	(`(array ,name ,vals)
187	(cons (cons name	114	(cons (cons name
188	(list->vector (map fff-val->scm vals)))	115	(map fff-pair->scm
		116	(ensure-nested-list pairs)))
189	it))	117	it))
190	(`(object ,name ,pairs)	118	(`(array (name ,name) ,values)
191	(cons (cons name	119	(cons (cons name
192	(map fff-pair->scm pairs))	120	(list->vector (map fff-value->scm
		121	(ensure-nested-list values))))
193	it))	122	it))
194	(`(item . ,pair)	123	(`(item . ,pair)
195	(cons (fff-pair->scm pair)	124	(cons (fff-pair->scm pair)
196	it))	125	it))
197	(_ it))))))	126	(_ it))))))
198		127
199	(define (fff-val->scm val)	128	(define* (fff-ref-resolve tree #:optional environment keep-dupes?)
200	(match val
201	(`(val ,v) v)
202	(`(ref ,r) (lambda (alist)
203	(assoc-ref alist r)))))
204
205	(define (fff-pair->scm pair)
206	(cons (cdr pair) (fff-val->scm (cadr pair))))
207
208	(define (atom? x)
209	(and (not (null? x))
210	(not (pair? x))))
211
212	(define (fff/refs->scm tree)
213	(define dupes '())	129	(define dupes '())
		130	(define env (append (or environment '())
		131	'(("true" . #t)
		132	("false" . #f)
		133	("null" . null))))
214	(filter (lambda (x)	134	(filter (lambda (x)
215	(not (member (car x) dupes)))	135	(if keep-dupes?
		136	#t
		137	(not (member (or (car-safe x) x)
		138	dupes))))
216	(let loop ((xs tree)	139	(let loop ((xs tree)
217	(it '())	140	(v? #f)
218	(v? #f))	141	(it '()))
219	(if (null? xs)	142	(if (null? xs)
220	((if v? list->vector identity) (reverse it))	143	((if v? list->vector identity)
221	(loop (cdr xs)	144	(reverse it))
222	(cons (let ((x (car xs)))	145	(begin
223	(cond	146	(loop (cdr xs)
224	((atom? x)	147	v?
225	x)	148	(cons (let ((x (car xs)))
226	((procedure? (cdr x))	149	(cond
227	(set! dupes (cons (car x) dupes))	150	((atom? x)
228	(cons (car x)	151	(set! env (cons x env))
229	((cdr x) tree)))	152	x)
230	((atom? (cdr x))	153	((procedure? (cdr x))
231	x)	154	(set! dupes (cons (car x) dupes))
232	((vector? (cdr x))	155	(let ((res
233	(cons (car x)	156	(cons (car x)
234	(loop (vector->list (cdr x)) '() #t)))	157	((cdr x) (append env tree)))))
235	(else	158	(set! env (cons res env))
236	(cons (car x) ; still not tail-recursive!	159	res))
237	(loop (cdr x) '() #f)))))	160	((atom? (cdr x))
238	it)	161	(set! env (cons x env))
239	v?)))))	162	x)
240		163	((vector? (cdr x))
241	;; (define (ref-resolve tree)	164	(let ((vl (vector->list (cdr x))))
242	;; (map (lambda (x)	165	(set! env (cons (fff-ref-resolve vl env #t)
243	;; (display x)	166	env))
244	;; (cond	167	(cons (car x)
245	;; ((atom? x)	168	(loop vl #t '()))))
246	;; (display ": atom\n")	169	(else ; object
247	;; x)	170	(set! env (cons (fff-ref-resolve x env #t)
248	;; ((procedure? (cdr x))	171	env))
249	;; (display " (cdr): procedure\n")	172	(cons (car x) ; not tail-recursive!
250	;; (cons (car x) ((cdr x) )))	173	(loop (cdr x) #f '())))))
251	;; ((atom? (cdr x))	174	it)))))))
252	;; (display " (cdr): atom\n")
253	;; x)
254	;; (else ; not tail-recursive!
255	;; (display " ...\n")
256	;; (cons (car x) (ref-resolve (cdr x))))))
257	;; tree))
258
259	;; (define (fff-object->scm obj)
260	;; (let loop ((rest obj)
261	;; (accum '()))
262	;; (if (null? rest)
263	;; (reverse accum)
264	;; (let* ((this (car rest))
265	;; (k (car (assq-ref this 'key)))
266	;; (v (car-safe (assq-ref this 'val)))
267	;; (r (assq-ref this 'ref)))
268	;; (loop (cdr rest)
269	;; (cons (cond
270	;; (v (cons k v))
271	;; (r (cons 'ref (cons k r)))
272	;; (else 'fuck))
273	;; accum))))))
274		175
275	;; (define (fff-array->scm arr)	176	(define (fff-pair->scm pair)
276	;; (let loop ((rest arr)	177	(cons (car pair) (fff-value->scm (cadr pair))))
277	;; (accum '()))
278	;; (if (null? rest)
279	;; (list->vector (reverse accum))
280	;; (let* ((this (car rest)))
281	;; (loop (cdr rest)
282	;; (cons (case (car this)
283	;; ((val) (cadr this))
284	;; ((ref) this))
285	;; accum))))))
286
287
288	;;; Testing
289
290	(use-modules (ice-9 textual-ports))
291
292	(define test-input
293	(call-with-input-file "/home/case/var/fff.fff" get-string-all))
294
295	(define test-input2
296	"
297	a: 1
298	b:2
299
300	c:3
301
302	d::
303	da: 10
304	db: 20
305
306	e::
307	: 30
308	:40
309	: 50
310
311	f::
312	z: @d
313	y: @a
314
315	g::
316	f: @f
317	another one: @f
318	")
319
320	(use-modules (ice-9 format))
321
322	(define (test-parse input)
323	(let loop ((str "")
324	(num 0)
325	(lst (string-split input #\newline)))
326	(if (or (null? lst)
327	(not (match-pattern fff str)))
328	(format #t "~s~%" lst)
329	(begin
330	;; (display (peg:tree (match-pattern fff str)))
331	(format #t "~s~%" (match-pattern fff str))
332	(when (match-pattern fff str)
333	(format #t "~s~%~%" (car lst)))
334	(loop (string-append str "\n" (car lst))
335	(+ num 1)
336	(cdr lst))))))
337
338
339	;;; Notes
340		178
341	#\|	179	(define (fff-value->scm val)
342	allow only `key:value` or named objects (list::..., dict::...)	180	(match val
343	put everything in a big object/dict	181	(`(val ,v) v)
344	resolve references: fff string => list with refs (lambdas ?) => resolved list	182	(`(ref ,r) (lambda (alist)
345	\|#	183	(assoc-ref alist r)))))