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

Add support for in-line class polymorphism

Browse Source
This commit is contained in:
Asumu Takikawa 2013-08-14 17:46:00 -04:00
parent 3c044e23fd
commit 37c1730bb3
3 changed files with 80 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -104,6 +104,14 @@
;; class clauses such as init or field.
(struct non-clause (stx))
(define-splicing-syntax-class maybe-type-parameter
(pattern (~seq #:forall type-variable:id)
#:attr type-variables #'(type-variable))
(pattern (~seq #:forall (type-variable:id ...))
#:attr type-variables #'(type-variable ...))
(pattern (~seq)
#:attr type-variables #'()))
(define-syntax-class init-decl
#:attributes (optional? ids type form)
(pattern id:id
@ -278,7 +286,7 @@
(define-syntax (class stx)
(syntax-parse stx
[(_ super e ...)
[(_ super forall:maybe-type-parameter e ...)
(define class-context (generate-class-expand-context))
(define (class-expand stx)
(local-expand stx class-context stop-forms))
@ -305,6 +313,7 @@
;; FIXME: maybe put this in a macro and/or a syntax class
;; so that it's easier to deal with
#`(class-internal
(#:forall #,@(attribute forall.type-variables))
(init #,@(dict-ref name-dict #'init '()))
(init-field #,@(dict-ref name-dict #'init-field '()))
(optional-init #,@optional-inits)

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

@ -16,7 +16,7 @@
(prefix-in c: racket/class)
(private parse-type syntax-properties type-annotation)
(base-env class-prims)
(env lexical-env)
(env lexical-env tvar-env)
(types utils abbrev union subtype resolve)
(typecheck check-below internal-forms)
(utils tc-utils)
@ -40,6 +40,7 @@
private-field c:augment c:pubment)
(pattern (begin (quote-syntax
(class-internal
(#:forall type-parameter:id ...)
(c:init init-names:name-pair ...)
(c:init-field init-field-names:name-pair ...)
(optional-init optional-names:id ...)
@ -53,6 +54,7 @@
(c:augment augment-names:name-pair ...)
(c:pubment pubment-names:name-pair ...)))
(#%plain-app values))
#:with type-parameters #'(type-parameter ...)
#:with init-internals #'(init-names.internal ...)
#:with init-externals #'(init-names.external ...)
#:with init-field-internals #'(init-field-names.internal ...)
@ -123,6 +125,7 @@
(define-syntax-class class-expansion
#:literals (let-values letrec-syntaxes+values #%plain-app)
#:attributes (superclass-expr
type-parameters
init-internals init-externals
init-field-internals init-field-externals
optional-inits
@ -166,6 +169,7 @@
[(tc-result1: (and self-class-type (Class: _ _ _ _ _)))
(parse-and-check form self-class-type)]
[(tc-result1: (Poly-names: ns body-type))
;; FIXME: this case probably isn't quite right
(check-class form (ret body-type))]
[#f (parse-and-check form #f)]
[_ (check-below (parse-and-check form #f) expected)]))
@ -184,8 +188,12 @@
;; as a sanity check too
(define super-type (tc-expr #'cls.superclass-expr))
;; Save parse attributes to pass through to helper functions
(define type-parameters (syntax->datum #'cls.type-parameters))
(define fresh-parameters (map gensym type-parameters))
(define parse-info
(hash 'superclass-expr #'cls.superclass-expr
(hash 'type-parameters type-parameters
'fresh-parameters fresh-parameters
'superclass-expr #'cls.superclass-expr
'make-methods #'cls.make-methods
'initializer-self-id #'cls.initializer-self-id
'initializer-args-id #'cls.initializer-args-id
@ -256,7 +264,8 @@
(syntax->datum #'cls.inherit-field-externals)
(syntax->datum #'cls.pubment-externals)
(syntax->datum #'cls.augment-externals))))
(do-check expected super-type parse-info)]))
(extend-tvars/new type-parameters fresh-parameters
(do-check expected super-type parse-info))]))
;; do-check : Type Type Dict -> Type
;; The actual type-checking
@ -403,7 +412,12 @@
super-augment-names)
(when expected
(check-below final-class-type expected))
final-class-type)
(define class-type-parameters (hash-ref parse-info 'type-parameters))
(if (null? class-type-parameters)
final-class-type
(make-Poly #:original-names class-type-parameters
(hash-ref parse-info 'fresh-parameters)
final-class-type)))
;; check-method-presence-and-absence : Dict Type Set<Symbol> ... -> Void
;; use the internal class: information to check whether clauses

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

@ -1059,6 +1059,58 @@
(init-field x)
(set! x 5))))
;; test polymorphism with keyword
(check-ok
(define point%
(class object%
#:forall X
(super-new)
(init-field [x : X] [y : X])))
(new (inst point% Integer) [x 0] [y 5])
(new (inst point% String) [x "foo"] [y "bar"]))
;; test polymorphism with two type parameters
(check-ok
(define point%
(class object%
#:forall (X Y)
(super-new)
(init-field [x : X] [y : Y])))
(new (inst point% Integer String) [x 0] [y "foo"])
(new (inst point% String Integer) [x "foo"] [y 3]))
;; test class polymorphism with method
(check-ok
(define id%
(class object%
#:forall (X)
(super-new)
(: m (X -> X))
(define/public (m x) x)))
(send (new (inst id% Integer)) m 0))
;; fails because m is not parametric
(check-err #:exn #rx"Expected X.*, but got String"
(class object%
#:forall (X)
(super-new)
(: m (X -> X))
(define/public (m x) (string-append x))))
;; fails because default init value cannot be polymorphic
(check-err #:exn #rx"Default init value has wrong type"
(class object%
#:forall Z
(super-new)
(init-field [x : Z] [y : Z 0])))
;; fails because default field value cannot be polymorphic
(check-err #:exn #rx"Expected Z.*, but got Zero"
(class object%
#:forall Z
(super-new)
(field [x : Z 0])))
;; test in-clause type annotations (next several tests)
(check-ok
(define c%