org-change.el

;;; org-change.el --- Annotate changes in org-mode files -*- lexical-binding: t; -*-

;; Copyright (C) 2023 Stefano Ghirlanda

;; Version: 0.4.2
;; Package-Requires: ((emacs "29.1") (org "9.3"))
;; URL: https://github.com/drghirlanda/org-change
;; Keywords: wp, convenience

;; 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/>.

;;; Commentary:

;; org-change is a minor mode to annotate changes in org-mode files by
;; defining a "change" link type that hides old text and shows new
;; text.  Mark additions to the text with org-change-add (C-` a),
;; deletions with org-change-delete (C-` d), and replacements with
;; org-change-replace (C-` r).  Accept or reject changes with
;; org-change-accept (C-` k) and org-change-reject (C-` x).  LaTeX and
;; HTML export are available.  To change key bindings and other
;; settings, run M-x customize-group RET org-change.  More information
;; at the package URL.

;;; Code:

(require 'org)
(require 'ox)
(require 'font-lock)

(defun org-change--erase-extra-space ()
  "Remove space added by org-change--replace."
  (when (and org-change-mode org-change--extra-space-flag)
    (delete-char 1)
    (setq org-change--extra-space-flag nil)))

(defvar org-change--link-regexp "\\[\\[change:\\(.*?\\)\\]\\[\\(.*?\\)\\]\\]\\(\\1?\\)"
  "Regexp to match change links.")

(defcustom org-change-deleted-marker "✗"
  "Placeholder for deleted text."
  :type 'string
  :group 'org-change)

(defun org-change-update-deleted-marker ()
  "Update the marker for deleted/replaced text to the current setting.

Use this function to update change links to the current setting
of the marker used for deleted/replaced text.  The function
prompts for the deleted marker string to be replaced, then
replaces the old marker with the new one in the current buffer."
  (interactive)
  (let ((old-marker (read-string "Old marker: ")))
    (save-excursion
      (goto-char (point-min))
      (while (re-search-forward org-change--link-regexp nil t)
	(if (equal (match-string 2) old-marker)
	    (replace-match org-change-deleted-marker t t nil 2))))))
  
(defun org-change--get-region ()
  "Return content of active region or nil."
  (when (use-region-p)
    (buffer-substring-no-properties
     (region-beginning)
     (region-end))))

(defun org-change--propertize-deleted (beg end)
  "Mark text between BEG and END as deleted text."
  (put-text-property beg end 'org-change-deleted-text t)
  (put-text-property beg end 'font-lock-face 'org-change-deleted-face)
  (put-text-property beg end 'read-only t))

(defun org-change--mark-change (old-text new-text)
  "Delete region and insert change link with OLD-TEXT and NEW-TEXT."
  (when (use-region-p)
    (delete-region (region-beginning) (region-end)))
  (insert (format "[[change:%s][%s]]"
		  (org-link-escape old-text)
		  (org-link-escape new-text)))
  (backward-char 3)
  (when (and (not (equal old-text nil)) org-change-show-deleted)
    (let ((beg (point)))
      (insert (org-link-escape old-text))
      (org-change--propertize-deleted beg (point))
      (search-backward "]]")
      (backward-char 1))))

(defun org-change-replace ()
  "Mark active region as old text and prompt new text."
  (interactive "")
  (let ((old-text (org-change--get-region)))
    (if (not old-text)
	(user-error "Select text to be replaced")
      (org-change--mark-change
       old-text
       " ")
      (setq org-change--extra-space-flag t))))

(defun org-change-delete ()
  "Mark active region as old text."
  (interactive "")
  (let ((old-text (org-change--get-region)))
    (if (equal old-text nil)
	(user-error "Select text to be deleted")
      (org-change--mark-change old-text org-change-deleted-marker))))

(defun org-change-kill ()
  "Like `org-change-delete', but kill (cut) rather than delete text.
Used together with `org-change-yank' to move text around."
  (interactive)
  (when (use-region-p)
    (kill-ring-save (region-beginning) (region-end)))
  (org-change-delete))

(defun org-change-yank ()
  "Yank (paste) text and mark it as an addition.
Used together with `org-change-kill' to move text around."
  (interactive)
  (insert "[[change:][")
  (yank)
  (insert "]]"))
  
