Generic support for menus.

1 files changed, 157 insertions, 0 deletions

diff --git a/elisp/geiser-menu.el b/elisp/geiser-menu.el
new file mode 100644
index 0000000..25c4630
--- /dev/null
+++ b/elisp/geiser-menu.el
@@ -0,0 +1,157 @@
+;;; geiser-menu.el -- menu and keymaps definition
+
+;; Copyright (c) 2010 Jose Antonio Ortega Ruiz
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the Modified BSD License. You should
+;; have received a copy of the license along with this program. If
+;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
+
+;; Start date: Sat Jun 12, 2010 03:01
+
+
+(require 'geiser-custom)
+(require 'geiser-base)
+
+
+;;; Customization:
+
+(geiser-custom--defcustom geiser-global-menu-always-on-p nil
+   "Whether the Geiser menu is always visible."
+   :type 'boolean
+   :group 'geiser)
+
+
+;;; Visibility:
+
+(make-variable-buffer-local
+ (defvar geiser-menu--geiser-component-p nil))
+
+(defun geiser-menu--visible-p ()
+  (or geiser-global-menu-always-on-p geiser-menu--geiser-component-p))
+
+(defun geiser-menu--provide ()
+  (setq geiser-menu--geiser-component-p t))
+
+
+;;; Top-level menu
+
+(define-key global-map [menu-bar geiser]
+  `(menu-item "Geiser" ,(make-sparse-keymap "Geiser")
+              :visible (geiser-menu--visible-p)))
+
+(add-to-list 'menu-bar-final-items 'geiser)
+
+(defmacro geiser-menu--add-items-1 (ev keymap keys)
+  `(progn ,@(mapcar (lambda (kd)
+                      (let* ((ev (if (listp ev) ev (list ev)))
+                             (title (nth 0 kd))
+                             (binding (nth 1 kd))
+                             (cmd (nth 2 kd))
+                             (hlp (nth 3 kd))
+                             (item (make-symbol title))
+                             (hlp (and (stringp hlp) (list :help hlp)))
+                             (rest (or (and hlp (nthcdr 4 kd))
+                                       (nthcdr 3 kd)))
+                             (binding (if (listp binding)
+                                          binding
+                                        (list binding))))
+                        `(progn (define-key global-map
+                                  [menu-bar geiser ,@ev ,item]
+                                  '(menu-item ,title ,cmd ,@hlp ,@rest))
+                                ,@(and binding
+                                       `((put ',cmd
+                                              :advertised-binding
+                                              ,(car binding))))
+                                ,@(mapcar (lambda (b)
+                                            `(define-key ,keymap ,b ',cmd))
+                                          binding))))
+                    keys)))
+
+(defmacro geiser-menu--add-items (keymap keys &optional visible)
+  (let ((keys (if visible
+                  (mapcar (lambda (k) (append k `(:visible ,visible))) keys)
+                keys)))
+    `(geiser-menu--add-items-1 nil ,keymap ,(reverse keys))))
+
+(defmacro geiser-menu--add-submenu (name keymap visible keys)
+  (let ((ev (make-symbol name)))
+    `(progn
+       (define-key global-map [menu-bar geiser ,ev]
+         (list 'menu-item ,name ,keymap :visible ',visible))
+       (geiser-menu--add-items-1 ,ev ,keymap ,keys))))
+
+(put 'geiser-menu--add-submenu 'lisp-indent-function 3)
+(put 'geiser-menu--add-items 'lisp-indent-function 1)
+
+(defvar geiser-menu--line-counter 0)
+
+(defun geiser-menu--add-line ()
+  (let ((line (make-symbol (format "line%s"
+                                   (setq geiser-menu--line-counter
+                                         (1+ geiser-menu--line-counter))))))
+    (define-key global-map `[menu-bar geiser ,line]
+      `(menu-item "--single-line"))))
+
+(defmacro geiser-menu--add-custom (title group keymap visible)
+  `(geiser-menu--add-items ,keymap
+     ((,title nil (lambda () (interactive) (customize-group ',group))))
+     ,visible))
+
+(defmacro geiser-menu--defmenu (keymap visible &rest keys)
+  (let ((fs))
+    (dolist (kd keys)
+      (setq fs
+            (cons (cond ((eq 'line kd) '(geiser-menu--add-line))
+                        ((stringp (car kd))
+                         `(geiser-menu--add-items ,keymap
+                            ,(list kd) ,visible))
+                        ((eq 'menu (car kd))
+                         `(geiser-menu--add-submenu ,(cadr kd) ,keymap
+                                                    ,visible ,(cddr kd)))
+                        ((eq 'custom (car kd))
+                         `(geiser-menu--add-custom ,(nth 1 kd)
+                                                   ,(nth 2 kd)
+                                                   ,keymap
+                                                   ,visible))
+                        (t (error "Bad form: %s" kd)))
+                  fs)))
+    `(progn ,@fs)))
+
+(put 'geiser-menu--defmenu 'lisp-indent-function 2)
+
+
+;;; Implementation support
+
+(define-key global-map [menu-bar geiser custom]
+  (cons "Customize" (make-sparse-keymap "Customize")))
+
+(defun geiser-menu--add-global-custom (title group)
+  (define-key global-map `[menu-bar geiser custom ,(make-symbol title)]
+    (cons title `(lambda () (interactive) (customize-group ',group)))))
+
+(defun geiser-menu--add-impl (name runner switcher)
+  (let ((title (capitalize (format "%s" name)))
+        (group (intern (format "geiser-%s" name))))
+    (define-key global-map `[menu-bar geiser run ,name] (cons title runner))
+    (define-key global-map `[menu-bar geiser switch ,name]
+      (cons title switcher))
+    (geiser-menu--add-global-custom title group)))
+
+
+;;; Permanent entries
+
+(geiser-menu--add-global-custom "Geiser" 'geiser)
+
+(define-key global-map [menu-bar geiser switch]
+  (cons "Switch to" (make-sparse-keymap "Switch to")))
+(define-key global-map [menu-bar geiser run]
+  (cons "Run" (make-sparse-keymap "Run")))
+
+(geiser-menu--add-line)
+
+
+
+(provide 'geiser-menu)
+;;; geiser-menu.el ends here
+