;;;; 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 error-argument-type))

;;

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

;; 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 (write-call-chain chain port header)
  (##sys#really-print-call-chain port chain header) )

#; ;using builtin
(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)) )

;;

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

) ;module condition-utils