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

Add syntactic sugar for recursive class types

Browse Source
This commit is contained in:
Asumu Takikawa 2013-05-27 17:23:43 -04:00
parent a1efc2c276
commit 081cc4777a
2 changed files with 31 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -540,7 +540,7 @@
(define-splicing-syntax-class class-type-clauses (define-splicing-syntax-class class-type-clauses
#:description "Class type clause" #:description "Class type clause"
#:attributes (extends-types #:attributes (self extends-types
init-names init-types init-optional?s init-names init-types init-optional?s
init-field-names init-field-types init-field-names init-field-types
init-field-optional?s init-field-optional?s
@ -548,6 +548,7 @@
method-names method-types) method-names method-types)
#:literals (init init-field field) #:literals (init init-field field)
(pattern (~seq (~or (~seq #:extends extends-type:expr) (pattern (~seq (~or (~seq #:extends extends-type:expr)
(~optional (~seq #:self self:id))
(init init-clause:init-type ...) (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 ...)
@ -653,24 +654,33 @@
[(kw clause:class-type-clauses) [(kw clause:class-type-clauses)
(add-disappeared-use #'kw) (add-disappeared-use #'kw)
(define parent-types (stx->list #'clause.extends-types)) (define parent-types (stx->list #'clause.extends-types))
(define recursive-type (attribute clause.self))
;; parsing the init, fields, and methods need to be aware of
;; the self type if it's given
(define parse-type*
(cond [recursive-type
(define var (syntax-e recursive-type))
(λ (stx) (extend-tvars (list var) (parse-type stx)))]
[else parse-type]))
(define given-inits (define given-inits
(for/list ([name (append (stx-map syntax-e #'clause.init-names) (for/list ([name (append (stx-map syntax-e #'clause.init-names)
(stx-map syntax-e #'clause.init-field-names))] (stx-map syntax-e #'clause.init-field-names))]
[type (append (stx-map parse-type #'clause.init-types) [type (append (stx-map parse-type* #'clause.init-types)
(stx-map parse-type #'clause.init-field-types))] (stx-map parse-type* #'clause.init-field-types))]
[optional? (append (attribute clause.init-optional?s) [optional? (append (attribute clause.init-optional?s)
(attribute clause.init-field-optional?s))]) (attribute clause.init-field-optional?s))])
(list name type optional?))) (list name type optional?)))
(define given-fields (define given-fields
(for/list ([name (append (stx-map syntax-e #'clause.field-names) (for/list ([name (append (stx-map syntax-e #'clause.field-names)
(stx-map syntax-e #'clause.init-field-names))] (stx-map syntax-e #'clause.init-field-names))]
[type (append (stx-map parse-type #'clause.field-types) [type (append (stx-map parse-type* #'clause.field-types)
(stx-map parse-type #'clause.init-field-types))]) (stx-map parse-type* #'clause.init-field-types))])
(list name type))) (list name type)))
(define given-methods (define given-methods
(for/list ([name (stx-map syntax-e #'clause.method-names)] (for/list ([name (stx-map syntax-e #'clause.method-names)]
[type (stx-map parse-type #'clause.method-types)]) [type (stx-map parse-type* #'clause.method-types)])
(list name type))) (list name type)))
;; merge with all given parent types, erroring if needed ;; merge with all given parent types, erroring if needed
@ -680,9 +690,16 @@
([parent-type parent-types]) ([parent-type parent-types])
(merge-with-parent-type parent-type fields methods))) (merge-with-parent-type parent-type fields methods)))
(define class-type
(make-Class (make-Class
#f ;; FIXME: put type if it's a row variable #f ;; FIXME: put type if it's a row variable
given-inits fields methods)])) given-inits fields methods))
(cond [recursive-type
=>
(λ (self-id)
(make-Mu (syntax-e self-id) class-type))]
[else class-type])]))
(define (parse-tc-results stx) (define (parse-tc-results stx)
(syntax-parse stx (syntax-parse stx

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

@ -222,6 +222,11 @@
[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]))]
;; test #:self
[(Class #:self This% [m ((Instance This%) -> Number)])
(-mu This%
(make-Class
#f null null `((m ,(t:-> (make-Instance This%) N)))))]
;; test #:extends ;; test #:extends
[(Class #:extends (Class [m (Number -> Number)]) (field [x Number])) [(Class #:extends (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))))]