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

Allow send to union of objects

Browse Source 
Also fix TR `send` for multiple/any values as receiver

Now emits a real type error instead of crashing with
an internal match error.

Closes PR 14547

original commit: 7743386eec4f5d752f5f87dab52e2da43bd11926
This commit is contained in:
Asumu Takikawa 2014-06-09 15:56:58 -04:00
parent 64a4fd6e1d
commit e03538a1ac
2 changed files with 55 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-send.rkt
View File

@ -4,7 +4,7 @@
(require "../utils/utils.rkt"
racket/match syntax/stx
(typecheck signatures tc-funapp)
(typecheck signatures tc-funapp tc-metafunctions)
(types base-abbrev resolve utils type-table)
(rep type-rep)
(utils tc-utils))
@ -13,13 +13,14 @@
(export tc-send^)
(define (tc/send form rcvr method args [expected #f])
;; do-check : Type/c -> tc-results/c
(define (do-check rcvr-type)
(match rcvr-type
[(tc-result1: (Instance: (? needs-resolving? type)))
(do-check (ret (make-Instance (resolve type))))]
[(tc-result1: (and obj (Instance: (Class: _ _ _ methods _ _))))
(match (tc-expr method)
[(tc-result1: (Value: (? symbol? s)))
[(Instance: (? needs-resolving? type))
(do-check (make-Instance (resolve type)))]
[(and obj (Instance: (Class: _ _ _ methods _ _)))
(match (tc-expr/t method)
[(Value: (? symbol? s))
(define ftype
(cond [(assq s methods) => cadr]
[else (tc-error/expr/fields
@ -27,14 +28,18 @@
"method name" s
"object type" obj
#:return -Bottom)]))
(define retval
(tc/funapp rcvr args (ret ftype) (stx-map tc-expr args) expected))
(add-typeof-expr form retval)
retval]
[(tc-result1: t)
(int-err "non-symbol methods not supported by Typed Racket: ~a" t)])]
[(tc-result1: t) (tc-error/expr/fields
"send: type mismatch"
"expected" "an object"
"given" t)]))
(do-check (tc-expr rcvr)))
(tc/funapp rcvr args (ret ftype) (stx-map tc-expr args) expected)]
[_ (int-err "non-symbol methods not supported by Typed Racket: ~a"
rcvr-type)])]
;; union of objects, check pointwise and union the results
[(Union: (list (and objs (Instance: _)) ...))
(merge-tc-results
(for/list ([obj (in-list objs)])
(do-check obj)))]
[_ (tc-error/expr/fields
"send: type mismatch"
"expected" "an object"
"given" rcvr-type)]))
(define final-ret (do-check (tc-expr/t rcvr)))
(add-typeof-expr form final-ret)
final-ret)

33
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt
View File

@ -109,6 +109,39 @@
[tc-err (send 4 m 3)
#:ret (ret (-val 5) -bot-filter)
#:expected (ret (-val 5) -no-filter -no-obj)]
;; Fails, sending to multiple/unknown values
[tc-err (send (values 'a 'b) m 'c)
#:msg #rx"expected single value"]
[tc-err (send (eval "3") m 'c)
#:msg #rx"expected single value"]
;; Send to a union of objects in various ways
[tc-e (let ()
(: f (-> (U (Object [m (-> String)])
(Object [m (-> Symbol)]
[n (-> Void)]))
(U Symbol String)))
(define (f o) (send o m))
(f (new (class object% (super-new) (define/public (m) "foo")))))
(t:Un -String -Symbol)]
[tc-e (let ()
(: f (-> (U (Object [m (-> (values String Symbol))])
(Object [m (-> (values Symbol String))]
[n (-> Void)]))
(values (U Symbol String) (U Symbol String))))
(define (f o) (send o m))
(f (new (class object% (super-new)
(define/public (m) (values "foo" 'bar))))))
#:ret (ret (list (t:Un -String -Symbol) (t:Un -String -Symbol)))]
[tc-err
(let ()
(define obj
(if (> (random) 0.5)
(new (class object% (super-new)
(define/public (m) "foo")))
(new (class object% (super-new)
(define/public (m) (values "foo" "bar"))))))
(send obj m))
#:msg #rx"Expected the same number of values.*got 1 and 2"]
;; Field access via get-field
[tc-e (let ()
(: j% (Class (field [n Integer])