[cells-cvs] CVS update: cell-cultures/clyde/visual-apropos/visual-apropos.lisp
Kenny Tilton
ktilton at common-lisp.net
Sun Jul 4 18:59:45 UTC 2004
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)
More information about the Cells-cvs
mailing list