21cbd9ad81
and documented and adjusted these libraries:
racket/contract/base
racket/contract/exists
racket/contract/parametric (renamed from exists)
racket/contract/region
45 lines
1.6 KiB
Racket
45 lines
1.6 KiB
Racket
#lang racket/base
|
|
(require racket/contract/base
|
|
racket/contract/combinator)
|
|
|
|
(define (get-stpc-proj stpc)
|
|
(let ([get-val-proj
|
|
(contract-projection
|
|
(struct-type-property/c-value-contract stpc))])
|
|
(lambda (blame)
|
|
(let ([val-proj (get-val-proj (blame-swap blame))])
|
|
(lambda (x)
|
|
(unless (struct-type-property? x)
|
|
(raise-blame-error blame x
|
|
"expected struct-type-property, given ~e"
|
|
x))
|
|
(let-values ([(nprop _pred _acc)
|
|
(make-struct-type-property
|
|
(wrap-name x)
|
|
(lambda (val _info)
|
|
(val-proj val))
|
|
(list (cons x values)))])
|
|
nprop))))))
|
|
|
|
(define (wrap-name x)
|
|
(string->symbol (format "wrapped-~a" (object-name x))))
|
|
|
|
(struct struct-type-property/c (value-contract)
|
|
#:property prop:contract
|
|
(build-contract-property
|
|
#:name (lambda (c)
|
|
(build-compound-type-name
|
|
'struct-type-property/c
|
|
(struct-type-property/c-value-contract c)))
|
|
#:first-order (lambda (c) struct-type-property?)
|
|
#:projection get-stpc-proj))
|
|
|
|
(define struct-type-property/c*
|
|
(let ([struct-type-property/c
|
|
(lambda (value-contract)
|
|
(struct-type-property/c
|
|
(coerce-contract 'struct-type-property/c value-contract)))])
|
|
struct-type-property/c))
|
|
|
|
(provide (rename-out [struct-type-property/c* struct-type-property/c]))
|