Move helper to a common file.
To avoid ->i depend on ->.
This commit is contained in:
parent
c735c88c2d
commit
5489fb937e
|
@ -7,7 +7,6 @@
|
||||||
"misc.rkt"
|
"misc.rkt"
|
||||||
"blame.rkt"
|
"blame.rkt"
|
||||||
"generate.rkt"
|
"generate.rkt"
|
||||||
"arrow-higher-order.rkt"
|
|
||||||
syntax/location
|
syntax/location
|
||||||
racket/private/performance-hint
|
racket/private/performance-hint
|
||||||
(for-syntax racket/base
|
(for-syntax racket/base
|
||||||
|
|
|
@ -24,7 +24,8 @@
|
||||||
the-unsupplied-arg unsupplied-arg?
|
the-unsupplied-arg unsupplied-arg?
|
||||||
values/drop
|
values/drop
|
||||||
(struct-out base->)
|
(struct-out base->)
|
||||||
raise-wrong-number-of-args-error)
|
raise-wrong-number-of-args-error
|
||||||
|
pre-post/desc-result->string)
|
||||||
|
|
||||||
;; min-arity : nat
|
;; min-arity : nat
|
||||||
;; doms : (listof contract?)[len >= min-arity]
|
;; doms : (listof contract?)[len >= min-arity]
|
||||||
|
@ -379,6 +380,32 @@
|
||||||
'(received: "~a argument~a" expected: "~a")
|
'(received: "~a argument~a" expected: "~a")
|
||||||
args-len (if (= args-len 1) "" "s") arity-string))
|
args-len (if (= args-len 1) "" "s") arity-string))
|
||||||
|
|
||||||
|
(define (pre-post/desc-result->string condition-result pre? who)
|
||||||
|
(cond
|
||||||
|
[(equal? condition-result #f)
|
||||||
|
(if pre?
|
||||||
|
"#:pre condition"
|
||||||
|
"#:post condition")]
|
||||||
|
[(string? condition-result)
|
||||||
|
condition-result]
|
||||||
|
[(and (list? condition-result)
|
||||||
|
(andmap string? condition-result))
|
||||||
|
(apply
|
||||||
|
string-append
|
||||||
|
(let loop ([s condition-result])
|
||||||
|
(cond
|
||||||
|
[(null? s) '()]
|
||||||
|
[(null? (cdr s)) s]
|
||||||
|
[else (list* (car s)
|
||||||
|
"\n "
|
||||||
|
(loop (cdr s)))])))]
|
||||||
|
[else
|
||||||
|
(error
|
||||||
|
who
|
||||||
|
"expected #:~a/desc to produce (or/c boolean? string? (listof string?)), got ~e"
|
||||||
|
(if pre? "pre" "post")
|
||||||
|
condition-result)]))
|
||||||
|
|
||||||
;; timing & size tests
|
;; timing & size tests
|
||||||
|
|
||||||
#;
|
#;
|
||||||
|
|
|
@ -18,7 +18,6 @@
|
||||||
->-proj
|
->-proj
|
||||||
check-pre-cond
|
check-pre-cond
|
||||||
check-post-cond
|
check-post-cond
|
||||||
pre-post/desc-result->string
|
|
||||||
arity-checking-wrapper)
|
arity-checking-wrapper)
|
||||||
|
|
||||||
(define-for-syntax (build-chaperone-constructor/real ;; (listof (or/c #f stx))
|
(define-for-syntax (build-chaperone-constructor/real ;; (listof (or/c #f stx))
|
||||||
|
@ -94,37 +93,11 @@
|
||||||
(void)]
|
(void)]
|
||||||
[else
|
[else
|
||||||
(define msg
|
(define msg
|
||||||
(pre-post/desc-result->string condition-result pre? '->*))
|
(arrow:pre-post/desc-result->string condition-result pre? '->*))
|
||||||
(raise-blame-error (if pre? (blame-swap blame) blame)
|
(raise-blame-error (if pre? (blame-swap blame) blame)
|
||||||
#:missing-party neg-party
|
#:missing-party neg-party
|
||||||
val "~a" msg)]))
|
val "~a" msg)]))
|
||||||
|
|
||||||
(define (pre-post/desc-result->string condition-result pre? who)
|
|
||||||
(cond
|
|
||||||
[(equal? condition-result #f)
|
|
||||||
(if pre?
|
|
||||||
"#:pre condition"
|
|
||||||
"#:post condition")]
|
|
||||||
[(string? condition-result)
|
|
||||||
condition-result]
|
|
||||||
[(and (list? condition-result)
|
|
||||||
(andmap string? condition-result))
|
|
||||||
(apply
|
|
||||||
string-append
|
|
||||||
(let loop ([s condition-result])
|
|
||||||
(cond
|
|
||||||
[(null? s) '()]
|
|
||||||
[(null? (cdr s)) s]
|
|
||||||
[else (list* (car s)
|
|
||||||
"\n "
|
|
||||||
(loop (cdr s)))])))]
|
|
||||||
[else
|
|
||||||
(error
|
|
||||||
who
|
|
||||||
"expected #:~a/desc to produce (or/c boolean? string? (listof string?)), got ~e"
|
|
||||||
(if pre? "pre" "post")
|
|
||||||
condition-result)]))
|
|
||||||
|
|
||||||
(define-for-syntax (create-chaperone blame neg-party blame+neg-party blame-party-info
|
(define-for-syntax (create-chaperone blame neg-party blame+neg-party blame-party-info
|
||||||
val rng-ctcs
|
val rng-ctcs
|
||||||
doms opt-doms
|
doms opt-doms
|
||||||
|
|
Loading…
Reference in New Issue
Block a user