contrib/lisp/org-velocity.el

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