org-velocity.el 31 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820
  1. ;;; org-velocity.el --- something like Notational Velocity for Org. -*- lexical-binding: t -*-
  2. ;; Copyright (C) 2010-2014 Paul M. Rodriguez
  3. ;; Author: Paul M. Rodriguez <paulmrodriguez@gmail.com>
  4. ;; Created: 2010-05-05
  5. ;; Version: 4.1
  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. (require 'cl-lib)
  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-show-previews t
  65. "Show previews of the text of each heading?"
  66. :group 'velocity
  67. :type 'boolean
  68. :safe 'booleanp)
  69. (defcustom org-velocity-exit-on-match nil
  70. "When searching incrementally, exit on a single match?"
  71. :group 'org-velocity
  72. :type 'boolean
  73. :safe 'booleanp)
  74. (defcustom org-velocity-force-new nil
  75. "Should exiting the minibuffer with C-j force a new entry?"
  76. :group 'org-velocity
  77. :type 'boolean
  78. :safe 'booleanp)
  79. (defcustom org-velocity-use-search-ring t
  80. "Push search to `search-ring' when visiting an entry?
  81. This means that C-s C-s will take you directly to the first
  82. instance of the search string."
  83. :group 'org-velocity
  84. :type 'boolean
  85. :safe 'booleanp)
  86. (defcustom org-velocity-always-use-bucket nil
  87. "Use bucket file even when called from an Org buffer?"
  88. :group 'org-velocity
  89. :type 'boolean
  90. :safe 'booleanp)
  91. (defcustom org-velocity-use-completion nil
  92. "Use completion?
  93. Notwithstanding the value of this option, calling
  94. `dabbrev-expand' always completes against the text of the bucket
  95. file."
  96. :group 'org-velocity
  97. :type '(choice
  98. (const :tag "Do not use completion" nil)
  99. (const :tag "Use completion" t))
  100. :safe 'booleanp)
  101. (defcustom org-velocity-search-method 'phrase
  102. "Match on whole phrase, any word, or all words?"
  103. :group 'org-velocity
  104. :type '(choice
  105. (const :tag "Match whole phrase" phrase)
  106. (const :tag "Match any word" any)
  107. (const :tag "Match all words" all)
  108. (const :tag "Match a regular expression" regexp))
  109. :safe (lambda (v) (memq v '(phrase any all regexp))))
  110. (defcustom org-velocity-capture-templates
  111. '(("v"
  112. "Velocity entry"
  113. entry
  114. (file "")
  115. "* %:search\n\n%i%?"))
  116. "Use these template with `org-capture'.
  117. Meanwhile `org-default-notes-file' is bound to `org-velocity-bucket-file'.
  118. The keyword :search inserts the current search.
  119. See the documentation for `org-capture-templates'."
  120. :group 'org-velocity
  121. :type (or (get 'org-capture-templates 'custom-type) 'list))
  122. (defcustom org-velocity-heading-level 1
  123. "Only match headings at this level or higher.
  124. 0 means to match headings at any level."
  125. :group 'org-velocity
  126. :type 'integer
  127. :safe (lambda (x)
  128. (and (integerp x)
  129. (>= x 0))))
  130. (defvar crm-separator) ;Ensure dynamic binding.
  131. (defsubst org-velocity-grab-preview ()
  132. "Grab preview of a subtree.
  133. The length of the preview is determined by `window-width'.
  134. Replace all contiguous whitespace with single spaces."
  135. (let* ((start (progn
  136. (forward-line 1)
  137. (if (looking-at org-property-start-re)
  138. (re-search-forward org-property-end-re)
  139. (1- (point)))))
  140. (string+props (buffer-substring
  141. start
  142. (min
  143. (+ start (window-width))
  144. (point-max)))))
  145. ;; We want to preserve the text properties so that, for example,
  146. ;; we don't end up with the raw text of links in the preview.
  147. (with-temp-buffer
  148. (insert string+props)
  149. (goto-char (point-min))
  150. (save-match-data
  151. (while (re-search-forward split-string-default-separators
  152. (point-max)
  153. t)
  154. (replace-match " ")))
  155. (buffer-string))))
  156. (cl-defstruct org-velocity-heading buffer position name level preview)
  157. (defsubst org-velocity-nearest-heading (position)
  158. "Return last heading at POSITION.
  159. If there is no last heading, return nil."
  160. (save-excursion
  161. (goto-char position)
  162. (re-search-backward (org-velocity-heading-regexp))
  163. (let ((components (org-heading-components)))
  164. (make-org-velocity-heading
  165. :buffer (current-buffer)
  166. :position (point)
  167. :name (nth 4 components)
  168. :level (nth 0 components)
  169. :preview (if org-velocity-show-previews
  170. (org-velocity-grab-preview))))))
  171. (defconst org-velocity-index
  172. (eval-when-compile
  173. (nconc (number-sequence 49 57) ;numbers
  174. (number-sequence 97 122) ;lowercase letters
  175. (number-sequence 65 90))) ;uppercase letters
  176. "List of chars for indexing results.")
  177. (defconst org-velocity-match-buffer-name "*Velocity matches*")
  178. (cl-defun org-velocity-heading-regexp (&optional (level org-velocity-heading-level))
  179. "Regexp to match headings at LEVEL or deeper."
  180. (if (zerop level)
  181. "^\\*+ "
  182. (format "^\\*\\{1,%d\\} " level)))
  183. (defvar org-velocity-search nil
  184. "Variable to bind to current search.")
  185. (defun org-velocity-buffer-file-name (&optional buffer)
  186. "Return the name of the file BUFFER saves to.
  187. Same as function `buffer-file-name' unless BUFFER is an indirect
  188. buffer or a minibuffer. In the former case, return the file name
  189. of the base buffer; in the latter, return the file name of
  190. `minibuffer-selected-window' (or its base buffer)."
  191. (let ((buffer (if (minibufferp buffer)
  192. (window-buffer (minibuffer-selected-window))
  193. buffer)))
  194. (buffer-file-name
  195. (or (buffer-base-buffer buffer)
  196. buffer))))
  197. (defun org-velocity-minibuffer-contents ()
  198. "Return the contents of the minibuffer when it is active."
  199. (when (active-minibuffer-window)
  200. (with-current-buffer (window-buffer (active-minibuffer-window))
  201. (minibuffer-contents))))
  202. (defun org-velocity-nix-minibuffer ()
  203. "Return the contents of the minibuffer and clear it."
  204. (when (active-minibuffer-window)
  205. (with-current-buffer (window-buffer (active-minibuffer-window))
  206. (prog1 (minibuffer-contents)
  207. (delete-minibuffer-contents)))))
  208. (defun org-velocity-bucket-file ()
  209. "Return the proper file for Org-Velocity to search.
  210. If `org-velocity-always-use-bucket' is t, use bucket file;
  211. complain if missing. Otherwise, if an Org file is current, then
  212. use it."
  213. (let ((org-velocity-bucket
  214. (when org-velocity-bucket (expand-file-name org-velocity-bucket)))
  215. (buffer
  216. (let ((buffer-file (org-velocity-buffer-file-name)))
  217. (when buffer-file
  218. ;; Use the target in capture buffers.
  219. (org-find-base-buffer-visiting buffer-file)))))
  220. (if org-velocity-always-use-bucket
  221. (or org-velocity-bucket (error "Bucket required but not defined"))
  222. (if (and (eq (buffer-local-value 'major-mode (or buffer (current-buffer)))
  223. 'org-mode)
  224. (org-velocity-buffer-file-name))
  225. (org-velocity-buffer-file-name)
  226. (or org-velocity-bucket
  227. (error "No bucket and not an Org file"))))))
  228. (defvar org-velocity-bucket-buffer nil)
  229. (defvar org-velocity-navigating nil)
  230. (defsubst org-velocity-bucket-buffer ()
  231. (or org-velocity-bucket-buffer
  232. (find-file-noselect (org-velocity-bucket-file))))
  233. (defsubst org-velocity-match-buffer ()
  234. "Return the proper buffer for Org-Velocity to display in."
  235. (get-buffer-create org-velocity-match-buffer-name))
  236. (defsubst org-velocity-match-window ()
  237. (get-buffer-window (org-velocity-match-buffer)))
  238. (defun org-velocity-beginning-of-headings ()
  239. "Goto the start of the first heading."
  240. (goto-char (point-min))
  241. ;; If we are before the first heading we could still be at the
  242. ;; first heading.
  243. (or (looking-at (org-velocity-heading-regexp))
  244. (re-search-forward (org-velocity-heading-regexp))))
  245. (defun org-velocity-make-indirect-buffer (heading)
  246. "Make or switch to an indirect buffer visiting HEADING."
  247. (let* ((bucket (org-velocity-heading-buffer heading))
  248. (name (org-velocity-heading-name heading))
  249. (existing (get-buffer name)))
  250. (if (and existing (buffer-base-buffer existing)
  251. (equal (buffer-base-buffer existing) bucket))
  252. existing
  253. (make-indirect-buffer
  254. bucket
  255. (generate-new-buffer-name (org-velocity-heading-name heading))
  256. t))))
  257. (defun org-velocity-capture ()
  258. "Record a note with `org-capture'."
  259. (let ((org-capture-templates
  260. org-velocity-capture-templates))
  261. (org-capture nil
  262. ;; This is no longer automatically selected.
  263. (when (null (cdr org-capture-templates))
  264. (caar org-capture-templates)))
  265. (when org-capture-mode
  266. (rename-buffer org-velocity-search t))))
  267. (defvar org-velocity-saved-winconf nil)
  268. (make-variable-buffer-local 'org-velocity-saved-winconf)
  269. (defun org-velocity-edit-entry (heading)
  270. (if org-velocity-navigating
  271. (org-velocity-edit-entry/inline heading)
  272. (org-velocity-edit-entry/indirect heading)))
  273. (cl-defun org-velocity-goto-entry (heading &key narrow)
  274. (goto-char (org-velocity-heading-position heading))
  275. (save-excursion
  276. (when narrow
  277. (org-narrow-to-subtree))
  278. (outline-show-all)))
  279. (defun org-velocity-edit-entry/inline (heading)
  280. "Edit entry at HEADING in the original buffer."
  281. (let ((buffer (org-velocity-heading-buffer heading)))
  282. (pop-to-buffer buffer)
  283. (with-current-buffer buffer
  284. (org-velocity-goto-entry heading))))
  285. (defun org-velocity-format-header-line (control-string &rest args)
  286. (set (make-local-variable 'header-line-format)
  287. (apply #'format control-string args)))
  288. (defun org-velocity-edit-entry/indirect (heading)
  289. "Edit entry at HEADING in an indirect buffer."
  290. (let ((winconf (current-window-configuration))
  291. (dd default-directory)
  292. (buffer (org-velocity-make-indirect-buffer heading))
  293. (inhibit-point-motion-hooks t)
  294. (inhibit-field-text-motion t))
  295. (with-current-buffer buffer
  296. (setq default-directory dd) ;Inherit default directory.
  297. (setq org-velocity-saved-winconf winconf)
  298. (org-velocity-goto-entry heading :narrow t)
  299. (goto-char (point-max))
  300. (add-hook 'org-ctrl-c-ctrl-c-hook 'org-velocity-dismiss nil t))
  301. (pop-to-buffer buffer)
  302. (org-velocity-format-header-line
  303. "%s Use C-c C-c to finish."
  304. (abbreviate-file-name
  305. (buffer-file-name
  306. (org-velocity-heading-buffer heading))))))
  307. (defun org-velocity-dismiss ()
  308. "Save current entry and close indirect buffer."
  309. (let ((winconf org-velocity-saved-winconf))
  310. (prog1 t ;Tell hook we're done.
  311. (save-buffer)
  312. (kill-buffer)
  313. (when (window-configuration-p winconf)
  314. (set-window-configuration winconf)))))
  315. (defun org-velocity-visit-button (button)
  316. (run-hooks 'mouse-leave-buffer-hook)
  317. (when org-velocity-use-search-ring
  318. (add-to-history 'search-ring
  319. (button-get button 'search)
  320. search-ring-max))
  321. (let ((match (button-get button 'match)))
  322. (throw 'org-velocity-done match)))
  323. (define-button-type 'org-velocity-button
  324. 'action #'org-velocity-visit-button
  325. 'follow-link 'mouse-face)
  326. (defsubst org-velocity-buttonize (heading)
  327. "Insert HEADING as a text button with no hints."
  328. (insert-text-button
  329. (propertize (org-velocity-heading-name heading) 'face 'link)
  330. :type 'org-velocity-button
  331. 'match heading
  332. 'search org-velocity-search))
  333. (defsubst org-velocity-insert-preview (heading)
  334. (when org-velocity-show-previews
  335. (insert-char ?\ 1)
  336. (insert
  337. (propertize
  338. (org-velocity-heading-preview heading)
  339. 'face 'shadow))))
  340. (defvar org-velocity-recursive-headings nil)
  341. (defvar org-velocity-recursive-search nil)
  342. (cl-defun org-velocity-search-with (fun style search
  343. &key (headings org-velocity-recursive-headings))
  344. (if headings
  345. (save-restriction
  346. (dolist (heading headings)
  347. (widen)
  348. (let ((start (org-velocity-heading-position heading)))
  349. (goto-char start)
  350. (let ((end (save-excursion
  351. (org-end-of-subtree)
  352. (point))))
  353. (narrow-to-region start end)
  354. (org-velocity-search-with fun style search
  355. :headings nil)))))
  356. (cl-ecase style
  357. ((phrase any regexp)
  358. (cl-block nil
  359. (while (re-search-forward search nil t)
  360. (let ((match (org-velocity-nearest-heading (point))))
  361. (funcall fun match))
  362. ;; Skip to the next heading.
  363. (unless (re-search-forward (org-velocity-heading-regexp) nil t)
  364. (cl-return)))))
  365. ((all)
  366. (let ((keywords
  367. (cl-loop for word in (split-string search)
  368. collect (concat "\\<" (regexp-quote word) "\\>"))))
  369. (org-map-entries
  370. (lambda ()
  371. ;; Only search the subtree once.
  372. (setq org-map-continue-from
  373. (save-excursion
  374. (org-end-of-subtree)
  375. (point)))
  376. (when (cl-loop for word in keywords
  377. always (save-excursion
  378. (re-search-forward word org-map-continue-from t)))
  379. (let ((match (org-velocity-nearest-heading (match-end 0))))
  380. (funcall fun match))))))))))
  381. (defun org-velocity-all-results (style search)
  382. (with-current-buffer (org-velocity-bucket-buffer)
  383. (save-excursion
  384. (goto-char (point-min))
  385. (let (matches)
  386. (org-velocity-search-with (lambda (match)
  387. (push match matches))
  388. style
  389. search)
  390. (nreverse matches)))))
  391. (defsubst org-velocity-present-match (hint match)
  392. (with-current-buffer (org-velocity-match-buffer)
  393. (when hint (insert "#" hint " "))
  394. (org-velocity-buttonize match)
  395. (org-velocity-insert-preview match)
  396. (newline)))
  397. (defun org-velocity-present-search (style search hide-hints)
  398. (let ((hints org-velocity-index) matches)
  399. (cl-block nil
  400. (org-velocity-search-with (lambda (match)
  401. (unless hints
  402. (cl-return))
  403. (let ((hint (if hide-hints
  404. nil
  405. (car hints))))
  406. (org-velocity-present-match hint match))
  407. (pop hints)
  408. (push match matches))
  409. style
  410. search))
  411. (nreverse matches)))
  412. (defun org-velocity-restrict-search ()
  413. (interactive)
  414. (let ((search (org-velocity-nix-minibuffer)))
  415. (when (equal search "")
  416. (error "No search to restrict to"))
  417. (push search org-velocity-recursive-search)
  418. (setq org-velocity-recursive-headings
  419. (org-velocity-all-results
  420. org-velocity-search-method
  421. search))
  422. ;; TODO We could extend the current search instead of starting
  423. ;; over.
  424. (org-velocity-update-match-header)
  425. (minibuffer-message "Restricting search to %s" search)))
  426. (cl-defun org-velocity-update-match-header (&key (match-buffer (org-velocity-match-buffer))
  427. (bucket-buffer (org-velocity-bucket-buffer))
  428. (search-method org-velocity-search-method))
  429. (let ((navigating? org-velocity-navigating)
  430. (recursive? org-velocity-recursive-search))
  431. (with-current-buffer match-buffer
  432. (org-velocity-format-header-line
  433. "%s search in %s%s (%s mode)"
  434. (capitalize (symbol-name search-method))
  435. (abbreviate-file-name (buffer-file-name bucket-buffer))
  436. (if (not recursive?)
  437. ""
  438. (let ((sep " > "))
  439. (concat sep (string-join (reverse recursive?) sep))))
  440. (if navigating? "nav" "notes")))))
  441. (cl-defun org-velocity-present (search &key hide-hints)
  442. "Buttonize matches for SEARCH in `org-velocity-match-buffer'.
  443. If HIDE-HINTS is non-nil, display entries without indices. SEARCH
  444. binds `org-velocity-search'.
  445. Return matches."
  446. (let ((match-buffer (org-velocity-match-buffer))
  447. (bucket-buffer (org-velocity-bucket-buffer))
  448. (search-method org-velocity-search-method))
  449. (if (and (stringp search) (not (string= "" search)))
  450. ;; Fold case when the search string is all lowercase.
  451. (let ((case-fold-search (equal search (downcase search)))
  452. (truncate-partial-width-windows t))
  453. (with-current-buffer match-buffer
  454. (erase-buffer)
  455. ;; Permanent locals.
  456. (setq cursor-type nil
  457. truncate-lines t)
  458. (org-velocity-update-match-header
  459. :match-buffer match-buffer
  460. :bucket-buffer bucket-buffer
  461. :search-method search-method))
  462. (prog1
  463. (with-current-buffer bucket-buffer
  464. (widen)
  465. (let* ((inhibit-point-motion-hooks t)
  466. (inhibit-field-text-motion t)
  467. (anchored? (string-match-p "^\\s-" search))
  468. (search
  469. (cl-ecase search-method
  470. (all search)
  471. (phrase
  472. (if anchored?
  473. (regexp-quote search)
  474. ;; Anchor the search to the start of a word.
  475. (concat "\\<" (regexp-quote search))))
  476. (any
  477. (concat "\\<" (regexp-opt (split-string search))))
  478. (regexp search))))
  479. (save-excursion
  480. (org-velocity-beginning-of-headings)
  481. (condition-case lossage
  482. (org-velocity-present-search search-method search hide-hints)
  483. (invalid-regexp
  484. (minibuffer-message "%s" lossage))))))
  485. (with-current-buffer match-buffer
  486. (goto-char (point-min)))))
  487. (with-current-buffer match-buffer
  488. (erase-buffer)))))
  489. (defun org-velocity-store-link ()
  490. "Function for `org-store-link-functions'."
  491. (if org-velocity-search
  492. (org-store-link-props
  493. :search org-velocity-search)))
  494. (add-hook 'org-store-link-functions 'org-velocity-store-link)
  495. (cl-defun org-velocity-create (search &key ask)
  496. "Create new heading named SEARCH.
  497. If ASK is non-nil, ask first."
  498. (when (or (null ask) (y-or-n-p "No match found, create? "))
  499. (let ((org-velocity-search search)
  500. (org-default-notes-file (org-velocity-bucket-file))
  501. ;; save a stored link
  502. org-store-link-plist)
  503. (org-velocity-capture))
  504. search))
  505. (defun org-velocity-engine (search)
  506. "Display a list of headings where SEARCH occurs."
  507. (let ((org-velocity-search search))
  508. (unless (or
  509. (not (stringp search))
  510. (string= "" search)) ;exit on empty string
  511. (cl-case
  512. (if (and org-velocity-force-new (eq last-command-event ?\C-j))
  513. :force
  514. (let* ((org-velocity-index (org-velocity-adjust-index))
  515. (matches (org-velocity-present search)))
  516. (cond ((null matches) :new)
  517. ((null (cdr matches)) :follow)
  518. (t :prompt))))
  519. (:prompt (progn
  520. (pop-to-buffer (org-velocity-match-buffer))
  521. (let ((hint (org-velocity-electric-read-hint)))
  522. (when hint (cl-case hint
  523. (:edit (org-velocity-read nil search))
  524. (:force (org-velocity-create search))
  525. (otherwise (org-velocity-activate-button hint)))))))
  526. (:new (unless (org-velocity-create search :ask t)
  527. (org-velocity-read nil search)))
  528. (:force (org-velocity-create search))
  529. (:follow (if (y-or-n-p "One match, follow? ")
  530. (progn
  531. (set-buffer (org-velocity-match-buffer))
  532. (goto-char (point-min))
  533. (button-activate (next-button (point))))
  534. (org-velocity-read nil search)))))))
  535. (defun org-velocity-activate-button (char)
  536. "Go to button on line number associated with CHAR in `org-velocity-index'."
  537. (goto-char (point-min))
  538. (forward-line (cl-position char org-velocity-index))
  539. (goto-char
  540. (button-start
  541. (next-button (point))))
  542. (message "%s" (button-label (button-at (point))))
  543. (button-activate (button-at (point))))
  544. (defun org-velocity-electric-undefined ()
  545. "Complain about an undefined key."
  546. (interactive)
  547. (message "%s"
  548. (substitute-command-keys
  549. "\\[org-velocity-electric-new] for new entry,
  550. \\[org-velocity-electric-edit] to edit search,
  551. \\[scroll-up] to scroll up,
  552. \\[scroll-down] to scroll down,
  553. \\[keyboard-quit] to quit."))
  554. (sit-for 4))
  555. (defun org-velocity-electric-follow (ev)
  556. "Follow a hint indexed by keyboard event EV."
  557. (interactive (list last-command-event))
  558. (if (not (> (cl-position ev org-velocity-index)
  559. (1- (count-lines (point-min) (point-max)))))
  560. (throw 'org-velocity-select ev)
  561. (call-interactively 'org-velocity-electric-undefined)))
  562. (defun org-velocity-electric-edit ()
  563. "Edit the search string."
  564. (interactive)
  565. (throw 'org-velocity-select :edit))
  566. (defun org-velocity-electric-new ()
  567. "Force a new entry."
  568. (interactive)
  569. (throw 'org-velocity-select :force))
  570. (defvar org-velocity-electric-map
  571. (let ((map (make-sparse-keymap)))
  572. (define-key map [t] 'org-velocity-electric-undefined)
  573. (dolist (c org-velocity-index)
  574. (define-key map (char-to-string c)
  575. 'org-velocity-electric-follow))
  576. (define-key map "0" 'org-velocity-electric-new)
  577. (define-key map "\C-v" 'scroll-up)
  578. (define-key map "\M-v" 'scroll-down)
  579. (define-key map (kbd "RET") 'org-velocity-electric-edit)
  580. (define-key map [mouse-1] nil)
  581. (define-key map [mouse-2] nil)
  582. (define-key map [escape] 'keyboard-quit)
  583. (define-key map "\C-h" 'help-command)
  584. map))
  585. (defun org-velocity-electric-read-hint ()
  586. "Read index of button electrically."
  587. (with-current-buffer (org-velocity-match-buffer)
  588. (when (featurep 'evil)
  589. ;; NB Idempotent.
  590. (evil-make-overriding-map org-velocity-electric-map))
  591. (use-local-map org-velocity-electric-map)
  592. (catch 'org-velocity-select
  593. (Electric-command-loop 'org-velocity-select "Follow: "))))
  594. (defvar org-velocity-incremental-keymap
  595. (let ((map (make-sparse-keymap)))
  596. (define-key map "\C-v" 'scroll-up)
  597. (define-key map "\M-v" 'scroll-down)
  598. map))
  599. (defun org-velocity-displaying-completions-p ()
  600. "Is there a *Completions* buffer showing?"
  601. (get-window-with-predicate
  602. (lambda (w)
  603. (eq (buffer-local-value 'major-mode (window-buffer w))
  604. 'completion-list-mode))))
  605. (defun org-velocity-update ()
  606. "Display results of search without hinting."
  607. (unless (org-velocity-displaying-completions-p)
  608. (let* ((search (org-velocity-minibuffer-contents))
  609. (matches (org-velocity-present search :hide-hints t)))
  610. (cond ((null matches)
  611. (select-window (active-minibuffer-window))
  612. (unless (or (null search) (= (length search) 0))
  613. (minibuffer-message "No match; RET to create")))
  614. ((and (null (cdr matches))
  615. org-velocity-exit-on-match)
  616. (throw 'click search))
  617. (t
  618. (with-current-buffer (org-velocity-match-buffer)
  619. (use-local-map org-velocity-incremental-keymap)))))))
  620. (defvar dabbrev--last-abbreviation)
  621. (defun org-velocity-dabbrev-completion-list (abbrev)
  622. "Return all dabbrev completions for ABBREV."
  623. ;; This is based on `dabbrev-completion'.
  624. (dabbrev--reset-global-variables)
  625. (setq dabbrev--last-abbreviation abbrev)
  626. (dabbrev--find-all-expansions abbrev case-fold-search))
  627. (defvar org-velocity-local-completion-map
  628. (let ((map (make-sparse-keymap)))
  629. (set-keymap-parent map minibuffer-local-completion-map)
  630. (define-key map " " 'self-insert-command)
  631. (define-key map "?" 'self-insert-command)
  632. (define-key map [remap minibuffer-complete] 'minibuffer-complete-word)
  633. (define-key map [(control ?@)] 'org-velocity-restrict-search)
  634. (define-key map [(control ?\s)] 'org-velocity-restrict-search)
  635. map)
  636. "Keymap for completion with `completing-read'.")
  637. (defun org-velocity-read-with-completion (prompt)
  638. "Completing read with PROMPT."
  639. (let ((minibuffer-local-completion-map
  640. org-velocity-local-completion-map)
  641. (completion-no-auto-exit t)
  642. (crm-separator " "))
  643. (completing-read prompt
  644. (completion-table-dynamic
  645. 'org-velocity-dabbrev-completion-list))))
  646. (cl-defun org-velocity-adjust-index
  647. (&optional (match-window (org-velocity-match-window)))
  648. "Truncate or extend `org-velocity-index' to the lines in
  649. MATCH-WINDOW."
  650. (with-selected-window match-window
  651. (let ((lines (window-height))
  652. (hints (length org-velocity-index)))
  653. (cond ((= lines hints)
  654. org-velocity-index)
  655. ;; Truncate the index to the size of
  656. ;; the buffer to be displayed.
  657. ((< lines hints)
  658. (cl-subseq org-velocity-index 0 lines))
  659. ;; If the window is so tall we run out of indices, at
  660. ;; least make the additional results clickable.
  661. ((> lines hints)
  662. (append org-velocity-index
  663. (make-list (- lines hints) nil)))))))
  664. (defun org-velocity-incremental-read (prompt)
  665. "Read string with PROMPT and display results incrementally.
  666. Stop searching once there are more matches than can be
  667. displayed."
  668. (let ((res
  669. (unwind-protect
  670. (let* ((match-window (display-buffer (org-velocity-match-buffer)))
  671. (org-velocity-index (org-velocity-adjust-index match-window)))
  672. (catch 'click
  673. (add-hook 'post-command-hook 'org-velocity-update)
  674. (cond ((eq org-velocity-search-method 'regexp)
  675. (read-regexp prompt))
  676. (org-velocity-use-completion
  677. (org-velocity-read-with-completion prompt))
  678. (t (read-string prompt)))))
  679. (remove-hook 'post-command-hook 'org-velocity-update))))
  680. (if (bufferp res) (org-pop-to-buffer-same-window res) res)))
  681. (defun org-velocity (arg &optional search)
  682. "Read a search string SEARCH for Org-Velocity interface.
  683. This means that a buffer will display all headings where SEARCH
  684. occurs, where one can be selected by a mouse click or by typing
  685. its index. If SEARCH does not occur, then a new heading may be
  686. created named SEARCH.
  687. If `org-velocity-bucket' is defined and
  688. `org-velocity-always-use-bucket' is non-nil, then the bucket file
  689. will be used; otherwise, this will work when called in any Org
  690. file.
  691. Calling with ARG reverses which file – the current file or the
  692. bucket file – to use. If the bucket file would have been used,
  693. then the current file is used instead, and vice versa."
  694. (interactive "P")
  695. (let ((org-velocity-always-use-bucket
  696. (if org-velocity-always-use-bucket
  697. (not arg)
  698. arg)))
  699. ;; complain if inappropriate
  700. (cl-assert (org-velocity-bucket-file))
  701. (let* ((starting-buffer (current-buffer))
  702. (org-velocity-bucket-buffer
  703. (find-file-noselect (org-velocity-bucket-file)))
  704. (org-velocity-navigating
  705. (eq starting-buffer org-velocity-bucket-buffer))
  706. (org-velocity-recursive-headings '())
  707. (org-velocity-recursive-search '())
  708. (org-velocity-heading-level
  709. (if org-velocity-navigating
  710. 0
  711. org-velocity-heading-level))
  712. (dabbrev-search-these-buffers-only
  713. (list org-velocity-bucket-buffer)))
  714. (unwind-protect
  715. (let ((match
  716. (catch 'org-velocity-done
  717. (org-velocity-engine
  718. (or search
  719. (org-velocity-incremental-read "Velocity search: ")))
  720. nil)))
  721. (when (org-velocity-heading-p match)
  722. (org-velocity-edit-entry match)))
  723. (kill-buffer (org-velocity-match-buffer))))))
  724. (defalias 'org-velocity-read 'org-velocity)
  725. (provide 'org-velocity)
  726. ;;; org-velocity.el ends here