Elimintate printing of complex filters.

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

svn: r16225

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))

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 "|")
+                           (if (null? thn)
-                           (for ([i els]) (fp " ~a" i))
+                               (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 ")")]))