1#lang racket/base
2(require "blame.rkt"
3         "kwd-info-struct.rkt"
4         "list.rkt")
5
6(provide do-arity-checking
7
8         ;; for test suites
9         arity-as-string
10         raw-arity-as-string)
11
12(define (do-arity-checking blame val
13                           ->stct-doms
14                           ->stct-rest
15                           ->stct-min-arity
16                           ->stct-kwd-infos
17                           method?)
18  (define proc/meth (if method? "a method" "a procedure"))
19  (let/ec k
20    (unless (procedure? val)
21      (k
22       (λ (neg-party)
23         (raise-blame-error blame #:missing-party neg-party val
24                            `(expected: ,proc/meth
25                                        given: "~e")
26                            val))))
27     (define-values (actual-mandatory-kwds actual-optional-kwds) (procedure-keywords val))
28     (define arity (if (list? (procedure-arity val))
29                       (procedure-arity val)
30                       (list (procedure-arity val))))
31
32     (define exra-required-args (if (ellipsis-rest-arg-ctc? ->stct-rest)
33                                    (length (*list-ctc-suffix ->stct-rest))
34                                    0))
35
36     ;; the function must be ok for *all* the arities the contract says are ok
37     (for/and ([base-number-of-non-keyword-args (in-range ->stct-min-arity (add1 (length ->stct-doms)))])
38       (define expected-number-of-non-keyword-args (+ base-number-of-non-keyword-args exra-required-args))
39       (define matching-arity?
40         (and (for/or ([a (in-list arity)])
41                (or (and (equal? expected-number-of-non-keyword-args a))
42                    (and (arity-at-least? a)
43                         (>= expected-number-of-non-keyword-args (arity-at-least-value a)))))
44              (if ->stct-rest
45                  (let ([lst (car (reverse arity))])
46                    (and (arity-at-least? lst)
47                         (<= (arity-at-least-value lst) (+ exra-required-args ->stct-min-arity))))
48                  #t)))
49       (unless matching-arity?
50         (k
51          (λ (neg-party)
52            (define expected-number-of-non-keyword-args*
53              ((if method? sub1 values) expected-number-of-non-keyword-args))
54            (raise-blame-error blame #:missing-party neg-party val
55                               `(expected:
56                                 ,(string-append proc/meth
57                                                 " that accepts ~a non-keyword argument~a~a")
58                                 given: "~e"
59                                 "\n  ~a")
60                               expected-number-of-non-keyword-args*
61                               (if (= expected-number-of-non-keyword-args* 1) "" "s")
62                               (if ->stct-rest
63                                   " and arbitrarily many more"
64                                   "")
65                               val
66                               (arity-as-string val))))))
67
68    (define (should-have-supplied kwd)
69      (k
70       (λ (neg-party)
71         (raise-blame-error blame #:missing-party neg-party val
72                            `(expected:
73                              ,(string-append proc/meth " that accepts the ~a keyword argument")
74                              given: "~e"
75                              "\n  ~a")
76                            kwd
77                            val
78                            (arity-as-string val method?)))))
79
80    (define (should-not-have-supplied kwd)
81      (k
82       (λ (neg-party)
83         (raise-blame-error blame #:missing-party neg-party val
84                            `(expected:
85                              ,(string-append proc/meth " that does not require the ~a keyword argument")
86                              given: "~e"
87                              "\n  ~a")
88                            kwd
89                            val
90                            (arity-as-string val method?)))))
91
92    (when actual-optional-kwds ;; when all kwds are okay, no checking required
93      (let loop ([mandatory-kwds actual-mandatory-kwds]
94                 [all-kwds actual-optional-kwds]
95                 [kwd-infos ->stct-kwd-infos])
96        (cond
97          [(null? kwd-infos)
98           (unless (null? mandatory-kwds)
99             (should-not-have-supplied (car mandatory-kwds)))]
100          [else
101           (define kwd-info (car kwd-infos))
102           (define-values (mandatory? kwd new-mandatory-kwds new-all-kwds)
103             (cond
104               [(null? all-kwds)
105                (should-have-supplied (kwd-info-kwd kwd-info))]
106               [else
107                (define mandatory?
108                  (and (pair? mandatory-kwds)
109                       (equal? (car mandatory-kwds) (car all-kwds))))
110                (values mandatory?
111                        (car all-kwds)
112                        (if mandatory?
113                            (cdr mandatory-kwds)
114                            mandatory-kwds)
115                        (cdr all-kwds))]))
116           (cond
117             [(equal? kwd (kwd-info-kwd kwd-info))
118              (when (and (not (kwd-info-mandatory? kwd-info))
119                         mandatory?)
120                (k
121                 (λ (neg-party)
122                   (raise-blame-error
123                    blame #:missing-party neg-party val
124                    `(expected:
125                      ,(string-append proc/meth " that optionally accepts the keyword ~a (this one is mandatory)")
126                      given: "~e"
127                      "\n  ~a")
128                    val
129                    kwd
130                    (arity-as-string val method?)))))
131              (loop new-mandatory-kwds new-all-kwds (cdr kwd-infos))]
132             [(keyword<? kwd (kwd-info-kwd kwd-info))
133              (when mandatory?
134                (should-not-have-supplied kwd))
135              (loop new-mandatory-kwds new-all-kwds kwd-infos)]
136             [else
137              (loop new-mandatory-kwds new-all-kwds kwd-infos)])])))
138
139    #f))
140
141
142(define (arity-as-string v [method? #f])
143  (define prefix (if (object-name v)
144                     (format "~a accepts: " (object-name v))
145                     (format "accepts: ")))
146  (string-append prefix (raw-arity-as-string v method?)))
147
148(define (raw-arity-as-string v [method? #f])
149  (define ar (procedure-arity v))
150  (define adjust (if method? sub1 values))
151  (define (plural n) (if (= n 1) "" "s"))
152  (define-values (man-kwds all-kwds) (procedure-keywords v))
153  (define opt-kwds (if all-kwds (remove* man-kwds all-kwds) #f))
154  (define normal-str (if (null? all-kwds) "" "normal "))
155  (define normal-args
156    (cond
157      [(null? ar) "no arguments"]
158      [(number? ar)
159       (define ar* (adjust ar))
160       (format "~a ~aargument~a" ar* normal-str (plural ar*))]
161      [(arity-at-least? ar) (format "~a or arbitrarily many more ~aarguments"
162                                    (adjust (arity-at-least-value ar))
163                                    normal-str)]
164      [else
165       (define comma
166         (if (and (= (length ar) 2)
167                  (not (arity-at-least? (list-ref ar 1))))
168             ""
169             ","))
170       (apply
171        string-append
172        (let loop ([ar ar])
173          (cond
174            [(null? (cdr ar))
175             (define v (car ar))
176             (cond
177               [(arity-at-least? v)
178                (list
179                 (format "~a, or arbitrarily many more ~aarguments"
180                         (arity-at-least-value (adjust v))
181                         normal-str))]
182               [else
183                (list (format "or ~a ~aarguments" (adjust v) normal-str))])]
184            [else
185             (cons (format "~a~a " (adjust (car ar)) comma)
186                   (loop (cdr ar)))])))]))
187  (cond
188    [(and (null? man-kwds) (null? opt-kwds))
189     normal-args]
190    [(and (null? man-kwds) (not opt-kwds))
191     (string-append normal-args " and optionally any keyword")]
192    [(and (null? man-kwds) (pair? opt-kwds))
193     (string-append normal-args
194                    " and the optional keyword"
195                    (plural (length opt-kwds))
196                    " "
197                    (kwd-list-as-string opt-kwds))]
198    [(and (pair? man-kwds) (not opt-kwds))
199     (string-append normal-args
200                    ", the mandatory keyword"
201                    (plural (length man-kwds))
202                    " "
203                    (kwd-list-as-string man-kwds)
204                    ", and optionally any keyword")]
205    [(and (pair? man-kwds) (null? opt-kwds))
206     (string-append normal-args
207                    " and the mandatory keyword"
208                    (plural (length man-kwds))
209                    " "
210                    (kwd-list-as-string man-kwds))]
211    [(and (pair? man-kwds) (pair? opt-kwds))
212     (string-append normal-args
213                    ", the mandatory keyword"
214                    (plural (length man-kwds))
215                    " "
216                    (kwd-list-as-string man-kwds)
217                    ", and the optional keyword"
218                    (plural (length opt-kwds))
219                    " "
220                    (kwd-list-as-string opt-kwds))]))
221
222(define (kwd-list-as-string kwds)
223  (cond
224    [(null? (cdr kwds))
225     (format "~a" (list-ref kwds 0))]
226    [(null? (cddr kwds))
227     (format "~a and ~a" (list-ref kwds 0) (list-ref kwds 1))]
228    [else
229     (apply
230      string-append
231      (let loop ([kwds kwds])
232        (cond
233          [(null? (cdr kwds))
234           (list (format "and ~a" (car kwds)))]
235          [else
236           (cons (format "~a, " (car kwds))
237                 (loop (cdr kwds)))])))]))
238
239