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.0
   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-search-is-incremental t
  82   "Show results incrementally when possible?"
  83   :group 'org-velocity
  84   :type 'boolean
  85   :safe 'booleanp)
  86
  87 (defcustom org-velocity-show-previews t
  88   "Show previews of the text of each heading?"
  89   :group 'velocity
  90   :type 'boolean
  91   :safe 'booleanp)
  92
  93 (defcustom org-velocity-exit-on-match nil
  94   "When searching incrementally, exit on a single match?"
  95   :group 'org-velocity
  96   :type 'boolean
  97   :safe 'booleanp)
  98
  99 (defcustom org-velocity-force-new nil
 100   "Should exiting the minibuffer with C-j force a new entry?"
 101   :group 'org-velocity
 102   :type 'boolean
 103   :safe 'booleanp)
 104
 105 (defcustom org-velocity-use-search-ring t
 106   "Push search to `search-ring' when visiting an entry?
 107
 108 This means that C-s C-s will take you directly to the first
 109 instance of the search string."
 110   :group 'org-velocity
 111   :type 'boolean
 112   :safe 'booleanp)
 113
 114 (defcustom org-velocity-always-use-bucket nil
 115   "Use bucket file even when called from an Org buffer?"
 116   :group 'org-velocity
 117   :type 'boolean
 118   :safe 'booleanp)
 119
 120 (defcustom org-velocity-use-completion nil
 121   "Use completion?
 122
 123 Notwithstanding the value of this option, calling
 124 `dabbrev-expand' always completes against the text of the bucket
 125 file."
 126   :group 'org-velocity
 127   :type '(choice
 128           (const :tag "Do not use completion" nil)
 129           (const :tag "Use completion" t))
 130   :safe 'booleanp)
 131
 132 (defcustom org-velocity-search-method 'phrase
 133   "Match on whole phrase, any word, or all words?"
 134   :group 'org-velocity
 135   :type '(choice
 136           (const :tag "Match whole phrase" phrase)
 137           (const :tag "Match any word" any)
 138           (const :tag "Match all words" all)
 139           (const :tag "Match a regular expression" regexp))
 140   :safe (lambda (v) (memq v '(phrase any all regexp))))
 141
 142 (defcustom org-velocity-capture-templates
 143   '(("v"
 144      "Velocity entry"
 145      entry
 146      (file "")
 147      "* %:search\n\n%i%?"))
 148   "Use these template with `org-capture'.
 149 Meanwhile `org-default-notes-file' is bound to `org-velocity-bucket-file'.
 150 The keyword :search inserts the current search.
 151 See the documentation for `org-capture-templates'."
 152   :group 'org-velocity
 153   :type (or (get 'org-capture-templates 'custom-type) 'list))
 154
 155 (defcustom org-velocity-heading-level 1
 156   "Only match headings at this level or higher.
 157 0 means to match headings at any level."
 158   :group 'org-velocity
 159   :type 'integer
 160   :safe (lambda (x)
 161           (and (integerp x)
 162                (>= x 0))))
 163
 164 (defvar crm-separator)                  ;Ensure dynamic binding.
 165
 166 (defsubst org-velocity-grab-preview ()
 167   "Grab preview of a subtree.
 168 The length of the preview is determined by `window-width'.
 169
 170 Replace all contiguous whitespace with single spaces."
 171   (let ((start (progn
 172                  (forward-line 1)
 173                  (if (looking-at org-property-start-re)
 174                      (re-search-forward org-property-end-re)
 175                    (1- (point))))))
 176     (mapconcat
 177      #'identity
 178      (split-string
 179       (buffer-substring-no-properties
 180        start
 181        (min
 182         (+ start (window-width))
 183         (point-max))))
 184      " ")))
 185
 186 (cl-defstruct org-velocity-heading buffer position name level preview)
 187
 188 (defsubst org-velocity-nearest-heading (position)
 189   "Return last heading at POSITION.
 190 If there is no last heading, return nil."
 191   (save-excursion
 192     (goto-char position)
 193     (re-search-backward (org-velocity-heading-regexp))
 194     (let ((components (org-heading-components)))
 195       (make-org-velocity-heading
 196        :buffer (current-buffer)
 197        :position (point)
 198        :name (nth 4 components)
 199        :level (nth 0 components)
 200        :preview (if org-velocity-show-previews
 201                     (org-velocity-grab-preview))))))
 202
 203 (defconst org-velocity-index
 204   (eval-when-compile
 205     (nconc (number-sequence 49 57)      ;numbers
 206            (number-sequence 97 122)     ;lowercase letters
 207            (number-sequence 65 90)))    ;uppercase letters
 208   "List of chars for indexing results.")
 209
 210 (defconst org-velocity-match-buffer-name "*Velocity matches*")
 211
 212 (cl-defun org-velocity-heading-regexp (&optional (level org-velocity-heading-level))
 213   "Regexp to match headings at LEVEL or deeper."
 214   (if (zerop level)
 215       "^\\*+ "
 216     (format "^\\*\\{1,%d\\} " level)))
 217
 218 (defvar org-velocity-search nil
 219   "Variable to bind to current search.")
 220
 221 (defun org-velocity-buffer-file-name (&optional buffer)
 222   "Return the name of the file BUFFER saves to.
 223 Same as function `buffer-file-name' unless BUFFER is an indirect
 224 buffer or a minibuffer. In the former case, return the file name
 225 of the base buffer; in the latter, return the file name of
 226 `minibuffer-selected-window' (or its base buffer)."
 227   (let ((buffer (if (minibufferp buffer)
 228                     (window-buffer (minibuffer-selected-window))
 229                   buffer)))
 230     (buffer-file-name
 231      (or (buffer-base-buffer buffer)
 232          buffer))))
 233
 234 (defun org-velocity-minibuffer-contents ()
 235   "Return the contents of the minibuffer when it is active."
 236   (if (active-minibuffer-window)
 237       (with-current-buffer (window-buffer (active-minibuffer-window))
 238         (minibuffer-contents))))
 239
 240 (defun org-velocity-bucket-file ()
 241   "Return the proper file for Org-Velocity to search.
 242 If `org-velocity-always-use-bucket' is t, use bucket file;
 243 complain if missing. Otherwise, if an Org file is current, then
 244 use it."
 245   (let ((org-velocity-bucket
 246          (when org-velocity-bucket (expand-file-name org-velocity-bucket)))
 247         (buffer
 248          (let ((buffer-file (org-velocity-buffer-file-name)))
 249            (when buffer-file
 250              ;; Use the target in capture buffers.
 251              (org-find-base-buffer-visiting buffer-file)))))
 252     (if org-velocity-always-use-bucket
 253         (or org-velocity-bucket (error "Bucket required but not defined"))
 254       (if (and (eq (buffer-local-value 'major-mode (or buffer (current-buffer)))
 255                    'org-mode)
 256                (org-velocity-buffer-file-name))
 257           (org-velocity-buffer-file-name)
 258         (or org-velocity-bucket
 259             (error "No bucket and not an Org file"))))))
 260
 261 (defvar org-velocity-bucket-buffer nil)
 262
 263 (defsubst org-velocity-bucket-buffer ()
 264   (or org-velocity-bucket-buffer
 265       (find-file-noselect (org-velocity-bucket-file))))
 266
 267 (defsubst org-velocity-match-buffer ()
 268   "Return the proper buffer for Org-Velocity to display in."
 269   (get-buffer-create org-velocity-match-buffer-name))
 270
 271 (defsubst org-velocity-match-window ()
 272   (get-buffer-window (org-velocity-match-buffer)))
 273
 274 (defsubst org-velocity-match-staging-buffer ()
 275   (get-buffer-create " Velocity matches"))
 276
 277 (defun org-velocity-beginning-of-headings ()
 278   "Goto the start of the first heading."
 279   (goto-char (point-min))
 280   ;; If we are before the first heading we could still be at the
 281   ;; first heading.
 282   (or (looking-at (org-velocity-heading-regexp))
 283       (re-search-forward (org-velocity-heading-regexp))))
 284
 285 (defun org-velocity-make-indirect-buffer (heading)
 286   "Make or switch to an indirect buffer visiting HEADING."
 287   (let* ((bucket (org-velocity-heading-buffer heading))
 288          (name (org-velocity-heading-name heading))
 289          (existing (get-buffer name)))
 290     (if (and existing (buffer-base-buffer existing)
 291              (equal (buffer-base-buffer existing) bucket))
 292         existing
 293       (make-indirect-buffer
 294        bucket
 295        (generate-new-buffer-name (org-velocity-heading-name heading))
 296        t))))
 297
 298 (defun org-velocity-capture ()
 299   "Record a note with `org-capture'."
 300   (let ((org-capture-templates
 301          org-velocity-capture-templates))
 302     (org-capture nil
 303                  ;; This is no longer automatically selected.
 304                  (when (null (cdr org-capture-templates))
 305                    (caar org-capture-templates)))
 306     (when org-capture-mode
 307       (rename-buffer org-velocity-search t))))
 308
 309 (defvar org-velocity-saved-winconf nil)
 310 (make-variable-buffer-local 'org-velocity-saved-winconf)
 311
 312 (defun org-velocity-edit-entry (heading)
 313   "Edit entry at HEADING in an indirect buffer."
 314   (let ((winconf (current-window-configuration))
 315         (buffer (org-velocity-make-indirect-buffer heading))
 316         (inhibit-point-motion-hooks t)
 317         (inhibit-field-text-motion t))
 318     (with-current-buffer buffer
 319       (setq org-velocity-saved-winconf winconf)
 320       (goto-char (org-velocity-heading-position heading))
 321       (let ((start (point))
 322             (end (save-excursion
 323                    (org-end-of-subtree t)
 324                    (point))))
 325         ;; Outline view and narrow-to-region interact poorly.
 326         (outline-flag-region start end nil)
 327         (narrow-to-region start end))
 328       (goto-char (point-max))
 329       (add-hook 'org-ctrl-c-ctrl-c-hook 'org-velocity-dismiss nil t))
 330     (pop-to-buffer buffer)
 331     (set (make-local-variable 'header-line-format)
 332          (format "%s Use C-c C-c to finish."
 333                  (abbreviate-file-name
 334                   (buffer-file-name
 335                    (org-velocity-heading-buffer heading)))))))
 336
 337 (defun org-velocity-dismiss ()
 338   "Save current entry and close indirect buffer."
 339   (let ((winconf org-velocity-saved-winconf))
 340     (prog1 t                            ;Tell hook we're done.
 341       (save-buffer)
 342       (kill-buffer)
 343       (when (window-configuration-p winconf)
 344         (set-window-configuration winconf)))))
 345
 346 (defun org-velocity-visit-button (button)
 347   (run-hooks 'mouse-leave-buffer-hook)
 348   (when org-velocity-use-search-ring
 349     (add-to-history 'search-ring
 350                     (button-get button 'search)
 351                     search-ring-max))
 352   (let ((match (button-get button 'match)))
 353     (throw 'org-velocity-done
 354            (lambda ()
 355              (org-velocity-edit-entry match)))))
 356
 357 (define-button-type 'org-velocity-button
 358   'action #'org-velocity-visit-button
 359   'follow-link 'mouse-face)
 360
 361 (defsubst org-velocity-buttonize (heading)
 362   "Insert HEADING as a text button with no hints."
 363   (insert-text-button
 364    (propertize (org-velocity-heading-name heading) 'face 'link)
 365    :type 'org-velocity-button
 366    'match heading
 367    'search org-velocity-search))
 368
 369 (defsubst org-velocity-insert-preview (heading)
 370   (when org-velocity-show-previews
 371     (insert-char ?\  1)
 372     (insert
 373      (propertize
 374       (org-velocity-heading-preview heading)
 375       'face 'shadow))))
 376
 377 (defsubst org-velocity-present-match (hint match)
 378   (with-current-buffer (org-velocity-match-staging-buffer)
 379     (when hint (insert "#" hint " "))
 380     (org-velocity-buttonize match)
 381     (org-velocity-insert-preview match)
 382     (newline)))
 383
 384 (defun org-velocity-generic-search (search &optional hide-hints)
 385   "Display any entry containing SEARCH."
 386   (let ((hints org-velocity-index) matches)
 387     (cl-block nil
 388       (while (and hints (re-search-forward search nil t))
 389         (let ((match (org-velocity-nearest-heading (point))))
 390           (org-velocity-present-match
 391            (unless hide-hints (car hints))
 392            match)
 393           (push match matches))
 394         (setq hints (cdr hints))
 395         (unless (re-search-forward (org-velocity-heading-regexp) nil t)
 396           (return))))
 397     (nreverse matches)))
 398
 399 (cl-defun org-velocity-all-search (search &optional hide-hints)
 400   "Display only entries containing every word in SEARCH."
 401   (let ((keywords (mapcar 'regexp-quote (split-string search)))
 402         (hints org-velocity-index)
 403         matches)
 404     (org-map-entries
 405      (lambda ()
 406        ;; Return if we've run out of hints.
 407        (when (null hints)
 408          (return-from org-velocity-all-search (nreverse matches)))
 409        ;; Only search the subtree once.
 410        (setq org-map-continue-from
 411              (save-excursion
 412                (goto-char (line-end-position))
 413                (if (re-search-forward (org-velocity-heading-regexp) nil t)
 414                    (line-end-position)
 415                  (point-max))))
 416        (when (cl-loop for word in keywords
 417                       always (save-excursion
 418                                (re-search-forward
 419                                 (concat "\\<" word "\\>")
 420                                 org-map-continue-from t)))
 421          (let ((match (org-velocity-nearest-heading (match-end 0))))
 422            (org-velocity-present-match
 423             (unless hide-hints (car hints))
 424             match)
 425            (push match matches)
 426            (setq hints (cdr hints))))))
 427     (nreverse matches)))
 428
 429 (cl-defun org-velocity-present (search &key hide-hints)
 430   "Buttonize matches for SEARCH in `org-velocity-match-buffer'.
 431 If HIDE-HINTS is non-nil, display entries without indices. SEARCH
 432 binds `org-velocity-search'.
 433
 434 Return matches."
 435   (if (and (stringp search) (not (string= "" search)))
 436       ;; Fold case when the search string is all lowercase.
 437       (let ((case-fold-search (equal search (downcase search)))
 438             (truncate-partial-width-windows t))
 439         (with-current-buffer (org-velocity-match-buffer)
 440           (erase-buffer)
 441           ;; Permanent locals.
 442           (setq cursor-type nil
 443                 truncate-lines t))
 444         (prog1
 445             (with-current-buffer (org-velocity-bucket-buffer)
 446               (let ((inhibit-point-motion-hooks t)
 447                     (inhibit-field-text-motion t))
 448                 (save-excursion
 449                   (org-velocity-beginning-of-headings)
 450                   (cl-case org-velocity-search-method
 451                     (all (org-velocity-all-search search hide-hints))
 452                     (phrase (org-velocity-generic-search
 453                              (concat "\\<" (regexp-quote search))
 454                              hide-hints))
 455                     (any (org-velocity-generic-search
 456                           (concat "\\<"
 457                                   (regexp-opt (split-string search)))
 458                           hide-hints))
 459                     (regexp (condition-case lossage
 460                                 (org-velocity-generic-search
 461                                  search hide-hints)
 462                               (invalid-regexp
 463                                (minibuffer-message "%s" lossage))))))))
 464           (with-current-buffer (org-velocity-match-buffer)
 465             (buffer-swap-text (org-velocity-match-staging-buffer))
 466             (goto-char (point-min)))))
 467     (with-current-buffer (org-velocity-match-buffer)
 468       (erase-buffer))))
 469
 470 (defun org-velocity-store-link ()
 471   "Function for `org-store-link-functions'."
 472   (if org-velocity-search
 473       (org-store-link-props
 474        :search org-velocity-search)))
 475
 476 (add-hook 'org-store-link-functions 'org-velocity-store-link)
 477
 478 (cl-defun org-velocity-create (search &key ask)
 479   "Create new heading named SEARCH.
 480 If ASK is non-nil, ask first."
 481   (when (or (null ask) (y-or-n-p "No match found, create? "))
 482     (let ((org-velocity-search search)
 483           (org-default-notes-file (org-velocity-bucket-file))
 484           ;; save a stored link
 485           org-store-link-plist)
 486       (org-velocity-capture))
 487     search))
 488
 489 (defun org-velocity-engine (search)
 490   "Display a list of headings where SEARCH occurs."
 491   (let ((org-velocity-search search))
 492     (unless (or
 493              (not (stringp search))
 494              (string= "" search))       ;exit on empty string
 495       (cl-case
 496           (if (and org-velocity-force-new (eq last-command-event ?\C-j))
 497               :force
 498             (let* ((org-velocity-index (org-velocity-adjust-index))
 499                    (matches (org-velocity-present search)))
 500               (cond ((null matches) :new)
 501                     ((null (cdr matches)) :follow)
 502                     (t :prompt))))
 503         (:prompt (progn
 504                    (pop-to-buffer (org-velocity-match-buffer))
 505                    (let ((hint (org-velocity-electric-read-hint)))
 506                      (when hint (cl-case hint
 507                                   (:edit (org-velocity-read nil search))
 508                                   (:force (org-velocity-create search))
 509                                   (otherwise (org-velocity-activate-button hint)))))))
 510         (:new (unless (org-velocity-create search :ask t)
 511                 (org-velocity-read nil search)))
 512         (:force (org-velocity-create search))
 513         (:follow (if (y-or-n-p "One match, follow? ")
 514                      (progn
 515                        (set-buffer (org-velocity-match-buffer))
 516                        (goto-char (point-min))
 517                        (button-activate (next-button (point))))
 518                    (org-velocity-read nil search)))))))
 519
 520 (defun org-velocity-activate-button (char)
 521   "Go to button on line number associated with CHAR in `org-velocity-index'."
 522   (goto-char (point-min))
 523   (forward-line (cl-position char org-velocity-index))
 524   (goto-char
 525    (button-start
 526     (next-button (point))))
 527   (message "%s" (button-label (button-at (point))))
 528   (button-activate (button-at (point))))
 529
 530 (defun org-velocity-electric-undefined ()
 531   "Complain about an undefined key."
 532   (interactive)
 533   (message "%s"
 534            (substitute-command-keys
 535             "\\[org-velocity-electric-new] for new entry,
 536 \\[org-velocity-electric-edit] to edit search,
 537 \\[scroll-up] to scroll up,
 538 \\[scroll-down] to scroll down,
 539 \\[keyboard-quit] to quit."))
 540   (sit-for 4))
 541
 542 (defun org-velocity-electric-follow (ev)
 543   "Follow a hint indexed by keyboard event EV."
 544   (interactive (list last-command-event))
 545   (if (not (> (cl-position ev org-velocity-index)
 546               (1- (count-lines (point-min) (point-max)))))
 547       (throw 'org-velocity-select ev)
 548     (call-interactively 'org-velocity-electric-undefined)))
 549
 550 (defun org-velocity-electric-edit ()
 551   "Edit the search string."
 552   (interactive)
 553   (throw 'org-velocity-select :edit))
 554
 555 (defun org-velocity-electric-new ()
 556   "Force a new entry."
 557   (interactive)
 558   (throw 'org-velocity-select :force))
 559
 560 (defvar org-velocity-electric-map
 561   (let ((map (make-sparse-keymap)))
 562     (define-key map [t] 'org-velocity-electric-undefined)
 563     (dolist (c org-velocity-index)
 564       (define-key map (char-to-string c)
 565         'org-velocity-electric-follow))
 566     (define-key map "0" 'org-velocity-electric-new)
 567     (define-key map "\C-v" 'scroll-up)
 568     (define-key map "\M-v" 'scroll-down)
 569     (define-key map (kbd "RET") 'org-velocity-electric-edit)
 570     (define-key map [mouse-1] nil)
 571     (define-key map [mouse-2] nil)
 572     (define-key map [escape] 'keyboard-quit)
 573     (define-key map "\C-h" 'help-command)
 574     map))
 575
 576 (defun org-velocity-electric-read-hint ()
 577   "Read index of button electrically."
 578   (with-current-buffer (org-velocity-match-buffer)
 579     (when (featurep 'evil)
 580       ;; NB Idempotent.
 581       (evil-make-overriding-map org-velocity-electric-map))
 582     (use-local-map org-velocity-electric-map)
 583     (catch 'org-velocity-select
 584       (Electric-command-loop 'org-velocity-select "Follow: "))))
 585
 586 (defvar org-velocity-incremental-keymap
 587   (let ((map (make-sparse-keymap)))
 588     (define-key map "\C-v" 'scroll-up)
 589     (define-key map "\M-v" 'scroll-down)
 590     map))
 591
 592 (defun org-velocity-displaying-completions-p ()
 593   "Is there a *Completions* buffer showing?"
 594   (get-window-with-predicate
 595    (lambda (w)
 596      (eq (buffer-local-value 'major-mode (window-buffer w))
 597          'completion-list-mode))))
 598
 599 (defun org-velocity-update ()
 600   "Display results of search without hinting."
 601   (unless (org-velocity-displaying-completions-p)
 602     (let* ((search (org-velocity-minibuffer-contents))
 603            (matches (org-velocity-present search :hide-hints t)))
 604       (cond ((null matches)
 605              (select-window (active-minibuffer-window))
 606              (unless (or (null search) (string= "" search))
 607                (minibuffer-message "No match; RET to create")))
 608             ((and (null (cdr matches))
 609                   org-velocity-exit-on-match)
 610              (throw 'click search))
 611             (t
 612              (with-current-buffer (org-velocity-match-buffer)
 613                (use-local-map org-velocity-incremental-keymap)))))))
 614
 615 (defvar dabbrev--last-abbreviation)
 616
 617 (defun org-velocity-dabbrev-completion-list (abbrev)
 618   "Return all dabbrev completions for ABBREV."
 619   ;; This is based on `dabbrev-completion'.
 620   (dabbrev--reset-global-variables)
 621   (setq dabbrev--last-abbreviation abbrev)
 622   (dabbrev--find-all-expansions abbrev case-fold-search))
 623
 624 (defvar org-velocity-local-completion-map
 625   (let ((map (make-sparse-keymap)))
 626     (set-keymap-parent map minibuffer-local-completion-map)
 627     (define-key map " " 'self-insert-command)
 628     (define-key map [remap minibuffer-complete] 'minibuffer-complete-word)
 629     map)
 630   "Keymap for completion with `completing-read'.")
 631
 632 (defun org-velocity-read-with-completion (prompt)
 633   "Completing read with PROMPT."
 634   (let ((minibuffer-local-completion-map
 635          org-velocity-local-completion-map)
 636         (completion-no-auto-exit t)
 637         (crm-separator " "))
 638     (funcall
 639      (cl-case org-velocity-search-method
 640        (phrase #'completing-read)
 641        (any    #'completing-read-multiple)
 642        (all    #'completing-read-multiple))
 643      prompt
 644      (completion-table-dynamic
 645       'org-velocity-dabbrev-completion-list))))
 646
 647 (defun org-velocity-read-string (prompt &optional initial-input)
 648   "Read string with PROMPT followed by INITIAL-INPUT."
 649   ;; The use of initial inputs to the minibuffer is deprecated (see
 650   ;; `read-from-minibuffer'), but in this case it is the user-friendly
 651   ;; thing to do.
 652   (minibuffer-with-setup-hook
 653       (let ((initial-input initial-input))
 654         (lambda ()
 655           (and initial-input (insert initial-input))
 656           (goto-char (point-max))))
 657     (if (eq org-velocity-search-method 'regexp)
 658         (read-regexp prompt)
 659       (if org-velocity-use-completion
 660           (org-velocity-read-with-completion prompt)
 661         (read-string prompt)))))
 662
 663 (cl-defun org-velocity-adjust-index
 664     (&optional (match-window (org-velocity-match-window)))
 665   "Truncate or extend `org-velocity-index' to the lines in
 666 MATCH-WINDOW."
 667   (with-selected-window match-window
 668     (let ((lines (window-height))
 669           (hints (length org-velocity-index)))
 670       (cond ((= lines hints)
 671              org-velocity-index)
 672             ;; Truncate the index to the size of
 673             ;; the buffer to be displayed.
 674             ((< lines hints)
 675              (cl-subseq org-velocity-index 0 lines))
 676             ;; If the window is so tall we run out of indices, at
 677             ;; least make the additional results clickable.
 678             ((> lines hints)
 679              (append org-velocity-index
 680                      (make-list (- lines hints) nil)))))))
 681
 682 (defun org-velocity-incremental-read (prompt)
 683   "Read string with PROMPT and display results incrementally.
 684 Stop searching once there are more matches than can be
 685 displayed."
 686   (let ((res
 687          (unwind-protect
 688              (let* ((match-window (display-buffer (org-velocity-match-buffer)))
 689                     (org-velocity-index (org-velocity-adjust-index match-window)))
 690                (catch 'click
 691                  (add-hook 'post-command-hook 'org-velocity-update)
 692                  (cond ((eq org-velocity-search-method 'regexp)
 693                         (read-regexp prompt))
 694                        (org-velocity-use-completion
 695                         (org-velocity-read-with-completion prompt))
 696                        (t (read-string prompt)))))
 697            (remove-hook 'post-command-hook 'org-velocity-update))))
 698     (if (bufferp res) (org-pop-to-buffer-same-window res) res)))
 699
 700 (defun org-velocity (arg &optional search)
 701   "Read a search string SEARCH for Org-Velocity interface.
 702 This means that a buffer will display all headings where SEARCH
 703 occurs, where one can be selected by a mouse click or by typing
 704 its index.  If SEARCH does not occur, then a new heading may be
 705 created named SEARCH.
 706
 707 If `org-velocity-bucket' is defined and
 708 `org-velocity-always-use-bucket' is non-nil, then the bucket file
 709 will be used; otherwise, this will work when called in any Org
 710 file.
 711
 712 Calling with ARG reverses which file – the current file or the
 713 bucket file – to use. If the bucket file would have been used,
 714 then the current file is used instead, and vice versa."
 715   (interactive "P")
 716   (let ((org-velocity-always-use-bucket
 717          (if org-velocity-always-use-bucket
 718              (not arg)
 719            arg)))
 720     ;; complain if inappropriate
 721     (cl-assert (org-velocity-bucket-file))
 722     (let ((org-velocity-bucket-buffer
 723            (find-file-noselect (org-velocity-bucket-file))))
 724       (unwind-protect
 725           (let ((dabbrev-search-these-buffers-only
 726                  (list (org-velocity-bucket-buffer))))
 727             (funcall
 728              (catch 'org-velocity-done
 729                (org-velocity-engine
 730                 (if org-velocity-search-is-incremental
 731                     (org-velocity-incremental-read "Velocity search: ")
 732                   (org-velocity-read-string "Velocity search: " search)))
 733                #'ignore)))
 734         (kill-buffer (org-velocity-match-buffer))))))
 735
 736 (defalias 'org-velocity-read 'org-velocity)
 737
 738 (provide 'org-velocity)
 739
 740 ;;; org-velocity.el ends here