source: trunk/cocoa-ide-contrib/foy/hemlock-commands-cm/hemlock-commands-2.lisp @ 14985

Last change on this file since 14985 was 14985, checked in by gfoy, 9 years ago

Updates for ccl 1.7

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