diff --git a/typed-racket-doc/typed-racket/scribblings/reference/unsafe.scrbl b/typed-racket-doc/typed-racket/scribblings/reference/unsafe.scrbl new file mode 100644 index 00000000..e614df34 --- /dev/null +++ b/typed-racket-doc/typed-racket/scribblings/reference/unsafe.scrbl @@ -0,0 +1,30 @@ +#lang scribble/manual + +@begin[(require (for-label (only-meta-in 0 [except-in typed/racket for])))] + +@title{Unsafe Typed Racket operations} + +@defmodule[typed/racket/unsafe] + +@bold{Warning}: the operations documented in this section are @emph{unsafe}, +meaning that they can circumvent the invariants of the type system. Unless the +@racket[#:no-optimize] language option is used, this may result in unpredictable +behavior and may even crash Typed Racket. + +@defform[(unsafe-require/typed m rt-clause ...)]{ + This form requires identifiers from the module @racket[m] with the same + import specifications as @racket[require/typed]. + + Unlike @racket[require/typed], this form is unsafe and will not generate + contracts that correspond to the specified types to check that the values + actually match their types. +} + +@defform[(unsafe-provide provide-spec ...)]{ + This form declares exports from a module with the same syntax as + the @racket[provide] form. + + Unlike @racket[provide], this form is unsafe and Typed Racket will not generate + any contracts that correspond to the specified types. This means that uses of the + exports in other modules may circumvent the type system's invariants. +} diff --git a/typed-racket-doc/typed-racket/scribblings/ts-reference.scrbl b/typed-racket-doc/typed-racket/scribblings/ts-reference.scrbl index 70ef5766..3bab52de 100644 --- a/typed-racket-doc/typed-racket/scribblings/ts-reference.scrbl +++ b/typed-racket-doc/typed-racket/scribblings/ts-reference.scrbl @@ -35,6 +35,7 @@ For a friendly introduction, see the companion manual @include-section["reference/no-check.scrbl"] @include-section["reference/typed-regions.scrbl"] @include-section["reference/optimization.scrbl"] +@include-section["reference/unsafe.scrbl"] @include-section["reference/legacy.scrbl"] @include-section["reference/compatibility-languages.scrbl"] @include-section["reference/experimental.scrbl"] 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 43667d38..0a778791 100644 --- a/typed-racket-lib/typed-racket/base-env/prims-contract.rkt +++ b/typed-racket-lib/typed-racket/base-env/prims-contract.rkt @@ -45,6 +45,15 @@ require/typed-legacy require/typed require/typed/provide require-typed-struct/provide cast make-predicate define-predicate)) +;; unsafe operations go in this submodule +(module* unsafe #f + ;; turned into a macro on the requiring side + (provide -unsafe-require/typed)) + +;; used for private unsafe functionality in require macros +;; *do not export* +(define-syntax unsafe-kw (syntax-rules ())) + (require (for-template (submod "." forms) "../utils/require-contract.rkt" (submod "../typecheck/internal-forms.rkt" forms) "colon.rkt" @@ -92,11 +101,12 @@ (pattern (nm:id parent:id))) -(define-values (require/typed-legacy require/typed) +(define-values (require/typed-legacy require/typed -unsafe-require/typed) (let () (define-syntax-class opt-rename - #:attributes (nm spec) + #:attributes (nm orig-nm spec) (pattern nm:id + #:with orig-nm #'nm #:with spec #'nm) (pattern (orig-nm:id internal-nm:id) #:with spec #'(orig-nm internal-nm) @@ -137,44 +147,58 @@ (pattern [(~or (~datum opaque) #:opaque) opaque ty:id pred:id #:name-exists] #:with opt #'(#:name-exists))) - (define-syntax-class (clause legacy lib) + (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)) (pattern (~var strc (struct-clause legacy)) #:attr spec - #`(require-typed-struct strc.nm (strc.body ...) strc.constructor-parts ... #,lib)) + #`(require-typed-struct strc.nm (strc.body ...) strc.constructor-parts ... + #,@(if unsafe? #'(unsafe-kw) #'()) + #,lib)) (pattern sig:signature-clause #:attr spec #`(require-typed-signature sig.sig-name (sig.var ...) (sig.type ...) #,lib)) (pattern sc:simple-clause #:attr spec - #`(require/typed #:internal sc.nm sc.ty #,lib))) + #`(require/typed #:internal sc.nm sc.ty #,lib + #,@(if unsafe? #'(unsafe-kw) #'())))) - (define ((r/t-maker legacy) stx) + (define ((r/t-maker legacy unsafe?) stx) (unless (or (unbox typed-context?) (eq? (syntax-local-context) 'module-begin)) (raise-syntax-error #f "only allowed in a typed module" stx)) (syntax-parse stx - [(_ lib:expr (~var c (clause legacy #'lib)) ...) + [(_ lib:expr (~var c (clause legacy unsafe? #'lib)) ...) (when (zero? (syntax-length #'(c ...))) (raise-syntax-error #f "at least one specification is required" stx)) #`(begin c.spec ...)] - [(_ #:internal nm:opt-rename ty lib (~optional [~seq #:struct-maker parent]) ...) + [(_ #:internal nm:opt-rename ty lib + (~optional [~seq #:struct-maker parent]) + (~optional (~and (~seq (~literal unsafe-kw)) + (~bind [unsafe? #t])) + #:defaults ([unsafe? #f]))) (define/with-syntax hidden (generate-temporary #'nm.nm)) (define/with-syntax sm (if (attribute parent) #'(#:struct-maker parent) #'())) - ;; define `cnt*` to be fixed up later by the module type-checking - (define cnt* - (syntax-local-lift-expression - (make-contract-def-rhs #'ty #f (attribute parent)))) - (quasisyntax/loc stx - (begin - ;; register the identifier so that it has a binding (for top-level) - #,@(if (eq? (syntax-local-context) 'top-level) - (list #'(define-syntaxes (hidden) (values))) - null) - #,(internal #'(require/typed-internal hidden ty . sm)) - #,(ignore #`(require/contract nm.spec hidden #,cnt* lib))))])) - (values (r/t-maker #t) (r/t-maker #f)))) + (cond [(not (attribute unsafe?)) + ;; define `cnt*` to be fixed up later by the module type-checking + (define cnt* + (syntax-local-lift-expression + (make-contract-def-rhs #'ty #f (attribute parent)))) + (quasisyntax/loc stx + (begin + ;; register the identifier so that it has a binding (for top-level) + #,@(if (eq? (syntax-local-context) 'top-level) + (list #'(define-syntaxes (hidden) (values))) + null) + #,(internal #'(require/typed-internal hidden ty . sm)) + #,(ignore #`(require/contract nm.spec hidden #,cnt* lib))))] + [else + (quasisyntax/loc stx + (begin + (require (only-in lib [nm.orig-nm hidden])) + (rename-without-provide nm.nm hidden) + #,(internal #'(require/typed-internal hidden ty . sm))))])])) + (values (r/t-maker #t #f) (r/t-maker #f #f) (r/t-maker #f #t)))) (define (require/typed/provide stx) @@ -356,10 +380,17 @@ (pattern (~seq #:constructor-name name:id) #:attr extra #f) (pattern (~seq #:extra-constructor-name name:id) #:attr extra #t)) + (define-splicing-syntax-class unsafe-clause + (pattern (~seq) #:attr unsafe? #f) + (pattern (~seq (~literal unsafe-kw)) #:attr unsafe? #t)) (define ((rts legacy) stx) (syntax-parse stx #:literals (:) - [(_ name:opt-parent ([fld : ty] ...) (~var input-maker (constructor-term legacy #'name.nm)) lib) + [(_ name:opt-parent + ([fld : ty] ...) + (~var input-maker (constructor-term legacy #'name.nm)) + unsafe:unsafe-clause + lib) (with-syntax* ([nm #'name.nm] [parent #'name.parent] [hidden (generate-temporary #'name.nm)] @@ -439,17 +470,20 @@ #,(ignore #'(require/contract pred hidden (any/c . c-> . boolean?) lib)) #,(internal #'(require/typed-internal hidden (Any -> Boolean : nm))) (require/typed #:internal (maker-name real-maker) nm lib - #:struct-maker parent) + #:struct-maker parent + #,@(if (attribute unsafe.unsafe?) #'(unsafe-kw) #'())) ;This needs to be a different identifier to meet the specifications ;of struct (the id constructor shouldn't expand to it) #,(if (syntax-e #'extra-maker) - #'(require/typed #:internal (maker-name extra-maker) nm lib - #:struct-maker parent) + #`(require/typed #:internal (maker-name extra-maker) nm lib + #:struct-maker parent + #,@(if (attribute unsafe.unsafe?) #'(unsafe-kw) #'())) #'(begin)) - (require/typed lib - [sel (nm -> ty)]) ...)))])) + #,@(if (attribute unsafe.unsafe?) + #'((require/typed #:internal sel (nm -> ty) lib unsafe-kw) ...) + #'((require/typed lib [sel (nm -> ty)]) ...)))))])) (values (rts #t) (rts #f)))) diff --git a/typed-racket-lib/typed-racket/private/syntax-properties.rkt b/typed-racket-lib/typed-racket/private/syntax-properties.rkt index a933a552..f9b4500e 100644 --- a/typed-racket-lib/typed-racket/private/syntax-properties.rkt +++ b/typed-racket-lib/typed-racket/private/syntax-properties.rkt @@ -79,5 +79,5 @@ (tr:unit:invoke tr:unit:invoke) (tr:unit:invoke:expr tr:unit:invoke:expr) (tr:unit:compound tr:unit:compound) - (tr:unit:from-context tr:unit:from-context #:mark)) - + (tr:unit:from-context tr:unit:from-context #:mark) + (unsafe-provide unsafe-provide #:mark)) diff --git a/typed-racket-lib/typed-racket/typecheck/provide-handling.rkt b/typed-racket-lib/typed-racket/typecheck/provide-handling.rkt index 7d9436ff..88c91353 100644 --- a/typed-racket-lib/typed-racket/typecheck/provide-handling.rkt +++ b/typed-racket-lib/typed-racket/typecheck/provide-handling.rkt @@ -13,10 +13,13 @@ (provide remove-provides provide? generate-prov) +;; Returns #t for safe provides. Returns #f for non-provide forms +;; and unsafe provides for which contracts will not be generated. (define (provide? form) (syntax-parse form #:literal-sets (kernel-literals) - [(#%provide . rest) form] + [(~and (#%provide . rest) (~not _:unsafe-provide^)) + form] [_ #f])) (define (remove-provides forms) diff --git a/typed-racket-lib/typed-racket/utils/require-contract.rkt b/typed-racket-lib/typed-racket/utils/require-contract.rkt index 2b775642..05219dbf 100644 --- a/typed-racket-lib/typed-racket/utils/require-contract.rkt +++ b/typed-racket-lib/typed-racket/utils/require-contract.rkt @@ -7,7 +7,7 @@ (for-syntax racket/base syntax/parse)) -(provide require/contract define-ignored) +(provide require/contract define-ignored rename-without-provide) (define-syntax (define-ignored stx) (syntax-case stx () @@ -26,6 +26,17 @@ 'inferred-name (syntax-e #'name)))])])) +;; Define a rename-transformer that's set up to avoid being provided +;; by all-defined-out or related forms. +(define-syntax (rename-without-provide stx) + (syntax-parse stx + [(_ nm:id hidden:id) + #'(define-syntax nm + (make-rename-transformer + (syntax-property (syntax-property (quote-syntax hidden) + 'not-free-identifier=? #t) + 'not-provide-all-defined #t)))])) + ;; Requires an identifier from an untyped module into a typed module ;; nm is the import ;; hidden is an id that will end up being the actual definition @@ -42,11 +53,7 @@ (syntax-parse stx [(require/contract nm:renameable hidden:id cnt lib) #`(begin (require (only-in lib [nm.orig-nm nm.orig-nm-r])) - (define-syntax nm.nm - (make-rename-transformer - (syntax-property (syntax-property (quote-syntax hidden) - 'not-free-identifier=? #t) - 'not-provide-all-defined #t))) + (rename-without-provide nm.nm hidden) (define-ignored hidden (contract cnt diff --git a/typed-racket-lib/typed/racket/unsafe.rkt b/typed-racket-lib/typed/racket/unsafe.rkt new file mode 100644 index 00000000..25e80cf8 --- /dev/null +++ b/typed-racket-lib/typed/racket/unsafe.rkt @@ -0,0 +1,19 @@ +#lang racket/base + +;; This module provides unsafe operations for Typed Racket + +(provide unsafe-provide + unsafe-require/typed) + +(require (for-syntax racket/base + typed-racket/private/syntax-properties + (submod typed-racket/base-env/prims-contract unsafe))) + +(define-syntax (unsafe-require/typed stx) + (-unsafe-require/typed stx)) + +(define-syntax (unsafe-provide stx) + (syntax-case stx () + [(_ . rst) + (quasisyntax/loc stx + #,(unsafe-provide #'(provide . rst)))])) diff --git a/typed-racket-test/succeed/unsafe-provide-struct.rkt b/typed-racket-test/succeed/unsafe-provide-struct.rkt new file mode 100644 index 00000000..82b26803 --- /dev/null +++ b/typed-racket-test/succeed/unsafe-provide-struct.rkt @@ -0,0 +1,15 @@ +#lang racket/base + +;; Test unsafe provide with a struct + +(module a racket/base + (struct foo (x y)) + (define a-foo (foo 1 2)) + (provide (struct-out foo) a-foo)) + +(module b typed/racket + (require typed/racket/unsafe) + (unsafe-provide (struct-out foo)) + (unsafe-require/typed (submod ".." a) + [#:struct foo ([x : String] [y : String])] + [a-foo foo])) diff --git a/typed-racket-test/succeed/unsafe-provide.rkt b/typed-racket-test/succeed/unsafe-provide.rkt new file mode 100644 index 00000000..da8a446c --- /dev/null +++ b/typed-racket-test/succeed/unsafe-provide.rkt @@ -0,0 +1,31 @@ +#lang racket/base + +;; Test unsafe provide form + +(require racket/contract/combinator + racket/function) + +(module a typed/racket + (require typed/racket/unsafe) + + (: f (-> String String)) + (define (f x) + (string-append x "foo")) + (unsafe-provide f) + (unsafe-provide (rename-out [f g])) + + (struct foo ([x : String])) + (unsafe-provide (struct-out foo))) + +(require 'a) + +;; UNSAFE +;; primitive error, no blame should be raised +(with-handlers ([(negate exn:fail:contract:blame?) void]) + (f 3)) + +(with-handlers ([(negate exn:fail:contract:blame?) void]) + (g 3)) + +(with-handlers ([(negate exn:fail:contract:blame?) void]) + (foo-x (foo 3))) diff --git a/typed-racket-test/succeed/unsafe-require.rkt b/typed-racket-test/succeed/unsafe-require.rkt new file mode 100644 index 00000000..3456b39c --- /dev/null +++ b/typed-racket-test/succeed/unsafe-require.rkt @@ -0,0 +1,32 @@ +#lang racket/base + +;; Test unsafe require forms + +(module a racket/base + (struct foo (x y)) + (define a-foo (foo 1 2)) + (provide (struct-out foo) a-foo)) + +(module b typed/racket + (require/typed racket/contract/combinator [#:opaque Blame exn:fail:contract:blame?]) + (require typed/racket/unsafe) + (unsafe-require/typed (submod ".." a) + [#:struct foo ([x : String] [y : String])] + [a-foo foo]) + + ;; UNSAFE + ;; primitive error, no blame should be raised + (with-handlers ([(negate exn:fail:contract:blame?) void]) + (string-append (foo-x a-foo)))) + +(module c typed/racket + (require/typed racket/contract/combinator [#:opaque Blame exn:fail:contract:blame?]) + (require typed/racket/unsafe) + (unsafe-require/typed racket/base + [string-append (-> String String Integer)]) + + ;; UNSAFE + (with-handlers ([(negate exn:fail:contract:blame?) void]) + (number->string (string-append "foo" "bar")))) + +(require 'b 'c)