emacs-orgmode@gnu.org archives
 help / color / mirror / code / Atom feed
* [PATCH] New version of org-velocity
@ 2014-10-27 19:06 Paul Rodriguez
  2014-10-30 19:18 ` Marco Wahl
  2014-12-01 15:27 ` Bastien
  0 siblings, 2 replies; 12+ messages in thread
From: Paul Rodriguez @ 2014-10-27 19:06 UTC (permalink / raw)
  To: emacs-orgmode


[-- Attachment #1.1: Type: text/plain, Size: 374 bytes --]

This is a new version of org-velocity. Principally it differs in using
cl-lib and lexical binding, but there are also some minor bugfixes for
presenting results on very large screens and compatibility with evil-mode.

Also, for anyone interested in org-velocity: there is now a development
repository on GitHub: <https://github.com/ruricolist/org-velocity>.

Paul Rodriguez

[-- Attachment #1.2: Type: text/html, Size: 523 bytes --]

[-- Attachment #2: 0001-New-version-of-Org-Velocity.patch --]
[-- Type: text/x-patch, Size: 25901 bytes --]

From 5cac25a0d21867bce9c6a24e10dff190ed92b566 Mon Sep 17 00:00:00 2001
From: "Paul M. Rodriguez" <pmr@ruricolist.com>
Date: Sun, 26 Oct 2014 17:13:18 -0500
Subject: [PATCH] New version of Org-Velocity

---
 contrib/lisp/org-velocity.el |  309 ++++++++++++++++++++++--------------------
 1 file changed, 163 insertions(+), 146 deletions(-)

diff --git a/contrib/lisp/org-velocity.el b/contrib/lisp/org-velocity.el
index e6788c6..a7820f1 100644
--- a/contrib/lisp/org-velocity.el
+++ b/contrib/lisp/org-velocity.el
@@ -1,10 +1,10 @@
-;;; org-velocity.el --- something like Notational Velocity for Org.
+;;; org-velocity.el --- something like Notational Velocity for Org. -*- lexical-binding: t -*-
 
 ;; Copyright (C) 2010-2014 Paul M. Rodriguez
 
 ;; Author: Paul M. Rodriguez <paulmrodriguez@gmail.com>
 ;; Created: 2010-05-05
-;; Version: 3.0
+;; Version: 4.0
 
 ;; This file is not part of GNU Emacs.
 
@@ -64,7 +64,7 @@
 (require 'button)
 (require 'electric)
 (require 'dabbrev)
-(eval-when-compile (require 'cl))
+(require 'cl-lib)
 
 (defgroup org-velocity nil
   "Notational Velocity-style interface for Org."
@@ -133,9 +133,9 @@ file."
   "Match on whole phrase, any word, or all words?"
   :group 'org-velocity
   :type '(choice
-	  (const :tag "Match whole phrase" phrase)
-	  (const :tag "Match any word" any)
-	  (const :tag "Match all words" all)
+          (const :tag "Match whole phrase" phrase)
+          (const :tag "Match any word" any)
+          (const :tag "Match all words" all)
           (const :tag "Match a regular expression" regexp))
   :safe (lambda (v) (memq v '(phrase any all regexp))))
 
@@ -152,6 +152,17 @@ See the documentation for `org-capture-templates'."
   :group 'org-velocity
   :type (or (get 'org-capture-templates 'custom-type) 'list))
 
+(defcustom org-velocity-heading-level 1
+  "Only match headings at this level or higher.
+0 means to match headings at any level."
+  :group 'org-velocity
+  :type 'integer
+  :safe (lambda (x)
+          (and (integerp x)
+               (>= x 0))))
+
+(defvar crm-separator)                  ;Ensure dynamic binding.
+
 (defsubst org-velocity-grab-preview ()
   "Grab preview of a subtree.
 The length of the preview is determined by `window-width'.
@@ -172,14 +183,14 @@ Replace all contiguous whitespace with single spaces."
         (point-max))))
      " ")))
 
-(defstruct org-velocity-heading buffer position name level preview)
+(cl-defstruct org-velocity-heading buffer position name level preview)
 
 (defsubst org-velocity-nearest-heading (position)
   "Return last heading at POSITION.
 If there is no last heading, return nil."
   (save-excursion
     (goto-char position)
-    (re-search-backward org-velocity-heading-regexp)
+    (re-search-backward (org-velocity-heading-regexp))
     (let ((components (org-heading-components)))
       (make-org-velocity-heading
        :buffer (current-buffer)
@@ -191,15 +202,18 @@ If there is no last heading, return nil."
 
 (defconst org-velocity-index
   (eval-when-compile
-    (nconc (number-sequence 49 57) 	;numbers
+    (nconc (number-sequence 49 57)      ;numbers
            (number-sequence 97 122)	;lowercase letters
            (number-sequence 65 90)))	;uppercase letters
   "List of chars for indexing results.")
 
 (defconst org-velocity-match-buffer-name "*Velocity matches*")
 
-(defconst org-velocity-heading-regexp "^\\* "
-  "Regexp to match only top-level headings.")
+(cl-defun org-velocity-heading-regexp (&optional (level org-velocity-heading-level))
+  "Regexp to match headings at LEVEL or deeper."
+  (if (zerop level)
+      "^\\*+ "
+    (format "^\\*\\{1,%d\\} " level)))
 
 (defvar org-velocity-search nil
   "Variable to bind to current search.")
@@ -223,12 +237,6 @@ of the base buffer; in the latter, return the file name of
       (with-current-buffer (window-buffer (active-minibuffer-window))
         (minibuffer-contents))))
 
-(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;
@@ -260,17 +268,22 @@ use it."
   "Return the proper buffer for Org-Velocity to display in."
   (get-buffer-create org-velocity-match-buffer-name))
 
+(defsubst org-velocity-match-window ()
+  (get-buffer-window (org-velocity-match-buffer)))
+
+(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))
   ;; 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)))
+  (or (looking-at (org-velocity-heading-regexp))
+      (re-search-forward (org-velocity-heading-regexp))))
 
 (defun org-velocity-make-indirect-buffer (heading)
   "Make or switch to an indirect buffer visiting HEADING."
-
   (let* ((bucket (org-velocity-heading-buffer heading))
          (name (org-velocity-heading-name heading))
          (existing (get-buffer name)))
@@ -279,7 +292,8 @@ use it."
         existing
       (make-indirect-buffer
        bucket
-       (generate-new-buffer-name (org-velocity-heading-name heading))))))
+       (generate-new-buffer-name (org-velocity-heading-name heading))
+       t))))
 
 (defun org-velocity-capture ()
   "Record a note with `org-capture'."
@@ -287,34 +301,38 @@ use it."
          org-velocity-capture-templates))
     (org-capture nil
                  ;; This is no longer automatically selected.
-                 (when (org-velocity-singlep org-capture-templates)
+                 (when (null (cdr org-capture-templates))
                    (caar org-capture-templates)))
-    (if org-capture-mode (rename-buffer org-velocity-search t))))
+    (when org-capture-mode
+      (rename-buffer org-velocity-search t))))
 
 (defvar org-velocity-saved-winconf nil)
 (make-variable-buffer-local 'org-velocity-saved-winconf)
 
 (defun org-velocity-edit-entry (heading)
   "Edit entry at HEADING in an indirect buffer."
-  (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))))))))
+  (let ((winconf (current-window-configuration))
+        (buffer (org-velocity-make-indirect-buffer heading))
+        (inhibit-point-motion-hooks t)
+        (inhibit-field-text-motion t))
+    (with-current-buffer buffer
+      (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))
+      (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)))))))
 
 (defun org-velocity-dismiss ()
   "Save current entry and close indirect buffer."
@@ -327,14 +345,18 @@ use it."
 
 (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)))
