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.

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)
+   (provide class-element
-   (define class-element (racket class)))
+            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)

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)
+  #:attributes (erased fun-name)
-  (pattern fun:id #:with erased #'fun)
+  (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

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
+         ;; override these macros to use TR define
-         class-internal
+         define/public
-         :-augment)
+         define/override
+         define/pubment
+         define/augment
+         define/private)
 
-;; give it a binding, but it shouldn't be used directly
+;; overriden forms
-(define-syntax (class-internal stx)
+(define-syntax-rule (define-define/class-kw ((?id ?class-kw) ...))
-  (raise-syntax-error 'class "should only be used internally"))
+  (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)
+(define-define/class-kw
-  (raise-syntax-error 'class "should only be used internally"))
+  ([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

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"))

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)
+    [(~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)

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))

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)