src/clfswm-menu.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Menu functions
   6 ;;; --------------------------------------------------------------------------
   7 ;;;
   8 ;;; (C) 2010 Philippe Brochard <hocwp@free.fr>
   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 ;;; --------------------------------------------------------------------------
  25
  26 (in-package :clfswm)
  27
  28
  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))))
  40
  41 (defun add-item (item &optional (menu *menu*))
  42   (setf (menu-item menu) (nconc (menu-item menu) (list item))))
  43
  44 (defun del-item (item &optional (menu *menu*))
  45   (setf (menu-item menu) (remove item (menu-item menu))))
  46
  47
  48
  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))))
  55
  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)))))))
  63
  64
  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))))
  70
  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))))
  76
  77
  78 (defun del-item-by-key (key &optional (menu *menu*))
  79   (del-item (find-item-by-key key menu) menu))
  80
  81 (defun del-item-by-value (value &optional (menu *menu*))
  82   (del-item (find-item-by-value value menu) menu))
  83
  84
  85
  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))
  92
  93
  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))))
  97
  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))
 105
 106
 107
 108 (defun del-menu-key (menu-name key &optional (root *menu*))
 109   (del-item-by-key key (find-menu menu-name root)))
 110
 111 (defun del-menu-value (menu-name value &optional (root *menu*))
 112   (del-item-by-value value (find-menu menu-name root)))
 113
 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)))
 116
 117
 118
 119 (defun add-menu-comment (menu-name &optional (comment "---") (root *menu*))
 120   (add-item (make-menu-item :key nil :value comment) (find-menu menu-name root)))
 121
 122
 123
 124 (defun init-menu ()
 125   (setf *menu* (make-menu :name 'main :doc "Main menu")))
 126
 127
 128 ;;; Display menu functions
 129 (defun open-menu-do-action (action menu parent)
 130   (typecase action
 131     (menu (open-menu action (cons menu parent)))
 132     (null (awhen (first parent)
 133             (open-menu it (rest parent))))
 134     (t (when (fboundp action)
 135          (funcall action)))))
 136
 137
 138 (defun open-menu (&optional (menu *menu*) (parent nil))
 139   "Open the main menu"
 140   (let ((action nil))
 141     (labels ((populate-menu ()
 142                (let ((info-list nil))
 143                  (dolist (item (menu-item menu))
 144                    (let ((value (menu-item-value item)))
 145                      (push (typecase value
 146                              (menu (list (list (format nil "~A" (menu-item-key item)) *menu-color-menu-key*)
 147                                          (list (format nil ": < ~A >" (menu-doc value)) *menu-color-submenu*)))
 148                              (string (list (list (format nil "~A" (menu-item-value item)) *menu-color-comment*)))
 149                              (t (list (list (format nil "~A" (menu-item-key item)) *menu-color-key*)
 150                                       (format nil ": ~A" (documentation value 'function)))))
 151                            info-list)
 152                      (when (menu-item-key item)
 153                        (define-info-key-fun (list (menu-item-key item))
 154                            (lambda (&optional args)
 155                              (declare (ignore args))
 156                              (setf action value)
 157                              (leave-info-mode nil))))))
 158                  (nreverse info-list))))
 159       (let ((selected-item (info-mode (populate-menu))))
 160         (dolist (item (menu-item menu))
 161           (undefine-info-key-fun (list (menu-item-key item))))
 162         (when selected-item
 163           (awhen (nth selected-item (menu-item menu))
 164             (setf action (menu-item-value it)))))
 165       (open-menu-do-action action menu parent))))
 166
 167