-
Notifications
You must be signed in to change notification settings - Fork 1
/
Copy pathformals.rkt
172 lines (157 loc) · 7.09 KB
/
formals.rkt
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
#lang racket/base
;;; Adapted from syntax/parse/lib/function-header
(require syntax/parse
racket/dict
racket/list
racket/syntax)
(provide keyword-argument
argument
splicing-arguments
arguments+rest
syntax->keyword)
;; We need to make sure that `no-value` is available at runtime,
;; if the surrounding module is required `for-syntax`.
;; But there is no `begin-for-template`, so we need a workaround.
(module no-value-mod racket/base
(provide no-value no-value?)
(define no-value (string->uninterned-symbol "no-value"))
(define (no-value? x)
(eq? x no-value)))
(require (for-template 'no-value-mod
racket/base))
;; This class ensures that the order of the arguments is preserved.
(define-splicing-syntax-class splicing-arguments
#:attributes (names kws defaults? binders call-args header)
(pattern (~seq arg:argument ...)
#:attr names #'(arg.name ...)
#:attr kws #'((~? arg.kw #f) ...) ; `#:! a` is `#:a`
#:attr defaults? (datum->syntax
#f
(map (λ (d) (if d #'#true #'#false))
(attribute arg.default))) ; (list-of boolean?)
;#'((~? arg.default #f) ...)
#:attr binders #'((~? arg.binder) ...)
#:attr header #'((~@ (~? arg.kw) (~? (arg.gen-name arg.default) arg.name)) ...)
#:attr call-args #'((~? (~@ arg.kw arg.name) arg.name) ...)
#:fail-when (check-duplicate-identifier (attribute arg.name))
"duplicate argument identifier"
#:fail-when (check-duplicates (attribute arg.kw)
(λ (x y)
(and x y (equal? (syntax-e x)
(syntax-e y)))))
"duplicate argument keyword"
#:fail-when (invalid-option-placement (attribute arg.kw)
(attribute arg.name)
(attribute arg.default))
"mandatory positional argument after optional positional argument"))
(define-syntax-class arguments+rest
#:attributes (names kws defaults? binders call-args header)
(pattern (~or* (args:splicing-arguments)
(args:splicing-arguments . rest-id:id))
#:attr names #'((~@ . args.names) (~? rest-id))
#:attr kws #'args.kws
#:attr defaults? (attribute args.defaults?)
#:attr binders #'args.binders
#:attr header (if (attribute rest-id)
#'((~@ . args.header) . rest-id)
#'args.header)
#:attr call-args #'args.call-args
#:fail-when (and (attribute rest-id)
(member #'rest-id (syntax->list #'args.names) bound-identifier=?)
#'rest-id)
"duplicate argument identifier"))
(define (syntax->keyword stx)
(string->keyword (format "~a" (syntax-e stx))))
(define-splicing-syntax-class keyword-argument
#:commit ; force greedy matching, no backtracking
#:attributes (name gen-name kw default binder)
(pattern (~seq #:! name:id)
#:attr gen-name #f
#:with kw2 (syntax->keyword #'name)
#:attr kw #'kw2
#:attr default #f
#:attr binder #f)
(pattern (~seq #:? name:id)
#:attr gen-name #'name ; no need to generate a temporary, but serves to say optional arg
#:with kw2 (syntax->keyword #'name)
#:attr kw #'kw2
#:attr default #'no-value
#:attr binder #f)
(pattern (~seq #:? [name:id given-default:expr])
#:with gen-name (generate-temporary)
#:with kw2 (syntax->keyword #'name)
;#:attr name #'name
#:attr default #'no-value
#:attr kw #'kw2
#:attr binder #'[name (if (eq? gen-name no-value) given-default gen-name)])
(pattern (~seq kw:keyword name:id)
#:attr gen-name #f
#:attr default #f
#:attr binder #f)
(pattern (~seq kw:keyword [name:id given-default:expr])
#:with gen-name (generate-temporary)
#:attr default #'no-value
#:attr binder #'[name (if (eq? gen-name no-value) given-default gen-name)]))
(define-splicing-syntax-class argument
#:commit ; force greedy matching, no backtracking
#:attributes (name gen-name kw default binder)
(pattern name:id
#:attr gen-name #f
#:attr kw #f
#:attr default #f
#:attr binder #f)
(pattern [name:id default:expr]
#:attr gen-name #'name ; no need to generate a temporary, but serves to say optional arg
#:attr kw #f
#:attr binder #f)
(pattern kw-arg:keyword-argument
#:attr name (attribute kw-arg.name)
#:attr gen-name (attribute kw-arg.gen-name)
#:attr default (attribute kw-arg.default)
#:attr kw (attribute kw-arg.kw)
#:attr binder (attribute kw-arg.binder)))
;; invalid-option-placement : (Listof Keyword) (Listof Id) (Listof Syntax/#f) -> Id/#f
;; Checks for mandatory argument after optional argument; if found, returns
;; identifier of mandatory argument.
;; Fix from original version: order does not matter in keyword arguments.
(define (invalid-option-placement kws names defaults)
;; find-mandatory : (Listof Keyword) (Listof Id) (Listof Syntax/#f) -> Id/#f
;; Finds first name w/o corresponding default.
(define (find-mandatory kws names defaults)
(for/first ([kw (in-list kws)]
[name (in-list names)]
[default (in-list defaults)]
#:when (and (not kw) (not default)))
name))
;; Skip through mandatory args until first optional found, then search
;; for another mandatory.
(let loop ([kws kws] [names names] [defaults defaults])
(cond [(or (null? names) (null? defaults))
#f]
[(or (car kws) ; keywords don't count
(eq? (car defaults) #f)) ;; mandatory
(loop (cdr kws) (cdr names) (cdr defaults))]
[else ;; found optional
(find-mandatory (cdr kws) (cdr names) (cdr defaults))])))
(module+ test
(require rackunit)
;; Backward compatibility with lambda for weird argument positions
(check-equal?
(syntax->datum
(syntax-parse #'(a #:b [b 1] c #:d d [e 2] #:f [f 3] [g 4] . rest)
[fmls:arguments+rest #'(fmls fmls.names)]))
'((a #:b (b 1) c #:d d (e 2) #:f (f 3) (g 4) . rest) (a b c d e f g rest)))
;; Default value let* binding
(check-match
(syntax-parse #'(#:? [x 3] #:y [y (+ x 3)] #:? [z (+ y 10)])
[fmls:arguments+rest
(syntax->datum
#'(lambda fmls.header
(let* fmls.binders
'xxx)))])
`(lambda (#:x (,x-gen no-value) #:y (,y-gen no-value) #:z (,z-gen no-value))
(let* ((x (if (eq? ,x-gen no-value) 3 ,x-gen))
(y (if (eq? ,y-gen no-value) (+ x 3) ,y-gen))
(z (if (eq? ,z-gen no-value) (+ y 10) ,z-gen)))
'xxx)))
)