forked from jeapostrophe/exp
-
Notifications
You must be signed in to change notification settings - Fork 0
/
keystruct.ss
39 lines (35 loc) · 1.36 KB
/
keystruct.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
#lang scheme
(require (for-syntax scheme/match
scheme/list
scheme/struct-info))
(define-for-syntax (fix-first l)
(if (first l)
l
(rest l)))
(define-syntax (struct-keyword-constructor stx)
(syntax-case stx ()
[(_ struct-id)
(unless (identifier? #'struct-id)
(raise-syntax-error 'struct-keyword-constructor "Not an identifier" #'struct-id))
(match
(syntax-local-value
#'struct-id
(lambda ()
(raise-syntax-error 'struct-keyword-constructor "Not bound syntax identifier" #'struct-id)))
[(and (? struct-info?)
(app extract-struct-info (list descriptor constructor predicate (list accessors-reversed ...) mutators super-type-info)))
(define accessors (fix-first (reverse accessors-reversed)))
(with-syntax
([formals
(for/fold ([l empty])
([a (in-list accessors-reversed)])
(if a
(list* (string->keyword (symbol->string (syntax-e a))) a l)
l))]
[(field ...) accessors])
(quasisyntax/loc stx
(lambda formals
(#,constructor field ...))))]
[else
(raise-syntax-error 'struct-keyword-constructor "Not bound to structure info" #'struct-id)])]))
(provide struct-keyword-constructor)