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

Improve source location tracking for TR classes

Browse Source 
Closes PR 14400
This commit is contained in:
Asumu Takikawa 2014-04-18 18:11:25 -04:00
parent dbf0206fb2
commit e3349674a6
1 changed files with 29 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -336,34 +336,35 @@
(define optional-inits (get-optional-inits clauses))
(ignore
(tr:class
#`(let-values ()
#,(internal (make-class-name-table (attribute forall.type-variables)
private-fields
ordered-inits
optional-inits
name-dict))
(untyped-class #,annotated-super
#,@(map clause-stx clauses)
;; construct in-body type annotations for clauses
#,@(apply append
(for/list ([a-clause clauses])
(match-define (clause _1 _2 ids types) a-clause)
(for/list ([id ids] [type types]
#:when type)
;; FIXME: it might be cleaner to use the type-label-property
;; here and use the property to build annotation tables
;; in the class type-checker.
(tr:class:type-annotation-property
(tr:class:top-level-property
#`(: #,(if (stx-pair? id) (stx-car id) id)
#,type)
#t)
#t))))
#,@(map non-clause-stx annotated-methods)
#,(tr:class:top-level-property
#`(begin #,@(map non-clause-stx other-top-level))
#t)
#,(make-locals-table name-dict private-fields)))))])]))
(quasisyntax/loc stx
(let-values ()
#,(internal (make-class-name-table (attribute forall.type-variables)
private-fields
ordered-inits
optional-inits
name-dict))
(untyped-class #,annotated-super
#,@(map clause-stx clauses)
;; construct in-body type annotations for clauses
#,@(apply append
(for/list ([a-clause clauses])
(match-define (clause _1 _2 ids types) a-clause)
(for/list ([id ids] [type types]
#:when type)
;; FIXME: it might be cleaner to use the type-label-property
;; here and use the property to build annotation tables
;; in the class type-checker.
(tr:class:type-annotation-property
(tr:class:top-level-property
#`(: #,(if (stx-pair? id) (stx-car id) id)
#,type)
#t)
#t))))
#,@(map non-clause-stx annotated-methods)
#,(tr:class:top-level-property
#`(begin #,@(map non-clause-stx other-top-level))
#t)
#,(make-locals-table name-dict private-fields))))))])]))
(begin-for-syntax
;; process-class-contents : Listof<Syntax> Dict<Id, Listof<Id>>