From d8a303983024a416be66b69f060270d2b39d4bb5 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Mon, 20 May 2013 23:03:38 -0400 Subject: [PATCH] Set init arguments as optional correctly --- .../typed-racket/base-env/class-prims.rkt | 41 +++++++++++++++---- .../typecheck/check-class-unit.rkt | 39 +++++++++++++++--- .../typed-racket/unit-tests/class-tests.rkt | 39 ++++++++++++++---- 3 files changed, 98 insertions(+), 21 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt index 8c1f897be3..2f26550ad1 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt @@ -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 -> Listof + ;; 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 diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt index 481c79a7a0..d312448cb8 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt @@ -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 Dict +;; infer-self-type : Dict Set Dict ;; Set * 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 Set 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 Set -> Void ;; check that the actual names don't include names not in the ;; expected type (i.e., the names must exactly match up) diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt index 8fb6f67866..eb6f24aa26 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt @@ -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)