(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)
  
  ;; syntax->source-representation : syntax -> syntax
  (define (syntax->location-representative stx)
    (datum->syntax-object #f 'location-representative stx #f))
  
  ;; syntax->location-string : stx -> string
  (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) "?"))))))

  ;; get-assertion-info : symbol (list-of assertion-info) -> any
  ;;
  ;; Find the most recent assertion information on the stack
  ;; with the given name.  Returns the value of the
  ;; assertion information of #f if not found.
  (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?))
  )