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
|
#lang racket/base
(provide (struct-out arguments)
(struct-out arity)
no-arguments
no-arity
to-procedure-arity
arguments->arity
check-arity
check-curry
join-sep
kw->string
diff/sorted/eq)
#|
An Arguments is
#s(arguments (listof stx) (listof keyword) (listof stx))
|#
(define-struct arguments (pargs kws kwargs) #:prefab)
(define no-arguments (arguments null null null))
#|
An Arity is
#s(arity nat nat/+inf.0 (listof keyword) (listof keyword))
|#
(define-struct arity (minpos maxpos minkws maxkws)
#:prefab)
(define no-arity (arity 0 0 null null))
;; ----
(define (to-procedure-arity minpos maxpos)
(cond [(= minpos maxpos) minpos]
[(= maxpos +inf.0) (arity-at-least minpos)]
[else (for/list ([i (in-range minpos (add1 maxpos))]) i)]))
(define (arguments->arity argu)
(let ([pos (length (arguments-pargs argu))]
[kws (arguments-kws argu)])
(arity pos pos kws kws)))
(define (check-arity arity pos-count keywords0 proc)
(define keywords (sort keywords0 keyword<?))
(define minpos (arity-minpos arity))
(define maxpos (arity-maxpos arity))
(define minkws (arity-minkws arity))
(define maxkws (arity-maxkws arity))
(unless (<= minpos pos-count maxpos)
(proc (format "syntax class arity mismatch~a\n expected: ~a\n given: ~a"
";\n the expected number of arguments does not match the given number"
(gen-expected-msg minpos maxpos minkws maxkws)
(gen-given-msg pos-count keywords))))
(let ([missing-kws (diff/sorted/eq minkws keywords)])
(unless (null? missing-kws)
(proc (format "syntax class required keyword argument~a not supplied\n required: ~a"
(s-if-plural missing-kws)
(join-sep (map kw->string missing-kws) "," "and")))))
(let ([extra-kws (diff/sorted/eq keywords maxkws)])
(unless (null? extra-kws)
(proc (format "syntax class does not expect given keyword argument~a\n given: ~a"
(s-if-plural extra-kws)
(join-sep (map kw->string extra-kws) "," "and"))))))
(define (gen-expected-msg minpos maxpos minkws maxkws)
(define pos-part
(cond [(= minpos maxpos) (format "~s" minpos)]
[(eqv? maxpos +inf.0) (format "at least ~s" minpos)]
[else (format "between ~s and ~s" minpos maxpos)]))
(define kws-part
(cond [(pair? minkws)
(format " plus keyword argument~a ~a"
(s-if-plural minkws)
(join-sep (map kw->string minkws) "," "and"))]
[else ""]))
(define optkws (diff/sorted/eq maxkws minkws))
(define optkws-part
(cond [(pair? optkws)
(format " plus optional keyword argument~a ~a"
(s-if-plural optkws)
(join-sep (map kw->string minkws) "," "and"))]
[else ""]))
(string-append pos-part kws-part optkws-part))
(define (gen-given-msg pos-count kws)
(define kws-part
(cond [(pair? kws)
(format " plus keyword argument~a ~a"
(s-if-plural kws)
(join-sep (map kw->string kws) "," "and"))]
[else ""]))
(format "~s~a" pos-count kws-part))
;; ----
(define (check-curry arity pos-count keywords proc)
(let ([maxpos (arity-maxpos arity)]
[maxkws (arity-maxkws arity)])
(when (> pos-count maxpos)
(proc (format "too many arguments\n expected: at most ~s\n given: ~s"
maxpos pos-count)))
(let ([extrakws (diff/sorted/eq keywords maxkws)])
(when (pair? extrakws)
(proc (format "syntax class does not expect given keyword arguments\n given keywords: ~a"
(join-sep (map kw->string extrakws) "," "and")))))))
;; ----
(define (kw->string kw) (format "~a" kw))
(define (diff/sorted/eq xs ys)
(if (pair? xs)
(let ([ys* (memq (car xs) ys)])
(if ys*
(diff/sorted/eq (cdr xs) (cdr ys*))
(cons (car xs) (diff/sorted/eq (cdr xs) ys))))
null))
(define (join-sep items sep0 ult0 [prefix ""])
(define sep (string-append sep0 " "))
(define ult (string-append ult0 " "))
(define (loop items)
(cond [(null? items)
null]
[(null? (cdr items))
(list sep ult (car items))]
[else
(list* sep (car items) (loop (cdr items)))]))
(case (length items)
[(0) #f]
[(1) (string-append prefix (car items))]
[(2) (format "~a~a ~a~a" prefix (car items) ult (cadr items))]
[else (let ([strings (list* (car items) (loop (cdr items)))])
(apply string-append prefix strings))]))
(define (s-if-plural xs) (if (= (length xs) 1) "" "s"))
|
