compute generic method default error msg in define-generic-method
- fixes generic test failures due to computing this info
This commit is contained in:
Stephen Chang
parent
56cf724d12
commit
dcf73f6bca
|
|
@ -64,7 +64,7 @@
|
|||
(error "computation did not terminate")))))
|
||||
|
||||
;; pull-request #821, report correct position of contract violation
|
||||
(check-exn #rx"meth:.*1st"
|
||||
(check-exn #rx"meth:.*AA.*1st"
|
||||
(lambda () (convert-compile-time-error
|
||||
(let ()
|
||||
(define-generics AA [meth AA b c])
|
||||
|
|
|
|||
|
|
@ -65,93 +65,6 @@
|
|||
(define defaults-by-type (map generate-methods default-preds))
|
||||
(define defaults-by-method (transpose-methods defaults-by-type))
|
||||
|
||||
(define/with-syntax ((req req-kw opt opt-kw rest) ...)
|
||||
(stx-map
|
||||
(λ (sg) (call-with-values (lambda () (parse-method-signature sg)) list))
|
||||
#'(method-signature ...)))
|
||||
;; (0-based) position of the "self" argument, for error reporting purposes
|
||||
(define/with-syntax (self-i ...)
|
||||
(stx-map
|
||||
(λ (req-ids)
|
||||
(for/first ([(id i) (in-indexed (syntax->list req-ids))]
|
||||
#:when (free-identifier=? id #'self-name))
|
||||
i))
|
||||
#'(req ...)))
|
||||
|
||||
;; interleaves two stx lists
|
||||
(define (stx-merge stx)
|
||||
(define stx-lst1 (syntax->list (stx-car stx)))
|
||||
(define stx-lst2 (syntax->list (car (stx-cdr stx))))
|
||||
(apply append (map list stx-lst1 stx-lst2)))
|
||||
; removes the lst element at (0-based) index pos
|
||||
(define (remove-at lst pos)
|
||||
(let loop ([i 0] [lst lst])
|
||||
(cond [(null? lst) '()]
|
||||
[else (if (= i pos)
|
||||
(cdr lst)
|
||||
(cons (car lst) (loop (add1 i) (cdr lst))))])))
|
||||
(define (stx-drop-last stx)
|
||||
(reverse (cdr (reverse (syntax->list stx)))))
|
||||
|
||||
(define/with-syntax ((req-name ...) ...) #'(req ...))
|
||||
(define/with-syntax (((reqkw-key reqkw-val) ...) ...) #'(req-kw ...))
|
||||
(define/with-syntax ((opt-name ...) ...) #'(opt ...))
|
||||
(define/with-syntax (((optkw-key optkw-val) ...) ...) #'(opt-kw ...))
|
||||
(define/with-syntax (arg-labels/restargs ...)
|
||||
#'(((symbol->string 'req-name) ...
|
||||
(string-append (symbol->string 'opt-name) " (optional)") ...
|
||||
(string-append "#:" (keyword->string 'reqkw-key)) ...
|
||||
(string-append "#:" (keyword->string 'optkw-key) " (optional)") ...
|
||||
"rest args") ...))
|
||||
(define/with-syntax (arg-labels ...) ; drop restargs if none
|
||||
(stx-map
|
||||
(λ (labels rst)
|
||||
(if (syntax->datum rst) labels (stx-drop-last labels)))
|
||||
#'(arg-labels/restargs ...) #'(rest ...)))
|
||||
(define/with-syntax (arg-vals/restargs ...)
|
||||
#`((req-name ...
|
||||
opt-name ...
|
||||
reqkw-val ...
|
||||
optkw-val ...
|
||||
rest) ...))
|
||||
(define/with-syntax (arg-vals ...) ; drop restargs if none
|
||||
(stx-map
|
||||
(λ (args rst)
|
||||
(if (syntax->datum rst) args (stx-drop-last args)))
|
||||
#'(arg-vals/restargs ...) #'(rest ...)))
|
||||
(define/with-syntax (bad-arg-label ...) ; only the bad arg name
|
||||
(stx-map
|
||||
(λ (args i) (list-ref (stx->list args) (syntax->datum i)))
|
||||
#'(arg-labels ...) #'(self-i ...)))
|
||||
(define/with-syntax (bad-arg ...) ; only the bad arg
|
||||
(stx-map
|
||||
(λ (args i) (list-ref (stx->list args) (syntax->datum i)))
|
||||
#'(arg-vals ...) #'(self-i ...)))
|
||||
(define/with-syntax (other-arg-labels ...) ; other arg labels
|
||||
(stx-map
|
||||
(λ (args i) (remove-at (stx->list args) (syntax->datum i)))
|
||||
#'(arg-labels ...) #'(self-i ...)))
|
||||
(define/with-syntax (other-args ...) ; other args
|
||||
(stx-map
|
||||
(λ (args i) (remove-at (stx->list args) (syntax->datum i)))
|
||||
#'(arg-vals ...) #'(self-i ...)))
|
||||
(define/with-syntax ((other-labels+args ...) ...) ; other args interleaved
|
||||
(stx-map stx-merge #'((other-arg-labels other-args) ...)))
|
||||
(define/with-syntax (err-fmt-str ...)
|
||||
(stx-map
|
||||
(λ (labels)
|
||||
(if (null? (syntax->list labels))
|
||||
(string-append "contract violation:\n"
|
||||
"expected: ~a\n"
|
||||
"given: ~v\n"
|
||||
"argument position: ~a")
|
||||
(string-append "contract violation:\n"
|
||||
"expected: ~a\n"
|
||||
"given: ~v\n"
|
||||
"argument position: ~a\n"
|
||||
"other arguments...:")))
|
||||
#'(other-arg-labels ...)))
|
||||
|
||||
(define/with-syntax size n)
|
||||
(define/with-syntax [method-index ...] method-indices)
|
||||
(define/with-syntax contract-str
|
||||
|
|
@ -265,20 +178,6 @@
|
|||
[else (raise-argument-error 'supported-name
|
||||
'contract-str
|
||||
self-name)]))
|
||||
;; Converts 0-based index to an ordinal string
|
||||
;; 0 => 1st
|
||||
;; 1 => 2nd
|
||||
(define (pos->ord n)
|
||||
(define n/1base (add1 n))
|
||||
(string-append
|
||||
(number->string n/1base)
|
||||
(case n/1base
|
||||
[(11 12 13) "th"]
|
||||
[else (case (remainder n/1base 10)
|
||||
[(1) "st"]
|
||||
[(2) "nd"]
|
||||
[(3) "rd"]
|
||||
[else "th"])])))
|
||||
|
||||
(define-generic-method
|
||||
method-name
|
||||
|
|
@ -290,12 +189,7 @@
|
|||
[(prop:pred self-name)
|
||||
(vector-ref (accessor-name self-name) 'method-index)]
|
||||
[(default-disp-name self-name) default-by-method]
|
||||
...
|
||||
[else
|
||||
(raise-arguments-error
|
||||
'method-name
|
||||
(format err-fmt-str 'contract-str bad-arg (pos->ord self-i))
|
||||
other-labels+args ...)])
|
||||
...)
|
||||
fallback)
|
||||
original)
|
||||
...
|
||||
|
|
@ -486,6 +380,22 @@
|
|||
(define default-arg
|
||||
(gensym 'default-arg))
|
||||
|
||||
|
||||
;; Converts 0-based index to an ordinal string
|
||||
;; 0 => 1st
|
||||
;; 1 => 2nd
|
||||
(define (pos->ord n)
|
||||
(define n/1base (add1 n))
|
||||
(string-append
|
||||
(number->string n/1base)
|
||||
(case n/1base
|
||||
[(11 12 13) "th"]
|
||||
[else (case (remainder n/1base 10)
|
||||
[(1) "st"]
|
||||
[(2) "nd"]
|
||||
[(3) "rd"]
|
||||
[else "th"])])))
|
||||
|
||||
(define-syntax (define-generic-method stx)
|
||||
(syntax-case stx ()
|
||||
[(_ method-name
|
||||
|
|
@ -502,8 +412,71 @@
|
|||
#'proc-name
|
||||
#'self-name
|
||||
#'method-signature))
|
||||
|
||||
; compute extra error info for default method
|
||||
(define-values (req req-kw opt opt-kw rest)
|
||||
(parse-method-signature #'method-signature))
|
||||
|
||||
;; (0-based) pos of the "self" argument, for error reporting purposes;
|
||||
;; method signature already checked so self-name is in signature
|
||||
(define self-i
|
||||
(for/first
|
||||
([(id i) (in-indexed req)] #:when (free-identifier=? id #'self-name))
|
||||
i))
|
||||
|
||||
; removes the lst element at (0-based) index pos
|
||||
(define (remove-at lst pos)
|
||||
(let loop ([i 0] [lst lst])
|
||||
(cond [(null? lst) '()]
|
||||
[else (if (= i pos)
|
||||
(cdr lst)
|
||||
(cons (car lst) (loop (add1 i) (cdr lst))))])))
|
||||
(define (stx-drop-last stx)
|
||||
(reverse (cdr (reverse (syntax->list stx)))))
|
||||
|
||||
(define/with-syntax (req-name ...) req)
|
||||
(define/with-syntax ((reqkw-key reqkw-val) ...) req-kw)
|
||||
(define/with-syntax (opt-name ...) opt)
|
||||
(define/with-syntax ((optkw-key optkw-val) ...) opt-kw)
|
||||
(define/with-syntax arg-labels/restargs ; labels for args
|
||||
#'((symbol->string 'req-name) ...
|
||||
(string-append (symbol->string 'opt-name) " (optional)") ...
|
||||
(string-append "#:" (keyword->string 'reqkw-key)) ...
|
||||
(string-append "#:" (keyword->string 'optkw-key) " (optional)") ...
|
||||
"rest args"))
|
||||
(define/with-syntax arg-labels ; drop restargs if none
|
||||
(if rest #'arg-labels/restargs (stx-drop-last #'arg-labels/restargs)))
|
||||
(define/with-syntax arg-vals/restargs ; arg values
|
||||
#`(req-name ... opt-name ... reqkw-val ... optkw-val ... #,rest))
|
||||
(define/with-syntax arg-vals ; drop restargs if none
|
||||
(if rest #'arg-vals/restargs (stx-drop-last #'arg-vals/restargs)))
|
||||
(define/with-syntax bad-arg ; only the bad arg
|
||||
(list-ref (stx->list #'arg-vals) self-i))
|
||||
(define/with-syntax other-arg-labels ; other arg labels
|
||||
(remove-at (stx->list #'arg-labels) self-i))
|
||||
(define/with-syntax other-args ; other args
|
||||
(remove-at (stx->list #'arg-vals) self-i))
|
||||
(define/with-syntax (other-labels+args ...) ; other args interleaved
|
||||
(apply append (stx-map list #'other-arg-labels #'other-args)))
|
||||
(define/with-syntax err-fmt-str
|
||||
(string-append "contract violation:\n"
|
||||
"expected: ~a\n"
|
||||
"given: ~v\n"
|
||||
(if (null? (syntax->list #'other-arg-labels))
|
||||
"argument position: ~a"
|
||||
(string-append "argument position: ~a\n"
|
||||
"other arguments...:"))))
|
||||
(define/with-syntax contract-str
|
||||
(format "~s?" (syntax-e #'self-name)))
|
||||
(define/with-syntax self-i-stx self-i)
|
||||
|
||||
#'(define (method-name . method-formals)
|
||||
(define proc-name proc)
|
||||
(when (void? proc-name)
|
||||
(raise-arguments-error
|
||||
'method-name
|
||||
(format err-fmt-str 'contract-str bad-arg (pos->ord self-i-stx))
|
||||
other-labels+args ...))
|
||||
(unless proc-name
|
||||
(raise-support-error 'method-name self-name))
|
||||
method-apply))]))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user