;;;; error-utils.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '18
;;;; Kon Lovett, may '17
;;;; Kon Lovett, Aug '10

(module error-utils

(;export
  ;
  error-format-procedure
  ;
  errorf
  ;
  error-print *error-print
  errorf-print)

(import scheme
  (chicken base)
  (chicken fixnum)
  (only (chicken format) format)
  (only (chicken string) ->string string-intersperse)
  (only (srfi 1) append!) )

;;;

;; Print error message but don't throw an exception
;;
(define (error-print . args)
  (let-values (((port args) (error-port-args args)))
    (*error-print args port) ) )

;; Print error-style message to port
;; unlike 'error' will print arguments when loc but no msg
;;
(define (*error-print args #!optional (port (current-error-port)))
  (let-values (((loc msg args) (error-params args)))
    (let (
      (errmsg
        (string-append
          "\n"
          "Error" (if (or loc msg) ": " "")
          (if (and loc msg) (string-append "(" (->string loc) ")" " ") "")
          (or (and msg (->string msg)) (and loc (->string loc)) "")
          (cond
            ((null? args)
              "" )
            ((null? (cdr args))
              (string-append ": " (->sexpr-string (car args))) )
            (else
              ;leading empty string so leading newline
              (string-intersperse (append '("") (map ->sexpr-string args)) "\n") ) )
          "\n" )))
      (display errmsg port) ) ) )

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

;;
(define (errorf-print . args)
  (let-values (((port args) (error-port-args args)))
    (*errorf port error-print 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 port proc args)
  (let ((portarg (if port `(,port) '())))
    (let-values (((loc fmt fmtargs) (error-params args)))
      (let (
        (err-args
          (if (not fmt)
            (append args portarg)
            (let ((msg (apply (error-format-procedure) #f fmt fmtargs)))
              (if loc
                (append! `(,loc ,msg) portarg)
                (append! `(,msg) portarg) ) ) ) ) )
        (apply proc err-args) ) ) ) )

;;
(define (->sexpr-string obj)
  ((error-format-procedure) #f "~S" obj) )

;; Parse error style argument list into (values loc msg args)
;;
(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
      (cond
        ((and loc msg)  (cddr args) )
        ((or loc msg)   (cdr args) )
        (else           args ) ) ) )
    (values loc msg args) ) )

;; Parse error-print style argument list into (values port args)
;;
(define (error-port-args 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)) ) )
    (values port args) ) )

) ;module error-utils