These functions have general utility, and I use them in many of my other modules.
Some of them probably belong in their own modules....
Many of these functions come from Michael Duggan. Thanks, Duggan.
;;; pg-util.el --- Utility functions
;; Copyright (C) 2017-2022 Phil Groce
;; Author: Phil Groce <pgroce@gmail.com>
;; Version: 0.3.4
;; Package-Requires: ((dash "2.13.0"))
;; Keywords: utility(eval-when-compile (require 'cl-macs))
;(require 'cl-lib)
(require 'find-func)
(require 'dash)The prefix for this library is pg-util, but the point of this library is to define frequently-used functions, and prepending them with pg-util all the time gets tiresome. Therefore, an exception: Each part of the API is defined as pg-util-* and also with the prefix /. For example, An alias for pg-util-spy is /spy.
I stole this from the dbg macro in this Clojure macro tutorial, and from the spy method of the Clojure logging API.
The following function will (message) out a lisp form and its value, then return the value. The form is evaluated only once, so if the form has side-effects, they won’t change when run in the debugging.
This makes for a very powerful debugging tool. Just replace, say, (foo x) with (pg-util-spy (foo x)) and you get the form and value printed out.
;;;###autoload
(defmacro pg-util-spy (x)
"Print the form and value of x to the message buffer, then
return x. x is only evaluated once."
(let ((pg-util-x (make-symbol "x")))
`(let ((,pg-util-x ,x)) (message (format "%s = %s" ',x ,pg-util-x)) ,pg-util-x)))
(defalias '/spy 'pg-util-spy)
I use dash.el for most list manipulation, but these functions have proven very convenient over the years.
(defgroup pg nil
"Customization group for pg-* family of libraries."
:group 'Emacs)
(defcustom pg-error-on-deprecation nil
"Set to `t' to change deprecation warnings to (traceable) errors."
:type 'boolean
:group 'pg)
;;;###autoload
(defun pg-util-zip (lists)
"Return list of lists where each element of index n of the
output list is a list of all elements of index n of the input
lists. For instance: (pg-util-zip '(1 2 3) '(4 5 6) '(7 8 9)) -> '((1
4 7) (2 5 8) (3 6 9))"
(if pg-error-on-deprecation
(error "pg-util-zip is deprecated. Use dash.el's -zip-lists instead.")
(warn "pg-util-zip is deprecated. Use dash.el's -zip-lists instead."))
(apply #'mapcar* #'list lists))
(defalias '/zip 'pg-util-zip)
;;;###autoload
(defun pg-util-list-add-unique (l1 l2)
"Return a new list composed of the values in L1 and the values
in L2 that don't already exist in L1. (IOW, L1 + L2, with no
duplications from L2.)
If there are duplicate values in L1, these will be preserved."
(-concat l1 (--filter (not (memq it l1)) l2)))
(defalias '/list-add-unique 'pg-util-list-add-unique)
;;;###autoload
(defun pg-util-list-add-unique-var (var values)
"Update the list in VAR with the new values in VALUES using
`pg-util-list-add-unique'."
(set var (pg-util-list-add-unique (symbol-value var) values)))
(defalias '/list-add-unique-var 'pg-util-list-add-unique-var)
;;;###autoload
(defun pg-util-list-update-1 (l elt matcher &optional no-match-action)
"Update matching item in L with ELT.
This function returns a copy of L with the first matching item in
L replaced with ELT. MATCHER takes an element in L and returns a
true value if they match and nil otherwise. It is up to MATCHER
to define how items match.
NO-MATCH-ACTION determines what happens if no item in L matches
ELT. If NO-MATCH-ACTION is the symbol `prepend', ELT will be
prepended onto L. If it is the symbol `append', ELT will be
appended to L. Otherwise (the default), L will not be changed."
(let ((match-idx (-find-index matcher l)))
(if (eq nil match-idx)
(if (eq no-match-action 'prepend)
(cons elt l)
(if (eq no-match-action 'append)
(append l (list elt))
l))
(-replace-at match-idx elt l))))
(defalias '/list-update-1 'pg-util-list-update-1)
;;;###autoload
(defun pg-util-list-update (l1 l2 matcher &optional no-match-action)
"Update L1 with matching elements in L2, according to MATCHER.
This function returns a new list, with each element in L1 that
matches an element in L2 replaced with the matching element,
using `pg-util-list-update-1'.
MATCHER is a function that takes two arguments representing items
in L1 and L2, respectively, and returns a true value if they
\"match\", otherwise nil.
The semantics of NO-MATCH-ACTION are equivalent to those in
`pg-util-list-update-1'."
(let ((rc l1))
(cl-dolist (elt2 l2 rc)
(let* ((matcher-all matcher)
(matcher-1 (lambda (elt1) (funcall matcher-all elt1 elt2))))
(setq rc (pg-util-list-update-1
rc
elt2
matcher-1
no-match-action))))))
(defalias '/list-update 'pg-util-list-update)
;;;###autoload
(defun pg-util-alist-update (a1 a2)
"Return a new alist with the elements in A1, updated by A2. If
an element key exists in A1 and A2, it is updated in-place with
the value from A2. Elements in A2 with keys that are not in A1
are appended to the end of the new alist."
(let ((a2-only (--filter (eq nil (assoc (car it) a1)) a2))
(updated-a1 (--map (or (assoc (car it) a2) it) a1)))
(-concat updated-a1 a2-only)))
(defalias '/alist-update 'pg-util-alist-update)
;;;###autoload
(defun pg-util-alist-update-var (var values)
"Update the alist in VAR with the new values in VALUES using
`pg-util-alist-update'. Shorthand for `(set
var (pg-util-alist-update (symbol-value-var) values)'."
(set var (pg-util-alist-update (symbol-value var) values)))
(defalias '/alist-update-var 'pg-util-alist-update-var)
;;;###autoload
(defun pg-util-alist-keys (in-alist)
"Return a list of the keys in IN-ALIST, an associative list."
(if (null in-alist)
nil
(cons (caar in-alist) (pg-util-alist-keys (cdr in-alist)))))
(defalias '/alist-keys 'pg-util-alist-keys)
;;;###autoload
(defun pg-util-plist-keys (in-plist)
"Return a list of the keys in IN-PLIST, a property list."
(if (null in-plist)
nil
(cons (car in-plist) (pg-util-plist-keys (cddr in-plist)))))
(defalias '/plist-keys 'pg-util-plist-keys)
;;; Note that hash-table-keys and hash-table-values live in subr-xauto-mode-alist is a little special, in that its keys are strings, so the standard alist functions (which use eq) don’t work on it. This usually doesn’t bother anyone because they just use (add-to-list ...) and don’t worry about the potential multiple entries for one file extension. But it worries me, dammit. It’s least confusing when there’s only one entry per extension.
This function manipulates auto-mode-alist-like lists to my satisfaction.
;;;###autoload
(defun pg-util-update-auto-mode-alist (ext new-mode &optional amalist)
"Return a new copy of AMALIST (if nil, use `auto-mode-alist')
in which the mode function for EXT is replaced with NEW-MODE."
(let* ((amalist (if amalist amalist auto-mode-alist))
(filtered-amalist (--filter (not (equal ext (car it)))
amalist)))
(add-to-list 'filtered-amalist `(,ext . ,new-mode))))
(defalias '/update-auto-mode-alist 'pg-util-update-auto-mode-alist)In some lists, it can be helpful to move some specific elements to the front. This is most useful in UIs (I use it to prioritize “important” files in a project), but could also be used to optimize searching. Performance is O(n) on the size of the input list, so it beats out “sort with a weird predicate” on performance.
(defun pg-util-prioritize (prioritized-items l)
"Return L, with any items in PRIORITIZED-ITEMS moved to the top of the list, in the order they are specified. The order of any other items in the list is unchanged. If items in PRIORITIZED-ITEMS are not in L, they will not exist in the output.
Examples:
(pg-util-prioritize '(e d) '(a b c d e)) => '(e d a b c)
(pg-util-prioritize nil '(a b c d e)) => '(a b c d e)
(pg-util-prioritize '(e d) '(a b c)) => '(a b c)"
(cl-assert (listp prioritized-items))
(cl-assert (listp l))
(setq prioritized-items (reverse prioritized-items))
(while prioritized-items
(let ((i (pop prioritized-items)))
(when (member i l)
(setq l (cons i (delete i l))))))
l)
(defalias '/prioritize 'pg-util-prioritize)Herewith, entirely too many words on tree traversal.
Dash has several functions for “pretending lists are trees,” but they mainly allow one to pretend trees are lists. That is, they visit each element in the tree, perhaps with the opportunity to manipulate it; -tree-map, for instance, transforms every leaf node in the tree independently of the tree’s context. -tree-map-nodes is a generalized version of the same thing, with a predicate function to determine whether an element is a leaf node which should be processed, or a branch node which should be descended into (but not processed).
A proper tree traversal, to me, would visit each of a tree’s branch nodes, returning a tree of the transformed nodes. This introduces, of course, the problem of the branch being transformed in a way that changes which children it has, and puts it on the user to avoid recursion errors.
Listing ex/tree-transform-1 shows the definition of an interface for a simple tree traversal and transformation function, tree-transform. It takes four arguments:
treeis the tree being transformed.- The
branch?function takes a an element intreeand returnstif it is a subtree. - The
transformerfunction takes a subtree and returns a list can can be used as a replacement for that subtree. Beyond being a list,transformercan transform its input arbitrarily, including removing or adding child subtrees. (The terms “branch node” and “subtree” are interchangeable.) - The
max-depthkeyword option allows the user to limit the depth of recursion into the tree. This guards against errors in thetransformfunction that result in infinite trees. If not provided, a default will be used.
;; Interface of tree-transform
(cl-defun tree-transform
(tree &key
(branch? 'listp)
(transformer 'identity)
(max-depth nil)))We can use tree-transform as in Listing ex/tree-transform/usage/1. Here, we use tree-transform to modify an s-expression such that the name of the first element of every list is prepended with foo-
(cl-letf (((symbol-function 'transformer)
(lambda (node)
(let ((head (car node)))
(if (not (symbolp head))
node
(let* ((new-name (->> (symbol-name head)
(format "foo-%s")))
(new-sym (intern new-name)))
(cons new-sym (cdr node))))))))
(pg-util-tree-transform '(a (b c) d (e (f g h) i))
:transformer #'transformer))Note that one can use the Dash library’s -cut function to build a function where tree is the last argument, as in Listing ex/tree-transform/usage/2. The result of executing this code is in Listing ex/tree-transform/usage/2/results/1.
(cl-letf (((symbol-function 'transformer)
(lambda (node)
(let ((head (car node)))
(if (not (symbolp head))
node
(let* ((new-name (->> (symbol-name head)
(format "foo-%s")))
(new-sym (intern new-name)))
(cons new-sym (cdr node))))))))
(funcall (-cut pg-util-tree-transform <> :transformer #'transformer)
'(a (b c) d (e (f (g h)) i))))(foo-a
(foo-b c)
d
(foo-e
(foo-f
(foo-g h))
i))Note what happens when we provide this function an input with interior quoting, such as '(a (b c) d (e '(f (g h)) i)), producing the output in ex/tree-transform/usage/2/results/2. Note that quote is transformed to foo-quote; ideally we would want to except quote from our transformation, and this can be done using the transformer in pg-util-tree-transform. It is not possible, however, to tell the transformer not to descend into the quoted subexpression and transform both f and g.
(foo-a
(foo-b c)
d
(foo-e
(foo-quote
(foo-f
(foo-g h)))
i))The pg-util-tree-transform function is adequate for a number of use cases and simple to use, so we want to keep it around. However, there are two vectors for more precise control over the tree transformation: We can provide more context to the transformer so it can make more types of decisions, and we can provide more context from the transformer to the traversal algorithm, so it can make better decisions. The pg-util-tree-transform-2 incorporates the latter improvement; the former may be addressed in the future in a pg-util-tree-transform-3.
The pg-util-tree-transform-2 function has a similar interface to pg-util-tree-transform, except that the return value of the tranform function is not a transformed node but a property list, containing the transformed node and additional metadata the traversal algorithm can use. At the moment, only one piece is honored, the :stop property, which tells pg-util-tree-transform-2 not to descend into this node’s child nodes. This can be done for efficiency, or because these nodes are off-limits.
For example, if one is transforming according to the rules of s-expressions, for instance, any quoted expression should be left alone. We can represent this by returning a value from nodes beginning with the quote symbol that says “here’s my (untransformed) node, and don’t try to transform my children.”
This could also be done for efficiency, if a transform function can determine that no further transformations of their children are necessary.
(defcustom pg-util-tree-traversal-max-depth 50
"Default maximum recursion for `pg-util-tree-transform'."
:type 'integer
:group 'pg)
(defun pg-util--tree-transform-2-recursive
(remaining-depth branch? transformer tree)
(if (= 0 remaining-depth)
tree
(let* ((transformed-plist (funcall transformer tree))
(transformed-node (plist-get transformed-plist :node)))
(--map-when
(and (not (plist-get transformed-plist :stop))
(funcall branch? it))
(pg-util--tree-transform-2-recursive
(- remaining-depth 1) branch? transformer it)
transformed-node))
))
(defun pg-util--tree-transform-2-identity (node) `(:node ,node))
(cl-defun pg-util-tree-transform-2 (tree &key
(branch? 'listp)
(transformer 'pg-util--tree-transform-2-identity)
(max-depth nil))
"Traverse a tree, transforming subtrees with TRANSFORMER.
BRANCH? is called on all elements of TREE. If it returns `t', the
`pg-util-tree-transform' will descend into the element. By
default, BRANCH? is set to `listp'; if this function returns
non-nil and the input is not a list, results are undefined.
TRANSFORMER is a function that takes a tree node (i.e., a list)
as input, and outputs a plist. The keys of the plist are:
:node - The transformed node
:stop - (Optional) If non-nil, don't descend into children of this node
The optional MAX-DEPTH parameter can be used to limit the depth
of the tree. If it is not supplied, the default in
`pg-util-tree-traversal-max-depth' is used"
(let ((depth (if (eq nil max-depth)
pg-util-tree-traversal-max-depth
max-depth)))
(pg-util--tree-transform-2-recursive
depth branch? transformer tree)))
(defalias '/tree-transform-2 'pg-util-tree-transform-2)The use of this function is more complex than tree-transform, but more powerful, as seen in Listing ex/tree-transform-2/usage/1. Here we demonstrate how to stop the traversal algorithm from descending into quoted nodes–including quoted elements. (Recall that 'a is equivalent to (quote a).)
<<src/tree-transform-2>>
(cl-letf (((symbol-function 'transformer)
(lambda (node)
(let ((head (car node)))
(cond
((not (symbolp head))
`(:node ,node))
((eq head 'quote)
`(:node ,node :stop t))
(t
(let* ((new-name (->> (symbol-name head)
(format "foo-%s")))
(new-sym (intern new-name)))
`(:node ,(cons new-sym (cdr node))))))))))
(/tree-transform-2
'('a (b c) d (e '(f (g h)) i))
:transformer 'transformer))('a
(foo-b c)
d
(foo-e
'(f
(g h))
i))Note that the pg-util-tree-transform functions return a copy of their input, as shown in Listing ex/tree-transform-2/usage/2.
<<src/tree-transform-2>>
(cl-letf (((symbol-function 'transformer)
(lambda (node)
(let ((head (car node)))
(cond
((not (symbolp head))
`(:node ,node))
((eq head 'quote)
`(:node ,node :stop t))
(t
(let* ((new-name (->> (symbol-name head)
(format "foo-%s")))
(new-sym (intern new-name)))
`(:node ,(cons new-sym (cdr node)))))))))
(input-tree '(a '(b c) d (e f))))
(list :transformed
(/tree-transform-2
input-tree
:transformer 'transformer)
:original
input-tree))(:transformed
(foo-a
'(b c)
d
(foo-e f))
:original
(a
'(b c)
d
(e f)))While pg-util-tree-transform-2 is more powerful, it is much easier to write transformation functions for tree-transform; it would be nicer to use where possible. Fortunately, it can be implemented easily in terms of pg-util-tree-transform-2, as shown in Listing src/tree-transform-1. (It is necessary to use lexical binding for the transform adapter to avoid shadowing issues with transform in pg-util-tree-transform-2.)
(cl-defun pg-util-tree-transform
(tree &key
(branch? 'listp)
(transformer 'identity)
(max-depth nil))
"Traverse a tree, transforming subtrees with TRANSFORMER. This function is a simpler, less powerful version of `pg-util-tree-transform-2'.
BRANCH? is called on all elements of TREE. If it returns `t', the
`pg-util-tree-transform' will descend into the element. By
default, BRANCH? is set to `listp'; if this function returns
non-nil and the input is not a list, results are undefined.
TRANSFORMER is a function that takes a tree node (i.e., a list)
as input, transforms it, and returns the transformed node.
The optional MAX-DEPTH parameter can be used to limit the depth
of the tree. If it is not supplied, the default in
`pg-util-tree-traversal-max-depth' is used"
(lexical-let* ((transformer-1 transformer)
(transformer-2
(lambda (node) `(:node ,(funcall transformer-1 node)))))
(pg-util-tree-transform-2 tree
:branch? branch?
:transformer transformer-2
:max-depth max-depth)))(cl-letf (((symbol-function 'transformer)
(lambda (node)
(let ((head (car node)))
(if (not (symbolp head))
node
(let* ((new-name (->> (symbol-name head)
(format "foo-%s")))
(new-sym (intern new-name)))
(cons new-sym (cdr node))))))))
(pg-util-tree-transform '(a (b c) d (e (f g h) i))
:transformer #'transformer))The branch predicate and the transformer could utilize a lot more information about their position in the tree. This would be helpful in certain specialized structures like n-partite trees that encode information in tree position.
At the limit, transformer could take the following arguments:
- the current tree node τ
- a root node Τ of which τ is a descendant
- a parent node ψ of which τ is an immediate child
- δ, the current node’s depth in Τ
- an index ι representing the current node’s position in ψ
Similarly, branch could take a number of additional arguments
- Τ, τ, ψ, ι and δ (possibly updated to reflect the prospective depth of the possible branch) from
transformer - ι\prime, the possible branch’s position in τ
This more powerful and more complicated version of traverse may be implemented at some point, and traverse could certainly be implemented in its terms.
There may be an easier way to detect if the current buffer features a particular minor mode, but I haven’t found it yet.
;;;###autoload
(defun pg-util-minor-mode-active-p (minor-mode)
"Return t if the minor mode is active in the current buffer,
otherwise nil."
(condition-case nil
(and (symbolp minor-mode) (symbol-value minor-mode))
('error nil)))
(defalias '/minor-mode-active-p 'pg-util-minor-mode-active-p)If you accidentally put sensitive material in the kill ring, you have various options, depending on the sensitivity of the data. It often isn’t appropriate to just clear the kill ring and move on; it’s unlikely that the memory will be overwritten before it’s free‘d, for instance.
If your only concern is that end-users don’t see the information in the history, though, this function is useful. It clears the kill ring, the “Select and Paste” menu, and the record of keys you can view with view-lossage.
;;;###autoload
(defun pg-util-nuke-kill-ring ()
"Try to annihilate all history of anything recently typed,
copied or pasted."
(setq kill-ring nil)
(setcdr yank-menu nil)
(clear-this-command-keys)
;; Things get ugly with various histories, but try a little
(setq minibuffer-history '()))
(defalias '/nuke-kill-ring 'pg-util-nuke-kill-ring)[[http://marmalade-repo.org/packages/diminish][diminish]] modifies how minor modes display their names on the modeline. It’s a depencency of use-package, so if you’re using that, you get diminish for free!
diminish only works on minor modes, though. “Diminishing” major modes is simple enough, but this macro simplifies it further.
;;;###autoload
(defmacro pg-util-diminish-major (mode new-name)
"Simulate the effects of diminish on major modes."
`(add-hook
(quote,(intern (format "%s-hook" (symbol-name mode))))
(lambda () (setq mode-name ,new-name))))
(defalias '/diminish-major 'pg-util-diminish-major)pg-util-find-thing-at-point will look at the thing at point, and if it’s a symbol take you to its definition.
(defun pg-util--library-name-at-point ()
(let* ((dirs (or find-function-source-path load-path))
(suffixes (find-library-suffixes))
(table (apply-partially 'locate-file-completion-table
dirs suffixes))
(def (thing-at-point 'symbol)))
(when (and def (not (test-completion def table)))
(setq def nil))
def))
(defalias '/-library-name-at-point 'pg-util--library-name-at-point)
(defun pg-util--function-name-at-point ()
"Return the name of the function at point, or nil if point is
not on a function name. (Contrast with `function-at-point', which assumes there's a function around somewhere and tries to find it. This just tells you if point is on a function, and if so which one.)"
(let ((symb (thing-at-point 'symbol)))
(if (functionp (intern symb))
symb
nil)))
(defalias '/-function-name-at-point 'pg-util--function-name-at-point)
(defun pg-util--variable-name-at-point ()
"Return variable name at point, or nil if there is none."
(let ((v (variable-at-point)))
(if (equal 0 v) nil v)))
(defalias '/-variable-name-at-point 'pg-util--variable-name-at-point)The main function.
;;;###autoload
(defun pg-util-find-thing-at-point ()
"Find the library, function, or variable (in that order) at
point, if it exists."
(interactive)
(let* ((symbcell (list (pg-util--library-name-at-point) 'lib))
(symbcell (if (car symbcell)
symbcell
(list (pg-util--function-name-at-point) 'fun)))
(symbcell (if (car symbcell)
symbcell
(list (pg-util--variable-name-at-point) 'var)))
(symb (car symbcell))
(symbtype (if symb
(cadr symbcell)
nil)))
(cl-case symbtype
('lib
(find-library symb))
('fun
(find-function (intern symb)))
('var
(find-variable symb))
(t (message "Can't ID symbol at point: %s" (thing-at-point 'symbol))))))
(defalias '/find-thing-at-point 'pg-util-find-thing-at-point)A section for things that are too small even to include in their own section.
These macros make conditional assignment more readable, especially when they’re done as part of a larger evaluation, such as in a let statement. Common lisp probably already has these; heck, maybe Emacs lisp already has these, but I haven’t come across it.
/if-2 is literally (if l l r), except l only has to be written once. This means that l is evaluated twice if it evaluates to a true value the first time.
/option is identical to /if-2, except that l is only evaluated once. This is useful if l is expensive or has side effects.
(defmacro pg-util-if-2 (l r)
"A compact way of saying (if l l r)"
(declare (indent 1))
`(if ,l
,l
,r))
(defalias '/if-2 'pg-util-if-2)
(defmacro pg-util-option (l r)
"Return L if it evaluates true, otherwise R. L is evaluated
exactly once. R is evaluated only if L evaluates to nil."
(declare (indent 1))
`(let ((l ,l))
(if l
l
,r)))
(defalias '/option 'pg-util-option) (provide 'pg-util)
;;; pg-util.el ends here