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
(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))]

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))]
[(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

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 (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]))

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*)))])]
[(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)

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?))]
[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)))])))

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

@ -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<Symbol, Symbol>
;; 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 <undefined>
(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<Symbol> Listof<Syntax> Dict<Symbol, Symbol> 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<Symbol, Syntax>
;; find-provided-inits : Syntax Inits -> Listof<Syntax> Dict<Symbol, Syntax>
;; 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<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
(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<Syntax>
;; 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>
;; Set<Symbol> Dict<Symbol, Symbol>
;; 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

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

@ -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<Syntax> Listof<Syntax> -> 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

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

@ -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]

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

@ -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)))

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
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)))

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
;; 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

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

@ -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)

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)
(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)