;;;; condition-utils.scm
;;;; Kon Lovett, May '17
;;;; Kon Lovett, Aug '14
;;;; 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+
  ;
  write-exn-condition
  write-condition )

(import scheme chicken)

(import (only srfi-1 append!))
(require-library srfi-1)

(use srfi-69 data-structures)

(use #;type-checks type-errors)

;;;

; 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

;((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'.
  (foldl
    (lambda (ls kndlst)
      (append! ls (cdr kndlst)) )
    '()
    (condition->list cnd)) )

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

;; memeoized condition-predicate ctor

(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?
(define-syntax make-condition-predicate
  (syntax-rules ()
    ((_ ?kind0 ...)
      (lambda (obj)
        (and
          ((condition-predicate* '?kind0) obj)
          ... ) ) ) ) )

;; memeoized condition-property-accessor ctor

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

;;;FIXME should be in standard-conditions module
;;; EXN Condition

;;

(define (make-exn-condition #!optional (loc #f) (msg "unknown") (args #f) (calls #f))
  ;
  (define (incl tag val)
    (if val `(,tag ,val) '()) )
  ;
  (apply make-property-condition 'exn
    (append!
      (incl 'location loc)
      `(message ,(or msg "unknown"))
      (incl 'arguments args)
      (incl '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 (pair? cnds) (call-chain? (car cnds)) (car cnds)) )
         (cnds (if chn (cdr cnds) cnds) ) )
    (apply
      make-composite-condition
      (make-exn-condition loc msg args chn)
      (expand-property-conditions cnds)) ) )

;;

;from 'write-exception' of https://github.com/dleslie/geiser/blob/master/scheme/chicken/geiser/emacs.scm
(define (write-exn-condition cnd #!optional (port (current-output-port)))
  ;
  (define (exn-prop prop)
    (->string ((condition-property-accessor 'exn prop "") cnd)) )
  ; EXN portion
  (display
    (string-append
      "Error: "
      "(" (exn-prop 'location) ")"
      " " (exn-prop 'message) ":"
      " " (exn-prop 'arguments))
    port)
  (newline port)
  ; Rest of the composite condition (if any)
  (write-condition (cdr (condition->list cnd)) port "    +: ")
  ; show everything
  (and-let* ((chn-lst ((condition-property-accessor 'exn 'call-chain #f) cnd)))
    (display "Call history: " port)
    (newline port)
    (write-call-chain-condition chn-lst port) ) )

(define (write-condition cnd #!optional (port (current-output-port)))
  (display "Error: " port)
  (write-condition (condition->list cnd) port "    +: ") )

;;

(define (write-condition cnd-lst port leader)
  (for-each
    (lambda (cnd-info)
      (let ((kind (car cnd-info))
            (args (cdr cnd-info)))
        (display leader port)
        (display kind port)
        (display ": " port)
        (foldl
          (lambda (1st? arg)
            (unless 1st?
              (display " " port) )
            (write arg port)
            #f )
          #t
          args)
        (newline port) ) )
    cnd-lst) )

(define (write-call-chain-condition chn-lst port)
  ;
  (define (write-call-entry call)
    (let ((type (vector-ref call 0))
          (line (vector-ref call 1)) )
      (write-type-item type line)
      #;
      (cond
        ((equal? type "<syntax>")
          (write-type-item type line) )
        ((equal? type "<eval>")
          (write-type-item type line) )
        (else
          ;what?
          ) ) ) )
  ;
  (define (write-type-item type line)
    (display type port)
    (display " " port)
    (write line port)
    (newline port) )
  ;
  (for-each write-call-entry chn-lst)
  (newline port) )

;;;

;; 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) )
        (else
          (error-argument-type
            'expand-property-conditions
            x 'condition-expression "cond-parm") ) ) )
    cnds) )

) ;module condition-utils