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