Syntax for predicates with non-empty paths

svn: r17660

collects/tests/typed-scheme/succeed/parse-path.ss

@@ -0,0 +1,4 @@
+#lang typed/scheme
+
+(: f ((Pair Any Any) -> Boolean : Number @ car))
+(define f (lambda: ([x : (Pair Any Any)]) (number? (car x))))

collects/typed-scheme/private/parse-type.ss

@@ -67,6 +67,7 @@
        (add-type-name-reference #'kw)
        (parameterize ([current-tvars (extend-env vars tvars (current-tvars))])
          (make-Poly vars (parse-type #'t))))]
+    [(t:All (_:id ...) _ _ _ ...) (tc-error "All: too many forms in body of All type")]
     [(t:All . rest) (tc-error "All: bad syntax")]))
 
 (define-splicing-syntax-class keyword-tys
@@ -75,6 +76,24 @@
   (pattern (~seq [k:keyword t:expr])
            #:attr Keyword (make-Keyword (syntax-e #'k) (parse-type #'t) #f)))
 
+(define-syntax-class path-elem
+  #:description "path element"
+  #:literals (car cdr)
+  (pattern car
+           #:attr pe (make-CarPE))
+  (pattern cdr
+           #:attr pe (make-CdrPE)))
+
+(define-splicing-syntax-class latent-filter
+  #:description "latent filter"  
+  (pattern (~seq t:expr @:id pe:path-elem ...)
+           #:fail-unless (eq? (syntax-e #'@) '@) "expected @"
+           #:attr type (parse-type #'t)
+           #:attr path (attribute pe.pe))
+  (pattern t:expr
+           #:attr type (parse-type #'t)
+           #:attr path '()))
+
 (define (parse-type stx)    
   (parameterize ([current-orig-stx stx])    
     (syntax-parse
@@ -171,10 +190,10 @@
        (add-type-name-reference #'kw)
        (-Param (parse-type #'t1) (parse-type #'t2))]
       ;; function types
-      [(dom (~and kw t:->) rng : pred-ty)
+      [(dom (~and kw t:->) rng : ~! latent:latent-filter)
        (add-type-name-reference #'kw)
        ;; 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) (attribute latent.type) 0 (attribute latent.path))]
       [(dom:expr ... rest:expr ddd:star kws:keyword-tys ... (~and kw t:->) rng)
        (add-type-name-reference #'kw)
        (make-Function

collects/typed-scheme/types/abbrev.ss

@@ -265,8 +265,11 @@
 (d/c make-pred-ty
   (case-> (c:-> Type/c Type/c)
           (c:-> (listof Type/c) Type/c Type/c Type/c)
-          (c:-> (listof Type/c) Type/c Type/c integer? Type/c))
+          (c:-> (listof Type/c) Type/c Type/c integer? Type/c)
+          (c:-> (listof Type/c) Type/c Type/c integer? (listof PathElem?) Type/c))
   (case-lambda 
+    [(in out t n p)
+     (->* in out : (-LFS (list (-filter t p n)) (list (-not-filter t p n))))]
     [(in out t n)
      (->* in out : (-LFS (list (-filter t null n)) (list (-not-filter t null n))))]
     [(in out t)

collects/typed-scheme/types/printer.ss

@@ -43,6 +43,8 @@
                                (fp "LTop")
                                (for ([i els]) (fp " ~a" i)))
                            (fp")")]
+    [(LNotTypeFilter: type path 0) (fp "(! ~a @ ~a)" type path)]
+    [(LTypeFilter: type path 0) (fp "(~a @ ~a)" type path)]
     [(LNotTypeFilter: type path idx) (fp "(! ~a @ ~a ~a)" type path idx)]
     [(LTypeFilter: type path idx) (fp "(~a @ ~a ~a)" type path idx)]
     [(LBot:) (fp "LBot")]
@@ -115,10 +117,13 @@
          [(Values: (list (Result: t (LFilterSet: (list) (list)) (LEmpty:))))
           (fp "-> ~a" t)]
          [(Values: (list (Result: t
-				  (LFilterSet: (list (LTypeFilter: ft '() 0))
-					       (list (LNotTypeFilter: ft '() 0)))
+				  (LFilterSet: (list (LTypeFilter: ft pth 0))
+					       (list (LNotTypeFilter: ft pth 0)))
 				  (LEmpty:)))) 
-          (fp "-> ~a : ~a" t ft)]
+          (if (null? pth)
+              (fp "-> ~a : ~a" t ft)
+              (begin (fp "-> ~a : ~a @" t ft)
+                     (for ([pe pth]) (fp " ~a" pe))))]
          [(Values: (list (Result: t fs (LEmpty:)))) 
           (fp/filter "-> ~a : ~a" t fs)]
          [(Values: (list (Result: t lf lo)))