GitHub - alphapapa/unpackaged.el: A collection of useful Emacs Lisp code that isn't substantial enough to be packaged (original) (raw)

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 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!

(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))))

Force monospace face in tables

If you use variable-pitch (a.k.a. “proportional”) fonts in Org buffers (e.g. using 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.

;;;###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)))

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.

(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))))))

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.

;;;###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))))

Used like:

(unpackaged/def-org-maybe-surround "~" "=" "*" "/" "+")

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: ts

(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))))

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 John Kitchin.

(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)))))

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 blog article and later 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:

(add-hook 'org-mode-hook 'unpackaged/org-mark-read-only)

The functions may also be called interactively as needed.

(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))))))

Sort tree by multiple methods at once

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

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

;;;###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))))

Packages

Delete all installed versions of a package

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

(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)))))

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.

(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 " ")))))

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 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:

• unpackaged/package-delete-all-versions

(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"))))

Upgrade one package in the package menu

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

(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))))))

Programming

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.

(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)))

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.

(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))))

iedit

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

iedit-scoped

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

;;;###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)

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.

(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)))))

Sort sexps

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

;;;###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)))))))))

Regular expressions

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.

;;;###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)))

Version control

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.

;;;###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))))))))

magit-log date headers

Add date headers to Magit log buffers.

Requires:

• ov.el

(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)))

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

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

smerge-mode

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 Kaushal Modi’s Emacs config.)

Requires:

• hydra
• Magit

See these screencasts comparing what it’s like to resolve the conflict with ediff and with this smerge-hydra.

(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)))))

Web

EWW Imenu support

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.

(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)

feed-for-url

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:

• esxml
• org-web-tools

(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))))

License

GPLv3