+  (when org-velocity-use-search-ring
+    (add-to-history 'search-ring
+                    (button-get button 'search)
+                    search-ring-max))
+  (let ((match (button-get button 'match)))
+    (throw 'org-velocity-done
+           (lambda ()
+             (org-velocity-edit-entry match)))))
 
 (define-button-type 'org-velocity-button
-  'action #'org-velocity-visit-button)
+  'action #'org-velocity-visit-button
+  'follow-link 'mouse-face)
 
 (defsubst org-velocity-buttonize (heading)
   "Insert HEADING as a text button with no hints."
@@ -352,8 +374,8 @@ use it."
       (org-velocity-heading-preview heading)
       'face 'shadow))))
 
-(defsubst* org-velocity-present-match (&key hint match)
-  (with-current-buffer (org-velocity-match-buffer)
+(defsubst org-velocity-present-match (hint match)
+  (with-current-buffer (org-velocity-match-staging-buffer)
     (when hint (insert "#" hint " "))
     (org-velocity-buttonize match)
     (org-velocity-insert-preview match)
@@ -362,19 +384,19 @@ use it."
 (defun org-velocity-generic-search (search &optional hide-hints)
   "Display any entry containing SEARCH."
   (let ((hints org-velocity-index) matches)
-    (block nil
+    (cl-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)
+           (unless hide-hints (car hints))
+           match)
           (push match matches))
         (setq hints (cdr hints))
-        (unless (re-search-forward org-velocity-heading-regexp nil t)
+        (unless (re-search-forward (org-velocity-heading-regexp) nil t)
           (return))))
     (nreverse matches)))
 
-(defun* org-velocity-all-search (search &optional hide-hints max)
+(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)
@@ -388,23 +410,23 @@ use it."
        (setq org-map-continue-from
              (save-excursion
                (goto-char (line-end-position))
-               (if (re-search-forward org-velocity-heading-regexp nil t)
+               (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)))
+       (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
-            :hint (unless hide-hints (car hints))
-            :match match)
+            (unless hide-hints (car hints))
+            match)
            (push match matches)
            (setq hints (cdr hints))))))
     (nreverse matches)))
 
