From a6508485aa298480a387a9760b032a7b15898ac4 Mon Sep 17 00:00:00 2001 From: Dmitry Kalyanov Date: Thu, 23 Apr 2009 23:06:50 +0400 Subject: [PATCH] Add class-browser demo --- gtk/gtk.demo.lisp | 54 +++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 52 insertions(+), 2 deletions(-) diff --git a/gtk/gtk.demo.lisp b/gtk/gtk.demo.lisp index 7282b5c..8c52342 100644 --- a/gtk/gtk.demo.lisp +++ b/gtk/gtk.demo.lisp @@ -22,7 +22,8 @@ #:test-calendar #:test-box-child-property #:test-builder - #:demo-text-editor)) + #:demo-text-editor + #:demo-class-browser)) (in-package :gtk-demo) @@ -628,4 +629,53 @@ ("eval" ,#'cb-eval))) (g-signal-connect window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main))) (g-signal-connect (text-view-buffer text-view) "changed" (lambda (b) (declare (ignore b)) (setf modified-p t) (set-properties))) - (widget-show window))))) \ No newline at end of file + (widget-show window))))) + +(defun demo-class-browser () + (let ((output *standard-output*)) + (with-main-loop + (let* ((window (make-instance 'gtk-window + :window-position :center + :title "Class Browser" + :default-width 400 + :default-height 600)) + (search-entry (make-instance 'entry)) + (search-button (make-instance 'button :label "Search")) + (scroll (make-instance 'scrolled-window + :hscrollbar-policy :automatic + :vscrollbar-policy :automatic)) + (slots-model (make-instance 'array-list-store)) + (slots-list (make-instance 'tree-view :model slots-model))) + (let ((v-box (make-instance 'v-box)) + (search-box (make-instance 'h-box))) + (container-add window v-box) + (box-pack-start v-box search-box :expand nil) + (box-pack-start search-box search-entry) + (box-pack-start search-box search-button :expand nil) + (box-pack-start v-box scroll) + (container-add scroll slots-list)) + (store-add-column slots-model "gchararray" + (lambda (slot) + (format nil "~S" (closer-mop:slot-definition-name slot)))) + (let ((col (make-instance 'tree-view-column :title "Slot name")) + (cr (make-instance 'cell-renderer-text))) + (tree-view-column-pack-start col cr) + (tree-view-column-add-attribute col cr "text" 0) + (tree-view-append-column slots-list col)) + (labels ((display-class-slots (class) + (format output "Displaying ~A~%" class) + (loop + repeat (store-items-count slots-model) + do (store-remove-item slots-model (store-item slots-model 0))) + (closer-mop:finalize-inheritance class) + (loop + for slot in (closer-mop:class-slots class) + do (store-add-item slots-model slot))) + (on-search-clicked (button) + (declare (ignore button)) + (with-gtk-message-error-handler + (let* ((class-name (read-from-string (entry-text search-entry))) + (class (find-class class-name))) + (display-class-slots class))))) + (g-signal-connect search-button "clicked" #'on-search-clicked)) + (widget-show window))))) -- 1.7.10.4