diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss index 91f503fa..aa6fbe1f 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -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)) diff --git a/collects/typed-scheme/types/printer.ss b/collects/typed-scheme/types/printer.ss index 78f3fa1f..33d6602b 100644 --- a/collects/typed-scheme/types/printer.ss +++ b/collects/typed-scheme/types/printer.ss @@ -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 ")")]))