1 ;;; --------------------------------------------------------------------------
2 ;;; CLFSWM - FullScreen Window Manager
4 ;;; --------------------------------------------------------------------------
5 ;;; Documentation: Menu functions
6 ;;; --------------------------------------------------------------------------
8 ;;; (C) 2011 Philippe Brochard <hocwp@free.fr>
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.
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.
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.
24 ;;; --------------------------------------------------------------------------
29 (defmacro with-all-menu
((menu item
) &body body
)
32 `(labels ((,rec
(,item
)
35 (dolist (,subm
(menu-item ,item
))
37 (when (and (menu-item-p ,item
) (menu-p (menu-item-value ,item
)))
38 (,rec
(menu-item-value ,item
)))))
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
))))
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
*))
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"
90 (string (number->char
(length (menu-item menu
))))
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
)
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
)
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
)))
127 (setf *menu
* (make-menu :name
'main
:doc
"Main menu")))
130 ;;; Display menu functions
131 (defun open-menu-do-action (action menu parent
)
133 (menu (open-menu action
(cons menu parent
)))
134 (null (awhen (first parent
)
135 (open-menu it
(rest parent
))))
136 (t (when (fboundp action
)
140 (defun open-menu (&optional
(menu *menu
*) (parent nil
))
144 (old-info-keys (copy-hash-table *info-keys
*)))
145 (labels ((populate-menu ()
146 (let ((info-list nil
))
147 (dolist (item (menu-item menu
))
148 (let ((value (menu-item-value item
)))
149 (push (typecase value
150 (menu (list (list (format nil
"~A" (menu-item-key item
)) *menu-color-menu-key
*)
151 (list (format nil
": < ~A >" (menu-doc value
)) *menu-color-submenu
*)))
152 (string (list (list (format nil
"~A" (menu-item-value item
)) *menu-color-comment
*)))
153 (t (list (list (format nil
"~A" (menu-item-key item
)) *menu-color-key
*)
154 (format nil
": ~A" (documentation value
'function
)))))
156 (when (menu-item-key item
)
157 (define-info-key-fun (list (menu-item-key item
))
158 (lambda (&optional args
)
159 (declare (ignore args
))
161 (leave-info-mode nil
))))))
162 (nreverse info-list
))))
163 (let ((selected-item (info-mode (populate-menu))))
164 (setf *info-keys
* old-info-keys
)
166 (awhen (nth selected-item
(menu-item menu
))
167 (setf action
(menu-item-value it
)))))
168 (open-menu-do-action action menu parent
)))))