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

Fix Custodian type

Browse Source 
original commit: d22532db163bdb06007c248628c4002280817579
This commit is contained in:
Asumu Takikawa 2012-11-10 11:11:32 -05:00
commit fb52e98a05
17 changed files with 159 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
collects/tests/typed-racket/fail/exn-any.rkt Normal file
View File

@ -0,0 +1,17 @@
#;
(exn-pred "Any")
#lang racket/load
(module m typed/racket
(struct: s ())
(struct: s2 s ())
(define: v : Any (s2))
(provide v))
(module n racket
(require 'm)
v)
(require 'n)

6
collects/tests/typed-racket/succeed/custodian.rkt Normal file
View File

@ -0,0 +1,6 @@
#lang typed/racket
;; Make sure the Custodian type is bound
(: cust Custodian)
(define cust (current-custodian))

7
collects/tests/typed-racket/succeed/parameter-c.rkt Normal file
View File

@ -0,0 +1,7 @@
#lang typed/racket/base
(require/typed
rackunit
[current-check-around (Parameter Any)])

16
collects/tests/typed-racket/succeed/variance-test.rkt Normal file
View File

@ -0,0 +1,16 @@
#lang typed/racket
;; Test a variance regression
(struct: (A) Foo ([elems : (Vectorof A)]))
(: make-foo (All (A) (A -> (Foo A))))
(define (make-foo x) (Foo (vector x)))
;; Need a module+ here because this test failed
;; originally when variance information wasn't preserved
;; across modules.
(module+ test
;; should type check, but won't if the element has
;; the Any type incorrectly
(+ 1 (vector-ref (Foo-elems (make-foo 1)) 0)))

11
collects/tests/typed-racket/succeed/vector-chap.rkt Normal file
View File

@ -0,0 +1,11 @@
#lang racket/load
(module m1 racket
(define (f x y) (equal? x y))
(provide f))
(module m2 typed/racket
(require/typed 'm1 [f (Any Any -> Boolean)])
(f (vector 1 2) (vector 1 2)))
(require 'm2)

4
collects/typed-racket/base-env/base-env.rkt
View File

@ -1484,8 +1484,8 @@
;;racket/udp
[udp-open-socket (->opt [(-opt -String) (-opt -String)] -UDP-Socket)]
[udp-bind! (-> -UDP-Socket (-opt -String) -PosInt)]
[udp-connect! (-> -UDP-Socket (-opt -String) -PosInt)]
[udp-bind! (-> -UDP-Socket (-opt -String) -Nat -Void)]
[udp-connect! (-> -UDP-Socket (-opt -String) (-opt -Nat) -Void)]
[udp-send-to (->opt -UDP-Socket -String -Nat -Bytes [-Nat -Nat] -Void)]
[udp-send (->opt -UDP-Socket -Bytes [-Nat -Nat] -Void)]

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

@ -54,14 +54,24 @@
(let ([typ (if maker?
((map fld-t (Struct-flds (lookup-type-name (Name-id typ)))) #f . t:->* . typ)
typ)])
(with-syntax ([cnt (type->contract
typ
;; this is for a `require/typed', so the value is not from the typed side
#:typed-side #f
#:kind kind
(lambda () (tc-error/stx prop "Type ~a could not be converted to a contract." typ)))])
(quasisyntax/loc stx (define-values (n) (recursive-contract cnt #,(contract-kind->keyword kind))))))]
[_ (int-err "should never happen - not a define-values: ~a" (syntax->datum stx))]))
(with-syntax ([cnt (type->contract
typ
;; this is for a `require/typed', so the value is not from the typed side
#:typed-side #f
#:kind kind
(λ ()
(tc-error/stx
prop
"Type ~a could not be converted to a contract."
typ)))])
(quasisyntax/loc
stx
(define-values (n)
(recursive-contract
cnt
#,(contract-kind->keyword kind))))))]
[_ (int-err "should never happen - not a define-values: ~a"
(syntax->datum stx))]))
(define (change-contract-fixups forms)
(map (lambda (e)
@ -89,7 +99,6 @@
(for/fold ((acc i)) ((v args))
(contract-kind-max2 v acc)))
(define (contract-kind-min i . args)
(define (contract-kind-min2 x y)
(cond
@ -106,7 +115,7 @@
(string->keyword (symbol->string sym)))
(define (type->contract ty fail #:out [out? #f] #:typed-side [from-typed? #t] #:kind [kind 'impersonator])
(define vars (make-parameter '()))
(define vars (make-parameter '()))
(define current-contract-kind (make-parameter flat-sym))
(define (increase-current-contract-kind! kind)
(current-contract-kind (contract-kind-max (current-contract-kind) kind)))
@ -138,7 +147,9 @@
[(and
(> (length arrs) 1)
;; Keyword args, range and rest specs all the same.
(let ([xs (map (match-lambda [(arr: _ rng rest-spec _ kws) (list rng rest-spec kws)]) arrs)])
(let ([xs (map (match-lambda [(arr: _ rng rest-spec _ kws)
(list rng rest-spec kws)])
arrs)])
(foldl equal? (first xs) (rest xs)))
;; Positionals are monotonically increasing.
(let-values ([(_ ok?)
@ -338,11 +349,13 @@
(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 (contract-kind-min kind chaperone-sym)])
[current-contract-kind
(contract-kind-min kind chaperone-sym)])
(define ctc (t->c b))
#`(letrec ([n* (recursive-contract
#,ctc
#,(contract-kind->keyword (current-contract-kind)))])
#,(contract-kind->keyword
(current-contract-kind)))])
n*))))]
[(Value: #f) #'false/c]
[(Instance: (? Mu? t))
@ -389,7 +402,9 @@
#`(syntax/c #,(t->c t #:kind flat-sym))]
[(Value: v) #`(flat-named-contract #,(format "~a" v) (lambda (x) (equal? x '#,v)))]
;; TODO Is this sound?
[(Param: in out) #`(parameter/c #,(t->c out))]
[(Param: in out)
(set-impersonator!)
#`(parameter/c #,(t->c out))]
[(Hashtable: k v)
(when (equal? kind flat-sym) (exit (fail)))
#`(hash/c #,(t->c k #:kind chaperone-sym) #,(t->c v) #:immutable 'dont-care)]

2
collects/typed-racket/rep/free-variance.rkt
View File

@ -46,7 +46,7 @@
(match var
((== Covariant) #'Covariant)
((== Contravariant) #'Contravariant)
((== Invariant) #'Contravariant)
((== Invariant) #'Invariant)
((== Constant) #'Constant)
((== Dotted) #'Dotted)))

5
collects/typed-racket/scribblings/guide/begin.scrbl
View File

@ -1,7 +1,7 @@
#lang scribble/manual
@begin[(require (for-label (only-meta-in 0 typed/racket)) scribble/eval
"../utils.rkt" (only-in "quick.scrbl" typed-mod))]
"../utils.rkt" (only-in "quick.scrbl" typed-mod))]
@(define the-eval (make-base-eval))
@(the-eval '(require typed/racket))
@ -131,3 +131,6 @@ Typed Racket also attempts to detect more than one error in the module.
(string-append "a string" (add1 "not a number"))
]
}
@close-eval[the-eval]

2
collects/typed-racket/typecheck/tc-app/tc-app-eq.rkt
View File

@ -40,7 +40,7 @@
;; identifier expr expr -> tc-results
(define (tc/eq comparator v1 v2)
(define (eq?-able e) (or (boolean? e) (keyword? e) (symbol? e) (eof-object? e)))
(define (eqv?-able e) (or (eq?-able e) (number? e)))
(define (eqv?-able e) (or (eq?-able e) (number? e) (char? e)))
(define (equal?-able e) #t)
(define (ok? val)
(define-syntax-rule (alt nm pred ...)

5
collects/typed-racket/types/abbrev.rkt
View File

@ -14,12 +14,11 @@
;; avoid the other dependencies of `racket/place`
'#%place
unstable/function
racket/udp
unstable/lazy-require
(except-in racket/contract/base ->* -> one-of/c)
(prefix-in c: racket/contract/base)
(for-syntax racket/base syntax/parse racket/list)
(for-template racket/base racket/contract/base racket/promise racket/tcp racket/flonum)
(for-template racket/base racket/contract/base racket/promise racket/tcp racket/flonum racket/udp '#%place)
racket/pretty racket/udp
;; for base type predicates
racket/promise racket/tcp racket/flonum)
@ -215,7 +214,7 @@
(define -Special-Comment
(make-Base 'Special-Comment #'special-comment? special-comment? #'-Special-Comment))
(define -Custodian (make-Base 'Custodian #'custodian? custodian? #'Custodian))
(define -Custodian (make-Base 'Custodian #'custodian? custodian? #'-Custodian))
(define -Parameterization (make-Base 'Parameterization #'parameterization? parameterization? #'-Parameterization))

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

@ -36,10 +36,16 @@
;; does t have a type name associated with it currently?
;; has-name : Type -> Maybe[Symbol]
(define (has-name? t)
(and print-aliases
(for/first ([(n t*) (in-pairs (in-list (force (current-type-names))))]
#:when (and (Type? t*) (type-equal? t t*)))
n)))
(cond
[print-aliases
(define candidates
(for/list ([(n t*) (in-pairs (in-list (force (current-type-names))))]
#:when (and (Type? t*) (type-equal? t t*)))
n))
(if (null? candidates)
#f
(car (sort candidates string>? #:key symbol->string)))]
[else #f]))
(define (print-filter c port write?)
(define (fp . args) (apply fprintf port args))

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

@ -6,13 +6,15 @@
(define (traverse b)
(define (fail v)
(raise-blame-error (blame-swap b) v "Attempted to use a higher-order value passed as `Any`"))
(raise-blame-error
(blame-swap b) v
"Attempted to use a higher-order value passed as `Any` in untyped code"))
(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))
(struct-type-info struct-type))
(when skip? (fail s)) ;; "Opaque struct type!")
(define-values (fun/chap-list _)
(for/fold ([res null]
@ -34,7 +36,7 @@
res)
imms))))
(cond
[par (cons fun/chap-list (extract-functions par))]
[par (append fun/chap-list (extract-functions par))]
[else fun/chap-list]))
(define-values (type skipped?) (struct-info s))
(when skipped? (fail s)); "Opaque struct type!"
@ -43,10 +45,24 @@
(match 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))))
(null? e) (regexp? e) (eq? undef e) (path? e)
(regexp? e) (keyword? e) (bytes? e) (boolean? e) (void? e))))
v]
[(cons x y) (cons (t x) (t y))]
[(? vector? (? immutable?))
;; fixme -- should have an immutable for/vector
(vector->immutable-vector
(for/vector #:length (vector-length v)
([i (in-vector v)]) (t i)))]
[(? box? (? immutable?)) (box-immutable (t (unbox v)))]
;; fixme -- handling keys
;; [(? hasheq? (? immutable?))
;; (for/hasheq ([(k v) (in-hash v)]) (values k v))]
;; [(? hasheqv? (? immutable?))
;; (for/hasheqv ([(k v) (in-hash v)]) (values k v))]
[(? hash? (? immutable?))
(for/hash ([(k v) (in-hash v)]) (values (t k) (t v)))]
[(? vector?) (chaperone-vector v
(lambda (v i e) (t e))
(lambda (v i e) (fail v)))]

17
collects/typed/framework/framework.rkt
View File

@ -9,28 +9,13 @@
()
([get-font (-> (Instance Font%))]))))])))
(dt Racket:Text% (Class ()
()
([begin-edit-sequence (-> Void)]
[end-edit-sequence (-> Void)]
[lock (Boolean -> Void)]
[last-position (-> Number)]
[last-paragraph (-> Exact-Nonnegative-Integer)]
[delete (Number Number -> Void)]
[auto-wrap (Any -> Void)]
[paragraph-end-position (Number -> Natural)]
[paragraph-start-position (Number -> Natural)]
[get-start-position (-> Number)]
[get-end-position (-> Number)]
[insert (String Number Number -> Void)])))
(require/typed/provide
framework/framework
[preferences:set-default (Symbol Sexp (Any -> Boolean) -> Void)]
[preferences:set (Symbol Sexp -> Void)]
[editor:get-standard-style-list
(-> (Instance Style-List%))]
[racket:text% Racket:Text%]
[racket:text% Text:Basic%]
[gui-utils:ok/cancel-buttons
((Instance Horizontal-Panel%)
((Instance Button%) (Instance Event%) -> Void)

34
collects/typed/mred/mred.rkt
View File

@ -20,28 +20,30 @@
([parent Any] [width Integer] [label String])
([show (Any -> Void)])))
(dt Text-Field% (Class ()
([parent Any] [callback Any] [label String])
([get-value (-> String)]
[focus (-> Void)])))
([parent (Instance Dialog%)]
[callback (Any Any -> Any)]
[label String])
([get-value (-> String)]
[focus (-> Void)])))
(dt Horizontal-Panel% (Class ()
([parent Any]
([parent (Instance Dialog%)]
[stretchable-height Any #t]
[alignment (List Symbol Symbol) #t])
()))
(dt Choice% (Class ()
([parent Any] [label String] [choices (Listof Any)] [callback Any])
([parent (Instance Horizontal-Panel%)] [label String] [choices (Listof Any)] [callback (Any Any -> Any)])
([get-selection (-> (Option Natural))]
[set-selection (Integer -> Any)]
[get-string-selection (-> (Option String))]
[set-string-selection (String -> Void)])))
(dt Message% (Class ()
([parent Any] [label String])
([parent (Instance Horizontal-Panel%)] [label String])
([set-label ((U String (Instance Bitmap%)) -> Void)])))
(dt Horizontal-Pane% (Class ()
([parent Any])
([parent (Instance Horizontal-Panel%)])
()))
(dt Editor-Canvas% (Class ()
([parent Any] [editor Any])
([parent (Instance Dialog%)] [editor (Instance Text:Basic%)])
([set-line-count ((U #f Integer) -> Void)])))
(dt Bitmap-DC% (Class ((Instance Bitmap%))
()
@ -55,6 +57,22 @@
(dt Snip% (Class () () ([get-count (-> Integer)])))
(dt Text:Basic% (Class ()
()
([begin-edit-sequence (-> Void)]
[end-edit-sequence (-> Void)]
[lock (Boolean -> Void)]
[last-position (-> Number)]
[last-paragraph (-> Exact-Nonnegative-Integer)]
[delete (Number Number -> Void)]
[auto-wrap (Any -> Void)]
[paragraph-end-position (Number -> Integer)]
[paragraph-start-position (Number -> Integer)]
[get-start-position (-> Integer)]
[get-end-position (-> Integer)]
[get-text (Integer (U Integer 'eof) -> String)]
[insert (String Number Number -> Void)])))
(dt Text% (Class ()
()
([begin-edit-sequence (-> Void)]

2
collects/typed/rackunit.rkt
View File

@ -1,3 +1,3 @@
#lang racket
#lang racket/base
(require typed/rackunit/main)
(provide (all-from-out typed/rackunit/main))

4
doc/release-notes/typed-racket/HISTORY.txt
View File

@ -1,3 +1,7 @@
5.3.1
- Revised handling of `Any` exported to untyped code
- Added `cast`
- Correctly compute variance of polymorphic type application
5.3
- Keyword and optional arguments
- Faster startup