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

(module error-utils

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

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

;;;

;; Return warning message printer
;;
(define ((warning-on #!optional (port (current-output-port))) . rest)
  ((error-format-procedure) port "Warning: ")
  (if (null? rest) ((error-format-procedure) port "~%")
      (for-each (lambda (x) ((error-format-procedure) port "~S~%" x)) rest)) )

;; 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 (sub1 len))))
         (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