;;;; coerce-extend.scm
;;;; Kon Lovett, Sep '09
;;;; Kon Lovett, Apr '12

(module coerce-extend

(;export
  extended-type-of
  ;;
  coerce-extend!
  coerce-composite-extension!
  coerce-extended?
  coerce-extension
  coerce-extension-remove!
  ;;
  type-of-extended?
  type-of-extend!
  type-of-extension
  type-of-composite-extension!
  type-of-remove!
  ;;
  other-coerce)

(import
  scheme chicken
  (only data-structures identity)
  (only miscmacros if*)
  (only type-checks check-procedure check-symbol)
  type-extend-support
  type-of)

(require-library
  data-structures
  miscmacros
  type-checks
  type-extend-support
  type-of)

;;;

(define (->boolean x) (and x #t))

;;;

(define (extended-type-of obj)
  (or
    (other-type-of obj)
    (type-of obj)) )

;;;

(define (other-type-of obj)
  (and-let* ((ti (typdef/object obj)))
    (typdef-type ti) ) )

(define (other-coerce obj result-type default-proc)
  (if* (typdef/type (type-of obj))
    ((typdef-proc it) obj result-type default-proc)
    (default-proc obj result-type)) )

(define ((composite-pred pred old-pred) obj)
  (or
    (pred obj)
    (old-pred obj)) )

(define ((composite-proc proc old-proc) obj typ err)
  (proc obj typ (lambda () (old-proc obj typ err))) )

;;; Extension

(define (coerce-extended? typ)
  (check-symbol 'coerce-extended? typ)
  (->boolean (typdef/type typ)) )

(define (coerce-extend! typ pred #!optional (proc identity))
  (check-symbol 'extend-coerce typ)
  (check-procedure 'extend-coerce pred)
  (check-procedure 'extend-coerce proc)
  (typdef-add! typ pred proc) )

(define (coerce-extension typ)
  (check-symbol 'coerce-extension typ)
  (if* (typdef/type typ)
    (values (typdef-pred it) (typdef-proc it))
    (values #f #f) ) )

(define (coerce-composite-extension! typ pred #!optional (proc identity))
  (check-symbol 'extend-coerce typ)
  (check-procedure 'extend-coerce pred)
  (check-procedure 'extend-coerce proc)
  (if* (typdef/type typ)
       ;then update old
       (let ((old-pred (typdef-pred it))
             (old-proc (typdef-proc it)) )
          ; don't replace when same
          (unless (and (eq? pred old-pred) (eq? proc old-proc))
            (let ((pred (if (eq? pred old-pred) pred (composite-pred pred old-pred)))
                  (proc (if (eq? proc old-proc) proc (composite-proc proc old-proc))) )
              (typdef-add! typ pred proc) ) ) )
       ;else create new
       (typdef-add! typ pred proc) ) )

(define (coerce-extension-remove! typ)
  (check-symbol 'remove-coerce-extension typ)
  (typdef-delete! typ) )

;;;

(define type-of-extended? coerce-extended?)
(define type-of-extend! coerce-extend!)
(define type-of-extension coerce-extension)
(define type-of-composite-extension! coerce-composite-extension!)
(define type-of-remove! coerce-extension-remove!)

) ;module coerce-extend