source: trunk/source/contrib/foy/cl-documentation-cm/cl-documentation-2.lisp @ 12784

Last change on this file since 12784 was 12784, checked in by gfoy, 11 years ago

Remove-duplicates in alpha list.

File size: 4.5 KB
Line 
1;;;-*-Mode: LISP; Package: HEMLOCK-COMMANDS -*-
2
3;;; ----------------------------------------------------------------------------
4;;;
5;;;      cl-documentation-2.lisp
6;;;
7;;;      copyright (c) 2009 Glen Foy
8;;;      (Permission is granted to Clozure Associates to distribute this file.)
9;;;
10;;;      This code adds an alphabetical index of :CL commands to the Context-Menu
11;;;      mechanism.  Command-Right-Click displays a list of letter submenus.
12;;;      Popping the submenu displays entries for all Hemlock Commands starting with
13;;;      that letter.  Selecting an entry opens a documentation dialog.
14;;;
15;;;      This software is offered "as is", without warranty of any kind.
16;;;
17;;;      Mod History, most recent first:
18;;;      9/2/9  version 0.1b1
19;;;              First cut.
20;;;
21;;; ----------------------------------------------------------------------------
22
23(in-package "CL-DOCUMENTATION") 
24
25
26;;; ----------------------------------------------------------------------------
27;;;
28(defclass CL-ALPHABETICAL-MENU-ITEM (ns:ns-menu-item)
29  ((symbol :initarg :symbol :accessor item-symbol))
30  (:documentation "Support for the CL alphabetical menu.")
31  (:metaclass ns:+ns-object))
32
33(defun populate-submenu (menu symbol-list)
34  "Make menu-items for all symbols in SYMBOL-LIST, and add them to MENU"
35  (dolist (symbol (reverse symbol-list))
36    (let* ((menu-item (make-instance 'cl-alphabetical-menu-item :symbol symbol))
37           (attributed-string (#/initWithString:attributes:
38                               (#/alloc ns:ns-attributed-string) 
39                               (ccl::%make-nsstring (string-downcase (string symbol)))
40                               cmenu:*hemlock-menu-dictionary*)))
41;      (setf (item-symbol menu-item) symbol)
42      (#/setAttributedTitle: menu-item attributed-string)
43      (#/setAction: menu-item (ccl::@selector "clAlphabeticalDocAction:"))
44      (#/setTarget: menu-item  *cl-alphabetical-menu*)
45      (#/addItem: menu menu-item))))
46
47(defun make-submenu-item (title symbol-list)
48  "Create a menu-item with a submenu, and populate the submenu with the symbols in SYMBOL-LIST."
49  (let ((menu-item (make-instance ns:ns-menu-item))
50        (attributed-string (#/initWithString:attributes:
51                            (#/alloc ns:ns-attributed-string) 
52                            (ccl::%make-nsstring title)
53                            cmenu:*hemlock-menu-dictionary*))
54        (submenu (make-instance ns:ns-menu)))
55    (#/setAttributedTitle: menu-item attributed-string)
56    (#/setSubmenu: menu-item submenu)
57    (populate-submenu submenu symbol-list)
58    menu-item))
59
60(defparameter *ABCs* "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
61
62;;; ----------------------------------------------------------------------------
63;;;
64(defclass CL-ALPHABETICAL-MENU (ns:ns-menu)
65  ((tool-menu :initform nil :accessor tool-menu)
66   (text-view :initform nil :accessor text-view)
67   (sub-title :initform "alphabetical" :reader sub-title))
68  (:documentation "A popup menu with alphabetically ordered letter submenus.")
69  (:metaclass ns:+ns-object))
70
71(objc:defmethod (#/clAlphabeticalDocAction: :void) ((m cl-alphabetical-menu) (sender :id))
72  (display-cl-doc (item-symbol sender) (text-view m)))
73
74(defmethod initialize-instance :after ((menu cl-alphabetical-menu) &key)
75  (setf (tool-menu menu) (cmenu:add-default-tool-menu menu)))
76
77(defmethod add-submenus ((menu cl-alphabetical-menu))
78  (let* ((letter-array-length (length *ABCs*))
79         (letter-array (make-array letter-array-length :initial-element nil))
80         miscellaneous first-letter index)
81    (dolist (sym (remove-duplicates (apply #'append *cl-symbol-lists*) :test #'eq))
82      (setq first-letter (elt (string sym) 0))
83      (setq index (position first-letter *ABCs* :test #'char-equal))
84      (if index
85        (push sym (aref letter-array index))
86        (push sym miscellaneous)))
87    (dotimes (idx letter-array-length)
88      (let ((submenu-item (make-submenu-item (elt *ABCs* idx) 
89                                             (sort (coerce (aref letter-array idx) 'list)
90                                                   #'string> :key #'string))))
91        (#/addItem: menu submenu-item)))
92    (when miscellaneous
93      (#/addItem: menu (#/separatorItem ns:ns-menu-item))   
94      (let ((submenu-item (make-submenu-item "Other:" miscellaneous)))
95        (#/addItem: menu submenu-item)))))
96
97(objc:defmethod (#/update :void) ((self cl-alphabetical-menu))
98  (cmenu:update-tool-menu self (tool-menu self) :sub-title (sub-title self))
99  (call-next-method))
100
101(setq *cl-alphabetical-menu* (make-instance 'cl-alphabetical-menu))
102
103(add-submenus *cl-alphabetical-menu*)
104
105
106
107
Note: See TracBrowser for help on using the repository browser.