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

unsafe-require/typed #:opaque doesn't warn about opaque structs passed as Any (#418)

Browse Source
This commit is contained in:
Alex Knauth 2016-08-31 11:37:05 -04:00 committed by Sam Tobin-Hochstadt
parent 6b10a5480d
commit dfd61642b6
2 changed files with 33 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
typed-racket-lib/typed-racket/base-env/prims-contract.rkt
View File

@ -163,7 +163,7 @@
(define-syntax-class (clause legacy unsafe? lib)
#:attributes (spec)
(pattern oc:opaque-clause #:attr spec
#`(require/opaque-type oc.ty oc.pred #,lib . oc.opt))
#`(require/opaque-type oc.ty oc.pred #,lib #,@(if unsafe? #'(unsafe-kw) #'()) . oc.opt))
(pattern (~var strc (struct-clause legacy)) #:attr spec
#`(require-typed-struct strc.nm (strc.tvar ...)
(strc.body ...) strc.constructor-parts ...
@ -370,13 +370,15 @@
(define (require/opaque-type stx)
(define-syntax-class unsafe-id
(pattern (~literal unsafe-kw)))
(define-syntax-class name-exists-kw
(pattern #:name-exists))
(syntax-parse stx
[_ #:when (eq? 'module-begin (syntax-local-context))
;; it would be inconvenient to find the correct #%module-begin here, so we rely on splicing
#`(begin #,stx (begin))]
[(_ ty:id pred:id lib (~optional ne:name-exists-kw) ...)
[(_ ty:id pred:id lib (~optional unsafe:unsafe-id) (~optional ne:name-exists-kw) ...)
(with-syntax ([hidden (generate-temporary #'pred)])
;; this is needed because this expands to the contract directly without
;; going through the normal `make-contract-def-rhs` function.
@ -391,9 +393,11 @@
#,(if (attribute ne)
(internal (syntax/loc stx (define-type-alias-internal ty (Opaque pred))))
(syntax/loc stx (define-type-alias ty (Opaque pred))))
#,(ignore #'(define pred-cnt
(or/c struct-predicate-procedure?/c
(any-wrap-warning/c . c-> . boolean?))))
#,(if (attribute unsafe)
(ignore #'(define pred-cnt any/c)) ; unsafe- shouldn't generate contracts
(ignore #'(define pred-cnt
(or/c struct-predicate-procedure?/c
(any-wrap-warning/c . c-> . boolean?)))))
#,(ignore #'(require/contract pred hidden pred-cnt lib)))))]))

25
typed-racket-test/succeed/unsafe-require.rkt
View File

@ -36,4 +36,27 @@
(with-handlers ([(negate exn:fail:contract:blame?) void])
(number->string (string-append "foo" "bar"))))
(require 'b 'c)
(module d typed/racket
(require/typed racket/contract/combinator [#:opaque Blame exn:fail:contract:blame?])
(require typed/rackunit typed/racket/unsafe)
(unsafe-require/typed (submod ".." a)
[#:opaque Foo foo?]
[foo (-> String String Foo)]
[foo-x (-> Foo String)]
[foo-y (-> Foo String)]
[a-foo Foo])
(define f (foo "olleh" "hello"))
(check-true (foo? f))
(check-true (foo? a-foo))
(check-false (foo? 5))
(check-false (foo? (vector f a-foo)))
(check-equal? (foo-x f) "olleh")
(check-equal? (foo-y f) "hello")
;; UNSAFE
;; primitive error, no blame should be raised
(with-handlers ([(negate exn:fail:contract:blame?) void])
(string-append (foo-x a-foo))))
(require 'b 'c 'd)