From 18182d16a615f5ecf7bed5428374010f609bb59e Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Wed, 29 Jan 2014 19:20:56 -0500 Subject: [PATCH] Add support for positional init arguments for TR This includes support for positional inits and also init-rest along with make-object and instantiate. --- .../typed-racket/base-env/class-prims.rkt | 21 +- .../typed-racket/env/init-envs.rkt | 5 +- .../typed-racket/private/parse-type.rkt | 9 +- .../typed-racket/private/type-contract.rkt | 4 +- .../typed-racket/rep/type-rep.rkt | 45 ++-- .../typecheck/check-class-unit.rkt | 218 +++++++++++++----- .../typecheck/tc-app/tc-app-objects.rkt | 73 ++++-- .../typed-racket/typecheck/tc-send.rkt | 2 +- .../typed-racket/types/abbrev.rkt | 3 +- .../typed-racket/types/classes.rkt | 30 ++- .../typed-racket/types/printer.rkt | 8 +- .../typed-racket/types/subtype.rkt | 11 +- .../unit-tests/typecheck-tests.rkt | 67 +++++- 13 files changed, 367 insertions(+), 129 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 84c8e846a8..87b4cf7f66 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 @@ -49,8 +49,7 @@ ;; forms that are not allowed by Typed Racket yet (define unsupported-forms - (list (quote-syntax init-rest) - (quote-syntax augride) + (list (quote-syntax augride) ;; FIXME: see if override contracts are enough ;; to keep these at bay or whether they ;; need to be handled @@ -75,6 +74,7 @@ (quote-syntax init) (quote-syntax field) (quote-syntax init-field) + (quote-syntax init-rest) (quote-syntax inherit-field) (quote-syntax private) (quote-syntax public) @@ -190,6 +190,11 @@ (stx->list #'(names.ids ...)) (attribute names.type) (attribute names.optional?))) + (pattern ((~literal init-rest) name:private-decl) + #:attr data (clause #'(init-rest name.form) + #'init-rest + (stx->list #'(name.id)) + (list (attribute name.type)))) (pattern ((~literal field) names:field-decl ...) #:attr data (clause #'(field names.form ...) #'field @@ -362,6 +367,7 @@ (#:forall #,@(attribute forall.type-variables)) (init #,@(dict-ref name-dict #'init '())) (init-field #,@(dict-ref name-dict #'init-field '())) + (init-rest #,@(dict-ref name-dict #'init-rest '())) (optional-init #,@optional-inits) (field #,@(dict-ref name-dict #'field '())) (public #,@(dict-ref name-dict #'public '())) @@ -406,7 +412,8 @@ ([content contents]) (define stx (non-clause-stx content)) (syntax-parse stx - #:literals (: define-values super-new) + #:literals (: define-values super-new + super-make-object super-instantiate) ;; if it's a method definition for a declared method, then ;; mark it as something to type-check [(define-values (id) . rst) @@ -447,7 +454,9 @@ (append rest-top (list plain-annotation)) private-fields)] ;; Identify super-new for the benefit of the type checker - [(super-new [init-id init-expr] ...) + [(~or (super-new [init-id init-expr] ...) + (super-make-object init-expr ...) + (super-instantiate (init-expr ...) [name expr] ...)) (define new-non-clause (non-clause (syntax-property stx 'tr:class:super-new #t))) (values methods (append rest-top (list new-non-clause)) @@ -504,6 +513,7 @@ (stx-map stx-car (dict-ref name-dict #'init-field '())))) (define init-names (stx-map stx-car (dict-ref name-dict #'init '()))) + (define init-rest-name (dict-ref name-dict #'init-rest '())) (define inherit-names (stx-map stx-car (dict-ref name-dict #'inherit '()))) (define inherit-field-names @@ -530,6 +540,9 @@ [(#,@init-names) (values #,@(map (λ (stx) #`(λ () #,stx)) init-names))] + [(#,@init-rest-name) + (values #,@(map (λ (stx) #`(λ () #,stx)) + init-rest-name))] [(#,@inherit-names) (values #,@(map (λ (stx) #`(λ () (#,stx))) inherit-names))] diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/init-envs.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/init-envs.rkt index b235084af0..2908c82fb5 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/init-envs.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/init-envs.rkt @@ -93,7 +93,7 @@ [(PolyDots-names: ns b) `(make-PolyDots (list ,@(map sub ns)) ,(sub b))] [(PolyRow-names: ns c b) `(make-PolyRow (list ,@(map sub ns)) (quote ,c) ,(sub b))] - [(Class: row inits fields methods augments) + [(Class: row inits fields methods augments init-rest) (cond [(and (current-class-cache) (dict-ref (unbox (current-class-cache)) v #f)) => car] [else @@ -108,7 +108,8 @@ (list ,@(convert inits #t)) (list ,@(convert fields)) (list ,@(convert methods)) - (list ,@(convert augments)))) + (list ,@(convert augments)) + ,(sub init-rest))) (define name (gensym)) (define cache-box (current-class-cache)) (when cache-box diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt index 042a71ad39..1f6d0e398a 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt @@ -589,7 +589,7 @@ (define parent-type (parse-type stx)) (define (match-parent-type parent-type) (match parent-type - [(Class: row-var _ fields methods augments) + [(Class: row-var _ fields methods augments _) (values row-var fields methods augments)] [(? Mu?) (match-parent-type (unfold parent-type))] @@ -662,7 +662,7 @@ (stx-map syntax-e #'clause.method-names) (stx-map parse-type #'clause.method-types))) (check-function-types methods) - (make-Instance (make-Class #f null fields methods null))])) + (make-Instance (make-Class #f null fields methods null #f))])) ;; Syntax -> Type ;; Parse a (Class ...) type @@ -679,6 +679,9 @@ (define given-row-var (and (attribute clause.row-var) (parse-type (attribute clause.row-var)))) + (define given-init-rest + (and (attribute clause.init-rest) + (parse-type (attribute clause.init-rest)))) (check-function-types given-methods) (check-function-types given-augments) @@ -702,7 +705,7 @@ (check-constraints augments (cadddr constraints))) (define class-type - (make-Class row-var given-inits fields methods augments)) + (make-Class row-var given-inits fields methods augments given-init-rest)) class-type])) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt index f79de467d7..65bc6b69f5 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt @@ -289,14 +289,14 @@ (recursive-sc-use (if (from-typed? typed-side) typed-n* untyped-n*)))])] [(Instance: (? Mu? t)) (t->sc (make-Instance (resolve-once t)))] - [(Instance: (Class: _ _ fields methods _)) + [(Instance: (Class: _ _ fields methods _ _)) (match-define (list (list field-names field-types) ...) fields) (match-define (list (list public-names public-types) ...) methods) (object/sc (append (map (λ (n sc) (member-spec 'method n sc)) public-names (map t->sc/method public-types)) (map (λ (n sc) (member-spec 'field n sc)) field-names (map t->sc/both field-types))))] - [(Class: _ inits fields publics augments) + [(Class: _ inits fields publics augments _) (match-define (list (list init-names init-types _) ...) inits) (match-define (list (list field-names field-types) ...) fields) (match-define (list (list public-names public-types) ...) publics) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/rep/type-rep.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/rep/type-rep.rkt index 5c721e2184..0a2323420b 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/rep/type-rep.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/rep/type-rep.rkt @@ -465,19 +465,22 @@ (def-type Row ([inits (listof (list/c symbol? Type/c boolean?))] [fields (listof (list/c symbol? Type/c))] [methods (listof (list/c symbol? Function?))] - [augments (listof (list/c symbol? Function?))]) + [augments (listof (list/c symbol? Function?))] + [init-rest (or/c Type/c #f)]) #:no-provide [#:frees (λ (f) (combine-frees (map f (append (map cadr inits) (map cadr fields) (map cadr methods) - (map cadr augments)))))] - [#:fold-rhs (match (list inits fields methods augments) + (map cadr augments) + (if init-rest (list init-rest) null)))))] + [#:fold-rhs (match (list inits fields methods augments init-rest) [(list (list (list init-names init-tys reqd) ___) (list (list fname fty) ___) (list (list mname mty) ___) - (list (list aname aty) ___)) + (list (list aname aty) ___) + init-rest) (*Row (map list init-names @@ -485,7 +488,8 @@ reqd) (map list fname (map type-rec-id fty)) (map list mname (map type-rec-id mty)) - (map list aname (map type-rec-id aty)))])]) + (map list aname (map type-rec-id aty)) + (if init-rest (type-rec-id init-rest) #f))])]) ;; Supertype of all Class types, cannot instantiate ;; or subclass these @@ -916,23 +920,25 @@ ;; Row* ;; This is a custom constructor for Row types ;; Sorts all clauses by the key (the clause name) -(define (Row* inits fields methods augments) - (*Row (sort-row-clauses inits) +(define (Row* inits fields methods augments init-rest) + (*Row inits (sort-row-clauses fields) (sort-row-clauses methods) - (sort-row-clauses augments))) + (sort-row-clauses augments) + init-rest)) ;; Class* ;; This is a custom constructor for Class types that ;; doesn't require writing make-Row everywhere -(define/cond-contract (Class* row-var inits fields methods augments) +(define/cond-contract (Class* row-var inits fields methods augments init-rest) (-> (or/c F? B? Row? #f) (listof (list/c symbol? Type/c boolean?)) (listof (list/c symbol? Type/c)) (listof (list/c symbol? Function?)) (listof (list/c symbol? Function?)) + (or/c Type/c #f) Class?) - (*Class row-var (Row* inits fields methods augments))) + (*Class row-var (Row* inits fields methods augments init-rest))) ;; Class:* ;; This match expander replaces the built-in matching with @@ -948,20 +954,29 @@ (define fields (Row-fields class-row)) (define methods (Row-methods class-row)) (define augments (Row-augments class-row)) + (define init-rest (Row-init-rest class-row)) (cond [(and row (Row? row)) (define row-inits (Row-inits row)) (define row-fields (Row-fields row)) (define row-methods (Row-methods row)) (define row-augments (Row-augments row)) + (define row-init-rest (Row-init-rest row)) (list row + ;; Init types from a mixin go at the start, since + ;; mixins only add inits at the start + (append row-inits inits) ;; FIXME: instead of sorting here every time ;; the match expander is called, the row ;; fields should be merged on substitution - (sort-row-clauses (append inits row-inits)) (sort-row-clauses (append fields row-fields)) (sort-row-clauses (append methods row-methods)) - (sort-row-clauses (append augments row-augments)))] - [else (list row inits fields methods augments)])) + (sort-row-clauses (append augments row-augments)) + ;; The class type's existing init-rest types takes + ;; precedence since it's the one that was already assumed + ;; (say, in a mixin type's domain). The mismatch will + ;; be caught by application type-checking later. + (if init-rest init-rest row-init-rest))] + [else (list row inits fields methods augments init-rest)])) ;; sorts the given field of a Row by the member name (define (sort-row-clauses clauses) @@ -970,9 +985,9 @@ (define-match-expander Class:* (λ (stx) (syntax-case stx () - [(_ row-pat inits-pat fields-pat methods-pat augments-pat) + [(_ row-pat inits-pat fields-pat methods-pat augments-pat init-rest-pat) #'(? Class? (app merge-class/row (list row-pat inits-pat fields-pat - methods-pat augments-pat)))]))) + methods-pat augments-pat init-rest-pat)))]))) 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 edb2d807e4..15e9fbe9b8 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 @@ -5,6 +5,7 @@ (require "../utils/utils.rkt" racket/dict racket/format + racket/list racket/match racket/pretty ;; DEBUG ONLY racket/set @@ -58,7 +59,7 @@ (define-syntax-class internal-class-data #:literals (#%plain-app quote-syntax class-internal begin - values c:init c:init-field optional-init c:field + values c:init c:init-field c:init-rest optional-init c:field c:public c:override c:private c:inherit c:inherit-field private-field c:augment c:pubment) (pattern (begin (quote-syntax @@ -66,6 +67,7 @@ (#:forall type-parameter:id ...) (c:init init-names:name-pair ...) (c:init-field init-field-names:name-pair ...) + (c:init-rest (~optional init-rest-name:id)) (optional-init optional-names:id ...) (c:field field-names:name-pair ...) (c:public public-names:name-pair ...) @@ -151,6 +153,7 @@ type-parameters init-internals init-externals init-field-internals init-field-externals + init-rest-name optional-inits field-internals field-externals public-internals public-externals @@ -189,7 +192,7 @@ ;; class produced by `class` due to the syntax property (define (check-class form [expected #f]) (match (and expected (resolve expected)) - [(tc-result1: (and self-class-type (Class: _ _ _ _ _))) + [(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 @@ -227,6 +230,8 @@ 'init-internals (set-union (syntax->datum #'cls.init-internals) (syntax->datum #'cls.init-field-internals)) + 'init-rest-name (and (attribute cls.init-rest-name) + (syntax-e (attribute cls.init-rest-name))) 'public-internals (syntax->datum #'cls.public-internals) 'override-internals (syntax->datum #'cls.override-internals) 'pubment-internals (syntax->datum #'cls.pubment-internals) @@ -297,12 +302,12 @@ (define (do-check expected super-type parse-info) ;; unpack superclass names and types (define-values (super-row super-inits super-fields - super-methods super-augments) + super-methods super-augments super-init-rest) (match super-type [(tc-result1: (Class: super-row super-inits super-fields - super-methods super-augments)) + super-methods super-augments super-init-rest)) (values super-row super-inits super-fields - super-methods super-augments)] + super-methods super-augments super-init-rest)] [(tc-result1: t) (tc-error/expr "expected a superclass but got value of type ~a" t #:stx (hash-ref parse-info 'superclass-expr)) @@ -333,15 +338,31 @@ (define super-new-stxs (trawl-for-property make-methods-stx 'tr:class:super-new)) (define super-new-stx (check-super-new-exists super-new-stxs)) - (define provided-super-inits + (define-values (provided-pos-args provided-super-inits) (if super-new-stx (find-provided-inits super-new-stx super-inits) - '())) + (values null null))) (define provided-init-names (dict-keys provided-super-inits)) - (define remaining-super-inits - (for/list ([(name val) (in-dict super-inits)] - #:unless (member name provided-init-names)) - (cons name val))) + (define pos-length (length provided-pos-args)) + ;; super-init-rest* - The init-rest passed to the `infer-self-type` function. + ;; This reflects any changes to the `super-init-rest` type + ;; that are necessary due to the super constructor call in + ;; this class. + (define-values (super-init-rest* remaining-super-inits) + (cond [;; too many init arguments, and no init-rest + (and (not super-init-rest) (> pos-length (length super-inits))) + (values super-init-rest + (tc-error/expr "too many positional init arguments provided" + #:return null))] + [;; no remaining by-name inits, so change the init-rest type + ;; and return a null remaining named inits list + (> pos-length (length super-inits)) + (values (Un) null)] + [else + (values super-init-rest + (for/list ([(name val) (in-dict (drop super-inits pos-length))] + #:unless (member name provided-init-names)) + (cons name val)))])) ;; define which init names are optional (define optional-inits (hash-ref parse-info 'optional-inits)) (define optional-external (for/set ([n optional-inits]) @@ -362,8 +383,9 @@ remaining-super-inits super-fields super-methods - super-augments)) - (match-define (Instance: (Class: _ inits fields methods augments)) + super-augments + super-init-rest*)) + (match-define (Instance: (Class: _ inits fields methods augments init-rest)) self-type) (do-timestamp "built self type") ;; trawl the body for the local name table @@ -371,6 +393,7 @@ (trawl-for-property make-methods-stx 'tr:class:local-table)) (define-values (local-method-table local-private-table local-field-table local-private-field-table local-init-table + local-init-rest-table local-inherit-table local-inherit-field-table local-super-table local-augment-table local-inner-table) @@ -393,6 +416,7 @@ local-field-table fields local-private-field-table private-field-types local-init-table inits + local-init-rest-table init-rest local-inherit-table local-inherit-field-table local-super-table @@ -403,7 +427,8 @@ self-type)) (do-timestamp "built local tables") (with-lexical-env/extend lexical-names/top-level lexical-types/top-level - (check-super-new provided-super-inits super-inits)) + (check-super-new provided-pos-args provided-super-inits + super-inits super-init-rest)) (do-timestamp "checked super-new") (with-lexical-env/extend lexical-names/top-level lexical-types/top-level (for ([stx top-level-exprs] @@ -467,7 +492,7 @@ remaining-super-inits super-field-names super-method-names super-augment-names) (when expected - (match-define (Class: _ inits fields methods augments) expected) + (match-define (Class: _ inits fields methods augments _) expected) (define exp-init-names (dict-keys inits)) (define exp-field-names (dict-keys fields)) (define exp-method-names (dict-keys methods)) @@ -519,7 +544,7 @@ (match-define (Instance: (and class-type - (Class: row-var inits fields methods augments))) + (Class: row-var inits fields methods augments init-rest))) self-type) (define (make-new-methods methods method-types) (for/fold ([methods methods]) @@ -535,7 +560,8 @@ (dict-set methods name type))) (make-Class row-var inits fields (make-new-methods methods method-types) - (make-new-methods augments augment-types))) + (make-new-methods augments augment-types) + init-rest)) ;; local-tables->lexical-env : Dict Dict ;; LocalMapping NameTypeDict @@ -551,6 +577,7 @@ local-private-field-table private-field-types local-init-table inits + local-init-rest-table init-rest local-inherit-table local-inherit-field-table local-super-table @@ -687,6 +714,17 @@ (define external (dict-ref internal-external-mapping i)) (car (dict-ref inits external (list -Bottom))))) + (define localized-init-rest-name + (let ([name (hash-ref parse-info 'init-rest-name)]) + (if name + (list (dict-ref local-init-rest-table name)) + null))) + + (define init-rest-type + (if (hash-ref parse-info 'init-rest-name) + (list (or init-rest Univ)) + null)) + (define all-names (append localized-method-names localized-private-methods localized-field-get-names @@ -713,6 +751,7 @@ ;; from top-level environment to avoid (append all-names localized-init-names + localized-init-rest-name ;; Set `self` to the self-type and `init-args` ;; to Any, so that accessors can use them without ;; problems. @@ -721,6 +760,7 @@ (hash-ref parse-info 'initializer-args-id))) (append all-types init-types + init-rest-type (list self-type (make-Univ))))) ;; check-methods : Listof Listof Dict Dict Type @@ -898,6 +938,8 @@ ...)] [(init:id ...) (#%plain-app values (#%plain-lambda () local-init:id) ...)] + [(init-rest:id ...) + (#%plain-app values (#%plain-lambda () local-init-rest:id) ...)] [(inherit:id ...) (#%plain-app values @@ -940,6 +982,10 @@ (map cons (syntax->datum #'(init ...)) (syntax->list #'(local-init ...))) + ;; this should only be a singleton list or null + (map cons + (syntax->datum #'(init-rest ...)) + (syntax->list #'(local-init-rest ...))) (map cons (syntax->datum #'(inherit ...)) (syntax->list #'(local-inherit ...))) @@ -971,12 +1017,19 @@ #f] [else (car stxs)])) -;; find-provided-inits : Syntax Inits -> Dict +;; find-provided-inits : Syntax Inits -> Listof Dict ;; Find the init arguments that were provided via super-new (define (find-provided-inits stx super-inits) (syntax-parse stx #:literals (#%plain-app list cons quote) - [(#%plain-app super-go _ _ _ _ _ + [(#%plain-app + (#%plain-lambda args + (#%plain-app super-go _ _ _ _ _ _)) + pos-arg:expr ...) + (values (syntax->list #'(pos-arg ...)) null)] + [(#%plain-app super-go _ _ _ _ + (~or (#%plain-app list pos-arg:expr ...) + (~and _ (~bind [(pos-arg 1) '()]))) (#%plain-app list (#%plain-app cons (quote init-id) arg:expr) @@ -986,17 +1039,40 @@ (unless (dict-ref super-inits name #f) (tc-error/expr "super-new: init argument ~a not accepted by superclass" name))) - (map cons provided-inits (syntax->list #'(arg ...)))])) + (values + (syntax->list #'(pos-arg ...)) + (map cons provided-inits (syntax->list #'(arg ...))))])) -;; check-super-new : Dict Dict -> Void +;; check-super-new : Listof Dict +;; Dict Type -> Void ;; Check if the super-new call is well-typed -(define (check-super-new provided-inits super-inits) - (for ([(init-id init-arg) (in-dict provided-inits)]) - (define maybe-expected (dict-ref super-inits init-id #f)) - (if maybe-expected - (tc-expr/check init-arg (ret (car maybe-expected))) - (tc-error/expr "init argument ~a not accepted by superclass" - init-id)))) +(define (check-super-new provided-pos-args provided-inits super-inits init-rest) + (define pos-init-diff (- (length provided-pos-args) (length super-inits))) + (cond [(and (> pos-init-diff 0) (not init-rest)) + ;; errror case that's caught above, do nothing + (void)] + [(> pos-init-diff 0) + (define-values (pos-args for-init-rest) + (split-at provided-pos-args (length super-inits))) + (for ([pos-arg pos-args] + [init super-inits]) + (match-define (list _ type _) init) + (tc-expr/check pos-arg (ret type))) + (tc-expr/check #`(#%plain-app list #,@for-init-rest) + (ret init-rest))] + [else + (define-values (pos-inits remaining-inits) + (split-at super-inits (length provided-pos-args))) + (for ([pos-arg provided-pos-args] + [init pos-inits]) + (match-define (list _ type _) init) + (tc-expr/check pos-arg (ret type))) + (for ([(init-id init-arg) (in-dict provided-inits)]) + (define maybe-expected (dict-ref remaining-inits init-id #f)) + (if maybe-expected + (tc-expr/check init-arg (ret (car maybe-expected))) + (tc-error/expr "init argument ~a not accepted by superclass" + init-id)))])) ;; Syntax -> Listof ;; Look through the expansion of the class macro in search for @@ -1079,7 +1155,7 @@ ;; infer-self-type : Dict RowVar Class Dict Dict ;; Set Dict -;; Inits Fields Methods +;; Inits Fields Methods Type ;; -> Type ;; Construct a self object type based on all type annotations ;; and the expected type @@ -1090,52 +1166,74 @@ optional-inits internal-external-mapping super-inits super-fields super-methods - super-augments) - (define (make-type-dict names supers maybe-expected - #:inits [inits? #f] - #:annotations-from [annotation-table annotation-table] - #:default-type [default-type Univ]) + super-augments super-init-rest) + ;; Gets a type for a given name in the class. + ;; A type is assigned for each member in this order: + ;; (1) a type annotation from the user + ;; (2) the expected type + ;; (3) Any or Procedure + (define (assign-type name expected annotation-table update default-type) + (cond [(dict-ref annotation-table name #f) => update] + [(and expected (dict-ref expected name #f)) + => (compose update car)] + [default-type => update])) + + ;; construct the new init type dict + (define (make-inits names supers expected) + (define-values (inits new-inits) + (for/fold ([type-dict supers] [new-entries '()]) + ([name names]) + (define external (dict-ref internal-external-mapping name)) + (define (update-dict type) + (define entry (list type (set-member? optional-inits name))) + ;; new entries have to go on the front, so sort them separately + (if (dict-has-key? type-dict external) + (values (dict-set type-dict external entry) new-entries) + (values type-dict (cons (cons external entry) new-entries)))) + (assign-type name expected annotation-table update-dict Univ))) + (append (reverse new-inits) inits)) + + ;; construct type dicts for fields, methods, and augments + (define (make-type-dict names supers expected default-type + #:annotations-from [annotation-table annotation-table]) (for/fold ([type-dict supers]) ([name names]) (define external (dict-ref internal-external-mapping name)) (define (update-dict type) - (define entry - (if inits? - (list type (set-member? optional-inits name)) - (list type))) + (define entry (list type)) (dict-set type-dict external entry)) - ;; A type is assigned for each member in this order: - ;; (1) a type annotation from the user - ;; (2) the expected type - ;; (3) Any or Procedure - (cond [(dict-ref annotation-table name #f) => update-dict] - [(and maybe-expected - (dict-ref maybe-expected name #f)) - => (compose update-dict car)] - [default-type => update-dict]))) + (assign-type name expected annotation-table update-dict default-type))) + (define-values (expected-inits expected-fields - expected-publics expected-augments) + expected-publics expected-augments + expected-init-rest) (match expected - [(Class: _ inits fields publics augments) - (values inits fields publics augments)] - [_ (values #f #f #f #f)])) - (define-values (inits fields publics pubments) + [(Class: _ inits fields publics augments init-rest) + (values inits fields publics augments init-rest)] + [_ (values #f #f #f #f #f)])) + (define-values (inits fields publics pubments init-rest-name) (values (hash-ref parse-info 'init-internals) (hash-ref parse-info 'field-internals) (hash-ref parse-info 'public-internals) - (hash-ref parse-info 'pubment-internals))) - (define init-types (make-type-dict inits super-inits expected-inits - #:inits #t)) - (define field-types (make-type-dict fields super-fields expected-fields)) + (hash-ref parse-info 'pubment-internals) + (hash-ref parse-info 'init-rest-name))) + (define init-types (make-inits inits super-inits expected-inits)) + (define field-types (make-type-dict fields super-fields expected-fields Univ)) (define public-types (make-type-dict (append publics pubments) super-methods expected-publics - #:default-type top-func)) + top-func)) (define augment-types (make-type-dict - pubments super-augments expected-augments - #:default-type top-func + pubments super-augments expected-augments top-func #:annotations-from augment-annotation-table)) + ;; For the init-rest type, if the user didn't provide one, then + ;; take the superclass init-rest. Otherwise, find the annotated type + ;; or use (Listof Any) as the type if no annotation exists. + (define init-rest-type + (cond [(not init-rest-name) super-init-rest] + [(dict-ref annotation-table init-rest-name #f)] + [else (-lst Univ)])) (make-Instance (make-Class super-row init-types field-types - public-types augment-types))) + public-types augment-types init-rest-type))) ;; function->method : Function Type -> Function ;; Fix up a method's arity from a regular function type diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-objects.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-objects.rkt index 0a8bdbd3ae..a027cf5eb9 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-objects.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-objects.rkt @@ -4,12 +4,13 @@ "signatures.rkt" "utils.rkt" syntax/parse syntax/stx racket/match unstable/sequence unstable/syntax - racket/dict + racket/dict racket/list (typecheck signatures) (types resolve union utils) (rep type-rep) (utils tc-utils) + (for-template racket/base) (for-label racket/base)) @@ -26,7 +27,7 @@ (#%plain-app list . pos-args) (#%plain-app list (#%plain-app cons (quote names) named-args) ...)) #:declare dmo (id-from 'do-make-object 'racket/private/class-internal) - (check-do-make-object #'b #'cl #'(names ...) #'(named-args ...))) + (check-do-make-object #'cl #'pos-args #'(names ...) #'(named-args ...))) (pattern (dmo . args) #:declare dmo (id-from 'do-make-object 'racket/private/class-internal) (int-err "unexpected arguments to do-make-object")) @@ -40,38 +41,62 @@ ;; check-do-make-object : Syntax Syntax Listof Listof -> TCResult ;; do-make-object now takes blame as its first argument, which isn't checked ;; (it's just an s-expression) -(define (check-do-make-object b cl names named-args) +(define (check-do-make-object cl arg-stx names named-args) + (define pos-args (syntax->list arg-stx)) (define given-names (stx-map syntax-e names)) (define name-assoc (for/list ([name (in-syntax names)] [arg (in-syntax named-args)]) (list (syntax-e name) arg))) (match (resolve (tc-expr/t cl)) [(Union: '()) (ret (Un))] - [(and c (Class: _ inits fields _ _)) - (define init-names (map car inits)) - (for ([given-name given-names] - #:unless (memq given-name init-names)) - (tc-error/delayed - "unknown named argument ~a for class\nlegal named arguments are ~a" - given-name (stringify init-names))) - (for ([init inits]) - (match-define (list init-name init-type opt?) init) - ;; stx if argument was provided, #f if it was - ;; not provided (and if mandatory, it errors) - (define maybe-stx - (cond [(assq init-name name-assoc) => cadr] - [(not opt?) - (tc-error/delayed "value not provided for named init arg ~a" - init-name) - #f] - [else #f])) - (when maybe-stx - (tc-expr/check maybe-stx (ret init-type)))) + [(and c (Class: _ inits fields _ _ init-rest)) + (cond [;; too many positional arguments, fail + (and (> (length pos-args) (length inits)) (not init-rest)) + ;; FIXME: better message + (tc-error "too many positional arguments supplied")] + [;; more args than inits, now feed them to init-rest + (and (> (length pos-args) (length inits))) + (define-values (pos-for-inits other-pos) + (split-at pos-args (length inits))) + (for ([pos-arg (in-list pos-for-inits)] + [init (in-list inits)]) + (match-define (list _ type _) init) + (tc-expr/check pos-arg (ret type))) + (tc-expr/check #`(#%plain-app list #,@other-pos) (ret init-rest))] + [else ; do pos args, then named inits + (define-values (inits-for-pos other-inits) + (split-at inits (length pos-args))) + (for ([pos-arg (in-list pos-args)] + [init (in-list inits-for-pos)]) + (match-define (list _ type _) init) + (tc-expr/check pos-arg (ret type))) + (check-named-inits other-inits given-names name-assoc)]) (ret (make-Instance c))] [t (tc-error/expr #:return (ret (Un)) "expected a class value for object creation, got: ~a" t)])) +(define (check-named-inits inits names name-assoc) + (define init-names (map car inits)) + (for ([name names] + #:unless (memq name init-names)) + (tc-error/delayed + "unknown named argument ~a for class\nlegal named arguments are ~a" + name (stringify init-names))) + (for ([init inits]) + (match-define (list init-name init-type opt?) init) + ;; stx if argument was provided, #f if it was + ;; not provided (and if mandatory, it errors) + (define maybe-stx + (cond [(assq init-name name-assoc) => cadr] + [(not opt?) + (tc-error/delayed "value not provided for named init arg ~a" + init-name) + #f] + [else #f])) + (when maybe-stx + (tc-expr/check maybe-stx (ret init-type))))) + ;; check-get-field : Syntax Syntax -> TCResult ;; type-check the `get-field` operation on objects (define (check-get-field meth obj) @@ -83,7 +108,7 @@ "expected a symbolic method name, but got ~a" meth)) (match obj-type ;; FIXME: handle unions and mu? - [(tc-result1: (and ty (Instance: (Class: _ _ (list fields ...) _ _)))) + [(tc-result1: (and ty (Instance: (Class: _ _ (list fields ...) _ _ _)))) (cond [(assq maybe-meth-sym fields) => (λ (field-entry) (ret (cadr field-entry)))] [else diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-send.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-send.rkt index 0f535fdc3a..e9d5573fa5 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-send.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-send.rkt @@ -16,7 +16,7 @@ (match rcvr-type [(tc-result1: (Instance: (? Mu? type))) (do-check (ret (make-Instance (unfold type))))] - [(tc-result1: (Instance: (and c (Class: _ _ _ methods _)))) + [(tc-result1: (Instance: (and c (Class: _ _ _ methods _ _)))) (match (tc-expr method) [(tc-result1: (Value: (? symbol? s))) (let* ([ftype (cond [(assq s methods) => cadr] diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/abbrev.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/abbrev.rkt index ecb6654019..f830b7e93b 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/abbrev.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/abbrev.rkt @@ -322,7 +322,8 @@ (append ?clause.inits ...) (append ?clause.fields ...) (append ?clause.methods ...) - (append ?clause.augments ...))])) + (append ?clause.augments ...) + #f)])) (define-syntax-rule (-object . ?clauses) (make-Instance (-class . ?clauses))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/classes.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/classes.rkt index d84abfe037..dd4cd48995 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/classes.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/classes.rkt @@ -77,7 +77,7 @@ (match-define (list init-absents field-absents method-absents augment-absents) constraints) - (match-define (Row: inits fields methods augments) row) + (match-define (Row: inits fields methods augments _) row) ;; check a given clause type (e.g., init, field) (define (check-clauses row-dict absence-set) (for ([(name _) (in-dict row-dict)]) @@ -92,15 +92,21 @@ (define-splicing-syntax-class (row-clauses parse-type) #:description "Row type clause" #:attributes (row) - (pattern (~seq (~var clause (type-clause parse-type)) ...) + #:literals (init-rest) + (pattern (~seq (~or (~optional (init-rest init-rest-type:expr)) + (~var clause (type-clause parse-type))) + ...) #:attr inits (apply append (attribute clause.init-entries)) #:attr fields (apply append (attribute clause.field-entries)) #:attr methods (apply append (attribute clause.method-entries)) #:attr augments (apply append (attribute clause.augment-entries)) + #:attr init-rest (and (attribute init-rest-type) + (parse-type (attribute init-rest-type))) #:attr row (make-Row (attribute inits) (attribute fields) (attribute methods) - (attribute augments)) + (attribute augments) + (attribute init-rest)) #:fail-when (check-duplicate (map first (attribute inits))) "duplicate init or init-field clause" @@ -122,7 +128,7 @@ (type-case (#:Type inf #:Filter (sub-f inf) #:Object (sub-o inf)) type - [#:Class row inits fields methods augments + [#:Class row inits fields methods augments init-rest (cond [(and row (F? row)) (match-define (list init-cs field-cs method-cs augment-cs) @@ -132,7 +138,7 @@ (append (dict-keys fields) field-cs) (append (dict-keys methods) method-cs) (append (dict-keys augments) augment-cs))) - (make-Class row inits fields methods augments)] + (make-Class row inits fields methods augments init-rest)] [else (match-define (list (list init-names init-tys init-reqds) ...) inits) (match-define (list (list field-names field-tys) ...) fields) @@ -143,7 +149,8 @@ (map list init-names (map inf init-tys) init-reqds) (map list field-names (map inf field-tys)) (map list method-names (map inf method-tys)) - (map list augment-names (map inf augment-tys)))])])) + (map list augment-names (map inf augment-tys)) + init-rest)])])) (inf type) (map remove-duplicates constraints)) @@ -152,7 +159,7 @@ (define (infer-row constraints class-type) (match-define (list init-cs field-cs method-cs augment-cs) constraints) - (match-define (Class: _ inits fields methods augments) + (match-define (Class: _ inits fields methods augments init-rest) (resolve class-type)) (define (dict-remove* dict keys) (for/fold ([dict dict]) @@ -161,7 +168,8 @@ (make-Row (dict-remove* inits init-cs) (dict-remove* fields field-cs) (dict-remove* methods method-cs) - (dict-remove* augments augment-cs))) + (dict-remove* augments augment-cs) + init-rest)) ;; Syntax -> Syntax ;; removes two levels of nesting @@ -195,15 +203,19 @@ (define-splicing-syntax-class (class-type-clauses parse-type) #:description "Class type clause" #:attributes (row-var extends-types - inits fields methods augments) + inits fields methods augments init-rest) + #:literals (init-rest) (pattern (~seq (~or (~optional (~seq #:row-var row-var:id)) (~seq #:implements extends-type:id) + (~optional (init-rest init-rest-type:expr)) (~var clause (type-clause parse-type))) ...) #:attr inits (apply append (attribute clause.init-entries)) #:attr fields (apply append (attribute clause.field-entries)) #:attr methods (apply append (attribute clause.method-entries)) #:attr augments (apply append (attribute clause.augment-entries)) + #:attr init-rest (and (attribute init-rest-type) + (parse-type (attribute init-rest-type))) #:with extends-types #'(extends-type ...) #:fail-when (check-duplicate (map first (attribute inits))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/printer.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/printer.rkt index 331a17e100..956213b08f 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/printer.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/printer.rkt @@ -330,7 +330,7 @@ ;; class->sexp : Class [#:object? Boolean] -> S-expression ;; Convert a class or object type to an s-expression (define (class->sexp cls #:object? [object? #f]) - (match-define (Class: row-var inits fields methods augments) cls) + (match-define (Class: row-var inits fields methods augments init-rest) cls) (define row-var* (if (and row-var (F? row-var)) `(#:row-var ,(F-n row-var)) '())) (define inits* @@ -358,8 +358,12 @@ (define augments* (cond [(or object? (null? augments)) '()] [else (list (cons 'augment augments))])) + (define init-rest* + (if (and init-rest (not object?)) + (list `(init-rest ,init-rest)) + null)) `(,(if object? 'Object 'Class) - ,@row-var* ,@inits* ,@fields* ,@methods* ,@augments*)) + ,@row-var* ,@inits* ,@init-rest* ,@fields* ,@methods* ,@augments*)) ;; type->sexp : Type -> S-expression ;; convert a type to an s-expression that can be printed diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/subtype.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/subtype.rkt index ecd037fbcb..3299592fea 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/subtype.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/subtype.rkt @@ -577,8 +577,8 @@ (subtype* s-out t-out))] [((Param: in out) t) (subtype* A0 (cl->* (-> out) (-> in -Void)) t)] - [((Instance: (Class: _ _ field-map method-map augment-map)) - (Instance: (Class: _ _ field-map* method-map* augment-map*))) + [((Instance: (Class: _ _ field-map method-map augment-map _)) + (Instance: (Class: _ _ field-map* method-map* augment-map* _))) (define (subtype-clause? map map*) ;; invariant: map and map* are sorted by key (let loop ([A A0] [map map] [map* map*]) @@ -600,8 +600,8 @@ (subtype-clause? method-map method-map*) (subtype-clause? field-map field-map*))] [((? Class?) (ClassTop:)) A0] - [((Class: row inits fields methods augments) - (Class: row* inits* fields* methods* augments*)) + [((Class: row inits fields methods augments init-rest) + (Class: row* inits* fields* methods* augments* init-rest*)) ;; TODO: should the result be folded instead? (define sub (curry subtype* A)) ;; check that each of inits, fields, methods, etc. are @@ -632,7 +632,8 @@ (equal-clause? inits inits* #t) (equal-clause? fields fields*) (equal-clause? methods methods*) - (equal-clause? augments augments*))] + (equal-clause? augments augments*) + (sub init-rest init-rest*))] ;; otherwise, not a subtype [(_ _) #f]))) (when (null? A) diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt index e6f8217348..f243f22f58 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt @@ -3421,7 +3421,72 @@ [tc-err (class object% (super-new) (define/pubment (foo x) 0) (define/public (g x) (foo 3))) - #:msg #rx"Cannot apply expression of type Any"]) + #:msg #rx"Cannot apply expression of type Any"] + ;; the next several tests are for positional init arguments + [tc-e (let () + (define c% (class object% (super-new) (init a b))) + (new c% [a "a"] [b "b"]) + (make-object c% "a" "b") + (instantiate c% ("a") [b "b"]) + (void)) + -Void] + [tc-e (let () + (define c% (class object% (super-new) (init a [b 'b]))) + (new c% [a "a"] [b "b"]) + (new c% [a "a"]) + (make-object c% "a") + (make-object c% "a" "b") + (instantiate c% () [a "a"] [b "b"]) + (instantiate c% ("a") [b "b"]) + (instantiate c% ("a" "b")) + (void)) + -Void] + [tc-e (let () + (define c% (class (class object% + (super-new) + (init [b 'b])) + (super-new) (init [a 'a]))) + (new c% [a "a"] [b "b"]) + (new c% [b "b"]) + (new c% [a "a"]) + (make-object c% "a") + (make-object c% "a" "b") + (instantiate c% () [a "a"] [b "b"]) + (instantiate c% ("a") [b "b"]) + (instantiate c% ("a" "b")) + (void)) + -Void] + [tc-e (let () + (define c% (class object% + (super-new) + (init-rest [rst : (List String String)]))) + (make-object c% "a" "b") + (void)) + -Void] + [tc-e (let () + (define c% (class object% + (super-new) + (init [a : Symbol]) + (init-rest [rst : (List String String)]))) + (make-object c% 'a "b" "c") + (void)) + -Void] + [tc-e (let () + (define c% (class object% + (super-new) + (init-rest [rst : (U (List Symbol) + (List String String))]))) + (make-object c% "b" "c") + (make-object c% 'a) + (void)) + -Void] + [tc-err (let () + (define c% (class object% + (super-new) + (init-rest [rst : (List Symbol)]))) + (make-object c% "wrong")) + #:msg #rx"expected: Symbol.*given: String"] + ) (test-suite "tc-literal tests" (tc-l 5 -PosByte)