From 50aab9806ff549ddc5f59f00d16ce336bc20eec6 Mon Sep 17 00:00:00 2001 From: AlexKnauth Date: Fri, 8 Jul 2016 23:04:31 -0400 Subject: [PATCH] warning instead of error on opaque structs passed to #:opaque predicates This fixes a math library error discussed here: https://github.com/racket/typed-racket/pull/385#issuecomment-231354377 --- .../typed-racket/base-env/prims-contract.rkt | 8 +-- .../typed-racket/utils/any-wrap.rkt | 64 +++++++++++++++++-- 2 files changed, 61 insertions(+), 11 deletions(-) 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..2af6d144 100644 --- a/typed-racket-lib/typed-racket/base-env/prims-contract.rkt +++ b/typed-racket-lib/typed-racket/base-env/prims-contract.rkt @@ -375,9 +375,6 @@ #`(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))) (quasisyntax/loc stx (begin ;; register the identifier for the top-level (see require/typed) @@ -388,7 +385,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 26761837..3e1951d4 100644 --- a/typed-racket-lib/typed-racket/utils/any-wrap.rkt +++ b/typed-racket-lib/typed-racket/utils/any-wrap.rkt @@ -67,7 +67,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 @@ -196,21 +200,67 @@ (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 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). (define (struct-predicate-procedure?/c x) @@ -218,4 +268,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)