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

Support some keyword arguments in type parsing/type->contract.

Browse Source 
svn: r17189
This commit is contained in:
Sam Tobin-Hochstadt 2009-12-05 00:48:46 +00:00
parent b844179642
commit 76b10347da
2 changed files with 29 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -66,6 +66,12 @@
(make-Poly vars (parse-type #'t))))] (make-Poly vars (parse-type #'t))))]
[(t:All . rest) (tc-error "All: bad syntax")])) [(t:All . rest) (tc-error "All: bad syntax")]))
(define-splicing-syntax-class keyword-tys
(pattern (~seq k:keyword t:expr)
#:attr Keyword (make-Keyword (syntax-e #'k) (parse-type #'t) #t))
(pattern (~seq [k:keyword t:expr])
#:attr Keyword (make-Keyword (syntax-e #'k) (parse-type #'t) #f)))
(define (parse-type stx) (define (parse-type stx)
(parameterize ([current-orig-stx stx]) (parameterize ([current-orig-stx stx])
(syntax-parse (syntax-parse
@ -119,10 +125,15 @@
(add-type-name-reference #'kw) (add-type-name-reference #'kw)
;; use parse-type instead of parse-values-type because we need to add the filters from the pred-ty ;; use parse-type instead of parse-values-type because we need to add the filters from the pred-ty
(make-pred-ty (list (parse-type #'dom)) (parse-type #'rng) (parse-type #'pred-ty))] (make-pred-ty (list (parse-type #'dom)) (parse-type #'rng) (parse-type #'pred-ty))]
[(dom ... rest ddd:star (~and kw t:->) rng) [(dom:expr ... rest:expr ddd:star kws:keyword-tys ... (~and kw t:->) rng)
(add-type-name-reference #'kw) (add-type-name-reference #'kw)
(->* (map parse-type (syntax->list #'(dom ...))) (parse-type #'rest) (parse-values-type #'rng))] (make-Function
[(dom ... rest :ddd/bound (~and kw t:->) rng) (list (make-arr
(map parse-type (syntax->list #'(dom ...)))
(parse-values-type #'rng)
#:rest (parse-type #'rest)
#:kws (attribute kws.Keyword))))]
[(dom:expr ... rest:expr :ddd/bound (~and kw t:->) rng)
(add-type-name-reference #'kw) (add-type-name-reference #'kw)
(let ([var (lookup (current-tvars) (syntax-e #'bound) (lambda (_) #f))]) (let ([var (lookup (current-tvars) (syntax-e #'bound) (lambda (_) #f))])
(if (not (Dotted? var)) (if (not (Dotted? var))
@ -141,7 +152,7 @@
(current-tvars))]) (current-tvars))])
(parse-type #'rest)) (parse-type #'rest))
(syntax-e #'bound))))))] (syntax-e #'bound))))))]
[(dom ... rest _:ddd (~and kw t:->) rng) [(dom:expr ... rest:expr _:ddd (~and kw t:->) rng)
(add-type-name-reference #'kw) (add-type-name-reference #'kw)
(let ([bounds (filter (compose Dotted? cdr) (let ([bounds (filter (compose Dotted? cdr)
(env-keys+vals (current-tvars)))]) (env-keys+vals (current-tvars)))])
@ -160,11 +171,19 @@
(current-tvars))]) (current-tvars))])
(parse-type #'rest)) (parse-type #'rest))
var)))))] var)))))]
;; has to be below the previous one #| ;; has to be below the previous one
[(dom ... (~and kw t:->) rng) [(dom:expr ... (~and kw t:->) rng)
(add-type-name-reference #'kw) (add-type-name-reference #'kw)
(->* (map parse-type (syntax->list #'(dom ...))) (->* (map parse-type (syntax->list #'(dom ...)))
(parse-values-type #'rng))] (parse-values-type #'rng))] |#
;; use expr to rule out keywords
[(dom:expr ... kws:keyword-tys ... (~and kw t:->) rng)
(add-type-name-reference #'kw)
(make-Function
(list (make-arr
(map parse-type (syntax->list #'(dom ...)))
(parse-values-type #'rng)
#:kws (attribute kws.Keyword))))]
[((~and kw case-lambda) tys ...) [((~and kw case-lambda) tys ...)
(add-type-name-reference #'kw) (add-type-name-reference #'kw)
(make-Function (make-Function

5
collects/typed-scheme/private/type-contract.ss
View File

@ -72,8 +72,9 @@
(define (f a) (define (f a)
(define-values (dom* rngs* rst) (define-values (dom* rngs* rst)
(match a (match a
[(arr: dom (Values: (list (Result: rngs (LFilterSet: '() '()) (LEmpty:)) ...)) rst #f '()) [(arr: dom (Values: (list (Result: rngs (LFilterSet: '() '()) (LEmpty:)) ...)) rst #f (list (Keyword: kws ktys #t) ...))
(values (map t->c/neg dom) (map t->c rngs) (and rst (t->c/neg rst)))] (values (append (map t->c/neg dom) (append-map (lambda (kw kty) (list kw (t->c/neg kty))) kws ktys))
(map t->c rngs) (and rst (t->c/neg rst)))]
[(arr: dom (Values: (list (Result: rngs _ _) ...)) rst #f '()) [(arr: dom (Values: (list (Result: rngs _ _) ...)) rst #f '())
(if (and out? pos?) (if (and out? pos?)
(values (map t->c/neg dom) (map t->c rngs) (and rst (t->c/neg rst))) (values (map t->c/neg dom) (map t->c rngs) (and rst (t->c/neg rst)))