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

Add `tech-equal?'.

Browse Source 
This refuses to work on inexact numbers and procedures.  Use it in
`check-expect' & friends.
This commit is contained in:
Mike Sperber 2010-10-15 15:26:24 +02:00
parent 1d0ebeae62
commit 39541c51b5
6 changed files with 51 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/deinprogramm/DMdA.rkt
View File

@ -16,7 +16,7 @@
(require deinprogramm/define-record-procedures)
(require (only-in lang/private/teachprims define-teach beginner-equal? beginner-equal~?))
(require (only-in lang/private/teachprims define-teach teach-equal? beginner-equal~?))
(require (for-syntax deinprogramm/syntax-checkers))
@ -1078,7 +1078,7 @@
#t))))))
(define (expect v1 v2)
(quickcheck:property () (beginner-equal? v1 v2)))
(quickcheck:property () (teach-equal? v1 v2)))
(define (ensure-real who n val)
(unless (real? val)
@ -1103,7 +1103,7 @@
(define (expect-member-of val . candidates)
(quickcheck:property ()
(ormap (lambda (cand)
(beginner-equal? val cand))
(teach-equal? val cand))
candidates)))
(define property (signature (predicate (lambda (x)

4
collects/deinprogramm/signature/signature-syntax.rkt
View File

@ -12,7 +12,7 @@
(for-syntax scheme/base)
(for-syntax syntax/stx)
(for-syntax stepper/private/shared)
(only-in lang/private/teachprims beginner-equal?))
(only-in lang/private/teachprims teach-equal?))
(define-for-syntax (phase-lift stx)
(with-syntax ((?stx stx))
@ -50,7 +50,7 @@
(syntax->list #'((?temp ?exp) ...)))))
#'(let ((?temp ?exp) ...)
?check ...
(make-case-signature '?name (list ?temp ...) beginner-equal? ?stx)))))
(make-case-signature '?name (list ?temp ...) teach-equal? ?stx)))))
((predicate ?exp)
(with-syntax ((?stx (phase-lift stx))
(?name name))

4
collects/lang/private/signature-syntax.rkt
View File

@ -11,7 +11,7 @@
(for-syntax scheme/base)
(for-syntax syntax/stx)
(for-syntax stepper/private/shared)
(only-in lang/private/teachprims beginner-equal?)
(only-in lang/private/teachprims teach-equal?)
(for-syntax "firstorder.rkt"))
(define-for-syntax (phase-lift stx)
@ -50,7 +50,7 @@
(syntax->list #'((?temp ?exp) ...)))))
#'(let ((?temp ?exp) ...)
?check ...
(make-case-signature '?name (list ?temp ...) beginner-equal? ?stx)))))
(make-case-signature '?name (list ?temp ...) teach-equal? ?stx)))))
((predicate ?exp)
(with-syntax ((?stx (phase-lift stx))
(?name name))

6
collects/lang/private/teach.rkt
View File

@ -52,7 +52,7 @@
scheme/class
"../posn.rkt"
(only lang/private/teachprims
beginner-equal? beginner-equal~?
beginner-equal? beginner-equal~? teach-equal?
advanced-cons advanced-list*))
(require-for-syntax "teachhelp.ss"
"teach-shared.ss"
@ -3003,7 +3003,7 @@
#t))))))
(define (expect v1 v2)
(quickcheck:property () (beginner-equal? v1 v2)))
(quickcheck:property () (teach-equal? v1 v2)))
(define (ensure-real who n val)
(unless (real? val)
@ -3028,7 +3028,7 @@
(define (expect-member-of val . candidates)
(quickcheck:property ()
(ormap (lambda (cand)
(beginner-equal? val cand))
(teach-equal? val cand))
candidates)))
(define Property (signature (predicate (lambda (x)

43
collects/lang/private/teachprims.rkt
View File

@ -242,7 +242,7 @@ namespace.
(define-teach beginner exit
(lambda () (exit)))
(define (tequal? a b epsilon)
(define (tequal? x y epsilon)
(let* ([ht (make-hash)] ;; make-hash
[union-find (lambda (a)
(let loop ([prev a]
@ -264,15 +264,49 @@ namespace.
#t
(begin
(hash-set! ht b a)
#f))))])
(let ? ([a a][b b])
#f))))]
[fail (lambda (fmt arg)
(raise (make-exn:fail:contract (if (or (eq? arg x)
(eq? arg y))
(format fmt arg)
(format "~a (originally comparing ~e and ~e)" (format fmt arg) x y))
(current-continuation-marks))))])
(let ? ([a x][b y])
(cond
[(real? a)
(and (real? b)
(beginner-=~ a b epsilon))]
[(procedure? a)
(fail "first argument of equality cannot be a procedure, given ~e" a)]
[(procedure? b)
(fail "second argument of equality cannot be a procedure, given ~e" b)]
[(union-equal!? a b) #t]
[else (equal?/recur a b ?)]))))
(define (teach-equal? x y)
(define (fail fmt arg)
(raise (make-exn:fail:contract (if (or (eq? arg x)
(eq? arg y))
(format fmt arg)
(format "~a (originally comparing ~e and ~e)" (format fmt arg) x y))
(current-continuation-marks))))
(let recur ([a x] [b y])
(cond
[(procedure? a)
(fail "first argument of equality cannot be a procedure, given ~e" a)]
[(procedure? b)
(fail "second argument of equality cannot be a procedure, given ~e" b)]
[(and (number? a)
(inexact? a))
(fail "first argument of equality cannot be an inexact number, given ~e" a)]
[(and (number? b)
(inexact? b))
(fail "first argument of equality cannot be an inexact number, given ~e" b)]
[else
(equal?/recur a b recur)])))
(define-teach beginner equal?
(lambda (a b)
(equal? a b)))
@ -423,7 +457,8 @@ namespace.
advanced-make-immutable-hash
advanced-make-immutable-hasheq
advanced-make-immutable-hasheqv
cyclic-list?)
cyclic-list?
teach-equal?)
;; -----------------------------------------------------------------------------
;; auxiliary stuff, ignore

4
collects/test-engine/racket-tests.rkt
View File

@ -156,7 +156,7 @@
actual INEXACT-NUMBERS-FMT #t)
(error-check (lambda (v) (not (procedure? v))) actual FUNCTION-FMT #f)
(send (send test-engine get-info) add-check)
(run-and-check (lambda (v1 v2 _) (beginner-equal? v1 v2))
(run-and-check (lambda (v1 v2 _) (teach-equal? v1 v2))
(lambda (src format v1 v2 _) (make-unequal src format v1 v2))
test actual #f src test-engine 'check-expect))
@ -247,7 +247,7 @@
(define (check-member-of-values-expected test first-actual actuals src test-engine)
(error-check (lambda (v) (not (procedure? v))) first-actual CHECK-MEMBER-OF-FUNCTION-FMT #f)
(send (send test-engine get-info) add-check)
(run-and-check (lambda (v2 v1 _) (memf (lambda (i) (beginner-equal? v1 i)) v2))
(run-and-check (lambda (v2 v1 _) (memf (lambda (i) (teach-equal? v1 i)) v2))
(lambda (src format v1 v2 _) (make-not-mem src format v1 v2))
test (cons first-actual actuals) #f src test-engine 'check-member-of))