License date update
[clfswm.git] / src / clfswm-menu.lisp
bloba4f2ba7f39acb3e977ed7157b81d69de8fbb7711
1 ;;; --------------------------------------------------------------------------
2 ;;; CLFSWM - FullScreen Window Manager
3 ;;;
4 ;;; --------------------------------------------------------------------------
5 ;;; Documentation: Menu functions
6 ;;; --------------------------------------------------------------------------
7 ;;;
8 ;;; (C) 2005-2015 Philippe Brochard <pbrochard@common-lisp.net>
9 ;;;
10 ;;; This program is free software; you can redistribute it and/or modify
11 ;;; it under the terms of the GNU General Public License as published by
12 ;;; the Free Software Foundation; either version 3 of the License, or
13 ;;; (at your option) any later version.
14 ;;;
15 ;;; This program is distributed in the hope that it will be useful,
16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;;; GNU General Public License for more details.
19 ;;;
20 ;;; You should have received a copy of the GNU General Public License
21 ;;; along with this program; if not, write to the Free Software
22 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
23 ;;;
24 ;;; --------------------------------------------------------------------------
26 (in-package :clfswm)
29 (defmacro with-all-menu ((menu item) &body body)
30 (let ((rec (gensym))
31 (subm (gensym)))
32 `(labels ((,rec (,item)
33 ,@body
34 (when (menu-p ,item)
35 (dolist (,subm (menu-item ,item))
36 (,rec ,subm)))
37 (when (and (menu-item-p ,item) (menu-p (menu-item-value ,item)))
38 (,rec (menu-item-value ,item)))))
39 (,rec ,menu))))
41 (defun add-item (item &optional (menu *menu*))
42 (setf (menu-item menu) (nconc (menu-item menu) (list item))))
44 (defun del-item (item &optional (menu *menu*))
45 (setf (menu-item menu) (remove item (menu-item menu))))
49 ;;; Finding functions
50 (defun find-menu (name &optional (root *menu*))
51 (with-all-menu (root item)
52 (when (and (menu-p item)
53 (equal name (menu-name item)))
54 (return-from find-menu item))))
56 (defun find-toplevel-menu (name &optional (root *menu*))
57 (when (menu-p root)
58 (dolist (item (menu-item root))
59 (when (and (menu-item-p item)
60 (menu-p (menu-item-value item)))
61 (when (equal name (menu-name (menu-item-value item)))
62 (return (menu-item-value item)))))))
65 (defun find-item-by-key (key &optional (root *menu*))
66 (with-all-menu (root item)
67 (when (and (menu-item-p item)
68 (equal (menu-item-key item) key))
69 (return-from find-item-by-key item))))
71 (defun find-item-by-value (value &optional (root *menu*))
72 (with-all-menu (root item)
73 (when (and (menu-item-p item)
74 (equal (menu-item-value item) value))
75 (return-from find-item-by-value item))))
78 (defun del-item-by-key (key &optional (menu *menu*))
79 (del-item (find-item-by-key key menu) menu))
81 (defun del-item-by-value (value &optional (menu *menu*))
82 (del-item (find-item-by-value value menu) menu))
86 ;;; Convenient functions
87 (defun find-next-menu-key (key menu)
88 "key is :next for the next free key in menu or a string"
89 (if (eql key :next)
90 (string (number->char (length (menu-item menu))))
91 key))
94 (defun add-menu-key (menu-name key value &optional (root *menu*))
95 (let ((menu (find-menu menu-name root)))
96 (add-item (make-menu-item :key (find-next-menu-key key menu) :value value) (find-menu menu-name root))))
98 (defun add-sub-menu (menu-or-name key sub-menu-name &optional (doc "Sub menu") (root *menu*))
99 (let ((menu (if (or (stringp menu-or-name) (symbolp menu-or-name))
100 (find-menu menu-or-name root)
101 menu-or-name))
102 (submenu (make-menu :name sub-menu-name :doc doc)))
103 (add-item (make-menu-item :key (find-next-menu-key key menu) :value submenu) menu)
104 submenu))
108 (defun del-menu-key (menu-name key &optional (root *menu*))
109 (del-item-by-key key (find-menu menu-name root)))
111 (defun del-menu-value (menu-name value &optional (root *menu*))
112 (del-item-by-value value (find-menu menu-name root)))
114 (defun del-sub-menu (menu-name sub-menu-name &optional (root *menu*))
115 (del-item-by-value (find-menu sub-menu-name) (find-menu menu-name root)))
117 (defun clear-sub-menu (menu-name sub-menu-name &optional (root *menu*))
118 (setf (menu-item (find-menu sub-menu-name (find-menu menu-name root))) nil))
121 (defun add-menu-comment (menu-name &optional (comment "---") (root *menu*))
122 (add-item (make-menu-item :key nil :value comment) (find-menu menu-name root)))
126 (defun init-menu ()
127 (setf *menu* (make-menu :name 'main :doc "Main menu")))
130 ;;; Display menu functions
131 (defun open-menu-do-action (action menu parent)
132 (typecase action
133 (menu (open-menu action (cons menu parent)))
134 (null (awhen (first parent)
135 (open-menu it (rest parent))))
136 (t (when (fboundp action)
137 (funcall action)))))
140 (let ((menu-oppened nil))
141 (defun reset-open-menu ()
142 (setf menu-oppened nil))
144 (defun open-menu (&optional (menu *menu*) (parent nil))
145 "Open the main menu"
146 (unless menu-oppened
147 (setf menu-oppened t)
148 (when menu
149 (let ((action nil)
150 (old-info-keys (copy-hash-table *info-keys*)))
151 (labels ((menu-entry (item value)
152 (list (list (format nil "~A" (menu-item-key item)) *menu-color-menu-key*)
153 (list (format nil ": < ~A >" (menu-doc value)) *menu-color-submenu*)
154 (list (format nil " ~A" (find-associated-key-bindings
155 (create-symbol 'open- (menu-name value))))
156 *menu-key-bound-color*)))
157 (menu-comment (item)
158 (list (list (format nil "~A" (menu-item-value item)) *menu-color-comment*)))
159 (menu-line (item value)
160 (list (list (format nil "~A" (menu-item-key item)) *menu-color-key*)
161 (format nil ": ~A" (documentation value 'function))
162 (list (format nil " ~A" (find-associated-key-bindings value))
163 *menu-key-bound-color*)))
164 (populate-menu ()
165 (let ((info-list nil))
166 (dolist (item (menu-item menu))
167 (let ((value (menu-item-value item)))
168 (push (typecase value
169 (menu (menu-entry item value))
170 (string (menu-comment item))
171 (t (menu-line item value)))
172 info-list)
173 (when (menu-item-key item)
174 (define-info-key-fun (list (menu-item-key item))
175 (lambda (&optional args)
176 (declare (ignore args))
177 (setf action value)
178 (leave-info-mode nil))))))
179 (nreverse info-list))))
180 (let ((selected-item (info-mode (populate-menu))))
181 (setf *info-keys* old-info-keys)
182 (when (and selected-item (>= selected-item 0))
183 (awhen (nth selected-item (menu-item menu))
184 (setf action (menu-item-value it)))))
185 (setf menu-oppened nil)
186 (open-menu-do-action action menu parent)))))))