;;;; exn-condition.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '18

(declare
  (bound-to-procedure ##sys#really-print-call-chain) )

(module exn-condition

(;export
  ;
  exn-condition?
  exn-location
  exn-message
  exn-arguments
  exn-call-chain
  exn-errno
  ;
  make-exn-condition make-exn-condition*
  make-exn-condition+
  ;
  write-exn-condition)

(import scheme
  (chicken base)
  (chicken condition)
  (chicken type)
  (only (srfi 1) append!)
  condition-utils-support
  condition-utils)

(: make-exn-condition (#!optional (or false symbol) (or false string) (or false list)
                                  (or false list) (or false fixnum) -> condition))
(: make-exn-condition* (#!key (location symbol)
                              (message string)
                              (arguments list)
                              (call-chain list)
                              (errno fixnum) -> condition))

(: make-exn-condition+ ((or false symbol) (or false string) (or false list) #!rest -> condition))

(: write-exn-condition (condition #!optional output-port string string -> void))

;;

; Signaled on errors.
(define exn-condition? (condition-predicate* 'exn))

(define exn-location (make-condition-property-accessor exn location))
(define exn-message (make-condition-property-accessor exn message))
(define exn-arguments (make-condition-property-accessor exn arguments))
(define exn-call-chain (make-condition-property-accessor exn call-chain))
(define exn-errno (make-condition-property-accessor exn errno))

;;

(define-inline (if@ tag val) (if val `(,tag ,val) '()))

(define (make-exn-condition #!optional (loc #f) (msg "unknown") (args #f) (chain #f) (errno #f))
  (apply make-property-condition 'exn
    (append!
      (if@ 'location loc)
      (if@ 'message (or msg "unknown"))
      (if@ 'arguments args)
      (if@ 'call-chain chain)
      (if@ 'errno errno))) )

(define (make-exn-condition* #!key (location #f)
                                   (message "unknown")
                                   (arguments #f)
                                   (call-chain #f)
                                   (errno #f))
  (make-exn-condition location message arguments call-chain errno) )

;;

(define-inline (ifarg cnds pred)
  (if (and (pair? cnds)
           (or (not (car cnds)) (pred (car cnds))))
      (values (car cnds) (cdr cnds))
      (values #f cnds)) )

(define (make-exn-condition+ loc msg args . cnds)
  (let*-values (((chain cnds) (ifarg cnds call-chain?))
                ((errno cnds) (ifarg cnds fixnum?)) )
    (apply make-composite-condition
      (make-exn-condition loc msg args chain errno)
      (expand-property-conditions cnds)) ) )

;;

;from 'write-exception' of https://github.com/dleslie/geiser/blob/master/scheme/chicken/geiser/emacs.scm
(define (write-exn-condition cnd
            #!optional
            (port (current-output-port))
            (header "Error")
            (chain-header "\n\tCall history:\n"))
  ;exn portion
  (print-error-message cnd port header)
  ;rest of the composite condition (if any)
  (write-condition-list (cdr (condition->list cnd)) port header)
  ;call-chain?
  (and-let* ((chain ((condition-property-accessor 'exn 'call-chain #f) cnd)))
    (write-call-chain chain port chain-header) )
  ;no abstraction leakage
  (void) )

) ;module exn-condition