suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

map: fix contract check on given function with required keyword arguments

Browse Source 
Compared to v6.12, `map` & co. already provide better checking in
reporting an error when a keyword-requiring function is provided
with empty lists, but repair the error message to talk about
required keywords instead of just by-position arity.

Thanks to Philip McGrath for reporting the problem.

Related to #2099
This commit is contained in:
Matthew Flatt 2018-05-24 13:51:25 -06:00
parent 643d0d2cc4
commit b58938dc89
3 changed files with 43 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
pkgs/racket-test-core/tests/racket/basic.rktl
View File

@ -1431,11 +1431,17 @@
(for-each (lambda (i) (vector-set! v i (* i i)))
'(0 1 2 3 4))
v))
(test '(1 2 3) map (lambda (s #:c [c string->number]) (c s)) '("1" "2" "3"))
(define (map-tests map)
(let ([size? exn:application:mismatch?]
[non-list? type?])
(define ((name-and pred) exn)
(and (pred exn)
(regexp-match? (format "^~a:" name) (exn-message exn))))
(let ([size? (name-and exn:application:mismatch?)]
[non-list? (name-and type?)]
[keywords? (lambda (exn)
(and (exn:fail:contract? exn)
(regexp-match #rx"expects keyword arguments" (exn-message exn))))])
(err/rt-test (map (lambda (x y) (+ x y)) '(1 2) '1))
(err/rt-test (map (lambda (x y) (+ x y)) '2 '(1 2)))
(err/rt-test (map (lambda (x y) (+ x y)) '(1 2) '(1 2 3)) size?)
@ -1449,7 +1455,9 @@
(err/rt-test (map (lambda (x y) (+ x y))) exn:application:arity?)
(err/rt-test (map (lambda () 10) null) exn:application:mismatch?)
(err/rt-test (map (case-lambda [() 9] [(x y) 10]) '(1 2 3)) exn:application:mismatch?)
(err/rt-test (map (lambda (x) 10) '(1 2) '(3 4)) exn:application:mismatch?)))
(err/rt-test (map (lambda (x) 10) '(1 2) '(3 4)) exn:application:mismatch?)
(err/rt-test (map (lambda (x #:y y) 10) '(1 2)) keywords?)
(err/rt-test (map (lambda (x #:y y) 10) '()) keywords?)))
(map-tests map)
(map-tests for-each)
(map-tests andmap)

2
pkgs/racket-test-core/tests/racket/procs.rktl
View File

@ -145,7 +145,7 @@
null))])
(test a procedure-arity (car p))
(when (number? a)
(let ([rx (regexp (format " mismatch;.*(expected number(?!.*expected:)|expected: ~a)"
(let ([rx (regexp (format " mismatch;.*(expected number(?!.*expected:)|expected: ~a|required keywords:)"
(if (zero? a) "(0|no)" (if method? (sub1 a) a))))]
[bad-args (cons 'extra (for/list ([i (in-range a)]) 'a))])
(test #t regexp-match? rx

34
racket/collects/racket/private/map.rkt
View File

@ -5,6 +5,7 @@
(module map '#%kernel
(#%require "small-scheme.rkt" "define.rkt"
"performance-hint.rkt"
"kw.rkt"
'#%paramz
(for-syntax '#%kernel))
@ -193,10 +194,14 @@
"procedure" f))
(loop len (cdr ls) (add1 i))))))
(unless (procedure-arity-includes? f (length ls))
(define-values (required-keywords optional-keywords) (procedure-keywords f))
(apply raise-arguments-error who
(string-append "argument mismatch;\n"
" the given procedure's expected number of arguments does not match"
" the given number of lists")
(if (pair? required-keywords)
(string-append "argument mismatch;\n"
" the given procedure expects keyword arguments")
(string-append "argument mismatch;\n"
" the given procedure's expected number of arguments does not match"
" the given number of lists"))
"given procedure" (unquoted-printing-string
(or (let ([n (object-name f)])
(and (symbol? n)
@ -205,6 +210,8 @@
(append
(let ([a (procedure-arity f)])
(cond
[(pair? required-keywords)
null]
[(integer? a)
(list "expected" a)]
[(arity-at-least? a)
@ -212,7 +219,26 @@
(string-append "at least " (number->string (arity-at-least-value a)))))]
[else
null]))
(list "given" (length ls))
(cond
[(pair? required-keywords)
null]
[else
(list "given" (length ls))])
(cond
[(pair? required-keywords)
(list "required keywords"
(unquoted-printing-string
(apply string-append
(cdr
(let loop ([kws required-keywords])
(cond
[(null? kws) null]
[else (list* " "
(string-append "#:"
(keyword->string (car kws)))
(loop (cdr kws)))]))))))]
[else
null])
(let ([w (quotient (error-print-width) (length ls))])
(if (w . > . 10)
(list "argument lists..."