diff --git a/typed-racket-lib/typed-racket/base-env/prims-contract.rkt b/typed-racket-lib/typed-racket/base-env/prims-contract.rkt index 2e7f0011..8807b3d4 100644 --- a/typed-racket-lib/typed-racket/base-env/prims-contract.rkt +++ b/typed-racket-lib/typed-racket/base-env/prims-contract.rkt @@ -85,6 +85,7 @@ "../utils/tc-utils.rkt" "../private/syntax-properties.rkt" "../private/cast-table.rkt" + "../private/type-contract.rkt" "../typecheck/internal-forms.rkt" ;; struct-extraction is actually used at both of these phases "../utils/struct-extraction.rkt" @@ -375,9 +376,9 @@ #`(begin #,stx (begin))] [(_ ty:id pred:id lib (~optional ne:name-exists-kw) ...) (with-syntax ([hidden (generate-temporary #'pred)]) - (define pred-cnt - (syntax-local-lift-expression - (make-contract-def-rhs #'(-> Any Boolean) #f #f))) + ;; this is needed because this expands to the contract directly without + ;; going through the normal `make-contract-def-rhs` function. + (set-box! include-extra-requires? #t) (quasisyntax/loc stx (begin ;; register the identifier for the top-level (see require/typed) @@ -388,7 +389,10 @@ #,(if (attribute ne) (internal (syntax/loc stx (define-type-alias-internal ty (Opaque pred)))) (syntax/loc stx (define-type-alias ty (Opaque pred)))) - #,(ignore #`(require/contract pred hidden #,pred-cnt lib)))))])) + #,(ignore #'(define pred-cnt + (or/c struct-predicate-procedure?/c + (any-wrap-warning/c . c-> . boolean?)))) + #,(ignore #'(require/contract pred hidden pred-cnt lib)))))])) diff --git a/typed-racket-lib/typed-racket/utils/any-wrap.rkt b/typed-racket-lib/typed-racket/utils/any-wrap.rkt index 8681829a..c6361ca5 100644 --- a/typed-racket-lib/typed-racket/utils/any-wrap.rkt +++ b/typed-racket-lib/typed-racket/utils/any-wrap.rkt @@ -66,7 +66,11 @@ (variable-reference? e) (weak-box? e))) -(define (late-neg-projection b) +;; late-neg-projection : +;; (-> #:on-opaque (-> Val Blame Neg-Party (U Val Error)) +;; (-> Blame +;; (-> Val Neg-Party Val))) +(define ((late-neg-projection #:on-opaque on-opaque) b) (define (fail neg-party v) (raise-blame-error (blame-swap b) #:missing-party neg-party @@ -195,18 +199,66 @@ (values v (any-wrap/traverse v neg-party)))) (lambda (e) (fail neg-party v)))] [_ - ;; this would be unsound, see https://github.com/racket/typed-racket/issues/379 - ;; (chaperone-struct v) - (fail neg-party v)])) + (on-opaque v b neg-party)])) any-wrap/traverse) -(define any-wrap/c +;; on-opaque-error : Val Blame Neg-Party -> Error +;; To be passed as the #:on-opaque argument to make any-wrap/c raise +;; an error on opaque values. +(define (on-opaque-error v blame neg-party) + (raise-any-wrap/c-opaque-error v blame neg-party)) + +;; on-opaque-display-warning : Val Blame Neg-Party -> Val +;; To be passed as the #:on-opaque argument to make any-wrap/c display +;; a warning, but keep going with possible unsoundness. +(define (on-opaque-display-warning v blame neg-party) + ;; this can lead to unsoundness, see https://github.com/racket/typed-racket/issues/379. + ;; an error here would make this sound, but it breaks the math library as of 2016-07-08, + ;; see https://github.com/racket/typed-racket/pull/385#issuecomment-231354377. + (display-any-wrap/c-opaque-warning v blame neg-party) + (chaperone-struct v)) + +;; make-any-wrap/c : (-> #:on-opaque (-> Val Blame Neg-Party (U Val Error)) Chaperone-Contract) +(define (make-any-wrap/c #:on-opaque on-opaque) (make-chaperone-contract #:name 'Any #:first-order (lambda (x) #t) - #:late-neg-projection late-neg-projection)) + #:late-neg-projection (late-neg-projection #:on-opaque on-opaque))) -(define ((struct?/inspector inspector) v) (struct? v)) +(define any-wrap/c + (make-any-wrap/c #:on-opaque on-opaque-error)) + +(define any-wrap-warning/c + (make-any-wrap/c #:on-opaque on-opaque-display-warning)) + +;; struct?/inspector : (-> Inspector (-> Any Boolean)) +(define ((struct?/inspector inspector) v) + (parameterize ([current-inspector inspector]) + (struct? v))) + +;; raise-any-wrap/c-opaque-error : Any Blame Neg-Party -> Error +(define (raise-any-wrap/c-opaque-error v blame neg-party) + (raise-blame-error + blame #:missing-party neg-party + v + (string-append + "any-wrap/c: Unable to protect opaque value passed as `Any`\n" + " value: ~e\n") + v)) + +;; display-any-wrap/c-opaque-warning : (-> Any Blame Neg-Party Void) +(define (display-any-wrap/c-opaque-warning v blame neg-party) + (displayln + ((current-blame-format) + (blame-add-missing-party blame neg-party) + v + (format + (string-append + "any-wrap/c: Unable to protect opaque value passed as `Any`\n" + " value: ~e\n" + " This warning will become an error in a future release.\n") + v)) + (current-error-port))) ;; Contract for "safe" struct predicate procedures. ;; We can trust that these obey the type (-> Any Boolean). @@ -215,4 +267,4 @@ (cpointer-predicate-procedure? x)) (not (impersonator? x)))) -(provide any-wrap/c struct-predicate-procedure?/c) +(provide any-wrap/c any-wrap-warning/c struct-predicate-procedure?/c)