elisp/geiser-menu.el

   1 ;;; geiser-menu.el -- menu and keymaps definition
   2
   3 ;; Copyright (c) 2010, 2012 Jose Antonio Ortega Ruiz
   4
   5 ;; This program is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the Modified BSD License. You should
   7 ;; have received a copy of the license along with this program. If
   8 ;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
   9
  10 ;; Start date: Sat Jun 12, 2010 03:01
  11
  12 \f
  13 ;;; Code:
  14
  15 (require 'geiser-custom)
  16 (require 'geiser-base)
  17
  18 \f
  19 ;;; Customization:
  20
  21 (geiser-custom--defcustom geiser-global-menu-always-on-p nil
  22   "Whether the Geiser menu is always visible."
  23   :type 'boolean
  24   :group 'geiser)
  25
  26 \f
  27 ;;; Top-level menu
  28
  29 (defmacro geiser-menu--add-item (keymap map kd)
  30   (cond ((or (eq '-- kd) (eq 'line kd)) `(geiser-menu--add-line ,map))
  31         ((stringp (car kd)) `(geiser-menu--add-basic-item ,keymap ,map ,kd))
  32         ((eq 'menu (car kd)) `(geiser-menu--add-submenu ,(cadr kd)
  33                                                         ,keymap ,map ,(cddr kd)))
  34         ((eq 'custom (car kd)) `(geiser-menu--add-custom ,(nth 1 kd)
  35                                                          ,(nth 2 kd)
  36                                                          ,keymap
  37                                                          ,map))
  38         ((eq 'mode (car kd)) `(geiser-menu--mode-toggle ,(nth 1 kd)
  39                                                         ,(nth 2 kd)
  40                                                         ,(nth 3 kd)
  41                                                         ,keymap
  42                                                         ,map))
  43         (t (error "Bad item form: %s" kd))))
  44
  45 (defmacro geiser-menu--add-basic-item (keymap map kd)
  46   (let* ((title (nth 0 kd))
  47          (binding (nth 1 kd))
  48          (cmd (nth 2 kd))
  49          (hlp (nth 3 kd))
  50          (item (make-symbol title))
  51          (hlp (and (stringp hlp) (list :help hlp)))
  52          (rest (or (and hlp (nthcdr 4 kd))
  53                    (nthcdr 3 kd)))
  54          (binding (if (listp binding)
  55                       binding
  56                     (list binding))))
  57     `(progn (define-key ,map [,item]
  58               '(menu-item ,title ,cmd ,@hlp ,@rest))
  59             ,@(and (car binding)
  60                    `((put ',cmd
  61                           :advertised-binding
  62                           ,(car binding))))
  63             ,@(mapcar (lambda (b)
  64                         `(define-key ,keymap ,b ',cmd))
  65                       binding))))
  66
  67 (defmacro geiser-menu--add-items (keymap map keys)
  68   `(progn ,@(mapcar (lambda (k) (list 'geiser-menu--add-item keymap map k))
  69                     (reverse keys))))
  70
  71 (defmacro geiser-menu--add-submenu (name keymap map keys)
  72   (let ((ev (make-symbol name))
  73         (map2 (make-symbol "map2")))
  74     `(progn
  75        (let ((,map2 (make-sparse-keymap ,name)))
  76          (define-key ,map [,ev] (cons ,name ,map2))
  77          (geiser-menu--add-items ,keymap ,map2 ,keys)))))
  78
  79 (defvar geiser-menu--line-counter 0)
  80
  81 (defun geiser-menu--add-line (&optional map)
  82   (let ((line (make-symbol (format "line%s"
  83                                    (setq geiser-menu--line-counter
  84                                          (1+ geiser-menu--line-counter))))))
  85     (define-key (or map global-map) `[,line]
  86       `(menu-item "--single-line"))))
  87
  88 (defmacro geiser-menu--add-custom (title group keymap map)
  89   `(geiser-menu--add-item ,keymap ,map
  90                           (,title nil (lambda () (interactive) (customize-group ',group)))))
  91
  92 (defmacro geiser-menu--mode-toggle (title bindings mode keymap map)
  93   `(geiser-menu--add-item ,keymap ,map
  94                           (,title ,bindings ,mode
  95                                   :button (:toggle . (and (boundp ',mode) ,mode)))))
  96
  97 (defmacro geiser-menu--defmenu (name keymap &rest keys)
  98   (let ((mmap (make-symbol "mmap")))
  99     `(progn
 100        (let ((,mmap (make-sparse-keymap "Geiser")))
 101          (define-key ,keymap [menu-bar ,name] (cons "Geiser" ,mmap))
 102          (define-key ,mmap [customize]
 103            (cons "Customize" geiser-menu--custom-customize))
 104          (define-key ,mmap [switch]
 105            (cons "Switch to" geiser-menu--custom-switch))
 106          (define-key ,mmap [Run] (cons "Run" geiser-menu--custom-run))
 107          (geiser-menu--add-line ,mmap)
 108          (geiser-menu--add-items ,keymap ,mmap ,keys)
 109          ,mmap))))
 110
 111 (put 'geiser-menu--defmenu 'lisp-indent-function 2)
 112
 113 \f
 114 ;;; Shared entries
 115
 116 (defvar geiser-menu--custom-map (make-sparse-keymap "Geiser"))
 117 (defvar geiser-menu--custom-run (make-sparse-keymap "Run"))
 118 (defvar geiser-menu--custom-switch (make-sparse-keymap "Switch"))
 119 (defvar geiser-menu--custom-customize (make-sparse-keymap "Customize"))
 120
 121 (define-key geiser-menu--custom-map [customize]
 122   (cons "Customize" geiser-menu--custom-customize))
 123 (define-key geiser-menu--custom-map [switch]
 124   (cons "Switch to" geiser-menu--custom-switch))
 125 (define-key geiser-menu--custom-map [run]
 126   (cons "Run" geiser-menu--custom-run))
 127
 128 (defun geiser-menu--add-global-custom (title group)
 129   (define-key geiser-menu--custom-customize `[,(make-symbol title)]
 130     (cons title `(lambda () (interactive) (customize-group ',group)))))
 131
 132 (defun geiser-menu--add-impl (name runner switcher)
 133   (let ((title (capitalize (format "%s" name)))
 134         (group (intern (format "geiser-%s" name))))
 135     (define-key geiser-menu--custom-run `[,name]
 136       `(menu-item ,title ,runner :enable (geiser-impl--active-p ',name)))
 137     (define-key geiser-menu--custom-switch `[,name]
 138       `(menu-item ,title ,switcher :enable (geiser-repl--repl/impl ',name)))
 139     (geiser-menu--add-global-custom title group)))
 140
 141 (geiser-menu--add-global-custom "Geiser" 'geiser)
 142
 143
 144 \f
 145 (provide 'geiser-menu)