820 lines
31 KiB
EmacsLisp
820 lines
31 KiB
EmacsLisp
;;; 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: 4.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.
|
||
|
||
;; You should have received a copy of the GNU General Public License
|
||
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
|
||
|
||
;;; Commentary:
|
||
;; Org-Velocity.el is an interface for Org inspired by the minimalist
|
||
;; notetaking program Notational Velocity. The idea is to let you
|
||
;; amass and access brief notes on many subjects with minimal fuss.
|
||
;; Each note is an entry in an ordinary Org file.
|
||
|
||
;; Org-Velocity can be used in two ways: when called outside Org, to
|
||
;; store and access notes in a designated bucket file; or, when called
|
||
;; inside Org, as a method for navigating any Org file. (Setting the
|
||
;; option `org-velocity-always-use-bucket' disables navigation inside
|
||
;; Org files by default, although you can still force this behavior by
|
||
;; calling `org-velocity-read' with an argument.)
|
||
|
||
;; Org-Velocity prompts for search terms in the minibuffer. A list of
|
||
;; headings of entries whose text matches your search is updated as
|
||
;; you type; you can end the search and visit an entry at any time by
|
||
;; clicking on its heading.
|
||
|
||
;; RET displays the results. If there are no matches, Org-Velocity
|
||
;; offers to create a new entry with your search string as its
|
||
;; heading. If there are matches, it displays a list of results where
|
||
;; the heading of each matching entry is hinted with a number or
|
||
;; letter; clicking a result, or typing the matching hint, opens the
|
||
;; entry for editing in an indirect buffer. 0 forces a new entry; RET
|
||
;; reopens the search for editing.
|
||
|
||
;; You can customize every step in this process, including the search
|
||
;; method, completion for search terms, and templates for creating new
|
||
;; entries; M-x customize-group RET org-velocity RET to see all the
|
||
;; options.
|
||
|
||
;; Thanks to Richard Riley, Carsten Dominik, Bastien Guerry, and Jeff
|
||
;; Horn for their suggestions.
|
||
|
||
;;; Usage:
|
||
;; (require 'org-velocity)
|
||
;; (setq org-velocity-bucket (expand-file-name "bucket.org" org-directory))
|
||
;; (global-set-key (kbd "C-c v") 'org-velocity)
|
||
|
||
;;; Code:
|
||
(require 'org)
|
||
(require 'button)
|
||
(require 'electric)
|
||
(require 'dabbrev)
|
||
(require 'cl-lib)
|
||
|
||
(defgroup org-velocity nil
|
||
"Notational Velocity-style interface for Org."
|
||
:tag "Org-Velocity"
|
||
:group 'outlines
|
||
:group 'hypermedia
|
||
:group 'org)
|
||
|
||
(defcustom org-velocity-bucket ""
|
||
"Where is the bucket file?"
|
||
:group 'org-velocity
|
||
:type 'file)
|
||
|
||
(defcustom org-velocity-show-previews t
|
||
"Show previews of the text of each heading?"
|
||
:group 'velocity
|
||
:type 'boolean
|
||
:safe 'booleanp)
|
||
|
||
(defcustom org-velocity-exit-on-match nil
|
||
"When searching incrementally, exit on a single match?"
|
||
:group 'org-velocity
|
||
:type 'boolean
|
||
:safe 'booleanp)
|
||
|
||
(defcustom org-velocity-force-new nil
|
||
"Should exiting the minibuffer with C-j force a new entry?"
|
||
:group 'org-velocity
|
||
:type 'boolean
|
||
:safe 'booleanp)
|
||
|
||
(defcustom org-velocity-use-search-ring t
|
||
"Push search to `search-ring' when visiting an entry?
|
||
|
||
This means that C-s C-s will take you directly to the first
|
||
instance of the search string."
|
||
:group 'org-velocity
|
||
:type 'boolean
|
||
:safe 'booleanp)
|
||
|
||
(defcustom org-velocity-always-use-bucket nil
|
||
"Use bucket file even when called from an Org buffer?"
|
||
:group 'org-velocity
|
||
:type 'boolean
|
||
:safe 'booleanp)
|
||
|
||
(defcustom org-velocity-use-completion nil
|
||
"Use completion?
|
||
|
||
Notwithstanding the value of this option, calling
|
||
`dabbrev-expand' always completes against the text of the bucket
|
||
file."
|
||
:group 'org-velocity
|
||
:type '(choice
|
||
(const :tag "Do not use completion" nil)
|
||
(const :tag "Use completion" t))
|
||
:safe 'booleanp)
|
||
|
||
(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)
|
||
(const :tag "Match a regular expression" regexp))
|
||
:safe (lambda (v) (memq v '(phrase any all regexp))))
|
||
|
||
(defcustom org-velocity-capture-templates
|
||
'(("v"
|
||
"Velocity entry"
|
||
entry
|
||
(file "")
|
||
"* %:search\n\n%i%?"))
|
||
"Use these template with `org-capture'.
|
||
Meanwhile `org-default-notes-file' is bound to `org-velocity-bucket-file'.
|
||
The keyword :search inserts the current search.
|
||
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'.
|
||
|
||
Replace all contiguous whitespace with single spaces."
|
||
(let* ((start (progn
|
||
(forward-line 1)
|
||
(if (looking-at org-property-start-re)
|
||
(re-search-forward org-property-end-re)
|
||
(1- (point)))))
|
||
(string+props (buffer-substring
|
||
start
|
||
(min
|
||
(+ start (window-width))
|
||
(point-max)))))
|
||
;; We want to preserve the text properties so that, for example,
|
||
;; we don't end up with the raw text of links in the preview.
|
||
(with-temp-buffer
|
||
(insert string+props)
|
||
(goto-char (point-min))
|
||
(save-match-data
|
||
(while (re-search-forward split-string-default-separators
|
||
(point-max)
|
||
t)
|
||
(replace-match " ")))
|
||
(buffer-string))))
|
||
|
||
(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))
|
||
(let ((components (org-heading-components)))
|
||
(make-org-velocity-heading
|
||
:buffer (current-buffer)
|
||
:position (point)
|
||
:name (nth 4 components)
|
||
:level (nth 0 components)
|
||
:preview (if org-velocity-show-previews
|
||
(org-velocity-grab-preview))))))
|
||
|
||
(defconst org-velocity-index
|
||
(eval-when-compile
|
||
(nconc (number-sequence 49 57) ;numbers
|
||
(number-sequence 97 122) ;lowercase letters
|
||
(number-sequence 65 90))) ;uppercase letters
|
||
"List of chars for indexing results.")
|
||
|
||
(defconst org-velocity-match-buffer-name "*Velocity matches*")
|
||
|
||
(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.")
|
||
|
||
(defun org-velocity-buffer-file-name (&optional buffer)
|
||
"Return the name of the file BUFFER saves to.
|
||
Same as function `buffer-file-name' unless BUFFER is an indirect
|
||
buffer or a minibuffer. In the former case, return the file name
|
||
of the base buffer; in the latter, return the file name of
|
||
`minibuffer-selected-window' (or its base buffer)."
|
||
(let ((buffer (if (minibufferp buffer)
|
||
(window-buffer (minibuffer-selected-window))
|
||
buffer)))
|
||
(buffer-file-name
|
||
(or (buffer-base-buffer buffer)
|
||
buffer))))
|
||
|
||
(defun org-velocity-minibuffer-contents ()
|
||
"Return the contents of the minibuffer when it is active."
|
||
(when (active-minibuffer-window)
|
||
(with-current-buffer (window-buffer (active-minibuffer-window))
|
||
(minibuffer-contents))))
|
||
|
||
(defun org-velocity-nix-minibuffer ()
|
||
"Return the contents of the minibuffer and clear it."
|
||
(when (active-minibuffer-window)
|
||
(with-current-buffer (window-buffer (active-minibuffer-window))
|
||
(prog1 (minibuffer-contents)
|
||
(delete-minibuffer-contents)))))
|
||
|
||
(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;
|
||
complain if missing. Otherwise, if an Org file is current, then
|
||
use it."
|
||
(let ((org-velocity-bucket
|
||
(when org-velocity-bucket (expand-file-name org-velocity-bucket)))
|
||
(buffer
|
||
(let ((buffer-file (org-velocity-buffer-file-name)))
|
||
(when buffer-file
|
||
;; Use the target in capture buffers.
|
||
(org-find-base-buffer-visiting buffer-file)))))
|
||
(if org-velocity-always-use-bucket
|
||
(or org-velocity-bucket (error "Bucket required but not defined"))
|
||
(if (and (eq (buffer-local-value 'major-mode (or buffer (current-buffer)))
|
||
'org-mode)
|
||
(org-velocity-buffer-file-name))
|
||
(org-velocity-buffer-file-name)
|
||
(or org-velocity-bucket
|
||
(error "No bucket and not an Org file"))))))
|
||
|
||
(defvar org-velocity-bucket-buffer nil)
|
||
(defvar org-velocity-navigating nil)
|
||
|
||
(defsubst org-velocity-bucket-buffer ()
|
||
(or org-velocity-bucket-buffer
|
||
(find-file-noselect (org-velocity-bucket-file))))
|
||
|
||
(defsubst org-velocity-match-buffer ()
|
||
"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)))
|
||
|
||
(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))))
|
||
|
||
(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)))
|
||
(if (and existing (buffer-base-buffer existing)
|
||
(equal (buffer-base-buffer existing) bucket))
|
||
existing
|
||
(make-indirect-buffer
|
||
bucket
|
||
(generate-new-buffer-name (org-velocity-heading-name heading))
|
||
t))))
|
||
|
||
(defun org-velocity-capture ()
|
||
"Record a note with `org-capture'."
|
||
(let ((org-capture-templates
|
||
org-velocity-capture-templates))
|
||
(org-capture nil
|
||
;; This is no longer automatically selected.
|
||
(when (null (cdr org-capture-templates))
|
||
(caar org-capture-templates)))
|
||
(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)
|
||
(if org-velocity-navigating
|
||
(org-velocity-edit-entry/inline heading)
|
||
(org-velocity-edit-entry/indirect heading)))
|
||
|
||
(cl-defun org-velocity-goto-entry (heading &key narrow)
|
||
(goto-char (org-velocity-heading-position heading))
|
||
(save-excursion
|
||
(when narrow
|
||
(org-narrow-to-subtree))
|
||
(outline-show-all)))
|
||
|
||
(defun org-velocity-edit-entry/inline (heading)
|
||
"Edit entry at HEADING in the original buffer."
|
||
(let ((buffer (org-velocity-heading-buffer heading)))
|
||
(pop-to-buffer buffer)
|
||
(with-current-buffer buffer
|
||
(org-velocity-goto-entry heading))))
|
||
|
||
(defun org-velocity-format-header-line (control-string &rest args)
|
||
(set (make-local-variable 'header-line-format)
|
||
(apply #'format control-string args)))
|
||
|
||
(defun org-velocity-edit-entry/indirect (heading)
|
||
"Edit entry at HEADING in an indirect buffer."
|
||
(let ((winconf (current-window-configuration))
|
||
(dd default-directory)
|
||
(buffer (org-velocity-make-indirect-buffer heading))
|
||
(inhibit-point-motion-hooks t)
|
||
(inhibit-field-text-motion t))
|
||
(with-current-buffer buffer
|
||
(setq default-directory dd) ;Inherit default directory.
|
||
(setq org-velocity-saved-winconf winconf)
|
||
(org-velocity-goto-entry heading :narrow t)
|
||
(goto-char (point-max))
|
||
(add-hook 'org-ctrl-c-ctrl-c-hook 'org-velocity-dismiss nil t))
|
||
(pop-to-buffer buffer)
|
||
(org-velocity-format-header-line
|
||
"%s Use C-c C-c to finish."
|
||
(abbreviate-file-name
|
||
(buffer-file-name
|
||
(org-velocity-heading-buffer heading))))))
|
||
|
||
(defun org-velocity-dismiss ()
|
||
"Save current entry and close indirect buffer."
|
||
(let ((winconf org-velocity-saved-winconf))
|
||
(prog1 t ;Tell hook we're done.
|
||
(save-buffer)
|
||
(kill-buffer)
|
||
(when (window-configuration-p winconf)
|
||
(set-window-configuration winconf)))))
|
||
|
||
(defun org-velocity-visit-button (button)
|
||
(run-hooks 'mouse-leave-buffer-hook)
|
||
(when org-velocity-use-search-ring
|
||
(add-to-history 'search-ring
|
||
(button-get button 'search)
|
||
search-ring-max))
|
||
(let ((match (button-get button 'match)))
|
||
(throw 'org-velocity-done match)))
|
||
|
||
(define-button-type 'org-velocity-button
|
||
'action #'org-velocity-visit-button
|
||
'follow-link 'mouse-face)
|
||
|
||
(defsubst org-velocity-buttonize (heading)
|
||
"Insert HEADING as a text button with no hints."
|
||
(insert-text-button
|
||
(propertize (org-velocity-heading-name heading) 'face 'link)
|
||
:type 'org-velocity-button
|
||
'match heading
|
||
'search org-velocity-search))
|
||
|
||
(defsubst org-velocity-insert-preview (heading)
|
||
(when org-velocity-show-previews
|
||
(insert-char ?\ 1)
|
||
(insert
|
||
(propertize
|
||
(org-velocity-heading-preview heading)
|
||
'face 'shadow))))
|
||
|
||
(defvar org-velocity-recursive-headings nil)
|
||
(defvar org-velocity-recursive-search nil)
|
||
|
||
(cl-defun org-velocity-search-with (fun style search
|
||
&key (headings org-velocity-recursive-headings))
|
||
(if headings
|
||
(save-restriction
|
||
(dolist (heading headings)
|
||
(widen)
|
||
(let ((start (org-velocity-heading-position heading)))
|
||
(goto-char start)
|
||
(let ((end (save-excursion
|
||
(org-end-of-subtree)
|
||
(point))))
|
||
(narrow-to-region start end)
|
||
(org-velocity-search-with fun style search
|
||
:headings nil)))))
|
||
(cl-ecase style
|
||
((phrase any regexp)
|
||
(cl-block nil
|
||
(while (re-search-forward search nil t)
|
||
(let ((match (org-velocity-nearest-heading (point))))
|
||
(funcall fun match))
|
||
;; Skip to the next heading.
|
||
(unless (re-search-forward (org-velocity-heading-regexp) nil t)
|
||
(cl-return)))))
|
||
((all)
|
||
(let ((keywords
|
||
(cl-loop for word in (split-string search)
|
||
collect (concat "\\<" (regexp-quote word) "\\>"))))
|
||
(org-map-entries
|
||
(lambda ()
|
||
;; Only search the subtree once.
|
||
(setq org-map-continue-from
|
||
(save-excursion
|
||
(org-end-of-subtree)
|
||
(point)))
|
||
(when (cl-loop for word in keywords
|
||
always (save-excursion
|
||
(re-search-forward word org-map-continue-from t)))
|
||
(let ((match (org-velocity-nearest-heading (match-end 0))))
|
||
(funcall fun match))))))))))
|
||
|
||
(defun org-velocity-all-results (style search)
|
||
(with-current-buffer (org-velocity-bucket-buffer)
|
||
(save-excursion
|
||
(goto-char (point-min))
|
||
(let (matches)
|
||
(org-velocity-search-with (lambda (match)
|
||
(push match matches))
|
||
style
|
||
search)
|
||
(nreverse matches)))))
|
||
|
||
(defsubst org-velocity-present-match (hint match)
|
||
(with-current-buffer (org-velocity-match-buffer)
|
||
(when hint (insert "#" hint " "))
|
||
(org-velocity-buttonize match)
|
||
(org-velocity-insert-preview match)
|
||
(newline)))
|
||
|
||
(defun org-velocity-present-search (style search hide-hints)
|
||
(let ((hints org-velocity-index) matches)
|
||
(cl-block nil
|
||
(org-velocity-search-with (lambda (match)
|
||
(unless hints
|
||
(cl-return))
|
||
(let ((hint (if hide-hints
|
||
nil
|
||
(car hints))))
|
||
(org-velocity-present-match hint match))
|
||
(pop hints)
|
||
(push match matches))
|
||
style
|
||
search))
|
||
(nreverse matches)))
|
||
|
||
(defun org-velocity-restrict-search ()
|
||
(interactive)
|
||
(let ((search (org-velocity-nix-minibuffer)))
|
||
(when (equal search "")
|
||
(error "No search to restrict to"))
|
||
(push search org-velocity-recursive-search)
|
||
(setq org-velocity-recursive-headings
|
||
(org-velocity-all-results
|
||
org-velocity-search-method
|
||
search))
|
||
;; TODO We could extend the current search instead of starting
|
||
;; over.
|
||
(org-velocity-update-match-header)
|
||
(minibuffer-message "Restricting search to %s" search)))
|
||
|
||
(cl-defun org-velocity-update-match-header (&key (match-buffer (org-velocity-match-buffer))
|
||
(bucket-buffer (org-velocity-bucket-buffer))
|
||
(search-method org-velocity-search-method))
|
||
(let ((navigating? org-velocity-navigating)
|
||
(recursive? org-velocity-recursive-search))
|
||
(with-current-buffer match-buffer
|
||
(org-velocity-format-header-line
|
||
"%s search in %s%s (%s mode)"
|
||
(capitalize (symbol-name search-method))
|
||
(abbreviate-file-name (buffer-file-name bucket-buffer))
|
||
(if (not recursive?)
|
||
""
|
||
(let ((sep " > "))
|
||
(concat sep (string-join (reverse recursive?) sep))))
|
||
(if navigating? "nav" "notes")))))
|
||
|
||
(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'.
|
||
|
||
Return matches."
|
||
(let ((match-buffer (org-velocity-match-buffer))
|
||
(bucket-buffer (org-velocity-bucket-buffer))
|
||
(search-method org-velocity-search-method))
|
||
(if (and (stringp search) (not (string= "" search)))
|
||
;; Fold case when the search string is all lowercase.
|
||
(let ((case-fold-search (equal search (downcase search)))
|
||
(truncate-partial-width-windows t))
|
||
(with-current-buffer match-buffer
|
||
(erase-buffer)
|
||
;; Permanent locals.
|
||
(setq cursor-type nil
|
||
truncate-lines t)
|
||
(org-velocity-update-match-header
|
||
:match-buffer match-buffer
|
||
:bucket-buffer bucket-buffer
|
||
:search-method search-method))
|
||
(prog1
|
||
(with-current-buffer bucket-buffer
|
||
(widen)
|
||
(let* ((inhibit-point-motion-hooks t)
|
||
(inhibit-field-text-motion t)
|
||
(anchored? (string-match-p "^\\s-" search))
|
||
(search
|
||
(cl-ecase search-method
|
||
(all search)
|
||
(phrase
|
||
(if anchored?
|
||
(regexp-quote search)
|
||
;; Anchor the search to the start of a word.
|
||
(concat "\\<" (regexp-quote search))))
|
||
(any
|
||
(concat "\\<" (regexp-opt (split-string search))))
|
||
(regexp search))))
|
||
(save-excursion
|
||
(org-velocity-beginning-of-headings)
|
||
(condition-case lossage
|
||
(org-velocity-present-search search-method search hide-hints)
|
||
(invalid-regexp
|
||
(minibuffer-message "%s" lossage))))))
|
||
(with-current-buffer match-buffer
|
||
(goto-char (point-min)))))
|
||
(with-current-buffer match-buffer
|
||
(erase-buffer)))))
|
||
|
||
(defun org-velocity-store-link ()
|
||
"Function for `org-store-link-functions'."
|
||
(if org-velocity-search
|
||
(org-store-link-props
|
||
:search org-velocity-search)))
|
||
|
||
(add-hook 'org-store-link-functions 'org-velocity-store-link)
|
||
|
||
(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? "))
|
||
(let ((org-velocity-search search)
|
||
(org-default-notes-file (org-velocity-bucket-file))
|
||
;; save a stored link
|
||
org-store-link-plist)
|
||
(org-velocity-capture))
|
||
search))
|
||
|
||
(defun org-velocity-engine (search)
|
||
"Display a list of headings where SEARCH occurs."
|
||
(let ((org-velocity-search search))
|
||
(unless (or
|
||
(not (stringp search))
|
||
(string= "" search)) ;exit on empty string
|
||
(cl-case
|
||
(if (and org-velocity-force-new (eq last-command-event ?\C-j))
|
||
:force
|
||
(let* ((org-velocity-index (org-velocity-adjust-index))
|
||
(matches (org-velocity-present search)))
|
||
(cond ((null matches) :new)
|
||
((null (cdr matches)) :follow)
|
||
(t :prompt))))
|
||
(:prompt (progn
|
||
(pop-to-buffer (org-velocity-match-buffer))
|
||
(let ((hint (org-velocity-electric-read-hint)))
|
||
(when hint (cl-case hint
|
||
(:edit (org-velocity-read nil search))
|
||
(:force (org-velocity-create search))
|
||
(otherwise (org-velocity-activate-button hint)))))))
|
||
(:new (unless (org-velocity-create search :ask t)
|
||
(org-velocity-read nil search)))
|
||
(:force (org-velocity-create search))
|
||
(:follow (if (y-or-n-p "One match, follow? ")
|
||
(progn
|
||
(set-buffer (org-velocity-match-buffer))
|
||
(goto-char (point-min))
|
||
(button-activate (next-button (point))))
|
||
(org-velocity-read nil search)))))))
|
||
|
||
(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 (cl-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-electric-undefined ()
|
||
"Complain about an undefined key."
|
||
(interactive)
|
||
(message "%s"
|
||
(substitute-command-keys
|
||
"\\[org-velocity-electric-new] for new entry,
|
||
\\[org-velocity-electric-edit] to edit search,
|
||
\\[scroll-up] to scroll up,
|
||
\\[scroll-down] to scroll down,
|
||
\\[keyboard-quit] to quit."))
|
||
(sit-for 4))
|
||
|
||
(defun org-velocity-electric-follow (ev)
|
||
"Follow a hint indexed by keyboard event EV."
|
||
(interactive (list last-command-event))
|
||
(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-edit ()
|
||
"Edit the search string."
|
||
(interactive)
|
||
(throw 'org-velocity-select :edit))
|
||
|
||
(defun org-velocity-electric-new ()
|
||
"Force a new entry."
|
||
(interactive)
|
||
(throw 'org-velocity-select :force))
|
||
|
||
(defvar org-velocity-electric-map
|
||
(let ((map (make-sparse-keymap)))
|
||
(define-key map [t] 'org-velocity-electric-undefined)
|
||
(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] nil)
|
||
(define-key map [mouse-2] nil)
|
||
(define-key map [escape] 'keyboard-quit)
|
||
(define-key map "\C-h" 'help-command)
|
||
map))
|
||
|
||
(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 "\C-v" 'scroll-up)
|
||
(define-key map "\M-v" 'scroll-down)
|
||
map))
|
||
|
||
(defun org-velocity-displaying-completions-p ()
|
||
"Is there a *Completions* buffer showing?"
|
||
(get-window-with-predicate
|
||
(lambda (w)
|
||
(eq (buffer-local-value 'major-mode (window-buffer w))
|
||
'completion-list-mode))))
|
||
|
||
(defun org-velocity-update ()
|
||
"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)))
|
||
(cond ((null matches)
|
||
(select-window (active-minibuffer-window))
|
||
(unless (or (null search) (= (length search) 0))
|
||
(minibuffer-message "No match; RET to create")))
|
||
((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-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-abbreviation abbrev)
|
||
(dabbrev--find-all-expansions abbrev case-fold-search))
|
||
|
||
(defvar org-velocity-local-completion-map
|
||
(let ((map (make-sparse-keymap)))
|
||
(set-keymap-parent map minibuffer-local-completion-map)
|
||
(define-key map " " 'self-insert-command)
|
||
(define-key map "?" 'self-insert-command)
|
||
(define-key map [remap minibuffer-complete] 'minibuffer-complete-word)
|
||
(define-key map [(control ?@)] 'org-velocity-restrict-search)
|
||
(define-key map [(control ?\s)] 'org-velocity-restrict-search)
|
||
map)
|
||
"Keymap for completion with `completing-read'.")
|
||
|
||
(defun org-velocity-read-with-completion (prompt)
|
||
"Completing read with PROMPT."
|
||
(let ((minibuffer-local-completion-map
|
||
org-velocity-local-completion-map)
|
||
(completion-no-auto-exit t)
|
||
(crm-separator " "))
|
||
(completing-read prompt
|
||
(completion-table-dynamic
|
||
'org-velocity-dabbrev-completion-list))))
|
||
|
||
(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.
|
||
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 (org-velocity-adjust-index match-window)))
|
||
(catch 'click
|
||
(add-hook 'post-command-hook 'org-velocity-update)
|
||
(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)))
|
||
|
||
(defun org-velocity (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 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 org-velocity-always-use-bucket
|
||
(not arg)
|
||
arg)))
|
||
;; complain if inappropriate
|
||
(cl-assert (org-velocity-bucket-file))
|
||
(let* ((starting-buffer (current-buffer))
|
||
(org-velocity-bucket-buffer
|
||
(find-file-noselect (org-velocity-bucket-file)))
|
||
(org-velocity-navigating
|
||
(eq starting-buffer org-velocity-bucket-buffer))
|
||
(org-velocity-recursive-headings '())
|
||
(org-velocity-recursive-search '())
|
||
(org-velocity-heading-level
|
||
(if org-velocity-navigating
|
||
0
|
||
org-velocity-heading-level))
|
||
(dabbrev-search-these-buffers-only
|
||
(list org-velocity-bucket-buffer)))
|
||
(unwind-protect
|
||
(let ((match
|
||
(catch 'org-velocity-done
|
||
(org-velocity-engine
|
||
(or search
|
||
(org-velocity-incremental-read "Velocity search: ")))
|
||
nil)))
|
||
(when (org-velocity-heading-p match)
|
||
(org-velocity-edit-entry match)))
|
||
(kill-buffer (org-velocity-match-buffer))))))
|
||
|
||
(defalias 'org-velocity-read 'org-velocity)
|
||
|
||
(provide 'org-velocity)
|
||
|
||
;;; org-velocity.el ends here
|