Update of /project/cells/cvsroot/cell-cultures/clyde/visual-apropos In directory common-lisp.net:/tmp/cvs-serv5472/clyde/visual-apropos

Modified Files: visual-apropos.lisp Log Message:

Date: Sun Jul 4 11:59:45 2004 Author: ktilton

Index: cell-cultures/clyde/visual-apropos/visual-apropos.lisp diff -u cell-cultures/clyde/visual-apropos/visual-apropos.lisp:1.1 cell-cultures/clyde/visual-apropos/visual-apropos.lisp:1.2 --- cell-cultures/clyde/visual-apropos/visual-apropos.lisp:1.1 Sun Jun 27 16:52:25 2004 +++ cell-cultures/clyde/visual-apropos/visual-apropos.lisp Sun Jul 4 11:59:45 2004 @@ -21,12 +21,7 @@

#| do list

-why some symbols show without classification? -close up list of symbols for gaps -add "String" with underscore for symbol entry -make symbol entry also a pop-up -get packages pop-up working and honored -make symbol list into proper listbox +at least show search in entry

|#

@@ -40,97 +35,224 @@

(defun vis-apropos () (make-be 'visual-apropos - :sub-symbol 'thread)) + :sub-symbol 'padding))

-(defmodel visual-apropos (frame) +(defmodel visual-apropos (frame-stack) ((symbols :initarg :symbols :initform nil :accessor symbols) (sub-symbol :initarg :sub-symbol :initform nil :accessor sub-symbol)) (:default-initargs - :layout (layout-stack) :symbols (c? (apropos-list (^sub-symbol))) + :pady 2 + :padx 4 + :layout (pack-layout? "-side left -fill both -expand 1 -anchor nw") :kids (c? (list (search-for-symbol) - (frame-row () - (frame-stack () - (exported-only) - (package-searching)) - (show-which-symbols)) + (frame-row + :padx 8 + :layout (pack-layout? "-side left -fill x") + :kids (c? (list + (frame-stack + :kids (c? (list + (checkbutton :md-name :exported-only + :text "Exported Only" + :underline 1 + :md-value (c-in nil) + :command (lambda (self) + (setf (^md-value) (not (^md-value))))) + (show-which-symbols)))) + (package-filtering)))) + (label :text (c? (format nil "Symbols containing ~a" + (sub-symbol .parent))) + :underline 4) (symbol-list)))))

(defun search-for-symbol () - (frame-row () - (label :text "String:" - :underline 4) - (entry :md-name :search-string - :text (c? (symbol-name (md-value (upper self visual-apropos))))) - (button :text "Search" - :underline 0 - :command (lambda (self) - (setf (md-value (upper self visual-apropos)) - (md-value (fm^ :search-string))))))) - -(defun exported-only () - (checkbutton :md-name :exported-only - :text "Show Exported Symbols Only" - :md-value (c-in nil) - :command (lambda (self) - (setf (^md-value) (not (^md-value)))))) - -(defun package-searching () - (labelframe :text "Package(s) to Search" - :layout (layout-row) - :kids (c? (list - (checkbutton :md-name :all-pkgs - :text "All" - :md-value (c-in t) + (frame-row + :relief 'ridge + :padx 8 + :layout (pack-layout? "-side left -fill x -anchor nw") + :kids-layout (c? (format nil + "pack ~a -side left; pack ~a -side left -expand 1 -fill x; pack ~a -side right" + (path (kid1 self)) + (path (second (^kids))) + (path (third (^kids))))) + :kids (c? (list (label :text "String:" + :underline 4) + (entry :md-name :search-string + :text (c? (symbol-name (sub-symbol (upper self visual-apropos)))) + :width 64) + (button :text "Search" + :underline 0 :command (lambda (self) - (setf (^md-value) (not (^md-value))))) - (label :text "FNYI: Package pop-up menu"))))) + (setf (md-value (upper self visual-apropos)) + (md-value (fm^ :search-string))))))))) + +; --- symbol package filtering ------------------------------- + +(defun package-filtering () + (labelframe-row + :text " Package(s) to Search " + :layout (pack-layout? "-side left -fill x -expand 1") + :kids (c? (list + (checkbutton :md-name :all-pkgs + :text "All" + :underline 1 + :md-value (c-in t) + :command (lambda (self) + (setf (^md-value) (not (^md-value))))) + (scrolled-list + :md-name :in-package + :list-height 4 + :layout (pack-layout? "-side left -fill x -expand 1") + :enabled (c? (not (md-value (psib)))) + :list-items (c? (loop for p in (list-all-packages) + collecting (make-instance 'listbox-item + :md-value p + :item-text (down$ (package-name p)))))))))) + +; --- symbol binding filtering ---------------------------------------

