Adjusted contract error messages to say given/produced appropriately
(and generally cleaned up the way values are actually put into the code, replacing some ~a's with ~e's and some Rackety)
This commit is contained in:
Robby Findler
parent
33613a75a6
commit
8739f15057
|
|
@ -113,7 +113,7 @@ v4 todo:
|
|||
[res-checker (λ (res-x ...) (values (p-app-x res-x) ...))])
|
||||
(λ (val)
|
||||
(unless (procedure? val)
|
||||
(raise-blame-error orig-blame val "expected a procedure, got ~v" val))
|
||||
(raise-blame-error orig-blame val "expected a procedure, ~a ~v" (given/produced orig-blame) val))
|
||||
(wrapper
|
||||
val
|
||||
(make-keyword-procedure
|
||||
|
|
@ -1873,7 +1873,7 @@ v4 todo:
|
|||
(raise-blame-error
|
||||
blame
|
||||
val
|
||||
"expected a ~a that accepts ~a~a~a argument~a~a~a, given: ~e"
|
||||
"expected a ~a that accepts ~a~a~a argument~a~a~a, ~a: ~e"
|
||||
(if mtd? "method" "procedure")
|
||||
(if (zero? dom-length) "no" dom-length)
|
||||
(if (null? optionals) "" " mandatory")
|
||||
|
|
@ -1882,6 +1882,7 @@ v4 todo:
|
|||
(if (zero? optionals) ""
|
||||
(format " and up to ~a optional argument~a" optionals (if (= 1 optionals) "" "s")))
|
||||
(keyword-error-text mandatory-kwds optional-keywords)
|
||||
(given/produced blame)
|
||||
val))]
|
||||
[else
|
||||
passes?]))
|
||||
|
|
@ -1948,13 +1949,14 @@ v4 todo:
|
|||
(raise-blame-error
|
||||
blame
|
||||
val
|
||||
"expected a ~a that accepts ~a argument~a and arbitrarily more~a, given: ~e"
|
||||
"expected a ~a that accepts ~a argument~a and arbitrarily more~a, ~a: ~e"
|
||||
(if mtd? "method" "procedure")
|
||||
(cond
|
||||
[(zero? dom-length) "no"]
|
||||
[else dom-length])
|
||||
(if (= 1 dom-length) "" "s")
|
||||
(keyword-error-text mandatory-kwds optional-kwds)
|
||||
(given/produced blame)
|
||||
val))]
|
||||
[else
|
||||
passes?]))
|
||||
|
|
|
|||
|
|
@ -92,8 +92,9 @@
|
|||
(raise-blame-error
|
||||
blame
|
||||
val
|
||||
"expected: ~s, given: ~e"
|
||||
"expected: ~s, ~a: ~e"
|
||||
(contract-name ctc)
|
||||
(given/produced blame)
|
||||
val)))
|
||||
(interleave-lifts
|
||||
lift-vars
|
||||
|
|
|
|||
|
|
@ -15,6 +15,7 @@
|
|||
blame-add-context
|
||||
blame-add-unknown-context
|
||||
blame-context
|
||||
given/produced
|
||||
|
||||
raise-blame-error
|
||||
current-blame-format
|
||||
|
|
@ -200,3 +201,9 @@
|
|||
|
||||
(define current-blame-format
|
||||
(make-parameter default-blame-format))
|
||||
|
||||
|
||||
(define (given/produced blame)
|
||||
(if (blame-original? blame)
|
||||
"produced"
|
||||
"given"))
|
||||
|
|
@ -14,31 +14,30 @@
|
|||
|
||||
(define-struct base-box/c (content immutable))
|
||||
|
||||
(define (check-box/c ctc)
|
||||
(let ([elem-ctc (base-box/c-content ctc)]
|
||||
[immutable (base-box/c-immutable ctc)]
|
||||
[flat? (flat-box/c? ctc)])
|
||||
(λ (val fail [first-order? #f])
|
||||
(unless (box? val)
|
||||
(fail "expected a box, got ~a" val))
|
||||
(case immutable
|
||||
[(#t)
|
||||
(unless (immutable? val)
|
||||
(fail "expected an immutable box, got ~a" val))]
|
||||
[(#f)
|
||||
(when (immutable? val)
|
||||
(fail "expected a mutable box, got ~a" val))]
|
||||
[(dont-care) (void)])
|
||||
(when first-order?
|
||||
(unless (contract-first-order-passes? elem-ctc (unbox val))
|
||||
(fail "expected: ~s, got ~v" (contract-name elem-ctc) val)))
|
||||
#t)))
|
||||
(define (check-box/c ctc val blame)
|
||||
(define elem-ctc (base-box/c-content ctc))
|
||||
(define immutable (base-box/c-immutable ctc))
|
||||
(unless (box? val)
|
||||
(raise-blame-error blame val "expected a box, ~a: ~a" (given/produced blame) val))
|
||||
(case immutable
|
||||
[(#t)
|
||||
(unless (immutable? val)
|
||||
(raise-blame-error blame val "expected an immutable box, ~a: ~a" (given/produced blame) val))]
|
||||
[(#f)
|
||||
(when (immutable? val)
|
||||
(raise-blame-error blame val "expected a mutable box, ~a: ~a" (given/produced blame) val))]
|
||||
[(dont-care) (void)]))
|
||||
|
||||
(define (box/c-first-order ctc)
|
||||
(let ([check (check-box/c ctc)])
|
||||
(λ (val)
|
||||
(let/ec return
|
||||
(check val (λ _ (return #f)) #t)))))
|
||||
(define elem-ctc (base-box/c-content ctc))
|
||||
(define immutable (base-box/c-immutable ctc))
|
||||
(λ (val)
|
||||
(and (box? val)
|
||||
(case immutable
|
||||
[(#t) (immutable? val)]
|
||||
[(#f) (not (immutable? val))]
|
||||
[(dont-care) #t])
|
||||
(contract-first-order-passes? elem-ctc (unbox val)))))
|
||||
|
||||
(define (box/c-name ctc)
|
||||
(let ([elem-name (contract-name (base-box/c-content ctc))]
|
||||
|
|
@ -66,7 +65,7 @@
|
|||
(λ (ctc)
|
||||
(λ (blame)
|
||||
(λ (val)
|
||||
((check-box/c ctc) val (λ args (apply raise-blame-error blame val args)))
|
||||
(check-box/c ctc val blame)
|
||||
(((contract-projection (base-box/c-content ctc)) blame) (unbox val))
|
||||
val)))))
|
||||
|
||||
|
|
@ -78,7 +77,7 @@
|
|||
(let ([pos-elem-proj ((contract-projection elem-ctc) blame)]
|
||||
[neg-elem-proj ((contract-projection elem-ctc) (blame-swap blame))])
|
||||
(λ (val)
|
||||
((check-box/c ctc) val (λ args (apply raise-blame-error blame val args)))
|
||||
(check-box/c ctc val blame)
|
||||
(if (immutable? val)
|
||||
(box-immutable (pos-elem-proj (unbox val)))
|
||||
(box-wrapper val
|
||||
|
|
|
|||
|
|
@ -253,7 +253,7 @@ it around flattened out.
|
|||
(raise-blame-error
|
||||
blame
|
||||
val
|
||||
"expected: ~s, got ~e" 'name val))
|
||||
"expected: ~s, ~a ~e" 'name (given/produced blame) val))
|
||||
(cond
|
||||
[(already-there? contract/info val lazy-depth-to-look)
|
||||
val]
|
||||
|
|
@ -458,8 +458,9 @@ it around flattened out.
|
|||
(raise-blame-error
|
||||
blame
|
||||
val
|
||||
"expected: ~s, got ~e"
|
||||
"expected: ~s, ~a ~e"
|
||||
(contract-name ctc)
|
||||
(given/produced blame)
|
||||
val)]))
|
||||
lifts
|
||||
superlifts
|
||||
|
|
@ -536,7 +537,7 @@ it around flattened out.
|
|||
(raise-blame-error
|
||||
(contract/info-blame contract/info)
|
||||
stct
|
||||
"failed `and' clause, got ~e" stct)))
|
||||
"failed `and' clause, ~a ~e" (given/produced (contract/info-blame contract/info)) stct)))
|
||||
|
||||
(define-values (evaluate-attr-prop evaluate-attr-prop-predicate evaluate-attr-prop-accessor)
|
||||
(make-struct-type-property 'evaluate-attr-prop))
|
||||
|
|
|
|||
|
|
@ -76,39 +76,48 @@
|
|||
[else
|
||||
(make-impersonator-hash/c dom-ctc rng-ctc immutable)])))
|
||||
|
||||
(define (check-hash/c ctc)
|
||||
(let ([dom-ctc (base-hash/c-dom ctc)]
|
||||
[rng-ctc (base-hash/c-rng ctc)]
|
||||
[immutable (base-hash/c-immutable ctc)]
|
||||
[flat? (flat-hash/c? ctc)])
|
||||
(λ (val fail [first-order? #f])
|
||||
(unless (hash? val)
|
||||
(fail "expected a hash, got ~a" val))
|
||||
(when (and (not flat?)
|
||||
(not (flat-contract? dom-ctc))
|
||||
(not (hash-equal? val)))
|
||||
(fail "expected equal?-based hash table due to higher-order domain contract, got ~a" val))
|
||||
(case immutable
|
||||
[(#t)
|
||||
(unless (immutable? val)
|
||||
(fail "expected an immutable hash, got ~a" val))]
|
||||
[(#f)
|
||||
(when (immutable? val)
|
||||
(fail "expected an mutable hash, got ~a" val))]
|
||||
[(dont-care) (void)])
|
||||
(when first-order?
|
||||
(for ([(k v) (in-hash val)])
|
||||
(unless (contract-first-order-passes? dom-ctc k)
|
||||
(fail "expected: ~s for key, got ~v" (contract-name dom-ctc) k))
|
||||
(unless (contract-first-order-passes? rng-ctc v)
|
||||
(fail "expected: ~s for value, got ~v" (contract-name rng-ctc) v))))
|
||||
#t)))
|
||||
(define (check-hash/c ctc val blame)
|
||||
(define dom-ctc (base-hash/c-dom ctc))
|
||||
(define rng-ctc (base-hash/c-rng ctc))
|
||||
(define immutable (base-hash/c-immutable ctc))
|
||||
(define flat? (flat-hash/c? ctc))
|
||||
(unless (hash? val)
|
||||
(raise-blame-error blame val "expected a hash, ~a: ~e" (given/produced blame) val))
|
||||
(when (and (not flat?)
|
||||
(not (flat-contract? dom-ctc))
|
||||
(not (hash-equal? val)))
|
||||
(raise-blame-error blame val
|
||||
"expected equal?-based hash table due to higher-order domain contract, ~a: ~e"
|
||||
(given/produced blame)
|
||||
val))
|
||||
(case immutable
|
||||
[(#t)
|
||||
(unless (immutable? val)
|
||||
(raise-blame-error blame val
|
||||
"expected an immutable hash, ~a: ~e" (given/produced blame) val))]
|
||||
[(#f)
|
||||
(when (immutable? val)
|
||||
(raise-blame-error blame val
|
||||
"expected an mutable hash, ~a: ~e" (given/produced blame) val))]
|
||||
[(dont-care) (void)]))
|
||||
|
||||
(define (hash/c-first-order ctc)
|
||||
(let ([check (check-hash/c ctc)])
|
||||
(λ (val)
|
||||
(let/ec return
|
||||
(check val (λ _ (return #f)) #t)))))
|
||||
(define dom-ctc (base-hash/c-dom ctc))
|
||||
(define rng-ctc (base-hash/c-rng ctc))
|
||||
(define immutable (base-hash/c-immutable ctc))
|
||||
(define flat? (flat-hash/c? ctc))
|
||||
(λ (val)
|
||||
(and (hash? val)
|
||||
(or flat?
|
||||
(flat-contract? dom-ctc)
|
||||
(hash-equal? val))
|
||||
(case immutable
|
||||
[(#t) (immutable? val)]
|
||||
[(#f) (not (immutable? val))]
|
||||
[else #t])
|
||||
(for/and ([(k v) (in-hash val)])
|
||||
(and (contract-first-order-passes? dom-ctc k)
|
||||
(contract-first-order-passes? rng-ctc v))))))
|
||||
|
||||
(define (hash/c-name ctc)
|
||||
(apply
|
||||
|
|
@ -139,7 +148,7 @@
|
|||
(λ (ctc)
|
||||
(λ (blame)
|
||||
(λ (val)
|
||||
((check-hash/c ctc) val (λ args (apply raise-blame-error blame val args)))
|
||||
(check-hash/c ctc val blame)
|
||||
(let ([dom-proj ((contract-projection (base-hash/c-dom ctc)) blame)]
|
||||
[rng-proj ((contract-projection (base-hash/c-rng ctc)) blame)])
|
||||
(for ([(k v) (in-hash val)])
|
||||
|
|
@ -158,8 +167,7 @@
|
|||
[pos-rng-proj (rng-proc blame)]
|
||||
[neg-rng-proj (rng-proc (blame-swap blame))])
|
||||
(λ (val)
|
||||
((check-hash/c ctc) val (λ args (apply raise-blame-error blame val args)))
|
||||
|
||||
(check-hash/c ctc val blame)
|
||||
(if (immutable? val)
|
||||
(let ([hash-maker
|
||||
(cond
|
||||
|
|
|
|||
|
|
@ -220,14 +220,16 @@
|
|||
(if candidate-proc
|
||||
(candidate-proc val)
|
||||
(raise-blame-error blame val
|
||||
"none of the branches of the or/c matched, given ~e"
|
||||
"none of the branches of the or/c matched, ~a: ~e"
|
||||
(given/produced blame)
|
||||
val))]
|
||||
[((car checks) val)
|
||||
(if candidate-proc
|
||||
(raise-blame-error blame val
|
||||
"two of the clauses in the or/c might both match: ~s and ~s, given ~e"
|
||||
"two of the clauses in the or/c might both match: ~s and ~s, ~a: ~e"
|
||||
(contract-name candidate-contract)
|
||||
(contract-name (car contracts))
|
||||
(given/produced blame)
|
||||
val)
|
||||
(loop (cdr checks)
|
||||
(cdr procs)
|
||||
|
|
@ -362,8 +364,9 @@
|
|||
(raise-blame-error
|
||||
blame
|
||||
val
|
||||
"expected: ~s, given ~e, which isn't ~s"
|
||||
"expected: ~s, ~a: ~e, which isn't ~s"
|
||||
(contract-name ctc)
|
||||
(given/produced blame)
|
||||
val
|
||||
(contract-name (car ctcs))))])))))
|
||||
|
||||
|
|
@ -642,8 +645,10 @@
|
|||
(λ (val)
|
||||
(unless (predicate? val)
|
||||
(raise-blame-error blame val
|
||||
"expected: ~s, given: ~e"
|
||||
'type-name val))
|
||||
"expected: ~s, ~a: ~e"
|
||||
'type-name
|
||||
(given/produced blame)
|
||||
val))
|
||||
(check-all p-app val))))
|
||||
(cond
|
||||
[(flat-contract? ctc)
|
||||
|
|
@ -687,7 +692,9 @@
|
|||
[cdr-p (cdr-proj (blame-add-context blame "the cdr of"))])
|
||||
(λ (v)
|
||||
(unless (pair? v)
|
||||
(raise-blame-error blame v "expected <cons?>, given: ~e" v))
|
||||
(raise-blame-error blame v "expected <cons?>, ~a: ~e"
|
||||
(given/produced blame)
|
||||
v))
|
||||
(combine v (car-p (car v)) (cdr-p (cdr v))))))
|
||||
(cond
|
||||
[(and (flat-contract? ctc-car) (flat-contract? ctc-cdr))
|
||||
|
|
@ -740,15 +747,17 @@
|
|||
(lambda (blame)
|
||||
(lambda (x)
|
||||
(unless (list? x)
|
||||
(raise-blame-error blame x "expected a list, got: ~e" x))
|
||||
(raise-blame-error blame x "expected a list, ~a: ~e" (given/produced blame) x))
|
||||
(let* ([args (generic-list/c-args c)]
|
||||
[expected (length args)]
|
||||
[actual (length x)])
|
||||
(unless (= actual expected)
|
||||
(raise-blame-error
|
||||
blame x
|
||||
"expected a list of ~a elements, but got ~a elements in: ~e"
|
||||
expected actual x))
|
||||
"expected a list of ~a elements, but ~a ~a elements in: ~e"
|
||||
expected
|
||||
(given/produced blame)
|
||||
actual x))
|
||||
(for ([arg/c (in-list args)] [v (in-list x)] [i (in-naturals 1)])
|
||||
(((contract-projection arg/c)
|
||||
(add-list-context blame i))
|
||||
|
|
@ -764,13 +773,15 @@
|
|||
(arg/c (add-list-context blame i))))
|
||||
(λ (x)
|
||||
(unless (list? x)
|
||||
(raise-blame-error blame x "expected a list, got: ~e" x))
|
||||
(raise-blame-error blame x "expected a list, ~a: ~e" (given/produced blame) x))
|
||||
(define actual (length x))
|
||||
(unless (= actual expected)
|
||||
(raise-blame-error
|
||||
blame x
|
||||
"expected a list of ~a elements, but got ~a elements in: ~e"
|
||||
expected actual x))
|
||||
"expected a list of ~a elements, but ~a ~a elements in: ~e"
|
||||
expected
|
||||
(given/produced blame)
|
||||
actual x))
|
||||
(for/list ([item (in-list x)]
|
||||
[proj (in-list projs)])
|
||||
(proj item)))))
|
||||
|
|
@ -822,7 +833,8 @@
|
|||
(raise-blame-error
|
||||
blame
|
||||
val
|
||||
"expected <promise>, given: ~e"
|
||||
"expected <promise>, ~a: ~e"
|
||||
(given/produced blame)
|
||||
val))
|
||||
(delay (p-app (force val))))))
|
||||
#:first-order promise?))))
|
||||
|
|
|
|||
|
|
@ -180,8 +180,9 @@
|
|||
(raise-blame-error
|
||||
blame
|
||||
val
|
||||
"expected a number between ~a and ~a, given: ~e"
|
||||
"expected a number between ~a and ~a, ~a: ~e"
|
||||
lo hi
|
||||
(given/produced blame)
|
||||
val))
|
||||
|
||||
(define-for-syntax (single-comparison-opter opt/info stx check-arg comparison arg)
|
||||
|
|
@ -216,8 +217,9 @@
|
|||
(raise-blame-error
|
||||
blame
|
||||
val
|
||||
"expected a number ~a ~a, given: ~e"
|
||||
"expected a number ~a ~a, ~a: ~e"
|
||||
(object-name comparison) m
|
||||
(given/produced blame)
|
||||
val))
|
||||
|
||||
|
||||
|
|
@ -302,8 +304,9 @@
|
|||
(raise-blame-error
|
||||
blame
|
||||
val
|
||||
"expected: ~s, given: ~e"
|
||||
"expected: ~s, ~a: ~e"
|
||||
(contract-name ctc)
|
||||
(given/produced blame)
|
||||
val))))
|
||||
(append lifts-hdp lifts-tlp)
|
||||
(append superlifts-hdp superlifts-tlp)
|
||||
|
|
@ -579,6 +582,7 @@
|
|||
(define (bad-number-of-arguments blame val args dom-len)
|
||||
(define num-values (length args))
|
||||
(raise-blame-error (blame-swap blame) val
|
||||
"expected ~a argument~a, got ~a argument~a"
|
||||
"expected ~a argument~a, ~a ~a argument~a"
|
||||
dom-len (if (= dom-len 1) "" "s")
|
||||
(given/produced blame)
|
||||
num-values (if (= num-values 1) "" "s")))
|
||||
|
|
|
|||
|
|
@ -30,23 +30,23 @@
|
|||
'...))
|
||||
#:projection
|
||||
(lambda (c)
|
||||
(lambda (b)
|
||||
(lambda (blame)
|
||||
|
||||
(define (wrap p)
|
||||
;; values in polymorphic types come in from negative position,
|
||||
;; relative to the poly/c contract
|
||||
(define negative? (blame-swapped? b))
|
||||
(define negative? (blame-swapped? blame))
|
||||
(define barrier/c (polymorphic-contract-barrier c))
|
||||
(define instances
|
||||
(for/list ([var (in-list (polymorphic-contract-vars c))])
|
||||
(barrier/c negative? var)))
|
||||
(define protector
|
||||
(apply (polymorphic-contract-body c) instances))
|
||||
(((contract-projection protector) b) p))
|
||||
(((contract-projection protector) blame) p))
|
||||
|
||||
(lambda (p)
|
||||
(unless (procedure? p)
|
||||
(raise-blame-error b p "expected a procedure; got: ~e" p))
|
||||
(raise-blame-error blame p "expected a procedure; ~a: ~e" (given/produced blame) p))
|
||||
(make-keyword-procedure
|
||||
(lambda (keys vals . args) (keyword-apply (wrap p) keys vals args))
|
||||
(case-lambda
|
||||
|
|
@ -73,12 +73,14 @@
|
|||
#:name (lambda (c) (barrier-contract-name c))
|
||||
#:projection
|
||||
(lambda (c)
|
||||
(lambda (b)
|
||||
(if (equal? (blame-original? b) (barrier-contract-positive? c))
|
||||
(lambda (blame)
|
||||
(if (equal? (blame-original? blame) (barrier-contract-positive? c))
|
||||
(lambda (x)
|
||||
((barrier-contract-make c) x))
|
||||
(lambda (x)
|
||||
(if ((barrier-contract-pred c) x)
|
||||
((barrier-contract-get c) x)
|
||||
(raise-blame-error b x "expected a(n) ~a; got: ~e"
|
||||
(barrier-contract-name c) x))))))))
|
||||
(raise-blame-error blame x "expected a(n) ~a; ~a: ~e"
|
||||
(barrier-contract-name c)
|
||||
(given/produced blame)
|
||||
x))))))))
|
||||
|
|
|
|||
|
|
@ -261,7 +261,11 @@
|
|||
(λ (x)
|
||||
(if (first-order x)
|
||||
x
|
||||
(raise-blame-error b x "expected: ~s, given: ~e" name x))))))
|
||||
(raise-blame-error b x
|
||||
"expected: ~s, ~a: ~e"
|
||||
name
|
||||
(given/produced b)
|
||||
x))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
|
|
|
|||
|
|
@ -14,7 +14,8 @@
|
|||
(lambda (x)
|
||||
(unless (struct-type-property? x)
|
||||
(raise-blame-error blame x
|
||||
"expected struct-type-property, given ~e"
|
||||
"expected struct-type-property, ~a: ~e"
|
||||
(given/produced blame)
|
||||
x))
|
||||
(let-values ([(nprop _pred _acc)
|
||||
(make-struct-type-property
|
||||
|
|
|
|||
|
|
@ -178,38 +178,48 @@
|
|||
(list '#:immutable immutable)
|
||||
null)))))
|
||||
|
||||
(define (check-vector/c c)
|
||||
(let ([elem-ctcs (base-vector/c-elems c)]
|
||||
[immutable (base-vector/c-immutable c)]
|
||||
[flat? (flat-vector/c? c)])
|
||||
(λ (val fail [first-order? #f])
|
||||
(unless (vector? val)
|
||||
(fail "expected a vector, got ~a" val))
|
||||
(cond
|
||||
[(eq? immutable #t)
|
||||
(unless (immutable? val)
|
||||
(fail "expected an immutable vector, got ~a" val))]
|
||||
[(eq? immutable #f)
|
||||
(when (immutable? val)
|
||||
(fail "expected an mutable vector, got ~a" val))]
|
||||
[else (void)])
|
||||
(let ([elem-count (length elem-ctcs)])
|
||||
(unless (= (vector-length val) elem-count)
|
||||
(fail "expected a vector of ~a element~a, got ~a"
|
||||
elem-count (if (= elem-count 1) "" "s") val)))
|
||||
(when first-order?
|
||||
(for ([e (in-vector val)]
|
||||
[n (in-naturals)]
|
||||
[c (in-list elem-ctcs)])
|
||||
(unless (contract-first-order-passes? c e)
|
||||
(fail "expected: ~s for element ~v, got ~v" (contract-name c) n val))))
|
||||
#t)))
|
||||
(define (check-vector/c ctc val blame)
|
||||
(define elem-ctcs (base-vector/c-elems ctc))
|
||||
(define immutable (base-vector/c-immutable ctc))
|
||||
(unless (vector? val)
|
||||
(raise-blame-error blame val "expected a vector, ~a: ~e"
|
||||
(given/produced blame)
|
||||
val))
|
||||
(cond
|
||||
[(eq? immutable #t)
|
||||
(unless (immutable? val)
|
||||
(raise-blame-error blame val
|
||||
"expected an immutable vector, ~a: ~e"
|
||||
(given/produced blame)
|
||||
val))]
|
||||
[(eq? immutable #f)
|
||||
(when (immutable? val)
|
||||
(raise-blame-error blame val
|
||||
"expected an mutable vector, ~a: ~e"
|
||||
(given/produced blame)
|
||||
val))]
|
||||
[else (void)])
|
||||
(define elem-count (length elem-ctcs))
|
||||
(unless (= (vector-length val) elem-count)
|
||||
(raise-blame-error blame val "expected a vector of ~a element~a, ~a: ~e"
|
||||
elem-count
|
||||
(if (= elem-count 1) "" "s")
|
||||
(given/produced blame)
|
||||
val)))
|
||||
|
||||
(define (vector/c-first-order ctc)
|
||||
(let ([check (check-vector/c ctc)])
|
||||
(λ (val)
|
||||
(let/ec return
|
||||
(check val (λ _ (return #f)) #t)))))
|
||||
(define elem-ctcs (base-vector/c-elems ctc))
|
||||
(define immutable (base-vector/c-immutable ctc))
|
||||
(λ (val)
|
||||
(and (vector? val)
|
||||
(cond
|
||||
[(eq? immutable #t) (immutable? val)]
|
||||
[(eq? immutable #f) (not (immutable? val))]
|
||||
[else #t])
|
||||
(= (vector-length val) (length elem-ctcs))
|
||||
(for/and ([e (in-vector val)]
|
||||
[c (in-list elem-ctcs)])
|
||||
(contract-first-order-passes? c e)))))
|
||||
|
||||
(define-struct (flat-vector/c base-vector/c) ()
|
||||
#:property prop:flat-contract
|
||||
|
|
@ -220,7 +230,7 @@
|
|||
(λ (ctc)
|
||||
(λ (blame)
|
||||
(λ (val)
|
||||
((check-vector/c ctc) val (λ args (apply raise-blame-error blame val args)))
|
||||
(check-vector/c ctc val blame)
|
||||
(for ([e (in-vector val)]
|
||||
[c (in-list (base-vector/c-elems ctc))])
|
||||
(((contract-projection c) blame) e))
|
||||
|
|
@ -236,7 +246,7 @@
|
|||
[elem-neg-projs (apply vector-immutable
|
||||
(map (λ (c) ((contract-projection c) (blame-swap blame))) elem-ctcs))])
|
||||
(λ (val)
|
||||
((check-vector/c ctc) val (λ args (apply raise-blame-error blame val args)))
|
||||
(check-vector/c ctc val blame)
|
||||
(if (immutable? val)
|
||||
(apply vector-immutable
|
||||
(for/list ([e (in-vector val)]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user