-(defun* org-velocity-present (search &key hide-hints)
+(cl-defun org-velocity-present (search &key hide-hints)
   "Buttonize matches for SEARCH in `org-velocity-match-buffer'.
 If HIDE-HINTS is non-nil, display entries without indices. SEARCH
 binds `org-velocity-search'.
@@ -425,7 +447,7 @@ Return matches."
                     (inhibit-field-text-motion t))
                 (save-excursion
                   (org-velocity-beginning-of-headings)
-                  (case org-velocity-search-method
+                  (cl-case org-velocity-search-method
                     (all (org-velocity-all-search search hide-hints))
                     (phrase (org-velocity-generic-search
                              (concat "\\<" (regexp-quote search))
@@ -440,6 +462,7 @@ Return matches."
                               (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))))
@@ -452,14 +475,14 @@ Return matches."
 
 (add-hook 'org-store-link-functions 'org-velocity-store-link)
 
-(defun* org-velocity-create (search &key ask)
+(cl-defun org-velocity-create (search &key ask)
   "Create new heading named SEARCH.
 If ASK is non-nil, ask first."
   (when (or (null ask) (y-or-n-p "No match found, create? "))
     (let ((org-velocity-search search)
-	  (org-default-notes-file (org-velocity-bucket-file))
-	  ;; save a stored link
-	  org-store-link-plist)
+          (org-default-notes-file (org-velocity-bucket-file))
+          ;; save a stored link
+          org-store-link-plist)
       (org-velocity-capture))
     search))
 
@@ -469,17 +492,18 @@ If ASK is non-nil, ask first."
     (unless (or
              (not (stringp search))
              (string= "" search))	;exit on empty string
-      (case
+      (cl-case
           (if (and org-velocity-force-new (eq last-command-event ?\C-j))
               :force
-            (let ((matches (org-velocity-present search)))
+            (let* ((org-velocity-index (org-velocity-adjust-index))
+                   (matches (org-velocity-present search)))
               (cond ((null matches) :new)
-                    ((org-velocity-singlep matches) :follow)
+                    ((null (cdr matches)) :follow)
                     (t :prompt))))
         (:prompt (progn
                    (pop-to-buffer (org-velocity-match-buffer))
                    (let ((hint (org-velocity-electric-read-hint)))
-                     (when hint (case hint
+                     (when hint (cl-case hint
                                   (:edit (org-velocity-read nil search))
                                   (:force (org-velocity-create search))
                                   (otherwise (org-velocity-activate-button hint)))))))
@@ -493,17 +517,10 @@ If ASK is non-nil, ask first."
                        (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
-        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'."
   (goto-char (point-min))
-  (forward-line (org-velocity-position char org-velocity-index))
+  (forward-line (cl-position char org-velocity-index))
   (goto-char
    (button-start
     (next-button (point))))
@@ -514,8 +531,8 @@ If ASK is non-nil, ask first."
   "Complain about an undefined key."
   (interactive)
   (message "%s"
-	   (substitute-command-keys
-	    "\\[org-velocity-electric-new] for new entry,
+           (substitute-command-keys
+            "\\[org-velocity-electric-new] for new entry,
 \\[org-velocity-electric-edit] to edit search,
 \\[scroll-up] to scroll up,
 \\[scroll-down] to scroll down,
@@ -525,20 +542,11 @@ If ASK is non-nil, ask first."
 (defun org-velocity-electric-follow (ev)
   "Follow a hint indexed by keyboard event EV."
   (interactive (list last-command-event))
-  (if (not (> (org-velocity-position ev org-velocity-index)
+  (if (not (> (cl-position ev org-velocity-index)
               (1- (count-lines (point-min) (point-max)))))
       (throw 'org-velocity-select ev)
     (call-interactively 'org-velocity-electric-undefined)))
 
-(defun org-velocity-electric-click (ev)
-  "Follow hint indexed by a mouse event EV."
-  (interactive "e")
-  (throw 'org-velocity-select
-	 (nth (1- (count-lines
-		   (point-min)
-		   (posn-point (event-start ev))))
-	      org-velocity-index)))
-
 (defun org-velocity-electric-edit ()
   "Edit the search string."
   (interactive)
@@ -552,14 +560,15 @@ If ASK is non-nil, ask first."
 (defvar org-velocity-electric-map
   (let ((map (make-sparse-keymap)))
     (define-key map [t] 'org-velocity-electric-undefined)
-    (loop for c in org-velocity-index
-	  do (define-key map (char-to-string c) 'org-velocity-electric-follow))
+    (dolist (c org-velocity-index)
+      (define-key map (char-to-string c)
+        'org-velocity-electric-follow))
     (define-key map "0" 'org-velocity-electric-new)
     (define-key map "\C-v" 'scroll-up)
     (define-key map "\M-v" 'scroll-down)
     (define-key map (kbd "RET") 'org-velocity-electric-edit)
-    (define-key map [mouse-1] 'org-velocity-electric-click)
-    (define-key map [mouse-2] 'org-velocity-electric-click)
+    (define-key map [mouse-1] nil)
+    (define-key map [mouse-2] nil)
     (define-key map [escape] 'keyboard-quit)
     (define-key map "\C-h" 'help-command)
     map))
@@ -567,29 +576,19 @@ If ASK is non-nil, ask first."
 (defun org-velocity-electric-read-hint ()
   "Read index of button electrically."
   (with-current-buffer (org-velocity-match-buffer)
+    (when (featurep 'evil)
+      ;; NB Idempotent.
+      (evil-make-overriding-map org-velocity-electric-map))
     (use-local-map org-velocity-electric-map)
     (catch 'org-velocity-select
       (Electric-command-loop 'org-velocity-select "Follow: "))))
 
 (defvar org-velocity-incremental-keymap
   (let ((map (make-sparse-keymap)))
-    (define-key map [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 ()
-  "Jump out of search and select hint clicked on."
-  (interactive)
-  (let ((ev last-command-event))
-    (org-velocity-activate-button
-     (nth (- (count-lines
-              (point-min)
-              (posn-point (event-start ev))) 2)
-          org-velocity-index)))
-  (throw 'click (current-buffer)))
-
 (defun org-velocity-displaying-completions-p ()
   "Is there a *Completions* buffer showing?"
   (get-window-with-predicate
@@ -598,8 +597,7 @@ If ASK is non-nil, ask first."
          'completion-list-mode))))
 
 (defun org-velocity-update ()
-  "Display results of search without hinting.
-Stop searching once there are more matches than can be displayed."
+  "Display results of search without hinting."
   (unless (org-velocity-displaying-completions-p)
     (let* ((search (org-velocity-minibuffer-contents))
            (matches (org-velocity-present search :hide-hints t)))
@@ -607,20 +605,20 @@ Stop searching once there are more matches than can be displayed."
              (select-window (active-minibuffer-window))
              (unless (or (null search) (string= "" search))
                (minibuffer-message "No match; RET to create")))
-            ((and (org-velocity-singlep matches)
+            ((and (null (cdr matches))
                   org-velocity-exit-on-match)
              (throw 'click search))
             (t
              (with-current-buffer (org-velocity-match-buffer)
                (use-local-map org-velocity-incremental-keymap)))))))
 
-(defvar dabbrev--last-abbrev)
+(defvar dabbrev--last-abbreviation)
 
 (defun org-velocity-dabbrev-completion-list (abbrev)
   "Return all dabbrev completions for ABBREV."
   ;; This is based on `dabbrev-completion'.
   (dabbrev--reset-global-variables)
-  (setq dabbrev--last-abbrev abbrev)
+  (setq dabbrev--last-abbreviation abbrev)
   (dabbrev--find-all-expansions abbrev case-fold-search))
 
 (defvar org-velocity-local-completion-map
@@ -638,7 +636,7 @@ Stop searching once there are more matches than can be displayed."
         (completion-no-auto-exit t)
         (crm-separator " "))
     (funcall
-     (case org-velocity-search-method
+     (cl-case org-velocity-search-method
        (phrase #'completing-read)
        (any    #'completing-read-multiple)
        (all    #'completing-read-multiple))
@@ -652,38 +650,50 @@ Stop searching once there are more matches than can be displayed."
   ;; `read-from-minibuffer'), but in this case it is the user-friendly
   ;; thing to do.
   (minibuffer-with-setup-hook
-      (lexical-let ((initial-input initial-input))
+      (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)
+        (read-regexp prompt)
       (if org-velocity-use-completion
-	  (org-velocity-read-with-completion prompt)
-	(read-string prompt)))))
+          (org-velocity-read-with-completion prompt)
+        (read-string prompt)))))
+
+(cl-defun org-velocity-adjust-index
+    (&optional (match-window (org-velocity-match-window)))
+  "Truncate or extend `org-velocity-index' to the lines in
+MATCH-WINDOW."
+  (with-selected-window match-window
+    (let ((lines (window-height))
+          (hints (length org-velocity-index)))
+      (cond ((= lines hints)
+             org-velocity-index)
+            ;; Truncate the index to the size of
+            ;; the buffer to be displayed.
+            ((< lines hints)
+             (cl-subseq org-velocity-index 0 lines))
+            ;; If the window is so tall we run out of indices, at
+            ;; least make the additional results clickable.
+            ((> lines hints)
+             (append org-velocity-index
+                     (make-list (- lines hints) nil)))))))
 
 (defun org-velocity-incremental-read (prompt)
-  "Read string with PROMPT and display results incrementally."
+  "Read string with PROMPT and display results incrementally.
+Stop searching once there are more matches than can be
+displayed."
   (let ((res
          (unwind-protect
              (let* ((match-window (display-buffer (org-velocity-match-buffer)))
-                    (org-velocity-index
-                     ;; 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))))
+                    (org-velocity-index (org-velocity-adjust-index match-window)))
                (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)))))
+                 (cond ((eq org-velocity-search-method 'regexp)
+                        (read-regexp prompt))
+                       (org-velocity-use-completion
+                        (org-velocity-read-with-completion prompt))
+                       (t (read-string prompt)))))
            (remove-hook 'post-command-hook 'org-velocity-update))))
     (if (bufferp res) (org-pop-to-buffer-same-window res) res)))
 
