emacs-config/elisp/org-mu4e-compose.el

;;; org-mu4e-compose.el --- Write mu4e messages with org-mode.  -*- lexical-binding: t; -*-
;;; Commentary:

;; I use evil.  This file does not depend on evil, but some of these keybindings
;; shadow useful org keybinding with message mode keybindings because the org
;; bindings being shadowed are available with evil under some other key sequence.

;;; Code:
(require 'mu4e)
(require 'org-mime)
(require 'shr)
(require 'dom)
(require 'sgml-mode)
(require 'cl-lib)

(defvar-local org-mu4e--html-message-p t
  "Weather or not the current message should be htmlized.")

(defvar-local org-mu4e--override-org-mode-check nil
  "Internal variable.
See `org-mu4e--override-org-mode-check-advice' for information about what this
does.")

(defvar org-mu4e--internal-message-mode-function
  (symbol-function 'mu4e-compose-mode)
  "The `message-mode' (or derived mode) used by `org-mu4e-compose-mode'.")

(defun org-mu4e--override-org-mode-check-advice (oldfun &rest r)
  "Around advice for various org mode functions.
This function will call OLDFUN with arguments R with `major-mode' let-bound to
\\='org-mode when `org-mu4e--override-org-mode-check' is t."
  (let ((major-mode (if org-mu4e--override-org-mode-check
                        'org-mode
                      major-mode)))
    (apply oldfun r)))

(advice-add 'org-element-at-point :around
            'org-mu4e--override-org-mode-check-advice)

(defun org-mu4e-toggle-htmlize-mssage (&optional arg no-message)
  "Toggle weather the current message should be htmlized.
If ARG is a positive number or zero, enable htmlization, if it is negative,
disable it.  Otherwise, toggle it.  With NO-MESSAGE, don't display a message
about this change."
  (interactive "P")
  (setq org-mu4e--html-message-p (or (wholenump arg)
                                     (and (not arg)
                                          (not org-mu4e--html-message-p))))
  (unless no-message
    (message "Message will be %ssent with an HTML part."
             (if org-mu4e--html-message-p "" "not ")))
  (force-mode-line-update))

(defun org-mu4e--bounds-of-mime-part (type)
  "Find the bounds of the mime part for TYPE in the current buffer."
  (save-excursion
    (goto-char (point-min))
    (when (and
           (re-search-forward (rx bol (literal mail-header-separator) eol)
                              nil t)
           (re-search-forward (rx "<#multipart" (* any) ">")
                              nil t)
           (re-search-forward (rx "<#part " (* any)
                                  "type=" (literal type) (* any) ">")
                              nil t))
      (let ((start (match-end 0))
            (end (point-max)))
        (when (re-search-forward
               (rx (or (and "<#/" (or "part" "multipart") ">")
                       (and "<#part" (* any) ">")))
               nil t)
          (setq end (match-beginning 0)))
        (cons (1+ start) end)))))

(defun org-mu4e--pretty-print-fontify-html-part ()
  "Pretty print and fontify the HTML part of the current buffer."
  (when-let ((bounds (org-mu4e--bounds-of-mime-part "text/html"))
             (real-buf (current-buffer)))
    (save-excursion
      (let ((content
             (with-temp-buffer
               (insert-buffer-substring real-buf (car bounds) (cdr bounds))
               (let (sgml-mode-hook html-mode-hook text-mode-hook)
                 (html-mode))
               (sgml-pretty-print (point-min) (point-max))
               (indent-region (point-min) (point-max))
               (put-text-property (point-min) (point-max) 'fontified nil)
               (font-lock-ensure)
               (buffer-string))))
        (delete-region (car bounds) (cdr bounds))
        (goto-char (car bounds))
        (insert content)))))

(defun org-mu4e--htmlize-and-cleanup ()
  "HTMLize and cleanup the visible portion of the buffer.
This moves point, wrap it in `save-excursion' if that is a problem."
  (org-mime-htmlize)
  ;; IDK why, but the above function adds a bunch of newlines to the end
  ;; of the buffer.
  (goto-char (point-min))
  (when (re-search-forward (rx (group (* "\n")) "\n" eos) nil t)
    (delete-region (match-beginning 1)
                   (match-end 1)))
  (font-lock-ensure)
  (org-mu4e--pretty-print-fontify-html-part))

(defun org-mu4e-preview-html ()
  "Preview the HTML version of the current buffer in a new buffer.
Return the newly created buffer."
  (interactive)
  (let ((msg-buffer (current-buffer))
        (buffer (get-buffer-create "*Org-Mu4e HTML Preview*"))
        (bounds (point-min))
        (cur-max (point-max)))
    (without-restriction
      (with-current-buffer buffer
        (special-mode)
        (setq-local org-mu4e--override-org-mode-check t)
        ;; Setup font-lock without all the other pesky major mode stuff
        (org-set-font-lock-defaults)
        (font-lock-add-keywords nil message-font-lock-keywords)
        (let ((inhibit-read-only t))
          (erase-buffer)
          (insert-buffer-substring msg-buffer)
          (narrow-to-region bounds cur-max)
          (org-mu4e--htmlize-and-cleanup))
        (goto-char (point-min))))
    (switch-to-buffer-other-window buffer)
    buffer))

(defun org-mu4e-render-preview ()
  "Render a preview of the HTML message."
  (interactive)
  (let ((msg-buffer (current-buffer))
        (buffer (get-buffer-create "*Org-Mu4e Render Preview*")))
    (save-excursion
      (without-restriction
        (goto-char (point-min))
        (if (re-search-forward (rx bol (literal mail-header-separator) eol)
                               nil t)
            (let* ((start (1+ (match-end 0)))
                   (org-export-with-latex org-mime-org-html-with-latex-default)
                   (org-preview-latex-image-directory
                    (expand-file-name "ltximg/" mm-tmp-directory))
                   (default-directory org-preview-latex-image-directory)
                   (org-html-postamble nil))
              (narrow-to-region start (point-max))
              (if-let ((export-data (org-export-as
                                     'html nil t nil
                                     org-mime-export-options)))
                  (progn
                    (with-current-buffer buffer
                      (special-mode)
                      (let ((inhibit-read-only t)
                            (default-directory
                             org-preview-latex-image-directory))
                        (erase-buffer)
                        (insert export-data)
                        (shr-render-region (point-min) (point-max))
                        ;; The above function inserts a text directionality
                        ;; character and then two newlines, just to be safe,
                        ;; check for them, then hide them
                        (goto-char (point-min))
                        (let ((new-start (point-min)))
                          (when (or (eq (char-after) #x200e)
                                    (eq (char-after) #x200f))
                            (cl-incf new-start))
                          (dotimes (_ 2)
                            (forward-char)
                            (when (eq (char-after) ?\n)
                              (cl-incf new-start)))
                          (narrow-to-region new-start (point-max)))))
                    (switch-to-buffer-other-window buffer))
                (user-error "HTML export failed")))
          (user-error "Can't find message start in current buffer"))))))

(defun org-mu4e-send (&optional arg)
  "HTMLize and send the message in the current buffer.
ARG is passed directly to `message-send'."
  ;; This has to return a non-nil value so that org knows we handled the C-c C-c
  (interactive "P")
  (let ((modified (buffer-modified-p))
        ;; we only restore the restriction if the sending below fails
        (old-rest (cons (point-min) (point-max))))
    (widen)
    (let ((save-text (buffer-substring-no-properties (point-min)
                                                     (point-max))))
      (condition-case _
          (progn
            (when org-mu4e--html-message-p
              (org-mu4e--htmlize-and-cleanup))
            (message-send arg)
            'sent)
        ((or error quit)
         (erase-buffer)
         (insert save-text)
         (narrow-to-region (car old-rest) (cdr old-rest))
         (restore-buffer-modified-p modified)
         'failed)))))

(defun org-mu4e-send-and-exit (&optional arg)
  "Call `org-mu4e-send', the save and kill the buffer.
ARG is passed directly to `message-send'."
  (interactive "P")
  (when (eq (org-mu4e-send arg) 'sent)
    (message-kill-buffer))
  t ;; this tells org that we have handled the C-c C-c
  )

;;;###autoload
(defun org-mu4e-compose-new (&rest r)
  "This is like `mu4e-compose-new', but it utilizes `org-mu4e-compose-mode'.
Each of the arguments in R are the same as `mu4e-compose-new', and are directly
passed to it."
  (interactive)
  ;; Save local variables set by `mu4e-compose-new'
  (let ((org-mu4e--internal-message-mode-function
         (symbol-function 'mu4e-compose-mode)))
    (cl-letf (((symbol-function 'mu4e-compose-mode) 'org-mu4e-compose-mode))
      (apply 'mu4e-compose-new r))))

;;;###autoload
(defvar-keymap org-mu4e-compose-mode-map
  :parent org-mode-map
  ;; These come straight from `message-mode-map' and override `org-mode-map'
  "C-c C-f C-t" #'message-goto-to
  "C-c C-f C-o" #'message-goto-from
  "C-c C-f C-b" #'message-goto-bcc
  "C-c C-f C-w" #'message-goto-fcc
  "C-c C-f C-c" #'message-goto-cc
  "C-c C-f C-s" #'message-goto-subject
  "C-c C-f C-r" #'message-goto-reply-to
  "C-c C-f C-d" #'message-goto-distribution
  "C-c C-f C-f" #'message-goto-followup-to
  "C-c C-f C-m" #'message-goto-mail-followup-to
  "C-c C-f C-k" #'message-goto-keywords
  "C-c C-f C-u" #'message-goto-summary
  "C-c C-f C-i" #'message-insert-or-toggle-importance
  "C-c C-f C-a" #'message-generate-unsubscribed-mail-followup-to

  ;; modify headers (and insert notes in body)
  "C-c C-f s" #'message-change-subject
  ;;
  "C-c C-f x" #'message-cross-post-followup-to
  ;; prefix+message-cross-post-followup-to = same without cross-post
  "C-c C-f t" #'message-reduce-to-to-cc
  "C-c C-f a" #'message-add-archive-header
  ;; mark inserted text
  "C-c M-m" #'message-mark-inserted-region
  "C-c M-f" #'message-mark-insert-file

  "C-c C-b" #'message-goto-body
  "C-c C-i" #'message-goto-signature

  "C-c C-t" #'message-insert-to
  "C-c C-f w" #'message-insert-wide-reply
  "C-c C-f C-e" #'message-insert-expires
  "C-c M-u" #'message-insert-or-toggle-importance
  "C-c M-n" #'message-insert-disposition-notification-to

  "C-c C-y" #'message-yank-original
  "C-c C-M-y" #'message-yank-buffer
  "C-c C-S-q" #'message-fill-yanked-message
  "C-c M-s" #'message-insert-signature
  "C-c M-h" #'message-insert-headers
  "C-c M-o" #'message-sort-headers

  ;; C-c C-c to send and exit is handled by `org-ctrl-c-ctrl-c-hook'
  "C-c C-s" #'org-mu4e-send
  "C-c C-k" #'message-kill-buffer
  "C-c C-d" #'message-dont-send

  "C-c M-k" #'message-kill-address
  "C-c M-e" #'message-elide-region
  "C-c M-v" #'message-delete-not-region
  "C-c M-z" #'message-kill-to-signature
  "<remap> <split-line>" #'message-split-line
  "<remap> <beginning-of-buffer>" #'mu4e-compose-goto-top
  "<remap> <end-of-buffer>" #'mu4e-compose-goto-bottom

  "C-c M-r" #'message-insert-screenshot

  "M-n" #'message-display-abbrev

  "C-c C-a" #'mail-add-attachment
  "C-c M-t" #'org-mu4e-toggle-htmlize-mssage
  "C-c M-p C-p" #'org-mu4e-preview-html
  "C-c M-p C-w" #'org-mu4e-render-preview
  "C-c C-;" #'mu4e-compose-context-switch)

;;;###autoload
(define-derived-mode org-mu4e-compose-mode org-mode "mu4e:org-compose"
  "Major mode for editing mu4e messages with `org-mode' syntax.
This is derived from `org-mode', but it also essentially runs
`mu4e-compose-mode' and `message-mode'.  Therefore, it runs their hooks too."
  ;; Enable all the things from `mu4e-compose-mode' (which derives from
  ;; `message-mode'), but don't let it change the major mode (or other things we
  ;; care about).
  (when org-mu4e--internal-message-mode-function
    (let ((major-mode major-mode)
          (mode-name mode-name)
          (local-abbrev-table local-abbrev-table)
          (font-lock-defaults font-lock-defaults)
          ;; some of these are not actually changed, but they are here just in
          ;; case they change in the future...
          (comment-start comment-start)
          (comment-end comment-end)
          (comment-start-skip comment-start-skip)
          (comment-add comment-add)
          (comment-style comment-style))
      (cl-letf (((symbol-function 'kill-all-local-variables) 'ignore)
                ((symbol-function 'use-local-map) 'ignore)
                ((symbol-function 'set-syntax-table) 'ignore))
        (funcall org-mu4e--internal-message-mode-function))))
  ;; Add `message-mode' keyword and quote highlighting on top of the org syntax
  ;; highlighting
  (font-lock-add-keywords nil message-font-lock-keywords)
  (setq-local org-mu4e--override-org-mode-check t)
  (add-to-list (make-local-variable 'org-ctrl-c-ctrl-c-final-hook)
               'org-mu4e-send-and-exit)
  (add-to-list (make-local-variable 'mode-line-misc-info)
               '(:eval (if org-mu4e--html-message-p
                           "Text/HTML "
                         "Text Only "))))

;;;###autoload
(define-mail-user-agent 'org-mu4e-user-agent
  #'org-mu4e-compose-new
  #'org-mu4e-send-and-exit
  #'message-kill-buffer
  'message-send-hook)

;;;###autoload
(defun org-mu4e-user-agent ()
  "Return `org-mu4e-user-agent'."
  'org-mu4e-user-agent)

(provide 'org-mu4e-compose)
;;; org-mu4e-compose.el ends here