;;;; condition-utils-support.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '18

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

(module condition-utils-support

(;export
  write-call-chain
  write-condition-list
  expand-property-conditions
  call-chain?)

(import scheme
  (chicken base)
  (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) proper-list? every concatenate)
  (only type-errors-basic error-argument-type)
  (check-errors sys))

(define-type call-chain (list-of vector))

(: call-chain? (* -> boolean : call-chain))

(: expand-property-conditions ((list-of (or condition pair (not false))) -> (list-of condition)))

(: write-call-chain (list #!optional output-port string -> void))

(: write-condition-list ((list-of pair) output-port string -> *)) ;(or string void)

;;

;NOTE "every/*?" causes '/*' within block comment
(define (every-nth? pred sel ls)
  (let loop ((ls ls))
    (or (null? ls)
        (and (pred (car ls))
             (loop (sel ls))))) )

;NOTE that correctness is favored over speed (errors further from the call site)

#;(define-inline (good-list? x) (pair? x))
(define-inline (good-list? x) (proper-list? x))

;

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

(define (condkind? x) (and x (atom? x)))

#; ;assumes proper-list!
(define (proplist? x) (every-nth? condkind? cddr x))
;assumes proper-list!
(define (proplist? x)
  (and (list? x) (even? (length x)) ;not quick
       (every-nth? condkind? cddr x)) )

(define (condition-arglist? x)
  (and (good-list? x)
       (condkind? (car x))
       (proplist? (cdr x))) )

(define (error-condition-expression loc x #!optional nam)
  (error-argument-type loc x "condition-expression" nam) )

(define (format-argslist args p) (for-each (cut format p " ~S" <>) args))

;;

;; Interpret condition expression

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

(define (expand-property-conditions cnds)
  (map (lambda (x)
         (cond ((condition? x)          x)
               ((condkind? x)           (make-property-condition x))
               ((condition-arglist? x)  (apply make-property-condition x))
               (else
                 (error-condition-expression 'expand-property-conditions x) ) ) )
       cnds) )

;;

(define *print-call-chain ##sys#really-print-call-chain)

(define (write-call-chain chain #!optional (port (current-output-port))
                                           (header "\n\tCall history:\n"))
  (*print-call-chain (check-output-port 'write-call-chain port)
                     (check-list 'write-call-chain chain)
                     (check-string 'write-call-chain header)) )

#; ;assumes implementation
(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) )

;;

(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 (cut format-argslist 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 (call-chain? x)
  (or (null? x) ;chain could be empty
      (and (good-list? x) (every vector? x))) )

) ;module condition-utils