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

Revamp handling of Any as a contract.

Browse Source 
The contract now has two major differences:
 - It raises an error when it would have to wrap.
 - It uses chaperones to delay errors as long as possible

In general, using `Any` as a type when exporting to untyped
code will now just work, unless the untyped code tries to
communicate values back to the typed side, in which case an
immediate error will be raised.

Much of the implementation comes from the membrane design
from [Strickland et al, OOPSLA 2012].

original commit: 962f2472e18356f357f026645bdcebdf3139ba29
This commit is contained in:
Sam Tobin-Hochstadt 2012-10-05 12:07:00 -04:00
parent cbca0b172f
commit 638b653967
5 changed files with 63 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/tests/typed-racket/unit-tests/contract-tests.rkt
View File

@ -20,7 +20,7 @@
(test-suite "Contract Tests"
(t (-Number . -> . -Number))
(t (-Promise -Number))
(t/fail (-set Univ))
(t (-set Univ))
))
(define-go contract-tests)

14
collects/typed-racket/private/type-contract.rkt
View File

@ -182,11 +182,10 @@
[(or (App: _ _ _) (Name: _)) (t->c (resolve-once ty))]
;; any/c doesn't provide protection in positive position
[(Univ:)
(if from-typed?
(begin
(set-impersonator!)
#'any-wrap/c)
#'any/c)]
(cond [from-typed?
(set-chaperone!)
#'any-wrap/c]
[else #'any/c])]
;; we special-case lists:
[(Mu: var (Union: (list (Value: '()) (Pair: elem-ty (F: var)))))
(if (and (not from-typed?) (type-equal? elem-ty t:Univ))
@ -293,7 +292,7 @@
(match-let ([(Mu-name: n-nm _) ty])
(with-syntax ([(n*) (generate-temporaries (list n-nm))])
(parameterize ([vars (cons (list n #'n*) (vars))]
[current-contract-kind flat-sym])
[current-contract-kind (contract-kind-min kind chaperone-sym)])
(define ctc (t->c b))
#`(letrec ([n* (recursive-contract
#,ctc
@ -329,7 +328,8 @@
(with-syntax* ([rec (generate-temporary 'rec)])
(define required-recursive-kind
(contract-kind-min kind (if mut? impersonator-sym chaperone-sym)))
(parameterize ((current-contract-kind flat-sym))
;(printf "kind: ~a mut-k: ~a req-rec-kind: ~a\n" kind (if mut? impersonator-sym chaperone-sym) required-recursive-kind)
(parameterize ((current-contract-kind (contract-kind-min kind chaperone-sym)))
(let ((fld-ctc (t->c fty #:seen (cons (cons ty #'rec) structs-seen)
#:kind required-recursive-kind)))
#`(let ((rec (recursive-contract struct-ctc #,(contract-kind->keyword (current-contract-kind)))))

1
collects/typed-racket/types/printer.rkt
View File

@ -213,6 +213,7 @@
[(Name: stx) (fp "~a" (syntax-e stx))]
[(app has-name? (? values name))
(fp "~a" name)]
[(StructType: (Struct: nm _ _ _ _ _)) (fp "(StructType ~a)" (syntax-e nm))]
[(StructTop: (Struct: nm _ _ _ _ _)) (fp "(Struct ~a)" (syntax-e nm))]
[(BoxTop:) (fp "Box")]
[(ChannelTop:) (fp "Channel")]

2
collects/typed-racket/types/subtype.rkt
View File

@ -52,7 +52,7 @@
(define k (cons (unsafe-struct-ref s 0) (unsafe-struct-ref t 0)))
(define (new-val)
(define result (handle-failure (and (subtype* (current-seen) s t) #t)))
(printf "subtype cache miss ~a ~a\n" s t)
;(printf "subtype cache miss ~a ~a\n" s t)
result)
(hash-ref! subtype-cache k new-val))

78
collects/typed-racket/utils/any-wrap.rkt
View File

@ -2,44 +2,72 @@
(require racket/match racket/contract/base racket/contract/combinator)
(define-struct any-wrap (val)
#:property prop:custom-write
(lambda (v p write?)
(fprintf p "#<Typed Value: ~a>" (any-wrap-val v))))
(define undef (letrec ([x x]) x))
(define (traverse wrap?)
(define (traverse b)
(define (fail v)
(raise-blame-error (blame-swap b) v "Attempted to use a higher-order value passed as `Any`"))
(define (t v)
(define (wrap-struct s)
(define (extract-functions struct-type)
(define-values (sym init auto ref set! imms par skip?)
(struct-type-info type))
(when skip? (fail s)) ;; "Opaque struct type!")
(define-values (fun/chap-list _)
(for/fold ([res null]
[imms imms])
([n (in-range (+ init auto))])
(if (and (pair? imms) (= (car imms) n))
;; field is immutable
(values
(list* (make-struct-field-accessor ref n)
(lambda (s v) (t v))
res)
(cdr imms))
;; field is mutable
(values
(list* (make-struct-field-accessor ref n)
(lambda (s v) (t v))
(make-struct-field-mutator set! n)
(lambda (s v) (fail s))
res)
imms))))
(cond
[par (cons fun/chap-list (extract-functions par))]
[else fun/chap-list]))
(define-values (type skipped?) (struct-info s))
(when skipped? (fail s)); "Opaque struct type!"
(apply chaperone-struct s (extract-functions type)))
(match v
[(? (lambda (e) (and (any-wrap? e) (not wrap?)))) (any-wrap-val v)]
[(? (lambda (e)
(or (number? e) (string? e) (char? e) (symbol? e)
(null? e) (regexp? e) (eq? undef e)
(keyword? e) (bytes? e) (boolean? e) (void? e))))
v]
[(cons x y) (cons (t x) (t y))]
[(and (? immutable?) (? vector?))
(for/vector #:length (vector-length v)
([i (in-vector v)]) (t i))]
[(and (? immutable?) (box v)) (box (t v))]
[(and (? immutable?) (? hash? v))
((cond [(hash-eq? v) make-immutable-hasheq]
[(hash-eqv? v) make-immutable-hasheqv]
[else make-immutable-hash])
(for/list ([(k v) (in-hash v)])
(cons (t k) (t v))))]
#; ;; need to check immutablity
[(? prefab-struct-key)
(let* ([k (prefab-struct-key v)]
[vals (struct->vector v)])
(apply make-prefab-struct k (for/list ([i (in-vector vals 1)]) i)))]
[_ (if wrap? (make-any-wrap v) v)]))
[(? vector?) (chaperone-vector v
(lambda (v i e) (t e))
(lambda (v i e) (fail v)))]
[(? box?) (chaperone-box v
(lambda (v e) (t e))
(lambda (v e) (fail v)))]
[(? hash?) (chaperone-hash v
(lambda (h k) (values k (lambda (h k v) (t v)))) ;; ref
(lambda (h k n) (if (immutable? v) (values k n) (fail v))) ;; set
(lambda (h v) v) ;; remove
(lambda (h k) (t k)))] ;; key
[(? evt?) (chaperone-evt v (lambda (e) (values e t)))]
[(? struct?) (wrap-struct v)]
[(? procedure?) (chaperone-procedure v (lambda _ (fail v)))]
[_ (fail v)]))
t)
(define any-wrap/c
(make-contract
(make-chaperone-contract
#:name 'Any
#:projection (compose traverse blame-original?)))
#:first-order (lambda (x) #t)
#:projection traverse))
(provide any-wrap/c)