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

(module error-utils

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

(import scheme)

(import chicken)

(import (only extras format) )
(require-library extras)

(import (only data-structures chop ->string) )
(require-library data-structures)

;;;

;; Print error message but don't throw an exception
;;
(define (error/no-raise . args)
  (let* ((len (length args) )
         (argls (and (<= 2 len) (chop args (fx- len 1))) )
         (args (if argls (car argls) args) )
         (port (and argls (caadr argls)) )
         (args (if (port? port) args (append args (if port `(,port) '()))) )
         (port (if (port? port) port (current-error-port)) ) )
    (*error/no-raise args port) ) )

;; 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)))
  (let-values (((loc msg args) (error-params args)))
    (newline port)
    (display
      (string-append
        "Error"
        (if (or loc msg) ": " "")
        (if (and loc msg) (string-append "(" (->string loc) ")") "")
        " "
        (or (and msg (->string msg)) (and loc (->string 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) ) )

;;
(define (errorf . args)
  (*errorf error args) )

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

;; Format procedure for error
;;
(define error-format-procedure
  (make-parameter
    format
    (lambda (x)
      (if (procedure? x)
        x
        (begin
          (warning 'error-format-procedure "invalid procedure" x)
          (error-format-procedure) ) ) ) ) )

;;;

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

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

) ;module error-utils