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

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

(module condition-utils-support

(;export
  write-call-chain
  write-condition-list
  expand-property-conditions)

(import scheme
  (chicken base)
  (chicken fixnum)
  (chicken condition)
  (chicken syntax)
  (chicken type)
  (only (chicken string) ->string)
  (only (chicken format) format)
  (only (chicken port) call-with-output-string)
  (only (srfi 69) make-hash-table hash-table-ref/default hash-table-set!)
  (only (srfi 1) concatenate)
  (only type-errors-basic error-argument-type)
  (check-errors sys))

(: expand-property-conditions ((list-of (or condition symbol pair)) -> (list-of condition)))
(: write-call-chain (list #!optional output-port string -> void))
(: write-condition-list ((list-of pair) output-port string -> string))

;;

(define (subheader-string header)
  (string-append (make-string (fx- (string-length header) 1) #\space) "+") )

;; Interpret condition expression

;; <condition>  ->  <condition>
;; <symbol>     ->  (make-property-condition <symbol>)
;; <pair>       ->  (apply make-property-condition <pair>)
;;
;; (<symbol> [<symbol> <object>]...)

(define (expand-property-conditions cnds)
  (map
    (lambda (x)
      (cond ((condition? x) x)
            ((symbol? x) (make-property-condition x))
            ((list? x) (apply make-property-condition x))
            (else
              (error-argument-type 'expand-property-conditions
                x 'condition-expression "cond-parm") ) ) )
    cnds) )

;;

(define *print-call-chain ##sys#really-print-call-chain)

(define (write-call-chain chain #!optional (port (current-output-port))
                                           (header "\n\tCall history:\n"))
  (*print-call-chain (check-output-port 'write-call-chain port)
                     (check-list 'write-call-chain chain)
                     (check-string 'write-call-chain header)) )

#; ;assumes implementation
(define (write-call-chain chain port header)
  ;
  (define (write-call-entry call)
    (let ((type (vector-ref call 0))
          (line (vector-ref call 1)) )
      (write-type-item type line header) ) )
  ;
  (define (write-type-item type line header)
    (format port "~A~A\t  ~S~%" header type line) )
  ;
  (for-each write-call-entry chain)
  (newline port) )

;;

(define (write-condition-list cnds port header)
  (let ((leader (string-append (subheader-string header) ": ")))
    (for-each
      (lambda (cnd-info)
        (let ((kind (car cnd-info))
              (args (cdr cnd-info)) )
          (format port "~A~A:~A~%"
            leader kind
            (call-with-output-string
              (lambda (p) (for-each (cut format p " ~S" <>) args)))) ) )
      cnds) ) )

;;

#; ;UNUSED
(define (exn-prop->string prop) (condition-property->string cnd 'exn prop))

#; ;UNUSED
(define (write-error-message cnd port header)
  (format port "~%~A(~A) ~A: ~A~%"
    header
    (exn-prop->string 'location)
    (exn-prop->string 'message)
    (exn-prop->string 'arguments)) )

) ;module condition-utils