source: trunk/source/contrib/foy/hemlock-commands-cm/hemlock-commands-2.lisp @ 12735

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

Changed the appearance of the Default Tool submenu and added an alphabetical index to CL-Documentation-CM

File size: 7.4 KB
Line 
1;;;-*-Mode: LISP; Package: HEMLOCK-COMMANDS -*-
2
3;;; ----------------------------------------------------------------------------
4;;;
5;;;      hemlock-commands-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 a Hemlock Commands documentation tool to the Context-Menu
11;;;      mechanism.  Right-Click displays a list of submenus.  The submenus are keywords.
12;;;      Popping the submenu displays entries for all Hemlock Commands filtered by that
13;;;      keyword.  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;;;      8/31/9  version 0.1b1
19;;;              First cut.
20;;;
21;;; ----------------------------------------------------------------------------
22
23(in-package "HEMLOCK-COMMANDS")
24
25;;; ----------------------------------------------------------------------------
26;;;
27(defclass HEMLOCK-COMMAND-KEYWORD-MENU-ITEM (ns:ns-menu-item)
28  ((command :initform nil :accessor item-command))
29  (:documentation "Support for the hemlock command keyword menu.")
30  (:metaclass ns:+ns-object))
31
32(defun display-doc (command)
33  "Open the documentation dialog for COMMAND."
34  (let ((keystroke-string
35         (do* ((bindings (hi::command-%bindings command) (rest bindings))
36               (bindings-length (length bindings))
37               (binding (car bindings) (car bindings))
38               (event-array (when binding (car binding))
39                            (when binding (car binding)))
40               (num-events (when event-array (array-dimension event-array 0))
41                           (when event-array (array-dimension event-array 0)))
42               (keystrokes "" (if binding 
43                                (concatenate 'string keystrokes ",   ")
44                                keystrokes)))
45              ((or (null bindings) (> bindings-length 4))
46                   (if (> bindings-length 4)
47                     "Too many bindings ..."
48                     keystrokes))
49           (when event-array
50             (cond ((= num-events 1)
51                    (setq keystrokes 
52                          (concatenate 'string
53                                       keystrokes
54                                       (hi::pretty-key-string (aref event-array 0) t))))
55                   (t
56                    (setq keystrokes
57                          (concatenate 'string 
58                                       keystrokes
59                                       (format nil "~A  ~A" 
60                                               (hi::pretty-key-string (aref event-array 0) t)
61                                               (hi::pretty-key-string (aref event-array 1) t))))))))))
62    (open-documentation-dialog (hi::command-%name command)
63                             (if (string= keystroke-string "") "no binding" keystroke-string)
64                             (hi::command-documentation command) :hemlock-p t)))
65
66(defun populate-submenu (menu command-list)
67  "Make menu-items for all commands in COMMAND-LIST, and add them to MENU"
68  (dolist (command-cons (reverse command-list))
69    (let* ((command-name (car command-cons))
70           (command (cdr command-cons))
71           (menu-item (make-instance 'hemlock-command-keyword-menu-item))
72           (attributed-string (#/initWithString:attributes:
73                               (#/alloc ns:ns-attributed-string) 
74                               (ccl::%make-nsstring command-name)
75                               cmenu:*hemlock-menu-dictionary*)))
76      (#/setAttributedTitle: menu-item attributed-string)
77      (#/setAction: menu-item (ccl::@selector "hemlockCommandDocAction:"))
78      (#/setTarget: menu-item  *hemlock-commands-keyword-menu*)
79      ;; (#/setImage: menu-item class-icon)
80      (setf (item-command menu-item) command)
81      (#/addItem: menu menu-item))))
82
83(defun make-submenu-item (title command-list)
84  "Create a menu-item with a submenu, and populate the submenu with the commands in COMMAND-LIST."
85  (let ((menu-item (make-instance ns:ns-menu-item))
86        (attributed-string (#/initWithString:attributes:
87                            (#/alloc ns:ns-attributed-string) 
88                            (ccl::%make-nsstring title)
89                            cmenu:*hemlock-menu-dictionary*))
90        (submenu (make-instance ns:ns-menu)))
91    (#/setAttributedTitle: menu-item attributed-string)
92    (#/setSubmenu: menu-item submenu)
93    (populate-submenu submenu command-list)
94    menu-item))
95
96(defparameter *hemlock-command-keywords*
97  '("auto" "backward" "beginning" "buffer" "character" "command" "comment" "compile" "completion" "count" "defun" "delete" "describe"
98    "down" "echo" "editor" "end" "evaluate" "expression" "file" "form" "forward" "function" "goto" "help" "i-search"
99    "indent" "insert" "interactive" "kill" "line" "list" "macroexpand" "mark" "mode" "next" "paragraph" "parse"
100    "point" "pop" "previous" "query" "region" "register" "save" "search" "select" "sentence" "set" "show" "space" 
101    "transpose" "up" "what" "word" "write"))
102
103;;; ----------------------------------------------------------------------------
104;;;
105(defclass HEMLOCK-COMMANDS-KEYWORD-MENU (ns:ns-menu)
106  ((tool-menu :initform nil :accessor tool-menu)
107   (sub-title :initform "keyword filters" :reader sub-title)
108   (doc-path :initform (merge-pathnames ";ReadMe.rtf" cl-user::*hemlock-commands-directory*) :reader doc-path))
109  (:documentation "A popup menu with keyword submenus for filtering Hemlock commands.")
110  (:metaclass ns:+ns-object))
111
112(objc:defmethod (#/hemlockCommandDocAction: :void) ((m hemlock-commands-keyword-menu) (sender :id))
113  (display-doc (item-command sender)))
114
115(defmethod initialize-instance :after ((menu hemlock-commands-keyword-menu) &key)
116  (setf (tool-menu menu) (cmenu:add-default-tool-menu menu :doc-file (doc-path menu))))
117
118(defmethod add-submenus ((menu hemlock-commands-keyword-menu))
119  (let ((keyword-array (make-array  (length *hemlock-command-keywords*) :initial-element nil))
120        miscellaneous)
121    (dotimes (index (hi::string-table-num-nodes hi::*command-names*))
122      (let* ((idx 0)
123             (command (hi::value-node-value (aref (hi::string-table-value-nodes hi::*command-names*) index)))
124             (command-name (hi::command-%name command))
125             (entry-found-p nil))
126        (dolist (keyword *hemlock-command-keywords*)
127          ;; commands will generally have multiple entries
128          (when (search keyword command-name :test #'string-equal)
129            (setq entry-found-p t)
130            (push (cons command-name command) (aref keyword-array idx)))
131          (incf idx))
132      (unless entry-found-p (push (cons command-name command) miscellaneous))))
133    (let ((idx 0))
134      (dolist (keyword *hemlock-command-keywords*)
135        (let ((submenu-item (make-submenu-item keyword (coerce (aref keyword-array idx) 'list))))
136          (#/addItem: menu submenu-item))
137        (incf idx)))
138    (when miscellaneous
139      (#/addItem: menu (#/separatorItem ns:ns-menu-item))   
140      (let ((submenu-item (make-submenu-item "Commands Without Keywords:" miscellaneous)))
141        (#/addItem: menu submenu-item)))))
142
143
144(objc:defmethod (#/update :void) ((self hemlock-commands-keyword-menu))
145  (cmenu:update-tool-menu self (tool-menu self) :sub-title (sub-title self))
146  (call-next-method))
147
148
149(setq *hemlock-commands-keyword-menu* (make-instance 'hemlock-commands-keyword-menu))
150
151(add-submenus *hemlock-commands-keyword-menu*)
152
153
154
155
Note: See TracBrowser for help on using the repository browser.