;;;; 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 (only (chicken format) fprintf))
(import (only (srfi 13) string-pad))
(import coops)
(import (only type-checks check-procedure))

;;;symbol-utils

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

;;;

(define-type coops-class *)

;;; Helpers

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

(define-constant MAXIMUM-SLOTNAME-LENGTH 32)

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

;;;

;;

(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
      (fprintf 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) )
        ;
        (fprintf 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)))
  (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)))
  (fprintf 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)))
  (fprintf 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))
    (args-fmt (if intd? "~S" "#<uninitialized>"))
    (args (if intd? `(,(slot-value obj slot)) '())) )
    (fprintf out "~A: ~?" nam args-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))
    (fprintf 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))
        (fprintf out "~A: ~S~%" i (##sys#slot proc i)) ) ) ) )

) ;coops-describe