;;; Example of using import and define-method.  
;;; (describe x) uses JDK 1.2 AccessibleObject to describe private
;;; fields of object x.  (define-method) can be used to specialize the
;;; description for different classes.

;;; Example:
;;; > (describe '(1 2 3))
;;; an instance of silk.Pair
;;;   first: 1
;;;   rest: (2 3)
;;; ()

(map import 
     (list
      "java.lang.Class"
      "java.lang.reflect.Array"
      "java.lang.reflect.Constructor"
      "java.lang.reflect.Method"
      "java.lang.reflect.Field"
      "java.lang.reflect.Modifier"
      ))

(import "java.lang.System")

(if (java-version>=1.2)  (import "java.lang.Package"))

;;; (describe) requires JDK 1.2 to get access to all fields.
(if (java-version>=1.2)
    (import "java.lang.reflect.AccessibleObject"))

(define (short-toString x max)
  (let ((it (symbol->string (toString x))))
    (if (<= (string-length it) max) it
	(string-append (substring it 0 (- max 4)) " ..."))))

(define-method describe ((x java.lang.Object))
  (display (short-toString x 80)) (newline)
  (dshow 
   " is an instance of " 
   (getName (getClass x)))
  (describe-fields x (getClass x)))

(define (describe-fields x superclass)
  (in-1.2
   #t
   (let ((fs (getDeclaredFields superclass)))
     (AccessibleObject.setAccessible fs #t) ; Make them all accessible.
     (for-each* (lambda (f)		; Not static fields.
		  (if (not (Modifier.isStatic (getModifiers f)))
		      (describe-field f x)))
		fs)
     (let ((superclass (getSuperclass superclass)))
       (if (not (null? superclass)) (describe-fields x superclass)))))


  (in-1.2
   #f
   (let ((fs (getFields superclass)))
     (for-each* (lambda (f)		; Not static fields.
		  (if (not (Modifier.isStatic (getModifiers f)))
		      (describe-field f x)))
		fs))))

(define (describe-field f x) (dshow "  " (getName f)": " (get f x)))

(define (dshow . items)
  (apply displays items)
  (newline))

(define-method describe ((x java.lang.Class)) (describe-class x #t))

'(define-method describe ((x java.lang.String))
  (let ((it (class x)))
    (if it (describe-class it #t)
	(print x))))

(define (class-cpl c)
  ;; Return a list describing the class precedence list of class c.
  ;; > (class-cpl (class "java.lang.Class"))
  ;; (class java.lang.Class class java.lang.Object
  ;;   interface java.io.Serializable)
  (class-cpl-1 '() (list c)))

(define (class-cpl-1 so-far tail)
  (if (null? tail) (reverse so-far)
      (let* ((c (car tail))
	     (tail (cdr tail))
	     (is (vector->list (getInterfaces c)))
	     (super (getSuperclass c)))
	(class-cpl-1 (cons c so-far) 
		     (if (not (null? super))
			 (cons super (append is tail))
			 (append is tail))))))

(define (displays . items) 
  (for-each 
   (lambda (i)
     (if (pair? i) (apply displays i)
	 (display i)))
   items))

(define (describe-class the-class all?)
  ;; Describe class c trying to use every method of the class Class.
  ;; if an all? argument is provided, show all public methods and 
  ;; fields, otherwise show the declared ones.
  (define (describe-items name what)
    (if (and (not (null? what)) (not (= (vector-length what) 0)))
	(begin
	  (display name)
	  (display ":
")
	  (for-each* indent-print what)
	  (newline))))
  (define (indent-print what)
    (display "  ")
    (print what))
  (define (describe-item name what)
    (if (not (null? what))
	(begin
	  (display name)
	  (display ": ")
	  (print what))))
  (define (maybe-display x)
    (if (and x (not (null? x)))
	(begin (display x)
	       (write-char #\space))))
  (let ((c (class-or-error the-class)))
    (if (isPrimitive c)
	(display "primitive "))
    (display (Modifier.toString (getModifiers c)))
    (display (if (isInterface c) " " " class "))
    (display (getName c))
    (let ((super (getSuperclass c)))
      (if (not (null? super)) (displays " extends " (getName super))))
    (let ((interfaces (getInterfaces c)))
      (if (and (not (null? interfaces))
	       (> (vector-length interfaces) 0))
	  (begin (newline) (display "  implements ")
		 (for-each (lambda (x) (display x) (display " "))
			   (map* getName interfaces)))))
    (newline)
    (describe-item "HashCode" (hashCode c))
    (describe-item "ClassLoader" (getClassLoader c))
    (if (java-version>=1.2) (describe-item "Package" (getPackage c)))
    (describe-item "Name" (getName c))
    (describe-item "isArray" (isArray c))
    (describe-item "ComponentType" (getComponentType c))
    (describe-item "DeclaringClass" (getDeclaringClass c))
    '(if (java-version>=1.2)
	 (describe-item "ProtectionDomain" (getProtectionDomain c)))
    (describe-items "Signers" (getSigners c))
    (display "Constructors
")
    (for-each* display-constructor (getDeclaredConstructors c))
    (display "Fields
")
    (for-each* display-field
	       ((if all? all-fields getDeclaredFields)
		c))
    (display "Methods
")
    (for-each* display-method ((if all? getMethods getDeclaredMethods) c))
       ;; KRA 13JAN99: Causes access violoation on NT and W95.
    (in-1.2 #t
	    (describe-items "Classes" (getDeclaredClasses c)))
    #f))


(define (modifier-string m)
  (Modifier.toString (getModifiers m)))

(define (static-final? m)
  (let ((ms (getModifiers m)))
    (and (Modifier.isStatic ms) (Modifier.isFinal ms))))

(define (short-class-name c)
  (if (isArray c)
      (string-append (short-class-name (getComponentType c)) "[]")
      (class-name-name (symbol->string  (getName c)))))

(define (commacomma items)
  (define (comma1 head items)
    (cons head (if (null? items) '()
		   (cons ", " (comma1 (car items) (cdr items))))))
  (if (null? items) (list "(" ")")
      (append (list "(") (comma1 (car items) (cdr items)) (list ")"))))


(define (display-constructor m)
  (displays "  " (modifier-string m) " " 
	    (short-class-name (getDeclaringClass m))
	    (commacomma
	     (map* short-class-name (getParameterTypes m)))
	    ";
"))


(define (display-field f)
  (displays "  " (modifier-string f) " "
	    (short-class-name (getType f)) " "
	    (getName f) "; // "
	    (getName (getDeclaringClass f)) "
"))

(define (display-method m)
  (displays "  " (modifier-string m) " "
	    (short-class-name (getReturnType m)) " "
	    (getName m)
	    (commacomma
	     (map* short-class-name (getParameterTypes m))) "; // "
	    (getName (getDeclaringClass m)) "
"))