* [PATCH] Org-Velocity rewrite
@ 2011-11-22 18:18 Paul M. Rodriguez
2011-12-11 16:14 ` Bastien
0 siblings, 1 reply; 2+ messages in thread
From: Paul M. Rodriguez @ 2011-11-22 18:18 UTC (permalink / raw)
To: emacs-orgmode
[-- Attachment #1: Type: text/plain, Size: 212 bytes --]
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.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: org-velocity.el.diff --]
[-- Type: text/x-diff, Size: 37460 bytes --]
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 <paulmrodriguez@gmail.com>
;; 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)
^ permalink raw reply related [flat|nested] 2+ messages in thread
* Re: [PATCH] Org-Velocity rewrite
2011-11-22 18:18 [PATCH] Org-Velocity rewrite Paul M. Rodriguez
@ 2011-12-11 16:14 ` Bastien
0 siblings, 0 replies; 2+ messages in thread
From: Bastien @ 2011-12-11 16:14 UTC (permalink / raw)
To: Paul M. Rodriguez; +Cc: emacs-orgmode
Hi Paul,
"Paul M. Rodriguez" <paulmrodriguez@gmail.com> writes:
> 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.
Applied, thanks a lot.
--
Bastien
^ permalink raw reply [flat|nested] 2+ messages in thread
end of thread, other threads:[~2011-12-11 16:13 UTC | newest]
Thread overview: 2+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2011-11-22 18:18 [PATCH] Org-Velocity rewrite Paul M. Rodriguez
2011-12-11 16:14 ` Bastien
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).