1 ;;; org-velocity.el --- something like Notational Velocity for Org.
3 ;; Copyright (C) 2010-2013 Paul M. Rodriguez
5 ;; Author: Paul M. Rodriguez <paulmrodriguez@gmail.com>
9 ;; This file is not part of GNU Emacs.
11 ;; This program is free software; you can redistribute it and/or
12 ;; modify it under the terms of the GNU General Public License as
13 ;; published by the Free Software Foundation version 2.
15 ;; This program is distributed in the hope that it will be useful, but
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 ;; General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
24 ;; Org-Velocity.el is an interface for Org inspired by the minimalist
25 ;; notetaking program Notational Velocity. The idea is to let you
26 ;; amass and access brief notes on many subjects with minimal fuss.
27 ;; Each note is an entry in an ordinary Org file.
29 ;; Org-Velocity can be used in two ways: when called outside Org, to
30 ;; store and access notes in a designated bucket file; or, when called
31 ;; inside Org, as a method for navigating any Org file. (Setting the
32 ;; option `org-velocity-always-use-bucket' disables navigation inside
33 ;; Org files by default, although you can still force this behavior by
34 ;; calling `org-velocity-read' with an argument.)
36 ;; Org-Velocity prompts for search terms in the minibuffer. A list of
37 ;; headings of entries whose text matches your search is updated as
38 ;; you type; you can end the search and visit an entry at any time by
39 ;; clicking on its heading.
41 ;; RET displays the results. If there are no matches, Org-Velocity
42 ;; offers to create a new entry with your search string as its
43 ;; heading. If there are matches, it displays a list of results where
44 ;; the heading of each matching entry is hinted with a number or
45 ;; letter; clicking a result, or typing the matching hint, opens the
46 ;; entry for editing in an indirect buffer. 0 forces a new entry; RET
47 ;; reopens the search for editing.
49 ;; You can customize every step in this process, including the search
50 ;; method, completion for search terms, and templates for creating new
51 ;; entries; M-x customize-group RET org-velocity RET to see all the
54 ;; Thanks to Richard Riley, Carsten Dominik, Bastien Guerry, and Jeff
55 ;; Horn for their suggestions.
58 ;; (require 'org-velocity)
59 ;; (setq org-velocity-bucket (expand-file-name "bucket.org" org-directory))
60 ;; (global-set-key (kbd "C-c v") 'org-velocity)
67 (eval-when-compile (require 'cl
))
69 (defgroup org-velocity nil
70 "Notational Velocity-style interface for Org."
76 (defcustom org-velocity-bucket
""
77 "Where is the bucket file?"
81 (defcustom org-velocity-search-is-incremental t
82 "Show results incrementally when possible?"
87 (defcustom org-velocity-show-previews t
88 "Show previews of the text of each heading?"
93 (defcustom org-velocity-exit-on-match nil
94 "When searching incrementally, exit on a single match?"
99 (defcustom org-velocity-force-new nil
100 "Should exiting the minibuffer with C-j force a new entry?"
105 (defcustom org-velocity-use-search-ring t
106 "Push search to `search-ring' when visiting an entry?
108 This means that C-s C-s will take you directly to the first
109 instance of the search string."
114 (defcustom org-velocity-always-use-bucket nil
115 "Use bucket file even when called from an Org buffer?"
120 (defcustom org-velocity-use-completion nil
123 Notwithstanding the value of this option, calling
124 `dabbrev-expand' always completes against the text of the bucket
128 (const :tag
"Do not use completion" nil
)
129 (const :tag
"Use completion" t
))
132 (defcustom org-velocity-search-method
'phrase
133 "Match on whole phrase, any word, or all words?"
136 (const :tag
"Match whole phrase" phrase
)
137 (const :tag
"Match any word" any
)
138 (const :tag
"Match all words" all
)
139 (const :tag
"Match a regular expression" regexp
))
140 :safe
(lambda (v) (memq v
'(phrase any all regexp
))))
142 (defcustom org-velocity-capture-templates
147 "* %:search\n\n%i%?"))
148 "Use these template with `org-capture'.
149 Meanwhile `org-default-notes-file' is bound to `org-velocity-bucket-file'.
150 The keyword :search inserts the current search.
151 See the documentation for `org-capture-templates'."
153 :type
(or (get 'org-capture-templates
'custom-type
) 'list
))
155 (defsubst org-velocity-grab-preview
()
156 "Grab preview of a subtree.
157 The length of the preview is determined by `window-width'.
159 Replace all contiguous whitespace with single spaces."
162 (if (looking-at org-property-start-re
)
163 (re-search-forward org-property-end-re
)
168 (buffer-substring-no-properties
171 (+ start
(window-width))
175 (defstruct org-velocity-heading buffer position name level preview
)
177 (defsubst org-velocity-nearest-heading
(position)
178 "Return last heading at POSITION.
179 If there is no last heading, return nil."
182 (re-search-backward org-velocity-heading-regexp
)
183 (let ((components (org-heading-components)))
184 (make-org-velocity-heading
185 :buffer
(current-buffer)
187 :name
(nth 4 components
)
188 :level
(nth 0 components
)
189 :preview
(if org-velocity-show-previews
190 (org-velocity-grab-preview))))))
192 (defconst org-velocity-index
194 (nconc (number-sequence 49 57) ;numbers
195 (number-sequence 97 122) ;lowercase letters
196 (number-sequence 65 90))) ;uppercase letters
197 "List of chars for indexing results.")
199 (defconst org-velocity-match-buffer-name
"*Velocity matches*")
201 (defconst org-velocity-heading-regexp
"^\\* "
202 "Regexp to match only top-level headings.")
204 (defvar org-velocity-search nil
205 "Variable to bind to current search.")
207 (defun org-velocity-buffer-file-name (&optional buffer
)
208 "Return the name of the file BUFFER saves to.
209 Same as function `buffer-file-name' unless BUFFER is an indirect
210 buffer or a minibuffer. In the former case, return the file name
211 of the base buffer; in the latter, return the file name of
212 `minibuffer-selected-window' (or its base buffer)."
213 (let ((buffer (if (minibufferp buffer
)
214 (window-buffer (minibuffer-selected-window))
217 (or (buffer-base-buffer buffer
)
220 (defun org-velocity-minibuffer-contents ()
221 "Return the contents of the minibuffer when it is active."
222 (if (active-minibuffer-window)
223 (with-current-buffer (window-buffer (active-minibuffer-window))
224 (minibuffer-contents))))
226 (defsubst org-velocity-singlep
(object)
227 "Return t when OBJECT is a list or sequence of one element."
230 (= (length object
) 1)))
232 (defun org-velocity-bucket-file ()
233 "Return the proper file for Org-Velocity to search.
234 If `org-velocity-always-use-bucket' is t, use bucket file;
235 complain if missing. Otherwise, if an Org file is current, then
237 (let ((org-velocity-bucket
238 (when org-velocity-bucket
(expand-file-name org-velocity-bucket
)))
240 (let ((buffer-file (org-velocity-buffer-file-name)))
242 ;; Use the target in capture buffers.
243 (org-find-base-buffer-visiting buffer-file
)))))
244 (if org-velocity-always-use-bucket
245 (or org-velocity-bucket
(error "Bucket required but not defined"))
246 (if (and (eq (buffer-local-value 'major-mode
(or buffer
(current-buffer)))
248 (org-velocity-buffer-file-name))
249 (org-velocity-buffer-file-name)
250 (or org-velocity-bucket
251 (error "No bucket and not an Org file"))))))
253 (defvar org-velocity-bucket-buffer nil
)
255 (defsubst org-velocity-bucket-buffer
()
256 (or org-velocity-bucket-buffer
257 (find-file-noselect (org-velocity-bucket-file))))
259 (defsubst org-velocity-match-buffer
()
260 "Return the proper buffer for Org-Velocity to display in."
261 (get-buffer-create org-velocity-match-buffer-name
))
263 (defun org-velocity-beginning-of-headings ()
264 "Goto the start of the first heading."
265 (goto-char (point-min))
266 ;; If we are before the first heading we could still be at the
268 (or (looking-at org-velocity-heading-regexp
)
269 (re-search-forward org-velocity-heading-regexp
)))
271 (defun org-velocity-make-indirect-buffer (heading)
272 "Make or switch to an indirect buffer visiting HEADING."
274 (let* ((bucket (org-velocity-heading-buffer heading
))
275 (name (org-velocity-heading-name heading
))
276 (existing (get-buffer name
)))
277 (if (and existing
(buffer-base-buffer existing
)
278 (equal (buffer-base-buffer existing
) bucket
))
280 (make-indirect-buffer
282 (generate-new-buffer-name (org-velocity-heading-name heading
))))))
284 (defun org-velocity-capture ()
285 "Record a note with `org-capture'."
286 (let ((org-capture-templates
287 org-velocity-capture-templates
))
289 ;; This is no longer automatically selected.
290 (when (org-velocity-singlep org-capture-templates
)
291 (caar org-capture-templates
)))
292 (if org-capture-mode
(rename-buffer org-velocity-search t
))))
294 (defvar org-velocity-saved-winconf nil
)
295 (make-variable-buffer-local 'org-velocity-saved-winconf
)
297 (defun org-velocity-edit-entry (heading)
298 "Edit entry at HEADING in an indirect buffer."
299 (let ((winconf (current-window-configuration)))
300 (let ((buffer (org-velocity-make-indirect-buffer heading
)))
301 (with-current-buffer buffer
302 (let ((org-inhibit-startup t
))
304 (setq org-velocity-saved-winconf winconf
)
305 (goto-char (org-velocity-heading-position heading
))
306 (narrow-to-region (point)
308 (org-end-of-subtree t
)
310 (goto-char (point-min))
311 (add-hook 'org-ctrl-c-ctrl-c-hook
'org-velocity-dismiss nil t
))
312 (pop-to-buffer buffer
)
313 (set (make-local-variable 'header-line-format
)
314 (format "%s Use C-c C-c to finish."
315 (abbreviate-file-name
317 (org-velocity-heading-buffer heading
))))))))
319 (defun org-velocity-dismiss ()
320 "Save current entry and close indirect buffer."
321 (let ((winconf org-velocity-saved-winconf
))
322 (prog1 t
;Tell hook we're done.
325 (when (window-configuration-p winconf
)
326 (set-window-configuration winconf
)))))
328 (defun org-velocity-visit-button (button)
329 (run-hooks 'mouse-leave-buffer-hook
)
330 (if org-velocity-use-search-ring
331 (add-to-history 'search-ring
332 (button-get button
'search
)
334 (org-velocity-edit-entry (button-get button
'match
)))
336 (define-button-type 'org-velocity-button
337 'action
#'org-velocity-visit-button
)
339 (defsubst org-velocity-buttonize
(heading)
340 "Insert HEADING as a text button with no hints."
342 (propertize (org-velocity-heading-name heading
) 'face
'link
)
343 :type
'org-velocity-button
345 'search org-velocity-search
))
347 (defsubst org-velocity-insert-preview
(heading)
348 (when org-velocity-show-previews
352 (org-velocity-heading-preview heading
)
355 (defsubst* org-velocity-present-match
(&key hint match
)
356 (with-current-buffer (org-velocity-match-buffer)
357 (when hint
(insert "#" hint
" "))
358 (org-velocity-buttonize match
)
359 (org-velocity-insert-preview match
)
362 (defun org-velocity-generic-search (search &optional hide-hints
)
363 "Display any entry containing SEARCH."
364 (let ((hints org-velocity-index
) matches
)
366 (while (and hints
(re-search-forward search nil t
))
367 (let ((match (org-velocity-nearest-heading (point))))
368 (org-velocity-present-match
369 :hint
(unless hide-hints
(car hints
))
371 (push match matches
))
372 (setq hints
(cdr hints
))
373 (unless (re-search-forward org-velocity-heading-regexp nil t
)
377 (defun* org-velocity-all-search
(search &optional hide-hints max
)
378 "Display only entries containing every word in SEARCH."
379 (let ((keywords (mapcar 'regexp-quote
(split-string search
)))
380 (hints org-velocity-index
)
384 ;; Return if we've run out of hints.
386 (return-from org-velocity-all-search
(nreverse matches
)))
387 ;; Only search the subtree once.
388 (setq org-map-continue-from
390 (goto-char (line-end-position))
391 (if (re-search-forward org-velocity-heading-regexp nil t
)
394 (when (loop for word in keywords
395 always
(save-excursion
397 (concat "\\<" word
"\\>")
398 org-map-continue-from t
)))
399 (let ((match (org-velocity-nearest-heading (match-end 0))))
400 (org-velocity-present-match
401 :hint
(unless hide-hints
(car hints
))
404 (setq hints
(cdr hints
))))))
407 (defun* org-velocity-present
(search &key hide-hints
)
408 "Buttonize matches for SEARCH in `org-velocity-match-buffer'.
409 If HIDE-HINTS is non-nil, display entries without indices. SEARCH
410 binds `org-velocity-search'.
413 (if (and (stringp search
) (not (string= "" search
)))
414 ;; Fold case when the search string is all lowercase.
415 (let ((case-fold-search (equal search
(downcase search
)))
416 (truncate-partial-width-windows t
))
417 (with-current-buffer (org-velocity-match-buffer)
420 (setq cursor-type nil
423 (with-current-buffer (org-velocity-bucket-buffer)
424 (let ((inhibit-point-motion-hooks t
)
425 (inhibit-field-text-motion t
))
427 (org-velocity-beginning-of-headings)
428 (case org-velocity-search-method
429 (all (org-velocity-all-search search hide-hints
))
430 (phrase (org-velocity-generic-search
431 (concat "\\<" (regexp-quote search
))
433 (any (org-velocity-generic-search
435 (regexp-opt (split-string search
)))
437 (regexp (condition-case lossage
438 (org-velocity-generic-search
441 (minibuffer-message "%s" lossage
))))))))
442 (with-current-buffer (org-velocity-match-buffer)
443 (goto-char (point-min)))))
444 (with-current-buffer (org-velocity-match-buffer)
447 (defun org-velocity-store-link ()
448 "Function for `org-store-link-functions'."
449 (if org-velocity-search
450 (org-store-link-props
451 :search org-velocity-search
)))
453 (add-hook 'org-store-link-functions
'org-velocity-store-link
)
455 (defun* org-velocity-create
(search &key ask
)
456 "Create new heading named SEARCH.
457 If ASK is non-nil, ask first."
458 (when (or (null ask
) (y-or-n-p "No match found, create? "))
459 (let ((org-velocity-search search
)
460 (org-default-notes-file (org-velocity-bucket-file))
461 ;; save a stored link
462 org-store-link-plist
)
463 (org-velocity-capture))
466 (defun org-velocity-engine (search)
467 "Display a list of headings where SEARCH occurs."
468 (let ((org-velocity-search search
))
470 (not (stringp search
))
471 (string= "" search
)) ;exit on empty string
473 (if (and org-velocity-force-new
(eq last-command-event ?\C-j
))
475 (let ((matches (org-velocity-present search
)))
476 (cond ((null matches
) :new
)
477 ((org-velocity-singlep matches
) :follow
)
480 (pop-to-buffer (org-velocity-match-buffer))
481 (let ((hint (org-velocity-electric-read-hint)))
482 (when hint
(case hint
483 (:edit
(org-velocity-read nil search
))
484 (:force
(org-velocity-create search
))
485 (otherwise (org-velocity-activate-button hint
)))))))
486 (:new
(unless (org-velocity-create search
:ask t
)
487 (org-velocity-read nil search
)))
488 (:force
(org-velocity-create search
))
489 (:follow
(if (y-or-n-p "One match, follow? ")
491 (set-buffer (org-velocity-match-buffer))
492 (goto-char (point-min))
493 (button-activate (next-button (point))))
494 (org-velocity-read nil search
)))))))
496 (defun org-velocity-position (item list
)
497 "Return first position of ITEM in LIST."
498 (loop for elt in list
500 when
(equal elt item
)
503 (defun org-velocity-activate-button (char)
504 "Go to button on line number associated with CHAR in `org-velocity-index'."
505 (goto-char (point-min))
506 (forward-line (org-velocity-position char org-velocity-index
))
509 (next-button (point))))
510 (message "%s" (button-label (button-at (point))))
511 (button-activate (button-at (point))))
513 (defun org-velocity-electric-undefined ()
514 "Complain about an undefined key."
517 (substitute-command-keys
518 "\\[org-velocity-electric-new] for new entry,
519 \\[org-velocity-electric-edit] to edit search,
520 \\[scroll-up] to scroll up,
521 \\[scroll-down] to scroll down,
522 \\[keyboard-quit] to quit."))
525 (defun org-velocity-electric-follow (ev)
526 "Follow a hint indexed by keyboard event EV."
527 (interactive (list last-command-event
))
528 (if (not (> (org-velocity-position ev org-velocity-index
)
529 (1- (count-lines (point-min) (point-max)))))
530 (throw 'org-velocity-select ev
)
531 (call-interactively 'org-velocity-electric-undefined
)))
533 (defun org-velocity-electric-click (ev)
534 "Follow hint indexed by a mouse event EV."
536 (throw 'org-velocity-select
537 (nth (1- (count-lines
539 (posn-point (event-start ev
))))
540 org-velocity-index
)))
542 (defun org-velocity-electric-edit ()
543 "Edit the search string."
545 (throw 'org-velocity-select
:edit
))
547 (defun org-velocity-electric-new ()
550 (throw 'org-velocity-select
:force
))
552 (defvar org-velocity-electric-map
553 (let ((map (make-sparse-keymap)))
554 (define-key map
[t] 'org-velocity-electric-undefined)
555 (loop for c in org-velocity-index
556 do (define-key map (char-to-string c) 'org-velocity-electric-follow))
557 (define-key map "0" 'org-velocity-electric-new)
558 (define-key map "\C-v" 'scroll-up)
559 (define-key map "\M-v" 'scroll-down)
560 (define-key map (kbd "RET") 'org-velocity-electric-edit)
561 (define-key map [mouse-1] 'org-velocity-electric-click)
562 (define-key map [mouse-2] 'org-velocity-electric-click)
563 (define-key map [escape] 'keyboard-quit)
564 (define-key map "\C-h" 'help-command)
567 (defun org-velocity-electric-read-hint ()
568 "Read index of button electrically."
569 (with-current-buffer (org-velocity-match-buffer)
570 (use-local-map org-velocity-electric-map)
571 (catch 'org-velocity-select
572 (Electric-command-loop 'org-velocity-select "Follow: "))))
574 (defvar org-velocity-incremental-keymap
575 (let ((map (make-sparse-keymap)))
576 (define-key map [mouse-1] 'org-velocity-click-for-incremental)
577 (define-key map [mouse-2] 'org-velocity-click-for-incremental)
578 (define-key map "\C-v" 'scroll-up)
579 (define-key map "\M-v" 'scroll-down)
582 (defun org-velocity-click-for-incremental ()
583 "Jump out of search and select hint clicked on."
585 (let ((ev last-command-event))
586 (org-velocity-activate-button
589 (posn-point (event-start ev))) 2)
590 org-velocity-index)))
591 (throw 'click (current-buffer)))
593 (defun org-velocity-displaying-completions-p ()
594 "Is there a *Completions* buffer showing?"
595 (get-window-with-predicate
597 (eq (buffer-local-value 'major-mode (window-buffer w))
598 'completion-list-mode))))
600 (defun org-velocity-update ()
601 "Display results of search without hinting.
602 Stop searching once there are more matches than can be displayed."
603 (unless (org-velocity-displaying-completions-p)
604 (let* ((search (org-velocity-minibuffer-contents))
605 (matches (org-velocity-present search :hide-hints t)))
606 (cond ((null matches)
607 (select-window (active-minibuffer-window))
608 (unless (or (null search) (string= "" search))
609 (minibuffer-message "No match; RET to create")))
610 ((and (org-velocity-singlep matches)
611 org-velocity-exit-on-match)
612 (throw 'click search))
614 (with-current-buffer (org-velocity-match-buffer)
615 (use-local-map org-velocity-incremental-keymap)))))))
617 (defvar dabbrev--last-abbrev)
619 (defun org-velocity-dabbrev-completion-list (abbrev)
620 "Return all dabbrev completions for ABBREV."
621 ;; This is based on `dabbrev-completion'.
622 (dabbrev--reset-global-variables)
623 (setq dabbrev--last-abbrev abbrev)
624 (dabbrev--find-all-expansions abbrev case-fold-search))
626 (defvar org-velocity-local-completion-map
627 (let ((map (make-sparse-keymap)))
628 (set-keymap-parent map minibuffer-local-completion-map)
629 (define-key map " " 'self-insert-command)
630 (define-key map [remap minibuffer-complete] 'minibuffer-complete-word)
632 "Keymap for completion with `completing-read'.")
634 (defun org-velocity-read-with-completion (prompt)
635 "Completing read with PROMPT."
636 (let ((minibuffer-local-completion-map
637 org-velocity-local-completion-map)
638 (completion-no-auto-exit t)
641 (case org-velocity-search-method
642 (phrase #'completing-read)
643 (any #'completing-read-multiple)
644 (all #'completing-read-multiple))
646 (completion-table-dynamic
647 'org-velocity-dabbrev-completion-list))))
649 (defun org-velocity-read-string (prompt &optional initial-input)
650 "Read string with PROMPT followed by INITIAL-INPUT."
651 ;; The use of initial inputs to the minibuffer is deprecated (see
652 ;; `read-from-minibuffer'), but in this case it is the user-friendly
654 (minibuffer-with-setup-hook
655 (lexical-let ((initial-input initial-input))
657 (and initial-input (insert initial-input))
658 (goto-char (point-max))))
659 (if (eq org-velocity-search-method 'regexp)
661 (if org-velocity-use-completion
662 (org-velocity-read-with-completion prompt)
663 (read-string prompt)))))
665 (defun org-velocity-incremental-read (prompt)
666 "Read string with PROMPT and display results incrementally."
669 (let* ((match-window (display-buffer (org-velocity-match-buffer)))
671 ;; Truncate the index to the size of the buffer to be
673 (with-selected-window match-window
674 (if (> (window-height) (length org-velocity-index))
675 ;; (subseq org-velocity-index 0 (window-height))
676 (let ((hints (copy-sequence org-velocity-index)))
677 (setcdr (nthcdr (window-height) hints) nil)
679 org-velocity-index))))
681 (add-hook 'post-command-hook 'org-velocity-update)
682 (if (eq org-velocity-search-method 'regexp)
684 (if org-velocity-use-completion
685 (org-velocity-read-with-completion prompt)
686 (read-string prompt)))))
687 (remove-hook 'post-command-hook 'org-velocity-update))))
688 (if (bufferp res) (org-pop-to-buffer-same-window res) res)))
690 (defun org-velocity (arg &optional search)
691 "Read a search string SEARCH for Org-Velocity interface.
692 This means that a buffer will display all headings where SEARCH
693 occurs, where one can be selected by a mouse click or by typing
694 its index. If SEARCH does not occur, then a new heading may be
695 created named SEARCH.
697 If `org-velocity-bucket' is defined and
698 `org-velocity-always-use-bucket' is non-nil, then the bucket file
699 will be used; otherwise, this will work when called in any Org
700 file. Calling with ARG forces current file."
702 (let ((org-velocity-always-use-bucket
703 (if arg nil org-velocity-always-use-bucket)))
704 ;; complain if inappropriate
705 (assert (org-velocity-bucket-file))
706 (let ((org-velocity-bucket-buffer
707 (find-file-noselect (org-velocity-bucket-file))))
709 (let ((dabbrev-search-these-buffers-only
710 (list (org-velocity-bucket-buffer))))
712 (if org-velocity-search-is-incremental
713 (org-velocity-incremental-read "Velocity search: ")
714 (org-velocity-read-string "Velocity search: " search))))
716 (kill-buffer (org-velocity-match-buffer))
717 (delete-other-windows))))))
719 (defalias 'org-velocity-read 'org-velocity)
721 (provide 'org-velocity)
723 ;;; org-velocity.el ends here