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

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

Four New Tools.

File size: 7.3 KB
Line 
1;;;-*-Mode: LISP; Package: HEMLOCK-COMMANDS -*-
2
3;;; ----------------------------------------------------------------------------
4;;;
5;;;      hemlock-commands-2.lisp
6;;;
7;;;      copyright © 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   (doc-path :initform (merge-pathnames ";ReadMe.rtf" cl-user::*hemlock-commands-directory*) :reader doc-path))
108  (:documentation "A popup menu with keyword submenus for filtering Hemlock commands.")
109  (:metaclass ns:+ns-object))
110
111(objc:defmethod (#/hemlockCommandDocAction: :void) ((m hemlock-commands-keyword-menu) (sender :id))
112  (display-doc (item-command sender)))
113
114(defmethod initialize-instance :after ((menu hemlock-commands-keyword-menu) &key)
115  (setf (tool-menu menu) (cmenu:add-default-tool-menu menu :doc-file (doc-path menu))))
116
117(defmethod add-submenus ((menu hemlock-commands-keyword-menu))
118  (let ((keyword-array (make-array  (length *hemlock-command-keywords*) :initial-element nil))
119        miscellaneous)
120    (dotimes (index (hi::string-table-num-nodes hi::*command-names*))
121      (let* ((idx 0)
122             (command (hi::value-node-value (aref (hi::string-table-value-nodes hi::*command-names*) index)))
123             (command-name (hi::command-%name command))
124             (entry-found-p nil))
125        (dolist (keyword *hemlock-command-keywords*)
126          ;; commands will generally have multiple entries
127          (when (search keyword command-name :test #'string-equal)
128            (setq entry-found-p t)
129            (push (cons command-name command) (aref keyword-array idx)))
130          (incf idx))
131      (unless entry-found-p (push (cons command-name command) miscellaneous))))
132    (let ((idx 0))
133      (dolist (keyword *hemlock-command-keywords*)
134        (let ((submenu-item (make-submenu-item keyword (coerce (aref keyword-array idx) 'list))))
135          (#/addItem: menu submenu-item))
136        (incf idx)))
137    (when miscellaneous
138      (#/addItem: menu (#/separatorItem ns:ns-menu-item))   
139      (let ((submenu-item (make-submenu-item "Commands Without Keywords:" miscellaneous)))
140        (#/addItem: menu submenu-item)))))
141
142
143(objc:defmethod (#/update :void) ((self hemlock-commands-keyword-menu))
144  (cmenu:update-tool-menu self (tool-menu self))
145  (call-next-method))
146
147
148(setq *hemlock-commands-keyword-menu* (make-instance 'hemlock-commands-keyword-menu))
149
150(add-submenus *hemlock-commands-keyword-menu*)
151
152
153
154
Note: See TracBrowser for help on using the repository browser.