added a few more contracts to those that get colored by check syntax

(and fixed a bug in the helper macros that support the coloring)

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

@@ -26,7 +26,7 @@
     (add-to-map stx 'racket/contract:function-contract arrow-map)
     (syntax-case stx ()
       [(a . b) (loop #'a) (loop #'b)]
-      [else (void)]))
+      [_ (void)]))
   
   ;; fill in the coloring-plans table for boundary contracts
   (for ([(start-k start-val) (in-hash boundary-start-map)])
@@ -128,6 +128,14 @@
                           (for ((rhs (in-list (module-identifier-mapping-get binding-inits binder))))
                             (ploop rhs polarity))))
                       (call-give-up))))]
+           [const
+            (let ([val (syntax-e #'const)])
+              (or (boolean? val)
+                  (number? val)
+                  (string? val)
+                  (char? val)
+                  (regexp? val)))
+            (base-color stx polarity boundary-contract? my-coloring-plans client-coloring-plans)]
            [(#%plain-lambda (id) expr ...)
             (identifier? #'id)
             (base-color stx polarity boundary-contract? my-coloring-plans client-coloring-plans)]
@@ -165,7 +173,7 @@
            [(set! a b)
             (call-give-up)]
            [(quote stuff)
-            (call-give-up)]
+            (base-color stx polarity boundary-contract? my-coloring-plans client-coloring-plans)]
            [(quote-syntax stuff)
             (call-give-up)]
            [(with-continuation-mark a b c)
@@ -175,7 +183,12 @@
            [(#%top . id)
             (call-give-up)]
            [(#%variable-reference ignored ...)
-            (call-give-up)])]))))
+            (call-give-up)]
+           [_ 
+            (begin
+              #;(error 'contract-traversal.rkt "unknown thing: ~s\n" stx)
+              (call-give-up))
+              ])]))))
 
 ;; add-to-map : syntax any hash[any -> (listof stx)]
 ;; looks at stx's property prop and updates map,

collects/racket/contract/private/guts.rkt

