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

Generate -> instead of ->* when required by case->.

Browse Source 
Closes PR 10977.

original commit: cf5c74a2ca36a951d7cbeac61e58235f493291dd
This commit is contained in:
Sam Tobin-Hochstadt 2010-06-13 14:50:33 -04:00
parent ae851e41cd
commit b4d568a84d
3 changed files with 20 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/tests/typed-scheme/fail/all-bad-syntax.rkt
View File

@ -1,5 +1,5 @@
#;
(exn-pred 1)
(exn-pred 2)
#lang typed-scheme
(require scheme/list)
@ -22,4 +22,4 @@
(list key)
(rt)))
#;empty))
(+ 'foo)
(+ 'foo)

8
collects/tests/typed-scheme/succeed/provide-case-rest.rkt Normal file
View File

@ -0,0 +1,8 @@
#lang typed/racket
(provide foo)
(define foo
(case-lambda:
(((x : Number)) x)
(((x : Number) (y : Number) z : Number *) y)))

15
collects/typed-scheme/private/type-contract.rkt
View File

@ -64,7 +64,7 @@
[(Function: arrs)
(when flat? (exit (fail)))
(let ()
(define (f a)
(define ((f [case-> #f]) a)
(define-values (dom* opt-dom* rngs* rst)
(match a
;; functions with no filters or objects
@ -91,16 +91,21 @@
[(list r) r]
[_ #`(values #,@rngs*)])]
[rst* rst])
(if (or rst (pair? (syntax-e #'(opt-dom* ...))))
#'((dom* ...) (opt-dom* ...) #:rest (listof rst*) . ->* . rng*)
#'(dom* ... . -> . rng*))))
;; Garr, I hate case->!
(if (and (pair? (syntax-e #'(opt-dom* ...))) case->)
(exit (fail))
(if (or rst (pair? (syntax-e #'(opt-dom* ...))))
(if case->
#'(dom* ... #:rest (listof rst*) . -> . rng*)
#'((dom* ...) (opt-dom* ...) #:rest (listof rst*) . ->* . rng*))
#'(dom* ... . -> . rng*)))))
(unless (no-duplicates (for/list ([t arrs])
(match t
[(arr: dom _ _ _ _) (length dom)]
;; is there something more sensible here?
[(top-arr:) (int-err "got top-arr")])))
(exit (fail)))
(match (map f arrs)
(match (map (f (not (= 1 (length arrs)))) arrs)
[(list e) e]
[l #`(case-> #,@l)]))]
[_ (int-err "not a function" f)]))