;;; org-velocity.el --- something like Notational Velocity for Org. -*- lexical-binding: t -*- ;; Copyright (C) 2010-2014 Paul M. Rodriguez ;; Author: Paul M. Rodriguez ;; Created: 2010-05-05 ;; Version: 4.0 ;; This file is not part of GNU Emacs. ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as ;; published by the Free Software Foundation version 2. ;; This program is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see . ;;; Commentary: ;; Org-Velocity.el is an interface for Org inspired by the minimalist ;; notetaking program Notational Velocity. The idea is to let you ;; amass and access brief notes on many subjects with minimal fuss. ;; Each note is an entry in an ordinary Org file. ;; Org-Velocity can be used in two ways: when called outside Org, to ;; store and access notes in a designated bucket file; or, when called ;; inside Org, as a method for navigating any Org file. (Setting the ;; option `org-velocity-always-use-bucket' disables navigation inside ;; Org files by default, although you can still force this behavior by ;; calling `org-velocity-read' with an argument.) ;; Org-Velocity prompts for search terms in the minibuffer. A list of ;; headings of entries whose text matches your search is updated as ;; you type; you can end the search and visit an entry at any time by ;; clicking on its heading. ;; RET displays the results. If there are no matches, Org-Velocity ;; offers to create a new entry with your search string as its ;; heading. If there are matches, it displays a list of results where ;; the heading of each matching entry is hinted with a number or ;; letter; clicking a result, or typing the matching hint, opens the ;; entry for editing in an indirect buffer. 0 forces a new entry; RET ;; reopens the search for editing. ;; You can customize every step in this process, including the search ;; method, completion for search terms, and templates for creating new ;; entries; M-x customize-group RET org-velocity RET to see all the ;; options. ;; Thanks to Richard Riley, Carsten Dominik, Bastien Guerry, and Jeff ;; Horn for their suggestions. ;;; Usage: ;; (require 'org-velocity) ;; (setq org-velocity-bucket (expand-file-name "bucket.org" org-directory)) ;; (global-set-key (kbd "C-c v") 'org-velocity) ;;; Code: (require 'org) (require 'button) (require 'electric) (require 'dabbrev) (require 'cl-lib) (defgroup org-velocity nil "Notational Velocity-style interface for Org." :tag "Org-Velocity" :group 'outlines :group 'hypermedia :group 'org) (defcustom org-velocity-bucket "" "Where is the bucket file?" :group 'org-velocity :type 'file) (defcustom org-velocity-search-is-incremental t "Show results incrementally when possible?" :group 'org-velocity :type 'boolean :safe 'booleanp) (defcustom org-velocity-show-previews t "Show previews of the text of each heading?" :group 'velocity :type 'boolean :safe 'booleanp) (defcustom org-velocity-exit-on-match nil "When searching incrementally, exit on a single match?" :group 'org-velocity :type 'boolean :safe 'booleanp) (defcustom org-velocity-force-new nil "Should exiting the minibuffer with C-j force a new entry?" :group 'org-velocity :type 'boolean :safe 'booleanp) (defcustom org-velocity-use-search-ring t "Push search to `search-ring' when visiting an entry? This means that C-s C-s will take you directly to the first instance of the search string." :group 'org-velocity :type 'boolean :safe 'booleanp) (defcustom org-velocity-always-use-bucket nil "Use bucket file even when called from an Org buffer?" :group 'org-velocity :type 'boolean :safe 'booleanp) (defcustom org-velocity-use-completion nil "Use completion? Notwithstanding the value of this option, calling `dabbrev-expand' always completes against the text of the bucket file." :group 'org-velocity :type '(choice (const :tag "Do not use completion" nil) (const :tag "Use completion" t)) :safe 'booleanp) (defcustom org-velocity-search-method 'phrase "Match on whole phrase, any word, or all words?" :group 'org-velocity :type '(choice (const :tag "Match whole phrase" phrase) (const :tag "Match any word" any) (const :tag "Match all words" all) (const :tag "Match a regular expression" regexp)) :safe (lambda (v) (memq v '(phrase any all regexp)))) (defcustom org-velocity-capture-templates '(("v" "Velocity entry" entry (file "") "* %:search\n\n%i%?")) "Use these template with `org-capture'. Meanwhile `org-default-notes-file' is bound to `org-velocity-bucket-file'. The keyword :search inserts the current search. See the documentation for `org-capture-templates'." :group 'org-velocity :type (or (get 'org-capture-templates 'custom-type) 'list)) (defcustom org-velocity-heading-level 1 "Only match headings at this level or higher. 0 means to match headings at any level." :group 'org-velocity :type 'integer :safe (lambda (x) (and (integerp x) (>= x 0)))) (defvar crm-separator) ;Ensure dynamic binding. (defsubst org-velocity-grab-preview () "Grab preview of a subtree. The length of the preview is determined by `window-width'. Replace all contiguous whitespace with single spaces." (let ((start (progn (forward-line 1) (if (looking-at org-property-start-re) (re-search-forward org-property-end-re) (1- (point)))))) (mapconcat #'identity (split-string (buffer-substring-no-properties start (min (+ start (window-width)) (point-max)))) " "))) (cl-defstruct org-velocity-heading buffer position name level preview) (defsubst org-velocity-nearest-heading (position) "Return last heading at POSITION. If there is no last heading, return nil." (save-excursion (goto-char position) (re-search-backward (org-velocity-heading-regexp)) (let ((components (org-heading-components))) (make-org-velocity-heading :buffer (current-buffer) :position (point) :name (nth 4 components) :level (nth 0 components) :preview (if org-velocity-show-previews (org-velocity-grab-preview)))))) (defconst org-velocity-index (eval-when-compile (nconc (number-sequence 49 57) ;numbers (number-sequence 97 122) ;lowercase letters (number-sequence 65 90))) ;uppercase letters "List of chars for indexing results.") (defconst org-velocity-match-buffer-name "*Velocity matches*") (cl-defun org-velocity-heading-regexp (&optional (level org-velocity-heading-level)) "Regexp to match headings at LEVEL or deeper." (if (zerop level) "^\\*+ " (format "^\\*\\{1,%d\\} " level))) (defvar org-velocity-search nil "Variable to bind to current search.") (defun org-velocity-buffer-file-name (&optional buffer) "Return the name of the file BUFFER saves to. Same as function `buffer-file-name' unless BUFFER is an indirect buffer or a minibuffer. In the former case, return the file name of the base buffer; in the latter, return the file name of `minibuffer-selected-window' (or its base buffer)." (let ((buffer (if (minibufferp buffer) (window-buffer (minibuffer-selected-window)) buffer))) (buffer-file-name (or (buffer-base-buffer buffer) buffer)))) (defun org-velocity-minibuffer-contents () "Return the contents of the minibuffer when it is active." (if (active-minibuffer-window) (with-current-buffer (window-buffer (active-minibuffer-window)) (minibuffer-contents)))) (defun org-velocity-bucket-file () "Return the proper file for Org-Velocity to search. If `org-velocity-always-use-bucket' is t, use bucket file; complain if missing. Otherwise, if an Org file is current, then use it." (let ((org-velocity-bucket (when org-velocity-bucket (expand-file-name org-velocity-bucket))) (buffer (let ((buffer-file (org-velocity-buffer-file-name))) (when buffer-file ;; Use the target in capture buffers. (org-find-base-buffer-visiting buffer-file))))) (if org-velocity-always-use-bucket (or org-velocity-bucket (error "Bucket required but not defined")) (if (and (eq (buffer-local-value 'major-mode (or buffer (current-buffer))) 'org-mode) (org-velocity-buffer-file-name)) (org-velocity-buffer-file-name) (or org-velocity-bucket (error "No bucket and not an Org file")))))) (defvar org-velocity-bucket-buffer nil) (defsubst org-velocity-bucket-buffer () (or org-velocity-bucket-buffer (find-file-noselect (org-velocity-bucket-file)))) (defsubst org-velocity-match-buffer () "Return the proper buffer for Org-Velocity to display in." (get-buffer-create org-velocity-match-buffer-name)) (defsubst org-velocity-match-window () (get-buffer-window (org-velocity-match-buffer))) (defsubst org-velocity-match-staging-buffer () (get-buffer-create " Velocity matches")) (defun org-velocity-beginning-of-headings () "Goto the start of the first heading." (goto-char (point-min)) ;; If we are before the first heading we could still be at the ;; first heading. (or (looking-at (org-velocity-heading-regexp)) (re-search-forward (org-velocity-heading-regexp)))) (defun org-velocity-make-indirect-buffer (heading) "Make or switch to an indirect buffer visiting HEADING." (let* ((bucket (org-velocity-heading-buffer heading)) (name (org-velocity-heading-name heading)) (existing (get-buffer name))) (if (and existing (buffer-base-buffer existing) (equal (buffer-base-buffer existing) bucket)) existing (make-indirect-buffer bucket (generate-new-buffer-name (org-velocity-heading-name heading)) t)))) (defun org-velocity-capture () "Record a note with `org-capture'." (let ((org-capture-templates org-velocity-capture-templates)) (org-capture nil ;; This is no longer automatically selected. (when (null (cdr org-capture-templates)) (caar org-capture-templates))) (when org-capture-mode (rename-buffer org-velocity-search t)))) (defvar org-velocity-saved-winconf nil) (make-variable-buffer-local 'org-velocity-saved-winconf) (defun org-velocity-edit-entry (heading) "Edit entry at HEADING in an indirect buffer." (let ((winconf (current-window-configuration)) (buffer (org-velocity-make-indirect-buffer heading)) (inhibit-point-motion-hooks t) (inhibit-field-text-motion t)) (with-current-buffer buffer (setq org-velocity-saved-winconf winconf) (goto-char (org-velocity-heading-position heading)) (let ((start (point)) (end (save-excursion (org-end-of-subtree t) (point)))) ;; Outline view and narrow-to-region interact poorly. (outline-flag-region start end nil) (narrow-to-region start end)) (goto-char (point-max)) (add-hook 'org-ctrl-c-ctrl-c-hook 'org-velocity-dismiss nil t)) (pop-to-buffer buffer) (set (make-local-variable 'header-line-format) (format "%s Use C-c C-c to finish." (abbreviate-file-name (buffer-file-name (org-velocity-heading-buffer heading))))))) (defun org-velocity-dismiss () "Save current entry and close indirect buffer." (let ((winconf org-velocity-saved-winconf)) (prog1 t ;Tell hook we're done. (save-buffer) (kill-buffer) (when (window-configuration-p winconf) (set-window-configuration winconf))))) (defun org-velocity-visit-button (button) (run-hooks 'mouse-leave-buffer-hook) (when org-velocity-use-search-ring (add-to-history 'search-ring (button-get button 'search) search-ring-max)) (let ((match (button-get button 'match))) (throw 'org-velocity-done (lambda () (org-velocity-edit-entry match))))) (define-button-type 'org-velocity-button 'action #'org-velocity-visit-button 'follow-link 'mouse-face) (defsubst org-velocity-buttonize (heading) "Insert HEADING as a text button with no hints." (insert-text-button (propertize (org-velocity-heading-name heading) 'face 'link) :type 'org-velocity-button 'match heading 'search org-velocity-search)) (defsubst org-velocity-insert-preview (heading) (when org-velocity-show-previews (insert-char ?\ 1) (insert (propertize (org-velocity-heading-preview heading) 'face 'shadow)))) (defsubst org-velocity-present-match (hint match) (with-current-buffer (org-velocity-match-staging-buffer) (when hint (insert "#" hint " ")) (org-velocity-buttonize match) (org-velocity-insert-preview match) (newline))) (defun org-velocity-generic-search (search &optional hide-hints) "Display any entry containing SEARCH." (let ((hints org-velocity-index) matches) (cl-block nil (while (and hints (re-search-forward search nil t)) (let ((match (org-velocity-nearest-heading (point)))) (org-velocity-present-match (unless hide-hints (car hints)) match) (push match matches)) (setq hints (cdr hints)) (unless (re-search-forward (org-velocity-heading-regexp) nil t) (return)))) (nreverse matches))) (cl-defun org-velocity-all-search (search &optional hide-hints) "Display only entries containing every word in SEARCH." (let ((keywords (mapcar 'regexp-quote (split-string search))) (hints org-velocity-index) matches) (org-map-entries (lambda () ;; Return if we've run out of hints. (when (null hints) (return-from org-velocity-all-search (nreverse matches))) ;; Only search the subtree once. (setq org-map-continue-from (save-excursion (goto-char (line-end-position)) (if (re-search-forward (org-velocity-heading-regexp) nil t) (line-end-position) (point-max)))) (when (cl-loop for word in keywords always (save-excursion (re-search-forward (concat "\\<" word "\\>") org-map-continue-from t))) (let ((match (org-velocity-nearest-heading (match-end 0)))) (org-velocity-present-match (unless hide-hints (car hints)) match) (push match matches) (setq hints (cdr hints)))))) (nreverse matches))) (cl-defun org-velocity-present (search &key hide-hints) "Buttonize matches for SEARCH in `org-velocity-match-buffer'. If HIDE-HINTS is non-nil, display entries without indices. SEARCH binds `org-velocity-search'. Return matches." (if (and (stringp search) (not (string= "" search))) ;; Fold case when the search string is all lowercase. (let ((case-fold-search (equal search (downcase search))) (truncate-partial-width-windows t)) (with-current-buffer (org-velocity-match-buffer) (erase-buffer) ;; Permanent locals. (setq cursor-type nil truncate-lines t)) (prog1 (with-current-buffer (org-velocity-bucket-buffer) (let ((inhibit-point-motion-hooks t) (inhibit-field-text-motion t)) (save-excursion (org-velocity-beginning-of-headings) (cl-case org-velocity-search-method (all (org-velocity-all-search search hide-hints)) (phrase (org-velocity-generic-search (concat "\\<" (regexp-quote search)) hide-hints)) (any (org-velocity-generic-search (concat "\\<" (regexp-opt (split-string search))) hide-hints)) (regexp (condition-case lossage (org-velocity-generic-search search hide-hints) (invalid-regexp (minibuffer-message "%s" lossage)))))))) (with-current-buffer (org-velocity-match-buffer) (buffer-swap-text (org-velocity-match-staging-buffer)) (goto-char (point-min))))) (with-current-buffer (org-velocity-match-buffer) (erase-buffer)))) (defun org-velocity-store-link () "Function for `org-store-link-functions'." (if org-velocity-search (org-store-link-props :search org-velocity-search))) (add-hook 'org-store-link-functions 'org-velocity-store-link) (cl-defun org-velocity-create (search &key ask) "Create new heading named SEARCH. If ASK is non-nil, ask first." (when (or (null ask) (y-or-n-p "No match found, create? ")) (let ((org-velocity-search search) (org-default-notes-file (org-velocity-bucket-file)) ;; save a stored link org-store-link-plist) (org-velocity-capture)) search)) (defun org-velocity-engine (search) "Display a list of headings where SEARCH occurs." (let ((org-velocity-search search)) (unless (or (not (stringp search)) (string= "" search)) ;exit on empty string (cl-case (if (and org-velocity-force-new (eq last-command-event ?\C-j)) :force (let* ((org-velocity-index (org-velocity-adjust-index)) (matches (org-velocity-present search))) (cond ((null matches) :new) ((null (cdr matches)) :follow) (t :prompt)))) (:prompt (progn (pop-to-buffer (org-velocity-match-buffer)) (let ((hint (org-velocity-electric-read-hint))) (when hint (cl-case hint (:edit (org-velocity-read nil search)) (:force (org-velocity-create search)) (otherwise (org-velocity-activate-button hint))))))) (:new (unless (org-velocity-create search :ask t) (org-velocity-read nil search))) (:force (org-velocity-create search)) (:follow (if (y-or-n-p "One match, follow? ") (progn (set-buffer (org-velocity-match-buffer)) (goto-char (point-min)) (button-activate (next-button (point)))) (org-velocity-read nil search))))))) (defun org-velocity-activate-button (char) "Go to button on line number associated with CHAR in `org-velocity-index'." (goto-char (point-min)) (forward-line (cl-position char org-velocity-index)) (goto-char (button-start (next-button (point)))) (message "%s" (button-label (button-at (point)))) (button-activate (button-at (point)))) (defun org-velocity-electric-undefined () "Complain about an undefined key." (interactive) (message "%s" (substitute-command-keys "\\[org-velocity-electric-new] for new entry, \\[org-velocity-electric-edit] to edit search, \\[scroll-up] to scroll up, \\[scroll-down] to scroll down, \\[keyboard-quit] to quit.")) (sit-for 4)) (defun org-velocity-electric-follow (ev) "Follow a hint indexed by keyboard event EV." (interactive (list last-command-event)) (if (not (> (cl-position ev org-velocity-index) (1- (count-lines (point-min) (point-max))))) (throw 'org-velocity-select ev) (call-interactively 'org-velocity-electric-undefined))) (defun org-velocity-electric-edit () "Edit the search string." (interactive) (throw 'org-velocity-select :edit)) (defun org-velocity-electric-new () "Force a new entry." (interactive) (throw 'org-velocity-select :force)) (defvar org-velocity-electric-map (let ((map (make-sparse-keymap))) (define-key map [t] 'org-velocity-electric-undefined) (dolist (c org-velocity-index) (define-key map (char-to-string c) 'org-velocity-electric-follow)) (define-key map "0" 'org-velocity-electric-new) (define-key map "\C-v" 'scroll-up) (define-key map "\M-v" 'scroll-down) (define-key map (kbd "RET") 'org-velocity-electric-edit) (define-key map [mouse-1] nil) (define-key map [mouse-2] nil) (define-key map [escape] 'keyboard-quit) (define-key map "\C-h" 'help-command) map)) (defun org-velocity-electric-read-hint () "Read index of button electrically." (with-current-buffer (org-velocity-match-buffer) (when (featurep 'evil) ;; NB Idempotent. (evil-make-overriding-map org-velocity-electric-map)) (use-local-map org-velocity-electric-map) (catch 'org-velocity-select (Electric-command-loop 'org-velocity-select "Follow: ")))) (defvar org-velocity-incremental-keymap (let ((map (make-sparse-keymap))) (define-key map "\C-v" 'scroll-up) (define-key map "\M-v" 'scroll-down) map)) (defun org-velocity-displaying-completions-p () "Is there a *Completions* buffer showing?" (get-window-with-predicate (lambda (w) (eq (buffer-local-value 'major-mode (window-buffer w)) 'completion-list-mode)))) (defun org-velocity-update () "Display results of search without hinting." (unless (org-velocity-displaying-completions-p) (let* ((search (org-velocity-minibuffer-contents)) (matches (org-velocity-present search :hide-hints t))) (cond ((null matches) (select-window (active-minibuffer-window)) (unless (or (null search) (string= "" search)) (minibuffer-message "No match; RET to create"))) ((and (null (cdr matches)) org-velocity-exit-on-match) (throw 'click search)) (t (with-current-buffer (org-velocity-match-buffer) (use-local-map org-velocity-incremental-keymap))))))) (defvar dabbrev--last-abbreviation) (defun org-velocity-dabbrev-completion-list (abbrev) "Return all dabbrev completions for ABBREV." ;; This is based on `dabbrev-completion'. (dabbrev--reset-global-variables) (setq dabbrev--last-abbreviation abbrev) (dabbrev--find-all-expansions abbrev case-fold-search)) (defvar org-velocity-local-completion-map (let ((map (make-sparse-keymap))) (set-keymap-parent map minibuffer-local-completion-map) (define-key map " " 'self-insert-command) (define-key map [remap minibuffer-complete] 'minibuffer-complete-word) map) "Keymap for completion with `completing-read'.") (defun org-velocity-read-with-completion (prompt) "Completing read with PROMPT." (let ((minibuffer-local-completion-map org-velocity-local-completion-map) (completion-no-auto-exit t) (crm-separator " ")) (funcall (cl-case org-velocity-search-method (phrase #'completing-read) (any #'completing-read-multiple) (all #'completing-read-multiple)) prompt (completion-table-dynamic 'org-velocity-dabbrev-completion-list)))) (defun org-velocity-read-string (prompt &optional initial-input) "Read string with PROMPT followed by INITIAL-INPUT." ;; The use of initial inputs to the minibuffer is deprecated (see ;; `read-from-minibuffer'), but in this case it is the user-friendly ;; thing to do. (minibuffer-with-setup-hook (let ((initial-input initial-input)) (lambda () (and initial-input (insert initial-input)) (goto-char (point-max)))) (if (eq org-velocity-search-method 'regexp) (read-regexp prompt) (if org-velocity-use-completion (org-velocity-read-with-completion prompt) (read-string prompt))))) (cl-defun org-velocity-adjust-index (&optional (match-window (org-velocity-match-window))) "Truncate or extend `org-velocity-index' to the lines in MATCH-WINDOW." (with-selected-window match-window (let ((lines (window-height)) (hints (length org-velocity-index))) (cond ((= lines hints) org-velocity-index) ;; Truncate the index to the size of ;; the buffer to be displayed. ((< lines hints) (cl-subseq org-velocity-index 0 lines)) ;; If the window is so tall we run out of indices, at ;; least make the additional results clickable. ((> lines hints) (append org-velocity-index (make-list (- lines hints) nil))))))) (defun org-velocity-incremental-read (prompt) "Read string with PROMPT and display results incrementally. Stop searching once there are more matches than can be displayed." (let ((res (unwind-protect (let* ((match-window (display-buffer (org-velocity-match-buffer))) (org-velocity-index (org-velocity-adjust-index match-window))) (catch 'click (add-hook 'post-command-hook 'org-velocity-update) (cond ((eq org-velocity-search-method 'regexp) (read-regexp prompt)) (org-velocity-use-completion (org-velocity-read-with-completion prompt)) (t (read-string prompt))))) (remove-hook 'post-command-hook 'org-velocity-update)))) (if (bufferp res) (org-pop-to-buffer-same-window res) res))) (defun org-velocity (arg &optional search) "Read a search string SEARCH for Org-Velocity interface. This means that a buffer will display all headings where SEARCH occurs, where one can be selected by a mouse click or by typing its index. If SEARCH does not occur, then a new heading may be created named SEARCH. If `org-velocity-bucket' is defined and `org-velocity-always-use-bucket' is non-nil, then the bucket file will be used; otherwise, this will work when called in any Org file. Calling with ARG reverses which file – the current file or the bucket file – to use. If the bucket file would have been used, then the current file is used instead, and vice versa." (interactive "P") (let ((org-velocity-always-use-bucket (if org-velocity-always-use-bucket (not arg) arg))) ;; complain if inappropriate (cl-assert (org-velocity-bucket-file)) (let ((org-velocity-bucket-buffer (find-file-noselect (org-velocity-bucket-file)))) (unwind-protect (let ((dabbrev-search-these-buffers-only (list (org-velocity-bucket-buffer)))) (funcall (catch 'org-velocity-done (org-velocity-engine (if org-velocity-search-is-incremental (org-velocity-incremental-read "Velocity search: ") (org-velocity-read-string "Velocity search: " search))) #'ignore))) (kill-buffer (org-velocity-match-buffer)))))) (defalias 'org-velocity-read 'org-velocity) (provide 'org-velocity) ;;; org-velocity.el ends here