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

Rework how keyword methods are handled by TR

Browse Source 
Override the `define/foo` forms for racket/class to
allow type annotations and to use TR's keyword property.
This commit is contained in:
Asumu Takikawa 2014-05-20 15:27:25 -04:00
parent 2d81c9667c
commit 4aa438937a
7 changed files with 120 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
pkgs/typed-racket-pkgs/typed-racket-doc/typed-racket/scribblings/reference/typed-classes.scrbl
View File

@ -35,8 +35,16 @@ additional provides all other bindings from @racketmodname[racket/class].
@;; in certain cases rather than the class defined here
@(module id-holder racket/base
(require scribble/manual (for-label racket/class))
(provide class-element)
(define class-element (racket class)))
(provide class-element
d/p-element d/o-element
d/pm-element d/a-element
d/pr-element)
(define class-element (racket class))
(define d/p-element (racket define/public))
(define d/o-element (racket define/override))
(define d/pm-element (racket define/pubment))
(define d/a-element (racket define/augment))
(define d/pr-element (racket define/private)))
@(require 'id-holder)
@defform[#:literals (inspect init init-field init-rest field inherit-field
@ -183,6 +191,39 @@ additional provides all other bindings from @racketmodname[racket/class].
]
}
@(define (define/foo-content define/foo)
@elem{
Like @define/foo from @racketmodname[racket/class], but uses the binding of
@racket[define] from Typed Racket.
The @racket[formals] may specify type annotations as in @racket[define].
})
@defform*[((define/public id expr)
(define/public (id . formals) body ...+))]{
@define/foo-content[d/p-element]
}
@defform*[((define/override id expr)
(define/override (id . formals) body ...+))]{
@define/foo-content[d/o-element]
}
@defform*[((define/pubment id expr)
(define/pubment (id . formals) body ...+))]{
@define/foo-content[d/pm-element]
}
@defform*[((define/augment id expr)
(define/augment (id . formals) body ...+))]{
@define/foo-content[d/a-element]
}
@defform*[((define/private id expr)
(define/private (id . formals) body ...+))]{
@define/foo-content[d/pr-element]
}
@section{Types}
@defform[#:literals (init init-field init-rest field augment)

7
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/annotate-classes.rkt
View File

@ -278,9 +278,12 @@
(template ((?@ . mand.form) ... (?@ . opt.form) ... . rest.form))))
(define-syntax-class curried-formals
#:attributes (erased)
(pattern fun:id #:with erased #'fun)
#:attributes (erased fun-name)
(pattern fun:id
#:with fun-name #'fun
#:with erased #'fun)
(pattern (fun:curried-formals . formals:lambda-formals)
#:with fun-name #'fun.fun-name
#:with erased #`(fun.erased . #,(attribute formals.erased))))
(define-splicing-syntax-class return-ann

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

@ -2,9 +2,17 @@
;; This module provides TR primitives for classes and objects
(require (rename-in racket/class [class untyped-class])
(require (rename-in (except-in racket/class
define/public
define/override
define/pubment
define/augment
define/private)
[class untyped-class])
"colon.rkt"
"../typecheck/internal-forms.rkt"
"../private/class-literals.rkt"
(only-in "prims.rkt" [define tr:define])
(for-syntax
racket/base
racket/class
@ -23,21 +31,35 @@
syntax/parse
syntax/stx
unstable/list
"annotate-classes.rkt"
"../private/syntax-properties.rkt"
"../utils/tc-utils.rkt"))
(provide ;; Typed class macro that coordinates with TR
class
;; for use in ~literal clauses
class-internal
:-augment)
;; override these macros to use TR define
define/public
define/override
define/pubment
define/augment
define/private)
;; give it a binding, but it shouldn't be used directly
(define-syntax (class-internal stx)
(raise-syntax-error 'class "should only be used internally"))
;; overriden forms
(define-syntax-rule (define-define/class-kw ((?id ?class-kw) ...))
(begin (define-syntax (?id stx)
(syntax-parse stx
[(_ ??header:curried-formals . ??body)
(quasisyntax/loc stx
(begin (tr:define ??header . ??body)
(?class-kw ??header.fun-name)))]))
...))
(define-syntax (:-augment stx)
(raise-syntax-error 'class "should only be used internally"))
(define-define/class-kw
([define/public public]
[define/override override]
[define/pubment pubment]
[define/augment augment]
[define/private private]))
(begin-for-syntax
;; forms that are not allowed by Typed Racket yet

14
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/class-literals.rkt Normal file
View File

@ -0,0 +1,14 @@
#lang racket/base
(require (for-syntax racket/base))
(provide ;; for use in ~literal clauses
class-internal
:-augment)
;; give it a binding, but it shouldn't be used directly
(define-syntax (class-internal stx)
(raise-syntax-error 'class "should only be used internally"))
(define-syntax (:-augment stx)
(raise-syntax-error 'class "should only be used internally"))

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

@ -14,7 +14,6 @@
syntax/stx
"signatures.rkt"
(private parse-type syntax-properties type-annotation)
(base-env class-prims)
(env lexical-env tvar-env)
(types utils abbrev union subtype resolve generalize)
(typecheck check-below internal-forms)
@ -22,7 +21,7 @@
(rep type-rep)
(for-syntax racket/base)
(for-template racket/base
(base-env class-prims)
(private class-literals)
(typecheck internal-forms)))
(import tc-if^ tc-lambda^ tc-app^ tc-let^ tc-expr^)
@ -886,6 +885,9 @@
;; type-check pubments/augments.
[(set-member? names-to-check external-name)
(do-timestamp (format "started checking method ~a" external-name))
;; FIXME: this case doesn't work very well yet for keyword methods
;; because TR can't recognize that the expansion is a kw
;; function (unlike the expected case).
(define type (tc-expr/t meth))
(do-timestamp (format "finished method ~a" external-name))
(cons (list external-name
@ -1415,12 +1417,13 @@
(#%plain-lambda (#,annotated-self-param . params)
body ...))])
m)]
[(let-values ([(meth-name:id)
(let-values (((core:id)
(#%plain-lambda params
core-body ...)))
method-body ...)])
m)
[(~and (let-values ([(meth-name:id)
(let-values (((core:id)
(#%plain-lambda params
core-body ...)))
method-body ...)])
m)
kw:kw-lambda^)
#`(let-values ([(#,(type-label-property #'meth-name method-type))
#,(kw-lambda-property
#`(let-values (((core)
@ -1429,7 +1432,7 @@
(#%plain-lambda params
core-body ...))))
method-body ...)
#t)])
(attribute kw.value))])
m)]
;; case-lambda methods
[(let-values ([(meth-name:id)

13
pkgs/typed-racket-pkgs/typed-racket-lib/typed/racket/class.rkt
View File

@ -1,7 +1,18 @@
#lang racket/base
(require (except-in racket/class class)
(require (except-in racket/class
class
define/public
define/override
define/pubment
define/augment
define/private)
typed-racket/base-env/class-prims)
(provide class
define/public
define/override
define/pubment
define/augment
define/private
(all-from-out racket/class))

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

@ -17,7 +17,9 @@
;; see typecheck-tests.rkt for rationale on imports
(require rackunit
(except-in racket/class class)
(except-in racket/class
class define/public define/override
define/pubment define/augment define/private)
(except-in typed-racket/utils/utils private)
(except-in (base-env extra-procs prims class-prims
base-types base-types-extra)