suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

update expr/c, wrap-expr/c tests for contract message change

Browse Source
This commit is contained in:
Ryan Culpepper 2019-02-19 13:53:27 +01:00
parent 166c97ecea
commit abb1ce71cc
2 changed files with 68 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
pkgs/racket-test/tests/stxparse/test-exprc.rkt
View File

@ -5,6 +5,17 @@
;; See also tests/syntax/contract/test-errors.rkt.
(define (check-ctc-exn rx swapped? thunk)
((with-handlers ([(lambda (e) #t)
(lambda (e)
(check-pred exn:fail:contract:blame? e)
(define b (exn:fail:contract:blame-object e))
(check-equal? (blame-swapped? b) swapped?)
(check-regexp-match rx (exn-message e))
void)])
(thunk)
(lambda () (fail "no exn raised")))))
(define-syntax (m-str stx)
(syntax-parse stx
[(_ e)
@ -12,8 +23,8 @@
#'e.c]))
(check-equal? (m-str "string") "string")
(check-exn #rx"m-str: contract violation.*expected: string?"
(lambda () (m-str 'not-a-string)))
(check-ctc-exn #rx"m-str: contract violation.*expected: string?" #t
(lambda () (m-str 'not-a-string)))
(define-syntax (m-arr stx)
(syntax-parse stx
@ -22,8 +33,8 @@
#'(f.c arg)]))
(check-equal? (m-arr string->symbol "a") 'a)
(check-exn #rx"m-arr: broke its own contract.*promised: string?"
(lambda () (m-arr string->symbol 'a)))
(check-ctc-exn #rx"m-arr: contract violation.*expected: string?" #f
(lambda () (m-arr string->symbol 'a)))
(define-syntax (m-app stx)
(syntax-parse stx
@ -38,14 +49,14 @@
"def")
"abcdef")
(check-exn #rx"m-app: broke its own contract.*promised: string?"
;; Yes, it's m-app's fault, because it didn't protect
;; f from bad arguments.
(lambda ()
((m-app (-> string? (-> string? string?))
(lambda (s) (lambda (t) (string-append s t)))
"abc")
'def)))
(check-ctc-exn #rx"m-app: contract violation.*expected: string?" #f
;; Yes, it's m-app's fault, because it didn't protect
;; f from bad arguments.
(lambda ()
((m-app (-> string? (-> string? string?))
(lambda (s) (lambda (t) (string-append s t)))
"abc")
'def)))
(define-syntax (m-res stx)
(syntax-parse stx
@ -58,13 +69,13 @@
(lambda (s) (lambda (t) (string-append s t))))
"abc") "def")
"abcdef")
(check-exn #rx"m-res: contract violation.*expected: string?"
(lambda ()
(((m-res (-> string? (-> string? string?))
(lambda (s) (lambda (t) (string-append s t))))
'abc) "def")))
(check-exn #rx"m-res: contract violation.*expected: string?"
(lambda ()
(((m-res (-> string? (-> string? string?))
(lambda (s) (lambda (t) (string-append s t))))
"abc") 'def)))
(check-ctc-exn #rx"m-res: contract violation.*expected: string?" #t
(lambda ()
(((m-res (-> string? (-> string? string?))
(lambda (s) (lambda (t) (string-append s t))))
'abc) "def")))
(check-ctc-exn #rx"m-res: contract violation.*expected: string?" #t
(lambda ()
(((m-res (-> string? (-> string? string?))
(lambda (s) (lambda (t) (string-append s t))))
"abc") 'def)))

58
pkgs/racket-test/tests/syntax/contract/test-errors.rkt
View File

@ -3,14 +3,25 @@
racket/contract
rackunit)
(define (check-ctc-exn rx swapped? thunk)
((with-handlers ([(lambda (e) #t)
(lambda (e)
(check-pred exn:fail:contract:blame? e)
(define b (exn:fail:contract:blame-object e))
(check-equal? (blame-swapped? b) swapped?)
(check-regexp-match rx (exn-message e))
void)])
(thunk)
(lambda () (fail "no exn raised")))))
(define-syntax (m-str stx)
(syntax-case stx ()
[(_ e)
(wrap-expr/c #'string? #'e #:context stx)]))
(check-equal? (m-str "string") "string")
(check-exn #rx"m-str: contract violation.*expected: string?"
(lambda () (m-str 'not-a-string)))
(check-ctc-exn #rx"m-str: contract violation.*expected: string?" #t
(lambda () (m-str 'not-a-string)))
(define-syntax (m-arr stx)
(syntax-case stx ()
@ -19,8 +30,8 @@
#'(f* arg))]))
(check-equal? (m-arr string->symbol "a") 'a)
(check-exn #rx"m-arr: broke its own contract.*promised: string?"
(lambda () (m-arr string->symbol 'a)))
(check-ctc-exn #rx"m-arr: contract violation.*expected: string?" #f
(lambda () (m-arr string->symbol 'a)))
(define-syntax (m-app stx)
(syntax-case stx ()
@ -35,14 +46,14 @@
"def")
"abcdef")
(check-exn #rx"m-app: broke its own contract.*promised: string?"
;; Yes, it's m-app's fault, because it didn't protect
;; f from bad arguments.
(lambda ()
((m-app (lambda (s) (lambda (t) (string-append s t)))
(-> string? (-> string? string?))
"abc")
'def)))
(check-ctc-exn #rx"m-app: contract violation.*expected: string?" #f
;; Yes, it's m-app's fault, because it didn't protect
;; f from bad arguments.
(lambda ()
((m-app (lambda (s) (lambda (t) (string-append s t)))
(-> string? (-> string? string?))
"abc")
'def)))
(define-syntax (m-res stx)
(syntax-case stx ()
@ -54,16 +65,16 @@
(-> string? (-> string? string?)))
"abc") "def")
"abcdef")
(check-exn #rx"m-res: contract violation.*expected: string?"
(lambda ()
(((m-res (lambda (s) (lambda (t) (string-append s t)))
(-> string? (-> string? string?)))
'abc) "def")))
(check-exn #rx"m-res: contract violation.*expected: string?"
(lambda ()
(((m-res (lambda (s) (lambda (t) (string-append s t)))
(-> string? (-> string? string?)))
"abc") 'def)))
(check-ctc-exn #rx"m-res: contract violation.*expected: string?" #t
(lambda ()
(((m-res (lambda (s) (lambda (t) (string-append s t)))
(-> string? (-> string? string?)))
'abc) "def")))
(check-ctc-exn #rx"m-res: contract violation.*expected: string?" #t
(lambda ()
(((m-res (lambda (s) (lambda (t) (string-append s t)))
(-> string? (-> string? string?)))
"abc") 'def)))
(let ()
(define fruit/c (and/c string? (or/c "orange" "peach" "strawberry")))
@ -72,10 +83,11 @@
[(_ ing)
(with-syntax ([ing.c (wrap-expr/c #'fruit/c #'ing #:context stx)])
#'(format "icy blended ~s" ing.c))]))
(check-exn
(check-ctc-exn
(regexp
(string-append
"^smoothie: contract violation.*"
"given: \"kale\".*"
"in:.*\\(and/c string[?] \\(or/c \"orange\" \"peach\" \"strawberry\"\\)\\).*"))
#t
(lambda () (smoothie "kale"))))