misc/fuel/fuel-menu.el

   1 ;;; fuel-menu.el -- menu utilities -*- lexical-binding: t -*-
   2
   3 ;; Copyright (c) 2010 Jose Antonio Ortega Ruiz
   4 ;; See http://factorcode.org/license.txt for BSD license.
   5
   6 ;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
   7 ;; Keywords: languages, fuel, factor
   8 ;; Start date: Sat Jun 12, 2010 03:01
   9 \f
  10
  11 (require 'fuel-base)
  12
  13 \f
  14 ;;; Top-level menu
  15
  16 (defmacro fuel-menu--add-item (keymap map kd)
  17   (cond ((or (eq '-- kd) (eq 'line kd)) `(fuel-menu--add-line ,map))
  18         ((stringp (car kd)) `(fuel-menu--add-basic-item ,keymap ,map ,kd))
  19         ((eq 'menu (car kd)) `(fuel-menu--add-submenu ,(cadr kd)
  20                                 ,keymap ,map ,(cddr kd)))
  21         ((eq 'custom (car kd)) `(fuel-menu--add-custom ,(nth 1 kd)
  22                                                          ,(nth 2 kd)
  23                                                          ,keymap
  24                                                          ,map))
  25         ((eq 'mode (car kd)) `(fuel-menu--mode-toggle ,(nth 1 kd)
  26                                                         ,(nth 2 kd)
  27                                                         ,(nth 3 kd)
  28                                                         ,keymap
  29                                                         ,map))
  30         (t (error "Bad item form: %s" kd))))
  31
  32 (defmacro fuel-menu--add-basic-item (keymap map kd)
  33   (let* ((title (nth 0 kd))
  34          (binding (nth 1 kd))
  35          (cmd (nth 2 kd))
  36          (hlp (nth 3 kd))
  37          (item (make-symbol title))
  38          (hlp (and (stringp hlp) (list :help hlp)))
  39          (rest (or (and hlp (nthcdr 4 kd))
  40                    (nthcdr 3 kd)))
  41          (binding (if (listp binding)
  42                       binding
  43                     (list binding))))
  44     `(progn (define-key ,map [,item]
  45               '(menu-item ,title ,cmd ,@hlp ,@rest))
  46             ,@(and (car binding)
  47                    `((put ',cmd
  48                           :advertised-binding
  49                           ,(car binding))))
  50             ,@(mapcar (lambda (b)
  51                         `(define-key ,keymap ,b ',cmd))
  52                       binding))))
  53
  54 (defmacro fuel-menu--add-items (keymap map keys)
  55   `(progn ,@(mapcar (lambda (k) (list 'fuel-menu--add-item keymap map k))
  56                     (reverse keys))))
  57
  58 (defmacro fuel-menu--add-submenu (name keymap map keys)
  59   (let ((ev (make-symbol name))
  60         (map2 (make-symbol "map2")))
  61     `(progn
  62        (let ((,map2 (make-sparse-keymap ,name)))
  63          (define-key ,map [,ev] (cons ,name ,map2))
  64          (fuel-menu--add-items ,keymap ,map2 ,keys)))))
  65
  66 (defvar fuel-menu--line-counter 0)
  67
  68 (defun fuel-menu--add-line (&optional map)
  69   (let ((line (make-symbol (format "line%s"
  70                                    (setq fuel-menu--line-counter
  71                                          (1+ fuel-menu--line-counter))))))
  72     (define-key (or map global-map) `[,line]
  73       `(menu-item "--single-line"))))
  74
  75 (defmacro fuel-menu--add-custom (title group keymap map)
  76   `(fuel-menu--add-item ,keymap ,map
  77      (,title nil (lambda () (interactive) (customize-group ',group)))))
  78
  79 (defmacro fuel-menu--mode-toggle (title bindings mode keymap map)
  80   `(fuel-menu--add-item ,keymap ,map
  81      (,title ,bindings ,mode
  82              :button (:toggle . (and (boundp ',mode) ,mode)))))
  83
  84 (defmacro fuel-menu--defmenu (name keymap &rest keys)
  85   (declare (indent 2))
  86   (let ((mmap (make-symbol "mmap")))
  87     `(progn
  88        (let ((,mmap (make-sparse-keymap "FUEL")))
  89          (define-key ,keymap [menu-bar ,name] (cons "FUEL" ,mmap))
  90          (define-key ,mmap [customize]
  91            (cons "Customize FUEL"
  92                  `(lambda () (interactive) (customize-group 'fuel))))
  93          (fuel-menu--add-line ,mmap)
  94          (fuel-menu--add-items ,keymap ,mmap ,keys)
  95          ,mmap))))
  96
  97 \f
  98 (provide 'fuel-menu)
  99
 100 ;;; fuel-menu.el ends here