make opt/c contract follow the blame-add-context protocol
This commit is contained in:
Robby Findler
parent
917ec51eee
commit
2e195935cf
|
|
@ -50,7 +50,12 @@
|
|||
|
||||
contract-projection
|
||||
contract-name
|
||||
n->th)
|
||||
n->th
|
||||
|
||||
blame-add-or-context
|
||||
blame-add-car-context
|
||||
blame-add-cdr-context
|
||||
raise-not-cons-blame-error)
|
||||
|
||||
(define-syntax (flat-rec-contract stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -152,12 +157,15 @@
|
|||
[pred (single-or/c-pred ctc)])
|
||||
(λ (blame)
|
||||
(define partial-contract
|
||||
(c-proc (blame-add-context blame "a disjunct of")))
|
||||
(c-proc (blame-add-or-context blame)))
|
||||
(λ (val)
|
||||
(cond
|
||||
[(pred val) val]
|
||||
[else (partial-contract val)])))))
|
||||
|
||||
(define (blame-add-or-context blame)
|
||||
(blame-add-context blame "a disjunct of"))
|
||||
|
||||
(define (single-or/c-first-order ctc)
|
||||
(let ([pred (single-or/c-pred ctc)]
|
||||
[ho (contract-first-order (single-or/c-ho-ctc ctc))])
|
||||
|
|
@ -629,6 +637,9 @@
|
|||
(define non-empty-listof-func (*-listof non-empty-list? non-empty-listof (λ (ctc) (make-generate-ctc-fail))))
|
||||
(define/subexpression-pos-prop (non-empty-listof a) (non-empty-listof-func a))
|
||||
|
||||
(define (blame-add-car-context blame) (blame-add-context blame "the car of"))
|
||||
(define (blame-add-cdr-context blame) (blame-add-context blame "the cdr of"))
|
||||
|
||||
(define cons/c-main-function
|
||||
(λ (car-c cdr-c)
|
||||
(let* ([ctc-car (coerce-contract 'cons/c car-c)]
|
||||
|
|
@ -641,13 +652,11 @@
|
|||
(contract-first-order-passes? ctc-car (car v))
|
||||
(contract-first-order-passes? ctc-cdr (cdr v))))
|
||||
(define ((ho-check combine) blame)
|
||||
(let ([car-p (car-proj (blame-add-context blame "the car of"))]
|
||||
[cdr-p (cdr-proj (blame-add-context blame "the cdr of"))])
|
||||
(let ([car-p (car-proj (blame-add-car-context blame))]
|
||||
[cdr-p (cdr-proj (blame-add-cdr-context blame))])
|
||||
(λ (v)
|
||||
(unless (pair? v)
|
||||
(raise-blame-error blame v
|
||||
'(expected "<pair?>" given: "~e")
|
||||
v))
|
||||
(raise-not-cons-blame-error blame v))
|
||||
(combine v (car-p (car v)) (cdr-p (cdr v))))))
|
||||
(cond
|
||||
[(and (flat-contract? ctc-car) (flat-contract? ctc-cdr))
|
||||
|
|
@ -666,6 +675,13 @@
|
|||
#:first-order fo-check
|
||||
#:projection (ho-check (λ (v a d) (cons a d))))]))))
|
||||
|
||||
(define (raise-not-cons-blame-error blame val)
|
||||
(raise-blame-error
|
||||
blame
|
||||
val
|
||||
'(expected: "pair?" given: "~e")
|
||||
val))
|
||||
|
||||
(define/subexpression-pos-prop (cons/c a b) (cons/c-main-function a b))
|
||||
|
||||
(define/subexpression-pos-prop (list/c . args)
|
||||
|
|
|
|||
|
|
@ -20,6 +20,7 @@
|
|||
opt/info-that
|
||||
|
||||
opt/info-swap-blame
|
||||
opt/info-add-blame-context
|
||||
opt/info-change-val
|
||||
|
||||
opt/unknown
|
||||
|
|
@ -147,12 +148,12 @@
|
|||
|
||||
;; struct for color-keeping across opters
|
||||
(define-struct opt/info
|
||||
(contract val blame-id swap-blame? free-vars recf base-pred this that))
|
||||
(contract val blame-stx swap-blame? free-vars recf base-pred this that))
|
||||
|
||||
(define (opt/info-blame oi)
|
||||
(if (opt/info-swap-blame? oi)
|
||||
#`(blame-swap #,(opt/info-blame-id oi))
|
||||
(opt/info-blame-id oi)))
|
||||
#`(blame-swap #,(opt/info-blame-stx oi))
|
||||
(opt/info-blame-stx oi)))
|
||||
|
||||
;; opt/info-swap-blame : opt/info -> opt/info
|
||||
;; swaps pos and neg
|
||||
|
|
@ -165,6 +166,14 @@
|
|||
(struct-copy opt/info info [val val]))
|
||||
|
||||
|
||||
;; opt/info-add-blame-context : opt/info (stx -> stx) -> opt/info
|
||||
;; calls 'f' on the current blame syntax to build a new one
|
||||
;; (presumably wrapping it with a call to (blame-add-context ...),
|
||||
;; possibly via a helper function) and returns an adjusted opt/info record
|
||||
(define (opt/info-add-blame-context info f)
|
||||
(struct-copy opt/info info
|
||||
[blame-stx (f (opt/info-blame-stx info))]))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; stronger helper functions
|
||||
|
|
|
|||
|
|
@ -59,7 +59,11 @@
|
|||
no-negative-blame
|
||||
(reverse names))]
|
||||
[else
|
||||
(define ps-optres (opt/i opt/info (car ps)))
|
||||
(define ps-optres (opt/i (opt/info-add-blame-context
|
||||
opt/info
|
||||
(λ (blame-stx)
|
||||
#`(blame-add-or-context #,blame-stx)))
|
||||
(car ps)))
|
||||
(if (optres-flat ps-optres)
|
||||
(loop (cdr ps)
|
||||
(cons (optres-flat ps-optres) next-ps)
|
||||
|
|
@ -306,8 +310,16 @@
|
|||
|
||||
(define/opter (cons/c opt/i opt/info stx)
|
||||
(define (opt/cons-ctc hdp tlp)
|
||||
(define optres-hd (opt/i opt/info hdp))
|
||||
(define optres-tl (opt/i opt/info tlp))
|
||||
(define optres-hd (opt/i (opt/info-add-blame-context
|
||||
opt/info
|
||||
(λ (stx)
|
||||
#`(blame-add-car-context #,stx)))
|
||||
hdp))
|
||||
(define optres-tl (opt/i (opt/info-add-blame-context
|
||||
opt/info
|
||||
(λ (stx)
|
||||
#`(blame-add-cdr-context #,stx)))
|
||||
tlp))
|
||||
(with-syntax ((check (with-syntax ((val (opt/info-val opt/info)))
|
||||
(syntax (pair? val)))))
|
||||
(build-optres
|
||||
|
|
@ -320,12 +332,8 @@
|
|||
(syntax (if check
|
||||
(cons (let ((val (car val))) next-hdp)
|
||||
(let ((val (cdr val))) next-tlp))
|
||||
(raise-blame-error
|
||||
blame
|
||||
val
|
||||
'(expected: "~s" given: "~e")
|
||||
(contract-name ctc)
|
||||
val))))
|
||||
(raise-not-cons-blame-error
|
||||
blame val))))
|
||||
#:lifts
|
||||
(append (optres-lifts optres-hd) (optres-lifts optres-tl))
|
||||
#:superlifts
|
||||
|
|
@ -352,7 +360,12 @@
|
|||
[(_ hdp tlp) (opt/cons-ctc #'hdp #'tlp)]))
|
||||
|
||||
(define-for-syntax (opt/listof-ctc content non-empty? opt/i opt/info)
|
||||
(define optres-ele (opt/i opt/info content))
|
||||
(define optres-ele (opt/i
|
||||
(opt/info-add-blame-context
|
||||
opt/info
|
||||
(λ (blame-stx)
|
||||
#`(blame-add-element-context #,blame-stx)))
|
||||
content))
|
||||
(with-syntax ([check (with-syntax ((val (opt/info-val opt/info)))
|
||||
(if non-empty?
|
||||
#'(and (list? val) (pair? val))
|
||||
|
|
@ -400,6 +413,9 @@
|
|||
'listof)
|
||||
#,(optres-name optres-ele)))))
|
||||
|
||||
(define (blame-add-element-context blame)
|
||||
(blame-add-context blame "an element of"))
|
||||
|
||||
(define/opter (listof opt/i opt/info stx)
|
||||
(syntax-case stx ()
|
||||
[(_ content) (opt/listof-ctc #'content #f opt/i opt/info)]))
|
||||
|
|
@ -465,7 +481,8 @@
|
|||
[partials-doms null]
|
||||
[stronger-ribs null]
|
||||
[chaperone? #t]
|
||||
[dom-names '()])
|
||||
[dom-names '()]
|
||||
[arg-num 1])
|
||||
(cond
|
||||
[(null? doms) (values (reverse next-doms)
|
||||
lifts-doms
|
||||
|
|
@ -475,7 +492,11 @@
|
|||
chaperone?
|
||||
(reverse dom-names))]
|
||||
[else
|
||||
(define optres-dom (opt/i (opt/info-swap-blame opt/info) (car doms)))
|
||||
(define optres-dom (opt/i (opt/info-add-blame-context
|
||||
(opt/info-swap-blame opt/info)
|
||||
(λ (blame-stx)
|
||||
#`(blame-add-nth-arg-context #,blame-stx #,arg-num)))
|
||||
(car doms)))
|
||||
(loop (cdr vars)
|
||||
(cdr doms)
|
||||
(cons (with-syntax ((next (optres-exp optres-dom))
|
||||
|
|
@ -488,7 +509,8 @@
|
|||
(append partials-doms (optres-partials optres-dom))
|
||||
(append (optres-stronger-ribs optres-dom) stronger-ribs)
|
||||
(combine-two-chaperone?s chaperone? (optres-chaperone optres-dom))
|
||||
(cons (optres-name optres-dom) dom-names))]))]
|
||||
(cons (optres-name optres-dom) dom-names)
|
||||
(+ arg-num 1))]))]
|
||||
[(next-rngs lifts-rngs superlifts-rngs partials-rngs stronger-ribs-rng rng-chaperone? rng-names)
|
||||
(let loop ([vars rng-vars]
|
||||
[rngs rngs]
|
||||
|
|
@ -508,7 +530,12 @@
|
|||
chaperone?
|
||||
(reverse rng-names))]
|
||||
[else
|
||||
(define optres-rng (opt/i opt/info (car rngs)))
|
||||
(define optres-rng (opt/i
|
||||
(opt/info-add-blame-context
|
||||
opt/info
|
||||
(λ (blame-stx)
|
||||
#`(blame-add-range-context #,blame-stx)))
|
||||
(car rngs)))
|
||||
(loop (cdr vars)
|
||||
(cdr rngs)
|
||||
(cons (with-syntax ((next (optres-exp optres-rng))
|
||||
|
|
@ -576,7 +603,8 @@
|
|||
[partials-doms null]
|
||||
[stronger-ribs null]
|
||||
[chaperone? #t]
|
||||
[names '()])
|
||||
[names '()]
|
||||
[arg-num 1])
|
||||
(cond
|
||||
[(null? doms) (values (reverse next-doms)
|
||||
lifts-doms
|
||||
|
|
@ -586,7 +614,11 @@
|
|||
chaperone?
|
||||
(reverse names))]
|
||||
[else
|
||||
(define optres-dom (opt/i (opt/info-swap-blame opt/info) (car doms)))
|
||||
(define optres-dom (opt/i (opt/info-add-blame-context
|
||||
(opt/info-swap-blame opt/info)
|
||||
(λ (blame-stx)
|
||||
#`(blame-add-nth-arg-context #,blame-stx #,arg-num)))
|
||||
(car doms)))
|
||||
(loop (cdr vars)
|
||||
(cdr doms)
|
||||
(cons #`(let ([#,(opt/info-val opt/info) #,(car vars)]) #,(optres-exp optres-dom))
|
||||
|
|
@ -596,7 +628,8 @@
|
|||
(append partials-doms (optres-partials optres-dom))
|
||||
(append (optres-stronger-ribs optres-dom) stronger-ribs)
|
||||
(combine-two-chaperone?s chaperone? (optres-chaperone optres-dom))
|
||||
(cons (optres-name optres-dom) names))]))])
|
||||
(cons (optres-name optres-dom) names)
|
||||
(+ arg-num 1))]))])
|
||||
(values
|
||||
(with-syntax ((blame (opt/info-blame opt/info))
|
||||
((dom-arg ...) dom-vars)
|
||||
|
|
@ -676,6 +709,13 @@
|
|||
#:name name)
|
||||
(opt/unknown opt/i opt/info stx))))]))
|
||||
|
||||
(define (blame-add-nth-arg-context blame n)
|
||||
(blame-add-context blame
|
||||
(format "the ~a argument of" (n->th n))))
|
||||
(define (blame-add-range-context blame)
|
||||
(blame-add-context blame
|
||||
"the range of"))
|
||||
|
||||
(define/opter (predicate/c opt/i opt/info stx) (predicate/c-optres opt/info))
|
||||
|
||||
(define (handle-non-exact-procedure val dom-len blame exact-proc)
|
||||
|
|
|
|||
|
|
@ -888,7 +888,12 @@
|
|||
|
||||
(define sub-val (car (generate-temporaries '(struct/dc))))
|
||||
|
||||
(define this-optres (opt/i (opt/info-change-val sub-val opt/info) exp))
|
||||
(define this-optres (opt/i
|
||||
(opt/info-add-blame-context
|
||||
(opt/info-change-val sub-val opt/info)
|
||||
(λ (blame-stx)
|
||||
#`(blame-add-struct-context #,blame-stx '#,sel-name)))
|
||||
exp))
|
||||
|
||||
(define sel-id (name->sel-id #'struct-id sel-name))
|
||||
|
||||
|
|
@ -1012,6 +1017,9 @@
|
|||
#:chaperone #t
|
||||
#:no-negative-blame? no-negative-blame))]))]))
|
||||
|
||||
(define (blame-add-struct-context blame fld)
|
||||
(blame-add-context blame (format "the ~a field of" fld)))
|
||||
|
||||
(define (struct/dc-error blame obj what)
|
||||
(raise-blame-error blame obj
|
||||
'(expected: "a struct of type ~a")
|
||||
|
|
|
|||
|
|
@ -13378,414 +13378,370 @@ so that propagation occurs.
|
|||
(string-append "did not find ``in:'', so no context in msg: "
|
||||
str)])))
|
||||
|
||||
(ctest '("the cdr of" "the 1st argument of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (-> (cons/c integer? boolean?) integer? integer?)
|
||||
(λ (x y) x)
|
||||
'pos
|
||||
'neg)
|
||||
(cons 1 2) 1)))
|
||||
|
||||
(ctest '("the 3rd element of" "the 2nd argument of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (-> integer? (list/c integer? integer? boolean?) integer?)
|
||||
(λ (x y) x)
|
||||
'pos
|
||||
'neg)
|
||||
1 (list 1 2 3))))
|
||||
|
||||
(ctest '("the range of" "the 4th element of")
|
||||
extract-context-lines
|
||||
(λ () ((cadddr (contract (list/c integer? integer? boolean? (-> number? number?))
|
||||
(list 1 2 #f (λ (x) #f))
|
||||
(define (context-test context expression)
|
||||
(contract-eval `(,test ',context extract-context-lines (lambda () ,expression)))
|
||||
(let/ec k
|
||||
(contract-eval `(,test ',context extract-context-lines (lambda () ,(rewrite expression k))))))
|
||||
|
||||
(context-test '("the 1st argument of")
|
||||
'((contract (-> boolean? integer? integer?)
|
||||
(λ (x y) x)
|
||||
'pos
|
||||
'neg)
|
||||
0 1))
|
||||
|
||||
(context-test '("the cdr of" "the 1st argument of")
|
||||
'((contract (-> (cons/c integer? boolean?) integer? integer?)
|
||||
(λ (x y) x)
|
||||
'pos
|
||||
'neg)
|
||||
(cons 1 2) 1))
|
||||
|
||||
(context-test '("the 3rd element of" "the 2nd argument of")
|
||||
'((contract (-> integer? (list/c integer? integer? boolean?) integer?)
|
||||
(λ (x y) x)
|
||||
'pos
|
||||
'neg)
|
||||
1 (list 1 2 3)))
|
||||
|
||||
(context-test '("the range of" "the 4th element of")
|
||||
'((cadddr (contract (list/c integer? integer? boolean? (-> number? number?))
|
||||
(list 1 2 #f (λ (x) #f))
|
||||
'pos
|
||||
'neg))
|
||||
1))
|
||||
|
||||
(context-test '("a disjunct of")
|
||||
'(contract (or/c 1 (-> number? number?))
|
||||
3
|
||||
'pos
|
||||
'neg))
|
||||
|
||||
(context-test '("the range of" "a disjunct of")
|
||||
'((contract (or/c 1 (-> number? number?) (-> number? boolean? number?))
|
||||
(λ (x) #f)
|
||||
'pos
|
||||
'neg)
|
||||
1))
|
||||
|
||||
(context-test '("the 2nd conjunct of")
|
||||
'(contract (and/c procedure? (-> integer? integer?))
|
||||
(λ (x y) 1)
|
||||
'pos
|
||||
'neg))
|
||||
|
||||
(context-test '("an element of")
|
||||
'(contract (listof number?)
|
||||
(list #f)
|
||||
'pos
|
||||
'neg))
|
||||
|
||||
(context-test '("the promise from")
|
||||
'(force (contract (promise/c number?)
|
||||
(delay #f)
|
||||
'pos
|
||||
'neg))
|
||||
1)))
|
||||
|
||||
(ctest '("a disjunct of")
|
||||
extract-context-lines
|
||||
(λ () (contract (or/c 1 (-> number? number?))
|
||||
3
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(ctest '("the range of" "a disjunct of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (or/c 1 (-> number? number?) (-> number? boolean? number?))
|
||||
(λ (x) #f)
|
||||
'pos
|
||||
'neg)
|
||||
1)))
|
||||
|
||||
(ctest '("the 2nd conjunct of")
|
||||
extract-context-lines
|
||||
(λ () (contract (and/c procedure? (-> integer? integer?))
|
||||
(λ (x y) 1)
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(ctest '("an element of")
|
||||
extract-context-lines
|
||||
(λ () (contract (listof number?)
|
||||
(list #f)
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(ctest '("the promise from")
|
||||
extract-context-lines
|
||||
(λ () (force (contract (promise/c number?)
|
||||
(delay #f)
|
||||
'pos
|
||||
'neg))))
|
||||
|
||||
(ctest '("the parameter of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (parameter/c number?)
|
||||
(make-parameter #f)
|
||||
'pos
|
||||
'neg))))
|
||||
(ctest '("the parameter of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (parameter/c number?)
|
||||
(make-parameter 1)
|
||||
'pos
|
||||
'neg)
|
||||
#f)))
|
||||
(ctest '("the #:x argument of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (-> #:x number? #:a char? #:w boolean? any)
|
||||
(λ (#:x x #:a a #:w w) x)
|
||||
'pos
|
||||
'neg)
|
||||
#:a #\a #:w #f #:x 'two)))
|
||||
|
||||
(ctest '("the #:a argument of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (-> #:x number? #:a char? #:w boolean? any)
|
||||
(λ (#:x x #:a a #:w w) x)
|
||||
'pos
|
||||
'neg)
|
||||
#:a #f #:w #f #:x 2)))
|
||||
|
||||
(ctest '("the #:w argument of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (-> #:x number? #:a char? #:w boolean? any)
|
||||
(λ (#:x x #:a a #:w w) x)
|
||||
'pos
|
||||
'neg)
|
||||
#:a #\a #:w 'false #:x 2)))
|
||||
|
||||
(ctest '("the #:x argument of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (->* () (#:x number?) any)
|
||||
(λ (#:x [x 1]) x)
|
||||
'pos
|
||||
'neg)
|
||||
#:x #f)))
|
||||
|
||||
(ctest '("the #:x argument of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (->* () (#:x number? #:a char? #:w boolean?) any)
|
||||
(λ (#:x [x 1] #:a [a #\a] #:w [w #f]) x)
|
||||
'pos
|
||||
'neg)
|
||||
#:a #\a #:w #f #:x 'two)))
|
||||
|
||||
(ctest '("the #:a argument of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (->* () (#:x number? #:a char? #:w boolean?) any)
|
||||
(λ (#:x [x 1] #:a [a #\a] #:w [w #f]) x)
|
||||
'pos
|
||||
'neg)
|
||||
#:a #f #:w #f #:x 2)))
|
||||
|
||||
(ctest '("the #:w argument of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (->* () (#:x number? #:a char? #:w boolean?) any)
|
||||
(λ (#:x [x 1] #:a [a #\a] #:w [w #f]) x)
|
||||
'pos
|
||||
'neg)
|
||||
#:a #\a #:w 'false #:x 2)))
|
||||
|
||||
(ctest '("the x argument of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (->i ([w integer?] [x boolean?] [a char?]) any)
|
||||
(λ (w x a) x)
|
||||
'pos
|
||||
'neg)
|
||||
1 'true #\a)))
|
||||
|
||||
(ctest '("the x argument of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (->i ([w integer?]) ([x boolean?] [a char?]) any)
|
||||
(λ (w [x #t] [a #\a]) x)
|
||||
'pos
|
||||
'neg)
|
||||
1 'true #\a)))
|
||||
|
||||
(ctest '("the y result of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (->i () (values [x integer?] [y integer?]))
|
||||
(λ () (values 1 #f))
|
||||
'pos
|
||||
'neg))))
|
||||
|
||||
(ctest '("the x result of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (->i () (values [x integer?] [y integer?]))
|
||||
(λ () (values #f 1))
|
||||
'pos
|
||||
'neg))))
|
||||
|
||||
(ctest '("the _ result of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (->i ([x integer?]) [_ (x) (<=/c x)])
|
||||
add1
|
||||
'pos
|
||||
'neg)
|
||||
1)))
|
||||
|
||||
(ctest '("the a argument of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (->i ([a integer?] #:b [b integer?]) ([c integer?] #:d [d integer?]) any)
|
||||
(λ (a #:b b [c 1] #:d [d 1]) 1)
|
||||
'pos
|
||||
'neg)
|
||||
'one #:b 2 3 #:d 4)))
|
||||
|
||||
(ctest '("the b argument of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (->i ([a integer?] #:b [b integer?]) ([c integer?] #:d [d integer?]) any)
|
||||
(λ (a #:b b [c 1] #:d [d 1]) 1)
|
||||
'pos
|
||||
'neg)
|
||||
1 #:b 'two 3 #:d 4)))
|
||||
|
||||
(ctest '("the c argument of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (->i ([a integer?] #:b [b integer?]) ([c integer?] #:d [d integer?]) any)
|
||||
(λ (a #:b b [c 1] #:d [d 1]) 1)
|
||||
'pos
|
||||
'neg)
|
||||
1 #:b 2 'three #:d 4)))
|
||||
|
||||
(ctest '("the d argument of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (->i ([a integer?] #:b [b integer?]) ([c integer?] #:d [d integer?]) any)
|
||||
(λ (a #:b b [c 1] #:d [d 1]) 1)
|
||||
'pos
|
||||
'neg)
|
||||
1 #:b 2 3 #:d 'four)))
|
||||
|
||||
'neg)))
|
||||
|
||||
(context-test '("the parameter of")
|
||||
'((contract (parameter/c number?)
|
||||
(make-parameter #f)
|
||||
'pos
|
||||
'neg)))
|
||||
(context-test '("the parameter of")
|
||||
'((contract (parameter/c number?)
|
||||
(make-parameter 1)
|
||||
'pos
|
||||
'neg)
|
||||
#f))
|
||||
(context-test '("the #:x argument of")
|
||||
'((contract (-> #:x number? #:a char? #:w boolean? any)
|
||||
(λ (#:x x #:a a #:w w) x)
|
||||
'pos
|
||||
'neg)
|
||||
#:a #\a #:w #f #:x 'two))
|
||||
|
||||
(context-test '("the #:a argument of")
|
||||
'((contract (-> #:x number? #:a char? #:w boolean? any)
|
||||
(λ (#:x x #:a a #:w w) x)
|
||||
'pos
|
||||
'neg)
|
||||
#:a #f #:w #f #:x 2))
|
||||
|
||||
(context-test '("the #:w argument of")
|
||||
'((contract (-> #:x number? #:a char? #:w boolean? any)
|
||||
(λ (#:x x #:a a #:w w) x)
|
||||
'pos
|
||||
'neg)
|
||||
#:a #\a #:w 'false #:x 2))
|
||||
|
||||
(context-test '("the #:x argument of")
|
||||
'((contract (->* () (#:x number?) any)
|
||||
(λ (#:x [x 1]) x)
|
||||
'pos
|
||||
'neg)
|
||||
#:x #f))
|
||||
|
||||
(context-test '("the #:x argument of")
|
||||
'((contract (->* () (#:x number? #:a char? #:w boolean?) any)
|
||||
(λ (#:x [x 1] #:a [a #\a] #:w [w #f]) x)
|
||||
'pos
|
||||
'neg)
|
||||
#:a #\a #:w #f #:x 'two))
|
||||
|
||||
(context-test '("the #:a argument of")
|
||||
'((contract (->* () (#:x number? #:a char? #:w boolean?) any)
|
||||
(λ (#:x [x 1] #:a [a #\a] #:w [w #f]) x)
|
||||
'pos
|
||||
'neg)
|
||||
#:a #f #:w #f #:x 2))
|
||||
|
||||
(context-test '("the #:w argument of")
|
||||
'((contract (->* () (#:x number? #:a char? #:w boolean?) any)
|
||||
(λ (#:x [x 1] #:a [a #\a] #:w [w #f]) x)
|
||||
'pos
|
||||
'neg)
|
||||
#:a #\a #:w 'false #:x 2))
|
||||
|
||||
(context-test '("the x argument of")
|
||||
'((contract (->i ([w integer?] [x boolean?] [a char?]) any)
|
||||
(λ (w x a) x)
|
||||
'pos
|
||||
'neg)
|
||||
1 'true #\a))
|
||||
|
||||
(context-test '("the x argument of")
|
||||
'((contract (->i ([w integer?]) ([x boolean?] [a char?]) any)
|
||||
(λ (w [x #t] [a #\a]) x)
|
||||
'pos
|
||||
'neg)
|
||||
1 'true #\a))
|
||||
|
||||
(context-test '("the y result of")
|
||||
'((contract (->i () (values [x integer?] [y integer?]))
|
||||
(λ () (values 1 #f))
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(context-test '("the x result of")
|
||||
'((contract (->i () (values [x integer?] [y integer?]))
|
||||
(λ () (values #f 1))
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(context-test '("the _ result of")
|
||||
'((contract (->i ([x integer?]) [_ (x) (<=/c x)])
|
||||
add1
|
||||
'pos
|
||||
'neg)
|
||||
1))
|
||||
|
||||
(context-test '("the a argument of")
|
||||
'((contract (->i ([a integer?] #:b [b integer?]) ([c integer?] #:d [d integer?]) any)
|
||||
(λ (a #:b b [c 1] #:d [d 1]) 1)
|
||||
'pos
|
||||
'neg)
|
||||
'one #:b 2 3 #:d 4))
|
||||
|
||||
(context-test '("the b argument of")
|
||||
'((contract (->i ([a integer?] #:b [b integer?]) ([c integer?] #:d [d integer?]) any)
|
||||
(λ (a #:b b [c 1] #:d [d 1]) 1)
|
||||
'pos
|
||||
'neg)
|
||||
1 #:b 'two 3 #:d 4))
|
||||
|
||||
(context-test '("the c argument of")
|
||||
'((contract (->i ([a integer?] #:b [b integer?]) ([c integer?] #:d [d integer?]) any)
|
||||
(λ (a #:b b [c 1] #:d [d 1]) 1)
|
||||
'pos
|
||||
'neg)
|
||||
1 #:b 2 'three #:d 4))
|
||||
|
||||
(context-test '("the d argument of")
|
||||
'((contract (->i ([a integer?] #:b [b integer?]) ([c integer?] #:d [d integer?]) any)
|
||||
(λ (a #:b b [c 1] #:d [d 1]) 1)
|
||||
'pos
|
||||
'neg)
|
||||
1 #:b 2 3 #:d 'four))
|
||||
|
||||
;; indy
|
||||
(ctest '("the 2nd argument of" "the x argument of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (->i ([x (-> number? boolean? integer?)] [a (x) (>=/c (x 11 'true))]) any)
|
||||
(λ (x a) x)
|
||||
'pos
|
||||
'neg)
|
||||
(λ (x y) 1) 11)))
|
||||
|
||||
(ctest '("the 2nd argument of" "the x result of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (->i () (values [x (-> number? boolean? integer?)] [a (x) (>=/c (x 11 'true))]))
|
||||
(λ () (values (λ (x y) x) 1))
|
||||
'pos
|
||||
'neg))))
|
||||
|
||||
(ctest '("the x argument of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (->i ([x () integer?]) any)
|
||||
(λ (x) x)
|
||||
'pos
|
||||
'neg)
|
||||
#f)))
|
||||
|
||||
(ctest '("the a argument of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (->i ([a integer?] [x (a) integer?]) any)
|
||||
(λ (a x) x)
|
||||
'pos
|
||||
'neg)
|
||||
#f 1)))
|
||||
|
||||
(ctest '("the 1st result of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (->i () (values [_ integer?] [_ integer?]))
|
||||
(λ () (values #f 1))
|
||||
'pos
|
||||
'neg))))
|
||||
|
||||
(ctest '("the result of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (->i () [_ integer?])
|
||||
(λ () (values #f))
|
||||
'pos
|
||||
'neg))))
|
||||
|
||||
(ctest '("the domain of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (->d ([x integer?]) [y integer?])
|
||||
(λ (x) #f)
|
||||
'pos
|
||||
'neg)
|
||||
#f)))
|
||||
|
||||
(ctest '("the range of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (->d ([x integer?]) [y integer?])
|
||||
(λ (x) #f)
|
||||
'pos
|
||||
'neg)
|
||||
1)))
|
||||
|
||||
(ctest '("the range of")
|
||||
extract-context-lines
|
||||
(λ () (letrec ([ctc (-> integer? (recursive-contract ctc))])
|
||||
(letrec ([f (λ (x) 'not-f)])
|
||||
((contract ctc f 'pos 'neg) 1)))))
|
||||
|
||||
(ctest '("the a field of")
|
||||
extract-context-lines
|
||||
(λ ()
|
||||
(struct s (a b))
|
||||
(contract (struct/dc s [a (b) (<=/c b)] [b integer?])
|
||||
(s 2 1)
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(ctest '("the a field of")
|
||||
extract-context-lines
|
||||
(λ ()
|
||||
(struct s (a b))
|
||||
(contract (struct/dc s [a (<=/c 1)] [b integer?])
|
||||
(s 2 1)
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(ctest '("an element of" "the 2nd element of")
|
||||
extract-context-lines
|
||||
(λ () (vector-ref
|
||||
(vector-ref
|
||||
(contract (vector/c (vectorof real?) (vectorof number?) (vectorof boolean?))
|
||||
(vector (vector 1) (vector 1) (vector 1))
|
||||
'pos
|
||||
'neg)
|
||||
2)
|
||||
0)))
|
||||
|
||||
(ctest '("the 0th element of")
|
||||
extract-context-lines
|
||||
(λ () (vector-ref (contract (vector/c integer?)
|
||||
(vector #f)
|
||||
'pos
|
||||
'neg)
|
||||
0)))
|
||||
|
||||
(ctest '("the 0th element of")
|
||||
extract-context-lines
|
||||
(λ () (vector-ref (contract (vector/c (-> integer? integer?))
|
||||
(vector #f)
|
||||
'pos
|
||||
'neg)
|
||||
0)))
|
||||
|
||||
(ctest '("the 0th element of")
|
||||
extract-context-lines
|
||||
(λ () (vector-ref (contract (vector/c (new-∀/c 'α))
|
||||
(vector #f)
|
||||
'pos
|
||||
'neg)
|
||||
0)))
|
||||
|
||||
(ctest '("an element of")
|
||||
extract-context-lines
|
||||
(λ () (vector-ref
|
||||
(contract (vectorof integer?)
|
||||
(vector #f)
|
||||
'pos
|
||||
'neg)
|
||||
0)))
|
||||
|
||||
(ctest '("an element of")
|
||||
extract-context-lines
|
||||
(λ () (vector-ref (contract (vectorof (-> integer? integer?))
|
||||
(vector #f)
|
||||
'pos
|
||||
'neg)
|
||||
0)))
|
||||
|
||||
(ctest '("an element of")
|
||||
extract-context-lines
|
||||
(λ () (vector-ref (contract (vectorof (new-∀/c 'α))
|
||||
(vector #f)
|
||||
'pos
|
||||
'neg)
|
||||
0)))
|
||||
|
||||
(ctest '("the keys of")
|
||||
extract-context-lines
|
||||
(λ () (contract (hash/c integer? (-> integer? integer?))
|
||||
(hash #f (λ (x) #f))
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(ctest '("the range of" "the values of")
|
||||
extract-context-lines
|
||||
(λ () ((hash-ref
|
||||
(contract (hash/c integer? (-> integer? integer?))
|
||||
(hash 0 (λ (x) #f))
|
||||
'pos
|
||||
'neg)
|
||||
0)
|
||||
1)))
|
||||
|
||||
(ctest '("an element of" "the rest argument of")
|
||||
extract-context-lines
|
||||
(λ ()
|
||||
((contract (->* () #:rest (listof number?) number?)
|
||||
+
|
||||
'pos 'neg)
|
||||
1 "a")))
|
||||
|
||||
(ctest '("the 2nd argument of")
|
||||
extract-context-lines
|
||||
(λ ()
|
||||
((contract (->* (number? number?) #:rest (listof number?) number?)
|
||||
+
|
||||
'pos 'neg)
|
||||
1 "a")))
|
||||
|
||||
(ctest '("an element of" "the rest argument of")
|
||||
extract-context-lines
|
||||
(λ ()
|
||||
((contract (->* (number?) #:rest (listof number?) number?)
|
||||
+
|
||||
'pos 'neg)
|
||||
1 "a")))
|
||||
(context-test '("the 2nd argument of" "the x argument of")
|
||||
'((contract (->i ([x (-> number? boolean? integer?)] [a (x) (>=/c (x 11 'true))]) any)
|
||||
(λ (x a) x)
|
||||
'pos
|
||||
'neg)
|
||||
(λ (x y) 1) 11))
|
||||
|
||||
(ctest '("the range of" "the 2nd case of")
|
||||
extract-context-lines
|
||||
(λ ()
|
||||
((contract (case-> (-> real? real? real?)
|
||||
(-> real? (values real? real?)))
|
||||
(case-lambda
|
||||
[(x y) 1]
|
||||
[(x) 1])
|
||||
'pos 'neg)
|
||||
1)))
|
||||
(context-test '("the 2nd argument of" "the x result of")
|
||||
'((contract (->i () (values [x (-> number? boolean? integer?)] [a (x) (>=/c (x 11 'true))]))
|
||||
(λ () (values (λ (x y) x) 1))
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(context-test '("the x argument of")
|
||||
'((contract (->i ([x () integer?]) any)
|
||||
(λ (x) x)
|
||||
'pos
|
||||
'neg)
|
||||
#f))
|
||||
|
||||
(context-test '("the a argument of")
|
||||
'((contract (->i ([a integer?] [x (a) integer?]) any)
|
||||
(λ (a x) x)
|
||||
'pos
|
||||
'neg)
|
||||
#f 1))
|
||||
|
||||
(context-test '("the 1st result of")
|
||||
'((contract (->i () (values [_ integer?] [_ integer?]))
|
||||
(λ () (values #f 1))
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(context-test '("the result of")
|
||||
'((contract (->i () [_ integer?])
|
||||
(λ () (values #f))
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(context-test '("the domain of")
|
||||
'((contract (->d ([x integer?]) [y integer?])
|
||||
(λ (x) #f)
|
||||
'pos
|
||||
'neg)
|
||||
#f))
|
||||
|
||||
(context-test '("the range of")
|
||||
'((contract (->d ([x integer?]) [y integer?])
|
||||
(λ (x) #f)
|
||||
'pos
|
||||
'neg)
|
||||
1))
|
||||
|
||||
(context-test '("the range of")
|
||||
'(letrec ([ctc (-> integer? (recursive-contract ctc))])
|
||||
(letrec ([f (λ (x) 'not-f)])
|
||||
((contract ctc f 'pos 'neg) 1))))
|
||||
|
||||
(context-test '("the a field of")
|
||||
'(let ()
|
||||
(struct s (a b))
|
||||
(contract (struct/dc s [a (b) (<=/c b)] [b integer?])
|
||||
(s 2 1)
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(context-test '("the a field of")
|
||||
'(let ()
|
||||
(struct s (a b))
|
||||
(contract (struct/dc s [a (<=/c 1)] [b integer?])
|
||||
(s 2 1)
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(context-test '("an element of" "the 2nd element of")
|
||||
'(vector-ref
|
||||
(vector-ref
|
||||
(contract (vector/c (vectorof real?) (vectorof number?) (vectorof boolean?))
|
||||
(vector (vector 1) (vector 1) (vector 1))
|
||||
'pos
|
||||
'neg)
|
||||
2)
|
||||
0))
|
||||
|
||||
(context-test '("the 0th element of")
|
||||
'(vector-ref (contract (vector/c integer?)
|
||||
(vector #f)
|
||||
'pos
|
||||
'neg)
|
||||
0))
|
||||
|
||||
(context-test '("the 0th element of")
|
||||
'(vector-ref (contract (vector/c (-> integer? integer?))
|
||||
(vector #f)
|
||||
'pos
|
||||
'neg)
|
||||
0))
|
||||
|
||||
(context-test '("the 0th element of")
|
||||
'(vector-ref (contract (vector/c (new-∀/c 'α))
|
||||
(vector #f)
|
||||
'pos
|
||||
'neg)
|
||||
0))
|
||||
|
||||
(context-test '("an element of")
|
||||
'(vector-ref
|
||||
(contract (vectorof integer?)
|
||||
(vector #f)
|
||||
'pos
|
||||
'neg)
|
||||
0))
|
||||
|
||||
(context-test '("an element of")
|
||||
'(vector-ref (contract (vectorof (-> integer? integer?))
|
||||
(vector #f)
|
||||
'pos
|
||||
'neg)
|
||||
0))
|
||||
|
||||
(context-test '("an element of")
|
||||
'(vector-ref (contract (vectorof (new-∀/c 'α))
|
||||
(vector #f)
|
||||
'pos
|
||||
'neg)
|
||||
0))
|
||||
|
||||
(context-test '("the keys of")
|
||||
'(contract (hash/c integer? (-> integer? integer?))
|
||||
(hash #f (λ (x) #f))
|
||||
'pos
|
||||
'neg))
|
||||
|
||||
(context-test '("the range of" "the values of")
|
||||
'((hash-ref
|
||||
(contract (hash/c integer? (-> integer? integer?))
|
||||
(hash 0 (λ (x) #f))
|
||||
'pos
|
||||
'neg)
|
||||
0)
|
||||
1))
|
||||
|
||||
(context-test '("an element of" "the rest argument of")
|
||||
'((contract (->* () #:rest (listof number?) number?)
|
||||
+
|
||||
'pos 'neg)
|
||||
1 "a"))
|
||||
|
||||
(context-test '("the 2nd argument of")
|
||||
'((contract (->* (number? number?) #:rest (listof number?) number?)
|
||||
+
|
||||
'pos 'neg)
|
||||
1 "a"))
|
||||
|
||||
(context-test '("an element of" "the rest argument of")
|
||||
'((contract (->* (number?) #:rest (listof number?) number?)
|
||||
+
|
||||
'pos 'neg)
|
||||
1 "a"))
|
||||
|
||||
(context-test '("the range of" "the 2nd case of")
|
||||
'((contract (case-> (-> real? real? real?)
|
||||
(-> real? (values real? real?)))
|
||||
(case-lambda
|
||||
[(x y) 1]
|
||||
[(x) 1])
|
||||
'pos 'neg)
|
||||
1))
|
||||
|
||||
(context-test '("the domain of" "the 2nd case of")
|
||||
'((contract (case-> (-> real? real? real?)
|
||||
(-> real? (values real? real?)))
|
||||
(case-lambda
|
||||
[(x y) 1]
|
||||
[(x) 1])
|
||||
'pos 'neg)
|
||||
#f))
|
||||
|
||||
(ctest '("the domain of" "the 2nd case of")
|
||||
extract-context-lines
|
||||
(λ ()
|
||||
((contract (case-> (-> real? real? real?)
|
||||
(-> real? (values real? real?)))
|
||||
(case-lambda
|
||||
[(x y) 1]
|
||||
[(x) 1])
|
||||
'pos 'neg)
|
||||
#f)))
|
||||
|
||||
|
||||
(let* ([blame-pos (contract-eval '(make-blame (srcloc #f #f #f #f #f) #f (λ () 'integer?) 'positive 'negative #t))]
|
||||
[blame-neg (contract-eval `(blame-swap ,blame-pos))])
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user