@@ -143,6 +143,72 @@
     [(or (regexp? x) (byte-regexp? x)) (make-regexp/c x)]
     [else #f]))
        
+(define-syntax (define/final-prop stx)
+  (syntax-case stx ()
+    [(_ header bodies ...)
+     (with-syntax ([ctc (if (identifier? #'header)
+                            #'header
+                            (car (syntax-e #'header)))])
+       (with-syntax ([ctc/proc (string->symbol (format "~a/proc" (syntax-e #'ctc)))])
+         #'(begin
+             (define ctc/proc
+               (let ()
+                 (define header bodies ...)
+                 ctc))
+             (define-syntax (ctc stx)
+               (syntax-case stx ()
+                 [x
+                  (identifier? #'x)
+                  (syntax-property 
+                   #'ctc/proc
+                   'racket/contract:contract 
+                   (vector (gensym 'ctc) 
+                           (list stx)
+                           '()))]
+                 [(_ margs (... ...))
+                  (with-syntax ([app (datum->syntax stx '#%app)])
+                    (syntax-property 
+                     #'(app ctc/proc margs (... ...))
+                     'racket/contract:contract 
+                     (vector (gensym 'ctc) 
+                             (list (car (syntax-e stx)))
+                             '())))])))))]))
+
+(define-syntax (define/subexpression-pos-prop stx)
+  (syntax-case stx ()
+    [(_ header bodies ...)
+     (with-syntax ([ctc (if (identifier? #'header)
+                            #'header
+                            (car (syntax-e #'header)))])
+       (with-syntax ([ctc/proc (string->symbol (format "~a/proc" (syntax-e #'ctc)))])
+         #'(begin
+             (define ctc/proc
+               (let ()
+                 (define header bodies ...)
+                 ctc))
+             (define-syntax (ctc stx)
+               (syntax-case stx ()
+                 [x
+                  (identifier? #'x)
+                  (syntax-property 
+                   #'ctc/proc
+                   'racket/contract:contract 
+                   (vector (gensym 'ctc) 
+                           (list stx)
+                           '()))]
+                 [(_ margs (... ...))
+                  (let ([this-one (gensym 'ctc)])
+                    (with-syntax ([(margs (... ...)) 
+                                   (map (λ (x) (syntax-property x 'racket/contract:positive-position this-one))
+                                        (syntax->list #'(margs (... ...))))]
+                                  [app (datum->syntax stx '#%app)])
+                      (syntax-property 
+                       #'(app ctc/proc margs (... ...))
+                       'racket/contract:contract 
+                       (vector this-one 
+                               (list (car (syntax-e stx)))
+                               '()))))])))))]))
+
 ;                                                      
 ;                                                      
 ;                                                      
@@ -239,7 +305,7 @@
                           this-ctcs
                           that-ctcs)))))))
 
-(define (and/c . raw-fs)
+(define/subexpression-pos-prop (and/c . raw-fs)
   (let ([contracts (coerce-contracts 'and/c raw-fs)])
     (cond
       [(null? contracts) any/c]
@@ -273,7 +339,7 @@
    #:name (λ (ctc) 'any/c)
    #:first-order get-any?))
 
-(define any/c (make-any/c))
+(define/final-prop any/c (make-any/c))
 
 (define (none-curried-proj ctc)
   (λ (blame)
@@ -294,7 +360,7 @@
    #:name (λ (ctc) (none/c-name ctc))
    #:first-order (λ (ctc) (λ (val) #f))))
 
-(define none/c (make-none/c 'none/c))
+(define/final-prop none/c (make-none/c 'none/c))
 
 
 
@@ -379,66 +445,3 @@
 
 (define (build-flat-contract name pred) (make-predicate-contract name pred))
 
-(define-syntax (define/final-prop stx)
-  (syntax-case stx ()
-    [(_ header bodies ...)
-     (with-syntax ([ctc (if (identifier? #'header)
-                            #'header
-                            (car (syntax-e #'header)))])
-       (with-syntax ([ctc/proc (string->symbol (format "~a/proc" (syntax-e #'ctc)))])
-         #'(begin
-             (define ctc/proc
-               (let ()
-                 (define header bodies ...)
-                 ctc))
-             (define-syntax (ctc stx)
-               (syntax-case stx ()
-                 [x
-                  (identifier? #'x)
-                  (syntax-property 
-                   #'x
-                   'racket/contract:contract 
-                   (vector (gensym 'ctc) 
-                           (list stx)
-                           '()))]
-                 [(_ margs (... ...))
-                  (syntax-property 
-                   #'(ctc/proc margs (... ...))
-                   'racket/contract:contract 
-                   (vector (gensym 'ctc) 
-                           (list (car (syntax-e stx)))
-                           '()))])))))]))
-
-(define-syntax (define/subexpression-pos-prop stx)
-  (syntax-case stx ()
-    [(_ header bodies ...)
-     (with-syntax ([ctc (if (identifier? #'header)
-                            #'header
-                            (car (syntax-e #'header)))])
-       (with-syntax ([ctc/proc (string->symbol (format "~a/proc" (syntax-e #'ctc)))])
-         #'(begin
-             (define ctc/proc
-               (let ()
-                 (define header bodies ...)
-                 ctc))
-             (define-syntax (ctc stx)
-               (syntax-case stx ()
-                 [x
-                  (identifier? #'x)
-                  (syntax-property 
-                   #'ctc/proc
-                   'racket/contract:contract 
-                   (vector (gensym 'ctc) 
-                           (list stx)
-                           '()))]
-                 [(_ margs (... ...))
-                  (let ([this-one (gensym 'ctc)])
-                    (with-syntax ([(margs (... ...)) 
-                                   (map (λ (x) (syntax-property x 'racket/contract:positive-position this-one))
-                                        (syntax->list #'(margs (... ...))))])
-                      (syntax-property 
-                       #'(ctc/proc margs (... ...))
-                       'racket/contract:contract 
-                       (vector this-one 
-                               (list (car (syntax-e stx)))
-                               '()))))])))))]))