From: Paul Rodriguez <paulmrodriguez@gmail.com>
To: emacs-orgmode@gnu.org
Subject: [PATCH] New version of org-velocity
Date: Mon, 14 Dec 2015 18:03:51 -0600 [thread overview]
Message-ID: <CAEzQWFMLxAfJ3cKpFry9+pEuwD9tJq-xo1dpdGpM=koMZGziUQ@mail.gmail.com> (raw)
[-- Attachment #1.1: Type: text/plain, Size: 292 bytes --]
This updates the version of org-velocity in contrib to the latest version.
The new version supports an Ido-like style of refining searches
interactively, and changes the default behavior to better accommodate users
who use org-velocity for navigation instead of note-taking.
Paul Rodriguez
[-- Attachment #1.2: Type: text/html, Size: 366 bytes --]
[-- Attachment #2: 0001-org-velocity-New-version-of-org-velocity.patch --]
[-- Type: text/x-patch, Size: 21562 bytes --]
From 6b073644a65a6a145c2b916c258fe05b68ac3e48 Mon Sep 17 00:00:00 2001
From: "Paul M. Rodriguez" <pmr@ruricolist.com>
Date: Mon, 14 Dec 2015 17:51:40 -0600
Subject: [PATCH] org-velocity: New version of org-velocity.
* contrib/lisp/org-velocity.el: New version.
---
contrib/lisp/org-velocity.el | 387 ++++++++++++++++++++++++++-----------------
1 file changed, 233 insertions(+), 154 deletions(-)
diff --git a/contrib/lisp/org-velocity.el b/contrib/lisp/org-velocity.el
index a7820f1..bfc4d6c 100644
--- a/contrib/lisp/org-velocity.el
+++ b/contrib/lisp/org-velocity.el
@@ -4,7 +4,7 @@
;; Author: Paul M. Rodriguez <paulmrodriguez@gmail.com>
;; Created: 2010-05-05
-;; Version: 4.0
+;; Version: 4.1
;; This file is not part of GNU Emacs.
@@ -78,12 +78,6 @@
:group 'org-velocity
:type 'file)
-(defcustom org-velocity-search-is-incremental t
- "Show results incrementally when possible?"
- :group 'org-velocity
- :type 'boolean
- :safe 'booleanp)
-
(defcustom org-velocity-show-previews t
"Show previews of the text of each heading?"
:group 'velocity
@@ -168,20 +162,27 @@ See the documentation for `org-capture-templates'."
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))))))
- (mapconcat
- #'identity
- (split-string
- (buffer-substring-no-properties
- start
- (min
- (+ start (window-width))
- (point-max))))
- " ")))
+ (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)
@@ -233,9 +234,16 @@ of the base buffer; in the latter, return the file name of
(defun org-velocity-minibuffer-contents ()
"Return the contents of the minibuffer when it is active."
- (if (active-minibuffer-window)
- (with-current-buffer (window-buffer (active-minibuffer-window))
- (minibuffer-contents))))
+ (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.
@@ -259,6 +267,7 @@ use it."
(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
@@ -271,9 +280,6 @@ use it."
(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))
@@ -310,29 +316,47 @@ use it."
(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)
- (goto-char (org-velocity-heading-position heading))
- (let ((start (point))
- (end (save-excursion
- (org-end-of-subtree t)
- (point))))
- ;; Outline view and narrow-to-region interact poorly.
- (outline-flag-region start end nil)
- (narrow-to-region start end))
+ (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)
- (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-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."
@@ -350,9 +374,7 @@ use it."
(button-get button 'search)
search-ring-max))
(let ((match (button-get button 'match)))
- (throw 'org-velocity-done
- (lambda ()
- (org-velocity-edit-entry match)))))
+ (throw 'org-velocity-done match)))
(define-button-type 'org-velocity-button
'action #'org-velocity-visit-button
@@ -374,57 +396,113 @@ use it."
(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-staging-buffer)
+ (with-current-buffer (org-velocity-match-buffer)
(when hint (insert "#" hint " "))
(org-velocity-buttonize match)
(org-velocity-insert-preview match)
(newline)))
-(defun org-velocity-generic-search (search &optional hide-hints)
- "Display any entry containing SEARCH."
+(defun org-velocity-present-search (style search hide-hints)
(let ((hints org-velocity-index) matches)
(cl-block nil
- (while (and hints (re-search-forward search nil t))
- (let ((match (org-velocity-nearest-heading (point))))
- (org-velocity-present-match
- (unless hide-hints (car hints))
- match)
- (push match matches))
- (setq hints (cdr hints))
- (unless (re-search-forward (org-velocity-heading-regexp) nil t)
- (return))))
+ (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)))
-(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)
- matches)
- (org-map-entries
- (lambda ()
- ;; Return if we've run out of hints.
- (when (null hints)
- (return-from org-velocity-all-search (nreverse matches)))
- ;; Only search the subtree once.
- (setq org-map-continue-from
- (save-excursion
- (goto-char (line-end-position))
- (if (re-search-forward (org-velocity-heading-regexp) nil t)
- (line-end-position)
- (point-max))))
- (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
- (unless hide-hints (car hints))
- match)
- (push match matches)
- (setq hints (cdr hints))))))
- (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'.
@@ -432,40 +510,49 @@ If HIDE-HINTS is non-nil, display entries without indices. SEARCH
binds `org-velocity-search'.
Return matches."
- (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 (org-velocity-match-buffer)
- (erase-buffer)
- ;; Permanent locals.
- (setq cursor-type nil
- truncate-lines t))
- (prog1
- (with-current-buffer (org-velocity-bucket-buffer)
- (let ((inhibit-point-motion-hooks t)
- (inhibit-field-text-motion t))
- (save-excursion
- (org-velocity-beginning-of-headings)
- (cl-case org-velocity-search-method
- (all (org-velocity-all-search search hide-hints))
- (phrase (org-velocity-generic-search
- (concat "\\<" (regexp-quote search))
- hide-hints))
- (any (org-velocity-generic-search
- (concat "\\<"
- (regexp-opt (split-string search)))
- hide-hints))
- (regexp (condition-case lossage
- (org-velocity-generic-search
- search hide-hints)
- (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))))
+ (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'."
@@ -603,7 +690,7 @@ If ASK is non-nil, ask first."
(matches (org-velocity-present search :hide-hints t)))
(cond ((null matches)
(select-window (active-minibuffer-window))
- (unless (or (null search) (string= "" search))
+ (unless (or (null search) (= (length search) 0))
(minibuffer-message "No match; RET to create")))
((and (null (cdr matches))
org-velocity-exit-on-match)
@@ -625,7 +712,10 @@ If ASK is non-nil, ask first."
(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'.")
@@ -635,30 +725,9 @@ If ASK is non-nil, ask first."
org-velocity-local-completion-map)
(completion-no-auto-exit t)
(crm-separator " "))
- (funcall
- (cl-case org-velocity-search-method
- (phrase #'completing-read)
- (any #'completing-read-multiple)
- (all #'completing-read-multiple))
- prompt
- (completion-table-dynamic
- 'org-velocity-dabbrev-completion-list))))
-
-(defun org-velocity-read-string (prompt &optional initial-input)
- "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.
- (minibuffer-with-setup-hook
- (let ((initial-input initial-input))
- (lambda ()
- (and initial-input (insert initial-input))
- (goto-char (point-max))))
- (if (eq org-velocity-search-method 'regexp)
- (read-regexp prompt)
- (if org-velocity-use-completion
- (org-velocity-read-with-completion prompt)
- (read-string prompt)))))
+ (completing-read prompt
+ (completion-table-dynamic
+ 'org-velocity-dabbrev-completion-list))))
(cl-defun org-velocity-adjust-index
(&optional (match-window (org-velocity-match-window)))
@@ -719,18 +788,28 @@ then the current file is used instead, and vice versa."
arg)))
;; complain if inappropriate
(cl-assert (org-velocity-bucket-file))
- (let ((org-velocity-bucket-buffer
- (find-file-noselect (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 ((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)))
- #'ignore)))
+ (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)
--
1.9.1
next reply other threads:[~2015-12-15 0:03 UTC|newest]
Thread overview: 12+ messages / expand[flat|nested] mbox.gz Atom feed top
2015-12-15 0:03 Paul Rodriguez [this message]
2015-12-15 17:19 ` [PATCH] New version of org-velocity Marco Wahl
2015-12-16 7:44 ` Marco Wahl
-- strict thread matches above, loose matches on Subject: below --
2014-10-27 19:06 Paul Rodriguez
2014-10-30 19:18 ` Marco Wahl
2014-10-30 19:55 ` Paul Rodriguez
2014-10-31 7:58 ` Marco Wahl
2014-10-31 19:22 ` Paul Rodriguez
2014-11-04 10:33 ` Marco Wahl
2014-12-01 15:43 ` Bastien
2014-10-31 19:17 ` Achim Gratz
2014-12-01 15:27 ` Bastien
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.orgmode.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to='CAEzQWFMLxAfJ3cKpFry9+pEuwD9tJq-xo1dpdGpM=koMZGziUQ@mail.gmail.com' \
--to=paulmrodriguez@gmail.com \
--cc=emacs-orgmode@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs/org-mode.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).