ndwarshuis
/
org-mode
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

309
contrib/lisp/org-velocity.el
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 ;; Copyright (C) 2010-2014 Paul M. Rodriguez
;; Author: Paul M. Rodriguez <paulmrodriguez@gmail.com> ;; Author: Paul M. Rodriguez <paulmrodriguez@gmail.com>
;; Created: 2010-05-05 ;; Created: 2010-05-05
;; Version: 3.0 ;; Version: 4.0
;; This file is not part of GNU Emacs. ;; This file is not part of GNU Emacs.
@ -64,7 +64,7 @@
(require 'button) (require 'button)
(require 'electric) (require 'electric)
(require 'dabbrev) (require 'dabbrev)
(eval-when-compile (require 'cl)) (require 'cl-lib)
(defgroup org-velocity nil (defgroup org-velocity nil
"Notational Velocity-style interface for Org." "Notational Velocity-style interface for Org."
@ -133,9 +133,9 @@ file."
"Match on whole phrase, any word, or all words?" "Match on whole phrase, any word, or all words?"
:group 'org-velocity :group 'org-velocity
:type '(choice :type '(choice
(const :tag "Match whole phrase" phrase) (const :tag "Match whole phrase" phrase)
(const :tag "Match any word" any) (const :tag "Match any word" any)
(const :tag "Match all words" all) (const :tag "Match all words" all)
(const :tag "Match a regular expression" regexp)) (const :tag "Match a regular expression" regexp))
:safe (lambda (v) (memq v '(phrase any all regexp)))) :safe (lambda (v) (memq v '(phrase any all regexp))))
@ -152,6 +152,17 @@ See the documentation for `org-capture-templates'."
:group 'org-velocity :group 'org-velocity
:type (or (get 'org-capture-templates 'custom-type) 'list)) :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 () (defsubst org-velocity-grab-preview ()
"Grab preview of a subtree. "Grab preview of a subtree.
The length of the preview is determined by `window-width'. The length of the preview is determined by `window-width'.
@ -172,14 +183,14 @@ Replace all contiguous whitespace with single spaces."
(point-max)))) (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) (defsubst org-velocity-nearest-heading (position)
"Return last heading at POSITION. "Return last heading at POSITION.
If there is no last heading, return nil." If there is no last heading, return nil."
(save-excursion (save-excursion
(goto-char position) (goto-char position)
(re-search-backward org-velocity-heading-regexp) (re-search-backward (org-velocity-heading-regexp))
(let ((components (org-heading-components))) (let ((components (org-heading-components)))
(make-org-velocity-heading (make-org-velocity-heading
:buffer (current-buffer) :buffer (current-buffer)
@ -191,15 +202,18 @@ If there is no last heading, return nil."
(defconst org-velocity-index (defconst org-velocity-index
(eval-when-compile (eval-when-compile
(nconc (number-sequence 49 57) ;numbers (nconc (number-sequence 49 57) ;numbers
(number-sequence 97 122) ;lowercase letters (number-sequence 97 122) ;lowercase letters
(number-sequence 65 90))) ;uppercase letters (number-sequence 65 90))) ;uppercase letters
"List of chars for indexing results.") "List of chars for indexing results.")
(defconst org-velocity-match-buffer-name "*Velocity matches*") (defconst org-velocity-match-buffer-name "*Velocity matches*")
(defconst org-velocity-heading-regexp "^\\* " (cl-defun org-velocity-heading-regexp (&optional (level org-velocity-heading-level))
"Regexp to match only top-level headings.") "Regexp to match headings at LEVEL or deeper."
(if (zerop level)
"^\\*+ "
(format "^\\*\\{1,%d\\} " level)))
(defvar org-velocity-search nil (defvar org-velocity-search nil
"Variable to bind to current search.") "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)) (with-current-buffer (window-buffer (active-minibuffer-window))
(minibuffer-contents)))) (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 () (defun org-velocity-bucket-file ()
"Return the proper file for Org-Velocity to search. "Return the proper file for Org-Velocity to search.
If `org-velocity-always-use-bucket' is t, use bucket file; 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." "Return the proper buffer for Org-Velocity to display in."
(get-buffer-create org-velocity-match-buffer-name)) (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 () (defun org-velocity-beginning-of-headings ()
"Goto the start of the first heading." "Goto the start of the first heading."
(goto-char (point-min)) (goto-char (point-min))
;; If we are before the first heading we could still be at the ;; If we are before the first heading we could still be at the
;; first heading. ;; first heading.
(or (looking-at org-velocity-heading-regexp) (or (looking-at (org-velocity-heading-regexp))
(re-search-forward org-velocity-heading-regexp))) (re-search-forward (org-velocity-heading-regexp))))
(defun org-velocity-make-indirect-buffer (heading) (defun org-velocity-make-indirect-buffer (heading)
"Make or switch to an indirect buffer visiting HEADING." "Make or switch to an indirect buffer visiting HEADING."
(let* ((bucket (org-velocity-heading-buffer heading)) (let* ((bucket (org-velocity-heading-buffer heading))
(name (org-velocity-heading-name heading)) (name (org-velocity-heading-name heading))
(existing (get-buffer name))) (existing (get-buffer name)))
@ -279,7 +292,8 @@ use it."
existing existing
(make-indirect-buffer (make-indirect-buffer
bucket bucket
(generate-new-buffer-name (org-velocity-heading-name heading)))))) (generate-new-buffer-name (org-velocity-heading-name heading))
t))))
(defun org-velocity-capture () (defun org-velocity-capture ()
"Record a note with `org-capture'." "Record a note with `org-capture'."
@ -287,34 +301,38 @@ use it."
org-velocity-capture-templates)) org-velocity-capture-templates))
(org-capture nil (org-capture nil
;; This is no longer automatically selected. ;; This is no longer automatically selected.
(when (org-velocity-singlep org-capture-templates) (when (null (cdr org-capture-templates))
(caar 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) (defvar org-velocity-saved-winconf nil)
(make-variable-buffer-local 'org-velocity-saved-winconf) (make-variable-buffer-local 'org-velocity-saved-winconf)
(defun org-velocity-edit-entry (heading) (defun org-velocity-edit-entry (heading)
"Edit entry at HEADING in an indirect buffer." "Edit entry at HEADING in an indirect buffer."
(let ((winconf (current-window-configuration))) (let ((winconf (current-window-configuration))
(let ((buffer (org-velocity-make-indirect-buffer heading))) (buffer (org-velocity-make-indirect-buffer heading))
(with-current-buffer buffer (inhibit-point-motion-hooks t)
(let ((org-inhibit-startup t)) (inhibit-field-text-motion t))
(org-mode)) (with-current-buffer buffer
(setq org-velocity-saved-winconf winconf) (setq org-velocity-saved-winconf winconf)
(goto-char (org-velocity-heading-position heading)) (goto-char (org-velocity-heading-position heading))
(narrow-to-region (point) (let ((start (point))
(save-excursion (end (save-excursion
(org-end-of-subtree t) (org-end-of-subtree t)
(point))) (point))))
(goto-char (point-min)) ;; Outline view and narrow-to-region interact poorly.
(add-hook 'org-ctrl-c-ctrl-c-hook 'org-velocity-dismiss nil t)) (outline-flag-region start end nil)
(pop-to-buffer buffer) (narrow-to-region start end))
(set (make-local-variable 'header-line-format) (goto-char (point-max))
(format "%s Use C-c C-c to finish." (add-hook 'org-ctrl-c-ctrl-c-hook 'org-velocity-dismiss nil t))
(abbreviate-file-name (pop-to-buffer buffer)
(buffer-file-name (set (make-local-variable 'header-line-format)
(org-velocity-heading-buffer heading)))))))) (format "%s Use C-c C-c to finish."
(abbreviate-file-name
(buffer-file-name
(org-velocity-heading-buffer heading)))))))
(defun org-velocity-dismiss () (defun org-velocity-dismiss ()
"Save current entry and close indirect buffer." "Save current entry and close indirect buffer."
@ -327,14 +345,18 @@ use it."
(defun org-velocity-visit-button (button) (defun org-velocity-visit-button (button)
(run-hooks 'mouse-leave-buffer-hook) (run-hooks 'mouse-leave-buffer-hook)
(if org-velocity-use-search-ring (when org-velocity-use-search-ring
(add-to-history 'search-ring (add-to-history 'search-ring
(button-get button 'search) (button-get button 'search)
search-ring-max)) 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 (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) (defsubst org-velocity-buttonize (heading)
"Insert HEADING as a text button with no hints." "Insert HEADING as a text button with no hints."
@ -352,8 +374,8 @@ use it."
(org-velocity-heading-preview heading) (org-velocity-heading-preview heading)
'face 'shadow)))) 'face 'shadow))))
(defsubst* org-velocity-present-match (&key hint match) (defsubst org-velocity-present-match (hint match)
(with-current-buffer (org-velocity-match-buffer) (with-current-buffer (org-velocity-match-staging-buffer)
(when hint (insert "#" hint " ")) (when hint (insert "#" hint " "))
(org-velocity-buttonize match) (org-velocity-buttonize match)
(org-velocity-insert-preview match) (org-velocity-insert-preview match)
@ -362,19 +384,19 @@ use it."
(defun org-velocity-generic-search (search &optional hide-hints) (defun org-velocity-generic-search (search &optional hide-hints)
"Display any entry containing SEARCH." "Display any entry containing SEARCH."
(let ((hints org-velocity-index) matches) (let ((hints org-velocity-index) matches)
(block nil (cl-block nil
(while (and hints (re-search-forward search nil t)) (while (and hints (re-search-forward search nil t))
(let ((match (org-velocity-nearest-heading (point)))) (let ((match (org-velocity-nearest-heading (point))))
(org-velocity-present-match (org-velocity-present-match
:hint (unless hide-hints (car hints)) (unless hide-hints (car hints))
:match match) match)
(push match matches)) (push match matches))
(setq hints (cdr hints)) (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)))) (return))))
(nreverse matches))) (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." "Display only entries containing every word in SEARCH."
(let ((keywords (mapcar 'regexp-quote (split-string search))) (let ((keywords (mapcar 'regexp-quote (split-string search)))
(hints org-velocity-index) (hints org-velocity-index)
@ -388,23 +410,23 @@ use it."
(setq org-map-continue-from (setq org-map-continue-from
(save-excursion (save-excursion
(goto-char (line-end-position)) (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) (line-end-position)
(point-max)))) (point-max))))
(when (loop for word in keywords (when (cl-loop for word in keywords
always (save-excursion always (save-excursion
(re-search-forward (re-search-forward
(concat "\\<" word "\\>") (concat "\\<" word "\\>")
org-map-continue-from t))) org-map-continue-from t)))
(let ((match (org-velocity-nearest-heading (match-end 0)))) (let ((match (org-velocity-nearest-heading (match-end 0))))
(org-velocity-present-match (org-velocity-present-match
:hint (unless hide-hints (car hints)) (unless hide-hints (car hints))
:match match) match)
(push match matches) (push match matches)
(setq hints (cdr hints)))))) (setq hints (cdr hints))))))
(nreverse matches))) (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'. "Buttonize matches for SEARCH in `org-velocity-match-buffer'.
If HIDE-HINTS is non-nil, display entries without indices. SEARCH If HIDE-HINTS is non-nil, display entries without indices. SEARCH
binds `org-velocity-search'. binds `org-velocity-search'.
@ -425,7 +447,7 @@ Return matches."
(inhibit-field-text-motion t)) (inhibit-field-text-motion t))
(save-excursion (save-excursion
(org-velocity-beginning-of-headings) (org-velocity-beginning-of-headings)
(case org-velocity-search-method (cl-case org-velocity-search-method
(all (org-velocity-all-search search hide-hints)) (all (org-velocity-all-search search hide-hints))
(phrase (org-velocity-generic-search (phrase (org-velocity-generic-search
(concat "\\<" (regexp-quote search)) (concat "\\<" (regexp-quote search))
@ -440,6 +462,7 @@ Return matches."
(invalid-regexp (invalid-regexp
(minibuffer-message "%s" lossage)))))))) (minibuffer-message "%s" lossage))))))))
(with-current-buffer (org-velocity-match-buffer) (with-current-buffer (org-velocity-match-buffer)
(buffer-swap-text (org-velocity-match-staging-buffer))
(goto-char (point-min))))) (goto-char (point-min)))))
(with-current-buffer (org-velocity-match-buffer) (with-current-buffer (org-velocity-match-buffer)
(erase-buffer)))) (erase-buffer))))
@ -452,14 +475,14 @@ Return matches."
(add-hook 'org-store-link-functions 'org-velocity-store-link) (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. "Create new heading named SEARCH.
If ASK is non-nil, ask first." If ASK is non-nil, ask first."
(when (or (null ask) (y-or-n-p "No match found, create? ")) (when (or (null ask) (y-or-n-p "No match found, create? "))
(let ((org-velocity-search search) (let ((org-velocity-search search)
(org-default-notes-file (org-velocity-bucket-file)) (org-default-notes-file (org-velocity-bucket-file))
;; save a stored link ;; save a stored link
org-store-link-plist) org-store-link-plist)
(org-velocity-capture)) (org-velocity-capture))
search)) search))
@ -469,17 +492,18 @@ If ASK is non-nil, ask first."
(unless (or (unless (or
(not (stringp search)) (not (stringp search))
(string= "" search)) ;exit on empty string (string= "" search)) ;exit on empty string
(case (cl-case
(if (and org-velocity-force-new (eq last-command-event ?\C-j)) (if (and org-velocity-force-new (eq last-command-event ?\C-j))
:force :force
(let ((matches (org-velocity-present search))) (let* ((org-velocity-index (org-velocity-adjust-index))
(matches (org-velocity-present search)))
(cond ((null matches) :new) (cond ((null matches) :new)
((org-velocity-singlep matches) :follow) ((null (cdr matches)) :follow)
(t :prompt)))) (t :prompt))))
(:prompt (progn (:prompt (progn
(pop-to-buffer (org-velocity-match-buffer)) (pop-to-buffer (org-velocity-match-buffer))
(let ((hint (org-velocity-electric-read-hint))) (let ((hint (org-velocity-electric-read-hint)))
(when hint (case hint (when hint (cl-case hint
(:edit (org-velocity-read nil search)) (:edit (org-velocity-read nil search))
(:force (org-velocity-create search)) (:force (org-velocity-create search))
(otherwise (org-velocity-activate-button hint))))))) (otherwise (org-velocity-activate-button hint)))))))
@ -493,17 +517,10 @@ If ASK is non-nil, ask first."
(button-activate (next-button (point)))) (button-activate (next-button (point))))
(org-velocity-read nil search))))))) (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) (defun org-velocity-activate-button (char)
"Go to button on line number associated with CHAR in `org-velocity-index'." "Go to button on line number associated with CHAR in `org-velocity-index'."
(goto-char (point-min)) (goto-char (point-min))
(forward-line (org-velocity-position char org-velocity-index)) (forward-line (cl-position char org-velocity-index))
(goto-char (goto-char
(button-start (button-start
(next-button (point)))) (next-button (point))))
@ -514,8 +531,8 @@ If ASK is non-nil, ask first."
"Complain about an undefined key." "Complain about an undefined key."
(interactive) (interactive)
(message "%s" (message "%s"
(substitute-command-keys (substitute-command-keys
"\\[org-velocity-electric-new] for new entry, "\\[org-velocity-electric-new] for new entry,
\\[org-velocity-electric-edit] to edit search, \\[org-velocity-electric-edit] to edit search,
\\[scroll-up] to scroll up, \\[scroll-up] to scroll up,
\\[scroll-down] to scroll down, \\[scroll-down] to scroll down,
@ -525,20 +542,11 @@ If ASK is non-nil, ask first."
(defun org-velocity-electric-follow (ev) (defun org-velocity-electric-follow (ev)
"Follow a hint indexed by keyboard event EV." "Follow a hint indexed by keyboard event EV."
(interactive (list last-command-event)) (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))))) (1- (count-lines (point-min) (point-max)))))
(throw 'org-velocity-select ev) (throw 'org-velocity-select ev)
(call-interactively 'org-velocity-electric-undefined))) (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 () (defun org-velocity-electric-edit ()
"Edit the search string." "Edit the search string."
(interactive) (interactive)
@ -552,14 +560,15 @@ If ASK is non-nil, ask first."
(defvar org-velocity-electric-map (defvar org-velocity-electric-map
(let ((map (make-sparse-keymap))) (let ((map (make-sparse-keymap)))
(define-key map [t] 'org-velocity-electric-undefined) (define-key map [t] 'org-velocity-electric-undefined)
(loop for c in org-velocity-index (dolist (c org-velocity-index)
do (define-key map (char-to-string c) 'org-velocity-electric-follow)) (define-key map (char-to-string c)
'org-velocity-electric-follow))
(define-key map "0" 'org-velocity-electric-new) (define-key map "0" 'org-velocity-electric-new)
(define-key map "\C-v" 'scroll-up) (define-key map "\C-v" 'scroll-up)
(define-key map "\M-v" 'scroll-down) (define-key map "\M-v" 'scroll-down)
(define-key map (kbd "RET") 'org-velocity-electric-edit) (define-key map (kbd "RET") 'org-velocity-electric-edit)
(define-key map [mouse-1] 'org-velocity-electric-click) (define-key map [mouse-1] nil)
(define-key map [mouse-2] 'org-velocity-electric-click) (define-key map [mouse-2] nil)
(define-key map [escape] 'keyboard-quit) (define-key map [escape] 'keyboard-quit)
(define-key map "\C-h" 'help-command) (define-key map "\C-h" 'help-command)
map)) map))
@ -567,29 +576,19 @@ If ASK is non-nil, ask first."
(defun org-velocity-electric-read-hint () (defun org-velocity-electric-read-hint ()
"Read index of button electrically." "Read index of button electrically."
(with-current-buffer (org-velocity-match-buffer) (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) (use-local-map org-velocity-electric-map)
(catch 'org-velocity-select (catch 'org-velocity-select
(Electric-command-loop 'org-velocity-select "Follow: ")))) (Electric-command-loop 'org-velocity-select "Follow: "))))
(defvar org-velocity-incremental-keymap (defvar org-velocity-incremental-keymap
(let ((map (make-sparse-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 "\C-v" 'scroll-up)
(define-key map "\M-v" 'scroll-down) (define-key map "\M-v" 'scroll-down)
map)) 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 () (defun org-velocity-displaying-completions-p ()
"Is there a *Completions* buffer showing?" "Is there a *Completions* buffer showing?"
(get-window-with-predicate (get-window-with-predicate
@ -598,8 +597,7 @@ If ASK is non-nil, ask first."
'completion-list-mode)))) 'completion-list-mode))))
(defun org-velocity-update () (defun org-velocity-update ()
"Display results of search without hinting. "Display results of search without hinting."
Stop searching once there are more matches than can be displayed."
(unless (org-velocity-displaying-completions-p) (unless (org-velocity-displaying-completions-p)
(let* ((search (org-velocity-minibuffer-contents)) (let* ((search (org-velocity-minibuffer-contents))
(matches (org-velocity-present search :hide-hints t))) (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)) (select-window (active-minibuffer-window))
(unless (or (null search) (string= "" search)) (unless (or (null search) (string= "" search))
(minibuffer-message "No match; RET to create"))) (minibuffer-message "No match; RET to create")))
((and (org-velocity-singlep matches) ((and (null (cdr matches))
org-velocity-exit-on-match) org-velocity-exit-on-match)
(throw 'click search)) (throw 'click search))
(t (t
(with-current-buffer (org-velocity-match-buffer) (with-current-buffer (org-velocity-match-buffer)
(use-local-map org-velocity-incremental-keymap))))))) (use-local-map org-velocity-incremental-keymap)))))))
(defvar dabbrev--last-abbrev) (defvar dabbrev--last-abbreviation)
(defun org-velocity-dabbrev-completion-list (abbrev) (defun org-velocity-dabbrev-completion-list (abbrev)
"Return all dabbrev completions for ABBREV." "Return all dabbrev completions for ABBREV."
;; This is based on `dabbrev-completion'. ;; This is based on `dabbrev-completion'.
(dabbrev--reset-global-variables) (dabbrev--reset-global-variables)
(setq dabbrev--last-abbrev abbrev) (setq dabbrev--last-abbreviation abbrev)
(dabbrev--find-all-expansions abbrev case-fold-search)) (dabbrev--find-all-expansions abbrev case-fold-search))
(defvar org-velocity-local-completion-map (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) (completion-no-auto-exit t)
(crm-separator " ")) (crm-separator " "))
(funcall (funcall
(case org-velocity-search-method (cl-case org-velocity-search-method
(phrase #'completing-read) (phrase #'completing-read)
(any #'completing-read-multiple) (any #'completing-read-multiple)
(all #'completing-read-multiple)) (all #'completing-read-multiple))
@ -652,38 +650,50 @@ Stop searching once there are more matches than can be displayed."
;; `read-from-minibuffer'), but in this case it is the user-friendly ;; `read-from-minibuffer'), but in this case it is the user-friendly
;; thing to do. ;; thing to do.
(minibuffer-with-setup-hook (minibuffer-with-setup-hook
(lexical-let ((initial-input initial-input)) (let ((initial-input initial-input))
(lambda () (lambda ()
(and initial-input (insert initial-input)) (and initial-input (insert initial-input))
(goto-char (point-max)))) (goto-char (point-max))))
(if (eq org-velocity-search-method 'regexp) (if (eq org-velocity-search-method 'regexp)
(read-regexp prompt) (read-regexp prompt)
(if org-velocity-use-completion (if org-velocity-use-completion
(org-velocity-read-with-completion prompt) (org-velocity-read-with-completion prompt)
(read-string 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) (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 (let ((res
(unwind-protect (unwind-protect
(let* ((match-window (display-buffer (org-velocity-match-buffer))) (let* ((match-window (display-buffer (org-velocity-match-buffer)))
(org-velocity-index (org-velocity-index (org-velocity-adjust-index match-window)))
;; 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))))
(catch 'click (catch 'click
(add-hook 'post-command-hook 'org-velocity-update) (add-hook 'post-command-hook 'org-velocity-update)
(if (eq org-velocity-search-method 'regexp) (cond ((eq org-velocity-search-method 'regexp)
(read-regexp prompt) (read-regexp prompt))
(if org-velocity-use-completion (org-velocity-use-completion
(org-velocity-read-with-completion prompt) (org-velocity-read-with-completion prompt))
(read-string prompt))))) (t (read-string prompt)))))
(remove-hook 'post-command-hook 'org-velocity-update)))) (remove-hook 'post-command-hook 'org-velocity-update))))
(if (bufferp res) (org-pop-to-buffer-same-window res) res))) (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 If `org-velocity-bucket' is defined and
`org-velocity-always-use-bucket' is non-nil, then the bucket file `org-velocity-always-use-bucket' is non-nil, then the bucket file
will be used; otherwise, this will work when called in any Org 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") (interactive "P")
(let ((org-velocity-always-use-bucket (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 ;; complain if inappropriate
(assert (org-velocity-bucket-file)) (cl-assert (org-velocity-bucket-file))
(let ((org-velocity-bucket-buffer (let ((org-velocity-bucket-buffer
(find-file-noselect (org-velocity-bucket-file)))) (find-file-noselect (org-velocity-bucket-file))))
(unwind-protect (unwind-protect
(let ((dabbrev-search-these-buffers-only (let ((dabbrev-search-these-buffers-only
(list (org-velocity-bucket-buffer)))) (list (org-velocity-bucket-buffer))))
(org-velocity-engine (funcall
(if org-velocity-search-is-incremental (catch 'org-velocity-done
(org-velocity-incremental-read "Velocity search: ") (org-velocity-engine
(org-velocity-read-string "Velocity search: " search)))) (if org-velocity-search-is-incremental
(progn (org-velocity-incremental-read "Velocity search: ")
(kill-buffer (org-velocity-match-buffer)) (org-velocity-read-string "Velocity search: " search)))
(delete-other-windows)))))) #'ignore)))
(kill-buffer (org-velocity-match-buffer))))))
(defalias 'org-velocity-read 'org-velocity) (defalias 'org-velocity-read 'org-velocity)