about summary refs log tree commit diff stats
diff options
context:
space:
mode:
-rw-r--r--fff-parse.scm183
-rwxr-xr-xfff.scm345
2 files changed, 528 insertions, 0 deletions
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 @@
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 new file mode 100755 index 0000000..c349765 --- /dev/null +++ b/fff.scm
@@ -0,0 +1,345 @@
1#!/bin/sh
2#| -*- scheme -*-
3exec guile -e main -s "$0" "$@"
4
5Flat Fuck Format
6--- a new configuration format, because who doesn't need that?
7
8Copyright (C) 2023 Case Duckworth <acdw@acdw.net>
9
10Everyone is permitted to do whatever with this software, without
11limitation. This software comes without any warranty whatsoever,
12but with two pieces of advice:
13
14- Don't hurt yourself.
15- Make good choices.
16
17Commentary:
18
19This script will convert files defined in the Flat Fuck Format (fff) into json.
20It will not convert anything back to fff. fff is explicitly made to be as
21simple as possible, and exclusively human-written. If a machine writes your
22configuration, ... use a better configuration format. Or make your program
23scriptable!
24
25FLAT FUCK FORMAT : Specification
26|#
27!#
28
29
30;;; Format
31
32(use-modules (ice-9 peg))
33
34;;; Structure
35
36(define-peg-pattern fff all
37 (and (* (or WHITESPACE NEWLINE))
38 (* (or comment
39 object
40 array
41 object-item))
42 blanks
43 (not-followed-by peg-any)))
44
45(define-peg-pattern object all
46 (and name
47 (+ object-item)
48 blanks))
49
50(define-peg-pattern array all
51 (and name
52 (+ 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
63(define-peg-pattern name body
64 (and key COLON COLON NEWLINE))
65
66(define-peg-pattern object-item body
67 (and key (* WHITESPACE)
68 COLON (* WHITESPACE)
69 (or ref val)
70 blanks))
71
72(define-peg-pattern array-item body
73 (and (* WHITESPACE)
74 COLON (* WHITESPACE)
75 (or ref val)
76 blanks))
77
78(define-peg-pattern key body
79 (+ (and (not-followed-by COLON)
80 NONEWLINE)))
81
82;; (define-peg-pattern key body
83;; key-raw)
84
85(define-peg-pattern val all
86 (* NONEWLINE))
87
88(define-peg-pattern ref all
89 (and AT key))
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
104(define-peg-pattern escaped body
105 (and BACKSLASH (or (and NEWLINE (* WHITESPACE))
106 peg-any)))
107
108;;; Terminals
109
110(define-peg-pattern BACKSLASH none
111 "\\")
112
113(define-peg-pattern COLON none
114 ":")
115
116(define-peg-pattern NEWLINE none
117 "\n")
118
119(define-peg-pattern WHITESPACE none
120 (or " " "\t"))
121
122(define-peg-pattern NONEWLINE body
123 (or escaped
124 (and (not-followed-by NEWLINE)
125 peg-any)))
126
127(define-peg-pattern HASH none
128 "#")
129
130(define-peg-pattern AT none
131 "@")
132
133
134;;; Serialization
135;; I want fff to serialize to a structure that's compatible with the structure
136;; guile-json uses ( https://github.com/aconchillo/guile-json )
137
138(use-modules (ice-9 exceptions)
139 (ice-9 match))
140
141(define (fff? x)
142 (and (pair? x)
143 (eq? (car x) 'fff)))
144
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)
165 (let ((fff (peg:tree
166 (match-pattern fff str))))
167 (if fff
168 (fff/refs->scm (fff->scm/refs fff))
169 #f)))
170
171(define (fff->scm/refs tree)
172 (let loop ((xs (cdr tree))
173 (it '()))
174 (if (null? xs)
175 (reverse it)
176 (loop (cdr xs)
177 (match (car xs)
178 ;; (`(anon . ,obj)
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
188 (list->vector (map fff-val->scm vals)))
189 it))
190 (`(object ,name ,pairs)
191 (cons (cons name
192 (map fff-pair->scm pairs))
193 it))
194 (`(item . ,pair)
195 (cons (fff-pair->scm pair)
196 it))
197 (_ it))))))
198
199(define (fff-val->scm val)
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 '())
214 (filter (lambda (x)
215 (not (member (car x) dupes)))
216 (let loop ((xs tree)
217 (it '())
218 (v? #f))
219 (if (null? xs)
220 ((if v? list->vector identity) (reverse it))
221 (loop (cdr xs)
222 (cons (let ((x (car xs)))
223 (cond
224 ((atom? x)
225 x)
226 ((procedure? (cdr x))
227 (set! dupes (cons (car x) dupes))
228 (cons (car x)
229 ((cdr x) tree)))
230 ((atom? (cdr x))
231 x)
232 ((vector? (cdr x))
233 (cons (car x)
234 (loop (vector->list (cdr x)) '() #t)))
235 (else
236 (cons (car x) ; still not tail-recursive!
237 (loop (cdr x) '() #f)))))
238 it)
239 v?)))))
240
241;; (define (ref-resolve tree)
242;; (map (lambda (x)
243;; (display x)
244;; (cond
245;; ((atom? x)
246;; (display ": atom\n")
247;; x)
248;; ((procedure? (cdr x))
249;; (display " (cdr): procedure\n")
250;; (cons (car x) ((cdr x) )))
251;; ((atom? (cdr x))
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
275;; (define (fff-array->scm arr)
276;; (let loop ((rest arr)
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 "
297a: 1
298b:2
299
300c:3
301
302d::
303da: 10
304db: 20
305
306e::
307: 30
308:40
309: 50
310
311f::
312z: @d
313y: @a
314
315g::
316f: @f
317another 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
341#|
342allow only `key:value` or named objects (list::..., dict::...)
343put everything in a big object/dict
344resolve references: fff string => list with refs (lambdas ?) => resolved list
345|#