suzanne.soy/typed-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add TR case-lambda with optional type annotations

Browse Source 
original commit: 58a3d12f0c1e27b2ea45bcb1c8ee1243825d28b1
This commit is contained in:
Asumu Takikawa 2014-02-20 12:05:21 -05:00
parent 4216d01b2d
commit 9a4ee81604
10 changed files with 127 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/typed-racket-pkgs/typed-racket-compatibility/typed/scheme/base.rkt
View File

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

6
pkgs/typed-racket-pkgs/typed-racket-doc/typed-racket/scribblings/reference/legacy.scrbl
View File

@ -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)]]{

22
pkgs/typed-racket-pkgs/typed-racket-doc/typed-racket/scribblings/reference/special-forms.scrbl
View File

@ -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}

46
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/case-lambda.rkt Normal file
View File

@ -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 ...))))]))

16
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt
View File

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

9
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt
View File

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

2
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/with-types.rkt
View File

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

2
pkgs/typed-racket-pkgs/typed-racket-lib/typed/racket/base.rkt
View File

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

2
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/parse-type-tests.rkt
View File

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

49
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt
View File

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