..

original commit: e918ee3ec5c89a35d9ed6322543b5cdd11019746

collects/framework/specs.ss

@@ -8,7 +8,8 @@
            case->)
   (require-for-syntax mzscheme
                       (lib "list.ss")
-		      (lib "stx.ss" "syntax"))
+		      (lib "name.ss" "syntax")
+                      (lib "stx.ss" "syntax"))
   
   (require (lib "class.ss"))
   
@@ -43,27 +44,32 @@
            (syntax
             (-contract a-contract to-check pos-blame-e neg-blame-e src-loc)))]
         [(_ a-contract-e to-check pos-blame-e neg-blame-e src-info-e)
-         (syntax
+         (let ([name (syntax-local-infer-name (syntax a-contract-e))])
-          (let ([a-contract a-contract-e]
+           (with-syntax ([named-a-contract-e
-                [name to-check]
+                          (if name
-                [neg-blame neg-blame-e]
+                              (syntax-property (syntax a-contract-e) 'inferred-name name)
-                [pos-blame pos-blame-e]
+                              (syntax a-contract-e))])
-                [src-info src-info-e])
+             (syntax
-            (unless (contract-p? a-contract)
+              (let ([a-contract named-a-contract-e]
-              (error 'contract "expected a contract as first argument, got: ~e, other args ~e ~e ~e ~e" 
+                    [name to-check]
-                     a-contract
+                    [neg-blame neg-blame-e]
-                     name
+                    [pos-blame pos-blame-e]
-                     pos-blame
+                    [src-info src-info-e])
-                     neg-blame
+                (unless (contract-p? a-contract)
-                     src-info))
+                  (error 'contract "expected a contract as first argument, got: ~e, other args ~e ~e ~e ~e" 
-            (unless (and (symbol? neg-blame)
+                         a-contract
-                         (symbol? pos-blame))
+                         name
-              (error 'contract "expected symbols as names for assigning blame, got: ~e and ~e, other args ~e ~e ~e"
+                         pos-blame
-                     neg-blame pos-blame
+                         neg-blame
-                     a-contract 
+                         src-info))
-                     name
+                (unless (and (symbol? neg-blame)
-                     src-info))
+                             (symbol? pos-blame))
-            (check-contract a-contract name pos-blame neg-blame src-info-e)))])))
+                  (error 'contract "expected symbols as names for assigning blame, got: ~e and ~e, other args ~e ~e ~e"
+                         neg-blame pos-blame
+                         a-contract 
+                         name
+                         src-info))
+                (check-contract a-contract name pos-blame neg-blame src-info-e)))))])))
   
   (define-syntaxes (-> ->* ->d ->d* case->)
     (let ()
@@ -381,12 +387,23 @@
               (with-syntax ([outer-args outer-args]
                             [inner-check (make-inner-check outer-args)]
                             [(inner-args body) (make-main outer-args)])
-                (add-outer-check
+                (with-syntax ([inner-lambda 
-                 (syntax
+                               (set-inferred-name-from
-                  (make-contract
+                                stx
-                   (lambda outer-args
+                                (syntax (lambda inner-args body)))])
-                     inner-check
+                  (add-outer-check
-                     (lambda inner-args body))))))))))
+                   (syntax
+                    (make-contract
+                     (lambda outer-args
+                       inner-check
+                       inner-lambda))))))))))
+      
+      ;; set-inferred-name-from : syntax syntax -> syntax
+      (define (set-inferred-name-from with-name to-be-named)
+        (let ([name (syntax-local-infer-name with-name)])
+          (if name
+              (syntax-property to-be-named 'inferred-name name)
+              to-be-named)))
       
       ;; ->/f : syntax -> syntax
       ;; the transformer for the -> macro
@@ -415,12 +432,16 @@
                (with-syntax ([outer-args outer-args]
                              [(inner-check ...) (make-inner-check outer-args)]
                              [(body ...) (make-bodies outer-args)])
-                 (add-outer-check
+                 (with-syntax ([inner-lambda 
-                  (syntax
+                                (set-inferred-name-from
-                   (make-contract
+                                 stx
-                    (lambda outer-args
+                                 (syntax (case-lambda body ...)))])
-                      inner-check ...
+                   (add-outer-check
-                      (case-lambda body ...))))))))]))
+                    (syntax
+                     (make-contract
+                      (lambda outer-args
+                        inner-check ...
+                        inner-lambda))))))))]))
       
       ;; case->/h : (listof syntax) -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
       ;; like the other /h functions, but composes the wrapper functions
@@ -484,15 +505,22 @@
            union symbols
            subclass?/c implementation?/c is-a?/c
            listof)
+  
+  (define-syntax (name stx)
+    (syntax-case stx ()
+      [(_ name exp)
+       (syntax (let ([name exp])
+                 name))]))
 
   (define (symbols . ss)
-    (lambda (x)
+    (name symbols
-      (memq x ss)))
+          (lambda (x)
+            (memq x ss))))
 
-  (define (>=/c x) (lambda (y) (and (number? y) (>= y x))))
+  (define (>=/c x) (name >=/c (lambda (y) (and (number? y) (>= y x)))))
-  (define (<=/c x) (lambda (y) (and (number? y) (<= y x))))
+  (define (<=/c x) (name <=/c (lambda (y) (and (number? y) (<= y x)))))
-  (define (</c x) (lambda (y) (and (number? y) (< y x))))
+  (define (</c x) (name </c (lambda (y) (and (number? y) (< y x)))))
-  (define (>/c x) (lambda (y) (and (number? y) (> y x))))
+  (define (>/c x) (name >/c (lambda (y) (and (number? y) (> y x)))))
 
   (define (is-a?/c <%>) (lambda (x) (is-a? x <%>)))
   (define (subclass?/c <%>) (lambda (x) (subclass? x <%>)))
@@ -507,7 +535,7 @@
                     (procedure-arity-includes? x 1))
          (error 'union "expected procedures of arity 1, got: ~e" x)))
      fs)
-    (apply or/f fs))
+    (name union (lambda (x) ((apply or/f fs) x))))
 
   (define (and/f . fs)
     (for-each
@@ -516,8 +544,9 @@
                     (procedure-arity-includes? x 1))
          (error 'and/f "expected procedures of arity 1, got: ~e" x)))
      fs)
-    (lambda (x)
+    (name and/f
-      (andmap (lambda (f) (f x)) fs)))
+          (lambda (x)
+            (andmap (lambda (f) (f x)) fs))))
   
   (define (or/f . fs)
     (for-each
@@ -526,16 +555,19 @@
                     (procedure-arity-includes? x 1))
          (error 'or/f "expected procedures of arity 1, got: ~e" x)))
      fs)
-    (lambda (x)
+    (name or/f
-      (ormap (lambda (f) (f x)) fs)))
+          (lambda (x)
+            (ormap (lambda (f) (f x)) fs))))
   
   (define (listof p)
-    (lambda (v)
+    (name listof
-      (and (list? v)
+          (lambda (v)
-           (andmap p v))))
+            (and (list? v)
+                 (andmap p v)))))
   
   (define (vectorof p)
-    (lambda (v)
+    (name vectorof 
-      (and (vector? v)
+          (lambda (v)
-           (andmap p (vector->list v)))))
+            (and (vector? v)
+                 (andmap p (vector->list v))))))
   )