mirror of
https://git.savannah.gnu.org/git/emacs/org-mode.git
synced 2024-09-12 06:39:54 +00:00
* contrib/lisp/org-velocity.el: New file. * contrib/README: List org-velocity.el * lisp/org.el (org-modules): Add entry for org-velocity
470 lines
16 KiB
EmacsLisp
470 lines
16 KiB
EmacsLisp
;;; org-velocity.el --- something like Notational Velocity for Org.
|
|
|
|
;; Copyright (C) 2010 Paul M. Rodriguez
|
|
|
|
;; Author: Paul M. Rodriguez <paulmrodriguez@gmail.com>
|
|
;; Created: 2010-05-05
|
|
;; Version: 2.1
|
|
|
|
;; This file is not part of GNU Emacs.
|
|
|
|
;; This program is free software; you can redistribute it and/or
|
|
;; modify it under the terms of the GNU General Public License as
|
|
;; published by the Free Software Foundation version 2.
|
|
|
|
;; This program is distributed in the hope that it will be useful, but
|
|
;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;; General Public License for more details.
|
|
|
|
;; For a copy of the GNU General Public License, search the Internet,
|
|
;; or write to the Free Software Foundation, Inc., 59 Temple Place,
|
|
;; Suite 330, Boston, MA 02111-1307 USA
|
|
|
|
;;; Commentary:
|
|
;; Org-Velocity.el implements an interface for Org inspired by the
|
|
;; minimalist notetaking program Notational Velocity. The idea is to
|
|
;; allow you to maintain, amass and access brief notes on many
|
|
;; subjects with minimal fuss.
|
|
|
|
;; It can be used in two ways: to store and access notes from any
|
|
;; buffer a universal bucket file; or as a method for navigating any
|
|
;; Org file.
|
|
|
|
;; The name of the bucket-file (`org-velocity-bucket') and whether to
|
|
;; always use it (`org-velocity-always-use-bucket-file') are set
|
|
;; through Customize. If the bucket file is set but not always to be
|
|
;; used, then calling Org-Velocity outside of Org-mode uses the bucket
|
|
;; file; calling it in Org mode uses the current buffer. If no bucket
|
|
;; file is set then Org-Velocity only works when called from Org.
|
|
;; Even if the bucket file is always to be used, calling
|
|
;; `org-velocity-read' with an argument will use the current file.
|
|
|
|
;; The interface, unlike its inspiration, is not incremental.
|
|
;; Org-Velocity prompts for search terms in the usual way; if the user
|
|
;; has customized `org-velocity-use-completion', completion is offered
|
|
;; on the headings in the target file. If the search multiple times
|
|
;; in the target file, a buffer containing a buttonized list of the
|
|
;; headings where it occurs is displayed. Results beyond what can be
|
|
;; indexed are discarded. After clicking on a heading, or typing a
|
|
;; character associated with it, the user is taken to the heading.
|
|
;; (Typing 0 forces a new heading to be created.) If
|
|
;; `org-velocity-edit-indirectly' is so set, the heading and its
|
|
;; subtree are displayed in an indirect buffer. Otherwise the user is
|
|
;; simply taken to the proper buffer and position.
|
|
|
|
;; If the user simply hits RET at the prompt, without making a choice,
|
|
;; then the search is restored for editing. A blank search quits.
|
|
;; This method of selection is obviously not as slick as the original,
|
|
;; but probably more useful for a keyboard-driven interface.
|
|
|
|
;; If the search does not occur in the file the user is offered a
|
|
;; choice to create a new heading named with the search. When
|
|
;; org-remember is loaded, or the user customizes
|
|
;; `org-velocity-use-remember', then org-remember is used to insert
|
|
;; the new heading. Otherwise the user is simply taken to a new
|
|
;; heading at the end of the file.
|
|
|
|
;; Thanks to Richard Riley, Carsten Dominik, and Bastien Guerry for
|
|
;; their suggestions.
|
|
|
|
;;; Usage:
|
|
;;; (require 'org-velocity)
|
|
;;; (setq org-velocity-bucket (concat org-directory "/bucket.org"))
|
|
;;; (global-set-key (kbd "C-c v") 'org-velocity-read)
|
|
|
|
;;; Code:
|
|
(require 'org)
|
|
(require 'button)
|
|
(eval-when-compile (require 'cl))
|
|
|
|
(defgroup org-velocity nil
|
|
"Notational Velocity-style interface for Org."
|
|
:tag "Org-Velocity"
|
|
:group 'outlines
|
|
:group 'hypermedia)
|
|
|
|
(defcustom org-velocity-bucket ""
|
|
"Where is the bucket file?"
|
|
:group 'org-velocity
|
|
:type 'file)
|
|
|
|
(defcustom org-velocity-always-use-bucket nil
|
|
"Use bucket file even when called from an Org buffer?"
|
|
:group 'org-velocity
|
|
:type 'boolean)
|
|
|
|
(defcustom org-velocity-use-completion nil
|
|
"Complete on heading names?"
|
|
:group 'org-velocity
|
|
:type 'boolean)
|
|
|
|
(defcustom org-velocity-use-remember (featurep 'org-remember)
|
|
"Use Org-remember or just visit the file?"
|
|
:group 'org-velocity
|
|
:type 'boolean)
|
|
|
|
(defcustom org-velocity-remember-method 'bottom
|
|
"Where in files should `org-remember' record new entries?"
|
|
:group 'org-velocity
|
|
:type '(choice (const :tag "Add at bottom" bottom)
|
|
(const :tag "Add at top" top)
|
|
(const :tag "Use date tree" date-tree)))
|
|
|
|
(defcustom org-velocity-edit-indirectly t
|
|
"Edit entries in an indirect buffer or just visit the file?"
|
|
:group 'org-velocity
|
|
:type 'boolean)
|
|
|
|
(defcustom org-velocity-search-method 'phrase
|
|
"Match on whole phrase, any word, or all words?"
|
|
:group 'org-velocity
|
|
:type '(choice
|
|
(const :tag "Match whole phrase" phrase)
|
|
(const :tag "Match any word" any)
|
|
(const :tag "Match all words" all)))
|
|
|
|
(defcustom org-velocity-allow-regexps nil
|
|
"Allow searches to use regular expressions?"
|
|
:group 'org-velocity
|
|
:type 'boolean)
|
|
|
|
(defvar org-velocity-index
|
|
(nconc (number-sequence 49 57) ;numbers
|
|
(number-sequence 97 122) ;lowercase letters
|
|
(number-sequence 65 90)) ;uppercase letters
|
|
"List of chars for indexing results.")
|
|
|
|
(defstruct (org-velocity-heading
|
|
(:constructor org-velocity-make-heading)
|
|
(:type list))
|
|
(marker (point-marker))
|
|
(name (substring-no-properties
|
|
(org-get-heading))))
|
|
|
|
(defun org-velocity-use-file ()
|
|
"Return the proper file for Org-Velocity to search.
|
|
If `org-velocity-always-use-bucket' is t, use bucket file; complain
|
|
if missing. Otherwise if this is an Org file, use it."
|
|
(let ((org-velocity-bucket
|
|
(and org-velocity-bucket (expand-file-name org-velocity-bucket))))
|
|
(if org-velocity-always-use-bucket
|
|
(or org-velocity-bucket (error "Bucket required but not defined"))
|
|
(if (and (eq major-mode 'org-mode)
|
|
(buffer-file-name))
|
|
(buffer-file-name)
|
|
(or org-velocity-bucket
|
|
(error "No bucket and not an Org file"))))))
|
|
|
|
(defsubst org-velocity-display-buffer ()
|
|
"Return the proper buffer for Org-Velocity to display in."
|
|
(get-buffer-create "*Velocity headings*"))
|
|
|
|
(defsubst org-velocity-bucket-buffer ()
|
|
"Return proper buffer for bucket operations."
|
|
(find-file-noselect (org-velocity-use-file)))
|
|
|
|
(defun org-velocity-quote (search)
|
|
"Quote SEARCH as a regexp if `org-velocity-allow-regexps' is non-nil.
|
|
Acts like `regexp-quote' on a string, `regexp-opt' on a list."
|
|
(if org-velocity-allow-regexps
|
|
search
|
|
(if (listp search)
|
|
(regexp-opt search)
|
|
(regexp-quote search))))
|
|
|
|
(defun org-velocity-nearest-heading (position)
|
|
"Return last heading at POSITION.
|
|
If there is no last heading, return nil."
|
|
(save-excursion
|
|
(goto-char position)
|
|
(unless (org-before-first-heading-p)
|
|
(org-back-to-heading)
|
|
(org-velocity-make-heading))))
|
|
|
|
(defun org-velocity-make-button-action (heading)
|
|
"Return a form to visit HEADING."
|
|
`(lambda (button)
|
|
(run-hooks 'mouse-leave-buffer-hook) ;turn off temporary modes
|
|
(if org-velocity-edit-indirectly
|
|
(org-velocity-edit-entry ',heading)
|
|
(progn
|
|
(message "%s" ,(org-velocity-heading-name heading))
|
|
(switch-to-buffer (marker-buffer
|
|
,(org-velocity-heading-marker heading)))
|
|
(goto-char (marker-position
|
|
,(org-velocity-heading-marker heading)))))))
|
|
|
|
(defun org-velocity-edit-entry (heading)
|
|
"Edit entry at HEADING in an indirect buffer."
|
|
(let ((buffer (make-indirect-buffer
|
|
(marker-buffer (org-velocity-heading-marker heading))
|
|
(generate-new-buffer-name
|
|
(org-velocity-heading-name heading)))))
|
|
(with-current-buffer buffer
|
|
(let ((org-inhibit-startup t))
|
|
(org-mode))
|
|
(goto-char (marker-position (org-velocity-heading-marker heading)))
|
|
(narrow-to-region (point)
|
|
(save-excursion
|
|
(org-end-of-subtree)
|
|
(point)))
|
|
(goto-char (point-min))
|
|
(add-hook 'org-ctrl-c-ctrl-c-hook 'org-velocity-dismiss nil t))
|
|
(pop-to-buffer buffer)
|
|
(message "%s" "Use C-c C-c to save changes.")))
|
|
|
|
(defun org-velocity-dismiss ()
|
|
"Save current entry and close indirect buffer."
|
|
(progn
|
|
(save-buffer)
|
|
(kill-buffer)))
|
|
|
|
(defun org-velocity-buttonize (heading)
|
|
"Insert HEADING as a text button."
|
|
(insert (format "#%c " (nth (1- (line-number-at-pos)) org-velocity-index)))
|
|
(insert-text-button
|
|
(org-velocity-heading-name heading)
|
|
'action (org-velocity-make-button-action heading))
|
|
(newline))
|
|
|
|
(defun org-velocity-insert-heading (heading)
|
|
"Add a new heading named HEADING."
|
|
(with-current-buffer (org-velocity-bucket-buffer)
|
|
(goto-char (point-max))
|
|
(newline)
|
|
(org-insert-heading) (insert heading)
|
|
(newline)
|
|
(goto-char (point-max))))
|
|
|
|
(defun org-velocity-remember (heading &optional region)
|
|
"Use `org-remember' to record a note to HEADING.
|
|
If there is a REGION that will be inserted."
|
|
(let ((org-remember-templates
|
|
(list (list
|
|
"Velocity entry"
|
|
?v
|
|
(let ((string "* %s\n\n%%?"))
|
|
(if region
|
|
(format (concat string "%s") heading region)
|
|
(format string heading)))
|
|
(org-velocity-use-file)
|
|
org-velocity-remember-method))))
|
|
(org-remember nil ?v)))
|
|
|
|
(defun org-velocity-all-search (search)
|
|
"Return entries containing all words in SEARCH."
|
|
(when (file-exists-p (org-velocity-use-file))
|
|
(save-excursion
|
|
(delq nil
|
|
(let ((keywords
|
|
(mapcar 'org-velocity-quote
|
|
(split-string search)))
|
|
(case-fold-search t))
|
|
(apply 'nconc
|
|
(org-map-entries
|
|
(lambda ()
|
|
(let ((limit (save-excursion (org-end-of-subtree)
|
|
(point))))
|
|
(catch 'fail
|
|
(mapcar
|
|
(lambda (word)
|
|
(or (save-excursion
|
|
(and (re-search-forward word limit t)
|
|
(org-velocity-nearest-heading
|
|
(match-beginning 0))))
|
|
(throw 'fail nil)))
|
|
keywords)))))))))))
|
|
|
|
(defun org-velocity-generic-search (search)
|
|
"Return entries containing SEARCH."
|
|
(save-excursion
|
|
(delq nil
|
|
(nreverse
|
|
(let (matches (case-fold-search t))
|
|
(goto-char (point-min))
|
|
(while (re-search-forward search
|
|
(point-max) t)
|
|
(push (org-velocity-nearest-heading (match-beginning 0))
|
|
matches)
|
|
(outline-next-heading))
|
|
matches)))))
|
|
|
|
(defsubst org-velocity-phrase-search (search)
|
|
"Return entries containing SEARCH as a phrase."
|
|
(org-velocity-generic-search (org-velocity-quote search)))
|
|
|
|
(defsubst org-velocity-any-search (search)
|
|
"Return entries containing any word in SEARCH."
|
|
(org-velocity-generic-search (org-velocity-quote (split-string search))))
|
|
|
|
(defun org-velocity-present (headings)
|
|
"Buttonize HEADINGS in `org-velocity-display-buffer'."
|
|
(and (listp headings) (delete-dups headings))
|
|
(let ((cdr (nthcdr
|
|
(1- (length org-velocity-index))
|
|
headings)))
|
|
(and (consp cdr) (setcdr cdr nil)))
|
|
(with-current-buffer (org-velocity-display-buffer)
|
|
(mapc
|
|
'org-velocity-buttonize
|
|
headings)
|
|
(goto-char (point-min))))
|
|
|
|
(defun org-velocity-new (search &optional ask)
|
|
"Create new heading named SEARCH.
|
|
If ASK is non-nil, ask first."
|
|
(if (or (null ask)
|
|
(y-or-n-p "No match found, create? "))
|
|
;; if there's a region, we want to insert it
|
|
(let ((region (if (use-region-p)
|
|
(buffer-substring
|
|
(region-beginning)
|
|
(region-end)))))
|
|
(if org-velocity-use-remember
|
|
(org-velocity-remember search region)
|
|
(progn
|
|
(org-velocity-insert-heading search)
|
|
(switch-to-buffer (org-velocity-bucket-buffer))
|
|
(when region (insert region))))
|
|
(when region (message "%s" "Inserted region"))
|
|
search)))
|
|
|
|
(defun org-velocity-engine (search)
|
|
"Display a list of headings where SEARCH occurs."
|
|
(with-current-buffer (org-velocity-display-buffer) (erase-buffer))
|
|
(unless (string-equal "" search);exit on empty string
|
|
(case
|
|
(with-current-buffer (org-velocity-bucket-buffer)
|
|
(save-excursion
|
|
(let ((matches
|
|
(case org-velocity-search-method
|
|
('phrase (org-velocity-phrase-search search))
|
|
('any (org-velocity-any-search search))
|
|
('all (org-velocity-all-search search)))))
|
|
(org-velocity-present matches)
|
|
(cond ((zerop (length matches)) 'new)
|
|
((= (length matches) 1) 'follow)
|
|
((> (length matches) 1) 'prompt)))))
|
|
('prompt (progn
|
|
(display-buffer (org-velocity-display-buffer))
|
|
(case (org-velocity-follow-hint)
|
|
('edit (org-velocity-read nil search))
|
|
('new (org-velocity-new search)))))
|
|
('new (unless (org-velocity-new search t)
|
|
(org-velocity-read nil search)))
|
|
('follow (if (y-or-n-p "One match, follow? ")
|
|
(progn
|
|
(set-buffer (org-velocity-display-buffer))
|
|
(goto-char (point-min))
|
|
(button-activate (next-button (point))))
|
|
(org-velocity-read nil search))))))
|
|
|
|
(defun org-velocity-list-position (elt list)
|
|
"Return first position of ELT in LIST"
|
|
(let ((copy (copy-list list)))
|
|
(1-
|
|
(length
|
|
(progn
|
|
(setcdr (member elt copy) nil)
|
|
copy)))))
|
|
|
|
(defun org-velocity-activate-button (char)
|
|
"Go to button on line number associated with CHAR in `org-velocity-index'."
|
|
(goto-char (point-min))
|
|
(forward-line (org-velocity-list-position char org-velocity-index))
|
|
(goto-char
|
|
(button-start
|
|
(next-button (point))))
|
|
(message "%s" (button-label (button-at (point))))
|
|
(button-activate (button-at (point))))
|
|
|
|
(defun org-velocity-follow-hint ()
|
|
"Prompt for index of button."
|
|
(let ((hint
|
|
(read-key
|
|
"Follow (0 for new note, RET to edit search, TAB to scroll): ")))
|
|
(cond
|
|
;; quit?
|
|
((or (eq hint 7) ;C-g
|
|
(eq hint 27)) ;ESC
|
|
(keyboard-quit))
|
|
;; zero?
|
|
((eq hint 48)
|
|
'new)
|
|
;; return?
|
|
((or (eq hint 13) ;\r
|
|
(eq hint 10)) ;\n
|
|
'edit)
|
|
;; tab?
|
|
((eq hint 9)
|
|
(let ((other-window-scroll-buffer
|
|
(org-velocity-display-buffer)))
|
|
(scroll-other-window))
|
|
(org-velocity-follow-hint))
|
|
;; click?
|
|
((mouse-event-p hint)
|
|
(mouse-set-point hint)
|
|
(if (button-at (point))
|
|
(push-button (point))
|
|
(org-velocity-follow-hint)))
|
|
;; unhandled char?
|
|
((not (memq hint org-velocity-index))
|
|
(org-velocity-follow-hint))
|
|
;; index beyond results?
|
|
((> (org-velocity-list-position hint org-velocity-index)
|
|
(with-current-buffer (org-velocity-display-buffer)
|
|
(1- (count-lines (point-min) (point-max)))))
|
|
(org-velocity-follow-hint))
|
|
;; follow hint
|
|
(t (set-buffer (org-velocity-display-buffer))
|
|
(org-velocity-activate-button hint)))))
|
|
|
|
(defun org-velocity-read-string (prompt &optional initial-input)
|
|
"Read string using `read-string', with PROMPT followed by INITIAL-INPUT."
|
|
;; The use of initial inputs to the minibuffer is deprecated (see
|
|
;; `read-from-minibuffer', but in this case it is the user-friendly
|
|
;; thing to do.
|
|
(let ((minibuffer-setup-hook minibuffer-setup-hook))
|
|
(add-hook 'minibuffer-setup-hook (lambda ()
|
|
(and initial-input (insert initial-input))
|
|
(goto-char (point-max))))
|
|
(if (and org-velocity-use-completion
|
|
;; map-entries complains for nonexistent files
|
|
(file-exists-p (org-velocity-use-file)))
|
|
(completing-read
|
|
prompt
|
|
(with-current-buffer (org-velocity-bucket-buffer)
|
|
(org-map-entries
|
|
(lambda ()
|
|
(substring-no-properties
|
|
(org-get-heading))))))
|
|
(read-string prompt))))
|
|
|
|
(defun org-velocity-read (arg &optional search)
|
|
"Read a search string SEARCH for Org-Velocity interface.
|
|
This means that a buffer will display all headings where SEARCH
|
|
occurs, where one can be selected by a mouse click or by typing
|
|
its index. If SEARCH does not occur, then a new heading may be
|
|
created named SEARCH.
|
|
|
|
If `org-velocity-bucket' is defined and
|
|
`org-velocity-always-use-bucket' is non-nil, then the bucket file
|
|
will be used; otherwise, this will work when called in any Org
|
|
file. Calling with ARG forces current file."
|
|
(interactive "P")
|
|
(let ((org-velocity-always-use-bucket
|
|
(if arg nil org-velocity-always-use-bucket)))
|
|
;; complain if inappropriate
|
|
(assert (org-velocity-use-file))
|
|
(unwind-protect
|
|
(org-velocity-engine
|
|
(org-velocity-read-string "Velocity search: " search))
|
|
(progn
|
|
(kill-buffer (org-velocity-display-buffer))
|
|
(delete-other-windows)))))
|
|
|
|
(provide 'org-velocity)
|
|
|
|
;;; org-velocity.el ends here
|