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

(module error-utils

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

  (import
    scheme
    chicken
    (only ports with-output-to-port)
    (only format-compiler-base format))

  (require-library ports format-compiler-base)

;; 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))
    (or (and msg (display msg port))
        (and 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 (errorf . args)
  (let-values (((loc fmt args) (error-params args)))
    (if (not fmt) (apply error args)
      (error loc (apply format #f fmt args)) ) ) )

) ;module error-utils