From 02454a62fd75812eaf2f50bdc6083eaad9aadce7 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Tue, 7 Jan 2014 21:13:34 -0800 Subject: [PATCH] Add sc-traverse for folding over static contracts. original commit: 6deb1e3193b81b2091ddda0a9aee445b9d857c50 --- .../static-contracts/combinators/any.rkt | 1 + .../static-contracts/combinators/case-lambda.rkt | 6 ++++++ .../static-contracts/combinators/control.rkt | 3 +++ .../static-contracts/combinators/function.rkt | 1 + .../static-contracts/combinators/none.rkt | 1 + .../static-contracts/combinators/object.rkt | 3 +++ .../static-contracts/combinators/parametric.rkt | 5 +++++ .../static-contracts/combinators/simple.rkt | 1 + .../static-contracts/combinators/struct.rkt | 5 +++++ .../static-contracts/combinators/structural.rkt | 12 +++++++++++- .../typed-racket/static-contracts/structures.rkt | 14 +++++++++++++- .../typed-racket/static-contracts/terminal.rkt | 1 + 12 files changed, 51 insertions(+), 2 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/any.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/any.rkt index 0ea524a8..e59d9a57 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/any.rkt +++ b/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)]) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/case-lambda.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/case-lambda.rkt index 18de550e..b1e82ba1 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/case-lambda.rkt +++ b/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)) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/control.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/control.rkt index 67994abb..5366dfc2 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/control.rkt +++ b/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)) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/function.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/function.rkt index 908354f6..64f570c9 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/function.rkt +++ b/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 diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/none.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/none.rkt index 5e9cc1bb..5cd27193 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/none.rkt +++ b/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)]) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/object.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/object.rkt index 5f258967..97b2bfc8 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/object.rkt +++ b/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) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/parametric.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/parametric.rkt index de444c15..3124b229 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/parametric.rkt +++ b/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) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/simple.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/simple.rkt index 15f5af48..3baf5de0 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/simple.rkt +++ b/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 diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/struct.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/struct.rkt index f4db52b3..fbbb83d7 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/struct.rkt +++ b/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 _) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt index fcd58326..1b445973 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt +++ b/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))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/structures.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/structures.rkt index b32eb74a..84ad2f34 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/structures.rkt +++ b/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)]) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/terminal.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/terminal.rkt index 386528e2..0b01c9fb 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/terminal.rkt +++ b/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)