;;;; error-utils.scm
;;;; Kon Lovett, Aug '10

(module error-utils

  (;export
    *error/no-raise
    error/no-raise
    error-format-procedure
    errorf)

  (import
    scheme
    chicken
    (only ports with-output-to-port)
    (only extras format)
    (only type-checks check-procedure))

  (require-library ports extras type-checks)

  (use variable-item)

;; Parse error-style argument list into 3 values

(define (error-params args)
  (let* ((loc (and (not (null? args)) (symbol? (car args)) (car args)) )
         (msg (if (not loc) (and (not (null? args)) (string? (car args)) (car args))
                (and (not (null? (cdr args))) (string? (cadr args)) (cadr args))) )
         (args (if (and loc msg) (cddr args) (if (or loc msg) (cdr args) args)) ) )
    (values loc msg args) ) )

;; Print error-style message to port

; unlike 'error' will print arguments when loc but no msg

(define (*error/no-raise args #!optional (port (current-error-port)))
  (newline port)
  (display "Error" port)
  (let-values (((loc msg args) (error-params args)))
    (when (or loc msg) (display ": " port))
    (when (and loc msg) (display #\( port) (display loc port) (display ") " port))
    (if msg
       (display msg port)
       (when loc (display loc port)))
    (unless (null? args)
      (if (null? (cdr args))
          (begin (display ": " port) (write (car args) port))
          (for-each (lambda (arg) (newline port) (write arg port)) args) ) ) )
  (newline port) )

;; Print error message but don't throw an exception

(define (error/no-raise . args) (*error/no-raise args))

;; Format version of error

(define-checked-variable error-format-procedure format procedure)

(define (errorf . args)
  (let-values (((loc fmt fmtargs) (error-params args)))
    (if (not fmt) (apply error args)
      (error loc (apply (error-format-procedure) #f fmt fmtargs)) ) ) )

) ;module error-utils