diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt index 6d451fe866..f8971e2387 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt @@ -72,6 +72,7 @@ This file defines two sorts of primitives. All of them are provided into any mod syntax/struct "annotate-classes.rkt" "../utils/tc-utils.rkt" + "../private/parse-classes.rkt" "../private/syntax-properties.rkt" "../types/utils.rkt" "for-clauses.rkt" @@ -1169,15 +1170,20 @@ This file defines two sorts of primitives. All of them are provided into any mod #:description "rest argument" #:attributes (form) #:literals (:) - (pattern () #:attr form #'()) + ;; specifying opaque here helps produce a better error + ;; message for optional argumenents, but produces worse + ;; error messages for rest arguments. + #:opaque (pattern rest:id #:attr form #'rest) - ;; FIXME: add a typed rest-arg case if a good syntax is found - ) + (pattern (rest:id : type:expr :star) + #:attr form (type-label-property #'rest #'type))) (define-syntax-class lambda-formals #:attributes (opt-property kw-property erased) #:literals (:) - (pattern (mand:mand-formal ... opt:opt-formal ... . rest:rest-arg) + (pattern (~or (mand:mand-formal ... opt:opt-formal ... . rest:rest-arg) + (~and (mand:mand-formal ... opt:opt-formal ...) + (~bind [rest.form #'()]))) #:attr kw-property (ormap values (append (attribute mand.kw) (attribute opt.kw))) #:attr opt-property diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/kw-types.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/kw-types.rkt index a176a90805..cb045f35eb 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/kw-types.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/kw-types.rkt @@ -173,10 +173,7 @@ [kw-type (in-list kw-args)]) (make-Keyword kw kw-type #t))) (define rest-type - (and rest? - (if (equal? (last other-args) Univ) - Univ - -Bottom))) + (and rest? (last other-args))) (make-Function (list (make-arr* (take other-args non-kw-argc) rng @@ -196,10 +193,7 @@ (define-values (mand-args opt-and-rest-args) (split-at other-args mand-non-kw-argc)) (define rest-type - (and rest? - (if (equal? (last opt-and-rest-args) Univ) - Univ - -Bottom))) + (and rest? (last opt-and-rest-args))) (define opt-types (take opt-and-rest-args opt-non-kw-argc)) (make-Function (for/list ([to-take (in-range (add1 (length opt-types)))]) @@ -301,10 +295,7 @@ (define-values (mand-args opt-and-rest-args) (split-at doms mand-argc)) (define rest-type - (and rest? - (if (equal? (last opt-and-rest-args) Univ) - Univ - -Bottom))) + (and rest? (last opt-and-rest-args))) (define opt-types (take opt-and-rest-args opt-argc)) (make-Function (for/list ([to-take (in-range (add1 (length opt-types)))]) diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt index 3f6e791d3e..0f6959f709 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt @@ -2062,13 +2062,20 @@ ;; test lambdas with mixed type expressions, typed keywords, typed ;; optional arguments - ;; FIXME: support rest args [tc-e (tr:lambda (x [y : String]) (string-append y "b")) #:ret (ret (t:-> Univ -String -String) (-FS -top -bot))] + [tc-e (tr:lambda (x [y : String] . z) (string-append y "b")) + #:ret (ret (->* (list Univ -String) Univ -String) (-FS -top -bot))] + [tc-e (tr:lambda (x [y : String] . [z : String *]) (string-append y "b")) + #:ret (ret (->* (list Univ -String) -String -String) (-FS -top -bot))] [tc-e (tr:lambda (x [y : String]) : String (string-append y "b")) #:ret (ret (t:-> Univ -String -String) (-FS -top -bot))] [tc-e (tr:lambda (x z [y : String]) (string-append y "b")) #:ret (ret (t:-> Univ Univ -String -String) (-FS -top -bot))] + [tc-e (tr:lambda (x z [y : String] . w) (string-append y "b")) + #:ret (ret (->* (list Univ Univ -String) Univ -String) (-FS -top -bot))] + [tc-e (tr:lambda (x z [y : String] . [w : String *]) (string-append y "b")) + #:ret (ret (->* (list Univ Univ -String) -String -String) (-FS -top -bot))] [tc-e (tr:lambda (x z [y : String]) : String (string-append y "b")) #:ret (ret (t:-> Univ Univ -String -String) (-FS -top -bot))] [tc-err (tr:lambda (x [y : String]) : Symbol (string-append y "b")) @@ -2077,6 +2084,10 @@ #:msg "expected optional lambda argument"] [tc-e (tr:lambda (x [y : String "a"]) (string-append y "b")) (->opt Univ [-String] -String)] + [tc-e (tr:lambda (x [y : String "a"] . z) (string-append y "b")) + (->optkey Univ [-String] #:rest Univ -String)] + [tc-e (tr:lambda (x [y : String "a"] . [z : String *]) (string-append y "b")) + (->optkey Univ [-String] #:rest -String -String)] [tc-e (tr:lambda (x y [z : String "a"]) (string-append z "b")) (->opt Univ Univ [-String] -String)] [tc-e (tr:lambda (w x [y : String "y"] [z : String "z"]) (string-append y z)) @@ -2086,6 +2097,10 @@ (->opt Univ -String [-String -String] -String)] [tc-e (tr:lambda (x #:y [y : String]) (string-append y "b")) (->key Univ #:y -String #t -String)] + [tc-e (tr:lambda (x #:y [y : String] . z) (string-append y "b")) + (->optkey Univ [] #:rest Univ #:y -String #t -String)] + [tc-e (tr:lambda (x #:y [y : String] . [z : String *]) (string-append y "b")) + (->optkey Univ [] #:rest -String #:y -String #t -String)] [tc-e (tr:lambda (x #:y [y : String]) : String (string-append y "b")) (->key Univ #:y -String #t -String)] [tc-e (tr:lambda (x #:y [y : String "a"]) (string-append y "b")) @@ -2104,6 +2119,10 @@ (->optkey Univ [Univ] #:y -String #f -String)] [tc-e (tr:lambda (x #:y [y : String] [z : String "z"]) (string-append y z)) (->optkey Univ [-String] #:y -String #t -String)] + [tc-e (tr:lambda (x #:y [y : String] [z : String "z"] . w) (string-append y z)) + (->optkey Univ [-String] #:rest Univ #:y -String #t -String)] + [tc-e (tr:lambda (x #:y [y : String] [z : String "z"] . [w : String *]) (string-append y z)) + (->optkey Univ [-String] #:rest -String #:y -String #t -String)] [tc-e (tr:lambda (x #:y [y : String "y"] [z : String "z"]) (string-append y z)) (->optkey Univ [-String] #:y -String #f -String)] [tc-e (tr:lambda (x [z : String "z"] #:y [y : String]) (string-append y z))