New version of Org-Velocity

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)