(defun org-change-add ()
  "Mark the active region as new text.
If there is no active region, ask for new text."
  (interactive "")
  (let ((new-text (or (org-change--get-region) " ")))
    (org-change--mark-change "" new-text)
    (when (equal new-text " ")
      (setq org-change--extra-space-flag t))))

(defun org-change--accept-or-reject (accept)
  "Accept (ACCEPT is t) or reject (ACCEPT is nil) change at point.
If there is no change at point, accept or reject all changes in
the active region."
  (let* ((link-position (org-in-regexp org-change--link-regexp 10))
	 (inhibit-read-only t))
    (if link-position
	(let ((old-text (match-string-no-properties 1))
	      ;; to get new-text we discard comments:
	      (new-text (replace-regexp-in-string
			 "\\*\\*.+\\*\\*$" ""
			 (match-string-no-properties 2)))
	      (beg (car link-position))
	      (end (cdr link-position)))
	  (delete-region beg end)
	  (if accept
	      (unless(equal new-text org-change-deleted-marker)
		(insert (org-link-escape new-text)))
	    (insert (org-link-escape old-text))))
      (when (use-region-p)
	(save-excursion
	  (save-restriction
	    (goto-char (region-beginning))
	    (while (re-search-forward org-change--link-regexp nil t)
	      (let ((beg (match-beginning 0)))
		(goto-char beg)
		(org-change--accept-or-reject accept)
		;; go to beg because buffer has changed and match-end
		;; is not reliable:
		(goto-char beg)))))))))

(defun org-change-accept ()
  "Accept change at point."
  (interactive "")
  (org-change--accept-or-reject t))

(defun org-change-reject ()
  "Reject change at point."
  (interactive "")
  (org-change--accept-or-reject nil))

(defun org-change-accept-reject-all ()
  "Go through all changes, prompting to accept or reject each one.
With an active region, only process changes in the region,
otherwise process the whole buffer."
  (interactive)
  (let* ((beg 1)
	 (end (buffer-end 1)))
    (save-mark-and-excursion
      (when (use-region-p)
	(setq beg (use-region-beginning)
	      end (use-region-end))
	(set-mark end))
      (goto-char beg)
      (while (re-search-forward org-change--link-regexp end t)
	(let ((answer (read-char "Accept change? [y/n] or SPC to skip, C-g to quit")))
	  (cond
	   ((char-equal answer ?y)
	    (org-change--accept-or-reject t))
	   ((char-equal answer ?n)
	    (org-change--accept-or-reject nil))
	   ((char-equal answer ?\s)) ; skip
	   (t
	    (goto-char (match-beginning 0))))))
      (deactivate-mark)))
  (message "No more changes"))


(defun org-change-toggle-deleted-text ()
  "Show/hide deleted text."
  (interactive)
  (setq org-change-show-deleted (not org-change-show-deleted))
  (org-change-fontify))

;;; Export mechanism

(defun org-change--export-latex (old-text new-text comment)
  "Export a change link to Latex.
OLD-TEXT, NEW-TEXT, and COMMENT are the elements of the change
link."
  (let ((comment (if (equal comment "") "" (format "[comment=%s]" comment))))
    (setq old-text (org-latex--protect-text old-text)
	  new-text (org-latex--protect-text new-text)
	  comment  (org-latex--protect-text comment))
    (cond ((equal old-text "")
	   (format "\\added%s{%s}" comment new-text))
	  ((equal new-text org-change-deleted-marker)
	   (format "\\deleted%s{%s}" comment old-text))
	  (t
	   (format "\\replaced%s{%s}{%s}" comment new-text old-text)))))

