diff options
Diffstat (limited to 'contrib/lisp/org-velocity.el')
| -rw-r--r-- | contrib/lisp/org-velocity.el | 309 |
1 files changed, 163 insertions, 146 deletions
diff --git a/contrib/lisp/org-velocity.el b/contrib/lisp/org-velocity.el index 3631a59..a7820f1 100644 --- a/contrib/lisp/org-velocity.el +++ b/contrib/lisp/org-velocity.el @@ -1,10 +1,10 @@ -;;; org-velocity.el --- something like Notational Velocity for Org. +;;; org-velocity.el --- something like Notational Velocity for Org. -*- lexical-binding: t -*- ;; Copyright (C) 2010-2014 Paul M. Rodriguez ;; Author: Paul M. Rodriguez <paulmrodriguez@gmail.com> ;; Created: 2010-05-05 -;; Version: 3.0 +;; Version: 4.0 ;; This file is not part of GNU Emacs. @@ -64,7 +64,7 @@ (require 'button) (require 'electric) (require 'dabbrev) -(eval-when-compile (require 'cl)) +(require 'cl-lib) (defgroup org-velocity nil "Notational Velocity-style interface for Org." @@ -133,9 +133,9 @@ file." "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 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)))) @@ -152,6 +152,17 @@ 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'. @@ -172,14 +183,14 @@ Replace all contiguous whitespace with single spaces." (point-max)))) " "))) -(defstruct org-velocity-heading buffer position name level preview) +(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) + (re-search-backward (org-velocity-heading-regexp)) (let ((components (org-heading-components))) (make-org-velocity-heading :buffer (current-buffer) @@ -191,15 +202,18 @@ If there is no last heading, return nil." (defconst org-velocity-index (eval-when-compile - (nconc (number-sequence 49 57) ;numbers + (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*") -(defconst org-velocity-heading-regexp "^\\* " - "Regexp to match only top-level headings.") +(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.") @@ -223,12 +237,6 @@ of the base buffer; in the latter, return the file name of (with-current-buffer (window-buffer (active-minibuffer-window)) (minibuffer-contents)))) -(defsubst org-velocity-singlep (object) - "Return t when OBJECT is a list or sequence of one element." - (if (consp object) - (null (cdr object)) - (= (length object) 1))) - (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; @@ -260,17 +268,22 @@ use it." "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))) + (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))) @@ -279,7 +292,8 @@ use it." existing (make-indirect-buffer bucket - (generate-new-buffer-name (org-velocity-heading-name heading)))))) + (generate-new-buffer-name (org-velocity-heading-name heading)) + t)))) (defun org-velocity-capture () "Record a note with `org-capture'." @@ -287,34 +301,38 @@ use it." org-velocity-capture-templates)) (org-capture nil ;; This is no longer automatically selected. - (when (org-velocity-singlep org-capture-templates) + (when (null (cdr org-capture-templates)) (caar org-capture-templates))) - (if org-capture-mode (rename-buffer org-velocity-search t)))) + (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))) - (let ((buffer (org-velocity-make-indirect-buffer heading))) - (with-current-buffer buffer - (let ((org-inhibit-startup t)) - (org-mode)) - (setq org-velocity-saved-winconf winconf) - (goto-char (org-velocity-heading-position heading)) - (narrow-to-region (point) - (save-excursion - (org-end-of-subtree t) - (point))) - (goto-char (point-min)) - (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)))))))) + (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." @@ -327,14 +345,18 @@ use it." (defun org-velocity-visit-button (button) (run-hooks 'mouse-leave-buffer-hook) - (if org-velocity-use-search-ring - (add-to-history 'search-ring - (button-get button 'search) - search-ring-max)) - (org-velocity-edit-entry (button-get button 'match))) + (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) + 'action #'org-velocity-visit-button + 'follow-link 'mouse-face) (defsubst org-velocity-buttonize (heading) "Insert HEADING as a text button with no hints." @@ -352,8 +374,8 @@ use it." (org-velocity-heading-preview heading) 'face 'shadow)))) -(defsubst* org-velocity-present-match (&key hint match) - (with-current-buffer (org-velocity-match-buffer) +(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) @@ -362,19 +384,19 @@ use it." (defun org-velocity-generic-search (search &optional hide-hints) "Display any entry containing SEARCH." (let ((hints org-velocity-index) matches) - (block nil + (cl-block nil (while (and hints (re-search-forward search nil t)) (let ((match (org-velocity-nearest-heading (point)))) (org-velocity-present-match - :hint (unless hide-hints (car hints)) - :match match) + (unless hide-hints (car hints)) + match) (push match matches)) (setq hints (cdr hints)) - (unless (re-search-forward org-velocity-heading-regexp nil t) + (unless (re-search-forward (org-velocity-heading-regexp) nil t) (return)))) (nreverse matches))) -(defun* org-velocity-all-search (search &optional hide-hints max) +(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) @@ -388,23 +410,23 @@ use it." (setq org-map-continue-from (save-excursion (goto-char (line-end-position)) - (if (re-search-forward org-velocity-heading-regexp nil t) + (if (re-search-forward (org-velocity-heading-regexp) nil t) (line-end-position) (point-max)))) - (when (loop for word in keywords - always (save-excursion - (re-search-forward - (concat "\\<" word "\\>") - org-map-continue-from t))) + (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 - :hint (unless hide-hints (car hints)) - :match match) + (unless hide-hints (car hints)) + match) (push match matches) (setq hints (cdr hints)))))) (nreverse matches))) -(defun* org-velocity-present (search &key hide-hints) +(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'. @@ -425,7 +447,7 @@ Return matches." (inhibit-field-text-motion t)) (save-excursion (org-velocity-beginning-of-headings) - (case org-velocity-search-method + (cl-case org-velocity-search-method (all (org-velocity-all-search search hide-hints)) (phrase (org-velocity-generic-search (concat "\\<" (regexp-quote search)) @@ -440,6 +462,7 @@ Return matches." (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)))) @@ -452,14 +475,14 @@ Return matches." (add-hook 'org-store-link-functions 'org-velocity-store-link) -(defun* org-velocity-create (search &key ask) +(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-default-notes-file (org-velocity-bucket-file)) + ;; save a stored link + org-store-link-plist) (org-velocity-capture)) search)) @@ -469,17 +492,18 @@ If ASK is non-nil, ask first." (unless (or (not (stringp search)) (string= "" search)) ;exit on empty string - (case + (cl-case (if (and org-velocity-force-new (eq last-command-event ?\C-j)) :force - (let ((matches (org-velocity-present search))) + (let* ((org-velocity-index (org-velocity-adjust-index)) + (matches (org-velocity-present search))) (cond ((null matches) :new) - ((org-velocity-singlep matches) :follow) + ((null (cdr matches)) :follow) (t :prompt)))) (:prompt (progn (pop-to-buffer (org-velocity-match-buffer)) (let ((hint (org-velocity-electric-read-hint))) - (when hint (case hint + (when hint (cl-case hint (:edit (org-velocity-read nil search)) (:force (org-velocity-create search)) (otherwise (org-velocity-activate-button hint))))))) @@ -493,17 +517,10 @@ If ASK is non-nil, ask first." (button-activate (next-button (point)))) (org-velocity-read nil search))))))) -(defun org-velocity-position (item list) - "Return first position of ITEM in LIST." - (loop for elt in list - for i from 0 - when (equal elt item) - return i)) - (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 (org-velocity-position char org-velocity-index)) + (forward-line (cl-position char org-velocity-index)) (goto-char (button-start (next-button (point)))) @@ -514,8 +531,8 @@ If ASK is non-nil, ask first." "Complain about an undefined key." (interactive) (message "%s" - (substitute-command-keys - "\\[org-velocity-electric-new] for new entry, + (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, @@ -525,20 +542,11 @@ If ASK is non-nil, ask first." (defun org-velocity-electric-follow (ev) "Follow a hint indexed by keyboard event EV." (interactive (list last-command-event)) - (if (not (> (org-velocity-position ev org-velocity-index) + (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-click (ev) - "Follow hint indexed by a mouse event EV." - (interactive "e") - (throw 'org-velocity-select - (nth (1- (count-lines - (point-min) - (posn-point (event-start ev)))) - org-velocity-index))) - (defun org-velocity-electric-edit () "Edit the search string." (interactive) @@ -552,14 +560,15 @@ If ASK is non-nil, ask first." (defvar org-velocity-electric-map (let ((map (make-sparse-keymap))) (define-key map [t] 'org-velocity-electric-undefined) - (loop for c in org-velocity-index - do (define-key map (char-to-string c) 'org-velocity-electric-follow)) + (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] 'org-velocity-electric-click) - (define-key map [mouse-2] 'org-velocity-electric-click) + (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)) @@ -567,29 +576,19 @@ If ASK is non-nil, ask first." (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 [mouse-1] 'org-velocity-click-for-incremental) - (define-key map [mouse-2] 'org-velocity-click-for-incremental) (define-key map "\C-v" 'scroll-up) (define-key map "\M-v" 'scroll-down) map)) -(defun org-velocity-click-for-incremental () - "Jump out of search and select hint clicked on." - (interactive) - (let ((ev last-command-event)) - (org-velocity-activate-button - (nth (- (count-lines - (point-min) - (posn-point (event-start ev))) 2) - org-velocity-index))) - (throw 'click (current-buffer))) - (defun org-velocity-displaying-completions-p () "Is there a *Completions* buffer showing?" (get-window-with-predicate @@ -598,8 +597,7 @@ If ASK is non-nil, ask first." 'completion-list-mode)))) (defun org-velocity-update () - "Display results of search without hinting. -Stop searching once there are more matches than can be displayed." + "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))) @@ -607,20 +605,20 @@ Stop searching once there are more matches than can be displayed." (select-window (active-minibuffer-window)) (unless (or (null search) (string= "" search)) (minibuffer-message "No match; RET to create"))) - ((and (org-velocity-singlep matches) + ((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-abbrev) +(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-abbrev abbrev) + (setq dabbrev--last-abbreviation abbrev) (dabbrev--find-all-expansions abbrev case-fold-search)) (defvar org-velocity-local-completion-map @@ -638,7 +636,7 @@ Stop searching once there are more matches than can be displayed." (completion-no-auto-exit t) (crm-separator " ")) (funcall - (case org-velocity-search-method + (cl-case org-velocity-search-method (phrase #'completing-read) (any #'completing-read-multiple) (all #'completing-read-multiple)) @@ -652,38 +650,50 @@ Stop searching once there are more matches than can be displayed." ;; `read-from-minibuffer'), but in this case it is the user-friendly ;; thing to do. (minibuffer-with-setup-hook - (lexical-let ((initial-input initial-input)) + (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) + (read-regexp prompt) (if org-velocity-use-completion - (org-velocity-read-with-completion prompt) - (read-string prompt))))) + (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." + "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 - ;; Truncate the index to the size of the buffer to be - ;; displayed. - (with-selected-window match-window - (if (> (window-height) (length org-velocity-index)) - ;; (subseq org-velocity-index 0 (window-height)) - (let ((hints (copy-sequence org-velocity-index))) - (setcdr (nthcdr (window-height) hints) nil) - hints) - org-velocity-index)))) + (org-velocity-index (org-velocity-adjust-index match-window))) (catch 'click (add-hook 'post-command-hook 'org-velocity-update) - (if (eq org-velocity-search-method 'regexp) - (read-regexp prompt) - (if org-velocity-use-completion - (org-velocity-read-with-completion prompt) - (read-string prompt))))) + (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))) @@ -697,24 +707,31 @@ 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 forces current file." +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 arg nil org-velocity-always-use-bucket))) + (if org-velocity-always-use-bucket + (not arg) + arg))) ;; complain if inappropriate - (assert (org-velocity-bucket-file)) + (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)))) - (org-velocity-engine - (if org-velocity-search-is-incremental - (org-velocity-incremental-read "Velocity search: ") - (org-velocity-read-string "Velocity search: " search)))) - (progn - (kill-buffer (org-velocity-match-buffer)) - (delete-other-windows)))))) + (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) |