contrib/lisp/org-velocity.el

   1 ;;; org-velocity.el --- something like Notational Velocity for Org. -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2010-2014 Paul M. Rodriguez
   4
   5 ;; Author: Paul M. Rodriguez <paulmrodriguez@gmail.com>
   6 ;; Created: 2010-05-05
   7 ;; Version: 4.1
   8
   9 ;; This file is not part of GNU Emacs.
  10
  11 ;; This program is free software; you can redistribute it and/or
  12 ;; modify it under the terms of the GNU General Public License as
  13 ;; published by the Free Software Foundation version 2.
  14
  15 ;; This program is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24 ;; Org-Velocity.el is an interface for Org inspired by the minimalist
  25 ;; notetaking program Notational Velocity. The idea is to let you
  26 ;; amass and access brief notes on many subjects with minimal fuss.
  27 ;; Each note is an entry in an ordinary Org file.
  28
  29 ;; Org-Velocity can be used in two ways: when called outside Org, to
  30 ;; store and access notes in a designated bucket file; or, when called
  31 ;; inside Org, as a method for navigating any Org file. (Setting the
  32 ;; option `org-velocity-always-use-bucket' disables navigation inside
  33 ;; Org files by default, although you can still force this behavior by
  34 ;; calling `org-velocity-read' with an argument.)
  35
  36 ;; Org-Velocity prompts for search terms in the minibuffer. A list of
  37 ;; headings of entries whose text matches your search is updated as
  38 ;; you type; you can end the search and visit an entry at any time by
  39 ;; clicking on its heading.
  40
  41 ;; RET displays the results. If there are no matches, Org-Velocity
  42 ;; offers to create a new entry with your search string as its
  43 ;; heading. If there are matches, it displays a list of results where
  44 ;; the heading of each matching entry is hinted with a number or
  45 ;; letter; clicking a result, or typing the matching hint, opens the
  46 ;; entry for editing in an indirect buffer. 0 forces a new entry; RET
  47 ;; reopens the search for editing.
  48
  49 ;; You can customize every step in this process, including the search
  50 ;; method, completion for search terms, and templates for creating new
  51 ;; entries; M-x customize-group RET org-velocity RET to see all the
  52 ;; options.
  53
  54 ;; Thanks to Richard Riley, Carsten Dominik, Bastien Guerry, and Jeff
  55 ;; Horn for their suggestions.
  56
  57 ;;; Usage:
  58 ;; (require 'org-velocity)
  59 ;; (setq org-velocity-bucket (expand-file-name "bucket.org" org-directory))
  60 ;; (global-set-key (kbd "C-c v") 'org-velocity)
  61
  62 ;;; Code:
  63 (require 'org)
  64 (require 'button)
  65 (require 'electric)
  66 (require 'dabbrev)
  67 (require 'cl-lib)
  68
  69 (defgroup org-velocity nil
  70   "Notational Velocity-style interface for Org."
  71   :tag "Org-Velocity"
  72   :group 'outlines
  73   :group 'hypermedia
  74   :group 'org)
  75
  76 (defcustom org-velocity-bucket ""
  77   "Where is the bucket file?"
  78   :group 'org-velocity
  79   :type 'file)
  80
  81 (defcustom org-velocity-show-previews t
  82   "Show previews of the text of each heading?"
  83   :group 'velocity
  84   :type 'boolean
  85   :safe 'booleanp)
  86
  87 (defcustom org-velocity-exit-on-match nil
  88   "When searching incrementally, exit on a single match?"
  89   :group 'org-velocity
  90   :type 'boolean
  91   :safe 'booleanp)
  92
  93 (defcustom org-velocity-force-new nil
  94   "Should exiting the minibuffer with C-j force a new entry?"
  95   :group 'org-velocity
  96   :type 'boolean
  97   :safe 'booleanp)
  98
  99 (defcustom org-velocity-use-search-ring t
 100   "Push search to `search-ring' when visiting an entry?
 101
 102 This means that C-s C-s will take you directly to the first
 103 instance of the search string."
 104   :group 'org-velocity
 105   :type 'boolean
 106   :safe 'booleanp)
 107
 108 (defcustom org-velocity-always-use-bucket nil
 109   "Use bucket file even when called from an Org buffer?"
 110   :group 'org-velocity
 111   :type 'boolean
 112   :safe 'booleanp)
 113
 114 (defcustom org-velocity-use-completion nil
 115   "Use completion?
 116
 117 Notwithstanding the value of this option, calling
 118 `dabbrev-expand' always completes against the text of the bucket
 119 file."
 120   :group 'org-velocity
 121   :type '(choice
 122           (const :tag "Do not use completion" nil)
 123           (const :tag "Use completion" t))
 124   :safe 'booleanp)
 125
 126 (defcustom org-velocity-search-method 'phrase
 127   "Match on whole phrase, any word, or all words?"
 128   :group 'org-velocity
 129   :type '(choice
 130           (const :tag "Match whole phrase" phrase)
 131           (const :tag "Match any word" any)
 132           (const :tag "Match all words" all)
 133           (const :tag "Match a regular expression" regexp))
 134   :safe (lambda (v) (memq v '(phrase any all regexp))))
 135
 136 (defcustom org-velocity-capture-templates
 137   '(("v"
 138      "Velocity entry"
 139      entry
 140      (file "")
 141      "* %:search\n\n%i%?"))
 142   "Use these template with `org-capture'.
 143 Meanwhile `org-default-notes-file' is bound to `org-velocity-bucket-file'.
 144 The keyword :search inserts the current search.
 145 See the documentation for `org-capture-templates'."
 146   :group 'org-velocity
 147   :type (or (get 'org-capture-templates 'custom-type) 'list))
 148
 149 (defcustom org-velocity-heading-level 1
 150   "Only match headings at this level or higher.
 151 0 means to match headings at any level."
 152   :group 'org-velocity
 153   :type 'integer
 154   :safe (lambda (x)
 155           (and (integerp x)
 156                (>= x 0))))
 157
 158 (defvar crm-separator)                  ;Ensure dynamic binding.
 159
 160 (defsubst org-velocity-grab-preview ()
 161   "Grab preview of a subtree.
 162 The length of the preview is determined by `window-width'.
 163
 164 Replace all contiguous whitespace with single spaces."
 165   (let* ((start (progn
 166                   (forward-line 1)
 167                   (if (looking-at org-property-start-re)
 168                       (re-search-forward org-property-end-re)
 169                     (1- (point)))))
 170          (string+props (buffer-substring
 171                         start
 172                         (min
 173                          (+ start (window-width))
 174                          (point-max)))))
 175     ;; We want to preserve the text properties so that, for example,
 176     ;; we don't end up with the raw text of links in the preview.
 177     (with-temp-buffer
 178       (insert string+props)
 179       (goto-char (point-min))
 180       (save-match-data
 181         (while (re-search-forward split-string-default-separators
 182                                   (point-max)
 183                                   t)
 184           (replace-match " ")))
 185       (buffer-string))))
 186
 187 (cl-defstruct org-velocity-heading buffer position name level preview)
 188
 189 (defsubst org-velocity-nearest-heading (position)
 190   "Return last heading at POSITION.
 191 If there is no last heading, return nil."
 192   (save-excursion
 193     (goto-char position)
 194     (re-search-backward (org-velocity-heading-regexp))
 195     (let ((components (org-heading-components)))
 196       (make-org-velocity-heading
 197        :buffer (current-buffer)
 198        :position (point)
 199        :name (nth 4 components)
 200        :level (nth 0 components)
 201        :preview (if org-velocity-show-previews
 202                     (org-velocity-grab-preview))))))
 203
 204 (defconst org-velocity-index
 205   (eval-when-compile
 206     (nconc (number-sequence 49 57)      ;numbers
 207            (number-sequence 97 122)     ;lowercase letters
 208            (number-sequence 65 90)))    ;uppercase letters
 209   "List of chars for indexing results.")
 210
 211 (defconst org-velocity-match-buffer-name "*Velocity matches*")
 212
 213 (cl-defun org-velocity-heading-regexp (&optional (level org-velocity-heading-level))
 214   "Regexp to match headings at LEVEL or deeper."
 215   (if (zerop level)
 216       "^\\*+ "
 217     (format "^\\*\\{1,%d\\} " level)))
 218
 219 (defvar org-velocity-search nil
 220   "Variable to bind to current search.")
 221
 222 (defun org-velocity-buffer-file-name (&optional buffer)
 223   "Return the name of the file BUFFER saves to.
 224 Same as function `buffer-file-name' unless BUFFER is an indirect
 225 buffer or a minibuffer. In the former case, return the file name
 226 of the base buffer; in the latter, return the file name of
 227 `minibuffer-selected-window' (or its base buffer)."
 228   (let ((buffer (if (minibufferp buffer)
 229                     (window-buffer (minibuffer-selected-window))
 230                   buffer)))
 231     (buffer-file-name
 232      (or (buffer-base-buffer buffer)
 233          buffer))))
 234
 235 (defun org-velocity-minibuffer-contents ()
 236   "Return the contents of the minibuffer when it is active."
 237   (when (active-minibuffer-window)
 238     (with-current-buffer (window-buffer (active-minibuffer-window))
 239       (minibuffer-contents))))
 240
 241 (defun org-velocity-nix-minibuffer ()
 242   "Return the contents of the minibuffer and clear it."
 243   (when (active-minibuffer-window)
 244     (with-current-buffer (window-buffer (active-minibuffer-window))
 245       (prog1 (minibuffer-contents)
 246         (delete-minibuffer-contents)))))
 247
 248 (defun org-velocity-bucket-file ()
 249   "Return the proper file for Org-Velocity to search.
 250 If `org-velocity-always-use-bucket' is t, use bucket file;
 251 complain if missing. Otherwise, if an Org file is current, then
 252 use it."
 253   (let ((org-velocity-bucket
 254          (when org-velocity-bucket (expand-file-name org-velocity-bucket)))
 255         (buffer
 256          (let ((buffer-file (org-velocity-buffer-file-name)))
 257            (when buffer-file
 258              ;; Use the target in capture buffers.
 259              (org-find-base-buffer-visiting buffer-file)))))
 260     (if org-velocity-always-use-bucket
 261         (or org-velocity-bucket (error "Bucket required but not defined"))
 262       (if (and (eq (buffer-local-value 'major-mode (or buffer (current-buffer)))
 263                    'org-mode)
 264                (org-velocity-buffer-file-name))
 265           (org-velocity-buffer-file-name)
 266         (or org-velocity-bucket
 267             (error "No bucket and not an Org file"))))))
 268
 269 (defvar org-velocity-bucket-buffer nil)
 270 (defvar org-velocity-navigating nil)
 271
 272 (defsubst org-velocity-bucket-buffer ()
 273   (or org-velocity-bucket-buffer
 274       (find-file-noselect (org-velocity-bucket-file))))
 275
 276 (defsubst org-velocity-match-buffer ()
 277   "Return the proper buffer for Org-Velocity to display in."
 278   (get-buffer-create org-velocity-match-buffer-name))
 279
 280 (defsubst org-velocity-match-window ()
 281   (get-buffer-window (org-velocity-match-buffer)))
 282
 283 (defun org-velocity-beginning-of-headings ()
 284   "Goto the start of the first heading."
 285   (goto-char (point-min))
 286   ;; If we are before the first heading we could still be at the
 287   ;; first heading.
 288   (or (looking-at (org-velocity-heading-regexp))
 289       (re-search-forward (org-velocity-heading-regexp))))
 290
 291 (defun org-velocity-make-indirect-buffer (heading)
 292   "Make or switch to an indirect buffer visiting HEADING."
 293   (let* ((bucket (org-velocity-heading-buffer heading))
 294          (name (org-velocity-heading-name heading))
 295          (existing (get-buffer name)))
 296     (if (and existing (buffer-base-buffer existing)
 297              (equal (buffer-base-buffer existing) bucket))
 298         existing
 299       (make-indirect-buffer
 300        bucket
 301        (generate-new-buffer-name (org-velocity-heading-name heading))
 302        t))))
 303
 304 (defun org-velocity-capture ()
 305   "Record a note with `org-capture'."
 306   (let ((org-capture-templates
 307          org-velocity-capture-templates))
 308     (org-capture nil
 309                  ;; This is no longer automatically selected.
 310                  (when (null (cdr org-capture-templates))
 311                    (caar org-capture-templates)))
 312     (when org-capture-mode
 313       (rename-buffer org-velocity-search t))))
 314
 315 (defvar org-velocity-saved-winconf nil)
 316 (make-variable-buffer-local 'org-velocity-saved-winconf)
 317
 318 (defun org-velocity-edit-entry (heading)
 319   (if org-velocity-navigating
 320       (org-velocity-edit-entry/inline heading)
 321     (org-velocity-edit-entry/indirect heading)))
 322
 323 (cl-defun org-velocity-goto-entry (heading &key narrow)
 324   (goto-char (org-velocity-heading-position heading))
 325   (save-excursion
 326     (when narrow
 327       (org-narrow-to-subtree))
 328     (outline-show-all)))
 329
 330 (defun org-velocity-edit-entry/inline (heading)
 331   "Edit entry at HEADING in the original buffer."
 332   (let ((buffer (org-velocity-heading-buffer heading)))
 333     (pop-to-buffer buffer)
 334     (with-current-buffer buffer
 335       (org-velocity-goto-entry heading))))
 336
 337 (defun org-velocity-format-header-line (control-string &rest args)
 338   (set (make-local-variable 'header-line-format)
 339        (apply #'format control-string args)))
 340
 341 (defun org-velocity-edit-entry/indirect (heading)
 342   "Edit entry at HEADING in an indirect buffer."
 343   (let ((winconf (current-window-configuration))
 344         (dd default-directory)
 345         (buffer (org-velocity-make-indirect-buffer heading))
 346         (inhibit-point-motion-hooks t)
 347         (inhibit-field-text-motion t))
 348     (with-current-buffer buffer
 349       (setq default-directory dd)       ;Inherit default directory.
 350       (setq org-velocity-saved-winconf winconf)
 351       (org-velocity-goto-entry heading :narrow t)
 352       (goto-char (point-max))
 353       (add-hook 'org-ctrl-c-ctrl-c-hook 'org-velocity-dismiss nil t))
 354     (pop-to-buffer buffer)
 355     (org-velocity-format-header-line
 356      "%s Use C-c C-c to finish."
 357      (abbreviate-file-name
 358       (buffer-file-name
 359        (org-velocity-heading-buffer heading))))))
 360
 361 (defun org-velocity-dismiss ()
 362   "Save current entry and close indirect buffer."
 363   (let ((winconf org-velocity-saved-winconf))
 364     (prog1 t                            ;Tell hook we're done.
 365       (save-buffer)
 366       (kill-buffer)
 367       (when (window-configuration-p winconf)
 368         (set-window-configuration winconf)))))
 369
 370 (defun org-velocity-visit-button (button)
 371   (run-hooks 'mouse-leave-buffer-hook)
 372   (when org-velocity-use-search-ring
 373     (add-to-history 'search-ring
 374                     (button-get button 'search)
 375                     search-ring-max))
 376   (let ((match (button-get button 'match)))
 377     (throw 'org-velocity-done match)))
 378
 379 (define-button-type 'org-velocity-button
 380   'action #'org-velocity-visit-button
 381   'follow-link 'mouse-face)
 382
 383 (defsubst org-velocity-buttonize (heading)
 384   "Insert HEADING as a text button with no hints."
 385   (insert-text-button
 386    (propertize (org-velocity-heading-name heading) 'face 'link)
 387    :type 'org-velocity-button
 388    'match heading
 389    'search org-velocity-search))
 390
 391 (defsubst org-velocity-insert-preview (heading)
 392   (when org-velocity-show-previews
 393     (insert-char ?\  1)
 394     (insert
 395      (propertize
 396       (org-velocity-heading-preview heading)
 397       'face 'shadow))))
 398
 399 (defvar org-velocity-recursive-headings nil)
 400 (defvar org-velocity-recursive-search nil)
 401
 402 (cl-defun org-velocity-search-with (fun style search
 403                                         &key (headings org-velocity-recursive-headings))
 404   (if headings
 405       (save-restriction
 406         (dolist (heading headings)
 407           (widen)
 408           (let ((start (org-velocity-heading-position heading)))
 409             (goto-char start)
 410             (let ((end (save-excursion
 411                          (org-end-of-subtree)
 412                          (point))))
 413               (narrow-to-region start end)
 414               (org-velocity-search-with fun style search
 415                                         :headings nil)))))
 416     (cl-ecase style
 417       ((phrase any regexp)
 418        (cl-block nil
 419          (while (re-search-forward search nil t)
 420            (let ((match (org-velocity-nearest-heading (point))))
 421              (funcall fun match))
 422            ;; Skip to the next heading.
 423            (unless (re-search-forward (org-velocity-heading-regexp) nil t)
 424              (cl-return)))))
 425       ((all)
 426        (let ((keywords
 427               (cl-loop for word in (split-string search)
 428                        collect (concat "\\<" (regexp-quote word) "\\>"))))
 429          (org-map-entries
 430           (lambda ()
 431             ;; Only search the subtree once.
 432             (setq org-map-continue-from
 433                   (save-excursion
 434                     (org-end-of-subtree)
 435                     (point)))
 436             (when (cl-loop for word in keywords
 437                            always (save-excursion
 438                                     (re-search-forward word org-map-continue-from t)))
 439               (let ((match (org-velocity-nearest-heading (match-end 0))))
 440                 (funcall fun match))))))))))
 441
 442 (defun org-velocity-all-results (style search)
 443   (with-current-buffer (org-velocity-bucket-buffer)
 444     (save-excursion
 445       (goto-char (point-min))
 446       (let (matches)
 447         (org-velocity-search-with (lambda (match)
 448                                     (push match matches))
 449                                   style
 450                                   search)
 451         (nreverse matches)))))
 452
 453 (defsubst org-velocity-present-match (hint match)
 454   (with-current-buffer (org-velocity-match-buffer)
 455     (when hint (insert "#" hint " "))
 456     (org-velocity-buttonize match)
 457     (org-velocity-insert-preview match)
 458     (newline)))
 459
 460 (defun org-velocity-present-search (style search hide-hints)
 461   (let ((hints org-velocity-index) matches)
 462     (cl-block nil
 463       (org-velocity-search-with (lambda (match)
 464                                   (unless hints
 465                                     (cl-return))
 466                                   (let ((hint (if hide-hints
 467                                                   nil
 468                                                 (car hints))))
 469                                     (org-velocity-present-match hint match))
 470                                   (pop hints)
 471                                   (push match matches))
 472                                 style
 473                                 search))
 474     (nreverse matches)))
 475
 476 (defun org-velocity-restrict-search ()
 477   (interactive)
 478   (let ((search (org-velocity-nix-minibuffer)))
 479     (when (equal search "")
 480       (error "No search to restrict to"))
 481     (push search org-velocity-recursive-search)
 482     (setq org-velocity-recursive-headings
 483           (org-velocity-all-results
 484            org-velocity-search-method
 485            search))
 486     ;; TODO We could extend the current search instead of starting
 487     ;; over.
 488     (org-velocity-update-match-header)
 489     (minibuffer-message "Restricting search to %s" search)))
 490
 491 (cl-defun org-velocity-update-match-header (&key (match-buffer (org-velocity-match-buffer))
 492                                                  (bucket-buffer (org-velocity-bucket-buffer))
 493                                                  (search-method org-velocity-search-method))
 494   (let ((navigating? org-velocity-navigating)
 495         (recursive? org-velocity-recursive-search))
 496     (with-current-buffer match-buffer
 497       (org-velocity-format-header-line
 498        "%s search in %s%s (%s mode)"
 499        (capitalize (symbol-name search-method))
 500        (abbreviate-file-name (buffer-file-name bucket-buffer))
 501        (if (not recursive?)
 502            ""
 503          (let ((sep " > "))
 504            (concat sep (string-join (reverse recursive?) sep))))
 505        (if navigating? "nav" "notes")))))
 506
 507 (cl-defun org-velocity-present (search &key hide-hints)
 508   "Buttonize matches for SEARCH in `org-velocity-match-buffer'.
 509 If HIDE-HINTS is non-nil, display entries without indices. SEARCH
 510 binds `org-velocity-search'.
 511
 512 Return matches."
 513   (let ((match-buffer (org-velocity-match-buffer))
 514         (bucket-buffer (org-velocity-bucket-buffer))
 515         (search-method org-velocity-search-method))
 516     (if (and (stringp search) (not (string= "" search)))
 517         ;; Fold case when the search string is all lowercase.
 518         (let ((case-fold-search (equal search (downcase search)))
 519               (truncate-partial-width-windows t))
 520           (with-current-buffer match-buffer
 521             (erase-buffer)
 522             ;; Permanent locals.
 523             (setq cursor-type nil
 524                   truncate-lines t)
 525             (org-velocity-update-match-header
 526              :match-buffer match-buffer
 527              :bucket-buffer bucket-buffer
 528              :search-method search-method))
 529           (prog1
 530               (with-current-buffer bucket-buffer
 531                 (widen)
 532                 (let* ((inhibit-point-motion-hooks t)
 533                        (inhibit-field-text-motion t)
 534                        (anchored? (string-match-p "^\\s-" search))
 535                        (search
 536                         (cl-ecase search-method
 537                           (all search)
 538                           (phrase
 539                            (if anchored?
 540                                (regexp-quote search)
 541                              ;; Anchor the search to the start of a word.
 542                              (concat "\\<" (regexp-quote search))))
 543                           (any
 544                            (concat "\\<" (regexp-opt (split-string search))))
 545                           (regexp search))))
 546                   (save-excursion
 547                     (org-velocity-beginning-of-headings)
 548                     (condition-case lossage
 549                         (org-velocity-present-search search-method search hide-hints)
 550                       (invalid-regexp
 551                        (minibuffer-message "%s" lossage))))))
 552             (with-current-buffer match-buffer
 553               (goto-char (point-min)))))
 554       (with-current-buffer match-buffer
 555         (erase-buffer)))))
 556
 557 (defun org-velocity-store-link ()
 558   "Function for `org-store-link-functions'."
 559   (if org-velocity-search
 560       (org-store-link-props
 561        :search org-velocity-search)))
 562
 563 (add-hook 'org-store-link-functions 'org-velocity-store-link)
 564
 565 (cl-defun org-velocity-create (search &key ask)
 566   "Create new heading named SEARCH.
 567 If ASK is non-nil, ask first."
 568   (when (or (null ask) (y-or-n-p "No match found, create? "))
 569     (let ((org-velocity-search search)
 570           (org-default-notes-file (org-velocity-bucket-file))
 571           ;; save a stored link
 572           org-store-link-plist)
 573       (org-velocity-capture))
 574     search))
 575
 576 (defun org-velocity-engine (search)
 577   "Display a list of headings where SEARCH occurs."
 578   (let ((org-velocity-search search))
 579     (unless (or
 580              (not (stringp search))
 581              (string= "" search))       ;exit on empty string
 582       (cl-case
 583           (if (and org-velocity-force-new (eq last-command-event ?\C-j))
 584               :force
 585             (let* ((org-velocity-index (org-velocity-adjust-index))
 586                    (matches (org-velocity-present search)))
 587               (cond ((null matches) :new)
 588                     ((null (cdr matches)) :follow)
 589                     (t :prompt))))
 590         (:prompt (progn
 591                    (pop-to-buffer (org-velocity-match-buffer))
 592                    (let ((hint (org-velocity-electric-read-hint)))
 593                      (when hint (cl-case hint
 594                                   (:edit (org-velocity-read nil search))
 595                                   (:force (org-velocity-create search))
 596                                   (otherwise (org-velocity-activate-button hint)))))))
 597         (:new (unless (org-velocity-create search :ask t)
 598                 (org-velocity-read nil search)))
 599         (:force (org-velocity-create search))
 600         (:follow (if (y-or-n-p "One match, follow? ")
 601                      (progn
 602                        (set-buffer (org-velocity-match-buffer))
 603                        (goto-char (point-min))
 604                        (button-activate (next-button (point))))
 605                    (org-velocity-read nil search)))))))
 606
 607 (defun org-velocity-activate-button (char)
 608   "Go to button on line number associated with CHAR in `org-velocity-index'."
 609   (goto-char (point-min))
 610   (forward-line (cl-position char org-velocity-index))
 611   (goto-char
 612    (button-start
 613     (next-button (point))))
 614   (message "%s" (button-label (button-at (point))))
 615   (button-activate (button-at (point))))
 616
 617 (defun org-velocity-electric-undefined ()
 618   "Complain about an undefined key."
 619   (interactive)
 620   (message "%s"
 621            (substitute-command-keys
 622             "\\[org-velocity-electric-new] for new entry,
 623 \\[org-velocity-electric-edit] to edit search,
 624 \\[scroll-up] to scroll up,
 625 \\[scroll-down] to scroll down,
 626 \\[keyboard-quit] to quit."))
 627   (sit-for 4))
 628
 629 (defun org-velocity-electric-follow (ev)
 630   "Follow a hint indexed by keyboard event EV."
 631   (interactive (list last-command-event))
 632   (if (not (> (cl-position ev org-velocity-index)
 633               (1- (count-lines (point-min) (point-max)))))
 634       (throw 'org-velocity-select ev)
 635     (call-interactively 'org-velocity-electric-undefined)))
 636
 637 (defun org-velocity-electric-edit ()
 638   "Edit the search string."
 639   (interactive)
 640   (throw 'org-velocity-select :edit))
 641
 642 (defun org-velocity-electric-new ()
 643   "Force a new entry."
 644   (interactive)
 645   (throw 'org-velocity-select :force))
 646
 647 (defvar org-velocity-electric-map
 648   (let ((map (make-sparse-keymap)))
 649     (define-key map [t] 'org-velocity-electric-undefined)
 650     (dolist (c org-velocity-index)
 651       (define-key map (char-to-string c)
 652         'org-velocity-electric-follow))
 653     (define-key map "0" 'org-velocity-electric-new)
 654     (define-key map "\C-v" 'scroll-up)
 655     (define-key map "\M-v" 'scroll-down)
 656     (define-key map (kbd "RET") 'org-velocity-electric-edit)
 657     (define-key map [mouse-1] nil)
 658     (define-key map [mouse-2] nil)
 659     (define-key map [escape] 'keyboard-quit)
 660     (define-key map "\C-h" 'help-command)
 661     map))
 662
 663 (defun org-velocity-electric-read-hint ()
 664   "Read index of button electrically."
 665   (with-current-buffer (org-velocity-match-buffer)
 666     (when (featurep 'evil)
 667       ;; NB Idempotent.
 668       (evil-make-overriding-map org-velocity-electric-map))
 669     (use-local-map org-velocity-electric-map)
 670     (catch 'org-velocity-select
 671       (Electric-command-loop 'org-velocity-select "Follow: "))))
 672
 673 (defvar org-velocity-incremental-keymap
 674   (let ((map (make-sparse-keymap)))
 675     (define-key map "\C-v" 'scroll-up)
 676     (define-key map "\M-v" 'scroll-down)
 677     map))
 678
 679 (defun org-velocity-displaying-completions-p ()
 680   "Is there a *Completions* buffer showing?"
 681   (get-window-with-predicate
 682    (lambda (w)
 683      (eq (buffer-local-value 'major-mode (window-buffer w))
 684          'completion-list-mode))))
 685
 686 (defun org-velocity-update ()
 687   "Display results of search without hinting."
 688   (unless (org-velocity-displaying-completions-p)
 689     (let* ((search (org-velocity-minibuffer-contents))
 690            (matches (org-velocity-present search :hide-hints t)))
 691       (cond ((null matches)
 692              (select-window (active-minibuffer-window))
 693              (unless (or (null search) (= (length search) 0))
 694                (minibuffer-message "No match; RET to create")))
 695             ((and (null (cdr matches))
 696                   org-velocity-exit-on-match)
 697              (throw 'click search))
 698             (t
 699              (with-current-buffer (org-velocity-match-buffer)
 700                (use-local-map org-velocity-incremental-keymap)))))))
 701
 702 (defvar dabbrev--last-abbreviation)
 703
 704 (defun org-velocity-dabbrev-completion-list (abbrev)
 705   "Return all dabbrev completions for ABBREV."
 706   ;; This is based on `dabbrev-completion'.
 707   (dabbrev--reset-global-variables)
 708   (setq dabbrev--last-abbreviation abbrev)
 709   (dabbrev--find-all-expansions abbrev case-fold-search))
 710
 711 (defvar org-velocity-local-completion-map
 712   (let ((map (make-sparse-keymap)))
 713     (set-keymap-parent map minibuffer-local-completion-map)
 714     (define-key map " " 'self-insert-command)
 715     (define-key map "?" 'self-insert-command)
 716     (define-key map [remap minibuffer-complete] 'minibuffer-complete-word)
 717     (define-key map [(control ?@)] 'org-velocity-restrict-search)
 718     (define-key map [(control ?\s)] 'org-velocity-restrict-search)
 719     map)
 720   "Keymap for completion with `completing-read'.")
 721
 722 (defun org-velocity-read-with-completion (prompt)
 723   "Completing read with PROMPT."
 724   (let ((minibuffer-local-completion-map
 725          org-velocity-local-completion-map)
 726         (completion-no-auto-exit t)
 727         (crm-separator " "))
 728     (completing-read prompt
 729                      (completion-table-dynamic
 730                       'org-velocity-dabbrev-completion-list))))
 731
 732 (cl-defun org-velocity-adjust-index
 733     (&optional (match-window (org-velocity-match-window)))
 734   "Truncate or extend `org-velocity-index' to the lines in
 735 MATCH-WINDOW."
 736   (with-selected-window match-window
 737     (let ((lines (window-height))
 738           (hints (length org-velocity-index)))
 739       (cond ((= lines hints)
 740              org-velocity-index)
 741             ;; Truncate the index to the size of
 742             ;; the buffer to be displayed.
 743             ((< lines hints)
 744              (cl-subseq org-velocity-index 0 lines))
 745             ;; If the window is so tall we run out of indices, at
 746             ;; least make the additional results clickable.
 747             ((> lines hints)
 748              (append org-velocity-index
 749                      (make-list (- lines hints) nil)))))))
 750
 751 (defun org-velocity-incremental-read (prompt)
 752   "Read string with PROMPT and display results incrementally.
 753 Stop searching once there are more matches than can be
 754 displayed."
 755   (let ((res
 756          (unwind-protect
 757              (let* ((match-window (display-buffer (org-velocity-match-buffer)))
 758                     (org-velocity-index (org-velocity-adjust-index match-window)))
 759                (catch 'click
 760                  (add-hook 'post-command-hook 'org-velocity-update)
 761                  (cond ((eq org-velocity-search-method 'regexp)
 762                         (read-regexp prompt))
 763                        (org-velocity-use-completion
 764                         (org-velocity-read-with-completion prompt))
 765                        (t (read-string prompt)))))
 766            (remove-hook 'post-command-hook 'org-velocity-update))))
 767     (if (bufferp res) (org-pop-to-buffer-same-window res) res)))
 768
 769 (defun org-velocity (arg &optional search)
 770   "Read a search string SEARCH for Org-Velocity interface.
 771 This means that a buffer will display all headings where SEARCH
 772 occurs, where one can be selected by a mouse click or by typing
 773 its index.  If SEARCH does not occur, then a new heading may be
 774 created named SEARCH.
 775
 776 If `org-velocity-bucket' is defined and
 777 `org-velocity-always-use-bucket' is non-nil, then the bucket file
 778 will be used; otherwise, this will work when called in any Org
 779 file.
 780
 781 Calling with ARG reverses which file – the current file or the
 782 bucket file – to use. If the bucket file would have been used,
 783 then the current file is used instead, and vice versa."
 784   (interactive "P")
 785   (let ((org-velocity-always-use-bucket
 786          (if org-velocity-always-use-bucket
 787              (not arg)
 788            arg)))
 789     ;; complain if inappropriate
 790     (cl-assert (org-velocity-bucket-file))
 791     (let* ((starting-buffer (current-buffer))
 792            (org-velocity-bucket-buffer
 793             (find-file-noselect (org-velocity-bucket-file)))
 794            (org-velocity-navigating
 795             (eq starting-buffer org-velocity-bucket-buffer))
 796            (org-velocity-recursive-headings '())
 797            (org-velocity-recursive-search '())
 798            (org-velocity-heading-level
 799             (if org-velocity-navigating
 800                 0
 801               org-velocity-heading-level))
 802            (dabbrev-search-these-buffers-only
 803             (list org-velocity-bucket-buffer)))
 804       (unwind-protect
 805           (let ((match
 806                  (catch 'org-velocity-done
 807                    (org-velocity-engine
 808                     (or search
 809                         (org-velocity-incremental-read "Velocity search: ")))
 810                    nil)))
 811             (when (org-velocity-heading-p match)
 812               (org-velocity-edit-entry match)))
 813         (kill-buffer (org-velocity-match-buffer))))))
 814
 815 (defalias 'org-velocity-read 'org-velocity)
 816
 817 (provide 'org-velocity)
 818
 819 ;;; org-velocity.el ends here