;;;; condition-utils.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '18
;;;; Kon Lovett, May '17
;;;; Kon Lovett, Aug '14
;;;; Kon Lovett, Jun '13
;;;; Kon Lovett, Aug '10
;;;; Kon Lovett, Apr '09

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

(module condition-utils

(;export
  ;
  call-chain?
  ;
  condition-irritants
  ;
  make-condition+
  condition-predicate*
  condition-property-accessor*
  (make-condition-predicate condition-predicate*)
  (make-condition-property-accessor condition-property-accessor*)
  ;
  write-condition)

(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)
  condition-utils-support)

;;;

; Symbols are convention. Any object supported.

#; ;UNUSED
(define (check-kind loc obj)
  #;(check-symbol loc obj 'property-kind)
  obj )

#; ;UNUSED
(define (check-property-tag loc obj)
  #;(check-symbol loc obj 'property-tag)
  obj )

;;;

;condition->plist
;condition->alist

;; All condition properties

(: condition-irritants (condition --> list))
;
;((exn (arguments (test)) (message "test") (location test)) (test) (extra (test 23)))
;=>
;((arguments (test)) (message "test") (location test) (test 23))
;
(define (condition-irritants cnd)
  ;indifferent to plist vs alist representation of condition-properties
  ;from 'condition->list'.
  (concatenate (map cdr (condition->list cnd))) )

;; Condition from condition expression; composite when indicated

(: make-condition+ (#!rest --> condition))
;
(define (make-condition+ . cnds)
  (let (
    (ls (expand-property-conditions cnds)) )
    (if (null? (cdr ls))
      (car ls)
      (apply make-composite-condition ls) ) ) )

;; memeoized condition-predicate ctor

(: condition-predicate* (symbol -> (* -> boolean : condition)))
;
(define condition-predicate*
  (let ((+preds+ (make-hash-table eq?)))
    (lambda (kind)
      #;(check-kind 'condition-predicate* kind)
      (or
        (hash-table-ref/default +preds+ kind #f)
        (let (
          (pred (condition-predicate kind)) )
          (hash-table-set! +preds+ kind pred)
          pred ) ) ) ) )

;; create composite condition-predicate

;should this be a procedure?
;kinda ugly when procedural since needs to loop over kinds

(define-syntax make-condition-predicate
  (syntax-rules ()
    ((_ ?kind0 ...)
      (lambda (obj)
        (and
          ((condition-predicate* '?kind0) obj)
          ... ) ) ) ) )

;; memeoized condition-property-accessor ctor

(: condition-property-accessor* (symbol symbol #!optional * -> (procedure (condition) *)))
;
(define condition-property-accessor*
  (let (
    (+getters+ (make-hash-table eq?)) )
    (lambda (kind prop #!optional dflt)
      #;(check-kind 'condition-property-accessor* kind)
      #;(check-property-tag 'condition-property-accessor* prop)
      (or
        (hash-table-ref/default +getters+ kind #f)
        (let (
          (key (cons kind prop))
          (getter (condition-property-accessor kind prop dflt)) )
          (hash-table-set! +getters+ key getter)
          getter ) ) ) ) )

;; create condition-property-accessor w/ "default" default

;should this be a procedure?
(define-syntax make-condition-property-accessor
  (syntax-rules ()
    ;
    ((_ ?kind ?prop)
      (make-condition-property-accessor ?kind ?prop #f) )
    ;
    ((_ ?kind ?prop ?dflt)
      (condition-property-accessor* '?kind '?prop ?dflt) ) ) )

;;

(: call-chain? (* -> boolean : (list-of vector)))
;
(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)))) )

(: write-condition (condition #!optional output-port string -> void))
;
(define (write-condition cnd #!optional (port (current-output-port)) (header "Error"))
  (format port "~A: ~A"
    header
    (call-with-output-string
      (lambda (p) (write-condition-list (condition->list cnd) p header)))) )

;;;

;;

(: condition-property->string (condition symbol symbol * -> string))
;
(define (condition-property->string cnd kind prop #!optional (def ""))
  (->string ((condition-property-accessor kind prop def) cnd)) )

;;

#; ;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