From 57e027f753e5f3c77030c97d3de7ad5a7dd61f86 Mon Sep 17 00:00:00 2001 From: Case Duckworth Date: Mon, 12 Apr 2021 17:58:33 -0500 Subject: Add `acdw-org/delete-backward-char' and advise The advice I've added untabifies in addition to deleting the character, which enables the function to look at `delete-backward-char-untabify-method' or whatev. Also ... whitespace apparently? --- init.el | 3 +- lisp/acdw-org.el | 268 ++++++++++++++++++++++++++++++------------------------- 2 files changed, 148 insertions(+), 123 deletions(-) diff --git a/init.el b/init.el index bba923d..aca677d 100644 --- a/init.el +++ b/init.el @@ -368,7 +368,8 @@ org-html-coding-system 'utf-8-unix org-startup-truncated nil) (:bind "RET" unpackaged/org-return-dwim) - (add-hook 'before-save-hook #'acdw/hook--org-mode-fix-blank-lines)) + (add-hook 'before-save-hook #'acdw/hook--org-mode-fix-blank-lines) + (advice-add 'org-delete-backward-char :override #'acdw-org/delete-backward-char)) (setup eshell (:option eshell-directory-name (acdw/dir "eshell/" t) diff --git a/lisp/acdw-org.el b/lisp/acdw-org.el index 9fa8767..47e8eb2 100644 --- a/lisp/acdw-org.el +++ b/lisp/acdw-org.el @@ -29,7 +29,7 @@ ELEMENT should be a list like that returned by ;; MAYBE: Use `org-element-lineage'. (when-let* ((parent (org-element-property :parent element))) (or (eq type (car parent)) - (unpackaged/org-element-descendant-of type parent)))) + (unpackaged/org-element-descendant-of type parent)))) (defun unpackaged/org-return-dwim (&optional default) "A helpful replacement for `org-return'. With prefix, @@ -44,97 +44,97 @@ appropriate. In tables, insert a new row or end the table." (if default (org-return) (cond - ;; Act depending on context around point. - - ;; NOTE: I prefer RET to not follow links, but by uncommenting - ;; this block, links will be followed. - ;; FURTHER NOTE: Ideally, I would follow links unless point - ;; /appeared/ to be at the end of the line (even if it's still - ;; inside the link) -- when it would do `org-return'. That - ;; would take some /doing/, however. - - ;; ((eq 'link (car (org-element-context))) - ;; ;; Link: Open it. - ;; (org-open-at-point-global)) - - ((org-at-heading-p) - ;; Heading: Move to position after entry content. NOTE: This is - ;; probably the most interesting feature of this function. - (let ((heading-start (org-entry-beginning-position))) - (goto-char (org-entry-end-position)) - (cond ((and (org-at-heading-p) - (= heading-start (org-entry-beginning-position))) - ;; Entry ends on its heading; add newline after - (end-of-line) - (insert "\n\n")) - (t - ;; Entry ends after its heading; back up - (forward-line -1) - (end-of-line) - (when (org-at-heading-p) - ;; At the same heading - (forward-line) - (insert "\n") - (forward-line -1)) - ;; FIXME: looking-back is supposed to be called with - ;; more arguments. - (while (not (looking-back (rx - (repeat 3 - (seq (optional blank) - "\n"))) - nil)) - (insert "\n")) - (forward-line -1))))) - - ((org-at-item-checkbox-p) - ;; Checkbox: Insert new item with checkbox. - (org-insert-todo-heading nil)) - - ((org-in-item-p) - ;; Plain list. Yes, this gets a little complicated... - (let ((context (org-element-context))) - (if (or (eq 'plain-list (car context)) ; First item in list - (and (eq 'item (car context)) - (not (eq (org-element-property - :contents-begin context) - (org-element-property - :contents-end context)))) - ;; Element in list item, e.g. a link - (unpackaged/org-element-descendant-of 'item context)) - ;; Non-empty item: Add new item. - (org-insert-item) - ;; Empty item: Close the list. - ;; TODO: Do this with org functions rather than operating - ;; on the text. Can't seem to find the right function. - (delete-region (line-beginning-position) (line-end-position)) - (insert "\n")))) - - ((when (fboundp 'org-inlinetask-in-task-p) - (org-inlinetask-in-task-p)) - ;; Inline task: Don't insert a new heading. - (org-return)) - - ((org-at-table-p) - (cond ((save-excursion - (beginning-of-line) - ;; See `org-table-next-field'. - (cl-loop with end = (line-end-position) - for cell = (org-element-table-cell-parser) - always (equal (org-element-property - :contents-begin cell) - (org-element-property - :contents-end cell)) - while (re-search-forward "|" end t))) - ;; Empty row: end the table. - (delete-region (line-beginning-position) - (line-end-position)) - (org-return)) - (t - ;; Non-empty row: call `org-return'. - (org-return)))) - (t - ;; All other cases: call `org-return'. - (org-return))))) + ;; Act depending on context around point. + + ;; NOTE: I prefer RET to not follow links, but by uncommenting + ;; this block, links will be followed. + ;; FURTHER NOTE: Ideally, I would follow links unless point + ;; /appeared/ to be at the end of the line (even if it's still + ;; inside the link) -- when it would do `org-return'. That + ;; would take some /doing/, however. + + ;; ((eq 'link (car (org-element-context))) + ;; ;; Link: Open it. + ;; (org-open-at-point-global)) + + ((org-at-heading-p) + ;; Heading: Move to position after entry content. NOTE: This is + ;; probably the most interesting feature of this function. + (let ((heading-start (org-entry-beginning-position))) + (goto-char (org-entry-end-position)) + (cond ((and (org-at-heading-p) + (= heading-start (org-entry-beginning-position))) + ;; Entry ends on its heading; add newline after + (end-of-line) + (insert "\n\n")) + (t + ;; Entry ends after its heading; back up + (forward-line -1) + (end-of-line) + (when (org-at-heading-p) + ;; At the same heading + (forward-line) + (insert "\n") + (forward-line -1)) + ;; FIXME: looking-back is supposed to be called with + ;; more arguments. + (while (not (looking-back (rx + (repeat 3 + (seq (optional blank) + "\n"))) + nil)) + (insert "\n")) + (forward-line -1))))) + + ((org-at-item-checkbox-p) + ;; Checkbox: Insert new item with checkbox. + (org-insert-todo-heading nil)) + + ((org-in-item-p) + ;; Plain list. Yes, this gets a little complicated... + (let ((context (org-element-context))) + (if (or (eq 'plain-list (car context)) ; First item in list + (and (eq 'item (car context)) + (not (eq (org-element-property + :contents-begin context) + (org-element-property + :contents-end context)))) + ;; Element in list item, e.g. a link + (unpackaged/org-element-descendant-of 'item context)) + ;; Non-empty item: Add new item. + (org-insert-item) + ;; Empty item: Close the list. + ;; TODO: Do this with org functions rather than operating + ;; on the text. Can't seem to find the right function. + (delete-region (line-beginning-position) (line-end-position)) + (insert "\n")))) + + ((when (fboundp 'org-inlinetask-in-task-p) + (org-inlinetask-in-task-p)) + ;; Inline task: Don't insert a new heading. + (org-return)) + + ((org-at-table-p) + (cond ((save-excursion + (beginning-of-line) + ;; See `org-table-next-field'. + (cl-loop with end = (line-end-position) + for cell = (org-element-table-cell-parser) + always (equal (org-element-property + :contents-begin cell) + (org-element-property + :contents-end cell)) + while (re-search-forward "|" end t))) + ;; Empty row: end the table. + (delete-region (line-beginning-position) + (line-end-position)) + (org-return)) + (t + ;; Non-empty row: call `org-return'. + (org-return)))) + (t + ;; All other cases: call `org-return'. + (org-return))))) ;;; ORG-FIX-BLANK-LINES ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -145,40 +145,64 @@ appropriate. In tables, insert a new row or end the table." headings's drawers." (interactive "P") (org-map-entries (lambda () - (org-with-wide-buffer - ;; `org-map-entries' narrows the buffer, which - ;; prevents us from seeing newlines before the - ;; current heading, so we do this part widened. - (while (not (looking-back "\n\n" nil)) - ;; Insert blank lines before heading. - (insert "\n"))) - (let ((end (org-entry-end-position))) - ;; Insert blank lines before entry content - (forward-line) - (while (and (org-at-planning-p) - (< (point) (point-max))) - ;; Skip planning lines - (forward-line)) - (while (re-search-forward - org-drawer-regexp end t) - ;; Skip drawers. You might think that - ;; `org-at-drawer-p' would suffice, but for - ;; some reason it doesn't work correctly when - ;; operating on hidden text. This works, taken - ;; from `org-agenda-get-some-entry-text'. - (re-search-forward "^[ \t]*:END:.*\n?" end t) - (goto-char (match-end 0))) - (unless (or (= (point) (point-max)) - (org-at-heading-p) - (looking-at-p "\n")) - (insert "\n")))) - t (if prefix - nil - 'tree))) + (org-with-wide-buffer + ;; `org-map-entries' narrows the buffer, which + ;; prevents us from seeing newlines before the + ;; current heading, so we do this part widened. + (while (not (looking-back "\n\n" nil)) + ;; Insert blank lines before heading. + (insert "\n"))) + (let ((end (org-entry-end-position))) + ;; Insert blank lines before entry content + (forward-line) + (while (and (org-at-planning-p) + (< (point) (point-max))) + ;; Skip planning lines + (forward-line)) + (while (re-search-forward + org-drawer-regexp end t) + ;; Skip drawers. You might think that + ;; `org-at-drawer-p' would suffice, but for + ;; some reason it doesn't work correctly when + ;; operating on hidden text. This works, taken + ;; from `org-agenda-get-some-entry-text'. + (re-search-forward "^[ \t]*:END:.*\n?" end t) + (goto-char (match-end 0))) + (unless (or (= (point) (point-max)) + (org-at-heading-p) + (looking-at-p "\n")) + (insert "\n")))) + t (if prefix + nil + 'tree))) (defun acdw/hook--org-mode-fix-blank-lines () (when (eq major-mode 'org-mode) (let ((current-prefix-arg 4)) (call-interactively #'unpackaged/org-fix-blank-lines)))) +;;; ADVICE + +;; Correct `org-delete-backward-char' to use `backward-delete-char-untabify' +(defun acdw-org/delete-backward-char (N) + "Like `delete-backward-char-untabify', insert whitespace at field end in tables. +When deleting backwards, in tables this function will insert +whitespace in front of the next \"|\" separator, to keep the +table aligned. The table will still be marked for re-alignment +if the field did fill the entire column, because, in this case +the deletion might narrow the column." + (interactive "p") + (save-match-data + (org-check-before-invisible-edit 'delete-backward) + (if (and (= N 1) + (not overwrite-mode) + (not (org-region-active-p)) + (not (eq (char-before) ?|)) + (save-excursion (skip-chars-backward " \t") (not (bolp))) + (looking-at-p ".*?|") + (org-at-table-p)) + (progn (forward-char -1) (org-delete-char 1)) + (backward-delete-char-untabify N) + (org-fix-tags-on-the-fly)))) + (provide 'acdw-org) -- cgit 1.4.1-21-gabe81