contrib/lisp/org-velocity.el

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