;;; embark-org.el --- Embark targets and actions for Org Mode  -*- lexical-binding: t; -*-

;; Copyright (C) 2022  Free Software Foundation, Inc.

;; Author: Omar Antolín Camarena <omar@matem.unam.mx>
;; Maintainer: Omar Antolín Camarena <omar@matem.unam.mx>
;; Keywords: convenience
;; Version: 0.2
;; Homepage: https://github.com/oantolin/embark
;; Package-Requires: ((emacs "27.1"))

;; 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 <https://www.gnu.org/licenses/>.

;;; Commentary:

;; This package configures the Embark package for use in Org Mode
;; buffers.  It teaches Embark a number of Org related targets and
;; appropriate actions.  Currently it has table cells, whole tables,
;; source blocks and links.  Targets to add: headings (Embark already
;; has generic support for outlines, so we just nee to add Org
;; specific actions), timestamps, etc.

;;; Code:

(require 'embark)
(require 'org)
(require 'org-element)

;;; Basic target finder for Org

;; There are very many org element and objects types, we'll only
;; recognize those for which there are specific actions we can put in
;; a keymap, or for even if there aren't any specific actions, if it's
;; import to be able to kill, delete or duplicate (embark-insert) them
;; conveniently.  I'll start conservatively and we can add more later

(defconst embark-org--types
  '(
    babel-call
    ;; bold
    ;; center-block
    ;; citation
    ;; citation-reference
    ;; clock
    ;; code
    ;; comment
    ;; comment-block
    ;; diary-sexp
    ;; drawer
    ;; dynamic-block
    ;; entity
    ;; example-block
    ;; export-block
    ;; export-snippet
    ;; fixed-width
    footnote-definition
    footnote-reference
    ;; headline ; the bounds include the entire subtree!
    ;; horizontal-rule
    ;; inline-babel-call
    ;; inline-src-block
    ;; inlinetask
    ;; italic
    item
    ;; keyword
    ;; latex-environment
    ;; latex-fragment
    ;; line-break
    link
    ;; macro
    ;; node-property
    ;; paragraph ; the existing general support seems fine
    plain-list
    ;; planning
    ;; property-drawer
    ;; quote-block
    ;; radio-target
    ;; section
    ;; special-block
    src-block
    ;; statistics-cookie
    ;; strike-through
    ;; subscript
    ;; superscript
    table ; supported via a specific target finder
    table-cell
    ;; table-row ; we'll put row & column actions in the cell map
    ;; target ; I think there are no useful actions for radio targets
    timestamp
    ;; underline
    ;; verbatim
    ;; verse-block
    )
  "Supported Org object and element types.")

(defun embark-org-target-element-context ()
  "Target all Org elements or objects around point."
  (when (derived-mode-p 'org-mode 'org-agenda-mode)
    (cl-loop
     for elt = (org-element-lineage (org-element-context) embark-org--types t)
     then (org-element-lineage elt embark-org--types)
     while elt
     for begin = (org-element-property :begin elt)
     for end = (org-element-property :end elt)
     for target = (buffer-substring begin end)
      ;; Adjust table-cell to exclude final |. (Why is that there?)
      ;; Note: We are not doing this is an embark transformer because we
      ;; want to adjust the bounds too.
      ;; TODO? If more adjustments like this become necessary, add a
      ;; nice mechanism for doing them.
      when (and (eq (car elt) 'table-cell) (string-suffix-p "|" target))
      do (setq target (string-trim (string-remove-suffix "|" target))
               end (1- end))
      collect `(,(intern (format "org-%s" (car elt))) ,target ,begin . ,end))))

(add-to-list 'embark-target-finders 'embark-org-target-element-context)

;;; Custom Org actions

(defvar org-export-with-toc)

(defun embark-org-copy-as-markdown (start end)
  "Export the region from START to END to markdown and save on the `kill-ring'."
  (interactive "r")
  (require 'ox)
  (kill-new
   (let (org-export-with-toc)
     (string-trim
      (org-export-string-as (buffer-substring-no-properties start end) 'md t))))
  (deactivate-mark))

(add-to-list 'embark-pre-action-hooks
             '(embark-org-copy-as-markdown embark--mark-target))

(define-key embark-region-map "M" #'embark-org-copy-as-markdown) ; good idea?

;;; Tables

(dolist (motion '(org-table-move-cell-up org-table-move-cell-down
                  org-table-move-cell-left org-table-move-cell-right))
  (add-to-list 'embark-repeat-actions motion))

(push 'embark--ignore-target
      (alist-get 'org-table-edit-field embark-target-injection-hooks))

(embark-define-keymap embark-org-table-cell-map
  "Keymap for actions the current cells, column or row of an Org table."
  ;; TODO: default action?
  ("<up>"    org-table-move-cell-up)
  ("<down>"  org-table-move-cell-down)
  ("<left>"  org-table-move-cell-left)
  ("<right>" org-table-move-cell-right)
  ("=" org-table-eval-formula)
  ("e" org-table-edit-field)
  ("g" org-table-recalculate))

(embark-define-keymap embark-org-table-map
  "Keymap for actions on entire Org table."
  ;; TODO: default action?
  ("=" org-table-edit-formulas)
  ("s" org-table-sort-lines)
  ("t" org-table-transpose-table-at-point)
  ("c" org-table-convert)
  ("f" org-table-follow-field-mode)
  ("y" org-table-paste-rectangle)
  ("d" org-table-toggle-formula-debugger)
  ("i" org-table-iterate)
  ("e" org-table-export))

(push 'embark--ignore-target            ; prompts for file name
      (alist-get 'org-table-export embark-target-injection-hooks))

(add-to-list 'embark-keymap-alist '(org-table . embark-org-table-map))

(add-to-list 'embark-keymap-alist '(org-table-cell . embark-org-table-cell-map))

;;; Links

;; The link support has a slightly complicated design in order to
;; achieve the following goals:

;; 1. RET should simply be org-open-at-point

;; 2. When the link is to a file, URL, email address or elisp
;;    expression or command, we want to offer the user actions for
;;    that underlying type.

;; 3. Even in those cases, we still want some actions to apply to the
;;    entire link including description: actions to copy the link as
;;    markdown, or just the link description or target.

;; So the strategy is as follows (illustrated with file links):

;; - The target will be just the file, without the description and
;;   also without the "file:" prefix nor the "::line-number or search"
;;   suffix.  That way, file actions will correctly apply to it.

;; - The type will not be 'file, but 'org-file-link that way we can
;;   register a keymap for 'org-file-link that inherits from both
;;   embark-org-link-map (with RET bound to org-open-at-point and a
;;   few other generic link actions) and embark-file-map.

;; - The commands to copy the link at point in some format will be
;;   written as commands that act on the Org link at point.  This way
;;   they are independently (plausibly) useful, and we circumvent the
;;   problem that the whole Org link is not actually the target (just
;;   the inner file is!).

;; Alternative design I considered: separate each target into two, a
;; whole link target which includes the description and brackets and
;; what not; and an "inner target" which is just the file or URL or
;; whatever.  Cons of this approach: much target cycling is required!
;; First of all, an unadorned embark-dwim definitely should be
;; org-open-at-point, which means the whole link target would need
;; priority. That means that any file, URL, etc. actions would require
;; you to cycle first.  This sounds very inconvenient, the above
;; slightly more complex design allows both whole-link and inner
;; target actions to work without cycling.

(autoload 'org-attach-dir "org-attach")

(defun embark-org--refine-link-type (_type target)
  "Refine type of link TARGET if we have more specific actions available."
  (when (string-match org-link-any-re target)
    (let ((target (or (match-string-no-properties 2 target)
                      (match-string-no-properties 0 target))))
      (cond
       ((string-prefix-p "http" target)
        (cons 'org-url-link target))
       ((string-prefix-p "mailto:" target)
        (cons 'org-email-link (string-remove-prefix "mailto:" target)))
       ((string-prefix-p "file:" target)
        (cons 'org-file-link
              (replace-regexp-in-string
               "::.*" "" (string-remove-prefix "file:" target))))
       ((string-prefix-p "attachment:" target)
        (cons 'org-file-link
              (expand-file-name
               (replace-regexp-in-string
                "::.*" "" (string-remove-prefix "attachment:" target))
               (org-attach-dir))))
       ((string-match-p "^[./]" target)
        (cons 'org-file-link (abbreviate-file-name (expand-file-name target))))
       ((string-prefix-p "elisp:(" target)
        (cons 'org-expression-link (string-remove-prefix "elisp:" target)))
       ((string-prefix-p "elisp:" target)
        (cons 'command (string-remove-prefix "elisp:" target)))
       (t (cons 'org-link target))))))

(add-to-list 'embark-transformer-alist
             '(org-link . embark-org--refine-link-type))

(defmacro embark-org-define-link-copier (name formula description)
  "Define a command that copies the Org link at point according to FORMULA.
The command's name is formed by appending NAME to
embark-org-copy-link.  The docstring includes the DESCRIPTION of
what part or in what format the link is copied."
  `(defun ,(intern (format "embark-org-copy-link-%s" name)) ()
     ,(format "Copy to the kill-ring the Org link at point%s." description)
     (interactive)
     (when (org-in-regexp org-link-any-re)
       (let* ((full (match-string-no-properties 0))
              (target (or (match-string-no-properties 2)
                          (match-string-no-properties 0)))
              (description (match-string-no-properties 3))
              (kill ,formula))
         (ignore full target description)
         (when kill
           (message "Saved '%s'" kill)
           (kill-new kill))))))

(embark-org-define-link-copier in-full full " in full")
(embark-org-define-link-copier description description "'s description")
(embark-org-define-link-copier target target "'s target")

(defalias 'embark-org-copy-link-inner-target #'kill-new
  "Copy 'inner part' of the Org link at point's target.
For mailto and elisp links, the inner part is the portion of the
target after 'mailto:' or 'elisp:'.

For file links the inner part is the file name, without the
'file:' prefix and without '::' suffix (used for line numbers,
IDs or search terms).

For URLs the inner part is the whole target including the 'http:'
or 'https:' prefix.  For any other type of link the inner part is
also the whole target.")

(embark-define-keymap embark-org-link-copy-map
  "Keymap for different ways to copy Org links to the kill-ring.

You should bind w in this map to your most frequently used link
copying function.  The default is for w to copy the \"inner
target\" (see `embark-org-copy-link-inner-target'); which is also
bound to i."
  :parent nil
  ("w" embark-org-copy-link-inner-target)
  ("f" embark-org-copy-link-in-full)
  ("d" embark-org-copy-link-description)
  ("t" embark-org-copy-link-target)
  ("i" embark-org-copy-link-inner-target)
  ("m" embark-org-copy-as-markdown))

(fset 'embark-org-link-copy-map embark-org-link-copy-map)

(embark-define-keymap embark-org-link-map
  "Keymap for actions on Org links."
  ("RET" org-open-at-point)
  ("'" org-insert-link)
  ("w" 'embark-org-link-copy-map))

;; The reason for this is left as an exercise to the reader.
;; Solution: Na ryvfc gnetrg znl cebzcg gur hfre sbe fbzrguvat!
(push 'embark--ignore-target
      (alist-get 'org-open-at-point embark-target-injection-hooks))

(push 'embark--ignore-target
      (alist-get 'org-insert-link embark-target-injection-hooks))

(add-to-list 'embark-keymap-alist
             '(org-link embark-org-link-map))
(add-to-list 'embark-keymap-alist
             '(org-url-link embark-org-link-map embark-url-map))
(add-to-list 'embark-keymap-alist
             '(org-email-link embark-org-link-map embark-email-map))
(add-to-list 'embark-keymap-alist
             '(org-file-link embark-org-link-map embark-file-map))
(add-to-list 'embark-keymap-alist
             '(org-expression-link embark-org-link-map embark-expression-map))

;;; Source blocks and babel calls

(embark-define-keymap embark-org-src-block-map
  "Keymap for actions on Org source blocks."
  ("RET" org-babel-execute-src-block)
  ("c" org-babel-check-src-block)
  ("k" org-babel-remove-result-one-or-many)
  ("p" org-babel-previous-src-block)
  ("n" org-babel-next-src-block)
  ("t" org-babel-tangle)
  ("s" org-babel-switch-to-session)
  ("l" org-babel-load-in-session)
  ("'" org-edit-special))

(dolist (motion '(org-babel-next-src-blockorg-babel-previous-src-block))
  (add-to-list 'embark-repeat-actions motion))

(add-to-list 'embark-keymap-alist '(org-src-block . embark-org-src-block-map))

;;; List items

(embark-define-keymap embark-org-item-map
  "Keymap for actions on Org list items."
  ("RET" org-toggle-checkbox)
  ("c" org-toggle-checkbox)
  ("t" org-toggle-item)
  ("n" org-next-item)
  ("p" org-previous-item)
  ("<left>" org-outdent-item)
  ("<right>" org-indent-item)
  ("<up>" org-move-item-up)
  ("<down>" org-move-item-down)
  (">" org-indent-item-tree)
  ("<" org-outdent-item-tree))

(dolist (cmd '(org-toggle-checkbox
               org-toggle-item
               org-next-item
               org-previous-item
               org-outdent-item
               org-indent-item
               org-move-item-up
               org-move-item-down
               org-indent-item-tree
               org-outdent-item-tree))
  (add-to-list 'embark-repeat-actions cmd))

(add-to-list 'embark-keymap-alist '(org-item . embark-org-item-map))

;;; Org plain lists

(embark-define-keymap embark-org-plain-list-map
  "Keymap for actions on plain Org lists."
  ("RET" org-list-repair)
  ("r" org-list-repair)
  ("s" org-sort-list)
  ("b" org-cycle-list-bullet)
  ("t" org-list-make-subtree)
  ("c" org-toggle-checkbox))

(add-to-list 'embark-repeat-actions 'org-cycle-list-bullet)

(add-to-list 'embark-keymap-alist '(org-plain-list . embark-org-plain-list-map))

(cl-defun embark-org--toggle-checkboxes
    (&rest rest &key run type &allow-other-keys)
  (apply (if (eq type 'org-plain-list) #'embark--mark-target run)
         :type type
         rest))

(cl-pushnew #'embark-org--toggle-checkboxes
            (alist-get 'org-toggle-checkbox embark-around-action-hooks))

;;; "Encode" region using Org export in place

(embark-define-keymap embark-org-export-in-place-map
  "Keymap for actions which replace the region by an exported version."
  ("m" org-md-convert-region-to-md)
  ("h" org-html-convert-region-to-html)
  ("a" org-ascii-convert-region-to-ascii)
  ("l" org-latex-convert-region-to-latex))

(fset 'embark-org-export-in-place-map embark-org-export-in-place-map)

(define-key embark-encode-map "o" 'embark-org-export-in-place-map)

(provide 'embark-org)
;;; embark-org.el ends here
