;;;; 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
  call-chain?)

(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 (not false) pair)) -> (list-of condition)))

(: write-call-chain (list #!optional output-port string -> void))
(: write-condition-list ((list-of pair) output-port string -> string))

(: call-chain? (* -> boolean : (list-of vector)))

;;

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

(define (condkind? x)
  (and x (atom? x)) )

(define (proplist? ls)
  (and (list? ls) (even? (length ls))
       (let loop ((ls ls)) (or (null? ls) (and (car ls) (loop (cddr ls))))) ) )

;; Interpret condition expression

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

(define (expand-property-conditions cnds)
  (map (lambda (x)
         (cond ((condition? x) x)
               ((condkind? x) (make-property-condition x))
               ((and (pair? x) (condkind? (car x)) (proplist? (cdr 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)) )

;;

(define (call-chain? x)
  ;(or (null? x) (and (proper-list? x) (every vector? x)))
  (or (null? x) ;chain could be empty
      (and (pair? x) (vector? (car x)))) )

) ;module condition-utils