From 6b073644a65a6a145c2b916c258fe05b68ac3e48 Mon Sep 17 00:00:00 2001 From: "Paul M. Rodriguez" 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 ;; 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