suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add custom writers for a bunch of contracts

Browse Source
This commit is contained in:
Robby Findler 2013-09-01 06:54:27 -05:00
parent 09458af39f
commit 864cc28341
7 changed files with 50 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
racket/collects/racket/contract/private/arrow.rkt
View File

@ -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)])

3
racket/collects/racket/contract/private/box.rkt
View File

@ -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

4
racket/collects/racket/contract/private/hash.rkt
View File

@ -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

34
racket/collects/racket/contract/private/misc.rkt
View File

@ -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"])))

1
racket/collects/racket/contract/private/object.rkt
View File

@ -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

2
racket/collects/racket/contract/private/parametric.rkt
View File

@ -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))

3
racket/collects/racket/contract/private/vector.rkt
View File

@ -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