From mboxrd@z Thu Jan 1 00:00:00 1970 From: "Paul M. Rodriguez" Subject: [PATCH] Org-Velocity rewrite Date: Tue, 22 Nov 2011 12:18:41 -0600 Message-ID: <87obw49g1q.fsf@gmail.com> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Return-path: Received: from eggs.gnu.org ([140.186.70.92]:36305) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1RSuvi-0003Sm-Pw for emacs-orgmode@gnu.org; Tue, 22 Nov 2011 13:18:54 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1RSuvd-00039O-UV for emacs-orgmode@gnu.org; Tue, 22 Nov 2011 13:18:50 -0500 Received: from mail-yw0-f41.google.com ([209.85.213.41]:55740) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1RSuvd-000394-MV for emacs-orgmode@gnu.org; Tue, 22 Nov 2011 13:18:45 -0500 Received: by ywp17 with SMTP id 17so591080ywp.0 for ; Tue, 22 Nov 2011 10:18:44 -0800 (PST) List-Id: "General discussions about Org-mode." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-orgmode-bounces+geo-emacs-orgmode=m.gmane.org@gnu.org Sender: emacs-orgmode-bounces+geo-emacs-orgmode=m.gmane.org@gnu.org To: emacs-orgmode@gnu.org --=-=-= Content-Type: text/plain This is a rewrite of Org-Velocity for speed. Delays due to file size should no longer be perceptible. I have also added in-line previews of entry contents and dropped support for Org-Remember. Paul Rodriguez. --=-=-= Content-Type: text/x-diff Content-Disposition: attachment; filename=org-velocity.el.diff diff --git a/contrib/lisp/org-velocity.el b/contrib/lisp/org-velocity.el index aae96b3..b288cda 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: 2.4 +;; Version: 3.0 ;; This file is not part of GNU Emacs. @@ -58,7 +58,7 @@ ;;; Usage: ;; (require 'org-velocity) ;; (setq org-velocity-bucket (expand-file-name "bucket.org" org-directory)) -;; (global-set-key (kbd "C-c v") 'org-velocity-read) +;; (global-set-key (kbd "C-c v") 'org-velocity) ;;; Code: (require 'org) @@ -85,6 +85,12 @@ :type 'boolean :safe 'booleanp) +(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 @@ -97,14 +103,6 @@ :type 'boolean :safe 'booleanp) -(defcustom org-velocity-max-depth nil - "Ignore headings deeper than this." - :group 'org-velocity - :type '(choice - (const :tag "No maximum depth" nil) - (integer :tag "Set maximum depth")) - :safe (lambda (v) (or (null v) (wholenump v)))) - (defcustom org-velocity-use-search-ring t "Push search to `search-ring' when visiting an entry? @@ -132,12 +130,6 @@ file." (const :tag "Use completion" t)) :safe 'booleanp) -(defcustom org-velocity-edit-indirectly t - "Edit entries in an indirect buffer or just visit the file?" - :group 'org-velocity - :type 'boolean - :safe 'booleanp) - (defcustom org-velocity-search-method 'phrase "Match on whole phrase, any word, or all words?" :group 'org-velocity @@ -148,28 +140,6 @@ file." (const :tag "Match a regular expression" regexp)) :safe (lambda (v) (memq v '(phrase any all regexp)))) -(defcustom org-velocity-create-method 'capture - "Prefer `org-capture', `org-remember', or neither?" - :group 'org-velocity - :type '(choice - (const :tag "Prefer capture > remember > default." capture) - (const :tag "Prefer remember > default." remember) - (const :tag "Edit in buffer." buffer)) - :safe (lambda (v) (memq v '(capture remember buffer)))) - -(defcustom org-velocity-remember-templates - '(("Velocity entry" - ?v - "* %:search\n\n%i%?" - nil - bottom)) - "Use these templates with `org-remember'. -Meanwhile `org-default-notes-file' is bound to `org-velocity-use-file'. -The keyword :search inserts the current search. -See the documentation for `org-remember-templates'." - :group 'org-velocity - :type (or (get 'org-remember-templates 'custom-type) 'list)) - (defcustom org-velocity-capture-templates '(("v" "Velocity entry" @@ -177,19 +147,48 @@ See the documentation for `org-remember-templates'." (file "") "* %:search\n\n%i%?")) "Use these template with `org-capture'. -Meanwhile `org-default-notes-file' is bound to `org-velocity-use-file'. +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)) -(defstruct (org-velocity-heading - (:constructor org-velocity-make-heading - (&aux (components (org-heading-components)))) - (:type list)) - (marker (point-marker)) - (name (nth 4 components)) - (level (nth 0 components))) +(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)))))) + (mapconcat + #'identity + (split-string + (buffer-substring-no-properties + start + (min + (+ start (window-width)) + (point-max)))) + " "))) + +(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 @@ -198,15 +197,18 @@ See the documentation for `org-capture-templates'." (number-sequence 65 90))) ;uppercase letters "List of chars for indexing results.") -(defconst org-velocity-display-buffer-name "*Velocity headings*") +(defconst org-velocity-match-buffer-name "*Velocity matches*") + +(defconst org-velocity-heading-regexp "^\\* " + "Regexp to match only top-level headings.") (defvar org-velocity-search nil "Variable to bind to current search.") -(defsubst org-velocity-buffer-file-name (&optional buffer) +(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 +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) @@ -222,71 +224,55 @@ of the base buffer; in the latter, return the file name of (with-current-buffer (window-buffer (active-minibuffer-window)) (minibuffer-contents)))) -(defun org-velocity-use-file () +(defsubst org-velocity-singlep (object) + "Return t when OBJECT is a list or sequence of one element." + (if (consp object) + (null (cdr object)) + (= (length object) 1))) + +(defun org-velocity-bucket-file () "Return the proper file for Org-Velocity to search. -If `org-velocity-always-use-bucket' is t, use bucket file; complain -if missing. Otherwise if this is an Org file, use it." - (or - ;; Use the target in in remember buffers. - (if (and (boundp 'org-remember-mode) org-remember-mode) - org-default-notes-file) - (let ((org-velocity-bucket - (and org-velocity-bucket (expand-file-name org-velocity-bucket))) - (buffer (if (org-velocity-buffer-file-name) - ;; Use the target in capture buffers. - (org-find-base-buffer-visiting (org-velocity-buffer-file-name))))) - (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"))))))) - -(defsubst org-velocity-display-buffer () - "Return the proper buffer for Org-Velocity to display in." - (get-buffer-create org-velocity-display-buffer-name)) +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) (defsubst org-velocity-bucket-buffer () - "Return proper buffer for bucket operations." - (find-file-noselect (org-velocity-use-file))) + (or org-velocity-bucket-buffer + (find-file-noselect (org-velocity-bucket-file)))) -(defun org-velocity-nearest-heading (position) - "Return last heading at POSITION. -If there is no last heading, return nil." - (save-excursion - (goto-char position) - ;; If we are before the first heading we could still be at the - ;; first heading. - (unless (and (org-before-first-heading-p) - (not (org-at-heading-p))) - (org-back-to-heading t) - (let ((heading (org-velocity-make-heading))) - (if org-velocity-max-depth - (if (<= (org-velocity-heading-level heading) - org-velocity-max-depth) - heading) - heading))))) - -(defun org-velocity-make-button-action (heading) - "Return a form to visit HEADING." - `(lambda (button) - (run-hooks 'mouse-leave-buffer-hook) ;turn off temporary modes - (if org-velocity-use-search-ring - (add-to-history 'search-ring ,org-velocity-search search-ring-max)) - (if org-velocity-edit-indirectly - (org-velocity-edit-entry ',heading) - (progn - (message "%s" ,(org-velocity-heading-name heading)) - (org-pop-to-buffer-same-window (marker-buffer - ,(org-velocity-heading-marker heading))) - (goto-char (marker-position - ,(org-velocity-heading-marker heading))))))) +(defsubst org-velocity-match-buffer () + "Return the proper buffer for Org-Velocity to display in." + (get-buffer-create org-velocity-match-buffer-name)) + +(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 (marker-buffer (org-velocity-heading-marker 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) @@ -296,144 +282,168 @@ If there is no last heading, return nil." bucket (generate-new-buffer-name (org-velocity-heading-name heading)))))) +(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 (org-velocity-singlep org-capture-templates) + (caar org-capture-templates))) + (if org-capture-mode (rename-buffer org-velocity-search t)))) + +(defvar org-velocity-saved-winconf nil) +(make-variable-buffer-local 'org-velocity-saved-winconf) + (defun org-velocity-edit-entry (heading) "Edit entry at HEADING in an indirect buffer." - (let ((buffer (org-velocity-make-indirect-buffer heading))) - (with-current-buffer buffer - (let ((org-inhibit-startup t)) - (org-mode)) - (goto-char (marker-position (org-velocity-heading-marker heading))) - (narrow-to-region (point) - (save-excursion - (org-end-of-subtree t) - (point))) - (goto-char (point-min)) - (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 - (marker-buffer - (org-velocity-heading-marker heading)))))))) + (let ((winconf (current-window-configuration))) + (let ((buffer (org-velocity-make-indirect-buffer heading))) + (with-current-buffer buffer + (let ((org-inhibit-startup t)) + (org-mode)) + (setq org-velocity-saved-winconf winconf) + (goto-char (org-velocity-heading-position heading)) + (narrow-to-region (point) + (save-excursion + (org-end-of-subtree t) + (point))) + (goto-char (point-min)) + (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)))))))) (defun org-velocity-dismiss () "Save current entry and close indirect buffer." - (progn - (save-buffer) - (kill-buffer))) - -(defun org-velocity-buttonize-no-hints (heading) + (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) + (if org-velocity-use-search-ring + (add-to-history 'search-ring + (button-get button 'search) + search-ring-max)) + (org-velocity-edit-entry (button-get button 'match))) + +(define-button-type 'org-velocity-button + 'action #'org-velocity-visit-button) + +(defsubst org-velocity-buttonize (heading) "Insert HEADING as a text button with no hints." - (let ((action (org-velocity-make-button-action heading))) - (insert-text-button - (org-velocity-heading-name heading) - 'action action)) - (newline)) - -(defun org-velocity-buttonize (heading) - "Insert HEADING as a text button with an hint." - (insert (format "#%c " (nth (1- (line-number-at-pos)) - org-velocity-index))) - (org-velocity-buttonize-no-hints heading)) - -(defun org-velocity-remember () - "Use `org-remember' to record a note." - (let ((org-remember-templates - org-velocity-remember-templates)) - (call-interactively 'org-remember) - (when org-remember-mode - (set (make-local-variable 'remember-buffer) - (rename-buffer org-velocity-search t))))) - -(defun org-velocity-capture () - "Use `org-capture' to record a note." - (let ((org-capture-templates - org-velocity-capture-templates)) - (when (fboundp 'org-capture) ;; quiet compiler - (call-interactively 'org-capture) - (if org-capture-mode (rename-buffer org-velocity-search t))))) - -(defun org-velocity-insert-heading (&optional heading) - "Add a new heading named HEADING and go to it." - (let ((heading (or heading org-velocity-search))) - (pop-to-buffer (org-velocity-bucket-buffer)) - (goto-char (point-max)) - (let ((inhibit-quit t)) - (newline) - (org-insert-heading t t) (insert heading) - (newline) - (goto-char (point-max))))) - -(defun org-velocity-generic-search (search) - "Return entries containing SEARCH." - (save-excursion - (loop initially (goto-char (point-min)) - while (re-search-forward search (point-max) t) - if (org-velocity-nearest-heading (match-beginning 0)) - collect it - do (outline-next-heading)))) - -(defsubst org-velocity-phrase-search (search) - "Return entries containing SEARCH as a phrase." - (org-velocity-generic-search (regexp-quote search))) - -(defsubst org-velocity-any-search (search) - "Return entries containing any word in SEARCH." - (org-velocity-generic-search (regexp-opt (split-string search)))) - -(defsubst org-velocity-regexp-search (search) - (condition-case lossage - (org-velocity-generic-search search) - (invalid-regexp (minibuffer-message "%s" lossage)))) - -(defun org-velocity-all-search (search) - "Return entries containing all words in SEARCH." - (save-excursion - (let ((keywords (mapcar 'regexp-quote (split-string search)))) - (delq nil - (org-map-entries - (lambda () - ;; Only search the subtree once. - (setq org-map-continue-from - (save-excursion (org-end-of-subtree t) (point))) - (if (loop for word in keywords - always (save-excursion - (re-search-forward - word org-map-continue-from t))) - (org-velocity-nearest-heading (point))))))))) - -(defun org-velocity-present (headings &optional no-hints search) - "Buttonize HEADINGS in `org-velocity-display-buffer'. -If NO-HINTS is non-nil, display entries without indices. -SEARCH binds `org-velocity-search'." - (and (listp headings) (delete-dups headings)) - (let ((cdr (nthcdr - (1- (length org-velocity-index)) - headings))) - (and (consp cdr) (setcdr cdr nil))) - (let ((org-velocity-search search)) - (with-current-buffer (org-velocity-display-buffer) - (mapc - (if no-hints 'org-velocity-buttonize-no-hints - 'org-velocity-buttonize) - headings) - (goto-char (point-min))))) - -(defun org-velocity-create-1 () - "Create a new heading. -The possible methods are `org-velocity-capture', -`org-velocity-remember', or `org-velocity-create', in -that order. Which is preferred is determined by -`org-velocity-create-method'." - (funcall - (ecase org-velocity-create-method - (capture (or (and (featurep 'org-capture) 'org-velocity-capture) - (and (featurep 'org-remember) 'org-velocity-remember) - 'org-velocity-insert-heading)) - (remember (or (and (featurep 'org-remember) 'org-velocity-remember) - 'org-velocity-insert-heading)) - (buffer 'org-velocity-insert-heading)))) + (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)))) + +(defsubst* org-velocity-present-match (&key 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-generic-search (search &optional hide-hints) + "Display any entry containing SEARCH." + (let ((hints org-velocity-index) matches) + (block nil + (while (and hints (re-search-forward search nil t)) + (let ((match (org-velocity-nearest-heading (point)))) + (org-velocity-present-match + :hint (unless hide-hints (car hints)) + :match match) + (push match matches)) + (setq hints (cdr hints)) + (unless (re-search-forward org-velocity-heading-regexp nil t) + (return)))) + (nreverse matches))) + +(defun* org-velocity-all-search (search &optional hide-hints max) + "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 (loop for word in keywords + always (save-excursion + (re-search-forward + (concat "\\<" word "\\>") + org-map-continue-from t))) + (let ((match (org-velocity-nearest-heading (match-end 0)))) + (org-velocity-present-match + :hint (unless hide-hints (car hints)) + :match match) + (push match matches) + (setq hints (cdr hints)))))) + (nreverse matches))) + +(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." + (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) + (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) + (goto-char (point-min))))) + (with-current-buffer (org-velocity-match-buffer) + (erase-buffer)))) (defun org-velocity-store-link () "Function for `org-store-link-functions'." @@ -443,72 +453,53 @@ that order. Which is preferred is determined by (add-hook 'org-store-link-functions 'org-velocity-store-link) -(defun org-velocity-create (search &optional ask) +(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-use-file)) + (org-default-notes-file (org-velocity-bucket-file)) ;; save a stored link org-store-link-plist) - (org-velocity-create-1)) + (org-velocity-capture)) search)) -(defun org-velocity-get-matches (search) - "Return matches for SEARCH in current bucket. -Use method specified by `org-velocity-search-method'." - (when (and search (not (string-equal "" search))) - (with-current-buffer (org-velocity-bucket-buffer) - ;; Fold case if the search string is lowercase. - (let ((case-fold-search (equal search (downcase search)))) - (case org-velocity-search-method - ('phrase (org-velocity-phrase-search search)) - ('any (org-velocity-any-search search)) - ('all (org-velocity-all-search search)) - ('regexp (org-velocity-regexp-search search))))))) - (defun org-velocity-engine (search) "Display a list of headings where SEARCH occurs." - (with-current-buffer (org-velocity-display-buffer) - (erase-buffer) - (setq cursor-type nil)) - (unless (or - (not (stringp search)) - (string-equal "" search)) ;exit on empty string - (case - (if (and org-velocity-force-new (eq last-command-event ?\C-j)) - 'force - (with-current-buffer (org-velocity-bucket-buffer) - (save-excursion - (let ((matches (org-velocity-get-matches search))) - (org-velocity-present matches nil search) - (cond ((zerop (length matches)) 'new) - ((= (length matches) 1) 'follow) - ((> (length matches) 1) 'prompt)))))) - ('prompt (progn - (Electric-pop-up-window (org-velocity-display-buffer)) - (let ((hint (org-velocity-electric-follow-hint))) - (if hint - (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 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-display-buffer)) - (goto-char (point-min)) - (button-activate (next-button (point)))) - (org-velocity-read nil search)))))) + (let ((org-velocity-search search)) + (unless (or + (not (stringp search)) + (string= "" search)) ;exit on empty string + (case + (if (and org-velocity-force-new (eq last-command-event ?\C-j)) + :force + (let ((matches (org-velocity-present search))) + (cond ((null matches) :new) + ((org-velocity-singlep matches) :follow) + (t :prompt)))) + (:prompt (progn + (pop-to-buffer (org-velocity-match-buffer)) + (let ((hint (org-velocity-electric-read-hint))) + (when hint (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-position (item list) "Return first position of ITEM in LIST." (loop for elt in list - for i from 0 - if (equal elt item) - return i)) + for i from 0 + when (equal elt item) + return i)) (defun org-velocity-activate-button (char) "Go to button on line number associated with CHAR in `org-velocity-index'." @@ -525,7 +516,11 @@ Use method specified by `org-velocity-search-method'." (interactive) (message "%s" (substitute-command-keys - "\\[org-velocity-electric-new] for new entry, \\[org-velocity-electric-edit] to edit search, \\[scroll-up] to scroll.")) + "\\[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) @@ -548,12 +543,12 @@ Use method specified by `org-velocity-search-method'." (defun org-velocity-electric-edit () "Edit the search string." (interactive) - (throw 'org-velocity-select 'edit)) + (throw 'org-velocity-select :edit)) (defun org-velocity-electric-new () "Force a new entry." (interactive) - (throw 'org-velocity-select 'force)) + (throw 'org-velocity-select :force)) (defvar org-velocity-electric-map (let ((map (make-sparse-keymap))) @@ -561,26 +556,28 @@ Use method specified by `org-velocity-search-method'." (loop for c in org-velocity-index do (define-key map (char-to-string c) 'org-velocity-electric-follow)) (define-key map "0" 'org-velocity-electric-new) - (define-key map [tab] 'scroll-up) - (define-key map [return] 'org-velocity-electric-edit) + (define-key map "\C-v" 'scroll-up) + (define-key map "\M-v" 'scroll-down) + (define-key map (kbd "RET") 'org-velocity-electric-edit) (define-key map [mouse-1] 'org-velocity-electric-click) (define-key map [mouse-2] 'org-velocity-electric-click) - (define-key map [escape escape escape] 'keyboard-quit) + (define-key map [escape] 'keyboard-quit) (define-key map "\C-h" 'help-command) map)) -(defun org-velocity-electric-follow-hint () +(defun org-velocity-electric-read-hint () "Read index of button electrically." - (with-current-buffer (org-velocity-display-buffer) + (with-current-buffer (org-velocity-match-buffer) (use-local-map org-velocity-electric-map) (catch 'org-velocity-select - (Electric-command-loop 'org-velocity-select - "Follow: ")))) + (Electric-command-loop 'org-velocity-select "Follow: ")))) (defvar org-velocity-incremental-keymap (let ((map (make-sparse-keymap))) (define-key map [mouse-1] 'org-velocity-click-for-incremental) (define-key map [mouse-2] 'org-velocity-click-for-incremental) + (define-key map "\C-v" 'scroll-up) + (define-key map "\M-v" 'scroll-down) map)) (defun org-velocity-click-for-incremental () @@ -601,30 +598,24 @@ Use method specified by `org-velocity-search-method'." (eq (buffer-local-value 'major-mode (window-buffer w)) 'completion-list-mode)))) -(defun org-velocity-display-for-incremental () - "Display results of search without hinting." - (when (and (sit-for idle-update-delay) - (not (org-velocity-displaying-completions-p))) +(defun org-velocity-update () + "Display results of search without hinting. +Stop searching once there are more matches than can be displayed." + (unless (org-velocity-displaying-completions-p) (let* ((search (org-velocity-minibuffer-contents)) - (matches (org-velocity-get-matches search))) - (if (zerop (length matches)) - (progn - (when (get-buffer-window (org-velocity-display-buffer)) - (delete-window - (get-buffer-window (org-velocity-display-buffer))) - (select-window (active-minibuffer-window))) - (unless (string-equal search "") - (minibuffer-message "No match; RET to create"))) - (if (and org-velocity-exit-on-match - (= (length matches) 1)) - (throw 'click search)) - (with-current-buffer (org-velocity-display-buffer) - (use-local-map org-velocity-incremental-keymap) - (erase-buffer) - (setq cursor-type nil)) - (with-current-buffer (org-velocity-bucket-buffer) - (org-velocity-present matches t search)) - (display-buffer (org-velocity-display-buffer)))))) + (matches (org-velocity-present search :hide-hints t))) + (cond ((null matches) + (select-window (active-minibuffer-window)) + (unless (or (null search) (string= "" search)) + (minibuffer-message "No match; RET to create"))) + ((and (org-velocity-singlep matches) + org-velocity-exit-on-match) + (throw 'click search)) + (t + (with-current-buffer (org-velocity-match-buffer) + (use-local-map org-velocity-incremental-keymap))))))) + +(defvar dabbrev--last-abbrev) (defun org-velocity-dabbrev-completion-list (abbrev) "Return all dabbrev completions for ABBREV." @@ -633,17 +624,25 @@ Use method specified by `org-velocity-search-method'." (setq dabbrev--last-abbrev 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 [remap minibuffer-complete] 'minibuffer-complete-word) + map) + "Keymap for completion with `completing-read'.") + (defun org-velocity-read-with-completion (prompt) "Completing read with PROMPT." (let ((minibuffer-local-completion-map - minibuffer-local-filename-completion-map) + org-velocity-local-completion-map) (completion-no-auto-exit t) (crm-separator " ")) (funcall (case org-velocity-search-method - (phrase 'completing-read) - (any 'completing-read-multiple) - (all 'completing-read-multiple)) + (phrase #'completing-read) + (any #'completing-read-multiple) + (all #'completing-read-multiple)) prompt (completion-table-dynamic 'org-velocity-dabbrev-completion-list)))) @@ -660,30 +659,36 @@ Use method specified by `org-velocity-search-method'." (goto-char (point-max)))) (if (eq org-velocity-search-method 'regexp) (read-regexp prompt) - (if (and org-velocity-use-completion - ;; map-entries complains for nonexistent files - (file-exists-p (org-velocity-use-file))) + (if org-velocity-use-completion (org-velocity-read-with-completion prompt) (read-string prompt))))) -(defun org-velocity-read-incrementally (prompt) +(defun org-velocity-incremental-read (prompt) "Read string with PROMPT and display results incrementally." (let ((res (unwind-protect - (catch 'click - (add-hook 'post-command-hook - 'org-velocity-display-for-incremental) - (if (eq org-velocity-search-method 'regexp) - (read-regexp prompt) - (if (and org-velocity-use-completion - (file-exists-p (org-velocity-use-file))) - (org-velocity-read-with-completion prompt) - (read-string prompt)))) - (remove-hook 'post-command-hook - 'org-velocity-display-for-incremental)))) + (let* ((match-window (display-buffer (org-velocity-match-buffer))) + (org-velocity-index + ;; Truncate the index to the size of the buffer to be + ;; displayed. + (with-selected-window match-window + (if (> (window-height) (length org-velocity-index)) + ;; (subseq org-velocity-index 0 (window-height)) + (let ((hints (copy-sequence org-velocity-index))) + (setcdr (nthcdr (window-height) hints) nil) + hints) + org-velocity-index)))) + (catch 'click + (add-hook 'post-command-hook 'org-velocity-update) + (if (eq org-velocity-search-method 'regexp) + (read-regexp prompt) + (if org-velocity-use-completion + (org-velocity-read-with-completion prompt) + (read-string prompt))))) + (remove-hook 'post-command-hook 'org-velocity-update)))) (if (bufferp res) (org-pop-to-buffer-same-window res) res))) -(defun org-velocity-read (arg &optional search) +(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 @@ -693,22 +698,26 @@ created named SEARCH. If `org-velocity-bucket' is defined and `org-velocity-always-use-bucket' is non-nil, then the bucket file will be used; otherwise, this will work when called in any Org -file. Calling with ARG forces current file." +file. Calling with ARG forces current file." (interactive "P") (let ((org-velocity-always-use-bucket (if arg nil org-velocity-always-use-bucket))) ;; complain if inappropriate - (assert (org-velocity-use-file)) - (unwind-protect - (let ((dabbrev-search-these-buffers-only - (list (org-velocity-bucket-buffer)))) - (org-velocity-engine - (if org-velocity-search-is-incremental - (org-velocity-read-incrementally "Velocity search: ") - (org-velocity-read-string "Velocity search: " search)))) - (progn - (kill-buffer (org-velocity-display-buffer)) - (delete-other-windows))))) + (assert (org-velocity-bucket-file)) + (let ((org-velocity-bucket-buffer + (find-file-noselect (org-velocity-bucket-file)))) + (unwind-protect + (let ((dabbrev-search-these-buffers-only + (list (org-velocity-bucket-buffer)))) + (org-velocity-engine + (if org-velocity-search-is-incremental + (org-velocity-incremental-read "Velocity search: ") + (org-velocity-read-string "Velocity search: " search)))) + (progn + (kill-buffer (org-velocity-match-buffer)) + (delete-other-windows)))))) + +(defalias 'org-velocity-read 'org-velocity) (provide 'org-velocity) --=-=-=--