about summary refs log tree commit diff stats
path: root/fff.scm
diff options
context:
space:
mode:
Diffstat (limited to 'fff.scm')
-rw-r--r--[-rwxr-xr-x]fff.scm378
1 files changed, 108 insertions, 270 deletions
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))
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 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 "
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 178
341#| 179(define (fff-value->scm val)
342allow only `key:value` or named objects (list::..., dict::...) 180 (match val
343put everything in a big object/dict 181 (`(val ,v) v)
344resolve references: fff string => list with refs (lambdas ?) => resolved list 182 (`(ref ,r) (lambda (alist)
345|# 183 (assoc-ref alist r)))))