contrib/lisp/org-velocity.el

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