(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/require.ss"
           "../model/class-hierarchy.ss")
  (require-hierarchy)
  (require-etc)

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

  (define-hierarchy/provide/contract
    (list-record
     ([class class?]
      [open boolean?]
      [active (one-of/c 'auto 'on 'off)])))

  (define-hierarchy/provide/contract
    (tree-record
     ([open boolean?]
      [active (one-of/c 'auto 'on 'off)])))

  (define (forest->predicate forest)
    (lambda (class%)
      (forest->pred/k forest class% (constant #t))))

  (define (forest->pred/k forest class% k)
    (let loop ([trees (class-forest-trees forest)])
      (if (null? trees)
          (k)
          (tree->pred/k (car trees) class%
                        (lambda ()
                          (loop (cdr trees)))))))

  (define (tree->pred/k tree class% k)
    (let* ([parent% (class-tree-parent tree)]
           [trecord (class-tree-assoc tree)]
           [children (class-tree-children tree)])
      (if (subclass? class% parent%)
          (if (subclass? parent% class%)
              (tree-record->pred/k trecord k)
              (forest->pred/k children class%
                              (lambda ()
                                (tree-record->pred/k trecord k))))
          (k))))

  (define (tree-record->pred/k trecord k)
    (case (tree-record-active trecord)
      [(on) #t]
      [(off) #f]
      [(auto) (k)]))

  (define (class-hierlist-mixin super%)
    (class super%
      (super-new)

      (init-field gui)
      (init hierarchy)

      (set-hierarchy hierarchy)

      (inherit get-items delete-item new-list)
      (override on-select
                on-item-opened
                on-item-closed)
      (public fold get-hierarchy set-hierarchy)
      (private clear-hierarchy add-forest)

      (define (on-select item)
        (send gui show-item (and item (send item user-data))))

      (define (on-item-opened item)
        (set-list-record-open! (send item user-data) #t))

      (define (on-item-closed item)
        (set-list-record-open! (send item user-data) #f))

      (define (fold combine base)
        (foldl (lambda (item base) (send item fold combine base))
               base
               (get-items)))

      (define (get-hierarchy)
        (fold (lambda (lrecord forest)
                (class-forest-insert
                 (list-record-class lrecord)
                 forest
                 (make-tree-record (list-record-open lrecord)
                                   (list-record-active lrecord))))
              (make-class-forest)))

      (define (set-hierarchy forest)
        (clear-hierarchy)
        (add-forest forest))

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

      (define (add-forest forest)
        (for-each (lambda (tree)
                    (send (new-list class-item-mixin) set-hierarchy tree))
                  (class-forest-trees forest)))
      ))

  (define (class-item-mixin super%)
    (class super%
      (super-new)

      (inherit user-data get-items get-editor open close new-list)
      (public fold set-hierarchy)

      (define (fold combine base)
        (foldl (lambda (item base) (send item fold combine base))
               (combine (user-data) base)
               (get-items)))

      (define (set-hierarchy tree)
        (let* ([parent (class-tree-parent tree)]
               [trecord (class-tree-assoc tree)]
               [open? (tree-record-open trecord)]
               [active (tree-record-active trecord)])
          (user-data (make-list-record parent open? active))
          (send (get-editor) insert
                (make-object string-snip% (class-name parent)))
          (if open? (open) (close))
          (for-each (lambda (child)
                      (send (new-list class-item-mixin) set-hierarchy child))
                    (class-forest-trees (class-tree-children tree)))))
      ))

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

      (init hierarchy)

      (define controls (new horizontal-panel%
                            [parent this]
                            [stretchable-height #f]))
      (define hierlist (new (class-hierlist-mixin hierarchical-list%)
                            [parent this]
                            [gui this]
                            [hierarchy hierarchy]))
      (define current-record #f)
      (define class-label
        (new message%
             [label "No class selected."]
             [parent controls]
             [stretchable-width #t]))
      (define active-choice
        (new choice%
             [parent controls]
             [label #f]
             [choices (list "auto" "on" "off")]
             [enabled #f]
             [callback
              (lambda (c e)
                (set-list-record-active!
                 current-record
                 (case (send active-choice get-selection)
                   [(0) 'auto]
                   [(1) 'on]
                   [(2) 'off])))]))

      (public get-hierarchy set-hierarchy show-item get-predicate)

      (define (get-hierarchy)
        (send hierlist get-hierarchy))

      (define (set-hierarchy hier)
        (show-item #f)
        (send hierlist set-hierarchy hier))

      (define (get-predicate)
        (forest->predicate (get-hierarchy)))

      (define (show-item lrecord)
        (set! current-record lrecord)
        (if lrecord
            (begin
              (send class-label set-label
                    (format "Trace class: ~a"
                            (class-name (list-record-class lrecord))))
              (send active-choice set-selection
                    (case (list-record-active lrecord)
                      [(auto) 0]
                      [(on) 1]
                      [(off) 2]))
              (send active-choice enable #t))
            (begin
              (send class-label set-label "No class selected.")
              (send active-choice enable #f))))
      ))

  (define (test)

    (define default-record (make-tree-record #t 'auto))
    (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 (lambda (c f)
                            (class-forest-insert c f default-record))
                          (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))

  )