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

Fix class typechecking for Name types

Browse Source 
Fixed check-class-unit and get-field for the addition
of recursive Name types.

original commit: 32c78065a58633de2b884bb8d81b81ea86066aa8
This commit is contained in:
Asumu Takikawa 2014-03-14 13:18:59 -04:00
parent b80597a56d
commit 2ecee7be45
3 changed files with 46 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt
View File

@ -211,11 +211,16 @@
;; we know by this point that #'form is an actual typed
;; class produced by `class` due to the syntax property
(define (check-class form [expected #f])
(match (and expected (resolve expected))
[(tc-result1: (and self-class-type (Class: _ _ _ _ _ _)))
(ret (parse-and-check form self-class-type))]
[(tc-result1: (Poly-names: ns body-type))
;; FIXME: this case probably isn't quite right
(define expected-type
(match expected
[(tc-result1: type) (resolve type)]
[_ #f]))
(match expected-type
[(? Class? class-type)
(ret (parse-and-check form class-type))]
[(Poly-names: ns body-type)
;; FIXME: make sure this case is correct, does it
;; introduce the right names in scope?
(check-class form (ret body-type))]
[#f (ret (parse-and-check form #f))]
[_ (check-below (ret (parse-and-check form #f)) expected)]))

36
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-objects.rkt
View File

@ -110,22 +110,30 @@
(define (check-get-field meth obj)
(define maybe-meth-sym
(syntax-parse meth [(quote m:id) (syntax-e #'m)] [_ #f]))
(define obj-type (tc-expr obj))
(define obj-type (tc-expr/t obj))
(unless maybe-meth-sym
(tc-error/expr #:return (ret (Un))
"expected a symbolic method name, but got ~a" meth))
(match obj-type
;; FIXME: handle unions and mu?
[(tc-result1: (and ty (Instance: (Class: _ _ (list fields ...) _ _ _))))
(cond [(assq maybe-meth-sym fields) =>
(λ (field-entry) (ret (cadr field-entry)))]
[else
(tc-error/expr #:return (ret (Un))
"expected an object with field ~a, but got ~a"
maybe-meth-sym ty)])]
[(tc-result1: t)
(tc-error/expr #:return (ret (Un))
"expected an object value for get-field, got ~a" t)]))
(define (check obj-type)
(match (resolve obj-type)
;; FIXME: handle unions and mu?
[(and ty (Instance: (Class: _ _ (list fields ...) _ _ _)))
(cond [(assq maybe-meth-sym fields) =>
(λ (field-entry) (ret (cadr field-entry)))]
[else
(tc-error/expr/fields "type mismatch"
#:return (ret (Un))
#:more "the object is missing an expected field"
"field" maybe-meth-sym
"object type" ty)])]
[(Instance: (? needs-resolving? type))
(check (make-Instance (resolve type)))]
[type
(tc-error/expr/fields "type mismatch"
#:more "expected an object value for get-field"
#:return (ret (Un))
"given" type)]))
(check obj-type))
;; check-set-field : Syntax Syntax Syntax -> TCResult
;; type-check the `set-field!` operation on objects
@ -156,7 +164,7 @@
maybe-field-sym)
#:return (ret (Un))
"given" ty)])]
[(Instance: type)
[(Instance: (? needs-resolving? type))
(check (make-Instance (resolve type)))]
[type
(tc-error/expr/fields "type mismatch"

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

@ -132,7 +132,7 @@
(super-new)
(define/public (m) (get-field n this))))
(void))
#:msg #rx"expected an object with field n"]
#:msg #rx"missing an expected field.*field: n"]
;; Fail, conflict with parent field
[tc-err (let ()
(: j% (Class (field [n Integer])
@ -1278,4 +1278,17 @@
(define/public (m . xs) (apply + xs)))
(void))
-Void]
;; test that Name types are ok with get-field and as an
;; expected type for class type-checking
[tc-e (let ()
(define-type-alias Foo%
(Class (init-field [x String])
[m (-> (Instance Foo%) String)]))
(: foo% Foo%)
(define foo%
(class object% (super-new)
(init-field x)
(define/public (m a-foo) (get-field x a-foo))))
(void))
-Void]
))