;;;; coops-extras.scm
;;;; Kon Lovett, Aug '10

(module coops-extras

  (;export
    slot@
    make/copy
    describe-object)

  (import
    scheme
    chicken
    (only extras fprintf)
    (only srfi-1 fold remove)
    (only srfi-13 string-pad)
    coops
    coops-introspection)

  (require-library
    extras srfi-1 srfi-13
    coops-introspection coops)

;;; Helpers

(define-inline (symbol-length sym) (string-length (symbol->string sym)))

; memq is not specific enough
(define-inline (initslot? slot initforms)
  (let loop ((initforms initforms))
    (and (not (null? initforms))
         (or (eq? slot (car initforms))
             (loop (cddr initforms)) ) ) ) )

(define-inline (slot-values x slots #!optional (base '()))
  (fold (lambda (slot ls) (cons slot (cons (slot-value x slot) ls))) base slots) )

(define-inline (*class-slots class) (slot-value class 'slots))

(define-inline (shadowed-initforms x initforms #!optional (class (class-of x)))
  (slot-values x (remove (cut initslot? <> initforms) (*class-slots class)) initforms) )

;;; Extras

;;

; sub-instance slot reference
(define-syntax slot@
  (syntax-rules (=)
    ((_ o) o )
    ((_ o slot = v) (set! (slot-value o 'slot) v) )
    ((_ o slot . slots) (slot@ (slot-value o 'slot) . slots)) ) )

;;

; use w/ <primitive-object> is very suspect
(define (make/copy x . initforms)
  (check-instance 'make/copy x)
  (let ((class (class-of x)))
    (apply make class (shadowed-initforms x initforms class)) ) )

;;

(define-generic (describe-object obj))

(define-method (describe-object (obj #t) #!optional (out (current-output-port)))
  (let ((class (class-of obj)))
    (cond
      ((eq? class #t)
        ; specific in that obj used thru a coops interface
        ; but might be misleading - (display obj out) perhaps?
        (fprintf out "coops instance of class `#t': ~S~%" obj) )
      (else
        (fprintf out "coops instance of class `~A':~%" (class-name class))
        (let* ((slots (*class-slots class))
               (maxlen (fold (lambda (slot len) (fxmax (symbol-length slot) len)) 0 slots)) )
          (for-each
            (lambda (slot)
              (display (string-pad (symbol->string slot) maxlen) out)
              (display " : " out)
              (if (slot-initialized? obj slot) (write (slot-value obj slot) out)
                  (display "#<uninitialized>" out) )
              (newline out) )
            slots) ) ) ) ) )

(define-method (describe-object (prim <primitive-object>) #!optional (out (current-output-port)))
  (fprintf out "coops instance of primitive class `~A': ~S~%" (class-name (class-of prim)) prim) )

(define-method (describe-object (proc <procedure>) #!optional (out (current-output-port)))
  (if (generic? proc) (fprintf out "coops instance of `<generic-procedure>'~%")
    (fprintf out "coops instance of primitive class `<procedure>'~%") ) )

(define-method (describe-object (class <standard-class>) #!optional (out (current-output-port)))
  (fprintf out "coops standard-class `~A'~%" (class-name class)) )

) ;coops-extras