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

Add support for positional init arguments for TR

Browse Source 
This includes support for positional inits and also
init-rest along with make-object and instantiate.
This commit is contained in:
Asumu Takikawa 2014-01-29 19:20:56 -05:00
parent 0b1eec20b5
commit 18182d16a6
13 changed files with 367 additions and 129 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -49,8 +49,7 @@
;; forms that are not allowed by Typed Racket yet ;; forms that are not allowed by Typed Racket yet
(define unsupported-forms (define unsupported-forms
(list (quote-syntax init-rest) (list (quote-syntax augride)
(quote-syntax augride)
;; FIXME: see if override contracts are enough ;; FIXME: see if override contracts are enough
;; to keep these at bay or whether they ;; to keep these at bay or whether they
;; need to be handled ;; need to be handled
@ -75,6 +74,7 @@
(quote-syntax init) (quote-syntax init)
(quote-syntax field) (quote-syntax field)
(quote-syntax init-field) (quote-syntax init-field)
(quote-syntax init-rest)
(quote-syntax inherit-field) (quote-syntax inherit-field)
(quote-syntax private) (quote-syntax private)
(quote-syntax public) (quote-syntax public)
@ -190,6 +190,11 @@
(stx->list #'(names.ids ...)) (stx->list #'(names.ids ...))
(attribute names.type) (attribute names.type)
(attribute names.optional?))) (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 ...) (pattern ((~literal field) names:field-decl ...)
#:attr data (clause #'(field names.form ...) #:attr data (clause #'(field names.form ...)
#'field #'field
@ -362,6 +367,7 @@
(#:forall #,@(attribute forall.type-variables)) (#:forall #,@(attribute forall.type-variables))
(init #,@(dict-ref name-dict #'init '())) (init #,@(dict-ref name-dict #'init '()))
(init-field #,@(dict-ref name-dict #'init-field '())) (init-field #,@(dict-ref name-dict #'init-field '()))
(init-rest #,@(dict-ref name-dict #'init-rest '()))
(optional-init #,@optional-inits) (optional-init #,@optional-inits)
(field #,@(dict-ref name-dict #'field '())) (field #,@(dict-ref name-dict #'field '()))
(public #,@(dict-ref name-dict #'public '())) (public #,@(dict-ref name-dict #'public '()))
@ -406,7 +412,8 @@
([content contents]) ([content contents])
(define stx (non-clause-stx content)) (define stx (non-clause-stx content))
(syntax-parse stx (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 ;; if it's a method definition for a declared method, then
;; mark it as something to type-check ;; mark it as something to type-check
[(define-values (id) . rst) [(define-values (id) . rst)
@ -447,7 +454,9 @@
(append rest-top (list plain-annotation)) (append rest-top (list plain-annotation))
private-fields)] private-fields)]
;; Identify super-new for the benefit of the type checker ;; 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 (define new-non-clause
(non-clause (syntax-property stx 'tr:class:super-new #t))) (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 new-non-clause))
@ -504,6 +513,7 @@
(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 init-rest-name (dict-ref name-dict #'init-rest '()))
(define inherit-names (define inherit-names
(stx-map stx-car (dict-ref name-dict #'inherit '()))) (stx-map stx-car (dict-ref name-dict #'inherit '())))
(define inherit-field-names (define inherit-field-names
@ -530,6 +540,9 @@
[(#,@init-names) [(#,@init-names)
(values #,@(map (λ (stx) #`(λ () #,stx)) (values #,@(map (λ (stx) #`(λ () #,stx))
init-names))] init-names))]
[(#,@init-rest-name)
(values #,@(map (λ (stx) #`(λ () #,stx))
init-rest-name))]
[(#,@inherit-names) [(#,@inherit-names)
(values #,@(map (λ (stx) #`(λ () (#,stx))) (values #,@(map (λ (stx) #`(λ () (#,stx)))
inherit-names))] inherit-names))]

5
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/init-envs.rkt vendored
View File

@ -93,7 +93,7 @@
[(PolyDots-names: ns b) `(make-PolyDots (list ,@(map sub ns)) ,(sub b))] [(PolyDots-names: ns b) `(make-PolyDots (list ,@(map sub ns)) ,(sub b))]
[(PolyRow-names: ns c b) `(make-PolyRow (list ,@(map sub ns)) [(PolyRow-names: ns c b) `(make-PolyRow (list ,@(map sub ns))
(quote ,c) ,(sub b))] (quote ,c) ,(sub b))]
[(Class: row inits fields methods augments) [(Class: row inits fields methods augments init-rest)
(cond [(and (current-class-cache) (cond [(and (current-class-cache)
(dict-ref (unbox (current-class-cache)) v #f)) => car] (dict-ref (unbox (current-class-cache)) v #f)) => car]
[else [else
@ -108,7 +108,8 @@
(list ,@(convert inits #t)) (list ,@(convert inits #t))
(list ,@(convert fields)) (list ,@(convert fields))
(list ,@(convert methods)) (list ,@(convert methods))
(list ,@(convert augments)))) (list ,@(convert augments))
,(sub init-rest)))
(define name (gensym)) (define name (gensym))
(define cache-box (current-class-cache)) (define cache-box (current-class-cache))
(when cache-box (when cache-box

9
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt
View File

@ -589,7 +589,7 @@
(define parent-type (parse-type stx)) (define parent-type (parse-type stx))
(define (match-parent-type parent-type) (define (match-parent-type parent-type)
(match parent-type (match parent-type
[(Class: row-var _ fields methods augments) [(Class: row-var _ fields methods augments _)
(values row-var fields methods augments)] (values row-var fields methods augments)]
[(? Mu?) [(? Mu?)
(match-parent-type (unfold parent-type))] (match-parent-type (unfold parent-type))]
@ -662,7 +662,7 @@
(stx-map syntax-e #'clause.method-names) (stx-map syntax-e #'clause.method-names)
(stx-map parse-type #'clause.method-types))) (stx-map parse-type #'clause.method-types)))
(check-function-types methods) (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 ;; Syntax -> Type
;; Parse a (Class ...) type ;; Parse a (Class ...) type
@ -679,6 +679,9 @@
(define given-row-var (define given-row-var
(and (attribute clause.row-var) (and (attribute clause.row-var)
(parse-type (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-methods)
(check-function-types given-augments) (check-function-types given-augments)
@ -702,7 +705,7 @@
(check-constraints augments (cadddr constraints))) (check-constraints augments (cadddr constraints)))
(define class-type (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])) class-type]))

4
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt
View File

@ -289,14 +289,14 @@
(recursive-sc-use (if (from-typed? typed-side) typed-n* untyped-n*)))])] (recursive-sc-use (if (from-typed? typed-side) typed-n* untyped-n*)))])]
[(Instance: (? Mu? t)) [(Instance: (? Mu? t))
(t->sc (make-Instance (resolve-once 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 field-names field-types) ...) fields)
(match-define (list (list public-names public-types) ...) methods) (match-define (list (list public-names public-types) ...) methods)
(object/sc (append (map (λ (n sc) (member-spec 'method n sc)) (object/sc (append (map (λ (n sc) (member-spec 'method n sc))
public-names (map t->sc/method public-types)) public-names (map t->sc/method public-types))
(map (λ (n sc) (member-spec 'field n sc)) (map (λ (n sc) (member-spec 'field n sc))
field-names (map t->sc/both field-types))))] 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 init-names init-types _) ...) inits)
(match-define (list (list field-names field-types) ...) fields) (match-define (list (list field-names field-types) ...) fields)
(match-define (list (list public-names public-types) ...) publics) (match-define (list (list public-names public-types) ...) publics)

45
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/rep/type-rep.rkt
View File

@ -465,19 +465,22 @@
(def-type Row ([inits (listof (list/c symbol? Type/c boolean?))] (def-type Row ([inits (listof (list/c symbol? Type/c boolean?))]
[fields (listof (list/c symbol? Type/c))] [fields (listof (list/c symbol? Type/c))]
[methods (listof (list/c symbol? Function?))] [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 #:no-provide
[#:frees (λ (f) (combine-frees [#:frees (λ (f) (combine-frees
(map f (append (map cadr inits) (map f (append (map cadr inits)
(map cadr fields) (map cadr fields)
(map cadr methods) (map cadr methods)
(map cadr augments)))))] (map cadr augments)
[#:fold-rhs (match (list inits fields methods augments) (if init-rest (list init-rest) null)))))]
[#:fold-rhs (match (list inits fields methods augments init-rest)
[(list [(list
(list (list init-names init-tys reqd) ___) (list (list init-names init-tys reqd) ___)
(list (list fname fty) ___) (list (list fname fty) ___)
(list (list mname mty) ___) (list (list mname mty) ___)
(list (list aname aty) ___)) (list (list aname aty) ___)
init-rest)
(*Row (*Row
(map list (map list
init-names init-names
@ -485,7 +488,8 @@
reqd) reqd)
(map list fname (map type-rec-id fty)) (map list fname (map type-rec-id fty))
(map list mname (map type-rec-id mty)) (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 ;; Supertype of all Class types, cannot instantiate
;; or subclass these ;; or subclass these
@ -916,23 +920,25 @@
;; Row* ;; Row*
;; This is a custom constructor for Row types ;; This is a custom constructor for Row types
;; Sorts all clauses by the key (the clause name) ;; Sorts all clauses by the key (the clause name)
(define (Row* inits fields methods augments) (define (Row* inits fields methods augments init-rest)
(*Row (sort-row-clauses inits) (*Row inits
(sort-row-clauses fields) (sort-row-clauses fields)
(sort-row-clauses methods) (sort-row-clauses methods)
(sort-row-clauses augments))) (sort-row-clauses augments)
init-rest))
;; Class* ;; Class*
;; This is a custom constructor for Class types that ;; This is a custom constructor for Class types that
;; doesn't require writing make-Row everywhere ;; 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) (-> (or/c F? B? Row? #f)
(listof (list/c symbol? Type/c boolean?)) (listof (list/c symbol? Type/c boolean?))
(listof (list/c symbol? Type/c)) (listof (list/c symbol? Type/c))
(listof (list/c symbol? Function?)) (listof (list/c symbol? Function?))
(listof (list/c symbol? Function?)) (listof (list/c symbol? Function?))
(or/c Type/c #f)
Class?) Class?)
(*Class row-var (Row* inits fields methods augments))) (*Class row-var (Row* inits fields methods augments init-rest)))
;; Class:* ;; Class:*
;; This match expander replaces the built-in matching with ;; This match expander replaces the built-in matching with
@ -948,20 +954,29 @@
(define fields (Row-fields class-row)) (define fields (Row-fields class-row))
(define methods (Row-methods class-row)) (define methods (Row-methods class-row))
(define augments (Row-augments class-row)) (define augments (Row-augments class-row))
(define init-rest (Row-init-rest class-row))
(cond [(and row (Row? row)) (cond [(and row (Row? row))
(define row-inits (Row-inits row)) (define row-inits (Row-inits row))
(define row-fields (Row-fields row)) (define row-fields (Row-fields row))
(define row-methods (Row-methods row)) (define row-methods (Row-methods row))
(define row-augments (Row-augments row)) (define row-augments (Row-augments row))
(define row-init-rest (Row-init-rest row))
(list 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 ;; FIXME: instead of sorting here every time
;; the match expander is called, the row ;; the match expander is called, the row
;; fields should be merged on substitution ;; fields should be merged on substitution
(sort-row-clauses (append inits row-inits))
(sort-row-clauses (append fields row-fields)) (sort-row-clauses (append fields row-fields))
(sort-row-clauses (append methods row-methods)) (sort-row-clauses (append methods row-methods))
(sort-row-clauses (append augments row-augments)))] (sort-row-clauses (append augments row-augments))
[else (list row inits fields methods 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 ;; sorts the given field of a Row by the member name
(define (sort-row-clauses clauses) (define (sort-row-clauses clauses)
@ -970,9 +985,9 @@
(define-match-expander Class:* (define-match-expander Class:*
(λ (stx) (λ (stx)
(syntax-case 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? #'(? Class?
(app merge-class/row (app merge-class/row
(list row-pat inits-pat fields-pat (list row-pat inits-pat fields-pat
methods-pat augments-pat)))]))) methods-pat augments-pat init-rest-pat)))])))

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

@ -5,6 +5,7 @@
(require "../utils/utils.rkt" (require "../utils/utils.rkt"
racket/dict racket/dict
racket/format racket/format
racket/list
racket/match racket/match
racket/pretty ;; DEBUG ONLY racket/pretty ;; DEBUG ONLY
racket/set racket/set
@ -58,7 +59,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 c:init-rest optional-init c:field
c:public c:override c:private c:inherit c:inherit-field c:public c:override c:private c:inherit c:inherit-field
private-field c:augment c:pubment) private-field c:augment c:pubment)
(pattern (begin (quote-syntax (pattern (begin (quote-syntax
@ -66,6 +67,7 @@
(#:forall type-parameter:id ...) (#:forall type-parameter:id ...)
(c:init init-names:name-pair ...) (c:init init-names:name-pair ...)
(c:init-field init-field-names:name-pair ...) (c:init-field init-field-names:name-pair ...)
(c:init-rest (~optional init-rest-name:id))
(optional-init optional-names:id ...) (optional-init optional-names:id ...)
(c:field field-names:name-pair ...) (c:field field-names:name-pair ...)
(c:public public-names:name-pair ...) (c:public public-names:name-pair ...)
@ -151,6 +153,7 @@
type-parameters type-parameters
init-internals init-externals init-internals init-externals
init-field-internals init-field-externals init-field-internals init-field-externals
init-rest-name
optional-inits optional-inits
field-internals field-externals field-internals field-externals
public-internals public-externals public-internals public-externals
@ -189,7 +192,7 @@
;; class produced by `class` due to the syntax property ;; class produced by `class` due to the syntax property
(define (check-class form [expected #f]) (define (check-class form [expected #f])
(match (and expected (resolve expected)) (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)] (parse-and-check form self-class-type)]
[(tc-result1: (Poly-names: ns body-type)) [(tc-result1: (Poly-names: ns body-type))
;; FIXME: this case probably isn't quite right ;; FIXME: this case probably isn't quite right
@ -227,6 +230,8 @@
'init-internals 'init-internals
(set-union (syntax->datum #'cls.init-internals) (set-union (syntax->datum #'cls.init-internals)
(syntax->datum #'cls.init-field-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) 'public-internals (syntax->datum #'cls.public-internals)
'override-internals (syntax->datum #'cls.override-internals) 'override-internals (syntax->datum #'cls.override-internals)
'pubment-internals (syntax->datum #'cls.pubment-internals) 'pubment-internals (syntax->datum #'cls.pubment-internals)
@ -297,12 +302,12 @@
(define (do-check expected super-type parse-info) (define (do-check expected super-type parse-info)
;; unpack superclass names and types ;; unpack superclass names and types
(define-values (super-row super-inits super-fields (define-values (super-row super-inits super-fields
super-methods super-augments) super-methods super-augments super-init-rest)
(match super-type (match super-type
[(tc-result1: (Class: super-row super-inits super-fields [(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 (values super-row super-inits super-fields
super-methods super-augments)] super-methods super-augments super-init-rest)]
[(tc-result1: t) [(tc-result1: t)
(tc-error/expr "expected a superclass but got value of type ~a" t (tc-error/expr "expected a superclass but got value of type ~a" t
#:stx (hash-ref parse-info 'superclass-expr)) #:stx (hash-ref parse-info 'superclass-expr))
@ -333,15 +338,31 @@
(define super-new-stxs (define super-new-stxs
(trawl-for-property make-methods-stx 'tr:class:super-new)) (trawl-for-property make-methods-stx 'tr:class:super-new))
(define super-new-stx (check-super-new-exists super-new-stxs)) (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 (if super-new-stx
(find-provided-inits super-new-stx super-inits) (find-provided-inits super-new-stx super-inits)
'())) (values null null)))
(define provided-init-names (dict-keys provided-super-inits)) (define provided-init-names (dict-keys provided-super-inits))
(define remaining-super-inits (define pos-length (length provided-pos-args))
(for/list ([(name val) (in-dict super-inits)] ;; 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)) #:unless (member name provided-init-names))
(cons name val))) (cons name val)))]))
;; define which init names are optional ;; define which init names are optional
(define optional-inits (hash-ref parse-info 'optional-inits)) (define optional-inits (hash-ref parse-info 'optional-inits))
(define optional-external (for/set ([n optional-inits]) (define optional-external (for/set ([n optional-inits])
@ -362,8 +383,9 @@
remaining-super-inits remaining-super-inits
super-fields super-fields
super-methods super-methods
super-augments)) super-augments
(match-define (Instance: (Class: _ inits fields methods augments)) super-init-rest*))
(match-define (Instance: (Class: _ inits fields methods augments init-rest))
self-type) self-type)
(do-timestamp "built self type") (do-timestamp "built self type")
;; trawl the body for the local name table ;; trawl the body for the local name table
@ -371,6 +393,7 @@
(trawl-for-property make-methods-stx 'tr:class:local-table)) (trawl-for-property make-methods-stx '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-private-field-table local-init-table local-private-field-table local-init-table
local-init-rest-table
local-inherit-table local-inherit-field-table local-inherit-table local-inherit-field-table
local-super-table local-super-table
local-augment-table local-inner-table) local-augment-table local-inner-table)
@ -393,6 +416,7 @@
local-field-table fields local-field-table fields
local-private-field-table private-field-types local-private-field-table private-field-types
local-init-table inits local-init-table inits
local-init-rest-table init-rest
local-inherit-table local-inherit-table
local-inherit-field-table local-inherit-field-table
local-super-table local-super-table
@ -403,7 +427,8 @@
self-type)) self-type))
(do-timestamp "built local tables") (do-timestamp "built local tables")
(with-lexical-env/extend lexical-names/top-level lexical-types/top-level (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") (do-timestamp "checked super-new")
(with-lexical-env/extend lexical-names/top-level lexical-types/top-level (with-lexical-env/extend lexical-names/top-level lexical-types/top-level
(for ([stx top-level-exprs] (for ([stx top-level-exprs]
@ -467,7 +492,7 @@
remaining-super-inits remaining-super-inits
super-field-names super-method-names super-augment-names) super-field-names super-method-names super-augment-names)
(when expected (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-init-names (dict-keys inits))
(define exp-field-names (dict-keys fields)) (define exp-field-names (dict-keys fields))
(define exp-method-names (dict-keys methods)) (define exp-method-names (dict-keys methods))
@ -519,7 +544,7 @@
(match-define (match-define
(Instance: (Instance:
(and class-type (and class-type
(Class: row-var inits fields methods augments))) (Class: row-var inits fields methods augments init-rest)))
self-type) self-type)
(define (make-new-methods methods method-types) (define (make-new-methods methods method-types)
(for/fold ([methods methods]) (for/fold ([methods methods])
@ -535,7 +560,8 @@
(dict-set methods name type))) (dict-set methods name type)))
(make-Class row-var inits fields (make-Class row-var inits fields
(make-new-methods methods method-types) (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<Symbol, Symbol> ;; local-tables->lexical-env : Dict Dict<Symbol, Symbol>
;; LocalMapping NameTypeDict ;; LocalMapping NameTypeDict
@ -551,6 +577,7 @@
local-private-field-table local-private-field-table
private-field-types private-field-types
local-init-table inits local-init-table inits
local-init-rest-table init-rest
local-inherit-table local-inherit-table
local-inherit-field-table local-inherit-field-table
local-super-table local-super-table
@ -687,6 +714,17 @@
(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)))))
(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 (define all-names (append localized-method-names
localized-private-methods localized-private-methods
localized-field-get-names localized-field-get-names
@ -713,6 +751,7 @@
;; from top-level environment to avoid <undefined> ;; from top-level environment to avoid <undefined>
(append all-names (append all-names
localized-init-names localized-init-names
localized-init-rest-name
;; 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.
@ -721,6 +760,7 @@
(hash-ref parse-info 'initializer-args-id))) (hash-ref parse-info 'initializer-args-id)))
(append all-types (append all-types
init-types init-types
init-rest-type
(list self-type (make-Univ))))) (list self-type (make-Univ)))))
;; check-methods : Listof<Symbol> Listof<Syntax> Dict<Symbol, Symbol> Dict Type ;; check-methods : Listof<Symbol> Listof<Syntax> Dict<Symbol, Symbol> Dict Type
@ -898,6 +938,8 @@
...)] ...)]
[(init:id ...) [(init:id ...)
(#%plain-app values (#%plain-lambda () local-init:id) ...)] (#%plain-app values (#%plain-lambda () local-init:id) ...)]
[(init-rest:id ...)
(#%plain-app values (#%plain-lambda () local-init-rest:id) ...)]
[(inherit:id ...) [(inherit:id ...)
(#%plain-app (#%plain-app
values values
@ -940,6 +982,10 @@
(map cons (map cons
(syntax->datum #'(init ...)) (syntax->datum #'(init ...))
(syntax->list #'(local-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 (map cons
(syntax->datum #'(inherit ...)) (syntax->datum #'(inherit ...))
(syntax->list #'(local-inherit ...))) (syntax->list #'(local-inherit ...)))
@ -971,12 +1017,19 @@
#f] #f]
[else (car stxs)])) [else (car stxs)]))
;; find-provided-inits : Syntax Inits -> Dict<Symbol, Syntax> ;; find-provided-inits : Syntax Inits -> Listof<Syntax> Dict<Symbol, Syntax>
;; Find the init arguments that were provided via super-new ;; Find the init arguments that were provided via super-new
(define (find-provided-inits stx super-inits) (define (find-provided-inits stx super-inits)
(syntax-parse stx (syntax-parse stx
#:literals (#%plain-app list cons quote) #: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 (#%plain-app
list list
(#%plain-app cons (quote init-id) arg:expr) (#%plain-app cons (quote init-id) arg:expr)
@ -986,17 +1039,40 @@
(unless (dict-ref super-inits name #f) (unless (dict-ref super-inits name #f)
(tc-error/expr "super-new: init argument ~a not accepted by superclass" (tc-error/expr "super-new: init argument ~a not accepted by superclass"
name))) name)))
(map cons provided-inits (syntax->list #'(arg ...)))])) (values
(syntax->list #'(pos-arg ...))
(map cons provided-inits (syntax->list #'(arg ...))))]))
;; check-super-new : Dict<Symbol, Syntax> Dict<Symbol, Type> -> Void ;; check-super-new : Listof<Syntax> Dict<Symbol, Syntax>
;; Dict<Symbol, Type> Type -> Void
;; Check if the super-new call is well-typed ;; Check if the super-new call is well-typed
(define (check-super-new provided-inits super-inits) (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)]) (for ([(init-id init-arg) (in-dict provided-inits)])
(define maybe-expected (dict-ref super-inits init-id #f)) (define maybe-expected (dict-ref remaining-inits init-id #f))
(if maybe-expected (if maybe-expected
(tc-expr/check init-arg (ret (car maybe-expected))) (tc-expr/check init-arg (ret (car maybe-expected)))
(tc-error/expr "init argument ~a not accepted by superclass" (tc-error/expr "init argument ~a not accepted by superclass"
init-id)))) init-id)))]))
;; Syntax -> Listof<Syntax> ;; Syntax -> Listof<Syntax>
;; Look through the expansion of the class macro in search for ;; Look through the expansion of the class macro in search for
@ -1079,7 +1155,7 @@
;; infer-self-type : Dict RowVar Class Dict<Symbol, Type> Dict<Symbol, Type> ;; infer-self-type : Dict RowVar Class Dict<Symbol, Type> Dict<Symbol, Type>
;; Set<Symbol> Dict<Symbol, Symbol> ;; Set<Symbol> Dict<Symbol, Symbol>
;; Inits Fields Methods ;; Inits Fields Methods Type
;; -> Type ;; -> Type
;; Construct a self object type based on all type annotations ;; Construct a self object type based on all type annotations
;; and the expected type ;; and the expected type
@ -1090,52 +1166,74 @@
optional-inits optional-inits
internal-external-mapping internal-external-mapping
super-inits super-fields super-methods super-inits super-fields super-methods
super-augments) super-augments super-init-rest)
(define (make-type-dict names supers maybe-expected ;; Gets a type for a given name in the class.
#:inits [inits? #f]
#:annotations-from [annotation-table annotation-table]
#:default-type [default-type Univ])
(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)))
(dict-set type-dict external entry))
;; A type is assigned for each member in this order: ;; A type is assigned for each member in this order:
;; (1) a type annotation from the user ;; (1) a type annotation from the user
;; (2) the expected type ;; (2) the expected type
;; (3) Any or Procedure ;; (3) Any or Procedure
(cond [(dict-ref annotation-table name #f) => update-dict] (define (assign-type name expected annotation-table update default-type)
[(and maybe-expected (cond [(dict-ref annotation-table name #f) => update]
(dict-ref maybe-expected name #f)) [(and expected (dict-ref expected name #f))
=> (compose update-dict car)] => (compose update car)]
[default-type => update-dict]))) [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 (list type))
(dict-set type-dict external entry))
(assign-type name expected annotation-table update-dict default-type)))
(define-values (expected-inits expected-fields (define-values (expected-inits expected-fields
expected-publics expected-augments) expected-publics expected-augments
expected-init-rest)
(match expected (match expected
[(Class: _ inits fields publics augments) [(Class: _ inits fields publics augments init-rest)
(values inits fields publics augments)] (values inits fields publics augments init-rest)]
[_ (values #f #f #f #f)])) [_ (values #f #f #f #f #f)]))
(define-values (inits fields publics pubments) (define-values (inits fields publics pubments init-rest-name)
(values (hash-ref parse-info 'init-internals) (values (hash-ref parse-info 'init-internals)
(hash-ref parse-info 'field-internals) (hash-ref parse-info 'field-internals)
(hash-ref parse-info 'public-internals) (hash-ref parse-info 'public-internals)
(hash-ref parse-info 'pubment-internals))) (hash-ref parse-info 'pubment-internals)
(define init-types (make-type-dict inits super-inits expected-inits (hash-ref parse-info 'init-rest-name)))
#:inits #t)) (define init-types (make-inits inits super-inits expected-inits))
(define field-types (make-type-dict fields super-fields expected-fields)) (define field-types (make-type-dict fields super-fields expected-fields Univ))
(define public-types (make-type-dict (append publics pubments) (define public-types (make-type-dict (append publics pubments)
super-methods expected-publics super-methods expected-publics
#:default-type top-func)) top-func))
(define augment-types (make-type-dict (define augment-types (make-type-dict
pubments super-augments expected-augments pubments super-augments expected-augments top-func
#:default-type top-func
#:annotations-from augment-annotation-table)) #: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 (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 ;; function->method : Function Type -> Function
;; Fix up a method's arity from a regular function type ;; Fix up a method's arity from a regular function type

51
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-objects.rkt
View File

@ -4,12 +4,13 @@
"signatures.rkt" "signatures.rkt"
"utils.rkt" "utils.rkt"
syntax/parse syntax/stx racket/match unstable/sequence unstable/syntax syntax/parse syntax/stx racket/match unstable/sequence unstable/syntax
racket/dict racket/dict racket/list
(typecheck signatures) (typecheck signatures)
(types resolve union utils) (types resolve union utils)
(rep type-rep) (rep type-rep)
(utils tc-utils) (utils tc-utils)
(for-template racket/base)
(for-label racket/base)) (for-label racket/base))
@ -26,7 +27,7 @@
(#%plain-app list . pos-args) (#%plain-app list . pos-args)
(#%plain-app list (#%plain-app cons (quote names) named-args) ...)) (#%plain-app list (#%plain-app cons (quote names) named-args) ...))
#:declare dmo (id-from 'do-make-object 'racket/private/class-internal) #: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) (pattern (dmo . args)
#:declare dmo (id-from 'do-make-object 'racket/private/class-internal) #:declare dmo (id-from 'do-make-object 'racket/private/class-internal)
(int-err "unexpected arguments to do-make-object")) (int-err "unexpected arguments to do-make-object"))
@ -40,20 +41,48 @@
;; check-do-make-object : Syntax Syntax Listof<Syntax> Listof<Syntax> -> TCResult ;; check-do-make-object : Syntax Syntax Listof<Syntax> Listof<Syntax> -> TCResult
;; do-make-object now takes blame as its first argument, which isn't checked ;; do-make-object now takes blame as its first argument, which isn't checked
;; (it's just an s-expression) ;; (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 given-names (stx-map syntax-e names))
(define name-assoc (for/list ([name (in-syntax names)] (define name-assoc (for/list ([name (in-syntax names)]
[arg (in-syntax named-args)]) [arg (in-syntax named-args)])
(list (syntax-e name) arg))) (list (syntax-e name) arg)))
(match (resolve (tc-expr/t cl)) (match (resolve (tc-expr/t cl))
[(Union: '()) (ret (Un))] [(Union: '()) (ret (Un))]
[(and c (Class: _ inits fields _ _)) [(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)) (define init-names (map car inits))
(for ([given-name given-names] (for ([name names]
#:unless (memq given-name init-names)) #:unless (memq name init-names))
(tc-error/delayed (tc-error/delayed
"unknown named argument ~a for class\nlegal named arguments are ~a" "unknown named argument ~a for class\nlegal named arguments are ~a"
given-name (stringify init-names))) name (stringify init-names)))
(for ([init inits]) (for ([init inits])
(match-define (list init-name init-type opt?) init) (match-define (list init-name init-type opt?) init)
;; stx if argument was provided, #f if it was ;; stx if argument was provided, #f if it was
@ -66,11 +95,7 @@
#f] #f]
[else #f])) [else #f]))
(when maybe-stx (when maybe-stx
(tc-expr/check maybe-stx (ret init-type)))) (tc-expr/check maybe-stx (ret init-type)))))
(ret (make-Instance c))]
[t
(tc-error/expr #:return (ret (Un))
"expected a class value for object creation, got: ~a" t)]))
;; check-get-field : Syntax Syntax -> TCResult ;; check-get-field : Syntax Syntax -> TCResult
;; type-check the `get-field` operation on objects ;; type-check the `get-field` operation on objects
@ -83,7 +108,7 @@
"expected a symbolic method name, but got ~a" meth)) "expected a symbolic method name, but got ~a" meth))
(match obj-type (match obj-type
;; FIXME: handle unions and mu? ;; 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) => (cond [(assq maybe-meth-sym fields) =>
(λ (field-entry) (ret (cadr field-entry)))] (λ (field-entry) (ret (cadr field-entry)))]
[else [else

2
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-send.rkt
View File

@ -16,7 +16,7 @@
(match rcvr-type (match rcvr-type
[(tc-result1: (Instance: (? Mu? type))) [(tc-result1: (Instance: (? Mu? type)))
(do-check (ret (make-Instance (unfold 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) (match (tc-expr method)
[(tc-result1: (Value: (? symbol? s))) [(tc-result1: (Value: (? symbol? s)))
(let* ([ftype (cond [(assq s methods) => cadr] (let* ([ftype (cond [(assq s methods) => cadr]

3
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/abbrev.rkt
View File

@ -322,7 +322,8 @@
(append ?clause.inits ...) (append ?clause.inits ...)
(append ?clause.fields ...) (append ?clause.fields ...)
(append ?clause.methods ...) (append ?clause.methods ...)
(append ?clause.augments ...))])) (append ?clause.augments ...)
#f)]))
(define-syntax-rule (-object . ?clauses) (define-syntax-rule (-object . ?clauses)
(make-Instance (-class . ?clauses))) (make-Instance (-class . ?clauses)))

30
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/classes.rkt
View File

@ -77,7 +77,7 @@
(match-define (list init-absents field-absents (match-define (list init-absents field-absents
method-absents augment-absents) method-absents augment-absents)
constraints) 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) ;; check a given clause type (e.g., init, field)
(define (check-clauses row-dict absence-set) (define (check-clauses row-dict absence-set)
(for ([(name _) (in-dict row-dict)]) (for ([(name _) (in-dict row-dict)])
@ -92,15 +92,21 @@
(define-splicing-syntax-class (row-clauses parse-type) (define-splicing-syntax-class (row-clauses parse-type)
#:description "Row type clause" #:description "Row type clause"
#:attributes (row) #: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 inits (apply append (attribute clause.init-entries))
#:attr fields (apply append (attribute clause.field-entries)) #:attr fields (apply append (attribute clause.field-entries))
#:attr methods (apply append (attribute clause.method-entries)) #:attr methods (apply append (attribute clause.method-entries))
#:attr augments (apply append (attribute clause.augment-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) #:attr row (make-Row (attribute inits)
(attribute fields) (attribute fields)
(attribute methods) (attribute methods)
(attribute augments)) (attribute augments)
(attribute init-rest))
#:fail-when #:fail-when
(check-duplicate (map first (attribute inits))) (check-duplicate (map first (attribute inits)))
"duplicate init or init-field clause" "duplicate init or init-field clause"
@ -122,7 +128,7 @@
(type-case (type-case
(#:Type inf #:Filter (sub-f inf) #:Object (sub-o inf)) (#:Type inf #:Filter (sub-f inf) #:Object (sub-o inf))
type type
[#:Class row inits fields methods augments [#:Class row inits fields methods augments init-rest
(cond (cond
[(and row (F? row)) [(and row (F? row))
(match-define (list init-cs field-cs method-cs augment-cs) (match-define (list init-cs field-cs method-cs augment-cs)
@ -132,7 +138,7 @@
(append (dict-keys fields) field-cs) (append (dict-keys fields) field-cs)
(append (dict-keys methods) method-cs) (append (dict-keys methods) method-cs)
(append (dict-keys augments) augment-cs))) (append (dict-keys augments) augment-cs)))
(make-Class row inits fields methods augments)] (make-Class row inits fields methods augments init-rest)]
[else [else
(match-define (list (list init-names init-tys init-reqds) ...) inits) (match-define (list (list init-names init-tys init-reqds) ...) inits)
(match-define (list (list field-names field-tys) ...) fields) (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 init-names (map inf init-tys) init-reqds)
(map list field-names (map inf field-tys)) (map list field-names (map inf field-tys))
(map list method-names (map inf method-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) (inf type)
(map remove-duplicates constraints)) (map remove-duplicates constraints))
@ -152,7 +159,7 @@
(define (infer-row constraints class-type) (define (infer-row constraints class-type)
(match-define (list init-cs field-cs method-cs augment-cs) (match-define (list init-cs field-cs method-cs augment-cs)
constraints) constraints)
(match-define (Class: _ inits fields methods augments) (match-define (Class: _ inits fields methods augments init-rest)
(resolve class-type)) (resolve class-type))
(define (dict-remove* dict keys) (define (dict-remove* dict keys)
(for/fold ([dict dict]) (for/fold ([dict dict])
@ -161,7 +168,8 @@
(make-Row (dict-remove* inits init-cs) (make-Row (dict-remove* inits init-cs)
(dict-remove* fields field-cs) (dict-remove* fields field-cs)
(dict-remove* methods method-cs) (dict-remove* methods method-cs)
(dict-remove* augments augment-cs))) (dict-remove* augments augment-cs)
init-rest))
;; Syntax -> Syntax ;; Syntax -> Syntax
;; removes two levels of nesting ;; removes two levels of nesting
@ -195,15 +203,19 @@
(define-splicing-syntax-class (class-type-clauses parse-type) (define-splicing-syntax-class (class-type-clauses parse-type)
#:description "Class type clause" #:description "Class type clause"
#:attributes (row-var extends-types #: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)) (pattern (~seq (~or (~optional (~seq #:row-var row-var:id))
(~seq #:implements extends-type:id) (~seq #:implements extends-type:id)
(~optional (init-rest init-rest-type:expr))
(~var clause (type-clause parse-type))) (~var clause (type-clause parse-type)))
...) ...)
#:attr inits (apply append (attribute clause.init-entries)) #:attr inits (apply append (attribute clause.init-entries))
#:attr fields (apply append (attribute clause.field-entries)) #:attr fields (apply append (attribute clause.field-entries))
#:attr methods (apply append (attribute clause.method-entries)) #:attr methods (apply append (attribute clause.method-entries))
#:attr augments (apply append (attribute clause.augment-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 ...) #:with extends-types #'(extends-type ...)
#:fail-when #:fail-when
(check-duplicate (map first (attribute inits))) (check-duplicate (map first (attribute inits)))

8
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/printer.rkt
View File

@ -330,7 +330,7 @@
;; class->sexp : Class [#:object? Boolean] -> S-expression ;; class->sexp : Class [#:object? Boolean] -> S-expression
;; Convert a class or object type to an s-expression ;; Convert a class or object type to an s-expression
(define (class->sexp cls #:object? [object? #f]) (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* (define row-var*
(if (and row-var (F? row-var)) `(#:row-var ,(F-n row-var)) '())) (if (and row-var (F? row-var)) `(#:row-var ,(F-n row-var)) '()))
(define inits* (define inits*
@ -358,8 +358,12 @@
(define augments* (define augments*
(cond [(or object? (null? augments)) '()] (cond [(or object? (null? augments)) '()]
[else (list (cons 'augment 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) `(,(if object? 'Object 'Class)
,@row-var* ,@inits* ,@fields* ,@methods* ,@augments*)) ,@row-var* ,@inits* ,@init-rest* ,@fields* ,@methods* ,@augments*))
;; type->sexp : Type -> S-expression ;; type->sexp : Type -> S-expression
;; convert a type to an s-expression that can be printed ;; convert a type to an s-expression that can be printed

11
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/subtype.rkt
View File

@ -577,8 +577,8 @@
(subtype* s-out t-out))] (subtype* s-out t-out))]
[((Param: in out) t) [((Param: in out) t)
(subtype* A0 (cl->* (-> out) (-> in -Void)) 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*) (define (subtype-clause? map map*)
;; invariant: map and map* are sorted by key ;; invariant: map and map* are sorted by key
(let loop ([A A0] [map map] [map* map*]) (let loop ([A A0] [map map] [map* map*])
@ -600,8 +600,8 @@
(subtype-clause? method-map method-map*) (subtype-clause? method-map method-map*)
(subtype-clause? field-map field-map*))] (subtype-clause? field-map field-map*))]
[((? Class?) (ClassTop:)) A0] [((? Class?) (ClassTop:)) A0]
[((Class: row inits fields methods augments) [((Class: row inits fields methods augments init-rest)
(Class: row* inits* fields* methods* augments*)) (Class: row* inits* fields* methods* augments* init-rest*))
;; TODO: should the result be folded instead? ;; TODO: should the result be folded instead?
(define sub (curry subtype* A)) (define sub (curry subtype* A))
;; check that each of inits, fields, methods, etc. are ;; check that each of inits, fields, methods, etc. are
@ -632,7 +632,8 @@
(equal-clause? inits inits* #t) (equal-clause? inits inits* #t)
(equal-clause? fields fields*) (equal-clause? fields fields*)
(equal-clause? methods methods*) (equal-clause? methods methods*)
(equal-clause? augments augments*))] (equal-clause? augments augments*)
(sub init-rest init-rest*))]
;; otherwise, not a subtype ;; otherwise, not a subtype
[(_ _) #f]))) [(_ _) #f])))
(when (null? A) (when (null? A)

67
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt
View File

@ -3421,7 +3421,72 @@
[tc-err (class object% (super-new) [tc-err (class object% (super-new)
(define/pubment (foo x) 0) (define/pubment (foo x) 0)
(define/public (g x) (foo 3))) (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 (test-suite
"tc-literal tests" "tc-literal tests"
(tc-l 5 -PosByte) (tc-l 5 -PosByte)