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

Add a typed/racket/unsafe library.

Browse Source 
Comes with `unsafe-require/typed` and `unsafe-provide`.
These operations do not generate contracts but are not
exported by default by Typed Racket.
This commit is contained in:
Asumu Takikawa 2015-05-02 01:48:51 -04:00
parent 7f8e91c571
commit eb90cd4e8c
10 changed files with 208 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
typed-racket-doc/typed-racket/scribblings/reference/unsafe.scrbl Normal file
View File

@ -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.
}

1
typed-racket-doc/typed-racket/scribblings/ts-reference.scrbl
View File

@ -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"]

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

@ -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))))

4
typed-racket-lib/typed-racket/private/syntax-properties.rkt
View File

@ -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))

5
typed-racket-lib/typed-racket/typecheck/provide-handling.rkt
View File

@ -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)

19
typed-racket-lib/typed-racket/utils/require-contract.rkt
View File

@ -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

19
typed-racket-lib/typed/racket/unsafe.rkt Normal file
View File

@ -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)))]))

15
typed-racket-test/succeed/unsafe-provide-struct.rkt Normal file
View File

@ -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]))

31
typed-racket-test/succeed/unsafe-provide.rkt Normal file
View File

@ -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)))

32
typed-racket-test/succeed/unsafe-require.rkt Normal file
View File

@ -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)