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

Support pubment and augment methods

Browse Source 
This required changes to the type and row
representation. I also got rid of the redundancy
between Row and Class types.

Some other bugs had to be quashed for these
changes, such as private methods not actually
being type-checked.
This commit is contained in:
Asumu Takikawa 2013-06-27 19:59:35 -04:00
parent 1dede05549
commit eb95264e3f
14 changed files with 545 additions and 210 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt
View File

@ -961,7 +961,7 @@
[struct-type? (make-pred-ty (make-StructTypeTop))] [struct-type? (make-pred-ty (make-StructTypeTop))]
;; Section 6.2 (Classes) ;; Section 6.2 (Classes)
[object% (make-Class #f null null null)] [object% (make-Class #f null null null null)]
;; Section 9.1 ;; Section 9.1
[exn:misc:match? (-> Univ B)] [exn:misc:match? (-> Univ B)]

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

@ -263,7 +263,9 @@
(override #,@(dict-ref name-dict #'override '())) (override #,@(dict-ref name-dict #'override '()))
(private #,@(dict-ref name-dict #'private '())) (private #,@(dict-ref name-dict #'private '()))
(private-field #,@private-fields) (private-field #,@private-fields)
(inherit #,@(dict-ref name-dict #'inherit '())))) (inherit #,@(dict-ref name-dict #'inherit '()))
(augment #,@(dict-ref name-dict #'augment '()))
(pubment #,@(dict-ref name-dict #'pubment '()))))
(class #,annotated-super (class #,annotated-super
#,@(map clause-stx clauses) #,@(map clause-stx clauses)
#,@(map non-clause-stx annotated-methods) #,@(map non-clause-stx annotated-methods)
@ -289,11 +291,12 @@
#:literals (define-values super-new) #:literals (define-values super-new)
;; 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
;; FIXME: this needs to track augments, etc.
[(define-values (id) . rst) [(define-values (id) . rst)
#:when (memf (λ (n) (free-identifier=? #'id n)) #:when (memf (λ (n) (free-identifier=? #'id n))
(append (stx-map stx-car (dict-ref name-dict #'public '())) (append (stx-map stx-car (dict-ref name-dict #'public '()))
(stx-map stx-car (dict-ref name-dict #'pubment '()))
(stx-map stx-car (dict-ref name-dict #'override '())) (stx-map stx-car (dict-ref name-dict #'override '()))
(stx-map stx-car (dict-ref name-dict #'augment '()))
(dict-ref name-dict #'private '()))) (dict-ref name-dict #'private '())))
(values (cons (non-clause (syntax-property stx (values (cons (non-clause (syntax-property stx
'tr:class:method 'tr:class:method
@ -342,7 +345,8 @@
;; set!-transformers to the appropriate accessors, which lets ;; set!-transformers to the appropriate accessors, which lets
;; us figure out the accessor identifiers. ;; us figure out the accessor identifiers.
(define (make-locals-table name-dict private-field-names) (define (make-locals-table name-dict private-field-names)
(define public-names (stx-map stx-car (dict-ref name-dict #'public '()))) (define public-names
(stx-map stx-car (dict-ref name-dict #'public '())))
(define override-names (define override-names
(stx-map stx-car (dict-ref name-dict #'override '()))) (stx-map stx-car (dict-ref name-dict #'override '())))
(define private-names (dict-ref name-dict #'private '())) (define private-names (dict-ref name-dict #'private '()))
@ -353,6 +357,9 @@
(stx-map stx-car (dict-ref name-dict #'init '()))) (stx-map stx-car (dict-ref name-dict #'init '())))
(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 augment-names
(append (stx-map stx-car (dict-ref name-dict #'pubment '()))
(stx-map stx-car (dict-ref name-dict #'augment '()))))
(syntax-property (syntax-property
#`(let-values ([(#,@public-names) #`(let-values ([(#,@public-names)
(values #,@(map (λ (stx) #`(λ () (#,stx))) (values #,@(map (λ (stx) #`(λ () (#,stx)))
@ -374,7 +381,10 @@
inherit-names))] inherit-names))]
[(#,@override-names) [(#,@override-names)
(values #,@(map (λ (stx) #`(λ () (#,stx) (super #,stx))) (values #,@(map (λ (stx) #`(λ () (#,stx) (super #,stx)))
override-names))]) override-names))]
[(#,@augment-names)
(values #,@(map (λ (stx) #`(λ () (#,stx) (inner #f #,stx)))
augment-names))])
(void)) (void))
'tr:class:local-table #t))) 'tr:class:local-table #t)))

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

@ -91,6 +91,18 @@
[(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)
;; FIXME: there's probably a better way to do this
(define (convert members [inits? #f])
(for/list ([m members])
`(list (quote ,(car m))
,(sub (cadr m))
,@(if inits? (cddr m) '()))))
`(make-Class ,(sub row)
(list ,@(convert inits #t))
(list ,@(convert fields))
(list ,@(convert methods))
(list ,@(convert augments)))]
[(arr: dom rng rest drest kws) [(arr: dom rng rest drest kws)
`(make-arr ,(sub dom) ,(sub rng) ,(sub rest) ,(sub drest) ,(sub kws))] `(make-arr ,(sub dom) ,(sub rng) ,(sub rest) ,(sub drest) ,(sub kws))]
[(TypeFilter: t p i) [(TypeFilter: t p i)

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

@ -559,10 +559,10 @@
;;; Utilities for (Class ...) type parsing ;;; Utilities for (Class ...) type parsing
;; process-class-clauses : Option<F> Syntax FieldDict MethodDict ;; process-class-clauses : Option<F> Syntax FieldDict MethodDict AugmentDict
;; -> Option<Id> FieldDict MethodDict ;; -> Option<Id> FieldDict MethodDict AugmentDict
;; Merges #:implements class type and the current class clauses appropriately ;; Merges #:implements class type and the current class clauses appropriately
(define (merge-with-parent-type row-var stx fields methods) (define (merge-with-parent-type row-var stx fields methods augments)
;; (Listof Symbol) Dict Dict String -> (Values Dict Dict) ;; (Listof Symbol) Dict Dict String -> (Values Dict Dict)
;; check for duplicates in a class clause ;; check for duplicates in a class clause
(define (check-duplicate-clause names super-names types super-types err-msg) (define (check-duplicate-clause names super-names types super-types err-msg)
@ -584,19 +584,22 @@
(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) [(Class: row-var _ fields methods augments)
(values row-var fields methods)] (values row-var fields methods augments)]
[(? Mu?) [(? Mu?)
(match-parent-type (unfold parent-type))] (match-parent-type (unfold parent-type))]
[_ (tc-error "expected a class type for #:implements clause, got ~a" [_ (tc-error "expected a class type for #:implements clause, got ~a"
parent-type)])) parent-type)]))
(define-values (super-row-var super-fields super-methods) (define-values (super-row-var super-fields
super-methods super-augments)
(match-parent-type parent-type)) (match-parent-type parent-type))
(match-define (list (list field-names _) ...) fields) (match-define (list (list field-names _) ...) fields)
(match-define (list (list method-names _) ...) methods) (match-define (list (list method-names _) ...) methods)
(match-define (list (list augment-names _) ...) augments)
(match-define (list (list super-field-names _) ...) super-fields) (match-define (list (list super-field-names _) ...) super-fields)
(match-define (list (list super-method-names _) ...) super-methods) (match-define (list (list super-method-names _) ...) super-methods)
(match-define (list (list super-augment-names _) ...) super-augments)
;; if any duplicates are found between this class and the superclass ;; if any duplicates are found between this class and the superclass
;; type, then raise an error ;; type, then raise an error
@ -606,10 +609,15 @@
fields super-fields fields super-fields
"field or init-field name ~a conflicts with #:implements clause")) "field or init-field name ~a conflicts with #:implements clause"))
(define-values (checked-methods checked-super-methods) (define-values (checked-methods checked-super-methods)
(check-duplicate-clause (check-duplicate-clause
method-names super-method-names method-names super-method-names
methods super-methods methods super-methods
"method name ~a conflicts with #:implements clause")) "method name ~a conflicts with #:implements clause"))
(define-values (checked-augments checked-super-augments)
(check-duplicate-clause
augment-names super-augment-names
augments super-augments
"augmentable method name ~a conflicts with #:implements clause"))
;; it is an error for both the extending type and extended type ;; it is an error for both the extending type and extended type
;; to have row variables ;; to have row variables
@ -620,7 +628,17 @@
;; then append the super types if there were no errors ;; then append the super types if there were no errors
(define merged-fields (append checked-super-fields checked-fields)) (define merged-fields (append checked-super-fields checked-fields))
(define merged-methods (append checked-super-methods checked-methods)) (define merged-methods (append checked-super-methods checked-methods))
(values (or row-var super-row-var) merged-fields merged-methods)) (define merged-augments (append checked-super-augments checked-augments))
;; make sure augments and methods are disjoint
(define maybe-dup (check-duplicate (append (dict-keys merged-methods)
(dict-keys merged-augments))))
(when maybe-dup
(tc-error (~a "method name " maybe-dup " conflicts with"
" another method name or augmentable method name")))
(values (or row-var super-row-var) merged-fields
merged-methods merged-augments))
;; Syntax -> Type ;; Syntax -> Type
;; Parse a (Object ...) type ;; Parse a (Object ...) type
@ -635,7 +653,7 @@
(define methods (map list (define methods (map list
(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)))
(make-Instance (make-Class #f null fields methods))])) (make-Instance (make-Class #f null fields methods null))]))
;; Syntax -> Type ;; Syntax -> Type
;; Parse a (Class ...) type ;; Parse a (Class ...) type
@ -648,27 +666,31 @@
(define given-inits (attribute clause.inits)) (define given-inits (attribute clause.inits))
(define given-fields (attribute clause.fields)) (define given-fields (attribute clause.fields))
(define given-methods (attribute clause.methods)) (define given-methods (attribute clause.methods))
(define given-augments (attribute clause.augments))
(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))))
;; merge with all given parent types, erroring if needed ;; merge with all given parent types, erroring if needed
(define-values (row-var fields methods) (define-values (row-var fields methods augments)
(for/fold ([row-var given-row-var] (for/fold ([row-var given-row-var]
[fields given-fields] [fields given-fields]
[methods given-methods]) [methods given-methods]
[augments given-augments])
([parent-type parent-types]) ([parent-type parent-types])
(merge-with-parent-type row-var parent-type fields methods))) (merge-with-parent-type row-var parent-type fields
methods augments)))
;; check constraints on row var for consistency with class ;; check constraints on row var for consistency with class
(when (and row-var (has-row-constraints? (F-n row-var))) (when (and row-var (has-row-constraints? (F-n row-var)))
(define constraints (lookup-row-constraints (F-n row-var))) (define constraints (lookup-row-constraints (F-n row-var)))
(check-constraints given-inits (car constraints)) (check-constraints given-inits (car constraints))
(check-constraints fields (cadr constraints)) (check-constraints fields (cadr constraints))
(check-constraints methods (caddr constraints))) (check-constraints methods (caddr constraints))
(check-constraints augments (cadddr constraints)))
(define class-type (define class-type
(make-Class row-var given-inits fields methods)) (make-Class row-var given-inits fields methods augments))
class-type])) class-type]))

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

@ -289,11 +289,12 @@
(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: _ _ _ (list (list names functions) ...))) [(Instance: (Class: _ _ _ (list (list names functions) ...) _))
(object/sc (map (λ (n sc) (member-spec 'method n sc)) names (map t->sc/method functions)))] (object/sc (map (λ (n sc) (member-spec 'method n sc)) names (map t->sc/method functions)))]
[(Class: _ (list (list by-name-inits by-name-init-tys _) ...) [(Class: _ (list (list by-name-inits by-name-init-tys _) ...)
fields fields
(list (list names functions) ...)) (list (list names functions) ...)
_)
(class/sc (append (class/sc (append
(map (λ (n sc) (member-spec 'method n sc)) (map (λ (n sc) (member-spec 'method n sc))
names (map t->sc/method functions)) names (map t->sc/method functions))

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

@ -32,7 +32,7 @@
remove-dups remove-dups
sub-f sub-o sub-pe sub-f sub-o sub-pe
(rename-out [Class:* Class:] (rename-out [Class:* Class:]
[*Class make-Class] [Class* make-Class]
[Mu:* Mu:] [Mu:* Mu:]
[Poly:* Poly:] [Poly:* Poly:]
[PolyDots:* PolyDots:] [PolyDots:* PolyDots:]
@ -246,7 +246,7 @@
;; constraints are row absence constraints, represented ;; constraints are row absence constraints, represented
;; as a set for each of init, field, methods ;; as a set for each of init, field, methods
(def-type PolyRow (constraints body) #:no-provide (def-type PolyRow (constraints body) #:no-provide
[#:contract (->i ([constraints (list/c list? list? list?)] [#:contract (->i ([constraints (list/c list? list? list? list?)]
[body (scope-depth 1)]) [body (scope-depth 1)])
(#:syntax [stx (or/c #f syntax?)]) (#:syntax [stx (or/c #f syntax?)])
[result PolyRow?])] [result PolyRow?])]
@ -458,67 +458,51 @@
;; A Row used in type instantiation ;; A Row used in type instantiation
;; For now, this should not appear in user code. It's used ;; For now, this should not appear in user code. It's used
;; internally to perform row instantiations ;; internally to perform row instantiations
;;
;; FIXME: should Classes just use this?
;;
(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?))])
[#: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)
[#:fold-rhs (match (list inits fields methods) (map cadr augments)))))]
[#:fold-rhs (match (list inits fields methods augments)
[(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) ___))
(*Row (*Row
(map list (map list
init-names init-names
(map type-rec-id init-tys) (map type-rec-id init-tys)
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)))])])
;; row : Option<(U F Row)> ;; row-ext : Option<(U F B Row)>
;; name-inits : (Listof (Tuple Symbol Type Boolean)) ;; row : Row
;; fields : (Listof (Tuple Symbol Type))
;; methods : (Listof (Tuple Symbol Function))
;; ;;
;; interp. The first field represents a row variable. ;; interp. The first field represents a row extension
;; The second field represents the named ;; The second field represents the concrete row
;; initialization argument types. ;; that the class starts with
;; The remainder are the types for public fields and
;; public methods, respectively.
;; ;;
(def-type Class ([row (or/c #f F? B? Row?)] (def-type Class ([row-ext (or/c #f F? B? Row?)]
[inits (listof (list/c symbol? Type/c boolean?))] [row Row?])
[fields (listof (list/c symbol? Type/c))]
[methods (listof (list/c symbol? Function?))])
#:no-provide #:no-provide
[#:frees (λ (f) (combine-frees [#:frees (λ (f) (combine-frees
;; FIXME: is this correct? ;; FIXME: is this correct?
`(,@(or (and (F? row) (list (f row))) `(,@(or (and (F? row-ext) (list (f row-ext)))
'()) '())
,@(map f (append (map cadr inits) ,(f row))))]
(map cadr fields)
(map cadr methods))))))]
[#:key 'class] [#:key 'class]
[#:fold-rhs (match (list row inits fields methods) [#:fold-rhs (match (list row-ext row)
[(list [(list row-ext row)
row
(list (list init-names init-tys reqd) ___)
(list (list fname fty) ___)
(list (list mname mty) ___))
(*Class (*Class
(and row (type-rec-id row)) (and row-ext (type-rec-id row-ext))
(map list (type-rec-id row))])])
init-names
(map type-rec-id init-tys)
reqd)
(map list fname (map type-rec-id fty))
(map list mname (map type-rec-id mty)))])])
;; cls : Class ;; cls : Class
(def-type Instance ([cls Type/c]) [#:key 'instance]) (def-type Instance ([cls Type/c]) [#:key 'instance])
@ -920,6 +904,18 @@
(PolyRow-body* fresh-syms t))) (PolyRow-body* fresh-syms t)))
(list nps freshp constrp bp)))]))) (list nps freshp constrp bp)))])))
;; 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)
(-> (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?))
Class?)
(*Class row-var (*Row inits fields methods augments)))
;; Class:* ;; Class:*
;; This match expander replaces the built-in matching with ;; This match expander replaces the built-in matching with
;; a version that will merge the members inside the substituted row ;; a version that will merge the members inside the substituted row
@ -928,25 +924,30 @@
;; helper function for the expansion of Class:* ;; helper function for the expansion of Class:*
;; just does the merging ;; just does the merging
(define (merge-class/row class-type) (define (merge-class/row class-type)
(define row (Class-row class-type)) (define row (Class-row-ext class-type))
(define inits (Class-inits class-type)) (define class-row (Class-row class-type))
(define fields (Class-fields class-type)) (define inits (Row-inits class-row))
(define methods (Class-methods class-type)) (define fields (Row-fields class-row))
(define methods (Row-methods class-row))
(define augments (Row-augments 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))
(list row (list row
(append inits row-inits) (append inits row-inits)
(append fields row-fields) (append fields row-fields)
(append methods row-methods))] (append methods row-methods)
[else (list row inits fields methods)])) (append augments row-augments))]
[else (list row inits fields methods augments)]))
(define-match-expander Class:* (define-match-expander Class:*
(λ (stx) (λ (stx)
(syntax-case stx () (syntax-case stx ()
[(_ row-pat inits-pat fields-pat methods-pat) [(_ row-pat inits-pat fields-pat methods-pat augments-pat)
#'(? Class? #'(? Class?
(app merge-class/row (app merge-class/row
(list row-pat inits-pat fields-pat methods-pat)))]))) (list row-pat inits-pat fields-pat
methods-pat augments-pat)))])))

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

@ -4,6 +4,7 @@
(require "../utils/utils.rkt" (require "../utils/utils.rkt"
racket/dict racket/dict
racket/format
racket/match racket/match
racket/pretty ;; DEBUG ONLY racket/pretty ;; DEBUG ONLY
racket/set racket/set
@ -35,7 +36,8 @@
(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 optional-init c:field
c:public c:override c:private c:inherit private-field) c:public c:override c:private c:inherit private-field
c:augment c:pubment)
(pattern (begin (quote-syntax (pattern (begin (quote-syntax
(class:-internal (class:-internal
(c:init init-names:name-pair ...) (c:init init-names:name-pair ...)
@ -46,7 +48,9 @@
(c:override override-names:name-pair ...) (c:override override-names:name-pair ...)
(c:private privates:id ...) (c:private privates:id ...)
(private-field private-fields:id ...) (private-field private-fields:id ...)
(c:inherit inherit-names:name-pair ...))) (c:inherit inherit-names:name-pair ...)
(c:augment augment-names:name-pair ...)
(c:pubment pubment-names:name-pair ...)))
(#%plain-app values)) (#%plain-app values))
#:with init-internals #'(init-names.internal ...) #:with init-internals #'(init-names.internal ...)
#:with init-externals #'(init-names.external ...) #:with init-externals #'(init-names.external ...)
@ -61,6 +65,10 @@
#:with override-externals #'(override-names.external ...) #:with override-externals #'(override-names.external ...)
#:with inherit-externals #'(inherit-names.external ...) #:with inherit-externals #'(inherit-names.external ...)
#:with inherit-internals #'(inherit-names.internal ...) #:with inherit-internals #'(inherit-names.internal ...)
#:with augment-externals #'(augment-names.external ...)
#:with augment-internals #'(augment-names.internal ...)
#:with pubment-externals #'(pubment-names.external ...)
#:with pubment-internals #'(pubment-names.internal ...)
#:with private-names #'(privates ...) #:with private-names #'(privates ...)
#:with private-field-names #'(private-fields ...))) #:with private-field-names #'(private-fields ...)))
@ -119,6 +127,8 @@
public-internals public-externals public-internals public-externals
override-internals override-externals override-internals override-externals
inherit-internals inherit-externals inherit-internals inherit-externals
augment-internals augment-externals
pubment-internals pubment-externals
private-names private-field-names private-names private-field-names
make-methods make-methods
initializer-body initializer-body
@ -151,7 +161,7 @@
(match expected (match expected
[(tc-result1: (? Mu? type)) [(tc-result1: (? Mu? type))
(check-class form (ret (unfold type)))] (check-class form (ret (unfold type)))]
[(tc-result1: (and self-class-type (Class: _ _ _ _))) [(tc-result1: (and self-class-type (Class: _ _ _ _ _)))
(do-check form #t self-class-type)] (do-check form #t self-class-type)]
[#f (do-check form #f #f)])) [#f (do-check form #f #f)]))
@ -167,21 +177,24 @@
;; FIXME: maybe should check the property on this expression ;; FIXME: maybe should check the property on this expression
;; as a sanity check too ;; as a sanity check too
(define super-type (tc-expr #'cls.superclass-expr)) (define super-type (tc-expr #'cls.superclass-expr))
(define-values (super-inits super-fields super-methods) (define-values (super-inits super-fields
super-methods super-augments)
(match super-type (match super-type
;; FIXME: should handle the case where the super class is ;; FIXME: should handle the case where the super class is
;; polymorphic ;; polymorphic
[(tc-result1: (Class: _ super-inits super-fields super-methods)) [(tc-result1: (Class: _ super-inits super-fields
(values super-inits super-fields super-methods)] super-methods super-augments))
(values super-inits super-fields super-methods super-augments)]
[(tc-result1: t) [(tc-result1: t)
(tc-error/expr "expected a superclass but got ~a" t (tc-error/expr "expected a superclass but got ~a" t
#:stx #'cls.superclass-expr) #:stx #'cls.superclass-expr)
;; FIXME: is this the right thing to do? ;; FIXME: is this the right thing to do?
(values null null null)])) (values null null null null)]))
;; Define sets of names for use later ;; Define sets of names for use later
(define super-init-names (list->set (dict-keys super-inits))) (define super-init-names (list->set (dict-keys super-inits)))
(define super-field-names (list->set (dict-keys super-fields))) (define super-field-names (list->set (dict-keys super-fields)))
(define super-method-names (list->set (dict-keys super-methods))) (define super-method-names (list->set (dict-keys super-methods)))
(define super-augment-names (list->set (dict-keys super-augments)))
(define this%-init-internals (define this%-init-internals
(list->set (append (syntax->datum #'cls.init-internals) (list->set (append (syntax->datum #'cls.init-internals)
(syntax->datum #'cls.init-field-internals)))) (syntax->datum #'cls.init-field-internals))))
@ -189,6 +202,10 @@
(list->set (syntax->datum #'cls.public-internals))) (list->set (syntax->datum #'cls.public-internals)))
(define this%-override-internals (define this%-override-internals
(list->set (syntax->datum #'cls.override-internals))) (list->set (syntax->datum #'cls.override-internals)))
(define this%-pubment-internals
(list->set (syntax->datum #'cls.pubment-internals)))
(define this%-augment-internals
(list->set (syntax->datum #'cls.augment-internals)))
(define this%-method-internals (define this%-method-internals
(set-union this%-public-internals this%-override-internals)) (set-union this%-public-internals this%-override-internals))
(define this%-field-internals (define this%-field-internals
@ -208,14 +225,22 @@
(list->set (syntax->datum #'cls.public-externals))) (list->set (syntax->datum #'cls.public-externals)))
(define this%-override-names (define this%-override-names
(list->set (syntax->datum #'cls.override-externals))) (list->set (syntax->datum #'cls.override-externals)))
(define this%-pubment-names
(list->set (append (syntax->datum #'cls.pubment-externals))))
(define this%-augment-names
(list->set (append (syntax->datum #'cls.augment-externals))))
(define this%-inherit-names (define this%-inherit-names
(list->set (syntax->datum #'cls.inherit-externals))) (list->set (syntax->datum #'cls.inherit-externals)))
(define this%-private-names (define this%-private-names
(list->set (syntax->datum #'cls.private-names))) (list->set (syntax->datum #'cls.private-names)))
(define this%-private-fields (define this%-private-fields
(list->set (syntax->datum #'cls.private-field-names))) (list->set (syntax->datum #'cls.private-field-names)))
(define this%-method-names (define this%-overridable-names
(set-union this%-public-names this%-override-names)) (set-union this%-public-names this%-override-names))
(define this%-augmentable-names
(set-union this%-augment-names this%-pubment-names))
(define this%-method-names
(set-union this%-overridable-names this%-augmentable-names))
(define all-internal (define all-internal
(apply append (apply append
(map (λ (stx) (syntax->datum stx)) (map (λ (stx) (syntax->datum stx))
@ -224,7 +249,9 @@
#'cls.field-internals #'cls.field-internals
#'cls.public-internals #'cls.public-internals
#'cls.override-internals #'cls.override-internals
#'cls.inherit-internals)))) #'cls.inherit-internals
#'cls.pubment-internals
#'cls.augment-internals))))
(define all-external (define all-external
(apply append (apply append
(map (λ (stx) (syntax->datum stx)) (map (λ (stx) (syntax->datum stx))
@ -233,7 +260,9 @@
#'cls.field-externals #'cls.field-externals
#'cls.public-externals #'cls.public-externals
#'cls.override-externals #'cls.override-externals
#'cls.inherit-externals)))) #'cls.inherit-externals
#'cls.pubment-externals
#'cls.augment-externals))))
;; establish a mapping between internal and external names ;; establish a mapping between internal and external names
(define internal-external-mapping (define internal-external-mapping
(for/hash ([internal all-internal] (for/hash ([internal all-internal]
@ -272,16 +301,19 @@
remaining-super-inits remaining-super-inits
super-fields super-fields
super-methods super-methods
super-augments
this%-init-internals this%-init-internals
this%-field-internals this%-field-internals
this%-public-internals))) this%-public-internals
(match-define (Instance: (Class: _ inits fields methods)) this%-pubment-internals)))
(match-define (Instance: (Class: _ inits fields methods augments))
self-type) self-type)
;; trawl the body for the local name table ;; trawl the body for the local name table
(define locals (trawl-for-property #'cls.make-methods 'tr:class:local-table)) (define locals (trawl-for-property #'cls.make-methods '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-inherit-table local-super-table) local-inherit-table local-super-table
local-augment-table local-inner-table)
(construct-local-mapping-tables (car locals))) (construct-local-mapping-tables (car locals)))
;; types for private elements ;; types for private elements
(define private-method-types (define private-method-types
@ -310,6 +342,10 @@
super-methods super-methods
this%-inherit-internals this%-inherit-internals
this%-override-internals this%-override-internals
local-augment-table local-inner-table
augments super-augments
this%-pubment-internals
this%-augment-internals
local-private-table private-method-types local-private-table private-method-types
this%-private-names this%-private-names
#'cls.initializer-self-id #'cls.initializer-self-id
@ -327,35 +363,51 @@
(define meth-stxs (trawl-for-property #'cls.make-methods 'tr:class:method)) (define meth-stxs (trawl-for-property #'cls.make-methods 'tr:class:method))
(define checked-method-types (define checked-method-types
(with-lexical-env/extend lexical-names lexical-types (with-lexical-env/extend lexical-names lexical-types
(check-methods internal-external-mapping meth-stxs methods self-type))) (check-methods internal-external-mapping meth-stxs methods self-type
#:filter this%-overridable-names)))
(define checked-pubment-types
(with-lexical-env/extend lexical-names lexical-types
(check-methods internal-external-mapping meth-stxs augments self-type
#:filter this%-augmentable-names)))
(with-lexical-env/extend lexical-names lexical-types
(check-private-methods meth-stxs this%-private-names
private-method-types self-type))
(define final-class-type (define final-class-type
(if expected? (if expected?
self-class-type self-class-type
(merge-types self-type checked-method-types))) (merge-types
self-type
checked-method-types
checked-pubment-types)))
(check-method-presence-and-absence (check-method-presence-and-absence
final-class-type final-class-type
this%-init-names this%-field-names this%-init-names this%-field-names
this%-public-names this%-override-names this%-public-names this%-override-names
this%-inherit-names this%-inherit-names
this%-pubment-names this%-augment-names
(set-union optional-external optional-super) (set-union optional-external optional-super)
remaining-super-inits super-field-names remaining-super-inits super-field-names
super-method-names) super-method-names
super-augment-names)
final-class-type])) final-class-type]))
;; check-method-presence-and-absence : Type Set<Symbol> * 9 -> Void ;; check-method-presence-and-absence : Type Set<Symbol> * 12 -> Void
;; use the internal class: information to check whether clauses ;; use the internal class: information to check whether clauses
;; exist or are absent appropriately ;; exist or are absent appropriately
(define (check-method-presence-and-absence (define (check-method-presence-and-absence
class-type this%-init-names this%-field-names class-type this%-init-names this%-field-names
this%-public-names this%-override-names this%-public-names this%-override-names
this%-inherit-names this%-inherit-names
this%-pubment-names this%-augment-names
optional-external optional-external
remaining-super-inits super-field-names remaining-super-inits super-field-names
super-method-names) super-method-names
(match-define (Class: _ inits fields methods) class-type) super-augment-names)
(match-define (Class: _ inits fields methods augments) class-type)
(define exp-init-names (list->set (dict-keys inits))) (define exp-init-names (list->set (dict-keys inits)))
(define exp-field-names (list->set (dict-keys fields))) (define exp-field-names (list->set (dict-keys fields)))
(define exp-method-names (list->set (dict-keys methods))) (define exp-method-names (list->set (dict-keys methods)))
(define exp-augment-names (list->set (dict-keys augments)))
(define exp-optional-inits (define exp-optional-inits
(for/set ([(name val) (in-dict inits)] (for/set ([(name val) (in-dict inits)]
#:when (cadr val)) #:when (cadr val))
@ -370,23 +422,34 @@
(check-same (set-union this%-field-names super-field-names) (check-same (set-union this%-field-names super-field-names)
exp-field-names exp-field-names
"public field") "public field")
(check-same (set-union this%-pubment-names super-augment-names)
exp-augment-names
"public augmentable method")
(check-same optional-external exp-optional-inits (check-same optional-external exp-optional-inits
"optional init argument") "optional init argument")
(check-exists super-method-names this%-override-names (check-exists super-method-names this%-override-names
"override method") "override method")
(check-exists super-method-names this%-inherit-names (check-exists super-augment-names this%-augment-names
"augment method")
(check-exists (set-union super-method-names super-augment-names)
this%-inherit-names
"inherited method") "inherited method")
(check-absent super-field-names this%-field-names "public field") (check-absent super-field-names this%-field-names "public field")
(check-absent super-method-names this%-public-names "public method")) (check-absent super-method-names this%-public-names "public method")
(check-absent super-augment-names this%-pubment-names
"public augmentable method"))
;; merge-types : Type Dict<Symbol, Type> -> Type ;; merge-types : Type Dict<Symbol, Type> Dict<Symbol, Type> -> Type
;; Given a self object type, construct the real class type based on ;; Given a self object type, construct the real class type based on
;; new information found from type-checking. Only used when an expected ;; new information found from type-checking. Only used when an expected
;; type was not provided. ;; type was not provided.
(define (merge-types self-type method-types) (define (merge-types self-type method-types pubment-types)
(match-define (Instance: (and class-type (Class: #f inits fields methods))) (match-define
self-type) (Instance:
(define new-methods (and class-type
(Class: #f inits fields methods augments)))
self-type)
(define (make-new-methods methods method-types)
(for/fold ([methods methods]) (for/fold ([methods methods])
([(name type) (in-dict method-types)]) ([(name type) (in-dict method-types)])
(define old-type (dict-ref methods name #f)) (define old-type (dict-ref methods name #f))
@ -394,7 +457,9 @@
(when (and old-type (not (equal? old-type type))) (when (and old-type (not (equal? old-type type)))
(tc-error "merge-types: internal error")) (tc-error "merge-types: internal error"))
(dict-set methods name type))) (dict-set methods name type)))
(make-Class #f inits fields new-methods)) (make-Class #f inits fields
(make-new-methods methods method-types)
(make-new-methods augments pubment-types)))
;; local-tables->lexical-env : Dict<Symbol, Symbol> ;; local-tables->lexical-env : Dict<Symbol, Symbol>
;; LocalMapping NameTypeDict Names ;; LocalMapping NameTypeDict Names
@ -412,6 +477,9 @@
local-inherit-table local-super-table local-inherit-table local-super-table
super-types super-types
inherit-names override-names inherit-names override-names
local-augment-table local-inner-table
augments super-augments
pubment-names augment-names
local-private-table local-private-table
private-types private-methods private-types private-methods
self-id init-args-id self-id init-args-id
@ -434,21 +502,38 @@
(localize local-private-table private-methods)) (localize local-private-table private-methods))
(define localized-override-names (define localized-override-names
(localize local-super-table override-names)) (localize local-super-table override-names))
(define localized-pubment-names
(localize local-augment-table pubment-names))
(define localized-augment-names
(localize local-augment-table augment-names))
(define localized-inner-names
(localize local-inner-table (set-union pubment-names augment-names)))
(define localized-init-names (localize local-init-table init-names)) (define localized-init-names (localize local-init-table init-names))
(define default-type (list (make-Univ)))
;; construct the types for method accessors ;; construct the types for method accessors
(define (make-method-types method-names type-map) (define (make-method-types method-names type-map
#:inner? [inner? #f])
(for/list ([m (in-set method-names)]) (for/list ([m (in-set method-names)])
(define external (dict-ref internal-external-mapping m)) (define external (dict-ref internal-external-mapping m))
(define maybe-type (dict-ref type-map external #f)) (define maybe-type (dict-ref type-map external #f))
(->* (list (make-Univ)) (->* (list (make-Univ))
(if maybe-type (cond [(and maybe-type (not inner?))
(fixup-method-type (car maybe-type) self-type) (fixup-method-type (car maybe-type) self-type)]
(make-Univ))))) [maybe-type
(Un (-val #f)
(fixup-method-type (car maybe-type) self-type))]
[else (make-Univ)]))))
(define method-types (make-method-types method-names methods)) (define method-types (make-method-types method-names methods))
(define inherit-types (make-method-types inherit-names super-types)) (define inherit-types
(make-method-types
inherit-names
(append super-types super-augments)))
(define augment-types (make-method-types augment-names augments))
(define inner-types
(make-method-types
(set-union pubment-names augment-names)
augments #:inner? #t))
;; construct field accessor types ;; construct field accessor types
(define (make-field-types field-names type-map #:private? [private? #f]) (define (make-field-types field-names type-map #:private? [private? #f])
@ -483,6 +568,8 @@
(make-private-like-types private-methods private-types)) (make-private-like-types private-methods private-types))
(define super-call-types (define super-call-types
(make-private-like-types override-names super-types)) (make-private-like-types override-names super-types))
(define pubment-types
(make-private-like-types pubment-names augments))
(define init-types (define init-types
(for/list ([i (in-set init-names)]) (for/list ([i (in-set init-names)])
@ -496,11 +583,15 @@
localized-private-field-get-names localized-private-field-get-names
localized-private-field-set-names localized-private-field-set-names
localized-inherit-names localized-inherit-names
localized-override-names)) localized-override-names
localized-pubment-names
localized-augment-names
localized-inner-names))
(define all-types (append method-types private-method-types (define all-types (append method-types private-method-types
field-get-types field-set-types field-get-types field-set-types
private-field-get-types private-field-set-types private-field-get-types private-field-set-types
inherit-types super-call-types)) inherit-types super-call-types
pubment-types augment-types inner-types))
(values all-names all-types (values all-names all-types
;; FIXME: consider removing method names and types ;; FIXME: consider removing method names and types
;; from top-level environment to avoid <undefined> ;; from top-level environment to avoid <undefined>
@ -519,11 +610,13 @@
;; -> Dict<Symbol, Type> ;; -> Dict<Symbol, Type>
;; Type-check the methods inside of a class ;; Type-check the methods inside of a class
(define (check-methods internal-external-mapping (define (check-methods internal-external-mapping
meths methods self-type) meths methods self-type
(for/list ([meth meths]) #:filter [filter #f])
(for/fold ([checked '()])
([meth meths])
(define method-name (syntax-property meth 'tr:class:method)) (define method-name (syntax-property meth 'tr:class:method))
(define external-name (dict-ref internal-external-mapping method-name)) (define external-name (dict-ref internal-external-mapping method-name #f))
(define maybe-expected (dict-ref methods external-name #f)) (define maybe-expected (and external-name (dict-ref methods external-name #f)))
(cond [maybe-expected (cond [maybe-expected
(define pre-method-type (car maybe-expected)) (define pre-method-type (car maybe-expected))
(define method-type (define method-type
@ -531,9 +624,34 @@
(define expected (ret method-type)) (define expected (ret method-type))
(define annotated (annotate-method meth self-type method-type)) (define annotated (annotate-method meth self-type method-type))
(tc-expr/check annotated expected) (tc-expr/check annotated expected)
(list external-name pre-method-type)] (cons (list external-name pre-method-type) checked)]
[else (list external-name ;; Only try to type-check if these names are in the
(unfixup-method-type (tc-expr/t meth)))]))) ;; filter when it's provided. This allows us to, say, only
;; type-check pubments/augments.
[(and filter (set-member? filter external-name))
(cons (list external-name
(unfixup-method-type (tc-expr/t meth)))
checked)]
[else checked])))
;; check-private-methods : Listof<Syntax> Listof<Sym> Dict<Sym, Type> Type
;; -> Void
;; Type-check private methods
(define (check-private-methods stxs names types self-type)
(for ([stx stxs])
(define method-name (syntax-property stx 'tr:class:method))
(define private? (set-member? names method-name))
(define annotation (dict-ref types method-name #f))
(cond [(and private? annotation)
(define pre-method-type annotation)
(define method-type
(fixup-method-type pre-method-type self-type))
(define expected (ret method-type))
(define annotated (annotate-method stx self-type method-type))
(tc-expr/check annotated expected)]
;; not private, then ignore since it's irrelevant
[(not private?) (void)]
[else (tc-expr/t stx)])))
;; check-field-set!s : Syntax Dict<Symbol, Symbol> Dict<Symbol, Type> -> Void ;; check-field-set!s : Syntax Dict<Symbol, Symbol> Dict<Symbol, Type> -> Void
;; Check that fields are initialized to the correct type ;; Check that fields are initialized to the correct type
@ -635,7 +753,7 @@
;; generated inside the untyped class macro. ;; generated inside the untyped class macro.
(define (construct-local-mapping-tables stx) (define (construct-local-mapping-tables stx)
(syntax-parse stx (syntax-parse stx
#:literals (let-values #%plain-app #%plain-lambda values) #:literals (let-values if quote #%plain-app #%plain-lambda values)
;; See base-env/class-prims.rkt to see how this in-syntax ;; See base-env/class-prims.rkt to see how this in-syntax
;; table is constructed at the surface syntax ;; table is constructed at the surface syntax
;; ;;
@ -681,6 +799,15 @@
(#%plain-lambda () (#%plain-lambda ()
(#%plain-app (#%plain-app local-override:id _) _) (#%plain-app (#%plain-app local-override:id _) _)
(#%plain-app local-super:id _)) (#%plain-app local-super:id _))
...)]
[(augment:id ...)
(#%plain-app
values
(#%plain-lambda ()
(~or (#%plain-app local-augment:id _)
(#%plain-app (#%plain-app local-augment:id _) _))
(let-values ([(_) (#%plain-app local-inner:id _)])
(if _ (#%plain-app _ _) _)))
...)]) ...)])
(#%plain-app void)) (#%plain-app void))
(values (map cons (values (map cons
@ -707,7 +834,13 @@
(syntax->list #'(local-inherit ...))) (syntax->list #'(local-inherit ...)))
(map cons (map cons
(syntax->datum #'(override ...)) (syntax->datum #'(override ...))
(syntax->list #'(local-super ...))))])) (syntax->list #'(local-super ...)))
(map cons
(syntax->datum #'(augment ...))
(syntax->list #'(local-augment ...)))
(map cons
(syntax->datum #'(augment ...))
(syntax->list #'(local-inner ...))))]))
;; check-super-new-exists : Listof<Syntax> -> (U Syntax #f) ;; check-super-new-exists : Listof<Syntax> -> (U Syntax #f)
;; Check if a `super-new` call exists and if there is only ;; Check if a `super-new` call exists and if there is only
@ -754,27 +887,26 @@
;; Look through the expansion of the class macro in search for ;; Look through the expansion of the class macro in search for
;; syntax with some property (e.g., methods) ;; syntax with some property (e.g., methods)
(define (trawl-for-property form prop) (define (trawl-for-property form prop)
(define (recur-on-all stx-list)
(apply append (map (λ (stx) (trawl-for-property stx prop))
(syntax->list stx-list))))
(syntax-parse form (syntax-parse form
#:literals (let-values letrec-values #%plain-app #:literals (let-values letrec-values #%plain-app
letrec-syntaxes+values) #%plain-lambda letrec-syntaxes+values)
[stx [stx
#:when (syntax-property form prop) #:when (syntax-property form prop)
(list form)] (list form)]
[(let-values (b ...) [(let-values (b ...) body ...)
body) (recur-on-all #'(b ... body ...))]
(trawl-for-property #'body prop)] ;; for letrecs, traverse the RHSs too
[(letrec-values (b ...) [(letrec-values ([(x ...) rhs ...] ...) body ...)
body) (recur-on-all #'(rhs ... ... body ...))]
(trawl-for-property #'body prop)] [(letrec-syntaxes+values (sb ...) ([(x ...) rhs ...] ...) body ...)
[(letrec-syntaxes+values (sb ...) (vb ...) (recur-on-all #'(rhs ... ... body ...))]
body)
(trawl-for-property #'body prop)]
[(#%plain-app e ...) [(#%plain-app e ...)
(apply append (map (λ (stx) (trawl-for-property stx prop)) (recur-on-all #'(e ...))]
(syntax->list #'(e ...))))]
[(#%plain-lambda (x ...) e ...) [(#%plain-lambda (x ...) e ...)
(apply append (map (λ (stx) (trawl-for-property stx prop)) (recur-on-all #'(e ...))]
(syntax->list #'(e ...))))]
[_ '()])) [_ '()]))
;; register-internals : Listof<Syntax> -> Dict<Symbol, Type> ;; register-internals : Listof<Syntax> -> Dict<Symbol, Type>
@ -797,13 +929,14 @@
;; infer-self-type : Dict<Symbol, Type> Set<Symbol> Dict<Symbol, Symbol> ;; infer-self-type : Dict<Symbol, Type> Set<Symbol> Dict<Symbol, Symbol>
;; Inits Fields Methods ;; Inits Fields Methods
;; Set<Symbol> * 3 -> Type ;; Set<Symbol> * 4 -> Type
;; Construct a self object type based on the registered types ;; Construct a self object type based on the registered types
;; from : inside the class body. ;; from : inside the class body.
(define (infer-self-type internals-table optional-inits (define (infer-self-type internals-table optional-inits
internal-external-mapping internal-external-mapping
super-inits super-fields super-methods super-inits super-fields super-methods
inits fields publics) super-augments
inits fields publics augments)
(define (make-type-dict names supers [inits? #f]) (define (make-type-dict names supers [inits? #f])
(for/fold ([type-dict supers]) (for/fold ([type-dict supers])
([name names]) ([name names])
@ -819,7 +952,9 @@
(define init-types (make-type-dict inits super-inits #t)) (define init-types (make-type-dict inits super-inits #t))
(define field-types (make-type-dict fields super-fields)) (define field-types (make-type-dict fields super-fields))
(define public-types (make-type-dict publics super-methods)) (define public-types (make-type-dict publics super-methods))
(make-Instance (make-Class #f init-types field-types public-types))) (define augment-types (make-type-dict augments super-augments))
(make-Instance (make-Class #f init-types field-types
public-types augment-types)))
;; fixup-method-type : Function Type -> Function ;; fixup-method-type : 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
@ -831,7 +966,7 @@
(match-define (arr: doms rng rest drest kws) arr) (match-define (arr: doms rng rest drest kws) arr)
(make-arr (cons self-type doms) rng rest drest kws))) (make-arr (cons self-type doms) rng rest drest kws)))
(make-Function fixed-arrs)] (make-Function fixed-arrs)]
[_ (displayln type) (tc-error "fixup-method-type: internal error")])) [_ (tc-error "fixup-method-type: internal error")]))
;; unfixup-method-type : Function -> Function ;; unfixup-method-type : Function -> Function
;; Turn a "real" method type back into a function type ;; Turn a "real" method type back into a function type
@ -919,7 +1054,6 @@
;; check that the actual names don't include names not in the ;; check that the actual names don't include names not in the
;; expected type (i.e., the names must exactly match up) ;; expected type (i.e., the names must exactly match up)
(define (check-no-extra actual expected) (define (check-no-extra actual expected)
(printf "actual : ~a expected : ~a~n" actual expected)
(unless (subset? actual expected) (unless (subset? actual expected)
;; FIXME: better error reporting here ;; FIXME: better error reporting here
(tc-error/expr "class defines names not in expected type"))) (tc-error/expr "class defines names not in expected type")))

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

@ -47,7 +47,7 @@
(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 _ _))
(define init-names (map car inits)) (define init-names (map car inits))
(for ([given-name given-names] (for ([given-name given-names]
#:unless (memq given-name init-names)) #:unless (memq given-name init-names))
@ -83,7 +83,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

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

@ -16,10 +16,10 @@
(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 augments))))
(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 (append methods augments)) => cadr]
[else (tc-error/expr "send: method ~a not understood by class ~a" s c)])] [else (tc-error/expr "send: method ~a not understood by class ~a" s c)])]
[retval (tc/funapp rcvr args (ret ftype) (stx-map tc-expr args) expected)]) [retval (tc/funapp rcvr args (ret ftype) (stx-map tc-expr args) expected)])
(add-typeof-expr form retval) (add-typeof-expr form retval)

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

@ -28,7 +28,7 @@
;; Data definitions ;; Data definitions
;; ;;
;; A RowConstraint is a ;; A RowConstraint is a
;; List(List<Sym>, List<Sym>, List<Sym>) ;; List(List<Sym>, List<Sym>, List<Sym>, List<Sym>)
;; Syntax -> Syntax ;; Syntax -> Syntax
;; Turn into datums and then flatten ;; Turn into datums and then flatten
@ -37,16 +37,18 @@
;; Syntax classes for rows ;; Syntax classes for rows
(define-splicing-syntax-class row-constraints (define-splicing-syntax-class row-constraints
#:literals (init init-field field) #:literals (init init-field field augment)
(pattern (~seq (~or (init iname:id ...) (pattern (~seq (~or (init iname:id ...)
(init-field ifname:id ...) (init-field ifname:id ...)
(field fname:id ...) (field fname:id ...)
(augment aname:id ...)
mname:id) mname:id)
...) ...)
#:attr init-names (flatten/datum #'((iname ...) ...)) #:attr init-names (flatten/datum #'((iname ...) ...))
#:attr init-field-names (flatten/datum #'((ifname ...) ...)) #:attr init-field-names (flatten/datum #'((ifname ...) ...))
#:attr field-names (flatten/datum #'((fname ...) ...)) #:attr field-names (flatten/datum #'((fname ...) ...))
#:attr method-names (syntax->datum #'(mname ...)) #:attr method-names (syntax->datum #'(mname ...))
#:attr augment-names (flatten/datum #'((aname ...) ...))
#:attr all-field-names (append (attribute init-field-names) #:attr all-field-names (append (attribute init-field-names)
(attribute field-names)) (attribute field-names))
#:attr all-init-names (append (attribute init-field-names) #:attr all-init-names (append (attribute init-field-names)
@ -57,19 +59,25 @@
#:fail-when #:fail-when
(check-duplicate (attribute all-field-names)) (check-duplicate (attribute all-field-names))
"duplicate field or init-field clause" "duplicate field or init-field clause"
#:fail-when
(check-duplicate (append (attribute method-names)
(attribute augment-names)))
"duplicate method or augmentable method clause"
#:attr constraints #:attr constraints
(list (attribute all-init-names) (list (attribute all-init-names)
(attribute all-field-names) (attribute all-field-names)
(attribute method-names)))) (attribute method-names)
(attribute augment-names))))
;; Row RowConstraints (Symbol -> Void) -> Void ;; Row RowConstraints (Symbol -> Void) -> Void
;; Check if the given row satisfies the absence constraints ;; Check if the given row satisfies the absence constraints
;; on the row variable or not. Call the fail thunk if it ;; on the row variable or not. Call the fail thunk if it
;; doesn't. ;; doesn't.
(define (check-row-constraints row constraints fail) (define (check-row-constraints row constraints fail)
(match-define (list init-absents field-absents method-absents) (match-define (list init-absents field-absents
method-absents augment-absents)
constraints) constraints)
(match-define (Row: inits fields methods) 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)])
@ -77,7 +85,8 @@
(fail name)))) (fail name))))
(check-clauses inits init-absents) (check-clauses inits init-absents)
(check-clauses fields field-absents) (check-clauses fields field-absents)
(check-clauses methods method-absents)) (check-clauses methods method-absents)
(check-clauses augments augment-absents))
;; Row types are similar to class types ;; Row types are similar to class types
(define-splicing-syntax-class (row-clauses parse-type) (define-splicing-syntax-class (row-clauses parse-type)
@ -87,9 +96,11 @@
#: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 row (make-Row (attribute inits) #:attr row (make-Row (attribute inits)
(attribute fields) (attribute fields)
(attribute methods)) (attribute methods)
(attribute augments))
#: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"
@ -97,45 +108,51 @@
(check-duplicate (map first (attribute fields))) (check-duplicate (map first (attribute fields)))
"duplicate field or init-field clause" "duplicate field or init-field clause"
#:fail-when #:fail-when
(check-duplicate (map first (attribute methods))) (check-duplicate (map first (append (attribute methods)
"duplicate method clause")) (attribute augments))))
"duplicate method or augmentable method clause"))
;; Type -> RowConstraint ;; Type -> RowConstraint
;; Infer constraints on a row for a row polymorphic function ;; Infer constraints on a row for a row polymorphic function
(define (infer-row-constraints type) (define (infer-row-constraints type)
(define constraints (list null null null)) (define constraints (list null null null null))
;; Crawl the type tree and mutate constraints when a ;; Crawl the type tree and mutate constraints when a
;; class type with row variable is found. ;; class type with row variable is found.
(define (inf type) (define (inf type)
(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 [#:Class row inits fields methods augments
(cond (cond
[(and row (F? row)) [(and row (F? row))
(match-define (list init-cs field-cs method-cs) constraints) (match-define (list init-cs field-cs method-cs augment-cs)
constraints)
(set! constraints (set! constraints
(list (append (dict-keys inits) init-cs) (list (append (dict-keys inits) init-cs)
(append (dict-keys fields) field-cs) (append (dict-keys fields) field-cs)
(append (dict-keys methods) method-cs))) (append (dict-keys methods) method-cs)
(make-Class row inits fields methods)] (append (dict-keys augments) augment-cs)))
(make-Class row inits fields methods augments)]
[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)
(match-define (list (list method-names method-tys) ...) methods) (match-define (list (list method-names method-tys) ...) methods)
(match-define (list (list augment-names augment-tys) ...) augments)
(make-Class (make-Class
(and row (inf row)) (and row (inf row))
(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)))])]))
(inf type) (inf type)
(map remove-duplicates constraints)) (map remove-duplicates constraints))
;; infer-row : RowConstraints Type -> Row ;; infer-row : RowConstraints Type -> Row
;; Infer a row based on a class type and row constraints ;; Infer a row based on a class type and row constraints
(define (infer-row constraints class-type) (define (infer-row constraints class-type)
(match-define (list init-cs field-cs method-cs) constraints) (match-define (list init-cs field-cs method-cs augment-cs)
(match-define (Class: _ inits fields methods) constraints)
(match-define (Class: _ inits fields methods augments)
(resolve class-type)) (resolve class-type))
(define (dict-remove* dict keys) (define (dict-remove* dict keys)
(for/fold ([dict dict]) (for/fold ([dict dict])
@ -143,7 +160,8 @@
(dict-remove dict key))) (dict-remove dict key)))
(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)))
;; Syntax -> Syntax ;; Syntax -> Syntax
;; removes two levels of nesting ;; removes two levels of nesting
@ -177,7 +195,7 @@
(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) inits fields methods augments)
(pattern (~seq (~or (~optional (~seq #:row-var row-var:id)) (pattern (~seq (~or (~optional (~seq #:row-var row-var:id))
(~seq #:implements extends-type:expr) (~seq #:implements extends-type:expr)
(~var clause (type-clause parse-type))) (~var clause (type-clause parse-type)))
@ -185,6 +203,7 @@
#: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))
#: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)))
@ -193,8 +212,9 @@
(check-duplicate (map first (attribute fields))) (check-duplicate (map first (attribute fields)))
"duplicate field or init-field clause" "duplicate field or init-field clause"
#:fail-when #:fail-when
(check-duplicate (map first (attribute methods))) (check-duplicate (map first (append (attribute methods)
"duplicate method clause")) (attribute augments))))
"duplicate method or augmentable method clause"))
;; Stx Stx Listof<Boolean> (Stx -> Type) -> Listof<(List Symbol Type Boolean)> ;; Stx Stx Listof<Boolean> (Stx -> Type) -> Listof<(List Symbol Type Boolean)>
;; Construct init entries for a dictionary for the class type ;; Construct init entries for a dictionary for the class type
@ -207,18 +227,20 @@
optional?))) optional?)))
;; Stx Stx (Stx -> Type) -> Listof<(List Symbol Type)> ;; Stx Stx (Stx -> Type) -> Listof<(List Symbol Type)>
;; Construct field entries for a class type dictionary ;; Construct field/augment entries for a class type dictionary
(define (make-field-entries labels types parse-type) (define (make-field/augment-entries labels types parse-type)
(for/list ([label (in-syntax labels)] (for/list ([label (in-syntax labels)]
[type (in-syntax types)]) [type (in-syntax types)])
(list (syntax-e label) (parse-type type)))) (list (syntax-e label) (parse-type type))))
(define-syntax-class (type-clause parse-type) (define-syntax-class (type-clause parse-type)
#:attributes (init-entries field-entries method-entries) #:attributes (init-entries field-entries
#:literals (init init-field field) method-entries augment-entries)
#:literals (init init-field field augment)
(pattern (~or (init init-clause:init-type ...) (pattern (~or (init init-clause:init-type ...)
(init-field init-field-clause:init-type ...) (init-field init-field-clause:init-type ...)
(field field-clause:field-or-method-type ...) (field field-clause:field-or-method-type ...)
(augment augment-clause:field-or-method-type ...)
method-clause:field-or-method-type) method-clause:field-or-method-type)
#:attr init-entries #:attr init-entries
(append (if (attribute init-clause) (append (if (attribute init-clause)
@ -237,13 +259,13 @@
null)) null))
#:attr field-entries #:attr field-entries
(append (if (attribute field-clause) (append (if (attribute field-clause)
(make-field-entries (make-field/augment-entries
#'(field-clause.label ...) #'(field-clause.label ...)
#'(field-clause.type ...) #'(field-clause.type ...)
parse-type) parse-type)
null) null)
(if (attribute init-field-clause) (if (attribute init-field-clause)
(make-field-entries (make-field/augment-entries
#'(init-field-clause.label ...) #'(init-field-clause.label ...)
#'(init-field-clause.type ...) #'(init-field-clause.type ...)
parse-type) parse-type)
@ -252,6 +274,13 @@
(if (attribute method-clause) (if (attribute method-clause)
(list (list (syntax-e #'method-clause.label) (list (list (syntax-e #'method-clause.label)
(parse-type #'method-clause.type))) (parse-type #'method-clause.type)))
null)
#:attr augment-entries
(if (attribute augment-clause)
(make-field/augment-entries
#'(augment-clause.label ...)
#'(augment-clause.type ...)
parse-type)
null))) null)))
(define-syntax-class init-type (define-syntax-class init-type

9
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) cls) (match-define (Class: row-var inits fields methods augments) 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*
@ -355,7 +355,12 @@
(for/list ([name+type (in-list methods)]) (for/list ([name+type (in-list methods)])
(match-define (list name type) name+type) (match-define (list name type) name+type)
`(,name ,(type->sexp type)))) `(,name ,(type->sexp type))))
`(,(if object? 'Object 'Class) ,@row-var* ,@inits* ,@fields* ,@methods*)) (define augments*
(cond [(null? augments) '()]
[object? augments]
[else (list (cons 'augment augments))]))
`(,(if object? 'Object 'Class)
,@row-var* ,@inits* ,@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

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

@ -577,16 +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: t) (Instance: t*)) [((Instance: (Class: _ _ field-map method-map augment-map))
(subtype* A0 t t*)] (Instance: (Class: _ _ field-map* method-map* augment-map*)))
[((Class: _ '() fields (list (and s (list names meths )) ...))
(Class: _ '() fields (list (and s* (list names* meths*)) ...)))
(for/fold ([A A0])
([n (in-list names*)] [m (in-list meths*)] #:break (not A))
(and A (cond [(assq n s) => (lambda (spec) (subtype* A (cadr spec) m))]
[else #f])))]
[((Instance: (Class: _ _ field-map method-map))
(Instance: (Class: _ _ field-map* method-map*)))
(define (subtype-clause? map map*) (define (subtype-clause? map map*)
(match-define (list (and s (list names types)) ...) map) (match-define (list (and s (list names types)) ...) map)
(match-define (list (and s* (list names* types*)) ...) map*) (match-define (list (and s* (list names* types*)) ...) map*)
@ -595,10 +587,13 @@
(and A (cond [(assq n s) => (and A (cond [(assq n s) =>
(lambda (spec) (subtype* A (cadr spec) m))] (lambda (spec) (subtype* A (cadr spec) m))]
[else #f])))) [else #f]))))
(and (subtype-clause? method-map method-map*) (and ;; Note that augment/public doesn't matter for object
;; subtyping, so these mappings can be merged
(subtype-clause? (append method-map augment-map)
(append method-map* augment-map*))
(subtype-clause? field-map field-map*))] (subtype-clause? field-map field-map*))]
[((Class: row inits fields methods) [((Class: row inits fields methods augments)
(Class: row* inits* fields* methods*)) (Class: row* inits* fields* methods* augments*))
;; check that each of inits, fields, methods, etc. are ;; check that each of inits, fields, methods, etc. are
;; equal by sorting and checking type equality ;; equal by sorting and checking type equality
(define (equal-clause? clause clause* [inits? #f]) (define (equal-clause? clause clause* [inits? #f])
@ -630,7 +625,9 @@
(equal? row row*)) (equal? row row*))
(equal-clause? inits inits* #t) (equal-clause? inits inits* #t)
(equal-clause? fields fields*) (equal-clause? fields fields*)
(equal-clause? methods methods*))] ;; augment/public distinction is important here
(equal-clause? methods methods*)
(equal-clause? augments augments*))]
;; otherwise, not a subtype ;; otherwise, not a subtype
[(_ _) #f]))) [(_ _) #f])))
(when (null? A) (when (null? A)

113
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt
View File

@ -826,5 +826,116 @@
(define (f cls) (define (f cls)
(class: cls (super-new) (class: cls (super-new)
(field [x 5]))) (field [x 5])))
(inst f #:row (field [x Integer]))))) (inst f #:row (field [x Integer])))
;; Check simple use of pubment
(check-ok
(define c%
(class: object%
(super-new)
(: m (Integer -> Integer))
(define/pubment (m x) 0)))
(send (new c%) m 3))
;; Local calls to pubment method
(check-ok
(define c%
(class: object%
(super-new)
(: m (Integer -> Integer))
(define/pubment (m x) 0)
(: n (-> Number))
(define/public (n) (m 5))))
(send (new c%) n))
;; Inheritance with augment
(check-ok
(define c%
(class: object%
(super-new)
(: m (Integer -> Integer))
(define/pubment (m x) 0)))
(define d%
(class: c%
(super-new)
(define/augment (m x)
(+ 1 x))))
(send (new c%) m 5))
;; Pubment with inner
(check-ok
(define c%
(class: object%
(super-new)
(: m (Integer -> Integer))
(define/pubment (m x)
(inner 0 m x))))
(define d%
(class: c%
(super-new)
(define/augment (m x)
(+ 1 x))))
(send (new c%) m 0))
;; Fail, bad inner default
(check-err
(define c%
(class: object%
(super-new)
(: m (Integer -> Integer))
(define/pubment (m x)
(inner "foo" m x)))))
;; Fail, wrong number of arguments to inner
(check-err
(define c%
(class: object%
(super-new)
(: m (Integer -> Integer))
(define/pubment (m x)
(inner 3 m)))))
;; Fail, bad augment type
(check-err
(define c%
(class: object%
(super-new)
(: m (Integer -> Integer))
(define/pubment (m x)
(inner 0 m x))))
(define d%
(class: c%
(super-new)
(define/augment (m x) "bad type"))))
;; Fail, cannot augment non-augmentable method
(check-err
(define c%
(class: object%
(super-new)
(: m (Integer -> Integer))
(define/public (m x) 0)))
(define d%
(class: c%
(super-new)
(define/augment (m x) 1))))
;; Pubment with separate internal/external names
(check-ok
(define c%
(class: object%
(super-new)
(: m (Integer -> Integer))
(pubment [n m])
(define n (λ (x) 0))))
(send (new c%) m 0))
;; Pubment with expected class type
(check-ok
(: c% (Class (augment [m (Natural -> Natural)])))
(define c%
(class: object%
(super-new)
(define/pubment (m x) 0)))
(send (new c%) m 3))))

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

@ -18,7 +18,7 @@
(base-env base-types base-types-extra colon) (base-env base-types base-types-extra colon)
;; needed for parsing case-lambda/case-> types ;; needed for parsing case-lambda/case-> types
(only-in (base-env case-lambda) case-lambda) (only-in (base-env case-lambda) case-lambda)
(only-in racket/class init init-field field) (only-in racket/class init init-field field augment)
rackunit) rackunit)
@ -200,20 +200,24 @@
(->optkey -String [] #:rest -String #:a -String #f -String)] (->optkey -String [] #:rest -String #:a -String #f -String)]
;;; Classes ;;; Classes
[(Class) (make-Class #f null null null)] [(Class) (make-Class #f null null null null)]
[(Class (init [x Number] [y Number])) [(Class (init [x Number] [y Number]))
(make-Class #f `((x ,-Number #f) (y ,-Number #f)) null null)] (make-Class #f `((x ,-Number #f) (y ,-Number #f)) null null null)]
[(Class (init [x Number] [y Number #:optional])) [(Class (init [x Number] [y Number #:optional]))
(make-Class #f `((x ,-Number #f) (y ,-Number #t)) null null)] (make-Class #f `((x ,-Number #f) (y ,-Number #t)) null null null)]
[(Class (init [x Number]) (init-field [y Number])) [(Class (init [x Number]) (init-field [y Number]))
(make-Class #f `((x ,-Number #f) (y ,-Number #f)) `((y ,-Number)) (make-Class #f `((x ,-Number #f) (y ,-Number #f)) `((y ,-Number))
null)] null null)]
[(Class [m (Number -> Number)]) [(Class [m (Number -> Number)])
(make-Class #f null null `((m ,(t:-> N N))))] (make-Class #f null null `((m ,(t:-> N N))) null)]
[(Class [m (Number -> Number)] (init [x Number])) [(Class [m (Number -> Number)] (init [x Number]))
(make-Class #f `((x ,-Number #f)) null `((m ,(t:-> N N))))] (make-Class #f `((x ,-Number #f)) null `((m ,(t:-> N N))) null)]
[(Class [m (Number -> Number)] (field [x Number])) [(Class [m (Number -> Number)] (field [x Number]))
(make-Class #f null `((x ,-Number)) `((m ,(t:-> N N))))] (make-Class #f null `((x ,-Number)) `((m ,(t:-> N N))) null)]
[(Class (augment [m (Number -> Number)]))
(make-Class #f null null null `((m ,(t:-> N N))))]
[(Class (augment [m (Number -> Number)]) (field [x Number]))
(make-Class #f null `((x ,-Number)) null `((m ,(t:-> N N))))]
[FAIL (Class foobar)] [FAIL (Class foobar)]
[FAIL (Class [x UNBOUND])] [FAIL (Class [x UNBOUND])]
[FAIL (Class [x Number #:random-keyword])] [FAIL (Class [x Number #:random-keyword])]
@ -223,19 +227,21 @@
[FAIL (Class (init [x Number]) (init [x Number]))] [FAIL (Class (init [x Number]) (init [x Number]))]
[FAIL (Class (init [x Number]) (init-field [x Number]))] [FAIL (Class (init [x Number]) (init-field [x Number]))]
[FAIL (Class (field [x Number]) (init-field [x Number]))] [FAIL (Class (field [x Number]) (init-field [x Number]))]
[FAIL (Class (augment [x (-> Number)]) [x (-> Number)])]
[FAIL (Class (augment [x (-> Number)] [x (-> String)]))]
;; test #:row-var ;; test #:row-var
[(All (r #:row) (Class #:row-var r)) [(All (r #:row) (Class #:row-var r))
(make-PolyRow (list 'r) (make-PolyRow (list 'r)
(list null null null) (list null null null null)
(make-Class (make-F 'r) null null null))] (make-Class (make-F 'r) null null null null))]
[(All (r #:row) (Class #:implements (Class #:row-var r))) [(All (r #:row) (Class #:implements (Class #:row-var r)))
(make-PolyRow (list 'r) (make-PolyRow (list 'r)
(list null null null) (list null null null null)
(make-Class (make-F 'r) null null null))] (make-Class (make-F 'r) null null null null))]
[(All (r #:row) (Class #:implements (Class) #:row-var r)) [(All (r #:row) (Class #:implements (Class) #:row-var r))
(make-PolyRow (list 'r) (make-PolyRow (list 'r)
(list null null null) (list null null null null)
(make-Class (make-F 'r) null null null))] (make-Class (make-F 'r) null null null null))]
[FAIL (Class #:row-var 5)] [FAIL (Class #:row-var 5)]
[FAIL (Class #:row-var (list 3))] [FAIL (Class #:row-var (list 3))]
[FAIL (Class #:implements (Class #:row-var r) #:row-var x)] [FAIL (Class #:implements (Class #:row-var r) #:row-var x)]
@ -246,30 +252,37 @@
[FAIL (All (r #:row) (Class #:implements (Class #:row-var r) #:row-var r))] [FAIL (All (r #:row) (Class #:implements (Class #:row-var r) #:row-var r))]
;; test #:implements ;; test #:implements
[(Class #:implements (Class [m (Number -> Number)]) (field [x Number])) [(Class #:implements (Class [m (Number -> Number)]) (field [x Number]))
(make-Class #f null `((x ,-Number)) `((m ,(t:-> N N))))] (make-Class #f null `((x ,-Number)) `((m ,(t:-> N N))) null)]
[(Class #:implements (Class [m (Number -> Number)]) [(Class #:implements (Class [m (Number -> Number)])
#:implements (Class [n (Number -> Number)]) #:implements (Class [n (Number -> Number)])
(field [x Number])) (field [x Number]))
(make-Class #f null `((x ,-Number)) `((n ,(t:-> N N)) (m ,(t:-> N N))))] (make-Class #f null `((x ,-Number))
`((n ,(t:-> N N)) (m ,(t:-> N N))) null)]
[(Class #:implements (Class [m (Number -> Number)]) [(Class #:implements (Class [m (Number -> Number)])
#:implements (Class [m (Number -> Number)]) #:implements (Class [m (Number -> Number)])
(field [x Number])) (field [x Number]))
(make-Class #f null `((x ,-Number)) `((m ,(t:-> N N))))] (make-Class #f null `((x ,-Number)) `((m ,(t:-> N N))) null)]
[(Class #:implements (Class (init [x Integer]) [m (Number -> Number)]) [(Class #:implements (Class (init [x Integer]) [m (Number -> Number)])
(field [x Number])) (field [x Number]))
(make-Class #f null `((x ,-Number)) `((m ,(t:-> N N))))] (make-Class #f null `((x ,-Number)) `((m ,(t:-> N N))) null)]
[FAIL (Class #:implements Number)] [FAIL (Class #:implements Number)]
[FAIL (Class #:implements Number [m (Number -> Number)])] [FAIL (Class #:implements Number [m (Number -> Number)])]
[FAIL (Class #:implements (Class [m (Number -> Number)]) [m String])] [FAIL (Class #:implements (Class [m (Number -> Number)]) [m String])]
[FAIL (Class #:implements (Class [m (Number -> Number)]) [FAIL (Class #:implements (Class [m (Number -> Number)])
#:implements (Class [m (String -> String)]) #:implements (Class [m (String -> String)])
(field [x Number]))] (field [x Number]))]
[FAIL (Class #:implements (Class (augment [m (Number -> Number)]))
#:implements (Class (augment [m (String -> String)]))
(field [x Number]))]
[FAIL (Class #:implements (Class (augment [m (Number -> Number)]))
(augment [m (-> Number)]))]
;; Test Object types ;; Test Object types
[(Object) (make-Instance (make-Class #f null null null))] [(Object) (make-Instance (make-Class #f null null null null))]
[(Object [m (Number -> Number)]) [(Object [m (Number -> Number)])
(make-Instance (make-Class #f null null `((m ,(t:-> N N)))))] (make-Instance (make-Class #f null null `((m ,(t:-> N N))) null))]
[(Object [m (Number -> Number)] (field [f Number])) [(Object [m (Number -> Number)] (field [f Number]))
(make-Instance (make-Class #f null `((f ,N)) `((m ,(t:-> N N)))))] (make-Instance (make-Class #f null `((f ,N))
`((m ,(t:-> N N))) null))]
[FAIL (Object foobar)] [FAIL (Object foobar)]
[FAIL (Object [x UNBOUND])] [FAIL (Object [x UNBOUND])]
[FAIL (Object [x Number #:random-keyword])] [FAIL (Object [x Number #:random-keyword])]
@ -279,14 +292,14 @@
[FAIL (Object [x Number] [x Number])] [FAIL (Object [x Number] [x Number])]
;; Test row polymorphic types ;; Test row polymorphic types
[(All (r #:row) ((Class #:row-var r) -> (Class #:row-var r))) [(All (r #:row) ((Class #:row-var r) -> (Class #:row-var r)))
(-polyrow (r) (list null null null) (-polyrow (r) (list null null null null)
(t:-> (make-Class r null null null) (t:-> (make-Class r null null null null)
(make-Class r null null null)))] (make-Class r null null null null)))]
[(All (r #:row (init x y z) (field f) m n) [(All (r #:row (init x y z) (field f) m n)
((Class #:row-var r) -> (Class #:row-var r))) ((Class #:row-var r) -> (Class #:row-var r)))
(-polyrow (r) (list '(x y z) '(f) '(m n)) (-polyrow (r) (list '(x y z) '(f) '(m n) '())
(t:-> (make-Class r null null null) (t:-> (make-Class r null null null null)
(make-Class r null null null)))] (make-Class r null null null null)))]
;; Class types cannot use a row variable that doesn't constrain ;; Class types cannot use a row variable that doesn't constrain
;; all of its members to be absent in the row ;; all of its members to be absent in the row
[FAIL (All (r #:row (init x)) [FAIL (All (r #:row (init x))