From mboxrd@z Thu Jan 1 00:00:00 1970 From: Carsten Dominik Subject: [Accepted] org-velocity and org-remember Date: Mon, 15 Nov 2010 11:23:22 +0100 (CET) Message-ID: <20101115102322.2E4A68592CD@u016822.science.uva.nl> References: <87mxpqc7rr.fsf@gmail.com> Mime-Version: 1.0 Content-Type: text/plain; charset="us-ascii" Content-Transfer-Encoding: 7bit Return-path: Received: from [140.186.70.92] (port=56661 helo=eggs.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1PHwDi-0004OX-IN for emacs-orgmode@gnu.org; Mon, 15 Nov 2010 05:23:34 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1PHwDd-0003KF-So for emacs-orgmode@gnu.org; Mon, 15 Nov 2010 05:23:30 -0500 Received: from u016822.science.uva.nl ([146.50.39.34]:49667) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1PHwDd-0003Jb-C2 for emacs-orgmode@gnu.org; Mon, 15 Nov 2010 05:23:25 -0500 List-Id: "General discussions about Org-mode." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Sender: emacs-orgmode-bounces+geo-emacs-orgmode=m.gmane.org@gnu.org Errors-To: emacs-orgmode-bounces+geo-emacs-orgmode=m.gmane.org@gnu.org To: emacs-orgmode@gnu.org Patch 362 (http://patchwork.newartisans.com/patch/362/) is now "Accepted". Maintainer comment: none This relates to the following submission: http://mid.gmane.org/%3C87mxpqc7rr.fsf%40gmail.com%3E Here is the original message containing the patch: > Content-Type: text/plain; charset="utf-8" > MIME-Version: 1.0 > Content-Transfer-Encoding: 7bit > Subject: [Orgmode] org-velocity and org-remember > Date: Thu, 04 Nov 2010 04:22:16 -0000 > From: Paul M. Rodriguez > X-Patchwork-Id: 362 > Message-Id: <87mxpqc7rr.fsf@gmail.com> > To: emacs-orgmode@gnu.org > > This patch supports org-capture (with fallback to org-remember) for > org-velocity. It also effects some internal changes, principally due to > the use of `Electric-command-loop' to replace an expedient equivalent. > > > diff --git a/contrib/lisp/org-velocity.el b/contrib/lisp/org-velocity.el > index 3e7453b..2a1f41b 100644 > --- a/contrib/lisp/org-velocity.el > +++ b/contrib/lisp/org-velocity.el > @@ -4,7 +4,7 @@ > > ;; Author: Paul M. Rodriguez > ;; Created: 2010-05-05 > -;; Version: 2.1 > +;; Version: 2.2 > > ;; This file is not part of GNU Emacs. > > @@ -59,23 +59,23 @@ > ;; but probably more useful for a keyboard-driven interface. > > ;; If the search does not occur in the file the user is offered a > -;; choice to create a new heading named with the search. When > -;; org-remember is loaded, or the user customizes > -;; `org-velocity-use-remember', then org-remember is used to insert > -;; the new heading. Otherwise the user is simply taken to a new > -;; heading at the end of the file. > +;; choice to create a new heading named with the search. Org-Velocity > +;; will use `org-capture' or `org-remember' if they are loaded, > +;; preferring `org-capture'. Otherwise the user is simply taken to a > +;; new heading at the end of the file. > > ;; Thanks to Richard Riley, Carsten Dominik, and Bastien Guerry for > ;; their suggestions. > > ;;; Usage: > -;;; (require 'org-velocity) > -;;; (setq org-velocity-bucket (concat org-directory "/bucket.org")) > -;;; (global-set-key (kbd "C-c v") 'org-velocity-read) > +;; (require 'org-velocity) > +;; (setq org-velocity-bucket (concat org-directory "/bucket.org")) > +;; (global-set-key (kbd "C-c v") 'org-velocity-read) > > ;;; Code: > (require 'org) > (require 'button) > +(require 'electric) > (eval-when-compile (require 'cl)) > > (defgroup org-velocity nil > @@ -99,18 +99,6 @@ > :group 'org-velocity > :type 'boolean) > > -(defcustom org-velocity-use-remember (featurep 'org-remember) > - "Use Org-remember or just visit the file?" > - :group 'org-velocity > - :type 'boolean) > - > -(defcustom org-velocity-remember-method 'bottom > - "Where in files should `org-remember' record new entries?" > - :group 'org-velocity > - :type '(choice (const :tag "Add at bottom" bottom) > - (const :tag "Add at top" top) > - (const :tag "Use date tree" date-tree))) > - > (defcustom org-velocity-edit-indirectly t > "Edit entries in an indirect buffer or just visit the file?" > :group 'org-velocity > @@ -124,17 +112,19 @@ > (const :tag "Match any word" any) > (const :tag "Match all words" all))) > > +(defcustom org-velocity-create-method 'capture > + "Prefer `org-capture', `org-remember', or neither?" > + :group 'org-velocity > + :type '(choice > + (const :tag "Prefer capture > remember > default." capture) > + (const :tag "Prefer remember > default." remember) > + (const :tag "Edit in buffer." buffer))) > + > (defcustom org-velocity-allow-regexps nil > "Allow searches to use regular expressions?" > :group 'org-velocity > :type 'boolean) > > -(defvar org-velocity-index > - (nconc (number-sequence 49 57) ;numbers > - (number-sequence 97 122) ;lowercase letters > - (number-sequence 65 90)) ;uppercase letters > - "List of chars for indexing results.") > - > (defstruct (org-velocity-heading > (:constructor org-velocity-make-heading) > (:type list)) > @@ -142,6 +132,13 @@ > (name (substring-no-properties > (org-get-heading)))) > > +(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.") > + > (defun org-velocity-use-file () > "Return the proper file for Org-Velocity to search. > If `org-velocity-always-use-bucket' is t, use bucket file; complain > @@ -212,7 +209,12 @@ If there is no last heading, return nil." > (goto-char (point-min)) > (add-hook 'org-ctrl-c-ctrl-c-hook 'org-velocity-dismiss nil t)) > (pop-to-buffer buffer) > - (message "%s" "Use C-c C-c to save changes."))) > + (set (make-local-variable 'header-line-format) > + (format "%s Use C-c C-c to finish." > + (abbreviate-file-name > + (buffer-file-name > + (marker-buffer > + (org-velocity-heading-marker heading)))))))) > > (defun org-velocity-dismiss () > "Save current entry and close indirect buffer." > @@ -222,21 +224,14 @@ If there is no last heading, return nil." > > (defun org-velocity-buttonize (heading) > "Insert HEADING as a text button." > - (insert (format "#%c " (nth (1- (line-number-at-pos)) org-velocity-index))) > - (insert-text-button > - (org-velocity-heading-name heading) > - 'action (org-velocity-make-button-action heading)) > + (insert (format "#%c " (nth (1- (line-number-at-pos)) > + org-velocity-index))) > + (let ((action (org-velocity-make-button-action heading))) > + (insert-text-button > + (org-velocity-heading-name heading) > + 'action action)) > (newline)) > > -(defun org-velocity-insert-heading (heading) > - "Add a new heading named HEADING." > - (with-current-buffer (org-velocity-bucket-buffer) > - (goto-char (point-max)) > - (newline) > - (org-insert-heading) (insert heading) > - (newline) > - (goto-char (point-max)))) > - > (defun org-velocity-remember (heading &optional region) > "Use `org-remember' to record a note to HEADING. > If there is a REGION that will be inserted." > @@ -244,14 +239,39 @@ If there is a REGION that will be inserted." > (list (list > "Velocity entry" > ?v > - (let ((string "* %s\n\n%%?")) > - (if region > - (format (concat string "%s") heading region) > - (format string heading))) > + (format "* %s\n\n%%?%s" heading (or region "")) > (org-velocity-use-file) > - org-velocity-remember-method)))) > + 'bottom)))) > (org-remember nil ?v))) > > +(defun org-velocity-capture (heading &optional region) > + "Use `org-capture' to record a note to HEADING. > +If there is a REGION that will be inserted." > + (let ((org-capture-templates > + (list `("v" > + "Velocity entry" > + entry > + (file ,(org-velocity-use-file)) > + ,(format "* %s\n\n%%?%s" heading (or region "")))))) > + (if (fboundp 'org-capture) ;; quiet compiler > + (org-capture nil "v")))) > + > +(defun org-velocity-insert-heading (heading) > + "Add a new heading named HEADING." > + (with-current-buffer (org-velocity-bucket-buffer) > + (goto-char (point-max)) > + (newline) > + (org-insert-heading) (insert heading) > + (newline) > + (goto-char (point-max)))) > + > +(defun org-velocity-create-heading (search region) > + "Add and visit a new heading named SEARCH. > +If REGION is non-nil insert as the contents of the heading." > + (org-velocity-insert-heading search) > + (switch-to-buffer (org-velocity-bucket-buffer)) > + (when region (insert region))) > + > (defun org-velocity-all-search (search) > "Return entries containing all words in SEARCH." > (when (file-exists-p (org-velocity-use-file)) > @@ -261,20 +281,16 @@ If there is a REGION that will be inserted." > (mapcar 'org-velocity-quote > (split-string search))) > (case-fold-search t)) > - (apply 'nconc > - (org-map-entries > - (lambda () > - (let ((limit (save-excursion (org-end-of-subtree) > - (point)))) > - (catch 'fail > - (mapcar > - (lambda (word) > - (or (save-excursion > - (and (re-search-forward word limit t) > - (org-velocity-nearest-heading > - (match-beginning 0)))) > - (throw 'fail nil))) > - keywords))))))))))) > + (org-map-entries > + (lambda () > + (if (loop with limit = (save-excursion > + (org-end-of-subtree) > + (point)) > + for word in keywords > + always (save-excursion > + (re-search-forward word limit t))) > + (org-velocity-nearest-heading > + (match-beginning 0)))))))))) > > (defun org-velocity-generic-search (search) > "Return entries containing SEARCH." > @@ -301,7 +317,7 @@ If there is a REGION that will be inserted." > (defun org-velocity-present (headings) > "Buttonize HEADINGS in `org-velocity-display-buffer'." > (and (listp headings) (delete-dups headings)) > - (let ((cdr (nthcdr > + (let ((cdr (nthcdr > (1- (length org-velocity-index)) > headings))) > (and (consp cdr) (setcdr cdr nil))) > @@ -311,7 +327,24 @@ If there is a REGION that will be inserted." > headings) > (goto-char (point-min)))) > > -(defun org-velocity-new (search &optional ask) > +(defun org-velocity-create-1 (search region) > + "Create a new heading named SEARCH. > +If REGION is non-nil insert as contents of new heading. > +The possible methods are `org-velocity-capture', > +`org-velocity-remember', or `org-velocity-create-heading', in > +that order. Which is preferred is determined by > +`org-velocity-create-method'." > + (funcall > + (ecase org-velocity-create-method > + (capture (or (and (featurep 'org-capture) 'org-velocity-capture) > + (and (featurep 'org-remember) 'org-velocity-remember) > + 'org-velocity-create-heading)) > + (remember (or (and (featurep 'org-remember) 'org-velocity-remember) > + 'org-velocity-create-heading)) > + (buffer 'org-velocity-create-heading)) > + search region)) > + > +(defun org-velocity-create (search &optional ask) > "Create new heading named SEARCH. > If ASK is non-nil, ask first." > (if (or (null ask) > @@ -321,37 +354,45 @@ If ASK is non-nil, ask first." > (buffer-substring > (region-beginning) > (region-end))))) > - (if org-velocity-use-remember > - (org-velocity-remember search region) > - (progn > - (org-velocity-insert-heading search) > - (switch-to-buffer (org-velocity-bucket-buffer)) > - (when region (insert region)))) > + (with-current-buffer (org-velocity-bucket-buffer) > + (org-velocity-create-1 search region)) > (when region (message "%s" "Inserted region")) > search))) > > +(defun org-velocity-get-matches (search) > + "Return matches for SEARCH in current bucket. > +Use method specified by `org-velocity-search-method'." > + (with-current-buffer (org-velocity-bucket-buffer) > + (case org-velocity-search-method > + ('phrase (org-velocity-phrase-search search)) > + ('any (org-velocity-any-search search)) > + ('all (org-velocity-all-search search))))) > + > (defun org-velocity-engine (search) > "Display a list of headings where SEARCH occurs." > - (with-current-buffer (org-velocity-display-buffer) (erase-buffer)) > - (unless (string-equal "" search);exit on empty string > + (with-current-buffer (org-velocity-display-buffer) > + (erase-buffer) > + (setq cursor-type nil)) > + (unless (or > + (not (stringp search)) > + (string-equal "" search)) ;exit on empty string > (case > (with-current-buffer (org-velocity-bucket-buffer) > (save-excursion > - (let ((matches > - (case org-velocity-search-method > - ('phrase (org-velocity-phrase-search search)) > - ('any (org-velocity-any-search search)) > - ('all (org-velocity-all-search search))))) > + (let ((matches (org-velocity-get-matches search))) > (org-velocity-present matches) > (cond ((zerop (length matches)) 'new) > ((= (length matches) 1) 'follow) > ((> (length matches) 1) 'prompt))))) > ('prompt (progn > - (display-buffer (org-velocity-display-buffer)) > - (case (org-velocity-follow-hint) > - ('edit (org-velocity-read nil search)) > - ('new (org-velocity-new search))))) > - ('new (unless (org-velocity-new search t) > + (Electric-pop-up-window (org-velocity-display-buffer)) > + (let ((hint (org-velocity-electric-follow-hint))) > + (if hint > + (case hint > + (edit (org-velocity-read nil search)) > + (new (org-velocity-create search)) > + (otherwise (org-velocity-activate-button hint))))))) > + ('new (unless (org-velocity-create search t) > (org-velocity-read nil search))) > ('follow (if (y-or-n-p "One match, follow? ") > (progn > @@ -360,86 +401,104 @@ If ASK is non-nil, ask first." > (button-activate (next-button (point)))) > (org-velocity-read nil search)))))) > > -(defun org-velocity-list-position (elt list) > - "Return first position of ELT in LIST" > - (let ((copy (copy-list list))) > - (1- > - (length > - (progn > - (setcdr (member elt copy) nil) > - copy))))) > +(defun org-velocity-position (item list) > + "Return first position of ITEM in LIST." > + (loop for elt in list > + for i from 0 > + if (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-list-position char org-velocity-index)) > + (forward-line (org-velocity-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-follow-hint () > - "Prompt for index of button." > - (let ((hint > - (read-key > - "Follow (0 for new note, RET to edit search, TAB to scroll): "))) > - (cond > - ;; quit? > - ((or (eq hint 7) ;C-g > - (eq hint 27)) ;ESC > - (keyboard-quit)) > - ;; zero? > - ((eq hint 48) > - 'new) > - ;; return? > - ((or (eq hint 13) ;\r > - (eq hint 10)) ;\n > - 'edit) > - ;; tab? > - ((eq hint 9) > - (let ((other-window-scroll-buffer > - (org-velocity-display-buffer))) > - (scroll-other-window)) > - (org-velocity-follow-hint)) > - ;; click? > - ((mouse-event-p hint) > - (mouse-set-point hint) > - (if (button-at (point)) > - (push-button (point)) > - (org-velocity-follow-hint))) > - ;; unhandled char? > - ((not (memq hint org-velocity-index)) > - (org-velocity-follow-hint)) > - ;; index beyond results? > - ((> (org-velocity-list-position hint org-velocity-index) > - (with-current-buffer (org-velocity-display-buffer) > +(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.")) > + (sit-for 4)) > + > +(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) > (1- (count-lines (point-min) (point-max))))) > - (org-velocity-follow-hint)) > - ;; follow hint > - (t (set-buffer (org-velocity-display-buffer)) > - (org-velocity-activate-button hint))))) > + (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) > + (throw 'org-velocity-select 'edit)) > + > +(defun org-velocity-electric-new () > + "Force a new entry." > + (interactive) > + (throw 'org-velocity-select 'new)) > + > +(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)) > + (define-key map "0" 'org-velocity-electric-new) > + (define-key map [tab] 'scroll-up) > + (define-key map [return] '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 [escape escape escape] 'keyboard-quit) > + (define-key map "\C-h" 'help-command) > + map)) > + > +(defun org-velocity-electric-follow-hint () > + "Read index of button electrically." > + (with-current-buffer (org-velocity-display-buffer) > + (use-local-map org-velocity-electric-map) > + (catch 'org-velocity-select > + (Electric-command-loop 'org-velocity-select > + "Follow: ")))) > + > +(defun org-velocity-read-with-completion (prompt) > + "Like `completing-read' on entries with PROMPT. > +Use `minibuffer-local-filename-completion-map'." > + (let ((minibuffer-local-completion-map > + minibuffer-local-filename-completion-map)) > + (completing-read > + prompt > + (mapcar 'substring-no-properties > + (org-map-entries 'org-get-heading))))) > > (defun org-velocity-read-string (prompt &optional initial-input) > - "Read string using `read-string', with PROMPT followed by 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 > + ;; `read-from-minibuffer'), but in this case it is the user-friendly > ;; thing to do. > - (let ((minibuffer-setup-hook minibuffer-setup-hook)) > - (add-hook 'minibuffer-setup-hook (lambda () > - (and initial-input (insert initial-input)) > - (goto-char (point-max)))) > + (minibuffer-with-setup-hook > + (lexical-let ((initial-input initial-input)) > + (lambda () > + (and initial-input (insert initial-input)) > + (goto-char (point-max)))) > (if (and org-velocity-use-completion > ;; map-entries complains for nonexistent files > (file-exists-p (org-velocity-use-file))) > - (completing-read > - prompt > - (with-current-buffer (org-velocity-bucket-buffer) > - (org-map-entries > - (lambda () > - (substring-no-properties > - (org-get-heading)))))) > - (read-string prompt)))) > + (org-velocity-read-with-completion prompt) > + (read-string prompt)))) > > (defun org-velocity-read (arg &optional search) > "Read a search string SEARCH for Org-Velocity interface. > @@ -465,5 +524,4 @@ file. Calling with ARG forces current file." > (delete-other-windows))))) > > (provide 'org-velocity) > - > ;;; org-velocity.el ends here >