;;;; 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)
(use
  (only srfi-69 make-hash-table hash-table-ref/default hash-table-set!)
  (only data-structures ->string)
  (only extras format)
  (only ports call-with-output-string)
  (only srfi-1 concatenate append!)
  (only type-errors error-argument-type))

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

;;;

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

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

;;

(: make-exn-condition (#!optional (or boolean symbol) (or boolean string) (or boolean list) (or boolean list) --> condition))
;
(define (make-exn-condition #!optional (loc #f) (msg "unknown") (args #f) (chain #f))
  (let (
    (if@ (lambda (tag val) (if val `(,tag ,val) '()))) )
    (apply make-property-condition 'exn
      (append!
        (if@ 'location    loc)
        (if@ 'message     (or msg "unknown"))
        (if@ 'arguments   args)
        (if@ 'call-chain  chain))) ) )

;;

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

;;

(: make-exn-condition+ ((or boolean symbol) (or boolean string) #!rest -> condition))
;
(define (make-exn-condition+ loc msg args . cnds)
  (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)) ) )

;;

(: write-exn-condition (condition #!optional output-port string string -> void))
;
;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))
            (header "Error")
            (chain-header "\n\tCall history:\n"))
  ;exn portion
  (print-error-message cnd port header)
  ;rest of the composite condition (if any)
  (write-condition-list (cdr (condition->list cnd)) port header)
  ;call-chain?
  (and-let* (
    (chain ((condition-property-accessor 'exn 'call-chain #f) cnd)) )
    (write-call-chain chain port chain-header) )
  ;no abstraction leakage
  (void) )

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

(: write-call-chain (list output-port string -> void))
;
(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) )

;;;

;;

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

;; Interpret condition expression

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

(: expand-property-conditions ((list-of (or condition symbol pair)) -> (list-of condition)))
;
(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) )

;;

(: write-condition-list ((list-of pair) output-port string -> string))
;
(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