-
Notifications
You must be signed in to change notification settings - Fork 111
/
sugar.ss
378 lines (331 loc) · 11.7 KB
/
sugar.ss
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
;;; -*- Gerbil -*-
;;; (C) vyzo
;;; some standard sugar
(export
defrule
catch
finally
try
with-destroy
defmethod/alias
using
using-method
with-methods
with-class-methods
with-class-method
assert!
while
until
hash
hash-eq
hash-eqv
let-hash
awhen
chain
is)
(defrules defrule ()
((_ (name args ...) body ...)
(defrules name () ((name args ...) body ...))))
(defrules catch ())
(defrules finally ())
(defsyntax (try stx)
(def (generate-thunk body)
(if (null? body)
(raise-syntax-error #f "Bad syntax; missing body" stx)
(with-syntax (((e ...) (reverse body)))
#'(lambda () e ...))))
(def (generate-fini thunk fini)
(with-syntax ((thunk thunk)
((e ...) fini))
#'(with-unwind-protect thunk (lambda () e ...))))
(def (generate-catch handlers thunk)
(with-syntax (($e (genident)))
(let lp ((rest handlers) (clauses []))
(match rest
([hd . rest]
(syntax-case hd (=>)
((pred => K)
(lp rest (cons #'(((? pred) $e) => K)
clauses)))
(((pred var) body ...)
(identifier? #'var)
(lp rest (cons #'(((? pred) $e) (let ((var $e)) body ...))
clauses)))
(((var) body ...)
(identifier? #'var)
(lp rest (cons #'(#t (let ((var $e)) body ...))
clauses)))
((us body ...)
(underscore? #'us)
(lp rest (cons #'(#t (begin body ...))
clauses)))))
(else
(with-syntax (((clause ...) clauses)
(thunk thunk))
#'(with-catch
(lambda ($e) (cond clause ... (else (raise $e))))
thunk)))))))
(syntax-case stx ()
((_ e ...)
(let lp ((rest #'(e ...)) (body []))
(syntax-case rest ()
((hd . rest)
(syntax-case #'hd (catch finally)
((finally fini ...)
(if (stx-null? #'rest)
(generate-fini (generate-thunk body) #'(fini ...))
(raise-syntax-error #f "Misplaced finally clause" stx)))
((catch handler ...)
(let lp ((rest #'rest) (handlers [#'(handler ...)]))
(syntax-case rest (catch finally)
(((catch handler ...) . rest)
(lp #'rest [#'(handler ...) . handlers]))
(((finally fini ...))
(with-syntax ((body (generate-catch handlers (generate-thunk body))))
(generate-fini #'(lambda () body) #'(fini ...))))
(()
(generate-catch handlers (generate-thunk body))))))
(_ (lp #'rest (cons #'hd body)))))
(() ; no clauses, just a begin
(cons 'begin (reverse body))))))))
(defrule (with-destroy obj body ...)
(let ($obj obj)
(try body ... (finally {destroy $obj}))))
(defsyntax (defmethod/alias stx)
(syntax-case stx (@method)
((_ {method (alias ...) type} body ...)
(and (identifier? #'method)
(stx-andmap identifier? #'(alias ...))
(syntax-local-type-info? #'type))
(with-syntax* (((values klass) (syntax-local-value #'type))
(type::t (runtime-type-identifier klass))
(method-impl (stx-identifier #'method #'type "::" #'method)))
#'(begin
(defmethod {method type} body ...)
(bind-method! type::t 'alias method-impl) ...)))))
(defrule (using obj method ...)
(begin (using-method obj method) ...))
(defrules using-method ()
((_ obj method)
(identifier? #'method)
(def method (checked-bound-method-ref obj 'method)))
((_ obj (method method-id))
(and (identifier? #'method) (identifier? #'method-id))
(def method (checked-bound-method-ref obj 'method-id))))
(defrule (with-methods o method ...)
(begin
(def $klass (object-type o))
(with-class-methods $klass method ...)))
(defrule (with-class-methods klass method ...)
(begin (with-class-method klass method) ...))
(defrules with-class-method ()
((_ klass (method method-id))
(and (identifier? #'method) (identifier? #'method-id))
(def method
(cond
((find-method klass 'method-id))
(else
(error "Missing method" klass 'method-id)))))
((recur klass method)
(identifier? #'method)
(recur klass (method method))))
(defrules assert! ()
((_ expr)
(unless expr
(error "Assertion failed" 'expr)))
((_ expr message)
(unless expr
(error "Assertion failed" message 'expr))))
(defrule (while test body ...)
(let lp ()
(when test
body ...
(lp))))
(defrule (until test body ...)
(let lp ()
(unless test
body ...
(lp))))
(defrule (hash (key val) ...)
(~hash-table make-hash-table (key val) ...))
(defrule (hash-eq (key val) ...)
(~hash-table make-hash-table-eq (key val) ...))
(defrule (hash-eqv (key val) ...)
(~hash-table make-hash-table-eqv (key val) ...))
(defsyntax (~hash-table stx)
(syntax-case stx ()
((_ make-ht clause ...)
(with-syntax* ((size (stx-length #'(clause ...)))
(((key val) ...) #'(clause ...)))
#'(let (ht (make-ht size: size))
(hash-put! ht `key val) ...
ht)))))
;; the hash deconstructor macro
;; usage: (let-hash a-hash body ...)
;; rebinds %%ref so that identifiers starting with a dot are looked up in the hash:
;; .x -> (hash-ref a-hash 'x) ; strong accessor
;; .?x -> (hash-get a-hash 'x) ; weak accessor
;; ..x -> (%%ref .x) ; escape
(defsyntax (let-hash stx)
(syntax-case stx ()
((macro expr body ...)
(with-syntax ((@ref (stx-identifier #'macro '%%ref)))
#'(let (ht expr)
(let-syntax
((var-ref
(syntax-rules ()
((_ id) (@ref id)))))
(let-syntax
((@ref
(lambda (stx)
(syntax-case stx ()
((_ id)
(let (str (symbol->string (stx-e #'id)))
(def (str->symbol start)
(string->symbol (substring str start (string-length str))))
(if (eq? (string-ref str 0) #\.) ; hash accessor?
(cond
((eq? (string-ref str 1) #\.) ; escape
(with-syntax ((sym (str->symbol 1)))
#'(var-ref sym)))
((eq? (string-ref str 1) #\?) ; weak
(with-syntax ((sym (str->symbol 2)))
#'(hash-get ht 'sym)))
(else
(with-syntax ((sym (str->symbol 1)))
#'(hash-ref ht 'sym))))
#'(var-ref id))))))))
body ...)))))))
(defrule (awhen (id test) body ...)
(let (id test)
(when id body ...)))
;; chain rewrites passed expressions by passing the previous expression
;; into the position of the <> diamond symbol. In case a previous expression
;; should be used in a sub-expression, or multiple times, the expression can
;; be prefixed with a variable (supports destructuring).
;;
;; When the first expression is a <>, chain will return a unary lambda.
;;
;; Example:
;; (chain [1 2 3]
;; ([_ . rest] (map number->string rest))
;; (v (string-join v ", "))
;; (string-append <> " :)"))
;; => "2, 3 :)"
(defrules chain (<>)
((_ <> exp exp* ...)
(lambda (init)
(~chain-wrap-fn init (exp exp* ...))))
((_ init exp exp* ...)
(~chain-wrap-fn init (exp exp* ...)))
((_ <>) (lambda (init) init))
((_ init) init))
;; ~chain-wrap-fn is an auxiliary macro to wrap unary procedures which
;; have no parentheses around with parentheses: proc -> (proc) to
;; distinguish them later in ~chain-aux.
(defrules ~chain-wrap-fn ()
((_ init () previous)
(~chain-aux previous init))
((_ init ((proc arg arg* ...) . more))
(~chain-wrap-fn init more ((proc arg arg* ...))))
((_ init ((proc arg arg* ...) . more) (previous ...))
(~chain-wrap-fn init more (previous ... (proc arg arg* ...))))
((_ init (proc . more))
(~chain-wrap-fn init more ((proc))))
((_ init (proc . more) (previous ...))
(~chain-wrap-fn init more (previous ... (proc)))))
;; ~chain-aux is an auxiliary macro which takes a list of expressions
;; and the initial chain value. It then loops over the expression list
;; and transforms one expression after the other.
(defrules ~chain-aux (<>)
((_ () previous)
previous)
((_ ((var ()) . more) previous)
(syntax-error "Body expression cannot be empty"))
;; variable
((_ ((var (body1 body2 . body*)) . more) previous)
(~chain-aux more
(~chain-aux-variable (var previous) (body1 body2 . body*))))
((_ ((var (body1 body2 . body*) (body-error ...) ...) . more) previous)
(syntax-error "More than one body expression in chain-variable context"))
;; unary procedure
((_ ((fn) . more) previous)
(~chain-aux more (fn previous)))
;; diamond
((_ ((fn . args) . more) previous)
(~chain-aux more
(~chain-aux-diamond (fn . args) () previous))))
;; ~chain-aux-variable is an auxiliary macro that transforms
;; the passed expression into a with-expression.
(defrules ~chain-aux-variable ()
((_ (() (fn . args)) body)
(syntax-error "The variable must be non-empty"))
((_ (var previous) body)
(with ((var previous)) body)))
;; ~chain-aux-diamond is an auxiliary macro that replaces the <> symbol
;; with the previous expressions. There must be only one <> diamond in a row
;; and it must be in the top-level expression.
(defrules ~chain-aux-diamond (<>)
((_ () acc)
acc)
((_ () acc previous)
(syntax-error "No diamond operator in expression"))
((_ (<> . more) (acc ...))
(syntax-error "More than one diamond operator in expression"))
((_ (<> . more) (acc ...) previous)
(~chain-aux-diamond more (acc ... previous)))
((_ (v . more) (acc ...) . previous) ; previous is not set after <> was replaced
(~chain-aux-diamond more (acc ... v) . previous)))
;; is converts a given value into a predicate testing for the presence of the
;; given value. Optionally a transforming procedure can prefix the value, which
;; can in this case also be a procedure. This allows to 'get' a value out of a
;; compound data structure before comparison (first map, then test).
;; For numbers, char and string specialized procedures are used automatically
;; if passed to the macro as value and not as variable. Alternatively, the
;; test: keyword can be used to supply a test, the default is equal?.
;;
;; Example:
;; (find (is cdr 5) '((a . 2) (b . 5) (c . 6)))
;; => (b . 5)
;;
;; (filter (is file-type 'regular) (directory-files))
;; => ("Documents" "Pictures" "Videos" "Music")
(defrules is ()
((_ proc n)
(stx-number? #'n)
(~is-helper proc number? = n))
((_ proc c)
(stx-char? #'c)
(lambda (v) (eqv? c (proc v))))
((_ proc s)
(stx-string? #'s)
(~is-helper proc string? string=? s))
((_ proc other)
(if (procedure? other)
(lambda (v) (other (proc v)))
(lambda (v) (equal? other (proc v)))))
((_ proc other test: test)
(if (procedure? other)
(lambda (v) (other (proc v)))
(lambda (v) (test other (proc v)))))
((_ n)
(stx-number? #'n)
(~is-helper number? = n))
((_ c)
(stx-char? #'c)
(lambda (v) (eqv? c v)))
((_ s)
(stx-string? #'s)
(~is-helper string? string=? s))
((_ v1)
(lambda (v2) (equal? v1 v2)))
((_ v1 test: test)
(lambda (v2) (test v1 v2))))
(defrules ~is-helper ()
((_ proc type-test value-test arg)
(chain <>
(proc <>)
(v (and (type-test v) (value-test arg v)))))
((_ type-test value-test arg)
(chain <>
(v (and (type-test v) (value-test arg v))))))