From 88b165314ad2e89c9c2b42e3dbc0b0b3ac333b26 Mon Sep 17 00:00:00 2001 From: Ben Greenman Date: Tue, 4 Dec 2018 16:04:01 -0500 Subject: [PATCH] fix pair accessor error messages (#2413) Change the error message for some functions like `caddr` so they describe pair structures that they expect --- .../racket/pair-accessor-error-message.rkt | 88 +++++++++++++++++++ racket/src/racket/src/list.c | 32 +++---- 2 files changed, 104 insertions(+), 16 deletions(-) create mode 100644 pkgs/racket-test-extra/tests/racket/pair-accessor-error-message.rkt diff --git a/pkgs/racket-test-extra/tests/racket/pair-accessor-error-message.rkt b/pkgs/racket-test-extra/tests/racket/pair-accessor-error-message.rkt new file mode 100644 index 0000000000..e7829097a1 --- /dev/null +++ b/pkgs/racket-test-extra/tests/racket/pair-accessor-error-message.rkt @@ -0,0 +1,88 @@ +#lang racket/base + +;; Check that the contract error messages for the `c*r` accessors +;; describe a value that the accessor accepts +;; +;; e.g. `cadr` accepts a `(cons/c any/c pair?)`, so the error message should +;; not ask for a `(cons/c pair? any/c)` + +(require racket/contract racket/port racket/match) + +(module+ test + (require rackunit) + + (for* ((num-letters (in-range 1 5)) + (accessor-num (in-range 0 (expt 2 num-letters)))) + (define ad* (fixnum->accessor-char* accessor-num num-letters)) + (define accessor (make-c*r ad*)) + (define sexp (accessor->expected-sexp accessor)) + (define val (sexp->value sexp)) + (define ctc (sexp->contract sexp)) + (if (contract-first-order-passes? ctc val) + (check-not-exn (lambda () (accessor val)) + (format "~a claims it expects a '~a but fails on ~a" + accessor sexp val)) + (error 'bad-value "(~a ~a) = #false" ctc val)))) + +;; ----------------------------------------------------------------------------- +;; --- helper functions + +(define (string->value str) + (with-input-from-string str read)) + +(define (accessor->expected-sexp f) + (define evil-value 0) + (define err-str + (with-handlers ((exn:fail:contract? exn-message)) + (f evil-value) + (raise-user-error 'accessor->expected-sexp "application failed to raise contract error (~a ~a)" f evil-value))) + (string->value (cadr (regexp-match "expected: (.*)$" err-str)))) + +(module+ test + (check-equal? (accessor->expected-sexp car) 'pair?) + (check-equal? (accessor->expected-sexp caddr) '(cons/c any/c (cons/c any/c pair?)))) + +(define (sexp->value sexp) + (match sexp + ['any/c 'any/c] + ['pair? (cons 'any/c 'any/c)] + [(list 'cons/c a b) (cons (sexp->value a) (sexp->value b))])) + +(module+ test + (check-equal? (sexp->value 'any/c) 'any/c) + (check-equal? (sexp->value 'pair?) (cons 'any/c 'any/c)) + (check-equal? (sexp->value '(cons/c any/c pair?)) (cons 'any/c (cons 'any/c 'any/c)))) + +(define (sexp->contract sexp) + (match sexp + ['any/c any/c] + ['pair? pair?] + [(list 'cons/c a b) (cons/c (sexp->contract a) (sexp->contract b))])) + +(module+ test + (check-eq? (sexp->contract 'any/c) any/c) + (check-eq? (sexp->contract 'pair?) pair?) + (check-pred contract? (sexp->contract '(cons/c any/c pair?)))) + +(define (fixnum->accessor-char* n k) + (unless (fixnum? n) + (raise-argument-error 'fixnum->accessor-char* "fixnum?" n)) + (reverse + (for/list ((i (in-range k))) + (if (bitwise-bit-set? n i) #\a #\d)))) + +(module+ test + (check-equal? (fixnum->accessor-char* 4 3) '(#\a #\d #\d)) + (check-equal? (fixnum->accessor-char* 1 1) '(#\a)) + (check-equal? (fixnum->accessor-char* 10 3) '(#\d #\a #\d))) + +(define make-c*r + (let ((ns (make-base-namespace))) + (lambda (cr*) + (unless (< 0 (length cr*) 5) + (raise-argument-error 'make-c*r "1 to 4 characters" cr*)) + (eval (string->symbol (format "c~ar" (list->string cr*))) ns)))) + +(module+ test + (check-eq? (make-c*r '(#\a #\a #\a)) caaar)) + diff --git a/racket/src/racket/src/list.c b/racket/src/racket/src/list.c index ea5cae9c12..4e83bea979 100644 --- a/racket/src/racket/src/list.c +++ b/racket/src/racket/src/list.c @@ -1790,13 +1790,13 @@ name ## _prim (int argc, Scheme_Object *argv[]) \ LISTFUNC3(cdddr, SCHEME_CDR, SCHEME_CDR, SCHEME_CDR, "(cons/c any/c (cons/c any/c pair?))") -LISTFUNC3(caddr, SCHEME_CAR, SCHEME_CDR, SCHEME_CDR, "(cons/c (cons/c any/c pair?) any/c)") +LISTFUNC3(caddr, SCHEME_CAR, SCHEME_CDR, SCHEME_CDR, "(cons/c any/c (cons/c any/c pair?))") LISTFUNC3(cdadr, SCHEME_CDR, SCHEME_CAR, SCHEME_CDR, "(cons/c any/c (cons/c pair? any/c))") -LISTFUNC3(cddar, SCHEME_CDR, SCHEME_CDR, SCHEME_CAR, "(cons/c any/c (cons/c any/c pair?))") +LISTFUNC3(cddar, SCHEME_CDR, SCHEME_CDR, SCHEME_CAR, "(cons/c (cons/c any/c pair?) any/c)") -LISTFUNC3(cdaar, SCHEME_CDR, SCHEME_CAR, SCHEME_CAR, "(cons/c any/c (cons/c pair? any/c))") +LISTFUNC3(cdaar, SCHEME_CDR, SCHEME_CAR, SCHEME_CAR, "(cons/c (cons/c pair? any/c) any/c)") LISTFUNC3(cadar, SCHEME_CAR, SCHEME_CDR, SCHEME_CAR, "(cons/c (cons/c any/c pair?) any/c)") -LISTFUNC3(caadr, SCHEME_CAR, SCHEME_CAR, SCHEME_CDR, "(cons/c (cons/c pair? any/c) any/c)") +LISTFUNC3(caadr, SCHEME_CAR, SCHEME_CAR, SCHEME_CDR, "(cons/c any/c (cons/c pair? any/c))") LISTFUNC3(caaar, SCHEME_CAR, SCHEME_CAR, SCHEME_CAR, "(cons/c (cons/c pair? any/c) any/c)") @@ -1815,22 +1815,22 @@ name ## _prim (int argc, Scheme_Object *argv[]) \ LISTFUNC4(cddddr, SCHEME_CDR, SCHEME_CDR, SCHEME_CDR, SCHEME_CDR, "(cons/c any/c (cons/c any/c (cons/c any/c pair?)))") -LISTFUNC4(cadddr, SCHEME_CAR, SCHEME_CDR, SCHEME_CDR, SCHEME_CDR, "(cons/c (cons/c any/c (cons/c any/c pair?)) any/c)") -LISTFUNC4(cdaddr, SCHEME_CDR, SCHEME_CAR, SCHEME_CDR, SCHEME_CDR, "(cons/c any/c (cons/c (cons/c any/c pair?) any/c))") -LISTFUNC4(cddadr, SCHEME_CDR, SCHEME_CDR, SCHEME_CAR, SCHEME_CDR, "(cons/c any/c (cons/c any/c (cons/c pair? any/c)))") -LISTFUNC4(cdddar, SCHEME_CDR, SCHEME_CDR, SCHEME_CDR, SCHEME_CAR, "(cons/c any/c (cons/c any/c (cons/c any/c pair?)))") +LISTFUNC4(cadddr, SCHEME_CAR, SCHEME_CDR, SCHEME_CDR, SCHEME_CDR, "(cons/c any/c (cons/c any/c (cons/c any/c pair?)))") +LISTFUNC4(cdaddr, SCHEME_CDR, SCHEME_CAR, SCHEME_CDR, SCHEME_CDR, "(cons/c any/c (cons/c any/c (cons/c pair? any/c)))") +LISTFUNC4(cddadr, SCHEME_CDR, SCHEME_CDR, SCHEME_CAR, SCHEME_CDR, "(cons/c any/c (cons/c (cons/c any/c pair?) any/c))") +LISTFUNC4(cdddar, SCHEME_CDR, SCHEME_CDR, SCHEME_CDR, SCHEME_CAR, "(cons/c (cons/c any/c (cons/c any/c pair?)) any/c)") -LISTFUNC4(caaddr, SCHEME_CAR, SCHEME_CAR, SCHEME_CDR, SCHEME_CDR, "(cons/c (cons/c (cons/c any/c pair?) any/c) any/c)") -LISTFUNC4(cadadr, SCHEME_CAR, SCHEME_CDR, SCHEME_CAR, SCHEME_CDR, "(cons/c (cons/c any/c (cons/c pair? any/c)) any/c)") +LISTFUNC4(caaddr, SCHEME_CAR, SCHEME_CAR, SCHEME_CDR, SCHEME_CDR, "(cons/c any/c (cons/c any/c (cons/c pair? any/c)))") +LISTFUNC4(cadadr, SCHEME_CAR, SCHEME_CDR, SCHEME_CAR, SCHEME_CDR, "(cons/c any/c (cons/c (cons/c any/c pair?) any/c))") LISTFUNC4(caddar, SCHEME_CAR, SCHEME_CDR, SCHEME_CDR, SCHEME_CAR, "(cons/c (cons/c any/c (cons/c any/c pair?)) any/c)") LISTFUNC4(cdaadr, SCHEME_CDR, SCHEME_CAR, SCHEME_CAR, SCHEME_CDR, "(cons/c any/c (cons/c (cons/c pair? any/c) any/c))") -LISTFUNC4(cdadar, SCHEME_CDR, SCHEME_CAR, SCHEME_CDR, SCHEME_CAR, "(cons/c any/c (cons/c (cons/c any/c pair?) any/c))") -LISTFUNC4(cddaar, SCHEME_CDR, SCHEME_CDR, SCHEME_CAR, SCHEME_CAR, "(cons/c any/c (cons/c any/c (cons/c pair? any/c)))") +LISTFUNC4(cdadar, SCHEME_CDR, SCHEME_CAR, SCHEME_CDR, SCHEME_CAR, "(cons/c (cons/c any/c (cons/c pair? any/c)) any/c)") +LISTFUNC4(cddaar, SCHEME_CDR, SCHEME_CDR, SCHEME_CAR, SCHEME_CAR, "(cons/c (cons/c (cons/c any/c pair?) any/c) any/c)") -LISTFUNC4(cdaaar, SCHEME_CDR, SCHEME_CAR, SCHEME_CAR, SCHEME_CAR, "(cons/c any/c (cons/c (cons/c pair? any/c) any/c))") -LISTFUNC4(cadaar, SCHEME_CAR, SCHEME_CDR, SCHEME_CAR, SCHEME_CAR, "(cons/c (cons/c any/c (cons/c pair? any/c)) any/c)") -LISTFUNC4(caadar, SCHEME_CAR, SCHEME_CAR, SCHEME_CDR, SCHEME_CAR, "(cons/c (cons/c (cons/c any/c pair?) any/c) any/c)") -LISTFUNC4(caaadr, SCHEME_CAR, SCHEME_CAR, SCHEME_CAR, SCHEME_CDR, "(cons/c (cons/c (cons/c pair? any/c) any/c) any/c)") +LISTFUNC4(cdaaar, SCHEME_CDR, SCHEME_CAR, SCHEME_CAR, SCHEME_CAR, "(cons/c (cons/c (cons/c pair? any/c) any/c) any/c)") +LISTFUNC4(cadaar, SCHEME_CAR, SCHEME_CDR, SCHEME_CAR, SCHEME_CAR, "(cons/c (cons/c (cons/c any/c pair?) any/c) any/c)") +LISTFUNC4(caadar, SCHEME_CAR, SCHEME_CAR, SCHEME_CDR, SCHEME_CAR, "(cons/c (cons/c any/c (cons/c pair? any/c)) any/c)") +LISTFUNC4(caaadr, SCHEME_CAR, SCHEME_CAR, SCHEME_CAR, SCHEME_CDR, "(cons/c any/c (cons/c (cons/c pair? any/c) any/c))") LISTFUNC4(caaaar, SCHEME_CAR, SCHEME_CAR, SCHEME_CAR, SCHEME_CAR, "(cons/c (cons/c (cons/c pair? any/c) any/c) any/c)")