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

Elimintate printing of complex filters.

Browse Source 
Allow parsing of ...* and ...a
Parameter for printing ...* and ...a

svn: r16225

original commit: 96f664354d80ed25ff70e27fd7d6dc7f694c6c7d
This commit is contained in:
Sam Tobin-Hochstadt 2009-10-02 20:41:56 +00:00
parent 43b5710477
commit bd75ded350
2 changed files with 35 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -28,13 +28,25 @@
(define-syntax-class star
#:description "*"
(pattern star:id
#:fail-unless (eq? '* (syntax-e #'star)) "missing *"))
#:fail-unless (eq? '* (syntax-e #'star)) "missing *")
(pattern star:id
#:fail-unless (eq? '...* (syntax-e #'star)) "missing ...*"))
(define-syntax-class ddd
#:description "..."
(pattern ddd:id
#:fail-unless (eq? '... (syntax-e #'ddd)) "missing ..."))
(define-splicing-syntax-class ddd/bound
#:description "... followed by variable name"
#:attributes (bound)
(pattern i:id
#:attr s (symbol->string (syntax-e #'i))
#:fail-unless ((string-length (attribute s)) . > . 3) #f
#:fail-unless (equal? "..." (substring (attribute s) 0 3)) "missing ..."
#:attr bound (datum->syntax #'i (string->symbol (substring (attribute s) 3)) #'i #'i))
(pattern (~seq _:ddd bound:id)))
(define (parse-all-type stx parse-type)
;(printf "parse-all-type: ~a ~n" (syntax->datum stx))
(syntax-parse stx #:literals (t:All)
@ -108,10 +120,9 @@
;; 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))]
[(dom ... rest ddd:star (~and kw t:->) rng)
#:fail-unless (eq? '* (syntax-e #'ddd))
(add-type-name-reference #'kw)
(->* (map parse-type (syntax->list #'(dom ...))) (parse-type #'rest) (parse-values-type #'rng))]
[(dom ... rest _:ddd bound:id (~and kw t:->) rng)
[(dom ... rest :ddd/bound (~and kw t:->) rng)
(add-type-name-reference #'kw)
(let ([var (lookup (current-tvars) (syntax-e #'bound) (lambda (_) #f))])
(if (not (Dotted? var))
@ -284,7 +295,7 @@
(define (parse-values-type stx)
(parameterize ([current-orig-stx stx])
(syntax-parse stx #:literals (values t:All)
[((~and kw values) tys ... dty :ddd bound:id)
[((~and kw values) tys ... dty :ddd/bound)
(add-type-name-reference #'kw)
(let ([var (lookup (current-tvars) (syntax-e #'bound) (lambda (_) #f))])
(if (not (Dotted? var))

26
collects/typed-scheme/types/printer.ss
View File

@ -11,6 +11,10 @@
;; do we use simple type aliases in printing
(define print-aliases #t)
(define special-dots-printing? (make-parameter #f))
(define print-complex-filters? (make-parameter #f))
(provide special-dots-printing? print-complex-filters?)
;; does t have a type name associated with it currently?
;; has-name : Type -> Maybe[Symbol]
(define (has-name? t)
@ -31,8 +35,13 @@
(define (fp . args) (apply fprintf port args))
(match c
[(LFilterSet: thn els) (fp "(")
(for ([i thn]) (fp "~a " i)) (fp "|")
(for ([i els]) (fp " ~a" i))
(if (null? thn)
(fp "LTop")
(for ([i thn]) (fp "~a " i)))
(fp "|")
(if (null? els)
(fp "LTop")
(for ([i els]) (fp " ~a" i)))
(fp")")]
[(LNotTypeFilter: type path idx) (fp "(! ~a @ ~a ~a)" type path idx)]
[(LTypeFilter: type path idx) (fp "(~a @ ~a ~a)" type path idx)]
@ -74,6 +83,10 @@
;; print-type : Type Port Boolean -> Void
(define (print-type c port write?)
(define (fp . args) (apply fprintf port args))
(define (fp/filter fmt ret . rest)
(if (print-complex-filters?)
(apply fp fmt ret rest)
(fp "-> ~a" ret)))
(define (print-arr a)
(match a
[(top-arr:)
@ -88,9 +101,10 @@
(fp "~a ~a " k t)
(fp "[~a ~a] " k t))]))
(when rest
(fp "~a* " rest))
(fp "~a ~a " rest (if (special-dots-printing?) "...*" "*")))
(when drest
(fp "~a ... ~a " (car drest) (cdr drest)))
(fp "~a ...~a~a "
(car drest) (if (special-dots-printing?) "" " ") (cdr drest)))
(match rng
[(Values: (list (Result: t (LFilterSet: (list) (list)) (LEmpty:))))
(fp "-> ~a" t)]
@ -100,9 +114,9 @@
(LEmpty:))))
(fp "-> ~a : ~a" t ft)]
[(Values: (list (Result: t fs (LEmpty:))))
(fp "-> ~a : ~a" t fs)]
(fp/filter "-> ~a : ~a" t fs)]
[(Values: (list (Result: t lf lo)))
(fp "-> ~a : ~a ~a" t lf lo)]
(fp/filter "-> ~a : ~a ~a" t lf lo)]
[_
(fp "-> ~a" rng)])
(fp ")")]))