Add sc-traverse for folding over static contracts.

original commit: 6deb1e3193b81b2091ddda0a9aee445b9d857c50

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/any.rkt

@@ -25,6 +25,7 @@
 (struct any-combinator combinator ()
         #:methods gen:sc
           [(define (sc-map v f) v)
+           (define (sc-traverse v f) (void))
            (define (sc->contract v f) #'any/c)
            (define (sc->constraints v f) (simple-contract-restrict 'flat))]
         #:methods gen:custom-write [(define write-proc any-write-proc)])

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/case-lambda.rkt

@@ -33,6 +33,9 @@
   #:methods gen:sc
     [(define (sc-map v f)
        (case-combinator (map (λ (a) (f a 'covariant)) (combinator-args v))))
+     (define (sc-traverse v f)
+       (for-each (λ (a) (f a 'covariant)) (combinator-args v))
+       (void))
      (define (sc->contract v f)
        #`(case-> #,@(map f (combinator-args v))))
      (define (sc->constraints v f)
@@ -43,6 +46,9 @@
   #:methods gen:sc
     [(define (sc-map v f)
        (arr-combinator (arr-seq-sc-map f (combinator-args v))))
+     (define (sc-traverse v f)
+       (arr-seq-sc-map f (combinator-args v))
+       (void))
      (define (sc->contract v f)
        (match v
         [(arr-combinator (arr-seq args rest range))

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/control.rkt

@@ -21,6 +21,9 @@
   #:methods gen:sc
     [(define (sc-map v f)
        (prompt-tag-combinator (pt-seq-map f (combinator-args v))))
+     (define (sc-traverse v f)
+       (pt-seq-map f (combinator-args v))
+       (void))
      (define (sc->contract v f)
        (match v
         [(prompt-tag-combinator (pt-seq vals call-cc))

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/function.rkt

@@ -29,6 +29,7 @@
         #:methods gen:sc
           [(define (sc->contract v f) (function-sc->contract v f))
            (define (sc-map v f) (function-sc-map v f))
+           (define (sc-traverse v f) (function-sc-map v f) (void))
            (define (sc->constraints v f) (function-sc-constraints v f))])
 
 (define (split-function-args ctcs mand-args-end opt-args-end

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/none.rkt

@@ -25,6 +25,7 @@
 (struct none-combinator combinator ()
         #:methods gen:sc
           [(define (sc-map v f) v)
+           (define (sc-traverse v f) (void))
            (define (sc->contract v f) #'none/c)
            (define (sc->constraints v f) (simple-contract-restrict 'flat))]
         #:methods gen:custom-write [(define write-proc none-write-proc)])

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/object.rkt

@@ -29,6 +29,9 @@
   #:methods gen:sc
     [(define (sc-map v f)
        (object-combinator (member-seq-sc-map f (combinator-args v))))
+     (define (sc-traverse v f)
+       (member-seq-sc-map f (combinator-args v))
+       (void))
      (define (sc->contract v f)
        (object/sc->contract v f))
      (define (sc->constraints v f)

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/parametric.rkt

@@ -23,6 +23,11 @@
        (match v
         [(parametric-combinator (list arg) vars)
          (parametric-combinator (list (f arg 'covariant)) vars)]))
+     (define (sc-traverse v f)
+       (match v
+        [(parametric-combinator (list arg) vars)
+         (f arg 'covariant)
+         (void)]))
      (define (sc->contract v f)
        (match v
         [(parametric-combinator (list arg) vars)

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/simple.rkt

@@ -35,6 +35,7 @@
 (struct simple-contract static-contract (syntax kind)
         #:methods gen:sc
          [(define (sc-map v f) v)
+          (define (sc-traverse v f) (void))
           (define (sc->contract v f) (simple-contract-syntax v))
           (define (sc->constraints v f) (simple-contract-restrict (simple-contract-kind v)))]
         #:methods gen:terminal-sc

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/struct.rkt

@@ -24,6 +24,11 @@
         [(struct-combinator args name mut?)
          (struct-combinator (map (λ (a) (f a (if mut? 'invariant 'covariant))) args)
                             name mut?)]))
+     (define (sc-traverse v f)
+       (match v
+        [(struct-combinator args name mut?)
+         (for-each (λ (a) (f a (if mut? 'invariant 'covariant))) args)
+         (void)]))
      (define (sc->contract v f)
        (match v
         [(struct-combinator args name _)

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt

@@ -39,7 +39,7 @@
              #:with category-stx (attribute category)])
 
   (define-syntax-class static-combinator-form
-    #:attributes (name struct-name definition combinator2 ->restricts matcher provides map)
+    #:attributes (name struct-name definition combinator2 ->restricts matcher provides map traverse)
     [pattern (name:id pos:argument-description ... )
              #:with struct-name (generate-temporary #'name)
              #:with matcher-name (format-id #'name "~a:" #'name)
@@ -63,6 +63,11 @@
                      (for/list ([a (in-list (combinator-args v))]
                                 [kind (in-list (list 'pos.variance ...))])
                        (f a kind))))
+             #:with traverse
+               #'(lambda (v f)
+                   (for ([a (in-list (combinator-args v))]
+                         [kind (in-list (list 'pos.variance ...))])
+                     (f a kind)))
              #:with ctc
                  #`(-> #,@(stx-map (lambda (_) #'static-contract?) #'(pos ...)) static-contract?)
              #:with provides #'(provide (contract-out [name ctc]) matcher-name)]
@@ -85,6 +90,10 @@
                    (struct-name
                      (for/list ([a (in-list (combinator-args v))])
                        (f a 'rest.variance))))
+             #:with traverse
+               #'(lambda (v f)
+                   (for ([a (in-list (combinator-args v))])
+                     (f a 'rest.variance)))
              #:with ctc
                  #'(->* () #:rest (listof static-contract?) static-contract?)
              #:with provides #'(provide (contract-out [name ctc]) matcher-name)]))
@@ -98,6 +107,7 @@
                  #:transparent
                  #:methods gen:sc
                    [(define sc-map sc.map)
+                    (define sc-traverse sc.traverse)
                     (define (sc->contract v recur)
                       (apply
                         (sc.combinator2 (lambda (args) #`(c #,@args)))

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/structures.rkt

@@ -15,6 +15,7 @@
     (struct combinator ([args sequence?]))
     (struct static-contract ())
     [sc-map (static-contract? (static-contract? variance/c . -> . static-contract?) . -> . static-contract?)]
+    [sc-traverse (static-contract? (static-contract? variance/c . -> . any/c) . -> . void?)]
     [sc->contract (static-contract? (static-contract? . -> . syntax?) . -> . syntax?)]
     [sc->constraints (static-contract? (static-contract? . -> . contract-restrict?) . -> . contract-restrict?)]
     [terminal-sc-kind (static-contract? . -> . (or/c #f contract-kind?))]
@@ -96,6 +97,10 @@
   ;; Each sub part should be replaced with the value of calling the supplied function on it. The
   ;; variance argument should be how the sub part relates to the static contract.
   [sc-map sc f]
+  ;; sc-traverse: static-contract? (static-contract? variance/c -> any/c) -> void?
+  ;; Takes a static contract and traverses it.  Each sub part should be called with supplied function.
+  ;; The variance argument should be how the sub part relates to the static contract.
+  [sc-traverse sc f]
   ;; sc->contract: static-contract? (static-contract? -> contract?) -> contract?
   ;; Takes a static contract and returns the corresponding contract.
   ;; The function argument should be used for sub parts of the static contract.
@@ -132,7 +137,13 @@
           [(define (sc-map v f)
              (match v
                [(recursive-contract names values body)
-                (recursive-contract names (map (λ (v) (f v 'covariant)) values) (f body 'covariant))]))]
+                (recursive-contract names (map (λ (v) (f v 'covariant)) values) (f body 'covariant))]))
+           (define (sc-traverse v f)
+             (match v
+               [(recursive-contract names values body)
+                (for-each (λ (v) (f v 'covariant)) values)
+                (f body 'covariant)
+                (void)]))]
         #:methods gen:custom-write [(define write-proc recursive-contract-write-proc)])
 
 ;; A use of a contract bound by recursive-contract
@@ -141,6 +152,7 @@
         #:transparent
         #:methods gen:sc
           [(define (sc-map v f) v)
+           (define (sc-traverse v f) (void))
            (define (sc->contract v f) (recursive-contract-use-name v))
            (define (sc->constraints v f) (variable-contract-restrict (recursive-contract-use-name v)))]
         #:methods gen:custom-write [(define write-proc recursive-contract-use-write-proc)])

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/terminal.rkt

@@ -28,6 +28,7 @@
          #:transparent
          #:methods gen:sc
           [(define (sc-map v f) v)
+           (define (sc-traverse v f) (void))
            (define (sc->contract v unused-f)
              (match-define (name args ...) v)
              body)