(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)
  
  ;; syntax->location-values : syntax -> list
  (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)))

  ;; location->string : list -> string
  (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))))))

  ;; 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
    (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?))
  )