@@ -697,24 +707,31 @@ 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 reverses which file – the current file or the
+bucket file – to use. If the bucket file would have been used,
+then the current file is used instead, and vice versa."
   (interactive "P")
   (let ((org-velocity-always-use-bucket
-	 (if arg nil org-velocity-always-use-bucket)))
+         (if org-velocity-always-use-bucket
+             (not arg)
+           arg)))
     ;; complain if inappropriate
-    (assert (org-velocity-bucket-file))
+    (cl-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))))))
+            (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)))
+        (kill-buffer (org-velocity-match-buffer))))))
 
 (defalias 'org-velocity-read 'org-velocity)
 
-- 
1.7.9.5


^ permalink raw reply related	[flat|nested] 12+ messages in thread
* [PATCH] New version of org-velocity
@ 2015-12-15  0:03 Paul Rodriguez
  2015-12-15 17:19 ` Marco Wahl
  2015-12-16  7:44 ` Marco Wahl
  0 siblings, 2 replies; 12+ messages in thread
From: Paul Rodriguez @ 2015-12-15  0:03 UTC (permalink / raw)
  To: emacs-orgmode


[-- 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


^ permalink raw reply related	[flat|nested] 12+ messages in thread

end of thread, other threads:[~2015-12-16  7:44 UTC | newest]

Thread overview: 12+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2014-10-27 19:06 [PATCH] New version of org-velocity 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
  -- strict thread matches above, loose matches on Subject: below --
2015-12-15  0:03 Paul Rodriguez
2015-12-15 17:19 ` Marco Wahl
2015-12-16  7:44 ` Marco Wahl

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).