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

Fix non-expected case with inits/fields missing annotations

Browse Source 
Also fix bogus test cases and the bug that hid them
This commit is contained in:
Asumu Takikawa 2013-05-21 19:45:13 -04:00
parent f188d7f103
commit 599beeae52
2 changed files with 71 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -113,7 +113,6 @@
;; FIXME: is this the right thing to do?
(values null null null)]))
;; Define sets of names for use later
(define optional-inits (list->set (syntax->datum #'data.optional-inits)))
(define super-init-names (list->set (dict-keys super-inits)))
(define super-field-names (list->set (dict-keys super-fields)))
(define super-method-names (list->set (dict-keys super-methods)))
@ -165,6 +164,10 @@
(for/hash ([internal all-internal]
[external all-external])
(values internal external)))
;; define which init names are optional
(define optional-inits (list->set (syntax->datum #'data.optional-inits)))
(define optional-external (for/set ([n optional-inits])
(dict-ref internal-external-mapping n)))
;; trawl the body for top-level expressions
(define top-level-exprs (trawl-for-property #'body 'tr:class:top-level))
(define internals-table (register-internals top-level-exprs))
@ -190,32 +193,6 @@
this%-public-internals)))
(match-define (Instance: (Class: _ inits fields methods))
self-type)
;; Use the internal class: information to check whether clauses
;; exist or are absent appropriately
(when expected?
(define exp-init-names (list->set (dict-keys inits)))
(define exp-field-names (list->set (dict-keys fields)))
(define exp-method-names (list->set (dict-keys methods)))
(define exp-optional-inits
(for/set ([(name val) (in-dict inits)]
#:when (cadr val))
name))
(check-same (set-union this%-init-names
(list->set (dict-keys remaining-super-inits)))
exp-init-names
"initialization argument")
(check-same (set-union this%-public-names super-method-names)
exp-method-names
"public method")
(check-same (set-union this%-field-names super-field-names)
exp-field-names
"public field")
(check-same exp-optional-inits this%-init-names
"optional init argument"))
(check-exists super-method-names this%-override-names
"override method")
(check-absent super-field-names this%-field-names "public field")
(check-absent super-method-names this%-public-names "public method")
;; trawl the body for the local name table
(define locals (trawl-for-property #'body 'tr:class:local-table))
(define-values (local-method-table local-private-table local-field-table)
@ -243,9 +220,52 @@
(define checked-method-types
(with-lexical-env/extend lexical-names lexical-types
(check-methods internal-external-mapping meths methods self-type)))
(define final-class-type
(if expected?
self-class-type
(merge-types self-type checked-method-types))]))
(merge-types self-type checked-method-types)))
(check-method-presence-and-absence
final-class-type
this%-init-names this%-field-names
this%-public-names this%-override-names
optional-external
remaining-super-inits super-field-names
super-method-names)
final-class-type]))
;; check-method-presence-and-absence : Type Set<Symbol> * 8 -> Void
;; use the internal class: information to check whether clauses
;; exist or are absent appropriately
(define (check-method-presence-and-absence
class-type this%-init-names this%-field-names
this%-public-names this%-override-names
optional-external
remaining-super-inits super-field-names
super-method-names)
(match-define (Class: _ inits fields methods) class-type)
(define exp-init-names (list->set (dict-keys inits)))
(define exp-field-names (list->set (dict-keys fields)))
(define exp-method-names (list->set (dict-keys methods)))
(define exp-optional-inits
(for/set ([(name val) (in-dict inits)]
#:when (cadr val))
name))
(check-same (set-union this%-init-names
(list->set (dict-keys remaining-super-inits)))
exp-init-names
"initialization argument")
(check-same (set-union this%-public-names super-method-names)
exp-method-names
"public method")
(check-same (set-union this%-field-names super-field-names)
exp-field-names
"public field")
(check-same optional-external exp-optional-inits
"optional init argument")
(check-exists super-method-names this%-override-names
"override method")
(check-absent super-field-names this%-field-names "public field")
(check-absent super-method-names this%-public-names "public method"))
;; merge-types : Type Dict<Symbol, Type> -> Type
;; Given a self object type, construct the real class type based on

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

@ -34,7 +34,7 @@
;; Basic class with init and public method
(check-ok
(: c% (Class (init [x Integer #:optional])
(: c% (Class (init [x Integer])
[m (Integer -> Integer)]))
(define c%
(class: object%
@ -45,7 +45,7 @@
;; Fails, bad superclass expression
(check-err
(: d% (Class (init [x Integer #:optional])
(: d% (Class (init [x Integer])
[m (Integer -> Integer)]))
(define d% (class: 5
(super-new)
@ -54,7 +54,7 @@
;; Method using argument type
(check-ok
(: e% (Class (init [x Integer #:optional])
(: e% (Class (init [x Integer])
[m (Integer -> Integer)]))
(define e% (class: object%
(super-new)
@ -63,7 +63,7 @@
;; Send inside a method
(check-ok
(: f% (Class (init [x Integer #:optional])
(: f% (Class (init [x Integer])
[m (Integer -> Integer)]))
(define f% (class: object%
(super-new)
@ -178,6 +178,19 @@
(define c% (class: object% (super-new)
(field [str "foo"] [x 0]))))
;; FIXME: for the following two tests, we could improve
;; things by either figuring out the init or field
;; type when a default expr is provided. Otherwise,
;; we should still provide a better error message.
;;
;; fails, init with no type annotation
(check-err
(define c% (class: object% (super-new) (init x))))
;; fails, field with no type annotation
(check-err
(define c% (class: object% (super-new) (field [x 0]))))
;; Mixin on classes without row polymorphism
(check-ok
(: mixin ((Class [m (-> Integer)])
@ -257,24 +270,24 @@
;; check a good super-new call
(check-ok
(: c% (Class (init [x Integer #:optional])))
(: c% (Class (init [x Integer])))
(define c% (class: object% (super-new) (init x)))
(: d% (Class))
(define d% (class: c% (super-new [x (+ 3 5)]))))
;; fails, missing super-new
(check-err
(: c% (Class (init [x Integer #:optional])))
(: c% (Class (init [x Integer])))
(define c% (class: object% (init x))))
;; fails, non-top-level super-new
(check-err
(: c% (Class (init [x Integer #:optional])))
(: c% (Class (init [x Integer])))
(define c% (class: object% (let () (super-new)) (init x))))
;; fails, bad super-new argument
(check-err
(: c% (Class (init [x Integer #:optional])))
(: c% (Class (init [x Integer])))
(define c% (class: object% (super-new) (init x)))
(: d% (Class))
(define d% (class: c% (super-new [x "bad"]))))