src/clfswm-menu.lisp

   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 ;;; --------------------------------------------------------------------------
  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 (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))
 119
 120
 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)))
 123
 124
 125
 126 (defun init-menu ()
 127   (setf *menu* (make-menu :name 'main :doc "Main menu")))
 128
 129
 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)))))
 138
 139
 140 (let ((menu-oppened nil))
 141   (defun reset-open-menu ()
 142     (setf menu-oppened nil))
 143
 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)))))))