From 0cff2f6caf83761ce03fd431df3cfcb7710fa4e7 Mon Sep 17 00:00:00 2001 From: shhyou Date: Wed, 14 Apr 2021 19:39:01 -0500 Subject: [PATCH] ->[*]: Put srcloc on the outermost syntax object --- .../tests/racket/contract/errortrace.rkt | 81 +++++++++++++++---- .../contract/private/arrow-val-first.rkt | 49 +++++------ 2 files changed, 91 insertions(+), 39 deletions(-) diff --git a/pkgs/racket-test/tests/racket/contract/errortrace.rkt b/pkgs/racket-test/tests/racket/contract/errortrace.rkt index 9e3b78d5c6..04d512ce95 100644 --- a/pkgs/racket-test/tests/racket/contract/errortrace.rkt +++ b/pkgs/racket-test/tests/racket/contract/errortrace.rkt @@ -1,5 +1,45 @@ #lang racket/base -(require "test-util.rkt") +(require "test-util.rkt" + racket/list) + +(define (test-errortrace-has-name #:name name + #:target-name [target-name name] + expr0 . exprs) + (define all-exprs (append (list expr0) exprs)) + (define init-exprs (drop-right all-exprs 1)) + (define expr (last all-exprs)) + (define test-case-name (string->symbol (format "checking-arrow-src-locs.~a" name))) + + (for ([index (in-naturals)] + [init-expr (in-list init-exprs)]) + (define sp (open-input-string (format "~s\n" init-expr))) + (define init-stx (read-syntax (string->symbol (format "~a.~a" name index)) sp)) + (close-input-port sp) + (contract-eval init-stx #:test-case-name test-case-name)) + + (define sp (open-input-string (format "~s\n" expr))) + (define stx (read-syntax name sp)) + (define exn + (with-handlers ((exn:fail? values)) + (contract-eval stx))) + (define sp2 (open-output-string)) + (parameterize ([current-error-port sp2]) + ((error-display-handler) (exn-message exn) exn)) + (define matches? + (regexp-match? (pregexp + (string-append (regexp-quote (format "~a:" target-name)) + "[[:digit:]]*" + ":" + "[[:digit:]]*" + ":" + "[^\n]*" + "->")) + (get-output-string sp2))) + (unless matches? + (display (get-output-string sp2))) + (test #t + test-case-name + matches?)) (parameterize ([current-contract-namespace (make-basic-contract-namespace 'racket/contract)]) @@ -8,18 +48,27 @@ ;; the argument to make-basic-contract-namespace) (parameterize ([current-namespace (current-contract-namespace)]) (dynamic-require 'errortrace #f)) - (define sp (open-input-string (format "~s\n" '(-> (λ (a b c) #f) any)))) - (define stx (read-syntax 'whereitsat sp)) - (define exn - (with-handlers ((exn:fail? values)) - (contract-eval stx))) - (define sp2 (open-output-string)) - (parameterize ([current-error-port sp2]) - ((error-display-handler) (exn-message exn) exn)) - (define matches? - (regexp-match? #rx"whereitsat" (get-output-string sp2))) - (unless matches? - (display (get-output-string sp2))) - (test #t - 'checking-arrow-src-locs - matches?)) + + (test-errortrace-has-name + #:name 'whereitsat + '(-> (λ (a b c) #f) any)) + + (test-errortrace-has-name + #:name 'whereitsat-star + '(->* ((λ (a b c) #f)) any)) + + (test-errortrace-has-name + #:name 'whereitsat-mod + #:target-name 'whereitsat-mod.0 + '(module anon-mod1 racket/base + (require racket/contract) + (-> (λ (a b c) #f) any)) + '(require 'anon-mod1)) + + (test-errortrace-has-name + #:name 'whereitsat-mod-star + #:target-name 'whereitsat-mod-star.0 + '(module anon-mod2 racket/base + (require racket/contract) + (->* ((λ (a b c) #f)) any)) + '(require 'anon-mod2))) diff --git a/racket/collects/racket/contract/private/arrow-val-first.rkt b/racket/collects/racket/contract/private/arrow-val-first.rkt index 019d11be3f..3c747f351a 100644 --- a/racket/collects/racket/contract/private/arrow-val-first.rkt +++ b/racket/collects/racket/contract/private/arrow-val-first.rkt @@ -861,7 +861,8 @@ plus1 arg list construction: build-plus-one-arity-function/real '())) method?)) (syntax-property - #`(let #,let-bindings + (quasisyntax/loc stx + (let #,let-bindings #,(cond [(and (not method?) (null? kwd-args) @@ -901,7 +902,7 @@ plus1 arg list construction: build-plus-one-arity-function/real #,(if ellipsis-info #`(ellipsis-rest-arg #,(length regular-args) #,@ellipsis-info) #'#f) - #,method?))])) + #,method?))]))) 'racket/contract:contract (vector this-> ;; the -> in the original input to this guy @@ -1090,27 +1091,29 @@ plus1 arg list construction: build-plus-one-arity-function/real (define rng-ctcs (parsed->*-rng-ctcs a-parsed->*)) (define chaperone-constructor (build-code-for-chaperone-constructor a-parsed->* method?)) (syntax-property - #`(let (let-bindings ...) - (build--> '->* - (list #,@(parsed->*-man-dom a-parsed->*)) - (list #,@(parsed->*-opt-dom a-parsed->*)) - '(mandatory-dom-kwd ...) - (list mandatory-dom-kwd-ctc ...) - '(optional-dom-kwd ...) - (list optional-dom-kwd-ctc ...) - #,rest-ctc - #,(cond [pre #''pre] [pre/desc #''pre/desc] [else #'#f]) - #,(or pre pre/desc #'#f) - #,(if rng-ctcs - #`(list #,@(for/list ([rng-ctc (in-list (syntax->list rng-ctcs))]) - (syntax-property rng-ctc - 'racket/contract:positive-position - this->*))) - #'#f) - #,(cond [post #''post] [post/desc #''post/desc] [else #'#f]) - #,(or post post/desc #'#f) - #,chaperone-constructor - #,method?)) + (quasisyntax/loc stx + (let (let-bindings ...) + #,(quasisyntax/loc stx + (build--> '->* + (list #,@(parsed->*-man-dom a-parsed->*)) + (list #,@(parsed->*-opt-dom a-parsed->*)) + '(mandatory-dom-kwd ...) + (list mandatory-dom-kwd-ctc ...) + '(optional-dom-kwd ...) + (list optional-dom-kwd-ctc ...) + #,rest-ctc + #,(cond [pre #''pre] [pre/desc #''pre/desc] [else #'#f]) + #,(or pre pre/desc #'#f) + #,(if rng-ctcs + #`(list #,@(for/list ([rng-ctc (in-list (syntax->list rng-ctcs))]) + (syntax-property rng-ctc + 'racket/contract:positive-position + this->*))) + #'#f) + #,(cond [post #''post] [post/desc #''post/desc] [else #'#f]) + #,(or post post/desc #'#f) + #,chaperone-constructor + #,method?)))) 'racket/contract:contract (vector this->*