Convert vectorof/vector-immutableof to the new regime.
Also add old-style vectorof to mzlib/contract. original commit: 3028f2d1424123d076a95572a7564b8fb069a86e
This commit is contained in:
parent
d41ec9e051
commit
a4087991e3
|
@ -37,7 +37,6 @@
|
||||||
;;
|
;;
|
||||||
|
|
||||||
(require racket/contract/private/base
|
(require racket/contract/private/base
|
||||||
racket/contract/private/vector
|
|
||||||
racket/contract/private/misc
|
racket/contract/private/misc
|
||||||
racket/contract/private/provide
|
racket/contract/private/provide
|
||||||
racket/contract/private/guts
|
racket/contract/private/guts
|
||||||
|
@ -52,7 +51,6 @@
|
||||||
contract-struct)
|
contract-struct)
|
||||||
|
|
||||||
(all-from-out racket/contract/private/base)
|
(all-from-out racket/contract/private/base)
|
||||||
(all-from-out racket/contract/private/vector)
|
|
||||||
(all-from-out racket/contract/private/provide)
|
(all-from-out racket/contract/private/provide)
|
||||||
(except-out (all-from-out racket/contract/private/misc)
|
(except-out (all-from-out racket/contract/private/misc)
|
||||||
check-between/c
|
check-between/c
|
||||||
|
|
|
@ -1,10 +1,13 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
|
|
||||||
(require (only-in racket/contract/private/box box-immutable/c)
|
(require (only-in racket/contract/private/box box-immutable/c)
|
||||||
|
(only-in racket/contract/private/vector
|
||||||
|
vector/c vector-immutableof vector-immutable/c)
|
||||||
racket/contract/private/blame
|
racket/contract/private/blame
|
||||||
racket/contract/private/guts)
|
racket/contract/private/guts)
|
||||||
|
|
||||||
(provide box/c box-immutable/c)
|
(provide box/c box-immutable/c
|
||||||
|
vector/c vectorof vector-immutableof vector-immutable/c)
|
||||||
|
|
||||||
(define/subexpression-pos-prop (box/c ctc)
|
(define/subexpression-pos-prop (box/c ctc)
|
||||||
(let ([ctc (coerce-flat-contract 'box/c ctc)])
|
(let ([ctc (coerce-flat-contract 'box/c ctc)])
|
||||||
|
@ -22,3 +25,22 @@
|
||||||
(raise-blame-error blame val "not a box"))
|
(raise-blame-error blame val "not a box"))
|
||||||
(proj (unbox val))
|
(proj (unbox val))
|
||||||
val))))))
|
val))))))
|
||||||
|
|
||||||
|
(define/subexpression-pos-prop (vectorof ctc)
|
||||||
|
(let ([ctc (coerce-flat-contract 'vectorof ctc)])
|
||||||
|
(make-flat-contract
|
||||||
|
#:name (build-compound-type-name 'vectorof ctc)
|
||||||
|
#:first-order
|
||||||
|
(λ (val)
|
||||||
|
(and (vector? val)
|
||||||
|
(for/and ([v (in-vector val)])
|
||||||
|
(contract-first-order-passes? ctc v))))
|
||||||
|
#:projection
|
||||||
|
(λ (blame)
|
||||||
|
(λ (val)
|
||||||
|
(let ([proj ((contract-projection ctc) blame)])
|
||||||
|
(unless (vector? val)
|
||||||
|
(raise-blame-error blame val "not a vector"))
|
||||||
|
(for ([v (in-vector val)])
|
||||||
|
(proj v))
|
||||||
|
val))))))
|
||||||
|
|
Loading…
Reference in New Issue
Block a user