(module filter-frame mzscheme

  (require (lib "contract.ss")
           (lib "class.ss")
           (lib "mred.ss" "mred")
           "class-gui.ss"
           "interfaces.ss"
           "../model/require.ss"
           "../model/class-hierarchy.ss"
           "../model/view.ss"
           "../model/action-util.ss"
           "../model/pool.ss")
  (require-etc)

  (provide/contract
   [filter-frame% (class/c frame% updatee<%>)])

  (define filter-frame%
    (class* frame% (updatee<%>)
      (super-new [label "Filter Traced Classes"])

      (inherit show)
      (public on-update)

      (init buffer)
      (init-field trace-display)
      (define view (make-view buffer (constant #t)))
      (define count (view-count-objects view))
      (define panel (new vertical-panel% [parent this]))
      (define gui (new class-gui%
                       [hierarchy (make-class-forest)]
                       [parent panel]))
      (define done-button
        (new button%
             [parent panel]
             [label "Done"]
             [callback
              (lambda (b e)
                (show #f)
                (let* ([class-pred (send gui get-predicate)]
                       [obj-pred (lambda (obj)
                                   (and obj
                                        (class-pred (object-class obj))))])
                  (send trace-display set-filter
                        (lambda (action)
                          (or (obj-pred (action-source action))
                              (obj-pred (action-target action)))))))]))
      (define default-record (make-tree-record #t 'auto))

      (define (on-update)
        (view-update view)
        (let* ([new-count (view-count-objects view)]
               [hierarchy
                (let iter ([index count]
                           [hierarchy (send gui get-hierarchy)])
                  (if (< index new-count)
                      (let* ([class%
                              (object-class (view-get-object view index))])
                        (iter (+ index 1)
                              (if (class-forest-exists? class% hierarchy)
                                  hierarchy
                                  (class-forest-insert
                                   class% hierarchy default-record))))
                      hierarchy))])
          (send gui set-hierarchy hierarchy)
          (set! count new-count)))))

  )