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
  57 (defun find-item-by-key (key &optional (root *menu*))
  58   (with-all-menu (root item)
  59     (when (and (menu-item-p item)
  60                (equal (menu-item-key item) key))
  61       (return-from find-item-by-key item))))
  62
  63 (defun find-item-by-value (value &optional (root *menu*))
  64   (with-all-menu (root item)
  65     (when (and (menu-item-p item)
  66                (equal (menu-item-value item) value))
  67       (return-from find-item-by-value item))))
  68
  69
  70 (defun del-item-by-key (key &optional (menu *menu*))
  71   (del-item (find-item-by-key key menu) menu))
  72
  73 (defun del-item-by-value (value &optional (menu *menu*))
  74   (del-item (find-item-by-value value menu) menu))
  75
  76
  77
  78 ;;; Convenient functions
  79 (defun find-next-menu-key (key menu)
  80   "key is :next for the next free key in menu or a string"
  81   (if (eql key :next)
  82       (string (number->char (length (menu-item menu))))
  83       key))
  84
  85
  86 (defun add-menu-key (menu-name key value &optional (root *menu*))
  87   (let ((menu (find-menu menu-name root)))
  88     (add-item (make-menu-item :key (find-next-menu-key key menu) :value value) (find-menu menu-name root))))
  89
  90 (defun add-sub-menu (menu-name key sub-menu-name &optional (doc "Sub menu") (root *menu*))
  91   (let ((menu (find-menu menu-name root)))
  92     (add-item (make-menu-item :key (find-next-menu-key key menu) :value (make-menu :name sub-menu-name :doc doc)) menu)))
  93
  94
  95
  96 (defun del-menu-key (menu-name key &optional (root *menu*))
  97   (del-item-by-key key (find-menu menu-name root)))
  98
  99 (defun del-menu-value (menu-name value &optional (root *menu*))
 100   (del-item-by-value value (find-menu menu-name root)))
 101
 102 (defun del-sub-menu (menu-name sub-menu-name &optional (root *menu*))
 103   (del-item-by-value (find-menu sub-menu-name) (find-menu menu-name root)))
 104
 105
 106
 107 (defun add-menu-comment (menu-name &optional (comment "---") (root *menu*))
 108   (add-item (make-menu-item :key nil :value comment) (find-menu menu-name root)))
 109
 110
 111
 112 (defun init-menu ()
 113   (setf *menu* (make-menu :name 'main :doc "Main menu")))
 114
 115
 116
 117 ;;; Display menu functions
 118 (defun open-menu (&optional (menu *menu*) (parent nil))
 119   "Open the main menu"
 120   (let ((info-list nil)
 121         (action nil))
 122     (dolist (item (menu-item menu))
 123       (let ((value (menu-item-value item)))
 124         (push (typecase value
 125                 (menu (list (list (format nil "~A" (menu-item-key item)) *menu-color-menu-key*)
 126                             (list (format nil ": < ~A >" (menu-doc value)) *menu-color-submenu*)))
 127                 (string (list (list (format nil "~A" (menu-item-value item)) *menu-color-comment*)))
 128                 (t (list (list (format nil "~A" (menu-item-key item)) *menu-color-key*)
 129                          (format nil ": ~A" (documentation value 'function)))))
 130               info-list)
 131         (when (menu-item-key item)
 132           (define-info-key-fun (list (menu-item-key item))
 133               (lambda (&optional args)
 134                 (declare (ignore args))
 135                 (setf action value)
 136                 (leave-info-mode nil))))))
 137     (let ((selected-item (info-mode (nreverse info-list))))
 138       (dolist (item (menu-item menu))
 139         (undefine-info-key-fun (list (menu-item-key item))))
 140       (when selected-item
 141         (awhen (nth selected-item (menu-item menu))
 142           (setf action (menu-item-value it))))
 143       (typecase action
 144         (menu (open-menu action (cons menu parent)))
 145         (null (awhen (first parent)
 146                 (open-menu it (rest parent))))
 147         (t (when (fboundp action)
 148              (funcall action)))))))
 149
 150