From 18b8cde3e22fa7b2d62956d6a1f2f341fafe735a Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Tue, 13 Jul 2010 04:44:11 -0500
Subject: [PATCH] adjusted the annotations so that contracts can declare
 multiple parts of themselves to be colored and then used that so that the
 #:pre-cond and #:post-cond keywords on ->i contracts are colored.

---
 .../private/syncheck/contract-traversal.rkt   |  8 +++--
 collects/racket/contract/private/arr-i.rkt    | 33 +++++++++++++++++--
 collects/racket/contract/private/arrow.rkt    |  3 +-
 3 files changed, 38 insertions(+), 6 deletions(-)

diff --git a/collects/drracket/private/syncheck/contract-traversal.rkt b/collects/drracket/private/syncheck/contract-traversal.rkt
index 39cf978b64..71b6eed44d 100644
--- a/collects/drracket/private/syncheck/contract-traversal.rkt
+++ b/collects/drracket/private/syncheck/contract-traversal.rkt
@@ -80,8 +80,12 @@
              [(pair? prop) (sloop (car prop)) (sloop (cdr prop))]
              [(vector? prop)
               (let ([id (vector-ref prop 0)]
-                    [to-color (vector-ref prop 1)])
-                (base-color #'id polarity boundary-contract? my-coloring-plans client-coloring-plans)
+                    [to-color-pos (vector-ref prop 1)]
+                    [to-color-neg (vector-ref prop 2)])
+                (for ((stx (in-list to-color-pos)))
+                  (base-color stx polarity boundary-contract? my-coloring-plans client-coloring-plans))
+                (for ((stx (in-list to-color-neg)))
+                  (base-color stx (not polarity) boundary-contract? my-coloring-plans client-coloring-plans))
                 (for ((stx (in-list (hash-ref domain-map id '()))))
                   (do-contract-traversal stx boundary-contract?
                                          my-coloring-plans client-coloring-plans
diff --git a/collects/racket/contract/private/arr-i.rkt b/collects/racket/contract/private/arr-i.rkt
index 90241d4c46..9bbe20d70a 100644
--- a/collects/racket/contract/private/arr-i.rkt
+++ b/collects/racket/contract/private/arr-i.rkt
@@ -119,6 +119,26 @@
          [(id . args)
           (datum->syntax sstx (cons #'this-arg #'args) sstx)])))))
 
+(define-for-syntax (find-pre/post-keywords stx)
+  (let ([pre #f]
+        [post #f])
+    (let loop ([stx (syntax->list stx)])
+      (cond
+        [(syntax? stx)
+         (loop (syntax-e stx))]
+        [(pair? stx)
+         (when (and (syntax? (car stx))
+                    (eq? (syntax-e (car stx))
+                         '#:pre-cond))
+           (set! pre (car stx)))
+         (when (and (syntax? (car stx))
+                    (eq? (syntax-e (car stx))
+                         '#:post-cond))
+           (set! post (car stx)))
+         (loop (cdr stx))]
+        [else (void)]))
+    (values pre post)))
+
 (define-syntax (->i stx)
   (syntax-case stx ()
     [(_ (raw-mandatory-doms ...)
@@ -250,9 +270,16 @@
                                            (syntax-local-infer-name stx)
                                            #`(λ args (apply f args)))))
                          'racket/contract:contract 
-                         (vector this->i 
-                                 ;; the -> in the original input to this guy
-                                 (car (syntax-e stx))))
+                         (let-values ([(pre-kwd post-kwd) (find-pre/post-keywords #'leftover)])
+                           (vector this->i 
+                                   ;; the -> in the original input to this guy
+                                   (let ([kwd (list (car (syntax-e stx)))])
+                                     (if post-kwd
+                                         (cons post-kwd kwd)
+                                         kwd))
+                                   (if pre-kwd
+                                       (list pre-kwd)
+                                       '()))))
                          'racket/contract:internal-contract
                          (gensym '->i-boundary)))))))))))]))
 
diff --git a/collects/racket/contract/private/arrow.rkt b/collects/racket/contract/private/arrow.rkt
index 8b6ff5ea53..2fb6e9d6a9 100644
--- a/collects/racket/contract/private/arrow.rkt
+++ b/collects/racket/contract/private/arrow.rkt
@@ -330,7 +330,8 @@ v4 todo:
             'racket/contract:contract 
             (vector this-> 
                     ;; the -> in the original input to this guy
-                    (car (syntax-e stx))))
+                    (list (car (syntax-e stx)))
+                    '()))
            inner-args/body
            (syntax (dom-names ... rng-names ...))))))))