From 4aa438937ac315d0b64bccffa86663a97cadde6f Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Tue, 20 May 2014 15:27:25 -0400 Subject: [PATCH] Rework how keyword methods are handled by TR Override the `define/foo` forms for racket/class to allow type annotations and to use TR's keyword property. --- .../scribblings/reference/typed-classes.scrbl | 45 ++++++++++++++++++- .../base-env/annotate-classes.rkt | 7 ++- .../typed-racket/base-env/class-prims.rkt | 40 +++++++++++++---- .../typed-racket/private/class-literals.rkt | 14 ++++++ .../typecheck/check-class-unit.rkt | 21 +++++---- .../typed-racket-lib/typed/racket/class.rkt | 13 +++++- .../typed-racket/unit-tests/class-tests.rkt | 4 +- 7 files changed, 120 insertions(+), 24 deletions(-) create mode 100644 pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/class-literals.rkt diff --git a/pkgs/typed-racket-pkgs/typed-racket-doc/typed-racket/scribblings/reference/typed-classes.scrbl b/pkgs/typed-racket-pkgs/typed-racket-doc/typed-racket/scribblings/reference/typed-classes.scrbl index 359533bf01..c450dc1e94 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-doc/typed-racket/scribblings/reference/typed-classes.scrbl +++ b/pkgs/typed-racket-pkgs/typed-racket-doc/typed-racket/scribblings/reference/typed-classes.scrbl @@ -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) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/annotate-classes.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/annotate-classes.rkt index 475d9c7674..21d213582c 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/annotate-classes.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/annotate-classes.rkt @@ -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 diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt index fcae34559e..adab88b967 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt @@ -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 diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/class-literals.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/class-literals.rkt new file mode 100644 index 0000000000..cc545dd40e --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/class-literals.rkt @@ -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")) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt index 1a2ceeef72..905a07ca59 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt @@ -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) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed/racket/class.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed/racket/class.rkt index cf7e274ea1..5515544f31 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed/racket/class.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed/racket/class.rkt @@ -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)) diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt index b6a75f7297..5bf42fe68e 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt @@ -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)