From 2e195935cfc753c152a5aea5502132d108954977 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Fri, 26 Apr 2013 19:11:34 -0500
Subject: [PATCH] make opt/c contract follow the blame-add-context protocol

---
 collects/racket/contract/private/misc.rkt     |  30 +-
 collects/racket/contract/private/opt-guts.rkt |  15 +-
 collects/racket/contract/private/opters.rkt   |  74 +-
 .../racket/contract/private/struct-dc.rkt     |  10 +-
 collects/tests/racket/contract-test.rktl      | 764 +++++++++---------
 5 files changed, 461 insertions(+), 432 deletions(-)

diff --git a/collects/racket/contract/private/misc.rkt b/collects/racket/contract/private/misc.rkt
index b395db5f9d..ba1545941a 100644
--- a/collects/racket/contract/private/misc.rkt
+++ b/collects/racket/contract/private/misc.rkt
@@ -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)
diff --git a/collects/racket/contract/private/opt-guts.rkt b/collects/racket/contract/private/opt-guts.rkt
index 924bc70d68..35e9566484 100644
--- a/collects/racket/contract/private/opt-guts.rkt
+++ b/collects/racket/contract/private/opt-guts.rkt
@@ -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
diff --git a/collects/racket/contract/private/opters.rkt b/collects/racket/contract/private/opters.rkt
index b004964319..dd1645a353 100644
--- a/collects/racket/contract/private/opters.rkt
+++ b/collects/racket/contract/private/opters.rkt
@@ -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)
diff --git a/collects/racket/contract/private/struct-dc.rkt b/collects/racket/contract/private/struct-dc.rkt
index a2af9a0bdc..9b77329e85 100644
--- a/collects/racket/contract/private/struct-dc.rkt
+++ b/collects/racket/contract/private/struct-dc.rkt
@@ -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")
diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl
index 390bdd2846..f6ea7a7374 100644
--- a/collects/tests/racket/contract-test.rktl
+++ b/collects/tests/racket/contract-test.rktl
@@ -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))])