;;; helm-org.el --- Helm for org headlines and keywords completion -*- lexical-binding: t -*-

;; Copyright (C) 2012 ~ 2016 Thierry Volpiatto <thierry.volpiatto@gmail.com>

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

;;; Code:
(require 'cl-lib)
(require 'helm)
(require 'helm-utils)
(require 'org)

(declare-function org-agenda-switch-to "org-agenda.el")

(defgroup helm-org nil
  "Org related functions for helm."
  :group 'helm)

(defcustom helm-org-headings-fontify nil
  "Fontify org buffers before parsing them.
This reflect fontification in helm-buffer when non--nil.
NOTE: This will be slow on large org buffers."
  :group 'helm-org
  :type 'boolean)

(defcustom helm-org-format-outline-path nil
  "Show all org level as path."
  :group 'helm-org
  :type 'boolean)

(defcustom helm-org-show-filename nil
  "Show org filenames in `helm-org-agenda-files-headings' when non--nil.
Note this have no effect in `helm-org-in-buffer-headings'."
  :group 'helm-org
  :type 'boolean)

(defcustom helm-org-headings-min-depth 1
  "Minimum depth of org headings to start with."
  :group 'helm-org
  :type 'integer)

(defcustom helm-org-headings-max-depth 8
  "Go down to this maximum depth of org headings."
  :group 'helm-org
  :type 'integer)

(defcustom helm-org-headings-actions
  '(("Go to heading" . helm-org-goto-marker)
    ("Open in indirect buffer `C-c i'" . helm-org--open-heading-in-indirect-buffer)
    ("Refile current heading to selected heading `C-c w`" . helm-org-heading-refile)
    ("Insert link to this heading `C-c l`" . helm-org-insert-link-to-heading-at-marker))
  "Default actions alist for
  `helm-source-org-headings-for-files'."
  :group 'helm-org
  :type '(alist :key-type string :value-type function))

(defcustom helm-org-truncate-lines t
  "Truncate org-header-lines when non-nil"
  :type 'boolean
  :group 'helm-org)

;;; Org capture templates
;;
;;
(defvar org-capture-templates)
(defun helm-source-org-capture-templates ()
  (helm-build-sync-source "Org Capture Templates:"
    :candidates (cl-loop for template in org-capture-templates
                         collect (cons (nth 1 template) (nth 0 template)))
    :action '(("Do capture" . (lambda (template-shortcut)
                                (org-capture nil template-shortcut))))))

;;; Org headings
;;
;;
(defun helm-org-goto-marker (marker)
  (switch-to-buffer (marker-buffer marker))
  (goto-char (marker-position marker))
  (org-show-context)
  (re-search-backward "^\\*+ " nil t)
  (org-show-entry))

(defun helm-org--open-heading-in-indirect-buffer (marker)
  (helm-org-goto-marker marker)
  (org-tree-to-indirect-buffer)

  ;; Put the non-indirect buffer at the bottom of the prev-buffers
  ;; list so it won't be selected when the indirect buffer is killed
  (set-window-prev-buffers nil (append (cdr (window-prev-buffers))
                                       (car (window-prev-buffers)))))

(defun helm-org-run-open-heading-in-indirect-buffer ()
  "Open selected Org heading in an indirect buffer."
  (interactive)
  (with-helm-alive-p
    (helm-exit-and-execute-action #'helm-org--open-heading-in-indirect-buffer)))
(put 'helm-org-run-open-heading-in-indirect-buffer 'helm-only t)

(defvar helm-org-headings-map
  (let ((map (make-sparse-keymap)))
    (set-keymap-parent map helm-map)
    (define-key map (kbd "<C-c i>") 'helm-org-run-open-heading-in-indirect-buffer)
    (define-key map (kbd "C-c w")   'helm-org-run-heading-refile)
    (define-key map (kbd "C-c l")   'helm-org-run-insert-link-to-heading-at-marker)
    map)
  "Keymap for `helm-source-org-headings-for-files'.")

(defclass helm-org-headings-class (helm-source-sync)
  ((parents
    :initarg :parents
    :initform nil
    :custom boolean)
   (match :initform
          (lambda (candidate)
            (string-match
             helm-pattern
             (helm-aif (get-text-property 0 'helm-real-display candidate)
                 it
               candidate))))
   (action :initform 'helm-org-headings-actions)
   (keymap :initform 'helm-org-headings-map)))

(defmethod helm--setup-source :after ((source helm-org-headings-class))
  (let ((parents (slot-value source 'parents)))
    (setf (slot-value source 'candidate-transformer)
          (lambda (candidates)
            (let ((cands (helm-org-get-candidates candidates parents)))
              (if parents (nreverse cands) cands))))))

(defun helm-source-org-headings-for-files (filenames &optional parents)
  (helm-make-source "Org Headings" 'helm-org-headings-class
    :parents parents
    :candidates filenames))

(defun helm-org-get-candidates (filenames &optional parents)
  (apply #'append
         (mapcar (lambda (filename)
                   (helm-org--get-candidates-in-file
                    filename
                    helm-org-headings-fontify
                    (or parents (null helm-org-show-filename))
                    parents))
                 filenames)))

(defun helm-org--get-candidates-in-file (filename &optional fontify nofname parents)
  (with-current-buffer (pcase filename
                         ((pred bufferp) filename)
                         ((pred stringp) (find-file-noselect filename)))
    (let ((match-fn (if fontify
                        #'match-string
                      #'match-string-no-properties))
          (search-fn (lambda ()
                       (re-search-forward
                        org-complex-heading-regexp nil t)))
          (file (unless nofname
                  (concat (helm-basename filename) ":"))))
      (when parents
        (add-function :around (var search-fn)
                      (lambda (old-fn &rest args)
                                (when (org-up-heading-safe)
                                  (apply old-fn args)))))
      (save-excursion
        (save-restriction
          (widen)
          (unless parents (goto-char (point-min)))
          ;; clear cache for new version of org-get-outline-path
          (and (boundp 'org-outline-path-cache)
               (setq org-outline-path-cache nil))
          (cl-loop with width = (window-width (helm-window))
                   while (funcall search-fn)
                   for beg = (point-at-bol)
                   for end = (point-at-eol)
                   when (and fontify
                             (null (text-property-any
                                    beg end 'fontified t)))
                   do (jit-lock-fontify-now beg end)
                   for level = (length (match-string-no-properties 1))
                   for heading = (funcall match-fn 4)
                   if (and (>= level helm-org-headings-min-depth)
                           (<= level helm-org-headings-max-depth))
                   collect `(,(propertize
                               (if helm-org-format-outline-path
                                   (org-format-outline-path
                                    ;; org-get-outline-path changed in signature and behaviour since org's
                                    ;; commit 105a4466971. Let's fall-back to the new version in case
                                    ;; of wrong-number-of-arguments error.
                                    (condition-case nil
                                        (append (apply #'org-get-outline-path
                                                       (unless parents
                                                         (list t level heading)))
                                                (list heading))
                                      (wrong-number-of-arguments
                                       (org-get-outline-path t t)))
                                    width file)
                                   (if file
                                       (concat file (funcall match-fn  0))
                                       (funcall match-fn  0)))
                               'helm-real-display heading)
                              . ,(point-marker))))))))

(defun helm-org-insert-link-to-heading-at-marker (marker)
  (with-current-buffer (marker-buffer marker)
    (let ((heading-name (save-excursion (goto-char (marker-position marker))
                                        (nth 4 (org-heading-components))))
          (file-name (buffer-file-name)))
      (with-helm-current-buffer
        (org-insert-link
         file-name (concat "file:" file-name "::*" heading-name))))))

(defun helm-org-run-insert-link-to-heading-at-marker ()
  (interactive)
  (with-helm-alive-p
    (helm-exit-and-execute-action
     'helm-org-insert-link-to-heading-at-marker)))

(defun helm-org-heading-refile (marker)
  (save-selected-window
    (when (eq major-mode 'org-agenda-mode)
      (org-agenda-switch-to))
    (org-cut-subtree)
    (let ((target-level (with-current-buffer (marker-buffer marker)
                          (goto-char (marker-position marker))
                          (org-current-level))))
      (helm-org-goto-marker marker)
      (org-end-of-subtree t t)
      (org-paste-subtree (+ target-level 1)))))

(defun helm-org-in-buffer-preselect ()
  (if (org-on-heading-p)
      (buffer-substring-no-properties (point-at-bol) (point-at-eol))
      (save-excursion
        (outline-previous-visible-heading 1)
        (buffer-substring-no-properties (point-at-bol) (point-at-eol)))))

(defun helm-org-run-heading-refile ()
  (interactive)
  (with-helm-alive-p
    (helm-exit-and-execute-action 'helm-org-heading-refile)))
(put 'helm-org-run-heading-refile 'helm-only t)

;;;###autoload
(defun helm-org-agenda-files-headings ()
  "Preconfigured helm for org files headings."
  (interactive)
  (helm :sources (helm-source-org-headings-for-files (org-agenda-files))
        :candidate-number-limit 99999
        :truncate-lines helm-org-truncate-lines
        :buffer "*helm org headings*"))

;;;###autoload
(defun helm-org-in-buffer-headings ()
  "Preconfigured helm for org buffer headings."
  (interactive)
  (let (helm-org-show-filename helm-org-format-outline-path)
    (helm :sources (helm-source-org-headings-for-files
                    (list (current-buffer)))
          :candidate-number-limit 99999
          :preselect (helm-org-in-buffer-preselect)
          :truncate-lines helm-org-truncate-lines
          :buffer "*helm org inbuffer*")))

;;;###autoload
(defun helm-org-parent-headings ()
  "Preconfigured helm for org headings that are parents of the
current heading."
  (interactive)
  ;; Use a large max-depth to ensure all parents are displayed.
  (let ((helm-org-headings-min-depth 1)
        (helm-org-headings-max-depth  50))
    (helm :sources (helm-source-org-headings-for-files
                    (list (current-buffer)) t)
          :candidate-number-limit 99999
          :truncate-lines helm-org-truncate-lines
          :buffer "*helm org parent headings*")))

;;;###autoload
(defun helm-org-capture-templates ()
  "Preconfigured helm for org templates."
  (interactive)
  (helm :sources (helm-source-org-capture-templates)
        :candidate-number-limit 99999
        :truncate-lines helm-org-truncate-lines
        :buffer "*helm org capture templates*"))

;;; Org tag completion

;; Based on code from Anders Johansson posted on 3 Mar 2016 at
;; <https://groups.google.com/d/msg/emacs-helm/tA6cn6TUdRY/G1S3TIdzBwAJ>

(defvar crm-separator)

;;;###autoload
(defun helm-org-completing-read-tags (prompt collection pred req initial
                                      hist def inherit-input-method _name _buffer)
  (if (not (string= "Tags: " prompt))
      ;; Not a tags prompt.  Use normal completion by calling
      ;; `org-icompleting-read' again without this function in
      ;; `helm-completing-read-handlers-alist'
      (let ((helm-completing-read-handlers-alist
             (rassq-delete-all
              'helm-org-completing-read-tags
              helm-completing-read-handlers-alist)))
        (org-icompleting-read
         prompt collection pred req initial hist def inherit-input-method))
    ;; Tags prompt
    (let* ((curr (and (stringp initial)
                      (not (string= initial ""))
                      (org-split-string initial ":")))
           (table   (delete curr
                            (org-uniquify
                             (mapcar 'car org-last-tags-completion-table))))
           (crm-separator ":\\|,\\|\\s-"))
      (cl-letf (((symbol-function 'crm-complete-word)
                 'self-insert-command))
        (mapconcat 'identity
                   (completing-read-multiple
                    prompt table pred nil initial hist def)
                   ":")))))

(provide 'helm-org)

;; Local Variables:
;; byte-compile-warnings: (not cl-functions obsolete)
;; coding: utf-8
;; indent-tabs-mode: nil
;; End:

;;; helm-org.el ends here