New version of Org-Velocity

This commit is contained in:
Paul M. Rodriguez 2014-10-26 17:13:18 -05:00 committed by Bastien Guerry
parent e435b0eac3
commit 8618c40ed4
1 changed files with 163 additions and 146 deletions

View File

@ -1,10 +1,10 @@
;;; org-velocity.el --- something like Notational Velocity for Org.
;;; org-velocity.el --- something like Notational Velocity for Org. -*- lexical-binding: t -*-
;; Copyright (C) 2010-2014 Paul M. Rodriguez
;; Author: Paul M. Rodriguez <paulmrodriguez@gmail.com>
;; Created: 2010-05-05
;; Version: 3.0
;; Version: 4.0
;; This file is not part of GNU Emacs.
@ -64,7 +64,7 @@
(require 'button)
(require 'electric)
(require 'dabbrev)
(eval-when-compile (require 'cl))
(require 'cl-lib)
(defgroup org-velocity nil
"Notational Velocity-style interface for Org."
@ -152,6 +152,17 @@ See the documentation for `org-capture-templates'."
:group 'org-velocity
:type (or (get 'org-capture-templates 'custom-type) 'list))
(defcustom org-velocity-heading-level 1
"Only match headings at this level or higher.
0 means to match headings at any level."
:group 'org-velocity
:type 'integer
:safe (lambda (x)
(and (integerp x)
(>= x 0))))
(defvar crm-separator) ;Ensure dynamic binding.
(defsubst org-velocity-grab-preview ()
"Grab preview of a subtree.
The length of the preview is determined by `window-width'.
@ -172,14 +183,14 @@ Replace all contiguous whitespace with single spaces."
(point-max))))
" ")))
(defstruct org-velocity-heading buffer position name level preview)
(cl-defstruct org-velocity-heading buffer position name level preview)
(defsubst org-velocity-nearest-heading (position)
"Return last heading at POSITION.
If there is no last heading, return nil."
(save-excursion
(goto-char position)
(re-search-backward org-velocity-heading-regexp)
(re-search-backward (org-velocity-heading-regexp))
(let ((components (org-heading-components)))
(make-org-velocity-heading
:buffer (current-buffer)
@ -198,8 +209,11 @@ If there is no last heading, return nil."
(defconst org-velocity-match-buffer-name "*Velocity matches*")
(defconst org-velocity-heading-regexp "^\\* "
"Regexp to match only top-level headings.")
(cl-defun org-velocity-heading-regexp (&optional (level org-velocity-heading-level))
"Regexp to match headings at LEVEL or deeper."
(if (zerop level)
"^\\*+ "
(format "^\\*\\{1,%d\\} " level)))
(defvar org-velocity-search nil
"Variable to bind to current search.")
@ -223,12 +237,6 @@ of the base buffer; in the latter, return the file name of
(with-current-buffer (window-buffer (active-minibuffer-window))
(minibuffer-contents))))
(defsubst org-velocity-singlep (object)
"Return t when OBJECT is a list or sequence of one element."
(if (consp object)
(null (cdr object))
(= (length object) 1)))
(defun org-velocity-bucket-file ()
"Return the proper file for Org-Velocity to search.
If `org-velocity-always-use-bucket' is t, use bucket file;
@ -260,17 +268,22 @@ use it."
"Return the proper buffer for Org-Velocity to display in."
(get-buffer-create org-velocity-match-buffer-name))
(defsubst org-velocity-match-window ()
(get-buffer-window (org-velocity-match-buffer)))
(defsubst org-velocity-match-staging-buffer ()
(get-buffer-create " Velocity matches"))
(defun org-velocity-beginning-of-headings ()
"Goto the start of the first heading."
(goto-char (point-min))
;; If we are before the first heading we could still be at the
;; first heading.
(or (looking-at org-velocity-heading-regexp)
(re-search-forward org-velocity-heading-regexp)))
(or (looking-at (org-velocity-heading-regexp))
(re-search-forward (org-velocity-heading-regexp))))
(defun org-velocity-make-indirect-buffer (heading)
"Make or switch to an indirect buffer visiting HEADING."
(let* ((bucket (org-velocity-heading-buffer heading))
(name (org-velocity-heading-name heading))
(existing (get-buffer name)))
@ -279,7 +292,8 @@ use it."
existing
(make-indirect-buffer
bucket
(generate-new-buffer-name (org-velocity-heading-name heading))))))
(generate-new-buffer-name (org-velocity-heading-name heading))
t))))
(defun org-velocity-capture ()
"Record a note with `org-capture'."
@ -287,34 +301,38 @@ use it."
org-velocity-capture-templates))
(org-capture nil
;; This is no longer automatically selected.
(when (org-velocity-singlep org-capture-templates)
(when (null (cdr org-capture-templates))
(caar org-capture-templates)))
(if org-capture-mode (rename-buffer org-velocity-search t))))
(when org-capture-mode
(rename-buffer org-velocity-search t))))
(defvar org-velocity-saved-winconf nil)
(make-variable-buffer-local 'org-velocity-saved-winconf)
(defun org-velocity-edit-entry (heading)
"Edit entry at HEADING in an indirect buffer."
(let ((winconf (current-window-configuration)))
(let ((buffer (org-velocity-make-indirect-buffer heading)))
(let ((winconf (current-window-configuration))
(buffer (org-velocity-make-indirect-buffer heading))
(inhibit-point-motion-hooks t)
(inhibit-field-text-motion t))
(with-current-buffer buffer
(let ((org-inhibit-startup t))
(org-mode))
(setq org-velocity-saved-winconf winconf)
(goto-char (org-velocity-heading-position heading))
(narrow-to-region (point)
(save-excursion
(let ((start (point))
(end (save-excursion
(org-end-of-subtree t)
(point)))
(goto-char (point-min))
(point))))
;; Outline view and narrow-to-region interact poorly.
(outline-flag-region start end nil)
(narrow-to-region start end))
(goto-char (point-max))
(add-hook 'org-ctrl-c-ctrl-c-hook 'org-velocity-dismiss nil t))
(pop-to-buffer buffer)
(set (make-local-variable 'header-line-format)
(format "%s Use C-c C-c to finish."
(abbreviate-file-name
(buffer-file-name
(org-velocity-heading-buffer heading))))))))
(org-velocity-heading-buffer heading)))))))
(defun org-velocity-dismiss ()
"Save current entry and close indirect buffer."
@ -327,14 +345,18 @@ use it."
(defun org-velocity-visit-button (button)
(run-hooks 'mouse-leave-buffer-hook)
(if org-velocity-use-search-ring
(when org-velocity-use-search-ring
(add-to-history 'search-ring
(button-get button 'search)
search-ring-max))
(org-velocity-edit-entry (button-get button 'match)))
(let ((match (button-get button 'match)))
(throw 'org-velocity-done
(lambda ()
(org-velocity-edit-entry match)))))
(define-button-type 'org-velocity-button
'action #'org-velocity-visit-button)
'action #'org-velocity-visit-button
'follow-link 'mouse-face)
(defsubst org-velocity-buttonize (heading)
"Insert HEADING as a text button with no hints."
@ -352,8 +374,8 @@ use it."
(org-velocity-heading-preview heading)
'face 'shadow))))
(defsubst* org-velocity-present-match (&key hint match)
(with-current-buffer (org-velocity-match-buffer)
(defsubst org-velocity-present-match (hint match)
(with-current-buffer (org-velocity-match-staging-buffer)
(when hint (insert "#" hint " "))
(org-velocity-buttonize match)
(org-velocity-insert-preview match)
@ -362,19 +384,19 @@ use it."
(defun org-velocity-generic-search (search &optional hide-hints)
"Display any entry containing SEARCH."
(let ((hints org-velocity-index) matches)
(block nil
(cl-block nil
(while (and hints (re-search-forward search nil t))
(let ((match (org-velocity-nearest-heading (point))))
(org-velocity-present-match
:hint (unless hide-hints (car hints))
:match match)
(unless hide-hints (car hints))
match)
(push match matches))
(setq hints (cdr hints))
(unless (re-search-forward org-velocity-heading-regexp nil t)
(unless (re-search-forward (org-velocity-heading-regexp) nil t)
(return))))
(nreverse matches)))
(defun* org-velocity-all-search (search &optional hide-hints max)
(cl-defun org-velocity-all-search (search &optional hide-hints)
"Display only entries containing every word in SEARCH."
(let ((keywords (mapcar 'regexp-quote (split-string search)))
(hints org-velocity-index)
@ -388,23 +410,23 @@ use it."
(setq org-map-continue-from
(save-excursion
(goto-char (line-end-position))
(if (re-search-forward org-velocity-heading-regexp nil t)
(if (re-search-forward (org-velocity-heading-regexp) nil t)
(line-end-position)
(point-max))))
(when (loop for word in keywords
(when (cl-loop for word in keywords
always (save-excursion
(re-search-forward
(concat "\\<" word "\\>")
org-map-continue-from t)))
(let ((match (org-velocity-nearest-heading (match-end 0))))
(org-velocity-present-match
:hint (unless hide-hints (car hints))
:match match)
(unless hide-hints (car hints))
match)
(push match matches)
(setq hints (cdr hints))))))
(nreverse matches)))
(defun* org-velocity-present (search &key hide-hints)
(cl-defun org-velocity-present (search &key hide-hints)
"Buttonize matches for SEARCH in `org-velocity-match-buffer'.
If HIDE-HINTS is non-nil, display entries without indices. SEARCH
binds `org-velocity-search'.
@ -425,7 +447,7 @@ Return matches."
(inhibit-field-text-motion t))
(save-excursion
(org-velocity-beginning-of-headings)
(case org-velocity-search-method
(cl-case org-velocity-search-method
(all (org-velocity-all-search search hide-hints))
(phrase (org-velocity-generic-search
(concat "\\<" (regexp-quote search))
@ -440,6 +462,7 @@ Return matches."
(invalid-regexp
(minibuffer-message "%s" lossage))))))))
(with-current-buffer (org-velocity-match-buffer)
(buffer-swap-text (org-velocity-match-staging-buffer))
(goto-char (point-min)))))
(with-current-buffer (org-velocity-match-buffer)
(erase-buffer))))
@ -452,7 +475,7 @@ Return matches."
(add-hook 'org-store-link-functions 'org-velocity-store-link)
(defun* org-velocity-create (search &key ask)
(cl-defun org-velocity-create (search &key ask)
"Create new heading named SEARCH.
If ASK is non-nil, ask first."
(when (or (null ask) (y-or-n-p "No match found, create? "))
@ -469,17 +492,18 @@ If ASK is non-nil, ask first."
(unless (or
(not (stringp search))
(string= "" search)) ;exit on empty string
(case
(cl-case
(if (and org-velocity-force-new (eq last-command-event ?\C-j))
:force
(let ((matches (org-velocity-present search)))
(let* ((org-velocity-index (org-velocity-adjust-index))
(matches (org-velocity-present search)))
(cond ((null matches) :new)
((org-velocity-singlep matches) :follow)
((null (cdr matches)) :follow)
(t :prompt))))
(:prompt (progn
(pop-to-buffer (org-velocity-match-buffer))
(let ((hint (org-velocity-electric-read-hint)))
(when hint (case hint
(when hint (cl-case hint
(:edit (org-velocity-read nil search))
(:force (org-velocity-create search))
(otherwise (org-velocity-activate-button hint)))))))
@ -493,17 +517,10 @@ If ASK is non-nil, ask first."
(button-activate (next-button (point))))
(org-velocity-read nil search)))))))
(defun org-velocity-position (item list)
"Return first position of ITEM in LIST."
(loop for elt in list
for i from 0
when (equal elt item)
return i))
(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-position char org-velocity-index))
(forward-line (cl-position char org-velocity-index))
(goto-char
(button-start
(next-button (point))))
@ -525,20 +542,11 @@ If ASK is non-nil, ask first."
(defun org-velocity-electric-follow (ev)
"Follow a hint indexed by keyboard event EV."
(interactive (list last-command-event))
(if (not (> (org-velocity-position ev org-velocity-index)
(if (not (> (cl-position ev org-velocity-index)
(1- (count-lines (point-min) (point-max)))))
(throw 'org-velocity-select ev)
(call-interactively 'org-velocity-electric-undefined)))
(defun org-velocity-electric-click (ev)
"Follow hint indexed by a mouse event EV."
(interactive "e")
(throw 'org-velocity-select
(nth (1- (count-lines
(point-min)
(posn-point (event-start ev))))
org-velocity-index)))
(defun org-velocity-electric-edit ()
"Edit the search string."
(interactive)
@ -552,14 +560,15 @@ If ASK is non-nil, ask first."
(defvar org-velocity-electric-map
(let ((map (make-sparse-keymap)))
(define-key map [t] 'org-velocity-electric-undefined)
(loop for c in org-velocity-index
do (define-key map (char-to-string c) 'org-velocity-electric-follow))
(dolist (c org-velocity-index)
(define-key map (char-to-string c)
'org-velocity-electric-follow))
(define-key map "0" 'org-velocity-electric-new)
(define-key map "\C-v" 'scroll-up)
(define-key map "\M-v" 'scroll-down)
(define-key map (kbd "RET") 'org-velocity-electric-edit)
(define-key map [mouse-1] 'org-velocity-electric-click)
(define-key map [mouse-2] 'org-velocity-electric-click)
(define-key map [mouse-1] nil)
(define-key map [mouse-2] nil)
(define-key map [escape] 'keyboard-quit)
(define-key map "\C-h" 'help-command)
map))
@ -567,29 +576,19 @@ If ASK is non-nil, ask first."
(defun org-velocity-electric-read-hint ()
"Read index of button electrically."
(with-current-buffer (org-velocity-match-buffer)
(when (featurep 'evil)
;; NB Idempotent.
(evil-make-overriding-map org-velocity-electric-map))
(use-local-map org-velocity-electric-map)
(catch 'org-velocity-select
(Electric-command-loop 'org-velocity-select "Follow: "))))
(defvar org-velocity-incremental-keymap
(let ((map (make-sparse-keymap)))
(define-key map [mouse-1] 'org-velocity-click-for-incremental)
(define-key map [mouse-2] 'org-velocity-click-for-incremental)
(define-key map "\C-v" 'scroll-up)
(define-key map "\M-v" 'scroll-down)
map))
(defun org-velocity-click-for-incremental ()
"Jump out of search and select hint clicked on."
(interactive)
(let ((ev last-command-event))
(org-velocity-activate-button
(nth (- (count-lines
(point-min)
(posn-point (event-start ev))) 2)
org-velocity-index)))
(throw 'click (current-buffer)))
(defun org-velocity-displaying-completions-p ()
"Is there a *Completions* buffer showing?"
(get-window-with-predicate
@ -598,8 +597,7 @@ If ASK is non-nil, ask first."
'completion-list-mode))))
(defun org-velocity-update ()
"Display results of search without hinting.
Stop searching once there are more matches than can be displayed."
"Display results of search without hinting."
(unless (org-velocity-displaying-completions-p)
(let* ((search (org-velocity-minibuffer-contents))
(matches (org-velocity-present search :hide-hints t)))
@ -607,20 +605,20 @@ Stop searching once there are more matches than can be displayed."
(select-window (active-minibuffer-window))
(unless (or (null search) (string= "" search))
(minibuffer-message "No match; RET to create")))
((and (org-velocity-singlep matches)
((and (null (cdr matches))
org-velocity-exit-on-match)
(throw 'click search))
(t
(with-current-buffer (org-velocity-match-buffer)
(use-local-map org-velocity-incremental-keymap)))))))
(defvar dabbrev--last-abbrev)
(defvar dabbrev--last-abbreviation)
(defun org-velocity-dabbrev-completion-list (abbrev)
"Return all dabbrev completions for ABBREV."
;; This is based on `dabbrev-completion'.
(dabbrev--reset-global-variables)
(setq dabbrev--last-abbrev abbrev)
(setq dabbrev--last-abbreviation abbrev)
(dabbrev--find-all-expansions abbrev case-fold-search))
(defvar org-velocity-local-completion-map
@ -638,7 +636,7 @@ Stop searching once there are more matches than can be displayed."
(completion-no-auto-exit t)
(crm-separator " "))
(funcall
(case org-velocity-search-method
(cl-case org-velocity-search-method
(phrase #'completing-read)
(any #'completing-read-multiple)
(all #'completing-read-multiple))
@ -652,7 +650,7 @@ Stop searching once there are more matches than can be displayed."
;; `read-from-minibuffer'), but in this case it is the user-friendly
;; thing to do.
(minibuffer-with-setup-hook
(lexical-let ((initial-input initial-input))
(let ((initial-input initial-input))
(lambda ()
(and initial-input (insert initial-input))
(goto-char (point-max))))
@ -662,28 +660,40 @@ Stop searching once there are more matches than can be displayed."
(org-velocity-read-with-completion prompt)
(read-string prompt)))))
(cl-defun org-velocity-adjust-index
(&optional (match-window (org-velocity-match-window)))
"Truncate or extend `org-velocity-index' to the lines in
MATCH-WINDOW."
(with-selected-window match-window
(let ((lines (window-height))
(hints (length org-velocity-index)))
(cond ((= lines hints)
org-velocity-index)
;; Truncate the index to the size of
;; the buffer to be displayed.
((< lines hints)
(cl-subseq org-velocity-index 0 lines))
;; If the window is so tall we run out of indices, at
;; least make the additional results clickable.
((> lines hints)
(append org-velocity-index
(make-list (- lines hints) nil)))))))
(defun org-velocity-incremental-read (prompt)
"Read string with PROMPT and display results incrementally."
"Read string with PROMPT and display results incrementally.
Stop searching once there are more matches than can be
displayed."
(let ((res
(unwind-protect
(let* ((match-window (display-buffer (org-velocity-match-buffer)))
(org-velocity-index
;; Truncate the index to the size of the buffer to be
;; displayed.
(with-selected-window match-window
(if (< (window-height) (length org-velocity-index))
;; (subseq org-velocity-index 0 (window-height))
(let ((hints (copy-sequence org-velocity-index)))
(setcdr (nthcdr (window-height) hints) nil)
hints)
org-velocity-index))))
(org-velocity-index (org-velocity-adjust-index match-window)))
(catch 'click
(add-hook 'post-command-hook 'org-velocity-update)
(if (eq org-velocity-search-method 'regexp)
(read-regexp prompt)
(if org-velocity-use-completion
(org-velocity-read-with-completion prompt)
(read-string prompt)))))
(cond ((eq org-velocity-search-method 'regexp)
(read-regexp prompt))
(org-velocity-use-completion
(org-velocity-read-with-completion prompt))
(t (read-string prompt)))))
(remove-hook 'post-command-hook 'org-velocity-update))))
(if (bufferp res) (org-pop-to-buffer-same-window res) res)))
@ -697,24 +707,31 @@ 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."
file.
Calling with ARG reverses which file the current file or the
bucket file to use. If the bucket file would have been used,
then the current file is used instead, and vice versa."
(interactive "P")
(let ((org-velocity-always-use-bucket
(if arg nil org-velocity-always-use-bucket)))
(if org-velocity-always-use-bucket
(not arg)
arg)))
;; complain if inappropriate
(assert (org-velocity-bucket-file))
(cl-assert (org-velocity-bucket-file))
(let ((org-velocity-bucket-buffer
(find-file-noselect (org-velocity-bucket-file))))
(unwind-protect
(let ((dabbrev-search-these-buffers-only
(list (org-velocity-bucket-buffer))))
(funcall
(catch 'org-velocity-done
(org-velocity-engine
(if org-velocity-search-is-incremental
(org-velocity-incremental-read "Velocity search: ")
(org-velocity-read-string "Velocity search: " search))))
(progn
(kill-buffer (org-velocity-match-buffer))
(delete-other-windows))))))
(org-velocity-read-string "Velocity search: " search)))
#'ignore)))
(kill-buffer (org-velocity-match-buffer))))))
(defalias 'org-velocity-read 'org-velocity)