lisp/org-mks.el

   1 ;;; org-mks.el --- Multi-key-selection for Org-mode
   2
   3 ;; Copyright (C) 2010  Free Software Foundation, Inc.
   4
   5 ;; Author: Carsten Dominik <carsten at orgmode dot org>
   6 ;; Keywords: outlines, hypermedia, calendar, wp
   7 ;; Homepage: http://orgmode.org
   8 ;; Version: 7.3
   9 ;;
  10 ;; This file is part of GNU Emacs.
  11 ;;
  12 ;; GNU Emacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  24 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25
  26
  27 ;;; Commentary:
  28 ;;
  29
  30 ;;; Code:
  31
  32 (require 'org)
  33 (eval-when-compile
  34   (require 'cl))
  35
  36 (defun org-mks (table title &optional prompt specials)
  37   "Select a member of an alist with multiple keys.
  38 TABLE is the alist which should contain entries where the car is a string.
  39 There should be two types of entries.
  40
  41 1. prefix descriptions like (\"a\" \"Description\")
  42    This indicates that `a' is a prefix key for multi-letter selection, and
  43    that there are entries following with keys like \"ab\", \"ax\"...
  44
  45 2. Selectable members must have more than two elements, with the first
  46    being the string of keys that lead to selecting it, and the second a
  47    short description string of the item.
  48
  49 The command will then make a temporary buffer listing all entries
  50 that can be selected with a single key, and all the single key
  51 prefixes.  When you press the key for a single-letter entry, it is selected.
  52 When you press a prefix key, the commands (and maybe further prefixes)
  53 under this key will be shown and offered for selection.
  54
  55 TITLE will be placed over the selection in the temporary buffer,
  56 PROMPT will be used when prompting for a key.  SPECIAL is an alist with
  57 also (\"key\" \"description\") entries.  When one of these is selection,
  58 only the bare key is returned."
  59   (setq prompt (or prompt "Select: "))
  60   (let (tbl orig-table dkey ddesc des-keys allowed-keys
  61             current prefix rtn re pressed buffer (inhibit-quit t))
  62     (save-window-excursion
  63       (setq buffer (org-switch-to-buffer-other-window "*Org Select*"))
  64       (setq orig-table table)
  65       (catch 'exit
  66         (while t
  67           (erase-buffer)
  68           (insert title "\n\n")
  69           (setq tbl table
  70                 des-keys nil
  71                 allowed-keys nil)
  72           (setq prefix (if current (concat current " ") ""))
  73           (while tbl
  74             (cond
  75              ((and (= 2 (length (car tbl))) (= (length (caar tbl)) 1))
  76               ;; This is a description on this level
  77               (setq dkey (caar tbl) ddesc (cadar tbl))
  78               (pop tbl)
  79               (push dkey des-keys)
  80               (push dkey allowed-keys)
  81               (insert prefix "[" dkey "]" "..." "  " ddesc "..." "\n")
  82               ;; Skip keys which are below this prefix
  83               (setq re (concat "\\`" (regexp-quote dkey)))
  84               (while (and tbl (string-match re (caar tbl))) (pop tbl)))
  85              ((= 2 (length (car tbl)))
  86               ;; Not yet a usable description, skip it
  87               )
  88              (t
  89               ;; usable entry on this level
  90               (insert prefix "[" (caar tbl) "]" "     " (nth 1 (car tbl)) "\n")
  91               (push (caar tbl) allowed-keys)
  92               (pop tbl))))
  93           (when specials
  94             (insert "-------------------------------------------------------------------------------\n")
  95             (let ((sp specials))
  96               (while sp
  97                 (insert (format "[%s]     %s\n"
  98                                 (caar sp) (nth 1 (car sp))))
  99                 (push (caar sp) allowed-keys)
 100                 (pop sp))))
 101           (push "\C-g" allowed-keys)
 102           (goto-char (point-min))
 103           (if (not (pos-visible-in-window-p (point-max)))
 104               (org-fit-window-to-buffer))
 105           (message prompt)
 106           (setq pressed (char-to-string (read-char-exclusive)))
 107           (while (not (member pressed allowed-keys))
 108             (message "Invalid key `%s'" pressed) (sit-for 1)
 109             (message prompt)
 110             (setq pressed (char-to-string (read-char-exclusive))))
 111           (when (equal pressed "\C-g")
 112             (kill-buffer buffer)
 113             (error "Abort"))
 114           (when (and (not (assoc pressed table))
 115                      (not (member pressed des-keys))
 116                      (assoc pressed specials))
 117             (throw 'exit (setq rtn pressed)))
 118           (unless (member pressed des-keys)
 119             (throw 'exit (setq rtn (rassoc (cdr (assoc pressed table))
 120                                            orig-table))))
 121           (setq current (concat current pressed))
 122           (setq table (mapcar
 123                        (lambda (x)
 124                          (if (and (> (length (car x)) 1)
 125                                   (equal (substring (car x) 0 1) pressed))
 126                              (cons (substring (car x) 1) (cdr x))
 127                            nil))
 128                        table))
 129           (setq table (remove nil table)))))
 130     (when buffer (kill-buffer buffer))
 131     rtn))
 132
 133 (provide 'org-mks)
 134
 135 ;; arch-tag: 4ea90d0e-c6e4-4684-bd61-baf878712f9f
 136
 137 ;;; org-mks.el ends here