(defun org-change--make-span (class text)
  "Return string <span class=\"CLASS\">TEXT</span> for HTML export."
    (if (equal text "")
	""
      (format "<span class=\"%s\">%s</span>" class text)))

(defun org-change--export-html (old-text new-text comment)
  "Export a change link to HTML.
OLD-TEXT, NEW-TEXT, and COMMENT are the elemtns of the change
link."
  (cond ((equal old-text "")
	 (org-change--make-span
	  "org-change-added"
	  (concat new-text (org-change--make-span
			    "org-change-comment"
			    comment))))
	((equal new-text org-change-deleted-marker)
	 (org-change--make-span
	  "org-change-deleted"
	  (concat old-text (org-change--make-span
			    "org-change-comment" comment))))
	(t
	 (concat
	  (org-change--make-span
	   "org-change-added"
	   (concat new-text (org-change--make-span
			     "org-change-comment" comment)))
	  (org-change--make-span "org-change-deleted" old-text)))))

(defvar org-change--exporters
  '((latex . org-change--export-latex)
    (html . org-change--export-html))
  "List of exporters known to Org Change.")

(defun org-change-add-export-backend (backend exporter)
  "Add export backend to Org Change.
The EXPORTER function must take arguments old-text, new-text, and
comment, and return a string appropriate to BACKEND."
  (add-to-list 'org-change--exporters (cons backend exporter)))

(defvar org-change-final
  nil
  "If nil, include changes when exporting, otherwise include only new text.")

(defun org-change-export-link (old new backend _)
  "Export a change link to a BACKEND.
This function operates within the standard `org-mode' link export,
but OLD and NEW replace link and description."
  (if (or (not old) (not new))
      (user-error "Malformed change: link with:\nold text = %s\nnew-text: %s" old new))
  (let* ((test (string-match "\\(.*\\)\\*\\*\\(.+\\)\\*\\*$" new))
	 (new-text (if test (match-string 1 new) new))
	 (comment (if test (match-string 2 new) "")))
    (if org-change-final
	(if (equal new-text org-change-deleted-marker) "" new-text)
      (let ((exporter (alist-get
		       backend
		       org-change--exporters
		       nil
		       nil
		       'org-export-derived-backend-p)))
	(if exporter
	    (funcall exporter old new-text comment)
	  (user-error "Change links not supported in %s export" backend))))))
  
(defun org-change-filter-final-output (text backend _)
  "Add the Latex package changes.sty to the Latex preamble.
TEXT is the whole document and BACKEND is checked for being
\\='latex or derived from \\='latex."
  (when (and (org-export-derived-backend-p backend 'latex)
	     (not org-change-final))
    (replace-regexp-in-string
     "\\\\begin{document}"
     (concat
      "\\\\usepackage"
      (when (boundp 'org-change-latex-options) org-change-latex-options)
      "{changes}\n\\\\begin{document}")
     text)))

(add-to-list 'org-export-filter-final-output-functions #'org-change-filter-final-output)

;; Customizations and minor mode definitions

(defgroup org-change nil
  "Customization options for Org Change."
  :group 'org)

(defcustom org-change-show-deleted nil
  "If non-nil, show deleted/replaced text alongside new text.

The deleted/replaced text is shown in the face
 `org-change-deleted-face', which defaults to gray and can also
 be cusotmized.  The deleted/replaced text is made read-only to
 avoid confusion."
  :type 'boolean
  :group 'org-change)

(defcustom org-change-add-key (kbd "C-` a")
  "Keybinding for `org-change-add'."
  :type 'key-sequence
  :group 'org-change)

(defcustom org-change-delete-key (kbd "C-` d")
  "Keybinding for `org-change-delete'."
  :type 'key-sequence
  :group 'org-change)

(defcustom org-change-kill-key (kbd "C-` w")
  "Keybinding for `org-change-kill'."
  :type 'key-sequence
  :group 'org-change)

(defcustom org-change-yank-key (kbd "C-` y")
  "Keybinding for `org-change-yank'."
  :type 'key-sequence
  :group 'org-change)

(defcustom org-change-replace-key (kbd "C-` r")
  "Keybinding for `org-change-replace'."
  :type 'key-sequence
  :group 'org-change)

(defcustom org-change-accept-key (kbd "C-` k")
  "Keybinding for `org-change-accept'."
  :type 'key-sequence
  :group 'org-change)

(defcustom org-change-reject-key (kbd "C-` x")
  "Keybinding for `org-change-reject'."
  :type 'key-sequence
  :group 'org-change)

(defcustom org-change-accept-reject-all-key (kbd "C-` b")
  "Keybinding for `org-change-accept-reject-all'."
  :type 'key-sequence
  :group 'org-change)

(defcustom org-change-fontify-key (kbd "C-` f")
  "Keybinding for `org-change-fontify'."
  :type 'key-sequence
  :group 'org-change)

(defface org-change-link-face
  '((t (:background "lavender blush" :underline nil)))
  "Face for Org Change links."
  :group 'org-change)

(defface org-change-deleted-face
  '((t (:foreground "gray")))
  "Face for Org Change deleted/replaced text."
  :group 'org-change)

(defcustom org-change-face 'org-change-link-face
  "Face for Org Change links."
  :type 'face
  :group 'org-change)

(defvar org-change
  "Mode variable and function prefix for org-change")

(defun org-change-fontify (&rest rbeg rend)
  "Fontify change links.
Called automatically when Org Change starts. Optional arguments
RBEG and REND delimit the region to fontify. If nil, RBEG is set
to buffer beginning and REND to buffer end."
  (interactive)
  (setq rbeg (or rbeg (point-min))
	rend (or rend (point-max)))
  (save-excursion
    (goto-char rbeg)
    (while (re-search-forward org-change--link-regexp rend t)
      (let ((beg (match-beginning 0))
	    (end (match-end 0))
	    (beg-del (match-beginning 3))
	    (end-del (match-end 3)))
	(message "Fontifying change links (%d%%)" (* 100 (/ (float end) (point-max))))
	(font-lock-fontify-region beg end)
	(if beg-del
	    (org-change--propertize-deleted beg-del end-del))
	(goto-char end))))
  (message "Fontifying change links (100%%)"))
      
(define-minor-mode org-change-mode
  "Minor mode for annotating changes in `org-mode' files."
  :lighter " Chg"
  :group 'org-change
  :keymap (let ((map (make-sparse-keymap)))
            (define-key map org-change-add-key #'org-change-add)
            (define-key map org-change-delete-key #'org-change-delete)
            (define-key map org-change-kill-key #'org-change-kill)
            (define-key map org-change-yank-key #'org-change-yank)
            (define-key map org-change-replace-key #'org-change-replace)
            (define-key map org-change-accept-key #'org-change-accept)
            (define-key map org-change-reject-key #'org-change-reject)
            (define-key map org-change-accept-reject-all-key #'org-change-accept-reject-all)
            (define-key map org-change-fontify-key #'org-change-fontify)
            map)
  (when org-change
    (add-hook 'post-self-insert-hook #'org-change--erase-extra-space 0 t)
    (setq-local org-change--extra-space-flag nil)
    (org-link-set-parameters
     "change"
     :follow #'org-change-open-link
     :export #'org-change-export-link
     :store #'org-change-store-link
     :face 'org-change-link-face)
    (org-change-fontify)))

(defun org-change-open-link (_path _)
  "Open a change link.  Currently does nothing."
  (message "Opening a change link currently does nothing"))

(defun org-change-store-link ()
  "Store a change link.  Currently does nothing."
  (message "Storing a change link currently does nothing"))

(provide 'org-change)

;;; org-change.el ends here