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