org-velocity.el 27 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724
  1. ;;; org-velocity.el --- something like Notational Velocity for Org.
  2. ;; Copyright (C) 2010-2013 Paul M. Rodriguez
  3. ;; Author: Paul M. Rodriguez <paulmrodriguez@gmail.com>
  4. ;; Created: 2010-05-05
  5. ;; Version: 3.0
  6. ;; This file is not part of GNU Emacs.
  7. ;; This program is free software; you can redistribute it and/or
  8. ;; modify it under the terms of the GNU General Public License as
  9. ;; published by the Free Software Foundation version 2.
  10. ;; This program is distributed in the hope that it will be useful, but
  11. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  13. ;; General Public License for more details.
  14. ;; You should have received a copy of the GNU General Public License
  15. ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
  16. ;;; Commentary:
  17. ;; Org-Velocity.el is an interface for Org inspired by the minimalist
  18. ;; notetaking program Notational Velocity. The idea is to let you
  19. ;; amass and access brief notes on many subjects with minimal fuss.
  20. ;; Each note is an entry in an ordinary Org file.
  21. ;; Org-Velocity can be used in two ways: when called outside Org, to
  22. ;; store and access notes in a designated bucket file; or, when called
  23. ;; inside Org, as a method for navigating any Org file. (Setting the
  24. ;; option `org-velocity-always-use-bucket' disables navigation inside
  25. ;; Org files by default, although you can still force this behavior by
  26. ;; calling `org-velocity-read' with an argument.)
  27. ;; Org-Velocity prompts for search terms in the minibuffer. A list of
  28. ;; headings of entries whose text matches your search is updated as
  29. ;; you type; you can end the search and visit an entry at any time by
  30. ;; clicking on its heading.
  31. ;; RET displays the results. If there are no matches, Org-Velocity
  32. ;; offers to create a new entry with your search string as its
  33. ;; heading. If there are matches, it displays a list of results where
  34. ;; the heading of each matching entry is hinted with a number or
  35. ;; letter; clicking a result, or typing the matching hint, opens the
  36. ;; entry for editing in an indirect buffer. 0 forces a new entry; RET
  37. ;; reopens the search for editing.
  38. ;; You can customize every step in this process, including the search
  39. ;; method, completion for search terms, and templates for creating new
  40. ;; entries; M-x customize-group RET org-velocity RET to see all the
  41. ;; options.
  42. ;; Thanks to Richard Riley, Carsten Dominik, Bastien Guerry, and Jeff
  43. ;; Horn for their suggestions.
  44. ;;; Usage:
  45. ;; (require 'org-velocity)
  46. ;; (setq org-velocity-bucket (expand-file-name "bucket.org" org-directory))
  47. ;; (global-set-key (kbd "C-c v") 'org-velocity)
  48. ;;; Code:
  49. (require 'org)
  50. (require 'button)
  51. (require 'electric)
  52. (require 'dabbrev)
  53. (eval-when-compile (require 'cl))
  54. (defgroup org-velocity nil
  55. "Notational Velocity-style interface for Org."
  56. :tag "Org-Velocity"
  57. :group 'outlines
  58. :group 'hypermedia
  59. :group 'org)
  60. (defcustom org-velocity-bucket ""
  61. "Where is the bucket file?"
  62. :group 'org-velocity
  63. :type 'file)
  64. (defcustom org-velocity-search-is-incremental t
  65. "Show results incrementally when possible?"
  66. :group 'org-velocity
  67. :type 'boolean
  68. :safe 'booleanp)
  69. (defcustom org-velocity-show-previews t
  70. "Show previews of the text of each heading?"
  71. :group 'velocity
  72. :type 'boolean
  73. :safe 'booleanp)
  74. (defcustom org-velocity-exit-on-match nil
  75. "When searching incrementally, exit on a single match?"
  76. :group 'org-velocity
  77. :type 'boolean
  78. :safe 'booleanp)
  79. (defcustom org-velocity-force-new nil
  80. "Should exiting the minibuffer with C-j force a new entry?"
  81. :group 'org-velocity
  82. :type 'boolean
  83. :safe 'booleanp)
  84. (defcustom org-velocity-use-search-ring t
  85. "Push search to `search-ring' when visiting an entry?
  86. This means that C-s C-s will take you directly to the first
  87. instance of the search string."
  88. :group 'org-velocity
  89. :type 'boolean
  90. :safe 'booleanp)
  91. (defcustom org-velocity-always-use-bucket nil
  92. "Use bucket file even when called from an Org buffer?"
  93. :group 'org-velocity
  94. :type 'boolean
  95. :safe 'booleanp)
  96. (defcustom org-velocity-use-completion nil
  97. "Use completion?
  98. Notwithstanding the value of this option, calling
  99. `dabbrev-expand' always completes against the text of the bucket
  100. file."
  101. :group 'org-velocity
  102. :type '(choice
  103. (const :tag "Do not use completion" nil)
  104. (const :tag "Use completion" t))
  105. :safe 'booleanp)
  106. (defcustom org-velocity-search-method 'phrase
  107. "Match on whole phrase, any word, or all words?"
  108. :group 'org-velocity
  109. :type '(choice
  110. (const :tag "Match whole phrase" phrase)
  111. (const :tag "Match any word" any)
  112. (const :tag "Match all words" all)
  113. (const :tag "Match a regular expression" regexp))
  114. :safe (lambda (v) (memq v '(phrase any all regexp))))
  115. (defcustom org-velocity-capture-templates
  116. '(("v"
  117. "Velocity entry"
  118. entry
  119. (file "")
  120. "* %:search\n\n%i%?"))
  121. "Use these template with `org-capture'.
  122. Meanwhile `org-default-notes-file' is bound to `org-velocity-bucket-file'.
  123. The keyword :search inserts the current search.
  124. See the documentation for `org-capture-templates'."
  125. :group 'org-velocity
  126. :type (or (get 'org-capture-templates 'custom-type) 'list))
  127. (defsubst org-velocity-grab-preview ()
  128. "Grab preview of a subtree.
  129. The length of the preview is determined by `window-width'.
  130. Replace all contiguous whitespace with single spaces."
  131. (let ((start (progn
  132. (forward-line 1)
  133. (if (looking-at org-property-start-re)
  134. (re-search-forward org-property-end-re)
  135. (1- (point))))))
  136. (mapconcat
  137. #'identity
  138. (split-string
  139. (buffer-substring-no-properties
  140. start
  141. (min
  142. (+ start (window-width))
  143. (point-max))))
  144. " ")))
  145. (defstruct org-velocity-heading buffer position name level preview)
  146. (defsubst org-velocity-nearest-heading (position)
  147. "Return last heading at POSITION.
  148. If there is no last heading, return nil."
  149. (save-excursion
  150. (goto-char position)
  151. (re-search-backward org-velocity-heading-regexp)
  152. (let ((components (org-heading-components)))
  153. (make-org-velocity-heading
  154. :buffer (current-buffer)
  155. :position (point)
  156. :name (nth 4 components)
  157. :level (nth 0 components)
  158. :preview (if org-velocity-show-previews
  159. (org-velocity-grab-preview))))))
  160. (defconst org-velocity-index
  161. (eval-when-compile
  162. (nconc (number-sequence 49 57) ;numbers
  163. (number-sequence 97 122) ;lowercase letters
  164. (number-sequence 65 90))) ;uppercase letters
  165. "List of chars for indexing results.")
  166. (defconst org-velocity-match-buffer-name "*Velocity matches*")
  167. (defconst org-velocity-heading-regexp "^\\* "
  168. "Regexp to match only top-level headings.")
  169. (defvar org-velocity-search nil
  170. "Variable to bind to current search.")
  171. (defun org-velocity-buffer-file-name (&optional buffer)
  172. "Return the name of the file BUFFER saves to.
  173. Same as function `buffer-file-name' unless BUFFER is an indirect
  174. buffer or a minibuffer. In the former case, return the file name
  175. of the base buffer; in the latter, return the file name of
  176. `minibuffer-selected-window' (or its base buffer)."
  177. (let ((buffer (if (minibufferp buffer)
  178. (window-buffer (minibuffer-selected-window))
  179. buffer)))
  180. (buffer-file-name
  181. (or (buffer-base-buffer buffer)
  182. buffer))))
  183. (defun org-velocity-minibuffer-contents ()
  184. "Return the contents of the minibuffer when it is active."
  185. (if (active-minibuffer-window)
  186. (with-current-buffer (window-buffer (active-minibuffer-window))
  187. (minibuffer-contents))))
  188. (defsubst org-velocity-singlep (object)
  189. "Return t when OBJECT is a list or sequence of one element."
  190. (if (consp object)
  191. (null (cdr object))
  192. (= (length object) 1)))
  193. (defun org-velocity-bucket-file ()
  194. "Return the proper file for Org-Velocity to search.
  195. If `org-velocity-always-use-bucket' is t, use bucket file;
  196. complain if missing. Otherwise, if an Org file is current, then
  197. use it."
  198. (let ((org-velocity-bucket
  199. (when org-velocity-bucket (expand-file-name org-velocity-bucket)))
  200. (buffer
  201. (let ((buffer-file (org-velocity-buffer-file-name)))
  202. (when buffer-file
  203. ;; Use the target in capture buffers.
  204. (org-find-base-buffer-visiting buffer-file)))))
  205. (if org-velocity-always-use-bucket
  206. (or org-velocity-bucket (error "Bucket required but not defined"))
  207. (if (and (eq (buffer-local-value 'major-mode (or buffer (current-buffer)))
  208. 'org-mode)
  209. (org-velocity-buffer-file-name))
  210. (org-velocity-buffer-file-name)
  211. (or org-velocity-bucket
  212. (error "No bucket and not an Org file"))))))
  213. (defvar org-velocity-bucket-buffer nil)
  214. (defsubst org-velocity-bucket-buffer ()
  215. (or org-velocity-bucket-buffer
  216. (find-file-noselect (org-velocity-bucket-file))))
  217. (defsubst org-velocity-match-buffer ()
  218. "Return the proper buffer for Org-Velocity to display in."
  219. (get-buffer-create org-velocity-match-buffer-name))
  220. (defun org-velocity-beginning-of-headings ()
  221. "Goto the start of the first heading."
  222. (goto-char (point-min))
  223. ;; If we are before the first heading we could still be at the
  224. ;; first heading.
  225. (or (looking-at org-velocity-heading-regexp)
  226. (re-search-forward org-velocity-heading-regexp)))
  227. (defun org-velocity-make-indirect-buffer (heading)
  228. "Make or switch to an indirect buffer visiting HEADING."
  229. (let* ((bucket (org-velocity-heading-buffer heading))
  230. (name (org-velocity-heading-name heading))
  231. (existing (get-buffer name)))
  232. (if (and existing (buffer-base-buffer existing)
  233. (equal (buffer-base-buffer existing) bucket))
  234. existing
  235. (make-indirect-buffer
  236. bucket
  237. (generate-new-buffer-name (org-velocity-heading-name heading))))))
  238. (defun org-velocity-capture ()
  239. "Record a note with `org-capture'."
  240. (let ((org-capture-templates
  241. org-velocity-capture-templates))
  242. (org-capture nil
  243. ;; This is no longer automatically selected.
  244. (when (org-velocity-singlep org-capture-templates)
  245. (caar org-capture-templates)))
  246. (if org-capture-mode (rename-buffer org-velocity-search t))))
  247. (defvar org-velocity-saved-winconf nil)
  248. (make-variable-buffer-local 'org-velocity-saved-winconf)
  249. (defun org-velocity-edit-entry (heading)
  250. "Edit entry at HEADING in an indirect buffer."
  251. (let ((winconf (current-window-configuration)))
  252. (let ((buffer (org-velocity-make-indirect-buffer heading)))
  253. (with-current-buffer buffer
  254. (let ((org-inhibit-startup t))
  255. (org-mode))
  256. (setq org-velocity-saved-winconf winconf)
  257. (goto-char (org-velocity-heading-position heading))
  258. (narrow-to-region (point)
  259. (save-excursion
  260. (org-end-of-subtree t)
  261. (point)))
  262. (goto-char (point-min))
  263. (add-hook 'org-ctrl-c-ctrl-c-hook 'org-velocity-dismiss nil t))
  264. (pop-to-buffer buffer)
  265. (set (make-local-variable 'header-line-format)
  266. (format "%s Use C-c C-c to finish."
  267. (abbreviate-file-name
  268. (buffer-file-name
  269. (org-velocity-heading-buffer heading))))))))
  270. (defun org-velocity-dismiss ()
  271. "Save current entry and close indirect buffer."
  272. (let ((winconf org-velocity-saved-winconf))
  273. (prog1 t ;Tell hook we're done.
  274. (save-buffer)
  275. (kill-buffer)
  276. (when (window-configuration-p winconf)
  277. (set-window-configuration winconf)))))
  278. (defun org-velocity-visit-button (button)
  279. (run-hooks 'mouse-leave-buffer-hook)
  280. (if org-velocity-use-search-ring
  281. (add-to-history 'search-ring
  282. (button-get button 'search)
  283. search-ring-max))
  284. (org-velocity-edit-entry (button-get button 'match)))
  285. (define-button-type 'org-velocity-button
  286. 'action #'org-velocity-visit-button)
  287. (defsubst org-velocity-buttonize (heading)
  288. "Insert HEADING as a text button with no hints."
  289. (insert-text-button
  290. (propertize (org-velocity-heading-name heading) 'face 'link)
  291. :type 'org-velocity-button
  292. 'match heading
  293. 'search org-velocity-search))
  294. (defsubst org-velocity-insert-preview (heading)
  295. (when org-velocity-show-previews
  296. (insert-char ?\ 1)
  297. (insert
  298. (propertize
  299. (org-velocity-heading-preview heading)
  300. 'face 'shadow))))
  301. (defsubst* org-velocity-present-match (&key hint match)
  302. (with-current-buffer (org-velocity-match-buffer)
  303. (when hint (insert "#" hint " "))
  304. (org-velocity-buttonize match)
  305. (org-velocity-insert-preview match)
  306. (newline)))
  307. (defun org-velocity-generic-search (search &optional hide-hints)
  308. "Display any entry containing SEARCH."
  309. (let ((hints org-velocity-index) matches)
  310. (block nil
  311. (while (and hints (re-search-forward search nil t))
  312. (let ((match (org-velocity-nearest-heading (point))))
  313. (org-velocity-present-match
  314. :hint (unless hide-hints (car hints))
  315. :match match)
  316. (push match matches))
  317. (setq hints (cdr hints))
  318. (unless (re-search-forward org-velocity-heading-regexp nil t)
  319. (return))))
  320. (nreverse matches)))
  321. (defun* org-velocity-all-search (search &optional hide-hints max)
  322. "Display only entries containing every word in SEARCH."
  323. (let ((keywords (mapcar 'regexp-quote (split-string search)))
  324. (hints org-velocity-index)
  325. matches)
  326. (org-map-entries
  327. (lambda ()
  328. ;; Return if we've run out of hints.
  329. (when (null hints)
  330. (return-from org-velocity-all-search (nreverse matches)))
  331. ;; Only search the subtree once.
  332. (setq org-map-continue-from
  333. (save-excursion
  334. (goto-char (line-end-position))
  335. (if (re-search-forward org-velocity-heading-regexp nil t)
  336. (line-end-position)
  337. (point-max))))
  338. (when (loop for word in keywords
  339. always (save-excursion
  340. (re-search-forward
  341. (concat "\\<" word "\\>")
  342. org-map-continue-from t)))
  343. (let ((match (org-velocity-nearest-heading (match-end 0))))
  344. (org-velocity-present-match
  345. :hint (unless hide-hints (car hints))
  346. :match match)
  347. (push match matches)
  348. (setq hints (cdr hints))))))
  349. (nreverse matches)))
  350. (defun* org-velocity-present (search &key hide-hints)
  351. "Buttonize matches for SEARCH in `org-velocity-match-buffer'.
  352. If HIDE-HINTS is non-nil, display entries without indices. SEARCH
  353. binds `org-velocity-search'.
  354. Return matches."
  355. (if (and (stringp search) (not (string= "" search)))
  356. ;; Fold case when the search string is all lowercase.
  357. (let ((case-fold-search (equal search (downcase search)))
  358. (truncate-partial-width-windows t))
  359. (with-current-buffer (org-velocity-match-buffer)
  360. (erase-buffer)
  361. ;; Permanent locals.
  362. (setq cursor-type nil
  363. truncate-lines t))
  364. (prog1
  365. (with-current-buffer (org-velocity-bucket-buffer)
  366. (let ((inhibit-point-motion-hooks t)
  367. (inhibit-field-text-motion t))
  368. (save-excursion
  369. (org-velocity-beginning-of-headings)
  370. (case org-velocity-search-method
  371. (all (org-velocity-all-search search hide-hints))
  372. (phrase (org-velocity-generic-search
  373. (concat "\\<" (regexp-quote search))
  374. hide-hints))
  375. (any (org-velocity-generic-search
  376. (concat "\\<"
  377. (regexp-opt (split-string search)))
  378. hide-hints))
  379. (regexp (condition-case lossage
  380. (org-velocity-generic-search
  381. search hide-hints)
  382. (invalid-regexp
  383. (minibuffer-message "%s" lossage))))))))
  384. (with-current-buffer (org-velocity-match-buffer)
  385. (goto-char (point-min)))))
  386. (with-current-buffer (org-velocity-match-buffer)
  387. (erase-buffer))))
  388. (defun org-velocity-store-link ()
  389. "Function for `org-store-link-functions'."
  390. (if org-velocity-search
  391. (org-store-link-props
  392. :search org-velocity-search)))
  393. (add-hook 'org-store-link-functions 'org-velocity-store-link)
  394. (defun* org-velocity-create (search &key ask)
  395. "Create new heading named SEARCH.
  396. If ASK is non-nil, ask first."
  397. (when (or (null ask) (y-or-n-p "No match found, create? "))
  398. (let ((org-velocity-search search)
  399. (org-default-notes-file (org-velocity-bucket-file))
  400. ;; save a stored link
  401. org-store-link-plist)
  402. (org-velocity-capture))
  403. search))
  404. (defun org-velocity-engine (search)
  405. "Display a list of headings where SEARCH occurs."
  406. (let ((org-velocity-search search))
  407. (unless (or
  408. (not (stringp search))
  409. (string= "" search)) ;exit on empty string
  410. (case
  411. (if (and org-velocity-force-new (eq last-command-event ?\C-j))
  412. :force
  413. (let ((matches (org-velocity-present search)))
  414. (cond ((null matches) :new)
  415. ((org-velocity-singlep matches) :follow)
  416. (t :prompt))))
  417. (:prompt (progn
  418. (pop-to-buffer (org-velocity-match-buffer))
  419. (let ((hint (org-velocity-electric-read-hint)))
  420. (when hint (case hint
  421. (:edit (org-velocity-read nil search))
  422. (:force (org-velocity-create search))
  423. (otherwise (org-velocity-activate-button hint)))))))
  424. (:new (unless (org-velocity-create search :ask t)
  425. (org-velocity-read nil search)))
  426. (:force (org-velocity-create search))
  427. (:follow (if (y-or-n-p "One match, follow? ")
  428. (progn
  429. (set-buffer (org-velocity-match-buffer))
  430. (goto-char (point-min))
  431. (button-activate (next-button (point))))
  432. (org-velocity-read nil search)))))))
  433. (defun org-velocity-position (item list)
  434. "Return first position of ITEM in LIST."
  435. (loop for elt in list
  436. for i from 0
  437. when (equal elt item)
  438. return i))
  439. (defun org-velocity-activate-button (char)
  440. "Go to button on line number associated with CHAR in `org-velocity-index'."
  441. (goto-char (point-min))
  442. (forward-line (org-velocity-position char org-velocity-index))
  443. (goto-char
  444. (button-start
  445. (next-button (point))))
  446. (message "%s" (button-label (button-at (point))))
  447. (button-activate (button-at (point))))
  448. (defun org-velocity-electric-undefined ()
  449. "Complain about an undefined key."
  450. (interactive)
  451. (message "%s"
  452. (substitute-command-keys
  453. "\\[org-velocity-electric-new] for new entry,
  454. \\[org-velocity-electric-edit] to edit search,
  455. \\[scroll-up] to scroll up,
  456. \\[scroll-down] to scroll down,
  457. \\[keyboard-quit] to quit."))
  458. (sit-for 4))
  459. (defun org-velocity-electric-follow (ev)
  460. "Follow a hint indexed by keyboard event EV."
  461. (interactive (list last-command-event))
  462. (if (not (> (org-velocity-position ev org-velocity-index)
  463. (1- (count-lines (point-min) (point-max)))))
  464. (throw 'org-velocity-select ev)
  465. (call-interactively 'org-velocity-electric-undefined)))
  466. (defun org-velocity-electric-click (ev)
  467. "Follow hint indexed by a mouse event EV."
  468. (interactive "e")
  469. (throw 'org-velocity-select
  470. (nth (1- (count-lines
  471. (point-min)
  472. (posn-point (event-start ev))))
  473. org-velocity-index)))
  474. (defun org-velocity-electric-edit ()
  475. "Edit the search string."
  476. (interactive)
  477. (throw 'org-velocity-select :edit))
  478. (defun org-velocity-electric-new ()
  479. "Force a new entry."
  480. (interactive)
  481. (throw 'org-velocity-select :force))
  482. (defvar org-velocity-electric-map
  483. (let ((map (make-sparse-keymap)))
  484. (define-key map [t] 'org-velocity-electric-undefined)
  485. (loop for c in org-velocity-index
  486. do (define-key map (char-to-string c) 'org-velocity-electric-follow))
  487. (define-key map "0" 'org-velocity-electric-new)
  488. (define-key map "\C-v" 'scroll-up)
  489. (define-key map "\M-v" 'scroll-down)
  490. (define-key map (kbd "RET") 'org-velocity-electric-edit)
  491. (define-key map [mouse-1] 'org-velocity-electric-click)
  492. (define-key map [mouse-2] 'org-velocity-electric-click)
  493. (define-key map [escape] 'keyboard-quit)
  494. (define-key map "\C-h" 'help-command)
  495. map))
  496. (defun org-velocity-electric-read-hint ()
  497. "Read index of button electrically."
  498. (with-current-buffer (org-velocity-match-buffer)
  499. (use-local-map org-velocity-electric-map)
  500. (catch 'org-velocity-select
  501. (Electric-command-loop 'org-velocity-select "Follow: "))))
  502. (defvar org-velocity-incremental-keymap
  503. (let ((map (make-sparse-keymap)))
  504. (define-key map [mouse-1] 'org-velocity-click-for-incremental)
  505. (define-key map [mouse-2] 'org-velocity-click-for-incremental)
  506. (define-key map "\C-v" 'scroll-up)
  507. (define-key map "\M-v" 'scroll-down)
  508. map))
  509. (defun org-velocity-click-for-incremental ()
  510. "Jump out of search and select hint clicked on."
  511. (interactive)
  512. (let ((ev last-command-event))
  513. (org-velocity-activate-button
  514. (nth (- (count-lines
  515. (point-min)
  516. (posn-point (event-start ev))) 2)
  517. org-velocity-index)))
  518. (throw 'click (current-buffer)))
  519. (defun org-velocity-displaying-completions-p ()
  520. "Is there a *Completions* buffer showing?"
  521. (get-window-with-predicate
  522. (lambda (w)
  523. (eq (buffer-local-value 'major-mode (window-buffer w))
  524. 'completion-list-mode))))
  525. (defun org-velocity-update ()
  526. "Display results of search without hinting.
  527. Stop searching once there are more matches than can be displayed."
  528. (unless (org-velocity-displaying-completions-p)
  529. (let* ((search (org-velocity-minibuffer-contents))
  530. (matches (org-velocity-present search :hide-hints t)))
  531. (cond ((null matches)
  532. (select-window (active-minibuffer-window))
  533. (unless (or (null search) (string= "" search))
  534. (minibuffer-message "No match; RET to create")))
  535. ((and (org-velocity-singlep matches)
  536. org-velocity-exit-on-match)
  537. (throw 'click search))
  538. (t
  539. (with-current-buffer (org-velocity-match-buffer)
  540. (use-local-map org-velocity-incremental-keymap)))))))
  541. (defvar dabbrev--last-abbrev)
  542. (defun org-velocity-dabbrev-completion-list (abbrev)
  543. "Return all dabbrev completions for ABBREV."
  544. ;; This is based on `dabbrev-completion'.
  545. (dabbrev--reset-global-variables)
  546. (setq dabbrev--last-abbrev abbrev)
  547. (dabbrev--find-all-expansions abbrev case-fold-search))
  548. (defvar org-velocity-local-completion-map
  549. (let ((map (make-sparse-keymap)))
  550. (set-keymap-parent map minibuffer-local-completion-map)
  551. (define-key map " " 'self-insert-command)
  552. (define-key map [remap minibuffer-complete] 'minibuffer-complete-word)
  553. map)
  554. "Keymap for completion with `completing-read'.")
  555. (defun org-velocity-read-with-completion (prompt)
  556. "Completing read with PROMPT."
  557. (let ((minibuffer-local-completion-map
  558. org-velocity-local-completion-map)
  559. (completion-no-auto-exit t)
  560. (crm-separator " "))
  561. (funcall
  562. (case org-velocity-search-method
  563. (phrase #'completing-read)
  564. (any #'completing-read-multiple)
  565. (all #'completing-read-multiple))
  566. prompt
  567. (completion-table-dynamic
  568. 'org-velocity-dabbrev-completion-list))))
  569. (defun org-velocity-read-string (prompt &optional initial-input)
  570. "Read string with PROMPT followed by INITIAL-INPUT."
  571. ;; The use of initial inputs to the minibuffer is deprecated (see
  572. ;; `read-from-minibuffer'), but in this case it is the user-friendly
  573. ;; thing to do.
  574. (minibuffer-with-setup-hook
  575. (lexical-let ((initial-input initial-input))
  576. (lambda ()
  577. (and initial-input (insert initial-input))
  578. (goto-char (point-max))))
  579. (if (eq org-velocity-search-method 'regexp)
  580. (read-regexp prompt)
  581. (if org-velocity-use-completion
  582. (org-velocity-read-with-completion prompt)
  583. (read-string prompt)))))
  584. (defun org-velocity-incremental-read (prompt)
  585. "Read string with PROMPT and display results incrementally."
  586. (let ((res
  587. (unwind-protect
  588. (let* ((match-window (display-buffer (org-velocity-match-buffer)))
  589. (org-velocity-index
  590. ;; Truncate the index to the size of the buffer to be
  591. ;; displayed.
  592. (with-selected-window match-window
  593. (if (> (window-height) (length org-velocity-index))
  594. ;; (subseq org-velocity-index 0 (window-height))
  595. (let ((hints (copy-sequence org-velocity-index)))
  596. (setcdr (nthcdr (window-height) hints) nil)
  597. hints)
  598. org-velocity-index))))
  599. (catch 'click
  600. (add-hook 'post-command-hook 'org-velocity-update)
  601. (if (eq org-velocity-search-method 'regexp)
  602. (read-regexp prompt)
  603. (if org-velocity-use-completion
  604. (org-velocity-read-with-completion prompt)
  605. (read-string prompt)))))
  606. (remove-hook 'post-command-hook 'org-velocity-update))))
  607. (if (bufferp res) (org-pop-to-buffer-same-window res) res)))
  608. (defun org-velocity (arg &optional search)
  609. "Read a search string SEARCH for Org-Velocity interface.
  610. This means that a buffer will display all headings where SEARCH
  611. occurs, where one can be selected by a mouse click or by typing
  612. its index. If SEARCH does not occur, then a new heading may be
  613. created named SEARCH.
  614. If `org-velocity-bucket' is defined and
  615. `org-velocity-always-use-bucket' is non-nil, then the bucket file
  616. will be used; otherwise, this will work when called in any Org
  617. file. Calling with ARG forces current file."
  618. (interactive "P")
  619. (let ((org-velocity-always-use-bucket
  620. (if arg nil org-velocity-always-use-bucket)))
  621. ;; complain if inappropriate
  622. (assert (org-velocity-bucket-file))
  623. (let ((org-velocity-bucket-buffer
  624. (find-file-noselect (org-velocity-bucket-file))))
  625. (unwind-protect
  626. (let ((dabbrev-search-these-buffers-only
  627. (list (org-velocity-bucket-buffer))))
  628. (org-velocity-engine
  629. (if org-velocity-search-is-incremental
  630. (org-velocity-incremental-read "Velocity search: ")
  631. (org-velocity-read-string "Velocity search: " search))))
  632. (progn
  633. (kill-buffer (org-velocity-match-buffer))
  634. (delete-other-windows))))))
  635. (defalias 'org-velocity-read 'org-velocity)
  636. (provide 'org-velocity)
  637. ;;; org-velocity.el ends here