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

(module coops-extras

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

(import scheme)

(import chicken)

(import (only data-structures o))
(require-library data-structures)

(import (only extras format))
(require-library extras)

(import (only srfi-1 cons* fold remove))
(require-library srfi-1)

(import (only srfi-13 string-pad))
(require-library srfi-13)

(require-extension coops-introspection coops)

;;; Helpers

;memq is not specific enough
(define (initslot? slot initforms)
  ;search plist for slot name
  (let loop ((initforms initforms))
    (and
      (not (null? initforms))
      (or
        (eq? slot (car initforms))
        (loop (cddr initforms)) ) ) ) )

(define (slot-values x slots #!optional (base '()))
  (fold
    (lambda (slot ls)
      ;per Jun 19, '17 email from Sandra Snan
      (if (slot-initialized? x slot)
        (cons* slot (slot-value x slot) ls)
        ls ) )
    base
    slots) )

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

(define (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 (=)
    ((_ ?obj)
      ?obj )
    ((_ ?obj ?slot = ?v)
      (set! (slot-value ?obj '?slot) ?v) )
    ((_ ?obj ?slot . ?slots)
      (slot@ (slot-value ?obj '?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?
        (format out "coops instance of class `#t': ~S~%" obj) )
      (else
        (format out "coops instance of class `~A':~%" (class-name class))
        (let* ((slots (*class-slots class))
               (maxlen (apply max (map (o string-length symbol->string) slots))) )
          (for-each
            (lambda (slot)
              (let ((intd? (slot-initialized? obj slot)))
                (format out "~A: ~?~%"
                  (string-pad (symbol->string slot) maxlen)
                  (if intd? "~S" "#<uninitialized>")
                  (if intd? `(,(slot-value obj slot)) '())) ) )
            slots) ) ) ) ) )

(define-method (describe-object (prim <primitive-object>)
                                #!optional (out (current-output-port)))
  (format 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)
    (format out "coops instance of `<generic-procedure>'~%")
    (format out "coops instance of primitive class `<procedure>'~%") ) )

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

;;

(define (print-closure p #!optional (out (current-output-port)))
  (##sys#check-closure p 'print-closure)
  (format out "0: #x~X~%" (##sys#peek-unsigned-integer p 0))
  (let ((size (##sys#size p)))
    (do ((i 1 (add1 i)))
        ((= i size))
      (format out "~A: ~S~%" i (##sys#slot p i)) ) ) )

) ;coops-extras