contrib/lisp/org-velocity.el

   1 ;;; org-velocity.el --- something like Notational Velocity for Org.
   2
   3 ;; Copyright (C) 2010 Paul M. Rodriguez
   4
   5 ;; Author: Paul M. Rodriguez <paulmrodriguez@gmail.com>
   6 ;; Created: 2010-05-05
   7 ;; Version: 2.3
   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 implements an interface for Org inspired by the
  26 ;; minimalist notetaking program Notational Velocity.  The idea is to
  27 ;; allow you to maintain, amass and access brief notes on many
  28 ;; subjects with minimal fuss.
  29
  30 ;; It can be used in two ways: to store and access notes from any
  31 ;; buffer a universal bucket file; or as a method for navigating any
  32 ;; Org file.
  33
  34 ;; The name of the bucket-file (`org-velocity-bucket') and whether to
  35 ;; always use it (`org-velocity-always-use-bucket-file') are set
  36 ;; through Customize.  If the bucket file is set but not always to be
  37 ;; used, then calling Org-Velocity outside of Org-mode uses the bucket
  38 ;; file; calling it in Org mode uses the current buffer.  If no bucket
  39 ;; file is set then Org-Velocity only works when called from Org.
  40 ;; Even if the bucket file is always to be used, calling
  41 ;; `org-velocity-read' with an argument will use the current file.
  42
  43 ;; The interface, unlike its inspiration, is not incremental.
  44 ;; Org-Velocity prompts for search terms in the usual way; if the user
  45 ;; has customized `org-velocity-use-completion', completion is offered
  46 ;; on the headings in the target file.  If the search multiple times
  47 ;; in the target file, a buffer containing a buttonized list of the
  48 ;; headings where it occurs is displayed.  Results beyond what can be
  49 ;; indexed are discarded.  After clicking on a heading, or typing a
  50 ;; character associated with it, the user is taken to the heading.
  51 ;; (Typing 0 forces a new heading to be created.)  If
  52 ;; `org-velocity-edit-indirectly' is so set, the heading and its
  53 ;; subtree are displayed in an indirect buffer.  Otherwise the user is
  54 ;; simply taken to the proper buffer and position.
  55
  56 ;; If the user simply hits RET at the prompt, without making a choice,
  57 ;; then the search is restored for editing.  A blank search quits.
  58 ;; This method of selection is obviously not as slick as the original,
  59 ;; but probably more useful for a keyboard-driven interface.
  60
  61 ;; If the search does not occur in the file the user is offered a
  62 ;; choice to create a new heading named with the search.  Org-Velocity
  63 ;; will use `org-capture' or `org-remember' if they are loaded,
  64 ;; preferring `org-capture'.  Otherwise the user is simply taken to a
  65 ;; new heading at the end of the file.
  66
  67 ;; Thanks to Richard Riley, Carsten Dominik, Bastien Guerry, and Jeff
  68 ;; Horn for their suggestions.
  69
  70 ;;; Usage:
  71 ;; (require 'org-velocity)
  72 ;; (setq org-velocity-bucket (concat org-directory "/bucket.org"))
  73 ;; (global-set-key (kbd "C-c v") 'org-velocity-read)
  74
  75 ;;; Code:
  76 (require 'org)
  77 (require 'button)
  78 (require 'electric)
  79 (eval-when-compile (require 'cl))
  80
  81 (defgroup org-velocity nil
  82   "Notational Velocity-style interface for Org."
  83   :tag "Org-Velocity"
  84   :group 'outlines
  85   :group 'hypermedia)
  86
  87 (defcustom org-velocity-bucket ""
  88   "Where is the bucket file?"
  89   :group 'org-velocity
  90   :type 'file)
  91
  92 (defcustom org-velocity-always-use-bucket nil
  93   "Use bucket file even when called from an Org buffer?"
  94   :group 'org-velocity
  95   :type 'boolean)
  96
  97 (defcustom org-velocity-use-completion nil
  98   "Complete on heading names?"
  99   :group 'org-velocity
 100   :type 'boolean)
 101
 102 (defcustom org-velocity-edit-indirectly t
 103   "Edit entries in an indirect buffer or just visit the file?"
 104   :group 'org-velocity
 105   :type 'boolean)
 106
 107 (defcustom org-velocity-search-method 'phrase
 108   "Match on whole phrase, any word, or all words?"
 109   :group 'org-velocity
 110   :type '(choice
 111           (const :tag "Match whole phrase" phrase)
 112           (const :tag "Match any word" any)
 113           (const :tag "Match all words" all)))
 114
 115 (defcustom org-velocity-create-method 'capture
 116   "Prefer `org-capture', `org-remember', or neither?"
 117   :group 'org-velocity
 118   :type '(choice
 119           (const :tag "Prefer capture > remember > default." capture)
 120           (const :tag "Prefer remember > default." remember)
 121           (const :tag "Edit in buffer." buffer)))
 122
 123 (defcustom org-velocity-allow-regexps nil
 124   "Allow searches to use regular expressions?"
 125   :group 'org-velocity
 126   :type 'boolean)
 127
 128 (defcustom org-velocity-remember-templates
 129   '(("Velocity entry"
 130      ?v
 131      "* %:search\n\n%i%?"
 132      nil
 133      bottom))
 134   "Use these templates with `org-remember'.
 135 Meanwhile `org-default-notes-file' is bound to `org-velocity-use-file'.
 136 The keyword :search inserts the current search.
 137 See the documentation for `org-remember-templates'."
 138   :group 'org-velocity
 139   :type (or (get 'org-remember-templates 'custom-type) 'list))
 140
 141 (defcustom org-velocity-capture-templates
 142   '(("v"
 143      "Velocity entry"
 144      entry
 145      (file "")
 146      "* %:search\n\n%i%?"))
 147   "Use these template with `org-capture'.
 148 Meanwhile `org-default-notes-file' is bound to `org-velocity-use-file'.
 149 The keyword :search inserts the current search.
 150 See the documentation for `org-capture-templates'."
 151   :group 'org-velocity
 152   :type (or (get 'org-capture-templates 'custom-type) 'list))
 153
 154 (defstruct (org-velocity-heading
 155             (:constructor org-velocity-make-heading)
 156             (:type list))
 157   (marker (point-marker))
 158   (name (substring-no-properties
 159          (org-get-heading))))
 160
 161 (defconst org-velocity-index
 162   (eval-when-compile
 163    (nconc (number-sequence 49 57)       ;numbers
 164           (number-sequence 97 122)      ;lowercase letters
 165           (number-sequence 65 90)))     ;uppercase letters
 166   "List of chars for indexing results.")
 167
 168 (defconst org-velocity-display-buffer-name "*Velocity headings*")
 169
 170 (defvar org-velocity-search nil
 171   "Variable to bind to current search.")
 172
 173 (defsubst org-velocity-buffer-file-name (&optional buffer)
 174   "Return the name of the file BUFFER saves to.
 175 Same as function `buffer-file-name' unless BUFFER is an
 176 indirect buffer."
 177   (buffer-file-name
 178    (or (buffer-base-buffer buffer)
 179        buffer)))
 180
 181 (defun org-velocity-use-file ()
 182   "Return the proper file for Org-Velocity to search.
 183 If `org-velocity-always-use-bucket' is t, use bucket file; complain
 184 if missing.  Otherwise if this is an Org file, use it."
 185   (or
 186    ;; In remember and capture buffers the target should be used.
 187    (and org-remember-mode org-default-notes-file)
 188    (let ((org-velocity-bucket
 189           (and org-velocity-bucket (expand-file-name org-velocity-bucket))))
 190      (if org-velocity-always-use-bucket
 191          (or org-velocity-bucket (error "Bucket required but not defined"))
 192        (if (and (eq major-mode 'org-mode)
 193                 (org-velocity-buffer-file-name))
 194            (org-velocity-buffer-file-name)
 195          (or org-velocity-bucket
 196              (error "No bucket and not an Org file")))))))
 197
 198 (defsubst org-velocity-display-buffer ()
 199   "Return the proper buffer for Org-Velocity to display in."
 200   (get-buffer-create org-velocity-display-buffer-name))
 201
 202 (defsubst org-velocity-bucket-buffer ()
 203   "Return proper buffer for bucket operations."
 204   (find-file-noselect (org-velocity-use-file)))
 205
 206 (defun org-velocity-quote (search)
 207   "Quote SEARCH as a regexp if `org-velocity-allow-regexps' is non-nil.
 208 Acts like `regexp-quote' on a string, `regexp-opt' on a list."
 209   (if org-velocity-allow-regexps
 210       search
 211     (if (listp search)
 212         (regexp-opt search)
 213       (regexp-quote search))))
 214
 215 (defun org-velocity-nearest-heading (position)
 216   "Return last heading at POSITION.
 217 If there is no last heading, return nil."
 218   (save-excursion
 219     (goto-char position)
 220     (unless (org-before-first-heading-p)
 221       (org-back-to-heading)
 222       (org-velocity-make-heading))))
 223
 224 (defun org-velocity-make-button-action (heading)
 225   "Return a form to visit HEADING."
 226   `(lambda (button)
 227     (run-hooks 'mouse-leave-buffer-hook) ;turn off temporary modes
 228     (if org-velocity-edit-indirectly
 229         (org-velocity-edit-entry ',heading)
 230       (progn
 231         (message "%s" ,(org-velocity-heading-name heading))
 232         (switch-to-buffer (marker-buffer
 233                            ,(org-velocity-heading-marker heading)))
 234         (goto-char (marker-position
 235                     ,(org-velocity-heading-marker heading)))))))
 236
 237 (defun org-velocity-edit-entry (heading)
 238   "Edit entry at HEADING in an indirect buffer."
 239   (let ((buffer (make-indirect-buffer
 240                  (marker-buffer (org-velocity-heading-marker heading))
 241                  (generate-new-buffer-name
 242                   (org-velocity-heading-name heading)))))
 243     (with-current-buffer buffer
 244       (let ((org-inhibit-startup t))
 245         (org-mode))
 246       (goto-char (marker-position (org-velocity-heading-marker heading)))
 247       (narrow-to-region (point)
 248                         (save-excursion
 249                           (org-end-of-subtree)
 250                           (point)))
 251       (goto-char (point-min))
 252       (add-hook 'org-ctrl-c-ctrl-c-hook 'org-velocity-dismiss nil t))
 253     (pop-to-buffer buffer)
 254     (set (make-local-variable 'header-line-format)
 255          (format "%s Use C-c C-c to finish."
 256                  (abbreviate-file-name
 257                   (buffer-file-name
 258                    (marker-buffer
 259                     (org-velocity-heading-marker heading))))))))
 260
 261 (defun org-velocity-dismiss ()
 262   "Save current entry and close indirect buffer."
 263   (progn
 264     (save-buffer)
 265     (kill-buffer)))
 266
 267 (defun org-velocity-buttonize (heading)
 268   "Insert HEADING as a text button."
 269   (insert (format "#%c " (nth (1- (line-number-at-pos))
 270                               org-velocity-index)))
 271   (let ((action (org-velocity-make-button-action heading)))
 272    (insert-text-button
 273     (org-velocity-heading-name heading)
 274     'action action))
 275   (newline))
 276
 277 (defun org-velocity-remember ()
 278   "Use `org-remember' to record a note."
 279   (let ((org-remember-templates
 280          org-velocity-remember-templates))
 281     (call-interactively 'org-remember)))
 282
 283 (defun org-velocity-capture ()
 284   "Use `org-capture' to record a note."
 285   (let ((org-capture-templates
 286          org-velocity-capture-templates))
 287     (if (fboundp 'org-capture) ;; quiet compiler
 288         (call-interactively 'org-capture))))
 289
 290 (defun org-velocity-insert-heading (heading)
 291   "Add a new heading named HEADING."
 292   (with-current-buffer (org-velocity-bucket-buffer)
 293     (goto-char (point-max))
 294     (newline)
 295     (org-insert-heading) (insert heading)
 296     (newline)
 297     (goto-char (point-max))))
 298
 299 (defun org-velocity-create-heading ()
 300   "Add and visit a new heading."
 301   (org-store-link nil)
 302   (destructuring-bind (&key search initial
 303                             &allow-other-keys)
 304       org-store-link-plist
 305     (org-velocity-insert-heading search)
 306     (switch-to-buffer (org-velocity-bucket-buffer))
 307     (insert (or initial ""))))
 308
 309 (defun org-velocity-all-search (search)
 310   "Return entries containing all words in SEARCH."
 311   (when (file-exists-p (org-velocity-use-file))
 312    (save-excursion
 313      (delq nil
 314            (let ((keywords
 315                   (mapcar 'org-velocity-quote
 316                           (split-string search)))
 317                  (case-fold-search t))
 318              (org-map-entries
 319               (lambda ()
 320                 (if (loop with limit = (save-excursion
 321                                          (org-end-of-subtree)
 322                                          (point))
 323                           for word in keywords
 324                           always (save-excursion
 325                                    (re-search-forward word limit t)))
 326                     (org-velocity-nearest-heading
 327                      (match-beginning 0))))))))))
 328
 329 (defun org-velocity-generic-search (search)
 330   "Return entries containing SEARCH."
 331   (save-excursion
 332     (delq nil
 333           (nreverse
 334            (let (matches (case-fold-search t))
 335              (goto-char (point-min))
 336              (while (re-search-forward search
 337                                        (point-max) t)
 338                (push (org-velocity-nearest-heading (match-beginning 0))
 339                      matches)
 340                (outline-next-heading))
 341              matches)))))
 342
 343 (defsubst org-velocity-phrase-search (search)
 344   "Return entries containing SEARCH as a phrase."
 345   (org-velocity-generic-search (org-velocity-quote search)))
 346
 347 (defsubst org-velocity-any-search (search)
 348   "Return entries containing any word in SEARCH."
 349   (org-velocity-generic-search (org-velocity-quote (split-string search))))
 350
 351 (defun org-velocity-present (headings)
 352   "Buttonize HEADINGS in `org-velocity-display-buffer'."
 353   (and (listp headings) (delete-dups headings))
 354   (let ((cdr (nthcdr
 355               (1- (length org-velocity-index))
 356               headings)))
 357     (and (consp cdr) (setcdr cdr nil)))
 358   (with-current-buffer (org-velocity-display-buffer)
 359     (mapc
 360      'org-velocity-buttonize
 361      headings)
 362     (goto-char (point-min))))
 363
 364 (defun org-velocity-create-1 ()
 365   "Create a new heading.
 366 The possible methods are `org-velocity-capture',
 367 `org-velocity-remember', or `org-velocity-create-heading', in
 368 that order.  Which is preferred is determined by
 369 `org-velocity-create-method'."
 370   (funcall
 371    (ecase org-velocity-create-method
 372      (capture (or (and (featurep 'org-capture) 'org-velocity-capture)
 373                   (and (featurep 'org-remember) 'org-velocity-remember)
 374                   'org-velocity-create-heading))
 375      (remember (or (and (featurep 'org-remember) 'org-velocity-remember)
 376                    'org-velocity-create-heading))
 377      (buffer 'org-velocity-create-heading))))
 378
 379 (defun org-velocity-store-link ()
 380   "Function for `org-store-link-functions'."
 381   (if org-velocity-search
 382    (org-store-link-props
 383     :search org-velocity-search)))
 384
 385 (add-hook 'org-store-link-functions 'org-velocity-store-link)
 386
 387 (defun org-velocity-create (search &optional ask)
 388   "Create new heading named SEARCH.
 389 If ASK is non-nil, ask first."
 390   (when (or (null ask)
 391             (y-or-n-p "No match found, create? "))
 392     (let ((org-velocity-search search)
 393           (org-default-notes-file (org-velocity-use-file))
 394           ;; save a stored link
 395           (org-store-link-plist))
 396       (org-velocity-create-1))
 397     search))
 398
 399 (defun org-velocity-get-matches (search)
 400   "Return matches for SEARCH in current bucket.
 401 Use method specified by `org-velocity-search-method'."
 402   (with-current-buffer (org-velocity-bucket-buffer)
 403    (case org-velocity-search-method
 404      ('phrase (org-velocity-phrase-search search))
 405      ('any    (org-velocity-any-search search))
 406      ('all    (org-velocity-all-search search)))))
 407
 408 (defun org-velocity-engine (search)
 409   "Display a list of headings where SEARCH occurs."
 410   (with-current-buffer (org-velocity-display-buffer)
 411     (erase-buffer)
 412     (setq cursor-type nil))
 413   (unless (or
 414            (not (stringp search))
 415            (string-equal "" search))    ;exit on empty string
 416     (case
 417         (with-current-buffer (org-velocity-bucket-buffer)
 418           (save-excursion
 419             (let ((matches (org-velocity-get-matches search)))
 420               (org-velocity-present matches)
 421               (cond ((zerop (length matches)) 'new)
 422                     ((= (length matches) 1)   'follow)
 423                     ((> (length matches) 1)   'prompt)))))
 424       ('prompt (progn
 425                  (Electric-pop-up-window (org-velocity-display-buffer))
 426                  (let ((hint (org-velocity-electric-follow-hint)))
 427                    (if hint
 428                        (case hint
 429                          (edit (org-velocity-read nil search))
 430                          (new (org-velocity-create search))
 431                          (otherwise (org-velocity-activate-button hint)))))))
 432       ('new (unless (org-velocity-create search t)
 433               (org-velocity-read nil search)))
 434       ('follow (if (y-or-n-p "One match, follow? ")
 435                    (progn
 436                      (set-buffer (org-velocity-display-buffer))
 437                      (goto-char (point-min))
 438                      (button-activate (next-button (point))))
 439                  (org-velocity-read nil search))))))
 440
 441 (defun org-velocity-position (item list)
 442   "Return first position of ITEM in LIST."
 443   (loop for elt in list
 444         for i from 0
 445         if (equal elt item)
 446         return i))
 447
 448 (defun org-velocity-activate-button (char)
 449   "Go to button on line number associated with CHAR in `org-velocity-index'."
 450   (goto-char (point-min))
 451   (forward-line (org-velocity-position char org-velocity-index))
 452   (goto-char
 453    (button-start
 454     (next-button (point))))
 455   (message "%s" (button-label (button-at (point))))
 456   (button-activate (button-at (point))))
 457
 458 (defun org-velocity-electric-undefined ()
 459   "Complain about an undefined key."
 460   (interactive)
 461   (message "%s"
 462            (substitute-command-keys
 463             "\\[org-velocity-electric-new] for new entry, \\[org-velocity-electric-edit] to edit search, \\[scroll-up] to scroll."))
 464   (sit-for 4))
 465
 466 (defun org-velocity-electric-follow (ev)
 467   "Follow a hint indexed by keyboard event EV."
 468   (interactive (list last-command-event))
 469   (if (not (> (org-velocity-position ev org-velocity-index)
 470            (1- (count-lines (point-min) (point-max)))))
 471       (throw 'org-velocity-select ev)
 472     (call-interactively 'org-velocity-electric-undefined)))
 473
 474 (defun org-velocity-electric-click (ev)
 475   "Follow hint indexed by a mouse event EV."
 476   (interactive "e")
 477   (throw 'org-velocity-select
 478          (nth (1- (count-lines
 479                    (point-min)
 480                    (posn-point (event-start ev))))
 481               org-velocity-index)))
 482
 483 (defun org-velocity-electric-edit ()
 484   "Edit the search string."
 485   (interactive)
 486   (throw 'org-velocity-select 'edit))
 487
 488 (defun org-velocity-electric-new ()
 489   "Force a new entry."
 490   (interactive)
 491   (throw 'org-velocity-select 'new))
 492
 493 (defvar org-velocity-electric-map
 494   (let ((map (make-sparse-keymap)))
 495     (define-key map [t] 'org-velocity-electric-undefined)    (loop for c in org-velocity-index
 496           do (define-key map (char-to-string c) 'org-velocity-electric-follow))
 497     (define-key map "0" 'org-velocity-electric-new)
 498     (define-key map [tab] 'scroll-up)
 499     (define-key map [return] 'org-velocity-electric-edit)
 500     (define-key map [mouse-1] 'org-velocity-electric-click)
 501     (define-key map [mouse-2] 'org-velocity-electric-click)
 502     (define-key map [escape escape escape] 'keyboard-quit)
 503     (define-key map "\C-h" 'help-command)
 504     map))
 505
 506 (defun org-velocity-electric-follow-hint ()
 507   "Read index of button electrically."
 508   (with-current-buffer (org-velocity-display-buffer)
 509     (use-local-map org-velocity-electric-map)
 510     (catch 'org-velocity-select
 511       (Electric-command-loop 'org-velocity-select
 512                              "Follow: "))))
 513
 514 (defun org-velocity-read-with-completion (prompt)
 515   "Like `completing-read' on entries with PROMPT.
 516 Use `minibuffer-local-filename-completion-map'."
 517   (let ((minibuffer-local-completion-map
 518          minibuffer-local-filename-completion-map))
 519     (completing-read
 520      prompt
 521      (mapcar 'substring-no-properties
 522              (org-map-entries 'org-get-heading)))))
 523
 524 (defun org-velocity-read-string (prompt &optional initial-input)
 525   "Read string with PROMPT followed by INITIAL-INPUT."
 526   ;; The use of initial inputs to the minibuffer is deprecated (see
 527   ;; `read-from-minibuffer'), but in this case it is the user-friendly
 528   ;; thing to do.
 529   (minibuffer-with-setup-hook
 530       (lexical-let ((initial-input initial-input))
 531         (lambda ()
 532           (and initial-input (insert initial-input))
 533           (goto-char (point-max))))
 534     (if (and org-velocity-use-completion
 535              ;; map-entries complains for nonexistent files
 536              (file-exists-p (org-velocity-use-file)))
 537         (org-velocity-read-with-completion prompt)
 538       (read-string prompt))))
 539
 540 (defun org-velocity-read (arg &optional search)
 541   "Read a search string SEARCH for Org-Velocity interface.
 542 This means that a buffer will display all headings where SEARCH
 543 occurs, where one can be selected by a mouse click or by typing
 544 its index.  If SEARCH does not occur, then a new heading may be
 545 created named SEARCH.
 546
 547 If `org-velocity-bucket' is defined and
 548 `org-velocity-always-use-bucket' is non-nil, then the bucket file
 549 will be used; otherwise, this will work when called in any Org
 550 file.  Calling with ARG forces current file."
 551   (interactive "P")
 552   (let ((org-velocity-always-use-bucket
 553          (if arg nil org-velocity-always-use-bucket)))
 554     ;; complain if inappropriate
 555     (assert (org-velocity-use-file))
 556     (unwind-protect
 557         (org-velocity-engine
 558          (org-velocity-read-string "Velocity search: " search))
 559       (progn
 560         (kill-buffer (org-velocity-display-buffer))
 561         (delete-other-windows)))))
 562
 563 (provide 'org-velocity)
 564 ;;; org-velocity.el ends here