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

Set init arguments as optional correctly

Browse Source
This commit is contained in:
Asumu Takikawa 2013-05-20 23:03:38 -04:00
parent f895e3156f
commit d8a3039830
3 changed files with 98 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -24,12 +24,16 @@
(provide ;; Typed class macro that coordinates with TR
class:
;; for use in ~literal clauses
class:-internal)
class:-internal
optional-init)
;; give it a binding, but it shouldn't be used directly
(define-syntax (class:-internal stx)
(raise-syntax-error "should only be used internally"))
(define-syntax (optional-init stx)
(raise-syntax-error "should only be used internally"))
(begin-for-syntax
(module+ test (require rackunit))
@ -180,13 +184,15 @@
[_ stx]))
(module+ test
;; equal? check but considers stx pair equality
;; equal? check but considers id & stx pair equality
(define (equal?/id x y)
(if (and (syntax? x) (syntax? y))
(and (free-identifier=? (stx-car x) (stx-car y))
(free-identifier=? (stx-car (stx-cdr x))
(stx-car (stx-cdr y))))
(equal?/recur x y equal?/id)))
(cond [(and (identifier? x) (identifier? y))
(free-identifier=? x y)]
[(and (syntax? x) (syntax? y))
(and (free-identifier=? (stx-car x) (stx-car y))
(free-identifier=? (stx-car (stx-cdr x))
(stx-car (stx-cdr y))))]
(equal?/recur x y equal?/id)))
;; utility macro for checking if a syntax matches a
;; given syntax class
@ -238,6 +244,7 @@
(process-class-contents others name-dict))
(define annotated-super
(syntax-property #'super 'tr:class:super #t))
(define optional-inits (get-optional-inits clauses))
(syntax-property
(syntax-property
#`(let-values ()
@ -247,6 +254,7 @@
#`(class:-internal
(init #,@(dict-ref name-dict #'init '()))
(init-field #,@(dict-ref name-dict #'init-field '()))
(optional-init #,@optional-inits)
(field #,@(dict-ref name-dict #'field '()))
(public #,@(dict-ref name-dict #'public '()))
(override #,@(dict-ref name-dict #'override '()))
@ -293,6 +301,25 @@
(non-clause (syntax-property stx 'tr:class:super-new #t)))
(values methods (append rest-top (list new-non-clause)))]
[_ (values methods (append rest-top (list content)))])))
;; get-optional-inits : Listof<Clause> -> Listof<Id>
;; Get a list of the internal names of mandatory inits
(define (get-optional-inits clauses)
(flatten
(for/list ([clause clauses]
#:when (init-clause? clause))
(for/list ([id-pair (stx->list (clause-ids clause))]
[optional? (init-clause-optional? clause)]
#:when optional?)
(stx-car id-pair)))))
(module+ test
(check-equal?/id
(get-optional-inits
(list (init-clause #'(init [x 0]) #'init #'([x x]) (list #t))
(init-clause #'(init [(a b)]) #'init #'([a b]) (list #f))))
(list #'x)))
;; This is a neat/horrible trick
;;
;; In order to detect the mappings that class-internal.rkt has

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

@ -34,12 +34,13 @@
(define-syntax-class internal-class-data
#:literals (#%plain-app quote-syntax class:-internal begin
values c:init c:init-field c:field
values c:init c:init-field optional-init c:field
c:public c:override c:private)
(pattern (begin (quote-syntax
(class:-internal
(c:init init-names:name-pair ...)
(c:init-field init-field-names:name-pair ...)
(optional-init optional-names:id ...)
(c:field field-names:name-pair ...)
(c:public public-names:name-pair ...)
(c:override override-names:name-pair ...)
@ -49,6 +50,7 @@
#:with init-externals #'(init-names.external ...)
#:with init-field-internals #'(init-field-names.internal ...)
#:with init-field-externals #'(init-field-names.external ...)
#:with optional-inits #'(optional-names ...)
#:with field-internals #'(field-names.internal ...)
#:with field-externals #'(field-names.external ...)
#:with public-internals #'(public-names.internal ...)
@ -111,6 +113,7 @@
;; 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)))
@ -170,6 +173,7 @@
(if self-class-type
(make-Instance self-class-type)
(infer-self-type internals-table
optional-inits
internal-external-mapping
this%-init-internals
this%-field-internals
@ -182,6 +186,11 @@
(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))
;; FIXME: these three should probably be `check-same`
(check-exists (set-union this%-init-names super-init-names)
exp-init-names
"initialization argument")
@ -190,7 +199,9 @@
"public method")
(check-exists (set-union this%-field-names super-field-names)
exp-field-names
"public field"))
"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")
@ -416,11 +427,12 @@
table)]
[_ table])))
;; infer-self-type : Dict<Symbol, Type> Dict<Symbol, Symbol>
;; infer-self-type : Dict<Symbol, Type> Set<Symbol> Dict<Symbol, Symbol>
;; Set<Symbol> * 3 -> Type
;; Construct a self object type based on the registered types
;; from : inside the class body.
(define (infer-self-type internals-table internal-external-mapping
(define (infer-self-type internals-table optional-inits
internal-external-mapping
inits fields publics)
(define (make-type-dict names [inits? #f])
(for/fold ([type-dict '()])
@ -431,7 +443,9 @@
(define entry
;; FIXME: this should record the correct optional
;; boolean based on internal macro data
(if inits? (list external type #f) (list external type)))
(if inits?
(list external type (set-member? optional-inits name))
(list external type)))
(cons entry type-dict))]
[else type-dict])))
(define init-types (make-type-dict inits #t))
@ -503,6 +517,21 @@
(tc-error/expr "superclass defines conflicting ~a ~a"
msg present)))
;; Set<Symbol> Set<Symbol> String -> Void
;; check that the names are exactly the same as expected
(define (check-same actual expected msg)
(define missing
(for/or ([m (in-set expected)])
(and (not (set-member? actual m)) m)))
(when missing
(tc-error/expr "class definition missing ~a ~a" msg missing))
(define too-many
(for/or ([m (in-set actual)])
(and (not (set-member? expected m)) m)))
(when too-many
(tc-error/expr "class definition has unexpected ~a ~a"
msg too-many)))
;; check-no-extra : Set<Symbol> Set<Symbol> -> Void
;; check that the actual names don't include names not in the
;; expected type (i.e., the names must exactly match up)

39
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])
(: c% (Class (init [x Integer #:optional])
[m (Integer -> Integer)]))
(define c%
(class: object%
@ -45,7 +45,7 @@
;; Fails, bad superclass expression
(check-err
(: d% (Class (init [x Integer])
(: d% (Class (init [x Integer #:optional])
[m (Integer -> Integer)]))
(define d% (class: 5
(super-new)
@ -54,7 +54,7 @@
;; Method using argument type
(check-ok
(: e% (Class (init [x Integer])
(: e% (Class (init [x Integer #:optional])
[m (Integer -> Integer)]))
(define e% (class: object%
(super-new)
@ -63,7 +63,7 @@
;; Send inside a method
(check-ok
(: f% (Class (init [x Integer])
(: f% (Class (init [x Integer #:optional])
[m (Integer -> Integer)]))
(define f% (class: object%
(super-new)
@ -72,7 +72,7 @@
;; Fails, send to missing method
(check-err
(: g% (Class (init [x Integer])
(: g% (Class (init [x Integer #:optional])
[m (Integer -> Integer)]))
(define g% (class: object%
(super-new)
@ -239,24 +239,24 @@
;; check a good super-new call
(check-ok
(: c% (Class (init [x Integer])))
(: c% (Class (init [x Integer #:optional])))
(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])))
(: c% (Class (init [x Integer #:optional])))
(define c% (class: object% (init x))))
;; fails, non-top-level super-new
(check-err
(: c% (Class (init [x Integer])))
(: c% (Class (init [x Integer #:optional])))
(define c% (class: object% (let () (super-new)) (init x))))
;; fails, bad super-new argument
(check-err
(: c% (Class (init [x Integer])))
(: c% (Class (init [x Integer #:optional])))
(define c% (class: object% (super-new) (init x)))
(: d% (Class))
(define d% (class: c% (super-new [x "bad"]))))
@ -317,6 +317,27 @@
(define/public (m y) 0)
(+ "foo" 5))))
;; test optional init arg
(check-ok
(: c% (Class (init [x Integer #:optional])))
(define c% (class: object% (super-new)
(: x Integer)
(init [x 0]))))
;; fails, expected mandatory but got optional
(check-err
(: c% (Class (init [x Integer])))
(define c% (class: object% (super-new)
(: x Integer)
(init [x 0]))))
;; fails, mandatory init not provided
(check-err
(define d% (class: object% (super-new)
(: x Integer)
(init x)))
(new d%))
;; test different internal/external names
(check-ok
(define c% (class: object% (super-new)