(defun show-which-symbols () (labelframe-selector :md-name :which-symbols - :text "Show" + :text " With bindings " :tk-variable 'which-symbols :layout (c? (format nil "pack ~a -side {left}~:{; grid ~a -column ~d -row ~d -sticky w~}" (path self) (mapcar (lambda (k) (list (path k)(floor (kid-no k) 2) (mod (kid-no k) 2))) (^kids)))) - :initial-selection (c? (fm-other :all)) - :selection (c-in nil) + :selection (c-in :any) :kids (c? (flet ((rb (n) (radiobutton :md-name n :text (string-capitalize (string n)) :tk-variable (tk-variable self) :value n - :layout nil :underline 0))) - (list (rb :all)(rb :functions)(rb :variables)(rb :classes)))))) + :layout nil + :underline 0))) + (list (rb :any)(rb :functions)(rb :variables)(rb :classes))))))

(defun symbol-list () - (canvas :md-name :symbol-list - :kids (c? (let ((root (upper self visual-apropos))) - (loop for symbol in (symbols root) - for n upfrom 0 - when (va-show-symbol-p self symbol) - collect - (make-instance 'symbol-indicator$ - :anchor "nw" - :md-value symbol - :coords (list 10 (* n 20)))))))) + (frame-stack :md-name :symbol-list + :layout (pack-layout? "-side top -expand 1 -fill both") + :width 64 + :background 'red + :kids (c? (list + (frame-row + :md-name :sym-sort + :md-value (c-in nil) + :relief 'groove + :layout (pack-layout? "-side top -fill x -anchor w") + :kids (c? (flet ((va-button (&rest args) + (apply 'make-instance 'va-sorter args))) + (list + (va-button :layout nil + :md-name :sym-sym :text "Symbol Name" :width 28) + (va-button :layout nil :padx 10 + :text "Package" + :sort-string-fn 'package-name) + (va-button :layout nil :text "Function") + (va-button :layout nil :text "Setf" + :sort-string-fn (lambda (fn) + (if fn "x" ""))) + (va-button :layout nil :text "Var" :padx 5) + (va-button :layout nil :text "Class") + (va-button :layout nil :text "Exp"))))) + (scrolled-list + :layout (pack-layout? "-side top -expand 1 -fill both") + :width 64 + :list-height nil + :background 'white + :md-value (c? (let ((root (upper self visual-apropos))) + (loop for s in (symbols root) + for n upfrom 0 + when (va-show-symbol-p self s) + collect + (list + (symbol-name s) + (symbol-package s) + (cond + ((special-operator-p s) "special") + ((macro-function s) "macro") + ((fboundp s) + (if (typep (fdefinition s) 'generic-function) + "gf" "func")) + (t "")) + (fboundp `(setf ,s)) + (when (boundp s) + (if (constantp s) "con" "var")) + (find-class s nil) + (exported-p s))))) + :list-items (c? (let ((sorter (let ((ss (fm^ :sym-sort))) + (or (md-value (fm^ :sym-sort)) + (kid1 ss))))) + (sort (loop for si in (^md-value) + collect (make-instance 'va-symbol-info + :md-value si)) + (sort-button-predicate sorter) + :key (sort-button-key sorter))))))))) + +(defmodel sort-button (button) + ((sort-button-predicate :initarg :sort-button-predicate :accessor sort-button-predicate + :initform #'string<) + (sort-button-key :initarg :sort-button-key :accessor sort-button-key + :initform #'identity))) + +(defmodel va-sorter (sort-button) + ((sort-string-fn :initform 'string :initarg :sort-string-fn :accessor sort-string-fn)) + (:default-initargs + :command (lambda (self) + (let* ((ss (fm^ :sym-sort))) + (if (eq self (or (md-value ss) (kid1 ss))) + (setf (sort-button-predicate self) + (if (eq (sort-button-predicate self) 'string<) + 'string> 'string<)) + (setf (md-value ss) self)))) + :sort-button-predicate (c-in 'string<) + :sort-button-key (c? (lambda (si) + (funcall (^sort-string-fn) + (elt (md-value si) (kid-no self))))))) + +(defmodel va-symbol-info (listbox-item) + () + (:default-initargs + :item-text (c? (destructuring-bind (sname pkg fn setf var class exp) + (^md-value) + (format nil "~(~a~) ~27,T~(~a~) ~36,T~a ~43,T~a ~46,T~a ~52,T~a ~57,T~a" + (if (< (length sname) 26) + sname + (conc$ (left$ sname 22) "...")) + (down$ (let ((nn (car (package-nicknames pkg)))) + (if (plusp (length nn)) + nn + (package-name pkg)))) + (or fn "") + (if setf "x" "") + (or var "") + (if class "x" "") + (if exp "x" "")))))) + +(defun exported-p (symbol) + (eq :external (symbol-status symbol)))

(defun va-show-symbol-p (self symbol) (when (md-value (fm^ :exported-only)) - (unless (eq :external (symbol-status symbol)) + (unless (exported-p symbol) (return-from va-show-symbol-p nil))) - (let ((rb (selection (fm^ :which-symbols)))) - (when rb ;; not during initialization since echo of init-sel deferred (FIX) - (unless (ecase (md-name rb) - (:all t) + (let ((which (selection (fm^ :which-symbols)))) + (unless (ecase which + (:any t) (:functions (fboundp symbol)) (:classes (find-class symbol nil)) (:variables (boundp symbol))) - (return-from va-show-symbol-p nil)))) + (return-from va-show-symbol-p nil))) + (unless (or (md-value (fm^ :all-pkgs)) + (bIf (sel (selection (fm^ :in-package))) + (eq (symbol-package symbol) + (md-value (elt (list-items (fm^ :in-package)) sel))) + t)) + (return-from va-show-symbol-p nil)) + t)

(defun symbol-status (sym)