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

Fix parsing of All to only use parse-values-type when appropriate.

Browse Source 
Fix tests for new names.
Fix tests for parse-type not handling values.

svn: r14752
This commit is contained in:
Sam Tobin-Hochstadt 2009-05-08 20:26:27 +00:00
parent 1911b762eb
commit 9f3d719b4e
4 changed files with 71 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/tests/typed-scheme/unit-tests/parse-type-tests.ss
View File

@ -55,6 +55,10 @@
(test-suite nm (test-suite nm
(pt-test elems ...) ...)])) (pt-test elems ...) ...)]))
(define N -Number)
(define B -Boolean)
(define Sym -Symbol)
(define (parse-type-tests) (define (parse-type-tests)
(pt-tests (pt-tests
"parse-type tests" "parse-type tests"
@ -65,7 +69,7 @@
[(Listof Boolean) (make-Listof B)] [(Listof Boolean) (make-Listof B)]
[(Vectorof (Listof Symbol)) (make-Vector (make-Listof Sym))] [(Vectorof (Listof Symbol)) (make-Vector (make-Listof Sym))]
[(pred Number) (make-pred-ty N)] [(pred Number) (make-pred-ty N)]
[(values Number Boolean Number) (-values (list N B N))] [(-> (values Number Boolean Number)) (t:-> (-values (list N B N)))]
[(Number -> Number) (t:-> N N)] [(Number -> Number) (t:-> N N)]
[(Number -> Number) (t:-> N N)] [(Number -> Number) (t:-> N N)]
[(Number Number Number Boolean -> Number) (N N N B . t:-> . N)] [(Number Number Number Boolean -> Number) (N N N B . t:-> . N)]
@ -80,8 +84,8 @@
[(∀ (a ...) (a ... a -> Integer)) (-polydots (a) ( (list) (a a) . ->... . -Integer))] [(∀ (a ...) (a ... a -> Integer)) (-polydots (a) ( (list) (a a) . ->... . -Integer))]
[(All (a ...) (a ... -> Number)) [(All (a ...) (a ... -> Number))
(-polydots (a) ((list) [a a] . ->... . N))] (-polydots (a) ((list) [a a] . ->... . N))]
[(All (a ...) (values a ...)) [(All (a ...) (-> (values a ...)))
(-polydots (a) (make-ValuesDots (list) a 'a))] (-polydots (a) (t:-> (make-ValuesDots (list) a 'a)))]
[(case-lambda (Number -> Boolean) (Number Number -> Number)) (cl-> [(N) B] [(case-lambda (Number -> Boolean) (Number Number -> Number)) (cl-> [(N) B]
[(N N) N])] [(N N) N])]
[1 (-val 1)] [1 (-val 1)]

46
collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss
View File

@ -15,15 +15,15 @@
(define (restrict-tests) (define (restrict-tests)
(restr-tests (restr-tests
[N (Un N Sym) N] [-Number (Un -Number -Symbol) -Number]
[N N N] [-Number -Number -Number]
[(Un (-val 'foo) (-val 6)) (Un N Sym) (Un (-val 'foo) (-val 6))] [(Un (-val 'foo) (-val 6)) (Un -Number -Symbol) (Un (-val 'foo) (-val 6))]
[N (-mu a (Un N Sym (make-Listof a))) N] [-Number (-mu a (Un -Number -Symbol (make-Listof a))) -Number]
[(Un N B) (-mu a (Un N Sym (make-Listof a))) N] [(Un -Number -Boolean) (-mu a (Un -Number -Symbol (make-Listof a))) -Number]
[(-mu x (Un N (make-Listof x))) (Un Sym N B) N] [(-mu x (Un -Number (make-Listof x))) (Un -Symbol -Number -Boolean) -Number]
[(Un N -String Sym B) N N] [(Un -Number -String -Symbol -Boolean) -Number -Number]
[(-lst N) (-pair Univ Univ) (-pair N (-lst N))] [(-lst -Number) (-pair Univ Univ) (-pair -Number (-lst -Number))]
;; FIXME ;; FIXME
#; #;
[-Listof -Sexp (-lst (Un B N -String Sym))] [-Listof -Sexp (-lst (Un B N -String Sym))]
@ -40,18 +40,18 @@
(define (remove-tests) (define (remove-tests)
(remo-tests (remo-tests
[(Un N Sym) N Sym] [(Un -Number -Symbol) -Number -Symbol]
[N N (Un)] [-Number -Number (Un)]
[(-mu x (Un N Sym (make-Listof x))) N (Un Sym (make-Listof (-mu x (Un N Sym (make-Listof x)))))] [(-mu x (Un -Number -Symbol (make-Listof x))) -Number (Un -Symbol (make-Listof (-mu x (Un -Number -Symbol (make-Listof x)))))]
[(-mu x (Un N Sym B (make-Listof x))) N (Un Sym B (make-Listof (-mu x (Un N Sym B (make-Listof x)))))] [(-mu x (Un -Number -Symbol -Boolean (make-Listof x))) -Number (Un -Symbol -Boolean (make-Listof (-mu x (Un -Number -Symbol -Boolean (make-Listof x)))))]
[(Un (-val #f) (-mu x (Un N Sym (make-Listof (-v x))))) [(Un (-val #f) (-mu x (Un -Number -Symbol (make-Listof (-v x)))))
(Un B N) (Un -Boolean -Number)
(Un Sym (make-Listof (-mu x (Un N Sym (make-Listof x)))))] (Un -Symbol (make-Listof (-mu x (Un -Number -Symbol (make-Listof x)))))]
[(Un (-val 'foo) (-val 6)) (Un N Sym) (Un)] [(Un (-val 'foo) (-val 6)) (Un -Number -Symbol) (Un)]
[(-> (Un Sym N) N) (-> N N) (Un)] [(-> (Un -Symbol -Number) -Number) (-> -Number -Number) (Un)]
[(Un (-poly (a) (make-Listof a)) (-> N N)) (-> N N) (-poly (a) (make-Listof a))] [(Un (-poly (a) (make-Listof a)) (-> -Number -Number)) (-> -Number -Number) (-poly (a) (make-Listof a))]
[(Un Sym N) (-poly (a) N) Sym] [(Un -Symbol -Number) (-poly (a) -Number) -Symbol]
[(-pair N (-v a)) (-pair Univ Univ) (Un)] [(-pair -Number (-v a)) (-pair Univ Univ) (Un)]
)) ))
(define-go (define-go
@ -62,11 +62,11 @@
(-mu list-rec (-mu list-rec
(Un (Un
(-val '()) (-val '())
(-pair (-mu x (Un B N -String Sym (-val '()) (-pair x x))) (-pair (-mu x (Un -Boolean -Number -String -Symbol (-val '()) (-pair x x)))
list-rec)))) list-rec))))
(define x2 (define x2
(Un (-val '()) (Un (-val '())
(-pair (-mu x (Un B N -String Sym (-val '()) (-pair x x))) (-pair (-mu x (Un -Boolean -Number -String -Symbol (-val '()) (-pair x x)))
(-mu x (Un B N -String Sym (-val '()) (-pair x x)))))) (-mu x (Un -Boolean -Number -String -Symbol (-val '()) (-pair x x))))))
(provide remove-tests restrict-tests) (provide remove-tests restrict-tests)

22
collects/tests/typed-scheme/unit-tests/type-equal-tests.ss
View File

@ -26,21 +26,21 @@
(define (type-equal-tests) (define (type-equal-tests)
(te-tests (te-tests
[N N] [-Number -Number]
[(Un N) N] [(Un -Number) -Number]
[(Un N Sym B) (Un N B Sym)] [(Un -Number -Symbol -Boolean) (Un -Number -Boolean -Symbol)]
[(Un N Sym B) (Un Sym B N)] [(Un -Number -Symbol -Boolean) (Un -Symbol -Boolean -Number)]
[(Un N Sym B) (Un Sym N B)] [(Un -Number -Symbol -Boolean) (Un -Symbol -Number -Boolean)]
[(Un N Sym B) (Un B (Un Sym N))] [(Un -Number -Symbol -Boolean) (Un -Boolean (Un -Symbol -Number))]
[(Un N Sym) (Un Sym N)] [(Un -Number -Symbol) (Un -Symbol -Number)]
[(-poly (x) (-> (Un Sym N) x)) (-poly (xyz) (-> (Un N Sym) xyz))] [(-poly (x) (-> (Un -Symbol -Number) x)) (-poly (xyz) (-> (Un -Number -Symbol) xyz))]
[(-mu x (Un N Sym x)) (-mu y (Un N Sym y))] [(-mu x (Un -Number -Symbol x)) (-mu y (Un -Number -Symbol y))]
;; found bug ;; found bug
[FAIL (Un (-mu heap-node [FAIL (Un (-mu heap-node
(-struct 'heap-node #f (list (-base 'comparator) N (-v a) (Un heap-node (-base 'heap-empty))))) (-struct 'heap-node #f (list (-base 'comparator) -Number (-v a) (Un heap-node (-base 'heap-empty)))))
(-base 'heap-empty)) (-base 'heap-empty))
(Un (-mu heap-node (Un (-mu heap-node
(-struct 'heap-node #f (list (-base 'comparator) N (-pair N N) (Un heap-node (-base 'heap-empty))))) (-struct 'heap-node #f (list (-base 'comparator) -Number (-pair -Number -Number) (Un heap-node (-base 'heap-empty)))))
(-base 'heap-empty))])) (-base 'heap-empty))]))
(define-go (define-go

54
collects/typed-scheme/private/parse-type.ss
View File

@ -278,6 +278,27 @@
(parameterize ([current-orig-stx stx]) (parameterize ([current-orig-stx stx])
(parse/get stx t type))) (parse/get stx t type)))
(define (parse-all-type stx parse-type)
(syntax-parse stx
[(All (vars ... v dd) t)
#:when (eq? (syntax-e #'dd) '...)
#:when (andmap identifier? (syntax->list #'(v vars ...)))
(let* ([vars (map syntax-e (syntax->list #'(vars ...)))]
[tvars (map make-F vars)]
[v (syntax-e #'v)]
[tv (make-Dotted (make-F v))])
(add-type-name-reference #'All)
(parameterize ([current-tvars (extend-env (cons v vars) (cons tv tvars) (current-tvars))])
(make-PolyDots (append vars (list v)) (parse-type #'t))))]
[(All (vars ...) t)
#:when (andmap identifier? (syntax->list #'(vars ...)))
(let* ([vars (map syntax-e (syntax->list #'(vars ...)))]
[tvars (map make-F vars)])
(add-type-name-reference #'All)
(parameterize ([current-tvars (extend-env vars tvars (current-tvars))])
(make-Poly vars (parse-type #'t))))]
[(All . rest) (tc-error "All: bad syntax")]))
(define (parse-type stx) (define (parse-type stx)
(parameterize ([current-orig-stx stx]) (parameterize ([current-orig-stx stx])
(syntax-case* stx () (syntax-case* stx ()
@ -423,27 +444,10 @@
[(quot t) [(quot t)
(eq? (syntax-e #'quot) 'quote) (eq? (syntax-e #'quot) 'quote)
(-val (syntax-e #'t))] (-val (syntax-e #'t))]
[(All (vars ... v dd) t) [(All . rest)
(and (or (eq? (syntax-e #'All) 'All) (or (eq? (syntax-e #'All) 'All)
(eq? (syntax-e #'All) '∀)) (eq? (syntax-e #'All) '∀))
(eq? (syntax-e #'dd) '...) (parse-all-type stx parse-type)]
(andmap identifier? (syntax->list #'(v vars ...))))
(let* ([vars (map syntax-e (syntax->list #'(vars ...)))]
[tvars (map make-F vars)]
[v (syntax-e #'v)]
[tv (make-Dotted (make-F v))])
(add-type-name-reference #'All)
(parameterize ([current-tvars (extend-env (cons v vars) (cons tv tvars) (current-tvars))])
(make-PolyDots (append vars (list v)) (parse-values-type #'t))))]
[(All (vars ...) t)
(and (or (eq? (syntax-e #'All) 'All)
(eq? (syntax-e #'All) '∀))
(andmap identifier? (syntax->list #'(vars ...))))
(let* ([vars (map syntax-e (syntax->list #'(vars ...)))]
[tvars (map make-F vars)])
(add-type-name-reference #'All)
(parameterize ([current-tvars (extend-env vars tvars (current-tvars))])
(make-Poly vars (parse-values-type #'t))))]
[(Opaque p?) [(Opaque p?)
(eq? (syntax-e #'Opaque) 'Opaque) (eq? (syntax-e #'Opaque) 'Opaque)
(begin (begin
@ -487,9 +491,7 @@
Err] Err]
[else [else
(tc-error/delayed "Unbound type name ~a" (syntax-e #'id)) (tc-error/delayed "Unbound type name ~a" (syntax-e #'id))
Err])] Err])]
[(All . rest) (eq? (syntax-e #'All) 'All) (tc-error "All: bad syntax")]
[(Opaque . rest) (eq? (syntax-e #'Opaque) 'Opqaue) (tc-error "Opaque: bad syntax")] [(Opaque . rest) (eq? (syntax-e #'Opaque) 'Opqaue) (tc-error "Opaque: bad syntax")]
[(U . rest) (eq? (syntax-e #'U) 'U) (tc-error "Union: bad syntax")] [(U . rest) (eq? (syntax-e #'U) 'U) (tc-error "Union: bad syntax")]
[(Vectorof . rest) (eq? (syntax-e #'Vectorof) 'Vectorof) (tc-error "Vectorof: bad syntax")] [(Vectorof . rest) (eq? (syntax-e #'Vectorof) 'Vectorof) (tc-error "Vectorof: bad syntax")]
@ -562,6 +564,10 @@
[(values tys ...) [(values tys ...)
#:when (eq? (syntax-e #'values) 'values) #:when (eq? (syntax-e #'values) 'values)
(-values (map parse-type (syntax->list #'(tys ...))))] (-values (map parse-type (syntax->list #'(tys ...))))]
[(All . rest)
#:when (or (eq? (syntax-e #'All) 'All)
(eq? (syntax-e #'All) '∀))
(parse-all-type stx parse-values-type)]
[t [t
(-values (list (parse-type #'t)))]))) (-values (list (parse-type #'t)))])))