gui/class-gui.ss
(module class-gui mzscheme

  (require (lib "contract.ss")
           (lib "class.ss")
           (lib "mred.ss" "mred")
           (lib "hierlist.ss" "hierlist")
           (lib "list.ss")
           "draw.ss"
           "interfaces.ss"
           "snip-gui.ss"
           "../model/class-hierarchy.ss")

  (provide/contract
   [class-gui% (class/c panel%)])

  (define class-gui%
    (class vertical-panel%
      (super-new)

      (init ([hier hierarchy]))

      (define hierarchy hier)
      (define hierlist (new hierarchical-list% [parent this] [style '()]))
      (send hierlist selectable #f)

      (public get-hierarchy set-hierarchy)
      (private on-update clear)

      (define (get-hierarchy)
        hierarchy)

      (define (set-hierarchy hier)
        (set! hierarchy hier)
        (on-update))

      (define (on-update)
        (clear)
        (add-forest hierarchy hierlist))

      (define (clear)
        (for-each (lambda (item) (send hierlist delete-item))
                  (send hierlist get-items)))

      ;; Initialization
      (on-update)))

  ;; add-forest : ClassForest HierList
  ;; Adds the structure of a class forest to a hierarchical list or list item.
  (define (add-forest forest hierlist)
    (for-each (lambda (tree) (add-tree tree hierlist))
              (class-forest-trees forest)))

  ;; add-tree : ClassTree HierList
  ;; Adds the structure of a class tree to a hierarchical list or list item.
  (define (add-tree tree hierlist)
    (if (class-tree-singleton? tree)
        (let* ([item (send hierlist new-item)])
          (initialize-item item tree))
        (let* ([item (send hierlist new-list)])
          (initialize-item item tree)
          (add-forest (class-tree-children tree) item))))

  ;; initialize-item : HierList Tree -> Void
  ;; Sets the display of an individual class.
  (define (initialize-item item tree)
    (send (send item get-editor) insert
          (make-object string-snip% (class-name (class-tree-parent tree)))))

  (define (test)

    (define class-one% (class object% (super-new)))
    (define class-two% (class object% (super-new)))
    (define class-one-one% (class class-one% (super-new)))
    (define class-one-one-one% (class class-one-one% (super-new)))
    (define class-two-one% (class class-two% (super-new)))
    (define class-two-two% (class class-two% (super-new)))

    (define forest (foldl class-forest-insert
                          (make-class-forest)
                          (list class-one% class-two%
                                class-one-one% class-one-one-one%
                                class-two-one% class-two-two%)))

    (define frame (new frame% [label "Class GUI"]))
    (define gui (new class-gui% [parent frame] [hierarchy forest]))

    (send frame show #t))

  (test)

  )