diff --git a/pkgs/typed-racket-pkgs/typed-racket-compatibility/typed/scheme/base.rkt b/pkgs/typed-racket-pkgs/typed-racket-compatibility/typed/scheme/base.rkt index 6bf62953..b6311cd9 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-compatibility/typed/scheme/base.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-compatibility/typed/scheme/base.rkt @@ -4,7 +4,7 @@ with-handlers default-continuation-prompt-tag define λ lambda define-struct for for* let let* let-values letrec letrec-values - let/cc let/ec do + let/cc let/ec do case-lambda for/list for/vector for/hash for/hasheq for/hasheqv for/and for/or for/sum for/product for/lists for/first for/last for/fold for*/list for*/lists diff --git a/pkgs/typed-racket-pkgs/typed-racket-doc/typed-racket/scribblings/reference/legacy.scrbl b/pkgs/typed-racket-pkgs/typed-racket-doc/typed-racket/scribblings/reference/legacy.scrbl index 34ae61b9..5746bf2d 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-doc/typed-racket/scribblings/reference/legacy.scrbl +++ b/pkgs/typed-racket-pkgs/typed-racket-doc/typed-racket/scribblings/reference/legacy.scrbl @@ -44,6 +44,12 @@ A function with optional arguments.} (popt-lambda: (a ... a ooo) formals . body)]]{ A polymorphic function with optional arguments.} +@defalias[case-lambda: case-lambda] + +@defform*[[(pcase-lambda: (a ...) [formals body] ...) + (pcase-lambda: (a ... b ooo) [formals body] ...)]]{ +A polymorphic function of multiple arities.} + @defform*[[ (let: ([v : t e] ...) . body) (let: loop : t0 ([v : t e] ...) . body)]]{ diff --git a/pkgs/typed-racket-pkgs/typed-racket-doc/typed-racket/scribblings/reference/special-forms.scrbl b/pkgs/typed-racket-pkgs/typed-racket-doc/typed-racket/scribblings/reference/special-forms.scrbl index f44f7de0..e201b369 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-doc/typed-racket/scribblings/reference/special-forms.scrbl +++ b/pkgs/typed-racket-pkgs/typed-racket-doc/typed-racket/scribblings/reference/special-forms.scrbl @@ -181,21 +181,27 @@ is the provided type annotation. @defform[(λ formals . body)]{ An alias for the same form using @racket[lambda].} -@defform[(case-lambda: [formals body] ...)]{ -A function of multiple arities. Note that each @racket[formals] must have a -different arity. +@defform[(case-lambda maybe-tvars [formals body] ...)]{ + +A function of multiple arities. The @racket[_formals] are identical +to those accepted by the @racket[lambda] form except that keyword +and optional arguments are not allowed. + +Polymorphic type variables, if provided, are bound in the type +expressions in the formals. + +Note that each @racket[formals] must have a different arity. + @ex[(define add-map - (case-lambda: + (case-lambda [([lst : (Listof Integer)]) (map add1 lst)] [([lst1 : (Listof Integer)] [lst2 : (Listof Integer)]) (map + lst1 lst2)]))] -For the type declaration of @racket[add-map] look at @racket[case-lambda].} -@defform*[[(pcase-lambda: (a ...) [formals body] ...) - (pcase-lambda: (a ... b ooo) [formals body] ...)]]{ -A polymorphic function of multiple arities.} +To see how to declare a type for @racket[add-map], see the +@racket[case->] type constructor.} @section{Loops} diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/case-lambda.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/case-lambda.rkt new file mode 100644 index 00000000..a7296b54 --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/case-lambda.rkt @@ -0,0 +1,46 @@ +#lang racket/base + +;; This file is logically part of "prims.rkt" but is in a separate +;; file to avoid cyclic module dependencies +;; +;; In particular, "parse-type.rkt" needs the binding of the TR +;; case-lambda in order to match for case-lambda types. + +(require (for-syntax "annotate-classes.rkt" + "../private/syntax-properties.rkt" + racket/base + syntax/parse)) + +(provide (rename-out [-case-lambda case-lambda] + [-case-lambda case-lambda:]) + pcase-lambda:) + +(begin-for-syntax + (define-syntax-class case-lambda-formals + (pattern (~or (formal:optionally-annotated-formal ... . rst:rest-arg) + (~and (formal:optionally-annotated-formal ...) + (~bind [rst.form #'()]))) + #:with form + (syntax/loc this-syntax + (formal.ann-name ... . rst.form))))) + +(define-syntax (-case-lambda stx) + (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))))])) + +(define-syntax (pcase-lambda: stx) + (syntax-parse stx + [(pcase-lambda: tvars:type-variables cl ...) + (quasisyntax/loc stx + (#%expression + #,(plambda-property + (syntax/loc stx (-case-lambda cl ...)) + #'(tvars.vars ...))))])) + 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 995c1bb8..623fe093 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 @@ -28,6 +28,7 @@ This file defines two sorts of primitives. All of them are provided into any mod ;; provide the contracted bindings as primitives (all-from-out "base-contracted.rkt") (all-from-out "top-interaction.rkt") + (all-from-out "case-lambda.rkt") : (rename-out [define-typed-struct define-struct:] [define-typed-struct define-struct] @@ -102,6 +103,7 @@ This file defines two sorts of primitives. All of them are provided into any mod "top-interaction.rkt" "base-types.rkt" "base-types-extra.rkt" + "case-lambda.rkt" 'struct-extraction racket/flonum ; for for/flvector and for*/flvector (for-syntax @@ -391,15 +393,6 @@ This file defines two sorts of primitives. All of them are provided into any mod (syntax/loc stx (lambda: formals . body)) #'(tvars.vars ...))))])) -(define-syntax (pcase-lambda: stx) - (syntax-parse stx - [(pcase-lambda: tvars:type-variables cl ...) - (quasisyntax/loc stx - (#%expression - #,(plambda-property - (syntax/loc stx (case-lambda: cl ...)) - #'(tvars.vars ...))))])) - (define-syntax (popt-lambda: stx) (syntax-parse stx [(popt-lambda: tvars:type-variables formals . body) @@ -438,11 +431,6 @@ This file defines two sorts of primitives. All of them are provided into any mod [(lambda: formals:annotated-formals . body) (syntax/loc stx (-lambda formals.ann-formals . body))])) -(define-syntax (case-lambda: stx) - (syntax-parse stx - [(case-lambda: [formals:annotated-formals . body] ...) - (syntax/loc stx (case-lambda [formals.ann-formals . body] ...))])) - (define-syntax (opt-lambda: stx) (syntax-parse stx [(opt-lambda: formals:opt-lambda-annotated-formals . body) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt index 4475f25b..8fa2148e 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt @@ -13,8 +13,13 @@ racket/match "parse-classes.rkt" (for-label - racket/base "../base-env/colon.rkt" - "../base-env/base-types-extra.rkt")) + (except-in racket/base case-lambda) + "../base-env/colon.rkt" + "../base-env/base-types-extra.rkt" + ;; match on the `case-lambda` binding in the TR primitives + ;; rather than the one from Racket, which is no longer bound + ;; in most TR modules. + (only-in "../base-env/case-lambda.rkt" case-lambda))) (provide/cond-contract ;; Parse the given syntax as a type [parse-type (syntax? . c:-> . Type/c)] diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/with-types.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/with-types.rkt index f5c2a2c2..eb04af92 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/with-types.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/with-types.rkt @@ -4,7 +4,7 @@ (for-template (except-in racket/base for for* with-handlers lambda λ define let let* letrec letrec-values let-values - let/cc let/ec do struct define-struct + let/cc let/ec do case-lambda struct define-struct default-continuation-prompt-tag for/list for/vector for/hash for/hasheq for/hasheqv for/and for/or for/sum for/product for/lists diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed/racket/base.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed/racket/base.rkt index 63058f75..ff139a34 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed/racket/base.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed/racket/base.rkt @@ -4,7 +4,7 @@ with-handlers default-continuation-prompt-tag define λ lambda define-struct for for* let let* let-values letrec letrec-values - let/cc let/ec do struct + let/cc let/ec do case-lambda struct for/list for/vector for/hash for/hasheq for/hasheqv for/and for/or for/sum for/product for/lists for/first for/last for/fold for*/list for*/lists diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/parse-type-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/parse-type-tests.rkt index b9ebdebd..a8f59692 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/parse-type-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/parse-type-tests.rkt @@ -15,6 +15,8 @@ [Un t:Un] [-> t:->] [->* t:->*])) (only-in typed-racket/typed-racket do-standard-inits) (base-env base-types base-types-extra colon) + ;; needed for parsing case-lambda/case-> types + (only-in (base-env case-lambda) case-lambda) rackunit) 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 ea6f1cbc..587b2902 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 @@ -166,9 +166,9 @@ typed-racket/utils/utils ;; Needed for bindings of types and TR primitives in expressions (except-in (base-env extra-procs prims base-types base-types-extra) - define lambda λ) + define lambda λ case-lambda) ;; For tests that rely on kw/opt properties - (prefix-in tr: (only-in (base-env prims) define lambda λ)) + (prefix-in tr: (only-in (base-env prims) define lambda λ case-lambda)) ;; Needed for the `let-name` syntax class before (prefix-in r: (only-in racket/base let-values)) ;; Needed for constructing TR types in expected values @@ -332,6 +332,7 @@ [tc-e/t (plambda: (a) ([l : (Listof a)]) (car l)) (make-Poly '(a) (t:-> (make-Listof (-v a)) (-v a)))] [tc-e/t (case-lambda: [([a : Number] [b : Number]) (+ a b)]) (t:-> -Number -Number -Number)] + [tc-e/t (tr:case-lambda [([a : Number] [b : Number]) (+ a b)]) (t:-> -Number -Number -Number)] [tc-e (let: ([x : Number 5]) x) -Number] [tc-e (let-values ([(x) 4]) (+ x 1)) -PosIndex] [tc-e (let-values ([(#{x : Number} #{y : Boolean}) (values 3 #t)]) (and (= x 1) (not y))) @@ -485,6 +486,21 @@ (case-lambda: [([x : Number]) x] [([y : Number] [x : Number]) x]) '(1 foo))] + [tc-err ((tr:case-lambda [([x : Number]) x] + [([y : Number] [x : Number]) x]) + 1 2 3)] + [tc-err ((tr:case-lambda [([x : Number]) x] + [([y : Number] [x : Number]) x]) + 1 'foo)] + + [tc-err (apply + (tr:case-lambda [([x : Number]) x] + [([y : Number] [x : Number]) x]) + '(1 2 3))] + [tc-err (apply + (tr:case-lambda [([x : Number]) x] + [([y : Number] [x : Number]) x]) + '(1 foo))] [tc-e (let: ([x : Any #f]) (if (number? (let ([z 1]) x)) @@ -801,6 +817,10 @@ [[x : Number *] (+ 1 (car x))]) 5) -Number] + [tc-e ((tr:case-lambda + [[x : Number *] (+ 1 (car x))]) + 5) + -Number] [tc-e `(4 ,@'(3)) (-pair -PosByte (-lst* -PosByte))] @@ -2240,6 +2260,31 @@ #:ret (ret -Integer (make-NoFilter) (make-NoObject))] [tc-e (do : Integer ([x : Integer 0 (add1 x)]) ((> x 10) x) (displayln x)) #:ret (ret -Integer (make-NoFilter) (make-NoObject))] + [tc-e (tr:case-lambda [(x [y : String]) x]) + #:ret (ret (t:-> Univ -String Univ + : (-FS (-not-filter (-val #f) (list 0 0)) + (-filter (-val #f) (list 0 0))) + : (make-Path null (list 0 0))) + (-FS -top -bot))] + [tc-e (tr:case-lambda [(x [y : String] . rst) x]) + #:ret (ret (->* (list Univ -String) Univ Univ + : (-FS (-not-filter (-val #f) (list 0 0)) + (-filter (-val #f) (list 0 0))) + : (make-Path null (list 0 0))) + (-FS -top -bot))] + [tc-e (tr:case-lambda [(x [y : String] . [rst : String *]) x]) + #:ret (ret (->* (list Univ -String) -String Univ + : (-FS (-not-filter (-val #f) (list 0 0)) + (-filter (-val #f) (list 0 0))) + : (make-Path null (list 0 0))) + (-FS -top -bot))] + [tc-e (tr:case-lambda #:forall (A) [([x : A]) x]) + #:ret (ret (-poly (A) + (t:-> A A + : (-FS (-not-filter (-val #f) (list 0 0)) + (-filter (-val #f) (list 0 0))) + : (make-Path null (list 0 0)))) + (-FS -top -bot))] ) (test-suite "tc-literal tests"