diff --git a/typed-racket-lib/typed-racket/typed-racket.rkt b/typed-racket-lib/typed-racket/typed-racket.rkt index dcb30c70..f6c702d4 100644 --- a/typed-racket-lib/typed-racket/typed-racket.rkt +++ b/typed-racket-lib/typed-racket/typed-racket.rkt @@ -5,6 +5,8 @@ "standard-inits.rkt") ;; these need to be available to the generated code "typecheck/renamer.rkt" syntax/location + ;; this defines the inspector that structs will use + "utils/inspector.rkt" (for-syntax (submod "base-env/prims-contract.rkt" self-ctor)) (for-syntax "utils/struct-extraction.rkt") (for-syntax "typecheck/renamer.rkt") @@ -16,6 +18,13 @@ with-type (for-syntax do-standard-inits)) +;; This sets the inspector that typed racket structs will use, so that +;; any-wrap/c can inspect them. This allows any-wrap/c to wrap structs +;; that are defined in typed racket, and to fail on structs that it +;; can't wrap safely. +;; https://github.com/racket/typed-racket/issues/379 +;; https://github.com/racket/typed-racket/pull/385 +(current-inspector new-inspector) (define-syntax-rule (drivers [name sym] ...) (begin diff --git a/typed-racket-lib/typed-racket/utils/any-wrap.rkt b/typed-racket-lib/typed-racket/utils/any-wrap.rkt index 2e006690..1899771b 100644 --- a/typed-racket-lib/typed-racket/utils/any-wrap.rkt +++ b/typed-racket-lib/typed-racket/utils/any-wrap.rkt @@ -11,7 +11,8 @@ (only-in racket/udp udp?) (only-in (combine-in racket/private/promise) promise? - prop:force promise-forcer)) + prop:force promise-forcer) + (only-in "inspector.rkt" old-inspector)) (define (base-val? e) (or (number? e) (string? e) (char? e) (symbol? e) @@ -68,11 +69,12 @@ v "Attempted to use a higher-order value passed as `Any` in untyped code: ~v" v)) - (define (wrap-struct neg-party s) + (define (wrap-struct neg-party s inspector) (define blame+neg-party (cons b neg-party)) (define (extract-functions struct-type) (define-values (sym init auto ref set! imms par skip?) - (struct-type-info struct-type)) + (parameterize ([current-inspector inspector]) + (struct-type-info struct-type))) (define-values (fun/chap-list _) (for/fold ([res null] [imms imms]) @@ -99,7 +101,9 @@ (cond [par (append fun/chap-list (extract-functions par))] [else fun/chap-list])) - (define-values (type skipped?) (struct-info s)) + (define-values (type skipped?) + (parameterize ([current-inspector inspector]) + (struct-info s))) ;; It's ok to just ignore skipped? -- see https://github.com/racket/typed-racket/issues/203 (apply chaperone-struct s (extract-functions type))) @@ -163,7 +167,8 @@ (for/set ([i (in-set v)]) (any-wrap/traverse i neg-party))] ;; could do something with generic sets here if they had ;; chaperones, or if i could tell if they were immutable. - [(? struct?) (wrap-struct neg-party v)] + [(? (struct?/inspector old-inspector)) + (wrap-struct neg-party v old-inspector)] [(? procedure?) (chaperone-procedure v (lambda args (fail neg-party v)))] [(? promise?) @@ -185,7 +190,10 @@ blame+neg-party (values v (any-wrap/traverse v neg-party)))) (lambda (e) (fail neg-party v)))] - [_ (chaperone-struct v)])) + [_ + ;; this would be unsound, see https://github.com/racket/typed-racket/issues/379 + ;; (chaperone-struct v) + (fail neg-party v)])) any-wrap/traverse) (define any-wrap/c @@ -194,6 +202,10 @@ #:first-order (lambda (x) #t) #:late-neg-projection late-neg-projection)) +(define ((struct?/inspector inspector) v) + (parameterize ([current-inspector inspector]) + (struct? v))) + ;; Contract for "safe" struct predicate procedures. ;; We can trust that these obey the type (-> Any Boolean). (define (struct-predicate-procedure?/c x) diff --git a/typed-racket-lib/typed-racket/utils/inspector.rkt b/typed-racket-lib/typed-racket/utils/inspector.rkt new file mode 100644 index 00000000..c8df7ab6 --- /dev/null +++ b/typed-racket-lib/typed-racket/utils/inspector.rkt @@ -0,0 +1,12 @@ +#lang racket/base + +(provide old-inspector new-inspector) + +;; Defines a new inspector that typed racket structs will use, +;; and make this new inspector a sub-inspector of the old one. +;; The old one is more powerfull than the new one, so any-wrap/c +;; can use the old one to inspect opaque structs created by +;; typed racket. +(define old-inspector (current-inspector)) +(define new-inspector (make-inspector old-inspector)) + diff --git a/typed-racket-test/succeed/exn-any-mutation.rkt b/typed-racket-test/succeed/exn-any-mutation.rkt new file mode 100644 index 00000000..d7bfcdca --- /dev/null +++ b/typed-racket-test/succeed/exn-any-mutation.rkt @@ -0,0 +1,21 @@ +#lang racket/base +(module untyped racket/base + (provide f) + (define (f x) x)) +(module typed typed/racket + (require typed/rackunit) + (struct (X) s ([i : X]) #:mutable) + (require/typed (submod ".." untyped) + [f (-> Any (s (U Integer String)))]) + (: s1 : (s Integer)) + (define s1 (s 42)) + (define s2 (ann s1 Any)) + (define s3 (f s2)) + (check-equal? (s-i s1) 42) + (check-equal? (s-i s3) 42) + (check-exn #rx"Attempted to use a higher-order value passed as `Any`" + (λ () (set-s-i! s3 "hi"))) + (check-equal? (s-i s1) 42 + "if the previous test hadn't errored, this would be \"hi\" with type Integer") + ) +(require 'typed) diff --git a/typed-racket-test/succeed/pr241-variation-4.rkt b/typed-racket-test/succeed/pr241-variation-4.rkt index 25446ae5..b9a77dbd 100644 --- a/typed-racket-test/succeed/pr241-variation-4.rkt +++ b/typed-racket-test/succeed/pr241-variation-4.rkt @@ -5,6 +5,8 @@ ;; From Issue #203 ;; https://github.com/racket/typed-racket/issues/203 -(require typed-racket/utils/any-wrap) +(require typed-racket/utils/any-wrap + typed-racket/utils/inspector) +(current-inspector new-inspector) (struct s ()) (contract any-wrap/c (s) 'a 'b)