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

Add support for inherited methods

Browse Source
This commit is contained in:
Asumu Takikawa 2013-05-23 11:54:40 -04:00
parent 30e3c49886
commit 4e5d0846ba
3 changed files with 100 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt
View File

@ -257,7 +257,8 @@
(field #,@(dict-ref name-dict #'field '())) (field #,@(dict-ref name-dict #'field '()))
(public #,@(dict-ref name-dict #'public '())) (public #,@(dict-ref name-dict #'public '()))
(override #,@(dict-ref name-dict #'override '())) (override #,@(dict-ref name-dict #'override '()))
(private #,@(dict-ref name-dict #'private '())))) (private #,@(dict-ref name-dict #'private '()))
(inherit #,@(dict-ref name-dict #'inherit '()))))
(class #,annotated-super (class #,annotated-super
#,@(map clause-stx clauses) #,@(map clause-stx clauses)
#,@(map non-clause-stx annotated-methods) #,@(map non-clause-stx annotated-methods)
@ -336,6 +337,8 @@
(stx-map stx-car (dict-ref name-dict #'init-field '())))) (stx-map stx-car (dict-ref name-dict #'init-field '()))))
(define init-names (define init-names
(stx-map stx-car (dict-ref name-dict #'init '()))) (stx-map stx-car (dict-ref name-dict #'init '())))
(define inherit-names
(stx-map stx-car (dict-ref name-dict #'inherit '())))
(syntax-property (syntax-property
#`(let-values ([(#,@method-names) #`(let-values ([(#,@method-names)
(values #,@(map (λ (stx) #`(λ () (#,stx))) (values #,@(map (λ (stx) #`(λ () (#,stx)))
@ -348,7 +351,10 @@
field-names))] field-names))]
[(#,@init-names) [(#,@init-names)
(values #,@(map (λ (stx) #`(λ () #,stx)) (values #,@(map (λ (stx) #`(λ () #,stx))
init-names))]) init-names))]
[(#,@inherit-names)
(values #,@(map (λ (stx) #`(λ () (#,stx)))
inherit-names))])
(void)) (void))
'tr:class:local-table #t))) 'tr:class:local-table #t)))

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

@ -35,7 +35,7 @@
(define-syntax-class internal-class-data (define-syntax-class internal-class-data
#:literals (#%plain-app quote-syntax class:-internal begin #:literals (#%plain-app quote-syntax class:-internal begin
values c:init c:init-field optional-init c:field values c:init c:init-field optional-init c:field
c:public c:override c:private) c:public c:override c:private c:inherit)
(pattern (begin (quote-syntax (pattern (begin (quote-syntax
(class:-internal (class:-internal
(c:init init-names:name-pair ...) (c:init init-names:name-pair ...)
@ -44,7 +44,8 @@
(c:field field-names:name-pair ...) (c:field field-names:name-pair ...)
(c:public public-names:name-pair ...) (c:public public-names:name-pair ...)
(c:override override-names:name-pair ...) (c:override override-names:name-pair ...)
(c:private privates:id ...))) (c:private privates:id ...)
(c:inherit inherit-names:name-pair ...)))
(#%plain-app values)) (#%plain-app values))
#:with init-internals #'(init-names.internal ...) #:with init-internals #'(init-names.internal ...)
#:with init-externals #'(init-names.external ...) #:with init-externals #'(init-names.external ...)
@ -57,6 +58,8 @@
#:with public-externals #'(public-names.external ...) #:with public-externals #'(public-names.external ...)
#:with override-internals #'(override-names.internal ...) #:with override-internals #'(override-names.internal ...)
#:with override-externals #'(override-names.external ...) #:with override-externals #'(override-names.external ...)
#:with inherit-externals #'(inherit-names.external ...)
#:with inherit-internals #'(inherit-names.internal ...)
#:with private-names #'(privates ...))) #:with private-names #'(privates ...)))
(define-syntax-class initializer-body (define-syntax-class initializer-body
@ -113,6 +116,7 @@
field-internals field-externals field-internals field-externals
public-internals public-externals public-internals public-externals
override-internals override-externals override-internals override-externals
inherit-internals inherit-externals
private-names private-names
make-methods make-methods
initializer-body initializer-body
@ -186,6 +190,8 @@
(define this%-field-internals (define this%-field-internals
(list->set (append (syntax->datum #'cls.field-internals) (list->set (append (syntax->datum #'cls.field-internals)
(syntax->datum #'cls.init-field-internals)))) (syntax->datum #'cls.init-field-internals))))
(define this%-inherit-internals
(list->set (syntax->datum #'cls.inherit-internals)))
(define this%-init-names (define this%-init-names
(list->set (list->set
(append (syntax->datum #'cls.init-externals) (append (syntax->datum #'cls.init-externals)
@ -198,6 +204,8 @@
(list->set (syntax->datum #'cls.public-externals))) (list->set (syntax->datum #'cls.public-externals)))
(define this%-override-names (define this%-override-names
(list->set (syntax->datum #'cls.override-externals))) (list->set (syntax->datum #'cls.override-externals)))
(define this%-inherit-names
(list->set (syntax->datum #'cls.inherit-externals)))
(define this%-private-names (define this%-private-names
(list->set (syntax->datum #'cls.private-names))) (list->set (syntax->datum #'cls.private-names)))
(define this%-method-names (define this%-method-names
@ -209,7 +217,8 @@
#'cls.init-field-internals #'cls.init-field-internals
#'cls.field-internals #'cls.field-internals
#'cls.public-internals #'cls.public-internals
#'cls.override-internals)))) #'cls.override-internals
#'cls.inherit-internals))))
(define all-external (define all-external
(apply append (apply append
(map (λ (stx) (syntax->datum stx)) (map (λ (stx) (syntax->datum stx))
@ -217,7 +226,8 @@
#'cls.init-field-externals #'cls.init-field-externals
#'cls.field-externals #'cls.field-externals
#'cls.public-externals #'cls.public-externals
#'cls.override-externals)))) #'cls.override-externals
#'cls.inherit-externals))))
;; establish a mapping between internal and external names ;; establish a mapping between internal and external names
(define internal-external-mapping (define internal-external-mapping
(for/hash ([internal all-internal] (for/hash ([internal all-internal]
@ -264,7 +274,7 @@
;; trawl the body for the local name table ;; trawl the body for the local name table
(define locals (trawl-for-property #'cls.make-methods 'tr:class:local-table)) (define locals (trawl-for-property #'cls.make-methods 'tr:class:local-table))
(define-values (local-method-table local-private-table local-field-table (define-values (local-method-table local-private-table local-field-table
local-init-table) local-init-table local-inherit-table)
(construct-local-mapping-tables (car locals))) (construct-local-mapping-tables (car locals)))
;; types for private elements ;; types for private elements
(define private-method-types (define private-method-types
@ -283,6 +293,8 @@
;; omit init-fields here since they don't have ;; omit init-fields here since they don't have
;; init accessors, only field accessors ;; init accessors, only field accessors
(list->set (syntax->datum #'cls.init-internals)) (list->set (syntax->datum #'cls.init-internals))
local-inherit-table super-methods
this%-inherit-internals
local-private-table private-method-types local-private-table private-method-types
this%-private-names this%-private-names
#'cls.initializer-self-id #'cls.initializer-self-id
@ -309,17 +321,19 @@
final-class-type final-class-type
this%-init-names this%-field-names this%-init-names this%-field-names
this%-public-names this%-override-names this%-public-names this%-override-names
this%-inherit-names
(set-union optional-external optional-super) (set-union optional-external optional-super)
remaining-super-inits super-field-names remaining-super-inits super-field-names
super-method-names) super-method-names)
final-class-type])) final-class-type]))
;; check-method-presence-and-absence : Type Set<Symbol> * 8 -> Void ;; check-method-presence-and-absence : Type Set<Symbol> * 9 -> Void
;; use the internal class: information to check whether clauses ;; use the internal class: information to check whether clauses
;; exist or are absent appropriately ;; exist or are absent appropriately
(define (check-method-presence-and-absence (define (check-method-presence-and-absence
class-type this%-init-names this%-field-names class-type this%-init-names this%-field-names
this%-public-names this%-override-names this%-public-names this%-override-names
this%-inherit-names
optional-external optional-external
remaining-super-inits super-field-names remaining-super-inits super-field-names
super-method-names) super-method-names)
@ -345,6 +359,8 @@
"optional init argument") "optional init argument")
(check-exists super-method-names this%-override-names (check-exists super-method-names this%-override-names
"override method") "override method")
(check-exists super-method-names this%-inherit-names
"inherited method")
(check-absent super-field-names this%-field-names "public field") (check-absent super-field-names this%-field-names "public field")
(check-absent super-method-names this%-public-names "public method")) (check-absent super-method-names this%-public-names "public method"))
@ -366,8 +382,8 @@
(make-Class #f inits fields new-methods)) (make-Class #f inits fields new-methods))
;; local-tables->lexical-env : Dict<Symbol, Symbol> ;; local-tables->lexical-env : Dict<Symbol, Symbol>
;; Dict<Symbol, Id> Dict List<Symbol> ;; LocalMapping NameTypeDict Names
;; Dict<Symbol, (List Id Id)> Dict List<Symbol> ;; (for each kind of clause) ...
;; Id Id Type ;; Id Id Type
;; -> List<Id> List<Type> List<Id> List<Type> ;; -> List<Id> List<Type> List<Id> List<Type>
;; Construct mappings to put into the lexical type-checking environment ;; Construct mappings to put into the lexical type-checking environment
@ -376,6 +392,8 @@
local-method-table methods method-names local-method-table methods method-names
local-field-table fields field-names local-field-table fields field-names
local-init-table inits init-names local-init-table inits init-names
local-inherit-table super-types
inherit-names
local-private-table local-private-table
private-types private-methods private-types private-methods
self-id init-args-id self-id init-args-id
@ -387,20 +405,25 @@
(define localized-field-pairs (localize local-field-table field-names)) (define localized-field-pairs (localize local-field-table field-names))
(define localized-field-get-names (map car localized-field-pairs)) (define localized-field-get-names (map car localized-field-pairs))
(define localized-field-set-names (map cadr localized-field-pairs)) (define localized-field-set-names (map cadr localized-field-pairs))
(define localized-inherit-names (localize local-inherit-table inherit-names))
(define localized-private-methods (define localized-private-methods
(localize local-private-table private-methods)) (localize local-private-table private-methods))
(define localized-init-names (localize local-init-table init-names)) (define localized-init-names (localize local-init-table init-names))
(define default-type (list (make-Univ))) (define default-type (list (make-Univ)))
;; construct the types for the accessors ;; construct the types for method accessors
(define method-types (define (make-method-types method-names type-map)
(for/list ([m (in-set method-names)]) (for/list ([m (in-set method-names)])
(define external (dict-ref internal-external-mapping m)) (define external (dict-ref internal-external-mapping m))
(define maybe-type (dict-ref methods external #f)) (define maybe-type (dict-ref type-map external #f))
(->* (list (make-Univ)) (->* (list (make-Univ))
(if maybe-type (if maybe-type
(fixup-method-type (car maybe-type) self-type) (fixup-method-type (car maybe-type) self-type)
(make-Univ))))) (make-Univ)))))
(define method-types (make-method-types method-names methods))
(define inherit-types (make-method-types inherit-names super-types))
(define field-get-types (define field-get-types
(for/list ([f (in-set field-names)]) (for/list ([f (in-set field-names)])
(define external (dict-ref internal-external-mapping f)) (define external (dict-ref internal-external-mapping f))
@ -424,26 +447,25 @@
(define external (dict-ref internal-external-mapping i)) (define external (dict-ref internal-external-mapping i))
(car (dict-ref inits external (list -Bottom))))) (car (dict-ref inits external (list -Bottom)))))
(values (append localized-method-names (define all-names (append localized-method-names
localized-private-methods localized-private-methods
localized-field-get-names localized-field-get-names
localized-field-set-names) localized-field-set-names
(append method-types private-method-types localized-inherit-names))
field-get-types field-set-types) (define all-types (append method-types private-method-types
field-get-types field-set-types
inherit-types))
(values all-names all-types
;; FIXME: consider removing method names and types ;; FIXME: consider removing method names and types
;; from top-level environment to avoid <undefined> ;; from top-level environment to avoid <undefined>
(append localized-method-names (append all-names
localized-private-methods
localized-field-get-names
localized-field-set-names
localized-init-names localized-init-names
;; Set `self` to the self-type and `init-args` ;; Set `self` to the self-type and `init-args`
;; to Any, so that accessors can use them without ;; to Any, so that accessors can use them without
;; problems. ;; problems.
;; Be careful though! ;; Be careful though!
(list self-id init-args-id)) (list self-id init-args-id))
(append method-types private-method-types (append all-types
field-get-types field-set-types
init-types init-types
(list self-type (make-Univ))))) (list self-type (make-Univ)))))
@ -571,6 +593,8 @@
#:literals (let-values #%plain-app #%plain-lambda values) #:literals (let-values #%plain-app #%plain-lambda values)
;; See base-env/class-prims.rkt to see how this in-syntax ;; See base-env/class-prims.rkt to see how this in-syntax
;; table is constructed at the surface syntax ;; table is constructed at the surface syntax
;;
;; FIXME: factor out with syntax classes
[(let-values ([(method:id ...) [(let-values ([(method:id ...)
(#%plain-app (#%plain-app
values values
@ -591,7 +615,13 @@
(let-values (((_) _)) (#%plain-app local-field-set:id _ _)))) (let-values (((_) _)) (#%plain-app local-field-set:id _ _))))
...)] ...)]
[(init:id ...) [(init:id ...)
(#%plain-app values (#%plain-lambda () local-init:id) ...)]) (#%plain-app values (#%plain-lambda () local-init:id) ...)]
[(inherit:id ...)
(#%plain-app
values
(#%plain-lambda ()
(#%plain-app (#%plain-app local-inherit:id _) _))
...)])
(#%plain-app void)) (#%plain-app void))
(values (map cons (values (map cons
(syntax->datum #'(method ...)) (syntax->datum #'(method ...))
@ -605,7 +635,10 @@
(syntax->list #'(local-field-set ...))) (syntax->list #'(local-field-set ...)))
(map cons (map cons
(syntax->datum #'(init ...)) (syntax->datum #'(init ...))
(syntax->list #'(local-init ...))))])) (syntax->list #'(local-init ...)))
(map cons
(syntax->datum #'(inherit ...))
(syntax->list #'(local-inherit ...))))]))
;; check-super-new-exists : Listof<Syntax> -> (U Syntax #f) ;; check-super-new-exists : Listof<Syntax> -> (U Syntax #f)
;; Check if a `super-new` call exists and if there is only ;; Check if a `super-new` call exists and if there is only
@ -765,6 +798,9 @@
;; Set<Symbol> Set<Symbol> String -> Void ;; Set<Symbol> Set<Symbol> String -> Void
;; check that all the required names are actually present ;; check that all the required names are actually present
;;
;; FIXME: This gives bad error messages. Consider using syntax
;; object lists instead of sets.
(define (check-exists actual required msg) (define (check-exists actual required msg)
(define missing (define missing
(for/or ([m (in-set required)]) (for/or ([m (in-set required)])

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

@ -485,6 +485,37 @@
(init x) (init x)
(super-new [x x])))) (super-new [x x]))))
;; test inherit method
(check-ok
(class: (class: object% (super-new)
(: m (Integer -> Integer))
(define/public (m x) (add1 x)))
(super-new)
(inherit m)
(m 5)))
;; test internal name with inherit
(check-ok
(class: (class: object% (super-new)
(: m (Integer -> Integer))
(define/public (m x) (add1 x)))
(super-new)
(inherit [n m])
(n 5)))
;; fails, missing super method for inherit
(check-err
(class: (class: object% (super-new)) (super-new) (inherit z)))
;; fails, bad argument type to inherited method
(check-err
(class: (class: object% (super-new)
(: m (Integer -> Integer))
(define/public (m x) (add1 x)))
(super-new)
(inherit m)
(m "foo")))
;; test different internal/external names ;; test different internal/external names
(check-ok (check-ok
(define c% (class: object% (super-new) (define c% (class: object% (super-new)