diff --git a/typed-racket-lib/typed-racket/base-env/case-lambda.rkt b/typed-racket-lib/typed-racket/base-env/case-lambda.rkt index a34f7311..70eb34f9 100644 --- a/typed-racket-lib/typed-racket/base-env/case-lambda.rkt +++ b/typed-racket-lib/typed-racket/base-env/case-lambda.rkt @@ -28,12 +28,10 @@ (syntax-parse stx [(_ vars:maybe-lambda-type-vars [formals:case-lambda-formals . body] ...) - (quasisyntax/loc stx - (#%expression - #,(plambda-property - (syntax/loc stx - (case-lambda [formals.form . body] ...)) - (attribute vars.type-vars))))])) + (plambda-property + (syntax/loc stx + (case-lambda [formals.form . body] ...)) + (attribute vars.type-vars))])) (define-syntax (pcase-lambda: stx) (syntax-parse stx diff --git a/typed-racket-lib/typed-racket/base-env/prims.rkt b/typed-racket-lib/typed-racket/base-env/prims.rkt index fd3d8ebe..4f80eb72 100644 --- a/typed-racket-lib/typed-racket/base-env/prims.rkt +++ b/typed-racket-lib/typed-racket/base-env/prims.rkt @@ -1158,9 +1158,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (opt-lambda-property d (attribute formals.opt-property)))) ;; attach a plambda property if necessary (if (attribute vars.type-vars) - (quasisyntax/loc stx - (#%expression - #,(plambda-property d/prop (attribute vars.type-vars)))) + (plambda-property d/prop (attribute vars.type-vars)) d/prop)])) ;; for backwards compatibility, note that this only accepts formals diff --git a/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt b/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt index b768dc58..f2387763 100644 --- a/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt +++ b/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt @@ -860,7 +860,7 @@ (define expected (ret method-type)) (register-method-ids meth self-type method-type) (do-timestamp (format "started checking method ~a" external-name)) - (tc-expr/check (add-kw-property meth) expected) + (tc-expr/check (add-lambda-properties meth) expected) (do-timestamp (format "finished method ~a" external-name)) (cons (list external-name pre-method-type) checked)] ;; Only try to type-check if these names are in the @@ -872,7 +872,7 @@ ;; because TR can't recognize that the expansion is a kw ;; function (unlike the expected case). (register-method-ids meth self-type #f) - (define type (tc-expr/t (add-kw-property meth))) + (define type (tc-expr/t (add-lambda-properties meth))) (do-timestamp (format "finished method ~a" external-name)) (cons (list external-name (method->function type)) @@ -893,12 +893,12 @@ (function->method pre-method-type self-type)) (define expected (ret method-type)) (register-method-ids stx self-type method-type) - (tc-expr/check (add-kw-property stx) expected)] + (tc-expr/check (add-lambda-properties stx) expected)] ;; not private, then ignore since it's irrelevant [(not private?) (void)] [else (register-method-ids stx self-type #f) - (tc-expr/t (add-kw-property stx))]))) + (tc-expr/t (add-lambda-properties stx))]))) ;; check-field-set!s : Syntax Dict Dict -> Void ;; Check that fields are initialized to the correct type @@ -1455,30 +1455,25 @@ [_ (int-err "register-method-ids: internal error")])) ;; Syntax -> Syntax -;; If the method syntax is for a keyword method, then propagate the keyword -;; property further into the syntax object. -(define (add-kw-property stx) +;; Propagate all syntax properties on the outer expansion of the +;; lambda to the core lambda that TR looks at +(define (add-lambda-properties stx) (syntax-parse stx #:literal-sets (kernel-literals) - [(~and (let-values ([(meth-name:id) core]) m) - kw:kw-lambda^) - (quasisyntax/loc stx - (let-values ([(meth-name) - #,(kw-lambda-property - (syntax/loc stx core) - (attribute kw.value))]) - m))] - [(~and (let-values ([(meth-name:id) core]) m) - opt:opt-lambda^) - (match-define (list required optional) (attribute opt.value)) + [(let-values ([(meth-name:id) core]) m) + (define opt-prop (opt-lambda-property stx)) + (define datum (syntax-e #'core)) + ;; the important bit is the last argument for copying properties + (define with-props (datum->syntax #'core datum stx stx)) + ;; the opt-lambda-property needs adjustment for `this` + (define with-opt + (if opt-prop + (opt-lambda-property + with-props + (list (add1 (car opt-prop)) (cadr opt-prop))) + with-props)) (quasisyntax/loc stx - (let-values ([(meth-name) - #,(opt-lambda-property - (syntax/loc stx core) - (list (add1 required) ; for `this` argument - optional))]) - m))] - [_ stx])) + (let-values ([(meth-name) #,with-opt]) m))])) ;; Set Set String -> Void ;; check that all the required names are actually present diff --git a/typed-racket-test/unit-tests/class-tests.rkt b/typed-racket-test/unit-tests/class-tests.rkt index c7b37639..e83acc34 100644 --- a/typed-racket-test/unit-tests/class-tests.rkt +++ b/typed-racket-test/unit-tests/class-tests.rkt @@ -1683,4 +1683,14 @@ (super-new) (override* [n (lambda () 5)]))) (send (new c%) n)) - -Integer])) + -Integer] + ;; PR 14904 + [tc-e (class object% + (super-new) + (: foo (All (X) (-> X X))) + (define/public foo (tr:lambda #:forall (A) ([x : A]) x))) + (-class #:method [(foo (-poly (a) (t:-> a a)))])] + [tc-e (class object% + (super-new) + (define/public foo (case-lambda [(str) (void)] [(sym size) (void)]))) + (-class #:method [(foo (cl->* (t:-> Univ Univ -Void) (t:-> Univ -Void)))])]))