;;;; 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
  ;
  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 boolean symbol) (or boolean string) (or boolean list) (or boolean list) --> condition))
(: make-exn-condition+ ((or boolean symbol) (or boolean string) #!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 (make-exn-condition #!optional (loc #f) (msg "unknown") (args #f) (chain #f))
  (let (
    (if@ (lambda (tag val) (if val `(,tag ,val) '()))) )
    (apply make-property-condition 'exn
      (append!
        (if@ 'location    loc)
        (if@ 'message     (or msg "unknown"))
        (if@ 'arguments   args)
        (if@ 'call-chain  chain))) ) )

;;

(define (make-exn-condition+ loc msg args . cnds)
  (let* (
    (chn (and (pair? cnds) (call-chain? (car cnds)) (car cnds)))
    (cnds (if chn (cdr cnds) cnds)) )
    (apply make-composite-condition
      (make-exn-condition loc msg args chn)
      (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