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

(import chicken)

(use srfi-69 data-structures)

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

#;(use type-checks)
(use type-errors)

(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

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

(define (call-chain? x)
  ;(and (proper-list? x) (every vector? x))
  (and (pair? x) (vector? (car x))) )

;;

(use error-utils)

;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
    (string-append (subheader-string header) ": "))
  ; show everything
  (and-let* ((chain ((condition-property-accessor 'exn 'call-chain #f) cnd)))
    (display chain-header port)
    (write-call-chain chain port "\n\t") )
  ;
  (void))

(define (write-condition cnd #!optional (port (current-output-port)) (header "Error"))
  (display header port)
  (display ": " port)
  (write-condition-list
    (condition->list cnd)
    port
    (string-append (subheader-string header) ": ")) )

(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)
    (display header port)
    (display type port)
    (display "\t  " port)
    (write line port)
    (newline port) )
  ;
  (for-each write-call-entry chain)
  (newline port) )

;;;

;;

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

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

;;

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

;;

(define (write-condition-list 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)
        (for-each
          (lambda (arg)
            (display " " port)
            (write arg port) )
          args)
        (newline port) ) )
    cnd-lst) )

;;

#; ;UNUSED
(define (write-error-message cnd port header)
  ;
  (define (exn-prop->string prop)
    (condition-property->string cnd 'exn prop) )
  ;
  (let ((errmsg
          (string-append
            "\n"
            header
            "(" (exn-prop->string 'location) ")"
            " " (exn-prop->string 'message) ":"
            " " (exn-prop->string 'arguments))))
    (display errmsg port)
    (newline port) ) )

) ;module condition-utils