;;;; coops-describe.scm  -*- Scheme -*-
;;;; Kon Lovett, Sep '18

(module coops-describe

(;export
  describe-object
  describe-object-slot
  print-closure)

(import scheme)
(import (chicken base))
(import (chicken type))
(import (chicken memory))
(import (chicken foreign))
(import (only (chicken format) format))
(import (only (srfi 13) string-pad))
(import coops)
(import (only (check-errors sys) check-procedure))

(include-relative "coops.types")

(: describe-object (* #!rest -> void))
(: describe-object-slot (* symbol #!optional fixnum output-port -> void))
(: print-closure (procedure #!optional output-port -> void))

;;;symbol-utils

(define (symbol-printname-length s) (string-length (symbol->string s)))

;;; Helpers

(: *class-slots (coops-class -> (list-of symbol)))

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

(include-relative "object-uword-ref")

;;;

;FIXME per what reference source?
(define-constant MAXIMUM-SLOTNAME-LENGTH 32)

;;

(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 symbol-printname-length 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)))
  (let ((lbl (if (generic-procedure? proc)
                 "`<generic-procedure>'"
                 "primitive class `<procedure>'")) )
    (format out "coops instance of ~A: ~S~%" lbl proc) ) )

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

;;

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

;;

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

(define (print-closure proc #!optional (out (current-output-port)))
  (let ((idx 0))
    (format out "~A: #x~X~%" idx
                             (object-uword-ref (check-procedure '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)) ) ) ) )

) ;coops-describe