| commit | author | age | ||
| 5cb5f7 | 1 | ;;; helm-org.el --- Helm for org headlines and keywords completion -*- lexical-binding: t -*- |
| C | 2 | |
| 3 | ;; Copyright (C) 2012 ~ 2018 Thierry Volpiatto <thierry.volpiatto@gmail.com> | |
| 4 | ||
| 5 | ;; This program is free software; you can redistribute it and/or modify | |
| 6 | ;; it under the terms of the GNU General Public License as published by | |
| 7 | ;; the Free Software Foundation, either version 3 of the License, or | |
| 8 | ;; (at your option) any later version. | |
| 9 | ||
| 10 | ;; This program is distributed in the hope that it will be useful, | |
| 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
| 13 | ;; GNU General Public License for more details. | |
| 14 | ||
| 15 | ;; You should have received a copy of the GNU General Public License | |
| 16 | ;; along with this program. If not, see <http://www.gnu.org/licenses/>. | |
| 17 | ||
| 18 | ;;; Code: | |
| 19 | (require 'cl-lib) | |
| 20 | (require 'helm) | |
| 21 | (require 'helm-utils) | |
| 22 | (require 'org) | |
| 23 | ||
| 24 | ;; Load org-with-point-at macro when compiling | |
| 25 | (eval-when-compile | |
| 26 | (require 'org-macs)) | |
| 27 | ||
| 28 | (declare-function org-agenda-switch-to "org-agenda.el") | |
| 29 | ||
| 30 | (defgroup helm-org nil | |
| 31 | "Org related functions for helm." | |
| 32 | :group 'helm) | |
| 33 | ||
| 34 | (defcustom helm-org-headings-fontify nil | |
| 35 | "Fontify org buffers before parsing them. | |
| 36 | This reflect fontification in helm-buffer when non--nil. | |
| 37 | NOTE: This will be slow on large org buffers." | |
| 38 | :group 'helm-org | |
| 39 | :type 'boolean) | |
| 40 | ||
| 41 | (defcustom helm-org-format-outline-path nil | |
| 42 | "Show all org level as path." | |
| 43 | :group 'helm-org | |
| 44 | :type 'boolean) | |
| 45 | ||
| 46 | (defcustom helm-org-show-filename nil | |
| 47 | "Show org filenames in `helm-org-agenda-files-headings' when non--nil. | |
| 48 | Note this have no effect in `helm-org-in-buffer-headings'." | |
| 49 | :group 'helm-org | |
| 50 | :type 'boolean) | |
| 51 | ||
| 52 | (defcustom helm-org-headings-min-depth 1 | |
| 53 | "Minimum depth of org headings to start with." | |
| 54 | :group 'helm-org | |
| 55 | :type 'integer) | |
| 56 | ||
| 57 | (defcustom helm-org-headings-max-depth 8 | |
| 58 | "Go down to this maximum depth of org headings." | |
| 59 | :group 'helm-org | |
| 60 | :type 'integer) | |
| 61 | ||
| 62 | (defcustom helm-org-headings-actions | |
| 63 | '(("Go to heading" . helm-org-goto-marker) | |
| 64 | ("Open in indirect buffer `C-c i'" . helm-org--open-heading-in-indirect-buffer) | |
| 65 | ("Refile heading(s) (marked-to-selected|current-to-selected) `C-c w`" . helm-org--refile-heading-to) | |
| 66 | ("Insert link to this heading `C-c l`" . helm-org-insert-link-to-heading-at-marker)) | |
| 67 | "Default actions alist for | |
| 68 | `helm-source-org-headings-for-files'." | |
| 69 | :group 'helm-org | |
| 70 | :type '(alist :key-type string :value-type function)) | |
| 71 | ||
| 72 | (defcustom helm-org-truncate-lines t | |
| 73 | "Truncate org-header-lines when non-nil" | |
| 74 | :type 'boolean | |
| 75 | :group 'helm-org) | |
| 76 | ||
| 77 | (defcustom helm-org-ignore-autosaves nil | |
| 78 | "Ignore autosave files when starting `helm-org-agenda-files-headings'." | |
| 79 | :type 'boolean | |
| 80 | :group 'helm-org) | |
| 81 | ||
| 82 | ||
| 83 | ;;; Org capture templates | |
| 84 | ;; | |
| 85 | ;; | |
| 86 | (defvar org-capture-templates) | |
| 87 | (defun helm-source-org-capture-templates () | |
| 88 | (helm-build-sync-source "Org Capture Templates:" | |
| 89 | :candidates (cl-loop for template in org-capture-templates | |
| 90 | collect (cons (nth 1 template) (nth 0 template))) | |
| 91 | :action '(("Do capture" . (lambda (template-shortcut) | |
| 92 | (org-capture nil template-shortcut)))))) | |
| 93 | ||
| 94 | ;;; Org headings | |
| 95 | ;; | |
| 96 | ;; | |
| 97 | (defun helm-org-goto-marker (marker) | |
| 98 | (switch-to-buffer (marker-buffer marker)) | |
| 99 | (goto-char (marker-position marker)) | |
| 100 | (org-show-context) | |
| 101 | (re-search-backward "^\\*+ " nil t) | |
| 102 | (org-show-entry)) | |
| 103 | ||
| 104 | (defun helm-org--open-heading-in-indirect-buffer (marker) | |
| 105 | (helm-org-goto-marker marker) | |
| 106 | (org-tree-to-indirect-buffer) | |
| 107 | ||
| 108 | ;; Put the non-indirect buffer at the bottom of the prev-buffers | |
| 109 | ;; list so it won't be selected when the indirect buffer is killed | |
| 110 | (set-window-prev-buffers nil (append (cdr (window-prev-buffers)) | |
| 111 | (car (window-prev-buffers))))) | |
| 112 | ||
| 113 | (defun helm-org-run-open-heading-in-indirect-buffer () | |
| 114 | "Open selected Org heading in an indirect buffer." | |
| 115 | (interactive) | |
| 116 | (with-helm-alive-p | |
| 117 | (helm-exit-and-execute-action #'helm-org--open-heading-in-indirect-buffer))) | |
| 118 | (put 'helm-org-run-open-heading-in-indirect-buffer 'helm-only t) | |
| 119 | ||
| 120 | (defvar helm-org-headings-map | |
| 121 | (let ((map (make-sparse-keymap))) | |
| 122 | (set-keymap-parent map helm-map) | |
| 123 | (define-key map (kbd "C-c i") 'helm-org-run-open-heading-in-indirect-buffer) | |
| 124 | (define-key map (kbd "C-c w") 'helm-org-run-refile-heading-to) | |
| 125 | (define-key map (kbd "C-c l") 'helm-org-run-insert-link-to-heading-at-marker) | |
| 126 | map) | |
| 127 | "Keymap for `helm-source-org-headings-for-files'.") | |
| 128 | ||
| 129 | (defclass helm-org-headings-class (helm-source-sync) | |
| 130 | ((parents | |
| 131 | :initarg :parents | |
| 132 | :initform nil | |
| 133 | :custom boolean) | |
| 134 | (match :initform | |
| 135 | (lambda (candidate) | |
| 136 | (string-match | |
| 137 | helm-pattern | |
| 138 | (helm-aif (get-text-property 0 'helm-real-display candidate) | |
| 139 | it | |
| 140 | candidate)))) | |
| 141 | (help-message :initform 'helm-org-headings-help-message) | |
| 142 | (action :initform 'helm-org-headings-actions) | |
| 143 | (keymap :initform 'helm-org-headings-map) | |
| 144 | (group :initform 'helm-org))) | |
| 145 | ||
| 146 | (defmethod helm--setup-source :after ((source helm-org-headings-class)) | |
| 147 | (let ((parents (slot-value source 'parents))) | |
| 148 | (setf (slot-value source 'candidate-transformer) | |
| 149 | (lambda (candidates) | |
| 150 | (let ((cands (helm-org-get-candidates candidates parents))) | |
| 151 | (if parents (nreverse cands) cands)))))) | |
| 152 | ||
| 153 | (defun helm-source-org-headings-for-files (filenames &optional parents) | |
| 154 | (helm-make-source "Org Headings" 'helm-org-headings-class | |
| 155 | :filtered-candidate-transformer 'helm-org-startup-visibility | |
| 156 | :parents parents | |
| 157 | :candidates filenames)) | |
| 158 | ||
| 159 | (defun helm-org-startup-visibility (candidates _source) | |
| 160 | "Indent headings and hide leading stars displayed in the helm buffer. | |
| 161 | If `org-startup-indented' and `org-hide-leading-stars' are nil, do | |
| 162 | nothing to CANDIDATES." | |
| 163 | (cl-loop for i in candidates | |
| 164 | collect | |
| 165 | ;; Transformation is not needed if these variables are t. | |
| 166 | (if (or helm-org-show-filename helm-org-format-outline-path) | |
| 167 | (cons | |
| 168 | (car i) (cdr i)) | |
| 169 | (cons | |
| 170 | (if helm-org-headings-fontify | |
| 171 | (when (string-match "^\\(\\**\\)\\(\\* \\)\\(.*\n?\\)" (car i)) | |
| 172 | (replace-match "\\1\\2\\3" t nil (car i))) | |
| 173 | (when (string-match "^\\(\\**\\)\\(\\* \\)\\(.*\n?\\)" (car i)) | |
| 174 | (let ((foreground (org-find-invisible-foreground))) | |
| 175 | (with-helm-current-buffer | |
| 176 | (cond | |
| 177 | ;; org-startup-indented is t, and org-hide-leading-stars is t | |
| 178 | ;; Or: #+STARTUP: indent hidestars | |
| 179 | ((and org-startup-indented org-hide-leading-stars) | |
| 180 | (with-helm-buffer | |
| 181 | (require 'org-indent) | |
| 182 | (org-indent-mode 1) | |
| 183 | (replace-match | |
| 184 | (format "%s\\2\\3" | |
| 185 | (propertize (replace-match "\\1" t nil (car i)) | |
| 186 | 'face `(:foreground ,foreground))) | |
| 187 | t nil (car i)))) | |
| 188 | ;; org-startup-indented is nil, org-hide-leading-stars is t | |
| 189 | ;; Or: #+STARTUP: noindent hidestars | |
| 190 | ((and (not org-startup-indented) org-hide-leading-stars) | |
| 191 | (with-helm-buffer | |
| 192 | (replace-match | |
| 193 | (format "%s\\2\\3" | |
| 194 | (propertize (replace-match "\\1" t nil (car i)) | |
| 195 | 'face `(:foreground ,foreground))) | |
| 196 | t nil (car i)))) | |
| 197 | ;; org-startup-indented is nil, and org-hide-leading-stars is nil | |
| 198 | ;; Or: #+STARTUP: noindent showstars | |
| 199 | (t | |
| 200 | (with-helm-buffer | |
| 201 | (replace-match "\\1\\2\\3" t nil (car i))))))))) | |
| 202 | (cdr i))))) | |
| 203 | ||
| 204 | (defun helm-org-get-candidates (filenames &optional parents) | |
| 205 | (apply #'append | |
| 206 | (mapcar (lambda (filename) | |
| 207 | (helm-org--get-candidates-in-file | |
| 208 | filename | |
| 209 | helm-org-headings-fontify | |
| 210 | (or parents (null helm-org-show-filename)) | |
| 211 | parents)) | |
| 212 | filenames))) | |
| 213 | ||
| 214 | (defun helm-org--get-candidates-in-file (filename &optional fontify nofname parents) | |
| 215 | (with-current-buffer (pcase filename | |
| 216 | ((pred bufferp) filename) | |
| 217 | ((pred stringp) (find-file-noselect filename t))) | |
| 218 | (let ((match-fn (if fontify | |
| 219 | #'match-string | |
| 220 | #'match-string-no-properties)) | |
| 221 | (search-fn (lambda () | |
| 222 | (re-search-forward | |
| 223 | org-complex-heading-regexp nil t))) | |
| 224 | (file (unless (or (bufferp filename) nofname) | |
| 225 | (concat (helm-basename filename) ":")))) | |
| 226 | (when parents | |
| 227 | (add-function :around (var search-fn) | |
| 228 | (lambda (old-fn &rest args) | |
| 229 | (when (org-up-heading-safe) | |
| 230 | (apply old-fn args))))) | |
| 231 | (save-excursion | |
| 232 | (save-restriction | |
| 233 | (unless (and (bufferp filename) | |
| 234 | (buffer-base-buffer filename)) | |
| 235 | ;; Only widen direct buffers, not indirect ones. | |
| 236 | (widen)) | |
| 237 | (unless parents (goto-char (point-min))) | |
| 238 | ;; clear cache for new version of org-get-outline-path | |
| 239 | (and (boundp 'org-outline-path-cache) | |
| 240 | (setq org-outline-path-cache nil)) | |
| 241 | (cl-loop with width = (window-width (helm-window)) | |
| 242 | while (funcall search-fn) | |
| 243 | for beg = (point-at-bol) | |
| 244 | for end = (point-at-eol) | |
| 245 | when (and fontify | |
| 246 | (null (text-property-any | |
| 247 | beg end 'fontified t))) | |
| 248 | do (jit-lock-fontify-now beg end) | |
| 249 | for level = (length (match-string-no-properties 1)) | |
| 250 | for heading = (funcall match-fn 4) | |
| 251 | if (and (>= level helm-org-headings-min-depth) | |
| 252 | (<= level helm-org-headings-max-depth)) | |
| 253 | collect `(,(propertize | |
| 254 | (if helm-org-format-outline-path | |
| 255 | (org-format-outline-path | |
| 256 | ;; org-get-outline-path changed in signature and behaviour since org's | |
| 257 | ;; commit 105a4466971. Let's fall-back to the new version in case | |
| 258 | ;; of wrong-number-of-arguments error. | |
| 259 | (condition-case nil | |
| 260 | (append (apply #'org-get-outline-path | |
| 261 | (unless parents | |
| 262 | (list t level heading))) | |
| 263 | (list heading)) | |
| 264 | (wrong-number-of-arguments | |
| 265 | (org-get-outline-path t t))) | |
| 266 | width file) | |
| 267 | (if file | |
| 268 | (concat file (funcall match-fn 0)) | |
| 269 | (funcall match-fn 0))) | |
| 270 | 'helm-real-display heading) | |
| 271 | . ,(point-marker)))))))) | |
| 272 | ||
| 273 | (defun helm-org-insert-link-to-heading-at-marker (marker) | |
| 274 | (with-current-buffer (marker-buffer marker) | |
| 275 | (let ((heading-name (save-excursion (goto-char (marker-position marker)) | |
| 276 | (nth 4 (org-heading-components)))) | |
| 277 | (file-name (buffer-file-name))) | |
| 278 | (with-helm-current-buffer | |
| 279 | (org-insert-link | |
| 280 | file-name (concat "file:" file-name "::*" heading-name)))))) | |
| 281 | ||
| 282 | (defun helm-org-run-insert-link-to-heading-at-marker () | |
| 283 | (interactive) | |
| 284 | (with-helm-alive-p | |
| 285 | (helm-exit-and-execute-action | |
| 286 | 'helm-org-insert-link-to-heading-at-marker))) | |
| 287 | ||
| 288 | (defun helm-org--refile-heading-to (marker) | |
| 289 | "Refile headings to heading at MARKER. | |
| 290 | If multiple candidates are marked in the Helm session, they will | |
| 291 | all be refiled. If no headings are marked, the selected heading | |
| 292 | will be refiled." | |
| 293 | (let* ((victims (with-helm-buffer (helm-marked-candidates))) | |
| 294 | (buffer (marker-buffer marker)) | |
| 295 | (filename (buffer-file-name buffer)) | |
| 296 | (rfloc (list nil filename nil marker))) | |
| 297 | (when (and (= 1 (length victims)) | |
| 298 | (equal (helm-get-selection) (car victims))) | |
| 299 | ;; No candidates are marked; we are refiling the entry at point | |
| 300 | ;; to the selected heading | |
| 301 | (setq victims (list (point)))) | |
| 302 | ;; Probably best to check that everything returned a value | |
| 303 | (when (and victims buffer filename rfloc) | |
| 304 | (cl-loop for victim in victims | |
| 305 | do (org-with-point-at victim | |
| 306 | (org-refile nil nil rfloc)))))) | |
| 307 | ||
| 308 | (defun helm-org-in-buffer-preselect () | |
| 309 | (if (org-on-heading-p) | |
| 310 | (buffer-substring-no-properties (point-at-bol) (point-at-eol)) | |
| 311 | (save-excursion | |
| 312 | (outline-previous-visible-heading 1) | |
| 313 | (buffer-substring-no-properties (point-at-bol) (point-at-eol))))) | |
| 314 | ||
| 315 | (defun helm-org-run-refile-heading-to () | |
| 316 | (interactive) | |
| 317 | (with-helm-alive-p | |
| 318 | (helm-exit-and-execute-action 'helm-org--refile-heading-to))) | |
| 319 | (put 'helm-org-run-refile-heading-to 'helm-only t) | |
| 320 | ||
| 321 | ;;;###autoload | |
| 322 | (defun helm-org-agenda-files-headings () | |
| 323 | "Preconfigured helm for org files headings." | |
| 324 | (interactive) | |
| 325 | (let ((autosaves (cl-loop for f in (org-agenda-files) | |
| 326 | when (file-exists-p | |
| 327 | (expand-file-name | |
| 328 | (concat "#" (helm-basename f) "#") | |
| 329 | (helm-basedir f))) | |
| 330 | collect (helm-basename f)))) | |
| 331 | (when (or (null autosaves) | |
| 332 | helm-org-ignore-autosaves | |
| 333 | (y-or-n-p (format "%s have auto save data, continue?" | |
| 334 | (mapconcat 'identity autosaves ", ")))) | |
| 335 | (helm :sources (helm-source-org-headings-for-files (org-agenda-files)) | |
| 336 | :candidate-number-limit 99999 | |
| 337 | :truncate-lines helm-org-truncate-lines | |
| 338 | :buffer "*helm org headings*")))) | |
| 339 | ||
| 340 | ;;;###autoload | |
| 341 | (defun helm-org-in-buffer-headings () | |
| 342 | "Preconfigured helm for org buffer headings." | |
| 343 | (interactive) | |
| 344 | (let (helm-org-show-filename) | |
| 345 | (helm :sources (helm-source-org-headings-for-files | |
| 346 | (list (current-buffer))) | |
| 347 | :candidate-number-limit 99999 | |
| 348 | :preselect (helm-org-in-buffer-preselect) | |
| 349 | :truncate-lines helm-org-truncate-lines | |
| 350 | :buffer "*helm org inbuffer*"))) | |
| 351 | ||
| 352 | ;;;###autoload | |
| 353 | (defun helm-org-parent-headings () | |
| 354 | "Preconfigured helm for org headings that are parents of the | |
| 355 | current heading." | |
| 356 | (interactive) | |
| 357 | ;; Use a large max-depth to ensure all parents are displayed. | |
| 358 | (let ((helm-org-headings-min-depth 1) | |
| 359 | (helm-org-headings-max-depth 50)) | |
| 360 | (helm :sources (helm-source-org-headings-for-files | |
| 361 | (list (current-buffer)) t) | |
| 362 | :candidate-number-limit 99999 | |
| 363 | :truncate-lines helm-org-truncate-lines | |
| 364 | :buffer "*helm org parent headings*"))) | |
| 365 | ||
| 366 | ;;;###autoload | |
| 367 | (defun helm-org-capture-templates () | |
| 368 | "Preconfigured helm for org templates." | |
| 369 | (interactive) | |
| 370 | (helm :sources (helm-source-org-capture-templates) | |
| 371 | :candidate-number-limit 99999 | |
| 372 | :truncate-lines helm-org-truncate-lines | |
| 373 | :buffer "*helm org capture templates*")) | |
| 374 | ||
| 375 | ;;; Org tag completion | |
| 376 | ||
| 377 | ;; Based on code from Anders Johansson posted on 3 Mar 2016 at | |
| 378 | ;; <https://groups.google.com/d/msg/emacs-helm/tA6cn6TUdRY/G1S3TIdzBwAJ> | |
| 379 | ||
| 380 | (defvar crm-separator) | |
| 381 | ||
| 382 | ;;;###autoload | |
| 383 | (defun helm-org-completing-read-tags (prompt collection pred req initial | |
| 384 | hist def inherit-input-method _name _buffer) | |
| 385 | "Completing read function for Org tags. | |
| 386 | ||
| 387 | This function is used as a `completing-read' function in | |
| 388 | `helm-completing-read-handlers-alist' by `org-set-tags' and | |
| 389 | `org-capture'. | |
| 390 | ||
| 391 | NOTE: Org tag completion will work only if you disable org fast tag | |
| 392 | selection, see (info \"(org) setting tags\")." | |
| 393 | (if (not (string= "Tags: " prompt)) | |
| 394 | ;; Not a tags prompt. Use normal completion by calling | |
| 395 | ;; `org-icompleting-read' again without this function in | |
| 396 | ;; `helm-completing-read-handlers-alist' | |
| 397 | (let ((helm-completing-read-handlers-alist | |
| 398 | (rassq-delete-all | |
| 399 | 'helm-org-completing-read-tags | |
| 400 | (copy-alist helm-completing-read-handlers-alist)))) | |
| 401 | (org-icompleting-read | |
| 402 | prompt collection pred req initial hist def inherit-input-method)) | |
| 403 | ;; Tags prompt | |
| 404 | (let* ((curr (and (stringp initial) | |
| 405 | (not (string= initial "")) | |
| 406 | (org-split-string initial ":"))) | |
| 407 | (table (delete curr | |
| 408 | (org-uniquify | |
| 409 | (mapcar 'car org-last-tags-completion-table)))) | |
| 410 | (crm-separator ":\\|,\\|\\s-")) | |
| 411 | (cl-letf (((symbol-function 'crm-complete-word) | |
| 412 | 'self-insert-command)) | |
| 413 | (mapconcat 'identity | |
| 414 | (completing-read-multiple | |
| 415 | prompt table pred nil initial hist def) | |
| 416 | ":"))))) | |
| 417 | ||
| 418 | (provide 'helm-org) | |
| 419 | ||
| 420 | ;; Local Variables: | |
| 421 | ;; byte-compile-warnings: (not obsolete) | |
| 422 | ;; coding: utf-8 | |
| 423 | ;; indent-tabs-mode: nil | |
| 424 | ;; End: | |
| 425 | ||
| 426 | ;;; helm-org.el ends here | |
