(use coops)
(use extras)
(use (only srfi-1 fold))
(use (only srfi-13 string-pad))
(import (only csi toplevel-command))
(use (prefix describe describe:))

(define-inline (symbol-length sym) (string-length (symbol->string sym)))
(define-inline (class-slots class) (slot-value class 'slots))

(define-generic (describe-object obj))

(define-method (describe-object (obj #t) out)
  (let ((class (class-of obj)))
    (cond
     ((eq? class #t)
      (describe:describe obj out))
     ;; Match objects with the metaclass of <standard-class>, i.e. those supporting slots
     ;; and classname.  We don't specialize on <standard-object> because other object
     ;; base classes having the standard metaclass should work as well, were you to
     ;; create any.  This also works for metaclasses that subclass <standard-class>.
     ((subclass? (class-of class) <standard-class>)
      (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))
             (lim (describe:describe-sequence-limit)))
        (let lp ((idx 0) (slots slots))
          (cond ((null? slots))
                ((< idx lim)
                 (let ((slot (car slots)))
                   (display "  ")
                   (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)
                   (lp (+ idx 1) (cdr slots))))
                (else
                 (fprintf out " (~A slots omitted)~%" (length slots)))))))
     (else
      ;; Handle case where metaclass is not a subclass of <standard-class>.
      ;; Although it's possible to create such a class, it has to have all the
      ;; usual slots (CPL, slots, etc.) of <standard-class> anyway, as make-class
      ;; relies on them.  So this is not terribly useful.
      ;; A contrived example of an object that would trigger this clause:
      ;; (make (make-class <test> () (x y z)
      ;;         (make-class <nonstdmeta> () (class-precedence-list slots classname initthunks))))
      (fprintf out "coops instance of non-standard class~%")
      (describe:describe obj out)))))

(define-method (describe-object (prim <primitive-object>) out)
  (fprintf out "coops instance of primitive class ~A~%"
           (class-name (class-of prim)))
  (describe:describe prim out))

(define-method (describe-object (proc <procedure>) out)
  (if (generic-procedure? proc)
      (fprintf out "coops instance of <generic-procedure>~%")
      (fprintf out "coops instance of primitive class <procedure>~%"))
  (describe:describe proc out))

(define-method (describe-object (class <standard-class>) out)
  (fprintf out "coops standard-class ~A~%" (class-name class))
  (fprintf out "  class precedence list: ~S~%"
           (map class-name (slot-value class 'class-precedence-list)))
  (fprintf out "  slots: ~S~%"
           (slot-value class 'slots)))

;; Note: initforms are buried in initthunks; introspecting their values by thunking may
;; be dangerous if the forms have side-effects.
;; (map (lambda (x) (cons (car x) ((cdr x)))) (slot-value class 'initthunks))


#|
(define-class <human> () ((name "Anne O. Nymous")
                          favorite-drink))
|#

;; Not sure if we need this indirection, rather than making 'describe' the generic.
;; It *might* help with recursive display. If so the describe egg would need the same treatment.

(define (describe obj #!optional (out (current-output-port)))
  (describe-object obj out))

(define dump describe:dump)
(define hexdump describe:hexdump)
(define set-describer! describe:set-describer!)
(define describe-sequence-limit describe:describe-sequence-limit)

;;; REPL



(when (feature? 'csi)
  (toplevel-command 'd
                    (lambda ()
                      (let* ([e (read)])
                        (describe (eval e))))
                    ",d EXP            (describe) Describe result of evaluated EXP"))