You get:

#+BEGIN_SRC html

So links to sections of the exported HTML will remain useful, rather than being different, random numbers every time the document is exported. If an anchor is not unique, its ancestor headings are prepended one-at-a-time until unique, and when no more ancestors remain, a number is appended and incremented until unique. For an example of how this works out in practice, see the links made to headings [[https://alphapapa.github.io/emacs-package-dev-handbook/][here]], of which there are many having the same name (e.g. =Tools=, =Libraries=, etc).

Note that this is somewhat of a hack, and it probably breaks some feature deep inside Org Export. But it seems to work, and it solves the problem!

#+BEGIN_SRC elisp
(eval-when-compile
(require 'easy-mmode)
(require 'ox))

(use-package ox
:config
(define-minor-mode unpackaged/org-export-html-with-useful-ids-mode
"Attempt to export Org as HTML with useful link IDs.
Instead of random IDs like \"#orga1b2c3\", use heading titles,
made unique when necessary."
:global t
(if unpackaged/org-export-html-with-useful-ids-mode
(advice-add #'org-export-get-reference :override #'unpackaged/org-export-get-reference)
(advice-remove #'org-export-get-reference #'unpackaged/org-export-get-reference)))

(defun unpackaged/org-export-get-reference (datum info)
"Like `org-export-get-reference', except uses heading titles instead of random numbers."
(let ((cache (plist-get info :internal-references)))
(or (car (rassq datum cache))
(let* ((crossrefs (plist-get info :crossrefs))
(cells (org-export-search-cells datum))
;; Preserve any pre-existing association between
;; a search cell and a reference, i.e., when some
;; previously published document referenced a location
;; within current file (see
;; `org-publish-resolve-external-link').
;;
;; However, there is no guarantee that search cells are
;; unique, e.g., there might be duplicate custom ID or
;; two headings with the same title in the file.
;;
;; As a consequence, before re-using any reference to
;; an element or object, we check that it doesn't refer
;; to a previous element or object.
(new (or (cl-some
(lambda (cell)
(let ((stored (cdr (assoc cell crossrefs))))
(when stored
(let ((old (org-export-format-reference stored)))
(and (not (assoc old cache)) stored)))))
cells)
(when (org-element-property :raw-value datum)
;; Heading with a title
(unpackaged/org-export-new-title-reference datum cache))
;; NOTE: This probably breaks some Org Export
;; feature, but if it does what I need, fine.
(org-export-format-reference
(org-export-new-reference cache))))
(reference-string new))
;; Cache contains both data already associated to
;; a reference and in-use internal references, so as to make
;; unique references.
(dolist (cell cells) (push (cons cell new) cache))
;; Retain a direct association between reference string and
;; DATUM since (1) not every object or element can be given
;; a search cell (2) it permits quick lookup.
(push (cons reference-string datum) cache)
(plist-put info :internal-references cache)
reference-string))))

(defun unpackaged/org-export-new-title-reference (datum cache)
"Return new reference for DATUM that is unique in CACHE."
(cl-macrolet ((inc-suffixf (place)
`(progn
(string-match (rx bos
(minimal-match (group (1+ anything)))
(optional "--" (group (1+ digit)))
eos)
,place)
;; HACK: `s1' instead of a gensym.
(-let* (((s1 suffix) (list (match-string 1 ,place)
(match-string 2 ,place)))
(suffix (if suffix
(string-to-number suffix)
0)))
(setf ,place (format "%s--%s" s1 (cl-incf suffix)))))))
(let* ((title (org-element-property :raw-value datum))
(ref (url-hexify-string (substring-no-properties title)))
(parent (org-element-property :parent datum)))
(while (--any (equal ref (car it))
cache)
;; Title not unique: make it so.
(if parent
;; Append ancestor title.
(setf title (concat (org-element-property :raw-value parent)
"--" title)
ref (url-hexify-string (substring-no-properties title))
parent (org-element-property :parent parent))
;; No more ancestors: add and increment a number.
(inc-suffixf ref)))
ref))))
#+END_SRC

** Force monospace face in tables

If you use variable-pitch (a.k.a. "proportional") fonts in Org buffers (e.g. using [[https://github.com/cadadr/elisp/blob/devel/org-variable-pitch.el][org-variable-pitch]]), you probably use monospace fonts for Org tables, so they align properly. However, other elements in a table (such as links, or perhaps timestamps) may still use variable-pitch fonts, which breaks alignment. This code fixes that by forcibly applying the =org-table= face family to entire Org tables (which are detected by finding existing text with the =org-table= face, which makes use of Org's built-in fontification).

To use, activate =unpackaged/org-table-face-mode=. You may want to add it to =org-mode-hook=.

#+BEGIN_SRC elisp
;;;###autoload
(define-minor-mode unpackaged/org-table-face-mode
"Apply `org-table' face family to all text in Org tables.
Useful for forcibly applying the face to portions of table data
that might have a different face, which could affect alignment."
:global nil
(let ((keywords '((unpackaged/org-table-face-matcher 0 'org-table))))
(if unpackaged/org-table-face-mode
(font-lock-add-keywords nil keywords 'append)
(font-lock-remove-keywords nil keywords))
(font-lock-flush)))

(cl-defun unpackaged/org-table-face-matcher
(limit &optional (face `(:family ,(face-attribute 'org-table :family))))
"Apply FACE to entire Org tables.
A `font-lock-keywords' function that searches up to LIMIT."
(cl-flet* ((find-face (face &optional limit not)
;; Return next position up to LIMIT that has FACE, or doesn't if NOT.
(cl-loop with prev-pos
with pos = (point)
while (not (eobp))
do (setf pos (next-single-property-change pos 'face nil limit))
while (and pos (not (equal pos prev-pos)))
for face-at = (get-text-property pos 'face)
for face-matches-p = (or (eq face-at face)
(when (listp face-at)
(member face face-at)))
when (or (and not (not face-matches-p))
face-matches-p)
return pos
do (setf prev-pos pos)))
(apply-face-from (pos face)
(unless (eobp)
(let* ((property-at-start (get-text-property pos 'face))
(table-face-start (if (or (eq property-at-start 'org-table)
(when (listp property-at-start)
(member 'org-table property-at-start)))
(point)
(find-face 'org-table limit)))
table-face-end)
(when table-face-start
(goto-char table-face-start)
(setf table-face-end (line-end-position))
(add-face-text-property table-face-start table-face-end face)
(goto-char table-face-end))))))
(cl-loop with applied-p
for applied = (apply-face-from (point) face)
when applied
do (setf applied-p t)
while applied
finally return applied-p)))
#+END_SRC

** Outline number overlays

This command displays outline numbers (like the ones used when exporting) in a buffer as overlays at the beginning of each heading. It doesn't update automatically, so it must be called when the outline structure changes.

[[images/org-outline-numbers.png]]

#+BEGIN_SRC elisp
(defun unpackaged/org-outline-numbers (&optional remove-p)
"Add outline number overlays to the current buffer.
When REMOVE-P is non-nil (interactively, with prefix), remove
them. Overlays are not automatically updated when the outline
structure changes."
;; NOTE: This does not necessarily play nicely with org-indent-mode
;; or org-bullets, but it probably wouldn't be too hard to fix that.
(interactive (list current-prefix-arg))
(cl-labels ((heading-number ()
(or (when-let ((num (previous-sibling-number)))
(1+ num))
1))
(previous-sibling-number ()
(save-excursion
(let ((pos (point)))
(org-backward-heading-same-level 1)
(when (/= pos (point))
(heading-number)))))
(number-list ()
(let ((ancestor-numbers (save-excursion
(cl-loop while (org-up-heading-safe)
collect (heading-number)))))
(nreverse (cons (heading-number) ancestor-numbers))))
(add-overlay ()
(let* ((ov-length (org-current-level))
(ov (make-overlay (point) (+ (point) ov-length)))
(ov-string (concat (mapconcat #'number-to-string (number-list) ".")
".")))
(overlay-put ov 'org-outline-numbers t)
(overlay-put ov 'display ov-string))))
(remove-overlays nil nil 'org-outline-numbers t)
(unless remove-p
(org-with-wide-buffer
(goto-char (point-min))
(when (org-before-first-heading-p)
(outline-next-heading))
(cl-loop do (add-overlay)
while (outline-next-heading))))))
#+END_SRC

** Surround region with emphasis or syntax characters

Define and bind interactive commands for each of ~KEYS~ that surround the region or insert text. Commands are bound in ~org-mode-map~ to each of ~KEYS~. If the region is active, commands surround it with the key character, otherwise call ~org-self-insert-command~.

#+BEGIN_SRC elisp
;;;###autoload
(defmacro unpackaged/def-org-maybe-surround (&rest keys)
"Define and bind interactive commands for each of KEYS that surround the region or insert text.
Commands are bound in `org-mode-map' to each of KEYS. If the
region is active, commands surround it with the key character,
otherwise call `org-self-insert-command'."
`(progn
,@(cl-loop for key in keys
for name = (intern (concat "unpackaged/org-maybe-surround-" key))
for docstring = (format "If region is active, surround it with \"%s\", otherwise call `org-self-insert-command'." key)
collect `(defun ,name ()
,docstring
(interactive)
(if (region-active-p)
(let ((beg (region-beginning))
(end (region-end)))
(save-excursion
(goto-char end)
(insert ,key)
(goto-char beg)
(insert ,key)))
(call-interactively #'org-self-insert-command)))
collect `(define-key org-mode-map (kbd ,key) #',name))))
#+END_SRC

Used like:

#+BEGIN_SRC elisp
(unpackaged/def-org-maybe-surround "~" "=" "*" "/" "+")
#+END_SRC

** Refile to datetree file using earliest/latest timestamp in entry

Refile current entry to datetree using timestamp found in entry. ~WHICH~ should be ~earliest~ or ~latest~. If ~SUBTREE~-P is non-nil, search whole subtree.

This is sort of like archiving to a datetree, but it uses either the earliest or latest timestamp found in the entry or subtree rather than the current date. It's helpful if you have an entry with lots of timestamps or log entries, and you're done with it, and you want to file it in a datetree in a leaf matching either when you started working on the entry or when you finished, using the first or last timestamp found anywhere in the entry.

/Note:/ If you can think of a more concise name for this command, please send it in!

*Requires:* [[https://github.com/alphapapa/ts.el][ts]]

#+BEGIN_SRC elisp
(require 'org)

(require 'ts)

;;;###autoload
(defun unpackaged/org-refile-to-datetree-using-ts-in-entry (which-ts file &optional subtree-p)
"Refile current entry to datetree in FILE using timestamp found in entry.
WHICH should be `earliest' or `latest'. If SUBTREE-P is non-nil,
search whole subtree."
(interactive (list (intern (completing-read "Which timestamp? " '(earliest latest)))
(read-file-name "File: " (concat org-directory "/") nil 'mustmatch nil
(lambda (filename)
(string-suffix-p ".org" filename)))
current-prefix-arg))
(require 'ts)
(let* ((sorter (pcase which-ts
('earliest #'ts<)
('latest #'ts>)))
(tss (unpackaged/org-timestamps-in-entry subtree-p))
(ts (car (sort tss sorter)))
(date (list (ts-month ts) (ts-day ts) (ts-year ts))))
(unpackaged/org-refile-to-datetree file :date date)))

;;;###autoload
(defun unpackaged/org-timestamps-in-entry (&optional subtree-p)
"Return timestamp objects for all Org timestamps in entry.
If SUBTREE-P is non-nil (interactively, with prefix), search
whole subtree."
(interactive (list current-prefix-arg))
(save-excursion
(let* ((beg (org-entry-beginning-position))
(end (if subtree-p
(org-end-of-subtree)
(org-entry-end-position))))
(goto-char beg)
(cl-loop while (re-search-forward org-tsr-regexp-both end t)
collect (ts-parse-org (match-string 0))))))

;;;###autoload
(cl-defun unpackaged/org-refile-to-datetree (file &key (date (calendar-current-date)) entry)
"Refile ENTRY or current node to entry for DATE in datetree in FILE.
DATE should be a list of (MONTH DAY YEAR) integers, e.g. as
returned by `calendar-current-date'."
(interactive (list (read-file-name "File: " (concat org-directory "/") nil 'mustmatch nil
(lambda (filename)
(string-suffix-p ".org" filename)))))
;; If org-datetree isn't loaded, it will cut the tree but not file
;; it anywhere, losing data. I don't know why
;; org-datetree-file-entry-under is in a separate package, not
;; loaded with the rest of org-mode.
(require 'org-datetree)
(unless entry
(org-cut-subtree))
;; Using a condition-case to be extra careful. In case the refile
;; fails in any way, put cut subtree back.
(condition-case err
(with-current-buffer (or (org-find-base-buffer-visiting file)
(find-file-noselect file))
(org-datetree-file-entry-under (or entry (car kill-ring)) date)
(save-buffer))
(error (unless entry
(org-paste-subtree))
(message "Unable to refile! %s" err))))
#+END_SRC

** ~org-return-dwim~

A helpful replacement for ~org-return~. With prefix, call ~org-return~.

On headings, move point to position after entry content. In lists, insert a new item or end the list, with checkbox if appropriate. In tables, insert a new row or end the table.

Inspired by [[http://kitchingroup.cheme.cmu.edu/blog/2017/04/09/A-better-return-in-org-mode/][John Kitchin]].

#+BEGIN_SRC elisp :results none :exports code
(defun unpackaged/org-element-descendant-of (type element)
"Return non-nil if ELEMENT is a descendant of TYPE.
TYPE should be an element type, like `item' or `paragraph'.
ELEMENT should be a list like that returned by `org-element-context'."
;; 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))))

;;;###autoload
(defun unpackaged/org-return-dwim (&optional default)
"A helpful replacement for `org-return'. With prefix, call `org-return'.

On headings, move point to position after entry content. In
lists, insert a new item or end the list, with checkbox if
appropriate. In tables, insert a new row or end the table."
;; Inspired by John Kitchin: http://kitchingroup.cheme.cmu.edu/blog/2017/04/09/A-better-return-in-org-mode/
(interactive "P")
(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.

;; ((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")))))
(insert "\n"))
(forward-line -1)))))

((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)))))
#+END_SRC

** Read-only trees

This code applies the =read-only= text-property to trees tagged =read_only=, preventing them from being modified accidentally. (Note: If read-only headings appear in an Agenda buffer, it can cause slightly unusual behavior. Usually this is not an issue.) This was originally inspired by John Kitchin's [[http://kitchingroup.cheme.cmu.edu/blog/2014/09/13/Make-some-org-sections-read-only/][blog article]] and later [[https://www.reddit.com/r/emacs/comments/92k7n1/guide_to_profiling_and_optimizing_an_orgrelated/][rewritten]] in a faster version.

To use, load these functions, and then add to this hook to automatically mark read-only sections when an Org file is loaded:

#+BEGIN_SRC elisp
(add-hook 'org-mode-hook 'unpackaged/org-mark-read-only)
#+END_SRC

The functions may also be called interactively as needed.

#+BEGIN_SRC elisp
(defun unpackaged/org-next-heading-tagged (tag)
"Move to beginning of next heading tagged with TAG and return point, or return nil if none found."
(when (re-search-forward (rx-to-string `(seq bol (1+ "*") (1+ blank) (optional (1+ not-newline) (1+ blank))
;; Beginning of tags
":"
;; Possible other tags
(0+ (seq (1+ (not (any ":" blank))) ":") )
;; The tag that matters
,tag ":"))
nil 'noerror)
(goto-char (match-beginning 0))))

;;;###autoload
(defun unpackaged/org-mark-read-only ()
"Mark all entries in the buffer tagged \"read_only\" with read-only text properties."
(interactive)
(org-with-wide-buffer
(goto-char (point-min))
(while (unpackaged/org-next-heading-tagged "read_only")
(add-text-properties (point) (org-end-of-subtree t)
'(read-only t)))))

(defun unpackaged/org-remove-read-only ()
"Remove read-only text properties from Org entries tagged \"read_only\" in current buffer."
(interactive)
(let ((inhibit-read-only t))
(org-with-wide-buffer
(goto-char (point-min))
(while (unpackaged/org-next-heading-tagged "read_only")
(remove-text-properties (point) (org-end-of-subtree t)
'(read-only t))))))
#+END_SRC

** Sort tree by multiple methods at once

Call ~org-sort-entries~ with multiple sorting methods specified in ~KEYS~.

This is much easier than doing @@html:@@C-c ^ KEY@@html:@@ several times in a row.

#+BEGIN_SRC elisp
;;;###autoload
(defun unpackaged/org-sort-multi ()
"Call `org-sort' until \\[keyboard-quit] is pressed."
(interactive)
;; Not sure if `with-local-quit' is necessary, but probably a good
;; idea in case of recursive edit.
(with-local-quit
(cl-loop while (call-interactively #'org-sort))))
#+END_SRC

* Packages :packages:

#+BEGIN_SRC elisp :exports none
;;; Packages

(require 'package)
#+END_SRC

** Delete all installed versions of a package

Delete all versions of package named ~NAME~. ~NAME~ may be a string or symbol.

#+BEGIN_SRC elisp
(defun unpackaged/package-delete-all-versions (name &optional force)
"Delete all versions of package named NAME.
NAME may be a string or symbol."
;; Copied from `package-delete'.
(let* ((package-name (cl-typecase name
(string (intern name))
(symbol name)))
(user-packages-list (->> package-alist
;; Just to be safe, we ignore built-ins.
(-select (-not #'package-built-in-p))))
(matching-versions (--select (eql (car it) package-name) user-packages-list)))
;; Safety checks.
(cl-loop for (symbol first-desc . rest) in matching-versions
do (progn
(unless force
(when-let* ((dependent (package--used-elsewhere-p first-desc)))
(error "Package `%s' depends on `%s'" (package-desc-name dependent) package-name)))
(unless (string-prefix-p (file-name-as-directory (expand-file-name package-user-dir))
(expand-file-name (package-desc-dir first-desc)))
(error "Package `%s' is a system package" symbol))))
;; Checks passed: delete packages.
(cl-loop for (_symbol . descs) in matching-versions
do (--each descs
(package-delete it force)))))
#+END_SRC

** Reload a package's features

Reload ~PACKAGE~'s features. If ~ALLP~ is non-nil (interactively, with prefix), load all of its features; otherwise only load ones that were already loaded.

This is useful to reload a package after upgrading it. Since a package may provide multiple features, to reload it properly would require either restarting Emacs or manually unloading and reloading each loaded feature. This automates that process.

Note that this unloads all of the package's symbols before reloading. Any data stored in those symbols will be lost, so if the package would normally save that data, e.g. when a mode is deactivated or when Emacs exits, the user should do so before using this command.

#+BEGIN_SRC elisp
(defun unpackaged/reload-package (package &optional allp)
"Reload PACKAGE's features.
If ALLP is non-nil (interactively, with prefix), load all of its
features; otherwise only load ones that were already loaded.

This is useful to reload a package after upgrading it. Since a
package may provide multiple features, to reload it properly
would require either restarting Emacs or manually unloading and
reloading each loaded feature. This automates that process.

Note that this unloads all of the package's symbols before
reloading. Any data stored in those symbols will be lost, so if
the package would normally save that data, e.g. when a mode is
deactivated or when Emacs exits, the user should do so before
using this command."
(interactive
(list (intern (completing-read "Package: "
(mapcar #'car package-alist) nil t))
current-prefix-arg))
;; This finds features in the currently installed version of PACKAGE, so if
;; it provided other features in an older version, those are not unloaded.
(when (yes-or-no-p (format "Unload all of %s's symbols and reload its features? " package))
(let* ((package-name (symbol-name package))
(package-dir (file-name-directory
(locate-file package-name load-path (get-load-suffixes))))
(package-files (directory-files package-dir 'full (rx ".el" eos)))
(package-features
(cl-loop for file in package-files
when (with-temp-buffer
(insert-file-contents file)
(when (re-search-forward (rx bol "(provide" (1+ space)) nil t)
(goto-char (match-beginning 0))
(cadadr (read (current-buffer)))))
collect it)))
(unless allp
(setf package-features (seq-intersection package-features features)))
(dolist (feature package-features)
(ignore-errors
;; Ignore error in case it's not loaded.
(unload-feature feature 'force)))
(dolist (feature package-features)
(require feature))
(message "Reloaded: %s" (mapconcat #'symbol-name package-features " ")))))
#+END_SRC

** Upgrade a ~quelpa-use-package~ form's package

Eval the current ~use-package~ form with ~quelpa-upgrade-p~ true. Delete the package first to remove obsolete versions. When ~RELOADP~ is non-nil, reload the package's features after upgrade using ~unpackaged/reload-package~; otherwise (interactively, with prefix), leave old features loaded.

This makes it easy to upgrade a package you install with [[https://framagit.org/steckerhalter/quelpa-use-package][quelpa-use-package]] without having to add ~:upgrade t~ to the form, which would cause Quelpa to /always/ upgrade the package every time Emacs loads.

*Requires:*

+ [[#delete-all-installed-versions-of-a-package][unpackaged/package-delete-all-versions]]

#+BEGIN_SRC elisp
(defvar quelpa-upgrade-p)

;;;###autoload
(cl-defun unpackaged/quelpa-use-package-upgrade (&key (reloadp t))
"Eval the current `use-package' form with `quelpa-upgrade-p' true.
Delete the package first to remove obsolete versions. When
RELOADP is non-nil, reload the package's features after upgrade
using `unpackaged/reload-package'; otherwise (interactively, with
prefix), leave old features loaded."
(interactive (list :reloadp (not current-prefix-arg)))
(save-excursion
(if (or (looking-at (rx "(use-package "))
(let ((limit (save-excursion
(or (re-search-backward (rx bol "("))
(point-min)))))
;; Don't go past previous top-level form
(re-search-backward (rx "(use-package ") limit t)))
(progn
(pcase-let* ((`(use-package ,package-name . ,rest) (read (current-buffer))))
(cl-assert package-name nil "Can't determine package name")
(cl-assert (memq :quelpa rest) nil "`:quelpa' form not found")
(unpackaged/package-delete-all-versions package-name 'force)
(let ((quelpa-upgrade-p t))
(call-interactively #'eval-defun))
(when reloadp
(unpackaged/reload-package package-name))))
(user-error "Not in a `use-package' form"))))
#+END_SRC

** Upgrade one package in the package menu

Mark current package for upgrading (i.e. also mark obsolete version for deletion.)

#+BEGIN_SRC elisp
(use-package package
:bind (:map package-menu-mode-map
("t" . #'unpackaged/package-menu-upgrade-package))
:config
;; I think the `use-package' form takes care of autoloading here.
(defun unpackaged/package-menu-upgrade-package ()
"Mark current package for upgrading (i.e. also mark obsolete version for deletion.)"
(interactive)
(when-let ((upgrades (package-menu--find-upgrades))
(description (tabulated-list-get-id))
(name (package-desc-name description))
(upgradable (cdr (assq name upgrades))))
;; Package is upgradable
(save-excursion
(goto-char (point-min))
(while (not (eobp))
(let* ((current-description (tabulated-list-get-id))
(current-name (package-desc-name current-description)))
(when (equal current-name name)
(cond ((equal description current-description)
(package-menu-mark-install)
(forward-line -1))
(t (package-menu-mark-delete)))))
(forward-line 1))))))
#+END_SRC

* Programming :programming:

#+BEGIN_SRC elisp :exports none
;;; Programming

#+END_SRC

** Compile top-level form with warnings

The only way to get byte-compilation warnings for Elisp is to compile the whole file with, e.g. =byte-compile-file=, which is less convenient when one wants to debug a single function. So this function byte-compiles just the current top-level form and displays the warnings.

Since ~compile-defun~ already takes a prefix argument (i.e. =C-u C-M-x= already does something), this could be bound to, e.g. =C-M-S-x=.

#+begin_src elisp
(defun unpackaged/compile-defun-debug ()
"Compile and evaluate the current top-level form, displaying compilation warnings.
Calls `compile-defun' with `byte-compile-debug' non-nil."
(interactive)
(let ((byte-compile-debug t))
(call-interactively #'compile-defun)))
#+end_src

** Flexibly fill/unfill paragraphs

Fill paragraph, incrementing fill column to cause a change when repeated. The global value of ~fill-column~ is not modified; it is only bound around calls to ~fill-paragraph~. When called for the first time in a sequence, unfill to the default ~fill-column~. When called repeatedly, increase ~fill-column~ until filling changes. With one universal prefix, increase ~fill-column~ until the number of lines is reduced. With two, unfill completely.

[[images/flex-fill-paragraph.gif]]

#+BEGIN_SRC elisp :exports code :results silent
(defvar unpackaged/flex-fill-paragraph-column nil
"Last fill column used in command `unpackaged/flex-fill-paragraph'.")

;;;###autoload
(defun unpackaged/flex-fill-paragraph (&optional fewer-lines unfill)
"Fill paragraph, incrementing fill column to cause a change when repeated.
The global value of `fill-column' is not modified; it is only
bound around calls to `fill-paragraph'.

When called for the first time in a sequence, unfill to the
default `fill-column'.

When called repeatedly, increase `fill-column' until filling
changes.

With one universal prefix, increase `fill-column' until the
number of lines is reduced. With two, unfill completely."
(interactive "P")
(let* ((fewer-lines (or fewer-lines (equal current-prefix-arg '(4))))
(unfill (or unfill (equal current-prefix-arg '(16))))
(fill-column
(cond (unfill (setf unpackaged/flex-fill-paragraph-column nil)
most-positive-fixnum)
(t (setf unpackaged/flex-fill-paragraph-column
(if (equal last-command this-command)
(or (unpackaged/flex-fill-paragraph--next-fill-column fewer-lines)
fill-column)
fill-column))))))
(fill-paragraph)
(message "Fill column: %s" fill-column)))

(defun unpackaged/flex-fill-paragraph--next-fill-column (&optional fewer-lines)
"Return next `fill-column' value.
If FEWER-LINES is non-nil, reduce the number of lines in the
buffer, otherwise just change the current paragraph."
;; This works well, but because of all the temp buffers, sometimes when called
;; in rapid succession, it can cause GC, which can be noticeable. It would be
;; nice to avoid that. Note that this has primarily been tested on
;; `emacs-lisp-mode'; hopefully it works well in other modes.
(let* ((point (point))
(source-buffer (current-buffer))
(mode major-mode)
(fill-column (or unpackaged/flex-fill-paragraph-column fill-column))
(old-fill-column fill-column)
(hash (unless fewer-lines
(buffer-hash)))
(original-num-lines (when fewer-lines
(line-number-at-pos (point-max)))))
(with-temp-buffer
(delay-mode-hooks
(funcall mode))
(setq-local fill-column old-fill-column)
(insert-buffer-substring source-buffer)
(goto-char point)
(cl-loop while (fill-paragraph)
;; If filling doesn't change after 100 iterations, abort by returning nil.
if (> (- fill-column old-fill-column) 100)
return nil
else do (cl-incf fill-column)
while (if fewer-lines
(= original-num-lines (line-number-at-pos (point-max)))
(string= hash (buffer-hash)))
finally return fill-column))))
#+END_SRC

** ~iedit~ :iedit:refactoring:

These commands make ~iedit-mode~ a bit easier to use.

*** COMMENT Add ~use-package~ form?

*** ~iedit-scoped~

Call ~iedit-mode~ with function-local scope, or global scope if called with a universal prefix.

#+BEGIN_SRC elisp
;;;###autoload
(defun unpackaged/iedit-scoped (orig-fn)
"Call `iedit-mode' with function-local scope, or global scope if called with a universal prefix."
(interactive)
(pcase-exhaustive current-prefix-arg
('nil (funcall orig-fn '(0)))
('(4) (funcall orig-fn))))

(advice-add #'iedit-mode :around #'unpackaged/iedit-scoped)
#+END_SRC

*** ~iedit-or-flyspell~ :flyspell:spell_checking:

Toggle ~iedit-mode~ or correct previous misspelling with ~flyspell~, depending on context.

With point in code or when ~iedit-mode~ is already active, toggle ~iedit-mode~. With point in a comment or string, and when ~iedit-mode~ is not already active, auto-correct previous misspelled word with ~flyspell~. Call this command a second time to choose a different correction.

#+BEGIN_SRC elisp
(defvar flyspell-previous-command)

;;;###autoload
(defun unpackaged/iedit-or-flyspell ()
"Toggle `iedit-mode' or correct previous misspelling with `flyspell', depending on context.

With point in code or when `iedit-mode' is already active, toggle
`iedit-mode'. With point in a comment or string, and when
`iedit-mode' is not already active, auto-correct previous
misspelled word with `flyspell'. Call this command a second time
to choose a different correction."
(interactive)
(if (or (bound-and-true-p iedit-mode)
(and (derived-mode-p 'prog-mode)
(not (or (nth 4 (syntax-ppss))
(nth 3 (syntax-ppss))))))
;; prog-mode is active and point is in a comment, string, or
;; already in iedit-mode
(call-interactively #'iedit-mode)
;; Not prog-mode or not in comment or string
(if (not (equal flyspell-previous-command this-command))
;; FIXME: This mostly works, but if there are two words on the
;; same line that are misspelled, it doesn't work quite right
;; when correcting the earlier word after correcting the later
;; one

;; First correction; autocorrect
(call-interactively 'flyspell-auto-correct-previous-word)
;; First correction was not wanted; use popup to choose
(progn
(save-excursion
(undo)) ; This doesn't move point, which I think may be the problem.
(flyspell-region (line-beginning-position) (line-end-position))
(call-interactively 'flyspell-correct-previous-word-generic)))))
#+END_SRC

** Sort sexps

Sort sexps in region. Comments stay with the code below.

#+BEGIN_SRC elisp
;;;###autoload
(defun unpackaged/sort-sexps (beg end)
"Sort sexps in region.
Comments stay with the code below."
(interactive "r")
(cl-flet ((skip-whitespace () (while (looking-at (rx (1+ (or space "\n"))))
(goto-char (match-end 0))))
(skip-both () (while (cond ((or (nth 4 (syntax-ppss))
(ignore-errors
(save-excursion
(forward-char 1)
(nth 4 (syntax-ppss)))))
(forward-line 1))
((looking-at (rx (1+ (or space "\n"))))
(goto-char (match-end 0)))))))
(save-excursion
(save-restriction
(narrow-to-region beg end)
(goto-char beg)
(skip-both)
(cl-destructuring-bind (sexps markers)
(cl-loop do (skip-whitespace)
for start = (point-marker)
for sexp = (ignore-errors
(read (current-buffer)))
for end = (point-marker)
while sexp
;; Collect the real string, then one used for sorting.
collect (cons (buffer-substring (marker-position start) (marker-position end))
(save-excursion
(goto-char (marker-position start))
(skip-both)
(buffer-substring (point) (marker-position end))))
into sexps
collect (cons start end)
into markers
finally return (list sexps markers))
(setq sexps (sort sexps (lambda (a b)
(string< (cdr a) (cdr b)))))
(cl-loop for (real . sort) in sexps
for (start . end) in markers
do (progn
(goto-char (marker-position start))
(insert-before-markers real)
(delete-region (point) (marker-position end)))))))))
#+END_SRC

* Regular expressions :regular_expressions:

#+BEGIN_SRC elisp :exports none
;;; Regular expressions

#+END_SRC

** query-replace-rx

Call ~query-replace-regexp~, reading regexp in ~rx~ syntax. Automatically wraps in parens and adds ~seq~ to the beginning of the form.

#+BEGIN_SRC elisp
;;;###autoload
(defun unpackaged/query-replace-rx (&rest _)
"Call `query-replace-regexp', reading regexp in `rx' syntax.
Automatically wraps in parens and adds `seq' to the beginning of
the form."
(interactive)
(cl-letf (((symbol-function #'query-replace-read-from) (lambda (&rest _)
(--> (read-string "rx form: ")
(concat "'(seq " it ")")
(read it)
(cadr it)
(rx-to-string it)))))
(call-interactively #'query-replace-regexp)))
#+END_SRC

* Version control :version_control:

#+BEGIN_SRC elisp :exports none
;;; Version control

#+END_SRC

** Magit :Magit:

*** Improved ~magit-status~ command

Open a ~magit-status~ buffer and close the other window so only Magit is visible. If a file was visited in the buffer that was active when this command was called, go to its unstaged changes section.

#+BEGIN_SRC elisp
;;;###autoload
(defun unpackaged/magit-status ()
"Open a `magit-status' buffer and close the other window so only Magit is visible.
If a file was visited in the buffer that was active when this
command was called, go to its unstaged changes section."
(interactive)
(let* ((buffer-file-path (when buffer-file-name
(file-relative-name buffer-file-name
(locate-dominating-file buffer-file-name ".git"))))
(section-ident `((file . ,buffer-file-path) (unstaged) (status))))
(call-interactively #'magit-status)
(delete-other-windows)
(when buffer-file-path
(goto-char (point-min))
(cl-loop until (when (equal section-ident (magit-section-ident (magit-current-section)))
(magit-section-show (magit-current-section))
(recenter)
t)
do (condition-case nil
(magit-section-forward)
(error (cl-return (magit-status-goto-initial-section-1))))))))
#+END_SRC

*** magit-log date headers

Add date headers to Magit log buffers.

*Requires:*
+ [[https://github.com/ShingoFukuyama/ov.el][ov.el]]

[[images/magit-log-date-headers.png]]

#+BEGIN_SRC elisp :results silent
(defun unpackaged/magit-log--add-date-headers (&rest _ignore)
"Add date headers to Magit log buffers."
(when (derived-mode-p 'magit-log-mode)
(save-excursion
(ov-clear 'date-header t)
(goto-char (point-min))
(cl-loop with last-age
for this-age = (-some--> (ov-in 'before-string 'any (line-beginning-position) (line-end-position))
car
(overlay-get it 'before-string)
(get-text-property 0 'display it)
cadr
(s-match (rx (group (1+ digit) ; number
" "
(1+ (not blank))) ; unit
(1+ blank) eos)
it)
cadr)
do (when (and this-age
(not (equal this-age last-age)))
(ov (line-beginning-position) (line-beginning-position)
'after-string (propertize (concat " " this-age "\n")
'face 'magit-section-heading)
'date-header t)
(setq last-age this-age))
do (forward-line 1)
until (eobp)))))

(define-minor-mode unpackaged/magit-log-date-headers-mode
"Display date/time headers in `magit-log' buffers."
:global t
(if unpackaged/magit-log-date-headers-mode
(progn
;; Enable mode
(add-hook 'magit-post-refresh-hook #'unpackaged/magit-log--add-date-headers)
(advice-add #'magit-setup-buffer-internal :after #'unpackaged/magit-log--add-date-headers))
;; Disable mode
(remove-hook 'magit-post-refresh-hook #'unpackaged/magit-log--add-date-headers)
(advice-remove #'magit-setup-buffer-internal #'unpackaged/magit-log--add-date-headers)))
#+END_SRC

This isn't always perfect, because dates in a git commit log are not always in order (e.g. when commits are merged at a later date), but it's often very helpful to visually group commits by their age.

*** Save buffer and show changes in Magit status

#+BEGIN_SRC elisp
;;;###autoload
(defun unpackaged/magit-save-buffer-show-status ()
"Save buffer and show its changes in `magit-status'."
(interactive)
(save-buffer)
(unpackaged/magit-status))
#+END_SRC

** ~smerge-mode~
:PROPERTIES:
:ID: 9d6983a6-3765-45c2-a140-34c23f381361
:END:

*** Hydra

This configuration automatically activates a helpful ~smerge-mode~ hydra when a file containing merge conflicts is visited from a Magit diff section. You can manually activate the hydra with the command ~unpackaged/smerge-hydra/body~. (Inspired by [[https://github.com/kaushalmodi/.emacs.d/blob/master/setup-files/setup-diff.el][Kaushal Modi's Emacs config]].)

*Requires*:
+ [[https://github.com/abo-abo/hydra][hydra]]
+ [[https://magit.vc/][Magit]]

[[images/smerge-mode-hydra.png]]

See these screencasts comparing what it's like to resolve the conflict with [[images/smerge-hydra-vs-ediff.gif][ediff]] and with this [[images/smerge-hydra.gif][smerge-hydra]].

#+BEGIN_SRC elisp
(require 'hydra)

(use-package smerge-mode
:config
(defhydra unpackaged/smerge-hydra
(:color pink :hint nil :post (smerge-auto-leave))
"
^Move^ ^Keep^ ^Diff^ ^Other^
^^-----------^^-------------------^^---------------------^^-------
_n_ext _b_ase _<_: upper/base _C_ombine
_p_rev _u_pper _=_: upper/lower _r_esolve
^^ _l_ower _>_: base/lower _k_ill current
^^ _a_ll _R_efine
^^ _RET_: current _E_diff
"
("n" smerge-next)
("p" smerge-prev)
("b" smerge-keep-base)
("u" smerge-keep-upper)
("l" smerge-keep-lower)
("a" smerge-keep-all)
("RET" smerge-keep-current)
("\C-m" smerge-keep-current)
("<" smerge-diff-base-upper)
("=" smerge-diff-upper-lower)
(">" smerge-diff-base-lower)
("R" smerge-refine)
("E" smerge-ediff)
("C" smerge-combine-with-next)
("r" smerge-resolve)
("k" smerge-kill-current)
("ZZ" (lambda ()
(interactive)
(save-buffer)
(bury-buffer))
"Save and bury buffer" :color blue)
("q" nil "cancel" :color blue))
:hook (magit-diff-visit-file . (lambda ()
(when smerge-mode
(unpackaged/smerge-hydra/body)))))
#+END_SRC

* Web :web:

#+BEGIN_SRC elisp :exports none
;;; Web

#+END_SRC

** EWW Imenu support :EWW:Imenu:

This function allows Imenu to offer links and HTML headings in EWW buffers, which is especially helpful for navigating long, technical documents.

*Note:* It's recommended to set the option ~imenu-max-item-length~ to ~nil~; otherwise the links and descriptions provided by this code get truncated too much to be useful.

#+begin_src elisp :exports code :results none
(require 'cl-lib)

(defun unpackaged/eww-imenu-index ()
"Return Imenu index for current EWW buffer.
Index includes links and headings."
(let ((shr-heading-faces '( shr-h1 shr-h2 shr-h3 shr-h4 shr-h5
shr-h6 shr-heading)))
(cl-labels ((range-matching (property predicate)
"Return (BEG . END) cons from point where PROPERTY matches PREDICATE.
PREDICATE is used for `text-property-search-forward', which see."
(when-let ((match (text-property-search-forward property nil predicate))
(end (cl-loop
for next-change-pos = (prop-match-end match) then next-change-pos
for next-change-pos = (next-single-property-change next-change-pos property)
when next-change-pos
for end-pos = next-change-pos
while (funcall predicate nil (get-text-property next-change-pos property))
finally return end-pos)))
(cons (prop-match-beginning match) end)))
(shr-heading-p (_ value-of)
(cl-typecase value-of
(atom (member value-of shr-heading-faces))
(list (seq-intersection value-of shr-heading-faces)))))
(let ((links (save-excursion
(goto-char (point-min))
(delete-dups
(cl-loop for url = (get-text-property (point) 'shr-url)
when url collect (cons (format "%s <%s>"
(button-label (button-at (point)))
url)
(point))
for pos = (next-single-property-change (point) 'shr-url)
while pos do (goto-char pos)))))
(headings (save-excursion
(goto-char (point-min))
(cl-loop for (next-beg . next-end) = (range-matching 'face #'shr-heading-p)
while next-beg
for text = (buffer-substring next-beg next-end)
collect (cons text next-beg)
and do (goto-char next-end)))))
(list (cons "Headings" headings)
(cons "Links" links))))))

(defun unpackaged/eww-imenu-goto (_label position)
"Go to POSITION and call `eww-follow-link' if one is there."
(goto-char position)
(when (button-at (point))
(declare-function eww-follow-link "eww")
(call-interactively #'eww-follow-link)))

(defun unpackaged/eww-imenu-setup ()
"Setup Imenu in EWW buffers."
(setq-local imenu-create-index-function #'unpackaged/eww-imenu-index
imenu-default-goto-function #'unpackaged/eww-imenu-goto))

(add-hook 'eww-mode-hook #'unpackaged/eww-imenu-setup)
#+end_src

** feed-for-url :RSS:Atom:XML:

Return ATOM or RSS feed ~URL~ for web page at ~URL~. Interactively, insert the ~URL~ at point. ~PREFER~ may be ~atom~ (the default) or ~rss~. When ~ALL~ is non-nil, return all feed URLs of all types; otherwise, return only one feed ~URL~, preferring the preferred type.

*Requires:*
+ [[https://github.com/tali713/esxml][esxml]]
+ [[https://github.com/alphapapa/org-web-tools][org-web-tools]]

#+BEGIN_SRC elisp :results silent
(eval-when-compile
(require 'esxml-query))

;;;###autoload
(cl-defun unpackaged/feed-for-url (url &key (prefer 'atom) (all nil))
"Return feed URL for web page at URL.
Interactively, insert the URL at point. PREFER may be
`atom' (the default) or `rss'. When ALL is non-nil, return all
feed URLs of all types; otherwise, return only one feed URL,
preferring the preferred type."
(interactive (list (org-web-tools--get-first-url)))
(require 'esxml-query)
(require 'org-web-tools)
(cl-flet ((feed-p (type)
;; Return t if TYPE appears to be an RSS/ATOM feed
(string-match-p (rx "application/" (or "rss" "atom") "+xml")
type)))
(let* ((preferred-type (format "application/%s+xml" (symbol-name prefer)))
(html (org-web-tools--get-url url))
(dom (with-temp-buffer
(insert html)
(libxml-parse-html-region (point-min) (point-max))))
(potential-feeds (esxml-query-all "link[rel=alternate]" dom))
(return (if all
;; Return all URLs
(cl-loop for (_tag attrs) in potential-feeds
when (feed-p (alist-get 'type attrs))
collect (url-expand-file-name (alist-get 'href attrs) url))
(or
;; Return the first URL of preferred type
(cl-loop for (_tag attrs) in potential-feeds
when (equal preferred-type (alist-get 'type attrs))
return (url-expand-file-name (alist-get 'href attrs) url))
;; Return the first URL of non-preferred type
(cl-loop for (_tag attrs) in potential-feeds
when (feed-p (alist-get 'type attrs))
return (url-expand-file-name (alist-get 'href attrs) url))))))
(if (called-interactively-p 'interactive)
(insert (if (listp return)
(s-join " " return)
return))
return))))
#+END_SRC

# Elisp footer

#+BEGIN_SRC elisp :exports none
(provide 'unpackaged)

;;; unpackaged.el ends here
#+END_SRC

* License
:PROPERTIES:
:TOC: :ignore this
:END:

GPLv3

* COMMENT Tasks / Ideas

** DONE customize-themes-faces
CLOSED: [2020-12-21 Mon 00:38]
:LOGBOOK:
- State "DONE" from "TODO" [2020-12-21 Mon 00:38]
:END:

[2020-12-19 Sat 16:18] See [[https://www.reddit.com/r/emacs/comments/kg8uc7/override_text_color_in_a_color_scheme/ggehxv8/][Override text color in a color scheme : emacs]].

#+BEGIN_SRC elisp
(defun unpackaged/customize-theme-faces (theme &rest faces)
"Customize THEME with FACES.
Advises `enable-theme' with a function that customizes FACES when
THEME is enabled. If THEME is already enabled, also applies
faces immediately. Calls `custom-theme-set-faces', which see."
(declare (indent defun))
(when (member theme custom-enabled-themes)
;; Theme already enabled: apply faces now.
(let ((custom--inhibit-theme-enable nil))
(apply #'custom-theme-set-faces theme faces)))
(let ((fn-name (intern (concat "unpackaged/enable-theme-advice-for-" (symbol-name theme)))))
;; Apply advice for next time theme is enabled.
(fset fn-name
(lambda (enabled-theme)
(when (eq enabled-theme theme)
(let ((custom--inhibit-theme-enable nil))
(apply #'custom-theme-set-faces theme faces)))))
(advice-remove #'enable-theme fn-name)
(advice-add #'enable-theme :after fn-name)))

(unpackaged/customize-theme-faces 'doom-solarized-dark
`(font-lock-builtin-face ((t :weight bold :foreground "#268bd2")))
`(org-list-dt ((t :weight bold)))
`(org-link ((t :inherit link :foreground ,(doom-color 'cyan) :weight normal)))
`(org-date ((t :weight bold))))
#+END_SRC

** MAYBE Tangle with Babel

Might be nice to be able to tangle all of the ~unpackaged/~ functions into a single file.

** TODO Select image with Helm

#+BEGIN_SRC elisp
(defun unpackaged/helm-read-image (&rest directories)
"Return path to image file found in DIRECTORIES, completing with `helm-comp-read'."
(helm-comp-read "Image: "
(cl-loop for file in (-flatten (mapcar #'f-files directories))
for image = (unpackaged/rescale-image (f-read-bytes file)
:max-width 48
:max-height 48)
for string = (with-temp-buffer
(insert " ")
(insert-image image file)
(buffer-string))
collect (cons string file))))

(cl-defun unpackaged/rescale-image (data &key max-width max-height &allow-other-keys)
"Return image DATA, rescaled if too big to fit the current buffer.
MAX-WIDTH and MAX-HEIGHT are used if set, otherwise they are
determined by the size of the buffer's window."
;; Based on image.el
(when (fboundp 'imagemagick-types)
(cond ((and max-width max-height)
;; Use given size
)
((get-buffer-window (current-buffer))
;; Use window size
(setq max-width (or max-width (window-pixel-width))
max-height (or max-height (/ (window-pixel-height) 2))))
((current-buffer)
;; Buffer not displayed; use frame
(setq max-width (or max-width (frame-pixel-width))
max-height (or max-height (/ (frame-pixel-height) 2))))
(t
;; This should not happen with the fixes above, but just in case:
(warn "Weird error rescaling image, please report. Buffer: %s" (current-buffer))))
(create-image data 'imagemagick 'data-p
:max-width max-width
:max-height max-height)))
#+END_SRC

*** Tasks

**** TODO Instructions/example

**** TODO Make useful interactively

e.g. it should allow selecting directories, and then presenting the images in them. Maybe filenames should also be displayed next to each image. So maybe it should somehow be a wrapper or advice to ~helm-find-files~ or ~helm-comp-read~ that simply adds images to the filename strings.
* COMMENT Config
:PROPERTIES:
:TOC: :ignore (this descendants)
:END:

I love Emacs and Org mode. This makes it so easy to make the document...alive! And automated! Beautiful.

** File-local properties

#+PROPERTY: header-args:elisp :tangle unpackaged.el

** Info export options

#+TEXINFO_DIR_CATEGORY: Emacs
#+TEXINFO_DIR_TITLE: Unpackaged: (unpackaged)
#+TEXINFO_DIR_DESC: Useful yet unsubstantial Emacs Lisp code

# NOTE: We could use these, but that causes a pointless error, "org-compile-file: File "..README.info" wasn't produced...", so we just rename the files in the after-save-hook instead.
# #+TEXINFO_FILENAME: unpackaged.info
# #+EXPORT_FILE_NAME: unpackaged.texi

** File-local variables

# Local Variables:
# eval: (require 'org-make-toc)
# eval: (unpackaged/org-export-html-with-useful-ids-mode 1)
# before-save-hook: org-make-toc
# after-save-hook: ((lambda nil (org-babel-tangle) (when (org-html-export-to-html) (rename-file "README.html" "index.html" t))) (lambda nil (when (and (require 'ox-texinfo nil t) (org-texinfo-export-to-info)) (delete-file "README.texi") (rename-file "README.info" "unpackaged.info" t))))
# org-export-with-properties: ()
# org-export-with-title: t
# org-export-with-broken-links: t
# org-id-link-to-org-use-id: nil
# org-export-initial-scope: buffer
# End: