added in unioning and a bit more coloring; checking in to prepare for some changes to the original check syntax (to support contract obligations better)

collects/drracket/private/syncheck/colors.rkt

@@ -7,75 +7,86 @@
 
 (define cs-my-obligation-color "my obligations")
 (define cs-their-obligation-color "my assumptions")
+(define cs-both-obligation-color "both obligations")
 (define cs-unk-obligation-color "unknown obligations")
 
+(define lexically-bound-variable-style-pref 'drracket:check-syntax:lexically-bound)
+(define imported-variable-style-pref 'drracket:check-syntax:imported)
+(define set!d-variable-style-pref 'drracket:check-syntax:set!d)
 
-    (define lexically-bound-variable-style-pref 'drracket:check-syntax:lexically-bound)
+(define lexically-bound-variable-style-name (symbol->string lexically-bound-variable-style-pref))
-    (define imported-variable-style-pref 'drracket:check-syntax:imported)
+(define imported-variable-style-name (symbol->string imported-variable-style-pref))
-    (define set!d-variable-style-pref 'drracket:check-syntax:set!d)
+(define set!d-variable-style-name (symbol->string set!d-variable-style-pref))
-    
+
-    (define lexically-bound-variable-style-name (symbol->string lexically-bound-variable-style-pref))
+(define my-obligation-style-pref 'drracket:check-syntax:my-obligation-style-pref)
-    (define imported-variable-style-name (symbol->string imported-variable-style-pref))
+(define their-obligation-style-pref 'drracket:check-syntax:their-obligation-style-pref)
-    (define set!d-variable-style-name (symbol->string set!d-variable-style-pref))
+(define unk-obligation-style-pref 'drracket:check-syntax:unk-obligation-style-pref)
+(define both-obligation-style-pref 'drracket:check-syntax:both-obligation-style-pref)
+
+(define my-obligation-style-name (symbol->string my-obligation-style-pref))
+(define their-obligation-style-name (symbol->string their-obligation-style-pref))
+(define unk-obligation-style-name (symbol->string unk-obligation-style-pref))
+(define both-obligation-style-name (symbol->string both-obligation-style-pref))
+
+(define error-style-name (scheme:short-sym->style-name 'error))
+;(define constant-style-name (scheme:short-sym->style-name 'constant))
+
+(define (syncheck-add-to-preferences-panel parent)
+  (color-prefs:build-color-selection-panel parent
+                                           lexically-bound-variable-style-pref
+                                           lexically-bound-variable-style-name
+                                           (string-constant cs-lexical-variable))
+  (color-prefs:build-color-selection-panel parent
+                                           imported-variable-style-pref
+                                           imported-variable-style-name
+                                           (string-constant cs-imported-variable))
+  (color-prefs:build-color-selection-panel parent
+                                           set!d-variable-style-pref
+                                           set!d-variable-style-name
+                                           (string-constant cs-set!d-variable))
+  (color-prefs:build-color-selection-panel parent
+                                           my-obligation-style-pref
+                                           my-obligation-style-name
+                                           cs-my-obligation-color)
+  (color-prefs:build-color-selection-panel parent
+                                           their-obligation-style-pref
+                                           their-obligation-style-name
+                                           cs-their-obligation-color)
+  (color-prefs:build-color-selection-panel parent
+                                           unk-obligation-style-pref
+                                           unk-obligation-style-name
+                                           cs-unk-obligation-color)
+  (color-prefs:build-color-selection-panel parent
+                                           both-obligation-style-pref
+                                           both-obligation-style-name
+                                           cs-both-obligation-color))
+
+(color-prefs:register-color-preference lexically-bound-variable-style-pref
+                                       lexically-bound-variable-style-name
+                                       (make-object color% 81 112 203)
+                                       (make-object color% 50 163 255))
+(color-prefs:register-color-preference set!d-variable-style-pref
+                                       set!d-variable-style-name
+                                       (send the-color-database find-color "firebrick")
+                                       (send the-color-database find-color "pink"))
+(color-prefs:register-color-preference imported-variable-style-pref
+                                       imported-variable-style-name
+                                       (make-object color% 68 0 203)
+                                       (make-object color% 166 0 255))
+(color-prefs:register-color-preference my-obligation-style-pref
+                                       my-obligation-style-name
+                                       (send the-color-database find-color "firebrick")
+                                       (send the-color-database find-color "pink"))
+(color-prefs:register-color-preference their-obligation-style-pref
+                                       their-obligation-style-name
+                                       (make-object color% 0 116 0)
+                                       (send the-color-database find-color "limegreen"))
+(color-prefs:register-color-preference unk-obligation-style-pref
+                                       unk-obligation-style-name
+                                       (send the-color-database find-color "black")
+                                       (send the-color-database find-color "white"))
+(color-prefs:register-color-preference both-obligation-style-pref
+                                       both-obligation-style-name
+                                       (make-object color% 139 142 28)
+                                       (send the-color-database find-color "khaki"))
 
-    (define my-obligation-style-pref 'drracket:check-syntax:my-obligation-style-pref)
-    (define their-obligation-style-pref 'drracket:check-syntax:their-obligation-style-pref)
-    (define unk-obligation-style-pref 'drracket:check-syntax:unk-obligation-style-pref)
-    (define my-obligation-style-name (symbol->string my-obligation-style-pref))
-    (define their-obligation-style-name (symbol->string their-obligation-style-pref))
-    (define unk-obligation-style-name (symbol->string unk-obligation-style-pref))
-    
-    (define error-style-name (scheme:short-sym->style-name 'error))
-    ;(define constant-style-name (scheme:short-sym->style-name 'constant))
-    
-    (define (syncheck-add-to-preferences-panel parent)
-      (color-prefs:build-color-selection-panel parent
-                                                  lexically-bound-variable-style-pref
-                                                  lexically-bound-variable-style-name
-                                                  (string-constant cs-lexical-variable))
-      (color-prefs:build-color-selection-panel parent
-                                                  imported-variable-style-pref
-                                                  imported-variable-style-name
-                                                  (string-constant cs-imported-variable))
-      (color-prefs:build-color-selection-panel parent
-                                                  set!d-variable-style-pref
-                                                  set!d-variable-style-name
-                                                  (string-constant cs-set!d-variable))
-      (color-prefs:build-color-selection-panel parent
-                                                  my-obligation-style-pref
-                                                  my-obligation-style-name
-                                                  cs-my-obligation-color)
-      (color-prefs:build-color-selection-panel parent
-                                                  their-obligation-style-pref
-                                                  their-obligation-style-name
-                                                  cs-their-obligation-color)
-      (color-prefs:build-color-selection-panel parent
-                                                  unk-obligation-style-pref
-                                                  unk-obligation-style-name
-                                                  cs-unk-obligation-color))
-    
-    (color-prefs:register-color-preference lexically-bound-variable-style-pref
-                                              lexically-bound-variable-style-name
-                                              (make-object color% 81 112 203)
-                                              (make-object color% 50 163 255))
-    (color-prefs:register-color-preference set!d-variable-style-pref
-                                              set!d-variable-style-name
-                                              (send the-color-database find-color "firebrick")
-                                              (send the-color-database find-color "pink"))
-    (color-prefs:register-color-preference imported-variable-style-pref
-                                              imported-variable-style-name
-                                              (make-object color% 68 0 203)
-                                              (make-object color% 166 0 255))
-    (color-prefs:register-color-preference my-obligation-style-pref
-                                              my-obligation-style-name
-                                              (send the-color-database find-color "firebrick")
-                                              (send the-color-database find-color "pink"))
-    (color-prefs:register-color-preference their-obligation-style-pref
-                                              their-obligation-style-name
-                                              (make-object color% 0 116 0)
-                                              (send the-color-database find-color "limegreen"))
-    (color-prefs:register-color-preference unk-obligation-style-pref
-                                              unk-obligation-style-name
-                                              (make-object color% 139 142 28)
-                                              (send the-color-database find-color "khaki"))
-    

collects/drracket/private/syncheck/contract-traversal.rkt

@@ -2,15 +2,19 @@
 (require "intf.rkt" 
          "annotate.rkt"
          "colors.rkt"
+         syntax/boundmap
          syntax/kerncase)
 (provide annotate-contracts)
 
-(define (annotate-contracts stx)
+(define (annotate-contracts stx low-binders varrefs)
   (define start-map (make-hash))
   (define arrow-map (make-hash))
   (define domain-map (make-hash))
   (define range-map (make-hash))
   
+  ;; coloring-plans : hash[stx -o-> (listof color)]
+  (define coloring-plans (make-hash))
+  
   (let loop ([stx stx])
     (add-to-map stx 'racket/contract:contract-on-boundary start-map)
     (add-to-map stx 'racket/contract:domain-of domain-map)
@@ -20,66 +24,112 @@
       [(a . b) (loop #'a) (loop #'b)]
       [else (void)]))
   
+  ;; fill in the coloring-plans table
   (for ([(start-k start-val) (in-hash start-map)])
     (for ([start-stx (in-list start-val)])
-      (do-contract-traversal start-stx arrow-map domain-map range-map #t))))
+      (do-contract-traversal start-stx
+                             coloring-plans low-binders 
+                             arrow-map domain-map range-map
+                             #t)))
+  
+  ;; enact the coloring plans
+  (for ([(stx colors) (in-hash coloring-plans)])
+    (cond
+      [(and (member my-obligation-style-name colors)
+            (member their-obligation-style-name colors))
+       (color stx both-obligation-style-name 'contract-mode)]
+      [(member my-obligation-style-name colors)
+       (color stx my-obligation-style-name 'contract-mode)]
+      [(member their-obligation-style-name colors)
+       (color stx their-obligation-style-name 'contract-mode)]
+      [(member unk-obligation-style-name colors)
+       (color stx unk-obligation-style-name 'contract-mode)])))
+
+(define (do-contract-traversal start-stx coloring-plans low-binders arrow-map domain-map range-map polarity)
+  (let ploop ([stx start-stx]
+              [polarity polarity])
+    
+    (let ([main-prop (syntax-property stx 'racket/contract:contract)])
+      (cond
+        [main-prop
+         ;; we've found a contract, now go color it and 
+         ;; continue with the sub-contract expressions (as indicated via the properties)
+         (let sloop ([prop main-prop])
+           (cond
+             [(pair? prop) (sloop (car prop)) (sloop (cdr prop))]
+             [(vector? prop)
+              (let ([id (vector-ref prop 0)]
+                    [to-color (vector-ref prop 1)])
+                (base-color to-color polarity coloring-plans)
+                (for ((stx (in-list (hash-ref domain-map id '()))))
+                  (do-contract-traversal stx coloring-plans low-binders arrow-map domain-map range-map (not polarity)))
+                (for ((stx (in-list (hash-ref range-map id '()))))
+                  (do-contract-traversal stx coloring-plans low-binders arrow-map domain-map range-map polarity)))]))]
+        
+        [else
+         ;; we didn't find a contract, but we might find one in a subexpression
+         ;; so we need to go look for it (possibly giving up)
+         (kernel-syntax-case stx #f
+           [(#%expression expr)
+            (ploop #'expr polarity)]
+           [(module id name-id (#%plain-module-begin mod-level-form ...))
+            (give-up start-stx coloring-plans)]
+           [(begin tl-form ... last-one)
+            (ploop #'last-one polarity)]
+           [(#%provide pvd ...)
+            (give-up start-stx coloring-plans)]
+           [(define-values (id ...) expr)
+            (give-up start-stx coloring-plans)]
+           [(define-syntaxes (id ...) expr)
+            (give-up start-stx coloring-plans)]
+           [(define-values-for-syntax (id ...) expr)
+            (give-up start-stx coloring-plans)]
+           [(#%require rspec ...)
+            (give-up start-stx coloring-plans)]
+           [id
+            (identifier? #'id)
+            (if (known-predicate? #'id)
+                (base-color #'id polarity coloring-plans)
+                (begin
+                  ;(printf "mapped to ~s\n" (module-identifier-mapping-get low-binders #'id))
+                  (give-up start-stx coloring-plans)))]
+           [(#%plain-lambda formals expr ...)
+            (give-up start-stx coloring-plans)]
+           [(case-lambda [formals expr] ...)
+            (give-up start-stx coloring-plans)]
+           [(if a b c)
+            ;; these calls are questionable. 
+            ;; if we ultimately end up giving up in both
+            ;; branches, maybe we should actually be coloring the entire thing
+            ;; in the blank color, but we'll only color the then and else branches
+            ;; in that color with this code.
+            ;; on the other hand, recurring like this will mean that the two
+            ;; branches are considered separately and thus calling give-up
+            ;; on one side will not pollute the other side.
+            (do-contract-traversal #'b coloring-plans low-binders arrow-map domain-map range-map polarity)
+            (do-contract-traversal #'c coloring-plans low-binders arrow-map domain-map range-map polarity)]
+           ;; [(begin expr ...) (void)]
+           [(begin0 fst rst ...)
+            (ploop #'fst polarity)]
+           [(let-values bindings body ... last-one)
+            (ploop #'last-one polarity)]
+           [(letrec-values bindings body ... last-one)
+            (ploop #'last-one polarity)]
+           [(set! a b)
+            (give-up start-stx coloring-plans)]
+           [(quote stuff)
+            (give-up start-stx coloring-plans)]
+           [(quote-syntax stuff)
+            (give-up start-stx coloring-plans)]
+           [(with-continuation-mark a b c)
+            (ploop #'c polarity)]
+           [(#%plain-app f args ...)
+            (give-up start-stx coloring-plans)]
+           [(#%top . id)
+            (give-up start-stx coloring-plans)]
+           [(#%variable-reference ignored ...)
+            (give-up start-stx coloring-plans)])]))))
 
-(define (do-contract-traversal start-stx arrow-map domain-map range-map polarity)
-  (let loop ([stx start-stx])
-    (base-color stx polarity)
-    (kernel-syntax-case stx #f
-      [(#%expression expr)
-       (loop #'expr)]
-      [(module id name-id (#%plain-module-begin mod-level-form ...))
-       (for-each loop (syntax->list #'(mod-level-form ...)))]
-      [(begin tl-form ... last-one)
-       (loop #'last-one)]
-      [(#%provide pvd ...)
-       (void)]
-      [(define-values (id ...) expr)
-       (void)]
-      [(define-syntaxes (id ...) expr)
-       (void)]
-      [(define-values-for-syntax (id ...) expr)
-       (void)]
-      [(#%require rspec ...)
-       (void)]
-      [id
-       (identifier? #'id)
-       (void)]
-      [(#%plain-lambda formals expr ...)
-       (void)]
-      [(case-lambda [formals expr] ...)
-       (void)]
-      [(if a b c)
-       (loop #'b)
-       (loop #'c)]
-      ;; [(begin expr ...) (void)]
-      [(begin0 fst rst ...)
-       (loop #'fst)]
-      [(let-values bindings body ... last-one)
-       (loop #'last-one)]
-      [(letrec-values bindings body ... last-one)
-       (loop #'last-one)]
-      [(set! a b)
-       (void)]
-      [(quote stuff)
-       (void)]
-      [(quote-syntax stuff)
-       (void)]
-      [(with-continuation-mark a b c)
-       (loop #'c)]
-      [(#%plain-app f args ...)
-       (void)]
-      [(#%top . id)
-       (void)]
-      [(#%variable-reference id)
-       (void)]
-      [(#%variable-reference)
-       (void)])))
-       
-       
-       
 ;; add-to-map : syntax any hash[any -> (listof stx)]
 ;; looks at stx's property prop and updates map,
 ;; using the value of the property as the key
@@ -92,41 +142,6 @@
        (loop (car val))
        (loop (cdr val))])))
 
-#|
-    (define (annotate-contracts stx)
-      (let loop ([stx stx])
-        (let sloop ([prop (syntax-property stx 'provide/contract-original-contract)])
-          (cond
-            [(vector? prop)
-             (color-obligations (vector-ref prop 1))]
-            [(pair? prop) (sloop (car prop)) 
-                          (sloop (cdr prop))]))
-        (syntax-case stx ()
-          [(a . b) (loop #'a) (loop #'b)]
-          [else (void)])))
-    
-    (define (color-obligations stx)
-      (let loop ([stx stx]
-                 [polarity #t])
-      (syntax-case stx (->)
-        [(-> a ... rng)
-         (begin
-           (base-color (car (syntax-e stx)) polarity)
-           (for-each (λ (x) (loop x (not polarity))) (syntax->list #'(a ...)))
-           (syntax-case #'rng (values any)
-             [(values b ...)
-              (for-each (λ (x) (loop x polarity)) (syntax->list #'(b ...)))]
-             [any
-              (void)]
-             [rng
-              (loop #'rng polarity)]))]
-        [id
-         (and (identifier? #'id)
-              (known-predicate? #'id))
-         (base-color stx polarity)]
-        [else
-         (color stx unk-obligation-style-name 'contract-mode)])))
-|#
 ;; returns #t if the result is known to be a predicate that shoudl correspond to a
 ;; complete obligation for the contract. If it is some unknown variable, this variable
 ;; may refer to some other contract with nested obligations, so we have to return #f here.
@@ -139,8 +154,35 @@
            (let-values ([(base rel) (module-path-index-split src)])
              (member base '('#%kernel racket racket/base scheme scheme/base)))))))
 
-(define (base-color stx polarity)
+(define (give-up stx coloring-plans) 
-  (printf "base-color ~s\n" stx)
+  (let loop ([stx stx])
-  (color stx 
+    (when (syntax-original? stx)
-         (if polarity my-obligation-style-name their-obligation-style-name) 
+      (blank-color stx coloring-plans))
-         'contract-mode))
+    
+    (let oloop ([origin (syntax-property stx 'origin)])
+      (cond
+        [(pair? origin) (oloop (car origin)) (oloop (cdr origin))]
+        [(syntax? origin) 
+         (when (syntax-original? origin)
+           (blank-color origin coloring-plans))]))
+    
+    (syntax-case stx ()
+      [(a . b) (loop #'a) (loop #'b)]
+      [_ (void)])))
+
+
+
+(define (base-color stx polarity coloring-plans)
+  (make-a-coloring-plan stx
+                        (if polarity my-obligation-style-name their-obligation-style-name)
+                        coloring-plans))
+
+(define (blank-color stx coloring-plans)
+  (make-a-coloring-plan stx unk-obligation-style-name coloring-plans))
+
+(define (make-a-coloring-plan stx plan coloring-plans)
+  (hash-set! coloring-plans
+             stx
+             (cons 
+              plan
+              (hash-ref coloring-plans stx '()))))

collects/drracket/private/syncheck/traversals.rkt

@@ -115,7 +115,7 @@
                                              require-for-syntaxes
                                              require-for-templates
                                              require-for-labels)
-                         (annotate-contracts sexp))]
+                         (annotate-contracts sexp low-binders varrefs))]
                       [else
                        (annotate-basic sexp
                                        user-namespace user-directory jump-to-id

collects/racket/contract/private/arrow.rkt

@@ -382,8 +382,10 @@ v4 todo:
                        (list kwd-ctcs ...) '(kwds ...) '() '()
                        (list rng-ctcs ...) use-any?
                        outer-lambda))
-            'racket/contract:function-contract 
+            'racket/contract:contract 
-            this->)
+            (vector this-> 
+                    ;; the -> in the original input to this guy
+                    (car (syntax-e stx))))
            inner-args/body
            (syntax (dom-names ... rng-names ...))))))))