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

->[*]: Put srcloc on the outermost syntax object

Browse Source
This commit is contained in:
shhyou 2021-04-14 19:39:01 -05:00 committed by Robby Findler
parent b1f84fa60d
commit 0cff2f6caf
2 changed files with 91 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

81
pkgs/racket-test/tests/racket/contract/errortrace.rkt
View File

@ -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)))

49
racket/collects/racket/contract/private/arrow-val-first.rkt
View File

@ -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->*