;;;; condition-utils.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '24
;;;; Kon Lovett, Jul '18
;;;; Kon Lovett, May '17
;;;; Kon Lovett, Aug '14
;;;; Kon Lovett, Jun '13
;;;; Kon Lovett, Aug '10
;;;; Kon Lovett, Apr '09

;; Issues
;;
;; - Symbols as `kind' & `tag' are convention. Any object is supported.

(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*)
  ;
  write-condition)

(import scheme)
(import (chicken base))
(import (chicken condition))
(import (chicken syntax))
(import (chicken type))
(import (only (chicken string) ->string))
(import (only (chicken format) format))
(import (only (chicken port) call-with-output-string))
(import (only (srfi 69) make-hash-table hash-table-ref/default hash-table-set!))
(import (only (srfi 1) concatenate))
(import (only type-errors-basic error-argument-type))
(import condition-utils-support)

(define-type kind-key (not false))
(define-type tag-key (not false))

(: condition-irritants (condition -> list))

(: make-condition+ (#!rest -> condition))
(: condition-predicate* (kind-key -> (* -> boolean : condition)))
(: condition-property-accessor* (kind-key tag-key #!optional * -> (procedure (condition) *)))

(: write-condition (condition #!optional output-port string -> void))

(: condition-property->string (condition kind-key tag-key * -> string))

;;

(define-inline (check-kind loc obj)
  (unless obj (error-argument-type loc obj '(not false)))
  obj )

(define-inline (check-tag loc obj)
  (unless obj (error-argument-type loc obj '(not false)))
  obj )

(define tag-def)
(define tag-def-set!)
(let ((+kinds+ (make-hash-table eq?)))
  (define (kind-def kind)
    (or (hash-table-ref/default +kinds+ kind #f)
        (let ((ht (make-hash-table eq?)))
          (hash-table-set! +kinds+ kind ht)
          ht ) ) )
  (set! tag-def
    (lambda (kind tag)
      (hash-table-ref/default (kind-def kind) tag #f) ) )
  (set! tag-def-set!
    (lambda (kind tag obj)
      (hash-table-set! (kind-def kind) tag obj) ) ) )

(define PRED-KEY '(condition-utils . predicate))

;;;

;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'.
  (concatenate (map cdr (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) ) ) )

;; memoized condition-predicate ctor

(define (condition-predicate* kind)
  (or (tag-def (check-kind 'condition-predicate* kind) PRED-KEY)
      (let ((pred (condition-predicate kind)))
        (tag-def-set! kind PRED-KEY 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)
             ... ) ) ) ) )

;; memoized condition-property-accessor ctor

(define (condition-property-accessor* kind prop #!optional def)
  (or (tag-def (check-kind 'condition-property-accessor* kind)
               (check-tag 'condition-property-accessor* prop))
      (let ((getter (condition-property-accessor kind prop def)))
        (tag-def-set! kind prop getter)
        getter ) ) )

;; create condition-property-accessor w/ "default" default

;should this be a procedure?
(define-syntax make-condition-property-accessor
  (syntax-rules ()
    ;
    ((make-condition-property-accessor ?kind ?prop)
      (make-condition-property-accessor ?kind ?prop #f) )
    ;
    ((make-condition-property-accessor ?kind ?prop ?def)
      (condition-property-accessor* '?kind '?prop ?def) ) ) )

;;

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

;;;

;;

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

) ;module condition-utils