;;;; condition-utils.scm
;;;; Kon Lovett, Jun '13
;;;; Kon Lovett, Aug '10
;;;; Kon Lovett, Apr '09

;; Issues
;;

(module condition-utils

  (;export
    ;
    condition-irritants
    make-condition+
    condition-predicate*
    condition-property-accessor*
    (make-condition-predicate condition-predicate*)
    (make-condition-property-accessor condition-property-accessor*)
    ;
    make-exn-condition
    make-exn-condition+
  )

  (import scheme chicken)

  (use srfi-1 srfi-69 #;type-checks)

;;;

; Symbols are convention. Any object supported.

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

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

;;;

;; 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) )
                ((pair? x)       (apply make-property-condition x) ) ) )
        cnds) )

;;;

;; All condition properties

(define (condition-irritants exn)
  (fold
    (lambda (kndlst lst) (append! lst (cdr kndlst)) )
    '()
    (condition->list exn)) )

;; Condition from condition expression; composite when indicated

(define (make-condition+ . cnds)
  (let ((ls (expand-property-conditions cnds)))
    (if (null? (cdr ls)) (car ls)
      (apply make-composite-condition ls) ) ) )

;;

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

;;

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

;;

(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)
      (let* ((key (cons kind prop))
             (p (hash-table-ref/default +getters+ kind #f)) )
        (or p
            (let ((getter (condition-property-accessor kind prop dflt)))
              (hash-table-set! +getters+ key getter)
              getter ) ) ) ) ) )

;;

(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) ) ) )

;;; EXN Condition

;;

(define (make-exn-condition #!optional (loc #f) (msg #f) (args #f) (calls #f))
  (apply make-property-condition 'exn
    (append!
      (list 'location loc)
      (list 'message (or msg ""))
      (list 'arguments (or args '()))
      (if calls (list 'call-chain calls) '()))) )

;;

(define (make-exn-condition+ loc msg args . cnds)
  (define (call-chain? x)
    ;(and (proper-list? x) (every vector? x))
    (and
      (pair? x)
      (vector? (car x))) )
  (let ((chn (and (not (null? cnds))
                  (call-chain? (car cnds))
                  (car cnds))))
    (apply make-composite-condition
           (apply make-exn-condition loc msg args (or chn '()))
           (expand-property-conditions (if chn (cdr cnds) cnds))) ) )

) ;module condition-utils