about summary refs log tree commit diff stats
path: root/fff-parse.scm
diff options
context:
space:
mode:
Diffstat (limited to 'fff-parse.scm')
-rw-r--r--fff-parse.scm183
1 files changed, 0 insertions, 183 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 @@
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)))))