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

;; Issues
;;

(module coops-extras

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

(import scheme chicken)

(use
  (only data-structures o)
  (only extras format)
  (only srfi-1 cons* remove)
  (only srfi-13 string-pad)
  coops-introspection coops)

(declare
  (bound-to-procedure
    ##sys#peek-unsigned-integer
    ##sys#check-closure ) )

;;;

(define-type coops-class *)
(define-type coops-instance *)
(define-type coops-generic *)
(define-type coops-method *)

;;; Helpers

(define-constant *MAXIMUM-SLOTNAME-LENGTH* 32)

;
(: closure-C-address (procedure --> number))
;
(define (closure-C-address proc)
  (##sys#peek-unsigned-integer proc 0) )

(: check-closure (symbol * --> *))
;
(define (check-closure loc obj)
  (##sys#check-closure obj loc)
  obj )

(: initslot? (symbol list --> boolean))
;
;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)) ) ) ) )

(: slot-values (coops-instance (list-of symbol) #!optional list --> list))
;
(define (slot-values x slots #!optional (base '()))
  (foldl
    (lambda (ls slot)
      (if (slot-initialized? x slot)  ;per Jun 19, '17 email from Sandra Snan
        (cons* slot (slot-value x slot) ls)
        ls ) )
    base
    slots) )

(: *class-slots (coops-class --> list))
;
(define (*class-slots class)
  (slot-value class 'slots) )

(: shadowed-initforms (coops-instance list #!optional coops-class --> list))
;
(define (shadowed-initforms obj initforms #!optional (class (class-of obj)))
  (slot-values
    obj
    (remove (cut initslot? <> initforms) (*class-slots class))
    initforms) )

;;; Extras

;;

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

;;

;use w/ <primitive-object> is very suspect
(: make-with-copy (coops-instance #!rest --> *))
;
(define (make-with-copy obj . initforms)
  (let ((class (class-of (check-instance 'make-with-copy obj))))
    (apply make class (shadowed-initforms obj initforms class)) ) )

;;

(define-generic (describe-object obj))

(define-method (describe-object (obj #t)
                  #!optional (out (current-output-port)))
  (let ((class (class-of obj)))
    (if (eq? class #t)
      ;then obj used thru a coops interface
      (format out "coops instance of class `#t': ~S~%" obj)
      ;else an instance
      (let* (
        (slots
          (*class-slots class) )
        (name-maxlen
          (apply max (map (o string-length symbol->string) slots)) ) )
        ;
        (define (slot-per-line slot)
          (describe-object-slot obj slot name-maxlen out)
          (newline out) )
        ;
        (format out "coops instance of class `~A':~%" (class-name class))
        (for-each (cut slot-per-line <>) 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)))
  (format out "~A~%"
    (if (generic-procedure? proc)
      "coops instance of `<generic-procedure>'"
      "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)) )

;;

(: describe-object-slot (* symbol #!optional fixnum (or boolean output-port) -> *))
;
(define (describe-object-slot obj slot
          #!optional
          (name-maxlen *MAXIMUM-SLOTNAME-LENGTH*)
          (out (current-output-port)))
  (let* (
    (intd? (slot-initialized? obj slot) )
    (nam (string-pad (symbol->string slot) name-maxlen) )
    (fmt (if intd? "~S" "#<uninitialized>") )
    (args (if intd? `(,(slot-value obj slot)) '()) ) )
    ;
    (format out "~A: ~?" nam fmt args) ) )

;;

;(call-with-output-string (lambda (port) (print-closure proc port)))

(: print-closure (procedure #!optional (or boolean output-port) -> *))
;
(define (print-closure proc #!optional (out (current-output-port)))
  (let ((idx 0))
    (format out "~A: #x~X~%"
      idx
      (closure-C-address (check-closure 'print-closure proc)))
    (let ((size (##sys#size proc)))
      (do ((i (add1 idx) (add1 i)))
          ((= i size))
        (format out "~A: ~S~%" i (##sys#slot proc i)) ) ) ) )

;;;DEPRECATED

(define make/copy make-with-copy)

) ;coops-extras