8ece97219a
The basic problem is that (with-check-info* '() (lambda () ...whatever...)) can, in some cases, double the information that is recorded in a failed test case. Probably the right thing is to use a parameter or something instead of using continuation marks directly.
69 lines
2.3 KiB
Racket
69 lines
2.3 KiB
Racket
#lang racket/base
|
|
(require racket/contract
|
|
"location.rkt"
|
|
(for-syntax racket/base
|
|
unstable/syntax))
|
|
|
|
;; Structures --------------------------------------------------
|
|
|
|
;; struct check-info : symbol any
|
|
(define-struct check-info (name value))
|
|
|
|
(provide/contract
|
|
[struct check-info ([name symbol?]
|
|
[value any/c])]
|
|
[check-info-mark symbol?]
|
|
[check-info-stack (continuation-mark-set? . -> . (listof check-info?))]
|
|
[with-check-info* ((listof check-info?) (-> any) . -> . any)])
|
|
(provide with-check-info)
|
|
|
|
;; Infrastructure ----------------------------------------------
|
|
|
|
;; The continuation mark under which all check-info is keyed
|
|
(define check-info-mark (gensym 'rackunit))
|
|
|
|
;; (continuation-mark-set -> (listof check-info))
|
|
(define (check-info-stack marks)
|
|
(let ([ht (make-hash)])
|
|
(for ([x (in-list (apply append (continuation-mark-set->list marks check-info-mark)))]
|
|
[i (in-naturals)])
|
|
(hash-set! ht (check-info-name x) (cons i x)))
|
|
(map cdr (sort (hash-map ht (λ (k v) v)) < #:key car))))
|
|
|
|
;; with-check-info* : (list-of check-info) thunk -> any
|
|
(define (with-check-info* info thunk)
|
|
(define current-marks
|
|
(continuation-mark-set-first #f check-info-mark))
|
|
(with-continuation-mark
|
|
check-info-mark
|
|
(append (if current-marks current-marks null) info)
|
|
(thunk)))
|
|
|
|
(define-syntax with-check-info
|
|
(syntax-rules ()
|
|
[(_ ((name val) ...) body ...)
|
|
(with-check-info*
|
|
(list (make-check-info name val) ...)
|
|
(lambda () body ...))]))
|
|
|
|
(define-syntax (define-check-type stx)
|
|
(syntax-case stx ()
|
|
[(_ id contract)
|
|
(with-syntax
|
|
([make-check-id (format-id #'id "make-check-~a" #'id)]
|
|
[check-id? (format-id #'id "check-~a?" #'id)])
|
|
(syntax/loc stx
|
|
(begin (define (make-check-id a) (make-check-info 'id a))
|
|
(define (check-id? info) (eq? (check-info-name info) 'id))
|
|
(provide/contract
|
|
[make-check-id (contract . -> . check-info?)]
|
|
[check-id? (check-info? . -> . boolean?)]))))]))
|
|
|
|
(define-check-type name any/c)
|
|
(define-check-type params any/c)
|
|
(define-check-type location location/c)
|
|
(define-check-type expression any/c)
|
|
(define-check-type message any/c)
|
|
(define-check-type actual any/c)
|
|
(define-check-type expected any/c)
|