(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)) )