;;;; detail-object.scm
;;;; Kon Lovett, Aug '10

;; Issues
;;
;; - Does not implement the spirit of SRFI 10.
;;
;;    - The ctors are, at best, placeholders.
;;
;;    - Need a class registry with lookup by-name.
;;
;; - WIthout some kind of method body registry will never be
;; able to reconstruct a method. At least w/o serialization.

(module detail-object (detail-object)

  (import
    scheme
    chicken
    (only extras fprintf)
    (only data-structures alist-ref)
    (only srfi-1 fold))

  (require-library extras data-structures srfi-1)

  (use tinyclos)

;;

(define +known-classes+ `(
  ("class" . ,<class>)
  ("object" . ,<object>)
  ("top" . ,<top>)
  ("generic" . ,<generic>)))

(define (known-class classname)
  (alist-ref classname +known-classes+ string=?)  )

(define (known-classes classnames)
  (fold
    (lambda (name ls)
      (and-let* ((ls)
                 (class (known-class name)) )
        (cons class ls) ) )
    '()
    classnames) )

;;

(define-generic detail-object)

(define-method (detail-object (x <object>) #!optional (port ##sys#standard-output))
  (let ((class (class-of x)))
    (fprintf port "#,(instance ~S ~S)"
      (class-name class)
      (map
        (lambda (s) (let ((nam (car s))) (cons nam (slot-ref x nam))))
        (class-slots class))) ) )

(define-reader-ctor 'instance
  (lambda (name slots)
    (warning "cannot faithfully reconstruct the instance:"
      name slots)
    (void) ) )

(define-method (detail-object (x <primitive>) #!optional (port ##sys#standard-output))
  (fprintf port "#,(primitive-instance ~S ~S)" (class-name (class-of x)) x) )

(define-reader-ctor 'primitive-instance
  (lambda (class object)
    object ) )

(define-method (detail-object (x <class>) #!optional (port ##sys#standard-output))
  (fprintf port "#,(class ~S ~S ~S ~S ~S ~S)"
    (class-name x)
    (class-name (class-of x))
    (map car (class-slots x))
    (map class-name (class-cpl x))
    (map car (class-direct-slots x))
    (map class-name (class-direct-supers x))) )

(define-reader-ctor 'class
  (lambda (name meta slots supers dslots dsupers)
    (warning "cannot faithfully reconstruct the class:"
      name meta slots supers dslots dsupers)
    (let ((metaclass (known-class meta))
          (superclasses (known-classes dsupers)) )
      (if (not (or metaclass superclasses)) (void)
        (make metaclass
          'name name
          'direct-supers superclasses
          'direct-slots dslots) ) ) ) )

(define-method (detail-object (x <generic>) #!optional (port ##sys#standard-output))
  (fprintf port "#,(generic ~S ~S ~S)"
    (generic-name x)
    (class-name (class-of x))
    (map (lambda (m) (map class-name (method-specializers m))) (generic-methods x))) )

(define-reader-ctor 'generic
  (lambda (name meta specializers)
    (warning "cannot faithfully reconstruct the generic procedure:"
      name meta specializers)
    (let ((metaclass (known-class meta)))
      (if (not metaclass) (void)
        (make metaclass 'name name) ) ) ) )

) ;module detail-object