(module assert-util mzscheme
(require (lib "plt-match.ss")
"assert-base.ss")
(provide syntax->location-values
location->string
get-assertion-info
get-assertion-name
get-assertion-params
get-assertion-location
get-assertion-expression
get-assertion-message)
(define (syntax->location-values stx)
(list (syntax-source stx)
(syntax-line stx)
(syntax-column stx)
(syntax-position stx)
(syntax-span stx)
(syntax-source-module stx)))
(define location->string
(let ((source->string
(lambda (source)
(cond
((string? source) source)
((not source) "unknown")
(else (let ((port (open-output-string)))
(display source port)
(get-output-string port)))))))
(match-lambda
((list source line column position span source-module)
(string-append (source->string source)
":"
(number->string line)
":"
(number->string column))))))
(define (get-assertion-info name stack)
(let loop ((stack stack))
(if (null? stack)
#f
(let ((head (car stack)))
(if (eq? (assertion-info-name head) name)
(assertion-info-value head)
(loop (cdr stack)))))))
(define (make-assertion-info-getter pred)
(lambda (stack)
(let loop ((stack stack))
(if (null? stack)
#f
(let ((head (car stack)))
(if (pred head)
(assertion-info-value head)
(loop (cdr stack))))))))
(define get-assertion-name
(make-assertion-info-getter assertion-name?))
(define get-assertion-params
(make-assertion-info-getter assertion-params?))
(define get-assertion-location
(make-assertion-info-getter assertion-location?))
(define get-assertion-expression
(make-assertion-info-getter assertion-expression?))
(define get-assertion-message
(make-assertion-info-getter assertion-message?))
)