diff --git a/collects/scheme/private/contract-arrow.ss b/collects/scheme/private/contract-arrow.ss index e29ee7f22c..ed9a29eda4 100644 --- a/collects/scheme/private/contract-arrow.ss +++ b/collects/scheme/private/contract-arrow.ss @@ -102,9 +102,10 @@ v4 todo: #:omit-define-syntaxes #:property proj-prop (λ (ctc) - (let* ([doms-proj (map (λ (x) ((proj-get x) x)) (->-doms/c ctc))] - [rest-proj (and (->-dom-rest/c ctc) - ((λ (x) ((proj-get x) x)) (->-dom-rest/c ctc)))] + (let* ([doms-proj (map (λ (x) ((proj-get x) x)) + (if (->-dom-rest/c ctc) + (append (->-doms/c ctc) (list (->-dom-rest/c ctc))) + (->-doms/c ctc)))] [doms-optional-proj (map (λ (x) ((proj-get x) x)) (->-optional-doms/c ctc))] [rngs-proj (map (λ (x) ((proj-get x) x)) (->-rngs/c ctc))] [mandatory-kwds-proj (map (λ (x) ((proj-get x) x)) (->-mandatory-kwds/c ctc))] @@ -116,36 +117,22 @@ v4 todo: [optionals-length (length (->-optional-doms/c ctc))] [has-rest? (and (->-dom-rest/c ctc) #t)]) (λ (pos-blame neg-blame src-info orig-str) - (let ([partial-doms (for/list ([dom (in-list doms-proj)] - [n (in-naturals 1)]) - (dom neg-blame pos-blame src-info - (cons (format "required argument ~a" n) orig-str)))] - [partial-rest (if rest-proj - (list (rest-proj neg-blame pos-blame src-info - (cons "rest argument" orig-str))) - null)] - [partial-optional-doms (for/list ([dom (in-list doms-optional-proj)] - [n (in-naturals 1)]) - (dom neg-blame pos-blame src-info - (cons (format "optional argument ~a" n) orig-str)))] - [partial-ranges (for/list ([rng (in-list rngs-proj)] - [n (in-naturals 1)]) - (rng pos-blame neg-blame src-info - (cons (format "result ~a" n) orig-str)))] - [partial-mandatory-kwds (for/list ([kwd (in-list mandatory-kwds-proj)] - [kwd-lit (in-list mandatory-keywords)]) - (kwd neg-blame pos-blame src-info - (cons (format "keyword argument ~a" kwd-lit) orig-str)))] - [partial-optional-kwds (for/list ([kwd (in-list optional-kwds-proj)] - [kwd-lit (in-list optional-keywords)]) - (kwd neg-blame pos-blame src-info - (cons (format "keyword argument ~a" kwd-lit) orig-str)))]) + (let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str)) + doms-proj)] + [partial-optional-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str)) + doms-optional-proj)] + [partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str)) + rngs-proj)] + [partial-mandatory-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str)) + mandatory-kwds-proj)] + [partial-optional-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str)) + optional-kwds-proj)]) (apply func (λ (val mtd?) (if has-rest? (check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords src-info pos-blame orig-str) (check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords src-info pos-blame orig-str))) - (append partial-doms partial-rest partial-optional-doms + (append partial-doms partial-optional-doms partial-mandatory-kwds partial-optional-kwds partial-ranges)))))) diff --git a/collects/scheme/private/contract-guts.ss b/collects/scheme/private/contract-guts.ss index 185e87eac7..b998a7521e 100644 --- a/collects/scheme/private/contract-guts.ss +++ b/collects/scheme/private/contract-guts.ss @@ -1,8 +1,7 @@ #lang scheme/base (require "contract-helpers.ss" - scheme/pretty - (only-in scheme/list add-between)) + scheme/pretty) (require (for-syntax scheme/base "contract-helpers.ss")) @@ -176,35 +175,22 @@ (lambda (x) (get x 0)) (lambda (x) (get x 1))))) -(define (default-contract-violation->string val src-info to-blame contract-sexp+extra msg) - (define (add-modifiers-to-contract modifiers contract-str) - (if (null? modifiers) - contract-str - (string-append "for " - (apply string-append (add-between modifiers " of ")) - " in " contract-str))) +(define (default-contract-violation->string val src-info to-blame contract-sexp msg) (let ([blame-src (src-info-as-string src-info)] [formatted-contract-sexp - (let-values ([(modifiers contract-sexp) - (let loop ([dlist contract-sexp+extra] - [modifiers null]) - (if (and (pair? dlist) - (string? (car dlist))) - (loop (cdr dlist) (cons (car dlist) modifiers)) - (values (reverse modifiers) dlist)))]) - (let ([one-line - (let ([sp (open-output-string)]) - (parameterize ([pretty-print-columns 'infinity]) - (pretty-print contract-sexp sp) - (get-output-string sp)))]) - (if (< (string-length one-line) 30) - (add-modifiers-to-contract modifiers one-line) - (let ([sp (open-output-string)]) - (newline sp) - (parameterize ([pretty-print-print-line print-contract-liner] - [pretty-print-columns 50]) - (pretty-print contract-sexp sp)) - (add-modifiers-to-contract modifiers (get-output-string sp))))))] + (let ([one-line + (let ([sp (open-output-string)]) + (parameterize ([pretty-print-columns 'infinity]) + (pretty-print contract-sexp sp) + (get-output-string sp)))]) + (if (< (string-length one-line) 30) + one-line + (let ([sp (open-output-string)]) + (newline sp) + (parameterize ([pretty-print-print-line print-contract-liner] + [pretty-print-columns 50]) + (pretty-print contract-sexp sp)) + (get-output-string sp))))] [specific-blame (cond [(syntax? src-info) @@ -223,9 +209,8 @@ (pair? (cdr to-blame)) (null? (cddr to-blame)) (equal? 'quote (car to-blame))) - (format "module '~s" (cadr to-blame))] - [(string? to-blame) to-blame] - [else (format "module ~s" to-blame)]) + (format "'~s" (cadr to-blame))] + [else (format "~s" to-blame)]) formatted-contract-sexp specific-blame) msg))) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 71b8d9c6b8..36fb29b5e8 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -135,13 +135,12 @@ improve method arity mismatch contract violation error messages? ; ; -(define-syntax-parameter current-contract-region #f) +(define-syntax-parameter current-contract-region (λ (stx) #'(#%variable-reference))) (define-for-syntax (make-with-contract-transformer contract-id id pos-blame-id) (make-set!-transformer (lambda (stx) - (with-syntax ([neg-blame-id (or (syntax-parameter-value #'current-contract-region) - #'(#%variable-reference))] + (with-syntax ([neg-blame-id #'(current-contract-region)] [pos-blame-id pos-blame-id] [contract-id contract-id] [id id]) @@ -259,10 +258,10 @@ improve method arity mismatch contract violation error messages? dupd-id)) (check-exports (append unprotected protected) expanded-bodies)) (with-syntax ([(contract-def ...) (map marker (filter values contract-defs))] - [blame-str (format "~a ~a" (syntax-e #'type) (syntax-e #'blame))] + [blame-stx #''(type blame)] [(marked-body ...) (map marker expanded-bodies)]) (quasisyntax/loc stx - (splicing-syntax-parameterize ([current-contract-region blame-str]) + (splicing-syntax-parameterize ([current-contract-region (λ (stx) #'blame-stx)]) marked-body ... contract-def ... #,@(map (λ (p c) @@ -270,7 +269,7 @@ improve method arity mismatch contract violation error messages? (make-with-contract-transformer (quote-syntax #,(marker c)) (quote-syntax #,(marker p)) - blame-str))) + (quote-syntax blame-stx)))) protected-ids contracts) #,@(map (λ (u) #`(define-syntax #,u @@ -279,7 +278,7 @@ improve method arity mismatch contract violation error messages? (define-values () (begin #,@(map (λ (p c) - #`(-contract #,(marker c) #,p blame-str 'ignored #,(id->contract-src-info p))) + #`(-contract #,(marker c) #,p blame-stx 'ignored #,(id->contract-src-info p))) protected-ids contracts) (values))) )))))]