mirror of https://github.com/Chizi123/.emacs.d.git

Chizi123
2018-11-17 5cb5f70b1872a757e93ea333b0e2dca50c6c8957
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