(module assert-util mzscheme
(require "assert-base.ss")
(provide syntax->location-representative
syntax->location-string
get-assertion-info
get-assertion-name
get-assertion-params
get-assertion-location-representative
get-assertion-expression
get-assertion-message)
(define (syntax->location-representative stx)
(datum->syntax-object #f 'location-representative stx #f))
(define syntax->location-string
(let ((source->string
(lambda (source)
(cond
((string? source) source)
((path? source) (path->string source))
((not source) "unknown")
(else (let ((port (open-output-string)))
(display source port)
(get-output-string port)))))))
(lambda (stx)
(string-append (source->string (syntax-source stx))
":"
(let ((line (syntax-line stx)))
(if line (number->string line) "?"))
":"
(let ((column (syntax-column stx)))
(if column (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-representative
(make-assertion-info-getter assertion-location-representative?))
(define get-assertion-expression
(make-assertion-info-getter assertion-expression?))
(define get-assertion-message
(make-assertion-info-getter assertion-message?))
)