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

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

@ -5,6 +5,17 @@
;; See also tests/syntax/contract/test-errors.rkt. ;; 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) (define-syntax (m-str stx)
(syntax-parse stx (syntax-parse stx
[(_ e) [(_ e)
@ -12,7 +23,7 @@
#'e.c])) #'e.c]))
(check-equal? (m-str "string") "string") (check-equal? (m-str "string") "string")
(check-exn #rx"m-str: contract violation.*expected: string?" (check-ctc-exn #rx"m-str: contract violation.*expected: string?" #t
(lambda () (m-str 'not-a-string))) (lambda () (m-str 'not-a-string)))
(define-syntax (m-arr stx) (define-syntax (m-arr stx)
@ -22,7 +33,7 @@
#'(f.c arg)])) #'(f.c arg)]))
(check-equal? (m-arr string->symbol "a") 'a) (check-equal? (m-arr string->symbol "a") 'a)
(check-exn #rx"m-arr: broke its own contract.*promised: string?" (check-ctc-exn #rx"m-arr: contract violation.*expected: string?" #f
(lambda () (m-arr string->symbol 'a))) (lambda () (m-arr string->symbol 'a)))
(define-syntax (m-app stx) (define-syntax (m-app stx)
@ -38,7 +49,7 @@
"def") "def")
"abcdef") "abcdef")
(check-exn #rx"m-app: broke its own contract.*promised: string?" (check-ctc-exn #rx"m-app: contract violation.*expected: string?" #f
;; Yes, it's m-app's fault, because it didn't protect ;; Yes, it's m-app's fault, because it didn't protect
;; f from bad arguments. ;; f from bad arguments.
(lambda () (lambda ()
@ -58,12 +69,12 @@
(lambda (s) (lambda (t) (string-append s t)))) (lambda (s) (lambda (t) (string-append s t))))
"abc") "def") "abc") "def")
"abcdef") "abcdef")
(check-exn #rx"m-res: contract violation.*expected: string?" (check-ctc-exn #rx"m-res: contract violation.*expected: string?" #t
(lambda () (lambda ()
(((m-res (-> string? (-> string? string?)) (((m-res (-> string? (-> string? string?))
(lambda (s) (lambda (t) (string-append s t)))) (lambda (s) (lambda (t) (string-append s t))))
'abc) "def"))) 'abc) "def")))
(check-exn #rx"m-res: contract violation.*expected: string?" (check-ctc-exn #rx"m-res: contract violation.*expected: string?" #t
(lambda () (lambda ()
(((m-res (-> string? (-> string? string?)) (((m-res (-> string? (-> string? string?))
(lambda (s) (lambda (t) (string-append s t)))) (lambda (s) (lambda (t) (string-append s t))))

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

@ -3,13 +3,24 @@
racket/contract racket/contract
rackunit) 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) (define-syntax (m-str stx)
(syntax-case stx () (syntax-case stx ()
[(_ e) [(_ e)
(wrap-expr/c #'string? #'e #:context stx)])) (wrap-expr/c #'string? #'e #:context stx)]))
(check-equal? (m-str "string") "string") (check-equal? (m-str "string") "string")
(check-exn #rx"m-str: contract violation.*expected: string?" (check-ctc-exn #rx"m-str: contract violation.*expected: string?" #t
(lambda () (m-str 'not-a-string))) (lambda () (m-str 'not-a-string)))
(define-syntax (m-arr stx) (define-syntax (m-arr stx)
@ -19,7 +30,7 @@
#'(f* arg))])) #'(f* arg))]))
(check-equal? (m-arr string->symbol "a") 'a) (check-equal? (m-arr string->symbol "a") 'a)
(check-exn #rx"m-arr: broke its own contract.*promised: string?" (check-ctc-exn #rx"m-arr: contract violation.*expected: string?" #f
(lambda () (m-arr string->symbol 'a))) (lambda () (m-arr string->symbol 'a)))
(define-syntax (m-app stx) (define-syntax (m-app stx)
@ -35,7 +46,7 @@
"def") "def")
"abcdef") "abcdef")
(check-exn #rx"m-app: broke its own contract.*promised: string?" (check-ctc-exn #rx"m-app: contract violation.*expected: string?" #f
;; Yes, it's m-app's fault, because it didn't protect ;; Yes, it's m-app's fault, because it didn't protect
;; f from bad arguments. ;; f from bad arguments.
(lambda () (lambda ()
@ -54,12 +65,12 @@
(-> string? (-> string? string?))) (-> string? (-> string? string?)))
"abc") "def") "abc") "def")
"abcdef") "abcdef")
(check-exn #rx"m-res: contract violation.*expected: string?" (check-ctc-exn #rx"m-res: contract violation.*expected: string?" #t
(lambda () (lambda ()
(((m-res (lambda (s) (lambda (t) (string-append s t))) (((m-res (lambda (s) (lambda (t) (string-append s t)))
(-> string? (-> string? string?))) (-> string? (-> string? string?)))
'abc) "def"))) 'abc) "def")))
(check-exn #rx"m-res: contract violation.*expected: string?" (check-ctc-exn #rx"m-res: contract violation.*expected: string?" #t
(lambda () (lambda ()
(((m-res (lambda (s) (lambda (t) (string-append s t))) (((m-res (lambda (s) (lambda (t) (string-append s t)))
(-> string? (-> string? string?))) (-> string? (-> string? string?)))
@ -72,10 +83,11 @@
[(_ ing) [(_ ing)
(with-syntax ([ing.c (wrap-expr/c #'fruit/c #'ing #:context stx)]) (with-syntax ([ing.c (wrap-expr/c #'fruit/c #'ing #:context stx)])
#'(format "icy blended ~s" ing.c))])) #'(format "icy blended ~s" ing.c))]))
(check-exn (check-ctc-exn
(regexp (regexp
(string-append (string-append
"^smoothie: contract violation.*" "^smoothie: contract violation.*"
"given: \"kale\".*" "given: \"kale\".*"
"in:.*\\(and/c string[?] \\(or/c \"orange\" \"peach\" \"strawberry\"\\)\\).*")) "in:.*\\(and/c string[?] \\(or/c \"orange\" \"peach\" \"strawberry\"\\)\\).*"))
#t
(lambda () (smoothie "kale")))) (lambda () (smoothie "kale"))))