suzanne.soy/typed-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

original commit: e3349674a64571793accb7ee83fd3865baab0e20
This commit is contained in:
Asumu Takikawa 2014-04-18 18:11:25 -04:00
commit 12e85ba9b6
3 changed files with 43 additions and 31 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>>

11
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt
View File

@ -113,9 +113,14 @@
[predicate-assertion
(assert-predicate-internal type predicate)]
[type-declaration
(:-internal id:identifier type)]
[typecheck-failure
(typecheck-fail-internal stx message:str var:id)])
(:-internal id:identifier type)])
;; Define separately outside of `define-internal-classes` since this form
;; is meant to appear in expression positions, so it doesn't make sense to use
;; the `define-values` protocol used for other internal forms.
(define-syntax-class typecheck-failure
#:literal-sets (kernel-literals internal-literals)
(pattern (quote-syntax (typecheck-fail-internal stx message:str var))))
;;; Internal form creation
(begin-for-syntax

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

@ -2747,6 +2747,12 @@
(f 1 2 3))
#:ret (ret Univ -true-filter)]
;; typecheck-fail should fail
[tc-err (typecheck-fail #'stx "typecheck-fail")
#:msg #rx"typecheck-fail"]
[tc-err (string-append (typecheck-fail #'stx "typecheck-fail") "bar")
#:ret (ret -String)
#:msg #rx"typecheck-fail"]
)
(test-suite
"tc-literal tests"