From 864cc28341f41fb2c794bd854042a8d16f4f609a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 1 Sep 2013 06:54:27 -0500 Subject: [PATCH] add custom writers for a bunch of contracts --- .../racket/contract/private/arrow.rkt | 6 ++++ .../collects/racket/contract/private/box.rkt | 3 ++ .../collects/racket/contract/private/hash.rkt | 4 ++- .../collects/racket/contract/private/misc.rkt | 34 +++++++++++++++++-- .../racket/contract/private/object.rkt | 1 + .../racket/contract/private/parametric.rkt | 2 ++ .../racket/contract/private/vector.rkt | 3 ++ 7 files changed, 50 insertions(+), 3 deletions(-) diff --git a/racket/collects/racket/contract/private/arrow.rkt b/racket/collects/racket/contract/private/arrow.rkt index ebea9acc97..b303fcffe3 100644 --- a/racket/collects/racket/contract/private/arrow.rkt +++ b/racket/collects/racket/contract/private/arrow.rkt @@ -619,6 +619,7 @@ (andmap gen-if-fun (base->-doms/c ctc) args)))) (define-struct (chaperone-> base->) () + #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract (parameterize ([skip-projection-wrapper? #t]) (build-chaperone-contract-property @@ -630,6 +631,7 @@ #:exercise ->-exercise))) (define-struct (impersonator-> base->) () + #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property #:projection (->-proj impersonate-procedure) @@ -1522,6 +1524,7 @@ ;; it first. At the very least, the projection function would ;; need to add checks in the appropriate places. (define-struct (impersonator-->d base-->d) () + #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property #:projection (->d-proj impersonate-procedure) @@ -1763,6 +1766,7 @@ (define (case->-stronger? this that) #f) (define-struct (chaperone-case-> base-case->) () + #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract (build-chaperone-contract-property #:projection (case->-proj chaperone-procedure) @@ -1771,6 +1775,7 @@ #:stronger case->-stronger?)) (define-struct (impersonator-case-> base-case->) () + #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property #:projection (case->-proj impersonate-procedure) @@ -2076,6 +2081,7 @@ predicate/c))) (struct predicate/c () + #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract (build-chaperone-contract-property #:projection (let ([pc (contract-struct-projection predicate/c-private->ctc)]) diff --git a/racket/collects/racket/contract/private/box.rkt b/racket/collects/racket/contract/private/box.rkt index 2712d39afd..78f49494a0 100644 --- a/racket/collects/racket/contract/private/box.rkt +++ b/racket/collects/racket/contract/private/box.rkt @@ -57,6 +57,7 @@ null)))))) (define-struct (flat-box/c base-box/c) () + #:property prop:custom-write custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property #:name box/c-name @@ -86,6 +87,7 @@ impersonator-prop:contracted ctc)))))))) (define-struct (chaperone-box/c base-box/c) () + #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract (build-chaperone-contract-property #:name box/c-name @@ -93,6 +95,7 @@ #:projection (ho-projection chaperone-box))) (define-struct (impersonator-box/c base-box/c) () + #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property #:name box/c-name diff --git a/racket/collects/racket/contract/private/hash.rkt b/racket/collects/racket/contract/private/hash.rkt index 454710b4cf..f3c9151cad 100644 --- a/racket/collects/racket/contract/private/hash.rkt +++ b/racket/collects/racket/contract/private/hash.rkt @@ -138,7 +138,7 @@ (define-struct (flat-hash/c base-hash/c) () #:omit-define-syntaxes - + #:property prop:custom-write custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property #:name hash/c-name @@ -196,6 +196,7 @@ (define-struct (chaperone-hash/c base-hash/c) () #:omit-define-syntaxes + #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract (build-chaperone-contract-property #:name hash/c-name @@ -204,6 +205,7 @@ (define-struct (impersonator-hash/c base-hash/c) () #:omit-define-syntaxes + #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property #:name hash/c-name diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt index adc212e59c..dd66b70193 100644 --- a/racket/collects/racket/contract/private/misc.rkt +++ b/racket/collects/racket/contract/private/misc.rkt @@ -55,7 +55,18 @@ blame-add-or-context blame-add-car-context blame-add-cdr-context - raise-not-cons-blame-error) + raise-not-cons-blame-error + + custom-write-property-proc) + +(define (custom-write-property-proc stct port display?) + (write-string "#<" port) + (cond + [(flat-contract? stct) (write-string "flat-" port)] + [(chaperone-contract? stct) (write-string "chaperone-" port)]) + (write-string "contract: " port) + (write-string (format "~.s" (contract-name stct)) port) + (write-string ">" port)) (define-syntax (flat-rec-contract stx) (syntax-case stx () @@ -185,6 +196,7 @@ (define-struct single-or/c (name pred flat-ctcs ho-ctc)) (define-struct (chaperone-single-or/c single-or/c) () + #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract (parameterize ([skip-projection-wrapper? #t]) (build-chaperone-contract-property @@ -194,6 +206,7 @@ #:stronger single-or/c-stronger?))) (define-struct (impersonator-single-or/c single-or/c) () + #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property #:projection single-or/c-projection @@ -268,6 +281,7 @@ (define-struct multi-or/c (name flat-ctcs ho-ctcs)) (define-struct (chaperone-multi-or/c multi-or/c) () + #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract (parameterize ([skip-projection-wrapper? #t]) (build-chaperone-contract-property @@ -277,6 +291,7 @@ #:stronger multi-or/c-stronger?))) (define-struct (impersonator-multi-or/c multi-or/c) () + #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property #:projection multi-or/c-proj @@ -285,6 +300,7 @@ #:stronger multi-or/c-stronger?)) (define-struct flat-or/c (pred flat-ctcs) + #:property prop:custom-write custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property #:name @@ -376,6 +392,7 @@ (define-struct base-and/c (ctcs)) (define-struct (first-order-and/c base-and/c) (predicates) + #:property prop:custom-write custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property #:projection first-order-and-proj @@ -383,6 +400,7 @@ #:first-order and-first-order #:stronger and-stronger?)) (define-struct (chaperone-and/c base-and/c) () + #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract (parameterize ([skip-projection-wrapper? #t]) (build-chaperone-contract-property @@ -391,6 +409,7 @@ #:first-order and-first-order #:stronger and-stronger?))) (define-struct (impersonator-and/c base-and/c) () + #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property #:projection and-proj @@ -459,6 +478,7 @@ (apply or/c or/c-args)) (define-struct between/c (low high) + #:property prop:custom-write custom-write-property-proc #:omit-define-syntaxes #:property prop:flat-contract (build-flat-contract-property @@ -707,6 +727,7 @@ (struct generic-list/c (args)) (struct flat-list/c generic-list/c () + #:property prop:custom-write custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property #:name list/c-name-proc @@ -767,6 +788,7 @@ [else "th"])))) (struct chaperone-list/c generic-list/c () + #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract (parameterize ([skip-projection-wrapper? #t]) (build-chaperone-contract-property @@ -775,6 +797,7 @@ #:projection list/c-chaperone/other-projection))) (struct higher-order-list/c generic-list/c () + #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property #:name list/c-name-proc @@ -834,6 +857,7 @@ ;; out - positive contract ;; both-supplied? - for backwards compat printing (define-struct parameter/c (in out both-supplied?) + #:property prop:custom-write custom-write-property-proc #:omit-define-syntaxes #:property prop:contract (build-contract-property @@ -877,6 +901,7 @@ (parameter/c-in this))))))) (define-struct procedure-arity-includes/c (n) + #:property prop:custom-write custom-write-property-proc #:omit-define-syntaxes #:property prop:flat-contract (build-flat-contract-property @@ -905,6 +930,7 @@ (define (any? x) #t) (define-struct any/c () + #:property prop:custom-write custom-write-property-proc #:omit-define-syntaxes #:property prop:flat-contract (build-flat-contract-property @@ -929,6 +955,7 @@ val)))) (define-struct none/c (name) + #:property prop:custom-write custom-write-property-proc #:omit-define-syntaxes #:property prop:flat-contract (build-flat-contract-property @@ -1016,6 +1043,7 @@ (define-struct base-prompt-tag/c (ctcs call/ccs)) (define-struct (chaperone-prompt-tag/c base-prompt-tag/c) () + #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract (build-chaperone-contract-property #:projection (prompt-tag/c-proj #t) @@ -1024,6 +1052,7 @@ #:name prompt-tag/c-name)) (define-struct (impersonator-prompt-tag/c base-prompt-tag/c) () + #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property #:projection (prompt-tag/c-proj #f) @@ -1075,6 +1104,7 @@ (define-struct (chaperone-continuation-mark-key/c base-continuation-mark-key/c) () + #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract (build-chaperone-contract-property #:projection (continuation-mark-key/c-proj chaperone-continuation-mark-key) @@ -1085,6 +1115,7 @@ (define-struct (impersonator-continuation-mark-key/c base-continuation-mark-key/c) () + #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property #:projection (continuation-mark-key/c-proj impersonate-continuation-mark-key) @@ -1185,4 +1216,3 @@ [(2) "nd"] [(3) "rd"] [else "th"]))) - diff --git a/racket/collects/racket/contract/private/object.rkt b/racket/collects/racket/contract/private/object.rkt index 176a5f7d9d..38bc931ce8 100644 --- a/racket/collects/racket/contract/private/object.rkt +++ b/racket/collects/racket/contract/private/object.rkt @@ -38,6 +38,7 @@ (raise-syntax-error #f "malformed object-contract clause" stx (car args))])]))) (define-struct object-contract (methods method-ctcs fields field-ctcs) + #:property prop:custom-write custom-write-property-proc #:omit-define-syntaxes #:property prop:contract (build-contract-property diff --git a/racket/collects/racket/contract/private/parametric.rkt b/racket/collects/racket/contract/private/parametric.rkt index 106b66ab29..38abe25719 100644 --- a/racket/collects/racket/contract/private/parametric.rkt +++ b/racket/collects/racket/contract/private/parametric.rkt @@ -21,6 +21,7 @@ (define-struct polymorphic-contract [barrier vars body] + #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property #:name @@ -66,6 +67,7 @@ (make-barrier-contract name positive? make pred get)) (define-struct barrier-contract [name positive? make pred get] + #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property #:name (lambda (c) (barrier-contract-name c)) diff --git a/racket/collects/racket/contract/private/vector.rkt b/racket/collects/racket/contract/private/vector.rkt index ba8c78b287..184a1b3a3c 100644 --- a/racket/collects/racket/contract/private/vector.rkt +++ b/racket/collects/racket/contract/private/vector.rkt @@ -75,6 +75,7 @@ (check val (λ _ (return #f)) #t))))) (define-struct (flat-vectorof base-vectorof) () + #:property prop:custom-write custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property #:name vectorof-name @@ -124,6 +125,7 @@ impersonator-prop:contracted ctc)))))))) (define-struct (chaperone-vectorof base-vectorof) () + #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract (build-chaperone-contract-property #:name vectorof-name @@ -131,6 +133,7 @@ #:projection (vectorof-ho-projection chaperone-vector))) (define-struct (impersonator-vectorof base-vectorof) () + #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property #:name vectorof-name