diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/context.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/context.rkt index 7657ab852e..f38c5f2e2a 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/contract/context.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/context.rkt @@ -470,6 +470,12 @@ (vector-immutable #f) 'pos 'neg)) + (context-test '("the range of") + '((contract (parametric->/c (x) (-> x x)) + (λ (x) 1) + 'pos 'neg) + 1)) + (let* ([blame-pos (contract-eval '(make-blame (srcloc #f #f #f #f #f) #f (λ () 'integer?) diff --git a/racket/collects/racket/contract/private/arr-i-parse.rkt b/racket/collects/racket/contract/private/arr-i-parse.rkt index e73f046d24..4e04e4a8c2 100644 --- a/racket/collects/racket/contract/private/arr-i-parse.rkt +++ b/racket/collects/racket/contract/private/arr-i-parse.rkt @@ -599,6 +599,7 @@ code does the parsing and validation of the syntax. (provide parse-->i ->i-valid-app-shapes + compute-quoted-src-expression (struct-out istx) (struct-out arg/res) (struct-out arg) diff --git a/racket/collects/racket/contract/private/parametric.rkt b/racket/collects/racket/contract/private/parametric.rkt index bc8ac1440d..fd2ed00969 100644 --- a/racket/collects/racket/contract/private/parametric.rkt +++ b/racket/collects/racket/contract/private/parametric.rkt @@ -3,7 +3,7 @@ "blame.rkt" "misc.rkt" "guts.rkt" - (for-syntax racket/base)) + (for-syntax "arr-i-parse.rkt" racket/base)) (provide parametric->/c) (define-syntax (parametric->/c stx) @@ -16,22 +16,24 @@ "expected an identifier" stx x))) - #'(make-polymorphic-contract opaque/c + #`(make-polymorphic-contract opaque/c '(x ...) - (lambda (x ...) c)))])) + (lambda (x ...) c) + '#,(compute-quoted-src-expression #'c)))])) -(define-struct polymorphic-contract [barrier vars body] + +(define-struct polymorphic-contract [barrier vars body body-src-exp] #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property #:name (lambda (c) - `(parametric->/c ,(polymorphic-contract-vars c) ...)) + `(parametric->/c ,(polymorphic-contract-vars c) ,(polymorphic-contract-body-src-exp c))) #:projection (lambda (c) - (lambda (blame) - + (lambda (orig-blame) + (define blame (blame-add-context orig-blame #f)) (define (wrap p) ;; values in polymorphic types come in from negative position, ;; relative to the poly/c contract