(use srfi-1)
(use slib)
(require 'pretty-print)

;; real kludge; ripped from 'apropos'
(define-syntax all-classes
  (syntax-rules ()
    ((_) (%all-classes (current-module)))
    ))

(define (%all-classes module)
  (let ((result '())
        (searched '()))

    (define (search mod)
      (unless (memq mod searched)
        (set! searched (cons mod searched))
        (hash-table-for-each
         (module-table mod)
         (lambda (symbol value)
           (let1 c (eval symbol mod)
             (when (is-a? c <class>)
               (set! result (cons c result))))))))

    (for-each search (module-imports module))
    (for-each search (module-precedence-list module))
    result))

(define (make-hierarchy-tree lis top parents-of name-of)
  (set! lis (sort lis
                  (lambda (a b)
                    (string<? (symbol->string (name-of a))
                              (symbol->string (name-of b))))))
  (let loop ((node top))
    (cons node
          (filter identity
                  (map (lambda (e)
                         (if (memq node (map name-of (parents-of e)))
                             (loop (name-of e)) #f))
                       lis)))))

(define (show-module-hierarchy . args)
  (let-optionals* args ((top 'null))
    (pretty-print (make-hierarchy-tree (all-modules) top
                                       module-parents module-name))))

(define (show-class-hierarchy . args)
  (let-optionals* args ((top '<top>))
    (pretty-print (make-hierarchy-tree (all-classes) top
                                       class-direct-supers class-name))))

(show-module-hierarchy)
(show-class-hierarchy)